From e55a937bea4ba780b03e14c7098421b2ab1fe109 Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Sat, 11 Feb 2023 14:04:08 -0500 Subject: [PATCH 001/109] Regression test updates: global_4dvar bug fix, oom fix, enhance error checking (#532) --- regression/global_4dvar.sh | 12 ++++----- regression/regression_driver.sh | 1 - regression/regression_param.sh | 4 +-- regression/regression_test.sh | 17 +++++++++--- regression/regression_test_enkf.sh | 43 ++++++++++++++++++++---------- 5 files changed, 50 insertions(+), 27 deletions(-) diff --git a/regression/global_4dvar.sh b/regression/global_4dvar.sh index ec2a8396e0..cac0d28e6b 100755 --- a/regression/global_4dvar.sh +++ b/regression/global_4dvar.sh @@ -98,7 +98,7 @@ SINGLEOB="" # bftab_sst= bufr table for sst ONLY needed for sst retrieval (retrieval=.true.) # aeroinfo = text file with information about assimilation of aerosol data -anavinfo=$fixgsi/global_anavinfo.l${LEVS}.txt +anavinfo=$fixgsi/global_anavinfo_qlqi.l${LEVS}.txt berror=$fixgsi/Big_Endian/global_berror.l${LEVS}y${NLAT}.f77 locinfo=$fixgsi/global_hybens_info.l${LEVS}.txt satinfo=$fixgsi/global_satinfo.txt @@ -311,9 +311,9 @@ $gsi_namelist EOF cp gsiparm.anl gsiparm.anl.obsvr -echo "run gsi now" +echo "run gsi observer" eval "$APRUN $tmpdir/gsi.x < gsiparm.anl > stdout.obsvr 2>&1" -rc=$? +ra=$? # Run gsi identity model 4dvar under Parallel Operating Environment (poe) on NCEP IBM rm -f siganl sfcanl.gsi satbias_out fort.2* @@ -331,8 +331,8 @@ cat < gsiparm.anl $gsi_namelist EOF -echo "run gsi now" +echo "run gsi 4dvar" eval "$APRUN $tmpdir/gsi.x < gsiparm.anl > stdout 2>&1" -rc=$? - +rb=$? +rc=$((ra+rb)) exit $rc diff --git a/regression/regression_driver.sh b/regression/regression_driver.sh index 621ccbf485..e1d3b18dc7 100755 --- a/regression/regression_driver.sh +++ b/regression/regression_driver.sh @@ -47,7 +47,6 @@ for jn in `seq ${RSTART} ${REND}`; do $scripts/regression_wait.sh ${job[$jn]} ${rcname} $check_resource rc=$? if [ $rc -ne 0 ]; then - rm -f ${rcname} exit 1 fi done diff --git a/regression/regression_param.sh b/regression/regression_param.sh index 85f2949bfe..a2808ddfc0 100755 --- a/regression/regression_param.sh +++ b/regression/regression_param.sh @@ -150,8 +150,8 @@ case $regtest in topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Jet" ]]; then topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" diff --git a/regression/regression_test.sh b/regression/regression_test.sh index deb34ff244..0bcb9f4d90 100755 --- a/regression/regression_test.sh +++ b/regression/regression_test.sh @@ -576,11 +576,20 @@ mkdir -p $vfydir $ncp $output $vfydir/ +# Final check for any failed tests +count=$(grep -i "fail" $output |wc -l) +if [ $count -gt 0 ]; then + (( failed_test = $failed_test + $count )) +fi + +# Remove job log files is no failures detected cd $scripts -rm -f ${exp1}.out -rm -f ${exp2}.out -rm -f ${exp3}.out -rm -f ${exp2_scale}.out +if [ $count -eq 0 ]; then + rm -f ${exp1}.out + rm -f ${exp2}.out + rm -f ${exp3}.out + rm -f ${exp2_scale}.out +fi if [[ "$clean" = ".true." ]]; then rm -rf $savdir diff --git a/regression/regression_test_enkf.sh b/regression/regression_test_enkf.sh index 213ee726da..f52a5d451f 100755 --- a/regression/regression_test_enkf.sh +++ b/regression/regression_test_enkf.sh @@ -34,7 +34,7 @@ maxtime=1200 maxmem=${maxmem:-3400000} # set in regression_param maxmem=$((${memnode:-64}*1024*1024)) -# Copy stdout and sanl files +# Copy stdout and incr files # from $savdir to $tmpdir list="$exp1 $exp2 $exp3" for exp in $list; do @@ -43,7 +43,7 @@ for exp in $list; do imem=1 while [[ $imem -le $nmem ]]; do member="_mem"`printf %03i $imem` - $ncp $savdir/$exp/sanl_${global_adate}_fhr06$member $tmpdir/sanl$member.$exp + $ncp $savdir/$exp/incr_${global_adate}_fhr06$member $tmpdir/incr$member.$exp (( imem = $imem + 1 )) done done @@ -282,10 +282,13 @@ nmem=10 imem=1 while [[ $imem -le $nmem ]]; do member="_mem"`printf %03i $imem` - if ! cmp -s sanl$member.${exp1} sanl$member.${exp2} -then - echo 'sanl'$member'.'${exp1}' sanl'$member'.'${exp2}' are NOT identical' -fi + ncdump incr$member.${exp1} > incr$member.${exp1}.out + ncdump incr$member.${exp2} > incr$member.${exp2}.out + if [ ! diff incr$member.${exp1}.out incr$member.${exp2}.out ]; then + echo 'incr'$member'.'${exp1}' incr'$member'.'${exp2}' are NOT identical' + else + rm -f incr$member.${exp1}.out incr$member.${exp2}.out + fi (( imem = $imem + 1 )) done echo @@ -379,11 +382,14 @@ else imem=1 while [[ $imem -le $nmem ]]; do member="_mem"`printf %03i $imem` - if ! cmp -s sanl$member.${exp1} sanl$member.${exp3} - then - echo 'sanl'$member'.'${exp1}' sanl'$member'.'${exp3}' are NOT identical' + ncdump incr$member.${exp1} > incr$member.${exp1}.out + ncdump incr$member.${exp3} > incr$member.${exp3}.out + if [ ! diff incr$member.${exp1}.out incr$member.${exp3}.out ]; then + echo 'incr'$member'.'${exp1}' incr'$member'.'${exp3}' are NOT identical' + else + rm -f incr$member.${exp1}.out incr$member.${exp3}.out fi - (( imem = $imem + 1 )) + (( imem = $imem + 1 )) done echo } >> $output @@ -411,11 +417,20 @@ mkdir -p $vfydir $ncp $output $vfydir/ +# Final check for any failed tests +count=$(grep -i "fail" $output |wc -l) +if [ $count -gt 0 ]; then + (( failed_test = $failed_test + $count )) +fi + +# Remove job log files is no failures detected cd $scripts -rm -f ${exp1}.out -rm -f ${exp2}.out -rm -f ${exp3}.out -rm -f ${exp2_scale}.out +if [ $count -eq 0 ]; then + rm -f ${exp1}.out + rm -f ${exp2}.out + rm -f ${exp3}.out + rm -f ${exp2_scale}.out +fi if [[ "$clean" = ".true." ]]; then rm -rf $savdir From 8857995a2467a2f0c608a10d08ca24fdf8589fcc Mon Sep 17 00:00:00 2001 From: Yongming-OUMAP <66268887+Wangy1111@users.noreply.github.com> Date: Mon, 13 Feb 2023 17:12:15 -0600 Subject: [PATCH 002/109] GitHub Issue NOAA-EMC/GSI#468 Enhancements to SDL and VDL for simultaneous multiscale EnVar and parallel ensemble IO for EnVar for FV3-LAM (#504) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The following capabilities developed by OU MAP lab are included (1) Further development for simultaneous multiscale EnVar for both global and regional DA (1a) spatial scale-dependent localization (SDL; contributed by Ting Lei and Daryl Kleist/EMC) is implemented in EnVar as described in Huang et al 2021, MWR for the global NWP application. (1b) variable-dependent localization (VDL) method by Wang and Wang 2022, JAMES is implemented in EnVar. (2)Development of parallel ensemble IO for EnVar for FV3-LAM  Implement an approach to simultaneously read in all ensemble members for EnVar. Specifically, parallel ensemble IO for both conventional and radar EnVar for FV3-LAM is implemented by reading in all ensemble members simultaneously. (3) Direct assimilation of radar reflectivity for EnVar for RRFS The direct radar reflectivity assimilation approach by Wang and Wang 2017, MWR is implemented and tested for FV3-LAM. Fixes #468 --- src/enkf/gridinfo_fv3reg.f90 | 3 +- src/gsi/apply_scaledepwgts.f90 | 173 ++++++ src/gsi/cplr_get_fv3_regional_ensperts.f90 | 519 +++++++++++++++++- src/gsi/general_specmod.f90 | 31 ++ src/gsi/get_gefs_ensperts_dualres.f90 | 32 ++ src/gsi/gsi_files.cmake | 1 + src/gsi/gsi_rfv3io_mod.f90 | 593 ++++++++++++++++++++- src/gsi/gsimod.F90 | 44 +- src/gsi/hybrid_ensemble_isotropic.F90 | 213 ++++++-- src/gsi/hybrid_ensemble_parameters.f90 | 21 + src/gsi/obsmod.F90 | 2 +- src/gsi/read_dbz_nc.f90 | 8 +- src/gsi/setupdbz.f90 | 48 +- src/gsi/update_guess.f90 | 6 +- 14 files changed, 1576 insertions(+), 118 deletions(-) create mode 100644 src/gsi/apply_scaledepwgts.f90 diff --git a/src/enkf/gridinfo_fv3reg.f90 b/src/enkf/gridinfo_fv3reg.f90 index 53e5f5b3de..ef5b242901 100644 --- a/src/enkf/gridinfo_fv3reg.f90 +++ b/src/enkf/gridinfo_fv3reg.f90 @@ -43,7 +43,8 @@ module gridinfo ! !$$$ -use mpisetup, only: nproc, mpi_integer, mpi_real4, mpi_comm_world,mpi_status +use mpisetup, only: nproc, mpi_integer, mpi_real4,mpi_status +use mpimod, only: mpi_comm_world use params, only: datapath,nlevs,nlons,nlats,use_gfs_nemsio, fgfileprefixes, & fv3fixpath, nx_res,ny_res, ntiles,l_fv3reg_filecombined,paranc, & fv3_io_layout_nx,fv3_io_layout_ny diff --git a/src/gsi/apply_scaledepwgts.f90 b/src/gsi/apply_scaledepwgts.f90 new file mode 100644 index 0000000000..62c455e011 --- /dev/null +++ b/src/gsi/apply_scaledepwgts.f90 @@ -0,0 +1,173 @@ +!$$$ program documentation block +! +! program history: +! +! 2018-03-28 T. Lei and D. Kleist - consoliated and added codes +! for the scale dependent scale localization scheme +! +!$$$ end documentation block + +function fwgtofwvlen (rvlft,rvrgt,rcons,rlen,rinput) +!$$$ subprogram documentation block +! +! subprogram: fwgtofwvlen +! +! abstract: Calculation of spectral filter functions +! +!$$$ end documentation block + + use kinds, only: r_kind,i_kind,r_single + implicit none + + real(r_kind),intent(in) :: rvlft,rvrgt,rcons,rlen,rinput + real(r_kind) :: fwgtofwvlen + real(r_kind) :: rlen1,rtem1,rconshalf + + rlen1=rlen/10.0_r_kind ! rlen corresponds to a (-5,5) region + rconshalf=0.5_r_kind*rcons + if(rinput > rvlft .and. rinput < rvrgt) then + fwgtofwvlen=rcons + else + rtem1=min(abs(rinput-rvlft),abs(rinput-rvrgt)) + fwgtofwvlen=rconshalf*(1.0_r_kind+tanh(5.0_r_kind-rtem1/rlen1)) + endif + +end function fwgtofwvlen +! . . . . +subroutine init_mult_spc_wgts(jcap_in) +!$$$ subprogram documentation block +! +! subprogram: init_mult_spc_wgts +! +!$$$ end documentation block + + use kinds, only: r_kind,i_kind,r_single + use hybrid_ensemble_parameters,only: s_ens_hv,sp_loc,grd_ens,grd_loc,sp_ens + use hybrid_ensemble_parameters,only: n_ens,p_sploc2ens,grd_sploc + use hybrid_ensemble_parameters,only: use_localization_grid + use gridmod,only: use_sp_eqspace + use general_specmod, only: general_init_spec_vars + use constants, only: zero,half,one,two,three,rearth,pi + use constants, only: rad2deg + use mpimod, only: mype + use general_sub2grid_mod, only: general_sub2grid_create_info + use egrid2agrid_mod,only: g_create_egrid2agrid + use general_sub2grid_mod, only: sub2grid_info + use gsi_io, only: verbose + use hybrid_ensemble_parameters, only: nsclgrp + use hybrid_ensemble_parameters, only: spc_multwgt,spcwgt_params,i_ensloccov4scl + implicit none + + integer(i_kind),intent(in ) :: jcap_in + real(r_kind),allocatable :: totwvlength(:) + + integer(i_kind) i,ii,j,k,l,n,kk,nsigend + integer(i_kind) ig + real(r_kind) rwv0,rtem1,rtem2 + real (r_kind):: fwgtofwvlen + integer(i_kind) :: l_sum_spc_weights + + ! Spectral scale decomposition is differernt between SDL-cross and SDL-nocross + if( i_ensloccov4scl == 1 )then + l_sum_spc_weights = 1 + else + l_sum_spc_weights = 0 + end if + + allocate(totwvlength(jcap_in)) + + rwv0=2*pi*rearth*0.001_r_kind + do i=1,jcap_in + totwvlength(i)= rwv0/real(i) + enddo + do i=1,jcap_in + rtem1=0 + do ig=1,nsclgrp + if(ig /= 2) then + spc_multwgt(i,ig)=fwgtofwvlen(spcwgt_params(1,ig),spcwgt_params(2,ig),& + spcwgt_params(3,ig),spcwgt_params(4,ig),totwvlength(i)) + if(l_sum_spc_weights == 0 ) then + rtem1=rtem1+spc_multwgt(i,ig) + else + rtem1=rtem1+spc_multwgt(i,ig)*spc_multwgt(i,ig) + endif + endif + enddo + rtem2 =1.0_r_kind - rtem1 + if(abs(rtem2) >= zero) then + + if(l_sum_spc_weights == 0 ) then + spc_multwgt(i,2)=rtem2 + else + spc_multwgt(i,2)=sqrt(rtem2) + endif + endif + enddo + spc_multwgt=max(spc_multwgt,0.0_r_kind) + + deallocate(totwvlength) + return +end subroutine init_mult_spc_wgts + +subroutine apply_scaledepwgts(grd_in,sp_in,wbundle,spwgts,wbundle2) +! +! Program history log: +! 2017-03-30 J. Kay, X. Wang - copied from Kleist's apply_scaledepwgts and +! add the calculation of scale-dependent weighting for mixed resolution ensemble +! POC: xuguang.wang@ou.edu +! + use constants, only: one + use control_vectors, only: nrf_var,cvars2d,cvars3d,control_vector + use kinds, only: r_kind,i_kind + use kinds, only: r_single + use mpimod, only: mype,nvar_id,levs_id + use hybrid_ensemble_parameters, only: oz_univ_static + use general_specmod, only: general_spec_multwgt + use gsi_bundlemod, only: gsi_bundle + use general_sub2grid_mod, only: general_sub2grid,general_grid2sub + use general_specmod, only: spec_vars + use general_sub2grid_mod, only: sub2grid_info + use mpimod, only: mpi_comm_world,mype,npe,ierror + use file_utility, only : get_lun + implicit none + +! Declare passed variables + type(gsi_bundle),intent(in) :: wbundle + type(gsi_bundle),intent(inout) :: wbundle2 + type(spec_vars),intent (in):: sp_in + type(sub2grid_info),intent(in)::grd_in + real(r_kind),dimension(0:sp_in%jcap),intent(in):: spwgts + +! Declare local variables + integer(i_kind) ii,kk + integer(i_kind) i,j,lunit + + real(r_kind),dimension(grd_in%lat2,grd_in%lon2):: slndt,sicet,sst + real(r_kind),dimension(grd_in%nlat*grd_in%nlon*grd_in%nlevs_alloc) :: hwork + real(r_kind),dimension(grd_in%nlat,grd_in%nlon,grd_in%nlevs_alloc) :: work + real(r_kind),dimension(sp_in%nc):: spc1 + character*64 :: fname1 + character*5:: varname1 + +! Beta1 first +! Get from subdomains to + call general_sub2grid(grd_in,wbundle%values,hwork) + work=reshape(hwork,(/grd_in%nlat,grd_in%nlon,grd_in%nlevs_alloc/)) + + do kk=1,grd_in%nlevs_alloc +! Transform from physical space to spectral space + call general_g2s0(grd_in,sp_in,spc1,work(:,:,kk)) + +! Apply spectral weights + call general_spec_multwgt(sp_in,spc1,spwgts) +! Transform back to physical space + call general_s2g0(grd_in,sp_in,spc1,work(:,:,kk)) + + end do + +! Transfer work back to subdomains + hwork=reshape(work,(/grd_in%nlat*grd_in%nlon*grd_in%nlevs_alloc/)) + call general_grid2sub(grd_in,hwork,wbundle2%values) + + return +end subroutine apply_scaledepwgts diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 index f99ca39790..6e94b29c6c 100644 --- a/src/gsi/cplr_get_fv3_regional_ensperts.f90 +++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90 @@ -8,14 +8,18 @@ module get_fv3_regional_ensperts_mod procedure, pass(this) :: get_fv3_regional_ensperts => get_fv3_regional_ensperts_run procedure, pass(this) :: ens_spread_dualres_regional => ens_spread_dualres_regional_fv3_regional procedure, pass(this) :: general_read_fv3_regional + procedure, pass(this) :: general_read_fv3_regional_parallel_over_ens + procedure, pass(this) :: parallel_read_fv3_step2 + procedure, nopass :: fill_regional_2d end type get_fv3_regional_ensperts_class - type(sub2grid_info):: grd_fv3lam_ens_dynvar_io_nouv,grd_fv3lam_ens_tracer_io_nouv,grd_fv3lam_ens_uv + type(sub2grid_info):: grd_fv3lam_ens_dynvar_io_nouv,grd_fv3lam_ens_tracer_io_nouv,grd_fv3lam_ens_uv,grd_fv3lam_ens_phyvar_io_nouv character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_ens_io_dynmetvars3d_nouv ! copy of cvars3d excluding uv 3-d fields character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_ens_io_tracermetvars3d_nouv ! copy of cvars3d excluding uv 3-d fields character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_ens_io_dynmetvars2d_nouv character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_ens_io_tracermetvars2d_nouv + character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_ens_io_phymetvars3d_nouv contains subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) @@ -46,8 +50,8 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) use kinds, only: r_kind,i_kind,r_single use constants, only: zero,one,half,zero_single,rd_over_cp,one_tenth - use mpimod, only: mpi_comm_world,ierror,mype - use hybrid_ensemble_parameters, only: n_ens,grd_ens + use mpimod, only: mpi_comm_world,ierror,mype,npe + use hybrid_ensemble_parameters, only: n_ens,grd_ens,parallelization_over_ensmembers use hybrid_ensemble_parameters, only: l_both_fv3sar_gfs_ens, n_ens_gfs,n_ens_fv3sar use hybrid_ensemble_parameters, only: ntlevs_ens,ensemble_path use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d @@ -69,6 +73,8 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) use gsi_rfv3io_mod, only: fv3lam_io_dynmetvars2d_nouv,fv3lam_io_tracermetvars2d_nouv use netcdf , only: nf90_open, nf90_close,nf90_nowrite,nf90_inquire,nf90_format_netcdf4 use netcdf_mod , only: nc_check + use gsi_rfv3io_mod, only: fv3lam_io_phymetvars3d_nouv + use obsmod, only: if_model_dbz implicit none @@ -79,7 +85,11 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig):: u,v,tv,oz,rh real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2):: ps - real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig)::w,ql,qi,qr,qg,qs,qnr + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig)::w,ql,qi,qr,qg,qs,qnr,dbz + real(r_kind),dimension(:,:,:),allocatable :: gg_u,gg_v,gg_tv,gg_rh + real(r_kind),dimension(:,:,:),allocatable :: gg_w,gg_dbz,gg_qr,gg_qs, & + gg_qi,gg_qg,gg_oz,gg_cwmr + real(r_kind),dimension(:,:),allocatable :: gg_ps real(r_single),pointer,dimension(:,:,:):: w3 =>NULL() real(r_single),pointer,dimension(:,:):: w2 =>NULL() @@ -96,9 +106,9 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) integer(i_kind):: i,j,k,n,mm1,istatus integer(i_kind):: ndynvario2d,ntracerio2d - integer(r_kind):: ndynvario3d,ntracerio3d + integer(r_kind):: ndynvario3d,ntracerio3d,nphyvario3d integer(i_kind):: inner_vars,numfields - integer(i_kind):: ilev,ic2,ic3 + integer(i_kind):: ilev,ic2,ic3,iope integer(i_kind):: m integer(i_kind)::loc_id,ncfmt @@ -125,8 +135,10 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) !clt setup varnames for IO ndynvario2d=0 ntracerio2d=0 + nphyvario3d=0 ndynvario3d=size(fv3lam_io_dynmetvars3d_nouv) ntracerio3d=size(fv3lam_io_tracermetvars3d_nouv) + nphyvario3d=size(fv3lam_io_phymetvars3d_nouv) if (allocated(fv3lam_io_dynmetvars2d_nouv))then ndynvario2d=size(fv3lam_io_dynmetvars2d_nouv) endif @@ -137,6 +149,10 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) allocate(fv3lam_ens_io_tracermetvars3d_nouv(ndynvario3d)) fv3lam_ens_io_dynmetvars3d_nouv=fv3lam_io_dynmetvars3d_nouv fv3lam_ens_io_tracermetvars3d_nouv=fv3lam_io_tracermetvars3d_nouv + if ( nphyvario3d > 0 )then + allocate(fv3lam_ens_io_phymetvars3d_nouv(nphyvario3d)) + fv3lam_ens_io_phymetvars3d_nouv=fv3lam_io_phymetvars3d_nouv + end if if (ndynvario2d > 0 ) then allocate(fv3lam_ens_io_dynmetvars2d_nouv(ndynvario2d)) fv3lam_ens_io_dynmetvars2d_nouv=fv3lam_io_dynmetvars2d_nouv @@ -168,6 +184,24 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) call general_sub2grid_create_info(grd_fv3lam_ens_dynvar_io_nouv,inner_vars,grd_ens%nlat,& grd_ens%nlon,grd_ens%nsig,numfields,regional,names=names,lnames=lnames) + if( nphyvario3d > 0 )then + inner_vars=1 + numfields=inner_vars*(nphyvario3d*grd_ens%nsig) + deallocate(lnames,names) + allocate(lnames(1,numfields),names(1,numfields)) + ilev=1 + do i=1,nphyvario3d + do k=1,grd_ens%nsig + lnames(1,ilev)=k + names(1,ilev)=fv3lam_ens_io_phymetvars3d_nouv(i) + ilev=ilev+1 + enddo + enddo + + call general_sub2grid_create_info(grd_fv3lam_ens_phyvar_io_nouv,inner_vars,grd_ens%nlat,& + grd_ens%nlon,grd_ens%nsig,numfields,regional,names=names,lnames=lnames) + end if + inner_vars=1 numfields=inner_vars*(ntracerio3d*grd_ens%nsig+ntracerio2d) deallocate(lnames,names) @@ -254,16 +288,73 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) mm1=mype+1 kap1=rd_over_cp+one kapr=one/rd_over_cp + + if( parallelization_over_ensmembers ) then + if(n_ens_fv3sar>npe) then + parallelization_over_ensmembers=.false. +130 format('Disabling parallelization_over_ensmembers because number of ensemble members (',I0,') is greater than number of MPI ranks (',I0,').') + if(mype==0) then + write(6,130) n_ens_fv3sar,npe + endif + endif + endif ! parallelization_over_ensmembers + + if(parallelization_over_ensmembers .and. mype==0) then + write(6,'(I0,A)') mype,': will read ensemble data in parallel (parallelization_over_ensmembers=.true.)' + endif + + if( parallelization_over_ensmembers )then + do n=1,n_ens_fv3sar + write(ensfilenam_str,22) trim(adjustl(ensemble_path)),ens_fhrlevs(m),n +22 format(a,'fv3SAR',i2.2,'_ens_mem',i3.3) + iope=(n-1)*npe/n_ens_fv3sar + ! DEFINE INPUT FILE NAME + fv3_filename%grid_spec=trim(ensfilenam_str)//'-fv3_grid_spec' + fv3_filename%ak_bk=trim(ensfilenam_str)//'-fv3_akbk' + fv3_filename%dynvars=trim(ensfilenam_str)//'-fv3_dynvars' + fv3_filename%tracers=trim(ensfilenam_str)//"-fv3_tracer" + fv3_filename%phyvars=trim(ensfilenam_str)//'-fv3_phyvars' + fv3_filename%sfcdata=trim(ensfilenam_str)//"-fv3_sfcdata" + fv3_filename%couplerres=trim(ensfilenam_str)//"-coupler.res" + + + if( mype==iope) then + allocate(gg_u(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_v(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_tv(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_rh(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_oz(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_ps(grd_ens%nlat,grd_ens%nlon)) + if ( .not. if_model_dbz ) then + call this%general_read_fv3_regional_parallel_over_ens(iope,fv3_filename,gg_ps,gg_u,gg_v,gg_tv,gg_rh,gg_oz) + else + allocate(gg_w(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_dbz(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_qr(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_qs(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_qi(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_qg(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_cwmr(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + call this%general_read_fv3_regional_parallel_over_ens(iope,fv3_filename,gg_ps,gg_u,gg_v,gg_tv,gg_rh,gg_oz, & + g_ql=gg_cwmr,g_qi=gg_qi,g_qr=gg_qr,g_qs=gg_qs,g_qg=gg_qg,g_w=gg_w,g_dbz=gg_dbz) + end if + end if + end do + if(mype==0) then + write(6,'(I0,A)') mype,': reading ensemble data in parallel is done (parallelization_over_ensmembers=.true.)' + endif + end if + call MPI_Barrier(mpi_comm_world,ierror) ! ! LOOP OVER ENSEMBLE MEMBERS do n_fv3sar=1,n_ens_fv3sar n=n_ens_gfs+n_fv3sar write(ensfilenam_str,22) trim(adjustl(ensemble_path)),ens_fhrlevs(m),n_fv3sar -22 format(a,'fv3SAR',i2.2,'_ens_mem',i3.3) ! DEFINE INPUT FILE NAME fv3_filename%grid_spec=trim(ensfilenam_str)//'-fv3_grid_spec' !exmaple thinktobe fv3_filename%ak_bk=trim(ensfilenam_str)//'-fv3_akbk' fv3_filename%dynvars=trim(ensfilenam_str)//'-fv3_dynvars' + fv3_filename%phyvars=trim(ensfilenam_str)//'-fv3_phyvars' fv3_filename%tracers=trim(ensfilenam_str)//"-fv3_tracer" fv3_filename%sfcdata=trim(ensfilenam_str)//"-fv3_sfcdata" fv3_filename%couplerres=trim(ensfilenam_str)//"-coupler.res" @@ -299,15 +390,52 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) endif ! ! READ ENEMBLE MEMBERS DATA - if (mype == 0) write(6,'(a,a)') & - 'CALL READ_FV3_REGIONAL_ENSPERTS FOR ENS DATA with the filename str : ',trim(ensfilenam_str) - if (.not.l_use_dbz_directDA ) then ! Read additional hydrometers and w for dirZDA - call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz) - else - call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz, & - g_ql=ql,g_qi=qi,g_qr=qr,g_qs=qs,g_qg=qg,g_qnr=qnr,g_w=w) + if( .not. parallelization_over_ensmembers )then + if (mype == 0) write(6,'(a,a)') & + 'CALL READ_FV3_REGIONAL_ENSPERTS FOR ENS DATA with the filename str : ',trim(ensfilenam_str) + if (.not. (l_use_dbz_directDA .or. if_model_dbz) ) then ! Read additional hydrometers and w for dirZDA + call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz) + else + if( l_use_dbz_directDA ) then + call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz, & + g_ql=ql,g_qi=qi,g_qr=qr,g_qs=qs,g_qg=qg,g_qnr=qnr,g_w=w) + else if( if_model_dbz )then + call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz, & + g_ql=ql,g_qi=qi,g_qr=qr,g_qs=qs,g_qg=qg,g_qnr=qnr,g_w=w,g_dbz=dbz) + end if + end if end if + if( parallelization_over_ensmembers )then + iope=(n_fv3sar-1)*npe/n_ens_fv3sar + if(mype==iope) then + write(0,'(I0,A,I0,A)') mype,': scatter member ',n_fv3sar,' to other ranks...' + if( if_model_dbz )then + call this%parallel_read_fv3_step2(mype,iope,& + g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,& + g_oz=oz,g_w=w,g_qr=qr,g_qs=qs,g_qi=qi,g_qg=qg,g_dbz=dbz,& + gg_ps=gg_ps,gg_tv=gg_tv,gg_u=gg_u,gg_v=gg_v,& + gg_rh=gg_rh,gg_w=gg_w,gg_dbz=gg_dbz,gg_qr=gg_qr,& + gg_qs=gg_qs,gg_qi=gg_qi,gg_qg=gg_qg,gg_ql=gg_cwmr) + else + call this%parallel_read_fv3_step2(mype,iope,& + g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,g_oz=oz, & + gg_ps=gg_ps,gg_tv=gg_tv,gg_u=gg_u,gg_v=gg_v,gg_rh=gg_rh) + end if + else + if( if_model_dbz )then + call this%parallel_read_fv3_step2(mype,iope,& + g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,& + g_oz=oz,g_w=w,g_qr=qr,g_qs=qs,g_qi=qi,g_qg=qg,g_dbz=dbz) + else + call this%parallel_read_fv3_step2(mype,iope,& + g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,g_oz=oz) + endif + endif + + call MPI_Barrier(mpi_comm_world,ierror) + end if + ! SAVE ENSEMBLE MEMBER DATA IN COLUMN VECTOR do ic3=1,nc3d @@ -463,6 +591,16 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) end do end do end do + + case('dbz','DBZ') + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = dbz(j,i,k) + x3(j,i,k)=x3(j,i,k)+dbz(j,i,k) + end do + end do + end do end select @@ -572,7 +710,7 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) end subroutine get_fv3_regional_ensperts_run subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g_rh,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,g_qnr,g_w) + g_ql,g_qi,g_qr,g_qs,g_qg,g_qnr,g_w,g_dbz) !$$$ subprogram documentation block ! first compied from general_read_arw_regional . . . . ! subprogram: general_read_fv3_regional read fv3sar model ensemble members @@ -623,7 +761,7 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g use hybrid_ensemble_parameters, only: grd_ens use directDA_radaruse_mod, only: l_use_cvpqx, cvpqx_pval, cld_nt_updt use directDA_radaruse_mod, only: l_cvpnr, cvpnr_pval - + use obsmod, only:if_model_dbz implicit none @@ -632,7 +770,7 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g class(get_fv3_regional_ensperts_class), intent(inout) :: this type (type_fv3regfilenameg) , intent (in) :: fv3_filenameginput real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),intent(out)::g_u,g_v,g_tv,g_rh,g_oz - real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),optional,intent(out)::g_ql,g_qi,g_qr + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),optional,intent(out)::g_ql,g_qi,g_qr,g_dbz real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),optional,intent(out)::g_qs,g_qg,g_qnr,g_w real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2),intent(out):: g_ps @@ -656,11 +794,13 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g character(len=24),parameter :: myname_ = 'general_read_fv3_regional' type(gsi_bundle) :: gsibundle_fv3lam_ens_dynvar_nouv type(gsi_bundle) :: gsibundle_fv3lam_ens_tracer_nouv + type(gsi_bundle) :: gsibundle_fv3lam_ens_phyvar_nouv type(gsi_grid):: grid_ens character(len=:),allocatable :: grid_spec !='fv3_grid_spec' character(len=:),allocatable :: ak_bk !='fv3_akbk' character(len=:),allocatable :: dynvars !='fv3_dynvars' + character(len=:),allocatable :: phyvars !='fv3_phyvars' character(len=:),allocatable :: tracers !='fv3_tracer' character(len=:),allocatable :: sfcdata !='fv3_sfcdata' character(len=:),allocatable :: couplerres!='coupler.res' @@ -676,6 +816,7 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g grid_spec=fv3_filenameginput%grid_spec ak_bk=fv3_filenameginput%ak_bk dynvars=fv3_filenameginput%dynvars + phyvars=fv3_filenameginput%phyvars tracers=fv3_filenameginput%tracers sfcdata=fv3_filenameginput%sfcdata couplerres=fv3_filenameginput%couplerres @@ -701,7 +842,10 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g endif - + if(allocated(fv3lam_ens_io_phymetvars3d_nouv))then + call gsi_bundlecreate(gsibundle_fv3lam_ens_phyvar_nouv,grid_ens,'gsibundle_fv3lam_ens_phyvar_nouv',istatus, & + names3d=fv3lam_ens_io_phymetvars3d_nouv) + end if if(fv3sar_ensemble_opt == 0 ) then @@ -714,6 +858,10 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g fv3_filenameginput%dynvars,fv3_filenameginput) call gsi_fv3ncdf_read(grd_fv3lam_ens_tracer_io_nouv,gsibundle_fv3lam_ens_tracer_nouv,& fv3_filenameginput%tracers,fv3_filenameginput) + if( if_model_dbz ) then + call gsi_fv3ncdf_read(grd_fv3lam_ens_phyvar_io_nouv,gsibundle_fv3lam_ens_phyvar_nouv,& + fv3_filenameginput%phyvars,fv3_filenameginput) + end if else call gsi_fv3ncdf_read_v1(grd_fv3lam_ens_dynvar_io_nouv,gsibundle_fv3lam_ens_dynvar_nouv,& fv3_filenameginput%dynvars,fv3_filenameginput) @@ -724,14 +872,17 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_dynvar_nouv, 'tsen' ,g_tsen ,istatus );ier=ier+istatus call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'q' ,g_q ,istatus );ier=ier+istatus call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'oz' ,g_oz ,istatus );ier=ier+istatus - if (l_use_dbz_directDA) then + if (l_use_dbz_directDA .or. if_model_dbz) then call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'ql' ,g_ql ,istatus );ier=ier+istatus call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'qi' ,g_qi ,istatus );ier=ier+istatus call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'qr' ,g_qr ,istatus );ier=ier+istatus call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'qs' ,g_qs ,istatus );ier=ier+istatus call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'qg' ,g_qg ,istatus );ier=ier+istatus + if (l_use_dbz_directDA) & call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'qnr',g_qnr ,istatus );ier=ier+istatus call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_dynvar_nouv, 'w' , g_w ,istatus );ier=ier+istatus + if( if_model_dbz )& + call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_phyvar_nouv, 'dbz' , g_dbz ,istatus );ier=ier+istatus end if @@ -834,11 +985,339 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g enddo call gsi_bundledestroy(gsibundle_fv3lam_ens_dynvar_nouv) call gsi_bundledestroy(gsibundle_fv3lam_ens_tracer_nouv) - + call gsi_bundledestroy(gsibundle_fv3lam_ens_phyvar_nouv) return end subroutine general_read_fv3_regional + subroutine general_read_fv3_regional_parallel_over_ens(this,iope,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g_rh,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,g_qnr,g_w,g_dbz) + !$$$ subprogram documentation block + ! first compied from general_read_arw_regional . . . . + ! subprogram: general_read_fv3_regional read fv3sar model ensemble members + ! prgmmr: Ting org: emc/ncep date: 2018 + ! + ! abstract: read ensemble members from the fv3sar model in "restart" or "cold start" netcdf format + ! for use with hybrid ensemble option. + ! + ! program history log: + ! 2018- Ting - intial versions + ! 2022-04-01 Y. Wang and X. Wang - read all fields for each member for + ! parallel ensemble IO capability + ! poc: xuguang.wang@ou.edu + ! + ! input argument list: + ! + ! output argument list: + ! + ! attributes: + ! language: f90 + ! machine: ibm RS/6000 SP + ! + !$$$ end documentation block + + use netcdf, only: nf90_nowrite + use netcdf, only: nf90_open,nf90_close + use netcdf, only: nf90_inq_dimid,nf90_inquire_dimension + use netcdf, only: nf90_inq_varid,nf90_inquire_variable,nf90_get_var + use kinds, only: r_kind,r_single,i_kind + use gridmod, only: eta1_ll,eta2_ll + use constants, only: zero,one,fv,zero_single,one_tenth,h300 + use hybrid_ensemble_parameters, only: grd_ens,q_hyb_ens + use hybrid_ensemble_parameters, only: fv3sar_ensemble_opt + + use mpimod, only: mpi_comm_world,mpi_rtype,mype + use netcdf_mod, only: nc_check + use gsi_rfv3io_mod,only: type_fv3regfilenameg + use gsi_rfv3io_mod,only:n2d + use constants, only: half,zero + use gsi_rfv3io_mod, only: gsi_fv3ncdf_read + use gsi_rfv3io_mod, only: gsi_fv3ncdf_read_v1 + use gsi_rfv3io_mod, only: gsi_fv3ncdf_readuv + use gsi_rfv3io_mod, only: gsi_fv3ncdf_readuv_v1 + use gsi_rfv3io_mod, only: gsi_fv3ncdf2d_read_v1 + use directDA_radaruse_mod, only: l_use_dbz_directDA + use gsi_bundlemod, only: gsi_gridcreate + use gsi_bundlemod, only: gsi_grid + use gsi_bundlemod, only: gsi_bundlecreate,gsi_bundledestroy + use gsi_bundlemod, only: gsi_bundlegetvar + use obsmod, only: if_model_dbz + use directDA_radaruse_mod, only: l_use_cvpqx, cvpqx_pval, cld_nt_updt + use directDA_radaruse_mod, only: l_cvpnr, cvpnr_pval + use gsi_rfv3io_mod, only: gsi_fv3ncdf_read_ens_parallel_over_ens,gsi_fv3ncdf_readuv_ens_parallel_over_ens + + + + implicit none +! +! Declare passed variables + class(get_fv3_regional_ensperts_class), intent(inout) :: this + integer(i_kind), intent (in) :: iope + type (type_fv3regfilenameg) , intent (in) :: fv3_filenameginput + real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig),intent(out)::g_u,g_v,g_tv,g_rh,g_oz + real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig),optional,intent(out)::g_ql,g_qi,g_qr,g_dbz + real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig),optional,intent(out)::g_qs,g_qg,g_qnr,g_w + + real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon),intent(out):: g_ps + real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig+1) ::g_prsi + real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig) ::g_prsl ,g_tsen,g_q,g_delp +! +! Declare local parameters + real(r_kind),parameter:: r0_01 = 0.01_r_kind + real(r_kind),parameter:: r10 = 10.0_r_kind + real(r_kind),parameter:: r100 = 100.0_r_kind + ! +! Declare local variables + + integer(i_kind):: i,j,k,kp + + integer(i_kind) iderivative + + + logical ice + + character(len=24),parameter :: myname_ = 'general_read_fv3_regional' + + character(len=:),allocatable :: grid_spec !='fv3_grid_spec' + character(len=:),allocatable :: ak_bk !='fv3_akbk' + character(len=:),allocatable :: dynvars !='fv3_dynvars' + character(len=:),allocatable :: phyvars !='fv3_phyvars' + character(len=:),allocatable :: tracers !='fv3_tracer' + character(len=:),allocatable :: sfcdata !='fv3_sfcdata' + character(len=:),allocatable :: couplerres!='coupler.res' + integer (i_kind) ier,istatus + + + associate( this => this ) ! eliminates warning for unused dummy argument needed for binding + end associate + + if( mype == iope )then + grid_spec=fv3_filenameginput%grid_spec + ak_bk=fv3_filenameginput%ak_bk + dynvars=fv3_filenameginput%dynvars + phyvars=fv3_filenameginput%phyvars + tracers=fv3_filenameginput%tracers + sfcdata=fv3_filenameginput%sfcdata + couplerres=fv3_filenameginput%couplerres + + if(fv3sar_ensemble_opt == 0 ) then + call gsi_fv3ncdf_readuv_ens_parallel_over_ens(g_u,g_v,fv3_filenameginput,iope) + else + write(6,*) "Warning: we can only grab fields from restart files not cold start files for ensemble!" + endif + + if(fv3sar_ensemble_opt == 0) then + if (if_model_dbz) then + call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%dynvars,fv3_filenameginput,delp=g_delp,tsen=g_tsen,w=g_w,iope=iope) + call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%tracers,fv3_filenameginput,q=g_q,oz=g_oz,ql=g_ql,qr=g_qr,& + qs=g_qs,qi=g_qi,qg=g_qg,iope=iope) + call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%phyvars,fv3_filenameginput,dbz=g_dbz,iope=iope) + else + call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%dynvars,fv3_filenameginput,delp=g_delp,tsen=g_tsen,iope=iope) + call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%tracers,fv3_filenameginput,q=g_q,oz=g_oz,iope=iope) + end if + else + write(6,*) "Warning: we can only grab fields from restart files not cold start files for ensemble!" + endif + + + if (fv3sar_ensemble_opt == 0) then + g_prsi(:,:,grd_ens%nsig+1)=eta1_ll(grd_ens%nsig+1) !thinkto be done , should use eta1_ll from ensemble grid + do i=grd_ens%nsig,1,-1 + g_prsi(:,:,i)=g_delp(:,:,i)*0.001_r_kind+g_prsi(:,:,i+1) + enddo + g_ps(:,:)=g_prsi(:,:,1) + + endif + + !! tsen2tv !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do k=1,grd_ens%nsig + do j=1,grd_ens%nlon + do i=1,grd_ens%nlat + g_tv(i,j,k)=g_tsen(i,j,k)*(one+fv*g_q(i,j,k)) + enddo + enddo + enddo + if (.not.q_hyb_ens) then + ice=.true. + iderivative=0 + do k=1,grd_ens%nsig + kp=k+1 + do j=1,grd_ens%nlon + do i=1,grd_ens%nlat + g_prsl(i,j,k)=(g_prsi(i,j,k)+g_prsi(i,j,kp))*half + end do + end do + end do + call genqsat(g_rh,g_tsen(1,1,1),g_prsl(1,1,1),grd_ens%nlat,grd_ens%nlon,grd_ens%nsig,ice,iderivative) + do k=1,grd_ens%nsig + do j=1,grd_ens%nlon + do i=1,grd_ens%nlat + g_rh(i,j,k) = g_q(i,j,k)/g_rh(i,j,k) + end do + end do + end do + else + do k=1,grd_ens%nsig + do j=1,grd_ens%nlon + do i=1,grd_ens%nlat + g_rh(i,j,k) = g_q(i,j,k) + end do + end do + end do + end if + end if ! mype + + return + end subroutine general_read_fv3_regional_parallel_over_ens + + + subroutine parallel_read_fv3_step2(this,mype,iope, & + g_ps,g_u,g_v,g_tv,g_rh,g_ql,g_oz,g_w,g_qr,g_qs,g_qi,& + g_qg,g_dbz, & + gg_ps,gg_tv,gg_u,gg_v,gg_rh,gg_w,gg_dbz,gg_qr,& + gg_qs,gg_qi,gg_qg,gg_ql) + + !$$$ subprogram documentation block + ! . + ! subprogram: parallel_read_fv3_step2 distribute all fields into all tasks + ! prgmmr: Y. Wang and X. Wang org: OU/MAP date: 2022-04-01 + ! + ! abstract: All fields have been read in by general_read_fv3_regional_parallel_over_ens. + ! Different tasks contain the data from different members. + ! This program will divided the full-domain fields into subdomains + ! and assign them to all tasks. poc: xuguang.wang@ou.edu + ! + ! program history log: + ! + ! 2022-04-01 Y. Wang and X. Wang - Changed from the code for WRF-ARW + ! + ! input argument list: + ! + ! output argument list: + ! + ! attributes: + ! language: f90 + ! machine: ibm RS/6000 SP + ! + !$$$ end documentation block + + use hybrid_ensemble_parameters, only: grd_ens + use mpimod, only: mpi_comm_world,ierror,mpi_rtype + use kinds, only: r_kind,r_single,i_kind + use gridmod,only: itotsub + + implicit none + + ! + ! Declare passed variables + class(get_fv3_regional_ensperts_class), intent(inout) :: this + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),intent(out):: & + g_u,g_v,g_tv,g_rh,g_ql,g_oz + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),intent(out),optional::& + g_w,g_qr,g_qs,g_qi,g_qg,g_dbz + integer(i_kind), intent(in) :: mype, iope + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2),intent(out):: g_ps + + ! The gg_ arrays are only sent by the rank doing I/O (mype==iope) + real(r_kind),optional,dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig) :: & + gg_u,gg_v,gg_tv,gg_rh + + real(r_kind),optional,dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig) :: & + gg_w,gg_dbz,gg_qr,gg_qs,gg_qi,gg_qg,gg_ql + real(r_kind),optional,dimension(grd_ens%nlat,grd_ens%nlon):: gg_ps + + ! Declare local variables + real(r_kind),allocatable,dimension(:):: wrk_send_2d + integer(i_kind) :: k + + ! transfer data from root to subdomains on each task + ! scatterv used, since full grids exist only on root task. + allocate(wrk_send_2d(grd_ens%itotsub)) + ! first PS (output from fill_regional_2d is a column vector with a halo) + if(mype==iope) call this%fill_regional_2d(gg_ps,wrk_send_2d) + call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_ps,grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) + ! then TV,U,V,RH + do k=1,grd_ens%nsig + if (mype==iope) then + call this%fill_regional_2d(gg_tv(:,:,k),wrk_send_2d) + endif + call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_tv(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) + if (mype==iope) call this%fill_regional_2d(gg_u(1,1,k),wrk_send_2d) + call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_u(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) + if (mype==iope) call this%fill_regional_2d(gg_v(1,1,k),wrk_send_2d) + call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_v(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) + if (mype==iope) call this%fill_regional_2d(gg_rh(1,1,k),wrk_send_2d) + call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_rh(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) + if( present(g_dbz) )then + if (mype==iope) call this%fill_regional_2d(gg_w(1,1,k),wrk_send_2d) + call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_w(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) + if (mype==iope) call this%fill_regional_2d(gg_dbz(1,1,k),wrk_send_2d) + call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype,& + g_dbz(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) + if (mype==iope) call this%fill_regional_2d(gg_qr(1,1,k),wrk_send_2d) + call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype,& + g_qr(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) + if (mype==iope) call this%fill_regional_2d(gg_qs(1,1,k),wrk_send_2d) + call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype,& + g_qs(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) + if (mype==iope) call this%fill_regional_2d(gg_qi(1,1,k),wrk_send_2d) + call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype,& + g_qi(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) + if (mype==iope) call this%fill_regional_2d(gg_qg(1,1,k),wrk_send_2d) + call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & + g_qg(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) + if (mype==iope) call this%fill_regional_2d(gg_ql(1,1,k),wrk_send_2d) + call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype,& + g_ql(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) + end if + enddo + deallocate(wrk_send_2d) + end subroutine parallel_read_fv3_step2 + + subroutine fill_regional_2d(fld_in,fld_out) + !$$$ subprogram documentation block + ! . . . . + ! subprogram: fill_regional_2d + ! prgmmr: mizzi org: ncar/mmm date: 2010-08-11 + ! + ! abstract: create a column vector for the subdomain (including halo) + ! from global 2d grid. + ! + ! + ! program history log: + ! 2010-08-11 parrish, initial documentation + ! 2012-03-12 whitaker, remove nx,ny,itotsub from argument list. + ! + ! input argument list: + ! + ! output argument list: + ! + ! attributes: + ! language: f90 + ! machine: ibm RS/6000 SP + ! + !$$$ end documentation block + use kinds, only: r_kind,i_kind + use hybrid_ensemble_parameters, only: grd_ens + implicit none + real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon)::fld_in + real(r_kind),dimension(grd_ens%itotsub)::fld_out + integer(i_kind):: i,j,k + do k=1,grd_ens%itotsub + i=grd_ens%ltosj_s(k) + j=grd_ens%ltosi_s(k) + fld_out(k)=fld_in(j,i) + enddo + return + end subroutine fill_regional_2d + subroutine ens_spread_dualres_regional_fv3_regional(this,mype,en_perts,nelen) !$$$ subprogram documentation block ! . . . . diff --git a/src/gsi/general_specmod.f90 b/src/gsi/general_specmod.f90 index 439e26e431..20feae98de 100644 --- a/src/gsi/general_specmod.f90 +++ b/src/gsi/general_specmod.f90 @@ -64,6 +64,7 @@ module general_specmod ! set subroutines to public public :: general_init_spec_vars public :: general_destroy_spec_vars + public :: general_spec_multwgt ! set passed variables to public public :: spec_vars public :: spec_cut @@ -306,6 +307,36 @@ subroutine general_init_spec_vars(sp,jcap,jcap_test,nlat_a,nlon_a,eqspace) return end subroutine general_init_spec_vars + subroutine general_spec_multwgt(sp,spcwrk,spcwgt) +! 2017-03-30 J. Kay, X. Wang - add general_spec_multwgt for scale-dependent +! weighting of mixed resolution ensemble, +! POC: xuguang.wang@ou.edu +! + implicit none + type(spec_vars),intent(in) :: sp + real(r_kind),dimension(sp%nc),intent(inout) :: spcwrk + real(r_kind),dimension(0:sp%jcap),intent(in) :: spcwgt + + integer(i_kind) ii1,l,m,jmax,ks,n + +!! Code borrowed from spvar in splib + jmax=sp%jcap + + do n=0,jmax + ks=2*n + spcwrk(ks+1)=spcwrk(ks+1)*spcwgt(n) + end do + do n=0,jmax + do l=MAX(1,n-jmax),MIN(n,jmax) + ks=l*(2*jmax+(-1)*(l-1))+2*n + spcwrk(ks+1) = spcwrk(ks+1)*spcwgt(n) + spcwrk(ks+2) = spcwrk(ks+2)*spcwgt(n) + end do + end do + + return + end subroutine general_spec_multwgt + subroutine general_destroy_spec_vars(sp) !$$$ subprogram documentation block ! . . . . diff --git a/src/gsi/get_gefs_ensperts_dualres.f90 b/src/gsi/get_gefs_ensperts_dualres.f90 index fa3d0ecbdd..1cb7586a89 100644 --- a/src/gsi/get_gefs_ensperts_dualres.f90 +++ b/src/gsi/get_gefs_ensperts_dualres.f90 @@ -68,6 +68,7 @@ subroutine get_gefs_ensperts_dualres use gsi_enscouplermod, only: gsi_enscoupler_create_sub2grid_info use gsi_enscouplermod, only: gsi_enscoupler_destroy_sub2grid_info use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info,general_sub2grid_destroy_info + use hybrid_ensemble_parameters, only: nsclgrp,sp_ens,spc_multwgt,global_spectral_filter_sd implicit none real(r_kind),pointer,dimension(:,:) :: ps @@ -78,6 +79,8 @@ subroutine get_gefs_ensperts_dualres real(r_kind),pointer,dimension(:,:):: x2 type(gsi_bundle),allocatable,dimension(:) :: en_read type(gsi_bundle):: en_bar + type(gsi_bundle) :: en_pertstmp1 + type(gsi_bundle) :: en_pertstmp2 ! type(gsi_grid) :: grid_ens real(r_kind) bar_norm,sig_norm,kapr,kap1 ! real(r_kind),allocatable,dimension(:,:):: z,sst2 @@ -91,6 +94,7 @@ subroutine get_gefs_ensperts_dualres ! integer(i_kind) il,jl logical ice,hydrometeor type(sub2grid_info) :: grd_tmp + integer(i_kind) :: ig0,ig ! Create perturbations grid and get variable names from perturbations if(en_perts(1,1,1)%grid%im/=grd_ens%lat2.or. & @@ -130,6 +134,16 @@ subroutine get_gefs_ensperts_dualres if ( istatus /= 0 ) & call die('get_gefs_ensperts_dualres',': trouble creating en_bar bundle, istatus =',istatus) +! Allocate bundle used for temporary usage + if( nsclgrp > 1 .and. global_spectral_filter_sd )then + call gsi_bundlecreate(en_pertstmp1,en_perts(1,1,1)%grid,'aux-ens-read',istatus,names2d=cvars2d,names3d=cvars3d) + call gsi_bundlecreate(en_pertstmp2,en_perts(1,1,1)%grid,'aux-ens-read',istatus,names2d=cvars2d,names3d=cvars3d) + if(istatus/=0) then + write(6,*)' get_gefs_ensperts_dualres: trouble creating en_read like tempbundle' + call stop2(999) + endif + end if + ! Allocate bundle used for reading members allocate(en_read(n_ens)) do n=1,n_ens @@ -318,12 +332,30 @@ subroutine get_gefs_ensperts_dualres end do end do ntlevs_ens_loop !end do over bins + if(nsclgrp > 1 .and. global_spectral_filter_sd) then + do m=1,ntlevs_ens + do n=1,n_ens + en_pertstmp1%values=en_perts(n,1,m)%valuesr4 + do ig=1,nsclgrp + call apply_scaledepwgts(grd_ens,sp_ens,en_pertstmp1,spc_multwgt(:,ig),en_pertstmp2) + en_perts(n,ig,m)%valuesr4=en_pertstmp2%values + enddo + enddo + enddo + endif + do n=n_ens,1,-1 call gsi_bundledestroy(en_read(n),istatus) if ( istatus /= 0 ) & call die('get_gefs_ensperts_dualres',': trouble destroying en_read bundle, istatus = ', istatus) end do deallocate(en_read) + if(nsclgrp > 1 .and. global_spectral_filter_sd) then + call gsi_bundledestroy(en_pertstmp1,istatus) + call gsi_bundledestroy(en_pertstmp2,istatus) + if ( istatus /= 0 ) & + call die('get_gefs_ensperts_dualres',': trouble destroying en_pertstmp2 bundle, istatus = ', istatus) + end if call gsi_enscoupler_destroy_sub2grid_info(grd_tmp) ! mm1=mype+1 diff --git a/src/gsi/gsi_files.cmake b/src/gsi/gsi_files.cmake index 461b49ddf6..1658c83bf4 100644 --- a/src/gsi/gsi_files.cmake +++ b/src/gsi/gsi_files.cmake @@ -87,6 +87,7 @@ anisofilter_glb.f90 antcorr_application.f90 antest_maps0.f90 antest_maps0_glb.f90 +apply_scaledepwgts.f90 atms_spatial_average_mod.f90 balmod.f90 berror.f90 diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index eb7a86160f..2edde4723f 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -68,6 +68,7 @@ module gsi_rfv3io_mod character(len=:),allocatable :: ak_bk !='fv3_akbk' character(len=:),allocatable :: dynvars !='fv3_dynvars' character(len=:),allocatable :: tracers !='fv3_tracer' + character(len=:),allocatable :: phyvars !='fv3_phyvars' character(len=:),allocatable :: sfcdata !='fv3_sfcdata' character(len=:),allocatable :: couplerres!='coupler.res' contains @@ -91,8 +92,9 @@ module gsi_rfv3io_mod type(sub2grid_info) :: grd_fv3lam_tracer_ionouv type(sub2grid_info) :: grd_fv3lam_tracerchem_ionouv type(sub2grid_info) :: grd_fv3lam_tracersmoke_ionouv + type(sub2grid_info) :: grd_fv3lam_phyvar_ionouv type(sub2grid_info) :: grd_fv3lam_uv - integer(i_kind) ,parameter:: ndynvarslist=13, ntracerslist=8 + integer(i_kind) ,parameter:: ndynvarslist=13, ntracerslist=8, nphyvarslist=1 character(len=max_varname_length), dimension(ndynvarslist), parameter :: & vardynvars = [character(len=max_varname_length) :: & @@ -100,12 +102,14 @@ module gsi_rfv3io_mod character(len=max_varname_length), dimension(ntracerslist+naero_cmaq_fv3+7+naero_smoke_fv3), parameter :: & vartracers = [character(len=max_varname_length) :: & 'q','oz','ql','qi','qr','qs','qg','qnr',aeronames_cmaq_fv3,'pm25at','pm25ac','pm25co','pm2_5','amassi','amassj','amassk',aeronames_smoke_fv3] - character(len=max_varname_length), dimension(15+naero_cmaq_fv3+7+naero_smoke_fv3), parameter :: & + character(len=max_varname_length), dimension(nphyvarslist), parameter :: & + varphyvars = [character(len=max_varname_length) :: 'dbz'] + character(len=max_varname_length), dimension(16+naero_cmaq_fv3+7+naero_smoke_fv3), parameter :: & varfv3name = [character(len=max_varname_length) :: & - 'u','v','W','T','delp','sphum','o3mr','liq_wat','ice_wat','rainwat','snowwat','graupel','rain_nc','ps','DZ', & + 'u','v','W','T','delp','sphum','o3mr','liq_wat','ice_wat','rainwat','snowwat','graupel','rain_nc','ref_f3d','ps','DZ', & aeronames_cmaq_fv3,'pm25at','pm25ac','pm25co','pm2_5','amassi','amassj','amassk',aeronames_smoke_fv3], & vgsiname = [character(len=max_varname_length) :: & - 'u','v','w','tsen','delp','q','oz','ql','qi','qr','qs','qg','qnr','ps','delzinc', & + 'u','v','w','tsen','delp','q','oz','ql','qi','qr','qs','qg','qnr','dbz','ps','delzinc', & aeronames_cmaq_fv3,'pm25at','pm25ac','pm25co','pm2_5','amassi','amassj','amassk',aeronames_smoke_fv3] character(len=max_varname_length),dimension(:),allocatable:: name_metvars2d character(len=max_varname_length),dimension(:),allocatable:: name_metvars3d @@ -119,6 +123,8 @@ module gsi_rfv3io_mod public :: gsi_fv3ncdf_read_v1 public :: gsi_fv3ncdf_readuv public :: gsi_fv3ncdf_readuv_v1 + public :: gsi_fv3ncdf_read_ens_parallel_over_ens + public :: gsi_fv3ncdf_readuv_ens_parallel_over_ens public :: read_fv3_files public :: read_fv3_netcdf_guess public :: wrfv3_netcdf @@ -131,6 +137,7 @@ module gsi_rfv3io_mod public :: ijns,ijns2d,displss,displss2d,ijnz,displsz_g public :: fv3lam_io_dynmetvars3d_nouv,fv3lam_io_tracermetvars3d_nouv public :: fv3lam_io_tracerchemvars3d_nouv,fv3lam_io_tracersmokevars3d_nouv + public :: fv3lam_io_phymetvars3d_nouv public :: fv3lam_io_dynmetvars2d_nouv,fv3lam_io_tracermetvars2d_nouv integer(i_kind) mype_u,mype_v,mype_t,mype_q,mype_p,mype_delz,mype_oz,mype_ql @@ -158,6 +165,7 @@ module gsi_rfv3io_mod ! copy of cvars3d excluding uv 3-d fields character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_io_tracermetvars3d_nouv ! copy of cvars3d excluding uv 3-d fields + character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_io_phymetvars3d_nouv character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_io_tracerchemvars3d_nouv character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_io_tracersmokevars3d_nouv ! copy of cvars3d excluding uv 3-d fields @@ -169,8 +177,10 @@ module gsi_rfv3io_mod !to define names in gsibundle character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_names_gsibundle_tracer_nouv !to define names in gsibundle + character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_names_gsibundle_phyvar_nouv type(gsi_bundle):: gsibundle_fv3lam_dynvar_nouv type(gsi_bundle):: gsibundle_fv3lam_tracer_nouv + type(gsi_bundle):: gsibundle_fv3lam_phyvar_nouv type(gsi_bundle):: gsibundle_fv3lam_tracerchem_nouv type(gsi_bundle):: gsibundle_fv3lam_tracersmoke_nouv @@ -204,6 +214,12 @@ subroutine fv3regfilename_init(this,it) write(filename,"(A11,I2.2)") 'fv3_tracer_',ifilesig(it) this%tracers=trim(filename) endif + if (it == ntguessig) then + this%phyvars='fv3_phyvars' + else + write(filename,"(A12,I2.2)") 'fv3_phyvars_',ifilesig(it) + this%phyvars=trim(filename) + endif if (it == ntguessig) then this%sfcdata='fv3_sfcdata' else @@ -740,6 +756,9 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) ! ! abstract: read guess for FV3 regional model ! program history log: +! 2022-04-01 Y. Wang and X. Wang - add capability to read reflectivity +! for direct radar EnVar DA using reflectivity as state +! variable, poc: xuguang.wang@ou.edu ! attributes: ! language: f90 ! machine: ibm RS/6000 SP @@ -768,6 +787,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) use gsi_metguess_mod, only: gsi_metguess_get use netcdf, only:nf90_open,nf90_close,nf90_inquire,nf90_nowrite, nf90_format_netcdf4 use gsi_chemguess_mod, only: gsi_chemguess_get + use obsmod, only: if_model_dbz implicit none @@ -797,7 +817,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) real(r_kind),dimension(:,:,:),pointer::ges_qg=>NULL() real(r_kind),dimension(:,:,:),pointer::ges_qnr=>NULL() real(r_kind),dimension(:,:,:),pointer::ges_w=>NULL() - + real(r_kind),dimension(:,:,:),pointer::ges_dbz=>NULL() real(r_kind),dimension(:,:,:),pointer::ges_aalj=>NULL() real(r_kind),dimension(:,:,:),pointer::ges_acaj=>NULL() @@ -890,8 +910,8 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) integer(i_kind),dimension(:,:),allocatable:: lnames integer(i_kind),dimension(:,:),allocatable:: uvlnames integer(i_kind):: inner_vars,numfields - integer(i_kind):: ndynvario2d,ntracerio2d,ilev,jdynvar,jtracer - integer(i_kind):: iuv,ndynvario3d,ntracerio3d + integer(i_kind):: ndynvario2d,ntracerio2d,ilev,jdynvar,jtracer,jphyvar + integer(i_kind):: iuv,ndynvario3d,ntracerio3d,nphyvario3d integer(i_kind):: ntracerchemio3d,ntracersmokeio3d integer(i_kind):: loc_id,ncfmt @@ -957,6 +977,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) iuv=0 ndynvario3d=0 ntracerio3d=0 + nphyvario3d=0 do i=1,size(name_metvars3d) vartem=trim(name_metvars3d(i)) if(trim(vartem)=='u'.or.trim(vartem)=='v') then @@ -967,6 +988,8 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) ndynvario3d=ndynvario3d+1 else if (ifindstrloc(vartracers,trim(vartem))> 0) then ntracerio3d=ntracerio3d+1 + else if (ifindstrloc(varphyvars,trim(vartem))> 0) then + nphyvario3d=nphyvario3d+1 else write(6,*)'the metvarname1 ',trim(vartem),' has not been considered yet, stop' call stop2(333) @@ -978,6 +1001,12 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) write(6,*)"the set up for met variable is not as expected, abort" call stop2(222) endif + if ( if_model_dbz ) then + if( nphyvario3d<=0 ) then + write(6,*)"the set up for met variable (phyvar) is not as expected, abort" + call stop2(223) + end if + endif if (fv3sar_bg_opt == 0.and.ifindstrloc(name_metvars3d,'delp') <= 0)then ndynvario3d=ndynvario3d+1 ! for delp endif @@ -987,6 +1016,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) if (l_reg_update_hydro_delz.and.fv3sar_bg_opt==0) ndynvario3d=ndynvario3d+1 ! for delzinc allocate(fv3lam_io_dynmetvars3d_nouv(ndynvario3d)) allocate(fv3lam_io_tracermetvars3d_nouv(ntracerio3d)) + allocate(fv3lam_io_phymetvars3d_nouv(nphyvario3d)) if (laeroana_fv3cmaq) then allocate(fv3lam_io_tracerchemvars3d_nouv(naero_cmaq_fv3+7)) @@ -998,6 +1028,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) jdynvar=0 jtracer=0 + jphyvar=0 do i=1,size(name_metvars3d) vartem=trim(name_metvars3d(i)) if(.not.(trim(vartem)=='u'.or.trim(vartem)=='v'.or.trim(vartem)=='iqr')) then @@ -1012,6 +1043,9 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) else if (ifindstrloc(vartracers,trim(vartem)) > 0) then jtracer=jtracer+1 fv3lam_io_tracermetvars3d_nouv(jtracer)=trim(vartem) + else if (ifindstrloc(varphyvars,trim(vartem)) > 0) then + jphyvar=jphyvar+1 + fv3lam_io_phymetvars3d_nouv(jphyvar)=trim(vartem) else write(6,*)'the metvarname ',vartem,' is not expected, stop' call flush(6) @@ -1027,7 +1061,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) jdynvar=jdynvar+1 fv3lam_io_dynmetvars3d_nouv(jdynvar)="delzinc" endif - if(jdynvar /= ndynvario3d.or.jtracer /= ntracerio3d ) then + if(jdynvar /= ndynvario3d.or.jtracer /= ntracerio3d.or.jphyvar /= nphyvario3d ) then write(6,*)'ndynvario3d is not as expected, stop' call flush(6) call stop2(333) @@ -1035,6 +1069,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) if(mype == 0) then write(6,*) ' fv3lam_io_dynmetvars3d_nouv is ',(trim(fv3lam_io_dynmetvars3d_nouv(i)),i=1,ndynvario3d) write(6,*) ' fv3lam_io_tracermevars3d_nouv is ',(trim(fv3lam_io_tracermetvars3d_nouv(i)),i=1,ntracerio3d) + write(6,*) ' fv3lam_io_phymetvars3d_nouv is ',(trim(fv3lam_io_phymetvars3d_nouv(i)),i=1,nphyvario3d) endif ndynvario2d=0 @@ -1047,7 +1082,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) else if (ifindstrloc(vartracers,trim(vartem)) > 0) then ntracerio2d=ntracerio2d+1 else if(trim(vartem)=='z') then - write(6,*)'the metvarname ',trim(vartem),' will be dealt separately' + if(mype == 0) write(6,*)'the metvarname ',trim(vartem),' will be dealt separately' else if(trim(vartem)=='t2m') then else if(trim(vartem)=='q2m') then else @@ -1165,6 +1200,11 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) ntracerio2d=0 endif + if( if_model_dbz )then + call gsi_bundlecreate(gsibundle_fv3lam_phyvar_nouv,GSI_MetGuess_Bundle(it)%grid,'gsibundle_fv3lam_phyvar_nouv',istatus, & + names3d=fv3lam_io_phymetvars3d_nouv) + end if + if (laeroana_fv3cmaq) then if (allocated(fv3lam_io_tracerchemvars3d_nouv) ) then call gsi_bundlecreate(gsibundle_fv3lam_tracerchem_nouv,GSI_ChemGuess_Bundle(it)%grid,'gsibundle_fv3lam_tracerchem_nouv',istatus, & @@ -1254,6 +1294,22 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) endif + if ( if_model_dbz )then + inner_vars=1 + numfields=inner_vars*(nphyvario3d*grd_a%nsig) + deallocate(lnames,names) + allocate(lnames(1,numfields),names(1,numfields)) + ilev=1 + do i=1,nphyvario3d + do k=1,grd_a%nsig + lnames(1,ilev)=k + names(1,ilev)=trim(fv3lam_io_phymetvars3d_nouv(i)) + ilev=ilev+1 + enddo + enddo + call general_sub2grid_create_info(grd_fv3lam_phyvar_ionouv,inner_vars,grd_a%nlat,& + grd_a%nlon,grd_a%nsig,numfields,regional,names=names,lnames=lnames) + end if inner_vars=2 numfields=grd_a%nsig @@ -1279,15 +1335,19 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'tv' ,ges_tv ,istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'q' ,ges_q ,istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'oz' ,ges_oz ,istatus );ier=ier+istatus - if (l_use_dbz_directDA) then + if (l_use_dbz_directDA .or. if_model_dbz) then call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'ql' ,ges_ql ,istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qi' ,ges_qi ,istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qr' ,ges_qr ,istatus );ier=ier+istatus - call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'iqr' ,ges_iqr ,istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qs' ,ges_qs ,istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qg' ,ges_qg ,istatus );ier=ier+istatus - call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qnr',ges_qnr ,istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'w' , ges_w ,istatus );ier=ier+istatus + if (l_use_dbz_directDA) then + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'iqr' ,ges_iqr ,istatus );ier=ier+istatus + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qnr',ges_qnr ,istatus );ier=ier+istatus + end if + if(if_model_dbz) & + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'dbz' , ges_dbz ,istatus );ier=ier+istatus end if if (ier/=0) call die(trim(myname),'cannot get pointers for fv3 met-fields, ier =',ier) @@ -1343,6 +1403,10 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) & ,fv3filenamegin(it)%dynvars,fv3filenamegin(it)) call gsi_fv3ncdf_read(grd_fv3lam_tracer_ionouv,gsibundle_fv3lam_tracer_nouv & & ,fv3filenamegin(it)%tracers,fv3filenamegin(it)) + if( if_model_dbz )then + call gsi_fv3ncdf_read(grd_fv3lam_phyvar_ionouv,gsibundle_fv3lam_phyvar_nouv & + & ,fv3filenamegin(it)%phyvars,fv3filenamegin(it)) + end if if (laeroana_fv3cmaq) then call gsi_fv3ncdf_read(grd_fv3lam_tracerchem_ionouv,gsibundle_fv3lam_tracerchem_nouv & & ,fv3filenamegin(it)%tracers,fv3filenamegin(it)) @@ -1439,6 +1503,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) call gsi_copy_bundle(gsibundle_fv3lam_tracersmoke_nouv,GSI_ChemGuess_Bundle(it)) endif + if(if_model_dbz) call gsi_copy_bundle(gsibundle_fv3lam_phyvar_nouv,GSI_MetGuess_Bundle(it)) call GSI_BundleGetPointer ( gsibundle_fv3lam_dynvar_nouv, 'tsen' ,ges_tsen_readin ,istatus );ier=ier+istatus !! tsen2tv !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! do k=1,nsig @@ -2151,13 +2216,15 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) character(len=max_varname_length) :: varname,vgsiname character(len=max_varname_length) :: name character(len=max_varname_length) :: filenamein2 - + real(r_kind),allocatable,dimension(:,:):: uu2d_tmp + integer(i_kind) :: countloc_tmp(3),startloc_tmp(3) integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(3),startloc(3) integer(i_kind) ilev,ilevtot,inative - integer(i_kind) kbgn,kend + integer(i_kind) kbgn,kend,len + logical :: phy_smaller_domain integer(i_kind) gfile_loc,iret,var_id - integer(i_kind) nz,nzp1,mm1 + integer(i_kind) nz,nzp1,mm1,nx_phy ! for io_layout > 1 real(r_kind),allocatable,dimension(:,:):: uu2d_layout integer(i_kind) :: nio @@ -2212,6 +2279,22 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) inative=nzp1-ilev startloc=(/1,1,inative/) countloc=(/nxcase,nycase,1/) + ! Variable ref_f3d in phy_data.nc has a smaller domain size than + ! dynvariables and tracers as well as a reversed order in vertical + if ( trim(adjustl(varname)) == 'ref_f3d' )then + iret=nf90_inquire_dimension(gfile_loc,1,name,len) + if(trim(name)=='xaxis_1') nx_phy=len + if( nx_phy == nxcase )then + allocate(uu2d_tmp(nxcase,nycase)) + countloc_tmp=(/nxcase,nycase,1/) + phy_smaller_domain = .false. + else + allocate(uu2d_tmp(nxcase-6,nycase-6)) + countloc_tmp=(/nxcase-6,nycase-6,1/) + phy_smaller_domain = .true. + end if + startloc_tmp=(/1,1,ilev/) + end if if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 @@ -2224,7 +2307,22 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) enddo else iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname)),var_id) - iret=nf90_get_var(gfile_loc,var_id,uu2d,start=startloc,count=countloc) + if ( trim(adjustl(varname)) == 'ref_f3d' )then + uu2d = 0.0_r_kind + iret=nf90_get_var(gfile_loc,var_id,uu2d_tmp,start=startloc_tmp,count=countloc_tmp) + where(uu2d_tmp < 0.0_r_kind) + uu2d_tmp = 0.0_r_kind + endwhere + + if( phy_smaller_domain )then + uu2d(4:nxcase-3,4:nycase-3) = uu2d_tmp + else + uu2d(1:nxcase,1:nycase) = uu2d_tmp + end if + deallocate(uu2d_tmp) + else + iret=nf90_get_var(gfile_loc,var_id,uu2d,start=startloc,count=countloc) + end if endif call fv3_h_to_ll(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) @@ -2642,6 +2740,395 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin) end subroutine gsi_fv3ncdf_readuv_v1 +subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & + delp,tsen,w,q,oz,ql,qr,qs,qi,qg,dbz,iope) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_fv3ncdf_read_ens_parallel_over_ens +! program history log: +! 2022-04-01 Y. Wang and X. Wang, changed from gsi_fv3ncdf_read_ens +! for FV3LAM ensemble parallel IO in hybrid EnVar +! poc: xuguang.wang@ou.edu +! +! abstract: read in fields excluding u and v +! program history log: +! +! input argument list: +! filenamein - file name to read from +! iope - pe to read in the field +! +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + + + use kinds, only: r_kind,i_kind + use mpimod, only: mpi_comm_world,mpi_rtype,mype + use mpimod, only: MPI_INFO_NULL + use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr + use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_inquire_variable + use netcdf, only: nf90_inq_varid + use gridmod, only: nsig,nlon,nlat + use mod_fv3_lola, only: fv3_h_to_ll + use gsi_bundlemod, only: gsi_bundle + 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 + real(r_kind),allocatable,dimension(:,:):: uu2d, uu2d_tmp + real(r_kind),allocatable,dimension(:):: wrk_send_2d + real(r_kind),dimension(nlat,nlon,nsig):: hwork + real(r_kind),dimension(nlat,nlon,nsig),intent(out),optional:: delp,tsen,w,q,oz,ql,qr,qs,qi,qg,dbz + character(len=max_varname_length) :: varname,vgsiname + character(len=max_varname_length) :: name + character(len=max_varname_length), allocatable,dimension(:) :: varname_files + + integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(3),startloc(3),countloc_tmp(3),startloc_tmp(3) + integer(i_kind) ilev,ilevtot,inative,ivar + integer(i_kind) kbgn,kend + integer(i_kind) gfile_loc,iret,var_id + integer(i_kind) nz,nzp1,mm1,len,nx_phy + logical :: phy_smaller_domain +! for io_layout > 1 + real(r_kind),allocatable,dimension(:,:):: uu2d_layout + integer(i_kind) :: nio + integer(i_kind),allocatable :: gfile_loc_layout(:) + character(len=180) :: filename_layout + + mm1=mype+1 + nloncase=nlon + nlatcase=nlat + nxcase=nx + nycase=ny + kbgn=1 + kend=nsig + + if( mype == iope )then + allocate(uu2d(nxcase,nycase)) + if( present(delp).or.present(tsen).or.present(w) )then ! dynvars + if( present(w) )then + allocate(varname_files(3)) + varname_files = (/'T ','delp','W '/) + else + allocate(varname_files(2)) + varname_files = (/'T ','delp'/) + end if + end if + if( present(q).or.present(ql).or.present(qr) )then ! tracers + if(present(qr))then + allocate(varname_files(7)) + varname_files = (/'sphum ','o3mr ','liq_wat','ice_wat','rainwat','snowwat','graupel'/) + else + allocate(varname_files(2)) + varname_files = (/'sphum',' o3mr'/) + end if + end if + if( present(dbz) )then ! phyvars: dbz + allocate(varname_files(1)) + varname_files = (/'ref_f3d'/) + end if + + if(fv3_io_layout_y > 1) then + allocate(gfile_loc_layout(0:fv3_io_layout_y-1)) + do nio=0,fv3_io_layout_y-1 + write(filename_layout,'(a,a,I4.4)') trim(filenamein),'.',nio + iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio),comm=mpi_comm_world,info=MPI_INFO_NULL) + if(iret/=nf90_noerr) then + write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filename_layout),gfile_loc_layout(nio),', Status = ',iret + call flush(6) + call stop2(333) + endif + enddo + else + iret=nf90_open(filenamein,nf90_nowrite,gfile_loc) + if(iret/=nf90_noerr) then + write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filenamein),gfile_loc,', Status = ',iret + call flush(6) + call stop2(333) + endif + endif + do ivar = 1, size(varname_files) + do ilevtot=kbgn,kend + ilev=ilevtot + nz=nsig + nzp1=nz+1 + inative=nzp1-ilev + startloc=(/1,1,inative/) + countloc=(/nxcase,nycase,1/) + varname = trim(varname_files(ivar)) + ! Variable ref_f3d in phy_data.nc has a smaller domain size than + ! dynvariables and tracers as well as a reversed order in vertical + if ( trim(adjustl(varname)) == 'ref_f3d' )then + iret=nf90_inquire_dimension(gfile_loc,1,name,len) + if(trim(name)=='xaxis_1') nx_phy=len + if( nx_phy == nxcase )then + allocate(uu2d_tmp(nxcase,nycase)) + countloc_tmp=(/nxcase,nycase,1/) + phy_smaller_domain = .false. + else + allocate(uu2d_tmp(nxcase-6,nycase-6)) + countloc_tmp=(/nxcase-6,nycase-6,1/) + phy_smaller_domain = .true. + end if + startloc_tmp=(/1,1,ilev/) + end if + + if(fv3_io_layout_y > 1) then + do nio=0,fv3_io_layout_y-1 + countloc=(/nxcase,ny_layout_len(nio),1/) + allocate(uu2d_layout(nxcase,ny_layout_len(nio))) + iret=nf90_inq_varid(gfile_loc_layout(nio),trim(adjustl(varname)),var_id) + iret=nf90_get_var(gfile_loc_layout(nio),var_id,uu2d_layout,start=startloc,count=countloc) + uu2d(:,ny_layout_b(nio):ny_layout_e(nio))=uu2d_layout + deallocate(uu2d_layout) + enddo + else + iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname)),var_id) + if ( trim(adjustl(varname)) == 'ref_f3d' )then + uu2d = 0.0_r_kind + iret=nf90_get_var(gfile_loc,var_id,uu2d_tmp,start=startloc_tmp,count=countloc_tmp) + where(uu2d_tmp < 0.0_r_kind) + uu2d_tmp = 0.0_r_kind + endwhere + if(phy_smaller_domain)then + uu2d(4:nxcase-3,4:nycase-3) = uu2d_tmp + else + uu2d = uu2d_tmp + end if + deallocate(uu2d_tmp) + else + iret=nf90_get_var(gfile_loc,var_id,uu2d,start=startloc,count=countloc) + end if + endif + call fv3_h_to_ll(uu2d,hwork(:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + enddo ! ilevtot + if( present(delp).or.present(tsen).or.present(w) )then ! dynvars + if(ivar == 1)then + tsen = hwork + else if(ivar == 2)then + delp = hwork + end if + if( present(w) .and. ivar == 3 )then + w = hwork + end if + end if + if( present(q).or.present(ql).or.present(qr) )then ! tracers + if(ivar == 1)then + q = hwork + else if(ivar == 2)then + oz = hwork + end if + if(present(qr))then + if(ivar == 3)then + ql = hwork + else if(ivar == 4)then + qi = hwork + else if(ivar == 5)then + qr = hwork + else if(ivar == 6)then + qs = hwork + else if(ivar == 7)then + qg = hwork + end if + end if + end if + if( present(dbz) )then ! phyvars: dbz + dbz = hwork + end if + + end do + + if(fv3_io_layout_y > 1) then + do nio=1,fv3_io_layout_y-1 + iret=nf90_close(gfile_loc_layout(nio)) + enddo + deallocate(gfile_loc_layout) + else + iret=nf90_close(gfile_loc) + endif + + deallocate (uu2d,varname_files) + end if + + return +end subroutine gsi_fv3ncdf_read_ens_parallel_over_ens + +subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens(ges_u,ges_v,fv3filenamegin,iope) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_fv3ncdf_readuv_ens_parallel_over_ens +! program history log: +! 2022-04-01 Y. Wang and X. Wang, changed from gsi_fv3ncdf_readuv_ens +! for FV3LAM ensemble parallel IO in hybrid EnVar +! poc: xuguang.wang@ou.edu +! +! abstract: read in a field from a netcdf FV3 file in mype_u,mype_v +! then scatter the field to each PE +! program history log: +! +! input argument list: +! +! output argument list: +! ges_u - output sub domain u field +! ges_v - output sub domain v field +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + use kinds, only: r_kind,i_kind + use mpimod, only: mpi_comm_world,mpi_rtype,mype,mpi_info_null + use gridmod, only: nsig,nlon,nlat + use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr + use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_inquire_variable + use netcdf, only: nf90_inq_varid + use mod_fv3_lola, only: fv3_h_to_ll,fv3uv2earth + use general_sub2grid_mod, only: sub2grid_info,general_grid2sub + + implicit none + 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 + real(r_kind),dimension(2,nlat,nlon,nsig):: hwork + character(:), allocatable:: filenamein + real(r_kind),allocatable,dimension(:,:):: u2d,v2d + real(r_kind),allocatable,dimension(:,:):: uc2d,vc2d + character(len=max_varname_length) :: varname,vgsiname + real(r_kind),allocatable,dimension(:,:,:,:):: worksub + integer(i_kind) u_grd_VarId,v_grd_VarId + integer(i_kind) nlatcase,nloncase + integer(i_kind) nxcase,nycase + integer(i_kind) u_countloc(3),u_startloc(3),v_countloc(3),v_startloc(3) + integer(i_kind) inative,ilev,ilevtot + integer(i_kind) kbgn,kend + + integer(i_kind) gfile_loc,iret + integer(i_kind) nz,nzp1,mm1 + +! for fv3_io_layout_y > 1 + real(r_kind),allocatable,dimension(:,:):: u2d_layout,v2d_layout + integer(i_kind) :: nio + integer(i_kind),allocatable :: gfile_loc_layout(:) + character(len=180) :: filename_layout + + mm1=mype+1 + nloncase=nlon + nlatcase=nlat + nxcase=nx + nycase=ny + kbgn=1 + kend=nsig + if( mype == iope )then + allocate(u2d(nxcase,nycase+1)) + allocate(v2d(nxcase+1,nycase)) + allocate(uc2d(nxcase,nycase)) + allocate(vc2d(nxcase,nycase)) + filenamein=fv3filenamegin%dynvars + + if(fv3_io_layout_y > 1) then + allocate(gfile_loc_layout(0:fv3_io_layout_y-1)) + do nio=0,fv3_io_layout_y-1 + write(filename_layout,'(a,a,I4.4)') trim(filenamein),".",nio + iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio),comm=mpi_comm_world,info=MPI_INFO_NULL) + if(iret/=nf90_noerr) then + write(6,*)'problem opening ',trim(filename_layout),gfile_loc_layout(nio),', Status = ',iret + call flush(6) + call stop2(333) + endif + enddo + else + iret=nf90_open(filenamein,nf90_nowrite,gfile_loc) + if(iret/=nf90_noerr) then + write(6,*)' problem opening ',trim(filenamein),', Status = ',iret + call flush(6) + call stop2(333) + endif + endif + do ilevtot=kbgn,kend + ilev=ilevtot + nz=nsig + nzp1=nz+1 + inative=nzp1-ilev + u_countloc=(/nxcase,nycase+1,1/) + v_countloc=(/nxcase+1,nycase,1/) + u_startloc=(/1,1,inative/) + v_startloc=(/1,1,inative/) + + if(fv3_io_layout_y > 1) then + do nio=0,fv3_io_layout_y-1 + u_countloc=(/nxcase,ny_layout_len(nio)+1,1/) + allocate(u2d_layout(nxcase,ny_layout_len(nio)+1)) + call check( nf90_inq_varid(gfile_loc_layout(nio),'u',u_grd_VarId) ) + iret=nf90_get_var(gfile_loc_layout(nio),u_grd_VarId,u2d_layout,start=u_startloc,count=u_countloc) + u2d(:,ny_layout_b(nio):ny_layout_e(nio))=u2d_layout(:,1:ny_layout_len(nio)) + if(nio==fv3_io_layout_y-1) u2d(:,ny_layout_e(nio)+1)=u2d_layout(:,ny_layout_len(nio)+1) + deallocate(u2d_layout) + + v_countloc=(/nxcase+1,ny_layout_len(nio),1/) + allocate(v2d_layout(nxcase+1,ny_layout_len(nio))) + call check( nf90_inq_varid(gfile_loc_layout(nio),'v',v_grd_VarId) ) + iret=nf90_get_var(gfile_loc_layout(nio),v_grd_VarId,v2d_layout,start=v_startloc,count=v_countloc) + v2d(:,ny_layout_b(nio):ny_layout_e(nio))=v2d_layout + deallocate(v2d_layout) + enddo + else + call check( nf90_inq_varid(gfile_loc,'u',u_grd_VarId) ) + iret=nf90_get_var(gfile_loc,u_grd_VarId,u2d,start=u_startloc,count=u_countloc) + call check( nf90_inq_varid(gfile_loc,'v',v_grd_VarId) ) + iret=nf90_get_var(gfile_loc,v_grd_VarId,v2d,start=v_startloc,count=v_countloc) + endif + + if(.not.grid_reverse_flag) then + call reverse_grid_r_uv (u2d,nxcase,nycase+1,1) + call reverse_grid_r_uv (v2d,nxcase+1,nycase,1) + endif + call fv3uv2earth(u2d(:,:),v2d(:,:),nxcase,nycase,uc2d,vc2d) + + ! NOTE on transfor to earth u/v: + ! The u and v before transferring need to be in E-W/N-S grid, which is + ! defined as reversed grid here because it is revered from map view. + ! + ! Have set the following flag for grid orientation + ! grid_reverse_flag=true: E-W/N-S grid + ! grid_reverse_flag=false: W-E/S-N grid + ! + ! So for preparing the wind transferring, need to reverse the grid + ! from + ! W-E/S-N grid to E-W/N-S grid when grid_reverse_flag=false: + ! + ! if(.not.grid_reverse_flag) call reverse_grid_r_uv + ! + ! and the last input parameter for fv3_h_to_ll is alway true: + ! + ! + call fv3_h_to_ll(uc2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) + call fv3_h_to_ll(vc2d,hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) + enddo ! ilevtot + if(fv3_io_layout_y > 1) then + do nio=0,fv3_io_layout_y-1 + iret=nf90_close(gfile_loc_layout(nio)) + enddo + deallocate(gfile_loc_layout) + else + iret=nf90_close(gfile_loc) + endif + deallocate(u2d,v2d,uc2d,vc2d) + ges_u = hwork(1,:,:,:) + ges_v = hwork(2,:,:,:) + end if ! mype + +end subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens + + subroutine wrfv3_netcdf(fv3filenamegin) !$$$ subprogram documentation block ! . . . . @@ -2653,7 +3140,8 @@ subroutine wrfv3_netcdf(fv3filenamegin) ! program history log: ! 2019-04-18 CAPS(C. Tong) - import direct reflectivity DA capabilities ! 2019-11-22 CAPS(C. Tong) - modify "add_saved" to properly output analyses -! 2021-01-05 x.zhang/lei - add code for updating delz analysis in regional da +! 2021-01-05 x.zhang/lei - add code for updating delz analysis in regional da +! 2022-04-01 Y. Wang and X. Wang - add code for updating reflectivity ! ! input argument list: ! @@ -2680,6 +3168,7 @@ subroutine wrfv3_netcdf(fv3filenamegin) use directDA_radaruse_mod, only: l_cvpnr, cvpnr_pval use gridmod, only: eta1_ll,eta2_ll use constants, only: one + use obsmod, only: if_model_dbz implicit none @@ -2705,6 +3194,7 @@ subroutine wrfv3_netcdf(fv3filenamegin) real(r_kind),pointer,dimension(:,:,:):: ges_qg =>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_qnr =>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_w =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_dbz =>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_delzinc =>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_delp =>NULL() real(r_kind),dimension(:,: ),allocatable:: ges_ps_write @@ -2794,14 +3284,17 @@ subroutine wrfv3_netcdf(fv3filenamegin) call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'u' , ges_u ,istatus);ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'v' , ges_v ,istatus);ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'q' ,ges_q ,istatus);ier=ier+istatus - if (l_use_dbz_directDA) then + if (l_use_dbz_directDA .or. if_model_dbz) then call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'ql' ,ges_ql ,istatus);ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qi' ,ges_qi ,istatus);ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qr' ,ges_qr ,istatus);ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qs' ,ges_qs ,istatus);ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qg' ,ges_qg ,istatus);ier=ier+istatus + if (l_use_dbz_directDA) & call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qnr',ges_qnr,istatus);ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'w' , ges_w ,istatus);ier=ier+istatus + if( if_model_dbz )& + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'dbz' , ges_dbz ,istatus);ier=ier+istatus end if if(i_use_2mq4b > 0 .and. i_use_2mt4b > 0 ) then call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'q2m',ges_q2m,istatus); ier=ier+istatus @@ -2931,6 +3424,7 @@ subroutine wrfv3_netcdf(fv3filenamegin) call gsi_copy_bundle(GSI_MetGuess_Bundle(it),gsibundle_fv3lam_dynvar_nouv) call gsi_copy_bundle(GSI_MetGuess_Bundle(it),gsibundle_fv3lam_tracer_nouv) + if( if_model_dbz ) call gsi_copy_bundle(GSI_MetGuess_Bundle(it),gsibundle_fv3lam_phyvar_nouv) if (laeroana_fv3cmaq) then call gsi_copy_bundle(GSI_ChemGuess_Bundle(it),gsibundle_fv3lam_tracerchem_nouv) end if @@ -2979,6 +3473,10 @@ subroutine wrfv3_netcdf(fv3filenamegin) add_saved,fv3filenamegin%dynvars,fv3filenamegin) call gsi_fv3ncdf_write(grd_fv3lam_tracer_ionouv,gsibundle_fv3lam_tracer_nouv, & add_saved,fv3filenamegin%tracers,fv3filenamegin) + if( if_model_dbz ) then + call gsi_fv3ncdf_write(grd_fv3lam_phyvar_ionouv,gsibundle_fv3lam_phyvar_nouv,& + add_saved,fv3filenamegin%phyvars,fv3filenamegin) + end if call gsi_fv3ncdf_writeuv(grd_fv3lam_uv,ges_u,ges_v,add_saved,fv3filenamegin) if (laeroana_fv3cmaq) then call gsi_fv3ncdf_write(grd_fv3lam_tracerchem_ionouv,gsibundle_fv3lam_tracerchem_nouv, & @@ -3598,6 +4096,7 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file use netcdf, only: nf90_open,nf90_close use netcdf, only: nf90_write,nf90_inq_varid use netcdf, only: nf90_put_var,nf90_get_var + use netcdf, only: nf90_inquire_dimension use gsi_bundlemod, only: gsi_bundle use general_sub2grid_mod, only: sub2grid_info,general_sub2grid implicit none @@ -3609,16 +4108,19 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file 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_varname_length) :: filenamein2 - character(len=max_varname_length) :: varname,vgsiname + character(len=max_varname_length) :: varname,vgsiname,name integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(3),startloc(3) + integer(i_kind) countloc_tmp(3),startloc_tmp(3) integer(i_kind) kbgn,kend integer(i_kind) inative,ilev,ilevtot integer(i_kind) :: VarId,gfile_loc - integer(i_kind) mm1,nzp1 + integer(i_kind) mm1,nzp1,len,nx_phy,iret + logical :: phy_smaller_domain real(r_kind),allocatable,dimension(:,:):: work_a real(r_kind),allocatable,dimension(:,:):: work_b real(r_kind),allocatable,dimension(:,:):: workb2,worka2 + real(r_kind),allocatable,dimension(:,:):: work_b_tmp ! for io_layout > 1 real(r_kind),allocatable,dimension(:,:):: work_b_layout @@ -3673,7 +4175,20 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file work_a=hwork(1,:,:,ilevtot) - + if( trim(varname) == 'ref_f3d' )then + iret=nf90_inquire_dimension(gfile_loc,1,name,len) + if(trim(name)=='xaxis_1') nx_phy=len + if( nx_phy == nxcase )then + allocate(work_b_tmp(nxcase,nycase)) + countloc_tmp=(/nxcase,nycase,1/) + phy_smaller_domain = .false. + else + allocate(work_b_tmp(nxcase-6,nycase-6)) + countloc_tmp=(/nxcase-6,nycase-6,1/) + phy_smaller_domain = .true. + end if + startloc_tmp=(/1,1,ilev/) + end if call check( nf90_inq_varid(gfile_loc,trim(varname),VarId) ) @@ -3703,16 +4218,29 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file deallocate(work_b_layout) enddo else - call check( nf90_get_var(gfile_loc,VarId,work_b,start = startloc, count = countloc) ) + if( trim(varname) == 'ref_f3d' )then + work_b = 0.0_r_kind + call check( nf90_get_var(gfile_loc,VarId,work_b_tmp,start = startloc_tmp, count = countloc_tmp) ) + where(work_b_tmp < 0.0_r_kind) + work_b_tmp = 0.0_r_kind + end where + if(phy_smaller_domain)then + work_b(4:nxcase-3,4:nycase-3) = work_b_tmp + else + work_b(1:nxcase,1:nycase) = work_b_tmp + end if + else + call check( nf90_get_var(gfile_loc,VarId,work_b,start = startloc, count = countloc) ) + end if endif call fv3_h_to_ll(work_b(:,:),worka2,nlon_regional,nlat_regional,nloncase,nlatcase,grid_reverse_flag) !!!!!!!! analysis_inc: work_a !!!!!!!!!!!!!!!! work_a(:,:)=work_a(:,:)-worka2(:,:) call fv3_ll_to_h(work_a(:,:),workb2,nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag) work_b(:,:)=work_b(:,:)+workb2(:,:) - else + else call fv3_ll_to_h(work_a(:,:),work_b(:,:),nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag) - endif + endif endif if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 @@ -3723,7 +4251,20 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file deallocate(work_b_layout) enddo else - call check( nf90_put_var(gfile_loc,VarId,work_b, start = startloc, count = countloc) ) + if( trim(varname) == 'ref_f3d' )then + if(phy_smaller_domain)then + work_b_tmp = work_b(4:nxcase-3,4:nycase-3) + else + work_b_tmp = work_b(1:nxcase,1:nycase) + end if + where(work_b_tmp < 0.0_r_kind) + work_b_tmp = 0.0_r_kind + end where + call check( nf90_put_var(gfile_loc,VarId,work_b_tmp, start = startloc_tmp, count = countloc_tmp) ) + deallocate(work_b_tmp) + else + call check( nf90_put_var(gfile_loc,VarId,work_b, start = startloc, count = countloc) ) + end if endif enddo !ilevtotl loop @@ -4443,6 +4984,8 @@ subroutine getfv3lamfilevname(vgsinamein,fv3filenamegref,filenameout,vname) filenameout=fv3filenamegref%dynvars else if(ifindstrloc(vartracers,vgsinamein)> 0 ) then filenameout=fv3filenamegref%tracers + else if(ifindstrloc(varphyvars,vgsinamein)> 0) then + filenameout=fv3filenamegref%phyvars else write(6,*)'the filename corresponding to var ',trim(vgsinamein),' is not found, stop ' call stop2(333) diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index 55d9298614..8ccef7c38e 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -151,7 +151,9 @@ module gsimod readin_beta,use_localization_grid,use_gfs_ens,q_hyb_ens,i_en_perts_io, & l_ens_in_diff_time,ensemble_path,ens_fast_read,sst_staticB,limqens, & ntotensgrp,nsclgrp,naensgrp,ngvarloc,ntlevs_ens,naensloc, & - i_ensloccov4tim,i_ensloccov4var,i_ensloccov4scl,l_timloc_opt + i_ensloccov4tim,i_ensloccov4var,i_ensloccov4scl,l_timloc_opt,& + vdl_scale,vloc_varlist,& + global_spectral_filter_sd,assign_vdl_nml,parallelization_over_ensmembers use hybrid_ensemble_parameters,only : l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar use rapidrefresh_cldsurf_mod, only: init_rapidrefresh_cldsurf, & dfi_radar_latent_heat_time_period,metar_impact_radius,& @@ -1375,6 +1377,36 @@ module gsimod ! i_ensloccov4scl - flag of cross-scale localization ! =0: cross-scale covariance is retained ! =1: cross-scale covariance is zero +! +! global_spectral_filter_sd - if true, use spectral filter function for +! scale decomposition in the global application (Huang et al. 2021) +! assign_vdl_nml - if true, vdl_scale, and vloc_varlist will be used for +! assigning variable-dependent localization upon SDL in gsiparm.anl. +! This method described in (Wang and Wang 2022, JAMES) is +! equivalent to, but different from the method associated +! with the parameter i_ensloccov4var. +! vloc_varlist - list of control variables using the same localization length, +! effective only with assign_vdl_nml=.true. For example, +! vloc_varlist(1,:) = 'sf','vp','ps','t', +! vloc_varlist(2,:) = 'q', +! vloc_varlist(3,:) = 'qr','qs','qg','dbz','w','ql','qi', +! vloc_varlist(4,:) = 'sf','vp','ps','t','q', +! vloc_varlist(5,:) = 'qr','qs','qg','dbz','w','ql','qi', +! This example indicates that 3 variable-groups will be adopted for VDL. +! 'sf','vp','ps','t' will share the same localization length of v1L1; +! 'q' will have the localization lenth of v2L1 +! 'qr','qs','qg','dbz','w','ql','qi', use the same localization length of v3L1 +! +! For L2, a different configuration of VDL can be applied: +! ~~~~~~~~~ +! 'sf','vp','ps','t','q' will share the same localization length of v2L2; +! 'qr','qs','qg','dbz','w','ql','qi', use the same localization length of v2L2 +! vdl_scale - number of variables in each variable-group, effective only with assign_vdl_nml=.true. +! if 3 variable-groups with 2 separated scale is set, +! vdl_scale = 3, 3, 3, 2, 2 +! ^ ^ ^ ^ ^ +! s_ens_h = v1L1 v2L1 v3L1 v1L2 v2L2 +! Then localization lengths will be assigned as above. ! namelist/hybrid_ensemble/l_hyb_ens,uv_hyb_ens,q_hyb_ens,aniso_a_en,generate_ens,n_ens,l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar,nlon_ens,nlat_ens,jcap_ens,& pseudo_hybens,merge_two_grid_ensperts,regional_ensemble_option,fv3sar_bg_opt,fv3sar_ensemble_opt,full_ensemble,pwgtflg,& @@ -1382,7 +1414,9 @@ module gsimod grid_ratio_ens, & oz_univ_static,write_ens_sprd,use_localization_grid,use_gfs_ens, & i_en_perts_io,l_ens_in_diff_time,ensemble_path,ens_fast_read,sst_staticB,limqens, & - nsclgrp,l_timloc_opt,ngvarloc,naensloc,i_ensloccov4tim,i_ensloccov4var,i_ensloccov4scl + nsclgrp,l_timloc_opt,ngvarloc,naensloc,i_ensloccov4tim,i_ensloccov4var,i_ensloccov4scl,& + vdl_scale,vloc_varlist,& + global_spectral_filter_sd,assign_vdl_nml,parallelization_over_ensmembers ! rapidrefresh_cldsurf (options for cloud analysis and surface ! enhancement for RR appilcation ): @@ -1839,7 +1873,9 @@ subroutine gsimain_initialize else naensgrp=ntotensgrp endif - if(naensloc 1)then + allocate(spc_multwgt(0:jcap_ens,nsclgrp)) + allocate(spcwgt_params(4,nsclgrp)) + spc_multwgt=1.0 + + ! The below parameters are used in Huang et al. (2021, MWR) + spcwgt_params(1,1)=4000.0_r_kind + spcwgt_params(2,1)=100000000.0_r_kind + spcwgt_params(3,1)=1.0_r_kind + spcwgt_params(4,1)=3000.0_r_kind + + if( nsclgrp >=3 )then + spcwgt_params(1,3)=0.0_r_kind + spcwgt_params(2,3)=500.0_r_kind + spcwgt_params(3,3)=1.0_r_kind + spcwgt_params(4,3)=500.0_r_kind + end if + + call init_mult_spc_wgts(jcap_ens) + + end if + return end subroutine hybens_grid_setup @@ -4148,6 +4171,8 @@ subroutine hybens_localization_setup ! 2012-10-16 wu - only call setup_ens_wgt if necessary ! 2014-05-22 wu modification to allow vertically varying localization scales in regional ! 2022-09-15 yokota - add scale/variable/time-dependent localization +! 2022-12-09 Y. Wang and X. Wang - add a variable-dependent localization option (assign_vdl_nml=.true.), +! poc: xuguang.wang@ou.edu ! ! input argument list: ! @@ -4168,9 +4193,11 @@ subroutine hybens_localization_setup use hybrid_ensemble_parameters, only: readin_beta,beta_s,beta_e,beta_s0,beta_e0,sqrt_beta_s,sqrt_beta_e use hybrid_ensemble_parameters, only: readin_localization,create_hybens_localization_parameters, & vvlocal,s_ens_h,s_ens_hv,s_ens_v,s_ens_vv - use hybrid_ensemble_parameters, only: ntotensgrp,naensgrp,naensloc,ntlevs_ens,nsclgrp - use hybrid_ensemble_parameters, only: en_perts + use hybrid_ensemble_parameters, only: ntotensgrp,naensgrp,naensloc,ntlevs_ens,nsclgrp,assign_vdl_nml + use hybrid_ensemble_parameters, only: en_perts,vdl_scale,vloc_varlist,global_spectral_filter_sd + use hybrid_ensemble_parameters, only: ngvarloc use gsi_io, only: verbose + use string_utility, only: StrLowCase implicit none @@ -4183,8 +4210,11 @@ 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_grid) :: grid_ens real(r_kind), pointer :: values(:) => NULL() + integer(i_kind) :: iscl, iv, smooth_scales_num character(len=*),parameter::myname_=myname//'*hybens_localization_setup' l_read_success=.false. @@ -4312,7 +4342,7 @@ subroutine hybens_localization_setup call init_sf_xy(jcap_ens) endif - if(ntotensgrp>1) then + if(ntotensgrp>1 .and. (.not. global_spectral_filter_sd)) then call gsi_bundlegetpointer(en_perts(1,1,1),cvars3d,ipc3d,istatus) if(istatus/=0) then write(6,*) myname_,': cannot find 3d pointers' @@ -4326,64 +4356,159 @@ subroutine hybens_localization_setup if(nsclgrp>1) then call gsi_gridcreate(grid_ens,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig) allocate(values(grd_ens%latlon11*grd_ens%nsig*n_ens)) - do ig=1,nsclgrp-1 - ii=0 - do n=1,n_ens - a_en(n)%values => values(ii+1:ii+grd_ens%latlon11*grd_ens%nsig) - call gsi_bundleset(a_en(n),grid_ens,'Ensemble Bundle',istatus,names3d=(/'a_en'/),bundle_kind=r_kind) - if (istatus/=0) then - write(6,*) myname_,': error alloc(ensemble bundle)' - call stop2(999) - endif - ii=ii+grd_ens%latlon11*grd_ens%nsig - enddo - do m=1,ntlevs_ens + if( .not. assign_vdl_nml )then + do ig=1,nsclgrp-1 + ii=0 do n=1,n_ens - en_perts(n,ig+1,m)%valuesr4=en_perts(n,ig,m)%valuesr4 + a_en(n)%values => values(ii+1:ii+grd_ens%latlon11*grd_ens%nsig) + call gsi_bundleset(a_en(n),grid_ens,'Ensemble Bundle',istatus,names3d=(/'a_en'/),bundle_kind=r_kind) + if (istatus/=0) then + write(6,*) myname_,': error alloc(ensemble bundle)' + call stop2(999) + endif + ii=ii+grd_ens%latlon11*grd_ens%nsig enddo - do ic3=1,nc3d - ipic=ipc3d(ic3) + do m=1,ntlevs_ens do n=1,n_ens - do k=1,grd_ens%nsig - a_en(n)%r3(1)%q(:,:,k)=en_perts(n,ig,m)%r3(ipic)%qr4(:,:,k) + en_perts(n,ig+1,m)%valuesr4=en_perts(n,ig,m)%valuesr4 + enddo + do ic3=1,nc3d + ipic=ipc3d(ic3) + do n=1,n_ens + do k=1,grd_ens%nsig + a_en(n)%r3(1)%q(:,:,k)=en_perts(n,ig,m)%r3(ipic)%qr4(:,:,k) + enddo + enddo + call bkgcov_a_en_new_factorization(naensgrp+ig,a_en) + do n=1,n_ens + do k=1,grd_ens%nsig + en_perts(n,ig,m)%r3(ipic)%qr4(:,:,k)=a_en(n)%r3(1)%q(:,:,k) + enddo enddo enddo - call bkgcov_a_en_new_factorization(naensgrp+ig,a_en) - do n=1,n_ens - do k=1,grd_ens%nsig - en_perts(n,ig,m)%r3(ipic)%qr4(:,:,k)=a_en(n)%r3(1)%q(:,:,k) + do ic2=1,nc2d + ipic=ipc2d(ic2) + do n=1,n_ens + do k=1,grd_ens%nsig + a_en(n)%r3(1)%q(:,:,k)=en_perts(n,ig,m)%r2(ipic)%qr4(:,:) + enddo + enddo + call bkgcov_a_en_new_factorization(naensgrp+ig,a_en) + do n=1,n_ens + en_perts(n,ig,m)%r2(ipic)%qr4(:,:)=a_en(n)%r3(1)%q(:,:,1) enddo enddo - enddo - do ic2=1,nc2d - ipic=ipc2d(ic2) do n=1,n_ens - do k=1,grd_ens%nsig - a_en(n)%r3(1)%q(:,:,k)=en_perts(n,ig,m)%r2(ipic)%qr4(:,:) + en_perts(n,ig+1,m)%valuesr4=en_perts(n,ig+1,m)%valuesr4-en_perts(n,ig,m)%valuesr4 + enddo + enddo + do n=1,n_ens + call gsi_bundleunset(a_en(n),istatus) + enddo + enddo + else ! assign_vdl_nml + smooth_scales_num = naensloc - naensgrp + ngvarloc = 1 ! forced to 1 in this option + 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) + call gsi_bundlecreate(en_pertstmp1(n,m),grid_ens,'ensemble1',istatus,names2d=cvars2d,names3d=cvars3d,bundle_kind=r_single) + end do + end do + ig = 1 + do iscl=1,smooth_scales_num + 1 + ii=0 + do n=1,n_ens + a_en(n)%values => values(ii+1:ii+grd_ens%latlon11*grd_ens%nsig) + call gsi_bundleset(a_en(n),grid_ens,'Ensemble Bundle',istatus,names3d=(/'a_en'/),bundle_kind=r_kind) + if (istatus/=0) then + write(6,*) myname_,': error alloc(ensemble bundle)' + call stop2(999) + endif + ii=ii+grd_ens%latlon11*grd_ens%nsig + enddo + + do m=1,ntlevs_ens + if( ig == 1 )then + do n=1,n_ens + en_pertstmp(n,m)%valuesr4=en_perts(n,ig,m)%valuesr4 + enddo + end if + do ic3=1,nc3d + ipic=ipc3d(ic3) + do n=1,n_ens + do k=1,grd_ens%nsig + a_en(n)%r3(1)%q(:,:,k)=en_pertstmp(n,m)%r3(ipic)%qr4(:,:,k) + enddo + enddo + if(iscl <= smooth_scales_num) call bkgcov_a_en_new_factorization(naensgrp+iscl,a_en) + do n=1,n_ens + do k=1,grd_ens%nsig + en_pertstmp1(n,m)%r3(ipic)%qr4(:,:,k)=a_en(n)%r3(1)%q(:,:,k) + if( vdl_scale(ig) == 0 )then + en_perts(n,ig,m)%r3(ipic)%qr4(:,:,k)=a_en(n)%r3(1)%q(:,:,k) + else ! VDL is activated + do iv = 1, vdl_scale(ig) + en_perts(n,ig+iv-1,m)%r3(ipic)%qr4(:,:,k)=0.0_r_single + if( any( trim(StrLowCase(cvars3d(ic3))) == vloc_varlist(ig+iv-1,:) ) ) then + en_perts(n,ig+iv-1,m)%r3(ipic)%qr4(:,:,k)=a_en(n)%r3(1)%q(:,:,k) + end if + end do + end if + enddo + enddo + enddo + do ic2=1,nc2d + ipic=ipc2d(ic2) + do n=1,n_ens + do k=1,grd_ens%nsig + a_en(n)%r3(1)%q(:,:,k)=en_pertstmp(n,m)%r2(ipic)%qr4(:,:) + enddo + enddo + if(iscl <= smooth_scales_num) call bkgcov_a_en_new_factorization(naensgrp+iscl,a_en) + do n=1,n_ens + en_pertstmp1(n,m)%r2(ipic)%qr4(:,:)=a_en(n)%r3(1)%q(:,:,1) + if( vdl_scale(ig) == 0 )then + en_perts(n,ig,m)%r2(ipic)%qr4(:,:)=a_en(n)%r3(1)%q(:,:,1) + else ! VDL is activated + do iv = 1, vdl_scale(ig) + en_perts(n,ig+iv-1,m)%r2(ipic)%qr4(:,:)=0.0_r_single + if( any( trim(StrLowCase(cvars2d(ic2))) == vloc_varlist(ig+iv-1,:) ) ) then + en_perts(n,ig+iv-1,m)%r2(ipic)%qr4(:,:)=a_en(n)%r3(1)%q(:,:,1) + end if + end do + end if enddo enddo - call bkgcov_a_en_new_factorization(naensgrp+ig,a_en) do n=1,n_ens - en_perts(n,ig,m)%r2(ipic)%qr4(:,:)=a_en(n)%r3(1)%q(:,:,1) + en_pertstmp(n,m)%valuesr4=en_pertstmp(n,m)%valuesr4-en_pertstmp1(n,m)%valuesr4 enddo enddo do n=1,n_ens - en_perts(n,ig+1,m)%valuesr4=en_perts(n,ig+1,m)%valuesr4-en_perts(n,ig,m)%valuesr4 + call gsi_bundleunset(a_en(n),istatus) enddo + if( vdl_scale(ig) == 0 )then + ig = ig + 1 + else + ig = ig + vdl_scale(ig) + end if enddo do n=1,n_ens - call gsi_bundleunset(a_en(n),istatus) - enddo - enddo - deallocate(values) - endif - do ig=nsclgrp+1,ntotensgrp - do m=1,ntlevs_ens - do n=1,n_ens - en_perts(n,ig,m)%valuesr4=en_perts(n,ig-nsclgrp,m)%valuesr4 - enddo - enddo - enddo + do m=1,ntlevs_ens + call gsi_bundledestroy(en_pertstmp(n,m),istatus) + call gsi_bundledestroy(en_pertstmp1(n,m),istatus) + end do + end do + end if + deallocate(values) + endif + do ig=nsclgrp+1,ntotensgrp + do m=1,ntlevs_ens + do n=1,n_ens + en_perts(n,ig,m)%valuesr4=en_perts(n,ig-nsclgrp,m)%valuesr4 + enddo + enddo + enddo endif !!!!!!!! setup beta_s, beta_e!!!!!!!!!!!! diff --git a/src/gsi/hybrid_ensemble_parameters.f90 b/src/gsi/hybrid_ensemble_parameters.f90 index 7b1c963764..17416f68fb 100644 --- a/src/gsi/hybrid_ensemble_parameters.f90 +++ b/src/gsi/hybrid_ensemble_parameters.f90 @@ -128,6 +128,7 @@ module hybrid_ensemble_parameters ! function of z, default = .false. ! ensemble_path: path to ensemble members; default './' ! ens_fast_read: read ensemble in parallel; default '.false.' +! parallelization_over_ensmembers: parallelly read ensemble members for FV3-LAM; default '.false' ! sst_staticB: if .true. (default) uses only static part of B error covariance for SST ! nsclgrp: number of scale-dependent localization lengths ! l_timloc_opt: if true, then turn on time-dependent localization @@ -327,10 +328,17 @@ module hybrid_ensemble_parameters public :: i_ensloccov4tim,i_ensloccov4var,i_ensloccov4scl public :: idaen3d,idaen2d public :: ens_fast_read + public :: parallelization_over_ensmembers public :: l_both_fv3sar_gfs_ens public :: sst_staticB public :: limqens + public :: spc_multwgt + public :: spcwgt_params + public :: vdl_scale,vloc_varlist + public :: global_spectral_filter_sd + public :: assign_vdl_nml + logical l_hyb_ens,uv_hyb_ens,q_hyb_ens,oz_univ_static,sst_staticB logical l_timloc_opt logical aniso_a_en @@ -348,6 +356,7 @@ module hybrid_ensemble_parameters logical vvlocal logical l_ens_in_diff_time logical ens_fast_read + logical parallelization_over_ensmembers logical l_both_fv3sar_gfs_ens integer(i_kind) i_en_perts_io integer(i_kind) n_ens,nlon_ens,nlat_ens,jcap_ens,jcap_ens_test @@ -389,6 +398,13 @@ module hybrid_ensemble_parameters integer(i_kind) :: i_ensloccov4scl=0 integer(i_kind),allocatable,dimension(:) :: idaen3d,idaen2d + real(r_kind),allocatable,dimension(:,:) :: spc_multwgt + real(r_kind),allocatable,dimension(:,:) :: spcwgt_params + character(len=3) vloc_varlist(max_naensloc,max_nvars) + integer(i_kind) vdl_scale(max_naensloc) + logical :: global_spectral_filter_sd + logical :: assign_vdl_nml + ! following is for storage of ensemble perturbations: ! def en_perts - array of ensemble perturbations @@ -476,10 +492,15 @@ subroutine init_hybrid_ensemble_parameters i_en_perts_io=0 ! default for en_pert IO. 0 is no IO ensemble_path = './' ! default for path to ensemble members ens_fast_read=.false. + parallelization_over_ensmembers=.false. limqens=1.0_r_single ! default for limiting ensemble RH (+/-) l_both_fv3sar_gfs_ens=.false. n_ens_gfs=0 n_ens_fv3sar=0 + vdl_scale = 0 + vloc_varlist = 'aaa' + global_spectral_filter_sd=.false. + assign_vdl_nml=.false. end subroutine init_hybrid_ensemble_parameters diff --git a/src/gsi/obsmod.F90 b/src/gsi/obsmod.F90 index 1fb03d0940..3dd936d94e 100644 --- a/src/gsi/obsmod.F90 +++ b/src/gsi/obsmod.F90 @@ -747,7 +747,7 @@ subroutine init_obsmod_dflts if_vterminal=.false. l2rwthin =.false. if_vrobs_raw=.false. - if_model_dbz=.true. + if_model_dbz=.false. inflate_obserr=.false. whichradar="KKKK" diff --git a/src/gsi/read_dbz_nc.f90 b/src/gsi/read_dbz_nc.f90 index 89eebde8b6..ee1d3cb2e4 100644 --- a/src/gsi/read_dbz_nc.f90 +++ b/src/gsi/read_dbz_nc.f90 @@ -71,7 +71,7 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no one_tenth,r1000,r60,r60inv,r100,r400,grav_equator, & eccentricity,somigliana,grav_ratio,grav,semi_major_axis,flattening use gridmod, only: tll2xy,nsig,nlat,nlon - use obsmod, only: iadate,doradaroneob, & + use obsmod, only: iadate,doradaroneob,oneoblat,oneoblon,oneobheight,oneobradid, & mintiltdbz,maxtiltdbz,minobrangedbz,maxobrangedbz,& static_gsi_nopcp_dbz,rmesh_dbz,zmesh_dbz use hybrid_ensemble_parameters,only : l_hyb_ens @@ -380,6 +380,12 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no thislon = lon(i,j) thislat = lat(i,j) + + if(doradaroneob) then + thislat=oneoblat + thislon=oneoblon + thishgt=oneobheight + endif !-Check format of longitude and correct if necessary diff --git a/src/gsi/setupdbz.f90 b/src/gsi/setupdbz.f90 index 9bbf5ed34b..1e158de9ea 100644 --- a/src/gsi/setupdbz.f90 +++ b/src/gsi/setupdbz.f90 @@ -1451,31 +1451,37 @@ subroutine setupdbz(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,radardbz_d ! Write information to diagnostic file if(radardbz_diagsave .and. ii>0 )then - write(string,600) jiter -600 format('radardbz_',i2.2) - diag_file=trim(dirname) // trim(string) - if(init_pass) then - open(newunit=lu_diag,file=trim(diag_file),form='unformatted',status='unknown',position='rewind') + if( .not. l_use_dbz_directDA )then + write(7)'dbz',nchar,nreal,ii,mype,ioff0 + write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) else - inquire(file=trim(diag_file),exist=diagexist) - if (diagexist) then - open(lu_diag,file=trim(diag_file),form='unformatted',status='old',position='append') + write(string,600) jiter +600 format('radardbz_',i2.2) + diag_file=trim(dirname) // trim(string) + if(init_pass) then + open(newunit=lu_diag,file=trim(diag_file),form='unformatted',status='unknown',position='rewind') else - open(lu_diag,file=trim(diag_file),form='unformatted',status='unknown',position='rewind') + inquire(file=trim(diag_file),exist=diagexist) + if (diagexist) then + open(lu_diag,file=trim(diag_file),form='unformatted',status='old',position='append') + else + open(lu_diag,file=trim(diag_file),form='unformatted',status='unknown',position='rewind') + endif + endif + if(init_pass .and. mype == 0) then + if ( .not. l_use_dbz_directDA ) then ! EnKF uses these diagnostics and EnKF uses single OBS file for now. + write(lu_diag) ianldate ! So do not write analysis date for binary in case of using direct reflectivity DA. + end if + write(6,*)'SETUPDBZ: write time record to file ',& + trim(diag_file), ' ',ianldate endif - endif - if(init_pass .and. mype == 0) then - if ( .not. l_use_dbz_directDA ) then ! EnKF uses these diagnostics and EnKF uses single OBS file for now. - write(lu_diag) ianldate ! So do not write analysis date for binary in case of using direct reflectivity DA. - end if - write(6,*)'SETUPDBZ: write time record to file ',& - trim(diag_file), ' ',ianldate - endif - write(lu_diag)'dbz',nchar,nreal,ii,mype,ioff0 - write(lu_diag)cdiagbuf(1:ii),rdiagbuf(:,1:ii) - deallocate(cdiagbuf,rdiagbuf) - close(lu_diag) + write(lu_diag)'dbz',nchar,nreal,ii,mype,ioff0 + write(lu_diag)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + deallocate(cdiagbuf,rdiagbuf) + close(lu_diag) + end if end if write(6,*)'mype, irefsmlobs,irejrefsmlobs are ',mype,' ',irefsmlobs, ' ',irejrefsmlobs ! close(52) !simulated obs diff --git a/src/gsi/update_guess.f90 b/src/gsi/update_guess.f90 index a90e7a19d6..e5a0f64245 100644 --- a/src/gsi/update_guess.f90 +++ b/src/gsi/update_guess.f90 @@ -287,7 +287,11 @@ subroutine update_guess(sval,sbias) ! since we don't know which comes first in met-guess, we ! must postpone updating tv after all other met-guess fields endif - icloud=getindex(cloud,guess(ic)) + if( allocated(cloud) )then + icloud=getindex(cloud,guess(ic)) + else + icloud=-999 + end if if ( .not. l_use_dbz_directDA ) then ! original code if(icloud>0) then ptr3dges = max(ptr3dges+ptr3dinc,zero) From df010e4e68effe73116aa9758080ef0f50ed5d37 Mon Sep 17 00:00:00 2001 From: ClaraDraper-NOAA <33430543+ClaraDraper-NOAA@users.noreply.github.com> Date: Thu, 2 Mar 2023 11:38:25 -0700 Subject: [PATCH 003/109] Bugfix in EnKF assim of conventional q obs (#545) **Description** Added code to divide hx_modens by qsat, for consistency with treatment of q as q/qsat. Fixes issue #544 --- src/enkf/readconvobs.f90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/enkf/readconvobs.f90 b/src/enkf/readconvobs.f90 index e1977298a6..f3b1e38f04 100644 --- a/src/enkf/readconvobs.f90 +++ b/src/enkf/readconvobs.f90 @@ -789,6 +789,9 @@ subroutine get_convobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, & x_obs(nob) = x_obs(nob) /Forecast_Saturation_Spec_Hum(i) hx_mean(nob) = hx_mean(nob) /Forecast_Saturation_Spec_Hum(i) hx_mean_nobc(nob) = hx_mean_nobc(nob) /Forecast_Saturation_Spec_Hum(i) + if (neigv>0) then + hx_modens(:,nob) = hx_modens(:,nob)/ Forecast_Saturation_Spec_Hum(i) + endif endif ! for wind, also read v-component From 723a034248448e31979abda063f8895ac3f9c918 Mon Sep 17 00:00:00 2001 From: David Huber <69919478+DavidHuber-NOAA@users.noreply.github.com> Date: Thu, 9 Mar 2023 10:24:13 -0500 Subject: [PATCH 004/109] Update Jet support (#537) --- modulefiles/gsi_jet.lua | 24 +++++++++++++++--------- regression/global_3dvar.sh | 2 +- regression/regression_param.sh | 16 ++++++++-------- regression/regression_var.sh | 9 +++------ ush/sub_jet | 3 ++- 5 files changed, 29 insertions(+), 25 deletions(-) diff --git a/modulefiles/gsi_jet.lua b/modulefiles/gsi_jet.lua index ddb255bc1f..855597a08e 100644 --- a/modulefiles/gsi_jet.lua +++ b/modulefiles/gsi_jet.lua @@ -1,26 +1,32 @@ help([[ ]]) -load("cmake/3.20.1") +prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/hpc-stack/libs/intel-18.0.5.274/modulefiles/stack") -prepend_path("MODULEPATH", "/contrib/anaconda/modulefiles") +local hpc_ver=os.getenv("hpc_ver") or "1.2.0" +local hpc_intel_ver=os.getenv("hpc_intel_ver") or "18.0.5.274" +local hpc_impi_ver=os.getenv("hpc_impi_ver") or "2018.4.274" +local cmake_ver=os.getenv("cmake_ver") or "3.20.1" +local anaconda_ver=os.getenv("anaconda_ver") or "5.3.1" +local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" -load("anaconda/5.3.1") +load(pathJoin("hpc", hpc_ver)) +load(pathJoin("hpc-intel", hpc_intel_ver)) +load(pathJoin("hpc-impi", hpc_impi_ver)) +load(pathJoin("cmake", cmake_ver)) -prepend_path("MODULEPATH", "/lfs4/HFIP/hfv3gfs/nwprod/hpc-stack/libs/modulefiles/stack") +prepend_path("MODULEPATH", "/contrib/anaconda/modulefiles") -load("hpc/1.1.0") -load("hpc-intel/18.0.5.274") -load("hpc-impi/2018.4.274") +load(pathJoin("anaconda", anaconda_ver)) load("gsi_common") -local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-axSSE4.2,AVX,CORE-AVX2") pushenv("FFLAGS", "-axSSE4.2,AVX,CORE-AVX2") -pushenv("GSI_BINARY_SOURCE_DIR", "/lfs4/HFIP/hfv3gfs/glopara/git/fv3gfs/fix/gsi/20221128") + +pushenv("GSI_BINARY_SOURCE_DIR", "/mnt/lfs4/HFIP/hfv3gfs/glopara/git/fv3gfs/fix/gsi/20221128") whatis("Description: GSI environment on Jet with Intel Compilers") diff --git a/regression/global_3dvar.sh b/regression/global_3dvar.sh index 145cb6212c..56f78ad384 100755 --- a/regression/global_3dvar.sh +++ b/regression/global_3dvar.sh @@ -294,7 +294,7 @@ for type in $listdiag; do date=`echo $diag_file | cut -d'.' -f2` $UNCOMPRESS $diag_file fnameanl=$(echo $fname|sed 's/_ges//g') - mv $fname.$date $fnameanl + mv ${fname}.${date} $fnameanl done # Run GSI diff --git a/regression/regression_param.sh b/regression/regression_param.sh index a2808ddfc0..6024dbdb54 100755 --- a/regression/regression_param.sh +++ b/regression/regression_param.sh @@ -53,8 +53,8 @@ case $regtest in topts[1]="0:15:00" ; popts[1]="12/5/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="12/9/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:50:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:50:00" ; popts[2]="12/9/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="12/5/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="12/9/" ; ropts[2]="/2" elif [[ "$machine" = "Cheyenne" ]]; then topts[1]="0:30:00" ; popts[1]="16/2/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="16/4/" ; ropts[2]="/2" @@ -123,8 +123,8 @@ case $regtest in topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="12/12/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:35:00" ; popts[1]="6/8/" ; ropts[1]="/1" - topts[2]="0:35:00" ; popts[2]="6/10/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2" elif [[ "$machine" = "Discover" ]]; then topts[1]="0:30:00" ; popts[1]="48/2" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="60/3" ; ropts[2]="/2" @@ -153,8 +153,8 @@ case $regtest in topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" @@ -255,8 +255,8 @@ case $regtest in topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "Cheyenne" ]]; then topts[1]="0:15:00" ; popts[1]="16/2/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="16/4/" ; ropts[2]="/2" diff --git a/regression/regression_var.sh b/regression/regression_var.sh index 250317f405..98083c8587 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -33,7 +33,7 @@ if [[ -d /glade ]]; then # Cheyenne export machine="Cheyenne" elif [[ -d /scratch1 ]]; then # Hera export machine="Hera" -elif [[ -d /jetmon ]]; then # Jet +elif [[ -d /mnt/lfs4 || -d /jetmon || -d /mnt/lfs1 ]]; then # Jet export machine="Jet" elif [[ -d /discover ]]; then # NCCS Discover export machine="Discover" @@ -138,19 +138,16 @@ case $machine in export noscrub=/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/noscrub export ptmp=/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/ptmp - export fixcrtm="/lfs1/NESDIS/nesdis-rdo2/David.Huber/save/CRTM_REL-2.2.3/crtm_v2.2.3/fix_update" - export casesdir="/lfs1/NESDIS/nesdis-rdo2/David.Huber/save/CASES" + export casesdir="/lfs1/NESDIS/nesdis-rdo2/David.Huber/save/CASES/regtest" export check_resource="no" export accnt="nesdis-rdo2" export group="global" export queue="batch" if [[ "$cmaketest" = "false" ]]; then - export basedir="/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/gsi" + export basedir="/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/save/git/gsi" fi - export ptmp="/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/ptmp/$ptmpName" - # On Jet, there are no scrubbers to remove old contents from stmp* directories. # After completion of regression tests, will remove the regression test subdirecories export clean=".true." diff --git a/ush/sub_jet b/ush/sub_jet index 5bd9a6d68c..e11be1280c 100755 --- a/ush/sub_jet +++ b/ush/sub_jet @@ -88,7 +88,7 @@ output=${output:-$jobname.out} myuser=$LOGNAME myhost=$(hostname) -DATA=$regdir/regtests/data +DATA=${DATA:-$ptmp/tmp} mkdir -p $DATA @@ -117,6 +117,7 @@ echo "#SBATCH --time=$timew" echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile #echo "#SBATCH -j oe" >> $cfile echo "#SBATCH --account=$accnt" >> $cfile +echo "#SBATCH --mem=0" >> $cfile echo "#SBATCH --partition=kjet" >> $cfile #echo "#SBATCH -V" >> $cfile #echo "#PBS -d" >> $cfile From 89c47116ef0f931f16b5bb5a3380fb58b9d87a1a Mon Sep 17 00:00:00 2001 From: emilyhcliu <36091766+emilyhcliu@users.noreply.github.com> Date: Tue, 14 Mar 2023 12:36:09 -0400 Subject: [PATCH 005/109] gfsda.v16 merge with develop (#526) merge changes made in recent GFS v16.3.x implementations into develop --- modulefiles/gsi_common.lua | 2 +- regression/netcdf_fv3_regional.sh | 9 --- regression/regression_var.sh | 12 --- src/gsi/aircraftinfo.f90 | 2 +- src/gsi/cplr_gfs_ensmod.f90 | 31 ++++---- src/gsi/general_read_gfsatm.f90 | 1 + src/gsi/gesinfo.F90 | 10 +-- src/gsi/netcdfgfs_io.f90 | 2 +- src/gsi/radinfo.f90 | 6 +- src/gsi/read_diag.f90 | 4 +- src/gsi/read_files.f90 | 8 +- src/gsi/read_prepbufr.f90 | 12 ++- src/gsi/read_satwnd.f90 | 19 ++--- src/gsi/setuprad.f90 | 2 +- src/gsi/setupw.f90 | 15 ++-- src/gsi/stub_wrf_binary_interface.f90 | 8 ++ src/gsi/stub_wrf_netcdf_interface.f90 | 5 +- src/gsi/write_incr.f90 | 3 +- ush/build_4nco_global.sh | 3 + ush/prune_4nco_global.sh | 107 ++++++++++++++++++-------- 20 files changed, 146 insertions(+), 115 deletions(-) diff --git a/modulefiles/gsi_common.lua b/modulefiles/gsi_common.lua index 6844372324..b2b08f1197 100644 --- a/modulefiles/gsi_common.lua +++ b/modulefiles/gsi_common.lua @@ -14,7 +14,7 @@ local sfcio_ver=os.getenv("sfcio_ver") or "1.4.1" local nemsio_ver=os.getenv("nemsio_ver") or "2.5.2" local wrf_io_ver=os.getenv("wrf_io_ver") or "1.2.0" local ncio_ver=os.getenv("ncio_ver") or "1.1.2" -local crtm_ver=os.getenv("crtm_ver") or "2.3.0" +local crtm_ver=os.getenv("crtm_ver") or "2.4.0" local ncdiag_ver=os.getenv("ncdiag_ver") or "1.0.0" load(pathJoin("netcdf", netcdf_ver)) diff --git a/regression/netcdf_fv3_regional.sh b/regression/netcdf_fv3_regional.sh index db5ecb920a..747794fae0 100755 --- a/regression/netcdf_fv3_regional.sh +++ b/regression/netcdf_fv3_regional.sh @@ -7,15 +7,6 @@ set -x # Set experiment name exp=$jobname -#TM=00 -#TM2=03 -#tmmark=tm${TM} - - -# Set path/file for gsi executable -#gsiexec=/meso/save/Wanshu.Wu/Code/trunk/trunk_40320/src/global_gsi_org -#gsiexec=/da/save/Michael.Lueken/trunk/src/global_gsi.x - # Set runtime and save directories tmpdir=$tmpdir/tmpreg_netcdf_fv3_regional/${exp} savdir=$savdir/outreg_netcdf_fv3_regional/${exp} diff --git a/regression/regression_var.sh b/regression/regression_var.sh index 98083c8587..8733a341e2 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -173,18 +173,6 @@ case $machine in ;; esac -if [[ "$cmaketest" = "false" ]]; then - export builddir=$noscrub/build - export gsisrc="$basedir/$updat/src" - export gsiexec_updat="$gsisrc/global_gsi.x" - export gsiexec_contrl="$basedir/$contrl/src/global_gsi.x" - export enkfexec_updat="$gsisrc/enkf/global_enkf.x" - export enkfexec_contrl="$basedir/$contrl/src/enkf/global_enkf.x" - export fixgsi="$basedir/$updat/fix" - export scripts="$basedir/$updat/regression" - export ush="$basedir/$updat/ush" -fi - # We are dealing with *which* endian files export endianness="Big_Endian" diff --git a/src/gsi/aircraftinfo.f90 b/src/gsi/aircraftinfo.f90 index b84455f47c..a29f1571b1 100644 --- a/src/gsi/aircraftinfo.f90 +++ b/src/gsi/aircraftinfo.f90 @@ -57,7 +57,7 @@ module aircraftinfo logical :: cleanup_tail ! logical to remove tail number no longer used logical :: upd_aircraft ! indicator if update bias at 06Z & 18Z - integer(i_kind), parameter :: max_tail=10000 ! max tail numbers + integer(i_kind), parameter :: max_tail=100000 ! max tail numbers integer(i_kind) npredt ! predictor number integer(i_kind) ntail ! total tail number integer(i_kind) ntail_update ! new total tail number diff --git a/src/gsi/cplr_gfs_ensmod.f90 b/src/gsi/cplr_gfs_ensmod.f90 index c16c0e8c0e..dc55bcaf9e 100644 --- a/src/gsi/cplr_gfs_ensmod.f90 +++ b/src/gsi/cplr_gfs_ensmod.f90 @@ -385,7 +385,7 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) character(len=70) :: filename integer(i_kind) :: ierr - integer(i_kind) :: km,m + integer(i_kind) :: km1,m integer(i_kind) :: icw,iql,iqi,iqr,iqs,iqg real(r_kind),pointer,dimension(:,:) :: ps !real(r_kind),pointer,dimension(:,:) :: sst @@ -440,31 +440,31 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) ! if(trim(cvars2d(m))=='sst') sst=en_loc3(:,:,m_cvars2d(m)) !no sst for now enddo - km = en_perts(1,1,1)%grid%km + km1 = en_perts(1,1,1)%grid%km - 1 !$omp parallel do schedule(dynamic,1) private(m) do m=1,nc3d if(trim(cvars3d(m))=='sf')then - u = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + u = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='vp') then - v = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + v = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='t') then - tv = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + tv = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='q') then - q = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + q = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='oz') then - oz = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + oz = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='cw') then - cwmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + cwmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='ql') then - qlmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + qlmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='qi') then - qimr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + qimr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='qr') then - qrmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + qrmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='qs') then - qsmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + qsmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='qg') then - qgmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km) + qgmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) end if enddo @@ -938,9 +938,8 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig ! If file exists, open and process atmges = open_dataset(filename,errcode=ierror) if (ierror /=0) then - write(6,*)' PARALLEL_READ_GFSNC_STATE: ***FATAL ERROR*** problem reading ',& - trim(filename),' ierror= ',ierror,' PROGRAM STOPS' - call die(myname_, ': ***FATAL ERROR*** problem reading ens fcst',999) + write(6,*)' PARALLEL_READ_GFSNC_STATE: ***FATAL ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS' + call stop2(999) endif ! get dimension sizes ncdim = get_dim(atmges, 'grid_xt'); lonb = ncdim%len diff --git a/src/gsi/general_read_gfsatm.f90 b/src/gsi/general_read_gfsatm.f90 index 39db75db73..0216b95fb6 100755 --- a/src/gsi/general_read_gfsatm.f90 +++ b/src/gsi/general_read_gfsatm.f90 @@ -2825,6 +2825,7 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z call gsi_bundlegetpointer(gfs_bundle,'q' ,g_q ,ier);istatus=istatus+ier call gsi_bundlegetpointer(gfs_bundle,'oz',g_oz ,ier);istatus=istatus+ier ! call gsi_bundlegetpointer(gfs_bundle,'cw',g_cwmr,ier);istatus=istatus+ier + istatus1=0 call gsi_bundlegetpointer(gfs_bundle,'ql',g_ql ,ier);istatus1=istatus1+ier call gsi_bundlegetpointer(gfs_bundle,'qi',g_qi ,ier);istatus1=istatus1+ier call gsi_bundlegetpointer(gfs_bundle,'qr',g_qr ,ier);istatus1=istatus1+ier diff --git a/src/gsi/gesinfo.F90 b/src/gsi/gesinfo.F90 index 792900b628..0aefd34c76 100644 --- a/src/gsi/gesinfo.F90 +++ b/src/gsi/gesinfo.F90 @@ -148,7 +148,7 @@ subroutine gesinfo write(filename,'("sigf",i2.2)')nhr_assimilation inquire(file=filename,exist=fexist) if(.not.fexist) then - write(6,*)' GESINFO: ***ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS' + write(6,*)' GESINFO: ***FATAL ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS' call stop2(99) stop end if @@ -339,12 +339,12 @@ subroutine gesinfo ! open the netCDF file atmges = open_dataset(filename,errcode=iret) if (iret /=0) then - write(6,*)'GESINFO: ***ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS' + write(6,*)'GESINFO: ***FATAL ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS' call stop2(99) endif sfcges = open_dataset(sfilename,errcode=iret) if (iret /=0) then - write(6,*)'GESINFO: ***ERROR*** ',trim(sfilename),' NOT AVAILABLE: PROGRAM STOPS' + write(6,*)'GESINFO: ***FATAL ERROR*** ',trim(sfilename),' NOT AVAILABLE: PROGRAM STOPS' call stop2(99) endif ! get dimension sizes @@ -451,7 +451,7 @@ subroutine gesinfo ! Check for consistency with namelist settings if (gfshead%jcap/=jcap_b.and..not.regional .or. gfshead%levs/=nsig) then if (gfshead%levs/=nsig) then - write(6,*)'GESINFO: ***ERROR*** guess levels inconsistent with namelist' + write(6,*)'GESINFO: ***FATAL ERROR*** guess levels inconsistent with namelist' write(6,*)' guess nsig=',gfshead%levs write(6,*)' namelist nsig=',nsig fatal = .true. @@ -466,7 +466,7 @@ subroutine gesinfo fatal = .false. else if ( mype == mype_out ) & - write(6,*)'GESINFO: ***ERROR*** guess jcap inconsistent with namelist' + write(6,*)'GESINFO: ***FATAL ERROR*** guess jcap inconsistent with namelist' fatal = .true. endif if ( mype == mype_out ) & diff --git a/src/gsi/netcdfgfs_io.f90 b/src/gsi/netcdfgfs_io.f90 index ce32e13554..e1255b773c 100644 --- a/src/gsi/netcdfgfs_io.f90 +++ b/src/gsi/netcdfgfs_io.f90 @@ -1300,7 +1300,7 @@ subroutine read_sfc_anl_(isli_anl) ! open the netCDF file sfcges = open_dataset(filename,errcode=iret) if (iret/=0) then - write(6,*) trim(my_name),': ***ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS' + write(6,*) trim(my_name),': ***FATAL ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS' call stop2(999) endif diff --git a/src/gsi/radinfo.f90 b/src/gsi/radinfo.f90 index 76a08c39a5..8bfb015d1c 100644 --- a/src/gsi/radinfo.f90 +++ b/src/gsi/radinfo.f90 @@ -615,7 +615,7 @@ subroutine radinfo_read ! !USES: use obsmod, only: iout_rad - use constants, only: zero,one,zero_quad + use constants, only: zero,one,zero_quad, r10 use mpimod, only: mype use mpeu_util, only: perr,die implicit none @@ -855,7 +855,8 @@ subroutine radinfo_read varA(i,j)=varx(i) end do ostats(j)=ostatsx - if ((any(varx/=zero) .and. iuse_rad(j)>-2) .or. iuse_rad(j)==4) & + if ((all(varx==zero) .and. iuse_rad(j)>-2) .or. iuse_rad(j)==4) cycle read3 + if ((any(varx/=r10) .and. iuse_rad(j)>-2) .or. iuse_rad(j)==4) & inew_rad(j)=.false. cycle read3 end if @@ -1867,6 +1868,7 @@ subroutine init_predx end do end do loop_a + write(6,*) 'INIT_PREDX: inst_sat new_chan = ', trim(fdiag_rad), new_chan if (.not. update .and. new_chan==0) then call close_radiag(fdiag_rad,lndiag) cycle loopf diff --git a/src/gsi/read_diag.f90 b/src/gsi/read_diag.f90 index 6a7fa44cb9..e389a708d5 100644 --- a/src/gsi/read_diag.f90 +++ b/src/gsi/read_diag.f90 @@ -1165,7 +1165,9 @@ subroutine read_radiag_data_nc(diag_status,header_fix,data_fix,data_chan,data_ex data_fix = diag_status%all_data_fix(diag_status%cur_ob_idx) data_chan(:) = diag_status%all_data_chan(diag_status%cur_ob_idx,:) - data_extra(:,:) = diag_status%all_data_extra(diag_status%cur_ob_idx,:,:) + if (header_fix%iextra > 0) then + data_extra(:,:) = diag_status%all_data_extra(diag_status%cur_ob_idx,:,:) + endif diag_status%cur_ob_idx = diag_status%cur_ob_idx + 1 diff --git a/src/gsi/read_files.f90 b/src/gsi/read_files.f90 index 93ddd17bf7..5d29efbace 100644 --- a/src/gsi/read_files.f90 +++ b/src/gsi/read_files.f90 @@ -620,7 +620,7 @@ subroutine read_files(mype) endif if (l4densvar .and. nfldsig/=ntlevs_ens) then if (mype==0) then - write(6,*)'READ_FILES: ***ERROR*** insufficient atm fcst for 4densvar: PROGRAM STOPS' + write(6,*)'READ_FILES: ***FATAL ERROR*** insufficient atm fcst for 4densvar: PROGRAM STOPS' do i=1,ntlevs_ens ihr=nhr_obsbin*(i-1)+nhr_half present=.false. @@ -629,7 +629,7 @@ subroutine read_files(mype) end do if (.not.present) then write(filename,'(''sigf'',i2.2)')ihr - write(6,*)'READ_FILES: ***ERROR*** file ',trim(filename),' missing: PROGRAM STOPS' + write(6,*)'READ_FILES: ***FATAL ERROR*** file ',trim(filename),' missing: PROGRAM STOPS' endif end do endif @@ -652,7 +652,7 @@ subroutine read_files(mype) endif if (l4densvar .and. nfldsfc/=ntlevs_ens) then if (mype==0) then - write(6,*)'READ_FILES: ***ERROR*** insufficient sfc fcst for 4densvar: PROGRAM STOPS' + write(6,*)'READ_FILES: ***FATAL ERROR*** insufficient sfc fcst for 4densvar: PROGRAM STOPS' do i=1,ntlevs_ens ihr=nhr_obsbin*(i-1)+nhr_half present=.false. @@ -661,7 +661,7 @@ subroutine read_files(mype) end do if (.not.present) then write(filename,'(''sfcf'',i2.2)')ihr - write(6,*)'READ_FILES: ***ERROR*** file ',trim(filename),' missing: PROGRAM STOPS' + write(6,*)'READ_FILES: ***FATAL ERROR*** file ',trim(filename),' missing: PROGRAM STOPS' endif end do endif diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index d2cb503926..f992ace329 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -475,7 +475,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if(tob)then nreal=25 else if(uvob) then - nreal=27 + nreal=26 else if(spdob) then nreal=24 else if(psob) then @@ -2239,8 +2239,8 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& cdata_all(25,iout)=var_jb(5,k) ! non linear qc parameter cdata_all(26,iout)=one ! hilbert curve weight, modified later if(perturb_obs)then - cdata_all(28,iout)=ran01dom()*perturb_fact ! u perturbation - cdata_all(29,iout)=ran01dom()*perturb_fact ! v perturbation + cdata_all(27,iout)=ran01dom()*perturb_fact ! u perturbation + cdata_all(28,iout)=ran01dom()*perturb_fact ! v perturbation endif else if(spdob) then @@ -3057,7 +3057,11 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& do k=1,ndata ikx=nint(cdata_out(10,k)) - itype=ictype(ikx) + if (ikx>0) then + itype=ictype(ikx) + else + itype=0 + endif if( itype ==230 .or. itype ==231 .or. itype ==233) then prest=r10*exp(cdata_out(4,k)) if (prest <100.0_r_kind) cycle diff --git a/src/gsi/read_satwnd.f90 b/src/gsi/read_satwnd.f90 index 874483c86e..c67d5a7e1f 100644 --- a/src/gsi/read_satwnd.f90 +++ b/src/gsi/read_satwnd.f90 @@ -74,8 +74,6 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ! or hilber curve downweighting ! ! 2020-05-04 wu - no rotate_wind for fv3_regional -! 2021-07-25 Genkova - read GOES-17 AMVQ flag:8-mitigated height -! 16-mit.target, 24-mit.target & height; write in diag ! 2021-07-25 Genkova - added code for Metop-B/C winds in new BUFR,NC005081 ! ! 2022-01-20 Genkova - added missing station_id for polar winds ! 2022-01-20 Genkova - added code for Meteosat and Himawari AMVs in new BUFR @@ -212,7 +210,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis real(r_kind),dimension(nsig):: presl real(r_double),dimension(13):: hdrdat - real(r_double),dimension(5):: obsdat + real(r_double),dimension(4):: obsdat real(r_double),dimension(2) :: hdrdat_test real(r_double),dimension(3,5) :: heightdat real(r_double),dimension(6,4) :: derdwdat @@ -242,8 +240,8 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis data hdrtr_v2 /'SAID CLATH CLONH YEAR MNTH DAYS HOUR MINU SWCM SAZA OGCE SCCF SWQM'/ ! OGCE replaces GCLONG, OGCE exists in old and new BUFR ! SWQM doesn't exist in the new BUFR, so qm is initialized to '2' manually - data obstr_v1 /'HAMD PRLC WDIR WSPD AMVQ'/ - data obstr_v2 /'EHAM PRLC WDIR WSPD AMVQ'/ + data obstr_v1 /'HAMD PRLC WDIR WSPD'/ + data obstr_v2 /'EHAM PRLC WDIR WSPD'/ ! data heightr/'MDPT '/ ! data derdwtr/'TWIND'/ data qcstr /' OGCE GNAP PCCF'/ @@ -271,7 +269,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ! Set lower limits for observation errors werrmin=one nsattype=0 - nreal=27 + nreal=26 if(perturb_obs ) nreal=nreal+2 ntread=1 ntmatch=0 @@ -644,10 +642,10 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis call ufbint(lunin,hdrdat_test,2,1,iret, 'CLAT CLON') if ( hdrdat_test(1) > 100000000.0_r_kind .and. hdrdat_test(2) > 100000000.0_r_kind ) then call ufbint(lunin,hdrdat,13,1,iret,hdrtr_v2) - call ufbint(lunin,obsdat,5,1,iret,obstr_v2) + call ufbint(lunin,obsdat,4,1,iret,obstr_v2) else call ufbint(lunin,hdrdat,13,1,iret,hdrtr_v1) - call ufbint(lunin,obsdat,5,1,iret,obstr_v1) + call ufbint(lunin,obsdat,4,1,iret,obstr_v1) endif ppb=obsdat(2) @@ -1586,11 +1584,10 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis cdata_all(23,iout)=r_sprvstg(1,1) ! subprovider name cdata_all(25,iout)=var_jb ! non linear qc parameter cdata_all(26,iout)=one ! hilbert curve weight - cdata_all(27,iout)=obsdat(5) ! AMVQ for GOES-17 mitig.AMVs if(perturb_obs)then - cdata_all(28,iout)=ran01dom()*perturb_fact ! u perturbation - cdata_all(29,iout)=ran01dom()*perturb_fact ! v perturbation + cdata_all(27,iout)=ran01dom()*perturb_fact ! u perturbation + cdata_all(28,iout)=ran01dom()*perturb_fact ! v perturbation endif enddo loop_readsb diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 index 8d0d343fb0..479d27af96 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -1816,7 +1816,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& err2 = one/error0**2 tbc0=tbc tb_obs0=tb_obs - wgtjo=varinv0 + wgtjo=varinv if (l_may_be_passive .and. .not. retrieval) then if(iii>0 .and. iinstr.ne.-1)then chan_count=(iii*(iii+1))/2 diff --git a/src/gsi/setupw.f90 b/src/gsi/setupw.f90 index 174b6e695e..62b58a0485 100644 --- a/src/gsi/setupw.f90 +++ b/src/gsi/setupw.f90 @@ -219,7 +219,6 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav ! level; they are now loaded by ! aircraftinfo. ! 2020-05-04 wu - no rotate_wind for fv3_regional -! 2021-07-25 Genkova - write AMVQ in diagnostic files ! 2021-10-xx pondeca/morris/zhao - added observation provider/subprovider ! information in diagonostic file, which is used ! in offline observation quality control program (AutoObsQC) @@ -293,7 +292,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav integer(i_kind) ihgt,ier2,iuse,ilate,ilone integer(i_kind) izz,iprvd,isprvd integer(i_kind) idomsfc,isfcr,iskint,iff10 - integer(i_kind) ibb,ikk,ihil,idddd,iamvq + integer(i_kind) ibb,ikk,ihil,idddd integer(i_kind) num_bad_ikx,iprev_station @@ -384,9 +383,8 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav icat=24 ! index of data level category ijb=25 ! index of non linear qc parameter ihil=26 ! index of hilbert curve weight - iamvq=27 ! index of AMVQ - iptrbu=28 ! index of u perturbation - iptrbv=29 ! index of v perturbation + iptrbu=27 ! index of u perturbation + iptrbv=28 ! index of v perturbation mm1=mype+1 scale=one @@ -402,7 +400,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav if(conv_diagsave)then ii=0 nchar=1 - ioff0=26 + ioff0=25 nreal=ioff0 if (lobsdiagsave) nreal=nreal+7*miter+2 if (twodvar_regional .or. l_obsprvdiag) then @@ -1254,7 +1252,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav call vqc_setup(vals,ratio_errors,error,cvar,& cg_t,ibb,ikk,var_jb,rat_err2v,wgt,valqcv) rwgt = rwgt+0.5_r_kind*wgt/wgtlim - valqc=valqcu+valqcv + valqc=half*(valqcu+valqcv) ! Accumulate statistics for obs belonging to this task if (muse(i)) then @@ -1725,7 +1723,6 @@ subroutine contents_binary_diag_(udiag,vdiag) rdiagbuf(23,ii) = factw ! 10m wind reduction factor rdiagbuf(24,ii) = 1.e+10_r_single ! u spread (filled in by EnKF) rdiagbuf(25,ii) = 1.e+10_r_single ! v spread (filled in by EnKF) - rdiagbuf(26,ii) = data(iamvq,i) ! AMVQ mitigation flag for AMVs;only for GOES17,LHP issue ioff=ioff0 if (lobsdiagsave) then @@ -1812,8 +1809,6 @@ subroutine contents_netcdf_diag_(udiag,vdiag) call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) - ! AMVQ Mitigated winds - call nc_diag_metadata("Mitigation_flag_AMVQ", sngl(data(iamvq,i)) ) call nc_diag_metadata("Wind_Reduction_Factor_at_10m", sngl(factw) ) if (.not. regional .or. fv3_regional) then diff --git a/src/gsi/stub_wrf_binary_interface.f90 b/src/gsi/stub_wrf_binary_interface.f90 index 201482df13..58ef9e004e 100644 --- a/src/gsi/stub_wrf_binary_interface.f90 +++ b/src/gsi/stub_wrf_binary_interface.f90 @@ -29,18 +29,26 @@ end subroutine convert_binary_mass_dummy subroutine convert_binary_nmm_dummy(this,update_pint,ctph0,stph0,tlm0) use kinds, only: r_kind + use constants, only: zero implicit none class(get_wrf_binary_interface_class), intent(inout) :: this logical ,intent(inout) :: update_pint real(r_kind),intent( out) :: ctph0,stph0,tlm0 + ctph0 = zero + stph0 = zero + tlm0 = zero end subroutine convert_binary_nmm_dummy subroutine convert_nems_nmmb_dummy(this,update_pint,ctph0,stph0,tlm0) use kinds, only: r_kind + use constants, only: zero implicit none class(get_wrf_binary_interface_class), intent(inout) :: this logical ,intent(inout) :: update_pint real(r_kind),intent( out) :: ctph0,stph0,tlm0 + ctph0 = zero + stph0 = zero + tlm0 = zero end subroutine convert_nems_nmmb_dummy end module get_wrf_binary_interface_mod diff --git a/src/gsi/stub_wrf_netcdf_interface.f90 b/src/gsi/stub_wrf_netcdf_interface.f90 index d80b765300..4235318686 100644 --- a/src/gsi/stub_wrf_netcdf_interface.f90 +++ b/src/gsi/stub_wrf_netcdf_interface.f90 @@ -30,12 +30,15 @@ end subroutine convert_netcdf_mass_dummy subroutine convert_netcdf_nmm_dummy(this,update_pint,ctph0,stph0,tlm0,guess) use kinds, only: r_single,i_kind,r_kind + use constants, only: zero implicit none class(convert_netcdf_class) ,intent(inout) :: this logical ,intent(in ) :: guess logical ,intent(inout) :: update_pint real(r_kind),intent( out) :: ctph0,stph0,tlm0 - + ctph0 = zero + stph0 = zero + tlm0 = zero end subroutine convert_netcdf_nmm_dummy subroutine update_netcdf_mass_dummy(this) diff --git a/src/gsi/write_incr.f90 b/src/gsi/write_incr.f90 index 69ad96e281..e312199998 100644 --- a/src/gsi/write_incr.f90 +++ b/src/gsi/write_incr.f90 @@ -366,10 +366,9 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) ncstart = (/ jstart(mype+1), 1, 1 /) nccount = (/ grd%lon1, grd%lat1-1, grd%nsig /) j1 = 2 - j2 = grd%lat1-1 else if (istart(mype+1)+grd%lat1 == grd%nlat+1) then nccount = (/ grd%lon1, grd%lat1-1, grd%nsig /) - j2 = grd%lat1-2 + j2 = grd%lat1-1 end if call mpi_barrier(mpi_comm_world,ierror) allocate(out3d(nccount(1),nccount(2),grd%nsig)) diff --git a/ush/build_4nco_global.sh b/ush/build_4nco_global.sh index 60382ce9b5..45d5eaf7a1 100755 --- a/ush/build_4nco_global.sh +++ b/ush/build_4nco_global.sh @@ -18,6 +18,9 @@ export GSI_MODE="GFS" export ENKF_MODE="GFS" export REGRESSION_TESTS="NO" +# Optionally set compiler flags +##export FFLAGS="-check all,noarg_temp_created" + # Prune the directory structure per NCO liking if [[ "${PRUNE_4NCO:-}" =~ [yYtT] ]]; then $DIR_ROOT/ush/prune_4nco_global.sh prune diff --git a/ush/prune_4nco_global.sh b/ush/prune_4nco_global.sh index 0e1eba2ead..149d2bab50 100755 --- a/ush/prune_4nco_global.sh +++ b/ush/prune_4nco_global.sh @@ -15,6 +15,8 @@ # removed directories and files # +function version { echo "$@" | awk -F. '{ printf("%d%03d%03d%03d\n", $1,$2,$3,$4); }'; } + set -ex mode=$1 @@ -23,7 +25,14 @@ mode=$1 if [[ "$mode" = "prune" ]]; then string="rm -r" elif [[ "$mode" = "restore" ]]; then - string="reset HEAD" + git_ver=$(git version | cut -d" " -f3) + if [ $(version $git_ver) -lt $(version "2.23.0") ]; then + use_checkout="YES" + string="checkout" + else + use_checkout="NO" + string="restore" + fi else echo " " echo "***ERROR*** invalid mode= $mode" @@ -46,38 +55,58 @@ echo " " cd $topdir rlist="regression src/GSD unit-tests" for type in $rlist; do - git $string ${type}* - rc=$? - if [[ $rc -ne 0 ]]; then - echo "***ERROR* git $string ${type}" - exit - fi - if [[ "$mode" = "restore" ]]; then - git checkout ${type}* - rc=$? - if [[ $rc -ne 0 ]]; then - echo "***ERROR* git checkout ${type}" + if [[ "$mode" = "prune" ]]; then + if [ -e $type ]; then + git $string ${type}* + rc=$? + if [[ $rc -ne 0 ]]; then + echo "***ERROR*** git $string ${type}" + exit + fi + fi + elif [[ "$mode" = "restore" ]]; then + if [[ "$use_checkout" = "YES" ]]; then + git reset HEAD ${type}* + git checkout ${type}* + rc=$? + else + git restore --staged ${type}* + git restore ${type}* + rc=$? + fi + if [[ $rc -ne 0 ]]; then + echo "***ERROR*** restore failed for ${type}" exit - fi + fi fi done # Process doc directories and files cd $topdir/doc -rlist="EnKF_user_guide GSI_user_guide README.discover" +rlist="EnKF_user_guide GSI_user_guide README.discover Release_Notes.fv3gfs_da.v15.0.0.txt Release_Notes.gfsda.v16.0.0.txt" for type in $rlist; do - git $string ${type}* - rc=$? - if [[ $rc -ne 0 ]]; then - echo "***ERROR* git $string ${type}" - exit - fi - if [[ "$mode" = "restore" ]]; then - git checkout ${type}* - rc=$? + if [[ "$mode" = "prune" ]]; then + if [ -e $type ]; then + git $string ${type}* + rc=$? + if [[ $rc -ne 0 ]]; then + echo "***ERROR*** git $string ${type}" + exit + fi + fi + elif [[ "$mode" = "restore" ]]; then + if [[ "$use_checkout" = "YES" ]]; then + git reset HEAD ${type}* + git checkout ${type}* + rc=$? + else + git restore --staged ${type}* + git restore ${type}* + rc=$? + fi if [[ $rc -ne 0 ]]; then - echo "***ERROR* git checkout ${type}" + echo "***ERROR*** restore failed for ${type}" exit fi fi @@ -88,17 +117,27 @@ done cd $topdir/ush rlist="sub" for type in $rlist; do - git $string ${type}* - rc=$? - if [[ $rc -ne 0 ]]; then - echo "***ERROR* git $string ${type}" - exit - fi - if [[ "$mode" = "restore" ]]; then - git checkout ${type}* - rc=$? + if [[ "$mode" = "prune" ]]; then + if [ -e $type ]; then + git $string ${type}* + rc=$? + if [[ $rc -ne 0 ]]; then + echo "***ERROR*** git $string ${type}" + exit + fi + fi + elif [[ "$mode" = "restore" ]]; then + if [[ "$use_checkout" = "YES" ]]; then + git reset HEAD ${type}* + git checkout ${type}* + rc=$? + else + git restore --staged ${type}* + git restore ${type}* + rc=$? + fi if [[ $rc -ne 0 ]]; then - echo "***ERROR* git checkout ${type}" + echo "***ERROR*** restore failed for ${type}" exit fi fi From 31b8b29a098fd8df50a9f0b11c6912d47ae0628c Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Thu, 16 Mar 2023 14:10:49 -0400 Subject: [PATCH 006/109] remove and update non crtm/2.4.0 references (#551) --- ci/spack.yaml | 2 +- modulefiles/gsi_gaea | 3 --- regression/regression_var.sh | 4 ---- 3 files changed, 1 insertion(+), 8 deletions(-) diff --git a/ci/spack.yaml b/ci/spack.yaml index eeb9f95512..a831de16ad 100644 --- a/ci/spack.yaml +++ b/ci/spack.yaml @@ -18,7 +18,7 @@ spack: - nemsio@2.5.2 - wrf-io@1.2.0 - ncio@1.1.2 - - crtm@2.3.0 + - crtm@2.4.0 - gsi-ncdiag@1.0.0 view: true concretizer: diff --git a/modulefiles/gsi_gaea b/modulefiles/gsi_gaea index 91089895a1..641f3d0fcf 100644 --- a/modulefiles/gsi_gaea +++ b/modulefiles/gsi_gaea @@ -52,9 +52,6 @@ module load sigio-intel-sandybridge/2.0.1 module load sp-intel-sandybridge/2.0.2 module load w3nco-intel-sandybridge/2.0.6 module load w3emc-intel-sandybridge/2.2.0 -module load crtm-intel/2.2.4 -#setenv CRTM_INC /lustre/f1/pdata/ncep_shared/NCEPLIBS/lib/crtm/v2.2.4/intel/include/crtm_v2.2.4 -#setenv CRTM_LIB /lustre/f1/pdata/ncep_shared/NCEPLIBS/lib/crtm/v2.2.4/intel/libcrtm_v2.2.4.a module load bacio-intel-sandybridge/2.0.2 setenv CRAYOS_VERSION $::env(CRAYPE_VERSION) #setenv CRAYOS_VERSION ${CRAYPE_VERSION} diff --git a/regression/regression_var.sh b/regression/regression_var.sh index 8733a341e2..05b5563ef1 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -58,7 +58,6 @@ case $machine in fi export ptmp="/glade/scratch/$LOGNAME/$ptmpName" - export fixcrtm="/glade/p/ral/jntp/tools/crtm/2.2.3/fix_update" export casesdir="/glade/p/ral/jntp/tools/CASES" export check_resource="no" @@ -99,7 +98,6 @@ case $machine in fi export ptmp="${ptmp:-/work/noaa/stmp/$LOGNAME/$ptmpName}" - export fixcrtm=${CRTM_FIX:-/apps/contrib/NCEPLIBS/orion/fix/crtm_v2.3.0} export casesdir="/work/noaa/da/rtreadon/CASES/regtest" export check_resource="no" @@ -124,7 +122,6 @@ case $machine in export ptmp="${ptmp:-/scratch1/NCEPDEV/stmp2/$LOGNAME/$ptmpName}" -## export fixcrtm="${CRTM_FIX:-/scratch1/NCEPDEV/da/Michael.Lueken/CRTM_REL-2.2.3/crtm_v2.2.3/fix_update}" export casesdir="/scratch1/NCEPDEV/da/Russ.Treadon/CASES/regtest" export check_resource="no" @@ -160,7 +157,6 @@ case $machine in export ptmp=$basedir export ptmp=$basedir export noscrub=$basedir - export fixcrtm="/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/gsi/etc/fix_ncep20170329/REL-2.2.3-r60152_local-rev_1/CRTM_Coeffs/$endianness" export casesdir="/discover/nobackup/projects/gmao/obsdev/wrmccart/NCEP_regression/CASES" export check_resource="no" export accnt="g0613" From 89ca542c963c7887494e728656515918ce7a8518 Mon Sep 17 00:00:00 2001 From: shoyokota <103961291+shoyokota@users.noreply.github.com> Date: Sat, 18 Mar 2023 01:39:18 +0900 Subject: [PATCH 007/109] GitHub Issue NOAA-EMC/GSI#538 Add options to tune weights of mixed ensemble for FV3-LAM EnVar (#541) This PR adds options (weight_ens_gfs and weight_ens_fv3sar) to tune weights of mixed ensemble for FV3-LAM EnVar (https://github.com/NOAA-EMC/GSI/issues/538). Regression tests for global 3dvar/4denvar/4dvar are not completed yet, but for other tests, issues are not found except for "failed the scalability test" and "exceeded maximum allowable hardware memory limit" on Orion. Fixes #538 Co-authored-by: Sho Yokota --- src/gsi/cplr_get_fv3_regional_ensperts.f90 | 4 ++-- src/gsi/get_gefs_for_regional.f90 | 4 ++-- src/gsi/gsimod.F90 | 8 +++++--- src/gsi/hybrid_ensemble_parameters.f90 | 4 ++++ 4 files changed, 13 insertions(+), 7 deletions(-) diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 index 6e94b29c6c..fb4afe121d 100644 --- a/src/gsi/cplr_get_fv3_regional_ensperts.f90 +++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90 @@ -52,7 +52,7 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) use constants, only: zero,one,half,zero_single,rd_over_cp,one_tenth use mpimod, only: mpi_comm_world,ierror,mype,npe use hybrid_ensemble_parameters, only: n_ens,grd_ens,parallelization_over_ensmembers - use hybrid_ensemble_parameters, only: l_both_fv3sar_gfs_ens, n_ens_gfs,n_ens_fv3sar + use hybrid_ensemble_parameters, only: l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar,weight_ens_fv3sar use hybrid_ensemble_parameters, only: ntlevs_ens,ensemble_path use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d use gsi_bundlemod, only: gsi_bundlecreate @@ -674,7 +674,7 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) ! ! ! CONVERT ENSEMBLE MEMBERS TO ENSEMBLE PERTURBATIONS - sig_norm=sqrt(one/max(one,n_ens_fv3sar-one)) + sig_norm=sqrt(weight_ens_fv3sar/max(one,n_ens_fv3sar-one)) do n=imem_start,n_ens do i=1,nelen diff --git a/src/gsi/get_gefs_for_regional.f90 b/src/gsi/get_gefs_for_regional.f90 index a076f0ccfd..43a88ef300 100644 --- a/src/gsi/get_gefs_for_regional.f90 +++ b/src/gsi/get_gefs_for_regional.f90 @@ -41,7 +41,7 @@ subroutine get_gefs_for_regional fv3_regional use hybrid_ensemble_parameters, only: region_lat_ens,region_lon_ens use hybrid_ensemble_parameters, only: en_perts,ps_bar,nelen - use hybrid_ensemble_parameters, only: n_ens_gfs,grd_ens,grd_a1,grd_e1,p_e2a,uv_hyb_ens,dual_res + use hybrid_ensemble_parameters, only: n_ens_gfs,weight_ens_gfs,grd_ens,grd_a1,grd_e1,p_e2a,uv_hyb_ens,dual_res use hybrid_ensemble_parameters, only: full_ensemble,q_hyb_ens,l_ens_in_diff_time,write_ens_sprd use hybrid_ensemble_parameters, only: ntlevs_ens,ensemble_path,jcap_ens use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d @@ -1311,7 +1311,7 @@ subroutine get_gefs_for_regional ! 2*J_b = x^T * (beta1*B + beta2*P_ens)^(-1) * x ! where P_ens is the ensemble covariance which is the sum of outer products of the ! ensemble perturbations (unnormalized) divided by n_ens-1 (or n_ens, depending on who you read). - sig_norm=sqrt(one/max(one,n_ens_temp-one)) + sig_norm=sqrt(weight_ens_gfs/max(one,n_ens_temp-one)) ! if(n_ens_temp==n_ens.and.n==n_ens+1) sig_norm=one ! if(n==1 .or. n==2 .or. n==50) then diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index 8ccef7c38e..a86c20880c 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -154,7 +154,7 @@ module gsimod i_ensloccov4tim,i_ensloccov4var,i_ensloccov4scl,l_timloc_opt,& vdl_scale,vloc_varlist,& global_spectral_filter_sd,assign_vdl_nml,parallelization_over_ensmembers - use hybrid_ensemble_parameters,only : l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar + use hybrid_ensemble_parameters,only : l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar,weight_ens_gfs,weight_ens_fv3sar use rapidrefresh_cldsurf_mod, only: init_rapidrefresh_cldsurf, & dfi_radar_latent_heat_time_period,metar_impact_radius,& metar_impact_radius_lowcloud,l_gsd_terrain_match_surftobs, & @@ -1408,7 +1408,8 @@ module gsimod ! s_ens_h = v1L1 v2L1 v3L1 v1L2 v2L2 ! Then localization lengths will be assigned as above. ! - namelist/hybrid_ensemble/l_hyb_ens,uv_hyb_ens,q_hyb_ens,aniso_a_en,generate_ens,n_ens,l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar,nlon_ens,nlat_ens,jcap_ens,& + namelist/hybrid_ensemble/l_hyb_ens,uv_hyb_ens,q_hyb_ens,aniso_a_en,generate_ens,n_ens,& + l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar,weight_ens_gfs,weight_ens_fv3sar,nlon_ens,nlat_ens,jcap_ens,& pseudo_hybens,merge_two_grid_ensperts,regional_ensemble_option,fv3sar_bg_opt,fv3sar_ensemble_opt,full_ensemble,pwgtflg,& jcap_ens_test,beta_s0,beta_e0,s_ens_h,s_ens_v,readin_localization,eqspace_ensgrid,readin_beta,& grid_ratio_ens, & @@ -1821,7 +1822,8 @@ subroutine gsimain_initialize else write(6,*)'n_ens_gfs and n_ens_fv3sar won"t be used if not regional_ensemble_option==5' endif - + weight_ens_gfs=one + weight_ens_fv3sar=one endif if(ltlint) then if(vqc .or. njqc .or. nvqc)then diff --git a/src/gsi/hybrid_ensemble_parameters.f90 b/src/gsi/hybrid_ensemble_parameters.f90 index 17416f68fb..d813541c7a 100644 --- a/src/gsi/hybrid_ensemble_parameters.f90 +++ b/src/gsi/hybrid_ensemble_parameters.f90 @@ -287,6 +287,7 @@ module hybrid_ensemble_parameters public :: generate_ens,n_ens,nlon_ens,nlat_ens,jcap_ens,jcap_ens_test,l_hyb_ens,& s_ens_h,oz_univ_static,vvlocal public :: n_ens_gfs,n_ens_fv3sar + public :: weight_ens_gfs,weight_ens_fv3sar public :: uv_hyb_ens,q_hyb_ens,s_ens_v,beta_s0,beta_e0,aniso_a_en,s_ens_hv,s_ens_vv public :: readin_beta,beta_s,beta_e public :: readin_localization @@ -361,6 +362,7 @@ module hybrid_ensemble_parameters integer(i_kind) i_en_perts_io integer(i_kind) n_ens,nlon_ens,nlat_ens,jcap_ens,jcap_ens_test integer(i_kind) n_ens_gfs,n_ens_fv3sar + real(r_kind) weight_ens_gfs,weight_ens_fv3sar real(r_kind) beta_s0,beta_e0,grid_ratio_ens integer(i_kind),parameter::max_naensloc=20 integer(i_kind),parameter::max_nvars=100 @@ -497,6 +499,8 @@ subroutine init_hybrid_ensemble_parameters l_both_fv3sar_gfs_ens=.false. n_ens_gfs=0 n_ens_fv3sar=0 + weight_ens_gfs=one + weight_ens_fv3sar=one vdl_scale = 0 vloc_varlist = 'aaa' global_spectral_filter_sd=.false. From 4afe6edba0ba830173ff97c9ac8b3fbfd17e0e21 Mon Sep 17 00:00:00 2001 From: chunhua zhou Date: Fri, 24 Mar 2023 13:12:29 -0600 Subject: [PATCH 008/109] Add dDZ for EnKF (#536) **Description** This update includes several functions added for dBZ analysis in EnKF: 1, Add dBZ ncdiag output for EnKF analysis 2, Enhanced binary dBZ diag output for EnKF analysis 3, Fix spurious analysis increments when assimilating reflectivity (from OU MAP) 4, Added EnKF interface for read in dBZ from FV3LAM ensemble forecast (from OU MAP) Fixed a bug for read in subdomain surface restart files Fixes #534 --- src/enkf/enkf.f90 | 41 +++++++++++-- src/enkf/gridinfo_fv3reg.f90 | 4 +- src/enkf/gridio_fv3reg.f90 | 109 +++++++++++++++++++++++++++++------ src/gsi/gsi_dbzOper.F90 | 23 +++++++- src/gsi/gsi_rfv3io_mod.f90 | 75 +++++++++++------------- src/gsi/setupdbz.f90 | 10 ++-- 6 files changed, 191 insertions(+), 71 deletions(-) diff --git a/src/enkf/enkf.f90 b/src/enkf/enkf.f90 index c117e4ba56..d35613b585 100644 --- a/src/enkf/enkf.f90 +++ b/src/enkf/enkf.f90 @@ -97,6 +97,12 @@ module enkf ! used to be the same) and the "chunks" come from loadbal ! 2018-05-31: whitaker: add modulated ensemble model-space vertical ! localization (neigv>0) and denkf option. +! 2022-04-01: Y. Wang and X. Wang: Add dbz_ind related if-blocks to fix spurious +! analysis increments due to some unstable amplifying behaviors near edges of +! strong precipitation when clear air and large reflectivity values are +! assimilated in locations near each other (as may be the case in the leading +! line of an MCS). +! poc: xuguang.wang@ou.edu ! ! attributes: ! language: f95 @@ -182,7 +188,7 @@ subroutine enkf_update() integer(i_kind) ierr ! kd-tree search results type(kdtree2_result),dimension(:),allocatable :: sresults1,sresults2 -integer(i_kind) nanal,nn,nnn,nobm,nsame,nn1,nn2,oz_ind,nlev +integer(i_kind) nanal,nn,nnn,nobm,nsame,nn1,nn2,oz_ind,nlev,dbz_ind real(r_single),dimension(nlevs_pres):: taperv logical lastiter, kdgrid, kdobs @@ -609,6 +615,7 @@ subroutine enkf_update() nn2 = ncdim end if if (nf2 > 0) then + dbz_ind = getindex(cvars3d, 'dbz') !$omp parallel do schedule(dynamic,1) private(ii,i,nb,obt,nn,nnn,nlev,lnsig,kfgain,ens_tmp,taper1,taper3,taperv) do ii=1,nf2 ! loop over nearby horiz grid points do nb=1,nbackgrounds ! loop over background time levels @@ -628,8 +635,13 @@ subroutine enkf_update() ! (through hpfhtcon) kfgain=taper1*sum(ens_tmp*anal_obtmp_modens) ! update mean. - ensmean_chunk(i,nn,nb) = ensmean_chunk(i,nn,nb) + & - kfgain*obinc_tmp + if ( (nn >= (dbz_ind-1)*nlevs+1 .and. nn <= (dbz_ind-1)*nlevs+nlevs) )then + ensmean_chunk(i,nn,nb) = max(ensmean_chunk(i,nn,nb) + & + kfgain*obinc_tmp,zero) + else + ensmean_chunk(i,nn,nb) = ensmean_chunk(i,nn,nb) + & + kfgain*obinc_tmp + end if ! update perturbations. anal_chunk(:,i,nn,nb) = anal_chunk(:,i,nn,nb) + & kfgain*obganl(:) @@ -652,7 +664,11 @@ subroutine enkf_update() ! (through hpfhtcon) kfgain=taperv(nnn)*sum(anal_chunk(:,i,nn,nb)*anal_obtmp) ! update mean. - ensmean_chunk(i,nn,nb) = ensmean_chunk(i,nn,nb) + kfgain*obinc_tmp + if ( (nn >= (dbz_ind-1)*nlevs+1 .and. nn <= (dbz_ind-1)*nlevs+nlevs) )then + ensmean_chunk(i,nn,nb) = max(ensmean_chunk(i,nn,nb) + kfgain*obinc_tmp,zero) + else + ensmean_chunk(i,nn,nb) = ensmean_chunk(i,nn,nb) + kfgain*obinc_tmp + end if ! update perturbations. anal_chunk(:,i,nn,nb) = anal_chunk(:,i,nn,nb) + kfgain*obganl(:) end if @@ -681,7 +697,13 @@ subroutine enkf_update() taper(obt*obtimelinv)* & sum(anal_obchunk_modens(:,nob2)*anal_obtmp_modens)*hpfhtcon ! update mean. - ensmean_obchunk(nob2) = ensmean_obchunk(nob2) + kfgain*obinc_tmp + nob3 = indxproc_obs(nproc+1,nob2) + if(trim(obtype(nob3)) == 'dbz' ) then + ensmean_obchunk(nob2) = max((ensmean_obchunk(nob2) + & + kfgain*obinc_tmp),zero) + else + ensmean_obchunk(nob2) = ensmean_obchunk(nob2) + kfgain*obinc_tmp + end if ! update perturbations. anal_obchunk(:,nob2) = anal_obchunk(:,nob2) + kfgain*obganl anal_obchunk_modens(:,nob2) = anal_obchunk_modens(:,nob2) + kfgain*obganl_modens @@ -707,7 +729,13 @@ subroutine enkf_update() taper(lnsig*lnsiglinv)*taper(obt*obtimelinv)* & sum(anal_obchunk(:,nob2)*anal_obtmp)*hpfhtcon ! update mean. - ensmean_obchunk(nob2) = ensmean_obchunk(nob2) + kfgain*obinc_tmp + nob3 = indxproc_obs(nproc+1,nob2) + if(trim(obtype(nob3)) == 'dbz' ) then + ensmean_obchunk(nob2) = max((ensmean_obchunk(nob2) + & + kfgain*obinc_tmp),zero) + else + ensmean_obchunk(nob2) = ensmean_obchunk(nob2) + kfgain*obinc_tmp + end if ! update perturbations. anal_obchunk(:,nob2) = anal_obchunk(:,nob2) + kfgain*obganl ! recompute ob space spread ratio for unassimlated obs @@ -758,6 +786,7 @@ subroutine enkf_update() tend = mpi_wtime() if (nproc .eq. 0) then write(6,8003) niter,'timing on proc',nproc,' = ',tend-tbegin,t2,t3,t4,t5,t6,nrej + if(allocated(assimltd_flag))deallocate(assimltd_flag) allocate(assimltd_flag(nobstot)) assimltd_flag = 99999 if (iassim_order == 2) then diff --git a/src/enkf/gridinfo_fv3reg.f90 b/src/enkf/gridinfo_fv3reg.f90 index ef5b242901..4eff63c003 100644 --- a/src/enkf/gridinfo_fv3reg.f90 +++ b/src/enkf/gridinfo_fv3reg.f90 @@ -72,10 +72,10 @@ module gridinfo integer(i_kind),public :: npts integer(i_kind),public :: ntrunc ! supported variable names in anavinfo -character(len=max_varname_length),public, dimension(15) :: & +character(len=max_varname_length),public, dimension(16) :: & vars3d_supported = [character(len=max_varname_length) :: & 'u', 'v', 'w', 't', 'q', 'oz', 'cw', 'tsen', 'prse', & - 'ql', 'qi', 'qr', 'qs', 'qg', 'qnr'] + 'ql', 'qi', 'qr', 'qs', 'qg', 'qnr','dbz'] character(len=max_varname_length),public, dimension(3) :: & vars2d_supported = [character(len=max_varname_length) :: & 'ps', 'pst', 'sst'] diff --git a/src/enkf/gridio_fv3reg.f90 b/src/enkf/gridio_fv3reg.f90 index fb23a21a0c..4939dd16ee 100644 --- a/src/enkf/gridio_fv3reg.f90 +++ b/src/enkf/gridio_fv3reg.f90 @@ -24,6 +24,8 @@ module gridio ! -- add code to update 'delp' directly ! from analysis icnrements ! 2022-06- Ting -- Implement paranc=.true. for fv3-lam + ! 2022-04-01 Yongming Wang and X. Wang: Add interface for read in dBZ + ! poc: xuguang.wang@ou.edu ! attributes: ! language: f95 ! @@ -60,17 +62,19 @@ module gridio !------------------------------------------------------------------------- - integer(i_kind) ,parameter:: ndynvarslist=6, ntracerslist=8 + integer(i_kind) ,parameter:: ndynvarslist=6, ntracerslist=8, nphysicslist=1 character(len=max_varname_length), parameter, dimension(ndynvarslist) :: & vardynvars = [character(len=max_varname_length) :: & 'u', 'v', 'T', 'W', 'DZ', 'delp'] character(len=max_varname_length), parameter, dimension(ntracerslist) :: & vartracers = [character(len=max_varname_length) :: & 'sphum','o3mr', 'liq_wat','ice_wat','rainwat','snowwat','graupel','rain_nc'] + character(len=max_varname_length), parameter, dimension(nphysicslist) :: & + varphysics = [character(len=max_varname_length) :: 'ref_f3d'] type type_fv3lamfile logical l_filecombined - character(len=max_varname_length), dimension(2):: fv3lamfilename - integer (i_kind), dimension(2):: fv3lam_fileid(2) + character(len=max_varname_length), dimension(3):: fv3lamfilename + integer (i_kind), dimension(3):: fv3lam_fileid contains procedure, pass(this) :: setupfile => type_bound_setupfile procedure, pass(this):: get_idfn => type_bound_getidfn @@ -104,9 +108,9 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, ! Define local variables character(len=500) :: filename - character(len=:),allocatable :: fv3filename,fv3filename1 + character(len=:),allocatable :: fv3filename,fv3filename1,fv3filename2 character(len=7) :: charnanal - integer(i_kind) file_id,file_id1 + integer(i_kind) file_id,file_id1,file_id2 real(r_single), dimension(:,:,:), allocatable ::workvar3d,uworkvar3d,& vworkvar3d,tvworkvar3d,tsenworkvar3d,& workprsi,qworkvar3d @@ -124,6 +128,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, integer(i_kind) :: nlevsp1 integer (i_kind):: i,j, k,nn,ntile,nn_tile0, nb,nanal,ne integer(i_kind) :: u_ind, v_ind, tv_ind,tsen_ind, q_ind, oz_ind + integer(i_kind) :: dbz_ind integer(i_kind) :: w_ind, ql_ind, qi_ind, qr_ind, qs_ind, qg_ind, qnr_ind integer (i_kind):: ps_ind, sst_ind integer (i_kind):: tmp_ind,ifile @@ -147,6 +152,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, qs_ind = getindex(vars3d, 'qs') ! Q snow (3D) qg_ind = getindex(vars3d, 'qg') ! Q graupel (3D) qnr_ind = getindex(vars3d, 'qnr') ! N rain (3D) + dbz_ind = getindex(vars3d, 'dbz') ! Reflectivity (3D) ps_ind = getindex(vars2d, 'ps') ! Ps (2D) sst_ind = getindex(vars2d, 'sst') ! SST (2D) @@ -191,9 +197,19 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, fv3filename1=trim(adjustl(filename))//"_tracer" call nc_check( nf90_open(trim(adjustl(fv3filename1)),nf90_nowrite,file_id1),& myname_,'open: '//trim(adjustl(fv3filename1)) ) - call fv3lamfile%setupfile(fileid1=file_id,fv3fn1=trim(adjustl(fv3filename)) , & - fileid2=file_id1,fv3fn2=trim(adjustl(fv3filename1)) ) - + if(dbz_ind > 0) then + fv3filename2=trim(adjustl(filename))//"_phyvar" + call nc_check(nf90_open(trim(adjustl(fv3filename2)),nf90_nowrite,file_id2),& + myname_,'open: '//trim(adjustl(fv3filename2)) ) + endif + if(dbz_ind > 0) then + call fv3lamfile%setupfile(fileid1=file_id,fv3fn1=trim(adjustl(fv3filename)) , & + fileid2=file_id1,fv3fn2=trim(adjustl(fv3filename1)),& + fileid3=file_id2,fv3fn3=trim(adjustl(fv3filename2))) + else + call fv3lamfile%setupfile(fileid1=file_id,fv3fn1=trim(adjustl(fv3filename)) , & + fileid2=file_id1,fv3fn2=trim(adjustl(fv3filename1))) + endif endif !---------------------------------------------------------------------- @@ -476,6 +492,27 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, endif + if (dbz_ind > 0) then + varstrname = 'ref_f3d' + call fv3lamfile%get_idfn(varstrname,file_id,fv3filename) + call read_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) + do k=1,nlevs + nn = nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + vargrid(nn,levels(dbz_ind-1)+k,nb,ne)=max(workvar3d(i,j,nlevs+1-k),0.0_r_kind) + enddo + enddo + enddo + do k = levels(dbz_ind-1)+1, levels(dbz_ind) + if (nproc .eq. 0) & + write(6,*) 'READFVregional : dbz ', & + & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne)) + enddo + + endif + ! set SST to zero for now if (sst_ind > 0) then vargrid(:,levels(n3d)+sst_ind,nb,ne) = zero @@ -549,7 +586,8 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, call nc_check( nf90_close(file_id),& myname_,'close '//trim(filename) ) else - do ifile=1,2 + do ifile=1,3 + if(dbz_ind <= 0 .and. ifile == 3) cycle file_id=fv3lamfile%fv3lam_fileid(ifile) filename=fv3lamfile%fv3lamfilename(ifile) call nc_check( nf90_close(file_id),& @@ -601,15 +639,15 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid !---------------------------------------------------------------------- ! Define variables computed within subroutine character(len=500) :: filename - character(len=:),allocatable :: fv3filename,fv3filename1 + character(len=:),allocatable :: fv3filename,fv3filename1,fv3filename2 character(len=7) :: charnanal !---------------------------------------------------------------------- - integer(i_kind) :: u_ind, v_ind, tv_ind, tsen_ind,q_ind, ps_ind,oz_ind - integer(i_kind) :: w_ind + integer(i_kind) :: u_ind, v_ind, tv_ind, tsen_ind,q_ind, ps_ind,oz_ind,dbz_ind + integer(i_kind) :: w_ind, cw_ind, ph_ind integer(i_kind) :: ql_ind, qi_ind, qr_ind, qs_ind, qg_ind, qnr_ind - integer(i_kind) file_id,file_id1 + integer(i_kind) file_id,file_id1,file_id2 real(r_single), dimension(:,:), allocatable ::pswork real(r_single), dimension(:,:,:), allocatable ::workvar3d,workinc3d,workinc3d2,uworkvar3d,& vworkvar3d,tvworkvar3d,tsenworkvar3d,& @@ -652,6 +690,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid qs_ind = getindex(vars3d, 'qs') ! QS (3D) for FV3 qg_ind = getindex(vars3d, 'qg') ! QG (3D) for FV3 qnr_ind = getindex(vars3d, 'qnr') ! QNR (3D) for FV3 + dbz_ind = getindex(vars3d, 'dbz') ! Reflectivity (3D) ps_ind = getindex(vars2d, 'ps') ! Ps (2D) @@ -699,6 +738,15 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid call fv3lamfile%setupfile(fileid1=file_id,fv3fn1=trim(adjustl(fv3filename)) , & fileid2=file_id1,fv3fn2=trim(adjustl(fv3filename1)) ) + if(dbz_ind > 0) then + call fv3lamfile%setupfile(fileid1=file_id,fv3fn1=trim(adjustl(fv3filename)) , & + fileid2=file_id1,fv3fn2=trim(adjustl(fv3filename1)),& + fileid3=file_id2,fv3fn3=trim(adjustl(fv3filename2))) + else + call fv3lamfile%setupfile(fileid1=file_id,fv3fn1=trim(adjustl(fv3filename)) , & + fileid2=file_id1,fv3fn2=trim(adjustl(fv3filename1))) + endif + endif @@ -1006,6 +1054,25 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid endif + if (dbz_ind > 0) then + varstrname = 'ref_f3d' + call fv3lamfile%get_idfn(varstrname,file_id,fv3filename) + call read_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) + do k=1,nlevs + nn = nn_tile0 + do j=1,ny_res + do i=1,nx_res + nn=nn+1 + workinc3d(i,j,nlevs+1-k)=vargrid(nn,levels(dbz_ind-1)+k,nb,ne) + enddo + enddo + enddo + workvar3d=workvar3d+workinc3d + where (workvar3d < 0.0_r_kind) workvar3d = 0.0_r_kind + call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) + + endif + if (ps_ind > 0) then allocate(workprsi(nx_res,ny_res,nlevsp1)) allocate(pswork(nx_res,ny_res)) @@ -1051,7 +1118,8 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid call nc_check( nf90_close(file_id),& myname_,'close '//trim(filename) ) else - do ifile=1,2 + do ifile=1,3 + if(dbz_ind <=0 .and. ifile == 3) cycle file_id=fv3lamfile%fv3lam_fileid(ifile) filename=fv3lamfile%fv3lamfilename(ifile) call nc_check( nf90_close(file_id),& @@ -2478,19 +2546,23 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat ! Return calculated values return end subroutine writegriddata_pnc -subroutine type_bound_setupfile(this,fileid1,fv3fn1,fileid2,fv3fn2) +subroutine type_bound_setupfile(this,fileid1,fv3fn1,fileid2,fv3fn2,fileid3,fv3fn3) implicit none class (type_fv3lamfile) :: this integer(i_kind) fileid1 - integer(i_kind), optional :: fileid2 + integer(i_kind), optional :: fileid2,fileid3 character(len=*)::fv3fn1 - character(len=*),optional ::fv3fn2 + character(len=*),optional ::fv3fn2,fv3fn3 if (present (fileid2)) then this%l_filecombined=.false. this%fv3lamfilename(1)=trim(fv3fn1) this%fv3lamfilename(2)=trim(fv3fn2) this%fv3lam_fileid(1)=fileid1 this%fv3lam_fileid(2)=fileid2 + if (present (fileid3)) then + this%fv3lamfilename(3)=trim(fv3fn3) + this%fv3lam_fileid(3)=fileid3 + endif else this%l_filecombined=.true. this%fv3lamfilename(1)=fv3fn1 @@ -2509,6 +2581,9 @@ subroutine type_bound_getidfn(this,vnamloc,fileid,fv3fn) else if(ifindstrloc(vartracers,vnamloc)> 0) then fv3fn=trim(this%fv3lamfilename(2)) fileid=this%fv3lam_fileid(2) + else if(ifindstrloc(varphysics,vnamloc)> 0) then + fv3fn=trim(this%fv3lamfilename(3)) + fileid=this%fv3lam_fileid(3) else write(6,*)"the varname ",trim(vnamloc)," is not recognized in the ype_bound_getidfn, stop" call stop2(23) diff --git a/src/gsi/gsi_dbzOper.F90 b/src/gsi/gsi_dbzOper.F90 index 74d9bdf65d..4a63d0995f 100644 --- a/src/gsi/gsi_dbzOper.F90 +++ b/src/gsi/gsi_dbzOper.F90 @@ -83,6 +83,10 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use jfunc , only: jiter use mpeu_util, only: die + + use directDA_radaruse_mod, only: l_use_dbz_directDA + use obsmod, only: dirname, ianldate + implicit none class(dbzOper ), intent(inout):: self integer(i_kind), intent(in):: lunin @@ -99,8 +103,25 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) character(len=len_isis ):: isis integer(i_kind):: nreal,nchanl,ier,nele logical:: diagsave + integer(i_kind):: lu_diag + character(128):: diag_file + character(80):: string + + if(nobs == 0) then - if(nobs == 0) return + if( (mype == 0) .and. init_pass .and. (.not. l_use_dbz_directDA) ) then + write(string,600) jiter +600 format('radardbz_',i2.2) + diag_file=trim(dirname) // trim(string) + write(6,*) 'write ianldate to ', diag_file + open(newunit=lu_diag,file=trim(diag_file),form='unformatted',status='unknown',position='rewind') + write(lu_diag) ianldate + close(lu_diag) + endif + + return + + endif read(lunin,iostat=ier) obstype,isis,nreal,nchanl if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 2edde4723f..7e7b11d57c 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -538,7 +538,7 @@ subroutine read_fv3_files(mype) ! Declare local variables logical(4) fexist character(6) filename - character(14) filenames + character(19) filenames integer(i_kind) in_unit integer(i_kind) i,j,iwan,npem1 integer(i_kind) nhr_half @@ -573,11 +573,19 @@ subroutine read_fv3_files(mype) in_unit=15 iwan=0 !WWWWWW setup for one first guess file for now - do i=0,9 !place holder for FGAT + do i=0,9 !place holder for FGAT if ( i == 6 ) then - write(filenames,"(A11)") 'fv3_dynvars' + if(fv3_io_layout_y > 1) then + write(filenames,"(A16)") 'fv3_dynvars.0000' + else + write(filenames,"(A11)") 'fv3_dynvars' + endif else - write(filenames,"(A12,I2.2)") 'fv3_dynvars_',i + if(fv3_io_layout_y > 1) then + write(filenames,"(A17,I2.2)") 'fv3_dynvars.0000_',i + else + write(filenames,"(A12,I2.2)") 'fv3_dynvars_',i + endif endif INQUIRE(FILE=filenames, EXIST=fexist) if(.not.fexist) cycle @@ -1119,7 +1127,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) if (allocated(fv3lam_io_dynmetvars2d_nouv)) & write(6,*)' fv3lam_io_dynmetvars2d_nouv is ',(trim(fv3lam_io_dynmetvars2d_nouv(i)), i=1,ndynvario2d) if (allocated(fv3lam_io_tracermetvars2d_nouv))& - write(6,*)'fv3lam_io_dynmetvars2d_nouv is ',(trim(fv3lam_io_dynmetvars2d_nouv(i)),i=1,ntracerio3d) + write(6,*)'fv3lam_io_tracermetvars2d_nouv is ',(trim(fv3lam_io_tracermetvars2d_nouv(i)),i=1,ntracerio2d) endif if (laeroana_fv3cmaq) then @@ -1783,6 +1791,8 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) ! abstract: read in 2d fields from fv3_sfcdata file in mype_2d ! Scatter the field to each PE ! program history log: +! 2023-02-14 Hu - Bug fix for read in subdomain surface restart files +! ! input argument list: ! it - time index for 2d fields ! @@ -1902,40 +1912,24 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) write(*,*) "wrong dimension number ndim =",ndim call stop2(119) endif - if(allocated(dim_id )) deallocate(dim_id ) - allocate(dim_id(ndim)) if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 - iret=nf90_inquire_variable(gfile_loc_layout(nio),i,dimids=dim_id) - if(allocated(sfc )) deallocate(sfc ) - if(dim(dim_id(1)) == nx .and. dim(dim_id(2))==ny_layout_len(nio)) then - if(ndim >=3) then - allocate(sfc(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) - iret=nf90_get_var(gfile_loc_layout(nio),i,sfc) - else if (ndim == 2) then - allocate(sfc(dim(dim_id(1)),dim(dim_id(2)),1)) - iret=nf90_get_var(gfile_loc_layout(nio),i,sfc(:,:,1)) - endif - else - write(*,*) "Mismatch dimension in surfacei reading:",nx,ny_layout_len(nio),dim(dim_id(1)),dim(dim_id(2)) - call stop2(119) - endif - sfc_fulldomain(:,ny_layout_b(nio):ny_layout_e(nio))=sfc(:,:,1) + if(allocated(sfc )) deallocate(sfc ) + allocate(sfc(nx,ny_layout_len(nio),1)) + if(ndim >=3) then + iret=nf90_get_var(gfile_loc_layout(nio),i,sfc) + else if (ndim == 2) then + iret=nf90_get_var(gfile_loc_layout(nio),i,sfc(:,:,1)) + endif + sfc_fulldomain(:,ny_layout_b(nio):ny_layout_e(nio))=sfc(:,:,1) enddo else - iret=nf90_inquire_variable(gfile_loc,i,dimids=dim_id) if(allocated(sfc )) deallocate(sfc ) - if(dim(dim_id(1)) == nx .and. dim(dim_id(2))==ny) then - if(ndim >=3) then !the block of 10 lines is compied from GSL gsi. - allocate(sfc(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) - iret=nf90_get_var(gfile_loc,i,sfc) - else if (ndim == 2) then - allocate(sfc(dim(dim_id(1)),dim(dim_id(2)),1)) - iret=nf90_get_var(gfile_loc,i,sfc(:,:,1)) - endif - else - write(*,*) "Mismatch dimension in surfacei reading:",nx,ny,dim(dim_id(1)),dim(dim_id(2)) - call stop2(119) + allocate(sfc(nx,ny,1)) + if(ndim >=3) then + iret=nf90_get_var(gfile_loc,i,sfc) + else if (ndim == 2) then + iret=nf90_get_var(gfile_loc,i,sfc(:,:,1)) endif sfc_fulldomain(:,:)=sfc(:,:,1) endif @@ -1997,19 +1991,16 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) iret=nf90_inquire_variable(gfile_loc,k,name,len) if(trim(name)=='PHIS' .or. trim(name)=='phis' ) then iret=nf90_inquire_variable(gfile_loc,k,ndims=ndim) - if(allocated(dim_id )) deallocate(dim_id ) - allocate(dim_id(ndim)) if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 - iret=nf90_inquire_variable(gfile_loc_layout(nio),k,dimids=dim_id) if(allocated(sfc1 )) deallocate(sfc1 ) - allocate(sfc1(dim(dim_id(1)),dim(dim_id(2))) ) + allocate(sfc1(nx,ny_layout_len(nio)) ) iret=nf90_get_var(gfile_loc_layout(nio),k,sfc1) sfc_fulldomain(:,ny_layout_b(nio):ny_layout_e(nio))=sfc1 enddo else - iret=nf90_inquire_variable(gfile_loc,k,dimids=dim_id) - allocate(sfc1(dim(dim_id(1)),dim(dim_id(2))) ) + if(allocated(sfc1 )) deallocate(sfc1 ) + allocate(sfc1(nx,ny) ) iret=nf90_get_var(gfile_loc,k,sfc1) sfc_fulldomain=sfc1 endif @@ -2040,7 +2031,8 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) end do end do - if(allocated(sfc1) .and. allocated(sfc))deallocate (dim_id,sfc,sfc1,dim) + if(allocated(sfc1) .and. allocated(sfc)) deallocate (sfc,sfc1) + if(allocated(dim)) deallocate (dim) if(allocated(sfc_fulldomain)) deallocate (sfc_fulldomain) endif ! mype @@ -3300,6 +3292,7 @@ subroutine wrfv3_netcdf(fv3filenamegin) call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'q2m',ges_q2m,istatus); ier=ier+istatus call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'t2m',ges_t2m,istatus );ier=ier+istatus endif + if (ier/=0) call die('wrfv3_netcdf','cannot get pointers for fv3 met-fields, ier =',ier) if (laeroana_fv3cmaq) then call GSI_BundleGetPointer ( GSI_ChemGuess_Bundle(it), 'aalj',ges_aalj,istatus );ier=ier+istatus diff --git a/src/gsi/setupdbz.f90 b/src/gsi/setupdbz.f90 index 1e158de9ea..96f0378c52 100644 --- a/src/gsi/setupdbz.f90 +++ b/src/gsi/setupdbz.f90 @@ -426,6 +426,7 @@ subroutine setupdbz(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,radardbz_d if (lobsdiagsave) nreal=nreal+4*miter+1 if (.not.allocated(cdiagbuf)) allocate(cdiagbuf(nobs)) if (.not.allocated(rdiagbuf)) allocate(rdiagbuf(nreal,nobs)) + if(netcdf_diag) call init_netcdf_diag_ end if mm1=mype+1 scale=one @@ -1447,15 +1448,16 @@ subroutine setupdbz(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,radardbz_d ! Release memory of local guess arrays call final_vars_ - ! Write information to diagnostic file - if(radardbz_diagsave .and. ii>0 )then + if(radardbz_diagsave .and. netcdf_diag) call nc_diag_write + if(radardbz_diagsave .and. binary_diag .and. ii>0 )then - if( .not. l_use_dbz_directDA )then + if( .not. l_use_dbz_directDA .and. .not. if_model_dbz )then write(7)'dbz',nchar,nreal,ii,mype,ioff0 write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii) deallocate(cdiagbuf,rdiagbuf) else + write(string,600) jiter 600 format('radardbz_',i2.2) diag_file=trim(dirname) // trim(string) @@ -1779,7 +1781,7 @@ subroutine init_netcdf_diag_ end if call nc_diag_init(diag_conv_file, append=append_diag) - + if (.not. append_diag) then ! don't write headers on append - the module will break? call nc_diag_header("date_time",ianldate ) call nc_diag_header("Number_of_state_vars", nsdim ) From 113e30778a6b4401404507f7d40fe99b60fbc2b6 Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Tue, 28 Mar 2023 11:27:50 -0400 Subject: [PATCH 009/109] Use prod ncio and ncdiag on wcoss2 (#554) **Description** The ncio and ncdiag modules have been promoted from para to prod on WCOSS2. This PR replaces the para load of these modules with prod on WCOSS2. Fixes #554 --- modulefiles/gsi_wcoss2.lua | 9 --------- 1 file changed, 9 deletions(-) diff --git a/modulefiles/gsi_wcoss2.lua b/modulefiles/gsi_wcoss2.lua index 84ffce874a..209af8c8a9 100644 --- a/modulefiles/gsi_wcoss2.lua +++ b/modulefiles/gsi_wcoss2.lua @@ -19,15 +19,6 @@ load(pathJoin("python", python_ver)) load(pathJoin("prod_util", prod_util_ver)) load("gsi_common") -unload("ncio") -unload("ncdiag") - -pushenv("HPC_OPT", "/apps/ops/para/libs") -prepend_path("MODULEPATH", "/apps/ops/para/libs/modulefiles/compiler/intel/19.1.3.304") -prepend_path("MODULEPATH", "/apps/ops/para/libs/modulefiles/mpi/intel/19.1.3.304/cray-mpich/8.1.7") - -load("ncio/1.1.2") -load("ncdiag/1.0.0") pushenv("GSI_BINARY_SOURCE_DIR", "/lfs/h2/emc/global/noscrub/emc.global/FIX/fix/gsi/20221128") From 14ae595af1b03471287d322596d35c0665336e95 Mon Sep 17 00:00:00 2001 From: shoyokota <103961291+shoyokota@users.noreply.github.com> Date: Mon, 3 Apr 2023 21:27:33 +0900 Subject: [PATCH 010/109] GitHub Issue NOAA-EMC/GSI#539 Add options to tune cross-scale/variable/time covariances in EnVar (#542) This PR modifies options (i_ensloccov4{scl,var,tim} -> r_ensloccov4{scl,var,tim}) to tune cross-scale/variable/time covariances in EnVar (https://github.com/NOAA-EMC/GSI/issues/539). Regression tests for global 3dvar/4denvar/4dvar are not completed yet, but for other tests, issues are not found except for "failed the scalability test" and "exceeded maximum allowable hardware memory limit" on Orion. Fixes #539 Co-authored-by: Sho Yokota --- src/gsi/apply_scaledepwgts.f90 | 6 ++--- src/gsi/gsimod.F90 | 31 +++++++++++++---------- src/gsi/hybrid_ensemble_isotropic.F90 | 35 ++++++-------------------- src/gsi/hybrid_ensemble_parameters.f90 | 35 ++++++++++++++++---------- 4 files changed, 50 insertions(+), 57 deletions(-) diff --git a/src/gsi/apply_scaledepwgts.f90 b/src/gsi/apply_scaledepwgts.f90 index 62c455e011..8b93cf0b57 100644 --- a/src/gsi/apply_scaledepwgts.f90 +++ b/src/gsi/apply_scaledepwgts.f90 @@ -47,7 +47,7 @@ subroutine init_mult_spc_wgts(jcap_in) use hybrid_ensemble_parameters,only: use_localization_grid use gridmod,only: use_sp_eqspace use general_specmod, only: general_init_spec_vars - use constants, only: zero,half,one,two,three,rearth,pi + use constants, only: zero,half,one,two,three,rearth,pi,tiny_r_kind use constants, only: rad2deg use mpimod, only: mype use general_sub2grid_mod, only: general_sub2grid_create_info @@ -55,7 +55,7 @@ subroutine init_mult_spc_wgts(jcap_in) use general_sub2grid_mod, only: sub2grid_info use gsi_io, only: verbose use hybrid_ensemble_parameters, only: nsclgrp - use hybrid_ensemble_parameters, only: spc_multwgt,spcwgt_params,i_ensloccov4scl + use hybrid_ensemble_parameters, only: spc_multwgt,spcwgt_params,r_ensloccov4scl implicit none integer(i_kind),intent(in ) :: jcap_in @@ -68,7 +68,7 @@ subroutine init_mult_spc_wgts(jcap_in) integer(i_kind) :: l_sum_spc_weights ! Spectral scale decomposition is differernt between SDL-cross and SDL-nocross - if( i_ensloccov4scl == 1 )then + if( r_ensloccov4scl < tiny_r_kind )then l_sum_spc_weights = 1 else l_sum_spc_weights = 0 diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index a86c20880c..c4317dbd2c 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -151,7 +151,7 @@ module gsimod readin_beta,use_localization_grid,use_gfs_ens,q_hyb_ens,i_en_perts_io, & l_ens_in_diff_time,ensemble_path,ens_fast_read,sst_staticB,limqens, & ntotensgrp,nsclgrp,naensgrp,ngvarloc,ntlevs_ens,naensloc, & - i_ensloccov4tim,i_ensloccov4var,i_ensloccov4scl,l_timloc_opt,& + r_ensloccov4tim,r_ensloccov4var,r_ensloccov4scl,l_timloc_opt,& vdl_scale,vloc_varlist,& global_spectral_filter_sd,assign_vdl_nml,parallelization_over_ensmembers use hybrid_ensemble_parameters,only : l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar,weight_ens_gfs,weight_ens_fv3sar @@ -1368,23 +1368,28 @@ module gsimod ! l_timloc_opt - if true, then turn on time-dependent localization ! ngvarloc - number of variable-dependent localization lengths ! naensloc - total number of spatial localization lengths and scale separation lengths (should be naensgrp+nsclgrp-1) -! i_ensloccov4tim - flag of cross-temporal localization -! =0: cross-temporal covariance is retained -! =1: cross-temporal covariance is zero -! i_ensloccov4var - flag of cross-variable localization -! =0: cross-variable covariance is retained -! =1: cross-variable covariance is zero -! i_ensloccov4scl - flag of cross-scale localization -! =0: cross-scale covariance is retained -! =1: cross-scale covariance is zero -! +! r_ensloccov4tim - factor multiplying to cross-time covariance +! For example, +! =0.0: cross-time covariance is decreased to zero +! =0.5: cross-time covariance is decreased to half +! =1.0: cross-time covariance is retained +! r_ensloccov4var - factor multiplying to cross-variable covariance +! For example, +! =0.0: cross-variable covariance is decreased to zero +! =0.5: cross-variable covariance is decreased to half +! =1.0: cross-variable covariance is retained +! r_ensloccov4scl - factor multiplying to cross-scale covariance +! For example, +! =0.0: cross-scale covariance is decreased to zero +! =0.5: cross-scale covariance is decreased to half +! =1.0: cross-scale covariance is retained ! global_spectral_filter_sd - if true, use spectral filter function for ! scale decomposition in the global application (Huang et al. 2021) ! assign_vdl_nml - if true, vdl_scale, and vloc_varlist will be used for ! assigning variable-dependent localization upon SDL in gsiparm.anl. ! This method described in (Wang and Wang 2022, JAMES) is ! equivalent to, but different from the method associated -! with the parameter i_ensloccov4var. +! with the parameter r_ensloccov4var. ! vloc_varlist - list of control variables using the same localization length, ! effective only with assign_vdl_nml=.true. For example, ! vloc_varlist(1,:) = 'sf','vp','ps','t', @@ -1415,7 +1420,7 @@ module gsimod grid_ratio_ens, & oz_univ_static,write_ens_sprd,use_localization_grid,use_gfs_ens, & i_en_perts_io,l_ens_in_diff_time,ensemble_path,ens_fast_read,sst_staticB,limqens, & - nsclgrp,l_timloc_opt,ngvarloc,naensloc,i_ensloccov4tim,i_ensloccov4var,i_ensloccov4scl,& + nsclgrp,l_timloc_opt,ngvarloc,naensloc,r_ensloccov4tim,r_ensloccov4var,r_ensloccov4scl,& vdl_scale,vloc_varlist,& global_spectral_filter_sd,assign_vdl_nml,parallelization_over_ensmembers diff --git a/src/gsi/hybrid_ensemble_isotropic.F90 b/src/gsi/hybrid_ensemble_isotropic.F90 index 7e74b3ec27..7b133ffb5a 100644 --- a/src/gsi/hybrid_ensemble_isotropic.F90 +++ b/src/gsi/hybrid_ensemble_isotropic.F90 @@ -5553,7 +5553,7 @@ subroutine setup_ensgrp2aensgrp ! !$$$ end documentation block use constants, only: zero,one - use hybrid_ensemble_parameters, only: l_timloc_opt,i_ensloccov4tim,i_ensloccov4var,i_ensloccov4scl + use hybrid_ensemble_parameters, only: l_timloc_opt,r_ensloccov4tim,r_ensloccov4var,r_ensloccov4scl use hybrid_ensemble_parameters, only: ensloccov4tim,ensloccov4var,ensloccov4scl use hybrid_ensemble_parameters, only: ntotensgrp,naensgrp,ntlevs_ens,nsclgrp,ngvarloc use hybrid_ensemble_parameters, only: ensgrp2aensgrp @@ -5596,33 +5596,12 @@ subroutine setup_ensgrp2aensgrp enddo enddo - if (i_ensloccov4tim==0) then - ensloccov4tim=one - elseif (i_ensloccov4tim==1)then - ensloccov4tim=zero - ensloccov4tim(1)=one - else - write(6,*)'setup_ensgrp2aensgrp: wrong i_ensloccov4tim' - call stop2(666) - endif - if (i_ensloccov4var==0) then - ensloccov4var=one - elseif (i_ensloccov4var==1)then - ensloccov4var=zero - ensloccov4var(1)=one - else - write(6,*)'setup_ensgrp2aensgrp: wrong i_ensloccov4var' - call stop2(666) - endif - if (i_ensloccov4scl==0) then - ensloccov4scl=one - elseif (i_ensloccov4scl==1)then - ensloccov4scl=zero - ensloccov4scl(1)=one - else - write(6,*)'setup_ensgrp2aensgrp: wrong i_ensloccov4scl' - call stop2(666) - endif + ensloccov4tim=r_ensloccov4tim + ensloccov4tim(1)=one + ensloccov4var=r_ensloccov4var + ensloccov4var(1)=one + ensloccov4scl=r_ensloccov4scl + ensloccov4scl(1)=one do itim2=1,ntimloc do itim1=1,ntimloc diff --git a/src/gsi/hybrid_ensemble_parameters.f90 b/src/gsi/hybrid_ensemble_parameters.f90 index d813541c7a..342dead615 100644 --- a/src/gsi/hybrid_ensemble_parameters.f90 +++ b/src/gsi/hybrid_ensemble_parameters.f90 @@ -134,15 +134,21 @@ module hybrid_ensemble_parameters ! l_timloc_opt: if true, then turn on time-dependent localization ! ngvarloc: number of variable-dependent localization lengths ! naensloc: total number of spatial localization lengths and scale separation lengths (should be naensgrp+nsclgrp-1) -! i_ensloccov4tim: flag of cross-temporal localization -! =0: cross-temporal covariance is retained -! =1: cross-temporal covariance is zero -! i_ensloccov4var: flag of cross-variable localization -! =0: cross-variable covariance is retained -! =1: cross-variable covariance is zero -! i_ensloccov4scl: flag of cross-scale localization -! =0: cross-scale covariance is retained -! =1: cross-scale covariance is zero +! r_ensloccov4tim: factor multiplying to cross-time covariance +! For example, +! =0.0: cross-time covariance is decreased to zero +! =0.5: cross-time covariance is decreased to half +! =1.0: cross-time covariance is retained +! r_ensloccov4var: factor multiplying to cross-variable covariance +! For example, +! =0.0: cross-variable covariance is decreased to zero +! =0.5: cross-variable covariance is decreased to half +! =1.0: cross-variable covariance is retained +! r_ensloccov4scl: factor multiplying to cross-scale covariance +! For example, +! =0.0: cross-scale covariance is decreased to zero +! =0.5: cross-scale covariance is decreased to half +! =1.0: cross-scale covariance is retained !===================================================================================================== ! ! @@ -326,7 +332,7 @@ module hybrid_ensemble_parameters public :: ensloccov4tim,ensloccov4var,ensloccov4scl public :: alphacvarsclgrpmat public :: l_timloc_opt - public :: i_ensloccov4tim,i_ensloccov4var,i_ensloccov4scl + public :: r_ensloccov4tim,r_ensloccov4var,r_ensloccov4scl public :: idaen3d,idaen2d public :: ens_fast_read public :: parallelization_over_ensmembers @@ -395,9 +401,9 @@ module hybrid_ensemble_parameters integer(i_kind) :: ntotensgrp=1 integer(i_kind) :: naensloc=1 integer(i_kind) :: ngvarloc=1 - integer(i_kind) :: i_ensloccov4tim=0 - integer(i_kind) :: i_ensloccov4var=0 - integer(i_kind) :: i_ensloccov4scl=0 + real(r_kind) :: r_ensloccov4tim + real(r_kind) :: r_ensloccov4var + real(r_kind) :: r_ensloccov4scl integer(i_kind),allocatable,dimension(:) :: idaen3d,idaen2d real(r_kind),allocatable,dimension(:,:) :: spc_multwgt @@ -501,6 +507,9 @@ subroutine init_hybrid_ensemble_parameters n_ens_fv3sar=0 weight_ens_gfs=one weight_ens_fv3sar=one + r_ensloccov4tim=one + r_ensloccov4var=one + r_ensloccov4scl=one vdl_scale = 0 vloc_varlist = 'aaa' global_spectral_filter_sd=.false. From 1661c15183a388742d67baf70621c93773f5830f Mon Sep 17 00:00:00 2001 From: jderber-NOAA <75998838+jderber-NOAA@users.noreply.github.com> Date: Fri, 14 Apr 2023 18:22:00 -0400 Subject: [PATCH 011/109] Fix write_incr (#559) --- src/gsi/write_incr.f90 | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/src/gsi/write_incr.f90 b/src/gsi/write_incr.f90 index e312199998..b22be8de30 100644 --- a/src/gsi/write_incr.f90 +++ b/src/gsi/write_incr.f90 @@ -76,6 +76,7 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) use general_sub2grid_mod, only: sub2grid_info use gsi_bundlemod, only: gsi_bundle, gsi_bundlegetpointer + use gsi_bundlemod, only: assignment(=) use control_vectors, only: control_vector use constants, only: one, rad2deg, r1000 @@ -158,7 +159,6 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) ! set up state space based off of xhatsave ! Convert from control space directly to physical ! space for comparison with obs. - call allocate_preds(sbiasinc) do iii=1,nobs_bins call allocate_state(svalinc(iii)) end do @@ -168,7 +168,10 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) do iii=1,ntlevs_ens call allocate_state(evalinc(iii)) end do + + call allocate_preds(sbiasinc) call control2state(xhatsave,mvalinc,sbiasinc) + call deallocate_preds(sbiasinc) if (l4dvar) then if (l_hyb_ens) then @@ -193,6 +196,12 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) end do end if end if + do iii=1,ntlevs_ens + call deallocate_state(evalinc(iii)) + end do + do iii=1,nsubwin + call deallocate_state(mvalinc(iii)) + end do ! Check hydrometeors in control variables iql = getindex(svars3d,'ql') @@ -527,6 +536,10 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) endif ! ! cleanup and exit call nccheck_incr(nf90_close(ncid_out)) + deallocate(out3d) + do iii=1,nobs_bins + call deallocate_state(svalinc(iii)) + end do if ( mype == mype_out ) then write(6,*) "FV3 netCDF increment written, file= "//trim(filename)//".nc" end if From 48ea34a9afbcec7b41e44dcd3cdf656bc1d49503 Mon Sep 17 00:00:00 2001 From: jderber-NOAA <75998838+jderber-NOAA@users.noreply.github.com> Date: Tue, 9 May 2023 13:10:46 -0400 Subject: [PATCH 012/109] Optimize GSI (#527) --- src/gsi/adjtest.f90 | 30 +- src/gsi/adjtest_obs.f90 | 1 + src/gsi/aeroinfo.f90 | 8 +- src/gsi/atms_spatial_average_mod.f90 | 2 +- src/gsi/bicg.f90 | 10 +- src/gsi/bicglanczos.F90 | 11 +- src/gsi/bkerror.f90 | 7 +- src/gsi/calctends_no_tl.f90 | 13 +- src/gsi/compact_diffs.f90 | 62 +- src/gsi/constants.f90 | 2 +- src/gsi/control2state.f90 | 646 +++++++-- src/gsi/control2state_ad.f90 | 441 ------ src/gsi/control_vectors.f90 | 55 +- src/gsi/convthin.f90 | 94 +- src/gsi/convthin_time.f90 | 114 +- src/gsi/correlated_obsmod.F90 | 99 +- src/gsi/cplr_gfs_ensmod.f90 | 462 +++---- src/gsi/cplr_gfs_nstmod.f90 | 262 ++-- src/gsi/cwhydromod.f90 | 73 +- src/gsi/deter_sfc_mod.f90 | 7 +- src/gsi/evaljgrad.f90 | 2 + src/gsi/genqsat.f90 | 6 +- src/gsi/get_gefs_ensperts_dualres.f90 | 134 +- src/gsi/getsiga.f90 | 1 + src/gsi/gridmod.F90 | 11 +- src/gsi/gsi_files.cmake | 1 - src/gsi/gsimod.F90 | 2 +- src/gsi/hybrid_ensemble_isotropic.F90 | 12 +- src/gsi/intall.f90 | 41 +- src/gsi/intgps.f90 | 19 +- src/gsi/intjcmod.f90 | 19 +- src/gsi/intjo.f90 | 3 - src/gsi/intrad.f90 | 226 ++-- src/gsi/intsst.f90 | 38 +- src/gsi/intt.f90 | 61 +- src/gsi/jgrad.f90 | 1 + src/gsi/lightinfo.f90 | 12 +- src/gsi/m_radNode.F90 | 7 +- src/gsi/ncepgfs_io.f90 | 4 +- src/gsi/obs_sensitivity.f90 | 1 + src/gsi/obsmod.F90 | 6 +- src/gsi/pcgsoi.f90 | 92 +- src/gsi/pvqc.f90 | 4 +- src/gsi/q_diag.f90 | 4 +- src/gsi/qcmod.f90 | 124 +- src/gsi/radinfo.f90 | 2 +- src/gsi/read_atms.f90 | 4 +- src/gsi/read_bufrtovs.f90 | 29 +- src/gsi/read_gps.f90 | 6 +- src/gsi/read_iasi.f90 | 67 +- src/gsi/read_obs.F90 | 15 +- src/gsi/read_satwnd.f90 | 2 +- src/gsi/setupcldtot.F90 | 2 +- src/gsi/setuppcp.f90 | 3 +- src/gsi/setuprad.f90 | 391 +++--- src/gsi/state_vectors.f90 | 99 +- src/gsi/statsconv.f90 | 1801 +++++++++++++------------ src/gsi/statslight.f90 | 70 +- src/gsi/statsrad.f90 | 8 +- src/gsi/stpcalc.f90 | 363 +++-- src/gsi/stpgps.f90 | 42 +- src/gsi/stpjo.f90 | 3 - src/gsi/stprad.f90 | 278 ++-- src/gsi/stpsst.f90 | 17 +- src/gsi/stpt.f90 | 19 +- src/gsi/vqc_int.f90 | 4 +- src/gsi/vqc_stp.f90 | 2 +- src/gsi/write_incr.f90 | 4 +- src/gsi/xhat_vordivmod.f90 | 14 +- 69 files changed, 3192 insertions(+), 3283 deletions(-) delete mode 100644 src/gsi/control2state_ad.f90 diff --git a/src/gsi/adjtest.f90 b/src/gsi/adjtest.f90 index d910d14f12..e1a5da7d07 100644 --- a/src/gsi/adjtest.f90 +++ b/src/gsi/adjtest.f90 @@ -33,10 +33,12 @@ module adjtest use control_vectors, only: control_vector,allocate_cv,random_cv, & deallocate_cv,dot_product,assignment(=) use state_vectors, only: allocate_state,deallocate_state,dot_product +use gridmod, only : minmype use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: assignment(=) use bias_predictors, only: predictors,allocate_preds,deallocate_preds, & assignment(=) +use control2state_mod, only: control2state,c2sset,control2state_ad implicit none private @@ -81,7 +83,7 @@ subroutine adtest(xhat) integer(i_kind) :: ii,idig real(r_kind) :: zz1,zz2,zz3 -if (mype==0) write(6,*)'ADTEST starting' +if (mype==minmype) write(6,*)'ADTEST starting' ! ---------------------------------------------------------------------- ! Allocate local variables @@ -97,10 +99,10 @@ subroutine adtest(xhat) ! Initialize control space vectors if (present(xhat)) then xtest1=xhat - if (mype==0) write(6,*)'ADTEST use input xhat' + if (mype==minmype) write(6,*)'ADTEST use input xhat' else call random_cv(xtest1) - if (mype==0) write(6,*)'ADTEST use random_cv(xhat)' + if (mype==minmype) write(6,*)'ADTEST use random_cv(xhat)' endif xtest2=zero @@ -135,18 +137,20 @@ subroutine adtest(xhat) do ii=1,nsubwin zz2=zz2+dot_product(stest1(ii),stest1(ii)) enddo -DO ii=1,nrclen +do ii=1,nrclen zz2=zz2+sbias1%values(ii)*sbias1%values(ii) -ENDDO +enddo -if ( abs(zz1+zz2) > sqrt(tiny(zz3)) ) then - zz3=two*abs(zz1-zz2)/(zz1+zz2) -else - zz3=abs(zz1-zz2) -endif -idig= int(-log(zz3+tiny(zz3))/log(10.0_r_kind)) +if (mype==minmype) then + if ( abs(zz1+zz2) > sqrt(tiny(zz3)) ) then + zz3=two*abs(zz1-zz2)/(zz1+zz2) + else + zz3=abs(zz1-zz2) + end if + idig= int(-log(zz3+tiny(zz3))/log(10.0_r_kind)) -if (mype==0) then +! Note that this result is not completely correct especially on processors +! other than minmype. See issue 548. write(6,'(A)')' ADTEST 0.123456789012345678' write(6,'(A,ES25.18)')' ADTEST = ',zz1 write(6,'(A,ES25.18)')' ADTEST = ',zz2 @@ -166,7 +170,7 @@ subroutine adtest(xhat) call deallocate_preds(sbias2) ! ---------------------------------------------------------------------- -if (mype==0) write(6,*)'ADTEST finished' +if (mype==minmype) write(6,*)'ADTEST finished' return end subroutine adtest diff --git a/src/gsi/adjtest_obs.f90 b/src/gsi/adjtest_obs.f90 index 67e2ff0cdd..294dc32ca0 100644 --- a/src/gsi/adjtest_obs.f90 +++ b/src/gsi/adjtest_obs.f90 @@ -78,6 +78,7 @@ subroutine adtest_obs use m_obsdiags, only: obsLLists use m_obsLList, only: obsLList_getTLDdotprod + use control2state_mod, only: control2state implicit none diff --git a/src/gsi/aeroinfo.f90 b/src/gsi/aeroinfo.f90 index dd8489029b..a030bdeffc 100644 --- a/src/gsi/aeroinfo.f90 +++ b/src/gsi/aeroinfo.f90 @@ -313,12 +313,10 @@ subroutine aeroinfo_read ! Successful read, return to calling routine else -! File does not exist, write warning message to alert users +! File does not exist, write warning message to unit 6 to alert users if (mype==mype_aero) then - open(iout_aero) - write(iout_aero,*)'AEROINFO_READ: ***WARNING*** FILE ',trim(fname),' does not exist' - write(iout_aero,*)'AEROINFO_READ: jpch_aero=',jpch_aero - close(iout_aero) + write(6,*)'AEROINFO_READ: ***WARNING*** FILE ',trim(fname),' does not exist' + write(6,*)'AEROINFO_READ: jpch_aero=',jpch_aero endif end if diff --git a/src/gsi/atms_spatial_average_mod.f90 b/src/gsi/atms_spatial_average_mod.f90 index dd05faa23e..b3e4aafc41 100644 --- a/src/gsi/atms_spatial_average_mod.f90 +++ b/src/gsi/atms_spatial_average_mod.f90 @@ -153,7 +153,7 @@ SUBROUTINE ATMS_Spatial_Average(Num_Obs, NChanl, FOV, Time, BT_InOut, & Scanline_Back(FOV(I),Scanline(I))=I END DO -!$omp parallel do schedule(dynamic,1) private(ichan,iscan,ios,ifov) +!$omp parallel do schedule(dynamic,1) private(i,ichan,iscan,ios,ifov) DO IChan=1,nchanl err(ichan)=0 diff --git a/src/gsi/bicg.f90 b/src/gsi/bicg.f90 index 6eb2f78905..d7ac743d8f 100644 --- a/src/gsi/bicg.f90 +++ b/src/gsi/bicg.f90 @@ -30,7 +30,7 @@ subroutine bicg() use kinds, only: r_kind,i_kind,r_quad use gsi_4dvar, only: l4dvar, & - ladtest, lgrtest, lanczosave, ltcost, nwrvecs + ladtest, lgrtest, lanczosave, ltcost, nwrvecs, lsqrtb use jfunc, only: jiter,miter,niter,xhatsave,yhatsave,jiterstart use constants, only: zero,tiny_r_kind use mpimod, only: mype @@ -39,6 +39,7 @@ subroutine bicg() use obsmod, only: lsaveobsens,l_do_adjoint use adjtest, only: adtest use grdtest, only: grtest +use gsi_bundlemod, only : gsi_bundlegetpointer use control_vectors, only: control_vector use control_vectors, only: allocate_cv,deallocate_cv,write_cv,inquire_cv use control_vectors, only: dot_product,assignment(=) @@ -89,6 +90,13 @@ subroutine bicg() call allocate_cv(gradf) call allocate_cv(grads) +if(l_hyb_ens .and. .not. aniso_a_en) then + if (lsqrtb) then + write(6,*)'l_hyb_ens: not for use with lsqrtb' + call stop2(317) + end if +end if + ! Get initial cost function and gradient nprt=2 diff --git a/src/gsi/bicglanczos.F90 b/src/gsi/bicglanczos.F90 index 1914b0214d..13525e38cb 100755 --- a/src/gsi/bicglanczos.F90 +++ b/src/gsi/bicglanczos.F90 @@ -57,13 +57,14 @@ module bicglanczos use constants, only : zero, one, half,two, zero_quad,tiny_r_kind use timermod , only : timer_ini, timer_fnl use lanczos , only : save_precond -use gsi_4dvar, only : iorthomax +use gsi_4dvar, only : iorthomax,lsqrtb use control_vectors, only: control_vector use control_vectors, only: allocate_cv,deallocate_cv,inquire_cv use control_vectors, only: read_cv,write_cv use control_vectors, only: dot_product,assignment(=) use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: assignment(=) +use gsi_bundlemod, only : gsi_bundlegetpointer use mpimod , only : mpi_comm_world use mpimod, only: mype use jfunc , only : iter, jiter @@ -248,7 +249,13 @@ subroutine pcglanczos(xhat,yhat,pcost,gradx,grady,preduc,kmaxit,lsavevecs) if(nprt>=1.and.ltcost_) call allocate_cv(gradf) call allocate_cv(dirw) -!--- 'zeta' is an upper bound on the relative error of the gradient. +if(l_hyb_ens .and. .not. aniso_a_en) then + if (lsqrtb) then + write(6,*)'l_hyb_ens: not for use with lsqrtb' + call stop2(317) + end if +end if + !--- 'zeta' is an upper bound on the relative error of the gradient. zeta = 1.0e-4_r_kind zreqrd = preduc diff --git a/src/gsi/bkerror.f90 b/src/gsi/bkerror.f90 index b3a0140691..7eb83b09d6 100644 --- a/src/gsi/bkerror.f90 +++ b/src/gsi/bkerror.f90 @@ -71,7 +71,6 @@ subroutine bkerror(grady) ! Declare local variables integer(i_kind) i,ii - integer(i_kind) i_t,i_p,i_st,i_vp integer(i_kind) ipnts(4),istatus ! integer(i_kind) nval_lenz,ndim2d real(r_kind),pointer,dimension(:,:,:):: p_t =>NULL() @@ -97,11 +96,7 @@ subroutine bkerror(grady) ! Only need to get pointer for ii=1 - all other are the same call gsi_bundlegetpointer ( grady%step(1), (/'t ','sf','vp','ps'/), & ipnts, istatus ) - i_t = ipnts(1) - i_st = ipnts(2) - i_vp = ipnts(3) - i_p = ipnts(4) - dobal = i_t>0.and.i_p>0.and.i_st>0.and.i_vp>0 + dobal = ipnts(1)>0 .and. ipnts(2)>0 .and. ipnts(3)>0 .and. ipnts(4)>0 ! if ensemble run, multiply by sqrt_beta_s if(l_hyb_ens) call sqrt_beta_s_mult(grady) diff --git a/src/gsi/calctends_no_tl.f90 b/src/gsi/calctends_no_tl.f90 index 73be86be2e..d4dacb94a5 100644 --- a/src/gsi/calctends_no_tl.f90 +++ b/src/gsi/calctends_no_tl.f90 @@ -244,28 +244,21 @@ subroutine calctends_no_tl(st,vp,t,p,mype,u_t,v_t,t_t,p_t,uvflag) end if end if -! top/bottom boundary condition: do j=jtstart(kk),jtstop(kk) do i=1,lat2 + +! top/bottom boundary condition: + what(i,j,1)=zero what(i,j,nsig+1)=zero - enddo - enddo - ! load actual dp/dt - do j=jtstart(kk),jtstop(kk) - do i=1,lat2 p_t(i,j)=prsth(i,j,1) - end do - end do ! before big k loop, zero out the km1 summation arrays - do j=jtstart(kk),jtstop(kk) - do i=1,lat2 sumkm1 (i,j)=zero sum2km1 (i,j)=zero sumvkm1 (i,j)=zero diff --git a/src/gsi/compact_diffs.f90 b/src/gsi/compact_diffs.f90 index 14f7b8fdc5..ae03407917 100644 --- a/src/gsi/compact_diffs.f90 +++ b/src/gsi/compact_diffs.f90 @@ -268,7 +268,6 @@ subroutine stvp2uv(work,idim) integer(i_kind) ix,iy integer(i_kind) ny,i,j real(r_kind) polsu,polnu,polnv,polsv - real(r_kind),dimension(nlon):: grid3n,grid3s,grid1n,grid1s real(r_kind),dimension(nlat-2,nlon):: a,b,grid1,grid2,grid3,grid4 if(idim <=1) write(6,*) ' error in call to stvp2uv ',idim @@ -318,27 +317,17 @@ subroutine stvp2uv(work,idim) polnv=polnv/float(nlon) polsu=polsu/float(nlon) polsv=polsv/float(nlon) - do ix=1,nlon - grid3n(ix)= polnu*coslon(ix)+polnv*sinlon(ix) - grid1n(ix)=-polnu*sinlon(ix)+polnv*coslon(ix) - grid3s(ix)= polsu*coslon(ix)+polsv*sinlon(ix) - grid1s(ix)= polsu*sinlon(ix)-polsv*coslon(ix) - end do ! work(1 is u, work(2 is v do j=1,nlon - do i=1,nlat - if(i /= 1 .and. i /= nlat)then - work(1,i,j)=grid3(i-1,j) - work(2,i,j)=grid1(i-1,j) - else if(i == 1)then - work(1,i,j)=grid3s(j) - work(2,i,j)=grid1s(j) - else - work(1,i,j)=grid3n(j) - work(2,i,j)=grid1n(j) - end if + do i=2,nlat-1 + work(1,i,j)=grid3(i-1,j) + work(2,i,j)=grid1(i-1,j) end do - enddo + work(1,1,j)= polsu*coslon(j)+polsv*sinlon(j) + work(2,1,j)= polsu*sinlon(j)-polsv*coslon(j) + work(1,nlat,j)= polnu*coslon(j)+polnv*sinlon(j) + work(2,nlat,j)= -polnu*sinlon(j)+polnv*coslon(j) + end do return end subroutine stvp2uv @@ -749,18 +738,14 @@ subroutine tstvp2uv(work,idim) ny=nlat-2 do j=1,nlon - do i=1,nlat - if(i /= 1 .and. i /= nlat)then - grid3(i-1,j)=work(1,i,j) - grid1(i-1,j)=work(2,i,j) - else if(i == 1)then - grid3s(j)=work(1,i,j) - grid1s(j)=work(2,i,j) - else - grid3n(j)=work(1,i,j) - grid1n(j)=work(2,i,j) - end if + do i=2,nlat-1 + grid3(i-1,j)=work(1,i,j) + grid1(i-1,j)=work(2,i,j) end do + grid3s(j)=work(1,1,j) + grid1s(j)=work(2,1,j) + grid3n(j)=work(1,nlat,j) + grid1n(j)=work(2,nlat,j) end do polnu=zero @@ -815,16 +800,15 @@ subroutine tstvp2uv(work,idim) nlon,ny,noq) !$omp end parallel sections do j=1,nlon - do i=1,nlat - if(i /= 1 .and. i /= nlat)then -! NOTE: Adjoint of first derivative is its negative - work(1,i,j)=-(a(i-1,j)+d(i-1,j)) - work(2,i,j)=-(b(i-1,j)+c(i-1,j)) - else - work(1,i,j)=zero - work(2,i,j)=zero - end if + do i=2,nlat-1 +! NOTE: Adjoint of first derivative is its negative + work(1,i,j)=-(a(i-1,j)+d(i-1,j)) + work(2,i,j)=-(b(i-1,j)+c(i-1,j)) end do + work(1,1,j)=zero + work(2,1,j)=zero + work(1,nlat,j)=zero + work(2,nlat,j)=zero end do return diff --git a/src/gsi/constants.f90 b/src/gsi/constants.f90 index 484e46b8b8..b4cf775068 100644 --- a/src/gsi/constants.f90 +++ b/src/gsi/constants.f90 @@ -90,7 +90,7 @@ module constants ! Declare derived constants integer(i_kind):: huge_i_kind - integer(i_kind), parameter :: max_varname_length=64 + integer(i_kind), parameter :: max_varname_length=20 real(r_single):: tiny_single, huge_single real(r_kind):: xai, xa, xbi, xb, dldt, rozcon,ozcon,fv, tpwcon,eps, rd_over_g real(r_kind):: el2orc, g_over_rd, rd_over_cp, cpr, omeps, epsm1, factor2 diff --git a/src/gsi/control2state.f90 b/src/gsi/control2state.f90 index fb87c1d0ef..f2d8849ce0 100644 --- a/src/gsi/control2state.f90 +++ b/src/gsi/control2state.f90 @@ -1,3 +1,65 @@ +!------------------------------------------------------------------------- +! NOAA/NCEP, National Centers for Environmental Prediction GSI ! +!------------------------------------------------------------------------- +!BOP +! +! !MODULE: control2state_mod --- control2state_mod variables and routines +! +! !INTERFACE: +! +module control2state_mod + +! !USES: + + +! !DESCRIPTION: module control2state routines and variables + +use kinds, only: r_kind,i_kind +use constants, only : max_varname_length, zero +use control_vectors, only: control_vector,c2sset_flg +use control_vectors, only: cvars3d,cvars2d +use bias_predictors, only: predictors +use jfunc, only: nsclen,npclen,ntclen +use gsi_4dvar, only: nsubwin, l4dvar, lsqrtb,ladtest_obs +use gsi_chemguess_mod, only: gsi_chemguess_get +use gsi_metguess_mod, only: gsi_metguess_get +use gsi_bundlemod, only: gsi_bundlegetpointer +use gsi_bundlemod, only: gsi_bundlecreate +use gsi_bundlemod, only: gsi_bundle +use gsi_bundlemod, only: gsi_bundlegetvar +use gsi_bundlemod, only: gsi_bundleputvar +use gsi_bundlemod, only: gsi_bundledestroy +use gsi_bundlemod, only: assignment(=) +use gridmod, only: nems_nmmb_regional +use gridmod, only: regional, twodvar_regional +use gridmod, only: lat2,lon2,nsig,nlat,nlon +use chemmod, only: laeroana_fv3cmaq, naero_cmaq_fv3,aeronames_cmaq_fv3,imodes_cmaq_fv3,icvt_cmaq_fv3 +use mpeu_util, only: getindex + +implicit none + +private +public :: do_getprs,do_normal_rh_to_q,do_tv_to_tsen,do_getuv,do_cw_to_hydro +public :: do_cw_to_hydro_hwrf,nclouds,ngases +public :: control2state +public :: control2state_ad +public :: c2sset +public :: icpblh,icgust,icvis,icoz,icwspd10m,icw +public :: ictd2m,icmxtm,icmitm,icpmsl,ichowv +public :: icsfwter,icvpwter,ictcamt,iclcbas +public :: iccldch,icuwnd10m,icvwnd10m + +logical :: do_getprs,do_normal_rh_to_q,do_tv_to_tsen,do_getuv,do_cw_to_hydro +logical :: do_cw_to_hydro_hwrf + +integer(i_kind) :: icpblh,icgust,icvis,icoz,icwspd10m,icw +integer(i_kind) :: ictd2m,icmxtm,icmitm,icpmsl,ichowv +integer(i_kind) :: icsfwter,icvpwter,ictcamt,iclcbas +integer(i_kind) :: iccldch,icuwnd10m,icvwnd10m + +integer :: ngases,nclouds + +contains subroutine control2state(xhat,sval,bval) !$$$ subprogram documentation block ! . . . . @@ -57,31 +119,11 @@ subroutine control2state(xhat,sval,bval) ! bval - Bias predictors ! !$$$ end documentation block -use kinds, only: r_kind,i_kind -use control_vectors, only: control_vector -use control_vectors, only: cvars3d,cvars2d -use bias_predictors, only: predictors -use gsi_4dvar, only: nsubwin, l4dvar, lsqrtb, ladtest_obs -use gridmod, only: regional,lat2,lon2,nsig, nlat, nlon, twodvar_regional -use jfunc, only: nsclen,npclen,ntclen -use cwhydromod, only: cw2hydro_tl use amassaeromod, only: amass2aero_tl -use cwhydromod, only: cw2hydro_tl_hwrf -use gsi_bundlemod, only: gsi_bundlecreate -use gsi_bundlemod, only: gsi_bundle -use gsi_bundlemod, only: gsi_bundlegetpointer -use gsi_bundlemod, only: gsi_bundlegetvar -use gsi_bundlemod, only: gsi_bundleputvar -use gsi_bundlemod, only: gsi_bundledestroy -use gsi_bundlemod, only: assignment(=) -use gsi_chemguess_mod, only: gsi_chemguess_get -use gsi_metguess_mod, only: gsi_metguess_get -use mpeu_util, only: getindex -use constants, only : max_varname_length, zero use general_sub2grid_mod, only: general_sub2grid,general_grid2sub use general_commvars_mod, only: s2g_cv -use gridmod, only: nems_nmmb_regional -use chemmod, only: laeroana_fv3cmaq, naero_cmaq_fv3,aeronames_cmaq_fv3,imodes_cmaq_fv3,icvt_cmaq_fv3 +use cwhydromod, only: cw2hydro_tl +use cwhydromod, only: cw2hydro_tl_hwrf implicit none ! Declare passed variables @@ -94,22 +136,9 @@ subroutine control2state(xhat,sval,bval) character(len=max_varname_length),allocatable,dimension(:) :: gases character(len=max_varname_length),allocatable,dimension(:) :: clouds real(r_kind),dimension(nlat*nlon*s2g_cv%nlevs_alloc) :: hwork -integer(i_kind) :: ii,jj,ic,id,ngases,nclouds,istatus,istatus_oz +integer(i_kind) :: ii,jj,ic,id,istatus,istatus_oz type(gsi_bundle):: wbundle ! work bundle -! Note: The following does not aim to get all variables in -! the state and control vectors, but rather the ones -! this routines knows how to handle. -! Declare required local control variables -integer(i_kind), parameter :: ncvars = 9 -integer(i_kind) :: icps(ncvars) -integer(i_kind) :: icpblh,icgust,icvis,icoz,icwspd10m,icw -integer(i_kind) :: ictd2m,icmxtm,icmitm,icpmsl,ichowv -integer(i_kind) :: icsfwter,icvpwter,ictcamt,iclcbas -integer(i_kind) :: iccldch,icuwnd10m,icvwnd10m -character(len=3), parameter :: mycvars(ncvars) = (/ & ! vars from CV needed here - 'sf ', 'vp ', 'ps ', 't ', 'q ', 'cw ', 'ql ', 'qi ', 'w ' /) -logical :: lc_sf,lc_vp,lc_w,lc_ps,lc_t,lc_rh,lc_cw,lc_ql,lc_qi real(r_kind),pointer,dimension(:,:) :: cv_ps=>NULL() real(r_kind),pointer,dimension(:,:) :: cv_lcbas=>NULL() real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL() @@ -120,14 +149,6 @@ subroutine control2state(xhat,sval,bval) real(r_kind),pointer,dimension(:,:,:) :: cv_sfwter=>NULL() real(r_kind),pointer,dimension(:,:,:) :: cv_vpwter=>NULL() -! Declare required local state variables -integer(i_kind), parameter :: nsvars = 12 -integer(i_kind) :: isps(nsvars) -character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here - 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ', 'qi ', 'w ', & - 'qr ', 'qs ', 'qg ', 'qh ' /) -logical :: ls_u,ls_v,ls_w,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi -logical :: ls_qr,ls_qs,ls_qg,ls_qh real(r_kind),pointer,dimension(:,:) :: sv_ps=>NULL(),sv_sst=>NULL() real(r_kind),pointer,dimension(:,:) :: sv_gust=>NULL(),sv_vis=>NULL(),sv_pblh=>NULL() real(r_kind),pointer,dimension(:,:) :: sv_wspd10m=>NULL(),sv_tcamt=>NULL(),sv_lcbas=>NULL() @@ -143,82 +164,17 @@ subroutine control2state(xhat,sval,bval) real(r_kind),allocatable,dimension(:,:,:):: uland,vland,uwter,vwter -logical :: do_getprs_tl,do_normal_rh_to_q,do_tv_to_tsen,do_getuv,do_cw_to_hydro -logical :: do_cw_to_hydro_hwrf - - -if (lsqrtb) then - write(6,*)trim(myname),': not for sqrt(B)' - call stop2(106) -end if -if (nsubwin/=1 .and. .not.l4dvar) then - write(6,*)trim(myname),': error 3dvar',nsubwin,l4dvar - call stop2(107) -end if - -! Inquire about cloud-vars -call gsi_metguess_get('clouds::3d',nclouds,istatus) +if (c2sset_flg)call c2sset(xhat,sval) if (nclouds>0) then allocate(clouds(nclouds)) call gsi_metguess_get('clouds::3d',clouds,istatus) end if -! Inquire about chemistry -call gsi_chemguess_get('dim',ngases,istatus) if (ngases>0) then allocate(gases(ngases)) call gsi_chemguess_get('gsinames',gases,istatus) endif -! Since each internal vector of xhat has the same structure, pointers are -! the same independent of the subwindow jj -call gsi_bundlegetpointer (xhat%step(1),mycvars,icps,istatus) -lc_sf =icps(1)>0; lc_vp =icps(2)>0; lc_ps =icps(3)>0 -lc_t =icps(4)>0; lc_rh =icps(5)>0; lc_cw =icps(6)>0 -lc_ql =icps(7)>0; lc_qi =icps(8)>0; lc_w =icps(9)>0 - -! Since each internal vector of xhat has the same structure, pointers are -! the same independent of the subwindow jj -call gsi_bundlegetpointer (sval(1),mysvars,isps,istatus) -ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0 -ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0 -ls_qi =isps(7)>0; ls_w =isps(8)>0 -ls_qr =isps(9)>0; ls_qs =isps(10)>0 -ls_qg =isps(11)>0; ls_qh =isps(12)>0 - -! Define what to do depending on what's in CV and SV -do_getprs_tl =lc_ps.and.lc_t .and.ls_prse -do_normal_rh_to_q=lc_rh.and.lc_t .and.ls_prse.and.ls_q -do_tv_to_tsen =lc_t .and.ls_q .and.ls_tsen -do_getuv =lc_sf.and.lc_vp.and.ls_u.and.ls_v - -do_cw_to_hydro=.false. -do_cw_to_hydro_hwrf=.false. -if (regional) then - do_cw_to_hydro=lc_cw.and.ls_ql.and.ls_qi - do_cw_to_hydro_hwrf=lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh -else - do_cw_to_hydro=lc_cw.and.ls_tsen.and.ls_ql.and.ls_qi.and.(.not.lc_ql) !ncep global -endif - -call gsi_bundlegetpointer (xhat%step(1),'oz',icoz,istatus) -call gsi_bundlegetpointer (xhat%step(1),'gust',icgust,istatus) -call gsi_bundlegetpointer (xhat%step(1),'vis',icvis,istatus) -call gsi_bundlegetpointer (xhat%step(1),'pblh',icpblh,istatus) -call gsi_bundlegetpointer (xhat%step(1),'wspd10m',icwspd10m,istatus) -call gsi_bundlegetpointer (xhat%step(1),'td2m',ictd2m,istatus) -call gsi_bundlegetpointer (xhat%step(1),'mxtm',icmxtm,istatus) -call gsi_bundlegetpointer (xhat%step(1),'mitm',icmitm,istatus) -call gsi_bundlegetpointer (xhat%step(1),'pmsl',icpmsl,istatus) -call gsi_bundlegetpointer (xhat%step(1),'howv',ichowv,istatus) -call gsi_bundlegetpointer (xhat%step(1),'sfwter',icsfwter,istatus) -call gsi_bundlegetpointer (xhat%step(1),'vpwter',icvpwter,istatus) -call gsi_bundlegetpointer (xhat%step(1),'w',icw,istatus) -call gsi_bundlegetpointer (xhat%step(1),'tcamt',ictcamt,istatus) -call gsi_bundlegetpointer (xhat%step(1),'lcbas',iclcbas,istatus) -call gsi_bundlegetpointer (xhat%step(1),'cldch',iccldch,istatus) -call gsi_bundlegetpointer (xhat%step(1),'uwnd10m',icuwnd10m,istatus) -call gsi_bundlegetpointer (xhat%step(1),'vwnd10m',icvwnd10m,istatus) ! Loop over control steps do jj=1,nsubwin @@ -295,7 +251,7 @@ subroutine control2state(xhat,sval,bval) ! Copy other variables call gsi_bundlegetvar ( wbundle, 't' , sv_tv, istatus ) ! Get 3d pressure - if(do_getprs_tl) call getprs_tl(cv_ps,cv_t,sv_prse) + if(do_getprs) call getprs_tl(cv_ps,cv_t,sv_prse) ! Convert input normalized RH to q if(do_normal_rh_to_q) call normal_rh_to_q(cv_rh,cv_t,sv_prse,sv_q) @@ -445,3 +401,471 @@ subroutine control2state(xhat,sval,bval) return end subroutine control2state +subroutine c2sset(xhat,sval) +!$$$ subprogram documentation block +! . . . . +! subprogram: c2sset +! prgmmr: derber +! +! abstract: Sets flags for control2state and control2state_ad +! +! program history log: +! 2022-08-30 derber - initial code from control2state + +! input argument list: +! xhat - Control variable +! sval - State variable +! +!$$$ end documentation block +implicit none + +! Declare passed variables +type(control_vector), intent(in) :: xhat +type(gsi_bundle) , intent(in) :: sval(nsubwin) + +! Declare local variables +character(len=*),parameter::myname='c2sset' +integer(i_kind) :: istatus + +! Note: The following does not aim to get all variables in +! the state and control vectors, but rather the ones +! this routines knows how to handle. +! Declare required local control variables +integer(i_kind), parameter :: ncvars = 9 +integer(i_kind) :: icps(ncvars) +character(len=3), parameter :: mycvars(ncvars) = (/ & ! vars from CV needed here + 'sf ', 'vp ', 'ps ', 't ', 'q ', 'cw ', 'ql ', 'qi ', 'w ' /) +logical :: lc_sf,lc_vp,lc_w,lc_ps,lc_t,lc_rh,lc_cw,lc_ql,lc_qi + +! Declare required local state variables +integer(i_kind), parameter :: nsvars = 12 +integer(i_kind) :: isps(nsvars) +character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here + 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ', 'qi ', 'w ', & + 'qr ', 'qs ', 'qg ', 'qh ' /) +logical :: ls_u,ls_v,ls_w,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi +logical :: ls_qr,ls_qs,ls_qg,ls_qh + + + +if (lsqrtb) then + write(6,*)trim(myname),': not for sqrt(B)' + call stop2(106) +end if +if (nsubwin/=1 .and. .not.l4dvar) then + write(6,*)trim(myname),': error 3dvar',nsubwin,l4dvar + call stop2(107) +end if + +! Inquire about cloud-vars +call gsi_metguess_get('clouds::3d',nclouds,istatus) + +! Inquire about chemistry +call gsi_chemguess_get('dim',ngases,istatus) + +! Since each internal vector of xhat has the same structure, pointers are +! the same independent of the subwindow jj +call gsi_bundlegetpointer (xhat%step(1),mycvars,icps,istatus) +lc_sf =icps(1)>0; lc_vp =icps(2)>0; lc_ps =icps(3)>0 +lc_t =icps(4)>0; lc_rh =icps(5)>0; lc_cw =icps(6)>0 +lc_ql =icps(7)>0; lc_qi =icps(8)>0; lc_w =icps(9)>0 + +! Since each internal vector of sval has the same structure, pointers are +! the same independent of the subwindow jj +call gsi_bundlegetpointer (sval(1),mysvars,isps,istatus) +ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0 +ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0 +ls_qi =isps(7)>0; ls_w =isps(8)>0 +ls_qr =isps(9)>0; ls_qs =isps(10)>0 +ls_qg =isps(11)>0; ls_qh =isps(12)>0 + +! Define what to do depending on what's in CV and SV +do_getprs =lc_ps.and.lc_t .and.ls_prse +do_normal_rh_to_q=lc_rh.and.lc_t .and.ls_prse.and.ls_q +do_tv_to_tsen =lc_t .and.ls_q .and.ls_tsen +do_getuv =lc_sf.and.lc_vp.and.ls_u.and.ls_v + +do_cw_to_hydro=.false. +do_cw_to_hydro_hwrf=.false. +if (regional) then + do_cw_to_hydro=lc_cw.and.ls_ql.and.ls_qi + do_cw_to_hydro_hwrf=lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh +else + do_cw_to_hydro=lc_cw.and.ls_tsen.and.ls_ql.and.ls_qi.and.(.not.lc_ql) !ncep global +endif + +call gsi_bundlegetpointer (xhat%step(1),'oz',icoz,istatus) +call gsi_bundlegetpointer (xhat%step(1),'gust',icgust,istatus) +call gsi_bundlegetpointer (xhat%step(1),'vis',icvis,istatus) +call gsi_bundlegetpointer (xhat%step(1),'pblh',icpblh,istatus) +call gsi_bundlegetpointer (xhat%step(1),'wspd10m',icwspd10m,istatus) +call gsi_bundlegetpointer (xhat%step(1),'td2m',ictd2m,istatus) +call gsi_bundlegetpointer (xhat%step(1),'mxtm',icmxtm,istatus) +call gsi_bundlegetpointer (xhat%step(1),'mitm',icmitm,istatus) +call gsi_bundlegetpointer (xhat%step(1),'pmsl',icpmsl,istatus) +call gsi_bundlegetpointer (xhat%step(1),'howv',ichowv,istatus) +call gsi_bundlegetpointer (xhat%step(1),'sfwter',icsfwter,istatus) +call gsi_bundlegetpointer (xhat%step(1),'vpwter',icvpwter,istatus) +call gsi_bundlegetpointer (xhat%step(1),'w',icw,istatus) +call gsi_bundlegetpointer (xhat%step(1),'tcamt',ictcamt,istatus) +call gsi_bundlegetpointer (xhat%step(1),'lcbas',iclcbas,istatus) +call gsi_bundlegetpointer (xhat%step(1),'cldch',iccldch,istatus) +call gsi_bundlegetpointer (xhat%step(1),'uwnd10m',icuwnd10m,istatus) +call gsi_bundlegetpointer (xhat%step(1),'vwnd10m',icvwnd10m,istatus) + +c2sset_flg=.false. +return +end subroutine c2sset +subroutine control2state_ad(rval,bval,grad) +!$$$ subprogram documentation block +! . . . . +! subprogram: control2state_ad +! prgmmr: tremolet +! +! abstract: Converts variables from physical space to control space +! This is also the adjoint of control2state +! +! program history log: +! 2007-04-16 tremolet - initial code +! 2008-11-28 todling - update to GSI May 2008: add tsen and p3d +! 2009-01-15 todling - handle predictors in quad precision +! 2009-04-21 derber - modify call to getstvp to call to getuv +! 2009-06-15 parrish - add call to strong_bk_ad when l_hyb_ens=.true. (hybrid ensemble run) +! 2009-08-12 lueken - update documentation +! 2009-11-27 parrish - for uv_hyb_ens=.true., then ensemble perturbations contain u,v instead of st,vp +! so introduce extra code to handle this case. +! 2010-02-20 parrish - introduce modifications to allow dual resolution capability when running +! in hybrid ensemble mode. +! 2010-03-24 zhu - use cstate for generalizing control variable +! 2010-04-29 todling - update to use gsi_bundle; rename cstate to wbundle +! 2010-05-31 todling - better consistency checks; add co/co2 +! - ready to bypass analysis of (any) meteorological fields +! 2010-06-15 todling - generalized handling of chemistry +! 2011-02-22 zhu - add gust,vis,pblh +! 2011-05-15 auligne/todling - generalized cloud handling +! 2011-07-12 zhu - add do_cw_to_hydro_ad and cw2hydro_ad +! 2011-11-01 eliu - generalize the use of do_cw_to_hydro_ad +! 2012-02-08 kleist - remove strong_bk_ad and ensemble_forward_model_ad and related parameters +! 2013-05-23 zhu - add ntclen and predt for aircraft temperature bias correction +! 2013-10-25 todling - nullify work pointers +! 2013-10-28 todling - rename p3d to prse +! 2014-01-31 mkim - add support for when ql and qi are CVs for all-sky mw radiance DA +! 2014-03-19 pondeca - add wspd10m +! 2014-04-10 pondeca - add td2m,mxtm,mitm,pmsl +! 2014-05-07 pondeca - add howv +! 2014-06-16 carley/zhu - add tcamt and lcbas +! 2014-12-03 derber - introduce parallel regions for optimization +! 2015-07-10 pondeca - add cloud ceiling height (cldch) +! 2016-05-03 pondeca - add uwnd10m, and vwnd10m +! 2017-05-12 Y. Wang and X. Wang - add w as state variable for rw DA, POC: xuguang.wang@ou.edu +! 2016-08-12 lippi - add vertical velocity (w) to mycvars and mysvars. +! 2016-05-03 pondeca - add uwnd10m, and vwnd10m +! 2022-05-24 H.Wang - add amass2aero_ad for regional FV3-CMAQ DA when using +! total mass as control variable. +! +! input argument list: +! rval - State variable +! bval +! output argument list: +! grad - Control variable +! +!$$$ +use amassaeromod, only: amass2aero_ad +use cwhydromod, only: cw2hydro_ad +use cwhydromod, only: cw2hydro_ad_hwrf + +implicit none + +! Declare passed variables +type(gsi_bundle) , intent(inout) :: rval(nsubwin) +type(predictors) , intent(in ) :: bval +type(control_vector), intent(inout) :: grad + +! Declare local variables +character(len=*),parameter::myname='control2state_ad' +character(len=max_varname_length),allocatable,dimension(:) :: gases +character(len=max_varname_length),allocatable,dimension(:) :: clouds +integer(i_kind) :: ii,jj,ic,id,istatus,istatus_oz +type(gsi_bundle) :: wbundle ! work bundle + +real(r_kind),pointer,dimension(:,:) :: cv_ps=>NULL() +real(r_kind),pointer,dimension(:,:) :: cv_lcbas=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: cv_vp=>NULL() +!real(r_kind),pointer,dimension(:,:,:) :: cv_w=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: cv_t=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: cv_rh=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: cv_sfwter=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: cv_vpwter=>NULL() + +! Declare required local state variables +real(r_kind),pointer,dimension(:,:) :: rv_ps=>NULL(),rv_sst=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_gust=>NULL(),rv_vis=>NULL(),rv_pblh=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_wspd10m=>NULL(),rv_tcamt=>NULL(),rv_lcbas=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_td2m=>NULL(),rv_mxtm=>NULL(),rv_mitm=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_pmsl=>NULL(),rv_howv=>NULL(),rv_cldch=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_uwnd10m=>NULL(),rv_vwnd10m=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_u=>NULL(),rv_v=>NULL(),rv_w=>NULL(),rv_dw=>NULL(),rv_prse=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_q=>NULL(),rv_tsen=>NULL(),rv_tv=>NULL(),rv_oz=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_rank3=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_rank2=>NULL() + +real(r_kind),allocatable,dimension(:,:,:):: uland,vland,uwter,vwter + + + +!****************************************************************************** + +if (c2sset_flg)call c2sset(grad,rval) +if (lsqrtb) then + write(6,*)trim(myname),': not for sqrt(B)' + call stop2(311) +end if + +! Inquire about clouds +if (nclouds>0) then + allocate(clouds(nclouds)) + call gsi_metguess_get ('clouds::3d',clouds,istatus) +endif + +! Inquire about chemistry +call gsi_chemguess_get('dim',ngases,istatus) +if (ngases>0) then + allocate(gases(ngases)) + call gsi_chemguess_get('gsinames',gases,istatus) +endif + + +! Loop over control steps +do jj=1,nsubwin + +! Create a work bundle similar to grad control vector's bundle + call gsi_bundlecreate ( wbundle, grad%step(jj), 'control2state_ad work', istatus ) + if (istatus/=0) then + write(6,*) trim(myname),': trouble creating work bundle' + call stop2(999) + endif + +!$omp parallel sections private(istatus,ii,ic,id,istatus_oz,rv_u,rv_v,rv_prse,rv_q,rv_tsen,uland,vland,uwter,vwter) + +!$omp section + + call gsi_bundlegetpointer (wbundle,'sf' ,cv_sf ,istatus) + call gsi_bundlegetpointer (wbundle,'vp' ,cv_vp ,istatus) + call gsi_bundlegetpointer (rval(jj),'u' ,rv_u, istatus) + call gsi_bundlegetpointer (rval(jj),'v' ,rv_v, istatus) + call gsi_bundleputvar ( wbundle, 'sf', zero, istatus ) + call gsi_bundleputvar ( wbundle, 'vp', zero, istatus ) +! Convert RHS calculations for u,v to st/vp for application of +! background error + if (do_getuv) then + if (twodvar_regional .and. icsfwter>0 .and. icvpwter>0) then + call gsi_bundlegetpointer (wbundle,'sfwter', cv_sfwter,istatus) + call gsi_bundlegetpointer (wbundle,'vpwter', cv_vpwter,istatus) + allocate(uland(lat2,lon2,nsig),vland(lat2,lon2,nsig), & + uwter(lat2,lon2,nsig),vwter(lat2,lon2,nsig)) + + uland=zero ; uwter=zero + vland=zero ; vwter=zero + + call landlake_uvmerge(rv_u,rv_v,uland,vland,uwter,vwter,0) + + call getuv(uwter,vwter,cv_sfwter,cv_vpwter,1) + call getuv(uland,vland,cv_sf,cv_vp,1) + deallocate(uland,vland,uwter,vwter) + else + call getuv(rv_u,rv_v,cv_sf,cv_vp,1) + endif + endif + + if(jj == 1)then + do ii=1,nsclen + grad%predr(ii)=bval%predr(ii) + enddo + do ii=1,npclen + grad%predp(ii)=bval%predp(ii) + enddo + if (ntclen>0) then + do ii=1,ntclen + grad%predt(ii)=bval%predt(ii) + enddo + end if + end if + +!$omp section + +! Get pointers to required control variables + call gsi_bundlegetpointer (wbundle,'ps' ,cv_ps ,istatus) + call gsi_bundlegetpointer (wbundle,'t' ,cv_t, istatus) + call gsi_bundlegetpointer (wbundle,'q' ,cv_rh ,istatus) + +! Get pointers to this subwin require state variables + call gsi_bundlegetpointer (rval(jj),'ps' ,rv_ps, istatus) + call gsi_bundlegetpointer (rval(jj),'prse',rv_prse,istatus) + call gsi_bundlegetpointer (rval(jj),'tv' ,rv_tv, istatus) + call gsi_bundlegetpointer (rval(jj),'tsen',rv_tsen,istatus) + call gsi_bundlegetpointer (rval(jj),'q' ,rv_q , istatus) + +! Adjoint of control to initial state + call gsi_bundleputvar ( wbundle, 't' , rv_tv, istatus ) + call gsi_bundleputvar ( wbundle, 'q' , zero, istatus ) + call gsi_bundleputvar ( wbundle, 'ps', rv_ps, istatus ) + + if (do_cw_to_hydro .and. .not.do_cw_to_hydro_hwrf) then +! Case when cloud-vars do not map one-to-one +! e.g. cw-to-ql&qi + call cw2hydro_ad(rval(jj),wbundle,clouds,nclouds) + elseif (do_cw_to_hydro_hwrf) then +! Case when cloud-vars do not map one-to-one +! e.g. cw-to-ql&qi&qr&qs&qg&qh + call cw2hydro_ad_hwrf(rval(jj),wbundle,rv_tsen) + else +! Case when cloud-vars map one-to-one, take care of them together +! e.g. cw-to-cw + do ic=1,nclouds + id=getindex(cvars3d,clouds(ic)) + if (id>0) then + call gsi_bundlegetpointer (rval(jj),clouds(ic),rv_rank3,istatus) + call gsi_bundleputvar (wbundle, clouds(ic),rv_rank3,istatus) + endif + enddo + end if +! Calculate sensible temperature + if(do_tv_to_tsen) call tv_to_tsen_ad(cv_t,rv_q,rv_tsen) + +! Adjoint of convert input normalized RH to q to add contribution of moisture +! to t, p , and normalized rh + if(do_normal_rh_to_q) call normal_rh_to_q_ad(cv_rh,cv_t,rv_prse,rv_q) + +! Adjoint to convert ps to 3-d pressure + if(do_getprs) call getprs_ad(cv_ps,cv_t,rv_prse) + + +!$omp section + + call gsi_bundlegetpointer (rval(jj),'sst' ,rv_sst, istatus) + call gsi_bundleputvar ( wbundle, 'sst', rv_sst, istatus ) + +! call gsi_bundlegetpointer (rval(jj),'oz' ,rv_oz , istatus) + call gsi_bundlegetpointer (rval(jj),'oz' ,rv_oz , istatus_oz) + + if (icoz>0) then + call gsi_bundleputvar ( wbundle, 'oz', rv_oz, istatus ) + else + if(istatus_oz==0) rv_oz=zero + end if + +! Same one-to-one map for chemistry-vars; take care of them together + if (.not.laeroana_fv3cmaq .and. icvt_cmaq_fv3 == 2) then + write(6,*) ' icvt_cmaq_fv3 == 2 but laeroana_fv3cmaq=false stop!!!' + call stop2(999) + endif + + if (icvt_cmaq_fv3 == 2) then + call amass2aero_ad(rval(jj),wbundle,aeronames_cmaq_fv3,naero_cmaq_fv3) + else + do ic=1,ngases + id=getindex(cvars3d,gases(ic)) + if (id>0) then + call gsi_bundlegetpointer (rval(jj),gases(ic),rv_rank3,istatus) + call gsi_bundleputvar (wbundle, gases(ic),rv_rank3,istatus) + endif + + id=getindex(cvars2d,gases(ic)) + if (id>0) then + call gsi_bundlegetpointer (rval(jj),gases(ic),rv_rank2,istatus) + call gsi_bundleputvar (wbundle, gases(ic),rv_rank2,istatus) + endif + enddo + end if + if (icgust>0) then + call gsi_bundlegetpointer (rval(jj),'gust' ,rv_gust, istatus) + call gsi_bundleputvar ( wbundle, 'gust', rv_gust, istatus ) + end if + if (icvis >0) then + call gsi_bundlegetpointer (rval(jj),'vis' ,rv_vis , istatus) + call gsi_bundleputvar ( wbundle, 'vis' , rv_vis , istatus ) + end if + if (icpblh>0)then + call gsi_bundlegetpointer (rval(jj),'pblh' ,rv_pblh, istatus) + call gsi_bundleputvar ( wbundle, 'pblh', rv_pblh, istatus ) + end if + if (icwspd10m>0) then + call gsi_bundlegetpointer (rval(jj),'wspd10m' ,rv_wspd10m, istatus) + call gsi_bundleputvar ( wbundle, 'wspd10m', rv_wspd10m, istatus ) + end if + if (ictd2m>0) then + call gsi_bundlegetpointer (rval(jj),'td2m' ,rv_td2m, istatus) + call gsi_bundleputvar ( wbundle, 'td2m', rv_td2m, istatus ) + end if + if (icmxtm>0) then + call gsi_bundlegetpointer (rval(jj),'mxtm' ,rv_mxtm, istatus) + call gsi_bundleputvar ( wbundle, 'mxtm', rv_mxtm, istatus ) + end if + if (icmitm>0) then + call gsi_bundlegetpointer (rval(jj),'mitm' ,rv_mitm, istatus) + call gsi_bundleputvar ( wbundle, 'mitm', rv_mitm, istatus ) + end if + if (icpmsl>0) then + call gsi_bundlegetpointer (rval(jj),'pmsl' ,rv_pmsl, istatus) + call gsi_bundleputvar ( wbundle, 'pmsl', rv_pmsl, istatus ) + end if + if (ichowv>0) then + call gsi_bundlegetpointer (rval(jj),'howv' ,rv_howv, istatus) + call gsi_bundleputvar ( wbundle, 'howv', rv_howv, istatus ) + end if + if (icw>0) then + call gsi_bundlegetpointer (rval(jj),'w' ,rv_w, istatus) + call gsi_bundleputvar ( wbundle, 'w', rv_w, istatus ) + if(nems_nmmb_regional)then + call gsi_bundlegetpointer (rval(jj),'dw' ,rv_dw, istatus) + call gsi_bundleputvar ( wbundle, 'dw', rv_dw, istatus ) + end if + end if + if (ictcamt>0) then + call gsi_bundlegetpointer (rval(jj),'tcamt',rv_tcamt, istatus) + call gsi_bundleputvar ( wbundle, 'tcamt', rv_tcamt, istatus ) + end if + if (iclcbas>0) then + call gsi_bundlegetpointer (wbundle,'lcbas',cv_lcbas,istatus) + call gsi_bundlegetpointer (rval(jj),'lcbas',rv_lcbas, istatus) + call gsi_bundleputvar ( wbundle, 'lcbas', zero, istatus ) + ! Adjoint of convert loglcbas to lcbas + call loglcbas_to_lcbas_ad(cv_lcbas,rv_lcbas) + end if + if (iccldch >0) then + call gsi_bundlegetpointer (rval(jj),'cldch' ,rv_cldch , istatus) + call gsi_bundleputvar ( wbundle, 'cldch' , rv_cldch , istatus ) + end if + if (icuwnd10m>0) then + call gsi_bundlegetpointer (rval(jj),'uwnd10m' ,rv_uwnd10m, istatus) + call gsi_bundleputvar ( wbundle, 'uwnd10m', rv_uwnd10m, istatus ) + end if + if (icvwnd10m>0) then + call gsi_bundlegetpointer (rval(jj),'vwnd10m' ,rv_vwnd10m, istatus) + call gsi_bundleputvar ( wbundle, 'vwnd10m', rv_vwnd10m, istatus ) + end if + +!$omp end parallel sections + +! Adjoint of transfer variables + + do ii=1,wbundle%ndim + grad%step(jj)%values(ii)=wbundle%values(ii)+grad%step(jj)%values(ii) + enddo + call gsi_bundledestroy(wbundle,istatus) + if (istatus/=0) then + write(6,*) trim(myname),': trouble destroying work bundle' + call stop2(999) + endif + +end do + +! Clean up +if (ngases>0) deallocate(gases) + +if (nclouds>0) deallocate(clouds) + +return +end subroutine control2state_ad +end module control2state_mod diff --git a/src/gsi/control2state_ad.f90 b/src/gsi/control2state_ad.f90 deleted file mode 100644 index ce1e9d2cd2..0000000000 --- a/src/gsi/control2state_ad.f90 +++ /dev/null @@ -1,441 +0,0 @@ -subroutine control2state_ad(rval,bval,grad) -!$$$ subprogram documentation block -! . . . . -! subprogram: control2state_ad -! prgmmr: tremolet -! -! abstract: Converts variables from physical space to control space -! This is also the adjoint of control2state -! -! program history log: -! 2007-04-16 tremolet - initial code -! 2008-11-28 todling - update to GSI May 2008: add tsen and p3d -! 2009-01-15 todling - handle predictors in quad precision -! 2009-04-21 derber - modify call to getstvp to call to getuv -! 2009-06-15 parrish - add call to strong_bk_ad when l_hyb_ens=.true. (hybrid ensemble run) -! 2009-08-12 lueken - update documentation -! 2009-11-27 parrish - for uv_hyb_ens=.true., then ensemble perturbations contain u,v instead of st,vp -! so introduce extra code to handle this case. -! 2010-02-20 parrish - introduce modifications to allow dual resolution capability when running -! in hybrid ensemble mode. -! 2010-03-24 zhu - use cstate for generalizing control variable -! 2010-04-29 todling - update to use gsi_bundle; rename cstate to wbundle -! 2010-05-31 todling - better consistency checks; add co/co2 -! - ready to bypass analysis of (any) meteorological fields -! 2010-06-15 todling - generalized handling of chemistry -! 2011-02-22 zhu - add gust,vis,pblh -! 2011-05-15 auligne/todling - generalized cloud handling -! 2011-07-12 zhu - add do_cw_to_hydro_ad and cw2hydro_ad -! 2011-11-01 eliu - generalize the use of do_cw_to_hydro_ad -! 2012-02-08 kleist - remove strong_bk_ad and ensemble_forward_model_ad and related parameters -! 2013-05-23 zhu - add ntclen and predt for aircraft temperature bias correction -! 2013-10-25 todling - nullify work pointers -! 2013-10-28 todling - rename p3d to prse -! 2014-01-31 mkim - add support for when ql and qi are CVs for all-sky mw radiance DA -! 2014-03-19 pondeca - add wspd10m -! 2014-04-10 pondeca - add td2m,mxtm,mitm,pmsl -! 2014-05-07 pondeca - add howv -! 2014-06-16 carley/zhu - add tcamt and lcbas -! 2014-12-03 derber - introduce parallel regions for optimization -! 2015-07-10 pondeca - add cloud ceiling height (cldch) -! 2016-05-03 pondeca - add uwnd10m, and vwnd10m -! 2017-05-12 Y. Wang and X. Wang - add w as state variable for rw DA, POC: xuguang.wang@ou.edu -! 2016-08-12 lippi - add vertical velocity (w) to mycvars and mysvars. -! 2016-05-03 pondeca - add uwnd10m, and vwnd10m -! 2022-05-24 H.Wang - add amass2aero_ad for regional FV3-CMAQ DA when using -! total mass as control variable. -! -! input argument list: -! rval - State variable -! bval -! output argument list: -! grad - Control variable -! -!$$$ -use kinds, only: i_kind,r_kind -use control_vectors, only: control_vector -use control_vectors, only: cvars3d,cvars2d -use bias_predictors, only: predictors -use gsi_4dvar, only: nsubwin, lsqrtb -use gridmod, only: regional,lat2,lon2,nsig,twodvar_regional -use jfunc, only: nsclen,npclen,ntclen -use cwhydromod, only: cw2hydro_ad -use amassaeromod, only: amass2aero_ad -use cwhydromod, only: cw2hydro_ad_hwrf -use gsi_bundlemod, only: gsi_bundlecreate -use gsi_bundlemod, only: gsi_bundle -use gsi_bundlemod, only: gsi_bundlegetpointer -use gsi_bundlemod, only: gsi_bundlegetvar -use gsi_bundlemod, only: gsi_bundleputvar -use gsi_bundlemod, only: gsi_bundledestroy -use gsi_chemguess_mod, only: gsi_chemguess_get -use gsi_metguess_mod, only: gsi_metguess_get -use mpeu_util, only: getindex -use constants, only: max_varname_length,zero -use gridmod, only: nems_nmmb_regional -use chemmod, only: laeroana_fv3cmaq, naero_cmaq_fv3,aeronames_cmaq_fv3,imodes_cmaq_fv3,icvt_cmaq_fv3 - -implicit none - -! Declare passed variables -type(gsi_bundle) , intent(inout) :: rval(nsubwin) -type(predictors) , intent(in ) :: bval -type(control_vector), intent(inout) :: grad - -! Declare local variables -character(len=*),parameter::myname='control2state_ad' -character(len=max_varname_length),allocatable,dimension(:) :: gases -character(len=max_varname_length),allocatable,dimension(:) :: clouds -integer(i_kind) :: ii,jj,ic,id,ngases,nclouds,istatus,istatus_oz -type(gsi_bundle) :: wbundle ! work bundle - -! Note: The following does not aim to get all variables in -! the state and control vectors, but rather the ones -! this routines knows how to handle. -integer(i_kind), parameter :: ncvars = 9 -integer(i_kind) :: icps(ncvars) -integer(i_kind) :: icpblh,icgust,icvis,icoz,icwspd10m,icw -integer(i_kind) :: ictd2m,icmxtm,icmitm,icpmsl,ichowv -integer(i_kind) :: ictcamt,iclcbas,icsfwter,icvpwter -integer(i_kind) :: iccldch,icuwnd10m,icvwnd10m -character(len=3), parameter :: mycvars(ncvars) = (/ & - 'sf ', 'vp ', 'ps ', 't ', 'q ', 'cw ', 'ql ', 'qi ', 'w ' /) -logical :: lc_sf,lc_vp,lc_w,lc_ps,lc_t,lc_rh,lc_cw,lc_ql,lc_qi -real(r_kind),pointer,dimension(:,:) :: cv_ps=>NULL() -real(r_kind),pointer,dimension(:,:) :: cv_lcbas=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: cv_vp=>NULL() -!real(r_kind),pointer,dimension(:,:,:) :: cv_w=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: cv_t=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: cv_rh=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: cv_sfwter=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: cv_vpwter=>NULL() - -! Declare required local state variables -integer(i_kind), parameter :: nsvars = 12 -integer(i_kind) :: isps(nsvars) -character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here - 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ', 'qi ', 'w ', & - 'qr ', 'qs ', 'qg ', 'qh ' /) -logical :: ls_u,ls_v,ls_w,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi -logical :: ls_qr,ls_qs,ls_qg,ls_qh -real(r_kind),pointer,dimension(:,:) :: rv_ps=>NULL(),rv_sst=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_gust=>NULL(),rv_vis=>NULL(),rv_pblh=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_wspd10m=>NULL(),rv_tcamt=>NULL(),rv_lcbas=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_td2m=>NULL(),rv_mxtm=>NULL(),rv_mitm=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_pmsl=>NULL(),rv_howv=>NULL(),rv_cldch=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_uwnd10m=>NULL(),rv_vwnd10m=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_u=>NULL(),rv_v=>NULL(),rv_w=>NULL(),rv_dw=>NULL(),rv_prse=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_q=>NULL(),rv_tsen=>NULL(),rv_tv=>NULL(),rv_oz=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_rank3=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_rank2=>NULL() - -real(r_kind),allocatable,dimension(:,:,:):: uland,vland,uwter,vwter - -logical :: do_getuv,do_tv_to_tsen_ad,do_normal_rh_to_q_ad,do_getprs_ad,do_cw_to_hydro_ad -logical :: do_cw_to_hydro_ad_hwrf - - -!****************************************************************************** - -if (lsqrtb) then - write(6,*)trim(myname),': not for sqrt(B)' - call stop2(311) -end if - -! Inquire about clouds -call gsi_metguess_get ('clouds::3d',nclouds,istatus) -if (nclouds>0) then - allocate(clouds(nclouds)) - call gsi_metguess_get ('clouds::3d',clouds,istatus) -endif - -! Inquire about chemistry -call gsi_chemguess_get('dim',ngases,istatus) -if (ngases>0) then - allocate(gases(ngases)) - call gsi_chemguess_get('gsinames',gases,istatus) -endif - -! Since each internal vector [step(jj)] of grad has the same structure, pointers are -! the same independent of the subwindow jj -call gsi_bundlegetpointer (grad%step(1),mycvars,icps,istatus) -lc_sf =icps(1)>0; lc_vp =icps(2)>0; lc_ps =icps(3)>0 -lc_t =icps(4)>0; lc_rh =icps(5)>0; lc_cw =icps(6)>0 -lc_ql =icps(7)>0; lc_qi =icps(8)>0; lc_w =icps(9)>0 - -! Since each internal vector of xhat has the same structure, pointers are -! the same independent of the subwindow jj -call gsi_bundlegetpointer (rval(1),mysvars,isps,istatus) -ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0 -ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0 -ls_qi =isps(7)>0; ls_w =isps(8)>0 -ls_qr =isps(9)>0; ls_qs =isps(10)>0 -ls_qg =isps(11)>0; ls_qh =isps(12)>0 - -! Define what to do depending on what's in CV and SV -do_getuv =lc_sf.and.lc_vp.and.ls_u .and.ls_v -do_tv_to_tsen_ad =lc_t .and.ls_q .and.ls_tsen -do_normal_rh_to_q_ad=lc_t .and.lc_rh.and.ls_prse.and.ls_q -do_getprs_ad =lc_t .and.lc_ps.and.ls_prse - -do_cw_to_hydro_ad=.false. -do_cw_to_hydro_ad_hwrf=.false. -if (regional) then - do_cw_to_hydro_ad=lc_cw.and.ls_ql.and.ls_qi - do_cw_to_hydro_ad_hwrf=lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh -else - do_cw_to_hydro_ad=lc_cw.and.ls_tsen.and.ls_ql.and.ls_qi.and.(.not.lc_ql) !ncep global -endif - -call gsi_bundlegetpointer (grad%step(1),'oz',icoz,istatus) -call gsi_bundlegetpointer (grad%step(1),'gust',icgust,istatus) -call gsi_bundlegetpointer (grad%step(1),'vis',icvis,istatus) -call gsi_bundlegetpointer (grad%step(1),'pblh',icpblh,istatus) -call gsi_bundlegetpointer (grad%step(1),'wspd10m',icwspd10m,istatus) -call gsi_bundlegetpointer (grad%step(1),'td2m',ictd2m,istatus) -call gsi_bundlegetpointer (grad%step(1),'mxtm',icmxtm,istatus) -call gsi_bundlegetpointer (grad%step(1),'mitm',icmitm,istatus) -call gsi_bundlegetpointer (grad%step(1),'pmsl',icpmsl,istatus) -call gsi_bundlegetpointer (grad%step(1),'howv',ichowv,istatus) -call gsi_bundlegetpointer (grad%step(1),'sfwter',icsfwter,istatus) -call gsi_bundlegetpointer (grad%step(1),'vpwter',icvpwter,istatus) -call gsi_bundlegetpointer (grad%step(1),'w',icw,istatus) -call gsi_bundlegetpointer (grad%step(1),'tcamt',ictcamt,istatus) -call gsi_bundlegetpointer (grad%step(1),'lcbas',iclcbas,istatus) -call gsi_bundlegetpointer (grad%step(1),'cldch',iccldch,istatus) -call gsi_bundlegetpointer (grad%step(1),'uwnd10m',icuwnd10m,istatus) -call gsi_bundlegetpointer (grad%step(1),'vwnd10m',icvwnd10m,istatus) - -! Loop over control steps -do jj=1,nsubwin - -! Create a work bundle similar to grad control vector's bundle - call gsi_bundlecreate ( wbundle, grad%step(jj), 'control2state_ad work', istatus ) - if (istatus/=0) then - write(6,*) trim(myname),': trouble creating work bundle' - call stop2(999) - endif - -!$omp parallel sections private(istatus,ii,ic,id,istatus_oz,rv_u,rv_v,rv_prse,rv_q,rv_tsen,uland,vland,uwter,vwter) - -!$omp section - - call gsi_bundlegetpointer (wbundle,'sf' ,cv_sf ,istatus) - call gsi_bundlegetpointer (wbundle,'vp' ,cv_vp ,istatus) - call gsi_bundlegetpointer (rval(jj),'u' ,rv_u, istatus) - call gsi_bundlegetpointer (rval(jj),'v' ,rv_v, istatus) - call gsi_bundleputvar ( wbundle, 'sf', zero, istatus ) - call gsi_bundleputvar ( wbundle, 'vp', zero, istatus ) -! Convert RHS calculations for u,v to st/vp for application of -! background error - if (do_getuv) then - if (twodvar_regional .and. icsfwter>0 .and. icvpwter>0) then - call gsi_bundlegetpointer (wbundle,'sfwter', cv_sfwter,istatus) - call gsi_bundlegetpointer (wbundle,'vpwter', cv_vpwter,istatus) - allocate(uland(lat2,lon2,nsig),vland(lat2,lon2,nsig), & - uwter(lat2,lon2,nsig),vwter(lat2,lon2,nsig)) - - uland=zero ; uwter=zero - vland=zero ; vwter=zero - - call landlake_uvmerge(rv_u,rv_v,uland,vland,uwter,vwter,0) - - call getuv(uwter,vwter,cv_sfwter,cv_vpwter,1) - call getuv(uland,vland,cv_sf,cv_vp,1) - deallocate(uland,vland,uwter,vwter) - else - call getuv(rv_u,rv_v,cv_sf,cv_vp,1) - endif - endif - - if(jj == 1)then - do ii=1,nsclen - grad%predr(ii)=bval%predr(ii) - enddo - do ii=1,npclen - grad%predp(ii)=bval%predp(ii) - enddo - if (ntclen>0) then - do ii=1,ntclen - grad%predt(ii)=bval%predt(ii) - enddo - end if - end if - -!$omp section - -! Get pointers to required control variables - call gsi_bundlegetpointer (wbundle,'ps' ,cv_ps ,istatus) - call gsi_bundlegetpointer (wbundle,'t' ,cv_t, istatus) - call gsi_bundlegetpointer (wbundle,'q' ,cv_rh ,istatus) - -! Get pointers to this subwin require state variables - call gsi_bundlegetpointer (rval(jj),'ps' ,rv_ps, istatus) - call gsi_bundlegetpointer (rval(jj),'prse',rv_prse,istatus) - call gsi_bundlegetpointer (rval(jj),'tv' ,rv_tv, istatus) - call gsi_bundlegetpointer (rval(jj),'tsen',rv_tsen,istatus) - call gsi_bundlegetpointer (rval(jj),'q' ,rv_q , istatus) - -! Adjoint of control to initial state - call gsi_bundleputvar ( wbundle, 't' , rv_tv, istatus ) - call gsi_bundleputvar ( wbundle, 'q' , zero, istatus ) - call gsi_bundleputvar ( wbundle, 'ps', rv_ps, istatus ) - - if (do_cw_to_hydro_ad .and. .not.do_cw_to_hydro_ad_hwrf) then -! Case when cloud-vars do not map one-to-one -! e.g. cw-to-ql&qi - call cw2hydro_ad(rval(jj),wbundle,clouds,nclouds) - elseif (do_cw_to_hydro_ad_hwrf) then -! Case when cloud-vars do not map one-to-one -! e.g. cw-to-ql&qi&qr&qs&qg&qh - call cw2hydro_ad_hwrf(rval(jj),wbundle,rv_tsen) - else -! Case when cloud-vars map one-to-one, take care of them together -! e.g. cw-to-cw - do ic=1,nclouds - id=getindex(cvars3d,clouds(ic)) - if (id>0) then - call gsi_bundlegetpointer (rval(jj),clouds(ic),rv_rank3,istatus) - call gsi_bundleputvar (wbundle, clouds(ic),rv_rank3,istatus) - endif - enddo - end if -! Calculate sensible temperature - if(do_tv_to_tsen_ad) call tv_to_tsen_ad(cv_t,rv_q,rv_tsen) - -! Adjoint of convert input normalized RH to q to add contribution of moisture -! to t, p , and normalized rh - if(do_normal_rh_to_q_ad) call normal_rh_to_q_ad(cv_rh,cv_t,rv_prse,rv_q) - -! Adjoint to convert ps to 3-d pressure - if(do_getprs_ad) call getprs_ad(cv_ps,cv_t,rv_prse) - - -!$omp section - - call gsi_bundlegetpointer (rval(jj),'sst' ,rv_sst, istatus) - call gsi_bundleputvar ( wbundle, 'sst', rv_sst, istatus ) - -! call gsi_bundlegetpointer (rval(jj),'oz' ,rv_oz , istatus) - call gsi_bundlegetpointer (rval(jj),'oz' ,rv_oz , istatus_oz) - - if (icoz>0) then - call gsi_bundleputvar ( wbundle, 'oz', rv_oz, istatus ) - else - if(istatus_oz==0) rv_oz=zero - end if - -! Same one-to-one map for chemistry-vars; take care of them together - if (.not.laeroana_fv3cmaq .and. icvt_cmaq_fv3 == 2) then - write(6,*) ' icvt_cmaq_fv3 == 2 but laeroana_fv3cmaq=false stop!!!' - call stop2(999) - endif - - if (icvt_cmaq_fv3 == 2) then - call amass2aero_ad(rval(jj),wbundle,aeronames_cmaq_fv3,naero_cmaq_fv3) - else - do ic=1,ngases - id=getindex(cvars3d,gases(ic)) - if (id>0) then - call gsi_bundlegetpointer (rval(jj),gases(ic),rv_rank3,istatus) - call gsi_bundleputvar (wbundle, gases(ic),rv_rank3,istatus) - endif - - id=getindex(cvars2d,gases(ic)) - if (id>0) then - call gsi_bundlegetpointer (rval(jj),gases(ic),rv_rank2,istatus) - call gsi_bundleputvar (wbundle, gases(ic),rv_rank2,istatus) - endif - enddo - end if - if (icgust>0) then - call gsi_bundlegetpointer (rval(jj),'gust' ,rv_gust, istatus) - call gsi_bundleputvar ( wbundle, 'gust', rv_gust, istatus ) - end if - if (icvis >0) then - call gsi_bundlegetpointer (rval(jj),'vis' ,rv_vis , istatus) - call gsi_bundleputvar ( wbundle, 'vis' , rv_vis , istatus ) - end if - if (icpblh>0)then - call gsi_bundlegetpointer (rval(jj),'pblh' ,rv_pblh, istatus) - call gsi_bundleputvar ( wbundle, 'pblh', rv_pblh, istatus ) - end if - if (icwspd10m>0) then - call gsi_bundlegetpointer (rval(jj),'wspd10m' ,rv_wspd10m, istatus) - call gsi_bundleputvar ( wbundle, 'wspd10m', rv_wspd10m, istatus ) - end if - if (ictd2m>0) then - call gsi_bundlegetpointer (rval(jj),'td2m' ,rv_td2m, istatus) - call gsi_bundleputvar ( wbundle, 'td2m', rv_td2m, istatus ) - end if - if (icmxtm>0) then - call gsi_bundlegetpointer (rval(jj),'mxtm' ,rv_mxtm, istatus) - call gsi_bundleputvar ( wbundle, 'mxtm', rv_mxtm, istatus ) - end if - if (icmitm>0) then - call gsi_bundlegetpointer (rval(jj),'mitm' ,rv_mitm, istatus) - call gsi_bundleputvar ( wbundle, 'mitm', rv_mitm, istatus ) - end if - if (icpmsl>0) then - call gsi_bundlegetpointer (rval(jj),'pmsl' ,rv_pmsl, istatus) - call gsi_bundleputvar ( wbundle, 'pmsl', rv_pmsl, istatus ) - end if - if (ichowv>0) then - call gsi_bundlegetpointer (rval(jj),'howv' ,rv_howv, istatus) - call gsi_bundleputvar ( wbundle, 'howv', rv_howv, istatus ) - end if - if (icw>0) then - call gsi_bundlegetpointer (rval(jj),'w' ,rv_w, istatus) - call gsi_bundleputvar ( wbundle, 'w', rv_w, istatus ) - if(nems_nmmb_regional)then - call gsi_bundlegetpointer (rval(jj),'dw' ,rv_dw, istatus) - call gsi_bundleputvar ( wbundle, 'dw', rv_dw, istatus ) - end if - end if - if (ictcamt>0) then - call gsi_bundlegetpointer (rval(jj),'tcamt',rv_tcamt, istatus) - call gsi_bundleputvar ( wbundle, 'tcamt', rv_tcamt, istatus ) - end if - if (iclcbas>0) then - call gsi_bundlegetpointer (wbundle,'lcbas',cv_lcbas,istatus) - call gsi_bundlegetpointer (rval(jj),'lcbas',rv_lcbas, istatus) - call gsi_bundleputvar ( wbundle, 'lcbas', zero, istatus ) - ! Adjoint of convert loglcbas to lcbas - call loglcbas_to_lcbas_ad(cv_lcbas,rv_lcbas) - end if - if (iccldch >0) then - call gsi_bundlegetpointer (rval(jj),'cldch' ,rv_cldch , istatus) - call gsi_bundleputvar ( wbundle, 'cldch' , rv_cldch , istatus ) - end if - if (icuwnd10m>0) then - call gsi_bundlegetpointer (rval(jj),'uwnd10m' ,rv_uwnd10m, istatus) - call gsi_bundleputvar ( wbundle, 'uwnd10m', rv_uwnd10m, istatus ) - end if - if (icvwnd10m>0) then - call gsi_bundlegetpointer (rval(jj),'vwnd10m' ,rv_vwnd10m, istatus) - call gsi_bundleputvar ( wbundle, 'vwnd10m', rv_vwnd10m, istatus ) - end if - -!$omp end parallel sections - -! Adjoint of transfer variables - - do ii=1,wbundle%ndim - grad%step(jj)%values(ii)=wbundle%values(ii)+grad%step(jj)%values(ii) - enddo - call gsi_bundledestroy(wbundle,istatus) - if (istatus/=0) then - write(6,*) trim(myname),': trouble destroying work bundle' - call stop2(999) - endif - -end do - -! Clean up -if (ngases>0) deallocate(gases) - -if (nclouds>0) deallocate(clouds) - -return -end subroutine control2state_ad diff --git a/src/gsi/control_vectors.f90 b/src/gsi/control_vectors.f90 index 0847257777..ea41b36c46 100644 --- a/src/gsi/control_vectors.f90 +++ b/src/gsi/control_vectors.f90 @@ -83,6 +83,7 @@ module control_vectors use hybrid_ensemble_parameters, only: beta_s0,l_hyb_ens use hybrid_ensemble_parameters, only: grd_ens use constants, only : max_varname_length +use gridmod, only : minmype use m_rerank, only : rerank use GSI_BundleMod, only : GSI_BundleCreate @@ -112,7 +113,7 @@ module control_vectors public dot_product public prt_control_norms, axpy, random_cv, setup_control_vectors, & write_cv, read_cv, inquire_cv, maxval, qdot_prod_sub, init_anacv, & - final_anacv + final_anacv,c2sset_flg ! ! Public variables @@ -157,6 +158,7 @@ module control_vectors integer(i_kind) :: latlon11,latlon1n,lat2,lon2,nsig,n_ens integer(i_kind) :: nval_lenz_en logical,save :: lsqrtb,lcalc_gfdl_cfrac +logical :: c2sset_flg integer(i_kind) :: m_vec_alloc, max_vec_alloc, m_allocs, m_deallocs @@ -413,6 +415,7 @@ subroutine init_anacv write(6,*) myname_,': ALL CONTROL VARIABLES ', nrf_var end if lcalc_gfdl_cfrac = .false. +c2sset_flg = .true. end subroutine init_anacv subroutine final_anacv @@ -889,12 +892,12 @@ real(r_quad) function qdot_prod_sub(xcv,ycv) end do endif else + m3d=xcv%step(1)%n3d + m2d=xcv%step(1)%n2d + itot=max(m3d,0)+max(m2d,0) + if(l_hyb_ens)itot=itot+n_ens + allocate(partsum(itot)) do ii=1,nsubwin - m3d=xcv%step(ii)%n3d - m2d=xcv%step(ii)%n2d - itot=max(m3d,0)+max(m2d,0) - if(l_hyb_ens)itot=itot+naensgrp*n_ens - allocate(partsum(itot)) !$omp parallel do schedule(dynamic,1) private(i) do i = 1,m3d partsum(i) = dplevs(xcv%step(ii)%r3(i)%q,ycv%step(ii)%r3(i)%q,ihalo=1) @@ -915,12 +918,12 @@ real(r_quad) function qdot_prod_sub(xcv,ycv) do i=1,itot qdot_prod_sub = qdot_prod_sub + partsum(i) end do - deallocate(partsum) end do + deallocate(partsum) end if ! Duplicated part of vector - if(mype == 0)then + if(mype == minmype)then do j=nclen1+1,nclen qdot_prod_sub=qdot_prod_sub+xcv%values(j)*ycv%values(j) end do @@ -966,37 +969,35 @@ subroutine qdot_prod_vars_eb(xcv,ycv,prods,eb) character(len=*) , intent(in ) :: eb real(r_quad) , intent( out) :: prods(nsubwin+1) - real(r_quad) :: zz(nsubwin) integer(i_kind) :: ii,i,nn,m3d,m2d real(r_quad),allocatable,dimension(:) :: partsum integer(i_kind) :: ig integer(i_kind) ::ngtmp,nn0 prods(:)=zero_quad - zz(:)=zero_quad ! Independent part of vector if (lsqrtb) then if(trim(eb) == 'cost_b') then do ii=1,nsubwin - zz(ii)=zz(ii)+qdot_product( xcv%step(ii)%values(:) ,ycv%step(ii)%values(:) ) + prods(ii)=prods(ii)+qdot_product( xcv%step(ii)%values(:) ,ycv%step(ii)%values(:) ) end do endif if(trim(eb) == 'cost_e') then do ig=1,naensgrp do nn=1,n_ens do ii=1,nsubwin - zz(ii)=zz(ii)+qdot_product( xcv%aens(ii,ig,nn)%values(:) ,ycv%aens(ii,ig,nn)%values(:) ) + prods(ii)=prods(ii)+qdot_product( xcv%aens(ii,ig,nn)%values(:) ,ycv%aens(ii,ig,nn)%values(:) ) end do end do end do endif else if(trim(eb) == 'cost_b') then + m3d=xcv%step(1)%n3d + m2d=xcv%step(1)%n2d + allocate(partsum(m2d+m3d)) do ii=1,nsubwin - m3d=xcv%step(ii)%n3d - m2d=xcv%step(ii)%n2d - allocate(partsum(m2d+m3d)) !$omp parallel do schedule(dynamic,1) private(i) do i = 1,m3d partsum(i)= dplevs(xcv%step(ii)%r3(i)%q,ycv%step(ii)%r3(i)%q,ihalo=1) @@ -1006,17 +1007,17 @@ subroutine qdot_prod_vars_eb(xcv,ycv,prods,eb) partsum(m3d+i)= dplevs(xcv%step(ii)%r2(i)%q,ycv%step(ii)%r2(i)%q,ihalo=1) enddo do i = 1,m2d+m3d - zz(ii)=zz(ii) + partsum(i) + prods(ii)=prods(ii) + partsum(i) end do - deallocate(partsum) end do + deallocate(partsum) end if if(trim(eb) == 'cost_e') then - do ii=1,nsubwin ! RTod: somebody could work in opt/zing this ... - allocate(partsum(n_ens*naensgrp)) + allocate(partsum(n_ens*naensgrp)) + do ii=1,nsubwin +!$omp parallel do schedule(dynamic,1) private(nn,m3d,m2d,ig,ngtmp,nn0) do ig=1,naensgrp ngtmp=(ig-1)*n_ens -!$omp parallel do schedule(dynamic,1) private(nn,m3d,m2d) do nn=1,n_ens nn0=nn+ngtmp partsum(nn0) = zero_quad @@ -1031,20 +1032,17 @@ subroutine qdot_prod_vars_eb(xcv,ycv,prods,eb) enddo end do do nn=1,n_ens*naensgrp - zz(ii)=zz(ii)+partsum(nn) + prods(ii)=prods(ii)+partsum(nn) end do - deallocate(partsum) end do + deallocate(partsum) end if end if - call mpl_allreduce(nsubwin,qpvals=zz) - prods(1:nsubwin) = zz(1:nsubwin) - ! Duplicated part of vector - if(trim(eb) == 'cost_b') then + if(mype == minmype .and. trim(eb) == 'cost_b' ) then if (nsclen>0) then - prods(nsubwin+1) = prods(nsubwin+1) + qdot_product(xcv%predr(:),ycv%predr(:)) + prods(nsubwin+1) = qdot_product(xcv%predr(:),ycv%predr(:)) endif if (npclen>0) then prods(nsubwin+1) = prods(nsubwin+1) + qdot_product(xcv%predp(:),ycv%predp(:)) @@ -1054,6 +1052,9 @@ subroutine qdot_prod_vars_eb(xcv,ycv,prods,eb) endif end if + call mpl_allreduce(nsubwin+1,qpvals=prods) + + return end subroutine qdot_prod_vars_eb ! ---------------------------------------------------------------------- diff --git a/src/gsi/convthin.f90 b/src/gsi/convthin.f90 index cc6d2ed1b5..99629b8aff 100644 --- a/src/gsi/convthin.f90 +++ b/src/gsi/convthin.f90 @@ -326,11 +326,8 @@ subroutine map3grids(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs ibest_save(itx,ip)=iin ! Case(3): obs score > best value at this location, -! --> do not use this obs, return to calling program. - elseif (icount_fore(itx,ip) > 0 .and. crit > score_crit_fore(itx,ip)) then - iuse=.false. - ! Case(4): none of the above cases are satisified, don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. endif ! cases @@ -358,25 +355,17 @@ subroutine map3grids(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs ibest_save(itx,ip)=iin ! Case(3): obs score > best value at this location, -! --> do not use this obs, return to calling program. - elseif(icount_aft(itx,ip) > 0 .and. crit > score_crit_aft(itx,ip)) then - iuse=.false. - ! Case(4): none of the above cases are satisified, -! --> don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. endif ! cases else -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit(itx,ip) .and. icount(itx,ip) > 0) then - iuse=.false. ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - elseif (icount(itx,ip) > 0 .and. crit < score_crit(itx,ip)) then + if (icount(itx,ip) > 0 .and. crit < score_crit(itx,ip)) then score_crit(itx,ip)= crit iobsout=ibest_obs(itx,ip) icount(itx,ip)=icount(itx,ip)+1 @@ -394,7 +383,8 @@ subroutine map3grids(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs ibest_save(itx,ip) = iin ! Case: none of the above cases are satisified, -! --> don't use this obs +! Case: obs score > best value at this location, +! --> do not use this obs, return to calling program. else iuse = .false. end if @@ -473,7 +463,8 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io integer(i_kind) ix,iy real(r_kind) dlat1,dlon1,pob1 - real(r_kind) dx,dy,dp,dxx,dyy,dpp + real(r_kind) dx,dy,dp + real(r_kind) dxx,dyy,dpp real(r_kind) crit!,dist1 logical foreswp, aftswp @@ -510,13 +501,13 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io dx=dlon1-ix ix=max(1,min(ix,mlon(iy))) - dxx=half-min(dx,one-dx) - dyy=half-min(dy,one-dy) - if( pflag == 1) then - dpp=half-min(dp,one-dp) - else - dpp=min(dp,one-dp) - endif +! dxx=half-min(dx,one-dx) +! dyy=half-min(dy,one-dy) +! if( pflag == 1) then +! dpp=half-min(dp,one-dp) +! else +! dpp=min(dp,one-dp) +! endif itx=hll(ix,iy) @@ -535,10 +526,10 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io ! TDR fore/aft (Pseudo-dual-Doppler-radars) if(foreswp) then ! fore sweeps + iobs=iobs+1 + iobsout=iobs ! Case(1): first obs at this location, keep this obs as starting point if (icount_fore(itx,ip)==0) then - iobs=iobs+1 - iobsout=iobs score_crit_fore(itx,ip)= crit icount_fore(itx,ip)=icount_fore(itx,ip)+1 ibest_obs(itx,ip) = iobs @@ -549,8 +540,6 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io ! Case(2): obs score < best value at this location, ! --> update score, count, and best obs counters elseif (icount_fore(itx,ip) > 0 .and. crit < score_crit_fore(itx,ip)) then - iobs=iobs+1 - iobsout=iobs score_crit(itx,ip)= crit ! iobsout=ibest_obs(itx,ip) icount(itx,ip)=icount(itx,ip)+1 @@ -560,27 +549,19 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io ibest_save(itx,ip)=iobs ! Case(3): obs score > best value at this location, -! --> do not use this obs, return to calling program. - elseif (icount_fore(itx,ip) > 0 .and. crit > score_crit_fore(itx,ip)) then - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.1_r_kind - iuse=.false. - ! Case(4): none of the above cases are satisified, don't use this obs +! --> do not use this obs, return to calling program. else - iuse = .false. - iobs=iobs+1 - iobsout=iobs rusage(iobs)=101.1_r_kind + iuse=.false. endif ! cases else if(aftswp) then ! aft sweeps + iobs=iobs+1 + iobsout=iobs ! Case(1): first obs at this location, keep this obs as starting point if (icount_aft(itx,ip)==0) then - iobs=iobs+1 - iobsout=iobs score_crit_aft(itx,ip)= crit icount_aft(itx,ip)=icount_aft(itx,ip)+1 ibest_obs(itx,ip) = iobs @@ -589,8 +570,6 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io ! Case(2): obs score < best value at this location, ! --> update score, count, and best obs counters elseif (icount_aft(itx,ip) > 0 .and. crit < score_crit_aft(itx,ip)) then - iobs=iobs+1 - iobsout=iobs score_crit_aft(itx,ip)= crit icount_aft(itx,ip)=icount_aft(itx,ip)+1 iobsout=ibest_obs(itx,ip) @@ -599,36 +578,20 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io rusage(iobs)=usage ! Case(3): obs score > best value at this location, -! --> do not use this obs, return to calling program. - elseif(icount_aft(itx,ip) > 0 .and. crit > score_crit_aft(itx,ip)) then - iuse=.false. - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.1_r_kind - ! Case(4): none of the above cases are satisified, -! --> don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. - iobs=iobs+1 - iobsout=iobs rusage(iobs)=101.1_r_kind endif ! cases else -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit(itx,ip) .and. icount(itx,ip) > 0) then - iuse=.false. - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.0_r_kind + iobs=iobs+1 + iobsout=iobs ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - elseif (icount(itx,ip) > 0 .and. crit < score_crit(itx,ip)) then - iobs=iobs+1 - iobsout=iobs + if (icount(itx,ip) > 0 .and. crit < score_crit(itx,ip)) then score_crit(itx,ip)= crit icount(itx,ip)=icount(itx,ip)+1 iiout = ibest_obs(itx,ip) @@ -640,20 +603,17 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io ! Case: first obs at this location, ! --> keep this obs as starting point elseif (icount(itx,ip)==0) then - iobs=iobs+1 - iobsout=iobs score_crit(itx,ip)= crit ibest_obs(itx,ip) = iobs icount(itx,ip)=icount(itx,ip)+1 ibest_save(itx,ip) = iin rusage(iobs)=usage -! Case: none of the above cases are satisified, -! --> don't use this obs +! Case: obs score > best value at this location, +! or none of the above cases are satisified, +! --> do not use this obs, return to calling program. else iuse = .false. - iobs=iobs+1 - iobsout=iobs rusage(iobs)=101.0_r_kind end if end if diff --git a/src/gsi/convthin_time.f90 b/src/gsi/convthin_time.f90 index 36ab178393..7f36caf09a 100644 --- a/src/gsi/convthin_time.f90 +++ b/src/gsi/convthin_time.f90 @@ -226,7 +226,8 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& integer(i_kind) ix,iy real(r_kind) dlat1,dlon1,pob1 - real(r_kind) dx,dy,dp,dxx,dyy,dpp + real(r_kind) dx,dy,dp +! real(r_kind) dxx,dyy,dpp real(r_kind) crit!,dist1 logical foreswp, aftswp @@ -262,13 +263,13 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& dx=dlon1-ix ix=max(1,min(ix,mlon(iy))) - dxx=half-min(dx,one-dx) - dyy=half-min(dy,one-dy) - if( pflag == 1) then - dpp=half-min(dp,one-dp) - else - dpp=min(dp,one-dp) - endif +! dxx=half-min(dx,one-dx) +! dyy=half-min(dy,one-dy) +! if( pflag == 1) then +! dpp=half-min(dp,one-dp) +! else +! dpp=min(dp,one-dp) +! endif itx=hll(ix,iy) @@ -306,10 +307,8 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& ibest_save_tm(itx,ip,itm)=iin ! Case(3): obs score > best value at this location, -! --> do not use this obs, return to calling program. - elseif (icount_fore_tm(itx,ip,itm) > 0 .and. crit > score_crit_fore_tm(itx,ip,itm)) then - iuse=.false. ! Case(4): none of the above cases are satisified, don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. endif ! cases @@ -337,25 +336,17 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& ibest_save_tm(itx,ip,itm)=iin ! Case(3): obs score > best value at this location, +! Case(4): none of the above cases are satisified, ! --> do not use this obs, return to calling program. - elseif(icount_aft_tm(itx,ip,itm) > 0 .and. crit > score_crit_aft_tm(itx,ip,itm)) then - iuse=.false. - -! Case(4): none of the above cases are satisified, -! --> don't use this obs else iuse = .false. endif ! cases else -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit_tm(itx,ip,itm) .and. icount_tm(itx,ip,itm) > 0) then - iuse=.false. ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - elseif (icount_tm(itx,ip,itm) > 0 .and. crit < score_crit_tm(itx,ip,itm)) then + if (icount_tm(itx,ip,itm) > 0 .and. crit < score_crit_tm(itx,ip,itm)) then score_crit_tm(itx,ip,itm)= crit iobsout=ibest_obs_tm(itx,ip,itm) icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 @@ -372,8 +363,9 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 ibest_save_tm(itx,ip,itm) = iin +! Case: obs score > best value at this location, ! Case: none of the above cases are satisified, -! --> don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. end if @@ -447,7 +439,8 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c integer(i_kind) ix,iy real(r_kind) dlat1,dlon1,pob1 - real(r_kind) dx,dy,dp,dxx,dyy,dpp + real(r_kind) dx,dy,dp +! real(r_kind) dxx,dyy,dpp real(r_kind) crit!,dist1 logical foreswp, aftswp @@ -484,13 +477,13 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c dx=dlon1-ix ix=max(1,min(ix,mlon(iy))) - dxx=half-min(dx,one-dx) - dyy=half-min(dy,one-dy) - if( pflag == 1) then - dpp=half-min(dp,one-dp) - else - dpp=min(dp,one-dp) - endif +! dxx=half-min(dx,one-dx) +! dyy=half-min(dy,one-dy) +! if( pflag == 1) then +! dpp=half-min(dp,one-dp) +! else +! dpp=min(dp,one-dp) +! endif itx=hll(ix,iy) @@ -508,19 +501,11 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c ! TDR fore (Pseudo-dual-Doppler-radars) if(foreswp) then ! fore sweeps -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit_fore_tm(itx,ip,itm) .and. icount_fore_tm(itx,ip,itm) > 0) then - iuse=.false. - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.1_r_kind - ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - elseif (icount_fore_tm(itx,ip,itm) > 0 .and. crit < score_crit_fore_tm(itx,ip,itm)) then - iobs=iobs+1 - iobsout=iobs + iobs=iobs+1 + iobsout=iobs + if (icount_fore_tm(itx,ip,itm) > 0 .and. crit < score_crit_fore_tm(itx,ip,itm)) then score_crit_fore_tm(itx,ip,itm)= crit ! iobsout=ibest_obs_tm(itx,ip) icount_fore_tm(itx,ip,itm)=icount_fore_tm(itx,ip,itm)+1 @@ -532,8 +517,6 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c ! Case: first obs at this location, ! --> keep this obs as starting point elseif (icount_fore_tm(itx,ip,itm)==0) then - iobs=iobs+1 - iobsout=iobs rusage(iobs)=usage score_crit_fore_tm(itx,ip,itm)= crit ibest_obs_tm(itx,ip,itm) = iobs @@ -541,28 +524,20 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c ibest_save_tm(itx,ip,itm) = iobs ! Case: none of the above cases are satisified, -! --> don't use this obs +! Case: obs score > best value at this location, +! --> do not use this obs, return to calling program. else iuse = .false. - iobs=iobs+1 - iobsout=iobs rusage(iobs)=101.0_r_kind end if ! TDR aft (Pseudo-dual-Doppler-radars) else if(aftswp) then ! fore sweeps -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit_aft_tm(itx,ip,itm) .and. icount_aft_tm(itx,ip,itm) > 0) then - iuse=.false. - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.0_r_kind + iobs=iobs+1 + iobsout=iobs ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - elseif (icount_aft_tm(itx,ip,itm) > 0 .and. crit < score_crit_aft_tm(itx,ip,itm)) then - iobs=iobs+1 - iobsout=iobs + if (icount_aft_tm(itx,ip,itm) > 0 .and. crit < score_crit_aft_tm(itx,ip,itm)) then score_crit_aft_tm(itx,ip,itm)= crit ! iobsout=ibest_obs_tm(itx,ip) icount_aft_tm(itx,ip,itm)=icount_aft_tm(itx,ip,itm)+1 @@ -574,37 +549,27 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c ! Case: first obs at this location, ! --> keep this obs as starting point elseif (icount_aft_tm(itx,ip,itm)==0) then - iobs=iobs+1 - iobsout=iobs rusage(iobs)=usage score_crit_aft_tm(itx,ip,itm)= crit ibest_obs_tm(itx,ip,itm) = iobs icount_aft_tm(itx,ip,itm)=icount_aft_tm(itx,ip,itm)+1 ibest_save_tm(itx,ip,itm) = iobs +! Case: obs score > best value at this location, ! Case: none of the above cases are satisified, -! --> don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. - iobs=iobs+1 - iobsout=iobs rusage(iobs)=101.1_r_kind end if else -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit_tm(itx,ip,itm) .and. icount_tm(itx,ip,itm) > 0) then - iuse=.false. - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.0_r_kind + iobs=iobs+1 + iobsout=iobs ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - elseif (icount_tm(itx,ip,itm) > 0 .and. crit < score_crit_tm(itx,ip,itm)) then - iobs=iobs+1 - iobsout=iobs + if (icount_tm(itx,ip,itm) > 0 .and. crit < score_crit_tm(itx,ip,itm)) then score_crit_tm(itx,ip,itm)= crit icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 iiout = ibest_obs_tm(itx,ip,itm) @@ -616,20 +581,17 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c ! Case: first obs at this location, ! --> keep this obs as starting point elseif (icount_tm(itx,ip,itm)==0) then - iobs=iobs+1 - iobsout=iobs rusage(iobs)=usage score_crit_tm(itx,ip,itm)= crit ibest_obs_tm(itx,ip,itm) = iobs icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 ibest_save_tm(itx,ip,itm) = iin +! Case: obs score > best value at this location, ! Case: none of the above cases are satisified, -! --> don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. - iobs=iobs+1 - iobsout=iobs rusage(iobs)=101.0_r_kind end if end if diff --git a/src/gsi/correlated_obsmod.F90 b/src/gsi/correlated_obsmod.F90 index 683e13d742..7a14cd3226 100644 --- a/src/gsi/correlated_obsmod.F90 +++ b/src/gsi/correlated_obsmod.F90 @@ -977,11 +977,15 @@ subroutine upd_varch_ if(isurf==1) then if(iamroot_)write(6,'(1x,a6,a20,2i6,2f20.15)')'>>>',idnames(itbl),jj,nn,varch(mm),sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) varch_sea(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) - endif - if(isurf==2) varch_land(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) - if(isurf==3) varch_ice(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) - if(isurf==4) varch_snow(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) - if(isurf==5) varch_mixed(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + else if(isurf==2) then + varch_land(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + else if(isurf==3) then + varch_ice(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + else if(isurf==4) then + varch_snow(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + else if(isurf==5) then + varch_mixed(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + end if enddo else allocate(ircv(nchanl1)) @@ -1023,15 +1027,9 @@ subroutine upd_varch_ IJsubset(iii)=ijac(ii) ! subset indexes in channels presently in use endif enddo - if (iii/=ncp) then - if (iamroot_) then - write(6,*) myname, ' iii,ncp= ',iii,ncp - endif - call die(myname_,' serious dimensions insconsistency, aborting') - endif - if (jjj/=ncp) then + if (iii/=ncp .or. jjj/=ncp) then if (iamroot_) then - write(6,*) myname, ' jjj,ncp= ',jjj,ncp + write(6,*) myname, ' iii,jjj,ncp= ',iii,jjj,ncp endif call die(myname_,' serious dimensions insconsistency, aborting') endif @@ -1039,11 +1037,17 @@ subroutine upd_varch_ nn=IJsubset(ii) mm=ich1(nn) rr=IRsubset(ii) - if(isurf==1) varch_sea(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) - if(isurf==2) varch_land(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) - if(isurf==3) varch_ice(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) - if(isurf==4) varch_snow(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) - if(isurf==5) varch_mixed(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + if(isurf==1) then + varch_sea(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + else if(isurf==2) then + varch_land(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + else if(isurf==3) then + varch_ice(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + else if(isurf==4) then + varch_snow(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + else if(isurf==5) then + varch_mixed(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + end if enddo ! clean up deallocate(IJsubset) @@ -1260,18 +1264,12 @@ logical function scale_jac_(depart,obs,err2,raterr2,jacobian,nchanl,varinv,diaga IJsubset(iii)=ijac(ii) ! subset indexes in Jac/dep presently in use endif enddo - if (iii/=ncp) then + if (iii/=ncp .and. jjj/=ncp) then if (iamroot_) then - write(6,*) myname, ' iii,ncp= ',iii,ncp + write(6,*) myname, ' iii,ncp= ',iii,jjj,ncp endif call die(myname_,' serious dimensions insconsistency (R), aborting') endif - if (jjj/=ncp) then - if (iamroot_) then - write(6,*) myname, ' jjj,ncp= ',jjj,ncp - endif - call die(myname_,' serious dimensions insconsistency (J), aborting') - endif if( ErrorCov%method<0 ) then ! Keep departures and Jacobian unchanged @@ -1300,33 +1298,25 @@ logical function scale_jac_(depart,obs,err2,raterr2,jacobian,nchanl,varinv,diaga ! decompose the sub-matrix - returning the result in the ! structure holding the full covariance - nsigjac=size(jacobian,1) - allocate(row(nsigjac,ncp)) - allocate(col(ncp),col2(ncp)) - row=zero_quad - col=zero_quad - col2=zero_quad - - allocate(qcaj(ncp)) allocate(UT(ncp,ncp)) - qcaj = one - UT = zero if( ErrorCov%method==2 ) then if(lqcoef)then + allocate(qcaj(ncp)) do jj=1,ncp - jjj=IJsubset(jj) - qcaj(jj) = raterr2(jjj) + qcaj(jj) = raterr2(IJsubset(jj)) enddo subset = choleskydecom_inv_ (IRsubset,IJsubset,ErrorCov,UT,diagadd,qcaj) + deallocate(qcaj) else subset = choleskydecom_inv_ (IRsubset,IJsubset,ErrorCov,UT,diagadd) endif else if( ErrorCov%method==1 ) then + allocate(qcaj(ncp)) do jj=1,ncp - jjj=IJsubset(jj) - qcaj(jj) = varinv(jjj) + qcaj(jj) = varinv(IJsubset(jj)) enddo subset = choleskydecom_inv_ (IRsubset,IJsubset,ErrorCov,UT,diagadd,qcaj) + deallocate(qcaj) endif if(.not.subset) then @@ -1345,23 +1335,31 @@ logical function scale_jac_(depart,obs,err2,raterr2,jacobian,nchanl,varinv,diaga do kk=ii,ncp rinvdiag(ii)=rinvdiag(ii)+UT(ii,kk)**2 enddo - enddo + end do + nsigjac=size(jacobian,1) + allocate(row(nsigjac,ncp)) + allocate(col(ncp),col2(ncp)) +!$omp parallel do schedule(dynamic,1) private(ii,jj,nn) do ii=1,ncp + row(:,ii)=zero_quad + col(ii)=zero_quad + col2(ii)=zero_quad do jj=1,ii nn=IJsubset(jj) col(ii) = col(ii) + UT(jj,ii) * depart(nn) - col2(ii) = col2(ii) + UT(jj,ii) * obs(nn) + col2(ii) = col2(ii) + UT(jj,ii) * obs(nn) row(:,ii) = row(:,ii) + UT(jj,ii) * jacobian(:,nn) enddo enddo + deallocate(UT) ! Place Jacobian and departure in output arrays - do jj=1,ncp - mm=IJsubset(jj) - depart(mm)=col(jj) - obs(mm)=col2(jj) - jacobian(:,mm)=row(:,jj) + do ii=1,ncp + mm=IJsubset(ii) + depart(mm)=col(ii) + obs(mm)=col2(ii) + jacobian(:,mm)=row(:,ii) raterr2(mm) = one err2(mm) = one wgtjo(mm) = one @@ -1369,8 +1367,6 @@ logical function scale_jac_(depart,obs,err2,raterr2,jacobian,nchanl,varinv,diaga deallocate(col,col2) deallocate(row) - deallocate(qcaj) - deallocate(UT) else if( ErrorCov%method==3 ) then !use diag(Re) scales GSI specified errors ! inv(Rg) = inv(De*Dg) @@ -1445,17 +1441,16 @@ logical function choleskydecom_inv_(Isubset,IJsubset,ErrorCov,UT,diagadd,qcaj) do ii=1,ncp UT(ii,jj) = ErrorCov%R(Isubset(ii),Isubset(jj))/sqrt(qcaj(ii)*qcaj(jj)) enddo + UT(jj,jj) = UT(jj,jj)+diagadd(IJsubset(jj)) enddo else do jj=1,ncp do ii=1,ncp UT(ii,jj) = ErrorCov%R(Isubset(ii),Isubset(jj)) enddo + UT(jj,jj) = UT(jj,jj)+diagadd(IJsubset(jj)) enddo endif - do jj=1,ncp - UT(jj,jj) = UT(jj,jj)+diagadd(IJsubset(jj)) - enddo if(r_kind==r_single) then ! this trick only works because this uses the f77 lapack interfaces call SPOTRF('U', ncp, UT, ncp, info ) else if(r_kind==r_double) then diff --git a/src/gsi/cplr_gfs_ensmod.f90 b/src/gsi/cplr_gfs_ensmod.f90 index dc55bcaf9e..67f15ebae2 100644 --- a/src/gsi/cplr_gfs_ensmod.f90 +++ b/src/gsi/cplr_gfs_ensmod.f90 @@ -16,12 +16,22 @@ module get_gfs_ensmod_mod ! machine: ibm RS/6000 SP ! !$$$ + use kinds, only: i_kind,r_kind,r_single use mpeu_util, only: die use mpimod, only: mype,npe use abstract_ensmod, only: this_ens_class => abstractEnsemble + use genex_mod, only: genex_info implicit none private + + integer(i_kind) :: ias,iae,iasm,iaem,iaemz,jas,jae,jasm,jaem,jaemz + integer(i_kind) :: kas,kae,kasm,kaem,kaemz,mas,mae,masm,maem,maemz + integer(i_kind) :: ibs,ibe,ibsm,ibem,ibemz,jbs,jbe,jbsm,jbem,jbemz + integer(i_kind) :: kbs,kbe,kbsm,kbem,kbemz,mbs,mbe,mbsm,mbem,mbemz + integer(i_kind) :: n2d + type(genex_info) :: s_a2b + public :: ensemble public :: ensemble_typemold @@ -84,7 +94,6 @@ subroutine get_gfs_Nens(this,grd,members,ntindex,atm_bundle,iret) ! !$$$ - use kinds, only: i_kind,r_kind,r_single use gridmod, only: use_gfs_nemsio, use_gfs_ncio use general_sub2grid_mod, only: sub2grid_info use hybrid_ensemble_parameters, only: ens_fast_read @@ -153,10 +162,10 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & ! ! input argument list: ! ntindex - time index for ensemble -! ens_atm_bundle - atm bundle w/ fields for ensemble +! atm_bundle - atm bundle w/ fields for ensemble ! ! output argument list: -! ens_atm_bundle - atm bundle w/ fields for ensemble +! atm_bundle - atm bundle w/ fields for ensemble ! iret - return code, 0 for successful read. ! ! attributes: @@ -166,16 +175,16 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & !$$$ use mpimod, only: mpi_comm_world,ierror,mpi_real8,mpi_integer4,mpi_max - use kinds, only: i_kind,r_single,r_kind use constants, only: zero use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_destroy_info use gsi_4dvar, only: ens_fhrlevs use gsi_bundlemod, only: gsi_bundle - use hybrid_ensemble_parameters, only: n_ens,grd_ens + use gsi_bundlemod, only : assignment(=) + use hybrid_ensemble_parameters, only: n_ens,grd_ens,ntlevs_ens use hybrid_ensemble_parameters, only: ensemble_path use control_vectors, only: nc2d,nc3d !use control_vectors, only: cvars2d,cvars3d - use genex_mod, only: genex_info,genex_create_info,genex,genex_destroy_info + use genex_mod, only: genex_create_info,genex,genex_destroy_info use gridmod, only: use_gfs_nemsio use jfunc, only: cnvw_option @@ -195,16 +204,11 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & character(len=70) :: filenamesfc integer(i_kind) :: i,ii,j,jj,k,n integer(i_kind) :: io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,i_ens - integer(i_kind) :: ip,ips,ipe,jps,jpe - integer(i_kind) :: ias,iae,iasm,iaem,iaemz,jas,jae,jasm,jaem,jaemz - integer(i_kind) :: kas,kae,kasm,kaem,kaemz,mas,mae,masm,maem,maemz - integer(i_kind) :: ibs,ibe,ibsm,ibem,ibemz,jbs,jbe,jbsm,jbem,jbemz - integer(i_kind) :: kbs,kbe,kbsm,kbem,kbemz,mbs,mbe,mbsm,mbem,mbemz - integer(i_kind) :: n2d + integer(i_kind) :: ip integer(i_kind) :: nlon,nlat,nsig - type(genex_info) :: s_a2b + integer(i_kind),dimension(n_ens) :: io_pe0 real(r_single),allocatable,dimension(:,:,:,:) :: en_full,en_loc - real(r_kind),allocatable,dimension(:,:,:) :: en_loc3 + real(r_kind),allocatable,dimension(:) :: sloc integer(i_kind),allocatable,dimension(:) :: m_cvars2dw,m_cvars3dw integer(i_kind) :: m_cvars2d(nc2d),m_cvars3d(nc3d) type(sub2grid_info) :: grd3d @@ -214,61 +218,69 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & nlon=grd_ens%nlon nsig=grd_ens%nsig + if(ntindex == 1)then ! set up partition of available processors for parallel read - if ( n_ens > npe ) & - call die(myname_, ': ***ERROR*** CANNOT READ ENSEMBLE n_ens > npe, increase npe >= n_ens', 99) + if ( n_ens > npe ) & + call die(myname_, ': ***ERROR*** CANNOT READ ENSEMBLE n_ens > npe, increase npe >= n_ens', 99) - call ens_io_partition_(n_ens,ntindex,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,i_ens) - ! setup communicator for scatter to subdomains: - - ! first, define gsi subdomain boundaries in global units: + call ens_io_partition_(n_ens,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,io_pe0,i_ens) - ip=1 ! halo width is hardwired at 1 - ips=grd_ens%istart(mype+1) - ipe=ips+grd_ens%lat1-1 - jps=grd_ens%jstart(mype+1) - jpe=jps+grd_ens%lon1-1 + ! setup communicator for scatter to subdomains: + ! first, define gsi subdomain boundaries in global units: !!!!!!!!!!!!NOTE--FOLLOWING HAS MANY VARS TO BE DEFINED--NLAT,NLON ARE ENSEMBLE DOMAIN DIMS !!!!!!!!for example, n2d = nc3d*nsig + nc2d - n2d=nc3d*grd_ens%nsig+nc2d - ias=1 ; iae=0 ; jas=1 ; jae=0 ; kas=1 ; kae=0 ; mas=1 ; mae=0 - if(mype==io_pe) then - iae=nlat - jae=nlon - kae=n2d - mas=n_io_pe_s ; mae=n_io_pe_em - endif - iasm=ias ; iaem=iae ; jasm=jas ; jaem=jae ; kasm=kas ; kaem=kae ; masm=mas ; maem=mae - - ibs =ips ; ibe =ipe ; jbs =jps ; jbe =jpe - ibsm=ibs-ip ; ibem=ibe+ip ; jbsm=jbs-ip ; jbem=jbe+ip - kbs =1 ; kbe =n2d ; mbs =1 ; mbe =n_ens - kbsm=kbs ; kbem=kbe ; mbsm=mbs ; mbem=mbe - iaemz=max(iasm,iaem) ; jaemz=max(jasm,jaem) - kaemz=max(kasm,kaem) ; maemz=max(masm,maem) - ibemz=max(ibsm,ibem) ; jbemz=max(jbsm,jbem) - kbemz=max(kbsm,kbem) ; mbemz=max(mbsm,mbem) - call genex_create_info(s_a2b,ias ,iae ,jas ,jae ,kas ,kae ,mas ,mae , & - ibs ,ibe ,jbs ,jbe ,kbs ,kbe ,mbs ,mbe , & - iasm,iaem,jasm,jaem,kasm,kaem,masm,maem, & - ibsm,ibem,jbsm,jbem,kbsm,kbem,mbsm,mbem) - - write(filename,22) trim(adjustl(ensemble_path)),ens_fhrlevs(ntindex),mas -22 format(a,'sigf',i2.2,'_ens_mem',i3.3) + n2d=nc3d*grd_ens%nsig+nc2d + ias=1 ; iae=0 ; jas=1 ; jae=0 ; kas=1 ; kae=0 ; mas=1 ; mae=0 + if(mype==io_pe) then + iae=nlat + jae=nlon + kae=n2d + mas=n_io_pe_s ; mae=n_io_pe_em + endif + iasm=ias ; iaem=iae ; jasm=jas ; jaem=jae ; kasm=kas ; kaem=kae ; masm=mas ; maem=mae + + ip=1 ! halo width is hardwired at 1 + ibs=grd_ens%istart(mype+1) + ibe=ibs+grd_ens%lat1-1 + jbs=grd_ens%jstart(mype+1) + jbe=jbs+grd_ens%lon1-1 + + ibsm=ibs-ip ; ibem=ibe+ip ; jbsm=jbs-ip ; jbem=jbe+ip + kbs =1 ; kbe =n2d ; mbs =1 ; mbe =n_ens + kbsm=kbs ; kbem=kbe ; mbsm=mbs ; mbem=mbe + iaemz=max(iasm,iaem) ; jaemz=max(jasm,jaem) + kaemz=max(kasm,kaem) ; maemz=max(masm,maem) + ibemz=max(ibsm,ibem) ; jbemz=max(jbsm,jbem) + kbemz=max(kbsm,kbem) ; mbemz=max(mbsm,mbem) + call genex_create_info(s_a2b,ias ,iae ,jas ,jae ,kas ,kae ,mas ,mae , & + ibs ,ibe ,jbs ,jbe ,kbs ,kbe ,mbs ,mbe , & + iasm,iaem,jasm,jaem,kasm,kaem,masm,maem, & + ibsm,ibem,jbsm,jbem,kbsm,kbem,mbsm,mbem) + + if(mype==0)then + do n=1,n_ens + write(6,'(3(a,1x,i5,1x))') 'reading ensemble member', n,'on pe', io_pe0(n) + enddo + end if + end if + if(mype==0) write(6,*) ' reading time level ',ntindex allocate(m_cvars2dw(nc2din),m_cvars3dw(nc3din)) m_cvars2dw=-999 m_cvars3dw=-999 - allocate(en_full(iasm:iaemz,jasm:jaemz,kasm:kaemz,masm:maemz)) + !! read ensembles if ( mas == mae ) then + allocate(en_full(iasm:iaemz,jasm:jaemz,kasm:kaemz,masm:maemz)) + write(filename,22) trim(adjustl(ensemble_path)),ens_fhrlevs(ntindex),mas +22 format(a,'sigf',i2.2,'_ens_mem',i3.3) if ( use_gfs_nemsio ) then if (cnvw_option) then write(filenamesfc,23) trim(adjustl(ensemble_path)),ens_fhrlevs(ntindex),mas @@ -284,7 +296,7 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & filename,.true.) end if else - call parallel_read_gfsnc_state_(en_full,m_cvars2dw,m_cvars3dw,nlon,nlat,nsig, & + call parallel_read_gfsnc_state_(en_full,m_cvars2dw,m_cvars3dw,nlon,nlat,nsig, & ias,jas,mas, & iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz, & filename) @@ -295,43 +307,41 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & call mpi_allreduce(m_cvars3dw,m_cvars3d,nc3d,mpi_integer4,mpi_max,mpi_comm_world,ierror) deallocate(m_cvars2dw,m_cvars3dw) + ! scatter to subdomains: +! en_loc=zero allocate(en_loc(ibsm:ibemz,jbsm:jbemz,kbsm:kbemz,mbsm:mbemz)) - - en_loc=zero call genex(s_a2b,en_full,en_loc) - deallocate(en_full) - call genex_destroy_info(s_a2b) ! check on actual routine name + if(mas == mae)deallocate(en_full) + -! transfer en_loc to en_loc3 then to atm_bundle +! call genex_destroy_info(s_a2b) ! check on actual routine name - allocate(en_loc3(lat2in,lon2in,nc2d+nc3d*nsig)) - iret = 0 + allocate(sloc(lat2in*lon2in*(nc2d+nc3d*nsig))) call create_grd23d_(grd3d,nc2d+nc3d*grd%nsig) + + iret=0 do n=1,n_ens + ii=0 do k=1,nc2d+nc3d*nsig - jj=0 do j=jbsm,jbem - jj=jj+1 - ii=0 do i=ibsm,ibem ii=ii+1 - en_loc3(ii,jj,k)=en_loc(i,j,k,n) + sloc(ii)=en_loc(i,j,k,n) enddo enddo enddo - call move2bundle_(grd3d,en_loc3,atm_bundle(n),m_cvars2d,m_cvars3d,iret) + call move2bundle_(grd3d,sloc,atm_bundle(n),m_cvars2d,m_cvars3d,iret) enddo + deallocate(en_loc,sloc) call general_sub2grid_destroy_info(grd3d,grd) - deallocate(en_loc,en_loc3) - end subroutine get_user_ens_gfs_fastread_ -subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) +subroutine move2bundle_(grd3d,sloc,atm_bundle,m_cvars2d,m_cvars3d,iret) !$$$ subprogram documentation block ! . . . . @@ -347,7 +357,7 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) ! ! input argument list: ! grd - grd info for ensemble -! en_loc3 - ensemble member +! sloc - ensemble member ! atm_bundle - empty atm bundle ! m_cvars2d - maps 3rd index in en_loc3 for start of each 2d variable ! m_cvars3d - maps 3rd index in en_loc3 for start of each 3d variable @@ -361,13 +371,11 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) ! !$$$ - use kinds, only: i_kind,r_kind,r_single use constants, only: zero,one,two,fv use general_sub2grid_mod, only: sub2grid_info use hybrid_ensemble_parameters, only: en_perts use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer - use gsi_bundlemod, only : assignment(=) use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d use mpeu_util, only: getindex @@ -375,10 +383,10 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) ! Declare passed variables type(sub2grid_info), intent(in ) :: grd3d - real(r_kind), intent(inout) :: en_loc3(grd3d%lat2,grd3d%lon2,nc2d+nc3d*grd3d%nsig) type(gsi_bundle), intent(inout) :: atm_bundle + real(r_kind), intent(inout) :: sloc(grd3d%lat2*grd3d%lon2*(nc2d+nc3d*grd3d%nsig)) integer(i_kind), intent(in ) :: m_cvars2d(nc2d),m_cvars3d(nc3d) - integer(i_kind), intent( out) :: iret + integer(i_kind), intent(inout) :: iret ! Declare internal variables character(len=*),parameter :: myname_='move2bundle_' @@ -389,13 +397,14 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) integer(i_kind) :: icw,iql,iqi,iqr,iqs,iqg real(r_kind),pointer,dimension(:,:) :: ps !real(r_kind),pointer,dimension(:,:) :: sst + real(r_kind),dimension(grd3d%lat2,grd3d%lon2,nc2d+nc3d*grd3d%nsig)::en_loc3 real(r_kind),pointer,dimension(:,:,:) :: u,v,tv,q,oz,cwmr real(r_kind),pointer,dimension(:,:,:) :: qlmr,qimr,qrmr,qsmr,qgmr real(r_kind),parameter :: r0_001 = 0.001_r_kind !--- now update halo values of all variables using general_sub2grid - call update_halos_(grd3d,en_loc3) + call update_halos_(grd3d,sloc,en_loc3) ! Check hydrometeors in control variables icw=getindex(cvars3d,'cw') @@ -405,12 +414,16 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) iqs=getindex(cvars3d,'qs') iqg=getindex(cvars3d,'qg') -! initialize atm_bundle to zero +! atm_bundle to zero done earlier - atm_bundle=zero + call gsi_bundlegetpointer(atm_bundle,'ps',ps, ierr); iret = iret+ierr + !call gsi_bundlegetpointer(atm_bundle,'sst',sst, ierr); iret = iret+ierr + do m=1,nc2d +! convert ps from Pa to cb + if(trim(cvars2d(m))=='ps') ps=r0_001*en_loc3(:,:,m_cvars2d(m)) +! if(trim(cvars2d(m))=='sst') sst=en_loc3(:,:,m_cvars2d(m)) !no sst for now + enddo - call gsi_bundlegetpointer(atm_bundle,'ps',ps, ierr); iret = ierr - !call gsi_bundlegetpointer(atm_bundle,'sst',sst, ierr); iret = ierr call gsi_bundlegetpointer(atm_bundle,'sf',u , ierr); iret = ierr + iret call gsi_bundlegetpointer(atm_bundle,'vp',v , ierr); iret = ierr + iret call gsi_bundlegetpointer(atm_bundle,'t' ,tv, ierr); iret = ierr + iret @@ -425,7 +438,7 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) if ( iret /= 0 ) then if ( mype == 0 ) then write(6,'(A)') trim(myname_) // ': ERROR!' - write(6,'(A)') trim(myname_) // ': For now, GFS requires all MetFields: ps,u,v,(sf,vp)tv,q,oz,cw' + write(6,'(A)') trim(myname_) // ': For now, GFS requires all MetFields: ps,u,v,(sf,vp)tv,q,oz' write(6,'(A)') trim(myname_) // ': but some have not been found. Aborting ... ' write(6,'(A)') trim(myname_) // ': WARNING!' write(6,'(3A,I5)') trim(myname_) // ': Trouble reading ensemble file : ', trim(filename), ', IRET = ', iret @@ -433,13 +446,6 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) return endif - - do m=1,nc2d -! convert ps from Pa to cb - if(trim(cvars2d(m))=='ps') ps=r0_001*en_loc3(:,:,m_cvars2d(m)) -! if(trim(cvars2d(m))=='sst') sst=en_loc3(:,:,m_cvars2d(m)) !no sst for now - enddo - km1 = en_perts(1,1,1)%grid%km - 1 !$omp parallel do schedule(dynamic,1) private(m) do m=1,nc3d @@ -477,7 +483,6 @@ end subroutine move2bundle_ subroutine create_grd23d_(grd23d,nvert) - use kinds, only: i_kind use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info use hybrid_ensemble_parameters, only: grd_ens @@ -498,21 +503,20 @@ subroutine create_grd23d_(grd23d,nvert) end subroutine create_grd23d_ -subroutine update_halos_(grd,s) +subroutine update_halos_(grd,sloc,s) - use kinds, only: i_kind,r_kind use general_sub2grid_mod, only: sub2grid_info,general_sub2grid,general_grid2sub implicit none ! Declare passed variables type(sub2grid_info), intent(in ) :: grd - real(r_kind), intent(inout) :: s(grd%lat2,grd%lon2,grd%num_fields) + real(r_kind), intent( out) :: s(grd%lat2,grd%lon2,grd%num_fields) + real(r_kind), intent(inout) :: sloc(grd%lat2*grd%lon2*grd%num_fields) ! Declare local variables - integer(i_kind) inner_vars,lat2,lon2,nlat,nlon,nvert,kbegin_loc,kend_loc,kend_alloc + integer(i_kind) inner_vars,lat2,lon2,nlat,nlon,nvert,kbegin_loc,kend_alloc integer(i_kind) ii,i,j,k - real(r_kind),allocatable,dimension(:) :: sloc real(r_kind),allocatable,dimension(:,:,:,:) :: work lat2=grd%lat2 @@ -522,22 +526,16 @@ subroutine update_halos_(grd,s) nvert=grd%num_fields inner_vars=grd%inner_vars kbegin_loc=grd%kbegin_loc - kend_loc=grd%kend_loc kend_alloc=grd%kend_alloc - allocate(sloc(lat2*lon2*nvert)) + + + allocate(work(inner_vars,nlat,nlon,kbegin_loc:kend_alloc)) - ii=0 - do k=1,nvert - do j=1,lon2 - do i=1,lat2 - ii=ii+1 - sloc(ii)=s(i,j,k) - enddo - enddo - enddo call general_sub2grid(grd,sloc,work) call general_grid2sub(grd,work,sloc) + deallocate(work) + ii=0 do k=1,nvert do j=1,lon2 @@ -548,33 +546,30 @@ subroutine update_halos_(grd,s) enddo enddo - deallocate(sloc,work) - end subroutine update_halos_ -subroutine ens_io_partition_(n_ens,ntindex,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,i_ens) +subroutine ens_io_partition_(n_ens,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,io_pe0,i_ens) ! do computation on all processors, then assign final local processor ! values. - use kinds, only: r_kind,i_kind use constants, only: half implicit none ! Declare passed variables - integer(i_kind),intent(in ) :: n_ens,ntindex + integer(i_kind),intent(in ) :: n_ens integer(i_kind),intent( out) :: io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,i_ens + integer(i_kind),intent( out) :: io_pe0(n_ens) ! Declare local variables - integer(i_kind) :: io_pe0(n_ens) integer(i_kind) :: iskip,jskip,nextra,ipe,n integer(i_kind) :: nsig i_ens=-1 nsig=1 iskip=npe/n_ens - nextra=npe-iskip*n_ens + nextra=npe-iskip*(n_ens-1)-1 jskip=iskip io_pe=-1 io_pe0=-1 @@ -589,13 +584,12 @@ subroutine ens_io_partition_(n_ens,ntindex,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em, else jskip=iskip endif + if(ipe > npe) then + write(6,*)' ens_io_partition_: ***ERROR*** ',ipe,jskip,' processor error: PROGRAM STOPS' + call stop2(999) + end if ipe=ipe+jskip enddo - if(mype==0)then - do n=1,n_ens - write(6,'(3(a,1x,i5,1x))') 'reading ensemble member', n,' time level',ntindex,'on pe', io_pe0(n) - enddo - end if do n=1,n_ens if(mype==io_pe0(n)) then @@ -614,7 +608,6 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz, & filename,init_head,filenamesfc) - use kinds, only: i_kind,r_kind,r_single use constants, only: r60,r3600,zero,one,half,deg2rad use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close use ncepnems_io, only: error_msg,imp_physics @@ -641,7 +634,6 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi ! Declare local variables integer(i_kind) i,ii,j,jj,k,lonb,latb,levs,latb2,lonb2 integer(i_kind) k2,k3,k3u,k3v,k3t,k3q,k3cw,k3oz,kf - integer(i_kind) k3ql,k3qi,k3qr,k3qs,k3qg integer(i_kind) iret integer(i_kind) :: istop = 101 integer(i_kind),dimension(7):: idate @@ -726,23 +718,40 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi allocate(work(nlon*(nlat-2))) if (imp_physics == 11) allocate(work2(nlon*(nlat-2))) allocate(temp3(nlat,nlon,nsig,nc3d)) - allocate(temp2(nlat,nlon,nc2d)) + temp3=zero k3u=0 ; k3v=0 ; k3t=0 ; k3q=0 ; k3cw=0 ; k3oz=0 - k3ql=0; k3qi=0; k3qr=0; k3qs=0; k3qg=0 do k3=1,nc3d - if(cvars3d(k3)=='sf') k3u=k3 - if(cvars3d(k3)=='vp') k3v=k3 - if(cvars3d(k3)=='t') k3t=k3 - if(cvars3d(k3)=='q') k3q=k3 - if(cvars3d(k3)=='cw') k3cw=k3 - if(cvars3d(k3)=='oz') k3oz=k3 - if(cvars3d(k3)=='ql') k3ql=k3 - if(cvars3d(k3)=='qi') k3qi=k3 - if(cvars3d(k3)=='qr') k3qr=k3 - if(cvars3d(k3)=='qs') k3qs=k3 - if(cvars3d(k3)=='qg') k3qg=k3 do k=1,nsig - if(trim(cvars3d(k3))=='cw') then + if(trim(cvars3d(k3))=='t') then + k3t=k3 + call nemsio_readrecv(gfile,'tmp','mid layer',k,work,iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'tmp','read',istop+3,iret,.true.) + call move1_(work,temp3(:,:,k,k3),nlon,nlat) + call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) + elseif(trim(cvars3d(k3))=='sf') then + k3u=k3 + call nemsio_readrecv(gfile,'ugrd','mid layer',k,work,iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'ugrd','read',istop+1,iret,.true.) + call move1_(work,temp3(:,:,k,k3),nlon,nlat) + elseif(trim(cvars3d(k3))=='vp') then + k3v=k3 + call nemsio_readrecv(gfile,'vgrd','mid layer',k,work,iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'vgrd','read',istop+2,iret,.true.) + call move1_(work,temp3(:,:,k,k3),nlon,nlat) + elseif(trim(cvars3d(k3))=='q') then + k3q=k3 + call nemsio_readrecv(gfile,'spfh','mid layer',k,work,iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),trim(cvars3d(k3)),'read',istop+4,iret,.true.) + call move1_(work,temp3(:,:,k,k3),nlon,nlat) + call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) + elseif(trim(cvars3d(k3))=='oz') then + k3oz=k3 + call nemsio_readrecv(gfile,'o3mr','mid layer',k,work,iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'o3mr','read',istop+5,iret,.true.) + call move1_(work,temp3(:,:,k,k3),nlon,nlat) + call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) + elseif(trim(cvars3d(k3))=='cw') then + k3cw=k3 call nemsio_readrecv(gfile,'clwmr','mid layer',k,work,iret=iret) if (iret /= 0) call error_msg(trim(myname_),trim(filename),'clwmr','read',istop+6,iret,.true.) if (imp_physics == 11) then @@ -789,30 +798,7 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi if (iret /= 0) call error_msg(trim(myname_),trim(filename),'grle','read',istop+12,iret) call move1_(work,temp3(:,:,k,k3),nlon,nlat) call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - elseif(trim(cvars3d(k3))=='oz') then - call nemsio_readrecv(gfile,'o3mr','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),'o3mr','read',istop+5,iret,.true.) - call move1_(work,temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - elseif(trim(cvars3d(k3))=='q') then - call nemsio_readrecv(gfile,'spfh','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),trim(cvars3d(k3)),'read',istop+4,iret,.true.) - call move1_(work,temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - elseif(trim(cvars3d(k3))=='t') then - call nemsio_readrecv(gfile,'tmp','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),'tmp','read',istop+3,iret,.true.) - call move1_(work,temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - elseif(trim(cvars3d(k3))=='sf') then - call nemsio_readrecv(gfile,'ugrd','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),'ugrd','read',istop+1,iret,.true.) - call move1_(work,temp3(:,:,k,k3),nlon,nlat) - elseif(trim(cvars3d(k3))=='vp') then - call nemsio_readrecv(gfile,'vgrd','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),'vgrd','read',istop+2,iret,.true.) - call move1_(work,temp3(:,:,k,k3),nlon,nlat) - endif + end if enddo enddo do k=1,nsig @@ -822,10 +808,29 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi if (k3u==0.or.k3v==0.or.k3t==0.or.k3q==0.or.k3oz==0) & write(6,'(" WARNING, problem with one of k3-")') +! move temp3 to en_full + kf=0 + do k3=1,nc3d + m_cvars3d(k3)=kf+1 + do k=1,nsig + kf=kf+1 + jj=jas-1 + do j=1,nlon + jj=jj+1 + ii=ias-1 + do i=1,nlat + ii=ii+1 + en_full(ii,jj,kf,mas)=temp3(i,j,k,k3) + enddo + enddo + enddo + enddo + deallocate(temp3) ! convert T to Tv: postpone this calculation ! temp3(:,:,:,k3t)=temp3(:,:,:,k3t)*(one+fv*temp3(:,:,:,k3q)) + allocate(temp2(nlat,nlon,nc2d)) temp2=zero do k2=1,nc2d !if(trim(cvars2d(k2))=='sst') then @@ -844,24 +849,7 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi deallocate(work) if (imp_physics == 11) deallocate(work2) -! move temp2,temp3 to en_full - kf=0 - do k3=1,nc3d - m_cvars3d(k3)=kf+1 - do k=1,nsig - kf=kf+1 - jj=jas-1 - do j=1,nlon - jj=jj+1 - ii=ias-1 - do i=1,nlat - ii=ii+1 - en_full(ii,jj,kf,mas)=temp3(i,j,k,k3) - enddo - enddo - enddo - enddo - deallocate(temp3) +! move temp2 to en_full do k2=1,nc2d m_cvars2d(k2)=kf+1 kf=kf+1 @@ -894,7 +882,6 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig ! !$$$ - use kinds, only: i_kind,r_kind,r_single use constants, only: r60,r3600,zero,one,half,deg2rad use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d use general_sub2grid_mod, only: sub2grid_info @@ -917,7 +904,6 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig logical :: file_exist integer(i_kind) i,ii,j,jj,k,lonb,latb,levs,kr,ierror integer(i_kind) k2,k3,k3u,k3v,k3t,k3q,k3cw,k3oz,kf - integer(i_kind) k3ql,k3qi,k3qr,k3qs,k3qg character(len=120) :: myname_ = 'parallel_read_gfsnc_state_' real(r_single),allocatable,dimension(:,:,:) :: rwork3d1, rwork3d2 real(r_single),allocatable,dimension(:,:) :: temp2,rwork2d @@ -968,9 +954,20 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig allocate(rwork3d1(nlon,(nlat-2),nsig)) allocate(temp3(nlat,nlon,nsig,nc3d)) k3u=0 ; k3v=0 ; k3t=0 ; k3q=0 ; k3cw=0 ; k3oz=0 - k3ql=0; k3qi=0; k3qr=0; k3qs=0; k3qg=0 do k3=1,nc3d - if (trim(cvars3d(k3))=='cw') then + if(trim(cvars3d(k3))=='t') then + k3t=k3 + call read_vardata(atmges, 'tmp', rwork3d1) + else if(trim(cvars3d(k3))=='sf') then + k3u=k3 + call read_vardata(atmges, 'ugrd', rwork3d1) + else if(trim(cvars3d(k3))=='vp') then + k3v=k3 + call read_vardata(atmges, 'vgrd', rwork3d1) + else if(trim(cvars3d(k3))=='q') then + k3q=k3 + call read_vardata(atmges, 'spfh', rwork3d1) + else if (trim(cvars3d(k3))=='cw') then k3cw=k3 call read_vardata(atmges, 'clwmr', rwork3d1) allocate(rwork3d2(nlon,(nlat-2),nsig)) @@ -978,90 +975,25 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig call read_vardata(atmges, 'icmr', rwork3d2) rwork3d1 = rwork3d1 + rwork3d2 deallocate(rwork3d2) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do + else if(trim(cvars3d(k3))=='oz') then + k3oz=k3 + call read_vardata(atmges, 'o3mr', rwork3d1) else if(trim(cvars3d(k3))=='ql') then - k3ql=k3 call read_vardata(atmges, 'clwmr', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do else if(trim(cvars3d(k3))=='qi') then - k3qi=k3 call read_vardata(atmges, 'icmr', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do else if(trim(cvars3d(k3))=='qr') then - k3qr=k3 call read_vardata(atmges, 'rwmr', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do else if(trim(cvars3d(k3))=='qs') then - k3qs=k3 call read_vardata(atmges, 'snmr', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do else if(trim(cvars3d(k3))=='qg') then - k3qg=k3 call read_vardata(atmges, 'grle', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do - else if(trim(cvars3d(k3))=='oz') then - k3oz=k3 - call read_vardata(atmges, 'o3mr', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do - else if(trim(cvars3d(k3))=='q') then - k3q=k3 - call read_vardata(atmges, 'spfh', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do - else if(trim(cvars3d(k3))=='t') then - k3t=k3 - call read_vardata(atmges, 'tmp', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do - else if(trim(cvars3d(k3))=='sf') then - k3u=k3 - call read_vardata(atmges, 'ugrd', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - end do - else if(trim(cvars3d(k3))=='vp') then - k3v=k3 - call read_vardata(atmges, 'vgrd', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - end do end if +!$omp parallel do schedule(dynamic,1) private(k,kr) + do k=1,nsig + kr = levs+1-k + call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) + end do enddo deallocate(rwork3d1) @@ -1069,13 +1001,20 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig if (k3u==0.or.k3v==0.or.k3t==0.or.k3q==0.or.k3oz==0) & write(6,'(" WARNING, problem with one of k3-")') +!$omp parallel do schedule(dynamic,1) private(k,k3) do k=1,nsig call fillpoles_sv_(temp3(:,:,k,k3u),temp3(:,:,k,k3v),nlon,nlat,clons,slons) end do -! move temp2,temp3 to en_full - kf=0 +! move temp3 to en_full +!$omp parallel do schedule(dynamic,1) private(k3,k,kf,j,jj,i,ii) do k3=1,nc3d + if(k3 /= k3u .and. k3 /= k3v)then + do k=1,nsig + call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) + end do + end if + kf=(k3-1)*nsig m_cvars3d(k3)=kf+1 do k=1,nsig kf=kf+1 @@ -1094,6 +1033,7 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig deallocate(temp3) allocate(temp2(nlat,nlon)) allocate(rwork2d(nlon,(nlat-2))) + kf=nc3d*nsig do k2=1,nc2d if(trim(cvars2d(k2))=='ps') then call read_vardata(atmges, 'pressfc', rwork2d) @@ -1103,6 +1043,7 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig temp2=zero endif +! move temp2 to en_full kf=kf+1 m_cvars2d(k2)=kf jj=jas-1 @@ -1115,6 +1056,7 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig enddo enddo enddo +! call close_dataset(atmges) deallocate(rwork2d) deallocate(temp2) @@ -1147,7 +1089,6 @@ subroutine fillpoles_ss_(temp,nlon,nlat) ! !$$$ - use kinds, only: i_kind,r_kind,r_single use constants, only: zero,one implicit none @@ -1157,6 +1098,7 @@ subroutine fillpoles_ss_(temp,nlon,nlat) integer(i_kind) nlatm1,i real(r_kind) sumn,sums,rnlon + real(r_single) sumn_sing,sums_sing ! Compute mean along southern and northern latitudes sumn=zero @@ -1167,13 +1109,13 @@ subroutine fillpoles_ss_(temp,nlon,nlat) sums=sums+temp(2,i) end do rnlon=one/float(nlon) - sumn=sumn*rnlon - sums=sums*rnlon + sumn_sing=sumn*rnlon + sums_sing=sums*rnlon ! Load means into local work array do i=1,nlon - temp(1,i) =sums - temp(nlat,i)=sumn + temp(1,i) =sums_sing + temp(nlat,i)=sumn_sing end do end subroutine fillpoles_ss_ @@ -1205,13 +1147,12 @@ subroutine fillpoles_sv_(tempu,tempv,nlon,nlat,clons,slons) ! !$$$ - use kinds, only: i_kind,r_kind,r_single use constants, only: zero implicit none integer(i_kind),intent(in ) :: nlon,nlat - real(r_single), intent(inout) :: tempu(nlat,nlon),tempv(nlat,nlon) + real(r_single), intent(inout) :: tempu(nlat,nlon),tempv(nlat,nlon) real(r_kind), intent(in ) :: clons(nlon),slons(nlon) integer(i_kind) i @@ -1266,7 +1207,6 @@ subroutine move1_(work,temp,nlon,nlat) ! !$$$ - use kinds, only: i_kind,r_kind,r_single use constants, only: zero implicit none @@ -1316,7 +1256,6 @@ subroutine get_gfs_ens(this,grd,member,ntindex,atm_bundle,iret) ! !$$$ - use kinds, only: i_kind,r_kind use gridmod, only: use_gfs_nemsio, use_gfs_ncio use general_sub2grid_mod, only: sub2grid_info use gsi_4dvar, only: ens_fhrlevs @@ -1420,7 +1359,6 @@ subroutine put_gfs_ens(this,grd,member,ntindex,pert,iret) ! !$$$ - use kinds, only: i_kind use general_sub2grid_mod, only: sub2grid_info use gsi_bundlemod, only: gsi_bundle use gsi_4dvar, only: ens_fhrlevs @@ -1483,7 +1421,6 @@ end subroutine put_gfs_ens subroutine non_gaussian_ens_grid_gfs(this,elats,elons) - use kinds, only: r_kind use hybrid_ensemble_parameters, only: sp_ens implicit none @@ -1515,7 +1452,6 @@ end subroutine non_gaussian_ens_grid_gfs subroutine create_sub2grid_info(s2gi,nsig,npe,s2gi_ref) !> Create temporary communication information object for read ensemble routines - use kinds, only: i_kind use gridmod, only: regional use general_sub2grid_mod, only: sub2grid_info use general_sub2grid_mod, only: general_sub2grid_create_info diff --git a/src/gsi/cplr_gfs_nstmod.f90 b/src/gsi/cplr_gfs_nstmod.f90 index b482085aac..220fa55af1 100644 --- a/src/gsi/cplr_gfs_nstmod.f90 +++ b/src/gsi/cplr_gfs_nstmod.f90 @@ -139,15 +139,15 @@ subroutine deter_nst_(dlat_earth,dlon_earth,obstime,zob,tref,dtw,dtc,tz_tr) integer(i_kind):: itnst,itnstp integer(i_kind):: ix,iy,ixp,iyp,j real(r_kind):: dx,dy,dx1,dy1,w00,w10,w01,w11,dtnst,dtnstp - real(r_kind):: tref_00,tref_01,tref_10,tref_11,tr_tmp - real(r_kind):: dt_cool_00,dt_cool_01,dt_cool_10,dt_cool_11 - real(r_kind):: z_c_00,z_c_01,z_c_10,z_c_11 - real(r_kind):: dt_warm_00,dt_warm_01,dt_warm_10,dt_warm_11 - real(r_kind):: z_w_00,z_w_01,z_w_10,z_w_11,z_w_tmp - real(r_kind):: c_0_00,c_0_01,c_0_10,c_0_11 - real(r_kind):: c_d_00,c_d_01,c_d_10,c_d_11 - real(r_kind):: w_0_00,w_0_01,w_0_10,w_0_11 - real(r_kind):: w_d_00,w_d_01,w_d_10,w_d_11 + real(r_kind):: tref_tt,tref2 + real(r_kind):: dt_cool_tt + real(r_kind):: z_c_tt + real(r_kind):: dt_warm_tt + real(r_kind):: z_w_tt + real(r_kind):: c_0_tt + real(r_kind):: c_d_tt + real(r_kind):: w_0_tt + real(r_kind):: w_d_tt real(r_kind):: wgtavg,dlat,dlon logical outside @@ -199,138 +199,137 @@ subroutine deter_nst_(dlat_earth,dlon_earth,obstime,zob,tref,dtw,dtc,tz_tr) ! ! Use the time interpolation factors for nst files ! - tref_00 = tref_full (ix ,iy ,itnst)*dtnst + tref_full (ix ,iy ,itnstp)*dtnstp - tref_01 = tref_full (ix ,iyp,itnst)*dtnst + tref_full (ix ,iyp,itnstp)*dtnstp - tref_10 = tref_full (ixp,iy ,itnst)*dtnst + tref_full (ixp,iy ,itnstp)*dtnstp - tref_11 = tref_full (ixp,iyp,itnst)*dtnst + tref_full (ixp,iyp,itnstp)*dtnstp - - dt_cool_00 = dt_cool_full(ix ,iy ,itnst)*dtnst + dt_cool_full(ix ,iy ,itnstp)*dtnstp - dt_cool_01 = dt_cool_full(ix ,iyp,itnst)*dtnst + dt_cool_full(ix ,iyp,itnstp)*dtnstp - dt_cool_10 = dt_cool_full(ixp,iy ,itnst)*dtnst + dt_cool_full(ixp,iy ,itnstp)*dtnstp - dt_cool_11 = dt_cool_full(ixp,iyp,itnst)*dtnst + dt_cool_full(ixp,iyp,itnstp)*dtnstp - - z_c_00 = z_c_full (ix ,iy ,itnst)*dtnst + z_c_full (ix ,iy ,itnstp)*dtnstp - z_c_01 = z_c_full (ix ,iyp,itnst)*dtnst + z_c_full (ix ,iyp,itnstp)*dtnstp - z_c_10 = z_c_full (ixp,iy ,itnst)*dtnst + z_c_full (ixp,iy ,itnstp)*dtnstp - z_c_11 = z_c_full (ixp,iyp,itnst)*dtnst + z_c_full (ixp,iyp,itnstp)*dtnstp - - dt_warm_00 = dt_warm_full(ix ,iy ,itnst)*dtnst + dt_warm_full(ix ,iy ,itnstp)*dtnstp - dt_warm_01 = dt_warm_full(ix ,iyp,itnst)*dtnst + dt_warm_full(ix ,iyp,itnstp)*dtnstp - dt_warm_10 = dt_warm_full(ixp,iy ,itnst)*dtnst + dt_warm_full(ixp,iy ,itnstp)*dtnstp - dt_warm_11 = dt_warm_full(ixp,iyp,itnst)*dtnst + dt_warm_full(ixp,iyp,itnstp)*dtnstp - - z_w_00 = z_w_full (ix ,iy ,itnst)*dtnst + z_w_full (ix ,iy ,itnstp)*dtnstp - z_w_01 = z_w_full (ix ,iyp,itnst)*dtnst + z_w_full (ix ,iyp,itnstp)*dtnstp - z_w_10 = z_w_full (ixp,iy ,itnst)*dtnst + z_w_full (ixp,iy ,itnstp)*dtnstp - z_w_11 = z_w_full (ixp,iyp,itnst)*dtnst + z_w_full (ixp,iyp,itnstp)*dtnstp - - c_0_00 = c_0_full (ix ,iy ,itnst)*dtnst + c_0_full (ix ,iy ,itnstp)*dtnstp - c_0_01 = c_0_full (ix ,iyp,itnst)*dtnst + c_0_full (ix ,iyp,itnstp)*dtnstp - c_0_10 = c_0_full (ixp,iy ,itnst)*dtnst + c_0_full (ixp,iy ,itnstp)*dtnstp - c_0_11 = c_0_full (ixp,iyp,itnst)*dtnst + c_0_full (ixp,iyp,itnstp)*dtnstp - - c_d_00 = c_d_full (ix ,iy ,itnst)*dtnst + c_d_full (ix ,iy ,itnstp)*dtnstp - c_d_01 = c_d_full (ix ,iyp,itnst)*dtnst + c_d_full (ix ,iyp,itnstp)*dtnstp - c_d_10 = c_d_full (ixp,iy ,itnst)*dtnst + c_d_full (ixp,iy ,itnstp)*dtnstp - c_d_11 = c_d_full (ixp,iyp,itnst)*dtnst + c_d_full (ixp,iyp,itnstp)*dtnstp - - w_0_00 = w_0_full (ix ,iy ,itnst)*dtnst + w_0_full (ix ,iy ,itnstp)*dtnstp - w_0_01 = w_0_full (ix ,iyp,itnst)*dtnst + w_0_full (ix ,iyp,itnstp)*dtnstp - w_0_10 = w_0_full (ixp,iy ,itnst)*dtnst + w_0_full (ixp,iy ,itnstp)*dtnstp - w_0_11 = w_0_full (ixp,iyp,itnst)*dtnst + w_0_full (ixp,iyp,itnstp)*dtnstp - - w_d_00 = w_d_full (ix ,iy ,itnst)*dtnst + w_d_full (ix ,iy ,itnstp)*dtnstp - w_d_01 = w_d_full (ix ,iyp,itnst)*dtnst + w_d_full (ix ,iyp,itnstp)*dtnstp - w_d_10 = w_d_full (ixp,iy ,itnst)*dtnst + w_d_full (ixp,iy ,itnstp)*dtnstp - w_d_11 = w_d_full (ixp,iyp,itnst)*dtnst + w_d_full (ixp,iyp,itnstp)*dtnstp ! Interpolate nst variables to obs location (water surface only) wgtavg = zero - tr_tmp = zero + tref2 = zero dt_cool = zero - z_c = zero dt_warm = zero - z_w_tmp = zero + z_c = zero + z_w = zero c_0 = zero c_d = zero w_0 = zero w_d = zero + tz_tr = one + dtw = zero + dtc = zero if (istyp00 == 0)then + tref_tt = tref_full (ix ,iy ,itnst)*dtnst + tref_full (ix ,iy ,itnstp)*dtnstp + dt_cool_tt = dt_cool_full(ix ,iy ,itnst)*dtnst + dt_cool_full(ix ,iy ,itnstp)*dtnstp + dt_warm_tt = dt_warm_full(ix ,iy ,itnst)*dtnst + dt_warm_full(ix ,iy ,itnstp)*dtnstp + z_c_tt = z_c_full (ix ,iy ,itnst)*dtnst + z_c_full (ix ,iy ,itnstp)*dtnstp + z_w_tt = z_w_full (ix ,iy ,itnst)*dtnst + z_w_full (ix ,iy ,itnstp)*dtnstp + c_0_tt = c_0_full (ix ,iy ,itnst)*dtnst + c_0_full (ix ,iy ,itnstp)*dtnstp + c_d_tt = c_d_full (ix ,iy ,itnst)*dtnst + c_d_full (ix ,iy ,itnstp)*dtnstp + w_0_tt = w_0_full (ix ,iy ,itnst)*dtnst + w_0_full (ix ,iy ,itnstp)*dtnstp + w_d_tt = w_d_full (ix ,iy ,itnst)*dtnst + w_d_full (ix ,iy ,itnstp)*dtnstp wgtavg = wgtavg + w00 - tr_tmp = tr_tmp + w00*tref_00 - dt_cool = dt_cool + w00*dt_cool_00 - z_c = z_c + w00*z_c_00 - dt_warm = dt_warm + w00*dt_warm_00 - z_w_tmp = z_w_tmp + w00*z_w_00 - c_0 = c_0 + w00*c_0_00 - c_d = c_d + w00*c_d_00 - w_0 = w_0 + w00*w_0_00 - w_d = w_d + w00*w_d_00 + tref2 = tref2 + w00*tref_tt + dt_cool = dt_cool + w00*dt_cool_tt + dt_warm = dt_warm + w00*dt_warm_tt + z_c = z_c + w00*z_c_tt + z_w = z_w + w00*z_w_tt + c_0 = c_0 + w00*c_0_tt + c_d = c_d + w00*c_d_tt + w_0 = w_0 + w00*w_0_tt + w_d = w_d + w00*w_d_tt endif if(istyp01 == 0)then + tref_tt = tref_full (ix ,iyp,itnst)*dtnst + tref_full (ix ,iyp,itnstp)*dtnstp + dt_cool_tt = dt_cool_full(ix ,iyp,itnst)*dtnst + dt_cool_full(ix ,iyp,itnstp)*dtnstp + dt_warm_tt = dt_warm_full(ix ,iyp,itnst)*dtnst + dt_warm_full(ix ,iyp,itnstp)*dtnstp + z_c_tt = z_c_full (ix ,iyp,itnst)*dtnst + z_c_full (ix ,iyp,itnstp)*dtnstp + z_w_tt = z_w_full (ix ,iyp,itnst)*dtnst + z_w_full (ix ,iyp,itnstp)*dtnstp + c_0_tt = c_0_full (ix ,iyp,itnst)*dtnst + c_0_full (ix ,iyp,itnstp)*dtnstp + c_d_tt = c_d_full (ix ,iyp,itnst)*dtnst + c_d_full (ix ,iyp,itnstp)*dtnstp + w_0_tt = w_0_full (ix ,iyp,itnst)*dtnst + w_0_full (ix ,iyp,itnstp)*dtnstp + w_d_tt = w_d_full (ix ,iyp,itnst)*dtnst + w_d_full (ix ,iyp,itnstp)*dtnstp wgtavg = wgtavg + w01 - tr_tmp = tr_tmp + w01*tref_01 - dt_cool = dt_cool + w01*dt_cool_01 - z_c = z_c + w01*z_c_01 - dt_warm = dt_warm + w01*dt_warm_01 - z_w_tmp = z_w_tmp + w01*z_w_01 - c_0 = c_0 + w01*c_0_01 - c_d = c_d + w01*c_d_01 - w_0 = w_0 + w01*w_0_01 - w_d = w_d + w01*w_d_01 + tref2 = tref2 + w01*tref_tt + dt_cool = dt_cool + w01*dt_cool_tt + dt_warm = dt_warm + w01*dt_warm_tt + z_c = z_c + w01*z_c_tt + z_w = z_w + w01*z_w_tt + c_0 = c_0 + w01*c_0_tt + c_d = c_d + w01*c_d_tt + w_0 = w_0 + w01*w_0_tt + w_d = w_d + w01*w_d_tt end if if(istyp10 == 0)then + tref_tt = tref_full (ixp,iy ,itnst)*dtnst + tref_full (ixp,iy ,itnstp)*dtnstp + dt_cool_tt = dt_cool_full(ixp,iy ,itnst)*dtnst + dt_cool_full(ixp,iy ,itnstp)*dtnstp + dt_warm_tt = dt_warm_full(ixp,iy ,itnst)*dtnst + dt_warm_full(ixp,iy ,itnstp)*dtnstp + z_c_tt = z_c_full (ixp,iy ,itnst)*dtnst + z_c_full (ixp,iy ,itnstp)*dtnstp + z_w_tt = z_w_full (ixp,iy ,itnst)*dtnst + z_w_full (ixp,iy ,itnstp)*dtnstp + c_0_tt = c_0_full (ixp,iy ,itnst)*dtnst + c_0_full (ixp,iy ,itnstp)*dtnstp + c_d_tt = c_d_full (ixp,iy ,itnst)*dtnst + c_d_full (ixp,iy ,itnstp)*dtnstp + w_0_tt = w_0_full (ixp,iy ,itnst)*dtnst + w_0_full (ixp,iy ,itnstp)*dtnstp + w_d_tt = w_d_full (ixp,iy ,itnst)*dtnst + w_d_full (ixp,iy ,itnstp)*dtnstp wgtavg = wgtavg + w10 - tr_tmp = tr_tmp + w10*tref_10 - dt_cool = dt_cool + w10*dt_cool_10 - z_c = z_c + w10*z_c_10 - dt_warm = dt_warm + w10*dt_warm_10 - z_w_tmp = z_w_tmp + w10*z_w_10 - c_0 = c_0 + w10*c_0_10 - c_d = c_d + w10*c_d_10 - w_0 = w_0 + w10*w_0_10 - w_d = w_d + w10*w_d_10 + tref2 = tref2 + w10*tref_tt + dt_cool = dt_cool + w10*dt_cool_tt + dt_warm = dt_warm + w10*dt_warm_tt + z_c = z_c + w10*z_c_tt + z_w = z_w + w10*z_w_tt + c_0 = c_0 + w10*c_0_tt + c_d = c_d + w10*c_d_tt + w_0 = w_0 + w10*w_0_tt + w_d = w_d + w10*w_d_tt end if if(istyp11 == 0)then + tref_tt = tref_full (ixp,iyp,itnst)*dtnst + tref_full (ixp,iyp,itnstp)*dtnstp + dt_cool_tt = dt_cool_full(ixp,iyp,itnst)*dtnst + dt_cool_full(ixp,iyp,itnstp)*dtnstp + dt_warm_tt = dt_warm_full(ixp,iyp,itnst)*dtnst + dt_warm_full(ixp,iyp,itnstp)*dtnstp + z_c_tt = z_c_full (ixp,iyp,itnst)*dtnst + z_c_full (ixp,iyp,itnstp)*dtnstp + z_w_tt = z_w_full (ixp,iyp,itnst)*dtnst + z_w_full (ixp,iyp,itnstp)*dtnstp + c_0_tt = c_0_full (ixp,iyp,itnst)*dtnst + c_0_full (ixp,iyp,itnstp)*dtnstp + c_d_tt = c_d_full (ixp,iyp,itnst)*dtnst + c_d_full (ixp,iyp,itnstp)*dtnstp + w_0_tt = w_0_full (ixp,iyp,itnst)*dtnst + w_0_full (ixp,iyp,itnstp)*dtnstp + w_d_tt = w_d_full (ixp,iyp,itnst)*dtnst + w_d_full (ixp,iyp,itnstp)*dtnstp wgtavg = wgtavg + w11 - tr_tmp = tr_tmp + w11*tref_11 - dt_cool = dt_cool + w11*dt_cool_11 - z_c = z_c + w11*z_c_11 - dt_warm = dt_warm + w11*dt_warm_11 - z_w_tmp = z_w_tmp + w11*z_w_11 - c_0 = c_0 + w11*c_0_11 - c_d = c_d + w11*c_d_11 - w_0 = w_0 + w11*w_0_11 - w_d = w_d + w11*w_d_11 + tref2 = tref2 + w11*tref_tt + dt_cool = dt_cool + w11*dt_cool_tt + dt_warm = dt_warm + w11*dt_warm_tt + z_c = z_c + w11*z_c_tt + z_w = z_w + w11*z_w_tt + c_0 = c_0 + w11*c_0_tt + c_d = c_d + w11*c_d_tt + w_0 = w_0 + w11*w_0_tt + w_d = w_d + w11*w_d_tt end if + if(wgtavg < 1.e-6)return - if(wgtavg > zero)then - tr_tmp = tr_tmp/wgtavg - tref = tr_tmp - - z_w_tmp = z_w_tmp/wgtavg - z_w = z_w_tmp + tref = tref2/wgtavg + z_w = z_w/wgtavg + z_c = z_c/wgtavg - dt_cool = dt_cool/wgtavg - z_c = z_c/wgtavg - dt_warm = dt_warm/wgtavg + if(fac_tsl == 1)then c_0 = c_0/wgtavg c_d = c_d/wgtavg + dt_cool = dt_cool/wgtavg + if(z_c > zero)dtc = dt_cool*(one-min(zob,z_c)/z_c) + else + c_0 = zero + c_d = zero + dt_cool = zero + end if + if(fac_dtl == 1)then w_0 = w_0/wgtavg w_d = w_d/wgtavg + dt_warm = dt_warm/wgtavg + if(z_w > zero)dtw = dt_warm*(one-min(zob,z_w)/z_w) + else + w_0 = zero + w_d = zero + dt_warm = zero + end if - dtw = fac_dtl*dt_warm*(one-min(zob,z_w)/z_w) - if ( z_c > zero ) then - dtc = fac_tsl*dt_cool*(one-min(zob,z_c)/z_c) - else - dtc = zero - endif - call cal_tztr_(dt_warm,c_0,c_d,w_0,w_d,z_c,z_w,zob,tz_tr) + call cal_tztr_(dt_warm,c_0,c_d,w_0,w_d,z_c,z_w,zob,tz_tr) - end if end subroutine deter_nst_ !******************************************************************************************* @@ -343,10 +342,10 @@ subroutine cal_tztr_(dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr) ! ! dt_warm : diurnal warming amount at the surface ! xz : DTL depth (M) -! c_0 : coefficint 1 to calculate d(Tc)/d(Ts) -! c_d : coefficint 2 to calculate d(Tc)/d(Ts) -! w_0 : coefficint 1 to calculate d(Tw)/d(Ts) -! w_d : coefficint 2 to calculate d(Tw)/d(Ts) +! c_0 : coefficient 1 to calculate d(Tc)/d(Ts) +! c_d : coefficient 2 to calculate d(Tc)/d(Ts) +! w_0 : coefficient 1 to calculate d(Tw)/d(Ts) +! w_d : coefficient 2 to calculate d(Tw)/d(Ts) ! ! output variables ! @@ -354,34 +353,39 @@ subroutine cal_tztr_(dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr) use kinds, only: r_kind use constants, only: one,two,half,zero - use gsi_nstcouplermod, only: fac_dtl,fac_tsl real(kind=r_kind), intent(in) :: dt_warm,c_0,c_d,w_0,w_d,zc,zw,z real(kind=r_kind), intent(out) :: tztr ! local variables - real(kind=r_kind) :: c1,c2,c3 + real(kind=r_kind) :: c1,c2,c3,fact - c1 = one-two*(fac_dtl*w_0-fac_tsl*c_0)-(fac_dtl*w_d-fac_tsl*c_d)*z - c2 = one-two*(fac_dtl*w_0-fac_tsl*c_0)-fac_dtl*w_d*z - c3 = one+fac_tsl*two*c_0+fac_dtl*c_d*z tztr = one + c1 = zero + c2 = zero + c3 = zero if ( dt_warm > zero ) then - if ( z <= zc .and. c1 /= zero ) then - tztr = (one-fac_dtl*w_0+fac_tsl*c_0)/c1 - elseif ( z > zc .and. z < zw .and. c2 /= zero ) then - tztr = (one-fac_dtl*w_0+fac_tsl*c_0)/c2 + fact = (one-w_0+c_0) + if ( z <= zc) then + c1 = one-two*(w_0-c_0)-(w_d-c_d)*z + if ( c1 /= zero ) tztr = fact/c1 + elseif ( z > zc .and. z < zw) then + c2 = one-two*(w_0-c_0)-w_d*z + if (c2 /= zero ) tztr = fact/c2 + else endif - elseif ( dt_warm == zero .and. c3 /= zero ) then - if ( z <= zc ) then - tztr = (one+fac_tsl*c_0)/c3 + elseif (dt_warm == zero) then + if ( z <= zc) then + c3 = one+two*c_0+c_d*z + if (c3 /= zero) tztr = (one+c_0)/c3 endif endif - if ( tztr <= -1.0_r_kind .or. tztr > 4.0_r_kind ) then - write(6,100) fac_dtl,fac_tsl,c1,c2,c3,dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr -100 format('CAL_TZTR compute ',2(i2,1x),12(g13.6,1x),' RESET tztr to 1.0') - tztr = one + if ( tztr < 0.5_r_kind .or. tztr > 1.5_r_kind ) then + write(6,100) c1,c2,c3,dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr +100 format('CAL_TZTR compute ',12(g13.6,1x),' RESET tztr to 0.5 .or. 1.5') + tztr = min(1.5_r_kind,tztr) + tztr = max(0.5_r_kind,tztr) endif end subroutine cal_tztr_ diff --git a/src/gsi/cwhydromod.f90 b/src/gsi/cwhydromod.f90 index a27bba545f..d2bde78129 100644 --- a/src/gsi/cwhydromod.f90 +++ b/src/gsi/cwhydromod.f90 @@ -100,14 +100,23 @@ subroutine cw2hydro(sval,clouds,nclouds) call gsi_bundlegetpointer (sval,clouds(ic),sv_rank3,istatus) if (istatus/=0) cycle sv_rank3=zero - do k=1,nsig - do j=1,lon2 - do i=1,lat2 - if (clouds(ic)=='ql') sv_rank3(i,j,k)=cwgues(i,j,k)*(one-work(i,j,k)) - if (clouds(ic)=='qi') sv_rank3(i,j,k)=cwgues(i,j,k)*work(i,j,k) + if (clouds(ic)=='ql') then + do k=1,nsig + do j=1,lon2 + do i=1,lat2 + sv_rank3(i,j,k)=cwgues(i,j,k)*(one-work(i,j,k)) + end do end do end do - end do + else if (clouds(ic)=='qi') then + do k=1,nsig + do j=1,lon2 + do i=1,lat2 + sv_rank3(i,j,k)=cwgues(i,j,k)*work(i,j,k) + end do + end do + end do + end if end do return @@ -174,16 +183,25 @@ subroutine cw2hydro_tl(sval,wbundle,clouds,nclouds) call gsi_bundlegetpointer (sval,clouds(ic),sv_rank3,istatus) if (istatus/=0) cycle sv_rank3=zero - do k=1,nsig - do j=1,lon2 - do i=1,lat2 -! if (clouds(ic)=='ql') sv_rank3(i,j,k)=cv_cw(i,j,k)*(one-work0(i,j,k))-cwgues(i,j,k)*work(i,j,k) -! if (clouds(ic)=='qi') sv_rank3(i,j,k)=cv_cw(i,j,k)*work0(i,j,k)+cwgues(i,j,k)*work(i,j,k) - if (clouds(ic)=='ql') sv_rank3(i,j,k)=cv_cw(i,j,k)*(one-work0(i,j,k)) - if (clouds(ic)=='qi') sv_rank3(i,j,k)=cv_cw(i,j,k)*work0(i,j,k) + if (clouds(ic)=='ql') then + do k=1,nsig + do j=1,lon2 + do i=1,lat2 +! sv_rank3(i,j,k)=cv_cw(i,j,k)*(one-work0(i,j,k))-cwgues(i,j,k)*work(i,j,k) + sv_rank3(i,j,k)=cv_cw(i,j,k)*(one-work0(i,j,k)) + end do end do end do - end do + else if (clouds(ic)=='qi') then + do k=1,nsig + do j=1,lon2 + do i=1,lat2 +! sv_rank3(i,j,k)=cv_cw(i,j,k)*work0(i,j,k)+cwgues(i,j,k)*work(i,j,k) + sv_rank3(i,j,k)=cv_cw(i,j,k)*work0(i,j,k) + end do + end do + end do + end if end do return @@ -226,8 +244,6 @@ subroutine cw2hydro_ad(rval,wbundle,clouds,nclouds) real(r_kind),pointer,dimension(:,:,:) :: cv_cw ! Get pointer to required control variable -call gsi_bundlegetpointer (wbundle,'cw',cv_cw,istatus) -cv_cw=zero do k=1,nsig do j=1,lon2 @@ -239,25 +255,30 @@ subroutine cw2hydro_ad(rval,wbundle,clouds,nclouds) end do end do +call gsi_bundlegetpointer (wbundle,'cw',cv_cw,istatus) do ic=1,nclouds call gsi_bundlegetpointer (rval,clouds(ic),rv_rank3,istatus) if (istatus/=0) cycle - do k=1,nsig - do j=1,lon2 - do i=1,lat2 - if (clouds(ic)=='ql') then + if (clouds(ic)=='ql') then + do k=1,nsig + do j=1,lon2 + do i=1,lat2 cv_cw(i,j,k)=cv_cw(i,j,k)+rv_rank3(i,j,k)*(one-work0(i,j,k)) rv_rank3(i,j,k)=zero - end if - - if (clouds(ic)=='qi') then + end do + end do + end do + else if (clouds(ic)=='qi') then + do k=1,nsig + do j=1,lon2 + do i=1,lat2 cv_cw(i,j,k)=cv_cw(i,j,k)+rv_rank3(i,j,k)*work0(i,j,k) rv_rank3(i,j,k)=zero - end if - + end do end do end do - end do + end if + end do return diff --git a/src/gsi/deter_sfc_mod.f90 b/src/gsi/deter_sfc_mod.f90 index 3c88aabb2a..e4e77283a4 100644 --- a/src/gsi/deter_sfc_mod.f90 +++ b/src/gsi/deter_sfc_mod.f90 @@ -207,7 +207,6 @@ subroutine deter_sfc(alat,alon,dlat_earth,dlon_earth,obstime,isflg, & sfcpct(istyp10)=sfcpct(istyp10)+w10 sfcpct(istyp11)=sfcpct(istyp11)+w11 - isflg = 0 if(sfcpct(0) > 0.99_r_kind)then isflg = 0 else if(sfcpct(1) > 0.99_r_kind)then @@ -517,7 +516,6 @@ subroutine deter_sfc_type(dlat_earth,dlon_earth,obstime,isflg,tsavg) sfcpct(istyp10)=sfcpct(istyp10)+w10 sfcpct(istyp11)=sfcpct(istyp11)+w11 - isflg = 0 if(sfcpct(0) > 0.99_r_kind)then isflg = 0 else if(sfcpct(1) > 0.99_r_kind)then @@ -1109,7 +1107,7 @@ subroutine deter_sfc_fov(fov_flag,ifov,instr,ichan,sat_aziang,dlat_earth_deg,& do i = min_i(j), max_i(j) call reduce2full(i,j,ifull) call time_int_sfc(ifull,j,itsfc,itsfcp,dtsfc,dtsfcp,sfc_mdl) -!$omp parallel do schedule(dynamic,1)private(jjj,iii,lat_mdl,lon_mdl) +!$omp parallel do schedule(dynamic,1) private(jjj,iii,lat_mdl,lon_mdl) do jjj = 1, subgrid_lengths_y if (y_off(jjj) >= zero) then lat_mdl = (one-y_off(jjj))*rlats_sfc(j)+y_off(jjj)*rlats_sfc(j+1) @@ -1316,7 +1314,6 @@ subroutine deter_sfc_amsre_low(dlat_earth,dlon_earth,isflg,sfcpct) ! sfcpct(3)=min(sfcpct(3),sfcpct(1)) ! sfcpct(1)=max(zero,sfcpct(1)-sfcpct(3)) - isflg = 0 if(sfcpct(0) > 0.99_r_kind)then isflg = 0 else if(sfcpct(1) > 0.99_r_kind)then @@ -1482,7 +1479,6 @@ subroutine deter_sfc_gmi(dlat_earth,dlon_earth,isflg,sfcpct) ! sfcpct(3)=min(sfcpct(3),sfcpct(1)) ! sfcpct(1)=max(zero,sfcpct(1)-sfcpct(3)) - isflg = 0 if(sfcpct(0) > 0.99_r_kind)then isflg = 0 else if(sfcpct(1) > 0.99_r_kind)then @@ -1986,7 +1982,6 @@ subroutine calc_sfc(sfc_sum,isflg,idomsfc,sfcpct,vfr,sty,vty,sm, & sfcr = sfc_sum%sfcr/count_tot zz = sfc_sum%zz/count_tot - isflg = 0 if(sfcpct(0) > 0.99_r_kind)then isflg = 0 ! open water else if(sfcpct(1) > 0.99_r_kind)then diff --git a/src/gsi/evaljgrad.f90 b/src/gsi/evaljgrad.f90 index 788454034d..e66ca11b8c 100644 --- a/src/gsi/evaljgrad.f90 +++ b/src/gsi/evaljgrad.f90 @@ -73,6 +73,7 @@ subroutine evaljgrad(xhat,fjcost,gradx,lupdfgs,nprt,calledby) use xhat_vordivmod, only : xhat_vordiv_init, xhat_vordiv_calc, xhat_vordiv_clean use mpeu_util, only: die use mpl_allreducemod, only: mpl_allreduce +use intradmod, only: setrad implicit none @@ -195,6 +196,7 @@ subroutine evaljgrad(xhat,fjcost,gradx,lupdfgs,nprt,calledby) end do qpred=zero_quad +call setrad(sval(1)) ! Compare obs to solution and transpose back to grid (H^T R^{-1} H) call intjo(rval,qpred,sval,sbias) diff --git a/src/gsi/genqsat.f90 b/src/gsi/genqsat.f90 index ed0eb152e6..bc33187497 100644 --- a/src/gsi/genqsat.f90 +++ b/src/gsi/genqsat.f90 @@ -145,9 +145,9 @@ subroutine genqsat(qsat,tsen,prsl,lat2,lon2,nsig,ice,iderivative) esw = psat * (tr**xa) * exp(xb*(one-tr)) esi = psat * (tr**xai) * exp(xbi*(one-tr)) w = (tdry - tmix) / (ttp - tmix) -! es = w * esw + (one-w) * esi - es = w * psat * (tr**xa) * exp(xb*(one-tr)) & - + (one-w) * psat * (tr**xai) * exp(xbi*(one-tr)) + es = w * esw + (one-w) * esi +! es = w * psat * (tr**xa) * exp(xb*(one-tr)) & +! + (one-w) * psat * (tr**xai) * exp(xbi*(one-tr)) endif diff --git a/src/gsi/get_gefs_ensperts_dualres.f90 b/src/gsi/get_gefs_ensperts_dualres.f90 index 1cb7586a89..fab95ad210 100644 --- a/src/gsi/get_gefs_ensperts_dualres.f90 +++ b/src/gsi/get_gefs_ensperts_dualres.f90 @@ -64,6 +64,7 @@ subroutine get_gefs_ensperts_dualres use gsi_bundlemod, only: gsi_bundlegetpointer use gsi_bundlemod, only: gsi_bundledestroy use gsi_bundlemod, only: gsi_gridcreate + use gsi_bundlemod, only : assignment(=) use gsi_enscouplermod, only: gsi_enscoupler_get_user_nens use gsi_enscouplermod, only: gsi_enscoupler_create_sub2grid_info use gsi_enscouplermod, only: gsi_enscoupler_destroy_sub2grid_info @@ -150,6 +151,7 @@ subroutine get_gefs_ensperts_dualres call gsi_bundlecreate(en_read(n),en_perts(1,1,1)%grid,'ensemble member',istatus,names2d=cvars2d,names3d=cvars3d) if ( istatus /= 0 ) & call die('get_gefs_ensperts_dualres',': trouble creating en_read bundle, istatus =',istatus) + en_read(n) = zero end do ! allocate(z(im,jm)) @@ -158,14 +160,6 @@ subroutine get_gefs_ensperts_dualres ! sst2=zero ! for now, sst not used in ensemble perturbations, so if sst array is called for ! then sst part of en_perts will be zero when sst2=zero -!$omp parallel do schedule(dynamic,1) private(m,n) - do m=1,ntlevs_ens - do n=1,n_ens - en_perts(n,1,m)%valuesr4=zero_single - end do - end do - - ntlevs_ens_loop: do m=1,ntlevs_ens call gsi_enscoupler_get_user_Nens(grd_tmp,n_ens,m,en_read,iret) @@ -180,28 +174,39 @@ subroutine get_gefs_ensperts_dualres cycle endif + en_bar%values=zero if (.not.q_hyb_ens) then !use RH - kap1=rd_over_cp+one - kapr=one/rd_over_cp - do n=1,n_ens + allocate(pri(im,jm,km+1)) + allocate(prsl(im,jm,km),tsen(im,jm,km)) + allocate(qs(im,jm,km)) + end if + do n=1,n_ens + call gsi_bundlegetpointer(en_read(n),'q' ,q ,ier);istatus=istatus+ier + do k=1,km + do j=1,jm + do i=1,im + q(i,j,k)=max(q(i,j,k),zero) + end do + end do + end do + if (.not.q_hyb_ens) then !use RH call gsi_bundlegetpointer(en_read(n),'ps',ps,ier);istatus=ier call gsi_bundlegetpointer(en_read(n),'t' ,tv,ier);istatus=istatus+ier - call gsi_bundlegetpointer(en_read(n),'q' ,q ,ier);istatus=istatus+ier ! Compute RH ! Get 3d pressure field now on interfaces - allocate(pri(im,jm,km+1)) call general_getprs_glb(ps,tv,pri) - allocate(prsl(im,jm,km),tsen(im,jm,km),qs(im,jm,km)) ! Get sensible temperature and 3d layer pressure if (idsl5 /= 2) then + kap1=rd_over_cp+one + kapr=one/rd_over_cp !$omp parallel do schedule(dynamic,1) private(k,j,i) do k=1,km do j=1,jm do i=1,im prsl(i,j,k)=((pri(i,j,k)**kap1-pri(i,j,k+1)**kap1)/& (kap1*(pri(i,j,k)-pri(i,j,k+1))))**kapr - tsen(i,j,k)= tv(i,j,k)/(one+fv*max(zero,q(i,j,k))) + tsen(i,j,k)= tv(i,j,k)/(one+fv*q(i,j,k)) end do end do end do @@ -211,12 +216,11 @@ subroutine get_gefs_ensperts_dualres do j=1,jm do i=1,im prsl(i,j,k)=(pri(i,j,k)+pri(i,j,k+1))*half - tsen(i,j,k)= tv(i,j,k)/(one+fv*max(zero,q(i,j,k))) + tsen(i,j,k)= tv(i,j,k)/(one+fv*q(i,j,k)) end do end do end do end if - deallocate(pri) ice=.true. iderivative=0 @@ -228,14 +232,7 @@ subroutine get_gefs_ensperts_dualres end do end do end do - deallocate(tsen,prsl,qs) - enddo - end if - - - en_bar%values=zero - - n_ens_loop: do n=1,n_ens + end if !$omp parallel do schedule(dynamic,1) private(i,k,j,ic3,hydrometeor,istatus,p3) @@ -246,14 +243,14 @@ subroutine get_gefs_ensperts_dualres trim(cvars3d(ic3))=='qs' .or. trim(cvars3d(ic3))=='qg' .or. & trim(cvars3d(ic3))=='qh' - call gsi_bundlegetpointer(en_read(n),trim(cvars3d(ic3)),p3,istatus) - if(istatus/=0) then - write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' from read in member ',n,m - call stop2(999) - end if if ( hydrometeor ) then + call gsi_bundlegetpointer(en_read(n),trim(cvars3d(ic3)),p3,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' from read in member ',n,m + call stop2(999) + end if do k=1,km do j=1,jm do i=1,im @@ -263,13 +260,17 @@ subroutine get_gefs_ensperts_dualres end do else if ( trim(cvars3d(ic3)) == 'oz' .and. oz_univ_static ) then + call gsi_bundlegetpointer(en_read(n),trim(cvars3d(ic3)),p3,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' from read in member ',n,m + call stop2(999) + end if p3 = zero end if end do !c3d do i=1,nelen - en_perts(n,1,m)%valuesr4(i)=en_read(n)%values(i) - en_bar%values(i)=en_bar%values(i)+en_read(n)%values(i) + en_bar%values(i)=en_bar%values(i)+en_read(n)%values(i)*bar_norm end do @@ -279,14 +280,14 @@ subroutine get_gefs_ensperts_dualres ! know who would want to commented out code below but be mindful ! of how it interacts with option sst_staticB, please - Todling. - end do n_ens_loop ! end do over ensemble - - do i=1,nelen - en_bar%values(i)=en_bar%values(i)*bar_norm - end do + end do ! end do over ensembles + if (.not.q_hyb_ens) then !use RH + deallocate(pri) + deallocate(tsen,prsl) + deallocate(qs) + end if ! Before converting to perturbations, get ensemble spread - !-- if (m == 1 .and. write_ens_sprd ) call ens_spread_dualres(en_bar,1) !!! it is not clear of the next statement is thread/$omp safe. if (write_ens_sprd ) call ens_spread_dualres(en_bar,m) @@ -297,7 +298,6 @@ subroutine get_gefs_ensperts_dualres ! Copy pbar to module array. ps_bar may be needed for vertical localization ! in terms of scale heights/normalized p/p -! Convert to mean do j=1,jm do i=1,im ps_bar(i,j,m)=x2(i,j) @@ -309,7 +309,7 @@ subroutine get_gefs_ensperts_dualres !$omp parallel do schedule(dynamic,1) private(n,i,ic3,ipic,k,j) do n=1,n_ens do i=1,nelen - en_perts(n,1,m)%valuesr4(i)=en_perts(n,1,m)%valuesr4(i)-en_bar%values(i) + en_perts(n,1,m)%valuesr4(i)=en_read(n)%values(i)-en_bar%values(i) end do if(.not. q_hyb_ens) then do ic3=1,nc3d @@ -332,6 +332,7 @@ subroutine get_gefs_ensperts_dualres end do end do ntlevs_ens_loop !end do over bins + call gsi_bundledestroy(en_bar,istatus) if(nsclgrp > 1 .and. global_spectral_filter_sd) then do m=1,ntlevs_ens do n=1,n_ens @@ -725,8 +726,6 @@ subroutine general_getprs_glb(ps,tv,prs) real(r_kind),parameter:: ten = 10.0_r_kind - kapr=one/rd_over_cp - if (regional) then if(wrf_nmm_regional.or.nems_nmmb_regional) then do k=1,nsig+1 @@ -767,32 +766,45 @@ subroutine general_getprs_glb(ps,tv,prs) end do endif else - k=1 - k2=nsig+1 - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - prs(i,j,k)=ps(i,j) - prs(i,j,k2)=zero - end do - end do if (idvc5 /= 3) then !$omp parallel do schedule(dynamic,1) private(k,j,i) - do k=2,nsig - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - prs(i,j,k)=ak5(k)+bk5(k)*ps(i,j) + do k=1,nsig + if(k == 1)then + k2=nsig+1 + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + prs(i,j,k)=ps(i,j) + prs(i,j,k2)=zero + end do end do - end do + else + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + prs(i,j,k)=ak5(k)+bk5(k)*ps(i,j) + end do + end do + end if end do else + kapr=one/rd_over_cp !$omp parallel do schedule(dynamic,1) private(k,j,i,trk) - do k=2,nsig - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - trk=(half*(tv(i,j,k-1)+tv(i,j,k))/tref5(k))**kapr - prs(i,j,k)=ak5(k)+(bk5(k)*ps(i,j))+(ck5(k)*trk) + do k=1,nsig + if(k == 1)then + k2=nsig+1 + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + prs(i,j,k)=ps(i,j) + prs(i,j,k2)=zero + end do end do - end do + else + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + trk=(half*(tv(i,j,k-1)+tv(i,j,k))/tref5(k))**kapr + prs(i,j,k)=ak5(k)+(bk5(k)*ps(i,j))+(ck5(k)*trk) + end do + end do + end if end do end if end if diff --git a/src/gsi/getsiga.f90 b/src/gsi/getsiga.f90 index 788e0652d7..ad47017be1 100644 --- a/src/gsi/getsiga.f90 +++ b/src/gsi/getsiga.f90 @@ -198,6 +198,7 @@ subroutine view_cv_ad (xhat,mydate,filename,readcv) use state_vectors, only: allocate_state,deallocate_state,prt_state_norms use bias_predictors, only: predictors,allocate_preds,deallocate_preds,assignment(=) use bias_predictors, only: read_preds +use control2state_mod, only: control2state_ad implicit none type(control_vector) :: xhat integer(i_kind), intent(in) :: mydate(5) ! as in iadate or ibdate, or similar diff --git a/src/gsi/gridmod.F90 b/src/gsi/gridmod.F90 index 928b9e9c43..559a3f576d 100644 --- a/src/gsi/gridmod.F90 +++ b/src/gsi/gridmod.F90 @@ -130,6 +130,7 @@ module gridmod public :: vectosub public :: reload public :: strip_periodic + public :: minmype ! set passed variables to public public :: nnnn1o,iglobal,itotsub,ijn,ijn_s,lat2,lon2,lat1,lon1,nsig,nsig_soil @@ -267,6 +268,7 @@ module gridmod integer(i_kind) jcap ! spectral triangular truncation of ncep global analysis integer(i_kind) jcap_b ! spectral triangular truncation of ncep global background integer(i_kind) nthreads ! number of threads used (currently only used in calctends routines) + integer(i_kind) minmype ! processor with minimum size subdomain logical periodic ! logical flag for periodic e/w domains @@ -574,7 +576,7 @@ subroutine init_grid_vars(jcap,npe,cvars3d,cvars2d,cvars,mype) integer(i_kind) n3d,n2d,nvars,tid,nth integer(i_kind) ipsf,ipvp,jpsf,jpvp,isfb,isfe,ivpb,ivpe integer(i_kind) istatus,icw,iql,iqi - integer(i_kind) icw_cv,iql_cv,iqi_cv + integer(i_kind) icw_cv,iql_cv,iqi_cv,minmax logical,allocatable,dimension(:):: vector logical print_verbose @@ -687,6 +689,8 @@ subroutine init_grid_vars(jcap,npe,cvars3d,cvars2d,cvars,mype) periodic=grd_a%periodic + minmype=0 + minmax=grd_a%ilat1(1)*grd_a%jlon1(1) do i=1,npe istart(i) =grd_a%istart(i) jstart(i) =grd_a%jstart(i) @@ -699,7 +703,12 @@ subroutine init_grid_vars(jcap,npe,cvars3d,cvars2d,cvars,mype) displs_s(i) =grd_a%displs_s(i) ijn(i) =grd_a%ijn(i) displs_g(i) =grd_a%displs_g(i) + if(grd_a%ilat1(i)*grd_a%jlon1(i)< minmax)then + minmax=grd_a%ilat1(i)*grd_a%jlon1(i) + minmype=i-1 + end if end do + if(mype == minmype) write(6,*) ' minmype = ',minmype !#omp parallel private(nth,tid) nth = omp_get_max_threads() diff --git a/src/gsi/gsi_files.cmake b/src/gsi/gsi_files.cmake index 1658c83bf4..b98cd2d0da 100644 --- a/src/gsi/gsi_files.cmake +++ b/src/gsi/gsi_files.cmake @@ -124,7 +124,6 @@ constants.f90 control2model.f90 control2model_ad.f90 control2state.f90 -control2state_ad.f90 control_vectors.f90 convb_ps.f90 convb_q.f90 diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index c4317dbd2c..c8ce5a45be 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -1825,7 +1825,7 @@ subroutine gsimain_initialize n_ens_gfs=n_ens n_ens_fv3sar=0 else - write(6,*)'n_ens_gfs and n_ens_fv3sar won"t be used if not regional_ensemble_option==5' + if(mype == 0)write(6,*)'n_ens_gfs and n_ens_fv3sar won"t be used if not regional_ensemble_option==5' endif weight_ens_gfs=one weight_ens_fv3sar=one diff --git a/src/gsi/hybrid_ensemble_isotropic.F90 b/src/gsi/hybrid_ensemble_isotropic.F90 index 7b133ffb5a..fe2e058dff 100644 --- a/src/gsi/hybrid_ensemble_isotropic.F90 +++ b/src/gsi/hybrid_ensemble_isotropic.F90 @@ -3592,7 +3592,7 @@ subroutine bkerror_a_en(grady) !$$$ end documentation block use kinds, only: r_kind,i_kind use constants, only: zero - use gsi_4dvar, only: nsubwin, lsqrtb + use gsi_4dvar, only: nsubwin use control_vectors, only: control_vector use timermod, only: timer_ini,timer_fnl use hybrid_ensemble_parameters, only: n_ens @@ -3610,11 +3610,6 @@ subroutine bkerror_a_en(grady) real(r_kind),allocatable,dimension(:,:) :: z real(r_kind),allocatable,dimension(:) :: ztmp - if (lsqrtb) then - write(6,*)'bkerror_a_en: not for use with lsqrtb' - call stop2(317) - end if - ! Initialize timer call timer_ini('bkerror_a_en') @@ -3629,6 +3624,7 @@ subroutine bkerror_a_en(grady) call sqrt_beta_e_mult(grady) ! Apply variances, as well as vertical & horizontal parts of background error +! !$omp parallel do schedule(dynamic,1) private(ii) do ii=1,nsubwin if (naensgrp==1) then call bkgcov_a_en_new_factorization(1,grady%aens(ii,1,1:n_ens)) @@ -3710,12 +3706,10 @@ subroutine bkgcov_a_en_new_factorization(ig,a_en) type(gsi_bundle),intent(inout) :: a_en(n_ens) ! Local Variables - integer(i_kind) ii,k,iflg,iadvance,iback,is,ie,ipnt,istatus + integer(i_kind) ii,k,iadvance,iback,is,ie,ipnt,istatus real(r_kind) hwork(grd_loc%inner_vars,grd_loc%nlat,grd_loc%nlon,grd_loc%kbegin_loc:grd_loc%kend_alloc) real(r_kind),allocatable,dimension(:):: a_en_work - iflg=1 - call gsi_bundlegetpointer(a_en(1),'a_en',ipnt,istatus) if(istatus/=0) then write(6,*)'bkgcov_a_en_new_factorization: trouble getting pointer to ensemble CV' diff --git a/src/gsi/intall.f90 b/src/gsi/intall.f90 index 0f8faa89f8..d10eb1e7e5 100644 --- a/src/gsi/intall.f90 +++ b/src/gsi/intall.f90 @@ -184,13 +184,13 @@ subroutine intall(sval,sbias,rval,rbias) use intjomod, only: intjo use bias_predictors, only : predictors,assignment(=) use state_vectors, only: allocate_state,deallocate_state + use state_vectors, only: qgpresent,qspresent,qrpresent,qipresent,qlpresent + use state_vectors, only: cldchpresent,lcbaspresent,howvpresent,wspd10mpresent,pblhpresent,vispresent,gustpresent use intjcmod, only: intlimq,intlimg,intlimv,intlimp,intlimw10m,intlimhowv,intlimcldch,& intliml,intjcpdry1,intjcpdry2,intjcdfi,intlimqc use timermod, only: timer_ini,timer_fnl use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: assignment(=) - use state_vectors, only: svars2d, svars3d - use mpeu_util, only: getindex use guess_grids, only: ntguessig,nfldsig use mpl_allreducemod, only: mpl_allreduce @@ -238,11 +238,11 @@ subroutine intall(sval,sbias,rval,rbias) end if if (ljclimqc) then if (.not.ljc4tlevs) then - if (getindex(svars3d,'ql')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'ql') - if (getindex(svars3d,'qi')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qi') - if (getindex(svars3d,'qr')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qr') - if (getindex(svars3d,'qs')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qs') - if (getindex(svars3d,'qg')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qg') + if (qlpresent) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'ql') + if (qipresent) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qi') + if (qrpresent) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qr') + if (qspresent) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qs') + if (qgpresent) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qg') else do ibin=1,nobs_bins if (nobs_bins /= nfldsig) then @@ -250,34 +250,34 @@ subroutine intall(sval,sbias,rval,rbias) else it=ibin end if - if (getindex(svars3d,'ql')>0) call intlimqc(rval(ibin),sval(ibin),it,'ql') - if (getindex(svars3d,'qi')>0) call intlimqc(rval(ibin),sval(ibin),it,'qi') - if (getindex(svars3d,'qr')>0) call intlimqc(rval(ibin),sval(ibin),it,'qr') - if (getindex(svars3d,'qs')>0) call intlimqc(rval(ibin),sval(ibin),it,'qs') - if (getindex(svars3d,'qg')>0) call intlimqc(rval(ibin),sval(ibin),it,'qg') + if (qlpresent) call intlimqc(rval(ibin),sval(ibin),it,'ql') + if (qipresent) call intlimqc(rval(ibin),sval(ibin),it,'qi') + if (qrpresent) call intlimqc(rval(ibin),sval(ibin),it,'qr') + if (qspresent) call intlimqc(rval(ibin),sval(ibin),it,'qs') + if (qgpresent) call intlimqc(rval(ibin),sval(ibin),it,'qg') end do end if end if ! ljclimqc ! RHS for gust constraint - if (getindex(svars2d,'gust')>0)call intlimg(rval(1),sval(1)) + if (gustpresent)call intlimg(rval(1),sval(1)) ! RHS for vis constraint - if (getindex(svars2d,'vis')>0) call intlimv(rval(1),sval(1)) + if (vispresent) call intlimv(rval(1),sval(1)) ! RHS for pblh constraint - if (getindex(svars2d,'pblh')>0) call intlimp(rval(1),sval(1)) + if (pblhpresent) call intlimp(rval(1),sval(1)) ! RHS for wspd10m constraint - if (getindex(svars2d,'wspd10m')>0) call intlimw10m(rval(1),sval(1)) + if (wspd10mpresent) call intlimw10m(rval(1),sval(1)) ! RHS for howv constraint - if (getindex(svars2d,'howv')>0) call intlimhowv(rval(1),sval(1)) + if (howvpresent) call intlimhowv(rval(1),sval(1)) ! RHS for lcbas constraint - if (getindex(svars2d,'lcbas')>0) call intliml(rval(1),sval(1)) + if (lcbaspresent) call intliml(rval(1),sval(1)) ! RHS for cldch constraint - if (getindex(svars2d,'cldch')>0) call intlimcldch(rval(1),sval(1)) + if (cldchpresent) call intlimcldch(rval(1),sval(1)) end if @@ -296,7 +296,7 @@ subroutine intall(sval,sbias,rval,rbias) end if -! Take care of background error for bias correction terms +! Sum over all processors for bias correction terms call mpl_allreduce(nrclen,qpvals=qpred) @@ -313,6 +313,7 @@ subroutine intall(sval,sbias,rval,rbias) ! RHS for Jc DFI if (ljcdfi .and. nobs_bins>1) call intjcdfi(rval,sval) +! Put bias correction terms in correct location if(nsclen > 0)then do i=1,nsclen rbias%predr(i)=qpred(i) diff --git a/src/gsi/intgps.f90 b/src/gsi/intgps.f90 index bc78db085e..16ead93d1c 100644 --- a/src/gsi/intgps.f90 +++ b/src/gsi/intgps.f90 @@ -118,6 +118,7 @@ subroutine intgps_(gpshead,rval,sval) real(r_kind) :: w1,w2,w3,w4 real(r_kind) :: p_TL,p_AD,t_TL,t_AD,q_TL,q_AD real(r_kind) :: val,pg_gps + real(r_kind),dimension(nsig) :: valk real(r_kind) ::cg_gps,grad,p0,wnotgross,wgross real(r_kind),pointer,dimension(:) :: st,sq real(r_kind),pointer,dimension(:) :: rt,rq @@ -154,16 +155,19 @@ subroutine intgps_(gpshead,rval,sval) w3=gpsptr%wij(3) w4=gpsptr%wij(4) - - val=zero - ! local refractivity (linear operator) +!$omp parallel do schedule(dynamic,1) private(j,t_TL,q_TL,p_TL) + do j=1,nsig + t_TL=w1*st(i1(j))+w2*st(i2(j))+w3*st(i3(j))+w4*st(i4(j)) + q_TL=w1*sq(i1(j))+w2*sq(i2(j))+w3*sq(i3(j))+w4*sq(i4(j)) + p_TL=w1*sp(i1(j))+w2*sp(i2(j))+w3*sp(i3(j))+w4*sp(i4(j)) + valk(j) = p_TL*gpsptr%jac_p(j) + t_TL*gpsptr%jac_t(j)+q_TL*gpsptr%jac_q(j) + end do + + val=zero do j=1,nsig - t_TL=w1* st(i1(j))+w2* st(i2(j))+w3* st(i3(j))+w4* st(i4(j)) - q_TL=w1* sq(i1(j))+w2* sq(i2(j))+w3* sq(i3(j))+w4* sq(i4(j)) - p_TL=w1* sp(i1(j))+w2* sp(i2(j))+w3* sp(i3(j))+w4* sp(i4(j)) - val = val + p_TL*gpsptr%jac_p(j) + t_TL*gpsptr%jac_t(j)+q_TL*gpsptr%jac_q(j) + val = val+valk(j) end do if (luse_obsdiag)then @@ -204,6 +208,7 @@ subroutine intgps_(gpshead,rval,sval) ! adjoint +!$omp parallel do schedule(dynamic,1) private(j,t_AD,q_AD,p_AD) do j=1,nsig t_AD = grad*gpsptr%jac_t(j) rt(i1(j))=rt(i1(j))+w1*t_AD diff --git a/src/gsi/intjcmod.f90 b/src/gsi/intjcmod.f90 index c0c23151ee..2b093312ac 100644 --- a/src/gsi/intjcmod.f90 +++ b/src/gsi/intjcmod.f90 @@ -740,7 +740,7 @@ subroutine intjcpdry(rval,sval,nbins,pjc) it=ntguessig mass=zero_quad - rcon=one_quad/(two_quad*float(nlon)) + rcon=(one_quad/(two_quad*float(nlon)))**2 mm1=mype+1 do n=1,nbins @@ -805,8 +805,7 @@ subroutine intjcpdry(rval,sval,nbins,pjc) ! Remove water-vapor contribution to get incremental dry ps ! if (mype==0) write(6,*)'intjcpdry: total mass =', mass(n) ! if (mype==0) write(6,*)'intjcpdry: wv mass =', mass(nbins+n) - dmass=mass(n)-mass(nbins+n) - dmass=bamp_jcpdry*dmass*rcon*rcon + dmass=bamp_jcpdry*(mass(n)-mass(nbins+n))*rcon if(present(pjc)) then pjc = dmass*dmass endif @@ -872,7 +871,7 @@ subroutine intjcpdry1(sval,nbins,mass) ! !$$$ use mpimod, only: mype - use gridmod, only: lat2,lon2,nsig,wgtlats,nlon,istart + use gridmod, only: lat2,lon2,nsig,wgtlats,istart use guess_grids, only: ges_prsi,ntguessig use gsi_metguess_mod, only: gsi_metguess_get implicit none @@ -884,7 +883,7 @@ subroutine intjcpdry1(sval,nbins,mass) ! Declare local variables real(r_quad),dimension(nsig) :: mass2 - real(r_quad) rcon,con + real(r_quad) con integer(i_kind) i,j,k,it,ii,mm1,icw,iql,iqi integer(i_kind) iq,iqr,iqs,iqg,iqh,ips real(r_kind),pointer,dimension(:,:,:) :: sq =>NULL() @@ -901,13 +900,11 @@ subroutine intjcpdry1(sval,nbins,mass) it=ntguessig mass=zero_quad - rcon=one_quad/(two_quad*float(nlon)) mm1=mype+1 do n=1,nbins ! Retrieve pointers ! Simply return if any pointer not found - iq=0; icw=0; iql=0; iqi=0; iqr=0; iqs=0; iqg=0; iqh=0 call gsi_bundlegetpointer(sval(n),'q' ,sq, iq ) call gsi_bundlegetpointer(sval(n),'cw',sc, icw ) call gsi_bundlegetpointer(sval(n),'ql',sql, iql ) @@ -1023,11 +1020,10 @@ subroutine intjcpdry2(rval,nbins,mass,pjc) integer(i_kind) :: n it=ntguessig - rcon=one_quad/(two_quad*float(nlon)) + rcon=(one_quad/(two_quad*float(nlon)))**2 mm1=mype+1 do n=1,nbins - iq=0; icw=0; iql=0; iqi=0; iqr=0; iqs=0; iqg=0; iqh=0 call gsi_bundlegetpointer(rval(n),'q' ,rq, iq ) call gsi_bundlegetpointer(rval(n),'cw',rc, icw ) call gsi_bundlegetpointer(rval(n),'ql',rql, iql ) @@ -1037,7 +1033,7 @@ subroutine intjcpdry2(rval,nbins,mass,pjc) call gsi_bundlegetpointer(rval(n),'qg',rqg, iqg ) call gsi_bundlegetpointer(rval(n),'qh',rqh, iqh ) call gsi_bundlegetpointer(rval(n),'ps',rp, ips ) - if( iq*ips /=0 .or. icw*(iql+iqi) /=0 ) then + if( ips /= 0 .or. iq /=0 .or. icw*(iql+iqi) /=0 ) then if (mype==0) write(6,*)'intjcpdry2: warning - missing some required variables' if (mype==0) write(6,*)'intjcpdry2: constraint for dry mass constraint not performed' return @@ -1045,8 +1041,7 @@ subroutine intjcpdry2(rval,nbins,mass,pjc) ! Remove water-vapor contribution to get incremental dry ps ! if (mype==0) write(6,*)'intjcpdry: total mass =', mass(n) ! if (mype==0) write(6,*)'intjcpdry: wv mass =', mass(nbins+n) - dmass=mass(n)-mass(nbins+n) - dmass=bamp_jcpdry*dmass*rcon*rcon + dmass=bamp_jcpdry*(mass(n)-mass(nbins+n))*rcon if(present(pjc)) then pjc = dmass*dmass endif diff --git a/src/gsi/intjo.f90 b/src/gsi/intjo.f90 index e514a38a22..91b811147e 100644 --- a/src/gsi/intjo.f90 +++ b/src/gsi/intjo.f90 @@ -240,8 +240,6 @@ subroutine intjo_(rval,qpred,sval,sbias) use m_obsdiags, only: obOper_destroy use gsi_obOper, only: obOper -use intradmod, only: setrad - implicit none ! Declare passed variables @@ -257,7 +255,6 @@ subroutine intjo_(rval,qpred,sval,sbias) class(obOper),pointer:: it_obOper !****************************************************************************** - call setrad(sval(1)) ! "RHS for jo", as it was labeled in intall(). !$omp parallel do schedule(dynamic,1) private(ibin,it,ix,it_obOper) diff --git a/src/gsi/intrad.f90 b/src/gsi/intrad.f90 index 689b6c821e..19bb400034 100644 --- a/src/gsi/intrad.f90 +++ b/src/gsi/intrad.f90 @@ -83,13 +83,14 @@ subroutine setrad(sval) use gsi_bundlemod, only: gsi_bundlegetpointer use gsi_metguess_mod, only: gsi_metguess_get use mpeu_util, only: getindex + use mpimod, only: mype implicit none ! Declare passed variables type(gsi_bundle), intent(in ) :: sval ! Declare local variables - integer(i_kind) ier,istatus,indx + integer(i_kind) indx logical look real(r_kind),pointer,dimension(:) :: st,sq,scw,soz,su,sv,sqg,sqh,sqi,sql,sqr,sqs @@ -97,91 +98,110 @@ subroutine setrad(sval) if(done_setting) return -! Retrieve pointers; return when not found (except in case of non-essentials) - ier=0; itsen=0; iqv=0; ius=0; ivs=0; isst=0; ioz=0; icw=0 - iqg=0; iqh=0; iqi=0; iql=0; iqr=0; iqs=0 - call gsi_bundlegetpointer(sval,'u', su, istatus);ius=istatus+ius - call gsi_bundlegetpointer(sval,'v', sv, istatus);ivs=istatus+ivs - call gsi_bundlegetpointer(sval,'tsen' ,st, istatus);itsen=istatus+itsen - call gsi_bundlegetpointer(sval,'q', sq, istatus);iqv=istatus+iqv - call gsi_bundlegetpointer(sval,'cw' ,scw,istatus);icw=istatus+icw - call gsi_bundlegetpointer(sval,'oz' ,soz,istatus);ioz=istatus+ioz - call gsi_bundlegetpointer(sval,'sst',sst,istatus);isst=istatus+isst - call gsi_bundlegetpointer(sval,'qg' ,sqg,istatus);iqg=istatus+iqg - call gsi_bundlegetpointer(sval,'qh' ,sqh,istatus);iqh=istatus+iqh - call gsi_bundlegetpointer(sval,'qi' ,sqi,istatus);iqi=istatus+iqi - call gsi_bundlegetpointer(sval,'ql' ,sql,istatus);iql=istatus+iql - call gsi_bundlegetpointer(sval,'qr' ,sqr,istatus);iqr=istatus+iqr - call gsi_bundlegetpointer(sval,'qs' ,sqs,istatus);iqs=istatus+iqs - lgoback=(ius/=0).and.(ivs/=0).and.(itsen/=0).and.(iqv/=0).and.(ioz/=0).and.(icw/=0).and.(isst/=0) - lgoback=lgoback .and.(iqg/=0).and.(iqh/=0).and.(iqi/=0).and.(iql/=0).and.(iqr/=0).and.(iqs/=0) - if(lgoback)return - ! check to see if variable participates in forward operator ! tsen indx=getindex(radjacnames,'tsen') - look=(itsen==0.and.indx>0) itsen=-1 - if(look) itsen=radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'tsen',st, itsen) + look=itsen==0 + if(look) itsen=radjacindxs(indx) + end if ! q indx=getindex(radjacnames,'q') - look=(iqv==0.and.indx>0) iqv=-1 - if(look) iqv=radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'q', sq, iqv) + look=iqv==0 + if(look) iqv=radjacindxs(indx) + end if ! oz indx=getindex(radjacnames,'oz') - look=(ioz ==0.and.indx>0) ioz=-1 - if(look) ioz =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'oz' , soz,ioz) + look=ioz ==0 + if(look) ioz =radjacindxs(indx) + end if ! cw indx=getindex(radjacnames,'cw') - look=(icw ==0.and.indx>0) icw=-1 - if(look) icw =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'cw' , scw,icw) + look=icw ==0 + if(look) icw =radjacindxs(indx) + end if ! sst indx=getindex(radjacnames,'sst') - look=(isst==0.and.indx>0) isst=-1 - if(look) isst=radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'sst', sst,isst) + look=isst==0 + if(look) isst=radjacindxs(indx) + end if ! us & vs indx=getindex(radjacnames,'u') - look=(ius==0.and.indx>0) ius=-1 - if(look) ius=radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'u', su, ius) + look=ius==0 + if(look) ius=radjacindxs(indx) + end if indx=getindex(radjacnames,'v') - look=(ivs==0.and.indx>0) ivs=-1 - if(look) ivs=radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'v', sv, ivs) + look=ivs==0 + if(look) ivs=radjacindxs(indx) + end if ! qg indx=getindex(radjacnames,'qg') - look=(iqg ==0.and.indx>0) iqg=-1 - if(look) iqg =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'qg' , sqg,iqg) + look=iqg ==0 + if(look) iqg =radjacindxs(indx) + end if ! qh indx=getindex(radjacnames,'qh') - look=(iqh ==0.and.indx>0) iqh=-1 - if(look) iqh =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'qh' , sqh,iqh) + look=iqh ==0 + if(look) iqh =radjacindxs(indx) + end if ! qi indx=getindex(radjacnames,'qi') - look=(iqi ==0.and.indx>0) iqi=-1 - if(look) iqi =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'qi' , sqi,iqi) + look=iqi ==0 + if(look) iqi =radjacindxs(indx) + end if ! ql indx=getindex(radjacnames,'ql') - look=(iql ==0.and.indx>0) iql=-1 - if(look) iql =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'ql' , sql,iql) + look=iql ==0 + if(look) iql =radjacindxs(indx) + end if ! qr indx=getindex(radjacnames,'qr') - look=(iqr ==0.and.indx>0) iqr=-1 - if(look) iqr =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'qr' , sqr,iqr) + look=iqr ==0 + if(look) iqr =radjacindxs(indx) + end if ! qs indx=getindex(radjacnames,'qs') - look=(iqs ==0.and.indx>0) iqs=-1 - if(look) iqs =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'qs' , sqs,iqs) + look=iqs ==0 + if(look) iqs =radjacindxs(indx) + end if luseu=ius>=0 lusev=ivs>=0 @@ -196,6 +216,26 @@ subroutine setrad(sval) luseqr=iqr>=0 luseqs=iqs>=0 lusesst=isst>=0 + lgoback=.not.(luseu .or. lusev .or. luset .or. luseq .or. luseoz .or. lusecw .or. & + luseql .or. luseqi .or. luseqh .or. luseqg .or. luseqr .or. luseqs .or. & + lusesst) + + if(mype == 0)then + write(6,*) ' following variables are used in int and stp radiance calculations ' + if(luset) write(6,*)'tsen' + if(luseq) write(6,*)'q' + if(luseoz)write(6,*)'oz' + if(luseu) write(6,*)'u' + if(lusev) write(6,*)'v' + if(lusesst) write(6,*)'sst' + if(lusecw) write(6,*)'cw' + if(luseql) write(6,*)'ql' + if(luseqi) write(6,*)'qi' + if(luseqh) write(6,*)'qh' + if(luseqg) write(6,*)'qg' + if(luseqr) write(6,*)'qr' + if(luseqs) write(6,*)'qs' + end if done_setting = .true. @@ -308,7 +348,7 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) ! Declare local variables integer(i_kind) i1,i2,i3,i4,n,k,ic,ix,nn,mm,ncr1,ncr2 - integer(i_kind) ier,istatus + integer(i_kind) istatus integer(i_kind),dimension(nsig) :: i1n,i2n,i3n,i4n real(r_kind),allocatable,dimension(:):: val real(r_kind) w1,w2,w3,w4 @@ -331,7 +371,6 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) call timer_ini('intrad') ! Retrieve pointers; return when not found (except in case of non-essentials) - ier=0 if(luseu)then call gsi_bundlegetpointer(sval,'u', su, istatus) call gsi_bundlegetpointer(rval,'u', ru, istatus) @@ -468,7 +507,6 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) end do - ! For all other configurations ! begin channel specific calculations allocate(val(radptr%nchan)) @@ -487,10 +525,8 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) end do end if -!$omp parallel do schedule(dynamic,1) private(nn,ic,ix,k) +!$omp parallel do schedule(dynamic,1) private(nn,k,ncr1) do nn=1,radptr%nchan - ic=radptr%icx(nn) - ix=(ic-1)*npred ! include observation increment and lapse rate contributions to bias correction val(nn)=zero @@ -499,25 +535,24 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) do k=1,nsigradjac val(nn)=val(nn)+tdir(k)*radptr%dtb_dvar(k,nn) end do - end do - ncr1=0 ! Include contributions from remaining bias correction terms - do nn=1,radptr%nchan if( .not. ladtest_obs) then if(radptr%use_corr_obs)then val_quad = zero_quad do mm=1,nn - ncr1=ncr1+1 + ncr1=radptr%iccerr(nn)+mm val_quad=val_quad+radptr%rsqrtinv(ncr1)*biasvect(mm) enddo val(nn)=val(nn) + val_quad else - val(nn)=val(nn)+biasvect(nn) + val(nn)=val(nn) + biasvect(nn) endif end if + end do - if(luse_obsdiag)then + if(luse_obsdiag)then + do nn=1,radptr%nchan if (lsaveobsens) then val(nn)=val(nn)*radptr%err2(nn)*radptr%raterr2(nn) !-- radptr%diags(nn)%ptr%obssen(jiter) = val(nn) @@ -526,13 +561,14 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) !-- if (radptr%luse) radptr%diags(nn)%ptr%tldepart(jiter) = val(nn) if (radptr%luse) call obsdiagNode_set(radptr%diags(nn)%ptr,jiter=jiter,tldepart=val(nn)) endif - endif - end do + end do + end if if (l_do_adjoint) then - do nn=1,radptr%nchan - ic=radptr%icx(nn) - if (.not. lsaveobsens) then + if (.not. lsaveobsens) then +!$omp parallel do schedule(dynamic,1) private(nn,ic,cg_rad,wnotgross,wgross,p0) + do nn=1,radptr%nchan + ic=radptr%icx(nn) if( .not. ladtest_obs) val(nn)=val(nn)-radptr%res(nn) ! Multiply by variance. @@ -546,51 +582,45 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) endif if(.not.ladtest_obs) val(nn) = val(nn)*radptr%err2(nn)*radptr%raterr2(nn) - endif - enddo + enddo + endif ! Extract contributions from bias correction terms -! use compensated summation if( .not. ladtest_obs) then - if (radptr%use_corr_obs) then - ncr1 = 0 - do mm=1,radptr%nchan - ncr1 = ncr1 + mm - ncr2 = ncr1 - biasvect(mm) = zero - do nn=mm,radptr%nchan - biasvect(mm)=biasvect(mm)+radptr%rsqrtinv(ncr2)*val(nn) - ncr2 = ncr2 + nn - enddo - end do - endif + if(radptr%luse)then + if (radptr%use_corr_obs) then +!$omp parallel do schedule(dynamic,1) private(n,nn,ix,ncr1,ncr2,mm) + do nn=1,radptr%nchan + ncr1 = radptr%iccerr(nn)+nn + ncr2 = ncr1 + biasvect(nn) = zero + do mm=nn,radptr%nchan + biasvect(nn)=biasvect(nn)+radptr%rsqrtinv(ncr2)*val(mm) + ncr2 = ncr2 + mm + enddo - if(radptr%luse)then - if(radptr%use_corr_obs)then - do nn=1,radptr%nchan - ix=(radptr%icx(nn)-1)*npred - do n=1,npred - rpred(ix+n)=rpred(ix+n)+biasvect(nn)*radptr%pred(n,nn) - enddo + ix=(radptr%icx(nn)-1)*npred + do n=1,npred + rpred(ix+n)=rpred(ix+n)+biasvect(nn)*radptr%pred(n,nn) enddo - else - do nn=1,radptr%nchan - ix=(radptr%icx(nn)-1)*npred - do n=1,npred - rpred(ix+n)=rpred(ix+n)+radptr%pred(n,nn)*val(nn) - end do - end do - end if - end if + enddo + else +!$omp parallel do schedule(dynamic,1) private(n,nn,ix) + do nn=1,radptr%nchan + ix=(radptr%icx(nn)-1)*npred + do n=1,npred + rpred(ix+n)=rpred(ix+n)+radptr%pred(n,nn)*val(nn) + end do + end do + end if + end if - deallocate(biasvect) + deallocate(biasvect) end if ! not ladtest_obs - endif ! Begin adjoint - if (l_do_adjoint) then !$omp parallel do schedule(dynamic,1) private(k,nn) do k=1,nsigradjac tval(k)=zero diff --git a/src/gsi/intsst.f90 b/src/gsi/intsst.f90 index d910247526..6b255d0d02 100644 --- a/src/gsi/intsst.f90 +++ b/src/gsi/intsst.f90 @@ -79,7 +79,7 @@ subroutine intsst(ssthead,rval,sval) ! !$$$ use kinds, only: r_kind,i_kind - use constants, only: half,one,tiny_r_kind,cg_term + use constants, only: zero,half,one,tiny_r_kind,cg_term use obsmod, only: lsaveobsens, l_do_adjoint,luse_obsdiag use qcmod, only: nlnqc_iter,varqc_iter use gsi_nstcouplermod, only: nst_gsi @@ -100,7 +100,6 @@ subroutine intsst(ssthead,rval,sval) ! real(r_kind) penalty real(r_kind) w1,w2,w3,w4 real(r_kind) val - real(r_kind) tval,tdir real(r_kind) cg_sst,p0,grad,wnotgross,wgross,pg_sst real(r_kind),pointer,dimension(:) :: ssst real(r_kind),pointer,dimension(:) :: rsst @@ -108,15 +107,14 @@ subroutine intsst(ssthead,rval,sval) ! If no sst data return if(.not. associated(ssthead))return + if(.not. nst_gsi > 2) return ! Retrieve pointers ! Simply return if any pointer not found - ier=0 - call gsi_bundlegetpointer(sval,'sst',ssst,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'sst',ssst,istatus);ier=istatus call gsi_bundlegetpointer(rval,'sst',rsst,istatus);ier=istatus+ier if(ier/=0)return - !sstptr => ssthead sstptr => sstNode_typecast(ssthead) do while (associated(sstptr)) j1=sstptr%ij(1) @@ -129,15 +127,9 @@ subroutine intsst(ssthead,rval,sval) w4=sstptr%wij(4) ! Forward model - val=w1*ssst(j1)+w2*ssst(j2)& - +w3*ssst(j3)+w4*ssst(j4) - - if ( nst_gsi > 2 ) then - tdir = w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) ! Forward - val = tdir*sstptr%tz_tr ! Include contributions from Tz jacobian - else - val = w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) ! Forward - endif + val=w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) + + val = val*sstptr%tz_tr ! Include contributions from Tz jacobian if(luse_obsdiag)then @@ -173,18 +165,12 @@ subroutine intsst(ssthead,rval,sval) endif ! Adjoint - if ( nst_gsi > 2 ) then - tval = sstptr%tz_tr*grad ! Extract contributions from surface jacobian - rsst(j1)=rsst(j1)+w1*tval ! Distribute adjoint contributions over surrounding grid points - rsst(j2)=rsst(j2)+w2*tval - rsst(j3)=rsst(j3)+w3*tval - rsst(j4)=rsst(j4)+w4*tval - else - rsst(j1)=rsst(j1)+w1*grad - rsst(j2)=rsst(j2)+w2*grad - rsst(j3)=rsst(j3)+w3*grad - rsst(j4)=rsst(j4)+w4*grad - endif + grad = sstptr%tz_tr*grad ! Extract contributions from surface jacobian + + rsst(j1)=rsst(j1)+w1*grad + rsst(j2)=rsst(j2)+w2*grad + rsst(j3)=rsst(j3)+w3*grad + rsst(j4)=rsst(j4)+w4*grad endif ! if (l_do_adjoint) then diff --git a/src/gsi/intt.f90 b/src/gsi/intt.f90 index 9401026e47..b4082712a9 100644 --- a/src/gsi/intt.f90 +++ b/src/gsi/intt.f90 @@ -145,7 +145,7 @@ subroutine intt_(thead,rval,sval,rpred,spred) ! Declare local variables integer(i_kind) j1,j2,j3,j4,j5,j6,j7,j8,ier,istatus,isst,ix,n - real(r_kind) w1,w2,w3,w4,w5,w6,w7,w8,time_t + real(r_kind) w1,w2,w3,w4,w5,w6,w7,w8 ! real(r_kind) penalty real(r_kind) cg_t,val,grad,rat_err2,error2,t_pg,var_jb real(r_kind) psfc_grad,tg_grad @@ -160,14 +160,13 @@ subroutine intt_(thead,rval,sval,rpred,spred) ! Retrieve pointers ! Simply return if any pointer not found - ier=0; isst=0 - call gsi_bundlegetpointer(sval,'tsen', st,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'tsen', st,istatus);ier=istatus call gsi_bundlegetpointer(sval,'tv', stv,istatus);ier=istatus+ier call gsi_bundlegetpointer(sval,'q', sq,istatus);ier=istatus+ier call gsi_bundlegetpointer(sval,'u', su,istatus);ier=istatus+ier call gsi_bundlegetpointer(sval,'v', sv,istatus);ier=istatus+ier call gsi_bundlegetpointer(sval,'prse', sp,istatus);ier=istatus+ier - call gsi_bundlegetpointer(sval,'sst',ssst,istatus);isst=istatus+isst + call gsi_bundlegetpointer(sval,'sst',ssst,istatus);isst=istatus if(ier/=0) return call gsi_bundlegetpointer(rval,'tsen', rt,istatus);ier=istatus+ier @@ -179,7 +178,6 @@ subroutine intt_(thead,rval,sval,rpred,spred) call gsi_bundlegetpointer(rval,'sst',rsst,istatus);isst=istatus+isst if(ier/=0) return - time_t=zero !tptr => thead tptr => tNode_typecast(thead) do while (associated(tptr)) @@ -205,20 +203,22 @@ subroutine intt_(thead,rval,sval,rpred,spred) !----------use surface model---------------------- + qs_prime0=w1* sq(j1)+w2* sq(j2)+w3* sq(j3)+w4* sq(j4) + us_prime0=w1* su(j1)+w2* su(j2)+w3* su(j3)+w4* su(j4) + vs_prime0=w1* sv(j1)+w2* sv(j2)+w3* sv(j3)+w4* sv(j4) + psfc_prime0=w1* sp(j1)+w2* sp(j2)+w3* sp(j3)+w4* sp(j4) + if(tptr%tv_ob)then ts_prime0=w1*stv(j1)+w2*stv(j2)+w3*stv(j3)+w4*stv(j4) else ts_prime0=w1*st(j1)+w2*st(j2)+w3*st(j3)+w4*st(j4) end if + if (isst==0) then tg_prime0=w1* ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) else tg_prime0=zero end if - qs_prime0=w1* sq(j1)+w2* sq(j2)+w3* sq(j3)+w4* sq(j4) - us_prime0=w1* su(j1)+w2* su(j2)+w3* su(j3)+w4* su(j4) - vs_prime0=w1* sv(j1)+w2* sv(j2)+w3* sv(j3)+w4* sv(j4) - psfc_prime0=w1* sp(j1)+w2* sp(j2)+w3* sp(j3)+w4* sp(j4) val=psfc_prime0*tptr%tlm_tsfc(1) + tg_prime0*tptr%tlm_tsfc(2) + & ts_prime0 *tptr%tlm_tsfc(3) + qs_prime0*tptr%tlm_tsfc(4) + & @@ -231,8 +231,8 @@ subroutine intt_(thead,rval,sval,rpred,spred) val=w1*stv(j1)+w2*stv(j2)+w3*stv(j3)+w4*stv(j4)& +w5*stv(j5)+w6*stv(j6)+w7*stv(j7)+w8*stv(j8) else - val=w1* st(j1)+w2* st(j2)+w3* st(j3)+w4* st(j4)& - +w5* st(j5)+w6* st(j6)+w7* st(j7)+w8* st(j8) + val=w1*st(j1)+ w2*st(j2)+ w3*st(j3)+ w4*st(j4)& + +w5*st(j5)+ w6*st(j6)+ w7*st(j7)+ w8*st(j8) end if end if @@ -310,21 +310,7 @@ subroutine intt_(thead,rval,sval,rpred,spred) rp(j2)=rp(j2)+w2*psfc_grad rp(j3)=rp(j3)+w3*psfc_grad rp(j4)=rp(j4)+w4*psfc_grad - vs_grad =tptr%tlm_tsfc(6)*grad - rv(j1)=rv(j1)+w1*vs_grad - rv(j2)=rv(j2)+w2*vs_grad - rv(j3)=rv(j3)+w3*vs_grad - rv(j4)=rv(j4)+w4*vs_grad - us_grad =tptr%tlm_tsfc(5)*grad - ru(j1)=ru(j1)+w1*us_grad - ru(j2)=ru(j2)+w2*us_grad - ru(j3)=ru(j3)+w3*us_grad - ru(j4)=ru(j4)+w4*us_grad - qs_grad =tptr%tlm_tsfc(4)*grad - rq(j1)=rq(j1)+w1*qs_grad - rq(j2)=rq(j2)+w2*qs_grad - rq(j3)=rq(j3)+w3*qs_grad - rq(j4)=rq(j4)+w4*qs_grad + if (isst==0) then tg_grad =tptr%tlm_tsfc(2)*grad rsst(j1)=rsst(j1)+w1*tg_grad @@ -333,22 +319,39 @@ subroutine intt_(thead,rval,sval,rpred,spred) rsst(j4)=rsst(j4)+w4*tg_grad end if - ts_grad =tptr%tlm_tsfc(3)*grad if(tptr%tv_ob)then rtv(j1)=rtv(j1)+w1*ts_grad rtv(j2)=rtv(j2)+w2*ts_grad rtv(j3)=rtv(j3)+w3*ts_grad rtv(j4)=rtv(j4)+w4*ts_grad - else rt(j1)=rt(j1)+w1*ts_grad rt(j2)=rt(j2)+w2*ts_grad rt(j3)=rt(j3)+w3*ts_grad rt(j4)=rt(j4)+w4*ts_grad - end if + qs_grad =tptr%tlm_tsfc(4)*grad + rq(j1)=rq(j1)+w1*qs_grad + rq(j2)=rq(j2)+w2*qs_grad + rq(j3)=rq(j3)+w3*qs_grad + rq(j4)=rq(j4)+w4*qs_grad + + us_grad =tptr%tlm_tsfc(5)*grad + ru(j1)=ru(j1)+w1*us_grad + ru(j2)=ru(j2)+w2*us_grad + ru(j3)=ru(j3)+w3*us_grad + ru(j4)=ru(j4)+w4*us_grad + + vs_grad =tptr%tlm_tsfc(6)*grad + rv(j1)=rv(j1)+w1*vs_grad + rv(j2)=rv(j2)+w2*vs_grad + rv(j3)=rv(j3)+w3*vs_grad + rv(j4)=rv(j4)+w4*vs_grad + + + else !------bypass surface model-------------------------- diff --git a/src/gsi/jgrad.f90 b/src/gsi/jgrad.f90 index 2e32556465..c6e2e5415c 100755 --- a/src/gsi/jgrad.f90 +++ b/src/gsi/jgrad.f90 @@ -58,6 +58,7 @@ subroutine jgrad(xhat,yhat,fjcost,gradx,lupdfgs,nprt,calledby) use hybrid_ensemble_parameters,only : l_hyb_ens,ntlevs_ens use mpl_allreducemod, only: mpl_allreduce use obs_sensitivity, only: efsoi_o2_update +use control2state_mod, only: control2state,control2state_ad implicit none diff --git a/src/gsi/lightinfo.f90 b/src/gsi/lightinfo.f90 index b0ebcdacfd..bdd6aee392 100755 --- a/src/gsi/lightinfo.f90 +++ b/src/gsi/lightinfo.f90 @@ -205,11 +205,13 @@ subroutine lightinfo_read else ! File does not exist, write warning message to alert users - if (mype==mype_light) then - open(iout_light) - write(iout_light,*)'LIGHTINFO_READ: ***WARNING*** FILE ',trim(fname),'does not exist' - close(iout_light) - endif +! For many usages light data is not important. Write line to output. +! if (mype==mype_light) then +! open(iout_light) +! write(iout_light,*)'LIGHTINFO_READ: ***WARNING*** FILE ',trim(fname),'does not exist' + if(mype==mype_light)write(6,*)'LIGHTINFO_READ: FILE ',trim(fname),'does not exist' +! close(iout_light) +! endif end if return diff --git a/src/gsi/m_radNode.F90 b/src/gsi/m_radNode.F90 index 33070e8382..ae4854920a 100644 --- a/src/gsi/m_radNode.F90 +++ b/src/gsi/m_radNode.F90 @@ -57,6 +57,7 @@ module m_radNode ! square root of inverse of R, only used ! if using correlated obs + integer(i_kind),dimension(:),pointer :: iccerr => NULL() integer(i_kind),dimension(:),pointer :: icx => NULL() integer(i_kind),dimension(:),pointer :: ich => NULL() integer(i_kind) :: nchan ! number of channels for this profile @@ -214,6 +215,7 @@ subroutine obsNode_clean_(aNode) if(associated(aNode%Rpred )) deallocate(aNode%Rpred ) if(associated(aNode%rsqrtinv)) deallocate(aNode%rsqrtinv) if(associated(aNode%icx )) deallocate(aNode%icx ) + if(associated(aNode%iccerr )) deallocate(aNode%iccerr ) _EXIT_(myname_) return end subroutine obsNode_clean_ @@ -276,6 +278,7 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) if(associated(aNode%Rpred )) deallocate(aNode%Rpred) if(associated(aNode%rsqrtinv)) deallocate(aNode%rsqrtinv) if(associated(aNode%icx )) deallocate(aNode%icx ) + if(associated(aNode%iccerr )) deallocate(aNode%iccerr ) nchan=aNode%nchan allocate( aNode%diags(nchan), & @@ -285,7 +288,7 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) aNode%pred (npred,nchan), & aNode%dtb_dvar(nsigradjac,nchan), & aNode%ich (nchan), & - aNode%icx (nchan) ) + aNode%icx (nchan), aNode%iccerr(nchan) ) read(iunit,iostat=istat) aNode%ich , & aNode%res , & @@ -293,6 +296,7 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) aNode%raterr2 , & aNode%pred , & aNode%icx , & + aNode%iccerr , & aNode%dtb_dvar, & aNode%wij , & aNode%ij @@ -368,6 +372,7 @@ subroutine obsNode_xwrite_(aNode,junit,jstat) aNode%raterr2 , & aNode%pred , & aNode%icx , & + aNode%iccerr , & aNode%dtb_dvar, & aNode%wij , & aNode%ij diff --git a/src/gsi/ncepgfs_io.f90 b/src/gsi/ncepgfs_io.f90 index 52dcc4e1b5..59be6d3925 100644 --- a/src/gsi/ncepgfs_io.f90 +++ b/src/gsi/ncepgfs_io.f90 @@ -1440,7 +1440,7 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) if ( use_gfs_nemsio ) then if ( write_fv3_incr ) then - call write_fv3_increment(grd_a,sp_a,filename,mype_atm, & + call write_fv3_increment(grd_a,filename,mype_atm, & atm_bundle,itoutsig) else if (fv3_full_hydro) then @@ -1461,7 +1461,7 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) else if ( use_gfs_ncio ) then if ( write_fv3_incr ) then - call write_fv3_increment(grd_a,sp_a,filename,mype_atm, & + call write_fv3_increment(grd_a,filename,mype_atm, & atm_bundle,itoutsig) else call write_gfsncatm(grd_a,sp_a,filename,mype_atm, & diff --git a/src/gsi/obs_sensitivity.f90 b/src/gsi/obs_sensitivity.f90 index 880ee6384a..b6498d09fc 100644 --- a/src/gsi/obs_sensitivity.f90 +++ b/src/gsi/obs_sensitivity.f90 @@ -61,6 +61,7 @@ module obs_sensitivity use hybrid_ensemble_isotropic, only: create_ensemble,load_ensemble,destroy_ensemble use hybrid_ensemble_isotropic, only: hybens_localization_setup use mpeu_util, only: perr,die +use control2state_mod, only: control2state,control2state_ad ! ------------------------------------------------------------------------------ implicit none save diff --git a/src/gsi/obsmod.F90 b/src/gsi/obsmod.F90 index 3dd936d94e..bb317d0752 100644 --- a/src/gsi/obsmod.F90 +++ b/src/gsi/obsmod.F90 @@ -435,8 +435,8 @@ module obsmod public :: iout_pcp,iout_rad,iadate,iadatemn,write_diag,reduce_diag,oberrflg,bflag,ndat,dthin,dmesh,l_do_adjoint public :: diag_radardbz public :: lsaveobsens - public :: iout_cldch, mype_cldch - public :: nprof_gps,time_offset,ianldate,tcp_box + public :: iout_cldch, mype_cldch + public :: nprof_gps,time_offset,ianldate,tcp_box public :: iout_oz,iout_co,dsis,ref_obs,obsfile_all,lobserver,tcp_posmatch,perturb_obs,ditype,dsfcalc,dplat public :: time_window,dval,dtype,dfile,dirname,obs_setup,oberror_tune,offtime_data public :: lobsdiagsave,lobsdiag_forenkf,blacklst,hilbert_curve,lobskeep,time_window_max,sfcmodel,ext_sonde @@ -831,7 +831,7 @@ subroutine init_obsmod_dflts iout_tcp=214 ! synthetic tc-mslp iout_lag=215 ! lagrangian tracers iout_co=216 ! co tracers - iout_aero=217 ! aerosol product (aod) + iout_aero=217 ! aerosol product (aod) CURRENTLY NOT USED iout_gust=218 ! wind gust iout_vis=219 ! visibility iout_pblh=221 ! pbl height diff --git a/src/gsi/pcgsoi.f90 b/src/gsi/pcgsoi.f90 index a4ae2431b1..fac01c9315 100644 --- a/src/gsi/pcgsoi.f90 +++ b/src/gsi/pcgsoi.f90 @@ -130,8 +130,8 @@ subroutine pcgsoi() iguess,read_guess_solution, & niter_no_qc,print_diag_pcg use gsi_4dvar, only: nobs_bins, nsubwin, l4dvar, iwrtinc, ladtest, & - iorthomax - use gridmod, only: twodvar_regional,periodic + iorthomax,lsqrtb + use gridmod, only: twodvar_regional,periodic,minmype use constants, only: zero,one,tiny_r_kind use mpimod, only: mype use mpl_allreducemod, only: mpl_allreduce @@ -148,15 +148,17 @@ subroutine pcgsoi() use bias_predictors, only: update_bias_preds use xhat_vordivmod, only : xhat_vordiv_init, xhat_vordiv_calc, xhat_vordiv_clean use timermod, only: timer_ini,timer_fnl - use hybrid_ensemble_parameters,only : l_hyb_ens,ntlevs_ens + use hybrid_ensemble_parameters,only : l_hyb_ens,ntlevs_ens,aniso_a_en use gsi_bundlemod, only : gsi_bundle use gsi_bundlemod, only : self_add,assignment(=) use gsi_bundlemod, only : gsi_bundleprint + use gsi_bundlemod, only : gsi_bundlegetpointer use gsi_4dcouplermod, only : gsi_4dcoupler_grtests use rapidrefresh_cldsurf_mod, only: i_gsdcldanal_type use gsi_io, only: verbose use berror, only: vprecond use stpjomod, only: stpjo_setup + use intradmod, only: setrad implicit none @@ -187,7 +189,7 @@ subroutine pcgsoi() type(control_vector), allocatable, dimension(:) :: cglwork type(control_vector), allocatable, dimension(:) :: cglworkhat integer(i_kind) :: iortho - logical :: print_verbose + logical :: print_verbose,ortho,diag_print logical :: lanlerr,read_success ! Step size diagnostic strings @@ -235,7 +237,9 @@ subroutine pcgsoi() nlnqc_iter=.false. call stpjo_setup(nobs_bins) + ortho=.false. if(iorthomax>0) then + ortho=.true. allocate(cglwork(iorthomax+1)) DO ii=1,iorthomax+1 CALL allocate_cv(cglwork(ii)) @@ -252,10 +256,19 @@ subroutine pcgsoi() end do sbias=zero + call setrad(sval(1)) + if(l_hyb_ens .and. .not. aniso_a_en) then + if (lsqrtb) then + write(6,*)'l_hyb_ens: not for use with lsqrtb' + call stop2(317) + end if + end if ! Perform inner iteration inner_iteration: do iter=0,niter(jiter) + + diag_print= iter <= 1 .and. print_diag_pcg -! Gradually turn on variational qc to avoid possible convergence problems +! Gradually turn on old variational qc to avoid possible convergence problems if(vqc) then nlnqc_iter = iter >= niter_no_qc(jiter) if(jiter == jiterstart) then @@ -266,17 +279,11 @@ subroutine pcgsoi() endif end if ! 1. Calculate gradient - do ii=1,nobs_bins - rval(ii)=zero - end do - rbias=zero gradx=zero - llprt=(mype==0).and.(iter<=1) -! Control to state -! call c2s(xhat,sval,sbias,llprt,.true.) + llprt=(mype==minmype).and.(iter<=1) - if (iter<=1 .and. print_diag_pcg) then + if (diag_print) then do ii=1,nobs_bins call prt_state_norms(sval(ii),'sval') enddo @@ -285,7 +292,7 @@ subroutine pcgsoi() ! Compare obs to solution and transpose back to grid call intall(sval,sbias,rval,rbias) - if (iter<=1 .and. print_diag_pcg) then + if (diag_print) then do ii=1,nobs_bins call prt_state_norms(rval(ii),'rval') enddo @@ -295,10 +302,12 @@ subroutine pcgsoi() call c2s_ad(gradx,rval,rbias,llprt) ! Print initial Jo table - if (iter==0 .and. print_diag_pcg .and. luse_obsdiag) then - nprt=2 - call evaljo(zjo,iobs,nprt,llouter) - call prt_control_norms(gradx,'gradx') + if (iter==0) then + if(print_diag_pcg .and. luse_obsdiag) then + nprt=2 + call evaljo(zjo,iobs,nprt,llouter) + call prt_control_norms(gradx,'gradx') + end if endif ! Add contribution from background term @@ -308,7 +317,7 @@ subroutine pcgsoi() ! End of gradient calculation ! Re-orthonormalization if requested - if(iorthomax>0) then + if(ortho) then iortho=min(iorthomax,iter) if(iter .ne. 0) then do ii=iortho,1,-1 @@ -323,13 +332,13 @@ subroutine pcgsoi() ! 2. Multiply by background error call multb(gradx,grady) - if(iorthomax>0) then + if(ortho) then ! save gradients if (iter <= iortho) then - zdla = sqrt(dot_product(gradx,grady,r_quad)) + zdla = one/sqrt(dot_product(gradx,grady,r_quad)) do i=1,nclen - cglwork(iter+1)%values(i)=gradx%values(i)/zdla - cglworkhat(iter+1)%values(i)=grady%values(i)/zdla + cglwork(iter+1)%values(i)=gradx%values(i)*zdla + cglworkhat(iter+1)%values(i)=grady%values(i)*zdla end do end if end if @@ -350,7 +359,7 @@ subroutine pcgsoi() ! different due to round off, so use average. gnorm(2)=dprod(2)-0.5_r_quad*(dprod(3)+dprod(4)) gnorm(3)=dprod(2) - if(mype == 0)then + if(mype == minmype)then aindex=abs(dprod(3)/dprod(2)) write(iout_iter,*) 'NL Index ',aindex if(aindex > 0.5_r_kind .or. print_verbose) write(iout_iter,*) 'NL Values ', dprod(3),dprod(2) @@ -370,7 +379,7 @@ subroutine pcgsoi() gnorm(1)=dprod(1) - if(mype == 0)write(iout_iter,*)'Minimization iteration',iter + if(mype == minmype)write(iout_iter,*)'Minimization iteration',iter ! 4. Calculate b and new search direction b=zero @@ -378,13 +387,13 @@ subroutine pcgsoi() if (iter > 1 .or. .not. read_success)then if (gsave>1.e-16_r_kind) b=gnorm(2)/gsave if (b30.0_r_kind) then - if (mype==0) then + if (mype==minmype) then if (iout_6) write(6,105) gnorm(2),gsave,b write(iout_iter,105) gnorm(2),gsave,b endif b=zero endif - if (mype==0 .and. print_verbose) write(6,888)'pcgsoi: gnorm(1:3),b=',gnorm,b + if (mype==minmype .and. print_verbose) write(6,888)'pcgsoi: gnorm(1:3),b=',gnorm,b end if do i=1,nclen @@ -432,22 +441,20 @@ subroutine pcgsoi() gnormx=gnorm(1)/gnormorig penx=penalty/penorig - if (mype==0) then + if (mype==minmype) then if (iter==0) then zgini=gnorm(1) zfini=penalty write(6,888)'Initial cost function =',zfini write(6,888)'Initial gradient norm =',sqrt(zgini) endif - if(print_verbose)then - write(iout_iter,888)'pcgsoi: gnorm(1:2)',gnorm - write(iout_iter,999)'costterms Jb,Jo,Jc,Jl =',jiter,iter,fjcost - end if istep=1 if (stp= pennorm .or. end_iter)then - if(mype == 0)then + if(mype == minmype)then if(iout_6) write(6,101) write(iout_iter,101) @@ -508,7 +515,7 @@ subroutine pcgsoi() ! End of inner iteration ! Deallocate space for renormalization - if(iorthomax>0) then + if(ortho) then do ii=1,iorthomax+1 call deallocate_cv(cglwork(ii)) enddo @@ -521,7 +528,7 @@ subroutine pcgsoi() ! Calculate adjusted observation error factor if( oberror_tune .and. (.not.l4dvar) ) then - if (mype == 0) write(6,*) 'PCGSOI: call penal for obs perturbation' + if (mype == minmype) write(6,*) 'PCGSOI: call penal for obs perturbation' ! call c2s(xhat,sval,sbias,.false.,.false.) call penal(sval(1)) @@ -535,17 +542,14 @@ subroutine pcgsoi() if (l_tlnmc .and. baldiag_inc) call strong_baldiag_inc(sval,size(sval)) - llprt=(mype==0) + llprt=(mype==minmype) ! call c2s(xhat,sval,sbias,llprt,.false.) if(print_diag_pcg)then ! Evaluate final cost function and gradient - if (mype==0) write(6,*)'Minimization final diagnostics' + if (mype==minmype) write(6,*)'Minimization final diagnostics' - do ii=1,nobs_bins - rval(ii)=zero - end do call intall(sval,sbias,rval,rbias) gradx=zero call c2s_ad(gradx,rval,rbias,llprt) @@ -575,16 +579,16 @@ subroutine pcgsoi() ! fjcost(1) = dot_product(xhatsave,yhatsave,r_quad) end if ! fjcost(2) = zjo - zfend=penaltynew -! if(l_hyb_ens) zfend=zfend+fjcost_e - if (mype==0) then + if (mype==minmype) then + zfend=penaltynew if(l_hyb_ens) then ! If hybrid ensemble run, print out contribution to Jb and Je separately write(iout_iter,999)'costterms Jb,Je,Jo,Jc,Jl =',jiter,iter,fjcostnew(1)- fjcost_e, & fjcost_e,fjcostnew(2:4) +! zfend=zfend+fjcost_e else write(iout_iter,999)'costterms Jb,Jo,Jc,Jl =',jiter,iter,fjcostnew @@ -905,6 +909,7 @@ subroutine c2s(hat,val,bias,llprt,ltest) use gsi_bundlemod, only : gsi_bundle,assignment(=) use gsi_4dvar, only: nobs_bins, nsubwin, l4dvar use gsi_4dcouplermod, only : gsi_4dcoupler_grtests + use control2state_mod, only: control2state,control2state_ad implicit none type(control_vector) ,intent(inout) :: hat @@ -971,6 +976,7 @@ subroutine c2s_ad(hat,val,bias,llprt) use gsi_bundlemod, only : gsi_bundle,assignment(=) use gsi_bundlemod, only : self_add use gsi_4dvar, only: nobs_bins, nsubwin, l4dvar + use control2state_mod, only: control2state_ad implicit none type(control_vector) ,intent(inout) :: hat diff --git a/src/gsi/pvqc.f90 b/src/gsi/pvqc.f90 index 81d27ba99f..3353b091a3 100755 --- a/src/gsi/pvqc.f90 +++ b/src/gsi/pvqc.f90 @@ -382,8 +382,8 @@ subroutine vqch_iii(ia,ib,ik,x,g,w)! [vqch] g=g-ya w=-w/xx else - g=-qx**2/2 - w=1 + g=-qx**2/2_dp + w=1_dp endif g=p*g end subroutine vqch_iii diff --git a/src/gsi/q_diag.f90 b/src/gsi/q_diag.f90 index 925a5775ec..15ef49c6b5 100644 --- a/src/gsi/q_diag.f90 +++ b/src/gsi/q_diag.f90 @@ -38,7 +38,7 @@ subroutine q_diag(it,mype) use mpimod, only: mpi_rtype,mpi_comm_world,mpi_sum,ierror use constants,only: zero,two,one,half use gridmod, only: lat2,lon2,nsig,nlat,nlon,lat1,lon1,iglobal,& - displs_g,ijn,wgtlats,itotsub,strip + displs_g,ijn,wgtlats,itotsub,strip,minmype use derivsmod, only: cwgues use general_commvars_mod, only: load_grid use gridmod, only: regional @@ -67,7 +67,7 @@ subroutine q_diag(it,mype) real(r_kind),pointer,dimension(:,:,:):: ges_q =>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_cwmr_it=>NULL() - mype_out=0 + mype_out=minmype mm1=mype+1 ier=0 diff --git a/src/gsi/qcmod.f90 b/src/gsi/qcmod.f90 index f4afdbae9d..7146ceff3e 100644 --- a/src/gsi/qcmod.f90 +++ b/src/gsi/qcmod.f90 @@ -2311,7 +2311,6 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & if (lcloud .ge. kmax(i)) then if(luse)aivals(11,is) = aivals(11,is) + one varinv(i) = zero - varinv_use(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_cloud_qc cycle end if @@ -2320,12 +2319,10 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & ! If more than 2% of the transmittance comes from the cloud layer, ! reject the channel (0.02 is a tunable parameter) - delta = 0.02_r_kind if ( ptau5(lcloud,i) > 0.02_r_kind) then ! QC4 in statsrad if(luse)aivals(11,is) = aivals(11,is) + one varinv(i) = zero - varinv_use(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_cloud_qc end if end do @@ -2353,8 +2350,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & delta=max(r0_05*tnoise(i),r0_02) if(abs(dts*ts(i)) > delta)then ! QC3 in statsrad - if(luse .and. varinv(i) > zero) & - aivals(10,is) = aivals(10,is) + one + if(luse .and. varinv(i) > zero) aivals(10,is) = aivals(10,is) + one varinv(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_sfcir_qc end if @@ -2369,8 +2365,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & do i=1,nchanl if (ts(i) > 0.2_r_kind) then ! QC3 in statsrad - if(luse .and. varinv(i) > zero) & - aivals(10,is) = aivals(10,is) + one + if(luse .and. varinv(i) > zero) aivals(10,is) = aivals(10,is) + one varinv(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_sfcir_qc end if @@ -2435,75 +2430,68 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & if(hirs) then do i=1,nchanl m=ich(i) - if (iomg_det(m) > 0 .and. i < 4 .and. abs(tbcnob(8)) > 40.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 12 .and. abs(tbcnob(8)) > 10.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif -!90S-60S - if(cenlat >= -90.0_r_kind .and. cenlat < -60.0_r_kind) then - if(iomg_det(m) > 0 .and. i == 4 .and. abs(tbcnob(8)) > 12.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 5 .and. abs(tbcnob(8)) > 6.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 6 .and. abs(tbcnob(8)) > 4.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif -!60S-30S - else if(cenlat >= -60.0_r_kind .and. cenlat < -30.0_r_kind) then - if(iomg_det(m) > 0 .and. i == 4 .and. abs(tbcnob(8)) > 10.0_r_kind) then + if(iomg_det(m) > 0 .and. i >= 4 .and. i <= 12)then + if (i < 4 .and. abs(tbcnob(8)) > 40.0_r_kind) then varinv(i) = zero if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 5 .and. abs(tbcnob(8)) > 2.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 6 .and. abs(tbcnob(8)) > 1.5_r_kind) then + else if(i == 12 .and. abs(tbcnob(8)) > 10.0_r_kind) then varinv(i) = zero if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det endif +!90S-60S + if(cenlat >= -90.0_r_kind .and. cenlat < -60.0_r_kind) then + if(i == 4 .and. abs(tbcnob(8)) > 12.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 5 .and. abs(tbcnob(8)) > 6.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 6 .and. abs(tbcnob(8)) > 4.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif +!60S-30S + else if(cenlat >= -60.0_r_kind .and. cenlat < -30.0_r_kind) then + if(i == 4 .and. abs(tbcnob(8)) > 10.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if( i == 5 .and. abs(tbcnob(8)) > 2.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 6 .and. abs(tbcnob(8)) > 1.5_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif !30S-30N - else if(cenlat >= -30.0_r_kind .and. cenlat < 30.0_r_kind) then - if(iomg_det(m) > 0 .and. i == 4 .and. abs(tbcnob(8)) > 5.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 5 .and. (tbcnob(8) < -2.0_r_kind .or. tbcnob(8) > 3.0_r_kind)) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 6 .and. (tbcnob(8) < -1.5_r_kind .or. tbcnob(8) > 3.0_r_kind)) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif + else if(cenlat >= -30.0_r_kind .and. cenlat < 30.0_r_kind ) then + if(i == 4 .and. abs(tbcnob(8)) > 5.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 5 .and. (tbcnob(8) < -2.0_r_kind .or. tbcnob(8) > 3.0_r_kind)) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 6 .and. (tbcnob(8) < -1.5_r_kind .or. tbcnob(8) > 3.0_r_kind)) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif !30N-60N - else if(cenlat >= 30.0_r_kind .and. cenlat < 60.0_r_kind) then - if(iomg_det(m) > 0 .and. i == 4 .and. abs(tbcnob(8)) > 8.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 5 .and. abs(tbcnob(8)) > 2.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 6 .and. abs(tbcnob(8)) > 1.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - endif !cenlat + else if(cenlat >= 30.0_r_kind .and. cenlat < 60.0_r_kind) then + if(i == 4 .and. abs(tbcnob(8)) > 8.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 5 .and. abs(tbcnob(8)) > 2.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 6 .and. abs(tbcnob(8)) > 1.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif + endif !cenlat + end if if (itopo_det(m) > 0 .and. zsges > 1500.0_r_kind) then varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_itopo_det + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_itopo_det endif end do endif !! if (hirs) @@ -2990,13 +2978,11 @@ subroutine qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, & dsval=((2.41_r_kind-0.0098_r_kind*tb_obsbc1)*tbc(ich238) + & 0.454_r_kind*tbc(ich314)-tbc(ich890))*w1f6 dsval=max(zero,dsval) - end if - - if(sea)then clwx=cosza*clw*w1f4 else clwx=0.6_r_kind end if + ! QC6 in statsrad if(clwx >= one .and. luse)aivals(13,is) = aivals(13,is) + one factch4=clwx**2+(tbc(ich528)*w2f4)**2 diff --git a/src/gsi/radinfo.f90 b/src/gsi/radinfo.f90 index 8bfb015d1c..ffc4641696 100644 --- a/src/gsi/radinfo.f90 +++ b/src/gsi/radinfo.f90 @@ -1741,7 +1741,7 @@ subroutine init_predx if (.not. (any(inew_rad) .or. any(update_tlapmean))) return if (ndat==0) return - if (mype==0) write(6,*) 'INIT_PREDX: enter routine' +! if (mype==0) write(6,*) 'INIT_PREDX: enter routine' ! Allocate and initialize data arrays if (any(update_tlapmean)) then diff --git a/src/gsi/read_atms.f90 b/src/gsi/read_atms.f90 index 9f5efb5301..47b675b3a3 100644 --- a/src/gsi/read_atms.f90 +++ b/src/gsi/read_atms.f90 @@ -511,10 +511,10 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& ALLOCATE(Relative_Time_In_Seconds(Num_Obs)) ALLOCATE(IScan(Num_Obs)) Relative_Time_In_Seconds = 3600.0_r_kind*T4DV_Save(1:Num_Obs) - write(6,*) 'Calling ATMS_Spatial_Average' +! write(6,*) 'Calling ATMS_Spatial_Average' CALL ATMS_Spatial_Average(Num_Obs, NChanl, IFOV_Save(1:Num_Obs), & Relative_Time_In_Seconds, BT_Save(1:nchanl,1:Num_Obs), IScan, IRet) - write(6,*) 'ATMS_Spatial_Average Called with IRet=',IRet +! write(6,*) 'ATMS_Spatial_Average Called with IRet=',IRet DEALLOCATE(Relative_Time_In_Seconds) IF (IRet /= 0) THEN diff --git a/src/gsi/read_bufrtovs.f90 b/src/gsi/read_bufrtovs.f90 index 0aed801ee5..0c954c7c1d 100644 --- a/src/gsi/read_bufrtovs.f90 +++ b/src/gsi/read_bufrtovs.f90 @@ -228,7 +228,7 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& real(r_kind),allocatable,dimension(:,:):: data_all real(crtm_kind),allocatable,dimension(:):: data1b4 - real(r_double),allocatable,dimension(:):: data1b8,data1b8x + real(r_double),allocatable,dimension(:):: data1b8 real(r_double),dimension(n1bhdr):: bfr1bhdr real(r_double),dimension(n2bhdr):: bfr2bhdr @@ -519,7 +519,6 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& ! support multiple spc coefficient files for any given sensor if(amsua .or. amsub .or. mhs)then quiet=.not.verbose - allocate(data1b8x(nchanl)) spc_coeff_versions = 0 spc_coeff_found = .true. do while (spc_coeff_found) @@ -748,13 +747,15 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& ! unless the satellite is n15 or n16, because tranamsua ! does this conversion because the coefficient files exist ! for it to use - data1b8x=data1b8 data1b4=data1b8 !call apply_antcorr(accoeff_sets(spc_coeff_versions),ifov,data1b4) call apply_antcorr(accoeff_sets(1),ifov,data1b4) - data1b8=data1b4 do j=1,nchanl - if(data1b8x(j) > r1000) data1b8(j) = 1000000._r_kind + if(data1b8(j) > r1000)then + data1b8(j) = 1000000._r_kind + else + data1b8(j) = data1b4(j) + end if end do end if else ! EARS / DB @@ -766,14 +767,16 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& ! data originator, ! then convert back to brightness temperature using the version ! of parameters used by the CRTM - data1b8x=data1b8 data1b4=data1b8 call remove_antcorr(accoeff_sets(sacv),ifov,data1b4) !call apply_antcorr(accoeff_sets(spc_coeff_versions),ifov,data1b4) call apply_antcorr(accoeff_sets(1),ifov,data1b4) - data1b8=data1b4 do j=1,nchanl - if(data1b8x(j) > r1000) data1b8(j) = 1000000._r_kind + if(data1b8(j) > r1000) then + data1b8(j) = 1000000._r_kind + else + data1b8(j)=data1b4(j) + end if end do end if end if @@ -785,12 +788,14 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& else ! EARS / DB call ufbrep(lnbufr,data1b8,1,nchanl,iret,'TMBRST') if ( amsua .or. amsub .or. mhs )then - data1b8x=data1b8 data1b4=data1b8 call remove_antcorr(accoeff_sets(1),ifov,data1b4) - data1b8=data1b4 do j=1,nchanl - if(data1b8x(j) > r1000)data1b8(j) = 1000000._r_kind + if(data1b8(j) > r1000)then + data1b8(j) = 1000000._r_kind + else + data1b8(j) = data1b4(j) + end if end do end if end if @@ -1053,8 +1058,6 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& call closbf(lnbufr) close(lnbufr) - if (allocated(data1b8x)) deallocate(data1b8x) - end do ears_db_loop deallocate(data1b8,data1b4) diff --git a/src/gsi/read_gps.f90 b/src/gsi/read_gps.f90 index 3d8379ee3b..c0cef658a6 100644 --- a/src/gsi/read_gps.f90 +++ b/src/gsi/read_gps.f90 @@ -368,8 +368,7 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & good=.true. if((abs(rlat)>90._r_kind).or.(abs(rlon)>r360).or.(height<=zero)) then good=.false. - endif - if (ref_obs) then + else if (ref_obs) then if ((ref>=1.e+9_r_kind).or.(ref<=zero).or.(height>=1.e+9_r_kind)) then good=.false. endif @@ -466,8 +465,9 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & write(6,*)'READ_GPS: # bad or missing data=', notgood do i=1,ngpsro_type if (nmrecs_id(i)>0) & - write(6,1020)'READ_GPS: LEO_id,nprof_gps = ',gpsro_itype(i),nmrecs_id(i) + write(6,1021)'READ_GPS: LEO_id,nprof_gps = ',gpsro_itype(i),nmrecs_id(i) end do +1021 format(a31,i6,i6) write(6,1020)'READ_GPS: ref_obs,nprof_gps= ',ref_obs,nprof_gps 1020 format(a31,L,i6) diff --git a/src/gsi/read_iasi.f90 b/src/gsi/read_iasi.f90 index 367c224508..d0a3793b4e 100644 --- a/src/gsi/read_iasi.f90 +++ b/src/gsi/read_iasi.f90 @@ -175,7 +175,6 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& character(len=4) :: senname character(len=80) :: allspotlist character(len=40) :: infile2 - integer(i_kind) :: jstart integer(i_kind) :: iret,ireadsb,ireadmg,irec,next, nrec_startx integer(i_kind),allocatable,dimension(:) :: nrec @@ -202,6 +201,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& real(r_kind),dimension(0:3) :: ts real(r_kind),dimension(10) :: sscale real(crtm_kind),allocatable,dimension(:) :: temperature + real(r_kind),allocatable,dimension(:) :: scalef real(r_kind),allocatable,dimension(:,:):: data_all real(r_kind) cdist,disterr,disterrmax,dlon00,dlat00 @@ -238,7 +238,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& integer(i_kind),parameter :: ilon = 3 integer(i_kind),parameter :: ilat = 4 real(r_kind) :: ptime,timeinflat,crit0 - integer(i_kind) :: ithin_time,n_tbin,it_mesh + integer(i_kind) :: ithin_time,n_tbin,it_mesh,jstart logical print_verbose print_verbose=.false. @@ -396,6 +396,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& allocate(temperature(1)) ! dependent on # of channels in the bufr file allocate(allchan(2,1)) ! actual values set after ireadsb allocate(bufr_chan_test(1))! actual values set after ireadsb + allocate(scalef(1)) ! Big loop to read data file next=0 @@ -442,10 +443,11 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& bufr_size = size(temperature,1) if ( bufr_size /= bufr_nchan ) then ! Re-allocation if number of channels has changed ! Allocate the arrays needed for the channel and radiance array - deallocate(temperature,allchan,bufr_chan_test) + deallocate(temperature,allchan,bufr_chan_test,scalef) allocate(temperature(bufr_nchan)) ! dependent on # of channels in the bufr file allocate(allchan(2,bufr_nchan)) allocate(bufr_chan_test(bufr_nchan)) + allocate(scalef(bufr_nchan)) bufr_chan_test(:)=0 endif ! allocation if @@ -675,6 +677,18 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& ! Read IASI channel number(CHNM) and radiance (SCRA) call ufbseq(lnbufr,allchan,2,bufr_nchan,iret,'IASICHN') + jstart=1 + scalef=one + do i=1,bufr_nchan + scaleloop: do j=jstart,10 + if(allchan(1,i) >= cscale(1,j) .and. allchan(1,i) <= cscale(2,j))then + scalef(i) = sscale(j) + jstart=j + exit scaleloop + end if + end do scaleloop + end do + if (iret /= bufr_nchan) then write(6,*)'READ_IASI: ### ERROR IN READING ', senname, ' BUFR DATA:', & iret, ' CH DATA IS READ INSTEAD OF ',bufr_nchan @@ -703,52 +717,49 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& cycle read_loop endif - iskip = 0 - jstart=1 +!$omp parallel do schedule(dynamic,1) private(i,sc_chan,bufr_chan,radiance) channel_loop: do i=1,satinfo_nchan - sc_chan = sc_index(i) - if ( bufr_index(i) == 0 ) cycle channel_loop bufr_chan = bufr_index(i) + if (bufr_chan /= 0 ) then ! check that channel number is within reason - if (( allchan(2,bufr_chan) > zero .and. allchan(2,bufr_chan) < 99999._r_kind)) then ! radiance bounds - radiance = allchan(2,bufr_chan) - scaleloop: do j=jstart,10 - if(allchan(1,bufr_chan) >= cscale(1,j) .and. allchan(1,bufr_chan) <= cscale(2,j))then - radiance = allchan(2,bufr_chan)*sscale(j) - jstart=j - exit scaleloop - end if - end do scaleloop - call crtm_planck_temperature(sensorindex,sc_chan,radiance,temperature(bufr_chan)) + if (( allchan(2,bufr_chan) > zero .and. allchan(2,bufr_chan) < 99999._r_kind)) then ! radiance bounds + radiance = allchan(2,bufr_chan)*scalef(bufr_chan) + sc_chan = sc_index(i) + call crtm_planck_temperature(sensorindex,sc_chan,radiance,temperature(bufr_chan)) + else + temperature(bufr_chan) = tbmin + endif else temperature(bufr_chan) = tbmin - endif + end if end do channel_loop ! Check for reasonable temperature values + iskip = 0 skip_loop: do i=1,satinfo_nchan if ( bufr_index(i) == 0 ) cycle skip_loop bufr_chan = bufr_index(i) if(temperature(bufr_chan) <= tbmin .or. temperature(bufr_chan) > tbmax ) then - temperature(bufr_chan) = min(tbmax,max(zero,temperature(bufr_chan))) + temperature(bufr_chan) = min(tbmax,max(tbmin,temperature(bufr_chan))) if(iuse_rad(ioff+i) >= 0)iskip = iskip + 1 endif end do skip_loop - if(iskip > 0 .and. print_verbose)write(6,*) ' READ_IASI : iskip > 0 ',iskip - if( iskip > 0 )cycle read_loop + if(iskip > 0)then + if(print_verbose)write(6,*) ' READ_IASI : iskip > 0 ',iskip + cycle read_loop + end if - crit1=crit1 + ten*float(iskip) +! crit1=crit1 + ten*float(iskip) ! If the surface channel exists (~960.0 cm-1) and the AVHRR cloud information is missing, use an ! estimate of the surface temperature to determine if the profile may be clear. if (.not. cloud_info) then pred = tsavg*0.98_r_kind - temperature(sfc_channel_index) pred = max(pred,zero) + crit1=crit1 + pred endif - crit1=crit1 + pred - ! Map obs to grids if (pred == zero) then call finalcheck(dist1,crit1,itx,iuse) @@ -818,11 +829,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& ! Put satinfo defined channel temperatures into data array do l=1,satinfo_nchan i = bufr_index(l) - if ( bufr_index(l) /= 0 ) then - data_all(l+nreal,itx) = temperature(i) ! brightness temerature - else - data_all(l+nreal,itx) = tbmin - endif + data_all(l+nreal,itx) = temperature(i) ! brightness temerature end do nrec(itx)=irec @@ -835,7 +842,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& end do ears_db_loop - deallocate(temperature, allchan, bufr_chan_test) + deallocate(temperature, allchan, bufr_chan_test,scalef) deallocate(channel_number,sc_index) deallocate(bufr_index) ! deallocate crtm info diff --git a/src/gsi/read_obs.F90 b/src/gsi/read_obs.F90 index 53b0723953..9017c498c2 100644 --- a/src/gsi/read_obs.F90 +++ b/src/gsi/read_obs.F90 @@ -221,9 +221,8 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) lexist=.false. end if if(lexist)then - if(jsatid == '')then - kidsat=0 - else if(jsatid == 'metop-a')then + kidsat=0 + if(jsatid == 'metop-a')then kidsat=4 else if(jsatid == 'metop-b')then kidsat=3 @@ -335,8 +334,6 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) ! kidsat = 288 else if ( jsatid == 'meghat' ) then kidsat = 440 - else - kidsat = 0 end if call closbf(lnbufr) @@ -346,8 +343,8 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) call datelen(10) if(kidsat /= 0)then - lexist = .false. - satloop: do while(ireadmg(lnbufr,subset,idate2) >= 0) + lexist = .false. + satloop: do while(ireadmg(lnbufr,subset,idate2) >= 0) if(ireadsb(lnbufr)==0)then call ufbint(lnbufr,satid,1,1,iret,'SAID') end if @@ -356,8 +353,8 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) exit satloop end if nread = nread + 1 - end do satloop - else if(trim(filename) == 'prepbufr')then ! RTod: wired-in filename is not a good idea + end do satloop + else if(trim(filename) == 'prepbufr')then lexist = .false. fileloop: do while(ireadmg(lnbufr,subset,idate2) >= 0) do while(ireadsb(lnbufr)>=0) diff --git a/src/gsi/read_satwnd.f90 b/src/gsi/read_satwnd.f90 index c67d5a7e1f..7a372b9e15 100644 --- a/src/gsi/read_satwnd.f90 +++ b/src/gsi/read_satwnd.f90 @@ -1206,7 +1206,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis else if(itype==240 .or. itype==245 .or. itype==246 .or. itype==251) then ! types 245 and 246 have been used to determine the acceptable pct1 range, but that pct1 range is applied to all GOES-R winds - if (pct1 < 0.04_r_kind) qm=15 + if (pct1 < 0.04_r_kind) qm=15 if (pct1 > 0.50_r_kind) qm=15 endif endif diff --git a/src/gsi/setupcldtot.F90 b/src/gsi/setupcldtot.F90 index 3d899d1a82..a30ef92a90 100755 --- a/src/gsi/setupcldtot.F90 +++ b/src/gsi/setupcldtot.F90 @@ -90,7 +90,7 @@ subroutine setupcldtot(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_di integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index + integer(i_kind) ,intent(in ) :: is ! ndat index logical ,intent(in ) :: conv_diagsave #ifdef RR_CLOUDANALYSIS diff --git a/src/gsi/setuppcp.f90 b/src/gsi/setuppcp.f90 index 970bc5b9af..8a6c8c0d80 100644 --- a/src/gsi/setuppcp.f90 +++ b/src/gsi/setuppcp.f90 @@ -223,7 +223,7 @@ subroutine setuppcp(obsLL,odiagLL,lunin,mype,aivals,nele,nobs,& character(12) string character(128) diag_pcp_file - integer(i_kind) km1,mm1,iiflg,iextra,ireal + integer(i_kind) km1,mm1,iextra,ireal integer(i_kind) ii,i,j,k,m,n,ibin,ioff,ioff0 integer(i_kind) ipt integer(i_kind) nsphys,ixp,iyp,ixx,iyy @@ -325,7 +325,6 @@ subroutine setuppcp(obsLL,odiagLL,lunin,mype,aivals,nele,nobs,& ! ONE TIME, INITIAL SETUP PRIOR TO PROCESSING SATELLITE DATA ! ! Initialize variables - iiflg = 1 ncloud = ncld nsphys = max(int(two*deltim/dtphys+0.9999_r_kind),1) dtp = two*deltim/nsphys diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 index 479d27af96..faa79f0efc 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -404,7 +404,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& real(r_kind),dimension(nchanl):: tcc real(r_kind) :: ptau5deriv, ptau5derivmax real(r_kind) :: clw_guess,clw_guess_retrieval,ciw_guess,rain_guess,snow_guess,clw_avg - real(r_kind) :: tnoise_save real(r_kind),dimension(:), allocatable :: rsqrtinv real(r_kind),dimension(:), allocatable :: rinvdiag real(r_kind),dimension(nchanl) :: abi2km_bc @@ -422,10 +421,10 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& integer(i_kind),allocatable,dimension(:) :: sc_index integer(i_kind) :: state_ind, nind, nnz - logical channel_passive + logical,dimension(jpch_rad) :: channel_passive logical,dimension(nobs):: luse integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - integer(i_kind):: nperobs + integer(i_kind):: nperobs,ncr character(10) filex character(12) string @@ -542,6 +541,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& jc=0 do j=1,jpch_rad + channel_passive(j)=iuse_rad(j)==-1 .or. iuse_rad(j)==0 if(isis == nusis(j))then jc=jc+1 if(jc > nchanl)then @@ -560,10 +560,9 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! ! Set error instrument channels tnoise(jc)=varch(j) - channel_passive=iuse_rad(j)==-1 .or. iuse_rad(j)==0 - if (iuse_rad(j)< -1 .or. (channel_passive .and. & + if (iuse_rad(j)< -1 .or. (channel_passive(j) .and. & .not.rad_diagsave)) tnoise(jc)=r1e10 - if (passive_bc .and. channel_passive) tnoise(jc)=varch(j) + if (passive_bc .and. channel_passive(j)) tnoise(jc)=varch(j) if (iuse_rad(j)>0) l_may_be_passive=.true. if (tnoise(jc) < 1.e4_r_kind) toss = .false. @@ -847,25 +846,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& iinstr=getindex(idnames,trim(covtype)) endif endif - do jc=1,nchanl - j=ich(jc) - - tnoise(jc)=varch(j) - - if(sea .and. (varch_sea(j)>zero)) tnoise(jc)=varch_sea(j) - if(land .and. (varch_land(j)>zero)) tnoise(jc)=varch_land(j) - if(ice .and. (varch_ice(j)>zero)) tnoise(jc)=varch_ice(j) - if(snow .and. (varch_snow(j)>zero)) tnoise(jc)=varch_snow(j) - if(mixed .and. (varch_mixed(j)>zero)) tnoise(jc)=varch_mixed(j) - tnoise_save = tnoise(jc) - - channel_passive=iuse_rad(j)==-1 .or. iuse_rad(j)==0 - if (iuse_rad(j)< -1 .or. (channel_passive .and. & - .not.rad_diagsave)) tnoise(jc)=r1e10 - if (passive_bc .and. channel_passive) tnoise(jc)=tnoise_save - if (tnoise(jc) < 1.e4_r_kind) toss = .false. - end do - ! Count data of different surface types if(luse(n))then if (mixed) then @@ -886,9 +866,30 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif endif + do jc=1,nchanl + j=ich(jc) + + tnoise(jc)=varch(j) + + if(mixed .and. (varch_mixed(j)>zero)) then + tnoise(jc)=varch_mixed(j) + else if(snow .and. (varch_snow(j)>zero)) then + tnoise(jc)=varch_snow(j) + else if(ice .and. (varch_ice(j)>zero)) then + tnoise(jc)=varch_ice(j) + else if(land .and. (varch_land(j)>zero)) then + tnoise(jc)=varch_land(j) + else if(sea .and. (varch_sea(j)>zero)) then + tnoise(jc)=varch_sea(j) + end if + + if (.not. (passive_bc .and. channel_passive(j))) then + if (iuse_rad(j)< -1 .or. (channel_passive(j) .and. & + .not.rad_diagsave)) tnoise(jc)=r1e10 + end if + ! Load channel data into work array. - do i = 1,nchanl - tb_obs(i) = data_s(i+nreal,n) + tb_obs(jc) = data_s(jc+nreal,n) end do @@ -996,29 +997,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& tsavg5=tsavg5+dtsavg endif -! If using adaptive angle dependent bias correction, update the predicctors -! for this part of bias correction. The AMSUA cloud liquid water algorithm -! uses total angle dependent bias correction for channels 1 and 2 - if (adp_anglebc) then - do i=1,nchanl - mm=ich(i) - if (goessndr .or. goes_img .or. ahi .or. seviri .or. ssmi .or. ssmis .or. gmi .or. abi) then - pred(npred,i)=nadir*deg2rad - else - pred(npred,i)=data_s(iscan_ang,n) - end if - do j=2,angord - pred(npred-j+1,i)=pred(npred,i)**j - end do - cbias(nadir,mm)=zero - if (iuse_rad(mm)/=4) then - do j=1,angord - cbias(nadir,mm)=cbias(nadir,mm)+predchan(npred-j+1,i)*pred(npred-j+1,i) - end do - end if - end do - end if - ! Compute microwave cloud liquid water or graupel water path for bias correction and QC. clw_obs=zero clw_guess_retrieval=zero @@ -1056,10 +1034,8 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& id_qc(1:nchanl) = ifail_cloud_qc endif endif - endif ! Screening for cold-air outbreak area (only applied to MW for now) - if (cao_check .and. radmod%lprecip) then - if(microwave .and. sea) then + if (cao_check .and. radmod%lprecip) then if(radmod%lcloud_fwd) then cao_flag = (stability < 12.0_r_kind) .and. (hwp_ratio < half) .and. (tcwv < 8.0_r_kind) if (cao_flag) then ! remove all tropospheric channels @@ -1083,10 +1059,28 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif predbias=zero - cld_rbc_idx2=zero +!$omp parallel do schedule(dynamic,1) private(i,mm,j,k,tlap,node,bias) do i=1,nchanl mm=ich(i) - +! If using adaptive angle dependent bias correction, update the predicctors +! for this part of bias correction. The AMSUA cloud liquid water algorithm +! uses total angle dependent bias correction for channels 1 and 2 + if (adp_anglebc) then + if (goessndr .or. goes_img .or. ahi .or. seviri .or. ssmi .or. ssmis .or. gmi .or. abi) then + pred(npred,i)=nadir*deg2rad + else + pred(npred,i)=data_s(iscan_ang,n) + end if + do j=2,angord + pred(npred-j+1,i)=pred(npred,i)**j + end do + cbias(nadir,mm)=zero + if (iuse_rad(mm)/=4) then + do j=1,angord + cbias(nadir,mm)=cbias(nadir,mm)+predchan(npred-j+1,i)*pred(npred-j+1,i) + end do + end if + end if !***** ! COMPUTE AND APPLY BIAS CORRECTION TO SIMULATED VALUES @@ -1115,28 +1109,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& end if if(radmod%lcloud_fwd .and. sea) pred(3,i ) = zero - - - ! Apply bias correction - - kmax(i) = 0 - if (lwrite_peakwt .or. passive_bc) then - ptau5derivmax = -9.9e31_r_kind -! maximum of weighting function is level at which transmittance -! (ptau5) is changing the fastest. This is used for the level -! assignment (needed for vertical localization). - weightmax(i) = zero - do k=2,nsig - ptau5deriv = abs( (ptau5(k-1,i)-ptau5(k,i))/ & - (log(prsltmp(k-1))-log(prsltmp(k))) ) - if (ptau5deriv > ptau5derivmax) then - ptau5derivmax = ptau5deriv - kmax(i) = k - weightmax(i) = r10*prsitmp(k) ! cb to mb. - end if - enddo - end if tlapchn(i)= (ptau5(2,i)-ptau5(1,i))*(tsavg5-tvp(2)) do k=2,nsig-1 @@ -1234,15 +1207,37 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& bias = bias+predbias(npred+2,i) cldeff_obs(i)=cldeff_obs(i) - bias ! observed cloud delta (bias corrected) endif + end do + kmax = 0 + if (lwrite_peakwt .or. passive_bc) then +!$omp parallel do schedule(dynamic,1) private(i,k,ptau5derivmax,ptau5deriv) + do i=1,nchanl + ptau5derivmax = -9.9e31_r_kind +! maximum of weighting function is level at which transmittance +! (ptau5) is changing the fastest. This is used for the level +! assignment (needed for vertical localization). + weightmax(i) = zero + do k=2,nsig + ptau5deriv = abs( (ptau5(k-1,i)-ptau5(k,i))/ & + (log(prsltmp(k-1))-log(prsltmp(k))) ) + if (ptau5deriv > ptau5derivmax) then + ptau5derivmax = ptau5deriv + kmax(i) = k + weightmax(i) = r10*prsitmp(k) ! cb to mb. + end if + enddo ! End of loop over channels - end do + end do + end if ! Compute retrieved microwave cloud liquid water and ! assign cld_rbc_idx for bias correction in allsky conditions cld_rbc_idx=one + cld_rbc_idx2=zero if (radmod%lcloud_fwd .and. radmod%ex_biascor .and. eff_area) then ierrret=0 +!$omp parallel do schedule(dynamic,1) private(i,mm,j) do i=1,nchanl mm=ich(i) tsim_bc(i)=tsim(i) @@ -1258,19 +1253,19 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& tsim_clr_bc(i)=tsim_clr_bc(i)+predbias(npred+2,i) end do - if(amsua.or.atms) call ret_amsua(tsim_bc,nchanl,tsavg5,zasat,clw_guess_retrieval,ierrret) - if(gmi) then - call gmi_37pol_diff(tsim_bc(6),tsim_bc(7),tsim_clr_bc(6),tsim_clr_bc(7),clw_guess_retrieval,ierrret) - call gmi_37pol_diff(tb_obs(6),tb_obs(7),tsim_clr_bc(6),tsim_clr_bc(7),clw_obs,ierrret) + if(amsua.or.atms) then + call ret_amsua(tsim_bc,nchanl,tsavg5,zasat,clw_guess_retrieval,ierrret) + else if(gmi) then + call gmi_37pol_diff(tsim_bc(6),tsim_bc(7),tsim_clr_bc(6),tsim_clr_bc(7),clw_guess_retrieval,ierrret) + call gmi_37pol_diff(tb_obs(6),tb_obs(7),tsim_clr_bc(6),tsim_clr_bc(7),clw_obs,ierrret) end if if (radmod%ex_obserr=='ex_obserr1') then call radiance_ex_biascor(radmod,nchanl,tsim_bc,tsavg5,zasat, & clw_guess_retrieval,clw_obs,cld_rbc_idx,ierrret) - end if -! if (radmod%ex_obserr=='ex_obserr2') then ! comment out for now, need to be tested +! else if (radmod%ex_obserr=='ex_obserr2') then ! comment out for now, need to be tested ! call radiance_ex_biascor(radmod,nchanl,cldeff_obs,cldeff_fg,cld_rbc_idx) ! end if - if (radmod%ex_obserr=='ex_obserr3') then + else if (radmod%ex_obserr=='ex_obserr3') then call radiance_ex_biascor_gmi(radmod,clw_obs,clw_guess_retrieval,nchanl,cld_rbc_idx) end if @@ -1323,17 +1318,17 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! Assign observation error for all-sky radiances if (radmod%lcloud_fwd .and. eff_area) then - if (radmod%ex_obserr=='ex_obserr1') & + if (radmod%ex_obserr=='ex_obserr1') then call radiance_ex_obserr(radmod,nchanl,clw_obs,clw_guess_retrieval,tnoise,tnoise_cld,error0) - if (radmod%ex_obserr=='ex_obserr3') & + else if (radmod%ex_obserr=='ex_obserr3') then call radiance_ex_obserr_gmi(radmod,nchanl,clw_obs,clw_guess_retrieval,tnoise,tnoise_cld,error0) + end if end if do i=1,nchanl mm=ich(i) - channel_passive=iuse_rad(ich(i))==-1 .or. iuse_rad(ich(i))==0 - if(tnoise(i) < 1.e4_r_kind .or. (channel_passive .and. rad_diagsave) & - .or. (passive_bc .and. channel_passive))then + if(tnoise(i) < 1.e4_r_kind .or. (channel_passive(mm) .and. rad_diagsave) & + .or. (passive_bc .and. channel_passive(mm)))then varinv(i) = varinv(i)/error0(i)**2 errf(i) = error0(i) else @@ -1365,14 +1360,10 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& do i=1,nchanl m=ich(i) - if (varinv(i) < tiny_r_kind) then - varinv_use(i) = zero + if (icld_det(m)>0 .and. varinv(i) >= tiny_r_kind) then + varinv_use(i) = varinv(i) else - if ((icld_det(m)>0)) then - varinv_use(i) = varinv(i) - else - varinv_use(i) = zero - end if + varinv_use(i) = zero end if end do call qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse(n),goessndr, & @@ -1464,14 +1455,10 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& else if (seviri .or. abi .or. ahi) then do i=1,nchanl m=ich(i) - if (varinv(i) < tiny_r_kind) then - varinv_use(i) = zero + if (icld_det(m)>0 .and. varinv(i) >= tiny_r_kind) then + varinv_use(i) = varinv(i) else - if ((icld_det(m)>0)) then - varinv_use(i) = varinv(i) - else - varinv_use(i) = zero - end if + varinv_use(i) = zero end if end do @@ -1490,9 +1477,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& do i=1,nchanl if((abi .or. ahi) .and. i/=2 .and. i/=3) then varinv(i)=zero - varinv_use(i)=zero - end if - if(seviri .and. i/=2) then + else if(seviri .and. i/=2) then varinv(i)=zero end if end do @@ -1500,15 +1485,15 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! ! additional qc for surface and chn7.3: use split window chns to remove opaque clouds - do i = 1,nchanl - if( (abi .or. ahi ).and. i/=2 .and. i/=3 ) then - if( varinv(i) > tiny_r_kind .and. & - (tb_obs(7)-tb_obs(8))-(tsim(7)-tsim(8)) <= -0.75_r_kind) then - varinv(i)=zero - varinv_use(i)=zero - end if - end if - end do + if(abi .or. ahi) then + do i = 1,nchanl + if( i/=2 .and. i/=3 .and.varinv(i) > tiny_r_kind) then + if((tb_obs(7)-tb_obs(8))-(tsim(7)-tsim(8)) <= -0.75_r_kind) then + varinv(i)=zero + end if + end if + end do + end if ! ! ---------- AVRHRR -------------- @@ -1526,14 +1511,10 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! channels with iuse_rad=-1 or 0 are used in cloud detection. do i=1,nchanl m=ich(i) - if (varinv(i) < tiny_r_kind) then - varinv_use(i) = zero + if (icld_det(m)>0 .and. varinv(i) >= tiny_r_kind) then + varinv_use(i) = varinv(i) else - if ((icld_det(m)>0)) then - varinv_use(i) = varinv(i) - else - varinv_use(i) = zero - end if + varinv_use(i) = zero end if end do @@ -1549,14 +1530,10 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! NOTE: use qc_avhrr for viirs qc do i=1,nchanl m=ich(i) - if (varinv(i) < tiny_r_kind) then - varinv_use(i) = zero + if (icld_det(m)>0 .and. varinv(i) >= tiny_r_kind) then + varinv_use(i) = varinv(i) else - if ((icld_det(m)>0)) then - varinv_use(i) = varinv(i) - else - varinv_use(i) = zero - end if + varinv_use(i) = zero end if end do @@ -1570,7 +1547,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& else if( ssmi .or. amsre .or. ssmis )then - frac_sea=data_s(ifrac_sea,n) if(amsre)then bearaz= (270._r_kind-data_s(ilazi_ang,n))*deg2rad sun_zenith=data_s(iszen_ang,n)*deg2rad @@ -1675,20 +1651,29 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& end do if(amsua .or. atms .or. amsub .or. mhs .or. msu .or. hsb)then - if(amsua)nlev=6 - if(atms)nlev=7 - if(amsub .or. mhs)nlev=5 - if(hsb)nlev=4 - if(msu)nlev=4 + if(amsua)then + nlev=6 + else if(atms)then + nlev=7 + else if(amsub .or. mhs)then + nlev=5 + else if(hsb)then + nlev=4 + else if(msu)then + nlev=4 + end if kval=0 do i=2,nlev ! do i=1,nlev - channel_passive=iuse_rad(ich(i))==-1 .or. iuse_rad(ich(i))==0 - if (varinv(i)=1) .or. & - (passive_bc .and. channel_passive))) then + mm=ich(i) + if (varinv(i)=1) .or. & + (passive_bc .and. channel_passive(mm)))) then kval=max(i-1,kval) - if(amsub .or. hsb .or. mhs)kval=nlev - if((amsua .or. atms) .and. i <= 3)kval = zero + if(amsub .or. hsb .or. mhs)then + kval=nlev + else if((amsua .or. atms) .and. i <= 3) then + kval = zero + end if end if end do if(kval > 0)then @@ -1699,60 +1684,55 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& if(amsua)then varinv(15)=zero if(id_qc(15) == igood_qc)id_qc(15)=ifail_interchan_qc - end if - if (atms) then + else if (atms) then varinv(16:18)=zero if(id_qc(16) == igood_qc)id_qc(16)=ifail_interchan_qc if(id_qc(17) == igood_qc)id_qc(17)=ifail_interchan_qc if(id_qc(18) == igood_qc)id_qc(18)=ifail_interchan_qc end if end if - end if - if(mhs.or.amsub)then - do i = 1, nchanl - m = ich(i) - if(sea .and. isst_det(m) >0 .and. tsavg5 < 278.0_r_kind) then - varinv(i) = zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_isst_det - endif - - if(sea .and. iwndspeed_det(m)>0 .and. tsavg5 < 285.0_r_kind .and. sfc_speed > 10.0_r_kind) then - varinv(i) = zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_iwndspeed_det - endif - if(iomg_det(m) > 0 .and. abs(tbcnob(2)) > 5.0_r_kind) then - varinv(i) = zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_iomg_det - endif - - if(itopo_det(m) > 0 .and. zsges > 1000.0_r_kind ) then - varinv(i) = zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_itopo_det - endif - enddo + if(mhs.or.amsub)then + do i = 1, nchanl + m = ich(i) + if(sea)then + if(isst_det(m) >0 .and. tsavg5 < 278.0_r_kind) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_isst_det + + else if(iwndspeed_det(m)>0 .and. tsavg5 < 285.0_r_kind .and. sfc_speed > 10.0_r_kind) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_iwndspeed_det + endif + end if + if(iomg_det(m) > 0 .and. abs(tbcnob(2)) > 5.0_r_kind) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_iomg_det + + else if(itopo_det(m) > 0 .and. zsges > 1000.0_r_kind ) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_itopo_det + endif + enddo + endif endif ! Screen out land surface types by channel. Flags are set in satinfo file. do i = 1, nchanl m = ich(i) - if(iwater_det(m) > 0 .and. sea) then + if(sea .and. iwater_det(m) > 0) then varinv(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_iwater_det - endif - if(isnow_det(m) > 0 .and. snow) then + else if(snow .and. isnow_det(m) > 0 ) then varinv(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_isnow_det - endif - if(mixed .and. imix_det(m) > 0) then + else if(mixed .and. imix_det(m) > 0) then varinv(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_imix_det - endif - if(land .and. iland_det(m) > 0) then + else if(land .and. iland_det(m) > 0) then varinv(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_iland_det - endif - if(ice .and. iice_det(m) > 0) then + else if(ice .and. iice_det(m) > 0) then varinv(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_iice_det endif @@ -1767,39 +1747,36 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif endif - do i = 1,nchanl - ! Reject radiances for single radiance test - if (lsingleradob) then + if (lsingleradob) then + do i = 1,nchanl + ! if the channels are beyond 0.01 of oblat/oblon, specified ! in gsi namelist, or aren't of type 'oneob_type', reject if ( (abs(cenlat - oblat) > one/r100 .or. & abs(cenlon - oblon) > one/r100) .or. & obstype /= oneob_type ) then varinv(i) = zero - varinv_use(i) = zero if (id_qc(i) == igood_qc) id_qc(i) = ifail_outside_range else ! if obchan <= zero, keep all footprints, if obchan > zero, ! keep only that which has channel obchan if (i /= obchan .and. obchan > zero) then varinv(i) = zero - varinv_use(i) = zero if (id_qc(i) == igood_qc) id_qc(i) = ifail_outside_range endif endif !cenlat/lon - endif !lsingleradob - enddo + enddo + endif !lsingleradob diagadd=zero account_for_corr_obs = .false. - iii=0 varinv0=zero +!$omp parallel do schedule(dynamic,1) private(ii,m,k,asum) do ii=1,nchanl m=ich(ii) if (varinv(ii)>tiny_r_kind .and. iuse_rad(m)>=1) then - iii=iii+1 varinv0(ii)=varinv(ii) raterr2(ii)=error0(ii)**2*varinv0(ii) if (l_may_be_passive .and. .not. retrieval) then @@ -1813,6 +1790,13 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& end if end if enddo + iii=0 + do ii=1,nchanl + m=ich(ii) + if (varinv(ii)>tiny_r_kind .and. iuse_rad(m)>=1) then + iii=iii+1 + end if + end do err2 = one/error0**2 tbc0=tbc tb_obs0=tb_obs @@ -1843,18 +1827,14 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& m = ich(i) if(luse(n))then - drad = tbc0(i) - dradnob = tbcnob(i) + drad = tbc0(i)*cld_rbc_idx(i) + dradnob = tbcnob(i)*cld_rbc_idx(i) varrad = tbc(i)*varinv(i) stats(1,m) = stats(1,m) + one !number of obs -! stats(3,m) = stats(3,m) + drad !obs-mod(w_biascor) -! stats(4,m) = stats(4,m) + tbc0(i)*drad !(obs-mod(w_biascor))**2 -! stats(5,m) = stats(5,m) + tbc(i)*varrad !penalty contribution -! stats(6,m) = stats(6,m) + dradnob !obs-mod(w/o_biascor) - stats(3,m) = stats(3,m) + drad*cld_rbc_idx(i) !obs-mod(w_biascor) - stats(4,m) = stats(4,m) + tbc0(i)*drad*cld_rbc_idx(i)!(obs-mod(w_biascor))**2 + stats(3,m) = stats(3,m) + drad !obs-mod(w_biascor) + stats(4,m) = stats(4,m) + tbc0(i)*drad !(obs-mod(w_biascor))**2 stats(5,m) = stats(5,m) + tbc(i)*varrad !penalty contribution - stats(6,m) = stats(6,m) + dradnob*cld_rbc_idx(i) !obs-mod(w/o_biascor) + stats(6,m) = stats(6,m) + dradnob !obs-mod(w/o_biascor) if (account_for_corr_obs .and. (cor_opt ==1 .or. cor_opt ==2) ) then exp_arg = -half*tbc(i)**2 @@ -1888,7 +1868,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! summation of observation number if (newpc4pred) then - ostats(m) = ostats(m) + one*cld_rbc_idx(i) + ostats(m) = ostats(m) + cld_rbc_idx(i) end if end if @@ -1899,12 +1879,11 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! At the end of analysis, prepare for bias correction for monitored channels ! Only "good monitoring" obs are included in J_passive calculation. - channel_passive=iuse_rad(m)==-1 .or. iuse_rad(m)==0 - if (passive_bc .and. (jiter>miter) .and. channel_passive) then + if (passive_bc .and. (jiter>miter) .and. channel_passive(m)) then ! summation of observation number, ! skip ostats accumulation for channels without coef. initialization if (newpc4pred .and. luse(n) .and. any(predx(:,m)/=zero)) then - ostats(m) = ostats(m) + one*cld_rbc_idx(i) + ostats(m) = ostats(m) + cld_rbc_idx(i) end if iccm=iccm+1 end if @@ -1950,7 +1929,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& my_head%raterr2(icc),my_head%pred(npred,icc), & my_head%dtb_dvar(nsigradjac,icc), & my_head%ich(icc),& - my_head%icx(icc)) + my_head%icx(icc),my_head%iccerr(icc)) if(luse_obsdiag)allocate(my_head%diags(icc)) call get_ij(mm1,slats,slons,my_head%ij,my_head%wij) @@ -2018,6 +1997,13 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& end if ! end of newpc4pred loop end if end do + ncr=0 + do ii=1,iii + my_head%iccerr(ii) = ncr + do mm=1,ii + ncr=ncr+1 + end do + end do my_head%nchan = iii ! profile observation count my_head%use_corr_obs=.false. @@ -2112,23 +2098,28 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& allocate(my_headm%res(iccm),my_headm%err2(iccm), & my_headm%raterr2(iccm),my_headm%pred(npred,iccm), & my_headm%ich(iccm), & - my_headm%icx(iccm)) + my_headm%icx(iccm),my_headm%iccerr(iccm)) my_headm%nchan = iccm ! profile observation count my_headm%time=dtime my_headm%luse=luse(n) my_headm%ich(:)=-1 iii=0 + ncr=0 do ii=1,nchanl m=ich(ii) - channel_passive=iuse_rad(m)==-1 .or. iuse_rad(m)==0 - if (varinv(ii)>tiny_r_kind .and. channel_passive) then + if (varinv(ii)>tiny_r_kind .and. channel_passive(m)) then iii=iii+1 my_headm%res(iii)=tbc(ii) ! obs-ges innovation my_headm%err2(iii)=one/error0(ii)**2 ! 1/(obs error)**2 (original uninflated error) my_headm%raterr2(iii)=error0(ii)**2*varinv(ii) ! (original error)/(inflated error) my_headm%icx(iii)=m ! channel index + do mm=1,ii + ncr=ncr+1 + end do + + my_headm%iccerr(iii)=ncr ! channel index do k=1,npred my_headm%pred(k,iii)=pred(k,ii)*upd_pred(k)*max(cld_rbc_idx(ii),cld_rbc_idx2(ii)) end do diff --git a/src/gsi/state_vectors.f90 b/src/gsi/state_vectors.f90 index 711043fa57..ffad280bf5 100644 --- a/src/gsi/state_vectors.f90 +++ b/src/gsi/state_vectors.f90 @@ -62,7 +62,7 @@ module state_vectors use GSI_BundleMod, only : GSI_GridCreate use mpeu_util, only: gettablesize -use mpeu_util, only: gettable +use mpeu_util, only: gettable,getindex implicit none @@ -83,6 +83,8 @@ module state_vectors public svars public levels public ns2d,ns3d,nsdim + public qgpresent,qspresent,qrpresent,qipresent,qlpresent + public cldchpresent,lcbaspresent,howvpresent,wspd10mpresent,pblhpresent,vispresent,gustpresent ! State vector definition ! Could contain model state fields plus other fields required @@ -101,6 +103,8 @@ module state_vectors character(len=max_varname_length),allocatable,dimension(:) :: svars2d integer(i_kind) ,allocatable,dimension(:) :: levels +logical qgpresent,qspresent,qrpresent,qipresent,qlpresent +logical cldchpresent,lcbaspresent,howvpresent,wspd10mpresent,pblhpresent,vispresent,gustpresent ! ---------------------------------------------------------------------- INTERFACE PRT_STATE_NORMS @@ -245,6 +249,18 @@ subroutine init_anasv write(6,*) myname_,': 3D-STATE VARIABLES ', svars3d write(6,*) myname_,': ALL STATE VARIABLES ', svars end if +qgpresent=getindex(svars3d,'qg')>0 +qspresent=getindex(svars3d,'qs')>0 +qrpresent=getindex(svars3d,'qr')>0 +qipresent=getindex(svars3d,'qi')>0 +qlpresent=getindex(svars3d,'ql')>0 +cldchpresent=getindex(svars2d,'cldch')>0 +lcbaspresent=getindex(svars2d,'lcbas')>0 +howvpresent=getindex(svars2d,'howv')>0 +wspd10mpresent=getindex(svars2d,'wspd10m')>0 +pblhpresent=getindex(svars2d,'pblh')>0 +vispresent=getindex(svars2d,'vis')>0 +gustpresent=getindex(svars2d,'gust')>0 end subroutine init_anasv subroutine final_anasv @@ -383,59 +399,32 @@ subroutine norms_vars(xst,pmin,pmax,psum,pnum) zloc=zero ! Independent part of vector -! Sum - ii=0 +! Sum,Max,Min and number of points +!$omp parallel do schedule(dynamic,1) !private(i) do i = 1,ns3d - ii=ii+1 if(xst%r3(i)%mykind==r_single)then - zloc(ii)= sum_mask(xst%r3(i)%qr4,ihalo=1) + zloc(i)= sum_mask(xst%r3(i)%qr4,ihalo=1) + zloc(nvars+i)= minval(xst%r3(i)%qr4) + zloc(2*nvars+i)= maxval(xst%r3(i)%qr4) else - zloc(ii)= sum_mask(xst%r3(i)%q,ihalo=1) + zloc(i)= sum_mask(xst%r3(i)%q,ihalo=1) + zloc(nvars+i)= minval(xst%r3(i)%q) + zloc(2*nvars+i)= maxval(xst%r3(i)%q) endif - nloc(ii) = real((lat2-2)*(lon2-2)*levels(i), r_kind) ! dim of 3d fields + nloc(i) = real((lat2-2)*(lon2-2)*levels(i), r_kind) ! dim of 3d fields enddo +!$omp parallel do schedule(dynamic,1) !private(i) do i = 1,ns2d - ii=ii+1 if(xst%r2(i)%mykind==r_single)then - zloc(ii)= sum_mask(xst%r2(i)%qr4,ihalo=1) + zloc(ns3d+i)= sum_mask(xst%r2(i)%qr4,ihalo=1) + zloc(nvars+ns3d+i)= minval(xst%r2(i)%qr4) + zloc(2*nvars+ns3d+i)= maxval(xst%r2(i)%qr4) else - zloc(ii)= sum_mask(xst%r2(i)%q,ihalo=1) - endif - nloc(ii) = real((lat2-2)*(lon2-2), r_kind) ! dim of 2d fields - enddo -! Min - do i = 1,ns3d - ii=ii+1 - if(xst%r3(i)%mykind==r_single)then - zloc(ii)= minval(xst%r3(i)%qr4) - else - zloc(ii)= minval(xst%r3(i)%q) - endif - enddo - do i = 1,ns2d - ii=ii+1 - if(xst%r2(i)%mykind==r_single)then - zloc(ii)= minval(xst%r2(i)%qr4) - else - zloc(ii)= minval(xst%r2(i)%q) - endif - enddo -! Max - do i = 1,ns3d - ii=ii+1 - if(xst%r3(i)%mykind==r_single)then - zloc(ii)= maxval(xst%r3(i)%qr4) - else - zloc(ii)= maxval(xst%r3(i)%q) - endif - enddo - do i = 1,ns2d - ii=ii+1 - if(xst%r2(i)%mykind==r_single)then - zloc(ii)= maxval(xst%r2(i)%qr4) - else - zloc(ii)= maxval(xst%r2(i)%q) + zloc(ns3d+i)= sum_mask(xst%r2(i)%q,ihalo=1) + zloc(nvars+ns3d+i)= minval(xst%r2(i)%q) + zloc(2*nvars+ns3d+i)= maxval(xst%r2(i)%q) endif + nloc(ns3d+i) = real((lat2-2)*(lon2-2), r_kind) ! dim of 2d fields enddo ! Gather contributions @@ -444,20 +433,12 @@ subroutine norms_vars(xst,pmin,pmax,psum,pnum) call mpi_allgather(nloc,size(nloc),mpi_rtype, & & nall,size(nloc),mpi_rtype, mpi_comm_world,ierror) - ii=0 - do i=1,ns3d - ii=ii+1 - psum(ii)=SUM(zall(ii,:)) - pnum(ii)=SUM(nall(ii,:)) - enddo - do i=1,ns2d - ii=ii+1 - psum(ii)=SUM(zall(ii,:)) - pnum(ii)=SUM(nall(ii,:)) - enddo - do ii=1,nvars - pmin(ii)=MINVAL(zall( nvars+ii,:)) - pmax(ii)=MAXVAL(zall(2*nvars+ii,:)) +!$omp parallel do schedule(dynamic,1) !private(i) + do i=1,nvars + psum(i)=SUM(zall(i,:)) + pnum(i)=SUM(nall(i,:)) + pmin(i)=MINVAL(zall( nvars+i,:)) + pmax(i)=MAXVAL(zall(2*nvars+i,:)) enddo ! Release work space diff --git a/src/gsi/statsconv.f90 b/src/gsi/statsconv.f90 index 7ddb7dea04..a01675d8d0 100644 --- a/src/gsi/statsconv.f90 +++ b/src/gsi/statsconv.f90 @@ -154,20 +154,6 @@ subroutine statsconv(mype,& ! Summary report for winds if(mype==mype_uv) then -! Open output file so as to point to correct position in output file - if(first)then - open(iout_uv) - else - open(iout_uv,position='append') - end if - - -! Compute and write counts, penalties, and ratio of penalty -! to data counts for each model level - numssm=nint(awork(6,i_uv)); numgross=nint(awork(4,i_uv)) - umplty=zero; vmplty=zero; uvqcplty=zero ; ntot=0; - tu=zero; tv=zero ; tuv=zero - tssm=zero ; qctssm=zero nread=0 nkeep=0 nreadspd=0 @@ -181,85 +167,92 @@ subroutine statsconv(mype,& nkeepspd=nkeepspd+ndata(i,3) end if end do - if(nkeep > 0 .or. nkeepspd > 0)then -! Write header information - mesage='current vfit of wind data, ranges in m/s$' + if(nread > 0 .or. nreadspd > 0)then +! Open output file so as to point to correct position in output file + if(first)then + open(iout_uv) + else + open(iout_uv,position='append') + end if -! Call routine to compute and write count, rms, and penalty information - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'spd' .or. trim(ioctype(j)) == 'uv' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_uv,pflag) - numlow = nint(awork(2,i_uv)) - numhgh = nint(awork(3,i_uv)) - write(iout_uv,900) 'wind',numhgh,numlow - numfailqc=nint(awork(21,i_uv)) -! keep a seperate record of numfailqc for ssmi wind speeds - numfailqc_ssmi=nint(awork(61,i_uv)) - do k=1,nsig - num(k)=nint(awork(6*nsig+k+100,i_uv)) - rat1=zero - rat2=zero - if(num(k) > 0)then - rat1=awork(4*nsig+k+100,i_uv)/float(num(k)) - rat2=awork(5*nsig+k+100,i_uv)/float(num(k)) + +! Compute and write counts, penalties, and ratio of penalty +! to data counts for each model level + numssm=nint(awork(6,i_uv)); numgross=nint(awork(4,i_uv)) + umplty=zero; vmplty=zero; uvqcplty=zero ; ntot=0; + tu=zero; tv=zero ; tuv=zero + tssm=zero ; qctssm=zero + if(nkeep > 0 .or. nkeepspd > 0)then +! Write header information + mesage='current vfit of wind data, ranges in m/s$' + +! Call routine to compute and write count, rms, and penalty information + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'spd' .or. trim(ioctype(j)) == 'uv' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_uv,pflag) + numlow = nint(awork(2,i_uv)) + numhgh = nint(awork(3,i_uv)) + write(iout_uv,900) 'wind',numhgh,numlow + numfailqc=nint(awork(21,i_uv)) +! keep a seperate record of numfailqc for ssmi wind speeds + numfailqc_ssmi=nint(awork(61,i_uv)) + do k=1,nsig + num(k)=nint(awork(6*nsig+k+100,i_uv)) + rat1=zero + rat2=zero + if(num(k) > 0)then + rat1=awork(4*nsig+k+100,i_uv)/float(num(k)) + rat2=awork(5*nsig+k+100,i_uv)/float(num(k)) + end if + umplty=umplty+awork(4*nsig+k+100,i_uv) + vmplty=vmplty+awork(5*nsig+k+100,i_uv) + ntot=ntot+num(k) + write(iout_uv,241) 'w',num(k),k,awork(4*nsig+k+100,i_uv),& + awork(5*nsig+k+100,i_uv),rat1,rat2 + end do + do k=1,nsig + num(k)=nint(awork(6*nsig+k+100,i_uv)) + rat1=zero + rat3=zero + if(num(k) > 0)then + rat1=(awork(4*nsig+k+100,i_uv)+awork(5*nsig+k+100,i_uv))/float(num(k)) + rat3=awork(3*nsig+k+100,i_uv)/float(num(k)) + end if + uvqcplty=uvqcplty+awork(3*nsig+k+100,i_uv) + write(iout_uv,240) 'w',num(k),k,awork(4*nsig+k+100,i_uv)+awork(5*nsig+k+100,i_uv), & + awork(3*nsig+k+100,i_uv),rat1,rat3 + end do + +! Write statistics gross checks + write(iout_uv,920)' number ssm/i winds that fail nonlinear qc =',numfailqc_ssmi + write(iout_uv,925) 'wind',numgross,numfailqc +! Write statistics regarding penalties + if(ntot > 0)then + tu=umplty/float(ntot) + tv=vmplty/float(ntot) + tuv=uvqcplty/float(ntot) end if - umplty=umplty+awork(4*nsig+k+100,i_uv) - vmplty=vmplty+awork(5*nsig+k+100,i_uv) - ntot=ntot+num(k) - write(iout_uv,241) 'w',num(k),k,awork(4*nsig+k+100,i_uv),& - awork(5*nsig+k+100,i_uv),rat1,rat2 - end do - do k=1,nsig - num(k)=nint(awork(6*nsig+k+100,i_uv)) - rat1=zero - rat3=zero - if(num(k) > 0)then - rat1=(awork(4*nsig+k+100,i_uv)+awork(5*nsig+k+100,i_uv))/float(num(k)) - rat3=awork(3*nsig+k+100,i_uv)/float(num(k)) + if(numssm > 0)then + tssm=awork(5,i_uv)/awork(6,i_uv) + qctssm=awork(22,i_uv)/awork(6,i_uv) end if - uvqcplty=uvqcplty+awork(3*nsig+k+100,i_uv) - write(iout_uv,240) 'w',num(k),k,awork(4*nsig+k+100,i_uv)+awork(5*nsig+k+100,i_uv), & - awork(3*nsig+k+100,i_uv),rat1,rat3 - end do - -! Write statistics gross checks - write(iout_uv,920)' number ssm/i winds that fail nonlinear qc =',numfailqc_ssmi - write(iout_uv,925) 'wind',numgross,numfailqc -! Write statistics regarding penalties - if(ntot > 0)then - tu=umplty/float(ntot) - tv=vmplty/float(ntot) - tuv=uvqcplty/float(ntot) end if - if(numssm > 0)then - tssm=awork(5,i_uv)/awork(6,i_uv) - qctssm=awork(22,i_uv)/awork(6,i_uv) - end if - end if - write(iout_uv,949) 'u',ntot,umplty,tu - write(iout_uv,949) 'v',ntot,vmplty,tv - write(iout_uv,950) 'uv',jiter,nread,nkeep,ntot*2 - write(iout_uv,951) 'uv',umplty+vmplty,uvqcplty,tu+tv,tuv - write(iout_uv,950) 'spd',jiter,nreadspd,nkeepspd,numssm - write(iout_uv,951) 'spd',awork(5,i_uv),awork(22,i_uv),tssm,qctssm + write(iout_uv,949) 'u',ntot,umplty,tu + write(iout_uv,949) 'v',ntot,vmplty,tv + write(iout_uv,950) 'uv',jiter,nread,nkeep,ntot*2 + write(iout_uv,951) 'uv',umplty+vmplty,uvqcplty,tu+tv,tuv + write(iout_uv,950) 'spd',jiter,nreadspd,nkeepspd,numssm + write(iout_uv,951) 'spd',awork(5,i_uv),awork(22,i_uv),tssm,qctssm ! Close unit receiving summary output - close(iout_uv) + close(iout_uv) + end if end if ! Summary report for gps if (mype==mype_gps)then - if(first)then - open(iout_gps) - else - open(iout_gps,position='append') - end if - - - gpsmplty=zero; gpsqcplty=zero ; ntot=0 - tgps=zero ; qctgps=zero nread=0 nkeep=0 ctype=' ' @@ -270,67 +263,64 @@ subroutine statsconv(mype,& ctype=dtype(i) end if end do - if(nkeep > 0)then - mesage='current fit of gps data in fractional difference$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'gps' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_gps,pflag) - do k=1,nsig - num(k)=nint(awork(5*nsig+k+100,i_gps)) - rat=zero - rat3=zero - if(num(k)>0) then - rat=awork(6*nsig+k+100,i_gps)/float(num(k)) - rat3=awork(3*nsig+k+100,i_gps)/float(num(k)) - end if - ntot=ntot+num(k); gpsmplty=gpsmplty+awork(6*nsig+k+100,i_gps) - gpsqcplty=gpsqcplty+awork(3*nsig+k+100,i_gps) - write(iout_gps,240)'gps',num(k),k,awork(6*nsig+k+100,i_gps), & - awork(3*nsig+k+100,i_gps),rat,rat3 - end do - numgross=nint(awork(4,i_gps)) - numfailqc=nint(awork(21,i_gps)) - numfail1_gps=nint(awork(22,i_gps)) - numfail2_gps=nint(awork(23,i_gps)) - numfail3_gps=nint(awork(24,i_gps)) - write(iout_gps,925)'gps',numgross,numfailqc - write(iout_gps,920)' number of gps obs failed stats qc in NH =',numfail1_gps - write(iout_gps,920)' number of gps obs failed stats qc in SH =',numfail2_gps - write(iout_gps,920)' number of gps obs failed stats qc in TR =',numfail3_gps - - numlow = nint(awork(2,i_gps)) - numhgh = nint(awork(3,i_gps)) - write(iout_gps,900) 'gps',numhgh,numlow - if(ntot > 0) then - tgps=gpsmplty/ntot - qctgps=gpsqcplty/ntot - endif - end if + if(nread > 0)then + if(first)then + open(iout_gps) + else + open(iout_gps,position='append') + end if - write(iout_gps,950) ctype,jiter,nread,nkeep,ntot - write(iout_gps,951) ctype,gpsmplty,gpsqcplty,tgps,qctgps - close(iout_gps) - endif + gpsmplty=zero; gpsqcplty=zero ; ntot=0 + tgps=zero ; qctgps=zero + if(nkeep > 0)then + mesage='current fit of gps data in fractional difference$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'gps' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_gps,pflag) + do k=1,nsig + num(k)=nint(awork(5*nsig+k+100,i_gps)) + rat=zero + rat3=zero + if(num(k)>0) then + rat=awork(6*nsig+k+100,i_gps)/float(num(k)) + rat3=awork(3*nsig+k+100,i_gps)/float(num(k)) + end if + ntot=ntot+num(k); gpsmplty=gpsmplty+awork(6*nsig+k+100,i_gps) + gpsqcplty=gpsqcplty+awork(3*nsig+k+100,i_gps) + write(iout_gps,240)'gps',num(k),k,awork(6*nsig+k+100,i_gps), & + awork(3*nsig+k+100,i_gps),rat,rat3 + end do + numgross=nint(awork(4,i_gps)) + numfailqc=nint(awork(21,i_gps)) + numfail1_gps=nint(awork(22,i_gps)) + numfail2_gps=nint(awork(23,i_gps)) + numfail3_gps=nint(awork(24,i_gps)) + write(iout_gps,925)'gps',numgross,numfailqc + write(iout_gps,920)' number of gps obs failed stats qc in NH =',numfail1_gps + write(iout_gps,920)' number of gps obs failed stats qc in SH =',numfail2_gps + write(iout_gps,920)' number of gps obs failed stats qc in TR =',numfail3_gps + + numlow = nint(awork(2,i_gps)) + numhgh = nint(awork(3,i_gps)) + write(iout_gps,900) 'gps',numhgh,numlow + if(ntot > 0) then + tgps=gpsmplty/ntot + qctgps=gpsqcplty/ntot + endif + end if + write(iout_gps,950) ctype,jiter,nread,nkeep,ntot + write(iout_gps,951) ctype,gpsmplty,gpsqcplty,tgps,qctgps -! Summary report for specific humidity - if(mype==mype_q) then - if(first)then - open(iout_q) - else - open(iout_q,position='append') + close(iout_gps) end if + endif - mesage='current fit of q data, units in per-cent of guess q-sat$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'q' - end do - call dtast(bwork,npres_print,pbotq,ptopq,mesage,jiter,iout_q,pflag) - qmplty=zero; qqcplty=zero ; ntot=0 - tq=zero ; qctq=zero +! Summary report for specific humidity + if(mype==mype_q) then nread=0 nkeep=0 do i=1,ndat @@ -339,53 +329,61 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - do k=1,nsig - num(k)=nint(awork(k+6*nsig+100,i_q)) - rat=zero - rat3=zero - if(num(k) > 0)then - rat=awork(5*nsig+k+100,i_q)/float(num(k)) - rat3=awork(3*nsig+k+100,i_q)/float(num(k)) - end if - qmplty=qmplty+awork(5*nsig+k+100,i_q) - qqcplty=qqcplty+awork(3*nsig+k+100,i_q) - ntot=ntot+num(k) - write(iout_q,240) 'q',num(k),k,awork(5*nsig+k+100,i_q), & - awork(3*nsig+k+100,i_q),rat,rat3 + if(nread > 0)then + if(first)then + open(iout_q) + else + open(iout_q,position='append') + end if + + mesage='current fit of q data, units in per-cent of guess q-sat$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'q' end do - grsmlt=five - numgrsq=nint(awork(4,i_q)) - numfailqc=nint(awork(21,i_q)) - write(iout_q,924)' (scaled as precent of guess specific humidity)' - write(iout_q,925) 'q',numgrsq,numfailqc - write(iout_q,975) grsmlt,'q',awork(5,i_q) - numlow = nint(awork(2,i_q)) - numhgh = nint(awork(3,i_q)) - write(iout_q,900) 'q',numhgh,numlow - if(ntot > 0) then - tq=qmplty/float(ntot) - qctq=qqcplty/float(ntot) + call dtast(bwork,npres_print,pbotq,ptopq,mesage,jiter,iout_q,pflag) + + qmplty=zero; qqcplty=zero ; ntot=0 + tq=zero ; qctq=zero + if(nkeep > 0)then + do k=1,nsig + num(k)=nint(awork(k+6*nsig+100,i_q)) + rat=zero + rat3=zero + if(num(k) > 0)then + rat=awork(5*nsig+k+100,i_q)/float(num(k)) + rat3=awork(3*nsig+k+100,i_q)/float(num(k)) + end if + qmplty=qmplty+awork(5*nsig+k+100,i_q) + qqcplty=qqcplty+awork(3*nsig+k+100,i_q) + ntot=ntot+num(k) + write(iout_q,240) 'q',num(k),k,awork(5*nsig+k+100,i_q), & + awork(3*nsig+k+100,i_q),rat,rat3 + end do + grsmlt=five + numgrsq=nint(awork(4,i_q)) + numfailqc=nint(awork(21,i_q)) + write(iout_q,924)' (scaled as precent of guess specific humidity)' + write(iout_q,925) 'q',numgrsq,numfailqc + write(iout_q,975) grsmlt,'q',awork(5,i_q) + numlow = nint(awork(2,i_q)) + numhgh = nint(awork(3,i_q)) + write(iout_q,900) 'q',numhgh,numlow + if(ntot > 0) then + tq=qmplty/float(ntot) + qctq=qqcplty/float(ntot) + end if end if - end if - write(iout_q,950) 'q',jiter,nread,nkeep,ntot - write(iout_q,951) 'q',qmplty,qqcplty,tq,qctq + write(iout_q,950) 'q',jiter,nread,nkeep,ntot + write(iout_q,951) 'q',qmplty,qqcplty,tq,qctq - close(iout_q) + close(iout_q) + end if end if ! Summary report for surface pressure if(mype==mype_ps) then - if(first)then - open(iout_ps) - else - open(iout_ps,position='append') - end if - - nump=nint(awork(5,i_ps)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -394,40 +392,42 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of surface pressure data, ranges in mb$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'ps' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_ps,pflag) + if(nread > 0)then + if(first)then + open(iout_ps) + else + open(iout_ps,position='append') + end if + + nump=nint(awork(5,i_ps)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of surface pressure data, ranges in mb$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'ps' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_ps,pflag) - numgross=nint(awork(6,i_ps)) - numfailqc=nint(awork(21,i_ps)) - write(iout_ps,925) 'psfc',numgross,numfailqc - if(nump > 0)then - pw=awork(4,i_ps)/float(nump) - pw3=awork(22,i_ps)/float(nump) + numgross=nint(awork(6,i_ps)) + numfailqc=nint(awork(21,i_ps)) + write(iout_ps,925) 'psfc',numgross,numfailqc + if(nump > 0)then + pw=awork(4,i_ps)/float(nump) + pw3=awork(22,i_ps)/float(nump) + end if end if - end if - write(iout_ps,950) 'psfc',jiter,nread,nkeep,nump - write(iout_ps,951) 'psfc',awork(4,i_ps),awork(22,i_ps),pw,pw3 + write(iout_ps,950) 'psfc',jiter,nread,nkeep,nump + write(iout_ps,951) 'psfc',awork(4,i_ps),awork(22,i_ps),pw,pw3 - close(iout_ps) + close(iout_ps) + end if end if ! Summary report for total precipitable water if(mype==mype_pw) then - if(first)then - open(iout_pw) - else - open(iout_pw,position='append') - end if - - nsuperp=nint(awork(4,i_pw)) - tpw=zero ; tpw3=zero nread=0 nkeep=0 do i=1,ndat @@ -436,41 +436,42 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of precip. water data, ranges in mm$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'pw' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pw,pflag) - - numgrspw=nint(awork(6,i_pw)) - numfailqc=nint(awork(21,i_pw)) - grsmlt=three - tpw=zero - tpw3=zero - if(nsuperp > 0)then - tpw=awork(5,i_pw)/nsuperp - tpw3=awork(22,i_pw)/nsuperp - end if - write(iout_pw,925) 'p.w.',numgrspw,numfailqc - write(iout_pw,975) grsmlt,'p.w.',awork(7,i_pw) - end if - write(iout_pw,950) 'pw',jiter,nread,nkeep,nsuperp - write(iout_pw,951) 'pw',awork(5,i_pw),awork(22,i_pw),tpw,tpw3 + if(nread > 0)then + if(first)then + open(iout_pw) + else + open(iout_pw,position='append') + end if + tpw=zero ; tpw3=zero + if(nkeep > 0)then + mesage='current fit of precip. water data, ranges in mm$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'pw' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pw,pflag) + + numgrspw=nint(awork(6,i_pw)) + numfailqc=nint(awork(21,i_pw)) + grsmlt=three + tpw=zero + tpw3=zero + nsuperp=nint(awork(4,i_pw)) + if(nsuperp > 0)then + tpw=awork(5,i_pw)/nsuperp + tpw3=awork(22,i_pw)/nsuperp + end if + write(iout_pw,925) 'p.w.',numgrspw,numfailqc + write(iout_pw,975) grsmlt,'p.w.',awork(7,i_pw) + end if + write(iout_pw,950) 'pw',jiter,nread,nkeep,nsuperp + write(iout_pw,951) 'pw',awork(5,i_pw),awork(22,i_pw),tpw,tpw3 - close(iout_pw) + close(iout_pw) + end if end if ! Summary report for conventional sst if(mype==mype_sst) then - if(first)then - open(iout_sst) - else - open(iout_sst,position='append') - end if - - numsst=nint(awork(5,i_sst)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -479,37 +480,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional sst data, ranges in C$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'sst' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_sst,pflag) + if(nread > 0)then + if(first)then + open(iout_sst) + else + open(iout_sst,position='append') + end if - numgross=nint(awork(6,i_sst)) - numfailqc=nint(awork(21,i_sst)) - if(numsst > 0)then - pw=awork(4,i_sst)/numsst - pw3=awork(22,i_sst)/numsst + numsst=nint(awork(5,i_sst)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional sst data, ranges in C$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'sst' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_sst,pflag) + + numgross=nint(awork(6,i_sst)) + numfailqc=nint(awork(21,i_sst)) + if(numsst > 0)then + pw=awork(4,i_sst)/numsst + pw3=awork(22,i_sst)/numsst + end if + write(iout_sst,925) 'sst',numgross,numfailqc end if - write(iout_sst,925) 'sst',numgross,numfailqc - end if - write(iout_sst,950) 'sst',jiter,nread,nkeep,numsst - write(iout_sst,951) 'sst',awork(4,i_sst),awork(22,i_sst),pw,pw3 + write(iout_sst,950) 'sst',jiter,nread,nkeep,numsst + write(iout_sst,951) 'sst',awork(4,i_sst),awork(22,i_sst),pw,pw3 - close(iout_sst) + close(iout_sst) + end if end if ! Summary report for conventional gust if(mype==mype_gust) then - if(first)then - open(iout_gust) - else - open(iout_gust,position='append') - end if - - numgust=nint(awork(5,i_gust)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -518,37 +521,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional gust data, ranges in m/s$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'gust' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_gust,pflag) + if(nread > 0)then + if(first)then + open(iout_gust) + else + open(iout_gust,position='append') + end if - numgross=nint(awork(6,i_gust)) - numfailqc=nint(awork(21,i_gust)) - if(numgust > 0)then - pw=awork(4,i_gust)/numgust - pw3=awork(22,i_gust)/numgust + numgust=nint(awork(5,i_gust)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional gust data, ranges in m/s$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'gust' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_gust,pflag) + + numgross=nint(awork(6,i_gust)) + numfailqc=nint(awork(21,i_gust)) + if(numgust > 0)then + pw=awork(4,i_gust)/numgust + pw3=awork(22,i_gust)/numgust + end if + write(iout_gust,925) 'gust',numgross,numfailqc end if - write(iout_gust,925) 'gust',numgross,numfailqc - end if - write(iout_gust,950) 'gust',jiter,nread,nkeep,numgust - write(iout_gust,951) 'gust',awork(4,i_gust),awork(22,i_gust),pw,pw3 + write(iout_gust,950) 'gust',jiter,nread,nkeep,numgust + write(iout_gust,951) 'gust',awork(4,i_gust),awork(22,i_gust),pw,pw3 - close(iout_gust) + close(iout_gust) + end if end if ! Summary report for conventional vis if(mype==mype_vis) then - if(first)then - open(iout_vis) - else - open(iout_vis,position='append') - end if - - numvis=nint(awork(5,i_vis)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -557,37 +562,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional vis data, ranges in m$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'vis' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_vis,pflag) + if(nread > 0)then + if(first)then + open(iout_vis) + else + open(iout_vis,position='append') + end if - numgross=nint(awork(6,i_vis)) - numfailqc=nint(awork(21,i_vis)) - if(numvis > 0)then - pw=awork(4,i_vis)/numvis - pw3=awork(22,i_vis)/numvis + numvis=nint(awork(5,i_vis)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional vis data, ranges in m$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'vis' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_vis,pflag) + + numgross=nint(awork(6,i_vis)) + numfailqc=nint(awork(21,i_vis)) + if(numvis > 0)then + pw=awork(4,i_vis)/numvis + pw3=awork(22,i_vis)/numvis + end if + write(iout_vis,925) 'vis',numgross,numfailqc end if - write(iout_vis,925) 'vis',numgross,numfailqc - end if - write(iout_vis,950) 'vis',jiter,nread,nkeep,numvis - write(iout_vis,951) 'vis',awork(4,i_vis),awork(22,i_vis),pw,pw3 + write(iout_vis,950) 'vis',jiter,nread,nkeep,numvis + write(iout_vis,951) 'vis',awork(4,i_vis),awork(22,i_vis),pw,pw3 - close(iout_vis) + close(iout_vis) + end if end if ! Summary report for conventional pblh if(mype==mype_pblh) then - if(first)then - open(iout_pblh) - else - open(iout_pblh,position='append') - end if - - numpblh=nint(awork(5,i_pblh)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -596,37 +603,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional pblh data, ranges in m$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'pblh' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pblh,pflag) + if(nread > 0)then + if(first)then + open(iout_pblh) + else + open(iout_pblh,position='append') + end if - numgross=nint(awork(6,i_pblh)) - numfailqc=nint(awork(21,i_pblh)) - if(numpblh > 0)then - pw=awork(4,i_pblh)/numpblh - pw3=awork(22,i_pblh)/numpblh + numpblh=nint(awork(5,i_pblh)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional pblh data, ranges in m$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'pblh' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pblh,pflag) + + numgross=nint(awork(6,i_pblh)) + numfailqc=nint(awork(21,i_pblh)) + if(numpblh > 0)then + pw=awork(4,i_pblh)/numpblh + pw3=awork(22,i_pblh)/numpblh + end if + write(iout_pblh,925) 'pblh',numgross,numfailqc end if - write(iout_pblh,925) 'pblh',numgross,numfailqc - end if - write(iout_pblh,950) 'pblh',jiter,nread,nkeep,numpblh - write(iout_pblh,951) 'pblh',awork(4,i_pblh),awork(22,i_pblh),pw,pw3 + write(iout_pblh,950) 'pblh',jiter,nread,nkeep,numpblh + write(iout_pblh,951) 'pblh',awork(4,i_pblh),awork(22,i_pblh),pw,pw3 - close(iout_pblh) + close(iout_pblh) + end if end if ! Summary report for conventional wspd10m if(mype==mype_wspd10m) then - if(first)then - open(iout_wspd10m) - else - open(iout_wspd10m,position='append') - end if - - numwspd10m=nint(awork(5,i_wspd10m)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -635,37 +644,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional wspd10m data, ranges in m/s$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'wspd10m' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_wspd10m,pflag) + if(nread > 0)then + if(first)then + open(iout_wspd10m) + else + open(iout_wspd10m,position='append') + end if - numgross=nint(awork(6,i_wspd10m)) - numfailqc=nint(awork(21,i_wspd10m)) - if(numwspd10m > 0)then - pw=awork(4,i_wspd10m)/numwspd10m - pw3=awork(22,i_wspd10m)/numwspd10m + numwspd10m=nint(awork(5,i_wspd10m)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional wspd10m data, ranges in m/s$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'wspd10m' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_wspd10m,pflag) + + numgross=nint(awork(6,i_wspd10m)) + numfailqc=nint(awork(21,i_wspd10m)) + if(numwspd10m > 0)then + pw=awork(4,i_wspd10m)/numwspd10m + pw3=awork(22,i_wspd10m)/numwspd10m + end if + write(iout_wspd10m,925) 'wspd10m',numgross,numfailqc end if - write(iout_wspd10m,925) 'wspd10m',numgross,numfailqc - end if - write(iout_wspd10m,950) 'wspd10m',jiter,nread,nkeep,numwspd10m - write(iout_wspd10m,951) 'wspd10m',awork(4,i_wspd10m),awork(22,i_wspd10m),pw,pw3 + write(iout_wspd10m,950) 'wspd10m',jiter,nread,nkeep,numwspd10m + write(iout_wspd10m,951) 'wspd10m',awork(4,i_wspd10m),awork(22,i_wspd10m),pw,pw3 - close(iout_wspd10m) + close(iout_wspd10m) + end if end if ! Summary report for conventional td2m if(mype==mype_td2m) then - if(first)then - open(iout_td2m) - else - open(iout_td2m,position='append') - end if - - numtd2m=nint(awork(5,i_td2m)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -674,37 +685,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional td2m data, ranges in K $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'td2m' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_td2m,pflag) + if(nread > 0)then + if(first)then + open(iout_td2m) + else + open(iout_td2m,position='append') + end if - numgross=nint(awork(6,i_td2m)) - numfailqc=nint(awork(21,i_td2m)) - if(numtd2m > 0)then - pw=awork(4,i_td2m)/numtd2m - pw3=awork(22,i_td2m)/numtd2m + numtd2m=nint(awork(5,i_td2m)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional td2m data, ranges in K $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'td2m' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_td2m,pflag) + + numgross=nint(awork(6,i_td2m)) + numfailqc=nint(awork(21,i_td2m)) + if(numtd2m > 0)then + pw=awork(4,i_td2m)/numtd2m + pw3=awork(22,i_td2m)/numtd2m + end if + write(iout_td2m,925) 'td2m',numgross,numfailqc end if - write(iout_td2m,925) 'td2m',numgross,numfailqc - end if - write(iout_td2m,950) 'td2m',jiter,nread,nkeep,numtd2m - write(iout_td2m,951) 'td2m',awork(4,i_td2m),awork(22,i_td2m),pw,pw3 + write(iout_td2m,950) 'td2m',jiter,nread,nkeep,numtd2m + write(iout_td2m,951) 'td2m',awork(4,i_td2m),awork(22,i_td2m),pw,pw3 - close(iout_td2m) + close(iout_td2m) + end if end if ! Summary report for conventional mxtm if(mype==mype_mxtm) then - if(first)then - open(iout_mxtm) - else - open(iout_mxtm,position='append') - end if - - nummxtm=nint(awork(5,i_mxtm)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -713,37 +726,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional mxtm data, ranges in K $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'mxtm' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_mxtm,pflag) + if(nread > 0)then + if(first)then + open(iout_mxtm) + else + open(iout_mxtm,position='append') + end if - numgross=nint(awork(6,i_mxtm)) - numfailqc=nint(awork(21,i_mxtm)) - if(nummxtm > 0)then - pw=awork(4,i_mxtm)/nummxtm - pw3=awork(22,i_mxtm)/nummxtm + nummxtm=nint(awork(5,i_mxtm)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional mxtm data, ranges in K $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'mxtm' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_mxtm,pflag) + + numgross=nint(awork(6,i_mxtm)) + numfailqc=nint(awork(21,i_mxtm)) + if(nummxtm > 0)then + pw=awork(4,i_mxtm)/nummxtm + pw3=awork(22,i_mxtm)/nummxtm + end if + write(iout_mxtm,925) 'mxtm',numgross,numfailqc end if - write(iout_mxtm,925) 'mxtm',numgross,numfailqc - end if - write(iout_mxtm,950) 'mxtm',jiter,nread,nkeep,nummxtm - write(iout_mxtm,951) 'mxtm',awork(4,i_mxtm),awork(22,i_mxtm),pw,pw3 + write(iout_mxtm,950) 'mxtm',jiter,nread,nkeep,nummxtm + write(iout_mxtm,951) 'mxtm',awork(4,i_mxtm),awork(22,i_mxtm),pw,pw3 - close(iout_mxtm) + close(iout_mxtm) + end if end if ! Summary report for conventional mitm if(mype==mype_mitm) then - if(first)then - open(iout_mitm) - else - open(iout_mitm,position='append') - end if - - nummitm=nint(awork(5,i_mitm)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -752,37 +767,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional mitm data, ranges in K $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'mitm' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_mitm,pflag) + if(nread > 0)then + if(first)then + open(iout_mitm) + else + open(iout_mitm,position='append') + end if - numgross=nint(awork(6,i_mitm)) - numfailqc=nint(awork(21,i_mitm)) - if(nummitm > 0)then - pw=awork(4,i_mitm)/nummitm - pw3=awork(22,i_mitm)/nummitm + nummitm=nint(awork(5,i_mitm)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional mitm data, ranges in K $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'mitm' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_mitm,pflag) + + numgross=nint(awork(6,i_mitm)) + numfailqc=nint(awork(21,i_mitm)) + if(nummitm > 0)then + pw=awork(4,i_mitm)/nummitm + pw3=awork(22,i_mitm)/nummitm + end if + write(iout_mitm,925) 'mitm',numgross,numfailqc end if - write(iout_mitm,925) 'mitm',numgross,numfailqc - end if - write(iout_mitm,950) 'mitm',jiter,nread,nkeep,nummitm - write(iout_mitm,951) 'mitm',awork(4,i_mitm),awork(22,i_mitm),pw,pw3 + write(iout_mitm,950) 'mitm',jiter,nread,nkeep,nummitm + write(iout_mitm,951) 'mitm',awork(4,i_mitm),awork(22,i_mitm),pw,pw3 - close(iout_mitm) + close(iout_mitm) + end if end if ! Summary report for conventional pmsl if(mype==mype_pmsl) then - if(first)then - open(iout_pmsl) - else - open(iout_pmsl,position='append') - end if - - numpmsl=nint(awork(5,i_pmsl)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -791,37 +808,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional pmsl data, ranges in hPa $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'pmsl' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pmsl,pflag) + if(nread > 0)then + if(first)then + open(iout_pmsl) + else + open(iout_pmsl,position='append') + end if - numgross=nint(awork(6,i_pmsl)) - numfailqc=nint(awork(21,i_pmsl)) - if(numpmsl > 0)then - pw=awork(4,i_pmsl)/numpmsl - pw3=awork(22,i_pmsl)/numpmsl + numpmsl=nint(awork(5,i_pmsl)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional pmsl data, ranges in hPa $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'pmsl' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pmsl,pflag) + + numgross=nint(awork(6,i_pmsl)) + numfailqc=nint(awork(21,i_pmsl)) + if(numpmsl > 0)then + pw=awork(4,i_pmsl)/numpmsl + pw3=awork(22,i_pmsl)/numpmsl + end if + write(iout_pmsl,925) 'pmsl',numgross,numfailqc end if - write(iout_pmsl,925) 'pmsl',numgross,numfailqc - end if - write(iout_pmsl,950) 'pmsl',jiter,nread,nkeep,numpmsl - write(iout_pmsl,951) 'pmsl',awork(4,i_pmsl),awork(22,i_pmsl),pw,pw3 + write(iout_pmsl,950) 'pmsl',jiter,nread,nkeep,numpmsl + write(iout_pmsl,951) 'pmsl',awork(4,i_pmsl),awork(22,i_pmsl),pw,pw3 - close(iout_pmsl) + close(iout_pmsl) + end if end if ! Summary report for conventional howv if(mype==mype_howv) then - if(first)then - open(iout_howv) - else - open(iout_howv,position='append') - end if - - numhowv=nint(awork(5,i_howv)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -830,37 +849,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional howv data, ranges in m $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'howv' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_howv,pflag) + if(nread > 0)then + if(first)then + open(iout_howv) + else + open(iout_howv,position='append') + end if - numgross=nint(awork(6,i_howv)) - numfailqc=nint(awork(21,i_howv)) - if(numhowv > 0)then - pw=awork(4,i_howv)/numhowv - pw3=awork(22,i_howv)/numhowv + numhowv=nint(awork(5,i_howv)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional howv data, ranges in m $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'howv' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_howv,pflag) + + numgross=nint(awork(6,i_howv)) + numfailqc=nint(awork(21,i_howv)) + if(numhowv > 0)then + pw=awork(4,i_howv)/numhowv + pw3=awork(22,i_howv)/numhowv + end if + write(iout_howv,925) 'howv',numgross,numfailqc end if - write(iout_howv,925) 'howv',numgross,numfailqc - end if - write(iout_howv,950) 'howv',jiter,nread,nkeep,numhowv - write(iout_howv,951) 'howv',awork(4,i_howv),awork(22,i_howv),pw,pw3 + write(iout_howv,950) 'howv',jiter,nread,nkeep,numhowv + write(iout_howv,951) 'howv',awork(4,i_howv),awork(22,i_howv),pw,pw3 - close(iout_howv) + close(iout_howv) + end if end if ! Summary report for tcamt if(mype==mype_tcamt) then - if(first)then - open(iout_tcamt) - else - open(iout_tcamt,position='append') - end if - - numtcamt=nint(awork(5,i_tcamt)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -869,37 +890,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional tcamt data, ranges in %$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'tcamt' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_tcamt,pflag) + if(nread > 0)then + if(first)then + open(iout_tcamt) + else + open(iout_tcamt,position='append') + end if - numgross=nint(awork(6,i_tcamt)) - numfailqc=nint(awork(21,i_tcamt)) - if(numtcamt > 0)then - pw=awork(4,i_tcamt)/numtcamt - pw3=awork(22,i_tcamt)/numtcamt + numtcamt=nint(awork(5,i_tcamt)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional tcamt data, ranges in %$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'tcamt' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_tcamt,pflag) + + numgross=nint(awork(6,i_tcamt)) + numfailqc=nint(awork(21,i_tcamt)) + if(numtcamt > 0)then + pw=awork(4,i_tcamt)/numtcamt + pw3=awork(22,i_tcamt)/numtcamt + end if + write(iout_tcamt,925) 'tcamt',numgross,numfailqc end if - write(iout_tcamt,925) 'tcamt',numgross,numfailqc - end if - write(iout_tcamt,950) 'tcamt',jiter,nread,nkeep,numtcamt - write(iout_tcamt,951) 'tcamt',awork(4,i_tcamt),awork(22,i_tcamt),pw,pw3 + write(iout_tcamt,950) 'tcamt',jiter,nread,nkeep,numtcamt + write(iout_tcamt,951) 'tcamt',awork(4,i_tcamt),awork(22,i_tcamt),pw,pw3 - close(iout_tcamt) + close(iout_tcamt) + end if end if ! Summary report for lcbas if(mype==mype_lcbas) then - if(first)then - open(iout_lcbas) - else - open(iout_lcbas,position='append') - end if - - numlcbas=nint(awork(5,i_lcbas)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -908,37 +931,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional lcbas data, ranges in m$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'lcbas' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_lcbas,pflag) + if(nread > 0)then + if(first)then + open(iout_lcbas) + else + open(iout_lcbas,position='append') + end if - numgross=nint(awork(6,i_lcbas)) - numfailqc=nint(awork(21,i_lcbas)) - if(numlcbas > 0)then - pw=awork(4,i_lcbas)/numlcbas - pw3=awork(22,i_lcbas)/numlcbas + numlcbas=nint(awork(5,i_lcbas)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional lcbas data, ranges in m$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'lcbas' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_lcbas,pflag) + + numgross=nint(awork(6,i_lcbas)) + numfailqc=nint(awork(21,i_lcbas)) + if(numlcbas > 0)then + pw=awork(4,i_lcbas)/numlcbas + pw3=awork(22,i_lcbas)/numlcbas + end if + write(iout_lcbas,925) 'lcbas',numgross,numfailqc end if - write(iout_lcbas,925) 'lcbas',numgross,numfailqc - end if - write(iout_lcbas,950) 'lcbas',jiter,nread,nkeep,numlcbas - write(iout_lcbas,951) 'lcbas',awork(4,i_lcbas),awork(22,i_lcbas),pw,pw3 + write(iout_lcbas,950) 'lcbas',jiter,nread,nkeep,numlcbas + write(iout_lcbas,951) 'lcbas',awork(4,i_lcbas),awork(22,i_lcbas),pw,pw3 - close(iout_lcbas) + close(iout_lcbas) + end if end if ! Summary report for conventional cldch if(mype==mype_cldch) then - if(first)then - open(iout_cldch) - else - open(iout_cldch,position='append') - end if - - numcldch=nint(awork(5,i_cldch)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -947,37 +972,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional cldch data, ranges in m$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'cldch' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_cldch,pflag) + if(nread > 0)then + if(first)then + open(iout_cldch) + else + open(iout_cldch,position='append') + end if - numgross=nint(awork(6,i_cldch)) - numfailqc=nint(awork(21,i_cldch)) - if(numcldch > 0)then - pw=awork(4,i_cldch)/numcldch - pw3=awork(22,i_cldch)/numcldch + numcldch=nint(awork(5,i_cldch)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional cldch data, ranges in m$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'cldch' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_cldch,pflag) + + numgross=nint(awork(6,i_cldch)) + numfailqc=nint(awork(21,i_cldch)) + if(numcldch > 0)then + pw=awork(4,i_cldch)/numcldch + pw3=awork(22,i_cldch)/numcldch + end if + write(iout_cldch,925) 'cldch',numgross,numfailqc end if - write(iout_cldch,925) 'cldch',numgross,numfailqc - end if - write(iout_cldch,950) 'cldch',jiter,nread,nkeep,numcldch - write(iout_cldch,951) 'cldch',awork(4,i_cldch),awork(22,i_cldch),pw,pw3 + write(iout_cldch,950) 'cldch',jiter,nread,nkeep,numcldch + write(iout_cldch,951) 'cldch',awork(4,i_cldch),awork(22,i_cldch),pw,pw3 - close(iout_cldch) + close(iout_cldch) + end if end if ! Summary report for conventional uwnd10m if(mype==mype_uwnd10m) then - if(first)then - open(iout_uwnd10m) - else - open(iout_uwnd10m,position='append') - end if - - numuwnd10m=nint(awork(5,i_uwnd10m)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -986,37 +1013,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional uwnd10m data, ranges in m/s$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'uwnd10m' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_uwnd10m,pflag) + if(nread > 0)then + if(first)then + open(iout_uwnd10m) + else + open(iout_uwnd10m,position='append') + end if - numgross=nint(awork(6,i_uwnd10m)) - numfailqc=nint(awork(21,i_uwnd10m)) - if(numuwnd10m > 0)then - pw=awork(4,i_uwnd10m)/numuwnd10m - pw3=awork(22,i_uwnd10m)/numuwnd10m + numuwnd10m=nint(awork(5,i_uwnd10m)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional uwnd10m data, ranges in m/s$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'uwnd10m' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_uwnd10m,pflag) + + numgross=nint(awork(6,i_uwnd10m)) + numfailqc=nint(awork(21,i_uwnd10m)) + if(numuwnd10m > 0)then + pw=awork(4,i_uwnd10m)/numuwnd10m + pw3=awork(22,i_uwnd10m)/numuwnd10m + end if + write(iout_uwnd10m,925) 'uwnd10m',numgross,numfailqc end if - write(iout_uwnd10m,925) 'uwnd10m',numgross,numfailqc - end if - write(iout_uwnd10m,950) 'uwnd10m',jiter,nread,nkeep,numuwnd10m - write(iout_uwnd10m,951) 'uwnd10m',awork(4,i_uwnd10m),awork(22,i_uwnd10m),pw,pw3 + write(iout_uwnd10m,950) 'uwnd10m',jiter,nread,nkeep,numuwnd10m + write(iout_uwnd10m,951) 'uwnd10m',awork(4,i_uwnd10m),awork(22,i_uwnd10m),pw,pw3 - close(iout_uwnd10m) + close(iout_uwnd10m) + end if end if ! Summary report for conventional vwnd10m if(mype==mype_vwnd10m) then - if(first)then - open(iout_vwnd10m) - else - open(iout_vwnd10m,position='append') - end if - - numvwnd10m=nint(awork(5,i_vwnd10m)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -1025,37 +1054,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional vwnd10m data, ranges in m/s$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'vwnd10m' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_vwnd10m,pflag) + if(nread > 0)then + if(first)then + open(iout_vwnd10m) + else + open(iout_vwnd10m,position='append') + end if - numgross=nint(awork(6,i_vwnd10m)) - numfailqc=nint(awork(21,i_vwnd10m)) - if(numvwnd10m > 0)then - pw=awork(4,i_vwnd10m)/numvwnd10m - pw3=awork(22,i_vwnd10m)/numvwnd10m + numvwnd10m=nint(awork(5,i_vwnd10m)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional vwnd10m data, ranges in m/s$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'vwnd10m' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_vwnd10m,pflag) + + numgross=nint(awork(6,i_vwnd10m)) + numfailqc=nint(awork(21,i_vwnd10m)) + if(numvwnd10m > 0)then + pw=awork(4,i_vwnd10m)/numvwnd10m + pw3=awork(22,i_vwnd10m)/numvwnd10m + end if + write(iout_vwnd10m,925) 'vwnd10m',numgross,numfailqc end if - write(iout_vwnd10m,925) 'vwnd10m',numgross,numfailqc - end if - write(iout_vwnd10m,950) 'vwnd10m',jiter,nread,nkeep,numvwnd10m - write(iout_vwnd10m,951) 'vwnd10m',awork(4,i_vwnd10m),awork(22,i_vwnd10m),pw,pw3 + write(iout_vwnd10m,950) 'vwnd10m',jiter,nread,nkeep,numvwnd10m + write(iout_vwnd10m,951) 'vwnd10m',awork(4,i_vwnd10m),awork(22,i_vwnd10m),pw,pw3 - close(iout_vwnd10m) + close(iout_vwnd10m) + end if end if ! Summary report for temperature if (mype==mype_t)then - if(first)then - open(iout_t) - else - open(iout_t,position='append') - end if - - tmplty=zero; tqcplty=zero ; ntot=0 - tt=zero ; qctt=zero nread=0 nkeep=0 do i=1,ndat @@ -1064,54 +1095,56 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of temperature data, ranges in K $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 't' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_t,pflag) - do k=1,nsig - num(k)=nint(awork(5*nsig+k+100,i_t)) - rat=zero ; rat3=zero - if(num(k) > 0) then - rat=awork(6*nsig+k+100,i_t)/float(num(k)) - rat3=awork(3*nsig+k+100,i_t)/float(num(k)) + if(nread > 0)then + if(first)then + open(iout_t) + else + open(iout_t,position='append') + end if + + tmplty=zero; tqcplty=zero ; ntot=0 + tt=zero ; qctt=zero + if(nkeep > 0)then + mesage='current fit of temperature data, ranges in K $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 't' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_t,pflag) + do k=1,nsig + num(k)=nint(awork(5*nsig+k+100,i_t)) + rat=zero ; rat3=zero + if(num(k) > 0) then + rat=awork(6*nsig+k+100,i_t)/float(num(k)) + rat3=awork(3*nsig+k+100,i_t)/float(num(k)) + end if + ntot=ntot+num(k); tmplty=tmplty+awork(6*nsig+k+100,i_t) + tqcplty=tqcplty+awork(3*nsig+k+100,i_t) + write(iout_t,240) 't',num(k),k,awork(6*nsig+k+100,i_t), & + awork(3*nsig+k+100,i_t),rat,rat3 + end do + numgross=nint(awork(4,i_t)) + numfailqc=nint(awork(21,i_t)) + write(iout_t,925) 'temp',numgross,numfailqc + numlow = nint(awork(2,i_t)) + numhgh = nint(awork(3,i_t)) + write(iout_t,900) 't',numhgh,numlow + if(ntot > 0) then + tt=tmplty/ntot + qctt=tqcplty/ntot end if - ntot=ntot+num(k); tmplty=tmplty+awork(6*nsig+k+100,i_t) - tqcplty=tqcplty+awork(3*nsig+k+100,i_t) - write(iout_t,240) 't',num(k),k,awork(6*nsig+k+100,i_t), & - awork(3*nsig+k+100,i_t),rat,rat3 - end do - numgross=nint(awork(4,i_t)) - numfailqc=nint(awork(21,i_t)) - write(iout_t,925) 'temp',numgross,numfailqc - numlow = nint(awork(2,i_t)) - numhgh = nint(awork(3,i_t)) - write(iout_t,900) 't',numhgh,numlow - if(ntot > 0) then - tt=tmplty/ntot - qctt=tqcplty/ntot end if - end if - write(iout_t,950) 't',jiter,nread,nkeep,ntot - write(iout_t,951) 't',tmplty,tqcplty,tt,qctt + write(iout_t,950) 't',jiter,nread,nkeep,ntot + write(iout_t,951) 't',tmplty,tqcplty,tt,qctt - close(iout_t) + close(iout_t) + end if endif ! Summary report for doppler lidar winds if(mype==mype_dw) then - if(first)then - open(iout_dw) - else - open(iout_dw,position='append') - end if - - dwmplty=zero; dwqcplty=zero ; ntot=0 - tdw=zero ; qctdw=zero nread=0 nkeep=0 do i=1,ndat @@ -1120,56 +1153,58 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current vfit of lidar wind data, ranges in m/s$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'dw' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_dw,pflag) + if(nread > 0)then + if(first)then + open(iout_dw) + else + open(iout_dw,position='append') + end if + + dwmplty=zero; dwqcplty=zero ; ntot=0 + tdw=zero ; qctdw=zero + if(nkeep > 0)then + mesage='current vfit of lidar wind data, ranges in m/s$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'dw' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_dw,pflag) - do k=1,nsig - num(k)=nint(awork(k+5*nsig+100,i_dw)) - rat=zero - rat3=zero - if(num(k) > 0) then - rat=awork(6*nsig+k+100,i_dw)/float(num(k)) - rat3=awork(3*nsig+k+100,i_dw)/float(num(k)) + do k=1,nsig + num(k)=nint(awork(k+5*nsig+100,i_dw)) + rat=zero + rat3=zero + if(num(k) > 0) then + rat=awork(6*nsig+k+100,i_dw)/float(num(k)) + rat3=awork(3*nsig+k+100,i_dw)/float(num(k)) + end if + ntot=ntot+num(k) + dwmplty=dwmplty+awork(6*nsig+k+100,i_dw) + dwqcplty=dwqcplty+awork(3*nsig+k+100,i_dw) + write(iout_dw,240) 'r',num(k),k,awork(6*nsig+k+100,i_dw), & + awork(3*nsig+k+100,i_dw),rat,rat3 + end do + numgross=nint(awork(4,i_dw)) + numfailqc=nint(awork(21,i_dw)) + if(ntot > 0) then + tdw=dwmplty/float(ntot) + qctdw=dwqcplty/float(ntot) end if - ntot=ntot+num(k) - dwmplty=dwmplty+awork(6*nsig+k+100,i_dw) - dwqcplty=dwqcplty+awork(3*nsig+k+100,i_dw) - write(iout_dw,240) 'r',num(k),k,awork(6*nsig+k+100,i_dw), & - awork(3*nsig+k+100,i_dw),rat,rat3 - end do - numgross=nint(awork(4,i_dw)) - numfailqc=nint(awork(21,i_dw)) - if(ntot > 0) then - tdw=dwmplty/float(ntot) - qctdw=dwqcplty/float(ntot) - end if - write(iout_dw,925) 'dw',numgross,numfailqc - numlow = nint(awork(2,i_dw)) - numhgh = nint(awork(3,i_dw)) - write(iout_dw,900) 'dw',numhgh,numlow - end if + write(iout_dw,925) 'dw',numgross,numfailqc + numlow = nint(awork(2,i_dw)) + numhgh = nint(awork(3,i_dw)) + write(iout_dw,900) 'dw',numhgh,numlow + end if - write(iout_dw,950) 'dw',jiter,nread,nkeep,ntot - write(iout_dw,951) 'dw',dwmplty,dwqcplty,tdw,qctdw + write(iout_dw,950) 'dw',jiter,nread,nkeep,ntot + write(iout_dw,951) 'dw',dwmplty,dwqcplty,tdw,qctdw - close(iout_dw) + close(iout_dw) + end if end if ! Summary report for radar radial winds if(mype==mype_rw) then - if(first)then - open(iout_rw) - else - open(iout_rw,position='append') - end if - - rwmplty=zero; rwqcplty=zero ; ntot=0 - trw=zero ; qctrw=zero nread=0 nkeep=0 do i=1,ndat @@ -1178,57 +1213,59 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current vfit of radar wind data, ranges in m/s$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'rw' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_rw,pflag) + if(nread > 0)then + if(first)then + open(iout_rw) + else + open(iout_rw,position='append') + end if + + rwmplty=zero; rwqcplty=zero ; ntot=0 + trw=zero ; qctrw=zero + if(nkeep > 0)then + mesage='current vfit of radar wind data, ranges in m/s$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'rw' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_rw,pflag) - numgross=nint(awork(4,i_rw)) - numfailqc=nint(awork(21,i_rw)) - do k=1,nsig - num(k)=nint(awork(k+5*nsig+100,i_rw)) - rat=zero - rat3=zero - if(num(k) > 0) then - rat=awork(6*nsig+k+100,i_rw)/float(num(k)) - rat3=awork(3*nsig+k+100,i_rw)/float(num(k)) + numgross=nint(awork(4,i_rw)) + numfailqc=nint(awork(21,i_rw)) + do k=1,nsig + num(k)=nint(awork(k+5*nsig+100,i_rw)) + rat=zero + rat3=zero + if(num(k) > 0) then + rat=awork(6*nsig+k+100,i_rw)/float(num(k)) + rat3=awork(3*nsig+k+100,i_rw)/float(num(k)) + end if + ntot=ntot+num(k) + rwmplty=rwmplty+awork(6*nsig+k+100,i_rw) + rwqcplty=rwqcplty+awork(3*nsig+k+100,i_rw) + write(iout_rw,240) 'r',num(k),k,awork(6*nsig+k+100,i_rw), & + awork(3*nsig+k+100,i_rw),rat,rat3 + end do + if(ntot > 0) then + trw=rwmplty/float(ntot) + qctrw=rwqcplty/float(ntot) end if - ntot=ntot+num(k) - rwmplty=rwmplty+awork(6*nsig+k+100,i_rw) - rwqcplty=rwqcplty+awork(3*nsig+k+100,i_rw) - write(iout_rw,240) 'r',num(k),k,awork(6*nsig+k+100,i_rw), & - awork(3*nsig+k+100,i_rw),rat,rat3 - end do - if(ntot > 0) then - trw=rwmplty/float(ntot) - qctrw=rwqcplty/float(ntot) - end if - write(iout_rw,925) 'rw',numgross,numfailqc - numlow = nint(awork(2,i_rw)) - numhgh = nint(awork(3,i_rw)) - nhitopo = nint(awork(5,i_rw)) - ntoodif = nint(awork(6,i_rw)) - write(iout_rw,900) 'rw',numhgh,numlow - write(iout_rw,905) 'rw',nhitopo,ntoodif - end if - write(iout_rw,950) 'rw',jiter,nread,nkeep,ntot - write(iout_rw,951) 'rw',rwmplty,rwqcplty,trw,qctrw + write(iout_rw,925) 'rw',numgross,numfailqc + numlow = nint(awork(2,i_rw)) + numhgh = nint(awork(3,i_rw)) + nhitopo = nint(awork(5,i_rw)) + ntoodif = nint(awork(6,i_rw)) + write(iout_rw,900) 'rw',numhgh,numlow + write(iout_rw,905) 'rw',nhitopo,ntoodif + end if + write(iout_rw,950) 'rw',jiter,nread,nkeep,ntot + write(iout_rw,951) 'rw',rwmplty,rwqcplty,trw,qctrw - close(iout_rw) + close(iout_rw) + end if end if ! Summary report for radar reflectivity if(mype==mype_dbz) then - if(first)then - open(iout_dbz) - else - open(iout_dbz,position='append') - end if - - dbzmplty=zero; dbzqcplty=zero ; ntot=0 - tdbz=zero ; qctdbz=zero nread=0 nkeep=0 do i=1,ndat @@ -1237,56 +1274,58 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current vfit of radar reflectivity data, ranges in dBZ$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'dbz' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_dbz,pflag) - - numgross=nint(awork(4,i_dbz)) - numfailqc=nint(awork(21,i_dbz)) - do k=1,nsig - num(k)=nint(awork(k+5*nsig+100,i_dbz)) - rat=zero - rat3=zero - if(num(k) > 0) then - rat=awork(6*nsig+k+100,i_dbz)/float(num(k)) - rat3=awork(3*nsig+k+100,i_dbz)/float(num(k)) + if(nread > 0)then + if(first)then + open(iout_dbz) + else + open(iout_dbz,position='append') + end if + + dbzmplty=zero; dbzqcplty=zero ; ntot=0 + tdbz=zero ; qctdbz=zero + if(nkeep > 0)then + mesage='current vfit of radar reflectivity data, ranges in dBZ$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'dbz' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_dbz,pflag) + + numgross=nint(awork(4,i_dbz)) + numfailqc=nint(awork(21,i_dbz)) + do k=1,nsig + num(k)=nint(awork(k+5*nsig+100,i_dbz)) + rat=zero + rat3=zero + if(num(k) > 0) then + rat=awork(6*nsig+k+100,i_dbz)/float(num(k)) + rat3=awork(3*nsig+k+100,i_dbz)/float(num(k)) + end if + ntot=ntot+num(k) + dbzmplty=dbzmplty+awork(6*nsig+k+100,i_dbz) + dbzqcplty=dbzqcplty+awork(3*nsig+k+100,i_dbz) + write(iout_dbz,240) 'r',num(k),k,awork(6*nsig+k+100,i_dbz), & + awork(3*nsig+k+100,i_dbz),rat,rat3 + end do + if(ntot > 0) then + tdbz=dbzmplty/float(ntot) + qctdbz=dbzqcplty/float(ntot) end if - ntot=ntot+num(k) - dbzmplty=dbzmplty+awork(6*nsig+k+100,i_dbz) - dbzqcplty=dbzqcplty+awork(3*nsig+k+100,i_dbz) - write(iout_dbz,240) 'r',num(k),k,awork(6*nsig+k+100,i_dbz), & - awork(3*nsig+k+100,i_dbz),rat,rat3 - end do - if(ntot > 0) then - tdbz=dbzmplty/float(ntot) - qctdbz=dbzqcplty/float(ntot) - end if - write(iout_dbz,925) 'dbz',numgross,numfailqc - numlow = nint(awork(2,i_dbz)) - numhgh = nint(awork(3,i_dbz)) - nhitopo = nint(awork(5,i_dbz)) - ntoodif = nint(awork(6,i_dbz)) - write(iout_dbz,900) 'dbz',numhgh,numlow - write(iout_dbz,905) 'dbz',nhitopo,ntoodif - end if - write(iout_dbz,950) 'dbz',jiter,nread,nkeep,ntot - write(iout_dbz,951) 'dbz',dbzmplty,dbzqcplty,tdbz,qctdbz + write(iout_dbz,925) 'dbz',numgross,numfailqc + numlow = nint(awork(2,i_dbz)) + numhgh = nint(awork(3,i_dbz)) + nhitopo = nint(awork(5,i_dbz)) + ntoodif = nint(awork(6,i_dbz)) + write(iout_dbz,900) 'dbz',numhgh,numlow + write(iout_dbz,905) 'dbz',nhitopo,ntoodif + end if + write(iout_dbz,950) 'dbz',jiter,nread,nkeep,ntot + write(iout_dbz,951) 'dbz',dbzmplty,dbzqcplty,tdbz,qctdbz - close(iout_dbz) + close(iout_dbz) + end if end if if(mype==mype_tcp) then - if(first)then - open(iout_tcp) - else - open(iout_tcp,position='append') - end if - - nump=nint(awork(5,i_tcp)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -1295,39 +1334,41 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of surface pressure data, ranges in mb$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'tcp' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_tcp,pflag) - - numgross=nint(awork(6,i_tcp)) - numfailqc=nint(awork(21,i_tcp)) - write(iout_tcp,925) 'psfc',numgross,numfailqc + if(nread > 0)then + if(first)then + open(iout_tcp) + else + open(iout_tcp,position='append') + end if - if(nump > 0)then - pw=awork(4,i_tcp)/float(nump) - pw3=awork(22,i_tcp)/float(nump) + nump=nint(awork(5,i_tcp)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of surface pressure data, ranges in mb$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'tcp' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_tcp,pflag) + + numgross=nint(awork(6,i_tcp)) + numfailqc=nint(awork(21,i_tcp)) + write(iout_tcp,925) 'psfc',numgross,numfailqc + + if(nump > 0)then + pw=awork(4,i_tcp)/float(nump) + pw3=awork(22,i_tcp)/float(nump) + end if end if - end if - write(iout_tcp,950) 'psfc',jiter,nread,nkeep,nump - write(iout_tcp,951) 'psfc',awork(4,i_tcp),awork(22,i_tcp),pw,pw3 + write(iout_tcp,950) 'psfc',jiter,nread,nkeep,nump + write(iout_tcp,951) 'psfc',awork(4,i_tcp),awork(22,i_tcp),pw,pw3 - close(iout_tcp) + close(iout_tcp) + end if end if ! Summary report for lagrangian if (mype==mype_lag)then - if(first)then - open(iout_lag) - else - open(iout_lag,position='append') - end if - - tmplty=zero; tqcplty=zero ; ntot=0 - tt=zero ; qctt=zero nread=0 nkeep=0 do i=1,ndat @@ -1336,53 +1377,54 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of lagangian data, ranges in m $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'lag' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_lag,pflag) - do k=1,nsig - num(k)=nint(awork(6*nsig+k+100,i_lag)) - rat=zero ; rat3=zero - if(num(k) > 0) then - rat=awork(4*nsig+k+100,i_lag)/float(num(k)) - rat3=awork(3*nsig+k+100,i_lag)/float(num(k)) + if(nread > 0)then + if(first)then + open(iout_lag) + else + open(iout_lag,position='append') + end if + + tmplty=zero; tqcplty=zero ; ntot=0 + tt=zero ; qctt=zero + if(nkeep > 0)then + mesage='current fit of lagangian data, ranges in m $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'lag' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_lag,pflag) + do k=1,nsig + num(k)=nint(awork(6*nsig+k+100,i_lag)) + rat=zero ; rat3=zero + if(num(k) > 0) then + rat=awork(4*nsig+k+100,i_lag)/float(num(k)) + rat3=awork(3*nsig+k+100,i_lag)/float(num(k)) + end if + ntot=ntot+num(k); tmplty=tmplty+awork(4*nsig+k+100,i_lag) + tqcplty=tqcplty+awork(3*nsig+k+100,i_lag) + write(iout_lag,240) 'lag',num(k),k,awork(4*nsig+k+100,i_lag), & + awork(3*nsig+k+100,i_lag),rat,rat3 + end do + numgross=nint(awork(4,i_lag)) + numfailqc=nint(awork(21,i_lag)) + write(iout_lag,925) 'lag',numgross,numfailqc + ! numlow = nint(awork(2,i_t)) + ! numhgh = nint(awork(3,i_t)) + ! write(iout_lag,900) 't',numhgh,numlow + if(ntot > 0) then + tt=tmplty/ntot + qctt=tqcplty/ntot end if - ntot=ntot+num(k); tmplty=tmplty+awork(4*nsig+k+100,i_lag) - tqcplty=tqcplty+awork(3*nsig+k+100,i_lag) - write(iout_lag,240) 'lag',num(k),k,awork(4*nsig+k+100,i_lag), & - awork(3*nsig+k+100,i_lag),rat,rat3 - end do - numgross=nint(awork(4,i_lag)) - numfailqc=nint(awork(21,i_lag)) - write(iout_lag,925) 'lag',numgross,numfailqc - ! numlow = nint(awork(2,i_t)) - ! numhgh = nint(awork(3,i_t)) - ! write(iout_lag,900) 't',numhgh,numlow - if(ntot > 0) then - tt=tmplty/ntot - qctt=tqcplty/ntot end if - end if - write(iout_lag,950) 'lag',jiter,nread,nkeep,ntot - write(iout_lag,951) 'lag',tmplty,tqcplty,tt,qctt + write(iout_lag,950) 'lag',jiter,nread,nkeep,ntot + write(iout_lag,951) 'lag',tmplty,tqcplty,tt,qctt - close(iout_lag) + close(iout_lag) + end if endif ! Summary report for solid-water content path if(mype==mype_swcp) then - if(first)then - open(iout_swcp) - else - open(iout_swcp,position='append') - end if - - nsuperp=nint(awork(4,i_swcp)) - - tswcp=zero ; tswcp3=zero nread=0 nkeep=0 do i=1,ndat @@ -1391,42 +1433,44 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of solid-water content path, ranges in kg/m^2$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'swcp' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_swcp,pflag) - - numgrsswcp=nint(awork(6,i_swcp)) - numfailqc=nint(awork(21,i_swcp)) - grsmlt=three - tswcp=zero - tswcp3=zero - if(nsuperp > 0)then - tswcp=awork(5,i_swcp)/nsuperp - tswcp3=awork(22,i_swcp)/nsuperp - end if - write(iout_swcp,925) 'swcp',numgrsswcp,numfailqc - write(iout_swcp,975) grsmlt,'swcp',awork(7,i_swcp) - end if - write(iout_swcp,950) 'swcp',jiter,nread,nkeep,nsuperp - write(iout_swcp,951) 'swcp',awork(5,i_swcp),awork(22,i_swcp),tswcp,tswcp3 + if(nread > 0)then + if(first)then + open(iout_swcp) + else + open(iout_swcp,position='append') + end if + + nsuperp=nint(awork(4,i_swcp)) + + tswcp=zero ; tswcp3=zero + if(nkeep > 0)then + mesage='current fit of solid-water content path, ranges in kg/m^2$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'swcp' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_swcp,pflag) + + numgrsswcp=nint(awork(6,i_swcp)) + numfailqc=nint(awork(21,i_swcp)) + grsmlt=three + tswcp=zero + tswcp3=zero + if(nsuperp > 0)then + tswcp=awork(5,i_swcp)/nsuperp + tswcp3=awork(22,i_swcp)/nsuperp + end if + write(iout_swcp,925) 'swcp',numgrsswcp,numfailqc + write(iout_swcp,975) grsmlt,'swcp',awork(7,i_swcp) + end if + write(iout_swcp,950) 'swcp',jiter,nread,nkeep,nsuperp + write(iout_swcp,951) 'swcp',awork(5,i_swcp),awork(22,i_swcp),tswcp,tswcp3 - close(iout_swcp) + close(iout_swcp) + end if end if ! Summary report for liquid-water content path if(mype==mype_lwcp) then - if(first)then - open(iout_lwcp) - else - open(iout_lwcp,position='append') - end if - - nsuperp=nint(awork(4,i_lwcp)) - - tlwcp=zero ; tlwcp3=zero nread=0 nkeep=0 do i=1,ndat @@ -1435,29 +1479,40 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of liquid-water content path, ranges in kg/m^2$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'lwcp' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_lwcp,pflag) - - numgrslwcp=nint(awork(6,i_lwcp)) - numfailqc=nint(awork(21,i_lwcp)) - grsmlt=three - tlwcp=zero - tlwcp3=zero - if(nsuperp > 0)then - tlwcp=awork(5,i_lwcp)/nsuperp - tlwcp3=awork(22,i_lwcp)/nsuperp - end if - write(iout_lwcp,925) 'lwcp',numgrslwcp,numfailqc - write(iout_lwcp,975) grsmlt,'lwcp',awork(7,i_lwcp) - end if - write(iout_lwcp,950) 'lwcp',jiter,nread,nkeep,nsuperp - write(iout_lwcp,951) 'lwcp',awork(5,i_lwcp),awork(22,i_lwcp),tlwcp,tlwcp3 + if(nread > 0)then + if(first)then + open(iout_lwcp) + else + open(iout_lwcp,position='append') + end if - close(iout_lwcp) + nsuperp=nint(awork(4,i_lwcp)) + + tlwcp=zero ; tlwcp3=zero + if(nkeep > 0)then + mesage='current fit of liquid-water content path, ranges in kg/m^2$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'lwcp' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_lwcp,pflag) + + numgrslwcp=nint(awork(6,i_lwcp)) + numfailqc=nint(awork(21,i_lwcp)) + grsmlt=three + tlwcp=zero + tlwcp3=zero + if(nsuperp > 0)then + tlwcp=awork(5,i_lwcp)/nsuperp + tlwcp3=awork(22,i_lwcp)/nsuperp + end if + write(iout_lwcp,925) 'lwcp',numgrslwcp,numfailqc + write(iout_lwcp,975) grsmlt,'lwcp',awork(7,i_lwcp) + end if + write(iout_lwcp,950) 'lwcp',jiter,nread,nkeep,nsuperp + write(iout_lwcp,951) 'lwcp',awork(5,i_lwcp),awork(22,i_lwcp),tlwcp,tlwcp3 + + close(iout_lwcp) + end if end if diff --git a/src/gsi/statslight.f90 b/src/gsi/statslight.f90 index ffcdef6a0a..7f8e7c8349 100644 --- a/src/gsi/statslight.f90 +++ b/src/gsi/statslight.f90 @@ -56,31 +56,14 @@ subroutine statslight(mype,i_light,bwork,awork,i_ref,ndata) real(r_kind) grsmlt,tlight real(r_kind) tlight3 - real(r_kind),dimension(1):: pbotall,ptopall logical,dimension(nlighttype):: pflag !********************************************************************************* -! Initialize constants and variables. - ptopall(1)=zero; pbotall(1)=2000.0_r_kind - - -! Generate summary statistics - - pflag=.FALSE. - -! Summary report for lightning flash rate +! Generate statistics Summary report for lightning flash rate if(mype==mype_light) then - if(first)then - open(iout_light) - else - open(iout_light,position='append') - end if - - nsuperl=nint(awork(4,i_light)) - tlight=zero ; tlight3=zero nread=0 nkeep=0 do i=1,ndat @@ -89,29 +72,40 @@ subroutine statslight(mype,i_light,bwork,awork,i_ref,ndata) nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of lightning data, range in #hits km-2 hr-1$' - do j=1,nlighttype - pflag(j)=trim(nulight(j)) == 'light' - enddo - - call dtast(bwork,1,pbot,ptop,mesage,jiter,iout_light,pflag) + if(nread > 0)then + pflag=.FALSE. + if(first)then + open(iout_light) + else + open(iout_light,position='append') + end if - numgrslight=nint(awork(6,i_light)) - numfailqc=nint(awork(21,i_light)) - grsmlt=three - tlight=zero - if(nsuperl > 0)then - tlight=awork(5,i_light)/nsuperl - tlight3=awork(22,i_light)/nsuperl + nsuperl=nint(awork(4,i_light)) + tlight=zero ; tlight3=zero + if(nkeep > 0)then + mesage='current fit of lightning data, range in #hits km-2 hr-1$' + do j=1,nlighttype + pflag(j)=trim(nulight(j)) == 'light' + enddo + + call dtast(bwork,1,pbot,ptop,mesage,jiter,iout_light,pflag) + + numgrslight=nint(awork(6,i_light)) + numfailqc=nint(awork(21,i_light)) + grsmlt=three + tlight=zero + if(nsuperl > 0)then + tlight=awork(5,i_light)/nsuperl + tlight3=awork(22,i_light)/nsuperl + end if + write(iout_light,925) 'light',numgrslight,numfailqc + write(iout_light,975) grsmlt,'light',awork(7,i_light) end if - write(iout_light,925) 'light',numgrslight,numfailqc - write(iout_light,975) grsmlt,'light',awork(7,i_light) - end if - write(iout_light,950) 'light',jiter,nread,nkeep,nsuperl - write(iout_light,951) 'light',awork(5,i_light),awork(22,i_light),tlight,tlight3 + write(iout_light,950) 'light',jiter,nread,nkeep,nsuperl + write(iout_light,951) 'light',awork(5,i_light),awork(22,i_light),tlight,tlight3 - close(iout_light) + close(iout_light) + end if end if diff --git a/src/gsi/statsrad.f90 b/src/gsi/statsrad.f90 index c6a993092c..121761fa76 100644 --- a/src/gsi/statsrad.f90 +++ b/src/gsi/statsrad.f90 @@ -142,7 +142,7 @@ subroutine statsrad(aivals,stats,ndata) ! Write obs count to runtime output file write(iout_rad,1109) do i=1,ndat - if(idisplay(i))then + if(idisplay(i) .and. ndata(i,2) > 0)then iobs2 = nint(aivals(38,i)) qcpenal = aivals(39,i) rpenal = aivals(40,i) @@ -162,9 +162,9 @@ subroutine statsrad(aivals,stats,ndata) 2012 format(12x,A7,5x,8(a7,1x)) 2999 format(' Illegal satellite type ') 1102 format(1x,i4,i5,1x,a16,2i7,1x,f10.3,1x,6(f11.7,1x)) -1109 format(t5,'it',t13,'satellite',t23,'instrument',t38, & - '# read',t49,'# keep',t59,'# assim',& - t68,'penalty',t81,'qcpnlty',t95,'cpen',t105,'qccpen') +1109 format(t5,'it',t13,'satellite',t23,'instrument',t40, & + '# read',t53,'# keep',t65,'# assim',& + t75,'penalty',t88,'qcpnlty',t104,'cpen',t115,'qccpen') 1115 format('o-g',1x,i2.2,1x,'rad',2x,2A10,2x,3(i11,2x),4(g12.5,1x)) ! Close output unit diff --git a/src/gsi/stpcalc.f90 b/src/gsi/stpcalc.f90 index 80fac64d61..2d79fd3e3b 100644 --- a/src/gsi/stpcalc.f90 +++ b/src/gsi/stpcalc.f90 @@ -226,17 +226,19 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & use stpjcmod, only: stplimq,stplimg,stplimv,stplimp,stplimw10m,& stplimhowv,stplimcldch,stpjcdfi,stpjcpdry,stpliml,stplimqc use bias_predictors, only: predictors - use control_vectors, only: control_vector,qdot_prod_sub,cvars2d,cvars3d + use control_vectors, only: control_vector,qdot_prod_sub + use state_vectors, only: qgpresent,qspresent,qrpresent,qipresent,qlpresent + use state_vectors, only: cldchpresent,lcbaspresent,howvpresent,wspd10mpresent,pblhpresent,vispresent,gustpresent use state_vectors, only: allocate_state,deallocate_state use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer use gsi_bundlemod, only: assignment(=) use guess_grids, only: ntguessig,nfldsig use mpl_allreducemod, only: mpl_allreduce - use mpeu_util, only: getindex use timermod, only: timer_ini,timer_fnl use stpjomod, only: stpjo use gsi_io, only: verbose + use gridmod, only: minmype implicit none ! Declare passed variables @@ -266,20 +268,19 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & real(r_quad),dimension(4,ipen):: pbc real(r_quad),dimension(4,nobs_type):: pbcjo real(r_quad),dimension(4,nobs_type,nobs_bins):: pbcjoi - real(r_quad),dimension(4,nobs_bins):: pbcqmin,pbcqmax + real(r_quad),dimension(4):: pbcqmin,pbcqmax real(r_quad),dimension(4,nobs_bins):: pbcql,pbcqi,pbcqr,pbcqs,pbcqg real(r_quad),dimension(ipen):: pen_est real(r_quad),dimension(3,ipenlin):: pstart real(r_quad) bx,cx,ccoef,bcoef,dels,sges1,sgesj real(r_quad),dimension(0:istp_iter):: stp real(r_kind),dimension(istp_iter):: stprat - real(r_quad),dimension(ipen):: bsum,csum,bsum_save,csum_save,pen_save + real(r_quad),dimension(ipen):: bsum,csum real(r_quad),dimension(ipen,nobs_bins):: pj real(r_kind) delpen real(r_kind) outpensave real(r_kind),dimension(4)::sges real(r_kind),dimension(ioutpen):: outpen,outstp - logical :: cxterm,change_dels,ifound logical :: print_verbose,pjcalc @@ -290,7 +291,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & ! Initialize variable print_verbose=.false. if(verbose)print_verbose=.true. - cxterm=.false. mm1=mype+1 stp(0)=stpinout outpen = zero @@ -387,10 +387,10 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & ! there, if one has to know or to reference them explicitly. pstart=zero_quad - pbc=zero_quad if(iter == 0 .and. kprt >= 2)pjcalc=.true. + ! penalty, b and c for background terms pstart(1,1) = qdot_prod_sub(xhatsave,yhatsave) @@ -426,11 +426,11 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & dels = one_tenth_quad stepsize: do ii=1,istp_iter + pbc=zero_quad pjcalc=.false. if(iter == 0 .and. kprt >= 2 .and. ii == 1)pjcalc=.true. iis=ii ! Delta stepsize - change_dels=.true. sges(1)= stp(ii-1) sges(2)=(one_quad-dels)*stp(ii-1) @@ -448,7 +448,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if ! Calculate penalty values for linear terms - do i=1,ipenlin sges1=real(sges(1),r_quad) pbc(1,i)=pstart(1,i)-(2.0_r_quad*pstart(2,i)-pstart(3,i)*sges1)*sges1 @@ -475,60 +474,72 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & else it=ibin end if - call stplimq(dval(ibin),sval(ibin),sges,pbcqmin(1,ibin),pbcqmax(1,ibin),nstep,it) - end do - pbc(:,4)=zero_quad - pbc(:,5)=zero_quad - do ibin=1,nobs_bins + call stplimq(dval(ibin),sval(ibin),sges,pbcqmin,pbcqmax,nstep,it) do j=1,nstep - pbc(j,4) = pbc(j,4)+pbcqmin(j,ibin) - pbc(j,5) = pbc(j,5)+pbcqmax(j,ibin) + pbc(j,4) = pbc(j,4)+pbcqmin(j) + pbc(j,5) = pbc(j,5)+pbcqmax(j) end do + if(pjcalc)then + pj(4,ibin)=pj(4,ibin)+pbcqmin(1)+pbcqmin(ipenloc) + pj(5,ibin)=pj(5,ibin)+pbcqmax(1)+pbcqmax(ipenloc) + end if end do - if(pjcalc)then - do ibin=1,nobs_bins - pj(4,ibin)=pj(4,ibin)+pbcqmin(1,ibin)+pbcqmin(ipenloc,ibin) - pj(5,ibin)=pj(5,ibin)+pbcqmax(1,ibin)+pbcqmax(ipenloc,ibin) - end do - end if end if +!$omp parallel sections +!$omp section ! penalties for gust constraint - if(getindex(cvars2d,'gust')>0) & - call stplimg(dval(1),sval(1),sges,pbc(1,6),nstep) - if(pjcalc)pj(6,1)=pbc(1,6)+pbc(ipenloc,6) + if(gustpresent) then + call stplimg(dval(1),sval(1),sges,pbc(1,6),nstep) + if(pjcalc)pj(6,1)=pbc(1,6)+pbc(ipenloc,6) + end if +!$omp section ! penalties for vis constraint - if(getindex(cvars2d,'vis')>0) & - call stplimv(dval(1),sval(1),sges,pbc(1,7),nstep) - if(pjcalc)pj(7,1)=pbc(1,7)+pbc(ipenloc,7) + if(vispresent) then + call stplimv(dval(1),sval(1),sges,pbc(1,7),nstep) + if(pjcalc)pj(7,1)=pbc(1,7)+pbc(ipenloc,7) + end if ! penalties for pblh constraint - if(getindex(cvars2d,'pblh')>0) & - call stplimp(dval(1),sval(1),sges,pbc(1,8),nstep) - if(pjcalc)pj(8,1)=pbc(1,8)+pbc(ipenloc,8) +!$omp section + if(pblhpresent) then + call stplimp(dval(1),sval(1),sges,pbc(1,8),nstep) + if(pjcalc)pj(8,1)=pbc(1,8)+pbc(ipenloc,8) + end if ! penalties for wspd10m constraint - if(getindex(cvars2d,'wspd10m')>0) & - call stplimw10m(dval(1),sval(1),sges,pbc(1,9),nstep) - if(pjcalc)pj(9,1)=pbc(1,9)+pbc(ipenloc,9) +!$omp section + if(wspd10mpresent) then + call stplimw10m(dval(1),sval(1),sges,pbc(1,9),nstep) + if(pjcalc)pj(9,1)=pbc(1,9)+pbc(ipenloc,9) + end if ! penalties for howv constraint - if(getindex(cvars2d,'howv')>0) & - call stplimhowv(dval(1),sval(1),sges,pbc(1,10),nstep) - if(pjcalc)pj(10,1)=pbc(1,10)+pbc(ipenloc,10) +!$omp section + if(howvpresent) then + call stplimhowv(dval(1),sval(1),sges,pbc(1,10),nstep) + if(pjcalc)pj(10,1)=pbc(1,10)+pbc(ipenloc,10) + end if ! penalties for lcbas constraint - if(getindex(cvars2d,'lcbas')>0) & - call stpliml(dval(1),sval(1),sges,pbc(1,11),nstep) - if(pjcalc)pj(11,1)=pbc(1,11)+pbc(ipenloc,11) +!$omp section + if(lcbaspresent) then + call stpliml(dval(1),sval(1),sges,pbc(1,11),nstep) + if(pjcalc)pj(11,1)=pbc(1,11)+pbc(ipenloc,11) + end if ! penalties for cldch constraint - if(getindex(cvars2d,'cldch')>0) & - call stplimcldch(dval(1),sval(1),sges,pbc(1,12),nstep) - if(pjcalc)pj(12,1)=pbc(1,12)+pbc(ipenloc,12) +!$omp section + if(cldchpresent) then + call stplimcldch(dval(1),sval(1),sges,pbc(1,12),nstep) + if(pjcalc)pj(12,1)=pbc(1,12)+pbc(ipenloc,12) + end if +!$omp end parallel sections if (ljclimqc) then - if (getindex(cvars3d,'ql')>0) then +!$omp parallel sections private (ibin,it,j) +!$omp section + if (qlpresent) then if(.not.ljc4tlevs) then call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,13),nstep,ntguessig,'ql') if(pjcalc) pj(13,1)=pbc(1,13)+pbc(ipenloc,13) @@ -541,7 +552,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if call stplimqc(dval(ibin),sval(ibin),sges,pbcql(1,ibin),nstep,it,'ql') end do - pbc(:,13)=zero_quad do ibin=1,nobs_bins do j=1,nstep pbc(j,13) = pbc(j,13)+pbcql(j,ibin) @@ -554,7 +564,8 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if end if end if - if (getindex(cvars3d,'qi')>0) then +!$omp section + if (qipresent) then if(.not.ljc4tlevs) then call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,14),nstep,ntguessig,'qi') if(pjcalc) pj(14,1)=pbc(1,14)+pbc(ipenloc,14) @@ -567,7 +578,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if call stplimqc(dval(ibin),sval(ibin),sges,pbcqi(1,ibin),nstep,it,'qi') end do - pbc(:,14)=zero_quad do ibin=1,nobs_bins do j=1,nstep pbc(j,14) = pbc(j,14)+pbcqi(j,ibin) @@ -580,7 +590,8 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if end if end if - if (getindex(cvars3d,'qr')>0) then +!$omp section + if (qrpresent) then if(.not.ljc4tlevs) then call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,15),nstep,ntguessig,'qr') if(pjcalc) pj(15,1)=pbc(1,15)+pbc(ipenloc,15) @@ -593,7 +604,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if call stplimqc(dval(ibin),sval(ibin),sges,pbcqr(1,ibin),nstep,it,'qr') end do - pbc(:,15)=zero_quad do ibin=1,nobs_bins do j=1,nstep pbc(j,15) = pbc(j,15)+pbcqr(j,ibin) @@ -606,7 +616,8 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if end if end if - if (getindex(cvars3d,'qs')>0) then +!$omp section + if (qspresent) then if(.not.ljc4tlevs) then call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,16),nstep,ntguessig,'qs') if(pjcalc) pj(16,1)=pbc(1,16)+pbc(ipenloc,16) @@ -619,7 +630,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if call stplimqc(dval(ibin),sval(ibin),sges,pbcqs(1,ibin),nstep,it,'qs') end do - pbc(:,16)=zero_quad do ibin=1,nobs_bins do j=1,nstep pbc(j,16) = pbc(j,16)+pbcqs(j,ibin) @@ -632,7 +642,8 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if end if end if - if (getindex(cvars3d,'qg')>0) then +!$omp section + if (qgpresent) then if(.not.ljc4tlevs) then call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,17),nstep,ntguessig,'qg') if(pjcalc) pj(17,1)=pbc(1,17)+pbc(ipenloc,17) @@ -645,7 +656,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if call stplimqc(dval(ibin),sval(ibin),sges,pbcqg(1,ibin),nstep,it,'qg') end do - pbc(:,17)=zero_quad do ibin=1,nobs_bins do j=1,nstep pbc(j,17) = pbc(j,17)+pbcqg(j,ibin) @@ -658,33 +668,35 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if end if end if +!$omp end parallel sections end if ! ljclimqc end if + ! penalties for Jo pbcjoi=zero_quad call stpjo(dval,dbias,sval,sbias,sges,pbcjoi,nstep) pbcjo=zero_quad - do ibin=1,size(pbcjoi,3) ! == obs_bins - do j=1,size(pbcjoi,2) - do i=1,size(pbcjoi,1) + do ibin=1,nobs_bins ! == obs_bins + do j=1,nobs_type + do i=1,4 pbcjo(i,j)=pbcjo(i,j)+pbcjoi(i,j,ibin) end do end do enddo + do j=1,nobs_type + do i=1,4 + pbc(i,n0+j)=pbcjo(i,j) + end do + end do if(pjcalc)then - do ibin=1,size(pbcjoi,3) - do j=1,size(pbcjoi,2) + do ibin=1,nobs_bins + do j=1,nobs_type pj(n0+j,ibin)=pj(n0+j,ibin)+pbcjoi(ipenloc,j,ibin)+pbcjoi(1,j,ibin) end do enddo endif - do j=1,size(pbcjo,2) - do i=1,size(pbcjo,1) - pbc(i,n0+j)=pbcjo(i,j) - end do - end do ! Gather J contributions call mpl_allreduce(4,ipen,pbc) @@ -718,114 +730,91 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & ! estimate of stepsize + istp_use=ii stp(ii)=stp(ii-1) - if(cx > 1.e-20_r_kind) then - stp(ii)=stp(ii)+bx/cx ! step size estimate - else -! Check for cx <= 0. (probable error or large nonlinearity) - if(mype == 0) then - write(iout_iter,*) ' entering cx <=0 stepsize option',cx,stp(ii) - write(iout_iter,105) (bsum(i),i=1,ipen) - write(iout_iter,110) (csum(i),i=1,ipen) - end if - stp(ii)=outstp(ipenloc) - outpensave=outpen(ipenloc) - do i=1,nsteptot - if(outpen(i) < outpensave)then - stp(ii)=outstp(i) - outpensave=outpen(i) - end if - end do - if(outpensave < outpen(ipenloc))then - if(mype == 0)write(iout_iter,*) ' early termination due to cx <=0 ',cx,stp(ii) - cxterm=.true. - else -! Try different (better?) stepsize - stp(ii)=max(outstp(1),1.0e-20_r_kind) - do i=2,nsteptot - if(outstp(i) < stp(ii) .and. outstp(i) > 1.0e-20_r_kind)stp(ii)=outstp(i) - end do - stp(ii)=one_tenth_quad*stp(ii) - change_dels=.false. - end if - end if - + if(cx > 1.e-20_r_quad) stp(ii)=stp(ii)+bx/cx ! step size estimate ! estimate various terms in penalty on first iteration if(ii == 1)then - do i=1,ipen - pen_save(i)=pbc(1,i) - bsum_save(i)=bsum(i) - csum_save(i)=csum(i) - end do - pjcost(1) = pen_save(1)+pbc(ipenloc,1) ! Jb + pjcost(1) = pbc(1,1)+pbc(ipenloc,1) ! Jb pjcost(2) = zero_quad do i=1,nobs_type - pjcost(2) = pjcost(2)+pen_save(n0+i)+pbc(ipenloc,n0+i) ! Jo + pjcost(2) = pjcost(2)+pbc(1,n0+i)+pbc(ipenloc,n0+i) ! Jo end do - pjcost(3) = pen_save(2) + pen_save(3)+pbc(ipenloc,3) ! Jc + pjcost(3) = pbc(1,2) + pbc(1,3)+pbc(ipenloc,3) ! Jc pjcost(4) = zero_quad do i=4,n0 - pjcost(4) = pjcost(4) + pen_save(i)+pbc(ipenloc,i) ! Jl + pjcost(4) = pjcost(4) + pbc(1,i)+pbc(ipenloc,i) ! Jl end do penalty=pjcost(1)+pjcost(2)+pjcost(3)+pjcost(4) ! J = Jb + Jo + Jc +Jl ! Write out detailed results to iout_iter - if(mype == 0) then - write(iout_iter,100) (pen_save(i)+pbc(ipenloc,i),i=1,ipen) - if(print_verbose)then - write(iout_iter,105) (bsum(i),i=1,ipen) - write(iout_iter,110) (csum(i),i=1,ipen) - end if - end if - endif - -! estimate of change in penalty - delpen = stp(ii)*(bx - 0.5_r_quad*stp(ii)*cx ) - -! If change in penalty is very small end stepsize calculation - if(abs(delpen/penalty) < 1.e-17_r_kind) then - if(mype == 0)then - write(iout_iter,*) ' minimization has converged ' - write(iout_iter,140) ii,delpen,bx,cx,stp(ii) + if(mype == minmype) then write(iout_iter,100) (pbc(1,i)+pbc(ipenloc,i),i=1,ipen) if(print_verbose)then write(iout_iter,105) (bsum(i),i=1,ipen) write(iout_iter,110) (csum(i),i=1,ipen) end if end if - end_iter = .true. -! Finalize timer - call timer_fnl('stpcalc') - istp_use=ii - exit stepsize - end if + endif -! Check for negative stepsize (probable error or large nonlinearity) - if(stp(ii) <= zero_quad) then - if(mype == 0) then - write(iout_iter,*) ' entering negative stepsize option',stp(ii) + if(cx <= 1.e-20_r_quad .or. stp(ii) <= zero_quad)then +! Check for cx <= 0 or. stp(ii) < zero. (probable error or large nonlinearity) + if(mype == minmype) then + write(iout_iter,*) ' entering cx <=0 or stp <= 0 stepsize option',cx,stp(ii) write(iout_iter,105) (bsum(i),i=1,ipen) write(iout_iter,110) (csum(i),i=1,ipen) end if stp(ii)=outstp(ipenloc) outpensave=outpen(ipenloc) - do i=1,nsteptot + do i=1,ii if(outpen(i) < outpensave)then - stp(ii)=outstp(i) outpensave=outpen(i) + istp_use=i end if end do + if(istp_use /= ii .and. stp(istp_use) > zero_quad)then + if(mype == minmype)then + write(iout_iter,*) ' early termination due to cx or stp <=0 ',cx,stp(ii) + write(iout_iter,*) ' better stepsize found',cx,stp(ii) + end if + exit stepsize + else if(ii == istp_iter)then + write(iout_iter,*) ' early termination due to no decrease in penalty ',cx,stp(ii) + stp(istp_use)=zero + end_iter = .true. + exit stepsize + else ! Try different (better?) stepsize - if(stp(ii) <= zero_quad .and. ii /= istp_iter)then - stp(ii)=max(outstp(1),1.0e-20_r_kind) - do i=2,nsteptot - if(outstp(i) < stp(ii) .and. outstp(i) > 1.0e-20_r_kind)stp(ii)=outstp(i) - end do - stp(ii)=one_tenth_quad*stp(ii) - change_dels=.false. + stp(ii)=one_tenth_quad*max(outstp(1),1.0e-20_r_kind) + end if + else + +! estimate of change in penalty + delpen = stp(ii)*(bx - 0.5_r_quad*stp(ii)*cx ) + +! If change in penalty is very small end stepsize calculation + if(abs(delpen/penalty) < 1.e-17_r_kind) then + if(mype == minmype)then + write(iout_iter,*) ' minimization has converged ' + write(iout_iter,140) ii,delpen,bx,cx,stp(ii) + write(iout_iter,100) (pbc(1,i)+pbc(ipenloc,i),i=1,ipen) + if(print_verbose)then + write(iout_iter,105) (bsum(i),i=1,ipen) + write(iout_iter,110) (csum(i),i=1,ipen) + end if + end if + end_iter = .true. +! Finalize timer + call timer_fnl('stpcalc') + exit stepsize end if +! Check for convergence in stepsize estimation + stprat(ii)=zero + if(stp(ii) > zero_quad)stprat(ii)=abs((stp(ii)-stp(ii-1))/stp(ii)) + if(stprat(ii) < 1.e-4_r_kind) exit stepsize + dels = one_tenth_quad*dels end if 100 format(' J=',3e25.18/,(3x,3e25.18)) @@ -839,31 +828,21 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & 141 format('***WARNING*** reduced penalty not found in search direction',/, & ' - probable error',(5e25.18)) -! Check for convergence in stepsize estimation - istp_use=ii - if(cxterm) exit stepsize - stprat(ii)=zero - if(stp(ii) > zero)then - stprat(ii)=abs((stp(ii)-stp(ii-1))/stp(ii)) - end if - if(stprat(ii) < 1.e-4_r_kind) exit stepsize - if(change_dels)dels = one_tenth_quad*dels ! If stepsize estimate has not converged use best stepsize estimate or zero if( ii == istp_iter)then stp(ii)=outstp(ipenloc) outpensave=outpen(ipenloc) - ifound=.false. ! Find best stepsize to this point do i=1,nsteptot if(outpen(i) < outpensave)then stp(ii)=outstp(i) outpensave=outpen(i) - ifound=.true. + istp_use=i end if end do - if(ifound)exit stepsize + if(istp_use /= istp_iter)exit stepsize ! If no best stepsize set to zero and end minimization - if(mype == 0)then + if(mype == minmype)then write(iout_iter,141)(outpen(i),i=1,nsteptot) end if end_iter = .true. @@ -874,39 +853,41 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end do stepsize if(kprt >= 2 .and. iter == 0)then call mpl_allreduce(ipen,nobs_bins,pj) - if(mype == 0)call prnt_j(pj,n0,ipen,kprt) + if(mype == minmype)call prnt_j(pj,n0,ipen,kprt) end if stpinout=stp(istp_use) ! Estimate terms in penalty - if(mype == 0 .and. print_verbose)then - do i=1,ipen - pen_est(i)=pen_save(i)-(stpinout-stp(0))*(2.0_r_quad*bsum_save(i)- & - (stpinout-stp(0))*csum_save(i)) + if(mype == minmype)then + if(print_verbose)then + do i=1,ipen + pen_est(i)=pbc(1,i)-(stpinout-stp(0))*(2.0_r_quad*bsum(i)- & + (stpinout-stp(0))*csum(i)) + end do + write(iout_iter,101) (pbc(1,i)-pen_est(i),i=1,ipen) + end if + pjcostnew(1) = pbc(1,1) ! Jb + pjcostnew(3) = pbc(1,2)+pbc(1,3) ! Jc + pjcostnew(4)=zero + do i=4,n0 + pjcostnew(4) = pjcostnew(4) + pbc(1,i) ! Jl end do - write(iout_iter,101) (pbc(1,i)-pen_est(i),i=1,ipen) - end if - pjcostnew(1) = pbc(1,1) ! Jb - pjcostnew(3) = pbc(1,2)+pbc(1,3) ! Jc - pjcostnew(4)=zero - do i=4,n0 - pjcostnew(4) = pjcostnew(4) + pbc(1,i) ! Jl - end do - pjcostnew(2) = zero - do i=1,nobs_type - pjcostnew(2) = pjcostnew(2)+pbc(1,n0+i) ! Jo - end do - penaltynew=pjcostnew(1)+pjcostnew(2)+pjcostnew(3)+pjcostnew(4) + pjcostnew(2) = zero + do i=1,nobs_type + pjcostnew(2) = pjcostnew(2)+pbc(1,n0+i) ! Jo + end do + penaltynew=pjcostnew(1)+pjcostnew(2)+pjcostnew(3)+pjcostnew(4) - if(mype == 0 .and. print_verbose)then - write(iout_iter,200) (stp(i),i=0,istp_use) - write(iout_iter,199) (stprat(ii),ii=1,istp_use) - write(iout_iter,201) (outstp(i),i=1,nsteptot) - write(iout_iter,202) (outpen(i)-outpen(4),i=1,nsteptot) + if(print_verbose)then + write(iout_iter,200) (stp(i),i=0,istp_use) + write(iout_iter,199) (stprat(ii),ii=1,istp_use) + write(iout_iter,201) (outstp(i),i=1,nsteptot) + write(iout_iter,202) (outpen(i)-outpen(4),i=1,nsteptot) + end if end if ! Check for final stepsize negative (probable error) if(stpinout <= zero)then - if(mype == 0)then + if(mype == minmype)then write(iout_iter,130) ii,bx,cx,stp(ii) write(iout_iter,105) (bsum(i),i=1,ipen) write(iout_iter,110) (csum(i),i=1,ipen) @@ -926,19 +907,22 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & endif ! Update solution - do i=1,nrclen - sbias%values(i)=sbias%values(i)+stpinout*dbias%values(i) - end do !$omp parallel do schedule(dynamic,1) private(i,ii) - do ii=1,nobs_bins - do i=1,sval(ii)%ndim - sval(ii)%values(i)=sval(ii)%values(i)+stpinout*dval(ii)%values(i) - end do - end do -!DIR$ IVDEP - do i=1,nclen - xhatsave%values(i)=xhatsave%values(i)+stpinout*dirx%values(i) - yhatsave%values(i)=yhatsave%values(i)+stpinout*diry%values(i) + do ii=1,nobs_bins+2 + if(ii <= nobs_bins)then + do i=1,sval(ii)%ndim + sval(ii)%values(i)=sval(ii)%values(i)+stpinout*dval(ii)%values(i) + end do + else if(ii == nobs_bins+1)then + do i=1,nrclen + sbias%values(i)=sbias%values(i)+stpinout*dbias%values(i) + end do + else + do i=1,nclen + xhatsave%values(i)=xhatsave%values(i)+stpinout*dirx%values(i) + yhatsave%values(i)=yhatsave%values(i)+stpinout*diry%values(i) + end do + end if end do @@ -975,6 +959,7 @@ subroutine prnt_j(pj,n0,ipen,kprt) use mpimod, only: mype use gsi_obOperTypeManager, only: nobs_type => obOper_count use gsi_obOperTypeManager, only: obOper_typeInfo + use gridmod, only: minmype real(r_quad),dimension(ipen,nobs_bins),intent(in ) :: pj integer(i_kind) ,intent(in ) :: n0,ipen,kprt @@ -986,7 +971,7 @@ subroutine prnt_j(pj,n0,ipen,kprt) integer(i_kind) :: ii,jj character(len=20) :: ctype(ipen) - if(kprt <=0 .or. mype /=0)return + if(kprt <=0 .or. mype /=minmype)return ctype(:)=".unknown." ctype(1)='background ' ctype(2)=' ' diff --git a/src/gsi/stpgps.f90 b/src/gsi/stpgps.f90 index f55e9f4292..d357df1c05 100644 --- a/src/gsi/stpgps.f90 +++ b/src/gsi/stpgps.f90 @@ -107,12 +107,13 @@ subroutine stpgps(gpshead,rval,sval,out,sges,nstep) real(r_kind),dimension(max(1,nstep)),intent(in ) :: sges ! Declare local variables - integer(i_kind) j,kk,ier,istatus - integer(i_kind),dimension(nsig):: i1,i2,i3,i4 + integer(i_kind):: j,kk,ier,istatus + integer(i_kind):: i1,i2,i3,i4 real(r_kind) :: val,val2 real(r_kind) :: w1,w2,w3,w4 real(r_kind) :: q_TL,p_TL,t_TL real(r_kind) :: rq_TL,rp_TL,rt_TL + real(r_kind),dimension(nsig) :: valk2,valk real(r_kind),pointer,dimension(:) :: st,sq real(r_kind),pointer,dimension(:) :: rt,rq real(r_kind),pointer,dimension(:) :: sp @@ -149,34 +150,33 @@ subroutine stpgps(gpshead,rval,sval,out,sges,nstep) val2=-gpsptr%res if(nstep > 0)then - do j=1,nsig - i1(j)= gpsptr%ij(1,j) - i2(j)= gpsptr%ij(2,j) - i3(j)= gpsptr%ij(3,j) - i4(j)= gpsptr%ij(4,j) - enddo w1=gpsptr%wij(1) w2=gpsptr%wij(2) w3=gpsptr%wij(3) w4=gpsptr%wij(4) - val=zero - - +!$omp parallel do schedule(dynamic,1) private(j,t_TL,rt_TL,q_TL,rq_TL,p_TL,rp_TL,i1,i2,i3,i4) do j=1,nsig - t_TL =w1* st(i1(j))+w2* st(i2(j))+w3* st(i3(j))+w4* st(i4(j)) - rt_TL=w1* rt(i1(j))+w2* rt(i2(j))+w3* rt(i3(j))+w4* rt(i4(j)) - q_TL =w1* sq(i1(j))+w2* sq(i2(j))+w3* sq(i3(j))+w4* sq(i4(j)) - rq_TL=w1* rq(i1(j))+w2* rq(i2(j))+w3* rq(i3(j))+w4* rq(i4(j)) - p_TL =w1* sp(i1(j))+w2* sp(i2(j))+w3* sp(i3(j))+w4* sp(i4(j)) - rp_TL=w1* rp(i1(j))+w2* rp(i2(j))+w3* rp(i3(j))+w4* rp(i4(j)) - val2 = val2 + t_tl*gpsptr%jac_t(j)+ q_tl*gpsptr%jac_q(j)+p_tl*gpsptr%jac_p(j) - val = val + rt_tl*gpsptr%jac_t(j)+rq_tl*gpsptr%jac_q(j)+rp_tl*gpsptr%jac_p(j) - + i1= gpsptr%ij(1,j) + i2= gpsptr%ij(2,j) + i3= gpsptr%ij(3,j) + i4= gpsptr%ij(4,j) + t_TL =w1* st(i1)+w2* st(i2)+w3* st(i3)+w4* st(i4) + rt_TL=w1* rt(i1)+w2* rt(i2)+w3* rt(i3)+w4* rt(i4) + q_TL =w1* sq(i1)+w2* sq(i2)+w3* sq(i3)+w4* sq(i4) + rq_TL=w1* rq(i1)+w2* rq(i2)+w3* rq(i3)+w4* rq(i4) + p_TL =w1* sp(i1)+w2* sp(i2)+w3* sp(i3)+w4* sp(i4) + rp_TL=w1* rp(i1)+w2* rp(i2)+w3* rp(i3)+w4* rp(i4) + valk2(j) = t_tl*gpsptr%jac_t(j)+ q_tl*gpsptr%jac_q(j)+ p_tl*gpsptr%jac_p(j) + valk(j) = rt_tl*gpsptr%jac_t(j)+rq_tl*gpsptr%jac_q(j)+rp_tl*gpsptr%jac_p(j) enddo - + val=zero + do j=1,nsig + val2 = val2 + valk2(j) + val = val + valk(j) + enddo ! penalty and gradient do kk=1,nstep diff --git a/src/gsi/stpjo.f90 b/src/gsi/stpjo.f90 index b0ff730823..0f80d9b4a2 100644 --- a/src/gsi/stpjo.f90 +++ b/src/gsi/stpjo.f90 @@ -267,8 +267,6 @@ subroutine stpjo(dval,dbias,xval,xbias,sges,pbcjo,nstep) use m_obsdiags, only: obOper_destroy use gsi_obOperTypeManager, only: obOper_typeInfo - use intradmod, only: setrad - use mpeu_util, only: perr,die use mpeu_util, only: tell use mpeu_mpif, only: MPI_comm_world @@ -290,7 +288,6 @@ subroutine stpjo(dval,dbias,xval,xbias,sges,pbcjo,nstep) class(obOper),pointer:: it_obOper !************************************************************************************ - call setrad(xval(1)) !$omp parallel do schedule(dynamic,1) private(ll,mm,ib,it_obOper) do mm=1,stpcnt diff --git a/src/gsi/stprad.f90 b/src/gsi/stprad.f90 index 0def855d61..20fe0dd1a9 100644 --- a/src/gsi/stprad.f90 +++ b/src/gsi/stprad.f90 @@ -110,7 +110,7 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) use gsi_metguess_mod, only: gsi_metguess_get use mpeu_util, only: getindex use intradmod, only: luseu,lusev,luset,luseq,lusecw,luseoz,luseqg,luseqh,luseqi,luseql, & - luseqr,luseqs + luseqr,luseqs,lusesst use intradmod, only: itsen,iqv,ioz,icw,ius,ivs,isst,iqg,iqh,iqi,iql,iqr,iqs,lgoback use m_obsNode, only: obsNode use m_radNode, only: radNode @@ -128,14 +128,15 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) type(gsi_bundle),intent(in) :: xval ! Declare local variables - integer(i_kind) istatus - integer(i_kind) nn,n,ic,k,nx,j1,j2,j3,j4,kk, mm, ic1,ncr + integer(i_kind) istatus,icx + integer(i_kind) nn,n,ic,k,nx,j1,j2,j3,j4,kk,mm,ncr real(r_kind) val2,val,w1,w2,w3,w4 real(r_kind),dimension(nsigradjac):: tdir,rdir real(r_kind) cg_rad,wgross,wnotgross integer(i_kind),dimension(nsig) :: j1n,j2n,j3n,j4n - real(r_kind),dimension(max(1,nstep)) :: term,rad + real(r_kind),dimension(max(1,nstep)) :: rad type(radNode), pointer :: radptr + real(r_kind),allocatable,dimension(:,:) :: term real(r_kind),allocatable,dimension(:) :: biasvects real(r_kind),allocatable,dimension(:) :: biasvectr real(r_kind),pointer,dimension(:) :: rt,rq,rcw,roz,ru,rv,rqg,rqh,rqi,rql,rqr,rqs @@ -150,34 +151,59 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) if(lgoback)return -! Retrieve pointers - call gsi_bundlegetpointer(xval,'u', su, istatus) - call gsi_bundlegetpointer(xval,'v', sv, istatus) - call gsi_bundlegetpointer(xval,'tsen' ,st, istatus) - call gsi_bundlegetpointer(xval,'q', sq, istatus) - call gsi_bundlegetpointer(xval,'cw' ,scw,istatus) - call gsi_bundlegetpointer(xval,'oz' ,soz,istatus) - call gsi_bundlegetpointer(xval,'sst',sst,istatus) - call gsi_bundlegetpointer(xval,'qg' ,sqg,istatus) - call gsi_bundlegetpointer(xval,'qh' ,sqh,istatus) - call gsi_bundlegetpointer(xval,'qi' ,sqi,istatus) - call gsi_bundlegetpointer(xval,'ql' ,sql,istatus) - call gsi_bundlegetpointer(xval,'qr' ,sqr,istatus) - call gsi_bundlegetpointer(xval,'qs' ,sqs,istatus) - - call gsi_bundlegetpointer(dval,'u', ru, istatus) - call gsi_bundlegetpointer(dval,'v', rv, istatus) - call gsi_bundlegetpointer(dval,'tsen' ,rt, istatus) - call gsi_bundlegetpointer(dval,'q', rq, istatus) - call gsi_bundlegetpointer(dval,'cw' ,rcw,istatus) - call gsi_bundlegetpointer(dval,'oz' ,roz,istatus) - call gsi_bundlegetpointer(dval,'sst',rst,istatus) - call gsi_bundlegetpointer(dval,'qg' ,rqg,istatus) - call gsi_bundlegetpointer(dval,'qh' ,rqh,istatus) - call gsi_bundlegetpointer(dval,'qi' ,rqi,istatus) - call gsi_bundlegetpointer(dval,'ql' ,rql,istatus) - call gsi_bundlegetpointer(dval,'qr' ,rqr,istatus) - call gsi_bundlegetpointer(dval,'qs' ,rqs,istatus) +! Retrieve pointers for used variables + if(luseu)then + call gsi_bundlegetpointer(dval,'u', ru, istatus) + call gsi_bundlegetpointer(xval,'u', su, istatus) + end if + if(lusev)then + call gsi_bundlegetpointer(xval,'v', sv, istatus) + call gsi_bundlegetpointer(dval,'v', rv, istatus) + end if + if(luset)then + call gsi_bundlegetpointer(xval,'tsen' ,st, istatus) + call gsi_bundlegetpointer(dval,'tsen' ,rt, istatus) + end if + if(luseq)then + call gsi_bundlegetpointer(xval,'q', sq, istatus) + call gsi_bundlegetpointer(dval,'q', rq, istatus) + end if + if(lusecw)then + call gsi_bundlegetpointer(xval,'cw' ,scw,istatus) + call gsi_bundlegetpointer(dval,'cw' ,rcw,istatus) + end if + if(luseoz)then + call gsi_bundlegetpointer(xval,'oz' ,soz,istatus) + call gsi_bundlegetpointer(dval,'oz' ,roz,istatus) + end if + if(lusesst)then + call gsi_bundlegetpointer(xval,'sst',sst,istatus) + call gsi_bundlegetpointer(dval,'sst',rst,istatus) + end if + if(luseqg)then + call gsi_bundlegetpointer(xval,'qg' ,sqg,istatus) + call gsi_bundlegetpointer(dval,'qg' ,rqg,istatus) + end if + if(luseqh)then + call gsi_bundlegetpointer(xval,'qh' ,sqh,istatus) + call gsi_bundlegetpointer(dval,'qh' ,rqh,istatus) + end if + if(luseqi)then + call gsi_bundlegetpointer(xval,'qi' ,sqi,istatus) + call gsi_bundlegetpointer(dval,'qi' ,rqi,istatus) + end if + if(luseql)then + call gsi_bundlegetpointer(xval,'ql' ,sql,istatus) + call gsi_bundlegetpointer(dval,'ql' ,rql,istatus) + end if + if(luseqr)then + call gsi_bundlegetpointer(xval,'qr' ,sqr,istatus) + call gsi_bundlegetpointer(dval,'qr' ,rqr,istatus) + end if + if(luseqs)then + call gsi_bundlegetpointer(xval,'qs' ,sqs,istatus) + call gsi_bundlegetpointer(dval,'qs' ,rqs,istatus) + end if tdir=zero @@ -187,118 +213,117 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) do while(associated(radptr)) if(radptr%luse)then if(nstep > 0)then - j1=radptr%ij(1) - j2=radptr%ij(2) - j3=radptr%ij(3) - j4=radptr%ij(4) w1=radptr%wij(1) w2=radptr%wij(2) w3=radptr%wij(3) w4=radptr%wij(4) - if(luseu)then - tdir(ius+1)=w1* su(j1) + w2* su(j2) + w3* su(j3) + w4* su(j4) - rdir(ius+1)=w1* ru(j1) + w2* ru(j2) + w3* ru(j3) + w4* ru(j4) - endif - if(lusev)then - tdir(ivs+1)=w1* sv(j1) + w2* sv(j2) + w3* sv(j3) + w4* sv(j4) - rdir(ivs+1)=w1* rv(j1) + w2* rv(j2) + w3* rv(j3) + w4* rv(j4) - endif - if (isst>=0) then - tdir(isst+1)=w1*sst(j1) + w2*sst(j2) + w3*sst(j3) + w4*sst(j4) - rdir(isst+1)=w1*rst(j1) + w2*rst(j2) + w3*rst(j3) + w4*rst(j4) - end if - j1n(1) = j1 - j2n(1) = j2 - j3n(1) = j3 - j4n(1) = j4 + j1n(1) = radptr%ij(1) + j2n(1) = radptr%ij(2) + j3n(1) = radptr%ij(3) + j4n(1) = radptr%ij(4) do n=2,nsig j1n(n) = j1n(n-1)+latlon11 j2n(n) = j2n(n-1)+latlon11 j3n(n) = j3n(n-1)+latlon11 j4n(n) = j4n(n-1)+latlon11 enddo - do n=1,nsig - j1 = j1n(n) - j2 = j2n(n) - j3 = j3n(n) - j4 = j4n(n) - -! Input state vector -! Input search direction vector - if(luset)then - tdir(itsen+n)=w1* st(j1) +w2* st(j2) + w3* st(j3) +w4* st(j4) - rdir(itsen+n)=w1* rt(j1) +w2* rt(j2) + w3* rt(j3) +w4* rt(j4) - endif - if(luseq)then - tdir(iqv+n)=w1* sq(j1) +w2* sq(j2) + w3* sq(j3) +w4* sq(j4) - rdir(iqv+n)=w1* rq(j1) +w2* rq(j2) + w3* rq(j3) +w4* rq(j4) - endif - if (luseoz) then - tdir(ioz+n)=w1*soz(j1)+w2*soz(j2)+ w3*soz(j3)+w4*soz(j4) - rdir(ioz+n)=w1*roz(j1)+w2*roz(j2)+ w3*roz(j3)+w4*roz(j4) - end if - if (lusecw) then - tdir(icw+n)=w1*scw(j1)+w2*scw(j2)+ w3*scw(j3)+w4*scw(j4) - rdir(icw+n)=w1*rcw(j1)+w2*rcw(j2)+ w3*rcw(j3)+w4*rcw(j4) - end if - if (luseqg) then - tdir(iqg+n)=w1*sqg(j1)+w2*sqg(j2)+ w3*sqg(j3)+w4*sqg(j4) - rdir(iqg+n)=w1*rqg(j1)+w2*rqg(j2)+ w3*rqg(j3)+w4*rqg(j4) - end if - if (luseqh) then - tdir(iqh+n)=w1*sqh(j1)+w2*sqh(j2)+ w3*sqh(j3)+w4*sqh(j4) - rdir(iqh+n)=w1*rqh(j1)+w2*rqh(j2)+ w3*rqh(j3)+w4*rqh(j4) - end if - if (luseqi) then - tdir(iqi+n)=w1*sqi(j1)+w2*sqi(j2)+ w3*sqi(j3)+w4*sqi(j4) - rdir(iqi+n)=w1*rqi(j1)+w2*rqi(j2)+ w3*rqi(j3)+w4*rqi(j4) - end if - if (luseql) then - tdir(iql+n)=w1*sql(j1)+w2*sql(j2)+ w3*sql(j3)+w4*sql(j4) - rdir(iql+n)=w1*rql(j1)+w2*rql(j2)+ w3*rql(j3)+w4*rql(j4) - end if - if (luseqr) then - tdir(iqr+n)=w1*sqr(j1)+w2*sqr(j2)+ w3*sqr(j3)+w4*sqr(j4) - rdir(iqr+n)=w1*rqr(j1)+w2*rqr(j2)+ w3*rqr(j3)+w4*rqr(j4) + allocate(biasvects(radptr%nchan)) + allocate(biasvectr(radptr%nchan)) + allocate(term(max(1,nstep),radptr%nchan)) + +!$omp parallel do schedule(dynamic,1) private(n,j1,j2,j3,j4,icx,vals_quad,valr_quad,nx) + do n=1,max(nsig,radptr%nchan) + if(n <= nsig)then + j1 = j1n(n) + j2 = j2n(n) + j3 = j3n(n) + j4 = j4n(n) + if(n == 1)then + if(luseu)then + tdir(ius+1)=w1* su(j1) + w2* su(j2) + w3* su(j3) + w4* su(j4) + rdir(ius+1)=w1* ru(j1) + w2* ru(j2) + w3* ru(j3) + w4* ru(j4) + endif + if(lusev)then + tdir(ivs+1)=w1* sv(j1) + w2* sv(j2) + w3* sv(j3) + w4* sv(j4) + rdir(ivs+1)=w1* rv(j1) + w2* rv(j2) + w3* rv(j3) + w4* rv(j4) + endif + if (lusesst) then + tdir(isst+1)=w1*sst(j1) + w2*sst(j2) + w3*sst(j3) + w4*sst(j4) + rdir(isst+1)=w1*rst(j1) + w2*rst(j2) + w3*rst(j3) + w4*rst(j4) + end if + end if + +! Input state vector +! Input search direction vector + if(luset)then + tdir(itsen+n)=w1* st(j1) +w2* st(j2) + w3* st(j3) +w4* st(j4) + rdir(itsen+n)=w1* rt(j1) +w2* rt(j2) + w3* rt(j3) +w4* rt(j4) + endif + if(luseq)then + tdir(iqv+n)=w1* sq(j1) +w2* sq(j2) + w3* sq(j3) +w4* sq(j4) + rdir(iqv+n)=w1* rq(j1) +w2* rq(j2) + w3* rq(j3) +w4* rq(j4) + endif + if (luseoz) then + tdir(ioz+n)=w1*soz(j1)+w2*soz(j2)+ w3*soz(j3)+w4*soz(j4) + rdir(ioz+n)=w1*roz(j1)+w2*roz(j2)+ w3*roz(j3)+w4*roz(j4) + end if + if (lusecw) then + tdir(icw+n)=w1*scw(j1)+w2*scw(j2)+ w3*scw(j3)+w4*scw(j4) + rdir(icw+n)=w1*rcw(j1)+w2*rcw(j2)+ w3*rcw(j3)+w4*rcw(j4) + end if + if (luseqg) then + tdir(iqg+n)=w1*sqg(j1)+w2*sqg(j2)+ w3*sqg(j3)+w4*sqg(j4) + rdir(iqg+n)=w1*rqg(j1)+w2*rqg(j2)+ w3*rqg(j3)+w4*rqg(j4) + end if + if (luseqh) then + tdir(iqh+n)=w1*sqh(j1)+w2*sqh(j2)+ w3*sqh(j3)+w4*sqh(j4) + rdir(iqh+n)=w1*rqh(j1)+w2*rqh(j2)+ w3*rqh(j3)+w4*rqh(j4) + end if + if (luseqi) then + tdir(iqi+n)=w1*sqi(j1)+w2*sqi(j2)+ w3*sqi(j3)+w4*sqi(j4) + rdir(iqi+n)=w1*rqi(j1)+w2*rqi(j2)+ w3*rqi(j3)+w4*rqi(j4) + end if + if (luseql) then + tdir(iql+n)=w1*sql(j1)+w2*sql(j2)+ w3*sql(j3)+w4*sql(j4) + rdir(iql+n)=w1*rql(j1)+w2*rql(j2)+ w3*rql(j3)+w4*rql(j4) + end if + if (luseqr) then + tdir(iqr+n)=w1*sqr(j1)+w2*sqr(j2)+ w3*sqr(j3)+w4*sqr(j4) + rdir(iqr+n)=w1*rqr(j1)+w2*rqr(j2)+ w3*rqr(j3)+w4*rqr(j4) + end if + if (luseqs) then + tdir(iqs+n)=w1*sqs(j1)+w2*sqs(j2)+ w3*sqs(j3)+w4*sqs(j4) + rdir(iqs+n)=w1*rqs(j1)+w2*rqs(j2)+ w3*rqs(j3)+w4*rqs(j4) + end if end if - if (luseqs) then - tdir(iqs+n)=w1*sqs(j1)+w2*sqs(j2)+ w3*sqs(j3)+w4*sqs(j4) - rdir(iqs+n)=w1*rqs(j1)+w2*rqs(j2)+ w3*rqs(j3)+w4*rqs(j4) + if(n <= radptr%nchan)then + icx=radptr%icx(n) + vals_quad = zero_quad + valr_quad = zero_quad + do nx=1,npred + vals_quad = vals_quad + spred(nx,icx)*radptr%pred(nx,n) + valr_quad = valr_quad + rpred(nx,icx)*radptr%pred(nx,n) + end do + biasvects(n) = vals_quad + biasvectr(n) = valr_quad end if - end do - end if - if(nstep > 0)then - allocate(biasvects(radptr%nchan)) - allocate(biasvectr(radptr%nchan)) - do nn=1,radptr%nchan - ic1=radptr%icx(nn) - vals_quad = zero_quad - valr_quad = zero_quad - do nx=1,npred - vals_quad = vals_quad + spred(nx,ic1)*radptr%pred(nx,nn) - valr_quad = valr_quad + rpred(nx,ic1)*radptr%pred(nx,nn) - end do - biasvects(nn) = vals_quad - biasvectr(nn) = valr_quad - end do endif - ncr=0 +!$omp parallel do schedule(dynamic,1) private(nn,ic,mm,ncr,k,kk,rad,val,val2,cg_rad,wnotgross,wgross) do nn=1,radptr%nchan - val2=-radptr%res(nn) - if(nstep > 0)then val = zero + val2=-radptr%res(nn) ! contribution from bias corection ic=radptr%icx(nn) if(radptr%use_corr_obs) then do mm=1,nn - ncr=ncr+1 + ncr=radptr%iccerr(nn)+mm val2=val2+radptr%rsqrtinv(ncr)*biasvects(mm) val =val +radptr%rsqrtinv(ncr)*biasvectr(mm) end do @@ -318,12 +343,12 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) rad(kk)=val2+sges(kk)*val end do else - rad(kk)= val2 + rad(1)= -radptr%res(nn) end if ! calculate contribution to J do kk=1,max(1,nstep) - term(kk) = radptr%err2(nn)*rad(kk)*rad(kk) + term(kk,nn) = radptr%err2(nn)*rad(kk)*rad(kk) end do ! Modify penalty term if nonlinear QC @@ -333,18 +358,23 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) wnotgross= one-pg_rad(ic)*varqc_iter wgross = varqc_iter*pg_rad(ic)*cg_rad/wnotgross do kk=1,max(1,nstep) - term(kk) = -two*log((exp(-half*term(kk) ) + wgross)/(one+wgross)) + term(kk,nn) = -two*log((exp(-half*term(kk,nn) ) + wgross)/(one+wgross)) end do endif - out(1) = out(1) + term(1)*radptr%raterr2(nn) + end do + + deallocate(biasvects, biasvectr) + + do nn=1,radptr%nchan + out(1) = out(1) + term(1,nn)*radptr%raterr2(nn) do kk=2,nstep - out(kk) = out(kk) + (term(kk)-term(1))*radptr%raterr2(nn) + out(kk) = out(kk) + (term(kk,nn)-term(1,nn))*radptr%raterr2(nn) end do end do - if(nstep > 0) deallocate(biasvects, biasvectr) + deallocate(term) end if diff --git a/src/gsi/stpsst.f90 b/src/gsi/stpsst.f90 index 222b67862c..765676010b 100644 --- a/src/gsi/stpsst.f90 +++ b/src/gsi/stpsst.f90 @@ -101,13 +101,13 @@ subroutine stpsst(ssthead,rval,sval,out,sges,nstep) real(r_kind) pg_sst real(r_kind),pointer,dimension(:) :: ssst real(r_kind),pointer,dimension(:) :: rsst - real(r_kind) tdir,rdir type(sstNode), pointer :: sstptr out=zero_quad ! If no sst data return if(.not. associated(ssthead))return + if(.not. nst_gsi > 2 ) return ! Retrieve pointers ! Simply return if any pointer not found @@ -129,15 +129,12 @@ subroutine stpsst(ssthead,rval,sval,out,sges,nstep) w3=sstptr%wij(3) w4=sstptr%wij(4) - if ( nst_gsi > 2 .and. (sstptr%tz_tr > zero .and. sstptr%tz_tr <= one) ) then - tdir = w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) - rdir = w1*rsst(j1)+w2*rsst(j2)+w3*rsst(j3)+w4*rsst(j4) - val = sstptr%tz_tr*rdir - val2 = sstptr%tz_tr*tdir - sstptr%res - else - val =w1*rsst(j1)+w2*rsst(j2)+w3*rsst(j3)+w4*rsst(j4) - val2=w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4)-sstptr%res - endif + val =w1*rsst(j1)+w2*rsst(j2)+w3*rsst(j3)+w4*rsst(j4) + val2=w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) + + val = sstptr%tz_tr*val + val2 = sstptr%tz_tr*val2 + val2=val2-sstptr%res do kk=1,nstep sst=val2+sges(kk)*val diff --git a/src/gsi/stpt.f90 b/src/gsi/stpt.f90 index 27f5385ac1..5911d87b9d 100644 --- a/src/gsi/stpt.f90 +++ b/src/gsi/stpt.f90 @@ -184,7 +184,6 @@ subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred) w6=tptr%wij(6) w7=tptr%wij(7) w8=tptr%wij(8) -! Note time derivative stuff not consistent for virtual temperature if(tptr%tv_ob)then val= w1*rtv(j1)+w2*rtv(j2)+w3*rtv(j3)+w4*rtv(j4)+ & @@ -208,9 +207,6 @@ subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred) end do end if - do kk=1,nstep - tt(kk)=val2+sges(kk)*val - end do if(tptr%use_sfc_model) then @@ -229,8 +225,9 @@ subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred) valv2=w1* sv(j1)+w2* sv(j2)+w3* sv(j3)+w4* sv(j4) valp =w1* rp(j1)+w2* rp(j2)+w3* rp(j3)+w4* rp(j4) valp2=w1* sp(j1)+w2* sp(j2)+w3* sp(j3)+w4* sp(j4) + do kk=1,nstep - ts_prime=tt(kk) + ts_prime=val2+sges(kk)*val tg_prime=valsst2+sges(kk)*valsst qs_prime=valq2+sges(kk)*valq us_prime=valu2+sges(kk)*valu @@ -239,14 +236,18 @@ subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred) tt(kk)=psfc_prime*tptr%tlm_tsfc(1) + tg_prime*tptr%tlm_tsfc(2) + & ts_prime *tptr%tlm_tsfc(3) + qs_prime*tptr%tlm_tsfc(4) + & - us_prime *tptr%tlm_tsfc(5) + vs_prime*tptr%tlm_tsfc(6) + us_prime *tptr%tlm_tsfc(5) + vs_prime*tptr%tlm_tsfc(6) - & + tptr%res + end do + + else + + do kk=1,nstep + tt(kk)=val2+sges(kk)*val-tptr%res end do end if - do kk=1,nstep - tt(kk)=tt(kk)-tptr%res - end do else tt(1)=tptr%res end if diff --git a/src/gsi/vqc_int.f90 b/src/gsi/vqc_int.f90 index 714ee23ea3..12abc53b35 100644 --- a/src/gsi/vqc_int.f90 +++ b/src/gsi/vqc_int.f90 @@ -27,12 +27,12 @@ subroutine vqc_int(error2,rat_error2,t_pgv,cg_tv,var_jbv,ibv,ikv,valv,gradv) real(r_kind), intent(out) :: gradv ! Declare local variables - real(r_kind) wnotgross,wgross,g_nvqc,w_nvqc,p0,qq + real(r_kind) wnotgross,wgross,g_nvqc,w_nvqc,p0,qq - if (vqc .and. nlnqc_iter .and. t_pgv > tiny_r_kind .and. & + if (vqc .and. nlnqc_iter .and. t_pgv > tiny_r_kind .and. & cg_tv > tiny_r_kind) then wnotgross= one-t_pgv wgross =t_pgv*cg_tv/wnotgross diff --git a/src/gsi/vqc_stp.f90 b/src/gsi/vqc_stp.f90 index 1c8f296853..04d9a91245 100644 --- a/src/gsi/vqc_stp.f90 +++ b/src/gsi/vqc_stp.f90 @@ -41,7 +41,7 @@ subroutine vqc_stp(pen_v,nstep_v,tpg_v,cgt_v,& ! Note: if wgross=0 (no gross error, then wnotgross=1 and this ! all reduces to the linear case (no qc) - if (vqc .and. nlnqc_iter .and. tpg_v > tiny_r_kind .and. cgt_v >tiny_r_kind) then + if (vqc .and. nlnqc_iter .and. tpg_v > tiny_r_kind .and. cgt_v >tiny_r_kind) then wnotgross= one-tpg_v wgross =tpg_v*cgt_v/wnotgross do kk=1,max(1,nstep_v) diff --git a/src/gsi/write_incr.f90 b/src/gsi/write_incr.f90 index b22be8de30..9adb150863 100644 --- a/src/gsi/write_incr.f90 +++ b/src/gsi/write_incr.f90 @@ -26,7 +26,7 @@ module write_incr contains - subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) + subroutine write_fv3_inc_ (grd,filename,mype_out,gfs_bundle,ibin) !$$$ subprogram documentation block ! . . . @@ -94,13 +94,13 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) use state_vectors, only: svars3d use mpeu_util, only: getindex + use control2state_mod, only: control2state implicit none ! !INPUT PARAMETERS: type(sub2grid_info), intent(in) :: grd - type(spec_vars), intent(in) :: sp_a character(len=24), intent(in) :: filename ! file to open and write to integer(i_kind), intent(in) :: mype_out ! mpi task to write output file type(gsi_bundle), intent(in) :: gfs_bundle diff --git a/src/gsi/xhat_vordivmod.f90 b/src/gsi/xhat_vordivmod.f90 index bff52aa9d4..e271fb9fb3 100644 --- a/src/gsi/xhat_vordivmod.f90 +++ b/src/gsi/xhat_vordivmod.f90 @@ -77,6 +77,8 @@ subroutine init_ allocate(xhat_vor(lat2,lon2,nsig,nobs_bins)) allocate(xhat_div(lat2,lon2,nsig,nobs_bins)) + xhat_vor=zero + xhat_div=zero end subroutine init_ subroutine clean_ @@ -146,18 +148,6 @@ subroutine calc_(sval) !******************************************************************************* -! Initialize local arrays - do ii=1,nobs_bins - do k=1,nsig - do j=1,lon2 - do i=1,lat2 - xhat_vor(i,j,k,ii) = zero - xhat_div(i,j,k,ii) = zero - end do - end do - end do - end do - ! The GSI analyzes stream function (sf) and velocity potential (vp). ! Wind field observations are in terms of zonal (u) and meridional ! (v) wind components or wind speed. Thus, the GSI carries wind From 726cc8dc16279b204deb146b584296246a7eb182 Mon Sep 17 00:00:00 2001 From: emilyhcliu <36091766+emilyhcliu@users.noreply.github.com> Date: Fri, 19 May 2023 14:42:03 -0400 Subject: [PATCH 013/109] Enhancement to handle hydrometeors in the EnKF I/O interface (#499) The enhancements made to the EnKF IO interface are the following: (1) For enkf I/O: add the handling of precipitation hydrometeors to parallel netcdf I.O --- preparation of next implementation --- src/enkf/gridio_gfs.f90 | 399 ++++++++++++++++++++++++++++++++-------- 1 file changed, 319 insertions(+), 80 deletions(-) diff --git a/src/enkf/gridio_gfs.f90 b/src/enkf/gridio_gfs.f90 index fe5199e395..456f8126e2 100644 --- a/src/enkf/gridio_gfs.f90 +++ b/src/enkf/gridio_gfs.f90 @@ -157,7 +157,7 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & levdim = get_dim(dset,'pfull'); nlevsin = levdim%len idvc=2 else - print *, 'parallel read only supported for netCDF, stopping with error' + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** parallel read only supported for netCDF' , ' PROGRAM STOPS' call stop2(23) end if ice = .false. ! calculate qsat w/resp to ice? @@ -185,6 +185,9 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & sst_ind = getindex(vars2d, 'sst') use_full_hydro = ( ql_ind > 0 .and. qi_ind > 0 .and. & qr_ind > 0 .and. qs_ind > 0 .and. qg_ind > 0 ) + ! Currently, we do not let precipiation to affect the enkf analysis + ! The following line will be removed after testing + use_full_hydro = .false. if (.not. isinitialized) call init_spec_vars(nlons,nlats,ntrunc,4) @@ -195,7 +198,7 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & call read_vardata(dset, 'pressfc', values_2d,errcode=iret) if (iret /= 0) then - print *,'error reading ps' + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading ps, iret= ',iret,' PROGRAM STOPS' call stop2(31) endif psg = 0.01_r_kind*reshape(values_2d,(/nlons*nlats/)) @@ -215,12 +218,12 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & call read_vardata(dset, 'ugrd', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) if (iret /= 0) then - print *,'error reading ugrd' + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading ugrd, iret= ',iret,' PROGRAM STOPS' call stop2(22) endif call read_vardata(dset, 'vgrd', vg3d, ncstart=ncstart, nccount=nccount, errcode=iret) if (iret /= 0) then - print *,'error reading vgrd' + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading vgrd, iret= ',iret,' PROGRAM STOPS' call stop2(23) endif call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& @@ -247,12 +250,12 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & end if call read_vardata(dset,'tmp', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) if (iret /= 0) then - print *,'error reading tmp' + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading tmp, iret= ',iret,' PROGRAM STOPS' call stop2(24) endif call read_vardata(dset,'spfh', vg3d, ncstart=ncstart, nccount=nccount, errcode=iret) if (iret /= 0) then - print *,'error reading spfh' + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading spfh, iret= ',iret,' PROGRAM STOPS' call stop2(25) endif call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& @@ -276,7 +279,7 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & if (oz_ind > 0) then call read_vardata(dset, 'o3mr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) if (iret /= 0) then - print *,'error reading o3mr' + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading o3mr, iret= ',iret,' PROGRAM STOPS' call stop2(26) endif if (cliptracers) where (ug3d < clip) ug3d = clip @@ -290,31 +293,122 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & end do end if endif - if (cw_ind > 0 .or. ql_ind > 0 .or. qi_ind > 0) then - call read_vardata(dset, 'clwmr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) - if (iret /= 0) then - print *,'error reading clwmr' - call stop2(27) + ! Read in hydrometeor fields based on control/state variables listed in anavinfo table + if (use_full_hydro) then + if(ql_ind > 0) then + call read_vardata(dset, 'clwmr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading clwmr, iret= ',iret,' PROGRAM STOPS' + call stop2(26) + endif + if (cliptracers) where (ug3d < clip) ug3d = clip + call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& + mpi_real4, 0, iocomms(mem_pe(nproc)),iret) + if (iope==0) then + do k=1,nlevs + krev = nlevs-k+1 + ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(ql_ind-1)+k,nb,ne)) + end do + end if endif - if (imp_physics == 11) then - call read_vardata(dset, 'icmr', vg3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if(qi_ind > 0) then + call read_vardata(dset, 'icmr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) if (iret /= 0) then - print *,'error reading icmr' - call stop2(28) + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading icmr, iret= ',iret,' PROGRAM STOPS' + call stop2(26) endif - ug3d = ug3d + vg3d + if (cliptracers) where (ug3d < clip) ug3d = clip + call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& + mpi_real4, 0, iocomms(mem_pe(nproc)),iret) + if (iope==0) then + do k=1,nlevs + krev = nlevs-k+1 + ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(qi_ind-1)+k,nb,ne)) + end do + end if + endif + if(qr_ind > 0) then + call read_vardata(dset, 'rwmr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading rwmr, iret= ',iret,' PROGRAM STOPS' + call stop2(26) + endif + if (cliptracers) where (ug3d < clip) ug3d = clip + call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& + mpi_real4, 0, iocomms(mem_pe(nproc)),iret) + if (iope==0) then + do k=1,nlevs + krev = nlevs-k+1 + ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(qr_ind-1)+k,nb,ne)) + end do + end if + endif + if(qs_ind > 0) then + call read_vardata(dset, 'snmr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading snmr, iret= ',iret,' PROGRAM STOPS' + call stop2(26) + endif + if (cliptracers) where (ug3d < clip) ug3d = clip + call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& + mpi_real4, 0, iocomms(mem_pe(nproc)),iret) + if (iope==0) then + do k=1,nlevs + krev = nlevs-k+1 + ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(qs_ind-1)+k,nb,ne)) + end do + end if + endif + if(qg_ind > 0) then + call read_vardata(dset, 'grle', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading grle, iret= ',iret,' PROGRAM STOPS' + call stop2(26) + endif + if (cliptracers) where (ug3d < clip) ug3d = clip + call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& + mpi_real4, 0, iocomms(mem_pe(nproc)),iret) + if (iope==0) then + do k=1,nlevs + krev = nlevs-k+1 + ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(qg_ind-1)+k,nb,ne)) + end do + end if + endif + else + ! Handle non-precipiting hydrometeors + ! if control or state variable is cw, make sure combine background ql and qi to cw + if (cw_ind > 0 .or. ql_ind > 0 .or. qi_ind > 0) then + call read_vardata(dset, 'clwmr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading clwmr, iret= ',iret,' PROGRAM STOPS' + call stop2(27) + endif + if (imp_physics == 11) then + call read_vardata(dset, 'icmr', vg3d, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading icmr, iret= ',iret,' PROGRAM STOPS' + call stop2(28) + endif + ug3d = ug3d + vg3d + endif + if (cliptracers) where (ug3d < clip) ug3d = clip + call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& + mpi_real4, 0, iocomms(mem_pe(nproc)),iret) + if (iope==0) then + do k=1,nlevs + krev = nlevs-k+1 + ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/)) + call copytogrdin(ug,cw(:,k)) + if (cw_ind > 0) grdin(:,levels(cw_ind-1)+k,nb,ne) = cw(:,k) + end do + end if endif - if (cliptracers) where (ug3d < clip) ug3d = clip - call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,& - mpi_real4, 0, iocomms(mem_pe(nproc)),iret) - if (iope==0) then - do k=1,nlevs - krev = nlevs-k+1 - ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/)) - call copytogrdin(ug,cw(:,k)) - if (cw_ind > 0) grdin(:,levels(cw_ind-1)+k,nb,ne) = cw(:,k) - end do - end if endif deallocate(ug3d,vg3d) @@ -355,22 +449,25 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & end if ! cloud derivatives + ! Currently, we do not let precipiation to affect the enkf analysis + ! The following line will be removed after testing + use_full_hydro = .true. if (.not. use_full_hydro .and. iope==0) then - if (ql_ind > 0 .or. qi_ind > 0) then - do k=1,nlevs - do i = 1, npts - qi_coef = -r0_05*(tv(i,k)/(one+fv*q(i,k))-t0c) - qi_coef = max(zero,qi_coef) - qi_coef = min(one,qi_coef) ! 0<=qi_coef<=1 - if (ql_ind > 0) then - grdin(i,levels(ql_ind-1)+k,nb,ne) = cw(i,k)*(one-qi_coef) - endif - if (qi_ind > 0) then - grdin(i,levels(qi_ind-1)+k,nb,ne) = cw(i,k)*qi_coef - endif + if (ql_ind > 0 .or. qi_ind > 0) then + do k=1,nlevs + do i = 1, npts + qi_coef = -r0_05*(tv(i,k)/(one+fv*q(i,k))-t0c) + qi_coef = max(zero,qi_coef) + qi_coef = min(one,qi_coef) ! 0<=qi_coef<=1 + if (ql_ind > 0) then + grdin(i,levels(ql_ind-1)+k,nb,ne) = cw(i,k)*(one-qi_coef) + endif + if (qi_ind > 0) then + grdin(i,levels(qi_ind-1)+k,nb,ne) = cw(i,k)*qi_coef + endif + enddo enddo - enddo - endif + endif endif if (sst_ind > 0 .and. iope==0) then @@ -3709,7 +3806,7 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate use netcdf use params, only: nbackgrounds,incfileprefixes,fgfileprefixes,reducedgrid,& datestring,nhr_anal - use constants, only: grav + use constants, only: grav,qcmin use mpi use module_ncio, only: Dataset, Variable, Dimension, open_dataset,& read_attribute, close_dataset, get_dim, read_vardata,& @@ -3744,7 +3841,8 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate integer(i_kind) :: ncid_out, lon_dimid, lat_dimid, lev_dimid, ilev_dimid integer(i_kind) :: lonvarid, latvarid, levvarid, pfullvarid, ilevvarid, & hyaivarid, hybivarid, uvarid, vvarid, delpvarid, delzvarid, & - tvarid, sphumvarid, liqwatvarid, o3varid, icvarid + tvarid, sphumvarid, liqwatvarid, o3varid, icvarid, & + rwmrvarid, snmrvarid, grlevarid integer(i_kind) :: iadateout ! fixed fields such as lat, lon, levs @@ -3846,6 +3944,12 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate call nccheck_incr(nf90_var_par_access(ncid_out, o3varid, nf90_collective)) call nccheck_incr(nf90_def_var(ncid_out, "icmr_inc", nf90_real, dimids3, icvarid)) call nccheck_incr(nf90_var_par_access(ncid_out, icvarid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "rwmr_inc", nf90_real, dimids3, rwmrvarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, rwmrvarid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "snmr_inc", nf90_real, dimids3, snmrvarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, snmrvarid, nf90_collective)) + call nccheck_incr(nf90_def_var(ncid_out, "grle_inc", nf90_real, dimids3, grlevarid)) + call nccheck_incr(nf90_var_par_access(ncid_out, grlevarid, nf90_collective)) ! place global attributes to parallel calc_increment output call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "source", "GSI EnKF")) call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "comment", & @@ -3874,11 +3978,14 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate ! old logical massbal_adjust, if non-zero use_full_hydro = ( ql_ind > 0 .and. qi_ind > 0 .and. & qr_ind > 0 .and. qs_ind > 0 .and. qg_ind > 0 ) + ! Currently, we do not let precipiation to affect the enkf analysis + ! The following line will be removed after testing + use_full_hydro = .false. dsfg = open_dataset(filenamein, paropen=.true., mpicomm=iocomms(mem_pe(nproc))) call read_attribute(dsfg, 'ak', values_1d,errcode=iret) if (iret /= 0) then - print *,'error reading ak' + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading ak, iret= ',iret,' PROGRAM STOPS' call stop2(29) endif do k=1,nlevs+1 @@ -3887,7 +3994,7 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate enddo call read_attribute(dsfg, 'bk', values_1d,errcode=iret) if (iret /= 0) then - print *,'error reading bk' + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading bk, iret= ',iret,' PROGRAM STOPS' call stop2(29) endif do k=1,nlevs+1 @@ -3997,7 +4104,7 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate allocate(tvanl(nlons,nlats,nccount(3)),tmpanl(nlons,nlats,nccount(3)),qanl(nlons,nlats,nccount(3))) call read_vardata(dsfg, 'spfh', q, ncstart=ncstart, nccount=nccount, errcode=iret) if (iret /= 0) then - print *,'error reading spfh' + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading spfh, iret= ',iret,' PROGRAM STOPS' call stop2(29) endif do k=lev_pe1(iope), lev_pe2(iope) @@ -4022,7 +4129,7 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate ! t increment call read_vardata(dsfg, 'tmp', tmp, ncstart=ncstart, nccount=nccount, errcode=iret) if (iret /= 0) then - print *,'error reading tmp' + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading tmp, iret= ',iret,' PROGRAM STOPS' call stop2(29) endif tv = tmp * ( 1.0 + fv*q) @@ -4094,39 +4201,171 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate call nccheck_incr(nf90_put_var(ncid_out, o3varid, sngl(inc3dout), & start = ncstart, count = nccount)) - ! liq wat increment - ! icmr increment - do k=lev_pe1(iope), lev_pe2(iope) - krev = nlevs-k+1 - ki = k - lev_pe1(iope) + 1 - ug = zero - if (cw_ind > 0) then - call copyfromgrdin(grdin(:,levels(cw_ind-1)+krev,nb,ne),ug) - end if - if (imp_physics == 11) then - work = -r0_05 * (reshape(tmpanl(:,:,ki),(/nlons*nlats/)) - t0c) - do i=1,nlons*nlats - work(i) = max(zero,work(i)) - work(i) = min(one,work(i)) - enddo - vg = ug * work ! cloud ice - ug = ug * (one - work) ! cloud water - inc3d2(:,:,ki) = reshape(vg,(/nlons,nlats/)) + ! For hydrometeors, following the treatment for specific humidity increment + ! Need to make sure the analysis value is not negative + ! Read in background + increment and make sure the minimum is qcmin + ! Adjust increment accordingly + + if (use_full_hydro) then + ! liq wat increment + call read_vardata(dsfg, 'clwmr', q, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading clwmr, iret= ',iret,' PROGRAM STOPS' + call stop2(29) endif - inc3d(:,:,ki) = reshape(ug,(/nlons,nlats/)) - enddo - do j=1,nlats - inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) - end do - if (should_zero_increments_for('liq_wat_inc')) inc3dout = zero - call nccheck_incr(nf90_put_var(ncid_out, liqwatvarid, sngl(inc3dout), & - start = ncstart, count = nccount)) - do j=1,nlats - inc3dout(:,nlats-j+1,:) = inc3d2(:,j,:) - end do - if (should_zero_increments_for('icmr_inc')) inc3dout = zero - call nccheck_incr(nf90_put_var(ncid_out, icvarid, sngl(inc3dout), & - start = ncstart, count = nccount)) + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + inc(:) = zero + if (ql_ind > 0) then + call copyfromgrdin(grdin(:,levels(ql_ind-1) + krev,nb,ne),inc) + endif + inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) + qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki) + end do + if (cliptracers) where (qanl < qcmin) qanl = qcmin + inc3d = qanl - q ! updated clwmr increment + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('liq_wat_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, liqwatvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! icmr increment + call read_vardata(dsfg, 'icmr', q, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading icmr, iret= ',iret,' PROGRAM STOPS' + call stop2(29) + endif + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + inc(:) = zero + if (qi_ind > 0) then + call copyfromgrdin(grdin(:,levels(qi_ind-1) + krev,nb,ne),inc) + endif + inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) + qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki) + end do + if (cliptracers) where (qanl < qcmin) qanl = qcmin + inc3d = qanl - q ! updated icmr increment + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('icmr_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, icvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! rwmr increment + call read_vardata(dsfg, 'rwmr', q, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading rwmr, iret= ',iret,' PROGRAM STOPS' + call stop2(29) + endif + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + inc(:) = zero + if (qr_ind > 0) then + call copyfromgrdin(grdin(:,levels(qr_ind-1) + krev,nb,ne),inc) + endif + inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) + qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki) + end do + if (cliptracers) where (qanl < qcmin) qanl = qcmin + inc3d = qanl - q ! updated rwmr increment + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('rwmr_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, rwmrvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! snmr increment + call read_vardata(dsfg, 'snmr', q, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading snmr, iret= ',iret,' PROGRAM STOPS' + call stop2(29) + endif + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + inc(:) = zero + if (qs_ind > 0) then + call copyfromgrdin(grdin(:,levels(qs_ind-1) + krev,nb,ne),inc) + endif + inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) + qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki) + end do + if (cliptracers) where (qanl < qcmin) qanl = qcmin + inc3d = qanl - q ! updated snmr increment + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('snmr_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, snmrvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! grle increment + call read_vardata(dsfg, 'grle', q, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading grle, iret= ',iret,' PROGRAM STOPS' + call stop2(29) + endif + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + inc(:) = zero + if (qg_ind > 0) then + call copyfromgrdin(grdin(:,levels(qg_ind-1) + krev,nb,ne),inc) + endif + inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) + qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki) + end do + if (cliptracers) where (qanl < qcmin) qanl = qcmin + inc3d = qanl - q ! updated grle increment + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('grle_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, grlevarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + else + ! liq wat increment + ! icmr increment + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + ug = zero + if (cw_ind > 0) then + call copyfromgrdin(grdin(:,levels(cw_ind-1)+krev,nb,ne),ug) + end if + if (imp_physics == 11) then + work = -r0_05 * (reshape(tmpanl(:,:,ki),(/nlons*nlats/)) - t0c) + do i=1,nlons*nlats + work(i) = max(zero,work(i)) + work(i) = min(one,work(i)) + enddo + vg = ug * work ! cloud ice + ug = ug * (one - work) ! cloud water + inc3d2(:,:,ki) = reshape(vg,(/nlons,nlats/)) + endif + inc3d(:,:,ki) = reshape(ug,(/nlons,nlats/)) + enddo + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('liq_wat_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, liqwatvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d2(:,j,:) + end do + if (should_zero_increments_for('icmr_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, icvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + endif call mpi_barrier(iocomms(mem_pe(nproc)), iret) From ac1a8cbdfa25014549b25fc38b6539b57c494f72 Mon Sep 17 00:00:00 2001 From: jderber-NOAA <75998838+jderber-NOAA@users.noreply.github.com> Date: Tue, 30 May 2023 11:28:42 -0400 Subject: [PATCH 014/109] Issue with global mean weight for multiscale ensemble runs for ig > 1 plus changes to make code work for multiscale (bugs introduced in develop). (#570) --- src/gsi/apply_scaledepwgts.f90 | 58 +++++++++------------- src/gsi/control_vectors.f90 | 2 +- src/gsi/convthin.f90 | 3 +- src/gsi/cplr_get_fv3_regional_ensperts.f90 | 9 ++-- src/gsi/cplr_gfs_ensmod.f90 | 9 ++-- src/gsi/general_specmod.f90 | 2 +- src/gsi/get_gefs_ensperts_dualres.f90 | 2 +- src/gsi/gsi_rfv3io_mod.f90 | 7 +-- src/gsi/read_dbz_nc.f90 | 2 +- src/gsi/read_iasi.f90 | 4 +- src/gsi/setuprad.f90 | 51 ++++++++++--------- src/gsi/state_vectors.f90 | 2 +- src/gsi/stpcalc.f90 | 4 +- src/gsi/stprad.f90 | 2 +- 14 files changed, 74 insertions(+), 83 deletions(-) diff --git a/src/gsi/apply_scaledepwgts.f90 b/src/gsi/apply_scaledepwgts.f90 index 8b93cf0b57..e97b6fb614 100644 --- a/src/gsi/apply_scaledepwgts.f90 +++ b/src/gsi/apply_scaledepwgts.f90 @@ -42,51 +42,47 @@ subroutine init_mult_spc_wgts(jcap_in) !$$$ end documentation block use kinds, only: r_kind,i_kind,r_single - use hybrid_ensemble_parameters,only: s_ens_hv,sp_loc,grd_ens,grd_loc,sp_ens - use hybrid_ensemble_parameters,only: n_ens,p_sploc2ens,grd_sploc - use hybrid_ensemble_parameters,only: use_localization_grid - use gridmod,only: use_sp_eqspace - use general_specmod, only: general_init_spec_vars use constants, only: zero,half,one,two,three,rearth,pi,tiny_r_kind - use constants, only: rad2deg use mpimod, only: mype use general_sub2grid_mod, only: general_sub2grid_create_info use egrid2agrid_mod,only: g_create_egrid2agrid use general_sub2grid_mod, only: sub2grid_info - use gsi_io, only: verbose use hybrid_ensemble_parameters, only: nsclgrp use hybrid_ensemble_parameters, only: spc_multwgt,spcwgt_params,r_ensloccov4scl implicit none integer(i_kind),intent(in ) :: jcap_in - real(r_kind),allocatable :: totwvlength(:) - integer(i_kind) i,ii,j,k,l,n,kk,nsigend + integer(i_kind) i integer(i_kind) ig real(r_kind) rwv0,rtem1,rtem2 real (r_kind):: fwgtofwvlen - integer(i_kind) :: l_sum_spc_weights + real(r_kind) :: totwvlength + logical :: l_sum_spc_weights ! Spectral scale decomposition is differernt between SDL-cross and SDL-nocross if( r_ensloccov4scl < tiny_r_kind )then - l_sum_spc_weights = 1 + l_sum_spc_weights = .false. else - l_sum_spc_weights = 0 + l_sum_spc_weights = .true. end if - allocate(totwvlength(jcap_in)) + spc_multwgt(0,1)=one + do ig=2,nsclgrp + spc_multwgt(0,ig)=zero + end do - rwv0=2*pi*rearth*0.001_r_kind - do i=1,jcap_in - totwvlength(i)= rwv0/real(i) - enddo + + rwv0=2.0_r_kind*pi*rearth*0.001_r_kind do i=1,jcap_in - rtem1=0 + totwvlength= rwv0/real(i) + rtem1=zero do ig=1,nsclgrp if(ig /= 2) then spc_multwgt(i,ig)=fwgtofwvlen(spcwgt_params(1,ig),spcwgt_params(2,ig),& - spcwgt_params(3,ig),spcwgt_params(4,ig),totwvlength(i)) - if(l_sum_spc_weights == 0 ) then + spcwgt_params(3,ig),spcwgt_params(4,ig),totwvlength) + spc_multwgt(i,ig)=min(max(spc_multwgt(i,ig),zero),one) + if(l_sum_spc_weights) then rtem1=rtem1+spc_multwgt(i,ig) else rtem1=rtem1+spc_multwgt(i,ig)*spc_multwgt(i,ig) @@ -94,18 +90,19 @@ subroutine init_mult_spc_wgts(jcap_in) endif enddo rtem2 =1.0_r_kind - rtem1 - if(abs(rtem2) >= zero) then + if(rtem2 >= zero) then - if(l_sum_spc_weights == 0 ) then + if(l_sum_spc_weights) then spc_multwgt(i,2)=rtem2 else spc_multwgt(i,2)=sqrt(rtem2) endif + else + if(mype == 0)write(6,*) ' rtem2 < zero ',i,rtem2,(spc_multwgt(i,ig),ig=1,nsclgrp) + spc_multwgt(i,2)=zero endif enddo - spc_multwgt=max(spc_multwgt,0.0_r_kind) - deallocate(totwvlength) return end subroutine init_mult_spc_wgts @@ -117,18 +114,15 @@ subroutine apply_scaledepwgts(grd_in,sp_in,wbundle,spwgts,wbundle2) ! POC: xuguang.wang@ou.edu ! use constants, only: one - use control_vectors, only: nrf_var,cvars2d,cvars3d,control_vector + use control_vectors, only: control_vector use kinds, only: r_kind,i_kind use kinds, only: r_single - use mpimod, only: mype,nvar_id,levs_id - use hybrid_ensemble_parameters, only: oz_univ_static use general_specmod, only: general_spec_multwgt use gsi_bundlemod, only: gsi_bundle use general_sub2grid_mod, only: general_sub2grid,general_grid2sub use general_specmod, only: spec_vars use general_sub2grid_mod, only: sub2grid_info - use mpimod, only: mpi_comm_world,mype,npe,ierror - use file_utility, only : get_lun + use mpimod, only: mpi_comm_world,mype implicit none ! Declare passed variables @@ -139,15 +133,11 @@ subroutine apply_scaledepwgts(grd_in,sp_in,wbundle,spwgts,wbundle2) real(r_kind),dimension(0:sp_in%jcap),intent(in):: spwgts ! Declare local variables - integer(i_kind) ii,kk - integer(i_kind) i,j,lunit + integer(i_kind) kk - real(r_kind),dimension(grd_in%lat2,grd_in%lon2):: slndt,sicet,sst real(r_kind),dimension(grd_in%nlat*grd_in%nlon*grd_in%nlevs_alloc) :: hwork real(r_kind),dimension(grd_in%nlat,grd_in%nlon,grd_in%nlevs_alloc) :: work real(r_kind),dimension(sp_in%nc):: spc1 - character*64 :: fname1 - character*5:: varname1 ! Beta1 first ! Get from subdomains to diff --git a/src/gsi/control_vectors.f90 b/src/gsi/control_vectors.f90 index ea41b36c46..97578124d2 100644 --- a/src/gsi/control_vectors.f90 +++ b/src/gsi/control_vectors.f90 @@ -895,7 +895,7 @@ real(r_quad) function qdot_prod_sub(xcv,ycv) m3d=xcv%step(1)%n3d m2d=xcv%step(1)%n2d itot=max(m3d,0)+max(m2d,0) - if(l_hyb_ens)itot=itot+n_ens + if(l_hyb_ens)itot=itot+n_ens*naensgrp allocate(partsum(itot)) do ii=1,nsubwin !$omp parallel do schedule(dynamic,1) private(i) diff --git a/src/gsi/convthin.f90 b/src/gsi/convthin.f90 index 99629b8aff..3a52188d73 100644 --- a/src/gsi/convthin.f90 +++ b/src/gsi/convthin.f90 @@ -464,8 +464,7 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io real(r_kind) dlat1,dlon1,pob1 real(r_kind) dx,dy,dp - real(r_kind) dxx,dyy,dpp - real(r_kind) crit!,dist1 + real(r_kind) crit !,dist1 logical foreswp, aftswp diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 index fb4afe121d..5a3e72970d 100644 --- a/src/gsi/cplr_get_fv3_regional_ensperts.f90 +++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90 @@ -1021,7 +1021,7 @@ subroutine general_read_fv3_regional_parallel_over_ens(this,iope,fv3_filenamegin use netcdf, only: nf90_inq_dimid,nf90_inquire_dimension use netcdf, only: nf90_inq_varid,nf90_inquire_variable,nf90_get_var use kinds, only: r_kind,r_single,i_kind - use gridmod, only: eta1_ll,eta2_ll + use gridmod, only: eta1_ll use constants, only: zero,one,fv,zero_single,one_tenth,h300 use hybrid_ensemble_parameters, only: grd_ens,q_hyb_ens use hybrid_ensemble_parameters, only: fv3sar_ensemble_opt @@ -1036,14 +1036,11 @@ subroutine general_read_fv3_regional_parallel_over_ens(this,iope,fv3_filenamegin use gsi_rfv3io_mod, only: gsi_fv3ncdf_readuv use gsi_rfv3io_mod, only: gsi_fv3ncdf_readuv_v1 use gsi_rfv3io_mod, only: gsi_fv3ncdf2d_read_v1 - use directDA_radaruse_mod, only: l_use_dbz_directDA use gsi_bundlemod, only: gsi_gridcreate use gsi_bundlemod, only: gsi_grid use gsi_bundlemod, only: gsi_bundlecreate,gsi_bundledestroy use gsi_bundlemod, only: gsi_bundlegetvar use obsmod, only: if_model_dbz - use directDA_radaruse_mod, only: l_use_cvpqx, cvpqx_pval, cld_nt_updt - use directDA_radaruse_mod, only: l_cvpnr, cvpnr_pval use gsi_rfv3io_mod, only: gsi_fv3ncdf_read_ens_parallel_over_ens,gsi_fv3ncdf_readuv_ens_parallel_over_ens @@ -1085,7 +1082,6 @@ subroutine general_read_fv3_regional_parallel_over_ens(this,iope,fv3_filenamegin character(len=:),allocatable :: tracers !='fv3_tracer' character(len=:),allocatable :: sfcdata !='fv3_sfcdata' character(len=:),allocatable :: couplerres!='coupler.res' - integer (i_kind) ier,istatus associate( this => this ) ! eliminates warning for unused dummy argument needed for binding @@ -1205,7 +1201,7 @@ subroutine parallel_read_fv3_step2(this,mype,iope, & use hybrid_ensemble_parameters, only: grd_ens use mpimod, only: mpi_comm_world,ierror,mpi_rtype use kinds, only: r_kind,r_single,i_kind - use gridmod,only: itotsub + use constants, only: half,zero implicit none @@ -1234,6 +1230,7 @@ subroutine parallel_read_fv3_step2(this,mype,iope, & ! transfer data from root to subdomains on each task ! scatterv used, since full grids exist only on root task. allocate(wrk_send_2d(grd_ens%itotsub)) + g_oz=zero ! first PS (output from fill_regional_2d is a column vector with a halo) if(mype==iope) call this%fill_regional_2d(gg_ps,wrk_send_2d) call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & diff --git a/src/gsi/cplr_gfs_ensmod.f90 b/src/gsi/cplr_gfs_ensmod.f90 index 67f15ebae2..550f85d209 100644 --- a/src/gsi/cplr_gfs_ensmod.f90 +++ b/src/gsi/cplr_gfs_ensmod.f90 @@ -180,7 +180,7 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & use gsi_4dvar, only: ens_fhrlevs use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only : assignment(=) - use hybrid_ensemble_parameters, only: n_ens,grd_ens,ntlevs_ens + use hybrid_ensemble_parameters, only: n_ens,grd_ens use hybrid_ensemble_parameters, only: ensemble_path use control_vectors, only: nc2d,nc3d !use control_vectors, only: cvars2d,cvars3d @@ -202,7 +202,7 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & character(len=*),parameter :: myname_='get_user_ens_gfs_fastread_' character(len=70) :: filename character(len=70) :: filenamesfc - integer(i_kind) :: i,ii,j,jj,k,n + integer(i_kind) :: i,ii,j,k,n integer(i_kind) :: io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,i_ens integer(i_kind) :: ip integer(i_kind) :: nlon,nlat,nsig @@ -301,6 +301,8 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz, & filename) end if + else + allocate(en_full(1,1,1,1)) end if call mpi_allreduce(m_cvars2dw,m_cvars2d,nc2d,mpi_integer4,mpi_max,mpi_comm_world,ierror) @@ -314,7 +316,7 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & allocate(en_loc(ibsm:ibemz,jbsm:jbemz,kbsm:kbemz,mbsm:mbemz)) call genex(s_a2b,en_full,en_loc) - if(mas == mae)deallocate(en_full) + deallocate(en_full) ! call genex_destroy_info(s_a2b) ! check on actual routine name @@ -921,6 +923,7 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig call die(myname_, ': ***FATAL ERROR*** insufficient ens fcst for hybrid',999) endif + ierror=0 ! If file exists, open and process atmges = open_dataset(filename,errcode=ierror) if (ierror /=0) then diff --git a/src/gsi/general_specmod.f90 b/src/gsi/general_specmod.f90 index 20feae98de..c90187bf70 100644 --- a/src/gsi/general_specmod.f90 +++ b/src/gsi/general_specmod.f90 @@ -317,7 +317,7 @@ subroutine general_spec_multwgt(sp,spcwrk,spcwgt) real(r_kind),dimension(sp%nc),intent(inout) :: spcwrk real(r_kind),dimension(0:sp%jcap),intent(in) :: spcwgt - integer(i_kind) ii1,l,m,jmax,ks,n + integer(i_kind) l,jmax,ks,n !! Code borrowed from spvar in splib jmax=sp%jcap diff --git a/src/gsi/get_gefs_ensperts_dualres.f90 b/src/gsi/get_gefs_ensperts_dualres.f90 index fab95ad210..e244fa9f53 100644 --- a/src/gsi/get_gefs_ensperts_dualres.f90 +++ b/src/gsi/get_gefs_ensperts_dualres.f90 @@ -95,7 +95,7 @@ subroutine get_gefs_ensperts_dualres ! integer(i_kind) il,jl logical ice,hydrometeor type(sub2grid_info) :: grd_tmp - integer(i_kind) :: ig0,ig + integer(i_kind) :: ig ! Create perturbations grid and get variable names from perturbations if(en_perts(1,1,1)%grid%im/=grd_ens%lat2.or. & diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 7e7b11d57c..4fcb2aba1d 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -1824,7 +1824,7 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) real(r_kind),intent(in),dimension(:,:),pointer::ges_q2m type (type_fv3regfilenameg),intent(in) :: fv3filenamegin character(len=max_varname_length) :: name - integer(i_kind),allocatable,dimension(:):: dim_id,dim + integer(i_kind),allocatable,dimension(:):: dim real(r_kind),allocatable,dimension(:):: work real(r_kind),allocatable,dimension(:,:):: a real(r_kind),allocatable,dimension(:,:,:):: sfcn2d @@ -2774,10 +2774,9 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & type (type_fv3regfilenameg),intent(in) ::fv3filenamegin integer(i_kind) ,intent(in ) :: iope real(r_kind),allocatable,dimension(:,:):: uu2d, uu2d_tmp - real(r_kind),allocatable,dimension(:):: wrk_send_2d real(r_kind),dimension(nlat,nlon,nsig):: hwork real(r_kind),dimension(nlat,nlon,nsig),intent(out),optional:: delp,tsen,w,q,oz,ql,qr,qs,qi,qg,dbz - character(len=max_varname_length) :: varname,vgsiname + character(len=max_varname_length) :: varname character(len=max_varname_length) :: name character(len=max_varname_length), allocatable,dimension(:) :: varname_files @@ -2994,8 +2993,6 @@ subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens(ges_u,ges_v,fv3filenamegin,i character(:), allocatable:: filenamein real(r_kind),allocatable,dimension(:,:):: u2d,v2d real(r_kind),allocatable,dimension(:,:):: uc2d,vc2d - character(len=max_varname_length) :: varname,vgsiname - real(r_kind),allocatable,dimension(:,:,:,:):: worksub integer(i_kind) u_grd_VarId,v_grd_VarId integer(i_kind) nlatcase,nloncase integer(i_kind) nxcase,nycase diff --git a/src/gsi/read_dbz_nc.f90 b/src/gsi/read_dbz_nc.f90 index ee1d3cb2e4..cddbd14de4 100644 --- a/src/gsi/read_dbz_nc.f90 +++ b/src/gsi/read_dbz_nc.f90 @@ -71,7 +71,7 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no one_tenth,r1000,r60,r60inv,r100,r400,grav_equator, & eccentricity,somigliana,grav_ratio,grav,semi_major_axis,flattening use gridmod, only: tll2xy,nsig,nlat,nlon - use obsmod, only: iadate,doradaroneob,oneoblat,oneoblon,oneobheight,oneobradid, & + use obsmod, only: iadate,doradaroneob,oneoblat,oneoblon,oneobheight, & mintiltdbz,maxtiltdbz,minobrangedbz,maxobrangedbz,& static_gsi_nopcp_dbz,rmesh_dbz,zmesh_dbz use hybrid_ensemble_parameters,only : l_hyb_ens diff --git a/src/gsi/read_iasi.f90 b/src/gsi/read_iasi.f90 index d0a3793b4e..208b333f49 100644 --- a/src/gsi/read_iasi.f90 +++ b/src/gsi/read_iasi.f90 @@ -720,7 +720,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& !$omp parallel do schedule(dynamic,1) private(i,sc_chan,bufr_chan,radiance) channel_loop: do i=1,satinfo_nchan bufr_chan = bufr_index(i) - if (bufr_chan /= 0 ) then + if (bufr_chan > 0 ) then ! check that channel number is within reason if (( allchan(2,bufr_chan) > zero .and. allchan(2,bufr_chan) < 99999._r_kind)) then ! radiance bounds radiance = allchan(2,bufr_chan)*scalef(bufr_chan) @@ -729,8 +729,6 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& else temperature(bufr_chan) = tbmin endif - else - temperature(bufr_chan) = tbmin end if end do channel_loop diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 index faa79f0efc..822ec8ea22 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -998,6 +998,29 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif ! Compute microwave cloud liquid water or graupel water path for bias correction and QC. + if (adp_anglebc) then +! If using adaptive angle dependent bias correction, update the predicctors +! for this part of bias correction. The AMSUA cloud liquid water algorithm +! uses total angle dependent bias correction for channels 1 and 2 + do i=1,nchanl + mm=ich(i) + if (goessndr .or. goes_img .or. ahi .or. seviri .or. ssmi .or. ssmis .or. gmi .or. abi) then + pred(npred,i)=nadir*deg2rad + else + pred(npred,i)=data_s(iscan_ang,n) + end if + do j=2,angord + pred(npred-j+1,i)=pred(npred,i)**j + end do + cbias(nadir,mm)=zero + if (iuse_rad(mm)/=4) then + do j=1,angord + cbias(nadir,mm)=cbias(nadir,mm)+predchan(npred-j+1,i)*pred(npred-j+1,i) + end do + end if + end do + end if +!***** clw_obs=zero clw_guess_retrieval=zero gwp=zero @@ -1059,28 +1082,13 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif predbias=zero + abi2km_bc = zero + abi2km_bc(2) = 233.5_r_kind + abi2km_bc(3) = 241.7_r_kind + abi2km_bc(4) = 250.5_r_kind !$omp parallel do schedule(dynamic,1) private(i,mm,j,k,tlap,node,bias) do i=1,nchanl mm=ich(i) -! If using adaptive angle dependent bias correction, update the predicctors -! for this part of bias correction. The AMSUA cloud liquid water algorithm -! uses total angle dependent bias correction for channels 1 and 2 - if (adp_anglebc) then - if (goessndr .or. goes_img .or. ahi .or. seviri .or. ssmi .or. ssmis .or. gmi .or. abi) then - pred(npred,i)=nadir*deg2rad - else - pred(npred,i)=data_s(iscan_ang,n) - end if - do j=2,angord - pred(npred-j+1,i)=pred(npred,i)**j - end do - cbias(nadir,mm)=zero - if (iuse_rad(mm)/=4) then - do j=1,angord - cbias(nadir,mm)=cbias(nadir,mm)+predchan(npred-j+1,i)*pred(npred-j+1,i) - end do - end if - end if !***** ! COMPUTE AND APPLY BIAS CORRECTION TO SIMULATED VALUES @@ -1107,6 +1115,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& else pred(3,i) = clw_obs*cosza*cosza end if + if(radmod%lcloud_fwd .and. sea) pred(3,i ) = zero ! Apply bias correction @@ -1156,10 +1165,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& end if if (abi2km .and. regional) then - abi2km_bc = zero - abi2km_bc(2) = 233.5_r_kind - abi2km_bc(3) = 241.7_r_kind - abi2km_bc(4) = 250.5_r_kind pred(:,i) = zero if (i>=2 .and. i<=4) then if (tb_obs(i) > 190.0_r_kind .and. tb_obs(i) < 300.0_r_kind) then diff --git a/src/gsi/state_vectors.f90 b/src/gsi/state_vectors.f90 index ffad280bf5..df332303b0 100644 --- a/src/gsi/state_vectors.f90 +++ b/src/gsi/state_vectors.f90 @@ -386,7 +386,7 @@ subroutine norms_vars(xst,pmin,pmax,psum,pnum) ! local variables real(r_kind),allocatable,dimension(:) :: zloc,nloc real(r_kind),allocatable,dimension(:,:) :: zall,nall - integer(i_kind) :: i,ii + integer(i_kind) :: i pmin=zero pmax=zero diff --git a/src/gsi/stpcalc.f90 b/src/gsi/stpcalc.f90 index 2d79fd3e3b..30387341e3 100644 --- a/src/gsi/stpcalc.f90 +++ b/src/gsi/stpcalc.f90 @@ -781,7 +781,9 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if exit stepsize else if(ii == istp_iter)then - write(iout_iter,*) ' early termination due to no decrease in penalty ',cx,stp(ii) + if(mype == minmype)then + write(iout_iter,*) ' early termination due to no decrease in penalty ',cx,stp(ii) + end if stp(istp_use)=zero end_iter = .true. exit stepsize diff --git a/src/gsi/stprad.f90 b/src/gsi/stprad.f90 index 20fe0dd1a9..e81688f7e3 100644 --- a/src/gsi/stprad.f90 +++ b/src/gsi/stprad.f90 @@ -313,7 +313,7 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) endif -!$omp parallel do schedule(dynamic,1) private(nn,ic,mm,ncr,k,kk,rad,val,val2,cg_rad,wnotgross,wgross) +! !$omp parallel do schedule(dynamic,1) private(nn,ic,mm,ncr,k,kk,rad,val,val2,cg_rad,wnotgross,wgross) do nn=1,radptr%nchan if(nstep > 0)then From d766977d72203bd9406b491c131ef84ec3b7139b Mon Sep 17 00:00:00 2001 From: shoyokota <103961291+shoyokota@users.noreply.github.com> Date: Fri, 2 Jun 2023 02:21:11 +0900 Subject: [PATCH 015/109] GitHub Issue NOAA-EMC/GSI#540 Modify to assimilate radar reflectivity and conventional data simultaneously without side effects in EnVar (#543) This PR removes forcing pure EnVar and adding an option (if_use_w_vr) to assimilate radar reflectivity and conventional data simultaneously without side effects in EnVar (https://github.com/NOAA-EMC/GSI/issues/540). Regression tests for global 3dvar/4denvar/4dvar are not completed yet, but for other tests, issues are not found except for "failed the scalability test" and "exceeded maximum allowable hardware memory limit" on Orion. Fixes #540 Co-authored-by: Sho Yokota --- src/gsi/gsimod.F90 | 14 ++++++++------ src/gsi/intrw.f90 | 6 +++--- src/gsi/obsmod.F90 | 5 +++-- src/gsi/setuprw.f90 | 4 ++-- src/gsi/stprw.f90 | 5 +++-- 5 files changed, 19 insertions(+), 15 deletions(-) diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index c8ce5a45be..ed4bbb1e55 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -24,7 +24,7 @@ module gsimod use obsmod, only: doradaroneob,oneoblat,oneoblon,oneobheight,oneobvalue,oneobddiff,oneobradid,& radar_no_thinning,ens_hx_dbz_cut,static_gsi_nopcp_dbz,rmesh_dbz,& - rmesh_vr,zmesh_dbz,zmesh_vr,if_vterminal, if_model_dbz,if_vrobs_raw,& + rmesh_vr,zmesh_dbz,zmesh_vr,if_vterminal, if_model_dbz,if_vrobs_raw,if_use_w_vr,& minobrangedbz,maxobrangedbz,maxobrangevr,maxtiltvr,missing_to_nopcp,& ntilt_radarfiles,whichradar,& minobrangevr,maxtiltdbz,mintiltvr,mintiltdbz,l2rwthin,hurricane_radar @@ -765,7 +765,7 @@ module gsimod oneoblon,oneobheight,oneobvalue,oneobddiff,oneobradid,& rmesh_vr,zmesh_dbz,zmesh_vr, ntilt_radarfiles, whichradar,& radar_no_thinning,ens_hx_dbz_cut,static_gsi_nopcp_dbz,rmesh_dbz,& - minobrangevr, maxtiltdbz, mintiltvr,mintiltdbz,if_vterminal,if_vrobs_raw,& + minobrangevr, maxtiltdbz, mintiltvr,mintiltdbz,if_vterminal,if_vrobs_raw,if_use_w_vr,& if_model_dbz,imp_physics,lupp,netcdf_diag,binary_diag,l_wcp_cwm,aircraft_recon,diag_version,& write_fv3_incr,incvars_to_zero,incvars_zero_strat,incvars_efold,diag_version,& cao_check,lcalc_gfdl_cfrac,tau_fcst,efsoi_order,lupdqc,lqcoef,cnvw_option,l2rwthin,hurricane_radar,& @@ -2045,15 +2045,17 @@ subroutine gsimain_initialize baldiag_inc =.false. end if -! If reflectivity is intended to be assimilated, beta_s0 should be zero. +! Warning of reflectivity assimilation with static B if ( beta_s0 > 0.0_r_kind )then ! skipped in case of direct reflectivity DA because it works in Envar and hybrid if ( l_use_rw_columntilt .or. l_use_dbz_directDA) then do i=1,ndat if ( if_model_dbz .and. (index(dtype(i), 'dbz') /= 0) )then - write(6,*)'beta_s0 needs to be set to zero in this GSI version, when reflectivity is directly assimilated. & - Static B extended for radar reflectivity assimilation will be included in future version.' - call stop2(8888) + if (mype==0) then + write(6,*)'GSIMOD: ***WARNING*** static B for reflectivity is regarded as zero in this GSI version & + even though beta_s0 =',beta_s0 + write(6,*)'Static B extended for radar reflectivity assimilation will be included in future version.' + end if end if end do end if diff --git a/src/gsi/intrw.f90 b/src/gsi/intrw.f90 index df3ec162a9..bac4448c0d 100644 --- a/src/gsi/intrw.f90 +++ b/src/gsi/intrw.f90 @@ -96,7 +96,7 @@ subroutine intrw_(rwhead,rval,sval) !$$$ use kinds, only: r_kind,i_kind use constants, only: half,one,tiny_r_kind,cg_term,r3600 - use obsmod, only: lsaveobsens,l_do_adjoint,luse_obsdiag + use obsmod, only: lsaveobsens,l_do_adjoint,luse_obsdiag,if_use_w_vr use qcmod, only: nlnqc_iter,varqc_iter use jfunc, only: jiter use gsi_bundlemod, only: gsi_bundle @@ -128,7 +128,7 @@ subroutine intrw_(rwhead,rval,sval) call gsi_bundlegetpointer(sval,'u',su,istatus);ier=istatus+ier call gsi_bundlegetpointer(sval,'v',sv,istatus);ier=istatus+ier call gsi_bundlegetpointer(sval,'w',sw,istatus) - if (istatus==0) then + if (if_use_w_vr.and.istatus==0) then include_w=.true. else include_w=.false. @@ -136,7 +136,7 @@ subroutine intrw_(rwhead,rval,sval) call gsi_bundlegetpointer(rval,'u',ru,istatus);ier=istatus+ier call gsi_bundlegetpointer(rval,'v',rv,istatus);ier=istatus+ier call gsi_bundlegetpointer(rval,'w',rw,istatus) - if (istatus==0) then + if (if_use_w_vr.and.istatus==0) then include_w=.true. else include_w=.false. diff --git a/src/gsi/obsmod.F90 b/src/gsi/obsmod.F90 index bb317d0752..3066cdb5ca 100644 --- a/src/gsi/obsmod.F90 +++ b/src/gsi/obsmod.F90 @@ -470,7 +470,7 @@ module obsmod ! ==== DBZ DA === public :: ntilt_radarfiles public :: whichradar - public :: vr_dealisingopt, if_vterminal, if_model_dbz, inflate_obserr, if_vrobs_raw, l2rwthin + public :: vr_dealisingopt, if_vterminal, if_model_dbz, inflate_obserr, if_vrobs_raw, if_use_w_vr, l2rwthin public :: doradaroneob,oneoblat,oneoblon public :: oneobddiff,oneobvalue,oneobheight,oneobradid @@ -617,7 +617,7 @@ module obsmod logical :: ta2tb logical :: doradaroneob - logical :: vr_dealisingopt, if_vterminal, if_model_dbz, inflate_obserr, if_vrobs_raw, l2rwthin + logical :: vr_dealisingopt, if_vterminal, if_model_dbz, inflate_obserr, if_vrobs_raw, if_use_w_vr, l2rwthin character(4) :: whichradar,oneobradid real(r_kind) :: oneoblat,oneoblon,oneobddiff,oneobvalue,oneobheight logical :: radar_no_thinning @@ -747,6 +747,7 @@ subroutine init_obsmod_dflts if_vterminal=.false. l2rwthin =.false. if_vrobs_raw=.false. + if_use_w_vr=.true. if_model_dbz=.false. inflate_obserr=.false. whichradar="KKKK" diff --git a/src/gsi/setuprw.f90 b/src/gsi/setuprw.f90 index c32ea80ab7..2211ee6caa 100644 --- a/src/gsi/setuprw.f90 +++ b/src/gsi/setuprw.f90 @@ -114,7 +114,7 @@ subroutine setuprw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa use obsmod, only: rmiss_single,lobsdiag_forenkf,& lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset,& if_vterminal, ens_hx_dbz_cut, if_model_dbz, & - doradaroneob,oneobddiff,oneobvalue, if_vrobs_raw + doradaroneob,oneobddiff,oneobvalue, if_vrobs_raw, if_use_w_vr use obsmod, only: netcdf_diag, binary_diag, dirname,ianldate use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & nc_diag_write, nc_diag_data2d @@ -972,7 +972,7 @@ subroutine check_vars_ (proceed, include_w) call gsi_metguess_get ('var::v' , ivar, istatus ) proceed=proceed.and.ivar>0 call gsi_metguess_get ('var::w' , ivar, istatus ) - if (ivar>0) then + if (if_use_w_vr.and.ivar>0) then include_w=.true. if(if_vterminal)then if( .not. if_model_dbz ) then diff --git a/src/gsi/stprw.f90 b/src/gsi/stprw.f90 index 710d9baa23..c5f996463c 100644 --- a/src/gsi/stprw.f90 +++ b/src/gsi/stprw.f90 @@ -83,6 +83,7 @@ subroutine stprw(rwhead,rval,sval,out,sges,nstep) ! !$$$ use kinds, only: r_kind,i_kind,r_quad + use obsmod, only: if_use_w_vr use qcmod, only: nlnqc_iter,varqc_iter use constants, only: half,one,two,tiny_r_kind,cg_term,zero_quad,r3600 use gsi_bundlemod, only: gsi_bundle @@ -124,7 +125,7 @@ subroutine stprw(rwhead,rval,sval,out,sges,nstep) call gsi_bundlegetpointer(sval,'u',su,istatus);ier=istatus+ier call gsi_bundlegetpointer(sval,'v',sv,istatus);ier=istatus+ier call gsi_bundlegetpointer(sval,'w',sw,istatus) - if (istatus==0) then + if (if_use_w_vr.and.istatus==0) then include_w=.true. else include_w=.false. @@ -132,7 +133,7 @@ subroutine stprw(rwhead,rval,sval,out,sges,nstep) call gsi_bundlegetpointer(rval,'u',ru,istatus);ier=istatus+ier call gsi_bundlegetpointer(rval,'v',rv,istatus);ier=istatus+ier call gsi_bundlegetpointer(rval,'w',rw,istatus) - if (istatus==0) then + if (if_use_w_vr.and.istatus==0) then include_w=.true. else include_w=.false. From 57ddc31054e79c8b12e748e5407c43c15d5ffe1f Mon Sep 17 00:00:00 2001 From: ClaraDraper-NOAA <33430543+ClaraDraper-NOAA@users.noreply.github.com> Date: Mon, 5 Jun 2023 13:51:08 -0600 Subject: [PATCH 016/109] Initial changes for GFS v17 soil moisture and temperature analysis (#557) --- src/enkf/controlvec.f90 | 11 +- src/enkf/gridinfo_gfs.f90 | 2 +- src/enkf/gridio_gfs.f90 | 485 ++++++- src/enkf/params.f90 | 29 +- src/enkf/readconvobs.f90 | 5 +- src/enkf/statevec.f90 | 4 +- src/gsi/general_read_gfsatm.f90 | 2362 +++++++++++++++++-------------- src/gsi/gsimod.F90 | 4 +- src/gsi/jfunc.f90 | 5 + src/gsi/netcdfgfs_io.f90 | 33 +- src/gsi/read_prepbufr.f90 | 33 +- src/gsi/setupq.f90 | 163 ++- src/gsi/setupt.f90 | 143 +- src/gsi/update_guess.f90 | 6 +- 14 files changed, 2170 insertions(+), 1115 deletions(-) diff --git a/src/enkf/controlvec.f90 b/src/enkf/controlvec.f90 index bb2421c89c..4aa2613c63 100644 --- a/src/enkf/controlvec.f90 +++ b/src/enkf/controlvec.f90 @@ -131,7 +131,7 @@ subroutine init_controlvec() cvars3d(nc3d) = trim(adjustl(var)) clevels(nc3d) = ilev + clevels(nc3d-1) else - if (nproc .eq. 0) print *,'Error: only ', nlevs, ' and ', nlevs+1,' number of levels is supported in current version, got ',ilev + if (nproc .eq. 0) print *,'Error controlvec: only ', nlevs, ' and ', nlevs+1,' number of levels is supported in current version, got ',ilev call stop2(503) endif enddo @@ -212,7 +212,10 @@ subroutine read_control() ! read in whole control vector on i/o procs - keep in memory ! (needed in write_ensemble) allocate(grdin(npts,ncdim,nbackgrounds,nanals_per_iotask)) -allocate(qsat(npts,nlevs,nbackgrounds,nanals_per_iotask)) +! if only updating the sfc fields, qsat will not be calculated in readgriddata +! only allocate if needed. +q_ind = getindex(cvars3d, 'q') +if (q_ind > 0) allocate(qsat(npts,nlevs,nbackgrounds,nanals_per_iotask)) if (paranc) then if (nproc == 0) t1 = mpi_wtime() call readgriddata_pnc(cvars3d,cvars2d,nc3d,nc2d,clevels,ncdim,nbackgrounds, & @@ -225,7 +228,8 @@ subroutine read_control() fgfileprefixes,fgsfcfileprefixes,reducedgrid,grdin,qsat) end if !print *,'min/max qsat',nanal,'=',minval(qsat),maxval(qsat) - if (use_qsatensmean) then + q_ind = getindex(cvars3d, 'q') + if (use_qsatensmean .and. q_ind>0 ) then allocate(qsatmean(npts,nlevs,nbackgrounds)) allocate(qsat_tmp(npts)) ! compute ensemble mean qsat @@ -257,7 +261,6 @@ subroutine read_control() ! print *,'min/max qsatmean proc',nproc,'=',& ! minval(qsatmean(:,:,nbackgrounds/2+1)),maxval(qsatmean(:,:,nbackgrounds/2+1)) !endif - q_ind = getindex(cvars3d, 'q') if (pseudo_rh .and. q_ind > 0) then if (use_qsatensmean) then do ne=1,nanals_per_iotask diff --git a/src/enkf/gridinfo_gfs.f90 b/src/enkf/gridinfo_gfs.f90 index c2e2b10f57..317ca2221c 100644 --- a/src/enkf/gridinfo_gfs.f90 +++ b/src/enkf/gridinfo_gfs.f90 @@ -66,7 +66,7 @@ module gridinfo ! supported variable names in anavinfo character(len=max_varname_length),public, dimension(13) :: vars3d_supported = (/'u ', 'v ', 'tv ', 'q ', 'oz ', 'cw ', 'tsen', 'prse', & 'ql ', 'qi ', 'qr ', 'qs ', 'qg '/) -character(len=max_varname_length),public, dimension(3) :: vars2d_supported = (/'ps ', 'pst', 'sst' /) +character(len=max_varname_length),public, dimension(13) :: vars2d_supported = (/'ps ', 'pst', 'sst', 't2m', 'q2m', 'st1', 'st2', 'st3', 'st4', 'sl1', 'sl2', 'sl3', 'sl4' /) ! supported variable names in anavinfo contains diff --git a/src/enkf/gridio_gfs.f90 b/src/enkf/gridio_gfs.f90 index 456f8126e2..5d560be3a8 100644 --- a/src/enkf/gridio_gfs.f90 +++ b/src/enkf/gridio_gfs.f90 @@ -35,6 +35,7 @@ module gridio ! a required input for EFSO calculations ! 2019-03-13 Add precipitation components ! 2019-07-10 Add convective clouds +! 2022-07-21 Draper: added read/write for sfc file for nc io (writeincrements, and readgridata) ! ! attributes: ! language: f95 @@ -100,12 +101,21 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & logical ice logical use_full_hydro integer(i_kind), allocatable, dimension(:) :: mem_pe, lev_pe1, lev_pe2, iocomms - integer(i_kind) :: iope, ionumproc, iolevs, krev + integer(i_kind) :: iope, ionumproc, iolevs, krev, ierr integer(i_kind) :: ncstart(3), nccount(3) ! mpi gatherv things integer(i_kind), allocatable, dimension(:) :: recvcounts, displs real(r_single), dimension(nlons,nlats,nlevs) :: ug3d_0, vg3d_0 + logical :: read_sfc_file, read_atm_file + + call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, read_sfc_file, read_atm_file) + + if (read_sfc_file) then + print *,'paranc not supported for reading surface files' + call mpi_barrier(mpi_comm_world,ierr) + call mpi_finalize(ierr) + endif ! figure out what member to read and do MPI sub-communicator things allocate(mem_pe(0:numproc-1)) @@ -554,7 +564,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, type(sigio_head) :: sighead type(sigio_data) :: sigdata type(nemsio_gfile) :: gfile - type(Dataset) :: dset + type(Dataset) :: dset, dset_sfc type(Dimension) :: londim,latdim,levdim type(nemsio_gfile) :: gfilesfc @@ -562,14 +572,20 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, integer(i_kind) :: qr_ind, qs_ind, qg_ind integer(i_kind) :: tsen_ind, ql_ind, qi_ind, prse_ind integer(i_kind) :: ps_ind, pst_ind, sst_ind + integer(i_kind) :: tmp2m_ind, spfh2m_ind, soilt1_ind, soilt2_ind, soilt3_ind + integer(i_kind) :: soilt4_ind,slc1_ind, slc2_ind, slc3_ind, slc4_ind integer(i_kind) :: k,iunitsig,iret,nb,i,idvc,nlonsin,nlatsin,nlevsin,ne,nanal integer(i_kind) :: nlonsin_sfc,nlatsin_sfc logical ice logical use_full_hydro + logical read_sfc_file, read_atm_file use_full_hydro = .false. + ! determine which files will be read in + call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, read_sfc_file, read_atm_file) + ne = 0 ensmemloop: do nanal=nanal1,nanal2 ne = ne + 1 @@ -662,6 +678,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, ! print *, 'ql: ', ql_ind, ', prse: ', prse_ind ! print *, 'ps: ', ps_ind, ', pst: ', pst_ind, ', sst: ', sst_ind ! endif + if (read_atm_file) then if (.not. isinitialized) call init_spec_vars(nlons,nlats,ntrunc,4) @@ -731,7 +748,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, pressi(:,k) = 0.01_r_kind*ak(nlevs-k+2)+bk(nlevs-k+2)*psg if (nanal .eq. 1) print *,'netcdf, min/max pressi',k,minval(pressi(:,k)),maxval(pressi(:,k)) enddo - deallocate(ak,bk,values_2d) + deallocate(ak,bk) else vrtspec = sigdata%ps call sptez_s(vrtspec,psg,1) @@ -1100,10 +1117,134 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, deallocate(pressi,pslg) deallocate(psg) if (pst_ind > 0) deallocate(vmassdiv,pstend) + endif ! read_atm_file + if (use_gfs_nemsio) call nemsio_close(gfile,iret=iret) if (use_gfs_ncio) call close_dataset(dset) if (use_gfs_nemsio) call nemsio_close(gfilesfc,iret=iret) + if ( read_sfc_file ) then + + if ( .not. use_gfs_ncio ) then + write(6,*) 'griddio/griddata for sfc update vars only coded for nc io' + call stop2(23) + endif + if ( reducedgrid ) then + write(6,*) "reducedgrid=T interpolation not valid for writing sfc files" + call stop2(22) + endif + + ! land sfc DA variables + tmp2m_ind = getindex(vars2d, 't2m') + spfh2m_ind = getindex(vars2d, 'q2m') + soilt1_ind = getindex(vars2d, 'st1') + slc1_ind = getindex(vars2d, 'sl1') + soilt2_ind = getindex(vars2d, 'st2') + slc2_ind = getindex(vars2d, 'sl2') + soilt3_ind = getindex(vars2d, 'st3') + slc3_ind = getindex(vars2d, 'sl3') + soilt4_ind = getindex(vars2d, 'st4') + slc4_ind = getindex(vars2d, 'sl4') + + dset_sfc = open_dataset(filenamesfc) + ! read in sfc vars, if requested + if (tmp2m_ind > 0) then + call read_vardata(dset_sfc, 'tmp2m', values_2d, errcode=iret) + if (iret /= 0) then + print *,'error reading tmp2m' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(n3d) + tmp2m_ind,nb,ne)) + endif + if (spfh2m_ind > 0) then + call read_vardata(dset_sfc, 'spfh2m', values_2d, errcode=iret) + if (iret /= 0) then + print *,'error reading spfh2m' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(n3d) + spfh2m_ind,nb,ne)) + endif + if (soilt1_ind > 0) then + call read_vardata(dset_sfc, 'soilt1', values_2d, errcode=iret) + if (iret /= 0) then + print *,'error reading soilt1' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(n3d) + soilt1_ind,nb,ne)) + endif + if (soilt2_ind > 0) then + call read_vardata(dset_sfc, 'soilt2', values_2d, errcode=iret) + if (iret /= 0) then + print *,'error reading soilt2' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(n3d) + soilt2_ind,nb,ne)) + endif + if (soilt3_ind > 0) then + call read_vardata(dset_sfc, 'soilt3', values_2d, errcode=iret) + if (iret /= 0) then + print *,'error reading soilt3' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(n3d) + soilt3_ind,nb,ne)) + endif + if (soilt4_ind > 0) then + call read_vardata(dset_sfc, 'soilt4', values_2d, errcode=iret) + if (iret /= 0) then + print *,'error reading soilt2' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(n3d) + soilt4_ind,nb,ne)) + endif + if (slc1_ind > 0) then + call read_vardata(dset_sfc, 'slc1', values_2d, errcode=iret) + if (iret /= 0) then + print *,'error reading slc1' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(n3d) + slc1_ind,nb,ne)) + endif + if (slc2_ind > 0) then + call read_vardata(dset_sfc, 'slc2', values_2d, errcode=iret) + if (iret /= 0) then + print *,'error reading slc2' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(n3d) + slc2_ind,nb,ne)) + endif + if (slc3_ind > 0) then + call read_vardata(dset_sfc, 'slc3', values_2d, errcode=iret) + if (iret /= 0) then + print *,'error reading slc3' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(n3d) + slc3_ind,nb,ne)) + endif + if (slc4_ind > 0) then + call read_vardata(dset_sfc, 'slc4', values_2d, errcode=iret) + if (iret /= 0) then + print *,'error reading slc2' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + call copytogrdin(ug,grdin(:,levels(n3d) + slc4_ind,nb,ne)) + endif + + call close_dataset(dset_sfc) + + endif ! sfc read + + if ( allocated(values_2d) ) deallocate(values_2d) + end do backgroundloop ! loop over backgrounds to read in end do ensmemloop ! loop over ens members to read in @@ -1998,6 +2139,15 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n integer k,krev,nt,ierr,iunitsig,nb,i,ne,nanal logical :: nocompress + logical :: write_sfc_file, write_atm_file + + call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, write_sfc_file, write_atm_file) + + if (write_sfc_file .and. nproc==0 ) then + ! adding the sfc increments requires adjusting several other variables. This is done is a separate + ! program. + write(6,*)'gridio/writegriddata: not coded to write sfc analysis, use separate add_incr program instead' + endif nocompress = .true. if (nccompress) nocompress = .false. @@ -3402,7 +3552,7 @@ end subroutine writegriddata subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag) use netcdf use params, only: nbackgrounds,incfileprefixes,fgfileprefixes,reducedgrid,& - datestring,nhr_anal,write_ensmean + datestring,nhr_anal,write_ensmean, fgsfcfileprefixes,incsfcfileprefixes use constants, only: grav use mpi use module_ncio, only: Dataset, Variable, Dimension, open_dataset,& @@ -3438,7 +3588,12 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, integer(i_kind) :: ncid_out, lon_dimid, lat_dimid, lev_dimid, ilev_dimid integer(i_kind) :: lonvarid, latvarid, levvarid, pfullvarid, ilevvarid, & hyaivarid, hybivarid, uvarid, vvarid, delpvarid, delzvarid, & - tvarid, sphumvarid, liqwatvarid, o3varid, icvarid + tvarid, sphumvarid, liqwatvarid, o3varid, icvarid, & + tmp2mvarid, spfh2mvarid, soilt1varid, soilt2varid, & + soilt3varid, soilt4varid, slc1varid, slc2varid, & + slc3varid, slc4varid, maskvarid + integer(i_kind) :: tmp2m_ind, spfh2m_ind, soilt1_ind, soilt2_ind, soilt3_ind, & + soilt4_ind,slc1_ind, slc2_ind, slc3_ind, slc4_ind integer(i_kind) :: iadateout ! fixed fields such as lat, lon, levs @@ -3450,10 +3605,17 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, ! increment real(r_kind), dimension(nlons*nlats) :: psinc, inc, ug, vg, work real(r_single), allocatable, dimension(:,:,:) :: inc3d, inc3d2, inc3dout + real(r_single), allocatable, dimension(:,:) :: inc2d, inc2dout real(r_single), allocatable, dimension(:,:,:) :: tv, tvanl, tmp, tmpanl, q, qanl real(r_kind), allocatable, dimension(:,:) :: values_2d real(r_kind), allocatable, dimension(:) :: psges, delzb, values_1d + ! soil / snow mask (not fixed) + integer(i_kind), dimension(nlons,nlats) :: mask + logical :: write_sfc_file, write_atm_file + + call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, write_sfc_file, write_atm_file) + if ( write_atm_file) then use_full_hydro = .false. clip = tiny_r_kind read(datestring,*) iadateout @@ -3774,14 +3936,267 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, call nccheck_incr(nf90_put_var(ncid_out, icvarid, sngl(inc3dout), & start = ncstart, count = nccount)) + call close_dataset(dsfg,errcode=iret) + if (iret/=0) then + write(6,*)'gridio/writeincrement gfs model: problem closing netcdf fg dataset, iret=',iret + call stop2(23) + endif ! deallocate things deallocate(inc3d,inc3d2,inc3dout) deallocate(tmp,tv,q,tmpanl,tvanl,qanl) - deallocate(delzb,psges) + if (allocated(delzb)) deallocate(delzb) + if (allocated(psges)) deallocate(psges) end do backgroundloop ! loop over backgrounds to read in end do ensmemloop ! loop over ens members to read in + endif ! write_atm_file + + if (write_sfc_file) then + + ne = 0 + sfcensmemloop: do nanal=nanal1,nanal2 + ne = ne + 1 + write(charnanal,'(i3.3)') nanal + sfcbackgroundloop: do nb=1,nbackgrounds + + if (nanal == 0 .and. write_ensmean) then + filenamein = trim(adjustl(datapath))//trim(adjustl(fgsfcfileprefixes(nb)))//"ensmean" + filenameout = trim(adjustl(datapath))//trim(adjustl(incsfcfileprefixes(nb)))//"ensmean" + else + if(no_inflate_flag) then + filenameout = trim(adjustl(datapath))//trim(adjustl(incsfcfileprefixes(nb)))//"nimem"//charnanal + else + filenameout = trim(adjustl(datapath))//trim(adjustl(incsfcfileprefixes(nb)))//"mem"//charnanal + end if + filenamein = trim(adjustl(datapath))//trim(adjustl(fgsfcfileprefixes(nb)))//"mem"//charnanal + endif + + ! create the output netCDF increment file + call nccheck_incr(nf90_create(path=trim(filenameout), cmode=nf90_netcdf4, ncid=ncid_out)) + + ! create dimensions based on analysis resolution, not guess + call nccheck_incr(nf90_def_dim(ncid_out, "longitude", nlons, lon_dimid)) + call nccheck_incr(nf90_def_dim(ncid_out, "latitude", nlats, lat_dimid)) + ! create variables + call nccheck_incr(nf90_def_var(ncid_out, "longitude", nf90_real, (/lon_dimid/), lonvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "latitude", nf90_real, (/lat_dimid/), latvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "tmp2m_inc", nf90_real, dimids3(1:2), tmp2mvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "spfh2m_inc", nf90_real, dimids3(1:2), spfh2mvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt1_inc", nf90_real, dimids3(1:2), soilt1varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt2_inc", nf90_real, dimids3(1:2), soilt2varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt3_inc", nf90_real, dimids3(1:2), soilt3varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt4_inc", nf90_real, dimids3(1:2), soilt4varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc1_inc", nf90_real, dimids3(1:2), slc1varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc2_inc", nf90_real, dimids3(1:2), slc2varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc3_inc", nf90_real, dimids3(1:2), slc3varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc4_inc", nf90_real, dimids3(1:2), slc4varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilsnow_mask", nf90_int, dimids3(1:2), maskvarid)) + ! place global attributes to serial calc_increment output + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "source", "GSI EnKF")) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "comment", & + "global landsfc anal increment from writeincrement")) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "analysis_time", iadateout)) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "IAU_hour_from_guess", nhr_anal(nb))) + ! add units to lat/lon because that's what the calc_increment utility has + call nccheck_incr(nf90_put_att(ncid_out, lonvarid, "units", "degrees_east")) + call nccheck_incr(nf90_put_att(ncid_out, latvarid, "units", "degrees_north")) + ! end the netCDF file definition + call nccheck_incr(nf90_enddef(ncid_out)) + + tmp2m_ind = getindex(vars2d, 't2m') !< indices in the state or control var arrays + spfh2m_ind = getindex(vars2d, 'q2m') + soilt1_ind = getindex(vars2d, 'st1') + slc1_ind = getindex(vars2d, 'sl1') + soilt2_ind = getindex(vars2d, 'st2') + slc2_ind = getindex(vars2d, 'sl2') + soilt3_ind = getindex(vars2d, 'st3') + slc3_ind = getindex(vars2d, 'sl3') + soilt4_ind = getindex(vars2d, 'st4') + slc4_ind = getindex(vars2d, 'sl4') + + dsfg = open_dataset(filenamein) + + ! longitudes + call read_vardata(dsfg, 'grid_xt', values_1d, errcode=iret) + deglons(:) = values_1d + call nccheck_incr(nf90_put_var(ncid_out, lonvarid, deglons, & + start = (/1/), count = (/nlons/))) + + call read_vardata(dsfg, 'grid_yt', values_1d, errcode=iret) + ! latitudes + do j=1,nlats + deglats(nlats-j+1) = values_1d(j) + end do + + call nccheck_incr(nf90_put_var(ncid_out, latvarid, deglats, & + start = (/1/), count = (/nlats/))) + + ! construct mask (1 - soil, 2 - snow, 0 - not snow) + ! note: same logic/threshold used in global_cycle to produce + ! mask on model grid. + + call read_vardata(dsfg, 'slc1', values_2d, errcode=iret) + + mask = 0 + do j=1,nlats + do i = 1, nlons + if (values_2d(i,j) .LT. 1.0) then + mask(i,nlats-j+1) = 1 + endif + enddo + end do + + call read_vardata(dsfg, 'weasd', values_2d, errcode=iret) + do j=1,nlats + do i = 1, nlons + if (values_2d(i,j) .GT. 0.001) then + mask(i,nlats-j+1) = 2 + endif + enddo + end do + call nccheck_incr(nf90_put_var(ncid_out, maskvarid, mask, & + start = ncstart(1:2), count = nccount(1:2))) + + allocate(inc2d(nlons,nlats)) + allocate(inc2dout(nlons,nlats)) + + ! tmp2m increment + inc(:) = zero + if (tmp2m_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d) + tmp2m_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, tmp2mvarid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! spfh2m increment + inc(:) = zero + if (spfh2m_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+spfh2m_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, spfh2mvarid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! soilt1 increment + inc(:) = zero + if (soilt1_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+soilt1_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + inc2dout=0. + do j=1,nlats + do i = 1, nlons + if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j) + enddo + end do + call nccheck_incr(nf90_put_var(ncid_out, soilt1varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! soilt2 increment + inc(:) = zero + if (soilt2_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+soilt2_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + inc2dout=0. + do j=1,nlats + do i = 1, nlons + if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j) + enddo + end do + call nccheck_incr(nf90_put_var(ncid_out, soilt2varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! soilt3 increment + inc(:) = zero + if (soilt3_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+soilt3_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + inc2dout=0. + do j=1,nlats + do i = 1, nlons + if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j) + enddo + end do + call nccheck_incr(nf90_put_var(ncid_out, soilt3varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! soilt4 increment + inc(:) = zero + if (soilt4_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+soilt4_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + inc2dout=0. + do j=1,nlats + do i = 1, nlons + if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j) + enddo + end do + call nccheck_incr(nf90_put_var(ncid_out, soilt4varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! slc1 increment + inc(:) = zero + if (slc1_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+slc1_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, slc1varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! slc2 increment + inc(:) = zero + if (slc2_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+slc2_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, slc2varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! slc3 increment + inc(:) = zero + if (slc3_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+slc3_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, slc3varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! slc4 increment + inc(:) = zero + if (slc4_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+slc4_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, slc4varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + + call close_dataset(dsfg,errcode=iret) + if (iret/=0) then + write(6,*)'gridio/writeincrement gfs model: problem closing netcdf sfc fg dataset, iret=',iret + call stop2(23) + endif + ! deallocate things + deallocate(inc2d,inc2dout) + + end do sfcbackgroundloop ! loop over backgrounds to read in + end do sfcensmemloop ! loop over ens members to read in + + endif ! write_sfc_file + return contains @@ -4402,6 +4817,64 @@ end subroutine copyfromgrdin end subroutine writeincrement_pnc + subroutine set_ncio_file_flags(vars3d, n3d, vars2d, n2d, sfc_file, atm_file) + ! determine if variables are in sfc and/or atm file, for ncio case. + character(len=max_varname_length), dimension(n2d), intent(in) :: vars2d + character(len=max_varname_length), dimension(n3d), intent(in) :: vars3d + integer, intent(in) :: n2d, n3d + logical, intent(out) :: sfc_file, atm_file + + integer(i_kind) :: u_ind, v_ind, tv_ind, q_ind, oz_ind, cw_ind + integer(i_kind) :: qr_ind, qs_ind, qg_ind + integer(i_kind) :: tsen_ind, ql_ind, qi_ind, prse_ind + integer(i_kind) :: ps_ind, pst_ind, sst_ind + integer(i_kind) :: tmp2m_ind, spfh2m_ind, soilt1_ind, soilt2_ind, soilt3_ind + integer(i_kind) :: soilt4_ind,slc1_ind, slc2_ind, slc3_ind, slc4_ind + + ! atmos file variables + u_ind = getindex(vars3d, 'u') !< indices in the state or control var arrays + v_ind = getindex(vars3d, 'v') ! U and V (3D) + tv_ind = getindex(vars3d, 'tv') ! Tv (3D) + q_ind = getindex(vars3d, 'q') ! Q (3D) + oz_ind = getindex(vars3d, 'oz') ! Oz (3D) + cw_ind = getindex(vars3d, 'cw') ! CW (3D) + tsen_ind = getindex(vars3d, 'tsen') !sensible T (3D) + ql_ind = getindex(vars3d, 'ql') ! QL (3D) + qi_ind = getindex(vars3d, 'qi') ! QI (3D) + prse_ind = getindex(vars3d, 'prse') + qr_ind = getindex(vars3d, 'qr') ! QR (3D) + qs_ind = getindex(vars3d, 'qs') ! QS (3D) + qg_ind = getindex(vars3d, 'qg') ! QG (3D) + ps_ind = getindex(vars2d, 'ps') ! Ps (2D) + pst_ind = getindex(vars2d, 'pst') ! Ps tendency (2D) // equivalent of + ! old logical massbal_adjust, if non-zero + sst_ind = getindex(vars2d, 'sst') ! is this really in the atmos file? + + ! for nc gfs io determine if requested variables are in sfc and/or atmos file + atm_file = ( u_ind>0 .or. v_ind>0 .or. tv_ind>0 .or. q_ind>0 .or. sst_ind>0 .or. & + oz_ind>0 .or. cw_ind>0 .or. tsen_ind>0 .or. ql_ind>0 .or. & + qi_ind>0 .or. prse_ind>0 .or. qr_ind>0 .or. qs_ind>0 .or. qg_ind>0 ) + + ! sfc file variables + tmp2m_ind = getindex(vars2d, 't2m') + spfh2m_ind = getindex(vars2d, 'q2m') + soilt1_ind = getindex(vars2d, 'st1') + slc1_ind = getindex(vars2d, 'sl1') + soilt2_ind = getindex(vars2d, 'st2') + slc2_ind = getindex(vars2d, 'sl2') + soilt3_ind = getindex(vars2d, 'st3') + slc3_ind = getindex(vars2d, 'sl3') + soilt4_ind = getindex(vars2d, 'st4') + slc4_ind = getindex(vars2d, 'sl4') + + sfc_file = ( tmp2m_ind > 0 .or. spfh2m_ind > 0 .or. soilt1_ind > 0 .or. & + slc1_ind > 0 .or. soilt2_ind > 0 .or. slc2_ind > 0 .or. & + soilt3_ind > 0 .or. slc3_ind > 0 .or. soilt4_ind > 0 .or. & + slc4_ind > 0 ) + + end subroutine set_ncio_file_flags + + logical function checkfield(field,fields,nrec) result(hasfield) use nemsio_module, only: nemsio_charkind integer, intent(in) :: nrec diff --git a/src/enkf/params.f90 b/src/enkf/params.f90 index 593e5a5ec4..b21d88abd0 100644 --- a/src/enkf/params.f90 +++ b/src/enkf/params.f90 @@ -85,7 +85,9 @@ module params character(len=120),dimension(7),public :: statefileprefixes character(len=120),dimension(7),public :: statesfcfileprefixes character(len=120),dimension(7),public :: anlfileprefixes +character(len=120),dimension(7),public :: anlsfcfileprefixes character(len=120),dimension(7),public :: incfileprefixes +character(len=120),dimension(7),public :: incsfcfileprefixes ! analysis date string (YYYYMMDDHH) character(len=10), public :: datestring ! Hour for datestring @@ -266,7 +268,7 @@ module params lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh,& lnsigcutoffpsnh,lnsigcutoffpstr,lnsigcutoffpssh,& fgfileprefixes,fgsfcfileprefixes,anlfileprefixes, & - incfileprefixes, & + anlsfcfileprefixes,incfileprefixes,incsfcfileprefixes,& statefileprefixes,statesfcfileprefixes, & covl_minfact,covl_efold,lupd_obspace_serial,letkf_novlocal,& analpertwtnh,analpertwtsh,analpertwttr,sprd_tol,& @@ -460,8 +462,8 @@ subroutine read_namelist() ! Initialize first-guess and analysis file name prefixes. ! (blank means use default names) fgfileprefixes = ''; anlfileprefixes=''; statefileprefixes='' -fgsfcfileprefixes = ''; statesfcfileprefixes='' -incfileprefixes = '' +anlsfcfileprefixes=''; fgsfcfileprefixes = ''; statesfcfileprefixes='' +incfileprefixes = ''; incsfcfileprefixes = '' ! option for including convective clouds in the all-sky cnvw_option=.false. @@ -720,7 +722,7 @@ subroutine read_namelist() endif endif if (trim(fgsfcfileprefixes(nbackgrounds+1)) .eq. "") then - fgsfcfileprefixes(nbackgrounds+1)="sfgsfc_"//datestring//"_fhr"//charfhr_anal(nbackgrounds+1)//"_" + fgsfcfileprefixes(nbackgrounds+1)="bfg_"//datestring//"_fhr"//charfhr_anal(nbackgrounds+1)//"_" end if nbackgrounds = nbackgrounds+1 end do @@ -742,7 +744,7 @@ subroutine read_namelist() endif endif if (trim(statesfcfileprefixes(nstatefields+1)) .eq. "") then - statesfcfileprefixes(nstatefields+1)="sfgsfc_"//datestring//"_fhr"//charfhr_state(nstatefields+1)//"_" + statesfcfileprefixes(nstatefields+1)="bfg_"//datestring//"_fhr"//charfhr_state(nstatefields+1)//"_" end if nstatefields = nstatefields+1 end do @@ -762,6 +764,23 @@ subroutine read_namelist() incfileprefixes(nb)="incr_"//datestring//"_fhr"//charfhr_anal(nb)//"_" ! else ! anlfileprefixes(nb)="sanl_"//datestring//"_" +! endif + endif + endif + if (trim(anlsfcfileprefixes(nb)) .eq. "") then + ! default analysis file prefix + if (regional) then + if (nbackgrounds > 1) then + anlsfcfileprefixes(nb)="sfc_analysis_fhr"//charfhr_anal(nb)//"." + else + anlsfcfileprefixes(nb)="sfc_analysis." + endif + else ! global +! if (nbackgrounds > 1) then + anlsfcfileprefixes(nb)="banl_"//datestring//"_fhr"//charfhr_anal(nb)//"_" + incsfcfileprefixes(nb)="sfcincr_"//datestring//"_fhr"//charfhr_anal(nb)//"_" +! else +! anlfileprefixes(nb)="sanl_"//datestring//"_" ! endif endif endif diff --git a/src/enkf/readconvobs.f90 b/src/enkf/readconvobs.f90 index f3b1e38f04..d1f4ec3ff8 100644 --- a/src/enkf/readconvobs.f90 +++ b/src/enkf/readconvobs.f90 @@ -24,6 +24,7 @@ module readconvobs ! reflectivity and radial velocity assimilation. POC: xuguang.wang@ou.edu ! 2017-12-13 shlyaeva - added netcdf diag read/write capability ! 2019-03-21 CAPS(C. Tong) - added direct reflectivity DA capability +! 2022-03-23 draper - added option to not scale qobs by forecast qsat. ! ! attributes: ! language: f95 @@ -32,7 +33,8 @@ module readconvobs use kinds, only: r_kind,i_kind,r_single,r_double use constants, only: one,zero,deg2rad -use params, only: npefiles, netcdf_diag, modelspace_vloc, l_use_enkf_directZDA +use params, only: npefiles, netcdf_diag, modelspace_vloc, & + l_use_enkf_directZDA implicit none private @@ -329,7 +331,6 @@ subroutine get_num_convobs_nc(obspath,datestring,num_obs_tot,num_obs_totdiag,id) call nc_diag_read_close(obsfile) - num_obs_totdiag = num_obs_totdiag + nobs_curr do i = 1, nobs_curr diff --git a/src/enkf/statevec.f90 b/src/enkf/statevec.f90 index d1be91af3c..5ad70346aa 100644 --- a/src/enkf/statevec.f90 +++ b/src/enkf/statevec.f90 @@ -14,7 +14,7 @@ module statevec ! ! Public Variables: ! nanals: (integer scalar) number of ensemble members (from module params) -! nlevs: number of analysis vertical levels (from module params). +! nlevs: number of analysis atmos vertical levels (from module params). ! ns3d: number of 3D variables ! ns2d: number of 2D variables ! svars3d: names of 3D variables @@ -120,7 +120,7 @@ subroutine init_statevec() svars3d(ns3d)=trim(adjustl(var)) slevels(ns3d)=ilev + slevels(ns3d-1) else - if (nproc .eq. 0) print *,'Error: only ', nlevs, ' and ', nlevs+1,' number of levels is supported in current version, got ',ilev + if (nproc .eq. 0) print *,'Error statevec: - only ', nlevs, ' and ', nlevs+1,' number of levels is supported in current version, got ',ilev call stop2(503) endif enddo diff --git a/src/gsi/general_read_gfsatm.f90 b/src/gsi/general_read_gfsatm.f90 index 0216b95fb6..ffdcd90c79 100755 --- a/src/gsi/general_read_gfsatm.f90 +++ b/src/gsi/general_read_gfsatm.f90 @@ -411,6 +411,77 @@ subroutine general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & return end subroutine general_reload2 + +! 2m reload +subroutine general_reload_sfc(grd,g_t2m, g_q2m,g_ps,icount,iflag,work) +! !USES: + use kinds, only: r_kind,i_kind + use mpimod, only: npe,mpi_comm_world,ierror,mpi_rtype + use general_sub2grid_mod, only: sub2grid_info + + implicit none +! !INPUT PARAMETERS: + + type(sub2grid_info), intent(in ) :: grd + integer(i_kind), intent(inout) :: icount + integer(i_kind),dimension(npe), intent(inout) :: iflag + real(r_kind),dimension(grd%itotsub),intent(in ) :: work + +! !OUTPUT PARAMETERS: + + real(r_kind),dimension(grd%lat2,grd%lon2), intent( out) :: g_t2m,& + g_q2m, g_ps + +! !DESCRIPTION: version of general_reload, for 2m variables. +! +! !REVISION HISTORY: +! 2023-03-2 Draper +!------------------------------------------------------------------------- + + integer(i_kind) i,j,ij,k + real(r_kind),dimension(grd%lat2*grd%lon2,npe):: sub + + call mpi_alltoallv(work,grd%sendcounts_s,grd%sdispls_s,mpi_rtype,& + sub,grd%recvcounts_s,grd%rdispls_s,mpi_rtype,& + mpi_comm_world,ierror) + +!$omp parallel do schedule(dynamic,1) private(k,i,j,ij) + + do k=1,icount + if ( iflag(k) == 2 ) then + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_t2m(i,j)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 3 ) then + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_q2m(i,j)=sub(ij,k) + enddo + enddo + elseif ( iflag(k) == 4 ) then + ij=0 + do j=1,grd%lon2 + do i=1,grd%lat2 + ij=ij+1 + g_ps(i,j)=sub(ij,k) + enddo + enddo + endif + enddo ! do k=1,icount + + icount=0 + iflag=0 + + return + +end subroutine general_reload_sfc + end module gfsreadmod subroutine general_read_gfsatm(grd,sp_a,sp_b,filename,uvflag,vordivflag,zflag, & @@ -431,6 +502,7 @@ subroutine general_read_gfsatm(grd,sp_a,sp_b,filename,uvflag,vordivflag,zflag, & ! 2014-11-30 todling - genelize interface to handle bundle instead of fields; ! internal code should be generalized ! 2014-12-03 derber - introduce vordivflag, zflag and optimize routines +! 2023-03-23 draper - added option to read sfc files (for 2m variables) ! ! input argument list: ! grd - structure variable containing information about grid @@ -1892,7 +1964,7 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & use gsi_bundlemod, only: gsi_bundlegetpointer use module_ncio, only: Dataset, Variable, Dimension, open_dataset,& close_dataset, get_dim, read_vardata,get_idate_from_time_units - use gfsreadmod, only: general_reload + use gfsreadmod, only: general_reload, general_reload_sfc implicit none @@ -1910,6 +1982,7 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & real(r_kind),pointer,dimension(:,:) :: ptr2d real(r_kind),pointer,dimension(:,:,:) :: ptr3d real(r_kind),pointer,dimension(:,:) :: g_ps + real(r_kind),pointer,dimension(:,:) :: g_t2m, g_q2m real(r_kind),pointer,dimension(:,:,:) :: g_vor,g_div,& g_cwmr,g_q,g_oz,g_tv @@ -1942,10 +2015,9 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & logical :: procuse,diff_res,eqspace type(egrid2agrid_parm) :: p_high logical,dimension(1) :: vector - type(Dataset) :: atmges + type(Dataset) :: filges type(Dimension) :: ncdim - - + logical :: read_2m, read_z !****************************************************************************** ! Initialize variables used below @@ -1959,6 +2031,19 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & mype_use=-1 icount=0 procuse=.false. + + if (filename(1:3) == 'sfc') then + read_2m = .true. + read_z = .false. + if ( mype == 0 ) write(6,* ) & + trim(my_name), ': reading 2m variables from ', trim(filename) + else + read_2m = .false. + read_z = zflag + if ( mype == 0 ) write(6,* ) & + trim(my_name), ': reading atmos variables from ', trim(filename) + endif + if ( mype == 0 ) procuse = .true. do i=1,npe if ( grd%recvcounts_s(i-1) > 0 ) then @@ -1992,20 +2077,21 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & if ( procuse ) then - atmges = open_dataset(filename, paropen=.true., mpicomm=mpi_comm_read) + filges = open_dataset(filename, paropen=.true., mpicomm=mpi_comm_read) ! get dimension sizes - ncdim = get_dim(atmges, 'grid_xt'); lonb = ncdim%len - ncdim = get_dim(atmges, 'grid_yt'); latb = ncdim%len - ncdim = get_dim(atmges, 'pfull'); levs = ncdim%len + ncdim = get_dim(filges, 'grid_xt'); lonb = ncdim%len + ncdim = get_dim(filges, 'grid_yt'); latb = ncdim%len + if (.not. read_2m) & + ncdim = get_dim(filges, 'pfull'); levs = ncdim%len ! get time information - idate = get_idate_from_time_units(atmges) + idate = get_idate_from_time_units(filges) odate(1) = idate(4) !hour odate(2) = idate(2) !month odate(3) = idate(3) !day odate(4) = idate(1) !year - call read_vardata(atmges, 'time', fhour) ! might need to change this to attribute later + call read_vardata(filges, 'time', fhour) ! might need to change this to attribute later ! depends on model changes from ! Jeff Whitaker fhour = float(nint(fhour)) @@ -2030,11 +2116,13 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & trim(my_name),grd%nlon,lonb !call stop2(101) endif - if ( levs /= grd%nsig ) then - if ( mype == 0 ) write(6, & - '(a,'': inconsistent spatial dimension nsig = '',i4,tr1,''levs = '',i4)') & - trim(my_name),grd%nsig,levs - call stop2(101) + if (.not. read_2m) then + if ( levs /= grd%nsig ) then + if ( mype == 0 ) write(6, & + '(a,'': inconsistent spatial dimension nsig = '',i4,tr1,''levs = '',i4)') & + trim(my_name),grd%nsig,levs + call stop2(101) + endif endif allocate( spec_vor(sp_a%nc), spec_div(sp_a%nc) ) @@ -2047,8 +2135,8 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & allocate(rwork3d1(lonb,latb,1)) allocate(rwork2d(lonb,latb)) allocate(rlats(latb+2),rlons(lonb),clons(lonb),slons(lonb)) - call read_vardata(atmges, 'grid_xt', rlons_tmp) - call read_vardata(atmges, 'grid_yt', rlats_tmp) + call read_vardata(filges, 'grid_xt', rlons_tmp) + call read_vardata(filges, 'grid_yt', rlats_tmp) do j=1,latb rlats(latb+2-j)=deg2rad*rlats_tmp(j) end do @@ -2073,57 +2161,73 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & endif ! if ( procuse ) ! Get pointer to relevant variables (this should be made flexible and general) - iredundant=0 - call gsi_bundlegetpointer(gfs_bundle,'sf',g_div ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - call gsi_bundlegetpointer(gfs_bundle,'div',g_div ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - if ( iredundant==2 ) then - if ( mype == 0 ) then - write(6,*) 'general_read_gfsatm_nems: ERROR' - write(6,*) 'cannot handle having both sf and div' - write(6,*) 'Aborting ... ' - endif - call stop2(999) - endif - iredundant=0 - call gsi_bundlegetpointer(gfs_bundle,'vp',g_vor ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - call gsi_bundlegetpointer(gfs_bundle,'vor',g_vor ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - if ( iredundant==2 ) then - if ( mype == 0 ) then - write(6,*) 'general_read_gfsatm_nems: ERROR' - write(6,*) 'cannot handle having both vp and vor' - write(6,*) 'Aborting ... ' - endif - call stop2(999) - endif - iredundant=0 - call gsi_bundlegetpointer(gfs_bundle,'t' ,g_tv ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - call gsi_bundlegetpointer(gfs_bundle,'tv',g_tv ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - if ( iredundant==2 ) then - if ( mype == 0 ) then - write(6,*) 'general_read_gfsatm_nems: ERROR' - write(6,*) 'cannot handle having both t and tv' - write(6,*) 'Aborting ... ' - endif - call stop2(999) - endif - istatus=0 - call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus=istatus+ier - call gsi_bundlegetpointer(gfs_bundle,'q' ,g_q ,ier);istatus=istatus+ier - call gsi_bundlegetpointer(gfs_bundle,'oz',g_oz ,ier);istatus=istatus+ier - call gsi_bundlegetpointer(gfs_bundle,'cw',g_cwmr,ier);istatus=istatus+ier - if ( istatus /= 0 ) then - if ( mype == 0 ) then - write(6,*) 'general_read_gfsatm_nems: ERROR' - write(6,*) 'Missing some of the required fields' - write(6,*) 'Aborting ... ' - endif - call stop2(999) + if (.not. read_2m) then + iredundant=0 + call gsi_bundlegetpointer(gfs_bundle,'sf',g_div ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + call gsi_bundlegetpointer(gfs_bundle,'div',g_div ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + if ( iredundant==2 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_nc: ERROR' + write(6,*) 'cannot handle having both sf and div' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + iredundant=0 + call gsi_bundlegetpointer(gfs_bundle,'vp',g_vor ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + call gsi_bundlegetpointer(gfs_bundle,'vor',g_vor ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + if ( iredundant==2 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_nc: ERROR' + write(6,*) 'cannot handle having both vp and vor' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + iredundant=0 + call gsi_bundlegetpointer(gfs_bundle,'t' ,g_tv ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + call gsi_bundlegetpointer(gfs_bundle,'tv',g_tv ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + if ( iredundant==2 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_nc: ERROR' + write(6,*) 'cannot handle having both t and tv' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + + istatus=0 + call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus=istatus+ier + call gsi_bundlegetpointer(gfs_bundle,'q' ,g_q ,ier);istatus=istatus+ier + call gsi_bundlegetpointer(gfs_bundle,'oz',g_oz ,ier);istatus=istatus+ier + call gsi_bundlegetpointer(gfs_bundle,'cw',g_cwmr,ier);istatus=istatus+ier + if ( istatus /= 0 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_nc: ERROR' + write(6,*) 'Missing some of the required fields' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + else ! read 2m vars + istatus=0 + call gsi_bundlegetpointer(gfs_bundle,'t2m',g_t2m ,ier);istatus=istatus+ier + call gsi_bundlegetpointer(gfs_bundle,'q2m',g_q2m ,ier);istatus=istatus+ier + call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus=istatus+ier + if ( istatus /= 0 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_nc: ERROR' + write(6,*) 'Missing 2m required variables' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif endif allocate(g_u(grd%lat2,grd%lon2,grd%nsig),g_v(grd%lat2,grd%lon2,grd%nsig)) allocate(g_z(grd%lat2,grd%lon2)) @@ -2135,8 +2239,8 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & ! Once on the grid, fields need to be scattered from the full domain to ! sub-domains. - ! Only read Terrain when zflag is true. - if ( zflag ) then + ! Only read Terrain when read_z is true. + if ( read_z ) then icount=icount+1 iflag(icount)=1 @@ -2145,7 +2249,7 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & ! Terrain: spectral --> grid transform, scatter to all mpi tasks if (mype==mype_use(icount)) then ! read hs - call read_vardata(atmges, 'hgtsfc', rwork2d) + call read_vardata(filges, 'hgtsfc', rwork2d) if ( diff_res ) then grid_b=rwork2d vector(1)=.false. @@ -2161,415 +2265,498 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & call general_fill_ns(grd,grid,work) endif endif - if ( icount == icm ) then + if ( icount == icm ) then call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & icount,iflag,ilev,work,uvflag,vordivflag) endif endif - icount=icount+1 - iflag(icount)=2 - ilev(icount)=1 + if (.not. read_2m) then + + icount=icount+1 + iflag(icount)=2 + ilev(icount)=1 + + ! Surface pressure: same procedure as terrain + if (mype==mype_use(icount)) then + ! read ps + call read_vardata(filges, 'pressfc', rwork2d) + rwork2d = r0_001*rwork2d ! convert Pa to cb + if ( diff_res ) then + vector(1)=.false. + grid_b=rwork2d + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif + + ! Thermodynamic variable: s-->g transform, communicate to all tasks + ! For multilevel fields, each task handles a given level. Periodic + ! mpi_alltoallv calls communicate the grids to all mpi tasks. + ! Finally, the grids are loaded into guess arrays used later in the + ! code. + + do k=1,nlevs + + icount=icount+1 + iflag(icount)=3 + ilev(icount)=k + kr = levs+1-k ! netcdf is top to bottom, need to flip + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'spfh', rwork3d1, nslice=kr, slicedim=3) + call read_vardata(filges, 'tmp', rwork3d0, nslice=kr, slicedim=3) + rwork2d = rwork3d0(:,:,1) * (one+fv*rwork3d1(:,:,1)) + if ( diff_res ) then + grid_b=rwork2d + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif + end do + + if ( vordivflag .or. .not. uvflag ) then + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + icount=icount+1 + iflag(icount)=4 + ilev(icount)=k + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) + ! Vorticity + ! Convert grid u,v to div and vor + if ( diff_res ) then + grid_b = rwork3d0(:,:,1) + grid_b2 = rwork3d1(:,:,1) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid(j,grd%nlat-i)=grid2(i,j,1) + enddo + enddo + call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work_v(kk)=grid2(i,j,1) + enddo + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid_v(j,grd%nlat-i)=grid2(i,j,1) + enddo + enddo + else + grid = rwork3d0(:,:,1) + grid_v = rwork3d1(:,:,1) + call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) + endif + allocate( grid_vor(grd%nlon,nlatm2)) + call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1) + call general_sptez_s_b(sp_a,sp_a,spec_vor,grid_vor,1) + ! Load values into rows for south and north pole + call general_fill_ns(grd,grid_vor,work) + deallocate(grid_vor) + endif + if ( icount == icm ) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif + + end do + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + + icount=icount+1 + iflag(icount)=5 + ilev(icount)=k + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) + ! Divergence + ! Convert grid u,v to div and vor + if ( diff_res ) then + grid_b = rwork3d0(:,:,1) + grid_b2 = rwork3d1(:,:,1) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid(j,grd%nlat-i)=grid2(i,j,1) + enddo + enddo + call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work_v(kk)=grid2(i,j,1) + enddo + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid_v(j,grd%nlat-i)=grid2(i,j,1) + enddo + enddo + else + grid = rwork3d0(:,:,1) + grid_v = rwork3d1(:,:,1) + call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) + endif + allocate( grid_div(grd%nlon,nlatm2) ) + call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1) + call general_sptez_s_b(sp_a,sp_a,spec_div,grid_div,1) + ! Load values into rows for south and north pole + call general_fill_ns(grd,grid_div,work) + deallocate(grid_div) + endif + if ( icount == icm ) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif + + end do + endif ! if ( vordivflag .or. .not. uvflag ) + if ( uvflag ) then + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + icount=icount+1 + iflag(icount)=6 + ilev(icount)=k + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) + + if ( diff_res ) then + grid_b = rwork3d0(:,:,1) + grid_b2 = rwork3d1(:,:,1) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid = rwork3d0(:,:,1) + grid_v = rwork3d1(:,:,1) + call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) + endif + endif + if ( icount == icm ) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif + + icount=icount+1 + iflag(icount)=7 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! V + call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) + if ( diff_res ) then + grid_b = rwork3d0(:,:,1) + grid_b2 = rwork3d1(:,:,1) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid = rwork3d0(:,:,1) + grid_v = rwork3d1(:,:,1) + ! Note work_v and work are switched because output must be in work. + call general_filluv_ns(grd,slons,clons,grid,grid_v,work_v,work) + endif + endif + if ( icount == icm ) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif + end do + endif ! if ( uvflag ) + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + icount=icount+1 + iflag(icount)=8 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! Specific humidity + call read_vardata(filges, 'spfh', rwork3d0, nslice=kr, slicedim=3) + if ( diff_res ) then + grid_b=rwork3d0(:,:,1) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid = rwork3d0(:,:,1) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif + end do + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + + icount=icount+1 + iflag(icount)=9 + ilev(icount)=k + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'o3mr', rwork3d0, nslice=kr, slicedim=3) + ! Ozone mixing ratio + if ( diff_res ) then + grid_b=rwork3d0(:,:,1) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork3d0(:,:,1) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif + end do + + do k=1,nlevs + icount=icount+1 + iflag(icount)=10 + ilev(icount)=k + kr = levs+1-k ! netcdf is top to bottom, need to flip + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'clwmr', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(filges, 'icmr', rwork3d1, nslice=kr, slicedim=3) + ! Cloud condensate mixing ratio. + rwork2d = rwork3d0(:,:,1)+rwork3d1(:,:,1) + if ( diff_res ) then + grid_b=rwork2d + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + + endif + + if ( icount == icm .or. k == nlevs ) then + call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & + icount,iflag,ilev,work,uvflag,vordivflag) + endif + + enddo ! do k=1,nlevs + else ! read_2m + + icount=icount+1 + iflag(icount)=2 + + ! 2m temperature from sfc file + if (mype==mype_use(icount)) then + call read_vardata(filges, 'tmp2m', rwork2d) + + if ( diff_res ) then + vector(1)=.false. + grid_b=rwork2d + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + endif + + icount=icount + 1 + iflag(icount)=3 + + ! 2m humidity from sfc file + if (mype==mype_use(icount)) then + call read_vardata(filges, 'spfh2m', rwork2d) + + if ( diff_res ) then + vector(1)=.false. + grid_b=rwork2d + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + endif + + icount=icount + 1 + iflag(icount)=4 + + if (mype==mype_use(icount)) then + ! read ps + call read_vardata(filges, 'pressfc', rwork2d) + rwork2d = r0_001*rwork2d ! convert Pa to cb + if ( diff_res ) then + vector(1)=.false. + grid_b=rwork2d + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + endif + + ! not using all procs. doesn't trigger. todo: figure out trigger + ! for when reading fewer vars. + !if ( icount == icm ) then + call general_reload_sfc(grd,g_t2m, g_q2m, g_ps, icount,iflag,work) + !endif + + endif ! read_2m - ! Surface pressure: same procedure as terrain - if (mype==mype_use(icount)) then - ! read ps - call read_vardata(atmges, 'pressfc', rwork2d) - rwork2d = r0_001*rwork2d ! convert Pa to cb - if ( diff_res ) then - vector(1)=.false. - grid_b=rwork2d - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork2d - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) + if ( procuse ) then + if ( diff_res) deallocate(grid_b,grid_b2,grid_c,grid_c2,grid2) + call destroy_egrid2agrid(p_high) + deallocate(spec_div,spec_vor) + deallocate(rwork3d1,rwork3d0,clons,slons) + deallocate(rwork2d) + deallocate(grid,grid_v) + call close_dataset(filges) endif + deallocate(work) - ! Thermodynamic variable: s-->g transform, communicate to all tasks - ! For multilevel fields, each task handles a given level. Periodic - ! mpi_alltoallv calls communicate the grids to all mpi tasks. - ! Finally, the grids are loaded into guess arrays used later in the - ! code. - - do k=1,nlevs + ! Convert dry temperature to virtual temperature + !do k=1,grd%nsig + ! do j=1,grd%lon2 + ! do i=1,grd%lat2 + ! g_tv(i,j,k) = g_tv(i,j,k)*(one+fv*g_q(i,j,k)) + ! enddo + ! enddo + !enddo - icount=icount+1 - iflag(icount)=3 - ilev(icount)=k - kr = levs+1-k ! netcdf is top to bottom, need to flip + ! Load u->div and v->vor slot when uv are used instead + if ( .not. read_2m ) then + if ( uvflag ) then + call gsi_bundlegetpointer(gfs_bundle,'u' ,ptr3d,ier) + if ( ier == 0 ) then + ptr3d=g_u + call gsi_bundlegetpointer(gfs_bundle,'v' ,ptr3d,ier) + if ( ier == 0 ) ptr3d=g_v + else ! in this case, overload: return u/v in sf/vp slot + call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier) + if ( ier == 0 ) then + ptr3d=g_u + call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier) + if ( ier == 0 ) ptr3d=g_v + endif + endif + else ! in this case, overload: return u/v in sf/vp slot + call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier) + if ( ier == 0 ) ptr3d=g_u + call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier) + if ( ier == 0 ) ptr3d=g_v + endif + endif ! read_2m + if (read_z) then + call gsi_bundlegetpointer(gfs_bundle,'z' ,ptr2d,ier) + if ( ier == 0 ) ptr2d=g_z + endif - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'spfh', rwork3d1, nslice=kr, slicedim=3) - call read_vardata(atmges, 'tmp', rwork3d0, nslice=kr, slicedim=3) - rwork2d = rwork3d0(:,:,1) * (one+fv*rwork3d1(:,:,1)) - if ( diff_res ) then - grid_b=rwork2d - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork2d - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) - endif - end do + ! Clean up + deallocate(g_z) + deallocate(g_u,g_v) - if ( vordivflag .or. .not. uvflag ) then - do k=1,nlevs - kr = levs+1-k ! netcdf is top to bottom, need to flip - icount=icount+1 - iflag(icount)=4 - ilev(icount)=k + ! Print date/time stamp + if ( mype == 0 ) then + write(6,700) lonb,latb,nlevs,grd%nlon,nlatm2,& + fhour,odate,trim(filename) +700 format('GENERAL_READ_GFSATM_NC: read lonb,latb,levs=',& + 3i6,', scatter nlon,nlat=',2i6,', hour=',f6.1,', idate=',4i5,1x,a) + endif - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) - call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) - ! Vorticity - ! Convert grid u,v to div and vor - if ( diff_res ) then - grid_b = rwork3d0(:,:,1) - grid_b2 = rwork3d1(:,:,1) - vector(1)=.true. - call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - do j=1,grd%nlon - do i=2,grd%nlat-1 - grid(j,grd%nlat-i)=grid2(i,j,1) - enddo - enddo - call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work_v(kk)=grid2(i,j,1) - enddo - do j=1,grd%nlon - do i=2,grd%nlat-1 - grid_v(j,grd%nlat-i)=grid2(i,j,1) - enddo - enddo - else - grid = rwork3d0(:,:,1) - grid_v = rwork3d1(:,:,1) - call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) - endif - allocate( grid_vor(grd%nlon,nlatm2)) - call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1) - call general_sptez_s_b(sp_a,sp_a,spec_vor,grid_vor,1) - ! Load values into rows for south and north pole - call general_fill_ns(grd,grid_vor,work) - deallocate(grid_vor) - endif - if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) - endif + return - end do - do k=1,nlevs - kr = levs+1-k ! netcdf is top to bottom, need to flip +end subroutine general_read_gfsatm_nc - icount=icount+1 - iflag(icount)=5 - ilev(icount)=k - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) - call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) - ! Divergence - ! Convert grid u,v to div and vor - if ( diff_res ) then - grid_b = rwork3d0(:,:,1) - grid_b2 = rwork3d1(:,:,1) - vector(1)=.true. - call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - do j=1,grd%nlon - do i=2,grd%nlat-1 - grid(j,grd%nlat-i)=grid2(i,j,1) - enddo - enddo - call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work_v(kk)=grid2(i,j,1) - enddo - do j=1,grd%nlon - do i=2,grd%nlat-1 - grid_v(j,grd%nlat-i)=grid2(i,j,1) - enddo - enddo - else - grid = rwork3d0(:,:,1) - grid_v = rwork3d1(:,:,1) - call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) - endif - allocate( grid_div(grd%nlon,nlatm2) ) - call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1) - call general_sptez_s_b(sp_a,sp_a,spec_div,grid_div,1) - ! Load values into rows for south and north pole - call general_fill_ns(grd,grid_div,work) - deallocate(grid_div) - endif - if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) - endif - - end do - endif ! if ( vordivflag .or. .not. uvflag ) - if ( uvflag ) then - do k=1,nlevs - kr = levs+1-k ! netcdf is top to bottom, need to flip - icount=icount+1 - iflag(icount)=6 - ilev(icount)=k - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) - call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) - - if ( diff_res ) then - grid_b = rwork3d0(:,:,1) - grid_b2 = rwork3d1(:,:,1) - vector(1)=.true. - call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid = rwork3d0(:,:,1) - grid_v = rwork3d1(:,:,1) - call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) - endif - endif - if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) - endif - - icount=icount+1 - iflag(icount)=7 - ilev(icount)=k - - if (mype==mype_use(icount)) then - ! V - call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) - call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) - if ( diff_res ) then - grid_b = rwork3d0(:,:,1) - grid_b2 = rwork3d1(:,:,1) - vector(1)=.true. - call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) - call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid = rwork3d0(:,:,1) - grid_v = rwork3d1(:,:,1) - ! Note work_v and work are switched because output must be in work. - call general_filluv_ns(grd,slons,clons,grid,grid_v,work_v,work) - endif - endif - if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) - endif - end do - endif ! if ( uvflag ) - do k=1,nlevs - kr = levs+1-k ! netcdf is top to bottom, need to flip - icount=icount+1 - iflag(icount)=8 - ilev(icount)=k - - if (mype==mype_use(icount)) then - ! Specific humidity - call read_vardata(atmges, 'spfh', rwork3d0, nslice=kr, slicedim=3) - if ( diff_res ) then - grid_b=rwork3d0(:,:,1) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid = rwork3d0(:,:,1) - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) - endif - end do - do k=1,nlevs - kr = levs+1-k ! netcdf is top to bottom, need to flip - - icount=icount+1 - iflag(icount)=9 - ilev(icount)=k - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'o3mr', rwork3d0, nslice=kr, slicedim=3) - ! Ozone mixing ratio - if ( diff_res ) then - grid_b=rwork3d0(:,:,1) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork3d0(:,:,1) - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) - endif - end do - - do k=1,nlevs - icount=icount+1 - iflag(icount)=10 - ilev(icount)=k - kr = levs+1-k ! netcdf is top to bottom, need to flip - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'clwmr', rwork3d0, nslice=kr, slicedim=3) - call read_vardata(atmges, 'icmr', rwork3d1, nslice=kr, slicedim=3) - ! Cloud condensate mixing ratio. - rwork2d = rwork3d0(:,:,1)+rwork3d1(:,:,1) - if ( diff_res ) then - grid_b=rwork2d - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork2d - call general_fill_ns(grd,grid,work) - endif - - endif - - if ( icount == icm .or. k == nlevs ) then - call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, & - icount,iflag,ilev,work,uvflag,vordivflag) - endif - - enddo ! do k=1,nlevs - - if ( procuse ) then - if ( diff_res) deallocate(grid_b,grid_b2,grid_c,grid_c2,grid2) - call destroy_egrid2agrid(p_high) - deallocate(spec_div,spec_vor) - deallocate(rwork3d1,rwork3d0,clons,slons) - deallocate(rwork2d) - deallocate(grid,grid_v) - call close_dataset(atmges) - endif - deallocate(work) - - ! Convert dry temperature to virtual temperature - !do k=1,grd%nsig - ! do j=1,grd%lon2 - ! do i=1,grd%lat2 - ! g_tv(i,j,k) = g_tv(i,j,k)*(one+fv*g_q(i,j,k)) - ! enddo - ! enddo - !enddo - - ! Load u->div and v->vor slot when uv are used instead - if ( uvflag ) then - call gsi_bundlegetpointer(gfs_bundle,'u' ,ptr3d,ier) - if ( ier == 0 ) then - ptr3d=g_u - call gsi_bundlegetpointer(gfs_bundle,'v' ,ptr3d,ier) - if ( ier == 0 ) ptr3d=g_v - else ! in this case, overload: return u/v in sf/vp slot - call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier) - if ( ier == 0 ) then - ptr3d=g_u - call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier) - if ( ier == 0 ) ptr3d=g_v - endif - endif - else ! in this case, overload: return u/v in sf/vp slot - call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier) - if ( ier == 0 ) ptr3d=g_u - call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier) - if ( ier == 0 ) ptr3d=g_v - endif - if (zflag) then - call gsi_bundlegetpointer(gfs_bundle,'z' ,ptr2d,ier) - if ( ier == 0 ) ptr2d=g_z - endif - - ! Clean up - deallocate(g_z) - deallocate(g_u,g_v) - - ! Print date/time stamp - if ( mype == 0 ) then - write(6,700) lonb,latb,nlevs,grd%nlon,nlatm2,& - fhour,odate,trim(filename) -700 format('GENERAL_READ_GFSATM_NC: read lonb,latb,levs=',& - 3i6,', scatter nlon,nlat=',2i6,', hour=',f6.1,', idate=',4i5,1x,a) - endif - - return - -end subroutine general_read_gfsatm_nc subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, & gfs_bundle,iret_read) !$$$ subprogram documentation block @@ -2618,7 +2805,7 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z use gsi_bundlemod, only: gsi_bundlegetpointer use module_ncio, only: Dataset, Variable, Dimension, open_dataset,& close_dataset, get_dim, read_vardata,get_idate_from_time_units - use gfsreadmod, only: general_reload2 + use gfsreadmod, only: general_reload2, general_reload_sfc use ncepnems_io, only: imp_physics implicit none @@ -2637,6 +2824,7 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z real(r_kind),pointer,dimension(:,:) :: ptr2d real(r_kind),pointer,dimension(:,:,:) :: ptr3d real(r_kind),pointer,dimension(:,:) :: g_ps + real(r_kind),pointer,dimension(:,:) :: g_t2m, g_q2m real(r_kind),pointer,dimension(:,:,:) :: g_vor,g_div,& g_q,g_oz,g_tv real(r_kind),pointer,dimension(:,:,:) :: g_ql,g_qi,g_qr,g_qs,g_qg @@ -2668,8 +2856,9 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z logical :: procuse,diff_res,eqspace type(egrid2agrid_parm) :: p_high logical,dimension(1) :: vector - type(Dataset) :: atmges + type(Dataset) :: filges type(Dimension) :: ncdim + logical :: read_2m, read_z @@ -2685,6 +2874,19 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z mype_use=-1 icount=0 procuse=.false. + + if (filename(1:3) == 'sfc') then + read_2m = .true. + read_z = .false. + if ( mype == 0 ) write(6,* ) & + trim(my_name), ': reading 2m variables from ', trim(filename) + else + read_2m = .false. + read_z = zflag + if ( mype == 0 ) write(6,* ) & + trim(my_name), ': reading atmos variables from ', trim(filename) + endif + if ( mype == 0 ) procuse = .true. do i=1,npe if ( grd%recvcounts_s(i-1) > 0 ) then @@ -2694,26 +2896,26 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z endif enddo icm=icount - allocate( work(grd%itotsub),work_v(grd%itotsub) ) + allocate( work(grd%itotsub)) work=zero - work_v=zero if ( procuse ) then - atmges = open_dataset(filename, paropen=.true.) + filges = open_dataset(filename, paropen=.true.) ! get dimension sizes - ncdim = get_dim(atmges, 'grid_xt'); lonb = ncdim%len - ncdim = get_dim(atmges, 'grid_yt'); latb = ncdim%len - ncdim = get_dim(atmges, 'pfull'); levs = ncdim%len + ncdim = get_dim(filges, 'grid_xt'); lonb = ncdim%len + ncdim = get_dim(filges, 'grid_yt'); latb = ncdim%len + if (.not. read_2m) & + ncdim = get_dim(filges, 'pfull'); levs = ncdim%len ! get time information - idate = get_idate_from_time_units(atmges) + idate = get_idate_from_time_units(filges) odate(1) = idate(4) !hour odate(2) = idate(2) !month odate(3) = idate(3) !day odate(4) = idate(1) !year - call read_vardata(atmges, 'time', fhour) ! might need to change this to attribute later + call read_vardata(filges, 'time', fhour) ! might need to change this to attribute later ! depends on model changes from ! Jeff Whitaker fhour = float(nint(fhour)) @@ -2738,11 +2940,13 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z trim(my_name),grd%nlon,lonb !call stop2(101) endif - if ( levs /= grd%nsig ) then - if ( mype == 0 ) write(6, & - '(a,'': inconsistent spatial dimension nsig = '',i4,tr1,''levs = '',i4)') & - trim(my_name),grd%nsig,levs - call stop2(101) + if (.not. read_2m) then + if ( levs /= grd%nsig ) then + if ( mype == 0 ) write(6, & + '(a,'': inconsistent spatial dimension nsig = '',i4,tr1,''levs = '',i4)') & + trim(my_name),grd%nsig,levs + call stop2(101) + endif endif allocate( spec_vor(sp_a%nc), spec_div(sp_a%nc) ) @@ -2755,8 +2959,8 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z allocate(rwork3d1(lonb,latb,1)) allocate(rwork2d(lonb,latb)) allocate(rlats(latb+2),rlons(lonb),clons(lonb),slons(lonb)) - call read_vardata(atmges, 'grid_xt', rlons_tmp) - call read_vardata(atmges, 'grid_yt', rlats_tmp) + call read_vardata(filges, 'grid_xt', rlons_tmp) + call read_vardata(filges, 'grid_yt', rlats_tmp) do j=1,latb rlats(latb+2-j)=deg2rad*rlats_tmp(j) end do @@ -2781,64 +2985,79 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z endif ! if ( procuse ) ! Get pointer to relevant variables (this should be made flexible and general) - iredundant=0 - call gsi_bundlegetpointer(gfs_bundle,'sf',g_div ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - call gsi_bundlegetpointer(gfs_bundle,'div',g_div ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - if ( iredundant==2 ) then - if ( mype == 0 ) then - write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR' - write(6,*) 'cannot handle having both sf and div' - write(6,*) 'Aborting ... ' - endif - call stop2(999) - endif - iredundant=0 - call gsi_bundlegetpointer(gfs_bundle,'vp',g_vor ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - call gsi_bundlegetpointer(gfs_bundle,'vor',g_vor ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - if ( iredundant==2 ) then - if ( mype == 0 ) then - write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR' - write(6,*) 'cannot handle having both vp and vor' - write(6,*) 'Aborting ... ' - endif - call stop2(999) - endif - iredundant=0 - call gsi_bundlegetpointer(gfs_bundle,'t' ,g_tv ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - call gsi_bundlegetpointer(gfs_bundle,'tv',g_tv ,ier) - if ( ier == 0 ) iredundant = iredundant + 1 - if ( iredundant==2 ) then - if ( mype == 0 ) then - write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR' - write(6,*) 'cannot handle having both t and tv' - write(6,*) 'Aborting ... ' - endif - call stop2(999) - endif - istatus=0 - call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus=istatus+ier - call gsi_bundlegetpointer(gfs_bundle,'q' ,g_q ,ier);istatus=istatus+ier - call gsi_bundlegetpointer(gfs_bundle,'oz',g_oz ,ier);istatus=istatus+ier -! call gsi_bundlegetpointer(gfs_bundle,'cw',g_cwmr,ier);istatus=istatus+ier - istatus1=0 - call gsi_bundlegetpointer(gfs_bundle,'ql',g_ql ,ier);istatus1=istatus1+ier - call gsi_bundlegetpointer(gfs_bundle,'qi',g_qi ,ier);istatus1=istatus1+ier - call gsi_bundlegetpointer(gfs_bundle,'qr',g_qr ,ier);istatus1=istatus1+ier - call gsi_bundlegetpointer(gfs_bundle,'qs',g_qs ,ier);istatus1=istatus1+ier - call gsi_bundlegetpointer(gfs_bundle,'qg',g_qg ,ier);istatus1=istatus1+ier -! call gsi_bundlegetpointer(gfs_bundle,'cf',g_cf ,ier);istatus1=istatus1+ier - if ( istatus1 /= 0 ) then - if ( mype == 0 ) then - write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR' - write(6,*) 'Missing some of the required hydrometeor fields for imp_physics = ', imp_physics - write(6,*) 'Aborting ... ' - endif - call stop2(999) + if (.not. read_2m) then + iredundant=0 + call gsi_bundlegetpointer(gfs_bundle,'sf',g_div ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + call gsi_bundlegetpointer(gfs_bundle,'div',g_div ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + if ( iredundant==2 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR' + write(6,*) 'cannot handle having both sf and div' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + iredundant=0 + call gsi_bundlegetpointer(gfs_bundle,'vp',g_vor ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + call gsi_bundlegetpointer(gfs_bundle,'vor',g_vor ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + if ( iredundant==2 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR' + write(6,*) 'cannot handle having both vp and vor' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + iredundant=0 + call gsi_bundlegetpointer(gfs_bundle,'t' ,g_tv ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + call gsi_bundlegetpointer(gfs_bundle,'tv',g_tv ,ier) + if ( ier == 0 ) iredundant = iredundant + 1 + if ( iredundant==2 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR' + write(6,*) 'cannot handle having both t and tv' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + istatus=0 + call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus=istatus+ier + call gsi_bundlegetpointer(gfs_bundle,'q' ,g_q ,ier);istatus=istatus+ier + call gsi_bundlegetpointer(gfs_bundle,'oz',g_oz ,ier);istatus=istatus+ier + ! call gsi_bundlegetpointer(gfs_bundle,'cw',g_cwmr,ier);istatus=istatus+ier + istatus1=0 + call gsi_bundlegetpointer(gfs_bundle,'ql',g_ql ,ier);istatus1=istatus1+ier + call gsi_bundlegetpointer(gfs_bundle,'qi',g_qi ,ier);istatus1=istatus1+ier + call gsi_bundlegetpointer(gfs_bundle,'qr',g_qr ,ier);istatus1=istatus1+ier + call gsi_bundlegetpointer(gfs_bundle,'qs',g_qs ,ier);istatus1=istatus1+ier + call gsi_bundlegetpointer(gfs_bundle,'qg',g_qg ,ier);istatus1=istatus1+ier + ! call gsi_bundlegetpointer(gfs_bundle,'cf',g_cf ,ier);istatus1=istatus1+ier + if ( istatus1 /= 0 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR' + write(6,*) 'Missing some of the required hydrometeor fields for imp_physics = ', imp_physics + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif + else ! read 2m vars + istatus=0 + call gsi_bundlegetpointer(gfs_bundle,'t2m',g_t2m ,ier);istatus=istatus+ier + call gsi_bundlegetpointer(gfs_bundle,'q2m',g_q2m ,ier);istatus=istatus+ier + call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus=istatus+ier + if ( istatus /= 0 ) then + if ( mype == 0 ) then + write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR' + write(6,*) 'Missing 2m required variables' + write(6,*) 'Aborting ... ' + endif + call stop2(999) + endif endif allocate(g_u(grd%lat2,grd%lon2,grd%nsig),g_v(grd%lat2,grd%lon2,grd%nsig)) @@ -2853,7 +3072,7 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z ! Only read Terrain when zflag is true. - if ( zflag ) then + if ( read_z ) then icount=icount+1 iflag(icount)=1 @@ -2862,7 +3081,7 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z ! Terrain: spectral --> grid transform, scatter to all mpi tasks if (mype==mype_use(icount)) then ! read hs - call read_vardata(atmges, 'hgtsfc', rwork2d) + call read_vardata(filges, 'hgtsfc', rwork2d) if ( diff_res ) then grid_b=rwork2d vector(1)=.false. @@ -2884,465 +3103,470 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z endif endif - icount=icount+1 - iflag(icount)=2 - ilev(icount)=1 - - ! Surface pressure: same procedure as terrain - if (mype==mype_use(icount)) then - ! read ps - call read_vardata(atmges, 'pressfc', rwork2d) - rwork2d = r0_001*rwork2d ! convert Pa to cb - if ( diff_res ) then - vector(1)=.false. - grid_b=rwork2d - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork2d - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - - ! Thermodynamic variable: s-->g transform, communicate to all tasks - ! For multilevel fields, each task handles a given level. Periodic - ! mpi_alltoallv calls communicate the grids to all mpi tasks. - ! Finally, the grids are loaded into guess arrays used later in the - ! code. - - do k=1,nlevs - - icount=icount+1 - iflag(icount)=3 - ilev(icount)=k - kr = levs+1-k ! netcdf is top to bottom, need to flip - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'spfh', rwork3d1, nslice=kr, slicedim=3) - call read_vardata(atmges, 'tmp', rwork3d0, nslice=kr, slicedim=3) - rwork2d = rwork3d0(:,:,1) * (one+fv*rwork3d1(:,:,1)) - if ( diff_res ) then - grid_b=rwork2d - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork2d - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - end do - - if ( vordivflag .or. .not. uvflag ) then - do k=1,nlevs - kr = levs+1-k ! netcdf is top to bottom, need to flip - icount=icount+1 - iflag(icount)=4 - ilev(icount)=k - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) - call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) - ! Vorticity - ! Convert grid u,v to div and vor - if ( diff_res ) then - grid_b = rwork3d0(:,:,1) - grid_b2 = rwork3d1(:,:,1) - vector(1)=.true. - call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - do j=1,grd%nlon - do i=2,grd%nlat-1 - grid(j,grd%nlat-i)=grid2(i,j,1) - enddo - enddo - call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work_v(kk)=grid2(i,j,1) - enddo - do j=1,grd%nlon - do i=2,grd%nlat-1 - grid_v(j,grd%nlat-i)=grid2(i,j,1) - enddo - enddo - else - grid = rwork3d0(:,:,1) - grid_v = rwork3d1(:,:,1) - call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) - endif - allocate( grid_vor(grd%nlon,nlatm2)) - call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1) - call general_sptez_s_b(sp_a,sp_a,spec_vor,grid_vor,1) - ! Load values into rows for south and north pole - call general_fill_ns(grd,grid_vor,work) - deallocate(grid_vor) - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - end do - do k=1,nlevs - kr = levs+1-k ! netcdf is top to bottom, need to flip - - icount=icount+1 - iflag(icount)=5 - ilev(icount)=k - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) - call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) - ! Divergence - ! Convert grid u,v to div and vor - if ( diff_res ) then - grid_b = rwork3d0(:,:,1) - grid_b2 = rwork3d1(:,:,1) - vector(1)=.true. - call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - do j=1,grd%nlon - do i=2,grd%nlat-1 - grid(j,grd%nlat-i)=grid2(i,j,1) - enddo - enddo - call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work_v(kk)=grid2(i,j,1) - enddo - do j=1,grd%nlon - do i=2,grd%nlat-1 - grid_v(j,grd%nlat-i)=grid2(i,j,1) - enddo - enddo - else - grid = rwork3d0(:,:,1) - grid_v = rwork3d1(:,:,1) - call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) - endif - allocate( grid_div(grd%nlon,nlatm2) ) - call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1) - call general_sptez_s_b(sp_a,sp_a,spec_div,grid_div,1) - ! Load values into rows for south and north pole - call general_fill_ns(grd,grid_div,work) - deallocate(grid_div) - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - - end do - endif ! if ( vordivflag .or. .not. uvflag ) - - if ( uvflag ) then - do k=1,nlevs - kr = levs+1-k ! netcdf is top to bottom, need to flip - icount=icount+1 - iflag(icount)=6 - ilev(icount)=k - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) - call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) - - if ( diff_res ) then - grid_b = rwork3d0(:,:,1) - grid_b2 = rwork3d1(:,:,1) - vector(1)=.true. - call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid = rwork3d0(:,:,1) - grid_v = rwork3d1(:,:,1) - call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) - endif - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - - icount=icount+1 - iflag(icount)=7 - ilev(icount)=k - - if (mype==mype_use(icount)) then - ! V - call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) - call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) - if ( diff_res ) then - grid_b = rwork3d0(:,:,1) - grid_b2 = rwork3d1(:,:,1) - vector(1)=.true. - call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) - call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid = rwork3d0(:,:,1) - grid_v = rwork3d1(:,:,1) - ! Note work_v and work are switched because output must be in work. - call general_filluv_ns(grd,slons,clons,grid,grid_v,work_v,work) - endif - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - end do - endif ! if ( uvflag ) - - do k=1,nlevs - kr = levs+1-k ! netcdf is top to bottom, need to flip - icount=icount+1 - iflag(icount)=8 - ilev(icount)=k - - if (mype==mype_use(icount)) then - ! Specific humidity - call read_vardata(atmges, 'spfh', rwork3d0, nslice=kr, slicedim=3) - if ( diff_res ) then - grid_b=rwork3d0(:,:,1) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid = rwork3d0(:,:,1) - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - end do - - do k=1,nlevs - kr = levs+1-k ! netcdf is top to bottom, need to flip - - icount=icount+1 - iflag(icount)=9 - ilev(icount)=k - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'o3mr', rwork3d0, nslice=kr, slicedim=3) - ! Ozone mixing ratio - if ( diff_res ) then - grid_b=rwork3d0(:,:,1) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork3d0(:,:,1) - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - end do - - do k=1,nlevs - icount=icount+1 - iflag(icount)=10 - ilev(icount)=k - kr = levs+1-k ! netcdf is top to bottom, need to flip - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'clwmr', rwork3d0, nslice=kr, slicedim=3) - ! Cloud liquid water mixing ratio. - if ( diff_res ) then - grid_b=rwork3d0(:,:,1) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork3d0(:,:,1) - call general_fill_ns(grd,grid,work) - endif - endif - - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - enddo ! do k=1,nlevs - - do k=1,nlevs - icount=icount+1 - iflag(icount)=11 - ilev(icount)=k - kr = levs+1-k ! netcdf is top to bottom, need to flip - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'icmr', rwork3d0, nslice=kr, slicedim=3) - ! Cloud ice water mixing ratio. - if ( diff_res ) then - grid_b=rwork3d0(:,:,1) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork3d0(:,:,1) - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - enddo ! do k=1,nlevs - - do k=1,nlevs - icount=icount+1 - iflag(icount)=12 - ilev(icount)=k - kr = levs+1-k ! netcdf is top to bottom, need to flip - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'rwmr', rwork3d0, nslice=kr, slicedim=3) - ! Rain water mixing ratio. - if ( diff_res ) then - grid_b=rwork3d0(:,:,1) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork3d0(:,:,1) - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - enddo ! do k=1,nlevs - - do k=1,nlevs - icount=icount+1 - iflag(icount)=13 - ilev(icount)=k - kr = levs+1-k ! netcdf is top to bottom, need to flip - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'snmr', rwork3d0, nslice=kr, slicedim=3) - ! Snow water mixing ratio. - if ( diff_res ) then - grid_b=rwork3d0(:,:,1) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork3d0(:,:,1) - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm ) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - enddo ! do k=1,nlevs - - do k=1,nlevs - icount=icount+1 - iflag(icount)=14 - ilev(icount)=k - kr = levs+1-k ! netcdf is top to bottom, need to flip - - if (mype==mype_use(icount)) then - call read_vardata(atmges, 'grle', rwork3d0, nslice=kr, slicedim=3) - ! Graupel mixing ratio. - if ( diff_res ) then - grid_b=rwork3d0(:,:,1) - vector(1)=.false. - call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) - call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) - do kk=1,grd%itotsub - i=grd%ltosi_s(kk) - j=grd%ltosj_s(kk) - work(kk)=grid2(i,j,1) - enddo - else - grid=rwork3d0(:,:,1) - call general_fill_ns(grd,grid,work) - endif - endif - if ( icount == icm .or. k==nlevs) then - call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) - endif - enddo ! do k=1,nlevs + if (.not. read_2m) then + + allocate( work_v(grd%itotsub) ) + work_v=zero + + icount=icount+1 + iflag(icount)=2 + ilev(icount)=1 + + ! Surface pressure: same procedure as terrain + if (mype==mype_use(icount)) then + ! read ps + call read_vardata(filges, 'pressfc', rwork2d) + rwork2d = r0_001*rwork2d ! convert Pa to cb + if ( diff_res ) then + vector(1)=.false. + grid_b=rwork2d + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + + ! Thermodynamic variable: s-->g transform, communicate to all tasks + ! For multilevel fields, each task handles a given level. Periodic + ! mpi_alltoallv calls communicate the grids to all mpi tasks. + ! Finally, the grids are loaded into guess arrays used later in the + ! code. + + do k=1,nlevs + + icount=icount+1 + iflag(icount)=3 + ilev(icount)=k + kr = levs+1-k ! netcdf is top to bottom, need to flip + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'spfh', rwork3d1, nslice=kr, slicedim=3) + call read_vardata(filges, 'tmp', rwork3d0, nslice=kr, slicedim=3) + rwork2d = rwork3d0(:,:,1) * (one+fv*rwork3d1(:,:,1)) + if ( diff_res ) then + grid_b=rwork2d + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + end do + + if ( vordivflag .or. .not. uvflag ) then + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + icount=icount+1 + iflag(icount)=4 + ilev(icount)=k + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) + ! Vorticity + ! Convert grid u,v to div and vor + if ( diff_res ) then + grid_b = rwork3d0(:,:,1) + grid_b2 = rwork3d1(:,:,1) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid(j,grd%nlat-i)=grid2(i,j,1) + enddo + enddo + call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work_v(kk)=grid2(i,j,1) + enddo + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid_v(j,grd%nlat-i)=grid2(i,j,1) + enddo + enddo + else + grid = rwork3d0(:,:,1) + grid_v = rwork3d1(:,:,1) + call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) + endif + allocate( grid_vor(grd%nlon,nlatm2)) + call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1) + call general_sptez_s_b(sp_a,sp_a,spec_vor,grid_vor,1) + ! Load values into rows for south and north pole + call general_fill_ns(grd,grid_vor,work) + deallocate(grid_vor) + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + end do + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + + icount=icount+1 + iflag(icount)=5 + ilev(icount)=k + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) + ! Divergence + ! Convert grid u,v to div and vor + if ( diff_res ) then + grid_b = rwork3d0(:,:,1) + grid_b2 = rwork3d1(:,:,1) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid(j,grd%nlat-i)=grid2(i,j,1) + enddo + enddo + call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work_v(kk)=grid2(i,j,1) + enddo + do j=1,grd%nlon + do i=2,grd%nlat-1 + grid_v(j,grd%nlat-i)=grid2(i,j,1) + enddo + enddo + else + grid = rwork3d0(:,:,1) + grid_v = rwork3d1(:,:,1) + call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) + endif + allocate( grid_div(grd%nlon,nlatm2) ) + call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1) + call general_sptez_s_b(sp_a,sp_a,spec_div,grid_div,1) + ! Load values into rows for south and north pole + call general_fill_ns(grd,grid_div,work) + deallocate(grid_div) + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + + end do + endif ! if ( vordivflag .or. .not. uvflag ) + + if ( uvflag ) then + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + icount=icount+1 + iflag(icount)=6 + ilev(icount)=k + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) + + if ( diff_res ) then + grid_b = rwork3d0(:,:,1) + grid_b2 = rwork3d1(:,:,1) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid = rwork3d0(:,:,1) + grid_v = rwork3d1(:,:,1) + call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + + icount=icount+1 + iflag(icount)=7 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! V + call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3) + call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3) + if ( diff_res ) then + grid_b = rwork3d0(:,:,1) + grid_b2 = rwork3d1(:,:,1) + vector(1)=.true. + call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons) + call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid = rwork3d0(:,:,1) + grid_v = rwork3d1(:,:,1) + ! Note work_v and work are switched because output must be in work. + call general_filluv_ns(grd,slons,clons,grid,grid_v,work_v,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + end do + endif ! if ( uvflag ) + + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + icount=icount+1 + iflag(icount)=8 + ilev(icount)=k + + if (mype==mype_use(icount)) then + ! Specific humidity + call read_vardata(filges, 'spfh', rwork3d0, nslice=kr, slicedim=3) + if ( diff_res ) then + grid_b=rwork3d0(:,:,1) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid = rwork3d0(:,:,1) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + end do + + do k=1,nlevs + kr = levs+1-k ! netcdf is top to bottom, need to flip + + icount=icount+1 + iflag(icount)=9 + ilev(icount)=k + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'o3mr', rwork3d0, nslice=kr, slicedim=3) + ! Ozone mixing ratio + if ( diff_res ) then + grid_b=rwork3d0(:,:,1) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork3d0(:,:,1) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + end do + + do k=1,nlevs + icount=icount+1 + iflag(icount)=10 + ilev(icount)=k + kr = levs+1-k ! netcdf is top to bottom, need to flip + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'clwmr', rwork3d0, nslice=kr, slicedim=3) + ! Cloud liquid water mixing ratio. + if ( diff_res ) then + grid_b=rwork3d0(:,:,1) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork3d0(:,:,1) + call general_fill_ns(grd,grid,work) + endif + endif + + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + enddo ! do k=1,nlevs + + do k=1,nlevs + icount=icount+1 + iflag(icount)=11 + ilev(icount)=k + kr = levs+1-k ! netcdf is top to bottom, need to flip + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'icmr', rwork3d0, nslice=kr, slicedim=3) + ! Cloud ice water mixing ratio. + if ( diff_res ) then + grid_b=rwork3d0(:,:,1) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork3d0(:,:,1) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + enddo ! do k=1,nlevs + + do k=1,nlevs + icount=icount+1 + iflag(icount)=12 + ilev(icount)=k + kr = levs+1-k ! netcdf is top to bottom, need to flip + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'rwmr', rwork3d0, nslice=kr, slicedim=3) + ! Rain water mixing ratio. + if ( diff_res ) then + grid_b=rwork3d0(:,:,1) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork3d0(:,:,1) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + enddo ! do k=1,nlevs + + do k=1,nlevs + icount=icount+1 + iflag(icount)=13 + ilev(icount)=k + kr = levs+1-k ! netcdf is top to bottom, need to flip + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'snmr', rwork3d0, nslice=kr, slicedim=3) + ! Snow water mixing ratio. + if ( diff_res ) then + grid_b=rwork3d0(:,:,1) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork3d0(:,:,1) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm ) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + enddo ! do k=1,nlevs + + do k=1,nlevs + icount=icount+1 + iflag(icount)=14 + ilev(icount)=k + kr = levs+1-k ! netcdf is top to bottom, need to flip + + if (mype==mype_use(icount)) then + call read_vardata(filges, 'grle', rwork3d0, nslice=kr, slicedim=3) + ! Graupel mixing ratio. + if ( diff_res ) then + grid_b=rwork3d0(:,:,1) + vector(1)=.false. + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork3d0(:,:,1) + call general_fill_ns(grd,grid,work) + endif + endif + if ( icount == icm .or. k==nlevs) then + call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, & + g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag) + endif + enddo ! do k=1,nlevs ! do k=1,nlevs ! icount=icount+1 @@ -3351,7 +3575,7 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z ! kr = levs+1-k ! netcdf is top to bottom, need to flip ! ! if (mype==mype_use(icount)) then -! call read_vardata(atmges, 'cld_amt', rwork3d0, nslice=kr, slicedim=3) +! call read_vardata(filges, 'cld_amt', rwork3d0, nslice=kr, slicedim=3) ! ! Cloud amount (cloud fraction). ! if ( diff_res ) then ! grid_b=rwork3d0(:,:,1) @@ -3375,6 +3599,87 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z ! endif ! enddo ! do k=1,nlevs + else ! read_2m + + icount=icount+1 + iflag(icount)=2 + + ! 2m temperature from sfc file + if (mype==mype_use(icount)) then + call read_vardata(filges, 'tmp2m', rwork2d) + + if ( diff_res ) then + vector(1)=.false. + grid_b=rwork2d + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + endif + + icount=icount + 1 + iflag(icount)=3 + + ! 2m humidity from sfc file + if (mype==mype_use(icount)) then + call read_vardata(filges, 'spfh2m', rwork2d) + + if ( diff_res ) then + vector(1)=.false. + grid_b=rwork2d + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + endif + + icount=icount + 1 + iflag(icount)=4 + + if (mype==mype_use(icount)) then + ! read ps + call read_vardata(filges, 'pressfc', rwork2d) + rwork2d = r0_001*rwork2d ! convert Pa to cb + if ( diff_res ) then + vector(1)=.false. + grid_b=rwork2d + call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb) + call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector) + do kk=1,grd%itotsub + i=grd%ltosi_s(kk) + j=grd%ltosj_s(kk) + work(kk)=grid2(i,j,1) + enddo + else + grid=rwork2d + call general_fill_ns(grd,grid,work) + endif + endif + + ! not necessarily using all assigned tasks (fewer vars), so below doesn't trigger. + ! todo: figure out what icm should be here. + !if ( icount == icm ) then + call general_reload_sfc(grd,g_t2m, g_q2m, g_ps, icount,iflag,work) + !endif + + endif ! read_2m + + + if ( procuse ) then if ( diff_res) deallocate(grid_b,grid_b2,grid_c,grid_c2,grid2) call destroy_egrid2agrid(p_high) @@ -3382,9 +3687,10 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z deallocate(rwork3d1,rwork3d0,clons,slons) deallocate(rwork2d) deallocate(grid,grid_v) - call close_dataset(atmges) + call close_dataset(filges) endif - deallocate(work, work_v) + deallocate(work) + if (allocated(work_v)) deallocate(work_v) ! Convert dry temperature to virtual temperature !do k=1,grd%nsig @@ -3396,27 +3702,29 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z !enddo ! Load u->div and v->vor slot when uv are used instead - if ( uvflag ) then - call gsi_bundlegetpointer(gfs_bundle,'u' ,ptr3d,ier) - if ( ier == 0 ) then - ptr3d=g_u - call gsi_bundlegetpointer(gfs_bundle,'v' ,ptr3d,ier) - if ( ier == 0 ) ptr3d=g_v - else ! in this case, overload: return u/v in sf/vp slot - call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier) - if ( ier == 0 ) then - ptr3d=g_u - call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier) - if ( ier == 0 ) ptr3d=g_v - endif - endif - else ! in this case, overload: return u/v in sf/vp slot - call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier) - if ( ier == 0 ) ptr3d=g_u - call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier) - if ( ier == 0 ) ptr3d=g_v - endif - if (zflag) then + if ( .not. read_2m ) then + if ( uvflag ) then + call gsi_bundlegetpointer(gfs_bundle,'u' ,ptr3d,ier) + if ( ier == 0 ) then + ptr3d=g_u + call gsi_bundlegetpointer(gfs_bundle,'v' ,ptr3d,ier) + if ( ier == 0 ) ptr3d=g_v + else ! in this case, overload: return u/v in sf/vp slot + call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier) + if ( ier == 0 ) then + ptr3d=g_u + call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier) + if ( ier == 0 ) ptr3d=g_v + endif + endif + else ! in this case, overload: return u/v in sf/vp slot + call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier) + if ( ier == 0 ) ptr3d=g_u + call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier) + if ( ier == 0 ) ptr3d=g_v + endif + endif !read_2m + if (read_z) then call gsi_bundlegetpointer(gfs_bundle,'z' ,ptr2d,ier) if ( ier == 0 ) ptr2d=g_z endif @@ -3429,7 +3737,7 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z if ( mype == 0 ) then write(6,700) lonb,latb,nlevs,grd%nlon,nlatm2,& fhour,odate,trim(filename) -700 format('GENERAL_READ_GFSATM_NC: read lonb,latb,levs=',& +700 format('GENERAL_READ_GFSATM_ALLHYDRO_NC: read lonb,latb,levs=',& 3i6,', scatter nlon,nlat=',2i6,', hour=',f6.1,', idate=',4i5,1x,a) endif diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index ed4bbb1e55..cf885c2b64 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -99,7 +99,7 @@ module gsimod factv,factl,factp,factg,factw10m,facthowv,factcldch,niter,niter_no_qc,biascor,& init_jfunc,qoption,cwoption,switch_on_derivatives,tendsflag,jiterstart,jiterend,R_option,& bcoption,diurnalbc,print_diag_pcg,tsensible,diag_precon,step_start,pseudo_q2,& - clip_supersaturation,cnvw_option + clip_supersaturation,cnvw_option,hofx_2m_sfcfile use state_vectors, only: init_anasv,final_anasv use control_vectors, only: init_anacv,final_anacv,nrf,nvars,nrf_3d,cvars3d,cvars2d,& nrf_var,lcalc_gfdl_cfrac,incvars_to_zero,incvars_zero_strat,incvars_efold @@ -1047,7 +1047,7 @@ module gsimod ! l_foreaft_thin - separate TDR fore/aft scan for thinning namelist/obs_input/dmesh,time_window_max,time_window_rad, & - ext_sonde,l_foreaft_thin + ext_sonde,l_foreaft_thin,hofx_2m_sfcfile ! SINGLEOB_TEST (one observation test case setup): ! maginnov - magnitude of innovation for one ob diff --git a/src/gsi/jfunc.f90 b/src/gsi/jfunc.f90 index 1b92ad2e94..616f835218 100644 --- a/src/gsi/jfunc.f90 +++ b/src/gsi/jfunc.f90 @@ -136,10 +136,12 @@ module jfunc public :: pseudo_q2 public :: varq public :: cnvw_option + public :: hofx_2m_sfcfile logical first,last,switch_on_derivatives,tendsflag,print_diag_pcg,tsensible,diag_precon logical clip_supersaturation,R_option logical pseudo_q2,limitqobs + logical hofx_2m_sfcfile logical cnvw_option integer(i_kind) iout_iter,miter,iguess,nclen,qoption,cwoption integer(i_kind) jiter,jiterstart,jiterend,iter @@ -249,6 +251,9 @@ subroutine init_jfunc ! option for including convective clouds in the all-sky assimilation cnvw_option=.false. +! option to calculate hofx for T2m and q2m by interpolating from 2m vars in sfc file + hofx_2m_sfcfile=.false. + return end subroutine init_jfunc diff --git a/src/gsi/netcdfgfs_io.f90 b/src/gsi/netcdfgfs_io.f90 index e1255b773c..41e8f33e03 100644 --- a/src/gsi/netcdfgfs_io.f90 +++ b/src/gsi/netcdfgfs_io.f90 @@ -105,6 +105,7 @@ subroutine read_ ! ! program history log: ! 2019-09-24 Martin - create routine based on read_nems +! 2022-03-23 Draper - add option to include T2m and q2m in MetGuess ! ! input argument list: ! @@ -129,6 +130,7 @@ subroutine read_ use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info,general_sub2grid_destroy_info use mpimod, only: npe,mype use cloud_efr_mod, only: cloud_calc_gfs,set_cloud_lower_bound + use jfunc, only: hofx_2m_sfcfile use gridmod, only: fv3_full_hydro implicit none @@ -141,6 +143,8 @@ subroutine read_ real(r_kind),pointer,dimension(:,: ):: ges_ps_it =>NULL() real(r_kind),pointer,dimension(:,: ):: ges_z_it =>NULL() + real(r_kind),pointer,dimension(:,: ):: ges_t2m_it =>NULL() + real(r_kind),pointer,dimension(:,: ):: ges_q2m_it =>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_u_it =>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_v_it =>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_div_it =>NULL() @@ -164,8 +168,10 @@ subroutine read_ type(gsi_grid) :: atm_grid integer(i_kind),parameter :: n2d=2 ! integer(i_kind),parameter :: n3d=8 + integer(i_kind),parameter :: n2d_2m=4 integer(i_kind),parameter :: n3d=14 character(len=4), parameter :: vars2d(n2d) = (/ 'z ', 'ps ' /) + character(len=4), parameter :: vars2d_with2m(n2d_2m) = (/ 'z ', 'ps ','t2m ','q2m ' /) ! character(len=4), parameter :: vars3d(n3d) = (/ 'u ', 'v ', & ! 'vor ', 'div ', & ! 'tv ', 'q ', & @@ -189,8 +195,11 @@ subroutine read_ ! Allocate bundle used for reading members call gsi_gridcreate(atm_grid,lat2,lon2,nsig) - - call gsi_bundlecreate(atm_bundle,atm_grid,'aux-atm-read',istatus,names2d=vars2d,names3d=vars3d) + if (hofx_2m_sfcfile) then + call gsi_bundlecreate(atm_bundle,atm_grid,'aux-atm-read',istatus,names2d=vars2d_with2m,names3d=vars3d) + else + call gsi_bundlecreate(atm_bundle,atm_grid,'aux-atm-read',istatus,names2d=vars2d,names3d=vars3d) + endif if(istatus/=0) then write(6,*) myname_,': trouble creating atm_bundle' call stop2(999) @@ -198,9 +207,15 @@ subroutine read_ do it=1,nfldsig - write(filename,'(''sigf'',i2.2)') ifilesig(it) - ! Read background fields into bundle + if (hofx_2m_sfcfile) then + if (mype==0) write(*,*) 'calling general_read_gfsatm_nc for 2m data', it + write(filename,'(''sfcf'',i2.2)') ifilesig(it) + call general_read_gfsatm_nc(grd_t,sp_a,filename,.true.,.true.,.true.,& + atm_bundle,.true.,istatus) + if (mype==0) write(*,*) 'done with general_read_gfsatm_nc for 2m data', it + end if + write(filename,'(''sigf'',i2.2)') ifilesig(it) if (fv3_full_hydro) then if (mype==0) write(*,*) 'calling general_read_gfsatm_allhydro_nc', it call general_read_gfsatm_allhydro_nc(grd_t,sp_a,filename,.true.,.true.,.true.,& @@ -273,6 +288,16 @@ subroutine set_guess_ call gsi_bundlegetpointer (gsi_metguess_bundle(it),'z' ,ges_z_it ,istatus) if(istatus==0) ges_z_it = ptr2d endif + call gsi_bundlegetpointer (atm_bundle,'t2m',ptr2d,istatus) + if (istatus==0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'t2m' ,ges_t2m_it ,istatus) + if(istatus==0) ges_t2m_it = ptr2d + endif + call gsi_bundlegetpointer (atm_bundle,'q2m',ptr2d,istatus) + if (istatus==0) then + call gsi_bundlegetpointer (gsi_metguess_bundle(it),'q2m' ,ges_q2m_it ,istatus) + if(istatus==0) ges_q2m_it = ptr2d + endif call gsi_bundlegetpointer (atm_bundle,'u',ptr3d,istatus) if (istatus==0) then call gsi_bundlegetpointer (gsi_metguess_bundle(it),'u' ,ges_u_it ,istatus) diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index f992ace329..355441e209 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -148,6 +148,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! ! 2020-05-04 wu - no rotate_wind for fv3_regional ! 2020-09-05 CAPS(C. Tong) - add flag for new vadwind obs to assimilate around the analysis time only +! 2023-03-23 draper - add code for processing T2m and q2m for global system ! input argument list: ! infile - unit from which to read BUFR data @@ -212,7 +213,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& use hilbertcurve,only: init_hilbertcurve, accum_hilbertcurve, & apply_hilbertcurve,destroy_hilbertcurve use ndfdgrids,only: init_ndfdgrid,destroy_ndfdgrid,relocsfcob,adjust_error - use jfunc, only: tsensible + use jfunc, only: tsensible, hofx_2m_sfcfile use deter_sfc_mod, only: deter_sfc_type,deter_sfc2 use gsi_nstcouplermod, only: nst_gsi,nstinfo use gsi_nstcouplermod, only: gsi_nstcoupler_deter @@ -263,7 +264,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& logical tob,qob,uvob,spdob,sstob,pwob,psob,gustob,visob,tdob,mxtmob,mitmob,pmob,howvob,cldchob logical metarcldobs,goesctpobs,tcamtob,lcbasob logical outside,driftl,convobs,inflate_error - logical sfctype + logical sfctype, global_2m_land logical luse,ithinp,windcorr logical patch_fog logical aircraftset,aircraftobs,aircraftobst,aircrafttype @@ -1614,10 +1615,15 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& pmq(k)=nint(qcmark(8,k)) end do +! 181, 183, 187, and 188 are the screen-level obs over land + global_2m_land = ( (kx==181 .or. kx==183 .or. kx==188 .or. kx==188 ) .and. hofx_2m_sfcfile ) + ! If temperature ob, extract information regarding virtual ! versus sensible temperature if(tob) then - if (.not. twodvar_regional .or. .not.tsensible) then + ! use tvirtual if tsensible flag not set, and not in either 2Dregional or global_2m DA mode + if ( (.not. tsensible) .and. .not. (twodvar_regional .or. global_2m_land) ) then + do k=1,levs tvflg(k)=one ! initialize as sensible do j=1,20 @@ -1914,6 +1920,26 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! Missing Values ==> Cycling! In this case for howv only. #ww3 if (howvob .and. owave(1,k) > r0_1_bmiss) cycle LOOP_K_LEVS +! Over-ride QM=9 and hard-wire errors for land obs and hofx_sfc_file option +! Can be deleted once prepbufr processing updated. + if ( global_2m_land ) then + if (tob .and. qm==9 ) then + pqm(k)=2 ! otherwise, type 183 will be discarded. + qm=2 + tqm(k)=2 + if (kx==187) obserr(3,k)=2.2 + if (kx==181) obserr(3,k)=1.5 + if (kx==183) obserr(3,k)=2.6 + endif + if (qob .and. qm == 9 ) then + qm = 2 + ! qob err specified as fraction of qsat, multiplied by 10. + if (kx==187) obserr(2,k)=1.0 + if (kx==181) obserr(2,k)=1.0 + if (kx==183) obserr(2,k)=1.0 + endif + + endif ! Set usage variable usage = zero if(icuse(nc) <= 0)usage=100._r_kind @@ -1957,6 +1983,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if(obsdat(12,k) > 32.2_r_kind) usage=118._r_kind ! > 90F endif endif + ! to-do: should we add qob checks from above for landsfctype too? if ((kx>129.and.kx<140).or.(kx>229.and.kx<240) ) then call get_aircraft_usagerj(kx,obstype,c_station_id,usage) diff --git a/src/gsi/setupq.f90 b/src/gsi/setupq.f90 index ed9fbb13db..554fe3e3dd 100644 --- a/src/gsi/setupq.f90 +++ b/src/gsi/setupq.f90 @@ -111,6 +111,8 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav ! information in diagonostic file, which is used ! in offline observation quality control program (AutoObsQC) ! for 3D-RTMA (if l_obsprvdiag is true). +! 2023-03-09 Draper added option to interpolate screen-level q from model 2m output. +! (hofx_2m_sfcfile) ! ! ! input argument list: @@ -160,7 +162,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav use constants, only: huge_single,wgtlim,three use constants, only: tiny_r_kind,five,half,two,huge_r_kind,r0_01 use qcmod, only: npres_print,ptopq,pbotq,dfact,dfact1,njqc,vqc,nvqc - use jfunc, only: jiter,last,jiterstart,miter,superfact,limitqobs + use jfunc, only: jiter,last,jiterstart,miter,superfact,limitqobs,hofx_2m_sfcfile use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype use convinfo, only: ibeta,ikapa use convinfo, only: icsubtype @@ -217,7 +219,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav ! Declare local variables real(r_double) rstation_id - real(r_kind) qob,qges,qsges,q2mges,q2mges_water + real(r_kind) qob,qges,qsges,q2mges,q2mges_water,qsges_o real(r_kind) ratio_errors,dlat,dlon,dtime,dpres,rmaxerr,error real(r_kind) rsig,dprpx,rlow,rhgh,presq,tfact,ramp real(r_kind) psges,sfcchk,ddiff,errorx @@ -231,6 +233,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav real(r_kind),dimension(nobs):: dup real(r_kind),dimension(lat2,lon2,nsig,nfldsig):: qg real(r_kind),dimension(lat2,lon2,nfldsig):: qg2m + real(r_kind),dimension(lat2,lon2,nfldsig):: qg2m_o real(r_kind),dimension(nsig):: prsltmp real(r_kind),dimension(34):: ptablq real(r_single),allocatable,dimension(:,:)::rdiagbuf @@ -277,10 +280,22 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q real(r_kind),allocatable,dimension(:,:,: ) :: ges_q2m + real(r_kind),allocatable,dimension(:,:,: ) :: ges_t2m logical:: l_pbl_pseudo_itype integer(i_kind):: ich0 type(obsLList),pointer,dimension(:):: qhead + + logical :: landsfctype + + real(r_kind) :: delta_z, lapse_error, q_delta_terrain + real(r_kind), parameter :: T_lapse = -0.0045 ! standard lapse rate, K/m +! use 4.5 K/km, in place of more standard 6.5 K/km, following +! https://agupubs.onlinelibrary.wiley.com/doi/10.1029/2019EA000984 +! lapse_error_frac around 0.5 ~ 2K/km, from Figure 2 of above. + real(r_kind), parameter :: lapse_error_frac = 0.5 ! inflation factor for obs error when vertically interpolating + real(r_kind), parameter :: max_delta_z = 300. ! max. vertical mismatch allowed (later: relax this) + qhead => obsLL(:) save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf @@ -359,8 +374,11 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav hr_offset=min_offset/60.0_r_kind dup=one do k=1,nobs + ikx=nint(data(ikxx,k)) + itype=ictype(ikx) + landsfctype =( itype==181 .or. itype==183 .or. itype==187 .or. itype==188 ) do l=k+1,nobs - if (twodvar_regional) then + if (twodvar_regional .or. (hofx_2m_sfcfile .and. landsfctype) ) then duplogic=data(ilat,k) == data(ilat,l) .and. & data(ilon,k) == data(ilon,l) .and. & data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & @@ -425,9 +443,15 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav ice=.false. ! get larger (in rh) q obs error for mixed and ice phases iderivative=0 + + ! calculate qsat and 2m qsat do jj=1,nfldsig - call genqsat(qg(1,1,1,jj),ges_tsen(1,1,1,jj),ges_prsl(1,1,1,jj),lat2,lon2,nsig,ice,iderivative) - qg2m(:,:,jj)=qg(:,:,1,jj) + call genqsat(qg(:,:,:,jj),ges_tsen(:,:,:,jj),ges_prsl(:,:,:,jj),lat2,lon2,nsig,ice,iderivative) + if (i_use_2mq4b > 0) then ! use lowest model level + qg2m(:,:,jj)=qg(:,:,1,jj) + elseif ( hofx_2m_sfcfile ) then ! calculate from 2m model output + call genqsat(qg2m(:,:,jj),ges_t2m(:,:,jj),ges_ps(:,:,jj),lat2,lon2,1,ice,iderivative) + endif end do @@ -440,10 +464,10 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav call dtime_check(dtime, in_curbin, in_anybin) if(.not.in_anybin) cycle + landsfctype =( itype==181 .or. itype==183 .or. itype==187 ) ! Flag static conditions to create PBL_pseudo_surfobsq obs. - l_pbl_pseudo_itype = l_pbl_pseudo_surfobsq .and. & - ( itype==181 .or. itype==183 .or.itype==187 ) + l_pbl_pseudo_itype = l_pbl_pseudo_surfobsq .and. landsfctype if(in_curbin) then ! Convert obs lats and lons to grid coordinates @@ -509,24 +533,28 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav presq=r10*exp(dpres) itype=ictype(ikx) dprpx=zero - if(((itype > 179 .and. itype < 190) .or. itype == 199) & + + if ( hofx_2m_sfcfile .and. landsfctype) then + dpres = one ! put obs on surface + else + if(((itype > 179 .and. itype < 190) .or. itype == 199) & .and. .not.twodvar_regional)then - dprpx=abs(one-exp(dpres-log(psges)))*r10 - end if + dprpx=abs(one-exp(dpres-log(psges)))*r10 + endif ! Put obs pressure in correct units to get grid coord. number - call grdcrd1(dpres,prsltmp(1),nsig,-1) + call grdcrd1(dpres,prsltmp(1),nsig,-1) ! Get approximate k value of surface by using surface pressure - sfcchk=log(psges) - call grdcrd1(sfcchk,prsltmp(1),nsig,-1) + sfcchk=log(psges) + call grdcrd1(sfcchk,prsltmp(1),nsig,-1) ! Check to see if observations is above the top of the model (regional mode) - if( dpres>=nsig+1)dprpx=1.e6_r_kind - if((itype > 179 .and. itype < 186) .or. itype == 199) dpres=one + if( dpres>=nsig+1)dprpx=1.e6_r_kind + if((itype > 179 .and. itype < 186) .or. itype == 199) dpres=one + + endif -! Scale errors by guess saturation q - qob = data(iqob,i) if(limitqobs) then call tintrp31(ges_qsat,qsges,dlat,dlon,dpres,dtime,hrdifsig,& @@ -534,11 +562,13 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav qob=min(qob,superfact*qsges) end if +! get qsges, to be used to scale the obs error call tintrp31(qg,qsges,dlat,dlon,dpres,dtime,hrdifsig,& mype,nfldsig) -! Interpolate 2-m qs to obs locations/times - if((i_use_2mq4b > 0) .and. ((itype > 179 .and. itype < 190) .or. itype == 199) & - .and. .not.twodvar_regional)then + +! overwrite qsges with 2-m qs if sfc obs scheme + if( ( (i_use_2mq4b > 0) .and. ((itype > 179 .and. itype < 190) .or. itype == 199) & + .and. .not.twodvar_regional) .or. (hofx_2m_sfcfile .and. landsfctype) )then call tintrp2a11(qg2m,qsges,dlat,dlon,dtime,hrdifsig,mype,nfldsig) endif @@ -549,10 +579,36 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav rmaxerr=max(small2,rmaxerr) errorx =(data(ier,i)+dprpx)*qsges -! Interpolate guess moisture to observation location and time - call tintrp31(ges_q,qges,dlat,dlon,dpres,dtime, & - hrdifsig,mype,nfldsig) - +! qges: Interpolate guess moisture to observation location and time + + if (.not. ( hofx_2m_sfcfile .and. landsfctype) ) then + call tintrp31(ges_q,qges,dlat,dlon,dpres,dtime, & + hrdifsig,mype,nfldsig) + else + ! only use land locations + if (int(data(idomsfc,i)) .NE. 1 ) muse(i) = .false. + + call tintrp2a11(ges_q2m,qges,dlat,dlon,dtime,hrdifsig,mype,nfldsig) + + ! terrain correction: assume RH_zo = RH_zm, and correct T with + ! same lapse rate as used for T2m terrain correction + + delta_z = data(istnelv,i) - data(izz,i) ! obs -model + + do jj=1,nfldsig + ! qsat in model at height of obs + call genqsat(qg2m_o(:,:,jj),ges_t2m(:,:,jj)+delta_z*T_lapse,ges_ps(:,:,jj),lat2,lon2,1,ice,iderivative) + enddo + + call tintrp2a11(qg2m_o,qsges_o,dlat,dlon,dtime,hrdifsig,mype,nfldsig) + q_delta_terrain = (qsges/qsges_o - 1)*qob + qob = qob * ( qsges/qsges_o) + + !update the station elevation + data(istnelv,i) = data(izz,i) + + endif + ddiff=qob-qges ! Setup dynamic ob error specification for aircraft recon in hurricanes @@ -572,18 +628,22 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav endif errorx =max(small1,errorx) - ! Adjust observation error to reflect the size of the residual. ! If extrapolation occurred, then further adjust error according to ! amount of extrapolation. - rlow=max(sfcchk-dpres,zero) + if (.not. (hofx_2m_sfcfile .and. landsfctype) ) then + rlow=max(sfcchk-dpres,zero) ! linear variation of observation ramp [between grid points 1(~3mb) and 15(~45mb) below the surface] - if(l_sfcobserror_ramp_q) then - ramp=min(max(((rlow-1.0_r_kind)/(15.0_r_kind-1.0_r_kind)),0.0_r_kind),1.0_r_kind)*0.001_r_kind + if(l_sfcobserror_ramp_q) then + ramp=min(max(((rlow-1.0_r_kind)/(15.0_r_kind-1.0_r_kind)),0.0_r_kind),1.0_r_kind)*0.001_r_kind + else + ramp=rlow + endif else - ramp=rlow + rlow = zero + ramp = zero endif rhgh=max(dpres-r0_001-rsig,zero) @@ -594,7 +654,20 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav if(rhgh/=zero) awork(3) = awork(3) + one end if - ratio_errors=error*qsges/(errorx+1.0e6_r_kind*rhgh+r8*ramp) +! inflate error for uncertainty in the terrain adjustment + lapse_error = 0. + if ( hofx_2m_sfcfile .and. landsfctype) then + if (abs(delta_z)max_delta_z do not assim. + ! inflate obs error to account for error in lapse_rate + ! also include some representativity error here (assuming + ! delta_z ~ heterogeneity) + lapse_error = abs(lapse_error_frac*q_delta_terrain) + else + muse(i)=.false. + endif + endif + + ratio_errors=error*qsges/(errorx+1.0e6_r_kind*rhgh+r8*ramp + lapse_error) ! Check to see if observations is above the top of the model (regional mode) if (dpres > rsig) ratio_errors=zero @@ -618,7 +691,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav dhx_dx%val(2) = delz ! weight for iz+1's level endif -! Interpolate 2-m q to obs locations/times +! i_use_2mq4b: Interpolate 2-m q to obs locations/times if(i_use_2mq4b>0 .and. itype > 179 .and. itype < 190 .and. .not.twodvar_regional)then if(i_coastline==2 .or. i_coastline==3) then @@ -643,7 +716,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav call stop2(100) endif ddiff=qob-qges - endif + endif ! i_use_2mq4b ! If requested, setup for single obs test. @@ -943,7 +1016,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav my_head => null() ENDDO - endif ! 181,183,187 + endif ! l_pbl_pseudo_itype !!!!!!!!!!!!!!!!!! PBL pseudo surface obs !!!!!!!!!!!!!!!!!!!!!!! ! End of loop over observations @@ -1025,7 +1098,7 @@ subroutine init_vars_ call stop2(999) endif ! get q2m ... - if (i_use_2mq4b>0) then + if (i_use_2mq4b>0 .or. hofx_2m_sfcfile) then varname='q2m' call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) if (istatus==0) then @@ -1044,6 +1117,25 @@ subroutine init_vars_ call stop2(999) endif endif ! i_use_2mq4b + if (hofx_2m_sfcfile) then + varname='t2m' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_t2m))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_t2m(size(rank2,1),size(rank2,2),nfldsig)) + ges_t2m(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_t2m(:,:,ifld)=rank2 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + endif ! hofx_2m_sfcfile ! get q ... varname='q' call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) @@ -1272,8 +1364,10 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) +! this is the obs height after being interpolated to the model (=model height) call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) call nc_diag_metadata("Pressure", sngl(presq) ) +! this is the original obs height (= stn elevation, before being interpolated) call nc_diag_metadata("Height", sngl(data(iobshgt,i)) ) call nc_diag_metadata("Time", sngl(dtime-time_offset)) call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) @@ -1392,6 +1486,7 @@ end subroutine contents_netcdf_diagp_ subroutine final_vars_ if(allocated(ges_q2m)) deallocate(ges_q2m) + if(allocated(ges_t2m)) deallocate(ges_t2m) if(allocated(ges_q )) deallocate(ges_q ) if(allocated(ges_ps)) deallocate(ges_ps) end subroutine final_vars_ diff --git a/src/gsi/setupt.f90 b/src/gsi/setupt.f90 index 815c16014d..a0710e8abb 100644 --- a/src/gsi/setupt.f90 +++ b/src/gsi/setupt.f90 @@ -54,11 +54,11 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav use gridmod, only: nsig,twodvar_regional,regional use gridmod, only: get_ijk,pt_ll - use jfunc, only: jiter,last,jiterstart,miter + use jfunc, only: jiter,last,jiterstart,miter,hofx_2m_sfcfile use guess_grids, only: nfldsig, hrdifsig,ges_lnprsl,& geop_hgtl,ges_tsen,pbl_height - use state_vectors, only: svars3d, levels + use state_vectors, only: svars3d, levels, ns3d, svars2d use constants, only: zero, one, four,t0c,rd_over_cp,three,rd_over_cp_mass,ten use constants, only: tiny_r_kind,half,two @@ -228,6 +228,8 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav ! for 3D-RTMA (if l_obsprvdiag is true). ! 2022-03-15 Hu change all th2 to t2m to indicate that 2m temperature ! is sensible instead of potentionl temperature +! 2023-03-21 Draper added option to interpolate screen-level T from model 2m output. +! (hofx_2m_sfcfile) ! ! !REMARKS: ! language: f90 @@ -309,7 +311,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav logical,dimension(nobs):: luse,muse integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - logical sfctype + logical sfctype, landsfctype logical iqtflg logical aircraftobst logical duplogic @@ -342,6 +344,18 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav integer(i_kind):: ich0 type(obsLList),pointer,dimension(:):: thead + + real(r_kind) :: delta_z, lapse_error + real(r_kind), parameter :: T_lapse = -0.0045 ! standard lapse rate, K/m +! use 4.5 K/km, in place of more standard 6.5 K/km, following +! https://agupubs.onlinelibrary.wiley.com/doi/10.1029/2019EA000984 +! lapse_error_frac around 0.5 ~ 2K/km, from Figure 2 of above. + real(r_kind), parameter :: lapse_error_frac = 0.5 ! inflation factor for obs error when vertically interpolating + real(r_kind), parameter :: max_delta_z = 300. ! max. vertical mismatch allowed + +! CSD - move this to where the namelists are read in. + if (i_use_2mt4b>0) hofx_2m_sfcfile=.false. + thead => obsLL(:) save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf @@ -432,8 +446,11 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav hr_offset=min_offset/60.0_r_kind dup=one do k=1,nobs + ikx=nint(data(ikxx,k)) + itype=ictype(ikx) + landsfctype =( itype==181 .or. itype==183 .or. itype==187 .or. itype==188 ) do l=k+1,nobs - if (twodvar_regional) then + if (twodvar_regional .or. (hofx_2m_sfcfile .and. landsfctype) ) then duplogic=data(ilat,k) == data(ilat,l) .and. & data(ilon,k) == data(ilon,l) .and. & data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & @@ -465,6 +482,10 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav end do ! Run a buddy-check +! Note: buddy check crashes for hofx_2m_sfcfile option. +! Ccurrent params have buddy radius of 108 km, max diff of 8 K. +! The gross error check removes O-F > 7., so this is probably removing +! most obs that fail the buddy check already if (twodvar_regional .and. buddycheck_t) call buddy_check_t(is,data,luse,mype,nele,nobs,muse,buddyuse) ! If requested, save select data for output to diagnostic file @@ -521,6 +542,10 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav rstation_id = data(id,i) prest=r10*exp(dpres) ! in mb sfctype=(itype>179.and.itype<190).or.(itype>=192.and.itype<=199) +! hofx_2m_sfcfile option to calculate hofx from 2m model output (rather than LML) +! is restricted to landsfctype only. GDAS assimilates 180 and 182 over ocean, +! should we also use 2m model output for the over-ocean obs? + landsfctype =( itype==181 .or. itype==183 .or. itype==187 ) iqtflg=nint(data(iqt,i)) == 0 var_jb=data(ijb,i) @@ -654,17 +679,22 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& nsig,mype,nfldsig) - drpx=zero - if(sfctype .and. .not.twodvar_regional) then - drpx=abs(one-((one/exp(dpres-log(psges))))**rd_over_cp)*t0c - end if + drpx = zero + if ( hofx_2m_sfcfile .and. landsfctype) then + dpres = one ! put obs at surface + else + if(sfctype .and. .not.twodvar_regional) then + drpx=abs(one-((one/exp(dpres-log(psges))))**rd_over_cp)*t0c + end if -! Put obs pressure in correct units to get grid coord. number - call grdcrd1(dpres,prsltmp(1),nsig,-1) +! Put obs pressure in correct units to get grid coord. number + call grdcrd1(dpres,prsltmp(1),nsig,-1) + endif ! Implementation of forward model ---------- - if(sfctype.and.sfcmodel) then +! SCENARIO 1: If obs is sfctype, and sfcmodel is requested. Outdated. + if(sfctype .and. sfcmodel) then tgges=data(iskint,i) roges=data(isfcr,i) @@ -694,8 +724,47 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav f10ges,u10ges,v10ges, t2ges, q2ges, regime, iqtflg) tges = t2ges +! SCENARIO 2: obs is sfctype, and hofx_2m_sfcfile scheme is on. +! 2m forecast has been read from the sfc guess files + elseif (landsfctype .and. hofx_2m_sfcfile ) then + +! mask: 0 - sea, 1 - land, 2-ice, >= 3 mixed +! for now, use only pure land + if (int(data(idomsfc,i)) .NE. 1 ) muse(i) = .false. + + call tintrp2a11(ges_t2m,tges2m,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + +! correct obs to model terrain height using a standard lapse rate. +! Later: look into updating with lapse-rate from the model (similar to gsd_terrain_match) + + delta_z = data(izz,i) - data(istnelv,i) + tob = tob + delta_z*T_lapse + !update the station elevation + data(istnelv,i) = data(izz,i) + + if(save_jacobian) then + t_ind = getindex(svars2d, 't2m') + if (t_ind < 0) then + print *, 'Error: no variable t2m in state vector.Exiting.' + call stop2(1300) + endif + dhx_dx%st_ind(1) = sum(levels(1:ns3d)) + t_ind + dhx_dx%end_ind(1) = sum(levels(1:ns3d)) + t_ind + dhx_dx%val(1) = one + dhx_dx%val(2) = zero ! in this case, there is no vertical interp + ! and nnz (=dim(dhx_dx%val)) should be one, + ! but nnz is a file attribute, so need to use + ! same value as for vertical profile obs. Get + ! around this by setting val(2) to zero. + endif + +! SCENARIO 3: obs is sfctype, and neither sfcmodel nor hofx_2m_sfcfile is chosen +! .or. obs is not sfctype. Interpoate hofx from model levels. else + if(iqtflg)then +! SCENARIO 3a: obs is a virtual temp. ! Interpolate guess tv to observation location and time call tintrp31(ges_tv,tges,dlat,dlon,dpres,dtime, & hrdifsig,mype,nfldsig) @@ -717,6 +786,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav dhx_dx%val(2) = delz ! weight for iz+1's level endif else +! SCENARIO 3b: obs is a sensible temp. ! Interpolate guess tsen to observation location and time call tintrp31(ges_tsen,tges,dlat,dlon,dpres,dtime, & hrdifsig,mype,nfldsig) @@ -739,6 +809,8 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav endif end if + +! SCENARIO 4: obs is sfctype, and i_use_2mt4b flag is on (turns on regional sfc DA) if(i_use_2mt4b>0 .and. sfctype) then if(i_coastline==1 .or. i_coastline==3) then @@ -773,17 +845,23 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav call grdcrd1(sfcchk,prsltmp(1),nsig,-1) ! Check to see if observations is above the top of the model (regional mode) - if(sfctype)then + if(sfctype .and. .not. (hofx_2m_sfcfile .and. landsfctype) )then if(abs(dpres)>four) drpx=1.0e10_r_kind pres_diff=prest-r10*psges if (twodvar_regional .and. abs(pres_diff)>=r1000) drpx=1.0e10_r_kind end if - rlow=max(sfcchk-dpres,zero) -! linear variation of observation ramp [between grid points 1(~3mb) and 15(~45mb) below the surface] - if(l_sfcobserror_ramp_t) then - ramp=min(max(((rlow-1.0_r_kind)/(15.0_r_kind-1.0_r_kind)),0.0_r_kind),1.0_r_kind) + + if (.not. (hofx_2m_sfcfile .and. landsfctype) ) then + rlow=max(sfcchk-dpres,zero) +! linear variation of observation ramp [between grid points 1(~3mb) and 15(~45mb) below the surface] + if(l_sfcobserror_ramp_t) then + ramp=min(max(((rlow-1.0_r_kind)/(15.0_r_kind-1.0_r_kind)),0.0_r_kind),1.0_r_kind) + else + ramp=rlow + endif else - ramp=rlow + rlow = zero + ramp = zero endif rhgh=max(zero,dpres-rsigp-r0_001) @@ -795,12 +873,26 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav if(rlow/=zero) awork(2) = awork(2) + one if(rhgh/=zero) awork(3) = awork(3) + one end if - - ratio_errors=error/(data(ier,i)+drpx+1.0e6_r_kind*rhgh+r8*ramp) + +! inflate error for uncertainty in the terrain adjustment + lapse_error = 0. + if ( hofx_2m_sfcfile .and. landsfctype) then + if (abs(delta_z)max_delta_z do not assim. + ! inflate obs error to account for error in lapse_rate + ! also include some representativity error here (assuming + ! delta_z ~ heterogeneity) + lapse_error = abs(lapse_error_frac*T_lapse*delta_z) + else + muse(i)=.false. + endif + endif + + ratio_errors=error/(data(ier,i)+drpx+1.0e6_r_kind*rhgh+r8*ramp + lapse_error) ! Compute innovation - if(i_use_2mt4b>0 .and. sfctype) then + if( (sfctype .and. i_use_2mt4b>0) .or. (hofx_2m_sfcfile .and. landsfctype) ) then ddiff = tob-tges2m + if (hofx_2m_sfcfile) tges=tges2m else ddiff = tob-tges endif @@ -1411,7 +1503,7 @@ subroutine init_vars_ write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus call stop2(999) endif - if(i_use_2mt4b>0) then + if(i_use_2mt4b>0 .or. hofx_2m_sfcfile) then ! get t2m ... varname='t2m' call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) @@ -1430,6 +1522,7 @@ subroutine init_vars_ write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus call stop2(999) endif + ! get q2m ... varname='q2m' call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) @@ -1676,8 +1769,10 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) +! this is the obs height after being interpolated to the model (=model height) call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) call nc_diag_metadata("Pressure", sngl(prest) ) +! this is the original obs height (= stn elevation, before being interpolated) call nc_diag_metadata("Height", sngl(data(iobshgt,i)) ) call nc_diag_metadata("Time", sngl(dtime-time_offset)) call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) @@ -1693,7 +1788,11 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) - call nc_diag_metadata("Observation", sngl(data(itob,i)) ) + if (hofx_2m_sfcfile ) then + call nc_diag_metadata("Observation", sngl(tob) ) + else + call nc_diag_metadata("Observation", sngl(data(itob,i)) ) + endif call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(tob-tges) ) diff --git a/src/gsi/update_guess.f90 b/src/gsi/update_guess.f90 index e5a0f64245..1885542a1b 100644 --- a/src/gsi/update_guess.f90 +++ b/src/gsi/update_guess.f90 @@ -113,7 +113,7 @@ subroutine update_guess(sval,sbias) use mpimod, only: mype use constants, only: zero,one,fv,max_varname_length,qmin,qcmin,tgmin,& r100,one_tenth,tiny_r_kind - use jfunc, only: iout_iter,bcoption,tsensible,clip_supersaturation,superfact + use jfunc, only: iout_iter,bcoption,tsensible,clip_supersaturation,superfact,hofx_2m_sfcfile use gridmod, only: lat2,lon2,nsig,& regional,twodvar_regional,regional_ozone,& l_reg_update_hydro_delz @@ -458,7 +458,7 @@ subroutine update_guess(sval,sbias) endif call gsd_update_soil_tq(tinc_1st,is_t,qinc_1st,is_q,it) endif ! l_gsd_soilTQ_nudge - if (i_use_2mt4b > 0 .and. is_t>0) then + if ( (i_use_2mt4b > 0.or. hofx_2m_sfcfile) .and. is_t>0) then do j=1,lon2 do i=1,lat2 tinc_1st(i,j)=p_tv(i,j,1) @@ -466,7 +466,7 @@ subroutine update_guess(sval,sbias) end do call gsd_update_t2m(tinc_1st,it) endif ! l_gsd_t2m_adjust - if (i_use_2mq4b > 0 .and. is_q>0) then + if ( (i_use_2mq4b > 0.or. hofx_2m_sfcfile) .and. is_q>0) then do j=1,lon2 do i=1,lat2 qinc_1st(i,j)=p_q(i,j,1) From 8735959064c3661a85b16328cb0bfc0cd546bc09 Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Tue, 6 Jun 2023 14:59:42 -0400 Subject: [PATCH 017/109] update fix submodule to bring in gfs.v16.3.7 changes (#581) --- fix | 2 +- modulefiles/gsi_hera.gnu.lua | 2 +- modulefiles/gsi_hera.intel.lua | 2 +- modulefiles/gsi_jet.lua | 2 +- modulefiles/gsi_orion.lua | 2 +- modulefiles/gsi_s4.lua | 2 +- modulefiles/gsi_wcoss2.lua | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) diff --git a/fix b/fix index 0be26971f8..6a42a29dbb 160000 --- a/fix +++ b/fix @@ -1 +1 @@ -Subproject commit 0be26971f834fe9b1d5b118e1e0ffed53facf671 +Subproject commit 6a42a29dbbc9fca3453cc9e829601185555890b9 diff --git a/modulefiles/gsi_hera.gnu.lua b/modulefiles/gsi_hera.gnu.lua index 3ed9fbddb0..4f0253ba4d 100644 --- a/modulefiles/gsi_hera.gnu.lua +++ b/modulefiles/gsi_hera.gnu.lua @@ -20,6 +20,6 @@ load(pathJoin("prod_util", prod_util_ver)) pushenv("MKLROOT", "/apps/oneapi/mkl/2022.0.2") -pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20221128") +pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20230601") whatis("Description: GSI environment on Hera with GNU Compilers") diff --git a/modulefiles/gsi_hera.intel.lua b/modulefiles/gsi_hera.intel.lua index 1efb6f4405..62a915ef72 100644 --- a/modulefiles/gsi_hera.intel.lua +++ b/modulefiles/gsi_hera.intel.lua @@ -26,6 +26,6 @@ load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-xHOST") pushenv("FFLAGS", "-xHOST") -pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20221128") +pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20230601") whatis("Description: GSI environment on Hera with Intel Compilers") diff --git a/modulefiles/gsi_jet.lua b/modulefiles/gsi_jet.lua index 855597a08e..a769deca6f 100644 --- a/modulefiles/gsi_jet.lua +++ b/modulefiles/gsi_jet.lua @@ -27,6 +27,6 @@ pushenv("CFLAGS", "-axSSE4.2,AVX,CORE-AVX2") pushenv("FFLAGS", "-axSSE4.2,AVX,CORE-AVX2") -pushenv("GSI_BINARY_SOURCE_DIR", "/mnt/lfs4/HFIP/hfv3gfs/glopara/git/fv3gfs/fix/gsi/20221128") +pushenv("GSI_BINARY_SOURCE_DIR", "/mnt/lfs4/HFIP/hfv3gfs/glopara/git/fv3gfs/fix/gsi/20230601") whatis("Description: GSI environment on Jet with Intel Compilers") diff --git a/modulefiles/gsi_orion.lua b/modulefiles/gsi_orion.lua index b69467f7ce..fb3df720e4 100644 --- a/modulefiles/gsi_orion.lua +++ b/modulefiles/gsi_orion.lua @@ -23,6 +23,6 @@ load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-xHOST") pushenv("FFLAGS", "-xHOST") -pushenv("GSI_BINARY_SOURCE_DIR", "/work/noaa/global/glopara/fix/gsi/20221128") +pushenv("GSI_BINARY_SOURCE_DIR", "/work/noaa/global/glopara/fix/gsi/20230601") whatis("Description: GSI environment on Orion with Intel Compilers") diff --git a/modulefiles/gsi_s4.lua b/modulefiles/gsi_s4.lua index f393ce516a..24b1f5962d 100644 --- a/modulefiles/gsi_s4.lua +++ b/modulefiles/gsi_s4.lua @@ -23,6 +23,6 @@ load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-march=ivybridge") pushenv("FFLAGS", "-march=ivybridge") -pushenv("GSI_BINARY_SOURCE_DIR", "/data/prod/glopara/fix/gsi/20221128") +pushenv("GSI_BINARY_SOURCE_DIR", "/data/prod/glopara/fix/gsi/20230601") whatis("Description: GSI environment on S4 with Intel Compilers") diff --git a/modulefiles/gsi_wcoss2.lua b/modulefiles/gsi_wcoss2.lua index 209af8c8a9..1872f89d17 100644 --- a/modulefiles/gsi_wcoss2.lua +++ b/modulefiles/gsi_wcoss2.lua @@ -20,6 +20,6 @@ load(pathJoin("prod_util", prod_util_ver)) load("gsi_common") -pushenv("GSI_BINARY_SOURCE_DIR", "/lfs/h2/emc/global/noscrub/emc.global/FIX/fix/gsi/20221128") +pushenv("GSI_BINARY_SOURCE_DIR", "/lfs/h2/emc/global/noscrub/emc.global/FIX/fix/gsi/20230601") whatis("Description: GSI environment on WCOSS2") From 00cac5443e49f466a8d117b18a7c30903747b6a0 Mon Sep 17 00:00:00 2001 From: TingLei-NOAA Date: Tue, 27 Jun 2023 00:15:18 -0400 Subject: [PATCH 018/109] Feature/enkf q2 (#568) Resubmit PR for cleaning the unneeded item in the previous PR In correspondence to the EMC GSI Issue#566, this PR contains a quick adding of the clipping of negative values of sphum (q) in the analysis of FV3-LAM EnKF. This part of codes are not tested in the current GSI regression tests, which, hence, are not run. The current codes are verified using local FV3-LAM case. It is found the differences from this changes exist for sphum ( maximum values about 0.003 (units) and 0.3 K for T (sensible T). The latter is because the sphum would be used when the analysis TV is converted to T. All differences are on spontaneous points and values are reasonable as expected. Hence, the code is regarded as verified. Fixes #566 **DUE DATE for this PR is 6/15/2023.** If this PR is not merged into `develop` by this date, the PR will be closed and returned to the developer. --- src/enkf/gridio_fv3reg.f90 | 72 +++++++++++--------------------------- src/enkf/innovstats.f90 | 2 +- 2 files changed, 22 insertions(+), 52 deletions(-) diff --git a/src/enkf/gridio_fv3reg.f90 b/src/enkf/gridio_fv3reg.f90 index 4939dd16ee..068e6cba8b 100644 --- a/src/enkf/gridio_fv3reg.f90 +++ b/src/enkf/gridio_fv3reg.f90 @@ -42,7 +42,7 @@ module gridio use params, only: nlevs, cliptracers, datapath, arw, nmm, datestring use params, only: nx_res,ny_res,nlevs,ntiles,l_fv3reg_filecombined,& fv3_io_layout_nx,fv3_io_layout_ny,nanals - use params, only: pseudo_rh, l_use_enkf_directZDA + use params, only: pseudo_rh use mpeu_util, only: getindex use read_fv3regional_restarts,only:read_fv3_restart_data1d,read_fv3_restart_data2d use read_fv3regional_restarts,only:read_fv3_restart_data3d,read_fv3_restart_data4d @@ -694,7 +694,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid ps_ind = getindex(vars2d, 'ps') ! Ps (2D) - + clip=tiny(clip) !---------------------------------------------------------------------- if (nbackgrounds > 1) then write(6,*)'gridio/writegriddata: writing multiple backgrounds not yet supported' @@ -853,6 +853,8 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid varstrname = 'sphum' call fv3lamfile%get_idfn(varstrname,file_id,fv3filename) call read_fv3_restart_data3d(varstrname,fv3filename,file_id,qworkvar3d) + !enforce lower positive bound (clip) to replace negative hydrometers + if ( cliptracers ) where (qworkvar3d < clip) qworkvar3d = clip tvworkvar3d=tsenworkvar3d*(one+fv*qworkvar3d) tvworkvar3d=tvworkvar3d+workinc3d if(q_ind > 0) then @@ -866,6 +868,8 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid enddo enddo qworkvar3d=qworkvar3d+workinc3d + !enforce lower positive bound (clip) to replace negative q + if ( cliptracers ) where (qworkvar3d < clip) qworkvar3d = clip endif tsenworkvar3d=tvworkvar3d/(one+fv*qworkvar3d) varstrname = 'T' @@ -932,10 +936,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) endif @@ -955,10 +956,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) endif @@ -978,10 +976,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) endif @@ -1001,10 +996,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) endif @@ -1024,10 +1016,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) endif @@ -1046,10 +1035,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d) endif @@ -1888,7 +1874,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat ps_ind = getindex(vars2d, 'ps') ! Ps (2D) - + clip=tiny(clip) allocate(my_neb(4)) !---------------------------------------------------------------------- if (nbackgrounds > 1) then @@ -2173,6 +2159,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat enddo if(iope ==0 ) then + if ( cliptracers ) where (qworkvar3d < clip) qworkvar3d = clip tvworkvar3d=tsenworkvar3d*(one+fv*qworkvar3d) tvworkvar3d=tvworkvar3d+workinc3d if(q_ind > 0) then @@ -2186,6 +2173,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat enddo enddo qworkvar3d=qworkvar3d+workinc3d + if ( cliptracers ) where (qworkvar3d < clip) qworkvar3d = clip endif tsenworkvar3d=tvworkvar3d/(one+fv*qworkvar3d) endif @@ -2281,10 +2269,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip endif do k=1,nlevs call mpi_scatterv(workvar3d(:,:,k),recvcounts2d,displs2d,mpi_real4,& @@ -2315,10 +2300,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip endif do k=1,nlevs call mpi_scatterv(workvar3d(:,:,k),recvcounts2d,displs2d,mpi_real4,& @@ -2349,10 +2331,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip endif do k=1,nlevs call mpi_scatterv(workvar3d(:,:,k),recvcounts2d,displs2d,mpi_real4,& @@ -2383,10 +2362,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip endif do k=1,nlevs call mpi_scatterv(workvar3d(:,:,k),recvcounts2d,displs2d,mpi_real4,& @@ -2417,10 +2393,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip endif do k=1,nlevs call mpi_scatterv(workvar3d(:,:,k),recvcounts2d,displs2d,mpi_real4,& @@ -2450,10 +2423,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat enddo enddo workvar3d=workvar3d+workinc3d - if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers - clip = tiny(workvar3d(1,1,1)) - where (workvar3d < clip) workvar3d = clip - end if + if ( cliptracers ) where (workvar3d < clip) workvar3d = clip endif do k=1,nlevs call mpi_scatterv(workvar3d(:,:,k),recvcounts2d,displs2d,mpi_real4,& diff --git a/src/enkf/innovstats.f90 b/src/enkf/innovstats.f90 index e67cf43f10..68668218fc 100644 --- a/src/enkf/innovstats.f90 +++ b/src/enkf/innovstats.f90 @@ -213,7 +213,7 @@ subroutine print_innovstats(obfit,obsprd) call printstats(' all gps',sumgps_nh,biasq_nh,sumgps_spread_nh,sumgps_oberr_nh,nobsgps_nh,& sumgps_sh,biasgps_sh,sumgps_spread_sh,sumgps_oberr_sh,nobsgps_sh,& sumgps_tr,biasgps_tr,sumgps_spread_tr,sumgps_oberr_tr,nobsgps_tr) - call printstats(' all dbz',sumdbz_nh,biasq_nh,sumdbz_spread_nh,sumdbz_oberr_nh,nobsdbz_nh,& + call printstats(' all dbz',sumdbz_nh,biasdbz_nh,sumdbz_spread_nh,sumdbz_oberr_nh,nobsdbz_nh,& sumdbz_sh,biasdbz_sh,sumdbz_spread_sh,sumdbz_oberr_sh,nobsdbz_sh,& sumdbz_tr,biasdbz_tr,sumdbz_spread_tr,sumdbz_oberr_tr,nobsdbz_tr) call printstats(' all rw',sumrw_nh,biasq_nh,sumrw_spread_nh,sumrw_oberr_nh,nobsrw_nh,& From 333ae16183c1c9a9b51c789efcf67888167ab61b Mon Sep 17 00:00:00 2001 From: emilyhcliu <36091766+emilyhcliu@users.noreply.github.com> Date: Wed, 28 Jun 2023 09:37:21 -0400 Subject: [PATCH 019/109] Zero increments for precipitation hydrometeors are written as missing values instead of zeros (#578) --- src/enkf/gridio_gfs.f90 | 283 ++++++++++++++++++---------------------- 1 file changed, 130 insertions(+), 153 deletions(-) diff --git a/src/enkf/gridio_gfs.f90 b/src/enkf/gridio_gfs.f90 index 5d560be3a8..e4631f4e2d 100644 --- a/src/enkf/gridio_gfs.f90 +++ b/src/enkf/gridio_gfs.f90 @@ -4270,6 +4270,7 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate real(r_kind), dimension(nlons*nlats) :: psinc, inc, ug, vg, work real(r_single), allocatable, dimension(:,:,:) :: inc3d, inc3d2, inc3dout real(r_single), allocatable, dimension(:,:,:) :: tv, tvanl, tmp, tmpanl, q, qanl + real(r_single), allocatable, dimension(:,:,:) :: q2, qanl2 real(r_kind), allocatable, dimension(:,:) :: values_2d real(r_kind), allocatable, dimension(:) :: psges, delzb, values_1d @@ -4393,9 +4394,6 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate ! old logical massbal_adjust, if non-zero use_full_hydro = ( ql_ind > 0 .and. qi_ind > 0 .and. & qr_ind > 0 .and. qs_ind > 0 .and. qg_ind > 0 ) - ! Currently, we do not let precipiation to affect the enkf analysis - ! The following line will be removed after testing - use_full_hydro = .false. dsfg = open_dataset(filenamein, paropen=.true., mpicomm=iocomms(mem_pe(nproc))) call read_attribute(dsfg, 'ak', values_1d,errcode=iret) @@ -4621,141 +4619,31 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate ! Read in background + increment and make sure the minimum is qcmin ! Adjust increment accordingly - if (use_full_hydro) then - ! liq wat increment - call read_vardata(dsfg, 'clwmr', q, ncstart=ncstart, nccount=nccount, errcode=iret) - if (iret /= 0) then - write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading clwmr, iret= ',iret,' PROGRAM STOPS' - call stop2(29) - endif - do k=lev_pe1(iope), lev_pe2(iope) - krev = nlevs-k+1 - ki = k - lev_pe1(iope) + 1 - inc(:) = zero - if (ql_ind > 0) then - call copyfromgrdin(grdin(:,levels(ql_ind-1) + krev,nb,ne),inc) - endif - inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) - qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki) - end do - if (cliptracers) where (qanl < qcmin) qanl = qcmin - inc3d = qanl - q ! updated clwmr increment - do j=1,nlats - inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) - end do - if (should_zero_increments_for('liq_wat_inc')) inc3dout = zero - call nccheck_incr(nf90_put_var(ncid_out, liqwatvarid, sngl(inc3dout), & - start = ncstart, count = nccount)) - - ! icmr increment - call read_vardata(dsfg, 'icmr', q, ncstart=ncstart, nccount=nccount, errcode=iret) - if (iret /= 0) then - write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading icmr, iret= ',iret,' PROGRAM STOPS' - call stop2(29) - endif - do k=lev_pe1(iope), lev_pe2(iope) - krev = nlevs-k+1 - ki = k - lev_pe1(iope) + 1 - inc(:) = zero - if (qi_ind > 0) then - call copyfromgrdin(grdin(:,levels(qi_ind-1) + krev,nb,ne),inc) - endif - inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) - qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki) - end do - if (cliptracers) where (qanl < qcmin) qanl = qcmin - inc3d = qanl - q ! updated icmr increment - do j=1,nlats - inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) - end do - if (should_zero_increments_for('icmr_inc')) inc3dout = zero - call nccheck_incr(nf90_put_var(ncid_out, icvarid, sngl(inc3dout), & - start = ncstart, count = nccount)) - - ! rwmr increment - call read_vardata(dsfg, 'rwmr', q, ncstart=ncstart, nccount=nccount, errcode=iret) - if (iret /= 0) then - write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading rwmr, iret= ',iret,' PROGRAM STOPS' - call stop2(29) - endif - do k=lev_pe1(iope), lev_pe2(iope) - krev = nlevs-k+1 - ki = k - lev_pe1(iope) + 1 - inc(:) = zero - if (qr_ind > 0) then - call copyfromgrdin(grdin(:,levels(qr_ind-1) + krev,nb,ne),inc) - endif - inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) - qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki) - end do - if (cliptracers) where (qanl < qcmin) qanl = qcmin - inc3d = qanl - q ! updated rwmr increment - do j=1,nlats - inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) - end do - if (should_zero_increments_for('rwmr_inc')) inc3dout = zero - call nccheck_incr(nf90_put_var(ncid_out, rwmrvarid, sngl(inc3dout), & - start = ncstart, count = nccount)) - - ! snmr increment - call read_vardata(dsfg, 'snmr', q, ncstart=ncstart, nccount=nccount, errcode=iret) - if (iret /= 0) then - write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading snmr, iret= ',iret,' PROGRAM STOPS' - call stop2(29) - endif - do k=lev_pe1(iope), lev_pe2(iope) - krev = nlevs-k+1 - ki = k - lev_pe1(iope) + 1 - inc(:) = zero - if (qs_ind > 0) then - call copyfromgrdin(grdin(:,levels(qs_ind-1) + krev,nb,ne),inc) - endif - inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) - qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki) - end do - if (cliptracers) where (qanl < qcmin) qanl = qcmin - inc3d = qanl - q ! updated snmr increment - do j=1,nlats - inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) - end do - if (should_zero_increments_for('snmr_inc')) inc3dout = zero - call nccheck_incr(nf90_put_var(ncid_out, snmrvarid, sngl(inc3dout), & - start = ncstart, count = nccount)) - - ! grle increment - call read_vardata(dsfg, 'grle', q, ncstart=ncstart, nccount=nccount, errcode=iret) - if (iret /= 0) then - write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading grle, iret= ',iret,' PROGRAM STOPS' - call stop2(29) - endif - do k=lev_pe1(iope), lev_pe2(iope) - krev = nlevs-k+1 - ki = k - lev_pe1(iope) + 1 - inc(:) = zero - if (qg_ind > 0) then - call copyfromgrdin(grdin(:,levels(qg_ind-1) + krev,nb,ne),inc) - endif - inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) - qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki) - end do - if (cliptracers) where (qanl < qcmin) qanl = qcmin - inc3d = qanl - q ! updated grle increment - do j=1,nlats - inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) - end do - if (should_zero_increments_for('grle_inc')) inc3dout = zero - call nccheck_incr(nf90_put_var(ncid_out, grlevarid, sngl(inc3dout), & - start = ncstart, count = nccount)) - else - ! liq wat increment - ! icmr increment - do k=lev_pe1(iope), lev_pe2(iope) - krev = nlevs-k+1 - ki = k - lev_pe1(iope) + 1 - ug = zero - if (cw_ind > 0) then - call copyfromgrdin(grdin(:,levels(cw_ind-1)+krev,nb,ne),ug) - end if + ! liq wat increment + ! icmr increment + ! if cw increment, make sure split the cw increment into ql and qi increments + allocate(q2(nlons,nlats,nccount(3)),qanl2(nlons,nlats,nccount(3))) + call read_vardata(dsfg, 'clwmr', q, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading clwmr, iret= ',iret,' PROGRAM STOPS' + call stop2(29) + endif + call read_vardata(dsfg, 'icmr', q2, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading icmr, iret= ',iret,' PROGRAM STOPS' + call stop2(29) + endif + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + ug = zero; vg = zero + if (cw_ind > 0) then + call copyfromgrdin(grdin(:,levels(cw_ind-1)+krev,nb,ne),ug) + else if (ql_ind > 0) then + call copyfromgrdin(grdin(:,levels(ql_ind-1)+krev,nb,ne),ug) + end if + ! analysis control variable is cw, need to split cw analysis to ql and qi + if (cw_ind > 0) then if (imp_physics == 11) then work = -r0_05 * (reshape(tmpanl(:,:,ki),(/nlons*nlats/)) - t0c) do i=1,nlons*nlats @@ -4764,29 +4652,118 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate enddo vg = ug * work ! cloud ice ug = ug * (one - work) ! cloud water - inc3d2(:,:,ki) = reshape(vg,(/nlons,nlats/)) endif - inc3d(:,:,ki) = reshape(ug,(/nlons,nlats/)) - enddo - do j=1,nlats - inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) - end do - if (should_zero_increments_for('liq_wat_inc')) inc3dout = zero - call nccheck_incr(nf90_put_var(ncid_out, liqwatvarid, sngl(inc3dout), & - start = ncstart, count = nccount)) - do j=1,nlats - inc3dout(:,nlats-j+1,:) = inc3d2(:,j,:) - end do - if (should_zero_increments_for('icmr_inc')) inc3dout = zero - call nccheck_incr(nf90_put_var(ncid_out, icvarid, sngl(inc3dout), & - start = ncstart, count = nccount)) + else if (qi_ind > 0) then + call copyfromgrdin(grdin(:,levels(qi_ind-1)+krev,nb,ne),vg) + endif + inc3d(:,:,ki) = reshape(ug,(/nlons,nlats/)) ! cloud water + qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki) + inc3d2(:,:,ki) = reshape(vg,(/nlons,nlats/)) ! cloud ice + qanl2(:,:,ki) = q2(:,:,ki) + inc3d(:,:,ki) + enddo + + ! adjust hydrometeor increment to make sure analysis is positive + if (cliptracers) where (qanl < qcmin) qanl = qcmin + inc3d = qanl - q ! ql + if (cliptracers) where (qanl2 < qcmin) qanl2 = qcmin + inc3d2 = qanl2 - q2 ! qi + + ! output ql increment + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('liq_wat_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, liqwatvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + ! output qi increment + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d2(:,j,:) + end do + if (should_zero_increments_for('icmr_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, icvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! rwmr increment + call read_vardata(dsfg, 'rwmr', q, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading rwmr, iret= ',iret,' PROGRAM STOPS' + call stop2(29) endif + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + inc(:) = zero + if (qr_ind > 0) then + call copyfromgrdin(grdin(:,levels(qr_ind-1) + krev,nb,ne),inc) + endif + inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) + qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki) + end do + if (cliptracers) where (qanl < qcmin) qanl = qcmin + inc3d = qanl - q ! updated rwmr increment + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('rwmr_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, rwmrvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! snmr increment + call read_vardata(dsfg, 'snmr', q, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading snmr, iret= ',iret,' PROGRAM STOPS' + call stop2(29) + endif + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + inc(:) = zero + if (qs_ind > 0) then + call copyfromgrdin(grdin(:,levels(qs_ind-1) + krev,nb,ne),inc) + endif + inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) + qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki) + end do + if (cliptracers) where (qanl < qcmin) qanl = qcmin + inc3d = qanl - q ! updated snmr increment + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('snmr_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, snmrvarid, sngl(inc3dout), & + start = ncstart, count = nccount)) + + ! grle increment + call read_vardata(dsfg, 'grle', q, ncstart=ncstart, nccount=nccount, errcode=iret) + if (iret /= 0) then + write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading grle, iret= ',iret,' PROGRAM STOPS' + call stop2(29) + endif + do k=lev_pe1(iope), lev_pe2(iope) + krev = nlevs-k+1 + ki = k - lev_pe1(iope) + 1 + inc(:) = zero + if (qg_ind > 0) then + call copyfromgrdin(grdin(:,levels(qg_ind-1) + krev,nb,ne),inc) + endif + inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/)) + qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki) + end do + if (cliptracers) where (qanl < qcmin) qanl = qcmin + inc3d = qanl - q ! updated grle increment + do j=1,nlats + inc3dout(:,nlats-j+1,:) = inc3d(:,j,:) + end do + if (should_zero_increments_for('grle_inc')) inc3dout = zero + call nccheck_incr(nf90_put_var(ncid_out, grlevarid, sngl(inc3dout), & + start = ncstart, count = nccount)) call mpi_barrier(iocomms(mem_pe(nproc)), iret) ! deallocate things deallocate(inc3d,inc3d2,inc3dout) deallocate(tmp,tv,q,tmpanl,tvanl,qanl) + deallocate(q2,qanl2) if (allocated(delzb)) deallocate(delzb) if (allocated(psges)) deallocate(psges) From accb07e291e0fa707e0ee0adf17c15a83d8e06d8 Mon Sep 17 00:00:00 2001 From: ClaraDraper-NOAA <33430543+ClaraDraper-NOAA@users.noreply.github.com> Date: Mon, 7 Aug 2023 09:50:18 -0600 Subject: [PATCH 020/109] Bugfix for pseudo_RH option (#602) --- regression/regression_namelists.sh | 4 +- src/enkf/controlvec.f90 | 101 +++++++---------------------- src/enkf/params.f90 | 12 +--- 3 files changed, 25 insertions(+), 92 deletions(-) diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh index 824c6f0719..3668a6f8c1 100755 --- a/regression/regression_namelists.sh +++ b/regression/regression_namelists.sh @@ -2155,7 +2155,7 @@ export gsi_namelist=" &nam_enkf datestring=${global_adate},datapath='${DATA}/', analpertwtnh=${analpertwt},analpertwtsh=${analpertwt},analpertwttr=${analpertwt}, - covinflatemax=1.e2,covinflatemin=1,pseudo_rh=.true.,iassim_order=0, + covinflatemax=1.e2,covinflatemin=1,pseudo_rh=.false.,iassim_order=0, corrlengthnh=${corrlength},corrlengthsh=${corrlength},corrlengthtr=${corrlength}, lnsigcutoffnh=${lnsigcutoff},lnsigcutoffsh=${lnsigcutoff},lnsigcutofftr=${lnsigcutoff}, lnsigcutoffpsnh=${lnsigcutoff},lnsigcutoffpssh=${lnsigcutoff},lnsigcutoffpstr=${lnsigcutoff}, @@ -2169,7 +2169,7 @@ export gsi_namelist=" use_gfs_nemsio=${use_gfs_nemsio},use_gfs_ncio=${use_gfs_ncio},imp_physics=$imp_physics,lupp=$lupp, univaroz=.false.,adp_anglebc=.true.,angord=4,use_edges=.false.,emiss_bc=.true., letkf_flag=${letkf_flag},nobsl_max=${nobsl_max},denkf=${denkf},getkf=${getkf}., - nhr_anal=${IAUFHRS_ENKF},nhr_state=${IAUFHRS_ENKF},use_qsatensmean=.true., + nhr_anal=${IAUFHRS_ENKF},nhr_state=${IAUFHRS_ENKF}, lobsdiag_forenkf=$lobsdiag_forenkf, write_spread_diag=$write_spread_diag, modelspace_vloc=$modelspace_vloc, diff --git a/src/enkf/controlvec.f90 b/src/enkf/controlvec.f90 index 4aa2613c63..40dff4dbad 100644 --- a/src/enkf/controlvec.f90 +++ b/src/enkf/controlvec.f90 @@ -51,7 +51,7 @@ module controlvec use gridinfo, only: getgridinfo, gridinfo_cleanup, & npts, vars3d_supported, vars2d_supported use params, only: nlevs, nbackgrounds, fgfileprefixes, reducedgrid, & - nanals, pseudo_rh, use_qsatensmean, nlons, nlats,& + nanals, pseudo_rh, nlons, nlats,& nanals_per_iotask, ntasks_io, nanal1, nanal2, & fgsfcfileprefixes, paranc, write_fv3_incr, write_ensmean use kinds, only: r_kind, i_kind, r_double, r_single @@ -64,7 +64,6 @@ module controlvec public :: read_control, write_control, controlvec_cleanup, init_controlvec real(r_single), public, allocatable, dimension(:,:,:,:) :: grdin real(r_double), public, allocatable, dimension(:,:,:,:) :: qsat -real(r_double), public, allocatable, dimension(:,:,:) :: qsatmean integer(i_kind), public :: nc2d, nc3d, ncdim character(len=max_varname_length), allocatable, dimension(:), public :: cvars3d @@ -160,7 +159,7 @@ subroutine init_controlvec() do i = 1, nc2d if (getindex(vars2d_supported, cvars2d(i))<0) then if (nproc .eq. 0) then - print *,'Error: 2D variable ', cvars2d(i), ' is not supported in current version.' + print *,'Error: control 2D variable ', cvars2d(i), ' is not supported in current version.' print *,'Supported variables: ', vars2d_supported endif call stop2(502) @@ -169,7 +168,7 @@ subroutine init_controlvec() do i = 1, nc3d if (getindex(vars3d_supported, cvars3d(i))<0) then if (nproc .eq. 0) then - print *,'Error: 3D variable ', cvars3d(i), ' is not supported in current version.' + print *,'Error: control 3D variable ', cvars3d(i), ' is not supported in current version.' print *,'Supported variables: ', vars3d_supported endif call stop2(502) @@ -192,7 +191,6 @@ subroutine read_control() ! read ensemble members on IO tasks implicit none real(r_double) :: t1,t2 -real(r_double), allocatable, dimension(:) :: qsat_tmp integer(i_kind) :: nb,nlev,ne integer(i_kind) :: q_ind integer(i_kind) :: ierr @@ -229,56 +227,18 @@ subroutine read_control() end if !print *,'min/max qsat',nanal,'=',minval(qsat),maxval(qsat) q_ind = getindex(cvars3d, 'q') - if (use_qsatensmean .and. q_ind>0 ) then - allocate(qsatmean(npts,nlevs,nbackgrounds)) - allocate(qsat_tmp(npts)) - ! compute ensemble mean qsat - qsatmean = 0_r_double - do ne=1,nanals_per_iotask - do nb=1,nbackgrounds - do nlev=1,nlevs - call mpi_allreduce(qsat(:,nlev,nb,ne),qsat_tmp,npts,mpi_real8,mpi_sum,mpi_comm_io,ierr) - qsatmean(:,nlev,nb) = qsatmean(:,nlev,nb) + qsat_tmp - enddo - enddo - enddo - deallocate(qsat_tmp) - qsatmean = qsatmean/real(nanals) - !print *,'min/max qsat ensmean',nanal,'=',minval(qsat),maxval(qsat) - endif if (nproc == 0) then t2 = mpi_wtime() print *,'time in readgridata on root',t2-t1,'secs' end if - !do ne=1,nanals_per_iotask - ! nanal = ne + (nproc-1)*nanals_per_iotask - ! print *,'min/max ps ens mem',nanal,'=',& - ! minval(grdin(:,ncdim,nbackgrounds/2+1,ne)),maxval(grdin(:,ncdim,nbackgrounds/2+1,ne)) - ! print *,'min/max qsat',nanal,'=',& - ! minval(qsat(:,:,nbackgrounds/2+1,ne)),maxval(qsat(:,:,nbackgrounds/2+1,ne)) - !enddo - !if (use_qsatensmean) then - ! print *,'min/max qsatmean proc',nproc,'=',& - ! minval(qsatmean(:,:,nbackgrounds/2+1)),maxval(qsatmean(:,:,nbackgrounds/2+1)) - !endif if (pseudo_rh .and. q_ind > 0) then - if (use_qsatensmean) then - do ne=1,nanals_per_iotask - do nb=1,nbackgrounds - ! create normalized humidity analysis variable. - grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne) = & - grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne)/qsatmean(:,:,nb) - enddo - enddo - else - do ne=1,nanals_per_iotask - do nb=1,nbackgrounds - ! create normalized humidity analysis variable. - grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne) = & - grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne)/qsat(:,:,nb,ne) - enddo - enddo - endif + do ne=1,nanals_per_iotask + do nb=1,nbackgrounds + ! create normalized humidity analysis variable. + grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne) = & + grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne)/qsat(:,:,nb,ne) + enddo + enddo end if endif @@ -299,6 +259,18 @@ subroutine write_control(no_inflate_flag) if (nproc <= ntasks_io-1) then + ! scale q by ensemble qsat, prior to averaging + q_ind = getindex(cvars3d, 'q') + if (pseudo_rh .and. q_ind > 0) then + do ne=1,nanals_per_iotask + do nb=1,nbackgrounds + grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne) = & + grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne)*qsat(:,:,nb,ne) + enddo + enddo + endif + + allocate(grdin_mean_tmp(npts,ncdim)) if (nproc == 0) then allocate(grdin_mean(npts,ncdim,nbackgrounds,1)) @@ -345,34 +317,6 @@ subroutine write_control(no_inflate_flag) 100 format('ens. mean anal. increment min/max ',a,2x,g19.12,2x,g19.12) deallocate(grdin_mean_tmp) - q_ind = getindex(cvars3d, 'q') - if (pseudo_rh .and. q_ind > 0) then - if (use_qsatensmean) then - do ne=1,nanals_per_iotask - do nb=1,nbackgrounds - ! re-scale normalized spfh with sat. sphf of ensmean first guess - grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne) = & - grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne)*qsatmean(:,:,nb) - enddo - enddo - else - do ne=1,nanals_per_iotask - do nb=1,nbackgrounds - ! re-scale normalized spfh with sat. sphf of first guess - grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne) = & - grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne)*qsat(:,:,nb,ne) - enddo - enddo - endif - if (nproc == 0 .and. write_ensmean) then - ! write_ensmean implies use_qsatensmean - do nb=1,nbackgrounds - ! re-scale normalized spfh with sat. sphf of ensmean first guess - grdin_mean(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,1) = & - grdin_mean(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,1)*qsatmean(:,:,nb) - enddo - endif - end if if (.not. paranc) then if (write_fv3_incr) then call writeincrement(nanal1(nproc),nanal2(nproc),cvars3d,cvars2d,nc3d,nc2d,clevels,ncdim,grdin,no_inflate_flag) @@ -427,7 +371,6 @@ subroutine controlvec_cleanup() if (allocated(index_pres)) deallocate(index_pres) if (allocated(grdin)) deallocate(grdin) if (allocated(qsat)) deallocate(qsat) -if (allocated(qsatmean)) deallocate(qsatmean) call gridinfo_cleanup() end subroutine controlvec_cleanup diff --git a/src/enkf/params.f90 b/src/enkf/params.f90 index b21d88abd0..62701c24a7 100644 --- a/src/enkf/params.f90 +++ b/src/enkf/params.f90 @@ -226,12 +226,6 @@ module params ! EFSOI calculation applications logical,public :: efsoi_flag = .false. -! if true, use ensemble mean qsat in definition of -! normalized humidity analysis variable (instead of -! qsat for each member, which is the default behavior -! when pseudo_rh=.true. If pseudo_rh=.false, use_qsatensmean -! is ignored. -logical,public :: use_qsatensmean = .false. logical,public :: write_spread_diag = .false. ! if true, use jacobian from GSI stored in diag file to compute ! ensemble perturbations in observation space. @@ -261,7 +255,7 @@ module params namelist /nam_enkf/datestring,datapath,iassim_order,nvars,& covinflatemax,covinflatemin,deterministic,sortinc,& mincorrlength_fact,corrlengthnh,corrlengthtr,corrlengthsh,& - varqc,huber,nlons,nlats,smoothparm,use_qsatensmean,& + varqc,huber,nlons,nlats,smoothparm,& readin_localization, zhuberleft,zhuberright,& obtimelnh,obtimeltr,obtimelsh,reducedgrid,& lnsigcutoffnh,lnsigcutofftr,lnsigcutoffsh,& @@ -681,10 +675,6 @@ subroutine read_namelist() letkf_flag) then print *,'warning: no time localization in LETKF!' endif - if ((write_ensmean .and. pseudo_rh) .and. .not. use_qsatensmean) then - print *,'write_ensmean=T requires use_qsatensmean=T when pseudo_rh=T' - call stop2(19) - endif print *, trim(adjustl(datapath)) From 9e5aa09c0a31ec3f4f8352f2a6de0dbf487d0b0d Mon Sep 17 00:00:00 2001 From: Jack Woollen Date: Tue, 8 Aug 2023 11:19:38 -0400 Subject: [PATCH 021/109] changes for reanalysis runs (#591) --- src/gsi/gsi_obOperTypeManager.F90 | 8 +- src/gsi/m_extOzone.F90 | 319 ++++++++++++++++++++++++++++-- src/gsi/read_bufrtovs.f90 | 2 +- src/gsi/read_obs.F90 | 9 +- src/gsi/read_satwnd.f90 | 110 ++++++++--- src/gsi/read_ssmi.f90 | 6 +- src/gsi/setupoz.f90 | 156 +++++++++++---- 7 files changed, 518 insertions(+), 92 deletions(-) diff --git a/src/gsi/gsi_obOperTypeManager.F90 b/src/gsi/gsi_obOperTypeManager.F90 index ea306953c4..5df899825a 100644 --- a/src/gsi/gsi_obOperTypeManager.F90 +++ b/src/gsi/gsi_obOperTypeManager.F90 @@ -276,6 +276,9 @@ function dtype2index_(dtype) result(index_) case("ompstc8"); index_= iobOper_oz case("ompsnp" ); index_= iobOper_oz case("ompsnm" ); index_= iobOper_oz + case("omieff" ); index_= iobOper_oz + case("tomseff" ); index_= iobOper_oz + case("ompsnmeff"); index_= iobOper_oz case("o3l" ,"[o3loper]" ); index_= iobOper_o3l case("o3lev" ); index_= iobOper_o3l @@ -283,11 +286,10 @@ function dtype2index_(dtype) result(index_) case("mls22" ); index_= iobOper_o3l case("mls30" ); index_= iobOper_o3l case("mls55" ); index_= iobOper_o3l - case("omieff" ); index_= iobOper_o3l - case("tomseff" ); index_= iobOper_o3l + case("ompslp" ); index_= iobOper_o3l case("ompslpuv" ); index_= iobOper_o3l case("ompslpvis"); index_= iobOper_o3l - case("ompslp" ); index_= iobOper_o3l + case("ompslpnc" ); index_= iobOper_o3l case("gpsbend","[gpsbendoper]"); index_= iobOper_gpsbend case("gps_bnd"); index_= iobOper_gpsbend diff --git a/src/gsi/m_extOzone.F90 b/src/gsi/m_extOzone.F90 index 3d4b6783c1..a28209292f 100644 --- a/src/gsi/m_extOzone.F90 +++ b/src/gsi/m_extOzone.F90 @@ -158,32 +158,36 @@ function is_extOzone_(dfile,dtype,dplat,class) is_extOzone_= & ifile_==iBUFR .and. dtype == 'o3lev' .or. & ifile_==iNC .and. dtype == 'mls55' .or. & + ifile_==iNC .and. dtype == 'ompslpnc' .or. & ifile_==iNC .and. dtype == 'ompslpvis' .or. & ifile_==iNC .and. dtype == 'ompslpuv' .or. & - ifile_==iNC .and. dtype == 'ompslp' .or. & ifile_==iNC .and. dtype == 'lims' .or. & ifile_==iNC .and. dtype == 'uarsmls' .or. & ifile_==iNC .and. dtype == 'mipas' .or. & ifile_==iNC .and. dtype == 'omieff' .or. & + ifile_==iNC .and. dtype == 'ompsnmeff' .or. & + ifile_==iNC .and. dtype == 'ompsnpnc' .or. & ifile_==iNC .and. dtype == 'tomseff' case(iLEVEL) is_extOzone_= & ifile_==iBUFR .and. dtype == 'o3lev' .or. & ifile_==iNC .and. dtype == 'mls55' .or. & + ifile_==iNC .and. dtype == 'ompslpnc' .or. & ifile_==iNC .and. dtype == 'ompslpvis' .or. & ifile_==iNC .and. dtype == 'ompslpuv' .or. & - ifile_==iNC .and. dtype == 'ompslp' .or. & ifile_==iNC .and. dtype == 'lims' .or. & ifile_==iNC .and. dtype == 'uarsmls' .or. & ifile_==iNC .and. dtype == 'mipas' case(iLAYER) - is_extOzone_= .false. + is_extOzone_= & + ifile_==iNC .and. dtype == 'ompsnpnc' case(iTOTAL) is_extOzone_= & - ifile_==iNC .and. dtype == 'omieff' .or. & + ifile_==iNC .and. dtype == 'omieff' .or. & + ifile_==iNC .and. dtype == 'ompsnmeff' .or. & ifile_==iNC .and. dtype == 'tomseff' case default @@ -332,7 +336,7 @@ subroutine read_(dfile,dtype,dplat,dsis, & ! intent(in), keys for type mana endif select case(dtype) - case('omieff','tomseff') ! layer-ozone or total-ozone types + case('omieff','tomseff','ompsnmeff') ! layer-ozone or total-ozone types select case(dfile_format(dfile)) case('nc') call oztot_ncInquire_(nreal,nchan,ilat,ilon, & @@ -381,7 +385,7 @@ subroutine read_(dfile,dtype,dplat,dsis, & ! intent(in), keys for type mana jsatid, gstime,twind) end select - case('mls55','ompslpvis','ompslpuv','ompslp','lims','uarsmls','mipas') + case('mls55','ompslpnc','ompslpvis','ompslpuv','lims','uarsmls','mipas') select case(dfile_format(dfile)) case('nc') call ozlev_ncInquire_( nreal,nchan,ilat,ilon,maxobs) @@ -393,6 +397,17 @@ subroutine read_(dfile,dtype,dplat,dsis, & ! intent(in), keys for type mana end select + case('ompsnpnc') + select case(dfile_format(dfile)) + case('nc') + call ozlay_ncInquire_( nreal,nchan,ilat,ilon,maxobs) + allocate(p_out(nreal+nchan,maxobs)) + p_out(:,:)=RMISS + + call ozlay_ncRead_(dfile,dtype, p_out,nread,npuse,nouse, gstime,twind) + + end select + end select if(nouse<0 .or. .not.associated(p_out)) then @@ -706,7 +721,7 @@ subroutine oztot_ncread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & ! Apply data screening based on quality flags ! Bit 10 (from the left) in TOQF represents row anomaly. All 17 bits in toqf is ! supposed to converted into array elements of binary(:), either for "tomseff" or -! "omieff". +! "omieff" or "ompsnmeff". binary(:)=0 select case(dtype) case('omieff') @@ -731,6 +746,9 @@ subroutine oztot_ncread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & ! 0 - good data, 1 - good data with SZA > 84 deg if (toqf /= 0) cycle recloop + case('ompsnmeff') + !! data in NetCDF are prescreened + case default end select @@ -764,10 +782,10 @@ subroutine oztot_ncread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & ozout(7,itx)=real(toqf) ! - total ozone quality code (not used) ozout(8,itx)=real(sza) ! solar zenith angle ozout(9,itx)=binary(10) ! row anomaly flag, is actually fixed to 0 - ozout(10,itx)=0. ! - cloud amount (not used) - ozout(11,itx)=0. ! - vzan (not used) - ozout(12,itx)=0. ! - aerosol index (not used) - ozout(13,itx)=0. ! - ascending/descending (not used) + ozout(10,itx)=zero ! - cloud amount (not used) + ozout(11,itx)=zero ! - vzan (not used) + ozout(12,itx)=zero ! - aerosol index (not used) + ozout(13,itx)=zero ! - ascending/descending (not used) ozout(14,itx)=real(fovn) ! scan position ! "(not used)" flags above imply that they ! are not used in setupozlay(). @@ -1421,13 +1439,286 @@ subroutine ozlev_bufrread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & call warn(myname_,' actual retained =',nodata) call warn(myname_,' size(ozout,2) =',maxobs) endif - call closbf(lunin) - close(lunin) ! write(stdout,'(3a,3i8,f8.2)') mprefix('read_ozone'), & ! ' obstype,nmrecs,ndata,nodata,no/ndata = ',dtype,nmrecs,ndata,nodata,real(nodata)/ndata -end subroutine ozlev_bufrread_ + end subroutine ozlev_bufrread_ + + subroutine ozlay_ncInquire_( nreal,nchan,ilat,ilon, maxrec) + implicit none + + integer(kind=i_kind), intent(out):: nreal ! number of real parameters per record + integer(kind=i_kind), intent(out):: nchan ! number of channels or levels per record + integer(kind=i_kind), intent(out):: ilat ! index to latitude in nreal parameters. + integer(kind=i_kind), intent(out):: ilon ! index to longitude in nreal parameters. + + integer(kind=i_kind), intent(out):: maxrec ! extimated input record count + + character(len=*), parameter:: myname_=myname//'::ozlay_ncInquire_' + + ! Configure the record, they are not (dfile,dtype,dplat) dependent in this case. + nreal = 9 + nchan = 22 + ilat=4 + ilon=3 + + maxrec = MAXOBS_ + end subroutine ozlay_ncInquire_ + + !.................................................................................. + subroutine ozlay_ncread_(dfile,dtype,ozout,nmrecs,ndata,nodata, gstime,twind) + !.................................................................................. + use netcdf, only: nf90_open + use netcdf, only: nf90_nowrite + use netcdf, only: nf90_noerr + use netcdf, only: nf90_inq_dimid + use netcdf, only: nf90_inquire_dimension + use netcdf, only: nf90_inq_varid + use netcdf, only: nf90_get_var + use netcdf, only: nf90_close + + 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 ozinfo, only: jpch_oz,nusis_oz,iuse_oz + use mpeu_util, only: perr,die + ! use mpeu_util, only: mprefix,stdout + + implicit none + character(len=*), intent(in):: dfile ! obs_input filename + character(len=*), intent(in):: dtype ! obs_input dtype + real (kind=r_kind), dimension(:,:), intent(out):: ozout + integer(kind=i_kind), intent(out):: nmrecs ! count of records read + integer(kind=i_kind), intent(out):: ndata ! count of processed + integer(kind=i_kind), intent(out):: nodata ! count of retained + real (kind=r_kind), intent(in):: gstime ! analysis time (minute) from reference date + real (kind=r_kind), intent(in):: twind ! input group time window (hour) + + character(len=*), parameter:: myname_=myname//'::ozlay_ncRead_' + + integer(kind=i_kind):: ier,nprofs,levs,ikx,i,k0,ilev,iprof + integer(kind=i_kind):: nrecDimId,lonVarID,latVarID,yyVarID,mmVarID,levsDimId + integer(kind=i_kind):: szaVarID,ozoneVarID,nmind,k + integer(kind=i_kind):: ddVarID,hhVarID,minVarID,ssVarID,maxobs,ncid + real (kind=r_kind):: dlon,dlon_earth,dlon_earth_deg + real (kind=r_kind):: dlat,dlat_earth,dlat_earth_deg + real (kind=r_kind):: slons0,slats0 + real (kind=r_kind):: tdiff,sstime,t4dv,rsat + integer(kind=i_kind):: idate5(5) + integer(kind=i_kind),allocatable,dimension(:):: ipos + real(r_kind),allocatable,dimension(:):: poz + + integer(kind=i_kind), allocatable :: iya(:),ima(:),idda(:),ihha(:),imina(:),iseca(:) + real (kind=r_kind), allocatable :: slatsa(:),slonsa(:),ozone(:,:),sza(:) + real(r_kind) totoz + + logical:: outside + logical:: first + real(r_kind),parameter:: badoz = 10000.0_r_kind + + maxobs=size(ozout,2) + rsat=999._r_kind + ndata = 0 + nmrecs=0 + nodata=-1 + + ! Open file and read dimensions + call check(nf90_open(trim(dfile),nf90_nowrite,ncid),stat=ier) + + ! ignore if the file is not actually present. + if(ier/=nf90_noerr) then + nodata = 0 + return + endif + + ! Get dimensions from the input file + call check(nf90_inq_dimid(ncid, "nrec", nrecDimId),stat=ier) + + ! ignore if error + if(ier/=nf90_noerr) then + nodata = 0 + call check(nf90_close(ncid),stat=ier) + return + endif + + ! Get dimensions from the input file: # of profiles and # of levels + nprofs=0 + call check(nf90_inquire_dimension(ncid, nrecDimId, len = nprofs),stat=ier) + ! ignore if error + if(ier/=nf90_noerr) then + call check(nf90_close(ncid),stat=ier) + return + endif + + if(nprofs==0) then + nodata=0 + call check(nf90_close(ncid),stat=ier) + return + endif + + ! Continue the input + call check(nf90_inq_dimid(ncid, "nlevs", levsDimId)) + call check(nf90_inquire_dimension(ncid, levsDimId, len = levs)) + !!!!! if (levs /= nchan) + + allocate(ipos(levs)) + ipos=999 + ikx = 0 + first=.false. + do i=1,jpch_oz + if( (.not. first) .and. index(nusis_oz(i), trim(dtype))/=0) then + k0=i + first=.true. + end if + if(first.and.index(nusis_oz(i),trim(dtype))/=0) then + ikx=ikx+1 + ipos(ikx)=k0+ikx-1 + end if + end do + + if (ikx/=levs+1) call die(myname_//': inconsistent levs for '//dtype) + + ! Allocate space and read data + allocate(iya(nprofs),ima(nprofs),idda(nprofs),ihha(nprofs),imina(nprofs), & + iseca(nprofs),slatsa(nprofs),slonsa(nprofs),sza(nprofs),ozone(levs,nprofs)) + allocate (poz(levs+1)) + + call check(nf90_inq_varid(ncid, "lon", lonVarId)) + call check(nf90_get_var(ncid, lonVarId, slonsa)) + + call check(nf90_inq_varid(ncid, "lat", latVarId)) + call check(nf90_get_var(ncid, latVarId, slatsa)) + + call check(nf90_inq_varid(ncid, "yy", yyVarId)) + call check(nf90_get_var(ncid, yyVarId, iya)) + + call check(nf90_inq_varid(ncid, "mm", mmVarId)) + call check(nf90_get_var(ncid, mmVarId, ima)) + + call check(nf90_inq_varid(ncid, "dd", ddVarId)) + call check(nf90_get_var(ncid, ddVarId, idda)) + + call check(nf90_inq_varid(ncid, "hh", hhVarId)) + call check(nf90_get_var(ncid, hhVarId, ihha)) + + call check(nf90_inq_varid(ncid, "min", minVarId)) + call check(nf90_get_var(ncid, minVarId, imina)) + + call check(nf90_inq_varid(ncid, "ss", ssVarId)) + call check(nf90_get_var(ncid, ssVarId, iseca)) + + call check(nf90_inq_varid(ncid, "sza", szaVarId)) + call check(nf90_get_var(ncid, szaVarId, sza)) + + call check(nf90_inq_varid(ncid, "ozone", ozoneVarId)) + call check(nf90_get_var(ncid, ozoneVarId, ozone)) + + ! close the data file + call check(nf90_close(ncid)) + + ! 'Unpack' the data + nmrecs = 0 + nodata = 0 + read_loop1: do iprof = 1, nprofs + do ilev = 1, levs + if (ozone(ilev, iprof) .lt. -900.0_r_kind) cycle ! undefined + end do +!!$ if (iuse_oz(ipos(ilev)) < 0) then +!!$ usage = 10000._r_kind +!!$ else +!!$ usage = zero +!!$ endif + nmrecs=nmrecs+levs+1 + + ! convert observation location to radians + slons0=slonsa(iprof) + slats0=slatsa(iprof) + if(abs(slats0)>90._r_kind .or. abs(slons0)>r360) cycle + if(slons0< zero) slons0=slons0+r360 + if(slons0==r360) slons0=zero + dlat_earth_deg = slats0 + dlon_earth_deg = slons0 + dlat_earth = slats0 * deg2rad + dlon_earth = slons0 * deg2rad + + if(regional)then + call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) + if(outside) cycle + else + dlat = dlat_earth + dlon = dlon_earth + call grdcrd1(dlat,rlats,nlat,1) + call grdcrd1(dlon,rlons,nlon,1) + endif + + idate5(1) = iya(iprof) !year + idate5(2) = ima(iprof) !month + idate5(3) = idda(iprof) !day + idate5(4) = ihha(iprof) !hour + idate5(5) = imina(iprof) !minute + call w3fs21(idate5,nmind) + t4dv=real((nmind-iwinbgn),r_kind)*r60inv + if (l4dvar.or.l4densvar) then + if (t4dvwinlen) then + write(6,*)'read_ozone: ', dtype,' obs time idate5=',idate5,', t4dv=',& + t4dv,' is outside time window, sstime=',sstime*r60inv + cycle + end if + else + sstime=real(nmind,r_kind) + tdiff=(sstime-gstime)*r60inv + if(abs(tdiff) > twind)then + write(6,*)'read_ozone: ',dtype,' obs time idate5=',idate5,', tdiff=',& + tdiff,' is outside time window=',twind + cycle + end if + end if + + !! Compute total ozone + totoz=zero + do k=1,levs + poz(k) = ozone(k,iprof) + totoz=totoz+ozone(k,iprof) + end do + poz(levs+1) = totoz + + !Check ozone layer values. If any layer value is bad, toss entire profile + do k=1,levs + if (poz(k)>badoz) cycle read_loop1 + end do + + ! Write ozone record to output file + ndata=min(ndata+1,maxobs) + if(ndata<=maxobs) then + nodata=nodata+levs+1 + ozout(1,ndata)=rsat + ozout(2,ndata)=t4dv + ozout(3,ndata)=dlon ! grid relative longitude + ozout(4,ndata)=dlat ! grid relative latitude + ozout(5,ndata)=dlon_earth_deg ! earth relative longitude (degrees) + ozout(6,ndata)=dlat_earth_deg ! earth relative latitude (degrees) + ozout(7,ndata)=zero ! total ozone error flag + ozout(8,ndata)=zero ! profile ozone error flag + ozout(9,ndata)=sza(iprof) ! solar zenith angle + do k=1,levs+1 + ozout(k+9,ndata)=poz(k) + end do + end if + end do read_loop1 + + deallocate(iya,ima,idda,ihha,imina,iseca,slatsa,slonsa, ozone, poz,sza) + deallocate(ipos) + if (ndata > maxobs) then + call perr('read_ozone','Number of layer obs reached maxobs = ', maxobs) + call perr(myname_,'Number of layer obs reached maxobs = ', maxobs) + call perr(myname_,' ndata = ', ndata) + call perr(myname_,' nodata = ', nodata) + call die(myname_) + endif + + end subroutine ozlay_ncread_ !.................................................................................. subroutine check(status,stat) diff --git a/src/gsi/read_bufrtovs.f90 b/src/gsi/read_bufrtovs.f90 index 0c954c7c1d..a819acd2c3 100644 --- a/src/gsi/read_bufrtovs.f90 +++ b/src/gsi/read_bufrtovs.f90 @@ -683,7 +683,7 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& if (llll > 1) then sacv = nint(bfr1bhdr(14)) if (sacv > spc_coeff_versions) then - write(6,*) 'READ_BUFRTOVS WARNING sacv greater than spc_coeff_versions' + write(6,*) 'READ_BUFRTOVS WARNING sacv greater than spc_coeff_versions',' ',jsatid,' ',obstype end if else ! normal feed doesn't have antenna correction, so set sacv to 0 sacv = 0 diff --git a/src/gsi/read_obs.F90 b/src/gsi/read_obs.F90 index 9017c498c2..86c7e4ce45 100644 --- a/src/gsi/read_obs.F90 +++ b/src/gsi/read_obs.F90 @@ -891,6 +891,7 @@ subroutine read_obs(ndata,mype) if(obstype == 'mls20' ) nmls_type=nmls_type+1 if(obstype == 'mls22' ) nmls_type=nmls_type+1 if(obstype == 'mls30' ) nmls_type=nmls_type+1 + if(obstype == 'mls55' ) nmls_type=nmls_type+1 if(nmls_type>1) then write(6,*) '******ERROR***********: there is more than one MLS data type, not allowed, please check' call stop2(339) @@ -934,6 +935,7 @@ subroutine read_obs(ndata,mype) .or. obstype == 'ompsnp' & .or. obstype == 'gome' & .or. index(obstype, 'omps') /= 0 & + .or. index(obstype, 'omi' ) /= 0 & .or. mls & ) then ditype(i) = 'ozone' @@ -1080,7 +1082,12 @@ subroutine read_obs(ndata,mype) if (ii>npem1) ii=0 if(mype==ii)then call gsi_inquire(lenbytes,lexist,trim(dfile(i)),mype) - call read_obs_check (lexist,trim(dfile(i)),dplat(i),dtype(i),minuse,read_rec1(i)) + + if (is_extOzone(dfile(i),obstype,dplat(i))) then + print*,'reading ',trim(dfile(i)),' ',obstype,' ',trim(dplat(i)),lexist,lenbytes + else + call read_obs_check (lexist,trim(dfile(i)),dplat(i),dtype(i),minuse,read_rec1(i)) + endif ! If no data set starting record to be 999999. Note if this is not large ! enough code should still work - just does a bit more work. diff --git a/src/gsi/read_satwnd.f90 b/src/gsi/read_satwnd.f90 index 7a372b9e15..1679708787 100644 --- a/src/gsi/read_satwnd.f90 +++ b/src/gsi/read_satwnd.f90 @@ -155,12 +155,12 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis real(r_kind),parameter:: r799=799.0_r_kind real(r_kind),parameter:: r1200= 1200.0_r_kind real(r_kind),parameter:: r10000= 10000.0_r_kind - - + + real(r_double),parameter:: rmiss=10d7 ! Declare local variables logical outside,inflate_error - logical luse,ithinp + logical luse,ithinp,do_qc logical,allocatable,dimension(:,:):: lmsg ! set true when convinfo entry id found in a message character(70) obstr_v1, obstr_v2,hdrtr_v1,hdrtr_v2 @@ -170,7 +170,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis character(8) c_prvstg,c_sprvstg character(8) c_station_id,stationid - integer(i_kind) mxtb,nmsgmax + 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 @@ -192,6 +192,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis integer(i_kind),dimension(5):: idate5 integer(i_kind),allocatable,dimension(:):: nrep,isort,iloc integer(i_kind),allocatable,dimension(:,:):: tab + integer(i_kind) :: icnt(1000) integer(i_kind) ntime,itime @@ -263,6 +264,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis wjbmax=5.0_r_kind pflag=0 var_jb=zero + icnt=0 ! allocate(etabl(302,33,6)) ! add 2 ObsErr profiles for GOES-R IR(itype=301) and WV(itype=300) (not used yet, 2015-07-08, Genkova) @@ -276,8 +278,8 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ntx(ntread)=0 ntxall=0 do nc=1,nconvtype - if( (trim(ioctype(nc)) == 'uv' .or. trim(ioctype(nc)) == 'wspd10m' .or. trim(ioctype(nc)) == 'uwnd10m' .or. trim(ioctype(nc)) == 'vwnd10m') .and. ictype(nc) >=240 & - .and. ictype(nc) <=265) then + if((trim(ioctype(nc)) == 'uv' .or. trim(ioctype(nc)) == 'wspd10m' .or. trim(ioctype(nc)) == 'uwnd10m' .or. & + trim(ioctype(nc)) == 'vwnd10m') .and. ictype(nc) >=240 .and. ictype(nc) <=265) then ntmatch=ntmatch+1 ntxall(ntmatch)=nc ithin=ithin_conv(nc) @@ -287,6 +289,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis end if end if end do + if(ntmatch == 0)then write(6,*) ' READ_SATWND: no matching obstype found in obsinfo ',obstype return @@ -299,7 +302,6 @@ 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)) - lmsg = .false. maxobs=0 @@ -338,6 +340,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis iobsub=0 itype=-1 iobsub=int(hdrdat(1)) + if(trim(subset) == 'NC005064' .or. trim(subset) == 'NC005065' .or. & trim(subset) == 'NC005066') then if( hdrdat(1) = r50) then !the range of EUMETSAT satellite IDS @@ -351,6 +354,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis itype=254 endif endif + 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 EUMETSAT satellite IDS @@ -364,6 +368,21 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis itype=254 endif endif + + else if(trim(subset) == 'NC005041' .or. trim(subset) == 'NC005042' .or. & + trim(subset) == 'NC005043') then + if( hdrdat(1) >=r100 .and. hdrdat(1) <=r199 ) then ! the range of JMA satellite IDS + if(hdrdat(9) == one) then ! IR winds + itype=252 + else if(hdrdat(9) == two) then ! visible winds + itype=242 + else if(hdrdat(9) == three) then ! WV cloud top + itype=250 + else if(hdrdat(9) >= four) then ! WV deep layer,monitored + itype=250 + endif + endif + else if(trim(subset) == 'NC005044' .or. trim(subset) == 'NC005045' .or. & trim(subset) == 'NC005046') then if( hdrdat(1) >=r100 .and. hdrdat(1) <=r199 ) then ! the range of JMA satellite IDS @@ -377,6 +396,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis itype=250 endif endif + else if(trim(subset) == 'NC005047' .or. trim(subset) == 'NC005048' .or.& trim(subset) == 'NC005049') then ! read new Him-8 BURF if( hdrdat(1) >=r100 .and. hdrdat(1) <=r199 ) then ! the range of JMA satellite IDS @@ -390,6 +410,25 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis itype=250 endif endif + + else if(trim(subset) == 'NC005001' .or. trim(subset) == 'NC005002' .or. & + trim(subset) == 'NC005003' ) then + if( hdrdat(1) >=r250 .and. hdrdat(1) <=r299 ) then ! the range of NESDIS satellite IDS + if(hdrdat(9) == one) then ! IR winds + if(hdrdat(12) <50000000000000.0_r_kind) then + itype=245 + else + itype=240 ! short wave IR winds + endif + else if(hdrdat(9) == two ) then ! visible winds + itype=251 + else if(hdrdat(9) == three ) then ! WV cloud top + itype=246 + else if(hdrdat(9) >= four ) then ! WV deep layer,monitored + itype=247 + endif + endif + else if(trim(subset) == 'NC005010' .or. trim(subset) == 'NC005011' .or. & trim(subset) == 'NC005012' ) then if( hdrdat(1) >=r250 .and. hdrdat(1) <=r299 ) then ! the range of NESDIS satellite IDS @@ -407,6 +446,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis itype=247 endif endif + else if(trim(subset) == 'NC005070' .or. trim(subset) == 'NC005071' ) 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 @@ -434,6 +474,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis write(6,*) 'READ_SATWND: wrong derived method value' endif 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 if(hdrdat(9) == one) then ! short wave IR winds @@ -546,6 +587,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis enddo msg_report + allocate(cdata_all(nreal,maxobs),isort(maxobs),rusage(maxobs)) isort = 0 cdata_all=zero @@ -557,10 +599,9 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ilat=3 rusage=101.0_r_kind -! Open, then read date from bufr data -!! read satellite winds one type a time - loop_convinfo: do nx=1,ntread + + ! set parameters for processing the next satwind type use_all = .true. use_all_tm = .true. ithin=0 @@ -602,8 +643,8 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis endif endif + ! Open and read the file once for each satwnd type call closbf(lunin) - close(lunin) open(lunin,file=trim(infile),form='unformatted') call openbf(lunin,'IN',lunin) call datelen(10) @@ -626,7 +667,6 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis derdwdat=bmiss qcdat=bmiss iobsub=0 - itype=-1 uob=bmiss vob=bmiss ppb=bmiss @@ -637,8 +677,9 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ee=r110 qifn=r110 qify=r110 + qm=2 -! Test for BUFR version using lat/lon mnemonics + ! test for BUFR version using lat/lon mnemonics call ufbint(lunin,hdrdat_test,2,1,iret, 'CLAT CLON') if ( hdrdat_test(1) > 100000000.0_r_kind .and. hdrdat_test(2) > 100000000.0_r_kind ) then call ufbint(lunin,hdrdat,13,1,iret,hdrtr_v2) @@ -648,18 +689,19 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis call ufbint(lunin,obsdat,4,1,iret,obstr_v1) endif + ! reject data with missing pressure or wind ppb=obsdat(2) - if (ppb > 100000000.0_r_kind .or. & - hdrdat(3) >100000000.0_r_kind .or. & - obsdat(4) > 100000000.0_r_kind) cycle loop_readsb - if(ppb >r10000) ppb=ppb/r100 + 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 r90 ) cycle loop_readsb if( hdrdat(3) =240.and.itype<=279) icnt(itype)=icnt(itype)+1 + + ! test for QCSTR or MANDATORY QC - if not skip over the extra blocks + call ufbrep(lunin,qcdat,3,12,qcret,qcstr) + do_qc = subset(1:7)=='NC00503'.and.nint(hdrdat(1))>=270 + do_qc = do_qc.or.subset(1:7)=='NC00501' + do_qc = do_qc.or.subset=='NC005081'.or.subset=='NC005091' + do_qc = do_qc.or.qcret>0 + + ! assign types and get quality info: start + + 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' @@ -1034,7 +1090,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis endif ! get quality information THIS SECTION NEEDS TO BE TESTED!!! call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}') - irep_array = int(rep_array) + 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 @@ -1238,10 +1294,10 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis cycle loop_readsb endif - if ( itype == -1 ) cycle loop_readsb ! unassigned itype - ! 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 @@ -1590,6 +1646,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis cdata_all(28,iout)=ran01dom()*perturb_fact ! v perturbation endif + enddo loop_readsb ! End of bufr read loop enddo loop_msg @@ -1609,7 +1666,6 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis 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)) diff --git a/src/gsi/read_ssmi.f90 b/src/gsi/read_ssmi.f90 index 3e47ee79b5..cece78ac03 100755 --- a/src/gsi/read_ssmi.f90 +++ b/src/gsi/read_ssmi.f90 @@ -132,7 +132,8 @@ subroutine read_ssmi(mype,val_ssmi,ithin,rmesh,jsatid,gstime,& real(r_kind),parameter:: tbmin=70.0_r_kind real(r_kind),parameter:: tbmax=320.0_r_kind character(80),parameter:: hdr1b='SAID YEAR MNTH DAYS HOUR MINU SECO ORBN' !use for ufbint() - character(40),parameter:: str1='CLAT CLON SFTG POSN SAZA' !use for ufbint() + character(40),parameter:: str1='CLATH CLONH SFTG POSN SAZA' !use for ufbint() new + character(40),parameter:: strx='CLAT CLON SFTG POSN SAZA' !use for ufbint() old character(40),parameter:: str2='TMBR' !use for ufbrep() ! Declare local variables @@ -302,6 +303,7 @@ subroutine read_ssmi(mype,val_ssmi,ithin,rmesh,jsatid,gstime,& ! SSM/I data are stored in groups of nscan, hence the loop. call ufbint(lnbufr,midat,nloc,nscan,iret,str1) + if(midat(1,1)>10e8) call ufbint(lnbufr,midat,nloc,nscan,iret,strx) !--- Extract brightness temperature data. Apply gross check to data. @@ -309,7 +311,6 @@ subroutine read_ssmi(mype,val_ssmi,ithin,rmesh,jsatid,gstime,& call ufbrep(lnbufr,mirad,1,nchanl*nscan,iret,str2) - ij=0 scan_loop: do js=1,nscan @@ -511,7 +512,6 @@ subroutine read_ssmi(mype,val_ssmi,ithin,rmesh,jsatid,gstime,& end do read_loop end do read_subset call closbf(lnbufr) - close(lnbufr) ! If multiple tasks read input bufr file, allow each tasks to write out ! information it retained and then let single task merge files together diff --git a/src/gsi/setupoz.f90 b/src/gsi/setupoz.f90 index 24381df447..2008f37559 100644 --- a/src/gsi/setupoz.f90 +++ b/src/gsi/setupoz.f90 @@ -83,6 +83,9 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& ! 2017-02-09 guo - Remove m_alloc, n_alloc. ! . Remove my_node with corrected typecast(). ! 2017-10-27 todling - revised netcdf output for lay case; obs-sens needs attention +! 2020-02-26 todling - reset obsbin from hr to min +! 2022-08-10 karpowicz - fixes to ncdiag air_pressure_levels, change mass output to +! ppmv/mole fraction, fix ompsnm scan positoin and solar zenith angle. ! ! input argument list: ! lunin - unit from which to read observations @@ -110,10 +113,10 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& use mpeu_util, only: die,perr,getindex use kinds, only: r_kind,r_single,i_kind - use state_vectors, only: svars3d, levels + use state_vectors, only: svars3d, levels, nsdim use constants, only : zero,half,one,two,tiny_r_kind - use constants, only : rozcon,cg_term,wgtlim,h300,r10 + use constants, only : constoz,rozcon,cg_term,wgtlim,h300,r10,r100,r1000 use m_obsdiagNode, only : obs_diag use m_obsdiagNode, only : obs_diags @@ -131,6 +134,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& use m_obsLList, only : obsLList use obsmod, only : nloz_omi use obsmod, only : luse_obsdiag +! use obsmod, only : wrtgeovals use obsmod, only: netcdf_diag, binary_diag, dirname use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & @@ -155,8 +159,8 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& implicit none ! !INPUT PARAMETERS: - type(obsLList ),target,dimension(:),intent(in):: obsLL - type(obs_diags),target,dimension(:),intent(in):: odiagLL + type(obsLList ),target,dimension(:),intent(inout):: obsLL + type(obs_diags),target,dimension(:),intent(inout):: odiagLL integer(i_kind) , intent(in ) :: lunin ! unit from which to read observations integer(i_kind) , intent(in ) :: mype ! mpi task id @@ -191,9 +195,9 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& ! Declare local variables - real(r_kind) omg,rat_err2,dlat,dtime,dlon,rat_err4diag + real(r_kind) omg,rat_err2,dlat,dtime,dlon real(r_kind) cg_oz,wgross,wnotgross,wgt,arg,exp_arg,term - real(r_kind) psi,errorinv + real(r_kind) psi,errorinv,rat_err4diag real(r_kind),dimension(nlevs):: ozges,varinv3,ozone_inv,ozobs,varinv4diag real(r_kind),dimension(nlevs):: ratio_errors,error real(r_kind),dimension(nlevs-1):: ozp @@ -201,6 +205,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& real(r_kind),dimension(nlevs):: pobs,gross,tnoise real(r_kind),dimension(nreal+nlevs,nobs):: data real(r_kind),dimension(nsig+1)::prsitmp + real(r_kind),dimension(nsig)::ozgestmp real(r_single),dimension(nlevs):: pob4,grs4,err4 real(r_single),dimension(ireal,nobs):: diagbuf real(r_single),allocatable,dimension(:,:,:)::rdiagbuf @@ -212,9 +217,10 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& real(r_kind),dimension(nsig,nloz_omi+1):: doz_dz1 integer(i_kind) :: oz_ind, nind, nnz type(sparr2) :: dhx_dx + real(r_single), dimension(nsdim) :: dhx_dx_array integer(i_kind) i,nlev,ii,jj,iextra,ibin, kk, nperobs - integer(i_kind) k,j,nz,jc,idia,irdim1,istatus,ioff0 + integer(i_kind) k1,k2,k,j,nz,jc,idia,irdim1,istatus,ioff0,ioff1 integer(i_kind) ioff,itoss,ikeep,ierror_toq,ierror_poq integer(i_kind) isolz,ifovn,itoqf integer(i_kind) mm1,itime,ilat,ilon,ilate,ilone,itoq,ipoq @@ -280,7 +286,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& iouse(jc)=iuse_oz(j) tnoise(jc)=error_oz(j) gross(jc)=min(r10*gross_oz(j),h300) - if (obstype == 'sbuv2' .or. obstype == 'ompsnp') then + if (obstype == 'sbuv2' .or. obstype == 'ompsnp' .or. obstype == 'ompsnpnc') then pobs(jc)=pob_oz(j) * 1.01325_r_kind else pobs(jc)=pob_oz(j) @@ -319,6 +325,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& irdim1=7 ioff0=irdim1 if(lobsdiagsave) irdim1=irdim1+4*miter+1 + ioff1=irdim1 if (save_jacobian) then nnz = nsig ! number of non-zero elements in dH(x)/dx profile nind = 1 @@ -363,7 +370,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& dlon=data(ilon,i) dtime=data(itime,i) - if (obstype == 'sbuv2' .or. obstype == 'ompsnp') then + if (obstype == 'sbuv2' .or. obstype == 'ompsnp' .or. obstype == 'ompsnpnc') then if (nobskeep>0) then ! write(6,*)'setupozlay: nobskeep',nobskeep call stop2(259) @@ -388,7 +395,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& enddo end if - if (obstype == 'omieff' .or. obstype == 'tomseff') then + if (obstype == 'omieff' .or. obstype == 'tomseff' .or. obstype == 'ompsnmeff') then pob_oz_omi(nloz_omi) = 1000.0_r_kind* 1.01325_r_kind do j=nloz_omi-1, 1, -1 pob_oz_omi(j) = pob_oz_omi(j+1)/2.0 @@ -410,7 +417,16 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& call grdcrd1(ozp_omi(nloz_omi),prsitmp,nsig+1,-1) end if - if (obstype /= 'omieff' .and. obstype /= 'tomseff') then + call tintrp2a1(ges_oz,ozgestmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + + ! need call to get pressures for pressure level output in ncdiags + call tintrp2a1(ges_prsi,prsitmp,dlat,dlon,dtime,hrdifsig,& + nsig+1,mype,nfldsig) + + + if (obstype /= 'omieff' .and. obstype /= 'tomseff' .and. & + obstype /= 'ompsnmeff' ) then call intrp3oz1(ges_oz,ozges,dlat,dlon,ozp,dtime,& nlevs,mype,doz_dz) endif @@ -441,7 +457,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& ! For OMI/GOME, nlev=1 do k=1,nlev j=ipos(k) - if (obstype == 'omieff' .or. obstype == 'tomseff' ) then + if (obstype == 'omieff' .or. obstype == 'tomseff' .or. obstype == 'ompsnmeff') then ioff=ifovn+1 ! else ioff=nreal+k ! SBUV and OMI w/o efficiency factors @@ -449,7 +465,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& ! Compute innovation and load obs error into local array ! KW OMI and TOMS have averaging kernels - if (obstype == 'omieff' .or. obstype == 'tomseff' ) then + if (obstype == 'omieff' .or. obstype == 'tomseff' .or. obstype == 'ompsnmeff') then ! everything in data is from top to bottom nlayers = nloz_omi + 1 apriori(1:nloz_omi) = data(ioff:ioff+nloz_omi -1, i) @@ -542,7 +558,8 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& rdiagbuf(3,k,ii) = errorinv ! inverse observation error if (obstype == 'gome' .or. obstype == 'omieff' .or. & obstype == 'omi' .or. obstype == 'tomseff' .or. & - obstype == 'ompstc8') then + obstype == 'ompsnmeff' .or. obstype == 'ompstc8' .or. & + obstype == 'ompsnm') then rdiagbuf(4,k,ii) = data(isolz,i) ! solar zenith angle rdiagbuf(5,k,ii) = data(ifovn,i) ! field of view number else @@ -556,7 +573,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& endif rdiagbuf(7,k,ii) = 1.e+10_r_single ! spread (filled in by EnKF) - idia = ioff0 + idia = ioff1 if (save_jacobian) then oz_ind = getindex(svars3d, 'oz') if (oz_ind < 0) then @@ -574,18 +591,39 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& endif if (netcdf_diag) then + k1 = k + k2 = k - 1 + if(k2 == 0)k2 = 1 + if(k == nlevs)then + k1=nlevs-1 + k2=1 + endif + if (obstype == 'sbuv2' .or. obstype == 'ompsnp' .or. obstype == 'ompsnpnc' ) then + call nc_diag_metadata("TopLevelPressure",sngl(pobs(k2)*r100)) + call nc_diag_metadata("BottomLevelPressure", & + sngl(pobs(k1)*r100)) + else + call & + nc_diag_metadata("TopLevelPressure",sngl(prsitmp(nsig+1)*r1000) ) + call nc_diag_metadata("BottomLevelPressure", & + sngl(prsitmp(1)*r1000) ) + endif call nc_diag_metadata("MPI_Task_Number", mype ) call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) call nc_diag_metadata("Time", sngl(data(itime,i)-time_offset) ) - call nc_diag_metadata("Reference_Pressure", sngl(pobs(k)) ) + call nc_diag_metadata("Reference_Pressure",sngl(pobs(k)*r100) ) call nc_diag_metadata("Analysis_Use_Flag", iouse(k) ) call nc_diag_metadata("Observation", sngl(ozobs(k))) call nc_diag_metadata("Inverse_Observation_Error", sngl(errorinv)) + call nc_diag_metadata("Input_Observation_Error", sngl(error(k))) call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ozone_inv(k))) call nc_diag_metadata("Obs_Minus_Forecast_unadjusted",sngl(ozone_inv(k))) + call nc_diag_metadata("Forecast_unadjusted", sngl(ozges(k))) + call nc_diag_metadata("Forecast_adjusted",sngl(ozges(k))) if (obstype == 'gome' .or. obstype == 'omieff' .or. & - obstype == 'omi' .or. obstype == 'tomseff' ) then + obstype == 'omi' .or. obstype == 'tomseff' .or. & + obstype == 'ompsnmeff' .or. obstype == 'ompsnm') then call nc_diag_metadata("Solar_Zenith_Angle", sngl(data(isolz,i)) ) call nc_diag_metadata("Scan_Position", sngl(data(ifovn,i)) ) else @@ -598,10 +636,13 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& call nc_diag_metadata("Row_Anomaly_Index", sngl(rmiss) ) endif if (save_jacobian) then - call nc_diag_data2d("Observation_Operator_Jacobian_stind", dhx_dx%st_ind) - call nc_diag_data2d("Observation_Operator_Jacobian_endind", dhx_dx%end_ind) - call nc_diag_data2d("Observation_Operator_Jacobian_val", real(dhx_dx%val,r_single)) + call fullarray(dhx_dx, dhx_dx_array) + call nc_diag_data2d("Observation_Operator_Jacobian", dhx_dx_array) endif + !if (wrtgeovals) then + ! call nc_diag_data2d("mole_fraction_of_ozone_in_air", sngl(constoz*ozgestmp)) + ! call nc_diag_data2d("air_pressure_levels",sngl(prsitmp*r1000)) + !endif endif endif @@ -642,7 +683,8 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& my_head%elon= data(ilone,i) nlevp=max(nlev-1,1) - if (obstype == 'omieff' .or. obstype == 'tomseff' ) nlevp = nloz_omi + if (obstype == 'omieff' .or. obstype == 'tomseff' .or. & + obstype == 'ompsnmeff') nlevp = nloz_omi allocate(my_head%res(nlev), & my_head%err2(nlev), & my_head%raterr2(nlev), & @@ -679,11 +721,12 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& my_head%luse=luse(i) my_head%time=dtime - if (obstype == 'sbuv2'.or. obstype == 'ompsnp' ) then + if (obstype == 'sbuv2' .or. obstype == 'ompsnp' .or. obstype == 'ompsnpnc') then do k=1,nlevs-1 my_head%prs(k) = ozp(k) enddo - else if (obstype == 'omieff' .or. obstype == 'tomseff') then + else if (obstype == 'omieff' .or. obstype == 'tomseff' .or. & + obstype == 'ompsnmeff') then do k=1,nloz_omi my_head%prs(k) = ozp_omi(k) enddo @@ -742,7 +785,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& if (ozone_diagsave.and.lobsdiagsave.and.luse(i)) then associate(odiag => my_diag) - idia=6 + idia=ioff0 do jj=1,miter idia=idia+1 if (odiag%muse(jj)) then @@ -785,7 +828,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& if(in_curbin) then if (ozone_diagsave.and.lobsdiagsave.and.luse(i)) then - rdiagbuf(7:irdim1,1:nlevs,ii) = zero + rdiagbuf(ioff0+1:irdim1,1:nlevs,ii) = zero endif endif ! (in_curbin) @@ -932,6 +975,7 @@ subroutine init_netcdf_diag_ call nc_diag_header("Satellite_Sensor", isis) call nc_diag_header("Satellite", dplat(is)) call nc_diag_header("Observation_type", obstype) + call nc_diag_header("Number_of_state_vars", nsdim ) call nc_diag_header("pobs", pobs) call nc_diag_header("gross",gross) call nc_diag_header("tnoise",tnoise) @@ -995,7 +1039,9 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& ! 2016-12-09 mccarty - add netcdf_diag capability ! 2017-02-09 guo - Remove m_alloc, n_alloc. ! . Remove my_node with corrected typecast(). -! +! 2020-02-26 todling - reset obsbin from hr to min +! 2022-08-10 karpowicz/todling - replace ncdiag analysis use flag with +/-1 instead of zero +! ! input argument list: ! lunin - unit from which to read observations ! mype - mpi task id @@ -1036,6 +1082,7 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& use obsmod, only : mype_diaghdr,dirname,time_offset,ianldate use obsmod, only : lobsdiag_allocated,lobsdiagsave,lobsdiag_forenkf use obsmod, only: netcdf_diag, binary_diag, dirname +! use obsmod, only: wrtgeovals use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & nc_diag_write, nc_diag_data2d use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close @@ -1048,7 +1095,7 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& use guess_grids, only : nfldsig,ges_lnprsl,hrdifsig use constants, only : zero,half,one,two,tiny_r_kind,four - use constants, only : cg_term,wgtlim,r10,constoz + use constants, only : cg_term,wgtlim,r10,r100,r1000,constoz use gsi_4dvar, only: nobs_bins,hr_obsbin @@ -1066,8 +1113,8 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& implicit none ! !INPUT PARAMETERS: - type(obsLList ),target,dimension(:),intent(in):: obsLL - type(obs_diags),target,dimension(:),intent(in):: odiagLL + type(obsLList ),target,dimension(:),intent(inout):: obsLL + type(obs_diags),target,dimension(:),intent(inout):: odiagLL integer(i_kind) , intent(in ) :: lunin ! unit from which to read observations integer(i_kind) , intent(in ) :: mype ! mpi task id @@ -1106,26 +1153,30 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& real(r_kind) o3ges, o3ppmv real(r_kind) rlow,rhgh,sfcchk - real(r_kind) omg,rat_err2,dlat,dtime,dlon,rat_err4diag + real(r_kind) omg,rat_err2,dlat,dtime,dlon real(r_kind) cg_oz,wgross,wnotgross,wgt,arg,exp_arg,term real(r_kind) errorinv - real(r_kind) psges,ozlv,airnd,uvnd,visnd + real(r_kind) psges,ozlv, airnd, uvnd, visnd - real(r_kind) varinv3,ratio_errors,varinv4diag + real(r_kind) varinv3,ratio_errors + real(r_kind) varinv4diag,rat_err4diag real(r_kind) dpres,obserror,ozone_inv,preso3l real(r_kind),dimension(nreal+nlevs,nobs):: data 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 - integer(i_kind) k,j,idia,irdim1,ioff0 + integer(i_kind) k1,k2,k,j,idia,irdim1,ioff0,ioff1 integer(i_kind) isolz,iuse integer(i_kind) mm1,itime,ilat,ilon,ilate,ilone,iozmr,ilev,ipres,iprcs,imls_levs + integer(i_kind) iairnd, iuvnd, ivisnd integer(i_kind),dimension(iint,nobs):: idiagbuf - integer(i_kind) iairnd,iuvnd,ivisnd real(r_kind) gross,tnoise,pobs + character(12) string character(10) filex character(128) diag_ozone_file @@ -1178,6 +1229,7 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& irdim1=10 ioff0 = irdim1 if(lobsdiagsave) irdim1=irdim1+4*miter+1 + ioff1 = irdim1 if (save_jacobian) then nnz = 2 ! number of non-zero elements in dH(x)/dx profile nind = 1 @@ -1315,6 +1367,9 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& obserror=1.0e6_r_kind end if + call tintrp2a1(ges_oz,ozgestmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + ! Interpolate guess ozone to observation location and time call tintrp31(ges_oz,o3ges,dlat,dlon,dpres,dtime, & hrdifsig,mype,nfldsig) @@ -1627,7 +1682,7 @@ subroutine contents_binary_diag_(odiag) rdiagbuf(10,1,ii) = visnd ! log10 ozone number density vis if (lobsdiagsave) then - idia=6 + idia=ioff0 do jj=1,miter idia=idia+1 if (odiag%muse(jj)) then @@ -1649,6 +1704,7 @@ subroutine contents_binary_diag_(odiag) rdiagbuf(idia,1,ii) = odiag%obssen(jj) enddo endif + idia = ioff1 if (save_jacobian) then call writearray(dhx_dx, rdiagbuf(idia+1:irdim1,1,ii)) idia = idia + size(dhx_dx) @@ -1668,19 +1724,33 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Observation", sngl(ozlv) ) call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ozone_inv) ) call nc_diag_metadata("Obs_Minus_Forecast_unadjusted",sngl(ozone_inv) ) - call nc_diag_metadata("Reference_Pressure", sngl(preso3l) ) + call nc_diag_metadata("Reference_Pressure", sngl(preso3l*r100) ) ! Pa + if(luse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", one ) + else + call nc_diag_metadata("Analysis_Use_Flag", -one ) + endif call nc_diag_metadata("Input_Observation_Error", sngl(obserror) ) - if(obstype =="omps_lp")then + if(obstype =="ompslp")then call nc_diag_metadata("Log10 Air Number Density", sngl(airnd)) - call nc_diag_metadata("Log10 Ozone Number Density UV", sngl(uvnd)) + call nc_diag_metadata("Log10 Ozone Number Density UV", sngl(uvnd)) call nc_diag_metadata("Log10 Ozone Number Density VIS",sngl(visnd)) endif - - if(luse(i)) then - call nc_diag_metadata("Analysis_Use_Flag", 1 ) - else - call nc_diag_metadata("Analysis_Use_Flag", -1 ) + call nc_diag_metadata("Forecast_adjusted", sngl(o3ppmv)) + call nc_diag_metadata("Forecast_unadjusted", sngl(o3ppmv)) + !if (wrtgeovals) then + ! ozgestmp = ozgestmp *constoz + ! call nc_diag_data2d("mole_fraction_of_ozone_in_air", sngl(ozgestmp)) + ! call nc_diag_data2d("air_pressure",sngl(exp(prsltmp)*r1000)) ! Pa + !endif + k1 = k + k2 = k - 1 + if(k2 == 0)k2 = 1 + if(k == nlevs)then + k1=nlevs-1 + k2=1 endif + if (save_jacobian) then call nc_diag_data2d("Observation_Operator_Jacobian_stind", dhx_dx%st_ind) call nc_diag_data2d("Observation_Operator_Jacobian_endind", dhx_dx%end_ind) From be4a3d91c92731d3611c46737ca695ce05cb9527 Mon Sep 17 00:00:00 2001 From: jderber-NOAA <75998838+jderber-NOAA@users.noreply.github.com> Date: Fri, 1 Sep 2023 12:34:05 -0400 Subject: [PATCH 022/109] Error in processing VAD winds. (#617) --- src/gsi/constants.f90 | 2 + src/gsi/gsi_rfv3io_mod.f90 | 16 ++-- src/gsi/read_prepbufr.f90 | 158 +++++++++++++++++++------------------ src/gsi/setupw.f90 | 6 -- 4 files changed, 91 insertions(+), 91 deletions(-) diff --git a/src/gsi/constants.f90 b/src/gsi/constants.f90 index b4cf775068..291a18ec97 100644 --- a/src/gsi/constants.f90 +++ b/src/gsi/constants.f90 @@ -74,6 +74,7 @@ module constants public :: psv_a, psv_b, psv_c, psv_d public :: ef_alpha, ef_beta, ef_gamma public :: max_varname_length + public :: max_filename_length public :: z_w_max,tfrozen public :: qmin,qcmin,tgmin public :: i_missing, r_missing @@ -91,6 +92,7 @@ module constants ! Declare derived constants integer(i_kind):: huge_i_kind integer(i_kind), parameter :: max_varname_length=20 + integer(i_kind), parameter :: max_filename_length=80 real(r_single):: tiny_single, huge_single real(r_kind):: xai, xa, xbi, xb, dldt, rozcon,ozcon,fv, tpwcon,eps, rd_over_g real(r_kind):: el2orc, g_over_rd, rd_over_cp, cpr, omeps, epsm1, factor2 diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 4fcb2aba1d..05f679cb60 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -48,7 +48,7 @@ module gsi_rfv3io_mod use kinds, only: r_kind,i_kind use gridmod, only: nlon_regional,nlat_regional - use constants, only:max_varname_length + use constants, only:max_varname_length,max_filename_length use gsi_bundlemod, only : gsi_bundle use general_sub2grid_mod, only: sub2grid_info use gridmod, only: fv3_io_layout_y @@ -2207,7 +2207,7 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) 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 character(len=max_varname_length) :: name - character(len=max_varname_length) :: filenamein2 + character(len=max_filename_length) :: filenamein2 real(r_kind),allocatable,dimension(:,:):: uu2d_tmp integer(i_kind) :: countloc_tmp(3),startloc_tmp(3) @@ -2381,7 +2381,7 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,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_varname_length) :: filenamein2 + character(len=max_filename_length) :: filenamein2 character(len=max_varname_length) :: varname,vgsiname @@ -2482,7 +2482,7 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) character(:), allocatable:: filenamein real(r_kind),allocatable,dimension(:,:):: u2d,v2d real(r_kind),allocatable,dimension(:,:):: uc2d,vc2d - character(len=max_varname_length) :: filenamein2 + character(len=max_filename_length) :: filenamein2 character(len=max_varname_length) :: varname,vgsiname real(r_kind),allocatable,dimension(:,:,:,:):: worksub integer(i_kind) u_grd_VarId,v_grd_VarId @@ -2658,7 +2658,7 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin) real(r_kind),allocatable,dimension(:,:):: us2d,vw2d real(r_kind),allocatable,dimension(:,:):: uorv2d real(r_kind),allocatable,dimension(:,:,:,:):: worksub - character(len=max_varname_length) :: filenamein2 + character(len=max_filename_length) :: filenamein2 character(len=max_varname_length) :: varname integer(i_kind) nlatcase,nloncase integer(i_kind) kbgn,kend @@ -2778,7 +2778,7 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & real(r_kind),dimension(nlat,nlon,nsig),intent(out),optional:: delp,tsen,w,q,oz,ql,qr,qs,qi,qg,dbz character(len=max_varname_length) :: varname character(len=max_varname_length) :: name - character(len=max_varname_length), allocatable,dimension(:) :: varname_files + character(len=max_filename_length), allocatable,dimension(:) :: varname_files integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(3),startloc(3),countloc_tmp(3),startloc_tmp(3) integer(i_kind) ilev,ilevtot,inative,ivar @@ -4097,7 +4097,7 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file 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_varname_length) :: filenamein2 + character(len=max_filename_length) :: filenamein2 character(len=max_varname_length) :: varname,vgsiname,name integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(3),startloc(3) @@ -4321,7 +4321,7 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f 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_varname_length) :: filenamein2 + character(len=max_filename_length) :: filenamein2 integer(i_kind) kbgn,kend integer(i_kind) inative,ilev,ilevtot diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index 355441e209..2bf3a7d05d 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -2003,6 +2003,85 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! don't use MESONET psfc obs if 8th character of station id is "x") if( kx==188 .and. psob .and. sidchr(8)=='x' ) usage=r100 +! Set inflate_error logical based on qm flag + inflate_error=.false. + if (qm==3 .or. qm==7) inflate_error=.true. + + if(uvob) then + selev=stnelev + oelev=obsdat(4,k) + if(kx >= 280 .and. kx < 300 )then + if (twodvar_regional.and.(kx==288.or.kx==295)) then + oelev=windsensht+selev !windsensht: read in from prepbufr + else + oelev=r10+selev + endif + if (kx == 280 )then + it29=nint(hdr(8)) + if(it29 == 522 .or. it29 == 523 .or. it29 == 531)then +! oelev=r20+selev + oelev=r20 + end if + end if + + if (kx == 282) oelev=r20+selev + if (kx == 285 .or. kx == 289 .or. kx == 290) then + oelev=selev + selev=zero + endif + else + if((kx >= 221 .and. kx <= 229) & + .and. selev >= oelev) oelev=r10+selev + end if + +! Rotate winds to rotated coordinate + uob=obsdat(5,k) + vob=obsdat(6,k) + !* thin new VAD wind and generate VAD superob + if(kx==224.and.newvad)then + klev=k+5 !*average over 6 points + ! klev=k !* no average + if(klev>levs) cycle loop_readsb + diffuu=obsdat(5,k)-fcstdat(1,k) + diffvv=obsdat(6,k)-fcstdat(2,k) + if(sqrt(diffuu**2+diffvv**2)>10.0_r_kind) cycle loop_k_levs + if(abs(diffvv)>8.0_r_kind) cycle loop_k_levs + !if(abs(diffvv)>5.0.and.oelev<5000.0.and.fcstdat(3,k)>276.3) cycle loop_k_levs + if(oelev>7000.0_r_kind) cycle loop_k_levs + if(abs(diffvv)>5.0_r_kind.and.oelev<5000.0_r_kind) cycle loop_k_levs + ! write(6,*)'sliu diffuu,vv::',diffuu, diffvv + uob=0.0 + vob=0.0 + oelev=0.0 + tkk=0 + do ikkk=k,klev + diffhgt=obsdat(4,ikkk)-obsdat(4,k) + if(diffhgt<301.0_r_kind)then + uob=uob+obsdat(5,ikkk) + vob=vob+obsdat(6,ikkk) + oelev=oelev+obsdat(4,ikkk) + tkk=tkk+1 + end if + end do + uob=uob/tkk + vob=vob/tkk + oelev=oelev/tkk + + diffuu=5.0_r_kind;diffvv=5.0_r_kind + diffhgt=0.0_r_kind + do ikkk=k,klev + diffuu=abs(obsdat(5,ikkk)-uob) + if(diffhgt5.0_r_kind)cycle LOOP_K_LEVS !* if u-u_avg>5.0, reject + if(tkk<3) cycle LOOP_K_LEVS !* obs numb<3, reject + !* unreasonable observation, will fix this in QC package + if(sqrt(uob**2+vob**2)>60.0_r_kind)cycle LOOP_readsb + end if + end if ! Get information from surface file necessary for conventional data here @@ -2088,9 +2167,6 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! Extract pressure level and quality marks dlnpob=log(plevs(k)) ! ln(pressure in cb) -! Set inflate_error logical based on qm flag - inflate_error=.false. - if (qm==3 .or. qm==7) inflate_error=.true. ! Temperature if(tob) then @@ -2143,6 +2219,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! Winds else if(uvob) then + if (aircraftobs .and. aircraft_t_bc .and. acft_profl_file) then call errormod_aircraft(pqm,wqm,levs,plevs,errout,k,presl,dpres,nsig,lim_qm,hdr3) else @@ -2151,80 +2228,6 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& woe=obserr(5,k)*errout if (inflate_error) woe=woe*r1_2 if(obsdat(1,k) < r50)woe=woe*r1_2 - selev=stnelev - oelev=obsdat(4,k) - if(kx >= 280 .and. kx < 300 )then - if (twodvar_regional.and.(kx==288.or.kx==295)) then - oelev=windsensht+selev !windsensht: read in from prepbufr - else - oelev=r10+selev - endif - if (kx == 280 )then - it29=nint(hdr(8)) - if(it29 == 522 .or. it29 == 523 .or. it29 == 531)then -! oelev=r20+selev - oelev=r20 - end if - end if - - if (kx == 282) oelev=r20+selev - if (kx == 285 .or. kx == 289 .or. kx == 290) then - oelev=selev - selev=zero - endif - else - if((kx >= 221 .and. kx <= 229) & - .and. selev >= oelev) oelev=r10+selev - end if - -! Rotate winds to rotated coordinate - uob=obsdat(5,k) - vob=obsdat(6,k) - !* thin new VAD wind and generate VAD superob - if(kx==224.and.newvad)then - klev=k+5 !*average over 6 points - ! klev=k !* no average - if(klev>levs) cycle loop_readsb - diffuu=obsdat(5,k)-fcstdat(1,k) - diffvv=obsdat(6,k)-fcstdat(2,k) - if(sqrt(diffuu**2+diffvv**2)>10.0_r_kind) cycle loop_k_levs - if(abs(diffvv)>8.0_r_kind) cycle loop_k_levs - !if(abs(diffvv)>5.0.and.oelev<5000.0.and.fcstdat(3,k)>276.3) cycle loop_k_levs - if(oelev>7000.0_r_kind) cycle loop_k_levs - if(abs(diffvv)>5.0_r_kind.and.oelev<5000.0_r_kind) cycle loop_k_levs - ! write(6,*)'sliu diffuu,vv::',diffuu, diffvv - uob=0.0 - vob=0.0 - oelev=0.0 - tkk=0 - do ikkk=k,klev - diffhgt=obsdat(4,ikkk)-obsdat(4,k) - if(diffhgt<301.0_r_kind)then - uob=uob+obsdat(5,ikkk) - vob=vob+obsdat(6,ikkk) - oelev=oelev+obsdat(4,ikkk) - tkk=tkk+1 - end if - end do - uob=uob/tkk - vob=vob/tkk - oelev=oelev/tkk - - diffuu=5.0_r_kind;diffvv=5.0_r_kind - diffhgt=0.0_r_kind - do ikkk=k,klev - diffuu=abs(obsdat(5,ikkk)-uob) - if(diffhgt5.0_r_kind)cycle LOOP_K_LEVS !* if u-u_avg>5.0, reject - if(tkk<3) cycle LOOP_K_LEVS !* obs numb<3, reject - !* unreasonable observation, will fix this in QC package - if(sqrt(uob**2+vob**2)>60.0_r_kind)cycle LOOP_readsb - end if - if(regional .and. .not. fv3_regional)then u0=uob v0=vob @@ -2237,6 +2240,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& end if endif + cdata_all(1,iout)=woe ! wind error cdata_all(2,iout)=dlon ! grid relative longitude cdata_all(3,iout)=dlat ! grid relative latitude diff --git a/src/gsi/setupw.f90 b/src/gsi/setupw.f90 index 62b58a0485..97ed1f8883 100644 --- a/src/gsi/setupw.f90 +++ b/src/gsi/setupw.f90 @@ -419,14 +419,8 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav if (netcdf_diag) call init_netcdf_diag_ end if - num_bad_ikx=0 do i=1,nobs muse(i)=nint(data(iuse,i)) <= jiter - ikx=nint(data(ikxx,i)) - if(ikx < 1 .or. ikx > nconvtype) then - num_bad_ikx=num_bad_ikx+1 - if(num_bad_ikx<=10) write(6,*)' in setupw ',ikx,i,nconvtype,mype - end if end do ! If HD raobs available move prepbufr version to monitor if(nhduv > 0)then From d7ac706d9f307f8ddfb09c7cc908f6be614b0fae Mon Sep 17 00:00:00 2001 From: daviddowellNOAA <72174157+daviddowellNOAA@users.noreply.github.com> Date: Fri, 8 Sep 2023 10:36:03 -0500 Subject: [PATCH 023/109] Gsi fed (#590) **Description** Initialization of the operational RRFSv1 will include assimilation of flash-extent density (FED) observations from the GOES Geostationary Lightning Mapper (GLM). The current PR is the first of at least 3 that will be needed to introduce the capability of FED assimilation into the code and regional workflow. The new capabilities that are added to GSI are: * reading NetCDF FED observations * applying an observation operator that maps the model state to FED. Much of the code was originally developed by Rong Kong at OU-CAPS (Kong et al. 2020, Wang et al. 2021, Kong et al. 2022; https://doi.org/10.1175/MWR-D-19-0192.1, https://doi.org/10.1175/MWR-D-20-0406.1, https://doi.org/10.1175/MWR-D-21-0326.1). Recently, the observation operator has been modified by Amanda Back and Ashley Sebok based on tests with regional, convection-allowing FV3 forecasts. The new observation operator includes a cap of 8 flashes / minute for both the observed and simulated FED. The observation operator is specific to the 3-km regional FV3 application in RRFS. Development of a more general observation operator is left to future work. Fixes #588 **Type of change** Please delete options that are not relevant. - [ ] Bug fix (non-breaking change which fixes an issue) - [X] New feature (non-breaking change which adds functionality) - [ ] Breaking change (fix or feature that would cause existing functionality to not work as expected) - [ ] This change requires a documentation update **How Has This Been Tested?** Initial tests were with NOAA-EMC GSI-EnKF code obtained in April 2023 and modified to include the assimilation of FED observations. A prototype of RRFSv1 was cycled hourly for 2.5 days, and the EnKF assimilation included FED data assimilation. For the current PR, only the GSI observer with FED (and radar reflectivity) observations was tested. It produces identical results to those obtained in April 2023. **Checklist** - [ ] My code follows the style guidelines of this project - [X] I have performed a self-review of my own code - [ ] I have commented my code, particularly in hard-to-understand areas - [ ] New and existing tests pass with my changes - [ ] Any dependent changes have been merged and published **DUE DATE for this PR is 8/24/2023.** If this PR is not merged into `develop` by this date, the PR will be closed and returned to the developer. --------- Co-authored-by: Ming Hu --- src/gsi/gsi_fedOper.F90 | 174 +++++ src/gsi/gsi_files.cmake | 4 + src/gsi/gsi_obOperTypeManager.F90 | 7 + src/gsi/gsimod.F90 | 7 +- src/gsi/intjo.f90 | 4 +- src/gsi/m_fedNode.F90 | 248 +++++++ src/gsi/m_obsNodeTypeManager.F90 | 7 + src/gsi/m_rhs.F90 | 2 + src/gsi/obsmod.F90 | 15 +- src/gsi/read_fed.f90 | 525 ++++++++++++++ src/gsi/read_obs.F90 | 14 +- src/gsi/setupfed.f90 | 1100 +++++++++++++++++++++++++++++ src/gsi/setuprhsall.f90 | 3 +- src/gsi/statsconv.f90 | 72 +- 14 files changed, 2169 insertions(+), 13 deletions(-) create mode 100644 src/gsi/gsi_fedOper.F90 create mode 100644 src/gsi/m_fedNode.F90 create mode 100644 src/gsi/read_fed.f90 create mode 100644 src/gsi/setupfed.f90 diff --git a/src/gsi/gsi_fedOper.F90 b/src/gsi/gsi_fedOper.F90 new file mode 100644 index 0000000000..b2b2400ff0 --- /dev/null +++ b/src/gsi/gsi_fedOper.F90 @@ -0,0 +1,174 @@ +module gsi_fedOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_fedOper +! +! abstract: an obOper extension for fedNode type +! +! program history log: +! 2023-07-10 D. Dowell - created new module for FED (flash extent +! density); gsi_dbzOper.F90 code used as a +! starting point for developing this new module +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_obOper, only: obOper + use m_fedNode , only: fedNode + implicit none + public:: fedOper ! data structure + public:: diag_fed + + type,extends(obOper):: fedOper + contains + procedure,nopass:: mytype + procedure,nopass:: nodeMold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type fedOper + +! def diag_fed- namelist logical to compute/write (=true) FED diag files + logical,save:: diag_fed=.false. + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_fedOper' + type(fedNode),save,target:: myNodeMold_ + +contains + function mytype(nodetype) + implicit none + character(len=:),allocatable:: mytype + logical,optional, intent(in):: nodetype + mytype="[fedOper]" + if(present(nodetype)) then + if(nodetype) mytype=myNodeMold_%mytype() + endif + end function mytype + + function nodeMold() + !> %nodeMold() returns a mold of its corresponding obsNode + use m_obsNode, only: obsNode + implicit none + class(obsNode),pointer:: nodeMold + nodeMold => myNodeMold_ + end function nodeMold + + subroutine setup_(self, lunin, mype, is, nobs, init_pass, last_pass) + use fed_setup, only: setup + use kinds, only: i_kind + use gsi_obOper, only: len_obstype + use gsi_obOper, only: len_isis + + use m_rhs , only: awork => rhs_awork + use m_rhs , only: bwork => rhs_bwork + use m_rhs , only: iwork => i_fed + + use obsmod , only: write_diag + use jfunc , only: jiter + + use mpeu_util, only: die + + use obsmod, only: dirname, ianldate + + implicit none + class(fedOper ), intent(inout):: self + integer(i_kind), intent(in):: lunin + integer(i_kind), intent(in):: mype + integer(i_kind), intent(in):: is + integer(i_kind), intent(in):: nobs + logical , intent(in):: init_pass ! supporting multi-pass setup() + logical , intent(in):: last_pass ! with incremental backgrounds. + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::setup_" + + character(len=len_obstype):: obstype + character(len=len_isis ):: isis + integer(i_kind):: nreal,nchanl,ier,nele + logical:: diagsave + integer(i_kind):: lu_diag + character(128):: diag_file + character(80):: string + + if(nobs == 0) then + + if( (mype == 0) .and. init_pass ) then + write(string,600) jiter +600 format('fed_',i2.2) + diag_file=trim(dirname) // trim(string) + write(6,*) 'write ianldate to ', diag_file + open(newunit=lu_diag,file=trim(diag_file),form='unformatted',status='unknown',position='rewind') + write(lu_diag) ianldate + close(lu_diag) + endif + + return + + endif + + read(lunin,iostat=ier) obstype,isis,nreal,nchanl + if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) + nele = nreal+nchanl + + diagsave = write_diag(jiter) .and. diag_fed + + call setup(self%obsLL(:), self%odiagLL(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave,init_pass) + + end subroutine setup_ + + subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use gsi_bundlemod , only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds , only: i_kind, r_quad + implicit none + class(fedOper ),intent(in ):: self + integer(i_kind ),intent(in ):: ibin + type(gsi_bundle),intent(inout):: rval ! (ibin) + type(gsi_bundle),intent(in ):: sval ! (ibin) + real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) + type(predictors),target, intent(in ):: sbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::intjo1_" + class(obsNode),pointer:: headNode + + end subroutine intjo1_ + + subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use gsi_bundlemod, only: gsi_bundle + use bias_predictors, only: predictors + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList_headNode + use kinds, only: r_quad,r_kind,i_kind + implicit none + class(fedOper ),intent(in):: self + integer(i_kind ),intent(in):: ibin + type(gsi_bundle),intent(in):: dval + type(gsi_bundle),intent(in):: xval + real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) + real(r_kind ),dimension(:),intent(in ):: sges + integer(i_kind),intent(in):: nstep + + type(predictors),target, intent(in):: dbias + type(predictors),target, intent(in):: xbias + + !---------------------------------------- + character(len=*),parameter:: myname_=myname//"::stpjo1_" + class(obsNode),pointer:: headNode + + end subroutine stpjo1_ + +end module gsi_fedOper diff --git a/src/gsi/gsi_files.cmake b/src/gsi/gsi_files.cmake index b98cd2d0da..b514e11c1e 100644 --- a/src/gsi/gsi_files.cmake +++ b/src/gsi/gsi_files.cmake @@ -217,6 +217,7 @@ gsi_colvkOper.F90 gsi_dbzOper.F90 gsi_dwOper.F90 gsi_enscouplermod.f90 +gsi_fedOper.F90 gsi_gpsbendOper.F90 gsi_gpsrefOper.F90 gsi_gustOper.F90 @@ -338,6 +339,7 @@ m_distance.f90 m_dtime.F90 m_dwNode.F90 m_extOzone.F90 +m_fedNode.F90 m_find.f90 m_gpsNode.F90 m_gpsrhs.F90 @@ -478,6 +480,7 @@ read_cris.f90 read_dbz_nc.f90 read_dbz_netcdf.f90 read_diag.f90 +read_fed.f90 read_files.f90 read_fl_hdob.f90 read_gfs_ozone_for_regional.f90 @@ -532,6 +535,7 @@ setupco.f90 setupdbz.f90 setupdbz_lib.f90 setupdw.f90 +setupfed.f90 setupgust.f90 setuphowv.f90 setuplag.f90 diff --git a/src/gsi/gsi_obOperTypeManager.F90 b/src/gsi/gsi_obOperTypeManager.F90 index 5df899825a..6db7921905 100644 --- a/src/gsi/gsi_obOperTypeManager.F90 +++ b/src/gsi/gsi_obOperTypeManager.F90 @@ -66,6 +66,7 @@ module gsi_obOperTypeManager use gsi_lightOper , only: lightOper use gsi_dbzOper , only: dbzOper + use gsi_fedOper , only: fedOper use gsi_cldtotOper , only: cldtotOper use kinds , only: i_kind @@ -136,6 +137,7 @@ module gsi_obOperTypeManager public:: iobOper_lwcp public:: iobOper_light public:: iobOper_dbz + public:: iobOper_fed public:: iobOper_cldtot enum, bind(C) @@ -181,6 +183,7 @@ module gsi_obOperTypeManager enumerator:: iobOper_lwcp enumerator:: iobOper_light enumerator:: iobOper_dbz + enumerator:: iobOper_fed enumerator:: iobOper_cldtot enumerator:: iobOper_extra_ @@ -242,6 +245,7 @@ module gsi_obOperTypeManager type( lwcpOper), target, save:: lwcpOper_mold type( lightOper), target, save:: lightOper_mold type( dbzOper), target, save:: dbzOper_mold + type( fedOper), target, save:: fedOper_mold type( cldtotOper), target, save:: cldtotOper_mold contains @@ -390,6 +394,7 @@ function dtype2index_(dtype) result(index_) case("goes_glm" ); index_= iobOper_light case("dbz" ,"[dbzoper]" ); index_= iobOper_dbz + case("fed" ,"[fedoper]" ); index_= iobOper_fed case("cldtot" ,"[cldtotoper]" ); index_= iobOper_cldtot case("mta_cld" ); index_= iobOper_cldtot @@ -487,6 +492,7 @@ function index2vmold_(iobOper) result(vmold_) case(iobOper_lwcp ); vmold_ => lwcpOper_mold case(iobOper_light ); vmold_ => lightOper_mold case(iobOper_dbz ); vmold_ => dbzOper_mold + case(iobOper_fed ); vmold_ => fedOper_mold case(iobOper_cldtot ); vmold_ => cldtotOper_mold case( obOper_undef ); vmold_ => null() @@ -602,6 +608,7 @@ subroutine cobstype_config_() cobstype(iobOper_lwcp ) ="lwcp " ! lwcp_ob_type cobstype(iobOper_light ) ="light " ! light_ob_type cobstype(iobOper_dbz ) ="dbz " ! dbz_ob_type + cobstype(iobOper_fed ) ="fed " ! fed_ob_type cobstype(iobOper_cldtot ) ="cldtot " ! using q_ob_type cobstype_configured_=.true. diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index cf885c2b64..de19c85fab 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -21,6 +21,7 @@ module gsimod lread_obs_save,lread_obs_skip,time_window_rad,tcp_posmatch,tcp_box, & neutral_stability_windfact_2dvar,use_similarity_2dvar,ta2tb use gsi_dbzOper, only: diag_radardbz + use gsi_fedOper, only: diag_fed use obsmod, only: doradaroneob,oneoblat,oneoblon,oneobheight,oneobvalue,oneobddiff,oneobradid,& radar_no_thinning,ens_hx_dbz_cut,static_gsi_nopcp_dbz,rmesh_dbz,& @@ -560,6 +561,7 @@ module gsimod ! diag_co - logical to turn off or on the diagnostic carbon monoxide file (true=on) ! diag_light - logical to turn off or on the diagnostic lightning file (true=on) ! diag_radardbz - logical to turn off or on the diagnostic radar reflectivity file (true=on) +! diag_fed - logical to turn off or on the diagnostic flash extent density file (true=on) ! write_diag - logical to write out diagnostic files on outer iteration ! lobsdiagsave - write out additional observation diagnostics ! ltlint - linearize inner loop @@ -738,8 +740,8 @@ module gsimod min_offset,pseudo_q2,& iout_iter,npredp,retrieval,& tzr_qc,tzr_bufrsave,& - diag_rad,diag_pcp,diag_conv,diag_ozone,diag_aero,diag_co,diag_light,diag_radardbz,iguess, & - write_diag,reduce_diag, & + diag_rad,diag_pcp,diag_conv,diag_ozone,diag_aero,diag_co,diag_light,diag_radardbz,diag_fed, & + iguess,write_diag,reduce_diag, & oneobtest,sfcmodel,dtbduv_on,ifact10,l_foto,offtime_data,& use_pbl,use_compress,nsig_ext,gpstop,commgpstop, commgpserrinf, & perturb_obs,perturb_fact,oberror_tune,preserve_restart_date, & @@ -1977,6 +1979,7 @@ subroutine gsimain_initialize diag_pcp=.false. diag_light=.false. diag_radardbz=.false. + diag_fed=.false. use_limit = 0 end if if(reduce_diag) use_limit = 0 diff --git a/src/gsi/intjo.f90 b/src/gsi/intjo.f90 index 91b811147e..a68355471b 100644 --- a/src/gsi/intjo.f90 +++ b/src/gsi/intjo.f90 @@ -31,7 +31,7 @@ module intjomod use gsi_obOperTypeManager, only: & iobOper_t, iobOper_pw, iobOper_q, & iobOper_cldtot, iobOper_w, iobOper_dw, & - iobOper_rw, iobOper_dbz, & + iobOper_rw, iobOper_dbz, iobOper_fed, & iobOper_spd, iobOper_oz, iobOper_o3l, iobOper_colvk, & iobOper_pm2_5, iobOper_pm10, iobOper_ps, iobOper_tcp, iobOper_sst, & iobOper_gpsbend, iobOper_gpsref, & @@ -60,7 +60,7 @@ module intjomod integer(i_kind),parameter,dimension(obOper_count):: ix_obtype = (/ & iobOper_t, iobOper_pw, iobOper_q, & iobOper_cldtot, iobOper_w, iobOper_dw, & - iobOper_rw, iobOper_dbz, & + iobOper_rw, iobOper_dbz, iobOper_fed, & iobOper_spd, iobOper_oz, iobOper_o3l, iobOper_colvk, & iobOper_pm2_5, iobOper_pm10, iobOper_ps, iobOper_tcp, iobOper_sst, & iobOper_gpsbend, iobOper_gpsref, & diff --git a/src/gsi/m_fedNode.F90 b/src/gsi/m_fedNode.F90 new file mode 100644 index 0000000000..84a319cd12 --- /dev/null +++ b/src/gsi/m_fedNode.F90 @@ -0,0 +1,248 @@ +module m_fedNode +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_fedNode +! prgmmr: YPW +! org: CIMMS +! date: 2019-09-24 +! +! abstract: class-module of obs-type fedNode (GLM flash extent density) +! Modified based on m_tdNode.f90 +! +! program history log: +! 2019-09-24 YPW - added this document block for the initial polymorphic +! implementation. +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use kinds , only: i_kind,r_kind + use mpeu_util, only: assert_,die,perr,warn,tell + use m_obsNode, only: obsNode + + implicit none + private + + public:: fedNode + + type,extends(obsNode):: fedNode + type(obs_diag), pointer :: diags => NULL() + real(r_kind) :: res ! flash extent density residual + real(r_kind) :: err2 ! flash extent density error squared + real(r_kind) :: raterr2 ! square of ratio of final obs error + ! to original obs error + real(r_kind) :: b ! variational quality control parameter + real(r_kind) :: pg ! variational quality control parameter + real(r_kind) :: jb ! variational quality control parameter + real(r_kind) :: wij(8) ! horizontal interpolation weights + real(r_kind) :: fedpertb ! random number adding to the obs + integer(i_kind) :: k1 ! level of errtable 1-33 + integer(i_kind) :: kx ! ob type + integer(i_kind) :: ij(8) ! horizontal locations + + real (r_kind) :: dlev ! reference to the vertical grid + contains + procedure,nopass:: mytype + procedure:: setHop => obsNode_setHop_ + procedure:: xread => obsNode_xread_ + procedure:: xwrite => obsNode_xwrite_ + procedure:: isvalid => obsNode_isvalid_ + procedure:: gettlddp => gettlddp_ + + end type fedNode + + public:: fedNode_typecast + public:: fedNode_nextcast + interface fedNode_typecast; module procedure typecast_ ; end interface + interface fedNode_nextcast; module procedure nextcast_ ; end interface + + public:: fedNode_appendto + interface fedNode_appendto; module procedure appendto_ ; end interface + + character(len=*),parameter:: MYNAME="m_fedNode" + +#include "myassert.H" +#include "mytrace.H" +contains +function typecast_(aNode) result(ptr_) +!-- cast a class(obsNode) to a type(tdNode) + use m_obsNode, only: obsNode + implicit none + type(fedNode),pointer:: ptr_ + class(obsNode),pointer,intent(in):: aNode + ptr_ => null() + if(.not.associated(aNode)) return + select type(aNode) + type is(fedNode) + ptr_ => aNode + end select +return +end function typecast_ + +function nextcast_(aNode) result(ptr_) +!-- cast an obsNode_next(obsNode) to a type(fedNode) + use m_obsNode, only: obsNode,obsNode_next + implicit none + type(fedNode),pointer:: ptr_ + class(obsNode),target,intent(in):: aNode + + class(obsNode),pointer:: inode_ + inode_ => obsNode_next(aNode) + ptr_ => typecast_(inode_) +return +end function nextcast_ + +subroutine appendto_(aNode,oll) +!-- append aNode to linked-list oLL + use m_obsNode , only: obsNode + use m_obsLList, only: obsLList,obsLList_appendNode + implicit none + type(fedNode),pointer,intent(in):: aNode + type(obsLList),intent(inout):: oLL + + class(obsNode),pointer:: inode_ + inode_ => aNode + call obsLList_appendNode(oLL,inode_) + inode_ => null() +end subroutine appendto_ + +! obsNode implementations + +function mytype() + implicit none + character(len=:),allocatable:: mytype + mytype="[fedNode]" +end function mytype + + +subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) + use m_obsdiagNode, only: obsdiagLookup_locate + implicit none + class(fedNode),intent(inout):: aNode + integer(i_kind),intent(in ):: iunit + integer(i_kind),intent( out):: istat + type(obs_diags),intent(in ):: diagLookup + logical,optional,intent(in ):: skip + + character(len=*),parameter:: myname_=MYNAME//'.obsNode_xread_' + logical:: skip_ +_ENTRY_(myname_) + skip_=.false. + if(present(skip)) skip_=skip + + istat=0 + if(skip_) then + read(iunit,iostat=istat) + if(istat/=0) then + call perr(myname_,'skipping read(%(res,err2,...)), iostat =',istat) + _EXIT_(myname_) + return + endif + + else + read(iunit,iostat=istat) aNode%res , & + aNode%err2 , & + aNode%raterr2 , & + aNode%b , & + aNode%pg , & + aNode%jb , & + aNode%k1 , & + aNode%kx , & + aNode%dlev , & + aNode%wij , & + aNode%ij + if(istat/=0) then + call perr(myname_,'read(%(res,err2,...), iostat =',istat) + _EXIT_(myname_) + return + endif + + aNode%diags => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,1_i_kind) + if(.not.associated(aNode%diags)) then + call perr(myname_,'obsdiagLookup_locate(), %idv =',aNode%idv) + call perr(myname_,' %iob =',aNode%iob) + call die(myname_) + endif + endif +_EXIT_(myname_) +return +end subroutine obsNode_xread_ + +subroutine obsNode_xwrite_(aNode,junit,jstat) + implicit none + class(fedNode),intent(in):: aNode + integer(i_kind),intent(in ):: junit + integer(i_kind),intent( out):: jstat + + character(len=*),parameter:: myname_=MYNAME//'.obsNode_xwrite_' +_ENTRY_(myname_) + + jstat=0 + write(junit,iostat=jstat) aNode%res , & + aNode%err2 , & + aNode%raterr2 , & + aNode%b , & + aNode%pg , & + aNode%jb , & + aNode%k1 , & + aNode%kx , & + aNode%dlev , & + aNode%wij , & + aNode%ij + if(jstat/=0) then + call perr(myname_,'write(%res,err2,...), iostat =',jstat) + _EXIT_(myname_) + return + endif +_EXIT_(myname_) +return +end subroutine obsNode_xwrite_ + +subroutine obsNode_setHop_(aNode) + use m_cvgridLookup, only: cvgridLookup_getiw + implicit none + class(fedNode),intent(inout):: aNode + + character(len=*),parameter:: myname_=MYNAME//'::obsNode_setHop_' +_ENTRY_(myname_) + call cvgridLookup_getiw(aNode%elat,aNode%elon,aNode%dlev,aNode%ij,aNode%wij) +_EXIT_(myname_) +return +end subroutine obsNode_setHop_ + +function obsNode_isvalid_(aNode) result(isvalid_) + implicit none + logical:: isvalid_ + class(fedNode),intent(in):: aNode + + character(len=*),parameter:: myname_=MYNAME//'::obsNode_isvalid_' +_ENTRY_(myname_) + isvalid_=associated(aNode%diags) +_EXIT_(myname_) +return +end function obsNode_isvalid_ + +pure subroutine gettlddp_(aNode,jiter,tlddp,nob) + use kinds, only: r_kind + implicit none + class(fedNode), intent(in):: aNode + integer(kind=i_kind),intent(in):: jiter + real(kind=r_kind),intent(inout):: tlddp + integer(kind=i_kind),optional,intent(inout):: nob + + tlddp = tlddp + aNode%diags%tldepart(jiter)*aNode%diags%tldepart(jiter) + if(present(nob)) nob=nob+1 +return +end subroutine gettlddp_ + +end module m_fedNode diff --git a/src/gsi/m_obsNodeTypeManager.F90 b/src/gsi/m_obsNodeTypeManager.F90 index b5ecc6e1ba..43b42e4bf2 100644 --- a/src/gsi/m_obsNodeTypeManager.F90 +++ b/src/gsi/m_obsNodeTypeManager.F90 @@ -70,6 +70,7 @@ module m_obsNodeTypeManager use m_lightNode, only: lightNode use m_dbzNode , only: dbzNode + use m_fedNode, only: fedNode use kinds, only: i_kind use m_obsNode, only: obsNode @@ -124,6 +125,7 @@ module m_obsNodeTypeManager public:: iobsNode_light public:: iobsNode_dbz + public:: iobsNode_fed public :: obsNode_typeMold public :: obsNode_typeIndex @@ -179,6 +181,7 @@ module m_obsNodeTypeManager type( lwcpNode), target, save:: lwcp_mold type( lightNode), target, save:: light_mold type( dbzNode), target, save:: dbz_mold + type( fedNode), target, save:: fed_mold !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ character(len=*),parameter :: myname='m_obsNodeTypeManager' @@ -245,6 +248,7 @@ module m_obsNodeTypeManager enumerator:: iobsNode_lwcp enumerator:: iobsNode_light enumerator:: iobsNode_dbz + enumerator:: iobsNode_fed enumerator:: iobsNode_extra_ end enum @@ -314,6 +318,7 @@ function vname2index_(vname) result(index_) case("light","[lightnode]"); index_ = iobsNode_light case("dbz" , "[dbznode]"); index_ = iobsNode_dbz + case("fed" , "[fednode]"); index_ = iobsNode_fed end select end function vname2index_ @@ -377,6 +382,7 @@ function vmold2index_select_(mold) result(index_) type is(lightNode); index_ = iobsNode_light type is( dbzNode); index_ = iobsNode_dbz + type is( fedNode); index_ = iobsNode_fed end select end function vmold2index_select_ @@ -434,6 +440,7 @@ function index2vmold_(i_obType) result(obsmold_) case(iobsNode_light); obsmold_ => light_mold case(iobsNode_dbz); obsmold_ => dbz_mold + case(iobsNode_fed); obsmold_ => fed_mold end select end function index2vmold_ diff --git a/src/gsi/m_rhs.F90 b/src/gsi/m_rhs.F90 index baee074688..aea417fe27 100644 --- a/src/gsi/m_rhs.F90 +++ b/src/gsi/m_rhs.F90 @@ -80,6 +80,7 @@ module m_rhs public:: i_lwcp public:: i_light public:: i_dbz + public:: i_fed public:: i_cldtot public:: awork_size @@ -146,6 +147,7 @@ module m_rhs enumerator:: i_lwcp enumerator:: i_light enumerator:: i_dbz + enumerator:: i_fed enumerator:: i_cldtot enumerator:: i_outbound diff --git a/src/gsi/obsmod.F90 b/src/gsi/obsmod.F90 index 3066cdb5ca..a059586e67 100644 --- a/src/gsi/obsmod.F90 +++ b/src/gsi/obsmod.F90 @@ -160,6 +160,7 @@ module obsmod ! 2021-11-16 Zhao - add option l_obsprvdiag (if true) to trigger the output of ! observation provider and sub-provider information into ! obsdiags files (used for AutoObsQC) +! 2023-07-10 Y. Wang, D. Dowell - add variables for flash extent density ! ! Subroutines Included: ! sub init_obsmod_dflts - initialize obs related variables to default values @@ -186,6 +187,7 @@ module obsmod ! def write_diag - namelist logical array to compute/write (=true) diag files ! def diag_radardbz- namelist logical to compute/write (=true) radar ! reflectiivty diag files +! def diag_fed - namelist logical to compute/write (=true) flash extent density diag files ! def reduce_diag - namelist logical to produce reduced radiance diagnostic files ! def use_limit - parameter set equal to -1 if diag files produced or 0 if not diag files or reduce_diag ! def obs_setup - prefix for files passing pe relative obs data to setup routines @@ -434,6 +436,7 @@ module obsmod public :: ran01dom,dval_use public :: iout_pcp,iout_rad,iadate,iadatemn,write_diag,reduce_diag,oberrflg,bflag,ndat,dthin,dmesh,l_do_adjoint public :: diag_radardbz + public :: diag_fed public :: lsaveobsens public :: iout_cldch, mype_cldch public :: nprof_gps,time_offset,ianldate,tcp_box @@ -483,7 +486,9 @@ module obsmod public :: iout_dbz, mype_dbz ! --- DBZ DA --- - + + public :: iout_fed, mype_fed + public :: obsmod_init_instr_table public :: obsmod_final_instr_table public :: nobs_sub @@ -583,12 +588,12 @@ module obsmod integer(i_kind) iout_co,iout_gust,iout_vis,iout_pblh,iout_tcamt,iout_lcbas integer(i_kind) iout_cldch integer(i_kind) iout_wspd10m,iout_td2m,iout_mxtm,iout_mitm,iout_pmsl,iout_howv - integer(i_kind) iout_uwnd10m,iout_vwnd10m + integer(i_kind) iout_uwnd10m,iout_vwnd10m,iout_fed integer(i_kind) mype_t,mype_q,mype_uv,mype_ps,mype_pw, & mype_rw,mype_dw,mype_gps,mype_sst, & mype_tcp,mype_lag,mype_co,mype_gust,mype_vis,mype_pblh, & mype_wspd10m,mype_td2m,mype_mxtm,mype_mitm,mype_pmsl,mype_howv,& - mype_uwnd10m,mype_vwnd10m, mype_tcamt,mype_lcbas, mype_dbz + mype_uwnd10m,mype_vwnd10m, mype_tcamt,mype_lcbas, mype_dbz, mype_fed integer(i_kind) mype_cldch integer(i_kind) iout_swcp, iout_lwcp integer(i_kind) mype_swcp, mype_lwcp @@ -638,6 +643,7 @@ module obsmod logical lobserver,l_do_adjoint, lobsdiag_forenkf logical,dimension(0:50):: write_diag logical diag_radardbz + logical diag_fed logical reduce_diag logical offtime_data logical hilbert_curve @@ -789,6 +795,7 @@ subroutine init_obsmod_dflts end do write_diag(1)=.true. diag_radardbz = .false. + diag_fed = .false. reduce_diag = .false. use_limit = -1 lobsdiagsave=.false. @@ -853,6 +860,7 @@ subroutine init_obsmod_dflts iout_lwcp=236 ! liquid-water content path iout_light=237 ! lightning iout_dbz=238 ! radar reflectivity + iout_fed=239 ! flash extent density mype_ps = npe-1 ! surface pressure mype_t = max(0,npe-2) ! temperature @@ -887,6 +895,7 @@ subroutine init_obsmod_dflts mype_lwcp=max(0,npe-31) ! liquid-water content path mype_light=max(0,npe-32)! GOES/GLM lightning mype_dbz=max(0,npe-33) ! radar reflectivity + mype_fed= max(0,npe-34) ! flash extent density ! Initialize arrays used in namelist obs_input diff --git a/src/gsi/read_fed.f90 b/src/gsi/read_fed.f90 new file mode 100644 index 0000000000..c478b3d93f --- /dev/null +++ b/src/gsi/read_fed.f90 @@ -0,0 +1,525 @@ +subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) +!$$$ subprogram documentation block +! . . . . +! ABSTRACT: +! This routine reads in netcdf or prepbufr flash-extent density (FED) data. +! +! PROGRAM HISTORY LOG: +! 2018-07-25 Rong Kong (CAPS/OU) - modified based on read_radarref_mosaic.f90 +! 2019-09-20 Yaping Wang (CIMMS/OU) +! 2021-07-01 David Dowell (DCD; NOAA GSL) - added maximum flashes/min for observed FED +! +! input argument list: +! infile - unit from which to read observation information file +! obstype - observation type to process +! lunout - unit to which to write data for further processing +! twind - input group time window (hours) +! sis - observation variable name +! +! output argument list: +! nread - number of type "obstype" observations read +! ndata - number of type "obstype" observations retained for further processing +! nobs - array of observations on each subdomain for each processor +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! +!$$$ +! +!_____________________________________________________________________ +! + use kinds, only: r_kind,r_double,i_kind + use constants, only: zero,one,deg2rad + use convinfo, only: nconvtype,ctwind,icuse,ioctype + use gsi_4dvar, only: l4dvar,l4densvar,winlen + use gridmod, only: tll2xy + use mod_wrfmass_to_a, only: wrfmass_obs_to_a8 + use mpimod, only: npe + use obsmod, only: perturb_obs,iadatemn + + use netcdf + implicit none + + include 'netcdf.inc' +! + character(len=*), intent(in) :: infile,obstype + integer(i_kind), intent(in) :: lunout + integer(i_kind), intent(inout) :: nread,ndata + integer(i_kind), intent(inout) :: nodata + integer(i_kind), dimension(npe) ,intent(inout) :: nobs + real(r_kind), intent(in ) :: twind + character(len=*), intent(in) :: sis + +! Declare local parameters + real(r_kind),parameter:: r90 = 90.0_r_kind + real(r_kind),parameter:: r360 = 360.0_r_kind + real(r_kind),parameter:: oe_fed = 1.0_r_kind + real(r_kind),parameter:: fed_lowbnd = 0.1_r_kind ! use fed == fed_lowbnd + real(r_kind),parameter:: fed_lowbnd2 = 0.1_r_kind ! use fed >= fed_lowbnd2 +! real(r_kind),parameter:: fed_highbnd = 18.0_r_kind ! 18 flashes/min from Sebok and Back (2021, unpublished) + real(r_kind),parameter:: fed_highbnd = 8.0_r_kind ! 8 flashes/min from Back (2023) for regional FV3 tests + +! +! For fed observations +! + integer(i_kind) nreal,nchanl + + integer(i_kind) ifn,i + + integer(i_kind) :: ilon,ilat + + logical :: fedobs, fedob + real(r_kind),allocatable,dimension(:,:):: cdata_out + real(r_kind) :: federr, thiserr + real(r_kind) :: hgt_fed(1) + data hgt_fed / 6500.0 / + + real(r_kind) :: i_maxloc,j_maxloc,k_maxloc + integer(i_kind) :: kint_maxloc + real(r_kind) :: fed_max + integer(i_kind) :: ndata2 + integer(i_kind) :: ppp + +! +! for read in bufr +! + real(r_kind) :: hdr(5),obs(1,3) + character(80):: hdrstr='SID XOB YOB DHR TYP' + character(80):: obsstr='FED' + + character(8) subset + character(8) station_id + real(r_double) :: rstation_id + equivalence(rstation_id,station_id) + integer(i_kind) :: lunin,idate + integer(i_kind) :: ireadmg,ireadsb + + integer(i_kind) :: maxlvl + integer(i_kind) :: numlvl,numfed,nmsgmax,maxobs + integer(i_kind) :: k,iret + integer(i_kind) :: nmsg,ntb + + real(r_kind),allocatable,dimension(:,:) :: fed3d_column ! 3D fed in column + real(r_kind),allocatable,dimension(:) :: utime ! time + + integer(i_kind) :: ikx + real(r_kind) :: timeo,t4dv + + character*128 :: myname='read_fed' + + real(r_kind) :: dlat, dlon ! rotated corrdinate + real(r_kind) :: dlat_earth, dlon_earth ! in unit of degree + real(r_kind) :: rlat00, rlon00 ! in unit of rad + + logical :: l_psot_fed + logical :: l_latlon_fedobs + logical :: outside + integer :: unit_table + +! for read netcdf + integer(i_kind) :: sec70,mins_an + integer(i_kind) :: varID, ncdfID, status + real(r_kind) :: timeb,twindm,rmins_an,rmins_ob + + + unit_table = 23 +!********************************************************************** +! +! END OF DECLARATIONS....start of program +! + write(6,*) "r_kind=",r_kind + l_psot_fed = .FALSE. + l_latlon_fedobs = .TRUE. + + fedob = obstype == 'fed' + if(fedob) then + nreal=25 + else + write(6,*) ' illegal obs type in read_fed : obstype=',obstype + call stop2(94) + end if + if(perturb_obs .and. fedob)nreal=nreal+1 + write(6,*)'read_fed: nreal=',nreal + + fedobs = .false. + ikx=0 + do i=1,nconvtype + if(trim(obstype) == trim(ioctype(i)) .and. abs(icuse(i))== 1) then + fedobs=.true. + ikx=i + federr = oe_fed ! Obs error (flashes per minute) + thiserr = federr + exit ! Exit loop when finished with initial convinfo fields + else if (i == nconvtype ) then + write(6,*) 'read_fed: Obs Type for fed is not in CONVINFO !' + write(6,*) 'read_fed: PLEASE modify the CONVINFO file !' + write(6,*) 'read_fed: abort read_fed !' + return + endif + end do + write(6,'(1x,A,A30,I4,A15,F7.3,A7)') & + trim(myname),': fed in convinfo-->ikx=',ikx,' fed ob err:',thiserr," (fed)" + + nread=0 + ndata=0 + nchanl=0 + ifn = 15 + + if(fedobs) then + maxlvl= 1 ! fed only has one level + + if(trim(infile) .eq. "fedbufr") then ! prebufr or netcdf format + !! get message and subset counts + ! nmsgmax and maxobs are read in from BUFR data file, not pre-set. + call getcount_bufr(infile,nmsgmax,maxobs) + write(6,*)'read_fed: nmsgmax=',nmsgmax,' maxobs=',maxobs + +! read in fed obs in bufr code format + lunin = 10 + allocate(fed3d_column(maxlvl+2+2,maxobs)) + + open ( unit = lunin, file = trim(infile),form='unformatted',err=200) + call openbf ( lunin, 'IN', lunin ) + open(unit_table,file='prepobs_kr.bufrtable') !temporily dump the bufr table, which is already saved in file + call dxdump(lunin,unit_table) + call datelen ( 10 ) + + nmsg=0 + ntb = 0 + + ndata =0 + ppp = 0 + msg_report: do while (ireadmg(lunin,subset,idate) == 0) + nmsg=nmsg+1 + if (nmsg>nmsgmax) then + write(6,*)'read_fed: messages exceed maximum ',nmsgmax + call stop2(50) + endif + loop_report: do while (ireadsb(lunin) == 0) + ntb = ntb+1 + if (ntb>maxobs) then + write(6,*)'read_fed: reports exceed maximum ',maxobs + call stop2(50) + endif + + ! Extract type, date, and location information from BUFR file + call ufbint(lunin,hdr,5,1,iret,hdrstr) + if(hdr(3) .gt. r90 ) write(6,*) "Inside read_fed.f90, hdr(2)=",hdr(2),"hdr(3)=",hdr(3) + if ( l_latlon_fedobs ) then + if(abs(hdr(3))>r90 .or. abs(hdr(2))>r360) cycle loop_report + if(hdr(2)== r360)hdr(2)=hdr(2)-r360 + if(hdr(2) < zero)hdr(2)=hdr(2)+r360 + end if + +! check time window in subset + if (l4dvar.or.l4densvar) then + t4dv=hdr(4) + if (t4dvwinlen) then + write(6,*)'read_fed: time outside window ',& + t4dv,' skip this report' + cycle loop_report + endif + else + timeo=hdr(4) + if (abs(timeo)>ctwind(ikx) .or. abs(timeo) > twind) then + write(6,*)'read_fed: time outside window ',& + timeo,' skip this report' + cycle loop_report + endif + endif +! read in observations + call ufbint(lunin,obs,1,3,iret,obsstr) !Single level bufr data, Rong Kong + if(obs(1,1) .gt. 5 ) write(6,*) "Inside read_fed.f90, obs(1,1)=",obs(1,1) + numlvl=min(iret,maxlvl) + if (numlvl .ne. maxlvl) then + write(6,*)' read_fed: numlvl is not equalt to maxlvl:',numlvl,maxlvl + end if + if(hdr(3) .gt. 90) write(6,*) "hdr(3)=",hdr(3) + if ( l_latlon_fedobs ) then + if(hdr(2)>= r360)hdr(2)=hdr(2)-r360 + if(hdr(2) < zero)hdr(2)=hdr(2)+r360 + fed3d_column(1,ntb)=hdr(2) ! observation location, earth lon + fed3d_column(2,ntb)=hdr(3) ! observation location, earth lat +! write(6,*) "Inside read_fed.f90, fed3d_column(1,ntb)=",fed3d_column(1,ntb),"fed3d_column(2,ntb)=",fed3d_column(2,ntb) + else + fed3d_column(1,ntb)=hdr(2)*10.0_r_kind ! observation location, grid index i + fed3d_column(2,ntb)=hdr(3)*10.0_r_kind ! observation location, grid index j + end if + + if (l_psot_fed .and. .NOT. l_latlon_fedobs ) then + do k=1,numlvl + if (NINT(fed3d_column(1,ntb)) .eq. 175 .and. NINT(fed3d_column(2,ntb)) .eq. 105 .and. & + NINT(hgt_fed(k)) .ge. 100 ) then + write(6,*) 'read_fed: single point/column obs run on grid: 175 105' + write(6,*) 'read_fed: found the pseudo single(column) fed obs:',fed3d_column(1:2,ntb),hgt_fed(k) + else + obs(1,1) = -999.0 + end if + end do + end if + + fed3d_column(3,ntb)=obs(1,1) + fed3d_column(4,ntb)=obs(1,2) + fed3d_column(5,ntb)=obs(1,3) + if (obs(1,1) == fed_lowbnd .or. obs(1,1) >= fed_lowbnd2 ) then + if (obs(1,1) == 0.0) then + ppp = ppp + 1 + endif + ndata = ndata + 1 + endif + + enddo loop_report + enddo msg_report + + write(6,*)'read_fed: messages/reports = ',nmsg,'/',ntb + print*,'number of Z that is less than 0 is ppp = ', ppp + numfed=ntb + +! - Finished reading fed observations from BUFR format data file +! + call closbf(lunin) + close(lunin) + + else ! NETCDF format +!!!! Start reading fed observations from NETCDF format data file + ! CHECK IF DATA FILE EXISTS + + ! OPEN NETCDF FILE + status = nf90_open(TRIM(infile), NF90_NOWRITE, ncdfID) + print*, '*** OPENING GOES FED OBS NETCDF FILE: ', infile, status + + + !------------------------ + ! Get date information + !------------------------- + ! status = nf90_get_att( ncdfID, nf90_global, 'year', idate5s(1) ) + ! print*, 'year ',status + ! status = nf90_get_att( ncdfID, nf90_global, 'month', idate5s(2) ) + ! status = nf90_get_att( ncdfID, nf90_global, 'day', idate5s(3) ) + ! status = nf90_get_att( ncdfID, nf90_global, 'hour', idate5s(4) ) + ! status = nf90_get_att( ncdfID, nf90_global, 'minute', idate5s(5) ) + ! read(idate5s(:) , *) idate5(:) + ! print*, idate5 + + !------------------------ + ! Get Dimension Info (1-D) + !------------------------- + status = nf90_inq_varid( ncdfID, 'numobs', varID ) + status = nf90_get_var( ncdfID, varID, maxobs ) + + !------------------------ + ! Allocate data arrays + !------------------------- + ALLOCATE( fed3d_column( 5, maxobs ) ) + ALLOCATE( utime( 1 ) ) ! seconds since from 2000-01-01 12:00 + + !------------------------ + ! Get useful data arrays + !------------------------- + ! LON + status = nf90_inq_varid( ncdfID, 'lon', varID ) + status = nf90_get_var( ncdfID, varID, fed3d_column(1, :) ) + ! LAT + status = nf90_inq_varid( ncdfID, 'lat', varID ) + status = nf90_get_var( ncdfID, varID, fed3d_column(2, :) ) + ! FED value + status = nf90_inq_varid( ncdfID, 'value', varID ) + status = nf90_get_var( ncdfID, varID, fed3d_column(3, :) ) + ! TIME + status = nf90_inq_varid( ncdfID, 'time', varID ) + status = nf90_get_var( ncdfID, varID, utime ) + + ! CLOSE NETCDF FILE + status = nf90_close( ncdfID ) + + + !-Obtain analysis time in minutes since reference date + sec70 = 694267200.0 ! seconds since from 1978-01-01 00:00 to 2000-01-01 12:00 + ! because the official GOES prescribed epoch time for GLM data is 2000-01-01 12:00:00 + + call w3fs21(iadatemn,mins_an) !mins_an -integer number of mins snce 01/01/1978 + rmins_an=mins_an !convert to real number + + ! SINCE ALL OBS WILL HAVE THE SAME TIME, CHECK TIME HERE: + rmins_ob = ( utime(1) + sec70 )/60 !Convert to Minutes from seconds + twindm = twind*60. !Convert to Minutes from hours + timeb = rmins_ob-rmins_an + + if(abs(timeb) > abs(twindm)) then + print*, 'WARNING: ALL FED OBSERVATIONS OUTSIDE ASSIMILATION TIME WINDOW: ', timeb, twindm + ! goto 314 + endif + numfed = maxobs + do i=1,numfed + if (fed3d_column( 3, i ) >= fed_lowbnd2 .or. fed3d_column( 3, i ) == fed_lowbnd ) then + ndata = ndata + 1 + end if + end do + end if ! end if prebufr or netcdf format + + write(6,*)'read_fed: total no. of obs = ',ndata + nread=ndata + nodata=ndata +!!! - Finished reading fed observations from NETCDF format data file + + + + allocate(cdata_out(nreal,ndata)) +! +! + do i=1,numfed + do k=1,maxlvl + +! DCD 1 July 2021 + if (fed3d_column(k+2,i) .gt. fed_highbnd) fed3d_column(k+2,i) = fed_highbnd + + end do + end do + + write(6,*) ' ------- check max and min value of OBS: bufr fed -------' + write(6,*) ' level maxval(fed) minval(fed)' + do k=1,maxlvl + write(6,*) k,maxval(fed3d_column(k+2,:)),minval(fed3d_column(k+2,:)) + end do + + + i_maxloc=-1.0 + j_maxloc=-1.0 + k_maxloc=-1.0 + kint_maxloc=-1 + fed_max=-999.99 + ndata2=0 + do i=1,numfed + do k=1,maxlvl + if( fed3d_column(k+2,i) >= fed_lowbnd2 .or. fed3d_column(k+2,i) == fed_lowbnd) then !Rong Kong + dlon_earth = fed3d_column(1,i) ! longitude (degrees) of observation + ! ilone=18 ! index of longitude (degrees) + dlat_earth = fed3d_column(2,i) ! latitude (degrees) of observation + ! ilate=19 ! index of latitude (degrees) + !-Check format of longitude and correct if necessary + if(dlon_earth>=r360) dlon_earth=dlon_earth-r360 + if(dlon_earth=r360 .or. dlat_earth >90.0_r_kind) cycle + + !-Convert back to radians + rlon00 = dlon_earth*deg2rad + rlat00 = dlat_earth*deg2rad + call tll2xy(rlon00,rlat00,dlon,dlat,outside) + if (outside) cycle + + !If observation is outside the domain + ! then cycle, but don't increase + ! range right away. + ! Domain could be rectangular, so ob + ! may be out of + ! range at one end, but not the + ! other. + + ndata2=ndata2+1 + cdata_out( 1,ndata2) = thiserr ! obs error (flashes/min) - inflated/adjusted + + cdata_out( 2,ndata2) = dlon ! + + cdata_out( 3,ndata2) = dlat + + cdata_out( 4,ndata2) = hgt_fed(k) ! obs absolute height (m) above MSL + ! ipres=4 ! index of pressure + cdata_out( 5,ndata2) = fed3d_column(k+2,i) ! FED value + ! idbzob=5 ! index of dbz observation + cdata_out( 6,ndata2) = rstation_id ! station id (charstring equivalent to real double) + ! id=6 ! index of station id + + cdata_out( 7,ndata2) = 0.0_r_kind ! observation time in data array + ! itime=7 ! index of observation time in data array + cdata_out( 8,ndata2) = ikx ! ob type + ! ikxx=8 ! index of ob type + cdata_out( 9,ndata2) = thiserr*2.0_r_kind ! max error + ! iqmax=9 ! index of max error + cdata_out(10,ndata2) = 273.0_r_kind ! dry temperature + ! itemp=10 ! index of dry temperature + cdata_out(11,ndata2) = 1.0_r_kind ! quality mark + ! iqc=11 ! index of quality mark + cdata_out(12,ndata2) = thiserr ! original-original obs error ratio + ! ier2=12 ! index of original-original obs error ratio + cdata_out(13,ndata2) = icuse(ikx) ! index of use parameter + ! iuse=13 ! index of use parameter + cdata_out(14,ndata2) = icuse(ikx) ! dominant surface type + ! idomsfc=14 ! index of dominant surface type + cdata_out(15,ndata2) = 273.0_r_kind ! index of surface skin temperature + ! iskint=15 ! index of surface skin temperature + cdata_out(16,ndata2) = 0.5_r_kind ! 10 meter wind factor + ! iff10=16 ! index of 10 meter wind factor + cdata_out(17,ndata2) = 0.5_r_kind ! surface roughness + ! isfcr=17 ! index of surface roughness + + cdata_out(18,ndata2) = dlon_earth ! longitude (degrees) + + cdata_out(19,ndata2) = dlat_earth ! latitude (degrees) + + cdata_out(20,ndata2) = hgt_fed(k) ! station elevation (m) + ! istnelv=20 ! index of station elevation (m) + cdata_out(21,ndata2) = hgt_fed(k) ! observation height (m) + ! iobshgt=21 ! index of observation height (m) + cdata_out(22,ndata2) = hgt_fed(k) ! surface height + ! izz=22 ! index of surface height + cdata_out(23,ndata2) = fed3d_column(4,i) ! i index of obs grid for bufr resolution (i.e.,8km) + + cdata_out(24,ndata2) = fed3d_column(5,i) ! j index of obs grid for bufr resolution + + cdata_out(25,ndata2) = hgt_fed(k) ! data level category + ! icat =25 ! index of data level category + if(perturb_obs .and. fedob)then + cdata_out(26,ndata2) = 1.0_r_kind ! obs perturbation + ! iptrb=26 ! index of q perturbation + end if +! print*,'cdata_out(:,ndata2)=',cdata_out(:,ndata2) + if(fed3d_column(k+2,i) > fed_max)then + kint_maxloc=k + k_maxloc=real(k,r_kind) + j_maxloc=fed3d_column(2,i) + i_maxloc=fed3d_column(1,i) + fed_max =fed3d_column(k+2,i) + end if + endif + enddo + enddo + +!---all looping done now print diagnostic output + write(6,*)'READ_FED: Reached eof on FED file' + write(6,*)'READ_FED: # read in obs. number =',nread + write(6,*)'READ_FED: # read in obs. number for further processing =',ndata2 + ! write(6,*)'READ_FED: dlon_earth', cdata_out(18,10:15) + + ilon=2 ! array index for longitude + ilat=3 ! array index for latitude in obs information array + ndata=ndata2 + nodata=ndata2 + + !---Write observations to scratch file---! + +! if(ndata > 0 ) then + call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs) + write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata + write(lunout) ((cdata_out(k,i),k=1,nreal),i=1,ndata) + ! print*,'cdata_out',cdata_out +! endif + + deallocate(cdata_out) + if (allocated(fed3d_column)) deallocate(fed3d_column) + + write(6,'(1x,A,F12.5,1x,A,3(1x,F8.3),1x,I4)') & + 'read_fed: max fed =',fed_max, '@ i j k =', & + i_maxloc,j_maxloc,k_maxloc,kint_maxloc + + end if +! close(lunout) ! ???? + return + +200 continue + write(6,*) 'read_fed, Warning : cannot find or open bufr fed data file: ', trim(infile) + +314 continue +print* ,'FINISHED WITH READ_FED' +end subroutine read_fed +! +! diff --git a/src/gsi/read_obs.F90 b/src/gsi/read_obs.F90 index 86c7e4ce45..15476e2d04 100644 --- a/src/gsi/read_obs.F90 +++ b/src/gsi/read_obs.F90 @@ -192,6 +192,7 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) if ( .not. l_use_dbz_directDA) then if(trim(dtype) == 'dbz' )return end if + if(trim(dtype) == 'fed' )return ! Use routine as usual @@ -911,7 +912,8 @@ subroutine read_obs(ndata,mype) obstype == 'mitm' .or. obstype=='pmsl' .or. & obstype == 'howv' .or. obstype=='tcamt' .or. & obstype=='lcbas' .or. obstype=='cldch' .or. obstype == 'larcglb' .or. & - obstype=='uwnd10m' .or. obstype=='vwnd10m' .or. obstype=='dbz' ) then + obstype=='uwnd10m' .or. obstype=='vwnd10m' .or. obstype=='dbz' .or. & + obstype=='fed') then ditype(i) = 'conv' else if (obstype == 'swcp' .or. obstype == 'lwcp') then ditype(i) = 'wcp' @@ -1302,6 +1304,10 @@ subroutine read_obs(ndata,mype) use_hgtl_full=.true. if(belong(i))use_hgtl_full_proc=.true. end if + if(obstype == 'fed')then + use_hgtl_full=.true. + if(belong(i))use_hgtl_full_proc=.true. + end if if(obstype == 'sst')then if(belong(i))use_sfc=.true. endif @@ -1639,6 +1645,12 @@ subroutine read_obs(ndata,mype) endif end if +! Process flash extent density + else if (obstype == 'fed' ) then + print *, "calling read_fed" + call read_fed(nread,npuse,nouse,infile,obstype,lunout,twind,sis,nobs_sub1(1,i)) + string='READ_FED' + ! Process lagrangian data else if (obstype == 'lag') then call read_lag(nread,npuse,nouse,infile,lunout,obstype,& diff --git a/src/gsi/setupfed.f90 b/src/gsi/setupfed.f90 new file mode 100644 index 0000000000..cf6334e567 --- /dev/null +++ b/src/gsi/setupfed.f90 @@ -0,0 +1,1100 @@ +module fed_setup + implicit none + private + public:: setup + interface setup; module procedure setupfed; end interface + +contains +subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsave,init_pass) +!$$$ subprogram documentation block +! . . . . +! subprogram: setupfed compute rhs of flash extent density +! orig. prgmmr: +! Rong Kong CAPS/OU 2018-01-21 (modified based on setupdbz.f90) +! modified: +! Yaping Wang CIMMS/OU 2019-11-11 +! David Dowell (DCD) NOAA GSL 2021-07-01 +! - added a second option (tanh) for observation operator, based on the +! work of Sebok and Back (2021, unpublished) +! - capped maximum model FED +! +! + use mpeu_util, only: die,perr + use kinds, only: r_kind,r_single,r_double,i_kind + use m_obsdiagNode, only: obs_diag + use m_obsdiagNode, only: obs_diags + use m_obsdiagNode, only: obsdiagLList_nextNode + use m_obsdiagNode, only: obsdiagNode_set + use m_obsdiagNode, only: obsdiagNode_get + use m_obsdiagNode, only: obsdiagNode_assert + use obsmod, only: rmiss_single,& + lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset + use obsmod, only: oberror_tune + use m_obsNode, only: obsNode + use m_fedNode, only: fedNode + use m_fedNode, only: fedNode_appendto + use obsmod, only: luse_obsdiag, netcdf_diag, binary_diag, dirname, ianldate + use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & + nc_diag_write, nc_diag_data2d + 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 guess_grids, only: hrdifsig,nfldsig,ges_prsi + use guess_grids, only: ges_lnprsl, geop_hgtl + use gridmod, only: lat2, lon2 + use gridmod, only: nsig, get_ij,get_ijk,tll2xy + use constants, only: flattening,semi_major_axis,grav_ratio,zero,grav,wgtlim + use constants, only: half,one,two,grav_equator,eccentricity,somigliana + use constants, only: deg2rad,r60,tiny_r_kind,cg_term,huge_single + use constants, only: r10,r100,r1000 + use constants, only: grav,tpwcon + use qcmod, only: npres_print,ptopq,pbotq + use jfunc, only: jiter,last,miter + use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype + use convinfo, only: icsubtype + use converr, only: ptabl + use m_dtime, only: dtime_setup, dtime_check, dtime_show + use state_vectors, only: nsdim + + use gsi_bundlemod, only: GSI_BundleGetPointer + use gsi_metguess_mod, only: gsi_metguess_get, GSI_MetGuess_Bundle + + use netcdf + + + implicit none +! Declare passed variables + type(obsLList ),target,dimension(:),intent(in):: obsLL + type(obs_diags),target,dimension(:),intent(in):: odiagLL + + logical ,intent(in ) :: fed_diagsave + integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs + real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork + real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork + integer(i_kind) ,intent(in ) :: is ! ndat index + logical ,intent(in ) :: init_pass ! state of "setup" parameters + + +! Declare local parameters + integer(i_kind),parameter:: fed_obs_ob_shape = 2 ! 1 = linear (Allen et al.) + ! 2 = tanh (Sebok and Back) +! coefficients for tanh operator, from Sebok and Back (2021) +! real(r_kind),parameter:: a_coeff = 8.4_r_kind ! a (flashes/min) in tanh operator +! real(r_kind),parameter:: b_coeff = 12.248_r_kind ! b (flashes/min) in tanh operator +! real(r_kind),parameter:: c_coeff = 5.0e-10_r_kind ! c (radians/kg) in tanh operator +! real(r_kind),parameter:: d_coeff = 1.68e9_r_kind ! d (kg) in tanh operator +! real(r_kind),parameter:: fed_highbnd = 18.0_r_kind ! DCD: Sebok and Back (2021, unpublished) + +! coefficients for tanh operator, from work by A. Back with regional FV3 (2023) + real(r_kind),parameter:: a_coeff = -3.645_r_kind ! a (flashes/min) in tanh operator + real(r_kind),parameter:: b_coeff = 15.75_r_kind ! b (flashes/min) in tanh operator + real(r_kind),parameter:: c_coeff = 1.939e-10_r_kind ! c (radians/kg) in tanh operator + real(r_kind),parameter:: d_coeff = -1.215e9_r_kind ! d (kg) in tanh operator + real(r_kind),parameter:: fed_highbnd = 8.0_r_kind ! DCD: Back (2023, unpublished) for FV3 + + real(r_kind),parameter:: fed_height = 6500.0_r_kind ! assumed height (m) of FED observations + real(r_kind),parameter:: r0_001 = 0.001_r_kind + real(r_kind),parameter:: r8 = 8.0_r_kind + real(r_kind),parameter:: ten = 10.0_r_kind + real(r_kind),parameter:: D608=0.608_r_kind + character(len=*),parameter:: myname='setupfed' + +! Declare external calls for code analysis + external:: tintrp2a1 + external:: tintrp2a11 + external:: tintrp2a1116 + external:: tintrp31 + external:: grdcrd1 + external:: stop2 + +! Declare local variables + real(r_kind) rlow,rhgh,rsig + real(r_kind) dz + real(r_kind) jqg_num,jqg + real(r_kind) dlnp,pobl,zob + real(r_kind) sin2,termg,termr,termrg + real(r_kind) psges,zsges + real(r_kind),dimension(nsig):: zges,hges + real(r_kind) prsltmp(nsig) + real(r_kind) sfcchk + real(r_kind) residual,obserrlm,obserror,ratio,scale,val2 + real(r_kind) ress,ressw + real(r_kind) val,valqc,rwgt + real(r_kind) cg_w,wgross,wnotgross,wgt,arg,exp_arg,term,rat_err2 + real(r_double) rstation_id + real(r_kind) dlat,dlon,dtime,dpres,ddiff,error,slat,dlat8km,dlon8km + real(r_kind) ratio_errors + real(r_kind) presw + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final + real(r_kind),dimension(nele,nobs):: data + real(r_kind),dimension(lat2,lon2,nfldsig)::rp + real(r_single),allocatable,dimension(:,:)::rdiagbuf + real(r_kind),allocatable,dimension(:,:,: ) :: ges_z + real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_qg,ges_qg_mask + + real(r_kind) :: presq + real(r_kind) :: T1D,RHO + real(r_kind) :: glmcoeff = 2.088_r_kind*10.0**(-8.0) ! Allen et al. (2016,MWR) + real(r_kind) :: CM = 0.5_r_kind ! tuning factor in eq. 14 of Kong et al. 2020 + + integer(i_kind) i,nchar,nreal,k,j,k1,ii,jj + integer(i_kind) mm1,k2 + integer(i_kind) jsig,ikxx,nn,ibin,ioff,ioff0 + integer(i_kind) ier,ilat,ilon,ifedob,ikx,itime,iuse + integer(i_kind) id,ilone,ilate + integer(i_kind) ier2 + + integer(i_kind) nlat_ll,nlon_ll,nsig_ll,nfld_ll + + integer(i_kind) ipres,iqmax,iqc,icat,itemp + integer(i_kind) istnelv,iobshgt,izz,iprvd,isprvd,iptrb + integer(i_kind) idomsfc,iskint,isfcr,iff10 + + character(8) station_id + character(8),allocatable,dimension(:):: cdiagbuf + character(80):: string + character(128):: diag_file + logical :: diagexist + logical,dimension(nobs):: luse,muse + integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID + logical proceed + + equivalence(rstation_id,station_id) + integer(i_kind) numequal,numnotequal + + type(fedNode),pointer:: my_head + type(obs_diag),pointer:: my_diag + type(obs_diags),pointer:: my_diagLL + + real(r_kind),dimension(nsig+1):: prsitmp + + +!------------------------------------------------! + + integer(i_kind) :: itmp,jtmp + + integer(i_kind), parameter :: ntimesfed=1 + integer(i_kind),parameter :: nxfed=99, nyfed=99, nzfed=1, nfldfed=3 + real(r_kind),dimension(nobs) :: FEDMdiag,FEDMdiagTL + integer(i_kind) :: npt + real(r_kind) :: dlat_earth,dlon_earth + +! YPW added the next lines + logical :: l_set_oerr_ratio_fed=.False. + logical :: l_gpht2gmht = .True. + real(r_kind),dimension(nobs) :: dlatobs,dlonobs + integer(i_kind):: ngx,ngy,igx,jgy + real(r_kind):: dx_m, dy_m + + type(obsLList),pointer,dimension(:):: fedhead + fedhead => obsLL(:) + +!============================================================================================ +! Read and reformat observations in work arrays. + read(lunin)data,luse,ioid + + write(6,*)myname,'(pe=',mype,') nele nobs =',nele,nobs, & + 'luse_obsdiag=',luse_obsdiag,'lat2,lon2=',lat2,lon2 + + ier=1 ! index of obs error + ilon=2 ! index of grid relative obs location (x) + ilat=3 ! index of grid relative obs location (y) + ipres=4 ! index of pressure + ifedob=5 ! index of fed observation + id=6 ! index of station id + itime=7 ! index of observation time in data array + ikxx=8 ! index of ob type + iqmax=9 ! index of max error + itemp=10 ! index of dry temperature + iqc=11 ! index of quality mark + ier2=12 ! index of original-original obs error ratio + iuse=13 ! index of use parameter + idomsfc=14 ! index of dominant surface type + iskint=15 ! index of surface skin temperature + iff10=16 ! index of 10 meter wind factor + isfcr=17 ! index of surface roughness + ilone=18 ! index of longitude (degrees) + ilate=19 ! index of latitude (degrees) + istnelv=20 ! index of station elevation (m) + iobshgt=21 ! index of observation height (m) + izz=22 ! index of surface height + iprvd=23 ! index of observation provider + isprvd=24 ! index of observation subprovider + icat =25 ! index of data level category + iptrb=26 ! index of fed perturbation + do i=1,nobs + muse(i)=nint(data(iuse,i)) <= jiter + end do + + numequal=0 + numnotequal=0 + +! +! If requested, save select data for output to diagnostic file + if(fed_diagsave)then + ii=0 + nchar=1_i_kind + ioff0=26_i_kind ! 21 + 5 (22->Zr; 23->Zs; 24->Zg; 25->tsenges;26->RHO;) + nreal=ioff0 + if (lobsdiagsave) nreal=nreal+4*miter+1 + allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) + rdiagbuf=zero + if(netcdf_diag) call init_netcdf_diag_ + end if + mm1=mype+1 + scale=one + rsig=nsig + + + + !============================================================================================ +! +! Check to see if required guess fields are available +! vars. list: ps, z, q +! vars. list: qr, qs, qg + !============================================================================================ + + call check_vars_(proceed) + if(.not.proceed) then + write(6,*) myname,': some or all necessary variables are not available for fed obs operator. Quit!' + return ! not all vars available, simply return + end if + +! If require guess vars available, extract from bundle ... + call init_vars_ +! qscalar=zero + + !============================================================================================ + ! 1) Calculate the graupel-mass and graupel-volume based flash extent density + ! (FED) on model space, added by R. Kong, 07/05/2018 + !============================================================================================ + ges_qg_mask=ges_qg + where(ges_qg>0.0005) !Count the volume where qg > 0.5/kg + ges_qg_mask=1.0 + elsewhere + ges_qg_mask=0.0 + endwhere + + ! Operator start here + ! set ngx and ngy =2, so the integrated domain is 15kmx15km + ngx = 2 + ngy = 2 + dx_m = 3000. + dy_m = 3000. + print*,'FED Operator start here!,ngx=',ngx,'ngy=',ngy + rp=zero + + print*, 'mype = ', mype + print*, 'nfldsig = ', nfldsig + print*, 'nsig = ', nsig + print*, 'lon2 = ', lon2 + print*, 'lat2 = ', lat2 + +! compute graupel mass, in kg per 15 km x 15 km column + do jj=1,nfldsig + do k=1,nsig + do i=1,lon2 + do j=1,lat2 !How to handle MPI???? + do igx=1,2*ngx+1 !horizontal integration of qg around point to calculate FED + do jgy=1,2*ngy+1 + itmp = i-ngx+igx-1 + jtmp = j-ngy+jgy-1 + itmp = min(max(1,itmp),lon2) + jtmp = min(max(1,jtmp),lat2) + rp(j,i,jj)=rp(j,i,jj) + ges_qg(jtmp,itmp,k,jj)* & + dx_m*dy_m*(ges_prsi(jtmp,itmp,k,jj)-ges_prsi(jtmp,itmp,k+1,jj))*& + tpwcon * r10 + end do !igx + end do !jgy + end do !j + end do !i + end do !k + end do !jj + +! compute FED, in flashes/min + do jj=1,nfldsig + do i=1,lon2 + do j=1,lat2 + if (fed_obs_ob_shape .eq. 1) then + rp(j,i,jj) = CM * glmcoeff * rp(j,i,jj) + else if (fed_obs_ob_shape .eq. 2) then + rp(j,i,jj) = a_coeff + b_coeff & + * tanh(c_coeff * (rp(j,i,jj) - d_coeff)) + else + write(6,*) ' unknown fed_obs_ob_shape: ', fed_obs_ob_shape + write(6,*) ' aborting setupfed' + call stop2(999) + end if + if (rp(j,i,jj) .gt. fed_highbnd) rp(j,i,jj) = fed_highbnd + end do !j + end do !i + end do !jj + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + write(6,*) 'fed_obs_ob_shape=',fed_obs_ob_shape + if (fed_obs_ob_shape .eq. 2) then + write(6,*) 'a_coeff=',a_coeff + write(6,*) 'b_coeff=',b_coeff + write(6,*) 'c_coeff=',c_coeff + write(6,*) 'd_coeff=',d_coeff + end if + write(6,*) 'fed_highbnd=',fed_highbnd + write(6,*) 'maxval(ges_qg)=',maxval(ges_qg),'pe=',mype + + + !============================================================================================ + + nlat_ll=size(ges_qg,1) + nlon_ll=size(ges_qg,2) + nsig_ll=size(ges_qg,3) + nfld_ll=size(ges_qg,4) + + +! - Observation times are checked in read routine - comment out for now + +! call dtime_setup() + +!print*,"maxval(data(ifedob,:)),mmaxval(data(ilat,:))=",minval(data(ifedob,:)),maxval(data(ifedob,:)),maxval(data(ilat,:)) +!write(6,*) "OKOKOKOKOK, nobs=", nobs + do i=1,nobs + dtime=data(itime,i) + dlat=data(ilat,i) + dlon=data(ilon,i) + + dlon8km=data(iprvd,i) !iprvd=23 + dlat8km=data(isprvd,i) !isprvd=24 + + dpres=data(ipres,i) ! from rdararef_mosaic2: this height abv MSL + ikx = nint(data(ikxx,i)) + error=data(ier2,i) + slat=data(ilate,i)*deg2rad ! needed when converting geophgt to + dlon_earth = data(ilone,i) !the lontitude and latitude on the obs pts. + dlat_earth = data(ilate,i) + ! geometric hgh (hges --> zges below) + + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + end if + + IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + + if (luse_obsdiag) my_diagLL => odiagLL(ibin) + +! Link obs to diagnostics structure + if(luse_obsdiag)then + my_diag => obsdiagLList_nextNode(my_diagLL ,& + create = .not.lobsdiag_allocated ,& + idv = is ,& + iob = ioid(i) ,& + ich = 1 ,& + elat = data(ilate,i) ,& + elon = data(ilone,i) ,& + luse = luse(i) ,& + miter = miter ) + if(.not.associated(my_diag)) call die(myname, & + 'obsdiagLList_nextNode(), create =',.not.lobsdiag_allocated) + end if + +! Interpolate terrain height(model elevation) to obs location. + call tintrp2a11(ges_z,zsges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) +! print*,'i,after tintrp2all',i,mype,dlat,zsges +! 1. dpres (MRMS obs height is height above MSL) is adjusted by zsges, so it +! is changed to height relative to model elevation (terrain). +! because in GSI, geop_hgtl is the height relative to terrain (ges_z) +! (subroutine guess_grids) + dpres=dpres-zsges + if (dpres rsig)ratio_errors = zero + +!----------------------------------------------------------------------------! +! ! +! Implementation of forward operator for flash extend densit ----------------! +! ! +!----------------------------------------------------------------------------! + + !============================================================================================ + ! 3) H(x), interpolate the FED from model space on the local domain to obs space (FEDMdiag) + !============================================================================================ + + npt = 0 + FEDMdiag(i) = 0. + call tintrp2a11(rp,FEDMdiag(i),dlat,dlon,dtime,hrdifsig,mype,nfldsig) + dlonobs(i) = dlon_earth + dlatobs(i) = dlat_earth + + ! also Jacobian used for TLM and ADM + !FEDMdiagTL, used for gsi-3dvar,will be implemented in future...... + FEDMdiagTL(i) = 0. + jqg_num = FEDMdiagTL(i) !=dFED/Dqg + jqg = jqg_num + + + !end select + + if(FEDMdiag(i)==data(ifedob,i)) then + numequal=numequal+1 + else + numnotequal=numnotequal+1 + end if + +!!!!!!!!!!!!!!!!!END H(x)!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! Compute innovations + !--------------Calculate departure from observation----------------! + + ddiff = data(ifedob,i) - FEDMdiag(i) + +! If requested, setup for single obs test. +! Note: do not use this way to run single obs test for fed in the current version. (g.zhao) + if (oneobtest) then + ddiff=maginnov +! if (trim(adjustl(oneob_type))=='fed') then +! data(ifedob,i) = maginnov +! ddiff = data(ifedob,i) - FEDMdiag(i) +! end if + error=one/(magoberr) + ratio_errors=one + end if + + +! Gross error checks + obserror = one/max(ratio_errors*error,tiny_r_kind) + obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) + + residual = abs(ddiff) != y-H(xb) + ratio = residual/obserrlm != y-H(xb)/sqrt(R) + + if (l_set_oerr_ratio_fed) then + if (ratio > cgross(ikx) .or. ratio_errors < tiny_r_kind) then + if (luse(i)) awork(4) = awork(4)+one + error = zero + ratio_errors = zero + end if + else + ratio_errors = one + end if + + if (ratio_errors*error <=tiny_r_kind) muse(i)=.false. +! if (nobskeep>0 .and. luse_obsdiag) muse(i)=obsdiags(i_fed_ob_type,ibin)%tail%muse(nobskeep) + if (nobskeep>0.and.luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i)) + + val = error*ddiff !=y-H(xb)/sqrt(R) + +! Compute penalty terms (linear & nonlinear qc). + if(luse(i))then + exp_arg = -half*val**2 + rat_err2 = ratio_errors**2 + val2=val*val !(o-g)**2/R, would be saved in awork + if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then + arg = exp(exp_arg) + wnotgross= one-cvar_pg(ikx) + cg_w=cvar_b(ikx) + wgross = cg_term*cvar_pg(ikx)/(cg_w*wnotgross) + term = log((arg+wgross)/(one+wgross)) + wgt = one-wgross/(arg+wgross) + rwgt = wgt/wgtlim + else + term = exp_arg + wgt = wgtlim + rwgt = wgt/wgtlim + end if + valqc = -two*rat_err2*term + +! print*,'Compute penalty terms' +! Accumulate statistics for obs belonging to this task + if (muse(i)) then + if(rwgt < one) awork(21) = awork(21)+one + jsig = dpres + jsig=max(1,min(jsig,nsig)) + awork(6*nsig+jsig+100)=awork(6*nsig+jsig+100)+val2*rat_err2 + awork(5*nsig+jsig+100)=awork(5*nsig+jsig+100)+one + awork(3*nsig+jsig+100)=awork(3*nsig+jsig+100)+valqc + end if +! Loop over pressure level groupings and obs to accumulate +! statistics as a function of observation type. + ress = scale*ddiff + ressw = ress*ress + nn=1 + if (.not. muse(i)) then + nn=2 + if(ratio_errors*error >=tiny_r_kind)nn=3 + end if + do k = 1,npres_print +! if(presw >=ptop(k) .and. presw<=pbot(k))then + if(presq >=ptopq(k) .and. presq<=pbotq(k))then + bwork(k,ikx,1,nn) = bwork(k,ikx,1,nn)+one ! count + bwork(k,ikx,2,nn) = bwork(k,ikx,2,nn)+ddiff ! bias + bwork(k,ikx,3,nn) = bwork(k,ikx,3,nn)+ressw ! (o-g)**2 + bwork(k,ikx,4,nn) = bwork(k,ikx,4,nn)+val2*rat_err2 ! penalty + bwork(k,ikx,5,nn) = bwork(k,ikx,5,nn)+valqc ! nonlin qc penalty + + end if + end do + end if + + if(luse_obsdiag)then + call obsdiagNode_set(my_diag, luse=luse(i), wgtjo=(error*ratio_errors)**2, & + jiter=jiter, muse=muse(i), nldepart=ddiff) + end if + +! 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 + + allocate(my_head) ! YPW added + call fedNode_appendto(my_head,fedhead(ibin)) + + my_head%idv=is + my_head%iob=i + my_head%elat= data(ilate,i) + my_head%elon= data(ilone,i) + + my_head%dlev= dpres + call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij) + my_head%res = ddiff ! Observation - ges + my_head%err2 = error**2 + my_head%raterr2 = ratio_errors**2 + my_head%time = dtime + my_head%b = cvar_b(ikx) + my_head%pg = cvar_pg(ikx) + my_head%luse = luse(i) + + if(oberror_tune) then + ! my_head%fedpertb=data(iptrb,i)/error/ratio_errors + my_head%kx=ikx + if(presq > ptabl(2))then + my_head%k1=1 + else if( presq <= ptabl(33)) then + my_head%k1=33 + else + k_loop: do k=2,32 + if(presq > ptabl(k+1) .and. presq <= ptabl(k)) then + my_head%k1=k + exit k_loop + end if + end do k_loop + end if + end if +!------------------------------------------------- + + 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 + end if + + my_head => null() + end if + +! Save select output for diagnostic file + if(.not.luse(i))write(6,*)' luse, mype',luse(i),mype + if(fed_diagsave .and. luse(i))then + ii=ii+1 + rstation_id = data(id,i) + err_input = data(ier2,i) + err_adjst = data(ier,i) + if (ratio_errors*error>tiny_r_kind) then + err_final = one/(ratio_errors*error) + else + err_final = huge_single + end if + errinv_input = huge_single + errinv_adjst = huge_single + errinv_final = huge_single + if (err_input>tiny_r_kind) errinv_input = one/err_input + if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst + if (err_final>tiny_r_kind) errinv_final = one/err_final + + if(binary_diag) call contents_binary_diag_(my_diag) + if(netcdf_diag) call contents_netcdf_diag_(my_diag) + + end if + end do + +! Release memory of local guess arrays + call final_vars_ + +! Write information to diagnostic file + if(fed_diagsave .and. netcdf_diag) call nc_diag_write + if(fed_diagsave .and. binary_diag .and. ii>0)then + + write(string,600) jiter +600 format('fed_',i2.2) + diag_file=trim(dirname) // trim(string) + if(init_pass) then + open(66,file=trim(diag_file),form='unformatted',status='unknown',position='rewind') + else + inquire(file=trim(diag_file),exist=diagexist) + if (diagexist) then + open(66,file=trim(diag_file),form='unformatted',status='old',position='append') + else + open(66,file=trim(diag_file),form='unformatted',status='unknown',position='rewind') + end if + end if + if(init_pass .and. mype == 0) then + write(66) ianldate + write(6,*)'SETUPFED: write time record to file ',& + trim(diag_file), ' ',ianldate + end if + +! call dtime_show(myname,'diagsave:fed',i_fed_ob_type) + write(66)'fed',nchar,nreal,ii,mype,ioff0 + write(66)cdiagbuf(1:ii),rdiagbuf(:,1:ii) + ! write(6,*)'fed,nchar,nreal,ii,mype',nchar,nreal,ii,mype + deallocate(cdiagbuf,rdiagbuf) + close(66) + end if + +! End of routine + + +! return + + contains + + subroutine check_vars_ (proceed) + + + logical,intent(inout) :: proceed + integer(i_kind) ivar, istatus +! Check to see if required guess fields are available + call gsi_metguess_get ('var::ps', ivar, istatus ) + proceed=ivar>0 + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::q' , ivar, istatus ) + proceed=proceed.and.ivar>0 +! call gsi_metguess_get ('var::tv' , ivar, istatus ) +! proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::qs', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::qg', ivar, istatus ) + proceed=proceed.and.ivar>0 + call gsi_metguess_get ('var::qr', ivar, istatus ) + proceed=proceed.and.ivar>0 + end subroutine check_vars_ + + + subroutine init_vars_ + +! use radaremul_cst, only: mphyopt + + real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() + real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() + character(len=5) :: varname + integer(i_kind) ifld, istatus + +! If require guess vars available, extract from bundle ... + if(size(gsi_metguess_bundle)==nfldsig) then +! get ps ... + varname='ps' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_ps))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + end if + allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig)) + ges_ps(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_ps(:,:,ifld)=rank2 + end do + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + end if +! get z ... + varname='z' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) + if (istatus==0) then + if(allocated(ges_z))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + end if + allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig)) + ges_z(:,:,1)=rank2 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) + ges_z(:,:,ifld)=rank2 + end do + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + end if +! get q ... + varname='q' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_q))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + end if + allocate(ges_q(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_q(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_q(:,:,:,ifld)=rank3 + end do + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + end if +! get tv ... +! varname='tv' +! call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) +! if (istatus==0) then +! if(allocated(ges_tv))then +! write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' +! call stop2(999) +! end if +! allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) +! ges_tv(:,:,:,1)=rank3 +! do ifld=2,nfldsig +! call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) +! ges_tv(:,:,:,ifld)=rank3 +! ges_tv(:,:,:,ifld)=rank3 +! end do +! else +! write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus +! call stop2(999) +! end if +! get qr ... +! get qg ... + varname='qg' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_qg))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + end if + allocate(ges_qg(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + if(.not. allocated(ges_qg_mask))then + allocate(ges_qg_mask(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + end if + + ges_qg(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_qg(:,:,:,ifld)=rank3 + end do + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + end if + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + end if + end subroutine init_vars_ + + subroutine init_netcdf_diag_ + character(len=80) string + character(len=128) diag_conv_file + integer(i_kind) ncd_fileid,ncd_nobs + logical append_diag + logical,parameter::verbose=.false. + write(string,900) jiter +900 format('conv_fed_',i2.2,'.nc4') + diag_conv_file=trim(dirname) // trim(string) + + inquire(file=diag_conv_file, exist=append_diag) + + if (append_diag) then + call nc_diag_read_init(diag_conv_file,ncd_fileid) + ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs') + call nc_diag_read_close(diag_conv_file) + + if (ncd_nobs > 0) then + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype + else + if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype + append_diag = .false. ! if there are no obs in existing file, then do not try to append + end if + end if + + call nc_diag_init(diag_conv_file, append=append_diag) + + if (.not. append_diag) then ! don't write headers on append - the module will break? + call nc_diag_header("date_time",ianldate ) + call nc_diag_header("Number_of_state_vars", nsdim ) + end if + end subroutine init_netcdf_diag_ + subroutine contents_binary_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag + + cdiagbuf(ii) = station_id ! station id + + rdiagbuf(1,ii) = ictype(ikx) ! observation type + rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype + + rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees) + rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees) + + rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) + rdiagbuf(6,ii) = presq ! observation pressure (hPa) + rdiagbuf(7,ii) = fed_height ! observation height (meters) + rdiagbuf(8,ii) = (dtime*r60)-time_offset ! obs time (sec relative to analysis time) + rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark + rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark + rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag + if(muse(i)) then + rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) + else + rdiagbuf(12,ii) = -one + end if + + rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight + rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (dBZ)**-1 + rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (dBZ)**-1 + rdiagbuf(16,ii) = errinv_final ! final inverse observation error (dBZ)**-1 + rdiagbuf(17,ii) = data(ifedob,i) ! radar reflectivity observation (dBZ) + rdiagbuf(18,ii) = ddiff ! obs-ges (dBZ) + rdiagbuf(19,ii) = data(ifedob,i)-FEDMdiag(i) ! obs-ges w/o bias correction (dBZ) (future slot) + rdiagbuf(20,ii) = dlat8km ! j-index on 8km bufr obs grid + rdiagbuf(21,ii) = dlon8km ! i-index on 8km bufr obs grid + +! print*,'data(ilat,i)=',data(ilat,i),'data(ilon,i)=',data(ilon,i) + + rdiagbuf(22,ii) = FEDMdiag(i) ! dBZ from rain water + + rdiagbuf(23,ii) = T1D ! temperature (sensible, K) + rdiagbuf(24,ii) = RHO ! air density (kg/m**3) + + if (lobsdiagsave) then + write(6,*)'wrong here, stop in setupfed.f90 ' + stop + ioff=nreal + do jj=1,miter + ioff=ioff+1 + if (odiag%muse(jj)) then + rdiagbuf(ioff,ii) = one + else + rdiagbuf(ioff,ii) = -one + end if + end do + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + end do + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + end do + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + end do + end if + + end subroutine contents_binary_diag_ + subroutine contents_netcdf_diag_(odiag) + type(obs_diag),pointer,intent(in):: odiag +! Observation class + character(7),parameter :: obsclass = ' fed' + real(r_kind),dimension(miter) :: obsdiag_iuse + call nc_diag_metadata("Station_ID", station_id ) + call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Observation_Type", ictype(ikx) ) + call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) + call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) + call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) + call nc_diag_metadata("Pressure", sngl(presq) ) + call nc_diag_metadata("Height", sngl(fed_height) ) + call nc_diag_metadata("Time", sngl(dtime*r60-time_offset)) + call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) + call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) +! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ! ) + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + if(muse(i)) then + call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + else + call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + end if + + call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) + call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) + call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + + call nc_diag_metadata("Observation", sngl(data(ifedob,i)) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(data(ifedob,i)-FEDMdiag(i)) ) + if (lobsdiagsave) then + do jj=1,miter + if (odiag%muse(jj)) then + obsdiag_iuse(jj) = one + else + obsdiag_iuse(jj) = -one + end if + end do + + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) + call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) + call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) + call nc_diag_data2d("ObsDiagSave_obssen" , odiag%obssen ) + end if + + end subroutine contents_netcdf_diag_ + + subroutine final_vars_ + if(allocated(ges_z )) deallocate(ges_z ) + if(allocated(ges_q )) deallocate(ges_q ) +! if(allocated(ges_tv)) deallocate(ges_tv) + if(allocated(ges_ps)) deallocate(ges_ps) + if(allocated(ges_qg)) deallocate(ges_qg) + end subroutine final_vars_ + + subroutine init_qcld(t_cld, qxmin_cld, icat_cld, t_dpnd) + use kinds, only: r_kind,r_single,r_double,i_kind + implicit none + real(r_kind), intent(in ) :: t_cld + real(r_kind), intent(inout) :: qxmin_cld + integer, intent(in ) :: icat_cld + logical, intent(in ) :: t_dpnd +! +! local variables + real :: tr_ll, qrmin_ll, tr_hl, qrmin_hl + real :: ts_ll, qsmin_ll, ts_hl, qsmin_hl + real :: tg_ll, qgmin_ll, tg_hl, qgmin_hl + real :: qr_min, qs_min, qg_min +!------------------------------------------------------ + + qr_min = 5.0E-6_r_kind + qs_min = 5.0E-6_r_kind + qg_min = 5.0E-6_r_kind + tr_ll = 275.65; qrmin_ll = 5.0E-6_r_kind; + tr_hl = 270.65; qrmin_hl = 1.0E-8_r_kind; + ts_ll = 275.65; qsmin_ll = 1.0E-8_r_kind; + ts_hl = 270.65; qsmin_hl = 5.0E-6_r_kind; + tg_ll = 275.65; qgmin_ll = 1.0E-6_r_kind; + tg_hl = 270.65; qgmin_hl = 5.0E-6_r_kind; + + select case (icat_cld) + case (1) + if ( t_dpnd ) then + if (t_cld <= tr_hl) then + qxmin_cld = qrmin_hl + else if (t_cld >= tr_ll) then + qxmin_cld = qrmin_ll + else + qxmin_cld = (qrmin_hl + qrmin_ll) * 0.5 + end if + else + qxmin_cld = qr_min + end if + case default + write(6,*) 'wrong cloud hydrometer category ID',icat_cld + end select + + return + + end subroutine init_qcld + +end subroutine setupfed +end module fed_setup diff --git a/src/gsi/setuprhsall.f90 b/src/gsi/setuprhsall.f90 index 3efcb69859..8075956431 100644 --- a/src/gsi/setuprhsall.f90 +++ b/src/gsi/setuprhsall.f90 @@ -168,6 +168,7 @@ subroutine setuprhsall(ndata,mype,init_pass,last_pass) i_gust,i_vis,i_pblh,i_wspd10m,i_td2m,i_mxtm,i_mitm,i_pmsl,i_howv, & i_tcamt,i_lcbas,i_cldch,i_uwnd10m,i_vwnd10m,i_swcp,i_lwcp use m_rhs, only: i_dbz + use m_rhs, only: i_fed use m_rhs, only: i_light use m_gpsStats, only: gpsStats_genstats ! was genstats_gps() @@ -625,7 +626,7 @@ subroutine setuprhsall(ndata,mype,init_pass,last_pass) call statsconv(mype,& i_ps,i_uv,i_t,i_q,i_pw,i_rw,i_dw,i_gps,i_sst,i_tcp,i_lag, & i_gust,i_vis,i_pblh,i_wspd10m,i_td2m,i_mxtm,i_mitm,i_pmsl,i_howv, & - i_tcamt,i_lcbas,i_cldch,i_uwnd10m,i_vwnd10m,i_swcp,i_lwcp,i_dbz, & + i_tcamt,i_lcbas,i_cldch,i_uwnd10m,i_vwnd10m,i_swcp,i_lwcp,i_fed,i_dbz, & size(awork1,2),bwork1,awork1,ndata) ! Compute and print statistics for "lightning" data diff --git a/src/gsi/statsconv.f90 b/src/gsi/statsconv.f90 index a01675d8d0..0da8606f24 100644 --- a/src/gsi/statsconv.f90 +++ b/src/gsi/statsconv.f90 @@ -2,7 +2,7 @@ subroutine statsconv(mype,& i_ps,i_uv,i_t,i_q,i_pw,i_rw,i_dw,i_gps,i_sst,i_tcp,i_lag, & i_gust,i_vis,i_pblh,i_wspd10m,i_td2m,i_mxtm,i_mitm,i_pmsl,i_howv, & i_tcamt,i_lcbas,i_cldch,i_uwnd10m,i_vwnd10m,& - i_swcp,i_lwcp,i_dbz,i_ref,bwork,awork,ndata) + i_swcp,i_lwcp,i_fed,i_dbz,i_ref,bwork,awork,ndata) !$$$ subprogram documentation block ! . . . . ! subprogram: statconv prints statistics for conventional data @@ -74,6 +74,7 @@ subroutine statsconv(mype,& ! i_vwnd10m- index in awork array holding vwnd10m info ! i_swcp - index in awork array holding swcp info ! i_lwcp - index in awork array holding lwcp info +! i_fed - index in awork array holding fed info ! i_dbz - index in awork array holding dbz info ! i_ref - size of second dimension of awork array ! bwork - array containing information for statistics @@ -96,12 +97,12 @@ subroutine statsconv(mype,& iout_gust,iout_vis,iout_pblh,iout_wspd10m,iout_td2m,& iout_mxtm,iout_mitm,iout_pmsl,iout_howv,iout_tcamt,iout_lcbas,iout_cldch,& iout_uwnd10m,iout_vwnd10m,& - iout_dbz,iout_swcp,iout_lwcp,& + iout_fed,iout_dbz,iout_swcp,iout_lwcp,& mype_dw,mype_rw,mype_sst,mype_gps,mype_uv,mype_ps,& mype_t,mype_pw,mype_q,mype_tcp,ndat,dtype,mype_lag,mype_gust,& mype_vis,mype_pblh,mype_wspd10m,mype_td2m,mype_mxtm,mype_mitm,& mype_pmsl,mype_howv,mype_tcamt,mype_lcbas,mype_cldch,mype_uwnd10m,mype_vwnd10m,& - mype_dbz,mype_swcp,mype_lwcp + mype_fed,mype_dbz,mype_swcp,mype_lwcp use qcmod, only: npres_print,ptop,pbot,ptopq,pbotq use jfunc, only: first,jiter use gridmod, only: nsig @@ -112,7 +113,7 @@ subroutine statsconv(mype,& integer(i_kind) ,intent(in ) :: mype,i_ps,i_uv,& i_t,i_q,i_pw,i_rw,i_dw,i_gps,i_sst,i_tcp,i_lag,i_gust,i_vis,i_pblh,& i_wspd10m,i_td2m,i_mxtm,i_mitm,i_pmsl,i_howv,i_tcamt,i_lcbas,& - i_cldch,i_uwnd10m,i_vwnd10m,i_swcp,i_lwcp,i_dbz,i_ref + i_cldch,i_uwnd10m,i_vwnd10m,i_swcp,i_lwcp,i_fed,i_dbz,i_ref real(r_kind),dimension(7*nsig+100,i_ref) ,intent(in ) :: awork real(r_kind),dimension(npres_print,nconvtype,5,3),intent(in ) :: bwork integer(i_kind),dimension(ndat,3) ,intent(in ) :: ndata @@ -136,6 +137,7 @@ subroutine statsconv(mype,& real(r_kind) dwqcplty,tqcplty,qctt,qctrw,rwqcplty,qctdw,qqcplty,qctgps real(r_kind) gpsqcplty,tpw3,pw3,qctq real(r_kind) tswcp3,tlwcp3,qctdbz,dbzqcplty + real(r_kind) fedmplty,tfed,qctfed,fedqcplty real(r_kind),dimension(1):: pbotall,ptopall logical,dimension(nconvtype):: pflag @@ -1325,6 +1327,68 @@ subroutine statsconv(mype,& end if end if +! Summary report for flash extent density + if(mype==mype_fed) then + nread=0 + nkeep=0 + do i=1,ndat + if(dtype(i)== 'fed')then + nread=nread+ndata(i,2) + nkeep=nkeep+ndata(i,3) + end if + end do + if(nread > 0)then + if(first)then + open(iout_fed) + else + open(iout_fed,position='append') + end if + + fedmplty=zero; fedqcplty=zero ; ntot=0 + tfed=zero ; qctfed=zero + if(nkeep > 0)then + mesage='current vfit of flash extent density, ranges in flashes per minute$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'fed' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_fed,pflag) + + numgross=nint(awork(4,i_fed)) + numfailqc=nint(awork(21,i_fed)) + do k=1,nsig + num(k)=nint(awork(k+5*nsig+100,i_fed)) + rat=zero + rat3=zero + if(num(k) > 0) then + rat=awork(6*nsig+k+100,i_fed)/float(num(k)) + rat3=awork(3*nsig+k+100,i_fed)/float(num(k)) + end if + ntot=ntot+num(k) + fedmplty=fedmplty+awork(6*nsig+k+100,i_fed) + fedqcplty=fedqcplty+awork(3*nsig+k+100,i_fed) + write(iout_fed,240) 'r',num(k),k,awork(6*nsig+k+100,i_fed), & + awork(3*nsig+k+100,i_fed),rat,rat3 + end do + if(ntot > 0) then + tfed=fedmplty/float(ntot) + qctfed=fedqcplty/float(ntot) + end if + write(iout_fed,925) 'fed',numgross,numfailqc + numlow = nint(awork(2,i_fed)) + numhgh = nint(awork(3,i_fed)) + nhitopo = nint(awork(5,i_fed)) + ntoodif = nint(awork(6,i_fed)) + write(iout_fed,900) 'fed',numhgh,numlow + write(iout_fed,905) 'fed',nhitopo,ntoodif + end if + write(iout_fed,950) 'fed',jiter,nread,nkeep,ntot + write(iout_fed,951) 'fed',fedmplty,fedqcplty,tfed,qctfed + + close(iout_fed) + end if + end if + + if(mype==mype_tcp) then nread=0 nkeep=0 From a6515bd8f429aea987a572a5de8a073801d566c4 Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Tue, 12 Sep 2023 08:45:06 -0400 Subject: [PATCH 024/109] add missing jacobian arrays to netcdf ozone diagnostic file (#618) (#619) **Description** PR #591 removed jacobian information from the netcdf ozone diagnostic file. This caused `enkf.x` to crash. This PR adds the removed ozone jacobian arrays back to the netcdf ozone diagnostic file. Fixes #618 **Type of change** - [x] Bug fix (non-breaking change which fixes an issue) **How Has This Been Tested?** The revised code was tested in the 20210814 18 gdas cycle of a C192L127 enkf parallel. The updated `gsi.x` created an oznstat file which was successfully processed by `enkf.x`. **Checklist** - [x] My code follows the style guidelines of this project - [x] I have performed a self-review of my own code - [x] New and existing tests pass with my changes --- src/gsi/setupoz.f90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/gsi/setupoz.f90 b/src/gsi/setupoz.f90 index 2008f37559..34f94d3a10 100644 --- a/src/gsi/setupoz.f90 +++ b/src/gsi/setupoz.f90 @@ -636,8 +636,9 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& call nc_diag_metadata("Row_Anomaly_Index", sngl(rmiss) ) endif if (save_jacobian) then - call fullarray(dhx_dx, dhx_dx_array) - call nc_diag_data2d("Observation_Operator_Jacobian", dhx_dx_array) + call nc_diag_data2d("Observation_Operator_Jacobian_stind", dhx_dx%st_ind) + call nc_diag_data2d("Observation_Operator_Jacobian_endind", dhx_dx%end_ind) + call nc_diag_data2d("Observation_Operator_Jacobian_val", real(dhx_dx%val,r_single)) endif !if (wrtgeovals) then ! call nc_diag_data2d("mole_fraction_of_ozone_in_air", sngl(constoz*ozgestmp)) From c46f5900233122c15f47428b6ee714c66b4a08b4 Mon Sep 17 00:00:00 2001 From: Ming Hu Date: Tue, 12 Sep 2023 14:25:40 -0400 Subject: [PATCH 025/109] Update intel compile to Intel2022 (#571) * caveat - the wcoss2 build remains at intel/19 --------- Co-authored-by: David Huber Co-authored-by: Natalie Perlin Co-authored-by: RussTreadon-NOAA --- ci/spack.yaml | 4 +- modulefiles/gsi_cheyenne.gnu.lua | 20 +- modulefiles/gsi_cheyenne.intel.lua | 6 +- modulefiles/gsi_common.lua | 7 +- modulefiles/gsi_gaea | 62 -- modulefiles/gsi_gaea.lua | 34 ++ modulefiles/gsi_hera.gnu.lua | 12 +- modulefiles/gsi_hera.intel.lua | 17 +- modulefiles/gsi_jet.lua | 15 +- modulefiles/gsi_orion.lua | 14 +- modulefiles/gsi_s4.lua | 6 +- regression/regression_driver.sh | 2 + regression/regression_param.sh | 71 ++- regression/regression_var.sh | 25 +- src/enkf/observer_gfs.f90 | 15 +- src/gsi/ensctl2state.f90 | 9 +- src/gsi/ensctl2state_ad.f90 | 9 +- src/gsi/general_read_fv3atm.f90 | 1 + src/gsi/genstats_gps.f90 | 44 +- src/gsi/gsi_rfv3io_mod.f90 | 932 ++++++++++++++++------------- src/gsi/gsimod.F90 | 2 +- src/gsi/guess_grids.F90 | 48 +- src/gsi/mpeu_util.F90 | 16 - src/gsi/obsmod.F90 | 36 +- src/gsi/read_files.f90 | 2 +- src/gsi/read_iasi.f90 | 2 + src/gsi/read_obs.F90 | 4 - src/gsi/read_prepbufr.f90 | 66 +- src/gsi/read_radar.f90 | 2 +- src/gsi/setupaod.f90 | 21 +- src/gsi/setupdbz.f90 | 36 +- src/gsi/setupdw.f90 | 32 +- src/gsi/setuplight.f90 | 32 +- src/gsi/setuplwcp.f90 | 38 +- src/gsi/setupoz.f90 | 73 +-- src/gsi/setupps.f90 | 41 +- src/gsi/setuppw.f90 | 32 +- src/gsi/setupq.f90 | 90 +-- src/gsi/setuprad.f90 | 163 ++--- src/gsi/setuprw.f90 | 44 +- src/gsi/setupspd.f90 | 36 +- src/gsi/setupsst.f90 | 42 +- src/gsi/setupswcp.f90 | 34 +- src/gsi/setupt.f90 | 76 +-- src/gsi/setuptcp.f90 | 28 +- src/gsi/setupw.f90 | 56 +- src/gsi/stpcalc.f90 | 22 +- ush/build.sh | 1 - ush/detect_machine.sh | 3 +- ush/module-setup.sh | 29 +- ush/sub_cheyenne | 169 ++++++ ush/sub_discover | 2 +- ush/sub_gaea | 170 ++++++ ush/sub_hera | 2 +- ush/sub_jet | 52 +- ush/sub_orion | 2 +- ush/sub_wcoss2 | 21 +- 57 files changed, 1658 insertions(+), 1172 deletions(-) delete mode 100644 modulefiles/gsi_gaea create mode 100644 modulefiles/gsi_gaea.lua create mode 100644 ush/sub_cheyenne create mode 100755 ush/sub_gaea diff --git a/ci/spack.yaml b/ci/spack.yaml index a831de16ad..0fc66547e5 100644 --- a/ci/spack.yaml +++ b/ci/spack.yaml @@ -15,11 +15,11 @@ spack: - ip@3.3.3 - sigio@2.3.2 - sfcio@1.4.1 - - nemsio@2.5.2 + - nemsio@2.5.4 - wrf-io@1.2.0 - ncio@1.1.2 - crtm@2.4.0 - - gsi-ncdiag@1.0.0 + - gsi-ncdiag@1.1.1 view: true concretizer: unify: true diff --git a/modulefiles/gsi_cheyenne.gnu.lua b/modulefiles/gsi_cheyenne.gnu.lua index 494ec6fb18..43e6aaf02c 100644 --- a/modulefiles/gsi_cheyenne.gnu.lua +++ b/modulefiles/gsi_cheyenne.gnu.lua @@ -4,26 +4,24 @@ help([[ load("cmake/3.22.0") load("python/3.7.9") load("ncarenv/1.3") -load("gnu/10.1.0") -load("mpt/2.22") +load("gnu/11.2.0") +load("mpt/2.25") load("ncarcompilers/0.5.0") +unload("intel") unload("netcdf") -prepend_path("MODULEPATH", "/glade/work/epicufsrt/GMTB/tools/gnu/10.1.0/hpc-stack-v1.2.0/modulefiles/stack") +prepend_path("MODULEPATH", "/glade/work/epicufsrt/contrib/hpc-stack/gnu11.2.0/modulefiles/stack") load("hpc/1.2.0") -load("hpc-gnu/10.1.0") -load("hpc-mpt/2.22") - --- Preload w3nco to work around nemsio "find_dependency(w3nco)" hpc-stack bug -load("w3nco/2.4.1") +load("hpc-gnu/11.2.0") +load("hpc-mpt/2.25") load("gsi_common") -local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" -load(pathJoin("prod_util", prod_util_ver)) +load(pathJoin("prod_util", os.getenv("prod_util_ver") or "1.2.2")) +load(pathJoin("openblas", os.getenv("openblas_ver") or "0.3.23")) -pushenv("MKLROOT", "/glade/u/apps/opt/intel/2022.1/mkl/latest") +pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_fix/fix") pushenv("CC", "mpicc") pushenv("FC", "mpif90") diff --git a/modulefiles/gsi_cheyenne.intel.lua b/modulefiles/gsi_cheyenne.intel.lua index 72bf458516..4a3525bca1 100644 --- a/modulefiles/gsi_cheyenne.intel.lua +++ b/modulefiles/gsi_cheyenne.intel.lua @@ -8,7 +8,7 @@ load("intel/2022.1") load("mpt/2.25") load("ncarcompilers/0.5.0") -prepend_path("MODULEPATH", "/glade/work/epicufsrt/GMTB/tools/intel/2022.1/hpc-stack-v1.2.0_6eb6/modulefiles/stack") +prepend_path("MODULEPATH", "/glade/work/epicufsrt/contrib/hpc-stack/intel2022.1/modulefiles/stack") load("hpc/1.2.0") load("hpc-intel/2022.1") @@ -17,8 +17,8 @@ load("mkl/2022.1") load("gsi_common") -local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" -load(pathJoin("prod_util", prod_util_ver)) +load(pathJoin("prod_util", os.getenv("prod_util_ver") or "1.2.2")) +pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_data/fix/20230601") pushenv("CFLAGS", "-xHOST") pushenv("FFLAGS", "-xHOST") diff --git a/modulefiles/gsi_common.lua b/modulefiles/gsi_common.lua index b2b08f1197..c54f6ddb92 100644 --- a/modulefiles/gsi_common.lua +++ b/modulefiles/gsi_common.lua @@ -6,16 +6,16 @@ local netcdf_ver=os.getenv("netcdf_ver") or "4.7.4" local bufr_ver=os.getenv("bufr_ver") or "11.7.0" local bacio_ver=os.getenv("bacio_ver") or "2.4.1" -local w3emc_ver=os.getenv("w3emc_ver") or "2.9.1" +local w3emc_ver=os.getenv("w3emc_ver") or "2.9.2" local sp_ver=os.getenv("sp_ver") or "2.3.3" local ip_ver=os.getenv("ip_ver") or "3.3.3" local sigio_ver=os.getenv("sigio_ver") or "2.3.2" local sfcio_ver=os.getenv("sfcio_ver") or "1.4.1" -local nemsio_ver=os.getenv("nemsio_ver") or "2.5.2" +local nemsio_ver=os.getenv("nemsio_ver") or "2.5.4" local wrf_io_ver=os.getenv("wrf_io_ver") or "1.2.0" local ncio_ver=os.getenv("ncio_ver") or "1.1.2" local crtm_ver=os.getenv("crtm_ver") or "2.4.0" -local ncdiag_ver=os.getenv("ncdiag_ver") or "1.0.0" +local ncdiag_ver=os.getenv("ncdiag_ver") or "1.1.1" load(pathJoin("netcdf", netcdf_ver)) @@ -31,4 +31,3 @@ load(pathJoin("wrf_io", wrf_io_ver)) load(pathJoin("ncio", ncio_ver)) load(pathJoin("crtm", crtm_ver)) load(pathJoin("ncdiag",ncdiag_ver)) - diff --git a/modulefiles/gsi_gaea b/modulefiles/gsi_gaea deleted file mode 100644 index 641f3d0fcf..0000000000 --- a/modulefiles/gsi_gaea +++ /dev/null @@ -1,62 +0,0 @@ -#%Module1.0 -###################################################################### -## NOAA-EMC/GSI -##_____________________________________________________ -proc ModulesHelp { } { -puts stderr "Set environment variables for NOAA-EMC/GSI" -puts stderr "This module initializes the environment " -puts stderr "for the Intel Compiler Suite $version\n" -} -module-whatis " NOAA-EMC/GSI whatis description" - -set COMPILER intel - -setenv FFLAGS_COM "-fp-model strict" -setenv LDFLAGS_COM " " - -#set WRF_SHARED_VER v1.1.0 -#set WRF_SHARED_ROOT /gpfs/hps/nco/ops/nwprod/wrf_shared -#set WRF_SHARED_ROOT /lustre/f1/pdata/ncep_shared/NCEPLIBS/lib/EXTERNAL/wrf_shared -#setenv WRF_SHARED_PATH ${WRF_SHARED_ROOT}.${WRF_SHARED_VER} - -setenv NCEPLIBS /lustre/f1/pdata/ncep_shared/NCEPLIBS/lib - -# Loading ncep environment -##module load ncep/1.0 -module use /opt/cray/pe/craype/2.5.5/modulefiles - -# Loading Intel Compiler Suite -module load PrgEnv-intel - -# Loading pe environment -module load cray-mpich -module load cray-libsci -module unload craype-broadwell -module load craype-haswell - -module use /sw/gaea/modulefiles -module load cmake - -# Loading nceplibs modules -module use /lustre/f1/pdata/ncep_shared/NCEPLIBS/lib/modulefiles -#module load HDF5-serial-intel-haswell/1.8.9 -#module load NetCDF-intel-haswell/4.2 -module load cray-hdf5 -module load cray-netcdf - -#module use /gpfs/hps/nco/ops/nwprod/lib/modulefiles -module load bufr-intel-sandybridge/11.0.1 -module load nemsio-intel-sandybridge/2.2.2 -module load sfcio-intel-sandybridge/1.0.0 -module load sigio-intel-sandybridge/2.0.1 -module load sp-intel-sandybridge/2.0.2 -module load w3nco-intel-sandybridge/2.0.6 -module load w3emc-intel-sandybridge/2.2.0 -module load bacio-intel-sandybridge/2.0.2 -setenv CRAYOS_VERSION $::env(CRAYPE_VERSION) -#setenv CRAYOS_VERSION ${CRAYPE_VERSION} - -# Compiler flags specific to this platform -setenv CFLAGS "-xCORE-AVX2" -setenv FFLAGS "-xCORE-AVX2" - diff --git a/modulefiles/gsi_gaea.lua b/modulefiles/gsi_gaea.lua new file mode 100644 index 0000000000..f76c8f3ad9 --- /dev/null +++ b/modulefiles/gsi_gaea.lua @@ -0,0 +1,34 @@ +help([[ +]]) + +load("cmake/3.20.1") + +prepend_path("MODULEPATH","/lustre/f2/dev/role.epic/contrib/hpc-stack/intel-classic-2022.0.2/modulefiles/stack") +load(pathJoin("hpc", os.getenv("hpc_ver") or "1.2.0")) + +load(pathJoin("intel-classic", os.getenv("intel_classic_ver") or "2022.0.2")) +load(pathJoin("cray-mpich", os.getenv("cray_mpich_ver") or "7.7.20")) +load(pathJoin("hpc-intel-classic", os.getenv("hpc_intel_classic_ver") or "2022.0.2")) +load(pathJoin("hpc-cray-mpich", os.getenv("hpc_cray_mpich_ver") or "7.7.20")) + +load("gsi_common") + +local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" +load(pathJoin("prod_util", prod_util_ver)) + +-- Needed at runtime: +load("alps") + +local MKLROOT="/opt/intel/oneapi/mkl/2022.0.2/" +prepend_path("LD_LIBRARY_PATH",pathJoin(MKLROOT,"lib/intel64")) +pushenv("MKLROOT", MKLROOT) + +pushenv("GSI_BINARY_SOURCE_DIR", "/lustre/f2/dev/role.epic/contrib/GSI_data/fix/20230601") + +setenv("CC","cc") +setenv("FC","ftn") +setenv("CXX","CC") +pushenv("CRAYPE_LINK_TYPE","dynamic") + +whatis("Description: GSI environment on Gaea with Intel Compilers") + diff --git a/modulefiles/gsi_hera.gnu.lua b/modulefiles/gsi_hera.gnu.lua index 4f0253ba4d..c309e67fe0 100644 --- a/modulefiles/gsi_hera.gnu.lua +++ b/modulefiles/gsi_hera.gnu.lua @@ -1,15 +1,18 @@ help([[ ]]) -prepend_path("MODULEPATH", "/scratch2/NCEPDEV/nwprod/hpc-stack/libs/hpc-stack/modulefiles/stack") +prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/hpc-stack/libs/gnu-9.2/modulefiles/stack") -local hpc_ver=os.getenv("hpc_ver") or "1.1.0" -local hpc_gnu_ver=os.getenv("hpc_gnu_ver") or "9.2.0" +local hpc_ver=os.getenv("hpc_ver") or "1.2.0" +local gnu_ver=os.getenv("gnu_ver") or "9.2.0" +local hpc_gnu_ver=os.getenv("hpc_gnu_ver") or "9.2" local hpc_mpich_ver=os.getenv("hpc_mpich_ver") or "3.3.2" local cmake_ver=os.getenv("cmake_ver") or "3.20.1" local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" +local openblas_ver=os.getenv("openblas_ver") or "0.3.23" load(pathJoin("hpc", hpc_ver)) +load(pathJoin("gnu", gnu_ver)) load(pathJoin("hpc-gnu", hpc_gnu_ver)) load(pathJoin("hpc-mpich", hpc_mpich_ver)) load(pathJoin("cmake", cmake_ver)) @@ -17,8 +20,7 @@ load(pathJoin("cmake", cmake_ver)) load("gsi_common") load(pathJoin("prod_util", prod_util_ver)) - -pushenv("MKLROOT", "/apps/oneapi/mkl/2022.0.2") +load(pathJoin("openblas", openblas_ver)) pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20230601") diff --git a/modulefiles/gsi_hera.intel.lua b/modulefiles/gsi_hera.intel.lua index 62a915ef72..866af02d50 100644 --- a/modulefiles/gsi_hera.intel.lua +++ b/modulefiles/gsi_hera.intel.lua @@ -1,13 +1,16 @@ help([[ ]]) -prepend_path("MODULEPATH", "/scratch2/NCEPDEV/nwprod/hpc-stack/libs/hpc-stack/modulefiles/stack") +prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/miniconda3/modulefiles") +miniconda3_ver=os.getenv("miniconda3_ver") or "4.12.0" +load(pathJoin("miniconda3", miniconda3_ver)) -local hpc_ver=os.getenv("hpc_ver") or "1.1.0" -local hpc_intel_ver=os.getenv("hpc_intel_ver") or "18.0.5.274" -local hpc_impi_ver=os.getenv("hpc_impi_ver") or "2018.0.4" +prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/hpc-stack/libs/intel-2022.1.2/modulefiles/stack") + +local hpc_ver=os.getenv("hpc_ver") or "1.2.0" +local hpc_intel_ver=os.getenv("hpc_intel_ver") or "2022.1.2" +local hpc_impi_ver=os.getenv("hpc_impi_ver") or "2022.1.2" local cmake_ver=os.getenv("cmake_ver") or "3.20.1" -local anaconda_ver=os.getenv("anaconda_ver") or "2.3.0" local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" load(pathJoin("hpc", hpc_ver)) @@ -15,10 +18,6 @@ load(pathJoin("hpc-intel", hpc_intel_ver)) load(pathJoin("hpc-impi", hpc_impi_ver)) load(pathJoin("cmake", cmake_ver)) -prepend_path("MODULEPATH", "/contrib/anaconda/modulefiles") - -load(pathJoin("anaconda", anaconda_ver)) - load("gsi_common") load(pathJoin("prod_util", prod_util_ver)) diff --git a/modulefiles/gsi_jet.lua b/modulefiles/gsi_jet.lua index a769deca6f..e2ea2ef1d0 100644 --- a/modulefiles/gsi_jet.lua +++ b/modulefiles/gsi_jet.lua @@ -1,13 +1,16 @@ help([[ ]]) -prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/hpc-stack/libs/intel-18.0.5.274/modulefiles/stack") +prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/miniconda3/modulefiles") +miniconda3_ver=os.getenv("miniconda3_ver") or "4.12.0" +load(pathJoin("miniconda3", miniconda3_ver)) + +prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/hpc-stack/libs/intel-2022.1.2/modulefiles/stack") local hpc_ver=os.getenv("hpc_ver") or "1.2.0" -local hpc_intel_ver=os.getenv("hpc_intel_ver") or "18.0.5.274" -local hpc_impi_ver=os.getenv("hpc_impi_ver") or "2018.4.274" +local hpc_intel_ver=os.getenv("hpc_intel_ver") or "2022.1.2" +local hpc_impi_ver=os.getenv("hpc_impi_ver") or "2022.1.2" local cmake_ver=os.getenv("cmake_ver") or "3.20.1" -local anaconda_ver=os.getenv("anaconda_ver") or "5.3.1" local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" load(pathJoin("hpc", hpc_ver)) @@ -15,10 +18,6 @@ load(pathJoin("hpc-intel", hpc_intel_ver)) load(pathJoin("hpc-impi", hpc_impi_ver)) load(pathJoin("cmake", cmake_ver)) -prepend_path("MODULEPATH", "/contrib/anaconda/modulefiles") - -load(pathJoin("anaconda", anaconda_ver)) - load("gsi_common") load(pathJoin("prod_util", prod_util_ver)) diff --git a/modulefiles/gsi_orion.lua b/modulefiles/gsi_orion.lua index fb3df720e4..a7ea874fb2 100644 --- a/modulefiles/gsi_orion.lua +++ b/modulefiles/gsi_orion.lua @@ -1,20 +1,22 @@ help([[ ]]) -prepend_path("MODULEPATH", "/apps/contrib/NCEP/libs/hpc-stack/modulefiles/stack") +prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/contrib/orion/miniconda3/modulefiles") +miniconda3_ver=os.getenv("miniconda3_ver") or "4.12.0" +load(pathJoin("miniconda3", miniconda3_ver)) -local hpc_ver=os.getenv("hpc_ver") or "1.1.0" -local hpc_intel_ver=os.getenv("hpc_intel_ver") or "2018.4" -local hpc_impi_ver=os.getenv("hpc_impi_ver") or "2018.4" +prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/contrib/orion/hpc-stack/intel-2022.1.2/modulefiles/stack") + +local hpc_ver=os.getenv("hpc_ver") or "1.2.0" +local hpc_intel_ver=os.getenv("hpc_intel_ver") or "2022.1.2" +local hpc_impi_ver=os.getenv("hpc_impi_ver") or "2022.1.2" local cmake_ver=os.getenv("cmake_ver") or "3.22.1" -local python_ver=os.getenv("python_ver") or "3.7.5" local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" load(pathJoin("hpc", hpc_ver)) load(pathJoin("hpc-intel", hpc_intel_ver)) load(pathJoin("hpc-impi", hpc_impi_ver)) load(pathJoin("cmake", cmake_ver)) -load(pathJoin("python", python_ver)) load("gsi_common") diff --git a/modulefiles/gsi_s4.lua b/modulefiles/gsi_s4.lua index 24b1f5962d..efdc6c4bfb 100644 --- a/modulefiles/gsi_s4.lua +++ b/modulefiles/gsi_s4.lua @@ -1,9 +1,9 @@ help([[ ]]) -local hpc_ver=os.getenv("hpc_ver") or "1.1.0" -local hpc_intel_ver=os.getenv("hpc_intel_ver") or "18.0.4" -local hpc_impi_ver=os.getenv("hpc_impi_ver") or "18.0.4" +local hpc_ver=os.getenv("hpc_ver") or "1.2.0" +local hpc_intel_ver=os.getenv("hpc_intel_ver") or "2022.1" +local hpc_impi_ver=os.getenv("hpc_impi_ver") or "2022.1" local miniconda_ver=os.getenv("miniconda_ver") or "3.8-s4" local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" diff --git a/regression/regression_driver.sh b/regression/regression_driver.sh index e1d3b18dc7..821cc7cedb 100755 --- a/regression/regression_driver.sh +++ b/regression/regression_driver.sh @@ -35,9 +35,11 @@ for jn in `seq ${RSTART} ${REND}`; do if [ $jn -le 2 ]; then export scripts=${scripts_updat:-$scripts} export fixgsi=${fixgsi_updat:-$fixgsi} + export modulefiles=${modulefiles_updat:-$modulefiles} else export scripts=${scripts_contrl:-$scripts} export fixgsi=${fixgsi_contrl:-$fixgsi} + export modulefiles=${modulefiles_contrl:-$modulefiles} fi rm -f ${job[$jn]}.out diff --git a/regression/regression_param.sh b/regression/regression_param.sh index 6024dbdb54..ea27521251 100755 --- a/regression/regression_param.sh +++ b/regression/regression_param.sh @@ -18,6 +18,11 @@ case $machine in sub_cmd="sub_jet" memnode=96 numcore=40 + ;; + Gaea) + sub_cmd="sub_gaea" + memnode=64 + numcore=36 ;; wcoss2) sub_cmd="sub_wcoss2" @@ -28,7 +33,9 @@ case $machine in sub_cmd="sub_discover" ;; Cheyenne) - sub_cmd="sub_ncar -a p48503002 -q economy -d $PWD" + sub_cmd="sub_cheyenne" + memnode=128 + numcore=36 ;; *) # EXIT out for unresolved machine echo "unknown $machine" @@ -56,8 +63,11 @@ case $regtest in topts[1]="0:15:00" ; popts[1]="12/5/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="12/9/" ; ropts[2]="/2" elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:30:00" ; popts[1]="16/2/" ; ropts[1]="/1" - topts[2]="0:30:00" ; popts[2]="16/4/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="16/2/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="16/4/" ; ropts[2]="/2" + elif [[ "$machine" = "Gaea" ]]; then + topts[1]="0:15:00" ; popts[1]="18/2/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="18/4/" ; ropts[2]="/2" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="12/5/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="12/9/" ; ropts[2]="/2" @@ -86,8 +96,11 @@ case $regtest in topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:35:00" ; popts[1]="16/2/" ; ropts[1]="/1" - topts[2]="0:25:00" ; popts[2]="16/4/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2" + elif [[ "$machine" = "Gaea" ]]; then + topts[1]="0:15:00" ; popts[1]="18/2/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="18/4/" ; ropts[2]="/2" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="28/2/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="28/4/" ; ropts[2]="/2" @@ -104,6 +117,8 @@ case $regtest in popts[1]="12/5/" elif [[ "$machine" = "Jet" ]]; then popts[1]="12/5/" + elif [[ "$machine" = "Gaea" ]]; then + popts[1]="18/5/" elif [[ "$machine" = "wcoss2" ]]; then popts[1]="28/4/" topts[1]="3:00:00" @@ -129,8 +144,11 @@ case $regtest in topts[1]="0:30:00" ; popts[1]="48/2" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="60/3" ; ropts[2]="/2" elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="1:59:00" ; popts[1]="6/8/" ; ropts[1]="/1" - topts[2]="0:35:00" ; popts[2]="6/10/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2" + elif [[ "$machine" = "Gaea" ]]; then + topts[1]="0:10:00" ; popts[1]="18/8/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="18/10/" ; ropts[2]="/2" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2" @@ -155,6 +173,12 @@ case $regtest in elif [[ "$machine" = "Jet" ]]; then topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + elif [[ "$machine" = "Cheyenne" ]]; then + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" + elif [[ "$machine" = "Gaea" ]]; then + topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" @@ -179,6 +203,12 @@ case $regtest in elif [[ "$machine" = "Jet" ]]; then topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" + elif [[ "$machine" = "Cheyenne" ]]; then + topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/2" + elif [[ "$machine" = "Gaea" ]]; then + topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="28/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="28/2/" ; ropts[2]="/1" @@ -204,8 +234,11 @@ case $regtest in topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:15:00" ; popts[1]="8/6/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="8/8/" ; ropts[2]="/1" + topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" + elif [[ "$machine" = "Gaea" ]]; then + topts[1]="0:30:00" ; popts[1]="8/6/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="8/8/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:30:00" ; popts[1]="14/8/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="14/14/" ; ropts[2]="/2" @@ -233,6 +266,9 @@ case $regtest in elif [[ "$machine" = "Cheyenne" ]]; then topts[1]="0:20:00" ; popts[1]="6/6/" ; ropts[1]="/1" topts[2]="0:20:00" ; popts[2]="8/8/" ; ropts[2]="/1" + elif [[ "$machine" = "Gaea" ]]; then + topts[1]="0:20:00" ; popts[1]="6/6/" ; ropts[1]="/1" + topts[2]="0:20:00" ; popts[2]="8/8/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="10/10/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="14/14/" ; ropts[2]="/2" @@ -258,8 +294,11 @@ case $regtest in topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:15:00" ; popts[1]="16/2/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="16/4/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2" + elif [[ "$machine" = "Gaea" ]]; then + topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:10:00" ; popts[1]="16/2/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="16/4/" ; ropts[2]="/2" @@ -316,13 +355,19 @@ elif [[ "$machine" = "Jet" ]]; then export MPI_BUFS_PER_PROC=256 export MPI_BUFS_PER_HOST=256 export MPI_GROUP_MAX=256 - export APRUN="srun" + export APRUN="srun -n \$ntasks --cpus-per-task=\$threads" +elif [[ "$machine" = "Gaea" ]]; then + export OMP_STACKSIZE=1024M + export MPI_BUFS_PER_PROC=256 + export MPI_BUFS_PER_HOST=256 + export MPI_GROUP_MAX=256 + export APRUN="srun --export=ALL --mpi=pmi2 -n \$ntasks" elif [[ "$machine" = "Cheyenne" ]]; then export OMP_STACKSIZE=1024M export MPI_BUFS_PER_PROC=256 export MPI_BUFS_PER_HOST=256 export MPI_GROUP_MAX=256 - export APRUN="mpirun -v -np \$NCPUS" + export APRUN="mpirun -v -np \$ntasks" elif [[ "$machine" = "wcoss2" ]]; then export OMP_PLACES=cores export OMP_STACKSIZE=2G diff --git a/regression/regression_var.sh b/regression/regression_var.sh index 05b5563ef1..3176372a3b 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -14,6 +14,7 @@ if [ "$#" = 7 ] ; then export enkfexec_contrl=$7 export fixgsi="$gsisrc/fix" export scripts="$gsisrc/regression" + export modulefiles="$gsisrc/modulefiles" export ush="$gsisrc/ush" export cmaketest="true" export clean="false" @@ -49,19 +50,33 @@ fi echo "Running Regression Tests on '$machine'"; case $machine in + Gaea) + export queue="normal" + export noscrub="/lustre/f2/scratch/$LOGNAME/gsi_tmp/noscrub" + export ptmp="/lustre/f2/scratch/$LOGNAME/gsi_tmp/ptmp" + export casesdir="/lustre/f2/dev/role.epic/contrib/GSI_data/CASES/regtest" + + export group="global" + if [[ "$cmaketest" = "false" ]]; then + export basedir="/lustre/f2/dev/$LOGNAME/sandbox/GSI" + fi + + export check_resource="no" + export accnt="nggps_emc" + ;; Cheyenne) - export queue="economy" - export noscrub="/glade/scratch/$LOGNAME" + export queue="regular" + export noscrub="/glade/scratch/$LOGNAME/noscrub" export group="global" if [[ "$cmaketest" = "false" ]]; then - export basedir="/glade/scratch/$LOGNAME/gsi" + export basedir="/glade/scratch/$LOGNAME" fi export ptmp="/glade/scratch/$LOGNAME/$ptmpName" - export casesdir="/glade/p/ral/jntp/tools/CASES" + export casesdir="/glade/work/epicufsrt/contrib/GSI_data/CASES/regtest" export check_resource="no" - export accnt="p48503002" + export accnt="NRAL0032" ;; wcoss2) export local_or_default="${local_or_default:-/lfs/h2/emc/da/noscrub/$LOGNAME}" diff --git a/src/enkf/observer_gfs.f90 b/src/enkf/observer_gfs.f90 index 983b25f959..07e4f58457 100644 --- a/src/enkf/observer_gfs.f90 +++ b/src/enkf/observer_gfs.f90 @@ -66,7 +66,7 @@ subroutine setup_linhx(rlat, rlon, time, ix, delx, ixp, delxp, iy, dely, & !$$$ use kinds, only: r_kind,i_kind,r_single use params, only: nstatefields, nlons, nlats, nhr_state, fhr_assim - use gridinfo, only: latsgrd, lonsgrd + use gridinfo, only: latsgrd, lonsgrd, npts use constants, only: zero,one,pi use mpisetup implicit none @@ -76,6 +76,7 @@ subroutine setup_linhx(rlat, rlon, time, ix, delx, ixp, delxp, iy, dely, & real(r_single) ,intent(in ) :: time ! observation time relative to middle of window integer(i_kind), intent(out) :: ix, iy, it, ixp, iyp, itp real(r_kind), intent(out) :: delx, dely, delxp, delyp, delt, deltp + integer(i_kind) :: ixnlons ! find interplation indices and deltas @@ -87,17 +88,21 @@ subroutine setup_linhx(rlat, rlon, time, ix, delx, ixp, delxp, iy, dely, & ix = min(ix, nlats-1) ixp = max(ix-1, 0) + ixnlons = ix*nlons + if (ixp /= ix) then - delx = (rlat - latsgrd(ix*nlons+1)) / (latsgrd(ixp*nlons + 1) - latsgrd(ix*nlons+1)) + delx = (rlat - latsgrd(ixnlons+1)) / (latsgrd(ixp*nlons + 1) - latsgrd(ixnlons+1)) else delx = one endif delx = max(zero,min(delx,one)) - iyp = 1 - do while (iyp <= nlons .and. lonsgrd(ix*nlons + iyp) <= rlon) - iyp = iyp + 1 + iyp=1 + do while(iyp <= nlons .and. ixnlons+iyp <= npts) + if (lonsgrd(ixnlons+iyp) > rlon) exit + iyp = iyp + 1 enddo + iy = iyp - 1 if(iy < 1) iy = iy + nlons if(iyp > nlons) iyp = iyp - nlons diff --git a/src/gsi/ensctl2state.f90 b/src/gsi/ensctl2state.f90 index 0d6d3042c5..bd72e12b76 100644 --- a/src/gsi/ensctl2state.f90 +++ b/src/gsi/ensctl2state.f90 @@ -240,7 +240,6 @@ subroutine ensctl2state(xhat,mval,eval) !$omp section ! Get pointers to required state variables - call gsi_bundlegetpointer (eval(jj),'oz' ,sv_oz , istatus) call gsi_bundlegetpointer (eval(jj),'sst' ,sv_sst, istatus) if(ls_w)then call gsi_bundlegetpointer (eval(jj),'w' ,sv_w, istatus) @@ -249,7 +248,6 @@ subroutine ensctl2state(xhat,mval,eval) end if end if ! Copy variables - call gsi_bundlegetvar ( wbundle_c, 'oz' , sv_oz, istatus ) call gsi_bundlegetvar ( wbundle_c, 'sst', sv_sst, istatus ) if(lc_w)then call gsi_bundlegetvar ( wbundle_c, 'w' , sv_w, istatus ) @@ -258,6 +256,13 @@ subroutine ensctl2state(xhat,mval,eval) 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' ,sv_oz , istatus) + call gsi_bundlegetvar ( wbundle_c, 'oz' , sv_oz, istatus ) + endif + !$omp end parallel sections ! Add contribution from static B, if necessary diff --git a/src/gsi/ensctl2state_ad.f90 b/src/gsi/ensctl2state_ad.f90 index 4c038c8c6e..d350743998 100644 --- a/src/gsi/ensctl2state_ad.f90 +++ b/src/gsi/ensctl2state_ad.f90 @@ -206,9 +206,7 @@ subroutine ensctl2state_ad(eval,mval,grad) !$omp section - call gsi_bundlegetpointer (eval(jj),'oz' ,rv_oz , istatus) call gsi_bundlegetpointer (eval(jj),'sst' ,rv_sst, istatus) - call gsi_bundleputvar ( wbundle_c, 'oz', rv_oz, istatus ) call gsi_bundleputvar ( wbundle_c, 'sst', rv_sst, istatus ) if(wdw_exist)then call gsi_bundlegetpointer (eval(jj),'w' ,rv_w, istatus) @@ -219,6 +217,13 @@ subroutine ensctl2state_ad(eval,mval,grad) 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 diff --git a/src/gsi/general_read_fv3atm.f90 b/src/gsi/general_read_fv3atm.f90 index 3d2646fbbb..847d1c4bd3 100644 --- a/src/gsi/general_read_fv3atm.f90 +++ b/src/gsi/general_read_fv3atm.f90 @@ -255,6 +255,7 @@ subroutine general_read_fv3atm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, & call stop2(999) endif istatus=0 + istatus1=0 call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus = istatus + ier call gsi_bundlegetpointer(gfs_bundle,'q' ,g_q ,ier);istatus = istatus + ier call gsi_bundlegetpointer(gfs_bundle,'oz',g_oz ,ier);istatus = istatus + ier diff --git a/src/gsi/genstats_gps.f90 b/src/gsi/genstats_gps.f90 index ce90d06f50..acf5ca2756 100644 --- a/src/gsi/genstats_gps.f90 +++ b/src/gsi/genstats_gps.f90 @@ -250,7 +250,7 @@ subroutine genstats_gps(bwork,awork,toss_gps_sub,conv_diagsave,mype) use obsmod, only: lobsdiagsave,luse_obsdiag use obsmod, only: binary_diag,netcdf_diag,dirname,ianldate use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & - nc_diag_write, nc_diag_data2d + nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close use gridmod, only: nsig,regional use constants, only: tiny_r_kind,half,wgtlim,one,two,zero,five,four @@ -766,27 +766,27 @@ subroutine contents_netcdf_diag_ obssubtype = gps_allptr%rdiag(2) call nc_diag_metadata("Observation_Type", obstype ) call nc_diag_metadata("Observation_Subtype", obssubtype ) - call nc_diag_metadata("Latitude", sngl(gps_allptr%rdiag(3)) ) - call nc_diag_metadata("Longitude", sngl(gps_allptr%rdiag(4)) ) - call nc_diag_metadata("Incremental_Bending_Angle", sngl(gps_allptr%rdiag(5)) ) - call nc_diag_metadata("Pressure", sngl(gps_allptr%rdiag(6)) ) - call nc_diag_metadata("Height", sngl(gps_allptr%rdiag(7)) ) - call nc_diag_metadata("Time", sngl(gps_allptr%rdiag(8)) ) - call nc_diag_metadata("Model_Elevation", sngl(gps_allptr%rdiag(9)) ) - call nc_diag_metadata("Setup_QC_Mark", sngl(gps_allptr%rdiag(10)) ) - call nc_diag_metadata("Prep_Use_Flag", sngl(gps_allptr%rdiag(11)) ) - call nc_diag_metadata("Analysis_Use_Flag", sngl(gps_allptr%rdiag(12)) ) - - call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(gps_allptr%rdiag(13)) ) - call nc_diag_metadata("Errinv_Input", sngl(gps_allptr%rdiag(14)) ) - call nc_diag_metadata("Errinv_Adjust", sngl(gps_allptr%rdiag(15)) ) - call nc_diag_metadata("Errinv_Final", sngl(gps_allptr%rdiag(16)) ) - call nc_diag_metadata("Observation", sngl(gps_allptr%rdiag(17)) ) - call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(gps_allptr%rdiag(17))*sngl(gps_allptr%rdiag(5)) ) - call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(gps_allptr%rdiag(17))*sngl(gps_allptr%rdiag(5)) ) - call nc_diag_metadata("GPS_Type", sngl(gps_allptr%rdiag(20)) ) - call nc_diag_metadata("Temperature_at_Obs_Location", sngl(gps_allptr%rdiag(18)) ) - call nc_diag_metadata("Specific_Humidity_at_Obs_Location", sngl(gps_allptr%rdiag(21)) ) + call nc_diag_metadata_to_single("Latitude", gps_allptr%rdiag(3) ) + call nc_diag_metadata_to_single("Longitude", gps_allptr%rdiag(4) ) + call nc_diag_metadata_to_single("Incremental_Bending_Angle", gps_allptr%rdiag(5) ) + call nc_diag_metadata_to_single("Pressure", gps_allptr%rdiag(6) ) + call nc_diag_metadata_to_single("Height", gps_allptr%rdiag(7) ) + call nc_diag_metadata_to_single("Time", gps_allptr%rdiag(8) ) + call nc_diag_metadata_to_single("Model_Elevation", gps_allptr%rdiag(9) ) + call nc_diag_metadata_to_single("Setup_QC_Mark", gps_allptr%rdiag(10) ) + call nc_diag_metadata_to_single("Prep_Use_Flag", gps_allptr%rdiag(11) ) + call nc_diag_metadata_to_single("Analysis_Use_Flag", gps_allptr%rdiag(12) ) + + call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt", gps_allptr%rdiag(13) ) + call nc_diag_metadata_to_single("Errinv_Input", gps_allptr%rdiag(14) ) + call nc_diag_metadata_to_single("Errinv_Adjust", gps_allptr%rdiag(15) ) + call nc_diag_metadata_to_single("Errinv_Final", gps_allptr%rdiag(16) ) + call nc_diag_metadata_to_single("Observation", gps_allptr%rdiag(17) ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted", gps_allptr%rdiag(17),gps_allptr%rdiag(5),"*") + call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",gps_allptr%rdiag(17),gps_allptr%rdiag(5),"*") + call nc_diag_metadata_to_single("GPS_Type", gps_allptr%rdiag(20) ) + call nc_diag_metadata_to_single("Temperature_at_Obs_Location", gps_allptr%rdiag(18) ) + call nc_diag_metadata_to_single("Specific_Humidity_at_Obs_Location",gps_allptr%rdiag(21) ) if (save_jacobian) then call readarray(dhx_dx, gps_allptr%rdiag(ioff+1:nreal)) diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 05f679cb60..62b23ee713 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -2188,7 +2188,7 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) use kinds, only: r_kind,i_kind - use mpimod, only: mpi_comm_world,mpi_rtype,mype + use mpimod, only: mpi_comm_world,mpi_rtype,mype,npe,setcomm,mpi_integer,mpi_max use mpimod, only: MPI_INFO_NULL use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension @@ -2217,6 +2217,11 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) logical :: phy_smaller_domain integer(i_kind) gfile_loc,iret,var_id 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 + logical:: procuse + ! for io_layout > 1 real(r_kind),allocatable,dimension(:,:):: uu2d_layout integer(i_kind) :: nio @@ -2232,108 +2237,132 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) kend=grd_ionouv%kend_loc allocate(uu2d(nxcase,nycase)) - if(fv3_io_layout_y > 1) then - allocate(gfile_loc_layout(0:fv3_io_layout_y-1)) - do nio=0,fv3_io_layout_y-1 - write(filename_layout,'(a,a,I4.4)') trim(filenamein),'.',nio - iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio),comm=mpi_comm_world,info=MPI_INFO_NULL) !clt - if(iret/=nf90_noerr) then - write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filename_layout),gfile_loc_layout(nio),', Status = ',iret - call flush(6) - call stop2(333) - endif - enddo - else - iret=nf90_open(filenamein,nf90_nowrite,gfile_loc,comm=mpi_comm_world,info=MPI_INFO_NULL) !clt - if(iret/=nf90_noerr) then - write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filenamein),gfile_loc,', Status = ',iret - call flush(6) - call stop2(333) - endif + procuse = .false. + members=-1 + members_read=-1 + if (kbgn<=kend) then + procuse = .true. + members(mm1) = mype endif - do ilevtot=kbgn,kend - vgsiname=grd_ionouv%names(1,ilevtot) - if(trim(vgsiname)=='delzinc') cycle !delzinc is not read from DZ ,it's started from hydrostatic height - if(trim(vgsiname)=='amassi') cycle - if(trim(vgsiname)=='amassj') cycle - if(trim(vgsiname)=='amassk') cycle - if(trim(vgsiname)=='pm2_5') cycle - call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname) - name=trim(varname) - if(trim(filenamein) /= trim(filenamein2)) then - write(6,*)'filenamein and filenamein2 are not the same as expected, stop' - call flush(6) - call stop2(333) - endif - ilev=grd_ionouv%lnames(1,ilevtot) - nz=grd_ionouv%nsig - nzp1=nz+1 - inative=nzp1-ilev - startloc=(/1,1,inative/) - countloc=(/nxcase,nycase,1/) - ! Variable ref_f3d in phy_data.nc has a smaller domain size than - ! dynvariables and tracers as well as a reversed order in vertical - if ( trim(adjustl(varname)) == 'ref_f3d' )then - iret=nf90_inquire_dimension(gfile_loc,1,name,len) - if(trim(name)=='xaxis_1') nx_phy=len - if( nx_phy == nxcase )then - allocate(uu2d_tmp(nxcase,nycase)) - countloc_tmp=(/nxcase,nycase,1/) - phy_smaller_domain = .false. - else - allocate(uu2d_tmp(nxcase-6,nycase-6)) - countloc_tmp=(/nxcase-6,nycase-6,1/) - phy_smaller_domain = .true. - end if - startloc_tmp=(/1,1,ilev/) - end if + call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror) - if(fv3_io_layout_y > 1) then - do nio=0,fv3_io_layout_y-1 - countloc=(/nxcase,ny_layout_len(nio),1/) - allocate(uu2d_layout(nxcase,ny_layout_len(nio))) - iret=nf90_inq_varid(gfile_loc_layout(nio),trim(adjustl(varname)),var_id) - iret=nf90_get_var(gfile_loc_layout(nio),var_id,uu2d_layout,start=startloc,count=countloc) - uu2d(:,ny_layout_b(nio):ny_layout_e(nio))=uu2d_layout - deallocate(uu2d_layout) - enddo - else - iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname)),var_id) - if ( trim(adjustl(varname)) == 'ref_f3d' )then - uu2d = 0.0_r_kind - iret=nf90_get_var(gfile_loc,var_id,uu2d_tmp,start=startloc_tmp,count=countloc_tmp) - where(uu2d_tmp < 0.0_r_kind) - uu2d_tmp = 0.0_r_kind - endwhere - - if( phy_smaller_domain )then - uu2d(4:nxcase-3,4:nycase-3) = uu2d_tmp - else - uu2d(1:nxcase,1:nycase) = uu2d_tmp - end if - deallocate(uu2d_tmp) - else - iret=nf90_get_var(gfile_loc,var_id,uu2d,start=startloc,count=countloc) - end if - endif + nread=0 + mype_read_rank=-1 + do i=1,npe + if (members_read(i) >= 0) then + nread=nread+1 + mype_read_rank(nread) = members_read(i) + endif + enddo + + call setcomm(iworld,iworld_group,nread,mype_read_rank,mpi_comm_read,ierror) - call fv3_h_to_ll(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) - enddo ! ilevtot + if (procuse) then - if(fv3_io_layout_y > 1) then - do nio=1,fv3_io_layout_y-1 - iret=nf90_close(gfile_loc_layout(nio)) - enddo - deallocate(gfile_loc_layout) - else - iret=nf90_close(gfile_loc) + if(fv3_io_layout_y > 1) then + allocate(gfile_loc_layout(0:fv3_io_layout_y-1)) + do nio=0,fv3_io_layout_y-1 + write(filename_layout,'(a,a,I4.4)') trim(filenamein),'.',nio + iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) !clt + if(iret/=nf90_noerr) then + write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filename_layout),gfile_loc_layout(nio),', Status = ',iret + call flush(6) + call stop2(333) + endif + enddo + else + iret=nf90_open(filenamein,nf90_nowrite,gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) !clt + if(iret/=nf90_noerr) then + write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filenamein),gfile_loc,', Status = ',iret + call flush(6) + call stop2(333) + endif + endif + do ilevtot=kbgn,kend + vgsiname=grd_ionouv%names(1,ilevtot) + if(trim(vgsiname)=='delzinc') cycle !delzinc is not read from DZ ,it's started from hydrostatic height + if(trim(vgsiname)=='amassi') cycle + if(trim(vgsiname)=='amassj') cycle + if(trim(vgsiname)=='amassk') cycle + if(trim(vgsiname)=='pm2_5') cycle + call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname) + name=trim(varname) + if(trim(filenamein) /= trim(filenamein2)) then + write(6,*)'filenamein and filenamein2 are not the same as expected, stop' + call flush(6) + call stop2(333) + endif + ilev=grd_ionouv%lnames(1,ilevtot) + nz=grd_ionouv%nsig + nzp1=nz+1 + inative=nzp1-ilev + startloc=(/1,1,inative/) + countloc=(/nxcase,nycase,1/) + ! Variable ref_f3d in phy_data.nc has a smaller domain size than + ! dynvariables and tracers as well as a reversed order in vertical + if ( trim(adjustl(varname)) == 'ref_f3d' )then + iret=nf90_inquire_dimension(gfile_loc,1,name,len) + if(trim(name)=='xaxis_1') nx_phy=len + if( nx_phy == nxcase )then + allocate(uu2d_tmp(nxcase,nycase)) + countloc_tmp=(/nxcase,nycase,1/) + phy_smaller_domain = .false. + else + allocate(uu2d_tmp(nxcase-6,nycase-6)) + countloc_tmp=(/nxcase-6,nycase-6,1/) + phy_smaller_domain = .true. + end if + startloc_tmp=(/1,1,ilev/) + end if + + if(fv3_io_layout_y > 1) then + do nio=0,fv3_io_layout_y-1 + countloc=(/nxcase,ny_layout_len(nio),1/) + allocate(uu2d_layout(nxcase,ny_layout_len(nio))) + iret=nf90_inq_varid(gfile_loc_layout(nio),trim(adjustl(varname)),var_id) + iret=nf90_get_var(gfile_loc_layout(nio),var_id,uu2d_layout,start=startloc,count=countloc) + uu2d(:,ny_layout_b(nio):ny_layout_e(nio))=uu2d_layout + deallocate(uu2d_layout) + enddo + else + iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname)),var_id) + if ( trim(adjustl(varname)) == 'ref_f3d' )then + uu2d = 0.0_r_kind + iret=nf90_get_var(gfile_loc,var_id,uu2d_tmp,start=startloc_tmp,count=countloc_tmp) + where(uu2d_tmp < 0.0_r_kind) + uu2d_tmp = 0.0_r_kind + endwhere + + if( phy_smaller_domain )then + uu2d(4:nxcase-3,4:nycase-3) = uu2d_tmp + else + uu2d(1:nxcase,1:nycase) = uu2d_tmp + end if + deallocate(uu2d_tmp) + else + iret=nf90_get_var(gfile_loc,var_id,uu2d,start=startloc,count=countloc) + end if + endif + + call fv3_h_to_ll(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + enddo ! ilevtot + + if(fv3_io_layout_y > 1) then + do nio=1,fv3_io_layout_y-1 + iret=nf90_close(gfile_loc_layout(nio)) + enddo + deallocate(gfile_loc_layout) + else + iret=nf90_close(gfile_loc) + endif endif - + call mpi_barrier(mpi_comm_world,ierror) + deallocate (uu2d) call general_grid2sub(grd_ionouv,hwork,cstate_nouv%values) return -end subroutine gsi_fv3ncdf_read + end subroutine gsi_fv3ncdf_read subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) @@ -2465,7 +2494,7 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) ! !$$$ end documentation block use kinds, only: r_kind,i_kind - use mpimod, only: mpi_comm_world,mpi_rtype,mype,mpi_info_null + use mpimod, only: mpi_comm_world,mpi_rtype,mype,mpi_info_null,npe,setcomm,mpi_integer,mpi_max use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension use netcdf, only: nf90_inquire_variable @@ -2495,6 +2524,10 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) integer(i_kind) gfile_loc,iret 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 + logical:: procuse + ! for fv3_io_layout_y > 1 real(r_kind),allocatable,dimension(:,:):: u2d_layout,v2d_layout integer(i_kind) :: nio @@ -2515,102 +2548,130 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) allocate (worksub(2,grd_uv%lat2,grd_uv%lon2,grd_uv%nsig)) filenamein=fv3filenamegin%dynvars - if(fv3_io_layout_y > 1) then - allocate(gfile_loc_layout(0:fv3_io_layout_y-1)) - do nio=0,fv3_io_layout_y-1 - write(filename_layout,'(a,a,I4.4)') trim(filenamein),".",nio - iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio),comm=mpi_comm_world,info=MPI_INFO_NULL) - if(iret/=nf90_noerr) then - write(6,*)'problem opening6 ',trim(filename_layout),gfile_loc_layout(nio),', Status = ',iret - call flush(6) - call stop2(333) - endif - enddo - else - iret=nf90_open(filenamein,nf90_nowrite,gfile_loc,comm=mpi_comm_world,info=MPI_INFO_NULL) !clt - if(iret/=nf90_noerr) then - write(6,*)' problem opening6 ',trim(filenamein),', Status = ',iret - call flush(6) - call stop2(333) - endif + procuse = .false. + members=-1 + members_read=-1 + if (kbgn<=kend) then + procuse = .true. + members(mm1) = mype endif - do ilevtot=kbgn,kend - vgsiname=grd_uv%names(1,ilevtot) - call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname) - if(trim(filenamein) /= trim(filenamein2)) then - write(6,*)'filenamein and filenamein2 are not the same as expected, stop' - call flush(6) - call stop2(333) - endif - ilev=grd_uv%lnames(1,ilevtot) - nz=grd_uv%nsig - nzp1=nz+1 - inative=nzp1-ilev - u_countloc=(/nxcase,nycase+1,1/) - v_countloc=(/nxcase+1,nycase,1/) - u_startloc=(/1,1,inative/) - v_startloc=(/1,1,inative/) - - if(fv3_io_layout_y > 1) then - do nio=0,fv3_io_layout_y-1 - u_countloc=(/nxcase,ny_layout_len(nio)+1,1/) - allocate(u2d_layout(nxcase,ny_layout_len(nio)+1)) - call check( nf90_inq_varid(gfile_loc_layout(nio),'u',u_grd_VarId) ) - iret=nf90_get_var(gfile_loc_layout(nio),u_grd_VarId,u2d_layout,start=u_startloc,count=u_countloc) - u2d(:,ny_layout_b(nio):ny_layout_e(nio))=u2d_layout(:,1:ny_layout_len(nio)) - if(nio==fv3_io_layout_y-1) u2d(:,ny_layout_e(nio)+1)=u2d_layout(:,ny_layout_len(nio)+1) - deallocate(u2d_layout) - - v_countloc=(/nxcase+1,ny_layout_len(nio),1/) - allocate(v2d_layout(nxcase+1,ny_layout_len(nio))) - call check( nf90_inq_varid(gfile_loc_layout(nio),'v',v_grd_VarId) ) - iret=nf90_get_var(gfile_loc_layout(nio),v_grd_VarId,v2d_layout,start=v_startloc,count=v_countloc) - v2d(:,ny_layout_b(nio):ny_layout_e(nio))=v2d_layout - deallocate(v2d_layout) - enddo - else - call check( nf90_inq_varid(gfile_loc,'u',u_grd_VarId) ) - iret=nf90_get_var(gfile_loc,u_grd_VarId,u2d,start=u_startloc,count=u_countloc) - call check( nf90_inq_varid(gfile_loc,'v',v_grd_VarId) ) - iret=nf90_get_var(gfile_loc,v_grd_VarId,v2d,start=v_startloc,count=v_countloc) - endif - if(.not.grid_reverse_flag) then - call reverse_grid_r_uv (u2d,nxcase,nycase+1,1) - call reverse_grid_r_uv (v2d,nxcase+1,nycase,1) - endif - call fv3uv2earth(u2d(:,:),v2d(:,:),nxcase,nycase,uc2d,vc2d) + write(6,115)mype,kbgn,kend,procuse +115 format('gsi_fv3ncdf_readuv: mype ',i6,' has kbgn,kend= ',2(i6,1x),' set procuse ',l7) -! NOTE on transfor to earth u/v: -! The u and v before transferring need to be in E-W/N-S grid, which is -! defined as reversed grid here because it is revered from map view. -! -! Have set the following flag for grid orientation -! grid_reverse_flag=true: E-W/N-S grid -! grid_reverse_flag=false: W-E/S-N grid -! -! So for preparing the wind transferring, need to reverse the grid from -! W-E/S-N grid to E-W/N-S grid when grid_reverse_flag=false: -! -! if(.not.grid_reverse_flag) call reverse_grid_r_uv -! -! and the last input parameter for fv3_h_to_ll is alway true: -! -! - call fv3_h_to_ll(uc2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) - call fv3_h_to_ll(vc2d,hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) - enddo ! i + call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror) - if(fv3_io_layout_y > 1) then - do nio=0,fv3_io_layout_y-1 - iret=nf90_close(gfile_loc_layout(nio)) - enddo - deallocate(gfile_loc_layout) - else - iret=nf90_close(gfile_loc) + nread=0 + mype_read_rank=-1 + do i=1,npe + if (members_read(i) >= 0) then + nread=nread+1 + mype_read_rank(nread) = members_read(i) + endif + enddo + + call setcomm(iworld,iworld_group,nread,mype_read_rank,mpi_comm_read,ierror) + + if (procuse) then + if(fv3_io_layout_y > 1) then + allocate(gfile_loc_layout(0:fv3_io_layout_y-1)) + do nio=0,fv3_io_layout_y-1 + write(filename_layout,'(a,a,I4.4)') trim(filenamein),".",nio + iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) + if(iret/=nf90_noerr) then + write(6,*)'problem opening6 ',trim(filename_layout),gfile_loc_layout(nio),', Status = ',iret + call flush(6) + call stop2(333) + endif + enddo + else + iret=nf90_open(filenamein,nf90_nowrite,gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) !clt + if(iret/=nf90_noerr) then + write(6,*)' problem opening6 ',trim(filenamein),', Status = ',iret + call flush(6) + call stop2(333) + endif + endif + + do ilevtot=kbgn,kend + vgsiname=grd_uv%names(1,ilevtot) + call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname) + if(trim(filenamein) /= trim(filenamein2)) then + write(6,*)'filenamein and filenamein2 are not the same as expected, stop' + call flush(6) + call stop2(333) + endif + ilev=grd_uv%lnames(1,ilevtot) + nz=grd_uv%nsig + nzp1=nz+1 + inative=nzp1-ilev + u_countloc=(/nxcase,nycase+1,1/) + v_countloc=(/nxcase+1,nycase,1/) + u_startloc=(/1,1,inative/) + v_startloc=(/1,1,inative/) + if(fv3_io_layout_y > 1) then + do nio=0,fv3_io_layout_y-1 + u_countloc=(/nxcase,ny_layout_len(nio)+1,1/) + allocate(u2d_layout(nxcase,ny_layout_len(nio)+1)) + call check( nf90_inq_varid(gfile_loc_layout(nio),'u',u_grd_VarId) ) + iret=nf90_get_var(gfile_loc_layout(nio),u_grd_VarId,u2d_layout,start=u_startloc,count=u_countloc) + u2d(:,ny_layout_b(nio):ny_layout_e(nio))=u2d_layout(:,1:ny_layout_len(nio)) + if(nio==fv3_io_layout_y-1) u2d(:,ny_layout_e(nio)+1)=u2d_layout(:,ny_layout_len(nio)+1) + deallocate(u2d_layout) + + v_countloc=(/nxcase+1,ny_layout_len(nio),1/) + allocate(v2d_layout(nxcase+1,ny_layout_len(nio))) + call check( nf90_inq_varid(gfile_loc_layout(nio),'v',v_grd_VarId) ) + iret=nf90_get_var(gfile_loc_layout(nio),v_grd_VarId,v2d_layout,start=v_startloc,count=v_countloc) + v2d(:,ny_layout_b(nio):ny_layout_e(nio))=v2d_layout + deallocate(v2d_layout) + enddo + else + call check( nf90_inq_varid(gfile_loc,'u',u_grd_VarId) ) + iret=nf90_get_var(gfile_loc,u_grd_VarId,u2d,start=u_startloc,count=u_countloc) + call check( nf90_inq_varid(gfile_loc,'v',v_grd_VarId) ) + iret=nf90_get_var(gfile_loc,v_grd_VarId,v2d,start=v_startloc,count=v_countloc) + endif + + if(.not.grid_reverse_flag) then + call reverse_grid_r_uv (u2d,nxcase,nycase+1,1) + call reverse_grid_r_uv (v2d,nxcase+1,nycase,1) + endif + call fv3uv2earth(u2d(:,:),v2d(:,:),nxcase,nycase,uc2d,vc2d) + + ! NOTE on transfor to earth u/v: + ! The u and v before transferring need to be in E-W/N-S grid, which is + ! defined as reversed grid here because it is revered from map view. + ! + ! Have set the following flag for grid orientation + ! grid_reverse_flag=true: E-W/N-S grid + ! grid_reverse_flag=false: W-E/S-N grid + ! + ! So for preparing the wind transferring, need to reverse the grid from + ! W-E/S-N grid to E-W/N-S grid when grid_reverse_flag=false: + ! + ! if(.not.grid_reverse_flag) call reverse_grid_r_uv + ! + ! and the last input parameter for fv3_h_to_ll is alway true: + ! + ! + call fv3_h_to_ll(uc2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) + call fv3_h_to_ll(vc2d,hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) + enddo ! i + + if(fv3_io_layout_y > 1) then + do nio=0,fv3_io_layout_y-1 + iret=nf90_close(gfile_loc_layout(nio)) + enddo + deallocate(gfile_loc_layout) + else + iret=nf90_close(gfile_loc) + endif endif - deallocate(u2d,v2d,uc2d,vc2d) + call mpi_barrier(mpi_comm_world,ierror) + deallocate(u2d,v2d,uc2d,vc2d) + call general_grid2sub(grd_uv,hwork,worksub) ges_u=worksub(1,:,:,:) ges_v=worksub(2,:,:,:) @@ -3533,7 +3594,7 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) ! !$$$ end documentation block - use mpimod, only: mpi_rtype,mpi_comm_world,mype,mpi_info_null + use mpimod, only: mpi_rtype,mpi_comm_world,mype,mpi_info_null,npe,setcomm,mpi_integer,mpi_max use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension use gridmod, only: nlon_regional,nlat_regional use mod_fv3_lola, only: fv3_ll_to_h,fv3_h_to_ll, & @@ -3566,6 +3627,10 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) real(r_kind),allocatable,dimension(:,:):: u2d,v2d,workau2,workav2 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 + logical:: procuse + ! for fv3_io_layout_y > 1 real(r_kind),allocatable,dimension(:,:):: u2d_layout,v2d_layout integer(i_kind) :: nio @@ -3597,117 +3662,143 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) call general_sub2grid(grd_uv,worksub,hwork) filenamein=fv3filenamegin%dynvars - if(fv3_io_layout_y > 1) then - allocate(gfile_loc_layout(0:fv3_io_layout_y-1)) - do nio=0,fv3_io_layout_y-1 - write(filename_layout,'(a,a,I4.4)') trim(filenamein),".",nio - call check( nf90_open(filename_layout,nf90_write,gfile_loc_layout(nio),comm=mpi_comm_world,info=MPI_INFO_NULL) ) - enddo - gfile_loc=gfile_loc_layout(0) - else - call check( nf90_open(filenamein,nf90_write,gfile_loc,comm=mpi_comm_world,info=MPI_INFO_NULL) ) + + procuse = .false. + members=-1 + members_read=-1 + if (kbgn<=kend) then + procuse = .true. + members(mm1) = mype endif - do ilevtot=kbgn,kend - varname=grd_uv%names(1,ilevtot) - ilev=grd_uv%lnames(1,ilevtot) - nz=grd_uv%nsig - nzp1=nz+1 - inative=nzp1-ilev - u_countloc=(/nxcase,nycase+1,1/) - v_countloc=(/nxcase+1,nycase,1/) - u_startloc=(/1,1,inative/) - v_startloc=(/1,1,inative/) + call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror) - work_au=hwork(1,:,:,ilevtot) - work_av=hwork(2,:,:,ilevtot) + nread=0 + mype_read_rank=-1 + do i=1,npe + if (members_read(i) >= 0) then + nread=nread+1 + mype_read_rank(nread) = members_read(i) + endif + enddo - call check( nf90_inq_varid(gfile_loc,'u',ugrd_VarId) ) - call check( nf90_inq_varid(gfile_loc,'v',vgrd_VarId) ) + call setcomm(iworld,iworld_group,nread,mype_read_rank,mpi_comm_read,ierror) - if(add_saved)then - allocate( workau2(nlatcase,nloncase),workav2(nlatcase,nloncase)) - allocate( workbu2(nlon_regional,nlat_regional+1)) - allocate( workbv2(nlon_regional+1,nlat_regional)) -!!!!!!!! readin work_b !!!!!!!!!!!!!!!! - if(fv3_io_layout_y > 1) then + if (procuse) then + if(fv3_io_layout_y > 1) then + allocate(gfile_loc_layout(0:fv3_io_layout_y-1)) do nio=0,fv3_io_layout_y-1 - allocate(u2d_layout(nxcase,ny_layout_len(nio)+1)) - u_countloc=(/nxcase,ny_layout_len(nio)+1,1/) - call check( nf90_get_var(gfile_loc_layout(nio),ugrd_VarId,u2d_layout,start=u_startloc,count=u_countloc) ) - work_bu(:,ny_layout_b(nio):ny_layout_e(nio))=u2d_layout(:,1:ny_layout_len(nio)) - if(nio==fv3_io_layout_y-1) work_bu(:,ny_layout_e(nio)+1)=u2d_layout(:,ny_layout_len(nio)+1) - deallocate(u2d_layout) - - allocate(v2d_layout(nxcase+1,ny_layout_len(nio))) - v_countloc=(/nxcase+1,ny_layout_len(nio),1/) - call check( nf90_get_var(gfile_loc_layout(nio),vgrd_VarId,v2d_layout,start=v_startloc,count=v_countloc) ) - work_bv(:,ny_layout_b(nio):ny_layout_e(nio))=v2d_layout - deallocate(v2d_layout) + write(filename_layout,'(a,a,I4.4)') trim(filenamein),".",nio + call check( nf90_open(filename_layout,nf90_write,gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) ) enddo - else - call check( nf90_get_var(gfile_loc,ugrd_VarId,work_bu,start=u_startloc,count=u_countloc) ) - call check( nf90_get_var(gfile_loc,vgrd_VarId,work_bv,start=v_startloc,count=v_countloc) ) - endif - if(.not.grid_reverse_flag) then - call reverse_grid_r_uv(work_bu,nlon_regional,nlat_regional+1,1) - call reverse_grid_r_uv(work_bv,nlon_regional+1,nlat_regional,1) - endif - call fv3uv2earth(work_bu,work_bv,nlon_regional,nlat_regional,u2d,v2d) - call fv3_h_to_ll(u2d,workau2,nlon_regional,nlat_regional,nloncase,nlatcase,.true.) - call fv3_h_to_ll(v2d,workav2,nlon_regional,nlat_regional,nloncase,nlatcase,.true.) + gfile_loc=gfile_loc_layout(0) + else + call check( nf90_open(filenamein,nf90_write,gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) ) + endif + + do ilevtot=kbgn,kend + varname=grd_uv%names(1,ilevtot) + ilev=grd_uv%lnames(1,ilevtot) + nz=grd_uv%nsig + nzp1=nz+1 + inative=nzp1-ilev + u_countloc=(/nxcase,nycase+1,1/) + v_countloc=(/nxcase+1,nycase,1/) + u_startloc=(/1,1,inative/) + v_startloc=(/1,1,inative/) + + work_au=hwork(1,:,:,ilevtot) + work_av=hwork(2,:,:,ilevtot) + + call check( nf90_inq_varid(gfile_loc,'u',ugrd_VarId) ) + call check( nf90_inq_varid(gfile_loc,'v',vgrd_VarId) ) + + if(add_saved)then + allocate( workau2(nlatcase,nloncase),workav2(nlatcase,nloncase)) + allocate( workbu2(nlon_regional,nlat_regional+1)) + allocate( workbv2(nlon_regional+1,nlat_regional)) +!!!!!!!! readin work_b !!!!!!!!!!!!!!!! + if(fv3_io_layout_y > 1) then + do nio=0,fv3_io_layout_y-1 + allocate(u2d_layout(nxcase,ny_layout_len(nio)+1)) + u_countloc=(/nxcase,ny_layout_len(nio)+1,1/) + call check( nf90_get_var(gfile_loc_layout(nio),ugrd_VarId,u2d_layout,start=u_startloc,count=u_countloc) ) + work_bu(:,ny_layout_b(nio):ny_layout_e(nio))=u2d_layout(:,1:ny_layout_len(nio)) + if(nio==fv3_io_layout_y-1) work_bu(:,ny_layout_e(nio)+1)=u2d_layout(:,ny_layout_len(nio)+1) + deallocate(u2d_layout) + + allocate(v2d_layout(nxcase+1,ny_layout_len(nio))) + v_countloc=(/nxcase+1,ny_layout_len(nio),1/) + call check( nf90_get_var(gfile_loc_layout(nio),vgrd_VarId,v2d_layout,start=v_startloc,count=v_countloc) ) + work_bv(:,ny_layout_b(nio):ny_layout_e(nio))=v2d_layout + deallocate(v2d_layout) + enddo + else + call check( nf90_get_var(gfile_loc,ugrd_VarId,work_bu,start=u_startloc,count=u_countloc) ) + call check( nf90_get_var(gfile_loc,vgrd_VarId,work_bv,start=v_startloc,count=v_countloc) ) + endif + if(.not.grid_reverse_flag) then + call reverse_grid_r_uv(work_bu,nlon_regional,nlat_regional+1,1) + call reverse_grid_r_uv(work_bv,nlon_regional+1,nlat_regional,1) + endif + call fv3uv2earth(work_bu,work_bv,nlon_regional,nlat_regional,u2d,v2d) + call fv3_h_to_ll(u2d,workau2,nlon_regional,nlat_regional,nloncase,nlatcase,.true.) + call fv3_h_to_ll(v2d,workav2,nlon_regional,nlat_regional,nloncase,nlatcase,.true.) !!!!!!!! find analysis_inc: work_a !!!!!!!!!!!!!!!! - work_au(:,:)=work_au(:,:)-workau2(:,:) - work_av(:,:)=work_av(:,:)-workav2(:,:) - call fv3_ll_to_h(work_au(:,:),u2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.) - call fv3_ll_to_h(work_av(:,:),v2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.) - call earthuv2fv3(u2d,v2d,nlon_regional,nlat_regional,workbu2,workbv2) + work_au(:,:)=work_au(:,:)-workau2(:,:) + work_av(:,:)=work_av(:,:)-workav2(:,:) + call fv3_ll_to_h(work_au(:,:),u2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.) + call fv3_ll_to_h(work_av(:,:),v2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.) + call earthuv2fv3(u2d,v2d,nlon_regional,nlat_regional,workbu2,workbv2) !!!!!!!! add analysis_inc to readin work_b !!!!!!!!!!!!!!!! - work_bu(:,:)=work_bu(:,:)+workbu2(:,:) - work_bv(:,:)=work_bv(:,:)+workbv2(:,:) - deallocate(workau2,workbu2,workav2,workbv2) - else - call fv3_ll_to_h(work_au(:,:),u2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.) - call fv3_ll_to_h(work_av(:,:),v2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.) - call earthuv2fv3(u2d,v2d,nlon_regional,nlat_regional,work_bu(:,:),work_bv(:,:)) - endif - if(.not.grid_reverse_flag) then - call reverse_grid_r_uv(work_bu,nlon_regional,nlat_regional+1,1) - call reverse_grid_r_uv(work_bv,nlon_regional+1,nlat_regional,1) - endif - - if(fv3_io_layout_y > 1) then - do nio=0,fv3_io_layout_y-1 - allocate(u2d_layout(nxcase,ny_layout_len(nio)+1)) - u_countloc=(/nxcase,ny_layout_len(nio)+1,1/) - u2d_layout=work_bu(:,ny_layout_b(nio):ny_layout_e(nio)+1) - call check( nf90_put_var(gfile_loc_layout(nio),ugrd_VarId,u2d_layout,start=u_startloc,count=u_countloc) ) - deallocate(u2d_layout) - - allocate(v2d_layout(nxcase+1,ny_layout_len(nio))) - v_countloc=(/nxcase+1,ny_layout_len(nio),1/) - v2d_layout=work_bv(:,ny_layout_b(nio):ny_layout_e(nio)) - call check( nf90_put_var(gfile_loc_layout(nio),vgrd_VarId,v2d_layout,start=v_startloc,count=v_countloc) ) - deallocate(v2d_layout) - enddo - else - call check( nf90_put_var(gfile_loc,ugrd_VarId,work_bu,start=u_startloc,count=u_countloc) ) - call check( nf90_put_var(gfile_loc,vgrd_VarId,work_bv,start=v_startloc,count=v_countloc) ) - endif - enddo !ilevltot + work_bu(:,:)=work_bu(:,:)+workbu2(:,:) + work_bv(:,:)=work_bv(:,:)+workbv2(:,:) + deallocate(workau2,workbu2,workav2,workbv2) + else + call fv3_ll_to_h(work_au(:,:),u2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.) + call fv3_ll_to_h(work_av(:,:),v2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.) + call earthuv2fv3(u2d,v2d,nlon_regional,nlat_regional,work_bu(:,:),work_bv(:,:)) + endif + if(.not.grid_reverse_flag) then + call reverse_grid_r_uv(work_bu,nlon_regional,nlat_regional+1,1) + call reverse_grid_r_uv(work_bv,nlon_regional+1,nlat_regional,1) + endif + + if(fv3_io_layout_y > 1) then + do nio=0,fv3_io_layout_y-1 + allocate(u2d_layout(nxcase,ny_layout_len(nio)+1)) + u_countloc=(/nxcase,ny_layout_len(nio)+1,1/) + u2d_layout=work_bu(:,ny_layout_b(nio):ny_layout_e(nio)+1) + call check( nf90_put_var(gfile_loc_layout(nio),ugrd_VarId,u2d_layout,start=u_startloc,count=u_countloc) ) + deallocate(u2d_layout) + + allocate(v2d_layout(nxcase+1,ny_layout_len(nio))) + v_countloc=(/nxcase+1,ny_layout_len(nio),1/) + v2d_layout=work_bv(:,ny_layout_b(nio):ny_layout_e(nio)) + call check( nf90_put_var(gfile_loc_layout(nio),vgrd_VarId,v2d_layout,start=v_startloc,count=v_countloc) ) + deallocate(v2d_layout) + enddo + else + call check( nf90_put_var(gfile_loc,ugrd_VarId,work_bu,start=u_startloc,count=u_countloc) ) + call check( nf90_put_var(gfile_loc,vgrd_VarId,work_bv,start=v_startloc,count=v_countloc) ) + endif + enddo !ilevltot - if(fv3_io_layout_y > 1) then - do nio=0,fv3_io_layout_y-1 - call check( nf90_close(gfile_loc_layout(nio)) ) - enddo - deallocate(gfile_loc_layout) - else - call check( nf90_close(gfile_loc) ) + if(fv3_io_layout_y > 1) then + do nio=0,fv3_io_layout_y-1 + call check( nf90_close(gfile_loc_layout(nio)) ) + enddo + deallocate(gfile_loc_layout) + else + call check( nf90_close(gfile_loc) ) + endif endif + + call mpi_barrier(mpi_comm_world,ierror) + deallocate(work_bu,work_bv,u2d,v2d) deallocate(work_au,work_av) - end subroutine gsi_fv3ncdf_writeuv subroutine gsi_fv3ncdf_writeuv_v1(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) !$$$ subprogram documentation block @@ -4080,7 +4171,7 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file ! !$$$ end documentation block - use mpimod, only: mpi_rtype,mpi_comm_world,mype,mpi_info_null + use mpimod, only: mpi_rtype,mpi_comm_world,mype,mpi_info_null,npe,setcomm,mpi_integer,mpi_max use mod_fv3_lola, only: fv3_ll_to_h use mod_fv3_lola, only: fv3_h_to_ll use netcdf, only: nf90_open,nf90_close @@ -4112,6 +4203,10 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file real(r_kind),allocatable,dimension(:,:):: workb2,worka2 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 + logical:: procuse + ! for io_layout > 1 real(r_kind),allocatable,dimension(:,:):: work_b_layout integer(i_kind) :: nio @@ -4133,143 +4228,168 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file allocate( workb2(nlon_regional,nlat_regional)) allocate( worka2(nlatcase,nloncase)) - if(fv3_io_layout_y > 1) then - allocate(gfile_loc_layout(0:fv3_io_layout_y-1)) - do nio=0,fv3_io_layout_y-1 - write(filename_layout,'(a,a,I4.4)') trim(filenamein),'.',nio - call check( nf90_open(filename_layout,nf90_write,gfile_loc_layout(nio),comm=mpi_comm_world,info=MPI_INFO_NULL) ) - enddo - gfile_loc=gfile_loc_layout(0) - else - call check( nf90_open(filenamein,nf90_write,gfile_loc,comm=mpi_comm_world,info=MPI_INFO_NULL) ) + procuse = .false. + members=-1 + members_read=-1 + if (kbgn<=kend) then + procuse = .true. + members(mm1) = mype endif - do ilevtot=kbgn,kend - vgsiname=grd_ionouv%names(1,ilevtot) - if(trim(vgsiname)=='amassi') cycle - if(trim(vgsiname)=='amassj') cycle - if(trim(vgsiname)=='amassk') cycle - if(trim(vgsiname)=='pm2_5') cycle - call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname) - if(trim(filenamein) /= trim(filenamein2)) then - write(6,*)'filenamein and filenamein2 are not the same as expected, stop' - call flush(6) - call stop2(333) - endif - ilev=grd_ionouv%lnames(1,ilevtot) - nz=grd_ionouv%nsig - nzp1=nz+1 - inative=nzp1-ilev - countloc=(/nxcase,nycase,1/) - startloc=(/1,1,inative/) - - work_a=hwork(1,:,:,ilevtot) - - if( trim(varname) == 'ref_f3d' )then - iret=nf90_inquire_dimension(gfile_loc,1,name,len) - if(trim(name)=='xaxis_1') nx_phy=len - if( nx_phy == nxcase )then - allocate(work_b_tmp(nxcase,nycase)) - countloc_tmp=(/nxcase,nycase,1/) - phy_smaller_domain = .false. - else - allocate(work_b_tmp(nxcase-6,nycase-6)) - countloc_tmp=(/nxcase-6,nycase-6,1/) - phy_smaller_domain = .true. - end if - startloc_tmp=(/1,1,ilev/) - end if + call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror) - call check( nf90_inq_varid(gfile_loc,trim(varname),VarId) ) + nread=0 + mype_read_rank=-1 + do i=1,npe + if (members_read(i) >= 0) then + nread=nread+1 + mype_read_rank(nread) = members_read(i) + endif + enddo + call setcomm(iworld,iworld_group,nread,mype_read_rank,mpi_comm_read,ierror) - if(index(vgsiname,"delzinc") > 0) then - if(fv3_io_layout_y > 1) then + if (procuse) then + if(fv3_io_layout_y > 1) then + allocate(gfile_loc_layout(0:fv3_io_layout_y-1)) do nio=0,fv3_io_layout_y-1 - countloc=(/nxcase,ny_layout_len(nio),1/) - allocate(work_b_layout(nxcase,ny_layout_len(nio))) - call check( nf90_get_var(gfile_loc_layout(nio),VarId,work_b_layout,start = startloc, count = countloc) ) - work_b(:,ny_layout_b(nio):ny_layout_e(nio))=work_b_layout - deallocate(work_b_layout) + write(filename_layout,'(a,a,I4.4)') trim(filenamein),'.',nio + call check( nf90_open(filename_layout,nf90_write,gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) ) enddo - else - call check( nf90_get_var(gfile_loc,VarId,work_b,start = startloc, count = countloc) ) - endif - call fv3_ll_to_h(work_a(:,:),workb2,nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag) - work_b(:,:)=work_b(:,:)+workb2(:,:) - else - if(add_saved)then - if(fv3_io_layout_y > 1) then + gfile_loc=gfile_loc_layout(0) + else + call check( nf90_open(filenamein,nf90_write,gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) ) + endif + + do ilevtot=kbgn,kend + vgsiname=grd_ionouv%names(1,ilevtot) + if(trim(vgsiname)=='amassi') cycle + if(trim(vgsiname)=='amassj') cycle + if(trim(vgsiname)=='amassk') cycle + if(trim(vgsiname)=='pm2_5') cycle + call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname) + if(trim(filenamein) /= trim(filenamein2)) then + write(6,*)'filenamein and filenamein2 are not the same as expected, stop' + call flush(6) + call stop2(333) + endif + ilev=grd_ionouv%lnames(1,ilevtot) + nz=grd_ionouv%nsig + nzp1=nz+1 + inative=nzp1-ilev + countloc=(/nxcase,nycase,1/) + startloc=(/1,1,inative/) + + work_a=hwork(1,:,:,ilevtot) + + if( trim(varname) == 'ref_f3d' )then + iret=nf90_inquire_dimension(gfile_loc,1,name,len) + if(trim(name)=='xaxis_1') nx_phy=len + if( nx_phy == nxcase )then + allocate(work_b_tmp(nxcase,nycase)) + countloc_tmp=(/nxcase,nycase,1/) + phy_smaller_domain = .false. + else + allocate(work_b_tmp(nxcase-6,nycase-6)) + countloc_tmp=(/nxcase-6,nycase-6,1/) + phy_smaller_domain = .true. + end if + startloc_tmp=(/1,1,ilev/) + end if + + call check( nf90_inq_varid(gfile_loc,trim(varname),VarId) ) + + + if(index(vgsiname,"delzinc") > 0) then + if(fv3_io_layout_y > 1) then + do nio=0,fv3_io_layout_y-1 + countloc=(/nxcase,ny_layout_len(nio),1/) + allocate(work_b_layout(nxcase,ny_layout_len(nio))) + call check( nf90_get_var(gfile_loc_layout(nio),VarId,work_b_layout,start = startloc, count = countloc) ) + work_b(:,ny_layout_b(nio):ny_layout_e(nio))=work_b_layout + deallocate(work_b_layout) + enddo + else + call check( nf90_get_var(gfile_loc,VarId,work_b,start = startloc, count = countloc) ) + endif + call fv3_ll_to_h(work_a(:,:),workb2,nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag) + work_b(:,:)=work_b(:,:)+workb2(:,:) + else + if(add_saved)then + if(fv3_io_layout_y > 1) then + do nio=0,fv3_io_layout_y-1 + countloc=(/nxcase,ny_layout_len(nio),1/) + allocate(work_b_layout(nxcase,ny_layout_len(nio))) + call check( nf90_get_var(gfile_loc_layout(nio),VarId,work_b_layout,start = startloc, count = countloc) ) + work_b(:,ny_layout_b(nio):ny_layout_e(nio))=work_b_layout + deallocate(work_b_layout) + enddo + else + if( trim(varname) == 'ref_f3d' )then + work_b = 0.0_r_kind + call check( nf90_get_var(gfile_loc,VarId,work_b_tmp,start = startloc_tmp, count = countloc_tmp) ) + where(work_b_tmp < 0.0_r_kind) + work_b_tmp = 0.0_r_kind + end where + if(phy_smaller_domain)then + work_b(4:nxcase-3,4:nycase-3) = work_b_tmp + else + work_b(1:nxcase,1:nycase) = work_b_tmp + end if + else + call check( nf90_get_var(gfile_loc,VarId,work_b,start = startloc, count = countloc) ) + end if + endif + call fv3_h_to_ll(work_b(:,:),worka2,nlon_regional,nlat_regional,nloncase,nlatcase,grid_reverse_flag) +!!!!!!!! analysis_inc: work_a !!!!!!!!!!!!!!!! + work_a(:,:)=work_a(:,:)-worka2(:,:) + call fv3_ll_to_h(work_a(:,:),workb2,nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag) + work_b(:,:)=work_b(:,:)+workb2(:,:) + else + call fv3_ll_to_h(work_a(:,:),work_b(:,:),nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag) + endif + endif + if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 countloc=(/nxcase,ny_layout_len(nio),1/) allocate(work_b_layout(nxcase,ny_layout_len(nio))) - call check( nf90_get_var(gfile_loc_layout(nio),VarId,work_b_layout,start = startloc, count = countloc) ) - work_b(:,ny_layout_b(nio):ny_layout_e(nio))=work_b_layout + work_b_layout=work_b(:,ny_layout_b(nio):ny_layout_e(nio)) + call check( nf90_put_var(gfile_loc_layout(nio),VarId,work_b_layout, start = startloc, count = countloc) ) deallocate(work_b_layout) - enddo - else - if( trim(varname) == 'ref_f3d' )then - work_b = 0.0_r_kind - call check( nf90_get_var(gfile_loc,VarId,work_b_tmp,start = startloc_tmp, count = countloc_tmp) ) - where(work_b_tmp < 0.0_r_kind) - work_b_tmp = 0.0_r_kind - end where - if(phy_smaller_domain)then - work_b(4:nxcase-3,4:nycase-3) = work_b_tmp - else - work_b(1:nxcase,1:nycase) = work_b_tmp - end if - else - call check( nf90_get_var(gfile_loc,VarId,work_b,start = startloc, count = countloc) ) - end if - endif - call fv3_h_to_ll(work_b(:,:),worka2,nlon_regional,nlat_regional,nloncase,nlatcase,grid_reverse_flag) -!!!!!!!! analysis_inc: work_a !!!!!!!!!!!!!!!! - work_a(:,:)=work_a(:,:)-worka2(:,:) - call fv3_ll_to_h(work_a(:,:),workb2,nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag) - work_b(:,:)=work_b(:,:)+workb2(:,:) - else - call fv3_ll_to_h(work_a(:,:),work_b(:,:),nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag) - endif - endif - if(fv3_io_layout_y > 1) then - do nio=0,fv3_io_layout_y-1 - countloc=(/nxcase,ny_layout_len(nio),1/) - allocate(work_b_layout(nxcase,ny_layout_len(nio))) - work_b_layout=work_b(:,ny_layout_b(nio):ny_layout_e(nio)) - call check( nf90_put_var(gfile_loc_layout(nio),VarId,work_b_layout, start = startloc, count = countloc) ) - deallocate(work_b_layout) - enddo - else - if( trim(varname) == 'ref_f3d' )then - if(phy_smaller_domain)then - work_b_tmp = work_b(4:nxcase-3,4:nycase-3) - else - work_b_tmp = work_b(1:nxcase,1:nycase) - end if - where(work_b_tmp < 0.0_r_kind) - work_b_tmp = 0.0_r_kind - end where - call check( nf90_put_var(gfile_loc,VarId,work_b_tmp, start = startloc_tmp, count = countloc_tmp) ) - deallocate(work_b_tmp) - else - call check( nf90_put_var(gfile_loc,VarId,work_b, start = startloc, count = countloc) ) - end if - endif - - enddo !ilevtotl loop - if(fv3_io_layout_y > 1) then - do nio=0,fv3_io_layout_y-1 - call check(nf90_close(gfile_loc_layout(nio))) - enddo - deallocate(gfile_loc_layout) - else - call check(nf90_close(gfile_loc)) + enddo + else + if( trim(varname) == 'ref_f3d' )then + if(phy_smaller_domain)then + work_b_tmp = work_b(4:nxcase-3,4:nycase-3) + else + work_b_tmp = work_b(1:nxcase,1:nycase) + end if + where(work_b_tmp < 0.0_r_kind) + work_b_tmp = 0.0_r_kind + end where + call check( nf90_put_var(gfile_loc,VarId,work_b_tmp, start = startloc_tmp, count = countloc_tmp) ) + deallocate(work_b_tmp) + else + call check( nf90_put_var(gfile_loc,VarId,work_b, start = startloc, count = countloc) ) + end if + endif + + enddo !ilevtotl loop + if(fv3_io_layout_y > 1) then + do nio=0,fv3_io_layout_y-1 + call check(nf90_close(gfile_loc_layout(nio))) + enddo + deallocate(gfile_loc_layout) + else + call check(nf90_close(gfile_loc)) + endif endif + + call mpi_barrier(mpi_comm_world,ierror) + deallocate(work_b,work_a) deallocate(workb2,worka2) - end subroutine gsi_fv3ncdf_write subroutine check(status) use kinds, only: i_kind diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index de19c85fab..2656a2dce4 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -2216,7 +2216,7 @@ subroutine gsimain_initialize endif ! Set up directories (or pe specific filenames) - call init_directories(mype) + call init_directories(mype,npe) ! Initialize space for qc call create_qcvars diff --git a/src/gsi/guess_grids.F90 b/src/gsi/guess_grids.F90 index e19ce93638..bf493a0628 100644 --- a/src/gsi/guess_grids.F90 +++ b/src/gsi/guess_grids.F90 @@ -977,18 +977,29 @@ subroutine create_gesfinfo nfldaer_all=nfldaer nfldaer_now=0 extrap_intime=.true. - allocate(hrdifsfc(nfldsfc),ifilesfc(nfldsfc), & - hrdifnst(nfldnst),ifilenst(nfldnst), & - hrdifsig(nfldsig),ifilesig(nfldsig), & - hrdifaer(nfldaer),ifileaer(nfldaer), & - hrdifsfc_all(nfldsfc_all), & - hrdifnst_all(nfldnst_all), & - hrdifsig_all(nfldsig_all), & - hrdifaer_all(nfldaer_all), & - stat=istatus) + if(nfldsig>0) allocate(hrdifsig(nfldsig),ifilesig(nfldsig), & + hrdifsig_all(nfldsig_all), & + stat=istatus) if (istatus/=0) & - write(6,*)'CREATE_GESFINFO(hrdifsfc,..): allocate error, istatus=',& - istatus + call die('CREATE_GESFINFO', '(hrdifsig,..): allocate error, istatus=', istatus) + if(nfldsfc>0) allocate(hrdifsfc(nfldsfc),ifilesfc(nfldsfc), & + hrdifsfc_all(nfldsfc_all), & + stat=istatus) + if (istatus/=0) & + call die('CREATE_GESFINFO', '(hrdifsfc,..): allocate error, istatus=',& + istatus) + if(nfldnst>0) allocate(hrdifnst(nfldnst),ifilenst(nfldnst), & + hrdifnst_all(nfldnst_all), & + stat=istatus) + if (istatus/=0) & + call die('CREATE_GESFINFO', '(hrdifnst,..): allocate error, istatus=',& + istatus) + if(nfldnst>0) allocate(hrdifaer(nfldaer),ifileaer(nfldaer), & + hrdifaer_all(nfldaer_all), & + stat=istatus) + if (istatus/=0) & + call die('CREATE_GESFINFO', '(hrdifaer,..): allocate error, istatus=',& + istatus) #endif /* HAVE_ESMF */ return @@ -1030,11 +1041,18 @@ subroutine destroy_gesfinfo gesfinfo_created_=.false. #ifndef HAVE_ESMF - deallocate(hrdifsfc,ifilesfc,hrdifnst,hrdifaer,ifilenst,hrdifsig,ifilesig,ifileaer,& - hrdifsfc_all,hrdifnst_all,hrdifsig_all,hrdifaer_all,stat=istatus) + if(nfldsig>0) deallocate(hrdifsig,ifilesig,hrdifsig_all,stat=istatus) if (istatus/=0) & - write(6,*)'DESTROY_GESFINFO: deallocate error, istatus=',& - istatus + call die('DESTROY_GESFINFO', 'deallocate error, istatus=',istatus) + if(nfldsfc>0) deallocate(hrdifsfc,ifilesfc,hrdifsfc_all,stat=istatus) + if (istatus/=0) & + call die('DESTROY_GESFINFO', 'deallocate error, istatus=',istatus) + if(nfldnst>0) deallocate(hrdifnst,ifilenst,hrdifnst_all,stat=istatus) + if (istatus/=0) & + call die('DESTROY_GESFINFO', 'deallocate error, istatus=',istatus) + if(nfldnst>0) deallocate(hrdifaer,ifileaer,hrdifaer_all,stat=istatus) + if (istatus/=0) & + call die('DESTROY_GESFINFO', 'deallocate error, istatus=',istatus) nfldsfc_all=0 nfldnst_all=0 diff --git a/src/gsi/mpeu_util.F90 b/src/gsi/mpeu_util.F90 index 960af8b71a..76271a4770 100644 --- a/src/gsi/mpeu_util.F90 +++ b/src/gsi/mpeu_util.F90 @@ -553,22 +553,6 @@ subroutine close_if_(fname,stat) endif end subroutine close_if_ -#ifdef _NEW_CODE_ -!! need to send outputs to variables. -!! need to set return code (stat=). -subroutine ls_(files) ! show information? or just inquire(exists(file)) - call system("ls "//files) -end subroutine ls_ -subroutine rm_(files) ! delete, open();close(status='delete') - call system("rm "//files) -end subroutine rm_ -subroutine mkdir_(dir,mode,parents) - call system("mkdir "//files) -end subroutine mkdir_ -subroutine size_(file) ! faster access? - call system("wc -c "//files) -end subroutine size_ -#endif #endif function myid_(who) diff --git a/src/gsi/obsmod.F90 b/src/gsi/obsmod.F90 index a059586e67..26f8ff1bbf 100644 --- a/src/gsi/obsmod.F90 +++ b/src/gsi/obsmod.F90 @@ -990,7 +990,7 @@ subroutine init_obsmod_dflts return end subroutine init_obsmod_dflts - subroutine init_directories(mype) + subroutine init_directories(in_pe,num_pe) !$$$ subprogram documentation block ! . . . . ! subprogram: create sub-directories @@ -1015,20 +1015,42 @@ subroutine init_directories(mype) ! machine: ibm rs/6000 sp ! !$$$ end documentation block +#ifdef __INTEL_COMPILER + use IFPORT +#endif implicit none - integer(i_kind),intent(in ) :: mype + integer(i_kind),intent(in ) :: in_pe + integer(i_kind),intent(in ) :: num_pe + logical :: l_mkdir_stat character(len=144):: command - character(len=8):: pe_name + character(len=8):: pe_name, loc_pe_name + character(len=128):: loc_dirname + integer(i_kind) :: i if (lrun_subdirs) then - write(pe_name,'(i4.4)') mype + write(pe_name,'(i4.4)') in_pe dirname = 'dir.'//trim(pe_name)//'/' - command = 'mkdir -p -m 755 ' // trim(dirname) - call system(command) +! Only create directories on one PE + if(in_pe == 0) then + do i = 0, num_pe + write(loc_pe_name,'(i4.4)') i + loc_dirname = 'dir.'//trim(loc_pe_name) +#ifdef __INTEL_COMPILER + l_mkdir_stat = MAKEDIRQQ(trim(loc_dirname)) + if(.not. l_mkdir_stat) then + write(6, *) "Failed to create directory ", trim(loc_dirname), " for PE ", loc_pe_name + call stop2(678) + endif +#else + command = 'mkdir -p -m 755 ' // trim(loc_dirname) + call system(command) +#endif + enddo + endif else - write(pe_name,100) mype + write(pe_name,100) in_pe 100 format('pe',i4.4,'.') dirname= trim(pe_name) end if diff --git a/src/gsi/read_files.f90 b/src/gsi/read_files.f90 index 5d29efbace..dadcbff3e5 100644 --- a/src/gsi/read_files.f90 +++ b/src/gsi/read_files.f90 @@ -585,7 +585,7 @@ subroutine read_files(mype) if (nst_gsi > 0 ) call mpi_bcast(time_nst,2*nfldnst,mpi_rtype,npem1,mpi_comm_world,ierror) ! for external aerosol files - if(.not.allocated(time_aer)) allocate(time_aer(nfldaer,2)) + if(lread_ext_aerosol .and. (.not.allocated(time_aer))) allocate(time_aer(nfldaer,2)) if (lread_ext_aerosol) call mpi_bcast(time_aer,2*nfldaer,mpi_rtype,npem1,mpi_comm_world,ierror) call mpi_bcast(iamana,3,mpi_rtype,npem1,mpi_comm_world,ierror) diff --git a/src/gsi/read_iasi.f90 b/src/gsi/read_iasi.f90 index 208b333f49..038188f92a 100644 --- a/src/gsi/read_iasi.f90 +++ b/src/gsi/read_iasi.f90 @@ -826,6 +826,8 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& ! Put satinfo defined channel temperatures into data array do l=1,satinfo_nchan + ! Prevent out of bounds reference from temperature + if ( bufr_index(l) == 0 ) cycle i = bufr_index(l) data_all(l+nreal,itx) = temperature(i) ! brightness temerature end do diff --git a/src/gsi/read_obs.F90 b/src/gsi/read_obs.F90 index 15476e2d04..8e451c75be 100644 --- a/src/gsi/read_obs.F90 +++ b/src/gsi/read_obs.F90 @@ -1526,10 +1526,6 @@ subroutine read_obs(ndata,mype) call read_fl_hdob(nread,npuse,nouse,infile,obstype,lunout,gstime,twind,sis,& prsl_full,nobs_sub1(1,i)) string='READ_FL_HDOB' - else if (index(infile,'uprair') /=0)then - call read_hdraob(nread,npuse,nouse,infile,obstype,lunout,twind,sis,& - prsl_full,hgtl_full,nobs_sub1(1,i),read_rec(i)) - string='READ_UPRAIR' else call read_prepbufr(nread,npuse,nouse,infile,obstype,lunout,twind,sis,& prsl_full,nobs_sub1(1,i),read_rec(i)) diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index 2bf3a7d05d..b72e584155 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -690,7 +690,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! identify drifting buoys - TYP=180/280 T29=562 and last three digits of SID between 500 and 999 ! (see https://www.wmo.int/pages/prog/amp/mmop/wmo-number-rules.html) Set kx to 199/299 - if (id_drifter .and. (kx==180 .or. kx==280) .and. nint(hdr(3))==562) then + if (id_drifter .and. (kx==180 .or. kx==280) .and. nint(hdr(3),r_double)==562) then rstation_id=hdr(4) read(c_station_id,*,iostat=ios) iwmo if (ios == 0 .and. iwmo > 0) then @@ -700,7 +700,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& end if end if - if (id_ship .and. (kx==180) .and. (nint(hdr(3))==522 .or. nint(hdr(3))==523)) then + if (id_ship .and. (kx==180) .and. (nint(hdr(3),r_double)==522 .or. nint(hdr(3),r_double)==523)) then rstation_id=hdr(4) kx = kx + 18 end if @@ -969,7 +969,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! ! identify drifting buoys - TYP=180/280 T29=562 and last three digits of SID between 500 and 999 ! (see https://www.wmo.int/pages/prog/amp/mmop/wmo-number-rules.html) Set kx to 199/299 - if (id_drifter .and. (kx==180 .or. kx==280) .and. nint(hdr(8))==562 ) then + if (id_drifter .and. (kx==180 .or. kx==280) .and. nint(hdr(8),r_double)==562) then rstation_id=hdr(1) read(c_station_id,*,iostat=ios) iwmo if (ios == 0 .and. iwmo > 0) then @@ -979,7 +979,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& end if end if - if (id_ship .and. (kx==180) .and. (nint(hdr(8))==522 .or. nint(hdr(8))==523) ) then + if (id_ship .and. (kx==180) .and. (nint(hdr(8),r_double)==522 .or. nint(hdr(8),r_double)==523) ) then rstation_id=hdr(1) kx = kx + 18 end if @@ -1179,7 +1179,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& enddo do k=1,levs ppb=obsdat(1,k) - cat=nint(min(obsdat(10,k),qcmark_huge)) + cat=idnint(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 @@ -1608,11 +1608,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)=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)) + 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)) end do ! 181, 183, 187, and 188 are the screen-level obs over land @@ -1642,14 +1642,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)=nint(qcmark(3,k)) + tqm(k)=idnint(qcmark(3,k)) exit - endif - endif + 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)=nint(qcmark(3,k)) + tqm(k)=idnint(qcmark(3,k)) end if if (tpc(k,j)>=bmiss) exit ! end of stack end do @@ -1731,11 +1731,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=nint(qcmark(7,k)) + pwq=idnint(qcmark(7,k)) qm=pwq else if(sstob) then sstq=100 - if (k==1) sstq=nint(min(sstdat(4,k),qcmark_huge)) + if (k==1) sstq=idnint(min(sstdat(4,k),qcmark_huge)) qm=sstq else if(gustob) then gustqm=0 @@ -1791,10 +1791,10 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& end if if (psob) then - cat=nint(min(obsdat(10,k),qcmark_huge)) + cat=idnint(min(obsdat(10,k),qcmark_huge)) if ( cat /=0 ) cycle loop_k_levs if ( obsdat(1,k)< r500) qm=100 - zqm=nint(qcmark(4,k)) + zqm=idnint(qcmark(4,k)) if (zqm>=lim_zqm .and. zqm/=15 .and. zqm/=9) qm=9 endif @@ -1804,7 +1804,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 (nint(obsdat(10,k))==7) cycle LOOP_K_LEVS + if (idnint(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 @@ -3270,7 +3270,7 @@ subroutine sonde_ext(obsdat,tpc,qcmark,obserr,drfdat,levsio,kx,vtcd) enddo do k=1,levs - cat(k)=nint(obsdat(10,k)) + cat(k)=idnint(obsdat(10,k)) enddo @@ -3287,10 +3287,10 @@ subroutine sonde_ext(obsdat,tpc,qcmark,obserr,drfdat,levsio,kx,vtcd) if(kx==120)then - 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)) + 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)) call grdcrd(dpres,levs,prsltmp(1),nsig,-1) do k=1,levs tvflg(k)=one ! initialize as sensible @@ -3302,10 +3302,10 @@ subroutine sonde_ext(obsdat,tpc,qcmark,obserr,drfdat,levsio,kx,vtcd) do i=2,levs im=i-1 - 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)) + 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)) 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 @@ -3361,14 +3361,14 @@ subroutine sonde_ext(obsdat,tpc,qcmark,obserr,drfdat,levsio,kx,vtcd) enddo !levs !!!!!!!!! w (not used) !!!!!!!!!!!!!!!!!!!!!!!!!!! elseif(kx==220)then - pqm(1)=nint(min(qcmark(1,1),10000.0)) - wqm(1)=nint(min(qcmark(5,1),10000.0)) + pqm(1)=idnint(min(qcmark(1,1),10000.0)) + wqm(1)=idnint(min(qcmark(5,1),10000.0)) call grdcrd(dpres,levs,prsltmp(1),nsig,-1) do i=2,levs im=i-1 - 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)) + 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)) 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 8e5de5aff9..40c77a7ee2 100644 --- a/src/gsi/read_radar.f90 +++ b/src/gsi/read_radar.f90 @@ -341,7 +341,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu if (.not.lexist1 .and. .not.lexist2 .and. .not.lexist3) return eradkm=rearth*0.001_r_kind - maxobs=2e8 + maxobs=4e6 nreal=maxdat nchanl=0 ilon=2 diff --git a/src/gsi/setupaod.f90 b/src/gsi/setupaod.f90 index a1e4656e76..5fe4233ada 100644 --- a/src/gsi/setupaod.f90 +++ b/src/gsi/setupaod.f90 @@ -61,7 +61,8 @@ subroutine setupaod(obsLL,odiagLL,lunin,mype,nchanl,nreal,nobs,& dplat,lobsdiagsave,lobsdiag_allocated,& dirname,time_offset,luse_obsdiag use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & - nc_diag_write, nc_diag_data2d, nc_diag_chaninfo_dim_set, nc_diag_chaninfo + nc_diag_write, nc_diag_data2d, nc_diag_chaninfo_dim_set, nc_diag_chaninfo, & + nc_diag_metadata_to_single use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close use gsi_4dvar, only: nobs_bins,hr_obsbin use gridmod, only: nsig,get_ij @@ -841,16 +842,16 @@ subroutine contents_netcdf_diag_ if ( iuse_aero(l) < 0 ) cycle call nc_diag_metadata("Channel_Index", i) call nc_diag_metadata("Observation_Class", obsclass) - call nc_diag_metadata("Latitude", sngl(cenlat)) ! observation latitude (degrees) - call nc_diag_metadata("Longitude", sngl(cenlon)) ! observation longitude (degrees) - call nc_diag_metadata("Obs_Time", sngl(dtime))!-time_offset)) ! observation time (hours relative to analysis time) - call nc_diag_metadata("Sol_Zenith_Angle", sngl(pangs)) ! solar zenith angle (degrees) - call nc_diag_metadata("Sol_Azimuth_Angle", sngl(data_s(isazi_ang,n))) ! solar azimuth angle (degrees) + call nc_diag_metadata_to_single("Latitude",(cenlat)) ! observation latitude (degrees) + call nc_diag_metadata_to_single("Longitude",(cenlon)) ! observation longitude (degrees) + call nc_diag_metadata_to_single("Obs_Time",(dtime))!-time_offset)) ! observation time (hours relative to analysis time) + call nc_diag_metadata_to_single("Sol_Zenith_Angle",(pangs)) ! solar zenith angle (degrees) + call nc_diag_metadata_to_single("Sol_Azimuth_Angle",(data_s(isazi_ang,n))) ! solar azimuth angle (degrees) call nc_diag_metadata("Surface_type", nint(data_s(istyp,n))) call nc_diag_metadata("MODIS_deep_blue_flag", nint(dbcf) ) - call nc_diag_metadata("Observation", sngl(diagbufchan(1,i)) ) ! observed aod - call nc_diag_metadata("Obs_Minus_Forecast_adjusted",sngl(diagbufchan(2,i))) - call nc_diag_metadata("Obs_Minus_Forecast_unadjusted",sngl(diagbufchan(2,i)))! obs - sim aod with no bias correction + call nc_diag_metadata("Observation",(diagbufchan(1,i)) ) ! observed aod + call nc_diag_metadata("Obs_Minus_Forecast_adjusted",(diagbufchan(2,i))) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted",(diagbufchan(2,i)))! obs - sim aod with no bias correction if (diagbufchan(3,i) > tiny_r_kind) then tmp(1)=one/diagbufchan(3,i) @@ -859,7 +860,7 @@ subroutine contents_netcdf_diag_ end if call nc_diag_metadata("Observation_Error",tmp(1)) - call nc_diag_metadata("QC_Flag", sngl(diagbufchan(4,i))) !quality control mark or event indicator + call nc_diag_metadata("QC_Flag",(diagbufchan(4,i))) !quality control mark or event indicator tmp(1)=get_zsfc() call nc_diag_metadata("sfc_height",tmp(1)) ! height in meters diff --git a/src/gsi/setupdbz.f90 b/src/gsi/setupdbz.f90 index 96f0378c52..068842cd6b 100644 --- a/src/gsi/setupdbz.f90 +++ b/src/gsi/setupdbz.f90 @@ -131,7 +131,7 @@ subroutine setupdbz(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,radardbz_d use obsmod, only: luse_obsdiag, netcdf_diag, binary_diag, dirname, ianldate use obsmod, only: doradaroneob,oneobddiff,oneobvalue use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & - nc_diag_write, nc_diag_data2d + nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim,nc_diag_read_close use oneobmod, only: oneobtest use oneobmod, only: maginnov @@ -1928,29 +1928,29 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Observation_Class", obsclass ) call nc_diag_metadata("Observation_Type", ictype(ikx) ) call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) - call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) - call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) - call nc_diag_metadata("Station_Elevation", sngl(data(ielev,i)) ) - call nc_diag_metadata("Pressure", sngl(presw) ) - call nc_diag_metadata("Height", sngl(data(ihgt,i)) ) - call nc_diag_metadata("Time", sngl(dtime-time_offset)) - call nc_diag_metadata("Prep_QC_Mark", sngl(zero) ) - call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + call nc_diag_metadata_to_single("Latitude", data(ilate,i) ) + call nc_diag_metadata_to_single("Longitude", data(ilone,i) ) + call nc_diag_metadata_to_single("Station_Elevation",data(ielev,i) ) + call nc_diag_metadata_to_single("Pressure", presw ) + call nc_diag_metadata_to_single("Height", data(ihgt,i) ) + call nc_diag_metadata_to_single("Time", dtime, time_offset, "-") + call nc_diag_metadata_to_single("Prep_QC_Mark", zero ) + call nc_diag_metadata_to_single("Prep_Use_Flag", data(iuse,i) ) ! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ! ) - call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt ) if(muse(i)) then - call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + call nc_diag_metadata_to_single("Analysis_Use_Flag",one ) else - call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + call nc_diag_metadata_to_single("Analysis_Use_Flag",-one ) endif - call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) - call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) - call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + call nc_diag_metadata_to_single("Errinv_Input", errinv_input ) + call nc_diag_metadata_to_single("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata_to_single("Errinv_Final", errinv_final ) - call nc_diag_metadata("Observation", sngl(data(idbzob,i)) ) - call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) - call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(data(idbzob,i)-rdBZ) ) + call nc_diag_metadata_to_single("Observation", data(idbzob,i) ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted", data(idbzob,i), rdBZ, "-") if (lobsdiagsave) then do jj=1,miter diff --git a/src/gsi/setupdw.f90 b/src/gsi/setupdw.f90 index 93749b2ad9..63c0df4b19 100644 --- a/src/gsi/setupdw.f90 +++ b/src/gsi/setupdw.f90 @@ -37,7 +37,7 @@ subroutine setupdw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa use obsmod, only: rmiss_single,lobsdiag_forenkf use obsmod, only: netcdf_diag, binary_diag, dirname, ianldate use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & - nc_diag_write, nc_diag_data2d + nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close use m_obsdiagNode, only: obs_diag use m_obsdiagNode, only: obs_diags @@ -904,29 +904,29 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Observation_Class", obsclass ) call nc_diag_metadata("Observation_Type", ictype(ikx) ) call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) - call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) - call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata_to_single("Latitude", data(ilate,i) ) + call nc_diag_metadata_to_single("Longitude", data(ilone,i) ) call nc_diag_metadata("Station_Elevation", missing ) - call nc_diag_metadata("Pressure", sngl(presw) ) - call nc_diag_metadata("Height", sngl(data(ihgt,i)) ) - call nc_diag_metadata("Time", sngl(dtime-time_offset)) + call nc_diag_metadata_to_single("Pressure", presw ) + call nc_diag_metadata_to_single("Height", data(ihgt,i) ) + call nc_diag_metadata_to_single("Time", dtime,time_offset,"-" ) call nc_diag_metadata("Prep_QC_Mark", missing ) - call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + call nc_diag_metadata_to_single("Prep_Use_Flag", data(iuse,i) ) ! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) - call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt ) if(muse(i)) then - call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + call nc_diag_metadata_to_single("Analysis_Use_Flag",one ) else - call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + call nc_diag_metadata_to_single("Analysis_Use_Flag",-one ) endif - call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) - call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) - call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + call nc_diag_metadata_to_single("Errinv_Input",errinv_input ) + call nc_diag_metadata_to_single("Errinv_Adjust",errinv_adjst ) + call nc_diag_metadata_to_single("Errinv_Final",errinv_final ) - call nc_diag_metadata("Observation", sngl(data(ilob,i))) - call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) - call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(data(ilob,i)-dwwind)) + call nc_diag_metadata_to_single("Observation",data(ilob,i) ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted", data(ilob,i), dwwind, '-') !_RT_NC4_TODO !_RT rdiagbuf(20,ii) = factw ! 10m wind reduction factor diff --git a/src/gsi/setuplight.f90 b/src/gsi/setuplight.f90 index e9ed19d3c3..040ef19bc6 100644 --- a/src/gsi/setuplight.f90 +++ b/src/gsi/setuplight.f90 @@ -90,7 +90,7 @@ subroutine setuplight(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,light_di nobskeep,lobsdiag_allocated use obsmod, only: netcdf_diag, binary_diag, dirname, ianldate use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & - nc_diag_write, nc_diag_data2d + nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close use obsmod, only: luse_obsdiag use m_obsNode, only: obsNode @@ -1619,25 +1619,25 @@ subroutine contents_netcdf_diag_(odiag) real(r_single),parameter:: missing = -9.99e9_r_single real(r_kind),dimension(miter) :: obsdiag_iuse - call nc_diag_metadata("GLM_Detect_Err", sngl(data(ier,i)) ) - call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) - call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) - call nc_diag_metadata("Lightning_FR_Obs", sngl(dlight ) ) - call nc_diag_metadata("Time", sngl(dtime) ) - call nc_diag_metadata("GLM_QC_Mark", sngl(data(iqc,i)) ) - call nc_diag_metadata("GLM_Orig_Detect_Err", sngl(data(ier2,i)) ) - call nc_diag_metadata("GLM_Use_Flag", sngl(data(iuse,i)) ) + call nc_diag_metadata_to_single("GLM_Detect_Err", data(ier,i) ) + call nc_diag_metadata_to_single("Latitude", data(ilate,i) ) + call nc_diag_metadata_to_single("Longitude", data(ilone,i) ) + call nc_diag_metadata_to_single("Lightning_FR_Obs", dlight ) + call nc_diag_metadata_to_single("Time", dtime ) + call nc_diag_metadata_to_single("GLM_QC_Mark", data(iqc,i) ) + call nc_diag_metadata_to_single("GLM_Orig_Detect_Err", data(ier2,i) ) + call nc_diag_metadata_to_single("GLM_Use_Flag", data(iuse,i) ) if(muse(i)) then call nc_diag_metadata("Analysis_Use_Flag", 1._r_single ) else call nc_diag_metadata("Analysis_Use_Flag", -1._r_single ) endif - call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) - call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) - call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) - call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) - call nc_diag_metadata("Obs_Minus_Forecast_VarBC", sngl(ddiff) ) - call nc_diag_metadata("Obs_Minus_Forecast_NoVarBC", sngl(dlight-lightges0) ) + call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt ) + call nc_diag_metadata_to_single("Errinv_Input", errinv_input ) + call nc_diag_metadata_to_single("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata_to_single("Errinv_Final", errinv_final ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_VarBC",ddiff ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_NoVarBC",dlight,lightges0,'-') if (lobsdiagsave) then do jj=1,miter if (odiag%muse(jj)) then @@ -1650,7 +1650,7 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) - call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) endif end subroutine contents_netcdf_diag_ diff --git a/src/gsi/setuplwcp.f90 b/src/gsi/setuplwcp.f90 index 7e06144f68..7b1549aab4 100644 --- a/src/gsi/setuplwcp.f90 +++ b/src/gsi/setuplwcp.f90 @@ -68,7 +68,7 @@ subroutine setuplwcp(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag use obsmod, only: netcdf_diag, binary_diag, dirname use nc_diag_write_mod, only: nc_diag_init, nc_diag_header,nc_diag_metadata, & - nc_diag_write, nc_diag_data2d + nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim,nc_diag_read_close use state_vectors, only: svars3d, levels @@ -848,28 +848,28 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Observation_Class", obsclass ) call nc_diag_metadata("Observation_Type", ictype(ikx) ) call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) - call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) - call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) - call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) - call nc_diag_metadata("Pressure", sngl(data(iobsprs,i)) ) - call nc_diag_metadata("Height", sngl(data(iobshgt,i)) ) - call nc_diag_metadata("Time", sngl(dtime-time_offset)) - call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) - call nc_diag_metadata("Setup_QC_Mark", sngl(rmiss_single) ) - call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + call nc_diag_metadata_to_single("Latitude", data(ilate,i) ) + call nc_diag_metadata_to_single("Longitude", data(ilone,i) ) + call nc_diag_metadata_to_single("Station_Elevation",data(istnelv,i) ) + call nc_diag_metadata_to_single("Pressure", data(iobsprs,i) ) + call nc_diag_metadata_to_single("Height", data(iobshgt,i) ) + call nc_diag_metadata_to_single("Time", dtime,time_offset,'-' ) + call nc_diag_metadata_to_single("Prep_QC_Mark", data(iqc,i) ) + call nc_diag_metadata("Setup_QC_Mark", rmiss_single ) + call nc_diag_metadata_to_single("Prep_Use_Flag", data(iuse,i) ) if(muse(i)) then - call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + call nc_diag_metadata("Analysis_Use_Flag", 1.0_r_single ) else - call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + call nc_diag_metadata("Analysis_Use_Flag", -1.0_r_single ) endif - call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) - call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) - call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) - call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) - call nc_diag_metadata("Observation", sngl(dlwcp) ) - call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) - call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(dlwcp-lwcpges)) + call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt ) + call nc_diag_metadata_to_single("Errinv_Input", errinv_input ) + call nc_diag_metadata_to_single("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata_to_single("Errinv_Final", errinv_final ) + call nc_diag_metadata_to_single("Observation", dlwcp ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",dlwcp,lwcpges,'-') if (lobsdiagsave) then do jj=1,miter diff --git a/src/gsi/setupoz.f90 b/src/gsi/setupoz.f90 index 34f94d3a10..d7a85de0b2 100644 --- a/src/gsi/setupoz.f90 +++ b/src/gsi/setupoz.f90 @@ -115,7 +115,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& use state_vectors, only: svars3d, levels, nsdim - use constants, only : zero,half,one,two,tiny_r_kind + use constants, only : zero,half,one,two,tiny_r_kind,r_missing use constants, only : constoz,rozcon,cg_term,wgtlim,h300,r10,r100,r1000 use m_obsdiagNode, only : obs_diag @@ -138,7 +138,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& use obsmod, only: netcdf_diag, binary_diag, dirname use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & - nc_diag_write, nc_diag_data2d + nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close use gsi_4dvar, only: nobs_bins,hr_obsbin @@ -609,31 +609,35 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& sngl(prsitmp(1)*r1000) ) endif call nc_diag_metadata("MPI_Task_Number", mype ) - call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) - call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) - call nc_diag_metadata("Time", sngl(data(itime,i)-time_offset) ) - call nc_diag_metadata("Reference_Pressure",sngl(pobs(k)*r100) ) + call nc_diag_metadata_to_single("Latitude",(data(ilate,i)) ) + call nc_diag_metadata_to_single("Longitude",(data(ilone,i)) ) + if(isnan(dtime) .or. isnan(time_offset)) then + call nc_diag_metadata("Time",sngl(real(r_missing))) + else + call nc_diag_metadata("Time",sngl(dtime-time_offset)) + endif + call nc_diag_metadata_to_single("Reference_Pressure",(pobs(k)*r100)) call nc_diag_metadata("Analysis_Use_Flag", iouse(k) ) - call nc_diag_metadata("Observation", sngl(ozobs(k))) - call nc_diag_metadata("Inverse_Observation_Error", sngl(errorinv)) - call nc_diag_metadata("Input_Observation_Error", sngl(error(k))) - call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ozone_inv(k))) - call nc_diag_metadata("Obs_Minus_Forecast_unadjusted",sngl(ozone_inv(k))) - call nc_diag_metadata("Forecast_unadjusted", sngl(ozges(k))) - call nc_diag_metadata("Forecast_adjusted",sngl(ozges(k))) + call nc_diag_metadata_to_single("Observation",(ozobs(k))) + call nc_diag_metadata_to_single("Inverse_Observation_Error",(errorinv)) + call nc_diag_metadata_to_single("Input_Observation_Error", (error(k))) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",(ozone_inv(k))) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",(ozone_inv(k))) + call nc_diag_metadata_to_single("Forecast_unadjusted", (ozges(k))) + call nc_diag_metadata_to_single("Forecast_adjusted", (ozges(k))) if (obstype == 'gome' .or. obstype == 'omieff' .or. & obstype == 'omi' .or. obstype == 'tomseff' .or. & obstype == 'ompsnmeff' .or. obstype == 'ompsnm') then - call nc_diag_metadata("Solar_Zenith_Angle", sngl(data(isolz,i)) ) - call nc_diag_metadata("Scan_Position", sngl(data(ifovn,i)) ) + call nc_diag_metadata_to_single("Solar_Zenith_Angle",(data(isolz,i)) ) + call nc_diag_metadata_to_single("Scan_Position",(data(ifovn,i)) ) else - call nc_diag_metadata("Solar_Zenith_Angle", sngl(rmiss) ) - call nc_diag_metadata("Scan_Position", sngl(rmiss) ) + call nc_diag_metadata_to_single("Solar_Zenith_Angle",(rmiss) ) + call nc_diag_metadata_to_single("Scan_Position",(rmiss) ) endif if (obstype == 'omieff' .or. obstype == 'omi' ) then - call nc_diag_metadata("Row_Anomaly_Index", sngl(data(itoqf,i)) ) + call nc_diag_metadata_to_single("Row_Anomaly_Index",(data(itoqf,i)) ) else - call nc_diag_metadata("Row_Anomaly_Index", sngl(rmiss) ) + call nc_diag_metadata_to_single("Row_Anomaly_Index",(rmiss) ) endif if (save_jacobian) then call nc_diag_data2d("Observation_Operator_Jacobian_stind", dhx_dx%st_ind) @@ -1085,7 +1089,7 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& use obsmod, only: netcdf_diag, binary_diag, dirname ! use obsmod, only: wrtgeovals use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & - nc_diag_write, nc_diag_data2d + nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close use m_obsNode, only: obsNode use m_o3lNode, only : o3lNode @@ -1717,25 +1721,26 @@ subroutine contents_netcdf_diag_(odiag) ! Observation class character(7),parameter :: obsclass = ' ozlev' real(r_kind),dimension(miter) :: obsdiag_iuse - call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) - call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata_to_single("Latitude", data(ilate,i) ) + call nc_diag_metadata_to_single("Longitude", data(ilone,i) ) call nc_diag_metadata("MPI_Task_Number", mype ) - call nc_diag_metadata("Time", sngl(data(itime,i)-time_offset)) - call nc_diag_metadata("Inverse_Observation_Error", sngl(errorinv) ) - call nc_diag_metadata("Observation", sngl(ozlv) ) - call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ozone_inv) ) - call nc_diag_metadata("Obs_Minus_Forecast_unadjusted",sngl(ozone_inv) ) - call nc_diag_metadata("Reference_Pressure", sngl(preso3l*r100) ) ! Pa + call nc_diag_metadata_to_single("Time", dtime,time_offset,'-' ) + call nc_diag_metadata_to_single("Inverse_Observation_Error",errorinv ) + call nc_diag_metadata_to_single("Observation", ozlv ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ozone_inv ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",ozone_inv ) + call nc_diag_metadata_to_single("Reference_Pressure", preso3l*r100 ) ! Pa if(luse(i)) then - call nc_diag_metadata("Analysis_Use_Flag", one ) + call nc_diag_metadata_to_single("Analysis_Use_Flag", one ) else - call nc_diag_metadata("Analysis_Use_Flag", -one ) + call nc_diag_metadata_to_single("Analysis_Use_Flag", -one ) endif - call nc_diag_metadata("Input_Observation_Error", sngl(obserror) ) + + call nc_diag_metadata_to_single("Input_Observation_Error",obserror ) if(obstype =="ompslp")then - call nc_diag_metadata("Log10 Air Number Density", sngl(airnd)) - call nc_diag_metadata("Log10 Ozone Number Density UV", sngl(uvnd)) - call nc_diag_metadata("Log10 Ozone Number Density VIS",sngl(visnd)) + call nc_diag_metadata_to_single("Log10 Air Number Density",airnd ) + call nc_diag_metadata_to_single("Log10 Ozone Number Density UV",uvnd ) + call nc_diag_metadata_to_single("Log10 Ozone Number Density VIS",visnd ) endif call nc_diag_metadata("Forecast_adjusted", sngl(o3ppmv)) call nc_diag_metadata("Forecast_unadjusted", sngl(o3ppmv)) diff --git a/src/gsi/setupps.f90 b/src/gsi/setupps.f90 index 6a0fdd4fb2..118ccb45d2 100644 --- a/src/gsi/setupps.f90 +++ b/src/gsi/setupps.f90 @@ -125,7 +125,7 @@ subroutine setupps(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa use obsmod, only: netcdf_diag, binary_diag, dirname use obsmod, only: l_obsprvdiag use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & - nc_diag_write, nc_diag_data2d + nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close use gridmod, only: nsig,get_ij,twodvar_regional use constants, only: zero,one_tenth,one,half,pi,g_over_rd, & @@ -890,30 +890,31 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Observation_Class", obsclass ) call nc_diag_metadata("Observation_Type", ictype(ikx) ) call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) - call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) - call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) - call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) - call nc_diag_metadata("Pressure", sngl(data(ipres,i)*r10)) - call nc_diag_metadata("Height", sngl(dhgt) ) - call nc_diag_metadata("Time", sngl(dtime-time_offset)) - call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) - call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) - call nc_diag_metadata("Nonlinear_QC_Var_Jb", sngl(var_jb) ) - call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + !Replace direct calls to nc_diag_metadata with the screening subroutine + call nc_diag_metadata_to_single("Latitude", data(ilate,i) ) + call nc_diag_metadata_to_single("Longitude", data(ilone,i) ) + call nc_diag_metadata_to_single("Station_Elevation",data(istnelv,i) ) + call nc_diag_metadata_to_single("Pressure", data(ipres,i),r10,'*' ) + call nc_diag_metadata_to_single("Height", dhgt ) + call nc_diag_metadata_to_single("Time", dtime,time_offset,'-' ) + call nc_diag_metadata_to_single("Prep_QC_Mark", data(iqc,i) ) + call nc_diag_metadata_to_single("Prep_Use_Flag", data(iuse,i) ) + call nc_diag_metadata_to_single("Nonlinear_QC_Var_Jb",var_jb ) + call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt ) if(muse(i)) then - call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + call nc_diag_metadata("Analysis_Use_Flag", 1.0_r_single ) else - call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + call nc_diag_metadata("Analysis_Use_Flag", 1.0_r_single ) endif - call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) - call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) - call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + call nc_diag_metadata_to_single("Errinv_Input", errinv_input ) + call nc_diag_metadata_to_single("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata_to_single("Errinv_Final", errinv_final ) + + call nc_diag_metadata_to_single("Observation", pob ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",pob,pges,'-') + call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",pob,pgesorig,'-') - call nc_diag_metadata("Observation", sngl(pob) ) - call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(pob-pges) ) - call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(pob-pgesorig)) - if (lobsdiagsave) then do jj=1,miter diff --git a/src/gsi/setuppw.f90 b/src/gsi/setuppw.f90 index b22d4eb661..08872c0a51 100644 --- a/src/gsi/setuppw.f90 +++ b/src/gsi/setuppw.f90 @@ -96,7 +96,7 @@ subroutine setuppw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset use obsmod, only: netcdf_diag, binary_diag, dirname use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & - nc_diag_write, nc_diag_data2d + nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close use m_obsNode, only: obsNode use m_pwNode, only: pwNode @@ -721,27 +721,27 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Observation_Class", obsclass ) call nc_diag_metadata("Observation_Type", ictype(ikx) ) call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) - call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) - call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) - call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) - call nc_diag_metadata("Pressure", sngl(prest) ) - call nc_diag_metadata("Height", sngl(data(iobshgt,i)) ) - call nc_diag_metadata("Time", sngl(dtime-time_offset) ) - call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) - call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + call nc_diag_metadata_to_single("Latitude", data(ilate,i) ) + call nc_diag_metadata_to_single("Longitude", data(ilone,i) ) + call nc_diag_metadata_to_single("Station_Elevation", data(istnelv,i) ) + call nc_diag_metadata_to_single("Pressure", prest ) + call nc_diag_metadata_to_single("Height", data(iobshgt,i) ) + call nc_diag_metadata_to_single("Time", dtime,time_offset,'-' ) + call nc_diag_metadata_to_single("Prep_QC_Mark", data(iqc,i) ) + call nc_diag_metadata_to_single("Prep_Use_Flag", data(iuse,i) ) call nc_diag_metadata("Setup_QC_Mark", missing ) if(muse(i)) then call nc_diag_metadata("Analysis_Use_Flag", 1._r_single ) else call nc_diag_metadata("Analysis_Use_Flag", -1._r_single ) endif - call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) - call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) - call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) - call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) - call nc_diag_metadata("Observation", sngl(dpw) ) - call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) - call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(dpw-pwges) ) + call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt ) + call nc_diag_metadata_to_single("Errinv_Input", errinv_input ) + call nc_diag_metadata_to_single("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata_to_single("Errinv_Final", errinv_final ) + call nc_diag_metadata_to_single("Observation", dpw ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted", dpw,pwges,'-' ) if (lobsdiagsave) then do jj=1,miter if (odiag%muse(jj)) then diff --git a/src/gsi/setupq.f90 b/src/gsi/setupq.f90 index 554fe3e3dd..aa557b72c2 100644 --- a/src/gsi/setupq.f90 +++ b/src/gsi/setupq.f90 @@ -152,7 +152,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav use obsmod, only: netcdf_diag, binary_diag, dirname use obsmod, only: l_obsprvdiag use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & - nc_diag_write, nc_diag_data2d + nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset use oneobmod, only: oneobtest,maginnov,magoberr @@ -1362,31 +1362,31 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Observation_Class", obsclass ) call nc_diag_metadata("Observation_Type", ictype(ikx) ) call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) - call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) - call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata_to_single("Latitude", data(ilate,i) ) + call nc_diag_metadata_to_single("Longitude", data(ilone,i) ) ! this is the obs height after being interpolated to the model (=model height) - call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) - call nc_diag_metadata("Pressure", sngl(presq) ) + call nc_diag_metadata_to_single("Station_Elevation",data(istnelv,i) ) + call nc_diag_metadata_to_single("Pressure", presq ) ! this is the original obs height (= stn elevation, before being interpolated) - call nc_diag_metadata("Height", sngl(data(iobshgt,i)) ) - call nc_diag_metadata("Time", sngl(dtime-time_offset)) - call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) - call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) - call nc_diag_metadata("Nonlinear_QC_Var_Jb", sngl(var_jb) ) - call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + call nc_diag_metadata_to_single("Height", data(iobshgt,i) ) + call nc_diag_metadata_to_single("Time", dtime,time_offset,'-' ) + call nc_diag_metadata_to_single("Prep_QC_Mark", data(iqc,i) ) + call nc_diag_metadata_to_single("Prep_Use_Flag",data(iuse,i) ) + call nc_diag_metadata_to_single("Nonlinear_QC_Var_Jb",var_jb ) + call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt ) if(muse(i)) then - call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + call nc_diag_metadata("Analysis_Use_Flag", 1.0_r_single ) else - call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + call nc_diag_metadata("Analysis_Use_Flag", -1.0_r_single ) endif - call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) - call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) - call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) - - call nc_diag_metadata("Observation", sngl(data(iqob,i))) - call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) - call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(qob-qges) ) - call nc_diag_metadata("Forecast_Saturation_Spec_Hum", sngl(qsges) ) + call nc_diag_metadata_to_single("Errinv_Input", errinv_input ) + call nc_diag_metadata_to_single("Errinv_Adjust",errinv_adjst ) + call nc_diag_metadata_to_single("Errinv_Final", errinv_final ) + + call nc_diag_metadata_to_single("Observation", data(iqob,i) ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",qob,qges,'-') + call nc_diag_metadata_to_single("Forecast_Saturation_Spec_Hum",qsges ) if (lobsdiagsave) then do jj=1,miter if (odiag%muse(jj)) then @@ -1399,14 +1399,14 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) - call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) endif if (twodvar_regional .or. l_obsprvdiag) then call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i) ) call nc_diag_metadata("Model_Terrain", data(izz,i) ) r_prvstg = data(iprvd,i) - call nc_diag_metadata("Provider_Name", c_prvstg ) + call nc_diag_metadata("Provider_Name", c_prvstg ) r_sprvstg = data(isprvd,i) call nc_diag_metadata("Subprovider_Name", c_sprvstg ) endif @@ -1428,29 +1428,29 @@ subroutine contents_netcdf_diagp_(odiag) call nc_diag_metadata("Observation_Class", obsclass ) call nc_diag_metadata("Observation_Type", ictype(ikx) ) call nc_diag_metadata("Observation_Subtype", -1 ) ! (-1 for pseudo obs sub-type) - call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) - call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) - call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) - call nc_diag_metadata("Pressure", sngl(presq) ) - call nc_diag_metadata("Height", sngl(data(iobshgt,i)) ) - call nc_diag_metadata("Time", sngl(dtime-time_offset)) - call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) - call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) - call nc_diag_metadata("Nonlinear_QC_Var_Jb", sngl(var_jb) ) - call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + call nc_diag_metadata_to_single("Latitude", data(ilate,i) ) + call nc_diag_metadata_to_single("Longitude", data(ilone,i) ) + call nc_diag_metadata_to_single("Station_Elevation",data(istnelv,i) ) + call nc_diag_metadata_to_single("Pressure", presq ) + call nc_diag_metadata_to_single("Height", data(iobshgt,i) ) + call nc_diag_metadata_to_single("Time", dtime,time_offset,'-' ) + call nc_diag_metadata_to_single("Prep_QC_Mark", data(iqc,i) ) + call nc_diag_metadata_to_single("Prep_Use_Flag", data(iuse,i) ) + call nc_diag_metadata_to_single("Nonlinear_QC_Var_Jb",var_jb ) + call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt ) if(muse(i)) then - call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + call nc_diag_metadata("Analysis_Use_Flag", 1.0_r_single ) else - call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + call nc_diag_metadata("Analysis_Use_Flag", -1.0_r_single ) endif - call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) - call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) - call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) - - call nc_diag_metadata("Observation", sngl(data(iqob,i))) - call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) - call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(ddiff) ) - call nc_diag_metadata("Forecast_Saturation_Spec_Hum", sngl(qsges) ) + call nc_diag_metadata_to_single("Errinv_Input", errinv_input ) + call nc_diag_metadata_to_single("Errinv_Adjust", errinv_adjst ) + call nc_diag_metadata_to_single("Errinv_Final", errinv_final ) + + call nc_diag_metadata_to_single("Observation", data(iqob,i) ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",ddiff ) + call nc_diag_metadata_to_single("Forecast_Saturation_Spec_Hum",qsges ) !---- if (lobsdiagsave) then do jj=1,miter @@ -1464,14 +1464,14 @@ subroutine contents_netcdf_diagp_(odiag) call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) - call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) endif if (twodvar_regional .or. l_obsprvdiag) then call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i) ) call nc_diag_metadata("Model_Terrain", data(izz,i) ) r_prvstg = data(iprvd,i) - call nc_diag_metadata("Provider_Name", "88888888" ) + call nc_diag_metadata("Provider_Name", "88888888" ) r_sprvstg = data(isprvd,i) call nc_diag_metadata("Subprovider_Name", "88888888" ) endif diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 index 822ec8ea22..ebdd8de52a 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -270,7 +270,8 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& use obsmod, only: luse_obsdiag,dval_use use obsmod, only: netcdf_diag, binary_diag, dirname use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & - nc_diag_write, nc_diag_data2d, nc_diag_chaninfo_dim_set, nc_diag_chaninfo + nc_diag_write, nc_diag_data2d, nc_diag_chaninfo_dim_set, & + nc_diag_chaninfo, nc_diag_metadata_to_single use gsi_4dvar, only: nobs_bins,hr_obsbin,l4dvar use gridmod, only: nsig,regional,get_ij use satthin, only: super_val1 @@ -551,10 +552,12 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& end if ! Load channel numbers into local array based on satellite type + if (iuse_rad(j)==4) then + predx(:,j)=zero + endif ich(jc)=j do i=1,npred - if (iuse_rad(j)==4) predx(i,j)=zero predchan(i,jc)=predx(i,j) end do ! @@ -2567,41 +2570,41 @@ subroutine contents_netcdf_diag_(odiags,idv,iob) do i=1,nchanl_diag call nc_diag_metadata("Channel_Index", i ) call nc_diag_metadata("Observation_Class", obsclass ) - call nc_diag_metadata("Latitude", sngl(cenlat) ) ! observation latitude (degrees) - call nc_diag_metadata("Longitude", sngl(cenlon) ) ! observation longitude (degrees) + call nc_diag_metadata_to_single("Latitude",cenlat ) ! observation latitude (degrees) + call nc_diag_metadata_to_single("Longitude",cenlon ) ! observation longitude (degrees) - call nc_diag_metadata("Elevation", sngl(zsges) ) ! model (guess) elevation at observation location + call nc_diag_metadata_to_single("Elevation",zsges ) ! model (guess) elevation at observation location - call nc_diag_metadata("Obs_Time", sngl(dtime-time_offset) ) ! observation time (hours relative to analysis time) + call nc_diag_metadata_to_single("Time",dtime,time_offset,'-') - call nc_diag_metadata("Scan_Position", sngl(data_s(iscan_pos,n)) ) ! sensor scan position - call nc_diag_metadata("Sat_Zenith_Angle", sngl(zasat*rad2deg) ) ! satellite zenith angle (degrees) - call nc_diag_metadata("Sat_Azimuth_Angle", sngl(data_s(ilazi_ang,n)) ) ! satellite azimuth angle (degrees) - call nc_diag_metadata("Sol_Zenith_Angle", sngl(pangs) ) ! solar zenith angle (degrees) - call nc_diag_metadata("Sol_Azimuth_Angle", sngl(data_s(isazi_ang,n)) ) ! solar azimuth angle (degrees) - call nc_diag_metadata("Sun_Glint_Angle", sngl(sgagl) ) ! sun glint angle (degrees) (sgagl) - call nc_diag_metadata("Scan_Angle", sngl(data_s(iscan_ang,n)*rad2deg) ) ! scan angle + call nc_diag_metadata_to_single("Scan_Position",data_s(iscan_pos,n) ) ! sensor scan position + call nc_diag_metadata_to_single("Sat_Zenith_Angle", zasat,rad2deg,'*') ! satellite zenith angle (degrees) + call nc_diag_metadata_to_single("Sat_Azimuth_Angle",data_s(ilazi_ang,n) ) ! satellite azimuth angle (degrees) + call nc_diag_metadata_to_single("Sol_Zenith_Angle",pangs ) ! solar zenith angle (degrees) + call nc_diag_metadata_to_single("Sol_Azimuth_Angle",data_s(isazi_ang,n) ) ! solar azimuth angle (degrees) + call nc_diag_metadata_to_single("Sun_Glint_Angle",sgagl ) ! sun glint angle (degrees) (sgagl) + call nc_diag_metadata_to_single("Scan_Angle",data_s(iscan_ang,n),rad2deg,'*' ) ! scan angle - call nc_diag_metadata("Water_Fraction", sngl(surface(1)%water_coverage) ) ! fractional coverage by water - call nc_diag_metadata("Land_Fraction", sngl(surface(1)%land_coverage) ) ! fractional coverage by land - call nc_diag_metadata("Ice_Fraction", sngl(surface(1)%ice_coverage) ) ! fractional coverage by ice - call nc_diag_metadata("Snow_Fraction", sngl(surface(1)%snow_coverage) ) ! fractional coverage by snow + call nc_diag_metadata_to_single("Water_Fraction",surface(1)%water_coverage ) ! fractional coverage by water + call nc_diag_metadata_to_single("Land_Fraction",surface(1)%land_coverage ) ! fractional coverage by land + call nc_diag_metadata_to_single("Ice_Fraction",surface(1)%ice_coverage ) ! fractional coverage by ice + call nc_diag_metadata_to_single("Snow_Fraction",surface(1)%snow_coverage ) ! fractional coverage by snow if(.not. retrieval)then - call nc_diag_metadata("Water_Temperature", sngl(surface(1)%water_temperature) ) ! surface temperature over water (K) - call nc_diag_metadata("Land_Temperature", sngl(surface(1)%land_temperature) ) ! surface temperature over land (K) - call nc_diag_metadata("Ice_Temperature", sngl(surface(1)%ice_temperature) ) ! surface temperature over ice (K) - call nc_diag_metadata("Snow_Temperature", sngl(surface(1)%snow_temperature) ) ! surface temperature over snow (K) - call nc_diag_metadata("Soil_Temperature", sngl(surface(1)%soil_temperature) ) ! soil temperature (K) - call nc_diag_metadata("Soil_Moisture", sngl(surface(1)%soil_moisture_content) ) ! soil moisture + call nc_diag_metadata_to_single("Water_Temperature",surface(1)%water_temperature ) ! surface temperature over water (K) + call nc_diag_metadata_to_single("Land_Temperature",surface(1)%land_temperature ) ! surface temperature over land (K) + call nc_diag_metadata_to_single("Ice_Temperature",surface(1)%ice_temperature ) ! surface temperature over ice (K) + call nc_diag_metadata_to_single("Snow_Temperature",surface(1)%snow_temperature ) ! surface temperature over snow (K) + call nc_diag_metadata_to_single("Soil_Temperature",surface(1)%soil_temperature ) ! soil temperature (K) + call nc_diag_metadata_to_single("Soil_Moisture",surface(1)%soil_moisture_content ) ! soil moisture call nc_diag_metadata("Land_Type_Index", surface(1)%land_type ) ! surface land type call nc_diag_metadata("tsavg5", missing ) ! SST first guess used for SST retrieval - call nc_diag_metadata("sstcu", missing ) ! NCEP SST analysis at t - call nc_diag_metadata("sstph", missing ) ! Physical SST retrieval - call nc_diag_metadata("sstnv", missing ) ! Navy SST retrieval + call nc_diag_metadata("sstcu", missing ) ! NCEP SST analysis at t + call nc_diag_metadata("sstph", missing ) ! Physical SST retrieval + call nc_diag_metadata("sstnv", missing ) ! Navy SST retrieval call nc_diag_metadata("dta", missing ) ! d(ta) corresponding to sstph call nc_diag_metadata("dqa", missing ) ! d(qa) corresponding to sstph - call nc_diag_metadata("dtp_avh", missing ) ! data type + call nc_diag_metadata("dtp_avh", missing ) ! data type else call nc_diag_metadata("Water_Temperature", missing ) ! surface temperature over water (K) call nc_diag_metadata("Land_Temperature", missing ) ! surface temperature over land (K) @@ -2610,27 +2613,27 @@ subroutine contents_netcdf_diag_(odiags,idv,iob) call nc_diag_metadata("Soil_Temperature", missing ) ! soil temperature (K) call nc_diag_metadata("Soil_Moisture", missing ) ! soil moisture call nc_diag_metadata("Land_Type_Index", imissing ) ! surface land type - call nc_diag_metadata("tsavg5", sngl(tsavg5) ) ! SST first guess used for SST retrieval - call nc_diag_metadata("sstcu", sngl(sstcu) ) ! NCEP SST analysis at t - call nc_diag_metadata("sstph", sngl(sstph) ) ! Physical SST retrieval - call nc_diag_metadata("sstnv", sngl(sstnv) ) ! Navy SST retrieval - call nc_diag_metadata("dta", sngl(dta) ) ! d(ta) corresponding to sstph - call nc_diag_metadata("dqa", sngl(dqa) ) ! d(qa) corresponding to sstph - call nc_diag_metadata("dtp_avh", sngl(dtp_avh) ) ! data type + call nc_diag_metadata_to_single("tsavg5",tsavg5 ) ! SST first guess used for SST retrieval + call nc_diag_metadata_to_single("sstcu",sstcu ) ! NCEP SST analysis at t + call nc_diag_metadata_to_single("sstph",sstph ) ! Physical SST retrieval + call nc_diag_metadata_to_single("sstnv",sstnv ) ! Navy SST retrieval + call nc_diag_metadata_to_single("dta",dta ) ! d(ta) corresponding to sstph + call nc_diag_metadata_to_single("dqa",dqa ) ! d(qa) corresponding to sstph + call nc_diag_metadata_to_single("dtp_avh",dtp_avh ) ! data type endif - call nc_diag_metadata("Vegetation_Fraction", sngl(surface(1)%vegetation_fraction) ) - call nc_diag_metadata("Snow_Depth", sngl(surface(1)%snow_depth) ) - call nc_diag_metadata("tpwc", sngl(tpwc_obs) ) - call nc_diag_metadata("clw_guess_retrieval", sngl(clw_guess_retrieval) ) + call nc_diag_metadata_to_single("Vegetation_Fraction",surface(1)%vegetation_fraction ) + call nc_diag_metadata_to_single("Snow_Depth",surface(1)%snow_depth ) + call nc_diag_metadata_to_single("tpwc",tpwc_obs ) + call nc_diag_metadata_to_single("clw_guess_retrieval",clw_guess_retrieval ) - call nc_diag_metadata("Sfc_Wind_Speed", sngl(surface(1)%wind_speed) ) - call nc_diag_metadata("Cloud_Frac", sngl(cld) ) - call nc_diag_metadata("CTP", sngl(cldp) ) - call nc_diag_metadata("CLW", sngl(clw_obs) ) - call nc_diag_metadata("TPWC", sngl(tpwc_obs) ) - call nc_diag_metadata("clw_obs", sngl(clw_obs) ) - call nc_diag_metadata("clw_guess", sngl(clw_guess) ) + call nc_diag_metadata_to_single("Sfc_Wind_Speed",surface(1)%wind_speed ) + call nc_diag_metadata_to_single("Cloud_Frac",cld ) + call nc_diag_metadata_to_single("CTP",cldp ) + call nc_diag_metadata_to_single("CLW",clw_obs ) + call nc_diag_metadata_to_single("TPWC",tpwc_obs ) + call nc_diag_metadata_to_single("clw_obs",clw_obs ) + call nc_diag_metadata_to_single("clw_guess",clw_guess ) if (nstinfo==0) then data_s(itref,n) = missing @@ -2639,21 +2642,21 @@ subroutine contents_netcdf_diag_(odiags,idv,iob) data_s(itz_tr,n) = missing endif - call nc_diag_metadata("Foundation_Temperature", sngl(data_s(itref,n)) ) ! reference temperature (Tr) in NSST - call nc_diag_metadata("SST_Warm_layer_dt", sngl(data_s(idtw,n)) ) ! dt_warm at zob - call nc_diag_metadata("SST_Cool_layer_tdrop", sngl(data_s(idtc,n)) ) ! dt_cool at zob - call nc_diag_metadata("SST_dTz_dTfound", sngl(data_s(itz_tr,n)) ) ! d(Tz)/d(Tr) + call nc_diag_metadata_to_single("Foundation_Temperature",data_s(itref,n) ) ! reference temperature (Tr) in NSST + call nc_diag_metadata_to_single("SST_Warm_layer_dt",data_s(idtw,n) ) ! dt_warm at zob + call nc_diag_metadata_to_single("SST_Cool_layer_tdrop",data_s(idtc,n) ) ! dt_cool at zob + call nc_diag_metadata_to_single("SST_dTz_dTfound",data_s(itz_tr,n) ) ! d(Tz)/d(Tr) - call nc_diag_metadata("Observation", sngl(tb_obs0(ich_diag(i))) ) ! observed brightness temperature (K) - call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(tbcnob(ich_diag(i))) ) ! observed - simulated Tb with no bias correction (K) - call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(tbc0(ich_diag(i) )) ) ! observed - simulated Tb with bias corrrection (K) + call nc_diag_metadata_to_single("Observation",tb_obs0(ich_diag(i)) ) ! observed brightness temperature (K) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",tbcnob(ich_diag(i)) ) ! observed - simulated Tb with no bias correction (K) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",tbc0(ich_diag(i) ) ) ! observed - simulated Tb with bias corrrection (K) errinv = sqrt(varinv0(ich_diag(i))) - call nc_diag_metadata("Inverse_Observation_Error", sngl(errinv) ) + call nc_diag_metadata_to_single("Inverse_Observation_Error",errinv ) if (save_jacobian .and. allocated(idnames)) then - call nc_diag_metadata("Observation_scaled", sngl(tb_obs(ich_diag(i))) ) ! observed brightness temperature (K) scaled by R^{-1/2} - call nc_diag_metadata("Obs_Minus_Forecast_adjusted_scaled", sngl(tbc(ich_diag(i) )) ) ! observed - simulated Tb with bias corrrection (K) scaled by R^{-1/2} + call nc_diag_metadata_to_single("Observation_scaled",tb_obs(ich_diag(i)) ) ! observed brightness temperature (K) scaled by R^{-1/2} + call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted_scaled",tbc(ich_diag(i) ) ) ! observed - simulated Tb with bias corrrection (K) scaled by R^{-1/2} errinv = sqrt(varinv(ich_diag(i))) - call nc_diag_metadata("Inverse_Observation_Error_scaled", sngl(errinv) ) + call nc_diag_metadata_to_single("Inverse_Observation_Error_scaled",errinv ) endif if (save_jacobian) then j = 1 @@ -2692,34 +2695,34 @@ subroutine contents_netcdf_diag_(odiags,idv,iob) useflag=one if (iuse_rad(ich(ich_diag(i))) < 1) useflag=-one - call nc_diag_metadata("QC_Flag", sngl(id_qc(ich_diag(i))*useflag) ) ! quality control mark or event indicator - - call nc_diag_metadata("Emissivity", sngl(emissivity(ich_diag(i))) ) ! surface emissivity - call nc_diag_metadata("Weighted_Lapse_Rate", sngl(tlapchn(ich_diag(i))) ) ! stability index - call nc_diag_metadata("dTb_dTs", sngl(ts(ich_diag(i))) ) ! d(Tb)/d(Ts) - - call nc_diag_metadata("BC_Constant", sngl(predbias(1,ich_diag(i))) ) ! constant bias correction term - call nc_diag_metadata("BC_Scan_Angle", sngl(predbias(2,ich_diag(i))) ) ! scan angle bias correction term - call nc_diag_metadata("BC_Cloud_Liquid_Water", sngl(predbias(3,ich_diag(i))) ) ! CLW bias correction term - call nc_diag_metadata("BC_Lapse_Rate_Squared", sngl(predbias(4,ich_diag(i))) ) ! square lapse rate bias correction term - call nc_diag_metadata("BC_Lapse_Rate", sngl(predbias(5,ich_diag(i))) ) ! lapse rate bias correction term - call nc_diag_metadata("BC_Cosine_Latitude_times_Node", sngl(predbias(6,ich_diag(i))) ) ! node*cos(lat) bias correction term - call nc_diag_metadata("BC_Sine_Latitude", sngl(predbias(7,ich_diag(i))) ) ! sin(lat) bias correction term - call nc_diag_metadata("BC_Emissivity", sngl(predbias(8,ich_diag(i))) ) ! emissivity sensitivity bias correction term - call nc_diag_metadata("BC_Fixed_Scan_Position", sngl(predbias(npred+1,ich_diag(i))) ) ! external scan angle + call nc_diag_metadata("QC_Flag",sngl(id_qc(ich_diag(i))*useflag))! quality control mark or event indicator + + call nc_diag_metadata_to_single("Emissivity",emissivity(ich_diag(i)) ) ! surface emissivity + call nc_diag_metadata_to_single("Weighted_Lapse_Rate",tlapchn(ich_diag(i)) ) ! stability index + call nc_diag_metadata_to_single("dTb_dTs",ts(ich_diag(i)) ) ! d(Tb)/d(Ts) + + call nc_diag_metadata_to_single("BC_Constant",predbias(1,ich_diag(i)) ) ! constant bias correction term + call nc_diag_metadata_to_single("BC_Scan_Angle",predbias(2,ich_diag(i)) ) ! scan angle bias correction term + call nc_diag_metadata_to_single("BC_Cloud_Liquid_Water",predbias(3,ich_diag(i)) ) ! CLW bias correction term + call nc_diag_metadata_to_single("BC_Lapse_Rate_Squared",predbias(4,ich_diag(i)) ) ! square lapse rate bias correction term + call nc_diag_metadata_to_single("BC_Lapse_Rate",predbias(5,ich_diag(i)) ) ! lapse rate bias correction term + call nc_diag_metadata_to_single("BC_Cosine_Latitude_times_Node",predbias(6,ich_diag(i)) ) ! node*cos(lat) bias correction term + call nc_diag_metadata_to_single("BC_Sine_Latitude",predbias(7,ich_diag(i)) ) ! sin(lat) bias correction term + call nc_diag_metadata_to_single("BC_Emissivity",predbias(8,ich_diag(i)) ) ! emissivity sensitivity bias correction term + call nc_diag_metadata_to_single("BC_Fixed_Scan_Position",predbias(npred+1,ich_diag(i)) ) ! external scan angle if (lwrite_predterms) then - call nc_diag_metadata("BCPred_Constant", sngl(pred(1,ich_diag(i))) ) ! constant bias correction term - call nc_diag_metadata("BCPred_Scan_Angle", sngl(pred(2,ich_diag(i))) ) ! scan angle bias correction term - call nc_diag_metadata("BCPred_Cloud_Liquid_Water", sngl(pred(3,ich_diag(i))) ) ! CLW bias correction term - call nc_diag_metadata("BCPred_Lapse_Rate_Squared", sngl(pred(4,ich_diag(i))) ) ! square lapse rate bias correction term - call nc_diag_metadata("BCPred_Lapse_Rate", sngl(pred(5,ich_diag(i))) ) ! lapse rate bias correction term - call nc_diag_metadata("BCPred_Cosine_Latitude_times_Node", sngl(pred(6,ich_diag(i))) ) ! node*cos(lat) bias correction term - call nc_diag_metadata("BCPred_Sine_Latitude", sngl(pred(7,ich_diag(i))) ) ! sin(lat) bias correction term - call nc_diag_metadata("BCPred_Emissivity", sngl(pred(8,ich_diag(i))) ) ! emissivity sensitivity bias correction term + call nc_diag_metadata_to_single("BCPred_Constant",pred(1,ich_diag(i)) ) ! constant bias correction term + call nc_diag_metadata_to_single("BCPred_Scan_Angle",pred(2,ich_diag(i)) ) ! scan angle bias correction term + call nc_diag_metadata_to_single("BCPred_Cloud_Liquid_Water",pred(3,ich_diag(i)) ) ! CLW bias correction term + call nc_diag_metadata_to_single("BCPred_Lapse_Rate_Squared",pred(4,ich_diag(i)) ) ! square lapse rate bias correction term + call nc_diag_metadata_to_single("BCPred_Lapse_Rate",pred(5,ich_diag(i)) ) ! lapse rate bias correction term + call nc_diag_metadata_to_single("BCPred_Cosine_Latitude_times_Node",pred(6,ich_diag(i)) ) ! node*cos(lat) bias correction term + call nc_diag_metadata_to_single("BCPred_Sine_Latitude",pred(7,ich_diag(i)) ) ! sin(lat) bias correction term + call nc_diag_metadata_to_single("BCPred_Emissivity",pred(8,ich_diag(i)) ) ! emissivity sensitivity bias correction term endif if (lwrite_peakwt) then - call nc_diag_metadata("Press_Max_Weight_Function", sngl(weightmax(ich_diag(i))) ) + call nc_diag_metadata_to_single("Press_Max_Weight_Function",weightmax(ich_diag(i)) ) endif if (adp_anglebc) then do j=1, angord diff --git a/src/gsi/setuprw.f90 b/src/gsi/setuprw.f90 index 2211ee6caa..1e3900aafa 100644 --- a/src/gsi/setuprw.f90 +++ b/src/gsi/setuprw.f90 @@ -117,7 +117,7 @@ subroutine setuprw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa doradaroneob,oneobddiff,oneobvalue, if_vrobs_raw, if_use_w_vr use obsmod, only: netcdf_diag, binary_diag, dirname,ianldate use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & - nc_diag_write, nc_diag_data2d + nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close use m_obsNode, only: obsNode use m_rwNode, only: rwNode @@ -1319,30 +1319,30 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Observation_Class", obsclass ) call nc_diag_metadata("Observation_Type", ictype(ikx) ) call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) - call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) - call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) - call nc_diag_metadata("Station_Elevation", sngl(data(ielev,i)) ) - call nc_diag_metadata("Pressure", sngl(presw) ) - call nc_diag_metadata("Height", sngl(data(ihgt,i)) ) - call nc_diag_metadata("Time", sngl(dtime-time_offset)) - call nc_diag_metadata("Prep_QC_Mark", sngl(zero) ) - call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + call nc_diag_metadata_to_single("Latitude",data(ilate,i) ) + call nc_diag_metadata_to_single("Longitude",data(ilone,i) ) + call nc_diag_metadata_to_single("Station_Elevation",data(ielev,i) ) + call nc_diag_metadata_to_single("Pressure",presw ) + call nc_diag_metadata_to_single("Height",data(ihgt,i) ) + call nc_diag_metadata_to_single("Time",dtime,time_offset,'-') + call nc_diag_metadata("Prep_QC_Mark", 0.0_r_single ) + call nc_diag_metadata_to_single("Prep_Use_Flag",data(iuse,i) ) ! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) - call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt ) if(muse(i)) then - call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + call nc_diag_metadata("Analysis_Use_Flag", 1.0_r_single ) else - call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + call nc_diag_metadata("Analysis_Use_Flag", -1.0_r_single ) endif - call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) - call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) - call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + call nc_diag_metadata_to_single("Errinv_Input",errinv_input ) + call nc_diag_metadata_to_single("Errinv_Adjust",errinv_adjst ) + call nc_diag_metadata_to_single("Errinv_Final",errinv_final ) + + call nc_diag_metadata_to_single("Observation",data(irwob,i) ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",data(irwob,i),rwwind,'-') - call nc_diag_metadata("Observation", sngl(data(irwob,i)) ) - call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) - call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(data(irwob,i)-rwwind) ) - if (lobsdiagsave) then do jj=1,miter if (odiag%muse(jj)) then @@ -1351,18 +1351,18 @@ subroutine contents_netcdf_diag_(odiag) obsdiag_iuse(jj) = -one endif enddo - + call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse ) call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart ) call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart ) - call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) + call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen ) endif if (save_jacobian) then call nc_diag_data2d("Observation_Operator_Jacobian_stind", dhx_dx%st_ind) call nc_diag_data2d("Observation_Operator_Jacobian_endind", dhx_dx%end_ind) call nc_diag_data2d("Observation_Operator_Jacobian_val", real(dhx_dx%val,r_single)) endif - + end subroutine contents_netcdf_diag_ subroutine final_vars_ diff --git a/src/gsi/setupspd.f90 b/src/gsi/setupspd.f90 index 91b2467bf3..64366394cb 100644 --- a/src/gsi/setupspd.f90 +++ b/src/gsi/setupspd.f90 @@ -114,7 +114,7 @@ subroutine setupspd(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diags use obsmod, only: netcdf_diag, binary_diag, dirname, ianldate use obsmod, only: l_obsprvdiag use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & - nc_diag_write, nc_diag_data2d + nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close use m_obsNode, only: obsNode use m_spdNode, only: spdNode @@ -949,29 +949,29 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Observation_Class", obsclass ) call nc_diag_metadata("Observation_Type", ictype(ikx) ) call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) - call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) - call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) - call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) - call nc_diag_metadata("Pressure", sngl(presw) ) - call nc_diag_metadata("Height", sngl(data(ihgt,i)) ) - call nc_diag_metadata("Time", sngl(dtime-time_offset)) - call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) - call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + call nc_diag_metadata_to_single("Latitude",data(ilate,i) ) + call nc_diag_metadata_to_single("Longitude",data(ilone,i) ) + call nc_diag_metadata_to_single("Station_Elevation",data(istnelv,i) ) + call nc_diag_metadata_to_single("Pressure",presw ) + call nc_diag_metadata_to_single("Height",data(ihgt,i) ) + call nc_diag_metadata_to_single("Time",dtime,time_offset,'-') + call nc_diag_metadata_to_single("Prep_QC_Mark",data(iqc,i) ) + call nc_diag_metadata_to_single("Prep_Use_Flag",data(iuse,i) ) ! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) - call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt ) if(muse(i)) then - call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + call nc_diag_metadata("Analysis_Use_Flag", 1.0_r_single ) else - call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + call nc_diag_metadata("Analysis_Use_Flag", 1.0_r_single ) endif - call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) - call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) - call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + call nc_diag_metadata_to_single("Errinv_Input",errinv_input ) + call nc_diag_metadata_to_single("Errinv_Adjust",errinv_adjst ) + call nc_diag_metadata_to_single("Errinv_Final",errinv_final ) - call nc_diag_metadata("Observation", sngl(spdob) ) - call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) - call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(spdob0-spdges) ) + call nc_diag_metadata_to_single("Observation",spdob ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted", spdob0,spdges,'-') if (lobsdiagsave) then do jj=1,miter diff --git a/src/gsi/setupsst.f90 b/src/gsi/setupsst.f90 index 6562d0392f..27d08daa86 100644 --- a/src/gsi/setupsst.f90 +++ b/src/gsi/setupsst.f90 @@ -99,7 +99,7 @@ subroutine setupsst(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diags use obsmod, only: luse_obsdiag use obsmod, only: netcdf_diag, binary_diag, dirname,ianldate use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & - nc_diag_write, nc_diag_data2d + nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close use gsi_4dvar, only: nobs_bins,hr_obsbin use oneobmod, only: magoberr,maginnov,oneobtest @@ -585,35 +585,35 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Observation_Class", obsclass ) call nc_diag_metadata("Observation_Type", ictype(ikx) ) call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) - call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) - call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) - call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) + call nc_diag_metadata_to_single("Latitude",data(ilate,i) ) + call nc_diag_metadata_to_single("Longitude",data(ilone,i) ) + call nc_diag_metadata_to_single("Station_Elevation",data(istnelv,i) ) call nc_diag_metadata("Pressure", missing ) - call nc_diag_metadata("Height", sngl(data(izob,i)) ) - call nc_diag_metadata("Time", sngl(dtime-time_offset)) - call nc_diag_metadata("Prep_QC_Mark", sngl(data(ipct,i)) ) - call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + call nc_diag_metadata_to_single("Height",data(izob,i) ) + call nc_diag_metadata_to_single("Time",dtime,time_offset,'-') + call nc_diag_metadata_to_single("Prep_QC_Mark",data(ipct,i) ) + call nc_diag_metadata_to_single("Prep_Use_Flag",data(iuse,i) ) ! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ) - call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt ) if(muse(i)) then - call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) + call nc_diag_metadata("Analysis_Use_Flag", 1.0_r_single ) else - call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + call nc_diag_metadata("Analysis_Use_Flag", -1.0_r_single ) endif - call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) - call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) - call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + call nc_diag_metadata_to_single("Errinv_Input",errinv_input ) + call nc_diag_metadata_to_single("Errinv_Adjust",errinv_adjst ) + call nc_diag_metadata_to_single("Errinv_Final",errinv_final ) - call nc_diag_metadata("Observation", sngl(data(isst,i)) ) - call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) - call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(data(isst,i)-sstges) ) + call nc_diag_metadata_to_single("Observation",data(isst,i) ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",data(isst,i),sstges,'-') if (nst_gsi>0) then - call nc_diag_metadata("FoundationTempBG", sngl(data(itref,i)) ) - call nc_diag_metadata("DiurnalWarming_at_zob", sngl(data(idtw,i)) ) - call nc_diag_metadata("SkinLayerCooling_at_zob", sngl(data(idtw,i)) ) - call nc_diag_metadata("Sensitivity_Tzob_Tr", sngl(data(itz_tr,i)) ) + call nc_diag_metadata_to_single("FoundationTempBG",data(itref,i) ) + call nc_diag_metadata_to_single("DiurnalWarming_at_zob",data(idtw,i) ) + call nc_diag_metadata_to_single("SkinLayerCooling_at_zob",data(idtw,i) ) + call nc_diag_metadata_to_single("Sensitivity_Tzob_Tr",data(itz_tr,i) ) endif if (lobsdiagsave) then diff --git a/src/gsi/setupswcp.f90 b/src/gsi/setupswcp.f90 index c65ad1495c..6797357103 100644 --- a/src/gsi/setupswcp.f90 +++ b/src/gsi/setupswcp.f90 @@ -67,7 +67,7 @@ subroutine setupswcp(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag use obsmod, only: netcdf_diag, binary_diag, dirname use nc_diag_write_mod, only: nc_diag_init, nc_diag_header,nc_diag_metadata, & - nc_diag_write, nc_diag_data2d + nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single use nc_diag_read_mod, only: nc_diag_read_init,nc_diag_read_get_dim,nc_diag_read_close use state_vectors, only: svars3d, levels @@ -893,28 +893,28 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Observation_Class", obsclass ) call nc_diag_metadata("Observation_Type", ictype(ikx) ) call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) - call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) - call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) - call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) - call nc_diag_metadata("Pressure", sngl(data(iobsprs,i)) ) - call nc_diag_metadata("Height", sngl(data(iobshgt,i)) ) - call nc_diag_metadata("Time", sngl(dtime-time_offset)) - call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) - call nc_diag_metadata("Setup_QC_Mark", sngl(rmiss_single) ) - call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + call nc_diag_metadata_to_single("Latitude",data(ilate,i) ) + call nc_diag_metadata_to_single("Longitude",data(ilone,i) ) + call nc_diag_metadata_to_single("Station_Elevation",data(istnelv,i) ) + call nc_diag_metadata_to_single("Pressure",data(iobsprs,i) ) + call nc_diag_metadata_to_single("Height",data(iobshgt,i) ) + call nc_diag_metadata_to_single("Time",dtime,time_offset,'-') + call nc_diag_metadata_to_single("Prep_QC_Mark",data(iqc,i) ) + call nc_diag_metadata("Setup_QC_Mark",rmiss_single ) + call nc_diag_metadata_to_single("Prep_Use_Flag",data(iuse,i) ) if(muse(i)) then call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) else call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) endif - call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) - call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) - call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) - call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) - call nc_diag_metadata("Observation", sngl(dswcp) ) - call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) - call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(dswcp-swcpges)) + call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt ) + call nc_diag_metadata_to_single("Errinv_Input",errinv_input ) + call nc_diag_metadata_to_single("Errinv_Adjust",errinv_adjst ) + call nc_diag_metadata_to_single("Errinv_Final",errinv_final ) + call nc_diag_metadata_to_single("Observation",dswcp ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted", dswcp,swcpges,'-') if (lobsdiagsave) then do jj=1,miter diff --git a/src/gsi/setupt.f90 b/src/gsi/setupt.f90 index a0710e8abb..5467a6dec9 100644 --- a/src/gsi/setupt.f90 +++ b/src/gsi/setupt.f90 @@ -42,7 +42,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav use obsmod, only: netcdf_diag, binary_diag, dirname use obsmod, only: l_obsprvdiag use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & - nc_diag_write, nc_diag_data2d + nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close use qcmod, only: npres_print,dfact,dfact1,ptop,pbot,buddycheck_t @@ -1767,42 +1767,42 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Observation_Class", obsclass ) call nc_diag_metadata("Observation_Type", ictype(ikx) ) call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) - call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) - call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata_to_single("Latitude",data(ilate,i)) + call nc_diag_metadata_to_single("Longitude",data(ilone,i)) ! this is the obs height after being interpolated to the model (=model height) - call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) - call nc_diag_metadata("Pressure", sngl(prest) ) + call nc_diag_metadata_to_single("Station_Elevation",data(istnelv,i)) + call nc_diag_metadata_to_single("Pressure",prest) ! this is the original obs height (= stn elevation, before being interpolated) - call nc_diag_metadata("Height", sngl(data(iobshgt,i)) ) - call nc_diag_metadata("Time", sngl(dtime-time_offset)) - call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) - call nc_diag_metadata("Setup_QC_Mark", sngl(data(iqt,i)) ) - call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + call nc_diag_metadata_to_single("Height",data(iobshgt,i)) + call nc_diag_metadata_to_single("Time",dtime,time_offset,'-') + call nc_diag_metadata_to_single("Prep_QC_Mark",data(iqc,i)) + call nc_diag_metadata_to_single("Setup_QC_Mark",data(iqt,i)) + call nc_diag_metadata_to_single("Prep_Use_Flag",data(iuse,i)) if(muse(i)) then call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) else call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) endif - call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) - call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) - call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) - call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt) + call nc_diag_metadata_to_single("Errinv_Input",errinv_input ) + call nc_diag_metadata_to_single("Errinv_Adjust",errinv_adjst ) + call nc_diag_metadata_to_single("Errinv_Final",errinv_final ) if (hofx_2m_sfcfile ) then - call nc_diag_metadata("Observation", sngl(tob) ) + call nc_diag_metadata_to_single("Observation", tob ) else - call nc_diag_metadata("Observation", sngl(data(itob,i)) ) + call nc_diag_metadata_to_single("Observation", data(itob,i) ) endif - call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) - call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(tob-tges) ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",tob,tges,'-') if (aircraft_t_bc_pof .or. aircraft_t_bc .or. aircraft_t_bc_ext) then - call nc_diag_metadata("Data_Pof", sngl(data(ipof,i)) ) - call nc_diag_metadata("Data_Vertical_Velocity", sngl(data(ivvlc,i)) ) + call nc_diag_metadata_to_single("Data_Pof",data(ipof,i)) + call nc_diag_metadata_to_single("Data_Vertical_Velocity",data(ivvlc,i)) if (npredt .gt. one) then call nc_diag_data2d("Bias_Correction_Terms", sngl(predbias) ) else if (npredt .eq. one) then - call nc_diag_metadata("Bias_Correction_Terms", sngl(predbias(1)) ) + call nc_diag_metadata_to_single("Bias_Correction_Terms",predbias(1)) endif else call nc_diag_metadata("Data_Pof", missing ) @@ -1856,33 +1856,35 @@ subroutine contents_netcdf_diagp_(odiag) real(r_single),parameter:: missing = -9.99e9_r_single real(r_kind),dimension(miter) :: obsdiag_iuse + real(r_kind) :: var_jb_m call nc_diag_metadata("Station_ID", station_id ) call nc_diag_metadata("Observation_Class", obsclass ) call nc_diag_metadata("Observation_Type", ictype(ikx) ) call nc_diag_metadata("Observation_Subtype", -1 ) ! (-1 for pseudo obs sub-type) - call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) - call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) - call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) - call nc_diag_metadata("Pressure", sngl(prest) ) - call nc_diag_metadata("Height", sngl(data(iobshgt,i)) ) - call nc_diag_metadata("Time", sngl(dtime-time_offset)) - call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) - call nc_diag_metadata("Setup_QC_Mark", sngl(data(iqt,i)) ) - call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + call nc_diag_metadata_to_single("Latitude",data(ilate,i)) + call nc_diag_metadata_to_single("Longitude",data(ilone,i)) + call nc_diag_metadata_to_single("Station_Elevation",data(istnelv,i)) + call nc_diag_metadata_to_single("Pressure",prest) + call nc_diag_metadata_to_single("Height",data(iobshgt,i)) + call nc_diag_metadata_to_single("Time",dtime,time_offset,'-') + call nc_diag_metadata_to_single("Prep_QC_Mark",data(iqc,i)) + call nc_diag_metadata_to_single("Setup_QC_Mark",data(iqt,i)) + call nc_diag_metadata_to_single("Prep_Use_Flag",data(iuse,i)) if(muse(i)) then call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) else call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) endif - call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(var_jb*1.0e+6+rwgt)) - call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) - call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) - call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) - call nc_diag_metadata("Observation", sngl(data(itob,i)) ) - call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) ) - call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(ddiff) ) + var_jb_m = var_jb * 1.0e+6 + call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",var_jb_m,rwgt,'-') + call nc_diag_metadata_to_single("Errinv_Input",errinv_input ) + call nc_diag_metadata_to_single("Errinv_Adjust",errinv_adjst ) + call nc_diag_metadata_to_single("Errinv_Final",errinv_final ) + call nc_diag_metadata_to_single("Observation",data(itob,i)) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",ddiff ) !---- if (lobsdiagsave) then diff --git a/src/gsi/setuptcp.f90 b/src/gsi/setuptcp.f90 index cfef05d06c..3d13c5fe8e 100644 --- a/src/gsi/setuptcp.f90 +++ b/src/gsi/setuptcp.f90 @@ -57,7 +57,7 @@ subroutine setuptcp(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diags time_offset,rmiss_single,lobsdiagsave,lobsdiag_forenkf,ianldate use obsmod, only: netcdf_diag, binary_diag, dirname use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & - nc_diag_write, nc_diag_data2d + nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close use m_obsNode, only: obsNode use m_tcpNode, only: tcpNode @@ -692,29 +692,29 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Observation_Class", obsclass ) call nc_diag_metadata("Observation_Type", ictype(ikx) ) call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) - call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) - call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) + call nc_diag_metadata_to_single("Latitude",data(ilate,i) ) + call nc_diag_metadata_to_single("Longitude",data(ilone,i) ) call nc_diag_metadata("Station_Elevation", sngl(zero) ) - call nc_diag_metadata("Pressure", sngl(data(ipres,i)*r10)) - call nc_diag_metadata("Height", sngl(zero) ) - call nc_diag_metadata("Time", sngl(dtime-time_offset)) + call nc_diag_metadata_to_single("Pressure", data(ipres,i),r10,'*') + call nc_diag_metadata_to_single("Height",zero ) + call nc_diag_metadata_to_single("Time",dtime,time_offset,'-') call nc_diag_metadata("Prep_QC_Mark", sngl(one) ) call nc_diag_metadata("Prep_Use_Flag", sngl(one) ) - call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) + call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",(rwgt) ) if(muse(i)) then call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) else - call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) + call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) endif - call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) - call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) - call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) + call nc_diag_metadata_to_single("Errinv_Input",errinv_input ) + call nc_diag_metadata_to_single("Errinv_Adjust",errinv_adjst ) + call nc_diag_metadata_to_single("Errinv_Final",errinv_final ) - call nc_diag_metadata("Observation", sngl(pob) ) - call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(pob-pges) ) - call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(pob-pgesorig)) + call nc_diag_metadata_to_single("Observation",pob ) + call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",pob,pges,'-') + call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",pob,pgesorig,'-') if (lobsdiagsave) then do jj=1,miter diff --git a/src/gsi/setupw.f90 b/src/gsi/setupw.f90 index 97ed1f8883..087c3c34ab 100644 --- a/src/gsi/setupw.f90 +++ b/src/gsi/setupw.f90 @@ -44,7 +44,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav use obsmod, only: l_obsprvdiag use obsmod, only: neutral_stability_windfact_2dvar,use_similarity_2dvar use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, & - nc_diag_write, nc_diag_data2d + nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset use qcmod, only: npres_print,ptop,pbot,dfact,dfact1,qc_satwnds,njqc,vqc @@ -1782,37 +1782,37 @@ subroutine contents_netcdf_diag_(udiag,vdiag) call nc_diag_metadata("Observation_Class", obsclass ) call nc_diag_metadata("Observation_Type", ictype(ikx) ) call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) ) - call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) - call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) - call nc_diag_metadata("Station_Elevation", sngl(data(ielev,i)) ) - call nc_diag_metadata("Pressure", sngl(presw) ) - call nc_diag_metadata("Height", sngl(data(ihgt,i)) ) - call nc_diag_metadata("Time", sngl(dtime-time_offset)) - call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) + call nc_diag_metadata_to_single("Latitude",data(ilate,i) ) + call nc_diag_metadata_to_single("Longitude",data(ilone,i) ) + call nc_diag_metadata_to_single("Station_Elevation",data(ielev,i) ) + call nc_diag_metadata_to_single("Pressure",presw ) + call nc_diag_metadata_to_single("Height",data(ihgt,i) ) + call nc_diag_metadata_to_single("Time",dtime,time_offset,'-') + call nc_diag_metadata_to_single("Prep_QC_Mark",data(iqc,i) ) ! call nc_diag_metadata("Setup_QC_Mark", rmiss_single ) - call nc_diag_metadata("Setup_QC_Mark", sngl(bmiss) ) - call nc_diag_metadata("Nonlinear_QC_Var_Jb", sngl(var_jb) ) - call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) + call nc_diag_metadata_to_single("Setup_QC_Mark",bmiss ) + call nc_diag_metadata_to_single("Nonlinear_QC_Var_Jb",var_jb ) + call nc_diag_metadata_to_single("Prep_Use_Flag",data(iuse,i) ) if(muse(i)) then call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) else call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) endif - call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) ) - call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) - call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) - call nc_diag_metadata("Errinv_Final", sngl(errinv_final) ) - call nc_diag_metadata("Wind_Reduction_Factor_at_10m", sngl(factw) ) + call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt ) + call nc_diag_metadata_to_single("Errinv_Input",errinv_input ) + call nc_diag_metadata_to_single("Errinv_Adjust",errinv_adjst ) + call nc_diag_metadata_to_single("Errinv_Final",errinv_final ) + call nc_diag_metadata_to_single("Wind_Reduction_Factor_at_10m",factw ) if (.not. regional .or. fv3_regional) then - call nc_diag_metadata("u_Observation", sngl(data(iuob,i)) ) - call nc_diag_metadata("u_Obs_Minus_Forecast_adjusted", sngl(dudiff) ) - call nc_diag_metadata("u_Obs_Minus_Forecast_unadjusted", sngl(uob-ugesin) ) + call nc_diag_metadata_to_single("u_Observation",data(iuob,i) ) + call nc_diag_metadata_to_single("u_Obs_Minus_Forecast_adjusted",dudiff ) + call nc_diag_metadata_to_single("u_Obs_Minus_Forecast_unadjusted",uob,ugesin,'-') - call nc_diag_metadata("v_Observation", sngl(data(ivob,i)) ) - call nc_diag_metadata("v_Obs_Minus_Forecast_adjusted", sngl(dvdiff) ) - call nc_diag_metadata("v_Obs_Minus_Forecast_unadjusted", sngl(vob-vgesin) ) + call nc_diag_metadata_to_single("v_Observation",data(ivob,i) ) + call nc_diag_metadata_to_single("v_Obs_Minus_Forecast_adjusted",dvdiff ) + call nc_diag_metadata_to_single("v_Obs_Minus_Forecast_unadjusted",vob,vgesin,'-') else ! (if regional) ! replace positions 17-22 with earth relative wind component information @@ -1823,13 +1823,13 @@ subroutine contents_netcdf_diag_(udiag,vdiag) call rotate_wind_xy2ll(ugesin,vgesin,uges_e,vges_e,dlon_e,dlon,dlat) call rotate_wind_xy2ll(dudiff,dvdiff,dudiff_e,dvdiff_e,dlon_e,dlon,dlat) - call nc_diag_metadata("u_Observation", sngl(uob_e) ) - call nc_diag_metadata("u_Obs_Minus_Forecast_adjusted", sngl(dudiff_e) ) - call nc_diag_metadata("u_Obs_Minus_Forecast_unadjusted", sngl(uob_e-uges_e) ) + call nc_diag_metadata_to_single("u_Observation",uob_e ) + call nc_diag_metadata_to_single("u_Obs_Minus_Forecast_adjusted",dudiff_e ) + call nc_diag_metadata_to_single("u_Obs_Minus_Forecast_unadjusted",uob_e,uges_e,'-') - call nc_diag_metadata("v_Observation", sngl(vob_e) ) - call nc_diag_metadata("v_Obs_Minus_Forecast_adjusted", sngl(dvdiff_e) ) - call nc_diag_metadata("v_Obs_Minus_Forecast_unadjusted", sngl(vob_e-vges_e) ) + call nc_diag_metadata_to_single("v_Observation",vob_e ) + call nc_diag_metadata_to_single("v_Obs_Minus_Forecast_adjusted",dvdiff_e ) + call nc_diag_metadata_to_single("v_Obs_Minus_Forecast_unadjusted",vob_e,vges_e,'-') endif if (lobsdiagsave) then diff --git a/src/gsi/stpcalc.f90 b/src/gsi/stpcalc.f90 index 30387341e3..dd60703ce2 100644 --- a/src/gsi/stpcalc.f90 +++ b/src/gsi/stpcalc.f90 @@ -263,7 +263,7 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & real(r_quad),parameter:: one_tenth_quad = 0.1_r_quad ! Declare local variables - integer(i_kind) i,j,mm1,ii,iis,ibin,ipenloc,it + integer(i_kind) i,j,mm1,ii,iis,final_ii,ibin,ipenloc,it integer(i_kind) istp_use,nstep,nsteptot,kprt real(r_quad),dimension(4,ipen):: pbc real(r_quad),dimension(4,nobs_type):: pbcjo @@ -299,6 +299,7 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & kprt=3 pjcalc=.false. pj=zero_quad + final_ii=1 ! Begin calculating contributions to penalty and stepsize for various terms ! @@ -779,6 +780,7 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & write(iout_iter,*) ' early termination due to cx or stp <=0 ',cx,stp(ii) write(iout_iter,*) ' better stepsize found',cx,stp(ii) end if + final_ii=ii exit stepsize else if(ii == istp_iter)then if(mype == minmype)then @@ -786,6 +788,7 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if stp(istp_use)=zero end_iter = .true. + final_ii=ii exit stepsize else ! Try different (better?) stepsize @@ -810,12 +813,16 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end_iter = .true. ! Finalize timer call timer_fnl('stpcalc') + final_ii=ii exit stepsize end if ! Check for convergence in stepsize estimation stprat(ii)=zero if(stp(ii) > zero_quad)stprat(ii)=abs((stp(ii)-stp(ii-1))/stp(ii)) - if(stprat(ii) < 1.e-4_r_kind) exit stepsize + if(stprat(ii) < 1.e-4_r_kind) then + final_ii=ii + exit stepsize + end if dels = one_tenth_quad*dels end if @@ -842,7 +849,10 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & istp_use=i end if end do - if(istp_use /= istp_iter)exit stepsize + if(istp_use /= istp_iter) then + final_ii=ii + exit stepsize + end if ! If no best stepsize set to zero and end minimization if(mype == minmype)then write(iout_iter,141)(outpen(i),i=1,nsteptot) @@ -850,8 +860,10 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end_iter = .true. stp(ii)=zero_quad istp_use=ii + final_ii=ii exit stepsize end if + final_ii=ii end do stepsize if(kprt >= 2 .and. iter == 0)then call mpl_allreduce(ipen,nobs_bins,pj) @@ -882,7 +894,7 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & if(print_verbose)then write(iout_iter,200) (stp(i),i=0,istp_use) - write(iout_iter,199) (stprat(ii),ii=1,istp_use) + write(iout_iter,199) (stprat(i),i=1,istp_use) write(iout_iter,201) (outstp(i),i=1,nsteptot) write(iout_iter,202) (outpen(i)-outpen(4),i=1,nsteptot) end if @@ -890,7 +902,7 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & ! Check for final stepsize negative (probable error) if(stpinout <= zero)then if(mype == minmype)then - write(iout_iter,130) ii,bx,cx,stp(ii) + 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) diff --git a/ush/build.sh b/ush/build.sh index 71674c4f4c..9a280c4e55 100755 --- a/ush/build.sh +++ b/ush/build.sh @@ -30,7 +30,6 @@ set -x # Set CONTROLPATH variable to user develop installation CONTROLPATH="$DIR_ROOT/../develop/install/bin" - # Collect BUILD Options CMAKE_OPTS+=" -DCMAKE_BUILD_TYPE=$BUILD_TYPE" diff --git a/ush/detect_machine.sh b/ush/detect_machine.sh index ecd1ad536e..6f0673ce29 100755 --- a/ush/detect_machine.sh +++ b/ush/detect_machine.sh @@ -3,7 +3,7 @@ case $(hostname -f) in adecflow0[12].acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### acorn - alogin0[12].acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### acorn + alogin0[1-3].acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### acorn clogin0[1-9].cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus01-9 clogin10.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus10 dlogin0[1-9].dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dogwood01-9 @@ -28,6 +28,7 @@ case $(hostname -f) in cheyenne[1-6].cheyenne.ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6 cheyenne[1-6].ib0.cheyenne.ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6 chadmin[1-6].ib0.cheyenne.ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6 + chadmin[1-6].ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6 login[1-4].stampede2.tacc.utexas.edu) MACHINE_ID=stampede ;; ### stampede1-4 diff --git a/ush/module-setup.sh b/ush/module-setup.sh index 469fd4a3c5..ab92477a56 100755 --- a/ush/module-setup.sh +++ b/ush/module-setup.sh @@ -18,7 +18,7 @@ elif [[ $MACHINE_ID = hera* ]] ; then elif [[ $MACHINE_ID = orion* ]] ; then # We are on Orion if ( ! eval module help > /dev/null 2>&1 ) ; then - source /apps/lmod/init/bash + source /apps/lmod/lmod/init/bash fi module purge @@ -57,33 +57,10 @@ elif [[ $MACHINE_ID = gaea* ]] ; then # /etc/profile here. source /etc/profile __ms_source_etc_profile=yes - else - __ms_source_etc_profile=no - fi - module purge - # clean up after purge - unset _LMFILES_ - unset _LMFILES_000 - unset _LMFILES_001 - unset LOADEDMODULES - module load modules - if [[ -d /opt/cray/ari/modulefiles ]] ; then - module use -a /opt/cray/ari/modulefiles - fi - if [[ -d /opt/cray/pe/ari/modulefiles ]] ; then - module use -a /opt/cray/pe/ari/modulefiles - fi - if [[ -d /opt/cray/pe/craype/default/modulefiles ]] ; then - module use -a /opt/cray/pe/craype/default/modulefiles - fi - if [[ -s /etc/opt/cray/pe/admin-pe/site-config ]] ; then - source /etc/opt/cray/pe/admin-pe/site-config - fi - if [[ "$__ms_source_etc_profile" == yes ]] ; then - source /etc/profile - unset __ms_source_etc_profile fi + source /lustre/f2/dev/role.epic/contrib/Lmod_init.sh + elif [[ $MACHINE_ID = expanse* ]]; then # We are on SDSC Expanse if ( ! eval module help > /dev/null 2>&1 ) ; then diff --git a/ush/sub_cheyenne b/ush/sub_cheyenne new file mode 100644 index 0000000000..7389bfeb24 --- /dev/null +++ b/ush/sub_cheyenne @@ -0,0 +1,169 @@ +#!/bin/sh --login +set -x +echo "starting sub_cheyenne" +usage="\ +Usage: $0 [options] executable [args] + where the options are: + -a account account (default: none) + -b binding run smt binding or not (default:NO) + -d dirin initial directory (default: cwd) + -e envars copy comma-separated environment variables + -g group group name + -i append standard input to command file + -j jobname specify jobname (default: executable basename) + -m machine machine on which to run (default: current) + -n write command file to stdout rather than submitting it + -o output specify output file (default: jobname.out) + -p procs[/nodes[/ppreq] + number of MPI tasks and optional nodes or Bblocking and + ppreq option (N or S) (defaults: serial, Bunlimited, S) + -q queue[/qpreq] queue name and optional requirement, e.g. dev/P + (defaults: 1 if serial or dev if parallel and none) + (queue 3 or 4 is dev or prod with twice tasks over ip) + (options: P=parallel, B=bigmem, b=batch) + -r rmem[/rcpu] resources memory and cpus/task (default: '1024 mb', 1) + -t timew wall time limit in [[hh:]mm:]ss format (default: 900) + -u userid userid to run under (default: self) + -v verbose mode + -w when when to run, in yyyymmddhh[mm], +hh[mm], thh[mm], or + Thh[mm] (full, incremental, today or tomorrow) format + (default: now) +Function: This command submits a job to the batch queue." +subcmd="$*" +stdin=NO +nosub=NO +account="" +binding="NO" +dirin="" +envars="" +group="" +jobname="" +machine="" +output="" +procs=0 +nodes="" +ppreq="" +queue="" +qpreq="" +rmem="1024" +rcpu="1" +timew="900" +userid="" +verbose=NO +when="" +while getopts a:b:d:e:g:ij:m:no:p:q:r:t:u:vw: opt;do + case $opt in + a) account="$OPTARG";; + b) binding="$OPTARG";; + d) dirin="$OPTARG";; + e) envars="$OPTARG";; + g) group="$OPTARG";; + i) stdin=YES;; + j) jobname=$OPTARG;; + m) machine="$OPTARG";; + n) nosub=YES;; + o) output=$OPTARG;; + p) procs=$(echo $OPTARG/|cut -d/ -f1);nodes=$(echo $OPTARG/|cut -d/ -f2);ppreq=$(echo $OPTARG/|cut -d/ -f3);; + q) queue=$(echo $OPTARG/|cut -d/ -f1);qpreq=$(echo $OPTARG/|cut -d/ -f2);; + r) rmem=$(echo $OPTARG/|cut -d/ -f1);rcpu=$(echo $OPTARG/|cut -d/ -f2);; + t) timew=$OPTARG;; + u) userid=$OPTARG;; + v) verbose=YES;; + w) when=$OPTARG;; + \?) echo $0: invalid option >&2;echo "$usage" >&2;exit 1;; + esac +done +shift $(($OPTIND-1)) +if [[ $# -eq 0 ]];then + echo $0: missing executable name >&2;echo "$usage" >&2;exit 1 +fi +exec=$1 +if [[ ! -s $exec ]]&&which $exec >/dev/null 2>&1;then + exec=$(which $exec) +fi +shift +args="$*" +bn=$(basename $exec) +export jobname=${jobname:-$bn} +output=${output:-$jobname.out} +myuser=$LOGNAME +myhost=$(hostname) + +DATA=/glade/scratch/$LOGNAME/tmp +mkdir -p $DATA + +timew=${timew:-01:20:00} +task_node=${task_node:-$procs} +size=$((nodes*task_node)) +envars=$envars +threads=${rcpu:-1} + +export TZ=GMT +cfile=$DATA/sub$$ +> $cfile +echo "#!/bin/sh --login" >> $cfile +echo "" >> $cfile +echo "#PBS -o $output" >> $cfile +echo "#PBS -N $jobname" >> $cfile +echo "#PBS -q $queue" >> $cfile +echo "#PBS -l walltime=$timew" >> $cfile +echo "#PBS -l select=$nodes:ncpus=$procs:mpiprocs=$procs" >> $cfile +echo "#PBS -j oe" >> $cfile +echo "#PBS -A $accnt" >> $cfile +echo "#PBS -V" >> $cfile + +echo "" >>$cfile +echo "export ntasks=$(( $nodes * $procs ))" >> $cfile +echo "export ppn=$procs" >> $cfile +echo "export threads=$threads" >> $cfile +echo "export OMP_NUM_THREADS=$threads" >> $cfile +echo "ulimit -s unlimited" >> $cfile +echo "" >>$cfile +echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile +echo "" >>$cfile + +echo "cfile = $cfile" +echo "source /glade/u/apps/ch/modulefiles/default/localinit/localinit.sh >> $cfile" +echo "module purge" >> $cfile +echo "module use $modulefiles" >> $cfile +echo "module load gsi_cheyenne.intel" >> $cfile +echo "module list" >> $cfile + +cat $exec >> $cfile + +if [[ $nosub = YES ]];then + cat $cfile + exit +elif [[ $verbose = YES ]];then + set -x + cat $cfile +fi + + +if [[ $stdin = YES ]];then + cat +fi >>$cfile +if [[ $nosub = YES ]];then + cat $cfile + exit +elif [[ $verbose = YES ]];then + set -x + cat $cfile +fi +qsub=${qsub:-qsub} + +ofile=$DATA/subout$$ +>$ofile +chmod 777 $ofile +$qsub $cfile >$ofile +rc=$? +cat $ofile +if [[ -w $SUBLOG ]];then + jobn=$(grep -i submitted $ofile|head -n1|cut -d\" -f2) + date -u +"%Y%m%d%H%M%S : $subcmd : $jobn" >>$SUBLOG +fi +rm $cfile $ofile +[[ $MKDATA = YES ]] && rmdir $DATA +echo "ending sub_cheyenne" +exit $rc + diff --git a/ush/sub_discover b/ush/sub_discover index 835cd37ace..583ffbef86 100755 --- a/ush/sub_discover +++ b/ush/sub_discover @@ -129,7 +129,7 @@ echo "export OMP_NUM_THREADS=$threads" >> $cfile echo "" >>$cfile echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile echo "" >>$cfile -echo "module use -a $gsisrc/modulefiles" >> $cfile +echo "module use -a $modulefiles" >> $cfile echo "module load gsi_discover" >> $cfile echo "" >>$cfile echo "jobname=$jobname" >>$cfile diff --git a/ush/sub_gaea b/ush/sub_gaea new file mode 100755 index 0000000000..6fed1b3c10 --- /dev/null +++ b/ush/sub_gaea @@ -0,0 +1,170 @@ +#!/bin/sh --login +set -x +usage="\ +Usage: $0 [options] executable [args] + where the options are: + -a account account (default: none) + -b binding run smt binding or not (default:NO) + -d dirin initial directory (default: cwd) + -e envars copy comma-separated environment variables + -g group group name + -i append standard input to command file + -j jobname specify jobname (default: executable basename) + -m machine machine on which to run (default: current) + -n write command file to stdout rather than submitting it + -o output specify output file (default: jobname.out) + -p procs[/nodes[/ppreq] + number of MPI tasks and optional nodes or Bblocking and + ppreq option (N or S) (defaults: serial, Bunlimited, S) + -q queue[/qpreq] queue name and optional requirement, e.g. dev/P + (defaults: 1 if serial or dev if parallel and none) + (queue 3 or 4 is dev or prod with twice tasks over ip) + (options: P=parallel, B=bigmem, b=batch) + -r rmem[/rcpu] resources memory and cpus/task (default: '1024 mb', 1) + -t timew wall time limit in [[hh:]mm:]ss format (default: 900) + -u userid userid to run under (default: self) + -v verbose mode + -w when when to run, in yyyymmddhh[mm], +hh[mm], thh[mm], or + Thh[mm] (full, incremental, today or tomorrow) format + (default: now) +Function: This command submits a job to the batch queue." +subcmd="$*" +stdin=NO +nosub=NO +account="" +binding="NO" +dirin="" +envars="" +group="" +jobname="" +machine="" +output="" +procs=0 +nodes="" +ppreq="" +queue="" +qpreq="" +rmem="1024" +rcpu="1" +timew="900" +userid="" +verbose=NO +when="" +while getopts a:b:d:e:g:ij:m:no:p:q:r:t:u:vw: opt;do + case $opt in + a) account="$OPTARG";; + b) binding="$OPTARG";; + d) dirin="$OPTARG";; + e) envars="$OPTARG";; + g) group="$OPTARG";; + i) stdin=YES;; + j) jobname=$OPTARG;; + m) machine="$OPTARG";; + n) nosub=YES;; + o) output=$OPTARG;; + p) procs=$(echo $OPTARG/|cut -d/ -f1);nodes=$(echo $OPTARG/|cut -d/ -f2);ppreq=$(echo $OPTARG/|cut -d/ -f3);; + q) queue=$(echo $OPTARG/|cut -d/ -f1);qpreq=$(echo $OPTARG/|cut -d/ -f2);; + r) rmem=$(echo $OPTARG/|cut -d/ -f1);rcpu=$(echo $OPTARG/|cut -d/ -f2);; + t) timew=$OPTARG;; + u) userid=$OPTARG;; + v) verbose=YES;; + w) when=$OPTARG;; + \?) echo $0: invalid option >&2;echo "$usage" >&2;exit 1;; + esac +done +shift $(($OPTIND-1)) +if [[ $# -eq 0 ]];then + echo $0: missing executable name >&2;echo "$usage" >&2;exit 1 +fi +exec=$1 +if [[ ! -s $exec ]]&&which $exec >/dev/null 2>&1;then + exec=$(which $exec) +fi +shift +args="$*" +bn=$(basename $exec) +export jobname=${jobname:-$bn} +output=${output:-$jobname.out} +myuser=$LOGNAME +myhost=$(hostname) + +if [ -d /lustre/f2/scratch/$LOGNAME ]; then + DATA=/lustre/f2/scratch/$LOGNAME/tmp +fi +DATA=${DATA:-$ptmp/tmp} + +mkdir -p $DATA + +queue=${queue:-batch} +timew=${timew:-01:20:00} +task_node=${task_node:-$procs} +size=$((nodes*task_node)) +envars=$envars +threads=${rcpu:-1} + +export TZ=GMT +cfile=$DATA/sub$$ +> $cfile +echo "#!/bin/bash -l" >> $cfile +echo "" >> $cfile +echo "#SBATCH --output=$output" >> $cfile +echo "#SBATCH --job-name=$jobname" >> $cfile +echo "#SBATCH --qos=$queue" >> $cfile +echo "#SBATCH --clusters=c4" >> $cfile +echo "#SBATCH --time=$timew" >> $cfile +echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile +echo "#SBATCH --account=$accnt" >> $cfile +echo "#SBATCH --mem=0" >> $cfile + +echo "" >>$cfile +echo "export ntasks=$(( $nodes * $procs ))" >> $cfile +echo "export ppn=$procs" >> $cfile +echo "export threads=$threads" >> $cfile +echo "export OMP_NUM_THREADS=$threads" >> $cfile +echo "ulimit -s unlimited" >> $cfile + +echo "" >>$cfile +echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile +echo "" >>$cfile + +echo "source /lustre/f2/dev/role.epic/contrib/Lmod_init.sh" >> $cfile +echo "module use $modulefiles" >> $cfile +echo "module load gsi_gaea" >> $cfile +echo "module list" >> $cfile +echo "" >>$cfile + +cat $exec >> $cfile + +if [[ $nosub = YES ]];then + cat $cfile + exit +elif [[ $verbose = YES ]];then + set -x + cat $cfile +fi + +if [[ $stdin = YES ]];then + cat +fi >>$cfile +if [[ $nosub = YES ]];then + cat $cfile + exit +elif [[ $verbose = YES ]];then + set -x + cat $cfile +fi +sbatch=${sbatch:-sbatch} + +ofile=$DATA/subout$$ +>$ofile +chmod 777 $ofile +$sbatch --export=ALL $cfile >$ofile +rc=$? +cat $ofile +if [[ -w $SUBLOG ]];then + jobn=$(grep -i submitted $ofile|head -n1|cut -d\" -f2) + date -u +"%Y%m%d%H%M%S : $subcmd : $jobn" >>$SUBLOG +fi +rm $cfile $ofile +[[ $MKDATA = YES ]] && rmdir $DATA +exit $rc diff --git a/ush/sub_hera b/ush/sub_hera index d904417190..610756af00 100755 --- a/ush/sub_hera +++ b/ush/sub_hera @@ -137,7 +137,7 @@ echo "" >>$cfile echo ". /apps/lmod/lmod/init/sh" >> $cfile echo "module purge" >> $cfile -echo "module use $gsisrc/modulefiles" >> $cfile +echo "module use $modulefiles" >> $cfile echo "module load gsi_hera.intel" >> $cfile echo "module list" >> $cfile echo "" >>$cfile diff --git a/ush/sub_jet b/ush/sub_jet index e11be1280c..d30c566ce3 100755 --- a/ush/sub_jet +++ b/ush/sub_jet @@ -98,16 +98,10 @@ task_node=${task_node:-$procs} size=$((nodes*task_node)) envars=$envars threads=${rcpu:-1} -#envars=$envars,mpi_tasks=$procs -#Options -###PBS -l partition=c1ms,size=0528,walltime=01:20:00 -##PBS -l partition=$queue,size=$size,walltime=$timew -##PBS -S /bin/sh export TZ=GMT cfile=$DATA/sub$$ > $cfile -#echo "#PBS -S /bin/sh" >> $cfile echo "#!/bin/sh --login" >> $cfile echo "" >> $cfile echo "#SBATCH --output=$output" >> $cfile @@ -115,24 +109,24 @@ echo "#SBATCH --job-name=$jobname" echo "#SBATCH --qos=$queue" >> $cfile echo "#SBATCH --time=$timew" >> $cfile echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile -#echo "#SBATCH -j oe" >> $cfile echo "#SBATCH --account=$accnt" >> $cfile echo "#SBATCH --mem=0" >> $cfile echo "#SBATCH --partition=kjet" >> $cfile -#echo "#SBATCH -V" >> $cfile -#echo "#PBS -d" >> $cfile -#. $exec >> $cfile -#echo "/bin/sh -x $exec" >> $cfile echo "" >>$cfile +echo "export ntasks=$(( $nodes * $procs ))" >> $cfile +echo "export ppn=$procs" >> $cfile +echo "export threads=$threads" >> $cfile echo "export OMP_NUM_THREADS=$threads" >> $cfile +echo "ulimit -s unlimited" >> $cfile + echo "" >>$cfile echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile echo "" >>$cfile echo ". /apps/lmod/lmod/init/sh" >> $cfile echo "module purge" >> $cfile -echo "module use $gsisrc/modulefiles" >> $cfile +echo "module use $modulefiles" >> $cfile echo "module load gsi_jet" >> $cfile echo "module list" >> $cfile echo "" >>$cfile @@ -146,40 +140,6 @@ elif [[ $verbose = YES ]];then set -x cat $cfile fi -#msub -I partition=$partition,size=$procs,walltime=$walltime $cfile - -#if [[ -n $when ]];then -# whena=$when -# if [[ $when = +* ]];then -# hr=$(echo $when|cut -c2-3) -# mn=$(echo $when|cut -c4-5) -# [[ -n $mn ]] || mn=00 -# now=$(date -u +"%Y%m%d%H%M") -# ((mn+=$(echo $now|cut -c11-12))) -# [[ $mn -ge 60 ]] && ((hr+=1)) && ((mn-=60)) -# [[ $mn -lt 10 ]] && mn=0$mn -# whena=$(/nwprod/util/exec/ndate +$hr $(echo $now|cut -c1-10))$mn -# elif [[ $when = t* ]];then -# hr=$(echo $when|cut -c2-3) -# mn=$(echo $when|cut -c4-5) -# [[ -n $mn ]] || mn=00 -# now=$(date -u +"%Y%m%d") -# whena=$now$hr$mn -# elif [[ $when = T* ]];then -# hr=$(echo $when|cut -c2-3) -# mn=$(echo $when|cut -c4-5) -# [[ -n $mn ]] || mn=00 -# now=$(date -u +"%Y%m%d%H") -# whena=$(/nwprod/util/exec/ndate +24 $now|cut -c1-8)$hr$mn -# fi -# yr=$(echo $whena|cut -c1-4) -# mo=$(echo $whena|cut -c5-6) -# dy=$(echo $whena|cut -c7-8) -# hr=$(echo $whena|cut -c9-10) -# mn=$(echo $whena|cut -c11-12) -# [[ -n $mn ]] || mn=00 -# echo "#@ startdate = $mo/$dy/$yr $hr:$mn" -#fi >>$cfile if [[ $stdin = YES ]];then diff --git a/ush/sub_orion b/ush/sub_orion index 065e7c8ab0..1bcce5cc4f 100755 --- a/ush/sub_orion +++ b/ush/sub_orion @@ -126,7 +126,7 @@ echo "" >>$cfile echo ". /apps/lmod/lmod/init/sh" >> $cfile echo "module purge" >> $cfile -echo "module use $gsisrc/modulefiles" >> $cfile +echo "module use $modulefiles" >> $cfile echo "module load gsi_orion" >> $cfile echo "module list" >> $cfile echo "" >> $cfile diff --git a/ush/sub_wcoss2 b/ush/sub_wcoss2 index 57115ef7c6..f2df099f23 100755 --- a/ush/sub_wcoss2 +++ b/ush/sub_wcoss2 @@ -123,19 +123,14 @@ echo "" >> $cfile echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile echo "" >> $cfile -echo "module purge" >> $cfile -echo "module load envvar/1.0" >> $cfile -echo "module load PrgEnv-intel/8.2.0" >> $cfile -echo "module load intel/19.1.3.304" >> $cfile -echo "module load craype/2.7.13" >> $cfile -echo "module load cray-mpich/8.1.12" >> $cfile -echo "module load cray-pals/1.1.3" >> $cfile -echo "module load prod_util/2.0.14" >> $cfile -echo "module load prod_envir/2.0.6" >> $cfile -echo "module load crtm/2.4.0" >> $cfile -echo "module load cfp/2.0.4" >> $cfile -echo "module load netcdf/4.7.4" >> $cfile -echo "module list" >> $cfile +echo "module reset" >> $cfile +echo "module use $modulefiles" >> $cfile +echo "module load gsi_wcoss2" >> $cfile +echo "module load envvar/1.0" >> $cfile +echo "module load cray-pals/1.2.2" >> $cfile +echo "module -t list 2>&1 | while read line;do module show $line 2>&1 | sed -n -e '2p';done | sort" >> $cfile +echo "module avail" >> $cfile + echo "" >> $cfile cat $exec >> $cfile From 008c63cc04d6d80c25b0c3220b2d2c3f98618d52 Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Thu, 14 Sep 2023 11:30:58 -0400 Subject: [PATCH 026/109] update fix submodule hash to include gfs.v16.3.9 updates (#621) **Description** This PR updates the `fix` submodule to bring in GFS v16.3.9 updates to `global_convinfo.txt` and `global_ozinfo.txt`. Issue #620 provides additional information on the GFS v16.3.9 updates. Please **note** the following - The change to `global_ozinfo.txt` alters analysis results if ompsnp observation from NOAA-20, NOAA-21, or NPP are processed by gsi.x or `enkf.x`. - The change to `global_convinfo.txt` alters analysis results if PlanetIQ GPSRO (type 267) is processed by `gsi.x` or `enkf.x`. Fixes #620 **Type of change** - [x] Breaking change (fix or feature that would cause existing functionality to not work as expected) See the **Note** above for potential impact on analysis results. **How Has This Been Tested?** ctests have been run on Hera, Orion, and WCOSS2 (Cactus) with results posted in issue #620. **Checklist** - [x] My code follows the style guidelines of this project - [x] I have performed a self-review of my own code --- fix | 2 +- modulefiles/gsi_cheyenne.intel.lua | 2 +- modulefiles/gsi_gaea.lua | 2 +- modulefiles/gsi_hera.gnu.lua | 2 +- modulefiles/gsi_hera.intel.lua | 2 +- modulefiles/gsi_jet.lua | 2 +- modulefiles/gsi_orion.lua | 2 +- modulefiles/gsi_s4.lua | 2 +- modulefiles/gsi_wcoss2.lua | 2 +- 9 files changed, 9 insertions(+), 9 deletions(-) diff --git a/fix b/fix index 6a42a29dbb..5722cd4d25 160000 --- a/fix +++ b/fix @@ -1 +1 @@ -Subproject commit 6a42a29dbbc9fca3453cc9e829601185555890b9 +Subproject commit 5722cd4d2519222137c5b356bdbc01bb34c5f1f4 diff --git a/modulefiles/gsi_cheyenne.intel.lua b/modulefiles/gsi_cheyenne.intel.lua index 4a3525bca1..26ed666695 100644 --- a/modulefiles/gsi_cheyenne.intel.lua +++ b/modulefiles/gsi_cheyenne.intel.lua @@ -18,7 +18,7 @@ load("mkl/2022.1") load("gsi_common") load(pathJoin("prod_util", os.getenv("prod_util_ver") or "1.2.2")) -pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_data/fix/20230601") +pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_data/fix/20230911") pushenv("CFLAGS", "-xHOST") pushenv("FFLAGS", "-xHOST") diff --git a/modulefiles/gsi_gaea.lua b/modulefiles/gsi_gaea.lua index f76c8f3ad9..a7a2454eff 100644 --- a/modulefiles/gsi_gaea.lua +++ b/modulefiles/gsi_gaea.lua @@ -23,7 +23,7 @@ local MKLROOT="/opt/intel/oneapi/mkl/2022.0.2/" prepend_path("LD_LIBRARY_PATH",pathJoin(MKLROOT,"lib/intel64")) pushenv("MKLROOT", MKLROOT) -pushenv("GSI_BINARY_SOURCE_DIR", "/lustre/f2/dev/role.epic/contrib/GSI_data/fix/20230601") +pushenv("GSI_BINARY_SOURCE_DIR", "/lustre/f2/dev/role.epic/contrib/GSI_data/fix/20230911") setenv("CC","cc") setenv("FC","ftn") diff --git a/modulefiles/gsi_hera.gnu.lua b/modulefiles/gsi_hera.gnu.lua index c309e67fe0..37504485e3 100644 --- a/modulefiles/gsi_hera.gnu.lua +++ b/modulefiles/gsi_hera.gnu.lua @@ -22,6 +22,6 @@ load("gsi_common") load(pathJoin("prod_util", prod_util_ver)) load(pathJoin("openblas", openblas_ver)) -pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20230601") +pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20230911") whatis("Description: GSI environment on Hera with GNU Compilers") diff --git a/modulefiles/gsi_hera.intel.lua b/modulefiles/gsi_hera.intel.lua index 866af02d50..619d0e76c9 100644 --- a/modulefiles/gsi_hera.intel.lua +++ b/modulefiles/gsi_hera.intel.lua @@ -25,6 +25,6 @@ load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-xHOST") pushenv("FFLAGS", "-xHOST") -pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20230601") +pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20230911") whatis("Description: GSI environment on Hera with Intel Compilers") diff --git a/modulefiles/gsi_jet.lua b/modulefiles/gsi_jet.lua index e2ea2ef1d0..c9e5e90680 100644 --- a/modulefiles/gsi_jet.lua +++ b/modulefiles/gsi_jet.lua @@ -26,6 +26,6 @@ pushenv("CFLAGS", "-axSSE4.2,AVX,CORE-AVX2") pushenv("FFLAGS", "-axSSE4.2,AVX,CORE-AVX2") -pushenv("GSI_BINARY_SOURCE_DIR", "/mnt/lfs4/HFIP/hfv3gfs/glopara/git/fv3gfs/fix/gsi/20230601") +pushenv("GSI_BINARY_SOURCE_DIR", "/mnt/lfs4/HFIP/hfv3gfs/glopara/git/fv3gfs/fix/gsi/20230911") whatis("Description: GSI environment on Jet with Intel Compilers") diff --git a/modulefiles/gsi_orion.lua b/modulefiles/gsi_orion.lua index a7ea874fb2..e75a01ef5e 100644 --- a/modulefiles/gsi_orion.lua +++ b/modulefiles/gsi_orion.lua @@ -25,6 +25,6 @@ load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-xHOST") pushenv("FFLAGS", "-xHOST") -pushenv("GSI_BINARY_SOURCE_DIR", "/work/noaa/global/glopara/fix/gsi/20230601") +pushenv("GSI_BINARY_SOURCE_DIR", "/work/noaa/global/glopara/fix/gsi/20230911") whatis("Description: GSI environment on Orion with Intel Compilers") diff --git a/modulefiles/gsi_s4.lua b/modulefiles/gsi_s4.lua index efdc6c4bfb..03c21e708d 100644 --- a/modulefiles/gsi_s4.lua +++ b/modulefiles/gsi_s4.lua @@ -23,6 +23,6 @@ load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-march=ivybridge") pushenv("FFLAGS", "-march=ivybridge") -pushenv("GSI_BINARY_SOURCE_DIR", "/data/prod/glopara/fix/gsi/20230601") +pushenv("GSI_BINARY_SOURCE_DIR", "/data/prod/glopara/fix/gsi/20230911") whatis("Description: GSI environment on S4 with Intel Compilers") diff --git a/modulefiles/gsi_wcoss2.lua b/modulefiles/gsi_wcoss2.lua index 1872f89d17..e5f4c7b812 100644 --- a/modulefiles/gsi_wcoss2.lua +++ b/modulefiles/gsi_wcoss2.lua @@ -20,6 +20,6 @@ load(pathJoin("prod_util", prod_util_ver)) load("gsi_common") -pushenv("GSI_BINARY_SOURCE_DIR", "/lfs/h2/emc/global/noscrub/emc.global/FIX/fix/gsi/20230601") +pushenv("GSI_BINARY_SOURCE_DIR", "/lfs/h2/emc/global/noscrub/emc.global/FIX/fix/gsi/20230911") whatis("Description: GSI environment on WCOSS2") From d84a18ffb7702c75e73434929ee189a3cc7132ed Mon Sep 17 00:00:00 2001 From: JingCheng-NOAA <135154465+JingCheng-NOAA@users.noreply.github.com> Date: Wed, 20 Sep 2023 11:04:19 -0400 Subject: [PATCH 027/109] Bring in HAFSv1 Related Changes (#608) **Description** Bring in HAFSv1 related maxobs changes and the capability of assimilating GOES-R high-resolution AMVs. Resolved #599 **Type of change** Use "maxobs" as a condition to check whether the number of observations exceeds the limit, to avoid the out of bound/dimension issue in read_anowbufr.f90 read_dbz_nc.f90 read_gmi.f90 read_goesglm.f90 read_radar.f90 read_radar_wind_ascii.f90 This update also added the capability of assimilating the CIMSS enhanced GOES-R AMVs in a new "satwhr" bufr file. Please delete options that are not relevant. - [x] Bug fix (non-breaking change which fixes an issue) - [x] New feature (non-breaking change which adds functionality) **How Has This Been Tested?** This updates passed the HAFS related regression tests. All tests are performed on Orion. **Checklist** - [x] My code follows the style guidelines of this project - [x] I have performed a self-review of my own code - [x] I have commented my code, particularly in hard-to-understand areas - [x] New and existing tests pass with my changes - [x] Any dependent changes have been merged and published **DUE DATE for this PR is 9/21/2023.** If this PR is not merged into develop by this date, the PR will be closed and returned to the developer. --------- Co-authored-by: jswhit Co-authored-by: Ting.Lei@noaa.gov Co-authored-by: Jili Dong Co-authored-by: Bin Liu Co-authored-by: daprediction Co-authored-by: TingLei-NOAA Co-authored-by: TingLei-NOAA <63461756+TingLei-NOAA@users.noreply.github.com> Co-authored-by: xulu Co-authored-by: Li Bi Co-authored-by: edward.safford Co-authored-by: MichaelLueken-NOAA <63728921+MichaelLueken-NOAA@users.noreply.github.com> Co-authored-by: RussTreadon-NOAA Co-authored-by: Michael Lueken Co-authored-by: AndrewEichmann-NOAA Co-authored-by: Rahul Mahajan Co-authored-by: Emily Liu Co-authored-by: emilyhcliu <36091766+emilyhcliu@users.noreply.github.com> Co-authored-by: Andrew Collard <40322596+ADCollard@users.noreply.github.com> Co-authored-by: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> --- src/gsi/read_anowbufr.f90 | 1 + src/gsi/read_dbz_nc.f90 | 1 + src/gsi/read_gmi.f90 | 1 + src/gsi/read_goesglm.f90 | 1 + src/gsi/read_obs.F90 | 7 ++--- src/gsi/read_radar.f90 | 2 ++ src/gsi/read_radar_wind_ascii.f90 | 1 + src/gsi/read_satwnd.f90 | 45 ++++++++++++++++++++++++------- src/gsi/setupuwnd10m.f90 | 2 +- src/gsi/setupvwnd10m.f90 | 2 +- src/gsi/setupw.f90 | 4 +-- src/gsi/setupwspd10m.f90 | 2 +- 12 files changed, 51 insertions(+), 18 deletions(-) diff --git a/src/gsi/read_anowbufr.f90 b/src/gsi/read_anowbufr.f90 index e2b744eb6a..1873d0b877 100644 --- a/src/gsi/read_anowbufr.f90 +++ b/src/gsi/read_anowbufr.f90 @@ -307,6 +307,7 @@ subroutine read_anowbufr(nread,ndata,nodata,gstime,& ndata=ndata+1 nodata=nodata+1 + if(ndata>maxobs) exit cdata_all(iconc,ndata) = conc ! pm2_5 obs cdata_all(ierror,ndata) = obserror ! pm2_5 obs error diff --git a/src/gsi/read_dbz_nc.f90 b/src/gsi/read_dbz_nc.f90 index cddbd14de4..f6ac9aa112 100644 --- a/src/gsi/read_dbz_nc.f90 +++ b/src/gsi/read_dbz_nc.f90 @@ -417,6 +417,7 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no !#################### Data thinning ################### icntpnt=icntpnt+1 + if(icntpnt>maxobs) exit if(ithin > 0)then diff --git a/src/gsi/read_gmi.f90 b/src/gsi/read_gmi.f90 index 0f45aa7e28..f59529662a 100644 --- a/src/gsi/read_gmi.f90 +++ b/src/gsi/read_gmi.f90 @@ -528,6 +528,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& flgch = 0 iobs=iobs+1 + if(iobs>maxobs) exit end do read_loop end do read_subset 690 continue diff --git a/src/gsi/read_goesglm.f90 b/src/gsi/read_goesglm.f90 index e0124abbf2..bf8639c72d 100644 --- a/src/gsi/read_goesglm.f90 +++ b/src/gsi/read_goesglm.f90 @@ -276,6 +276,7 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis) icntpnt=icntpnt+1 ndata=ndata+1 + if(ndata>maxobs) exit nodata=nodata+1 iout=ndata isort(icntpnt)=iout diff --git a/src/gsi/read_obs.F90 b/src/gsi/read_obs.F90 index 8e451c75be..cb4a7c4b8f 100644 --- a/src/gsi/read_obs.F90 +++ b/src/gsi/read_obs.F90 @@ -436,10 +436,10 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) end do nread = nread + 1 end do airploop - else if(trim(filename) == 'satwndbufr')then + else if(index(filename,'satwnd') /=0 .or. index(filename,'satwhr') /=0) then lexist = .false. loop: do while(ireadmg(lnbufr,subset,idate2) >= 0) -! 5 GOES-R AMVs (NC005030, NC005031, NC005032, NC005034 and NC005039) +! 5 GOES-R AMVs (NC005030, NC005031, NC005032, NC005034, NC005039, NC005099) ! are added as the GOES-R bufr file provide do not contain other winds. ! May not be necessary with the operational satwnd BUFR if(trim(subset) == 'NC005010' .or. trim(subset) == 'NC005011' .or.& @@ -450,6 +450,7 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) trim(subset) == 'NC005030' .or. trim(subset) == 'NC005031' .or.& trim(subset) == 'NC005032' .or. trim(subset) == 'NC005034' .or.& trim(subset) == 'NC005039' .or. & + trim(subset) == 'NC005099' .or. & trim(subset) == 'NC005090' .or. trim(subset) == 'NC005091' .or.& trim(subset) == 'NC005067' .or. trim(subset) == 'NC005068' .or. trim(subset) == 'NC005069' .or.& trim(subset) == 'NC005047' .or. trim(subset) == 'NC005048' .or. trim(subset) == 'NC005049' .or.& @@ -1503,7 +1504,7 @@ subroutine read_obs(ndata,mype) else if(obstype == 'uv' .or. obstype == 'wspd10m' .or. & obstype == 'uwnd10m' .or. obstype == 'vwnd10m') then ! Process satellite winds which seperate from prepbufr - if ( index(infile,'satwnd') /=0 ) then + if ( index(infile,'satwnd') /=0 .or. index(infile,'satwhr') /=0 ) then call read_satwnd(nread,npuse,nouse,infile,obstype,lunout,gstime,twind,sis,& prsl_full,nobs_sub1(1,i)) string='READ_SATWND' diff --git a/src/gsi/read_radar.f90 b/src/gsi/read_radar.f90 index 40c77a7ee2..9ce156e736 100644 --- a/src/gsi/read_radar.f90 +++ b/src/gsi/read_radar.f90 @@ -2911,6 +2911,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu !#################### Data thinning ################### icntpnt=icntpnt+1 + if(icntpnt>maxobs) exit if(ithin > 0)then if(zflag == 0)then @@ -4031,6 +4032,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) end if !#################### Data thinning ################### icntpnt=icntpnt+1 + if(icntpnt>maxobs) exit ithin=1 !number of obs to keep per grid box if(radar_no_thinning) then ithin=-1 diff --git a/src/gsi/read_radar_wind_ascii.f90 b/src/gsi/read_radar_wind_ascii.f90 index 2e1b06a50c..604d9d0eca 100644 --- a/src/gsi/read_radar_wind_ascii.f90 +++ b/src/gsi/read_radar_wind_ascii.f90 @@ -509,6 +509,7 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg !#################### Data thinning ################### icntpnt=icntpnt+1 + if(icntpnt>maxobs) exit if(ithin > 0)then if(zflag == 0)then diff --git a/src/gsi/read_satwnd.f90 b/src/gsi/read_satwnd.f90 index 1679708787..943cf4d47b 100644 --- a/src/gsi/read_satwnd.f90 +++ b/src/gsi/read_satwnd.f90 @@ -18,6 +18,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ! 253: EUMETSAT IR winds, 254: EUMETSAT WV deep layer winds ! 257,258,259: MODIS IR,WV cloud top, WV deep layer winds ! 260: VIIR IR winds +! 241: CIMSS enhanced AMV winds ! respectively ! For satellite subtype: 50-80 from EUMETSAT geostationary satellites(METEOSAT) ! 100-199 from JMA geostationary satellites(MTSAT) @@ -77,6 +78,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ! 2021-07-25 Genkova - added code for Metop-B/C winds in new BUFR,NC005081 ! ! 2022-01-20 Genkova - added missing station_id for polar winds ! 2022-01-20 Genkova - added code for Meteosat and Himawari AMVs in new BUFR +! 2022-12-10 Bi - added code for CIMSS enhanced AMVs in new BUFR ! ! ! input argument list: @@ -155,7 +157,6 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis real(r_kind),parameter:: r799=799.0_r_kind real(r_kind),parameter:: r1200= 1200.0_r_kind real(r_kind),parameter:: r10000= 10000.0_r_kind - real(r_double),parameter:: rmiss=10d7 ! Declare local variables @@ -212,7 +213,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis real(r_double),dimension(13):: hdrdat real(r_double),dimension(4):: obsdat - real(r_double),dimension(2) :: hdrdat_test + 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,12) :: qcdat @@ -509,7 +510,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis !GOES-R section of the 'if' statement over 'subsets' else if(trim(subset) == 'NC005030' .or. trim(subset) == 'NC005031' .or. trim(subset) == 'NC005032' .or. & - trim(subset) == 'NC005034' .or. trim(subset) == 'NC005039') then + 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 ! NOTE: Once it is confirmed that SWCM values are sensible, apply this logic and replace lines 685-702 ! if(hdrdat(9) == one) then @@ -537,6 +538,8 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis 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 ! wind is not recognised and itype is not assigned cycle loop_report @@ -735,7 +738,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis do_qc = subset(1:7)=='NC00503'.and.nint(hdrdat(1))>=270 do_qc = do_qc.or.subset(1:7)=='NC00501' do_qc = do_qc.or.subset=='NC005081'.or.subset=='NC005091' - do_qc = do_qc.or.qcret>0 + do_qc = do_qc.or.qcret>0 ! assign types and get quality info: start @@ -1051,7 +1054,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis endif ! get quality information THIS SECTION NEEDS TO BE TESTED!!! call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}') - irep_array = int(rep_array) + 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 @@ -1175,9 +1178,12 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis endif ! Extra block for VIIRS NOAA20: End ! Extra block for GOES-R winds: Start - else if(trim(subset) == 'NC005030' .or. trim(subset) == 'NC005031' .or. trim(subset) == 'NC005032' .or. & !IR(LW) / CS WV / VIS GOES-R like winds - trim(subset) == 'NC005034' .or. trim(subset) == 'NC005039' ) then !CT WV / IR(SW) GOES-R like winds + 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 + 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 @@ -1209,6 +1215,10 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis c_station_id='WV'//stationid c_sprvstg='WV' !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 ! call ufbint(lunin,rep_array,1,1,iret, '{AMVAHA}') @@ -1223,6 +1233,8 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ! 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)) @@ -1253,7 +1265,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis 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) then + 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 @@ -1279,6 +1291,16 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis 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 + + 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 + ! winds rejected by qc dont get used if (qm == 15) usage=r100 if (qm == 3 .or. qm ==7) woe=woe*r1_2 @@ -1288,9 +1310,12 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis 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' cycle loop_readsb endif @@ -1338,7 +1363,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ! 3 snow ! 4 mixed if( .not. twodvar_regional) then - if(itype ==245 .or. itype ==252 .or. itype ==253 .or. itype ==240) then + if(itype ==245 .or. itype ==252 .or. itype ==253 .or. itype ==240 .or. itype ==241) then if(hdrdat(2) >20.0_r_kind) then call deter_sfc_type(dlat_earth,dlon_earth,t4dv,isflg,tsavg) if(isflg /= 0) cycle loop_readsb @@ -1465,7 +1490,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ! 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' ) then + trim(subset) == 'NC005034' .or. trim(subset) == 'NC005039' .or. trim(subset) == 'NC005099') then obserr=obserr/two endif diff --git a/src/gsi/setupuwnd10m.f90 b/src/gsi/setupuwnd10m.f90 index 4552a7e81a..24a4e3d4f7 100644 --- a/src/gsi/setupuwnd10m.f90 +++ b/src/gsi/setupuwnd10m.f90 @@ -428,7 +428,7 @@ subroutine setupuwnd10m(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_d lowlevelsat=itype==242.or.itype==243.or.itype==245.or.itype==246.or. & itype==247.or.itype==250.or.itype==251.or.itype==252.or. & itype==253.or.itype==254.or.itype==257.or.itype==258.or. & - itype==259 + itype==259.or.itype==241 if (lowlevelsat .and. twodvar_regional) then call windfactor(presw,factw) data(iuob,i)=factw*data(iuob,i) diff --git a/src/gsi/setupvwnd10m.f90 b/src/gsi/setupvwnd10m.f90 index 0c601e716b..0f5b46900a 100644 --- a/src/gsi/setupvwnd10m.f90 +++ b/src/gsi/setupvwnd10m.f90 @@ -428,7 +428,7 @@ subroutine setupvwnd10m(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_d lowlevelsat=itype==242.or.itype==243.or.itype==245.or.itype==246.or. & itype==247.or.itype==250.or.itype==251.or.itype==252.or. & itype==253.or.itype==254.or.itype==257.or.itype==258.or. & - itype==259 + itype==259.or.itype==241 if (lowlevelsat .and. twodvar_regional) then call windfactor(presw,factw) data(iuob,i)=factw*data(iuob,i) diff --git a/src/gsi/setupw.f90 b/src/gsi/setupw.f90 index 087c3c34ab..784df1dfbe 100644 --- a/src/gsi/setupw.f90 +++ b/src/gsi/setupw.f90 @@ -877,7 +877,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav lowlevelsat=itype==242.or.itype==243.or.itype==245.or.itype==246.or. & itype==247.or.itype==250.or.itype==251.or.itype==252.or. & itype==253.or.itype==254.or.itype==257.or.itype==258.or. & - itype==259 + itype==259.or.itype==241 if (lowlevelsat .and. twodvar_regional) then call windfactor(presw,factw) data(iuob,i)=factw*data(iuob,i) @@ -1146,7 +1146,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav if(itype ==244) then ! AVHRR, use same as MODIS qcgross=r0_7*cgross(ikx) endif - if( itype == 245 .or. itype ==246) then + if( itype == 245 .or. itype ==246 .or. itype ==241) then if(presw <400.0_r_kind .and. presw >300.0_r_kind ) qcgross=r0_7*cgross(ikx) endif if(itype == 253 .or. itype ==254) then diff --git a/src/gsi/setupwspd10m.f90 b/src/gsi/setupwspd10m.f90 index 22618fbf9e..ad50c5b0c1 100644 --- a/src/gsi/setupwspd10m.f90 +++ b/src/gsi/setupwspd10m.f90 @@ -635,7 +635,7 @@ subroutine setupwspd10m(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_d lowlevelsat=itype==242.or.itype==243.or.itype==245.or.itype==246.or. & itype==247.or.itype==250.or.itype==251.or.itype==252.or. & itype==253.or.itype==254.or.itype==257.or.itype==258.or. & - itype==259 + itype==259.or.itype==241 if (lowlevelsat .and. twodvar_regional) then call windfactor(presw,factw) data(iuob,i)=factw*data(iuob,i) From aa656c6ee23d9a8d253be3dad95615b29ac0d033 Mon Sep 17 00:00:00 2001 From: Jeff Whitaker Date: Fri, 22 Sep 2023 08:05:11 -0600 Subject: [PATCH 028/109] fix for zero total ozone pressure in EnKF (issue #625) (#626) The fix involves setting the pressure to 0.001Pa for ozone obs that have zero pressure (to avoid Inf when log(p) calculated), and turning off ob-space vertical localization. Has no effect on current operational setup which uses model-space vertical localization (modelspace_vloc=T). --------- Co-authored-by: jswhit2 --- src/enkf/enkf_obsmod.f90 | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/enkf/enkf_obsmod.f90 b/src/enkf/enkf_obsmod.f90 index ba4b2946b1..ea8f6446fb 100644 --- a/src/enkf/enkf_obsmod.f90 +++ b/src/enkf/enkf_obsmod.f90 @@ -262,7 +262,6 @@ subroutine readobs() allocate(corrlengthsq(nobstot),lnsigl(nobstot),obtimel(nobstot)) lnsigl=1.e10 do nob=1,nobstot - oblnp(nob) = -log(obpress(nob)) ! distance measured in log(p) units if (obloclon(nob) < zero) obloclon(nob) = obloclon(nob) + 360._r_single radlon=deg2rad*obloclon(nob) radlat=deg2rad*obloclat(nob) @@ -283,6 +282,13 @@ subroutine readobs() lnsigl(nob)=latval(deglat,lnsigcutoffnh,lnsigcutofftr,lnsigcutoffsh) end if endif + ! total column ozone has pressure set to zero, set to 0.001Pa + ! and turn vertical localization off (no effect if modelspace_vloc=T) + if (obpress(nob) < 0.001 .and. obtype(nob)(1:3) .eq. ' oz') then + lnsigl(nob) = 1.e30 ! turn ob-space vert localization off + obpress(nob) = 0.001 ! set to a non-zero value + endif + oblnp(nob) = -log(obpress(nob)) ! distance measured in log(p) units corrlengthsq(nob)=latval(deglat,corrlengthnh,corrlengthtr,corrlengthsh)**2 if ( (obtype(nob)(1:3) == 'dbz' .or. obtype(nob)(1:3) == ' rw') .and. l_use_enkf_directZDA ) then corrlengthsq(nob)=latval(deglat,corrlengthrdrnh,corrlengthrdrtr,corrlengthrdrsh)**2 From 2f4e7fe8124603c6ac8c14ed2cf1aa393d6ec07d Mon Sep 17 00:00:00 2001 From: jderber-NOAA <75998838+jderber-NOAA@users.noreply.github.com> Date: Fri, 22 Sep 2023 12:17:22 -0400 Subject: [PATCH 029/109] Optimize the reading of ensembles and setup for global multiscale runs (#594) This update improves the efficiency of the GSI, especially for multiscale runs. Details can be found in issue #585 --- src/gsi/apply_scaledepwgts.f90 | 152 ++++++--- src/gsi/control_vectors.f90 | 8 +- src/gsi/cplr_gfs_ensmod.f90 | 263 ++++++++-------- src/gsi/general_specmod.f90 | 31 -- src/gsi/general_spectral_transforms.f90 | 4 +- src/gsi/general_sub2grid_mod.f90 | 167 ++++++++++ src/gsi/get_gefs_ensperts_dualres.f90 | 402 +++++++++++++----------- src/gsi/hybrid_ensemble_isotropic.F90 | 265 ++++++++-------- src/gsi/read_iasi.f90 | 6 +- src/gsi/read_prepbufr.f90 | 6 +- src/gsi/setupcldtot.F90 | 19 +- src/gsi/setuprad.f90 | 10 +- src/gsi/stpcalc.f90 | 3 +- 13 files changed, 790 insertions(+), 546 deletions(-) diff --git a/src/gsi/apply_scaledepwgts.f90 b/src/gsi/apply_scaledepwgts.f90 index e97b6fb614..e4952b28fa 100644 --- a/src/gsi/apply_scaledepwgts.f90 +++ b/src/gsi/apply_scaledepwgts.f90 @@ -16,18 +16,18 @@ function fwgtofwvlen (rvlft,rvrgt,rcons,rlen,rinput) ! !$$$ end documentation block - use kinds, only: r_kind,i_kind,r_single + use kinds, only: r_kind implicit none real(r_kind),intent(in) :: rvlft,rvrgt,rcons,rlen,rinput real(r_kind) :: fwgtofwvlen real(r_kind) :: rlen1,rtem1,rconshalf - rlen1=rlen/10.0_r_kind ! rlen corresponds to a (-5,5) region - rconshalf=0.5_r_kind*rcons if(rinput > rvlft .and. rinput < rvrgt) then fwgtofwvlen=rcons else + rlen1=rlen/10.0_r_kind ! rlen corresponds to a (-5,5) region + rconshalf=0.5_r_kind*rcons rtem1=min(abs(rinput-rvlft),abs(rinput-rvrgt)) fwgtofwvlen=rconshalf*(1.0_r_kind+tanh(5.0_r_kind-rtem1/rlen1)) endif @@ -41,23 +41,21 @@ subroutine init_mult_spc_wgts(jcap_in) ! !$$$ end documentation block - use kinds, only: r_kind,i_kind,r_single - use constants, only: zero,half,one,two,three,rearth,pi,tiny_r_kind + use kinds, only: r_kind,i_kind + use constants, only: zero,half,one,rearth,pi,tiny_r_kind use mpimod, only: mype - use general_sub2grid_mod, only: general_sub2grid_create_info - use egrid2agrid_mod,only: g_create_egrid2agrid - use general_sub2grid_mod, only: sub2grid_info use hybrid_ensemble_parameters, only: nsclgrp use hybrid_ensemble_parameters, only: spc_multwgt,spcwgt_params,r_ensloccov4scl implicit none integer(i_kind),intent(in ) :: jcap_in - integer(i_kind) i + integer(i_kind) i,l,ks integer(i_kind) ig - real(r_kind) rwv0,rtem1,rtem2 - real (r_kind):: fwgtofwvlen + real(r_kind) :: rwv0,rtem1,rtem2 + real(r_kind) :: fwgtofwvlen real(r_kind) :: totwvlength + real(r_kind),dimension(0:jcap_in,nsclgrp) :: spcwgt logical :: l_sum_spc_weights ! Spectral scale decomposition is differernt between SDL-cross and SDL-nocross @@ -67,9 +65,9 @@ subroutine init_mult_spc_wgts(jcap_in) l_sum_spc_weights = .true. end if - spc_multwgt(0,1)=one + spcwgt(0,1)=one do ig=2,nsclgrp - spc_multwgt(0,ig)=zero + spcwgt(0,ig)=zero end do @@ -79,13 +77,13 @@ subroutine init_mult_spc_wgts(jcap_in) rtem1=zero do ig=1,nsclgrp if(ig /= 2) then - spc_multwgt(i,ig)=fwgtofwvlen(spcwgt_params(1,ig),spcwgt_params(2,ig),& - spcwgt_params(3,ig),spcwgt_params(4,ig),totwvlength) - spc_multwgt(i,ig)=min(max(spc_multwgt(i,ig),zero),one) + spcwgt(i,ig)=fwgtofwvlen(spcwgt_params(1,ig),spcwgt_params(2,ig),& + spcwgt_params(3,ig),spcwgt_params(4,ig),totwvlength) + spcwgt(i,ig)=min(max(spcwgt(i,ig),zero),one) if(l_sum_spc_weights) then - rtem1=rtem1+spc_multwgt(i,ig) + rtem1=rtem1+spcwgt(i,ig) else - rtem1=rtem1+spc_multwgt(i,ig)*spc_multwgt(i,ig) + rtem1=rtem1+spcwgt(i,ig)*spcwgt(i,ig) endif endif enddo @@ -93,20 +91,52 @@ subroutine init_mult_spc_wgts(jcap_in) if(rtem2 >= zero) then if(l_sum_spc_weights) then - spc_multwgt(i,2)=rtem2 + spcwgt(i,2)=rtem2 else - spc_multwgt(i,2)=sqrt(rtem2) + spcwgt(i,2)=sqrt(rtem2) endif else - if(mype == 0)write(6,*) ' rtem2 < zero ',i,rtem2,(spc_multwgt(i,ig),ig=1,nsclgrp) - spc_multwgt(i,2)=zero + if(mype == 0)write(6,*) ' rtem2 < zero ',i,rtem2,(spcwgt(i,ig),ig=1,nsclgrp) + spcwgt(i,2)=zero endif enddo +!! Code borrowed from spvar in splib + + spc_multwgt = zero + do ig=1,nsclgrp + do i=0,jcap_in + ks=2*i + spc_multwgt(ks+1,ig)=spcwgt(i,ig) + end do + do i=0,jcap_in + do l=MAX(1,i-jcap_in),MIN(i,jcap_in) + ks=l*(2*jcap_in+1-l)+2*i + spc_multwgt(ks+1,ig) = spcwgt(i,ig) + spc_multwgt(ks+2,ig) = spcwgt(i,ig) + end do + end do + end do + return end subroutine init_mult_spc_wgts +subroutine destroy_mult_spc_wgts +!$$$ subprogram documentation block +! +! subprogram: destroy_mult_spc_wgts +! +!$$$ end documentation block + + use hybrid_ensemble_parameters, only: spc_multwgt,spcwgt_params + implicit none + + deallocate(spc_multwgt,spcwgt_params) -subroutine apply_scaledepwgts(grd_in,sp_in,wbundle,spwgts,wbundle2) + return +end subroutine destroy_mult_spc_wgts + + +subroutine apply_scaledepwgts(m,grd_in,sp_in) ! ! Program history log: ! 2017-03-30 J. Kay, X. Wang - copied from Kleist's apply_scaledepwgts and @@ -115,49 +145,67 @@ subroutine apply_scaledepwgts(grd_in,sp_in,wbundle,spwgts,wbundle2) ! use constants, only: one use control_vectors, only: control_vector - use kinds, only: r_kind,i_kind - use kinds, only: r_single - use general_specmod, only: general_spec_multwgt + use kinds, only: r_kind,i_kind,r_single use gsi_bundlemod, only: gsi_bundle use general_sub2grid_mod, only: general_sub2grid,general_grid2sub use general_specmod, only: spec_vars use general_sub2grid_mod, only: sub2grid_info - use mpimod, only: mpi_comm_world,mype + use hybrid_ensemble_parameters, only: spc_multwgt,en_perts,nsclgrp,n_ens + use mpimod, only: mype implicit none ! Declare passed variables - type(gsi_bundle),intent(in) :: wbundle - type(gsi_bundle),intent(inout) :: wbundle2 + integer,intent(in) :: m type(spec_vars),intent (in):: sp_in type(sub2grid_info),intent(in)::grd_in - real(r_kind),dimension(0:sp_in%jcap),intent(in):: spwgts ! Declare local variables - integer(i_kind) kk + integer(i_kind) kk,ig,n,ig2,i,j - real(r_kind),dimension(grd_in%nlat*grd_in%nlon*grd_in%nlevs_alloc) :: hwork - real(r_kind),dimension(grd_in%nlat,grd_in%nlon,grd_in%nlevs_alloc) :: work - real(r_kind),dimension(sp_in%nc):: spc1 - -! Beta1 first -! Get from subdomains to - call general_sub2grid(grd_in,wbundle%values,hwork) - work=reshape(hwork,(/grd_in%nlat,grd_in%nlon,grd_in%nlevs_alloc/)) - - do kk=1,grd_in%nlevs_alloc -! Transform from physical space to spectral space - call general_g2s0(grd_in,sp_in,spc1,work(:,:,kk)) - -! Apply spectral weights - call general_spec_multwgt(sp_in,spc1,spwgts) -! Transform back to physical space - call general_s2g0(grd_in,sp_in,spc1,work(:,:,kk)) + real(r_single),dimension(grd_in%nlat,grd_in%nlon,grd_in%nlevs_alloc,nsclgrp) :: hwork2 + real(r_kind),dimension(grd_in%nlat,grd_in%nlon) :: work + real(r_kind),dimension(sp_in%nc,grd_in%nlevs_alloc):: spc1 + real(r_kind),dimension(sp_in%nc):: spc2 + + do n=1,n_ens +! Get from subdomains to full grid + call general_sub2grid(grd_in,en_perts(n,1,m)%valuesr4(:),hwork2(:,:,:,1)) + +!$omp parallel do schedule(static,1) private(i,j,kk,work) + do kk=1,grd_in%nlevs_loc + do j=1,grd_in%nlon + do i=1,grd_in%nlat + work(i,j)=hwork2(i,j,kk,1) + end do + end do +! Transform from physical space to spectral space + call general_g2s0(grd_in,sp_in,spc1(1,kk),work) + + end do +!$omp parallel do schedule(static,1) private(kk,ig,ig2,i,j,work,spc2) + do ig2=1,nsclgrp*grd_in%nlevs_loc + ig=(ig2-1)/grd_in%nlevs_loc+1 + kk=ig2-(ig-1)*grd_in%nlevs_loc + + do i=1,sp_in%nc + spc2(i)=spc1(i,kk)*spc_multwgt(i,ig) + end do +! Apply spectral weights +! Transform back to physical space + call general_s2g0(grd_in,sp_in,spc2,work) + + do j=1,grd_in%nlon + do i=1,grd_in%nlat + hwork2(i,j,kk,ig)=work(i,j) + end do + end do + end do + do ig=1,nsclgrp +! Transfer work back to subdomains + call general_grid2sub(grd_in,hwork2(:,:,:,ig),en_perts(n,ig,m)%valuesr4(:)) + end do end do -! Transfer work back to subdomains - hwork=reshape(work,(/grd_in%nlat*grd_in%nlon*grd_in%nlevs_alloc/)) - call general_grid2sub(grd_in,hwork,wbundle2%values) - return end subroutine apply_scaledepwgts diff --git a/src/gsi/control_vectors.f90 b/src/gsi/control_vectors.f90 index 97578124d2..73f605b95f 100644 --- a/src/gsi/control_vectors.f90 +++ b/src/gsi/control_vectors.f90 @@ -897,21 +897,23 @@ real(r_quad) function qdot_prod_sub(xcv,ycv) itot=max(m3d,0)+max(m2d,0) if(l_hyb_ens)itot=itot+n_ens*naensgrp allocate(partsum(itot)) + partsum=zero_quad do ii=1,nsubwin !$omp parallel do schedule(dynamic,1) private(i) do i = 1,m3d - partsum(i) = dplevs(xcv%step(ii)%r3(i)%q,ycv%step(ii)%r3(i)%q,ihalo=1) + partsum(i) = partsum(i)+dplevs(xcv%step(ii)%r3(i)%q,ycv%step(ii)%r3(i)%q,ihalo=1) enddo !$omp parallel do schedule(dynamic,1) private(i) do i = 1,m2d - partsum(m3d+i) = dplevs(xcv%step(ii)%r2(i)%q,ycv%step(ii)%r2(i)%q,ihalo=1) + partsum(m3d+i) = partsum(m3d+i)+dplevs(xcv%step(ii)%r2(i)%q,ycv%step(ii)%r2(i)%q,ihalo=1) enddo if(l_hyb_ens) then do ig=1,naensgrp nigtmp=n_ens*(ig-1) !$omp parallel do schedule(dynamic,1) private(i) do i = 1,n_ens - partsum(m3d+m2d+nigtmp+i) = dplevs(xcv%aens(ii,ig,i)%r3(1)%q,ycv%aens(ii,ig,i)%r3(1)%q,ihalo=1) + partsum(m3d+m2d+nigtmp+i) = partsum(m3d+m2d+nigtmp+i) + & + dplevs(xcv%aens(ii,ig,i)%r3(1)%q,ycv%aens(ii,ig,i)%r3(1)%q,ihalo=1) end do end do end if diff --git a/src/gsi/cplr_gfs_ensmod.f90 b/src/gsi/cplr_gfs_ensmod.f90 index 550f85d209..6f7d1184c5 100644 --- a/src/gsi/cplr_gfs_ensmod.f90 +++ b/src/gsi/cplr_gfs_ensmod.f90 @@ -29,6 +29,7 @@ module get_gfs_ensmod_mod integer(i_kind) :: kas,kae,kasm,kaem,kaemz,mas,mae,masm,maem,maemz integer(i_kind) :: ibs,ibe,ibsm,ibem,ibemz,jbs,jbe,jbsm,jbem,jbemz integer(i_kind) :: kbs,kbe,kbsm,kbem,kbemz,mbs,mbe,mbsm,mbem,mbemz + integer(i_kind) :: icw,iql,iqi,iqr,iqs,iqg integer(i_kind) :: n2d type(genex_info) :: s_a2b @@ -180,13 +181,13 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & use gsi_4dvar, only: ens_fhrlevs use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only : assignment(=) - use hybrid_ensemble_parameters, only: n_ens,grd_ens + use hybrid_ensemble_parameters, only: n_ens,grd_ens,ntlevs_ens use hybrid_ensemble_parameters, only: ensemble_path - use control_vectors, only: nc2d,nc3d - !use control_vectors, only: cvars2d,cvars3d + use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d use genex_mod, only: genex_create_info,genex,genex_destroy_info use gridmod, only: use_gfs_nemsio use jfunc, only: cnvw_option + use mpeu_util, only: getindex implicit none @@ -206,9 +207,9 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & integer(i_kind) :: io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,i_ens integer(i_kind) :: ip integer(i_kind) :: nlon,nlat,nsig - integer(i_kind),dimension(n_ens) :: io_pe0 + integer(i_kind),dimension(n_ens) :: io_pe0,iretx real(r_single),allocatable,dimension(:,:,:,:) :: en_full,en_loc - real(r_kind),allocatable,dimension(:) :: sloc + real(r_single),allocatable,dimension(:,:,:) :: sloc integer(i_kind),allocatable,dimension(:) :: m_cvars2dw,m_cvars3dw integer(i_kind) :: m_cvars2d(nc2d),m_cvars3d(nc3d) type(sub2grid_info) :: grd3d @@ -234,10 +235,10 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & !!!!!!!!for example, n2d = nc3d*nsig + nc2d n2d=nc3d*grd_ens%nsig+nc2d - ias=1 ; iae=0 ; jas=1 ; jae=0 ; kas=1 ; kae=0 ; mas=1 ; mae=0 + ias=0 ; iae=0 ; jas=0 ; jae=0 ; kas=1 ; kae=0 ; mas=1 ; mae=0 if(mype==io_pe) then - iae=nlat - jae=nlon + iae=nlat+1 + jae=nlon+1 kae=n2d mas=n_io_pe_s ; mae=n_io_pe_em endif @@ -248,8 +249,13 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & ibe=ibs+grd_ens%lat1-1 jbs=grd_ens%jstart(mype+1) jbe=jbs+grd_ens%lon1-1 + jbs=jbs-1 + jbe=jbe+1 + ibs=ibs-1 + ibe=ibe+1 + + ibsm=ibs ; ibem=ibe ; jbsm=jbs ; jbem=jbe - ibsm=ibs-ip ; ibem=ibe+ip ; jbsm=jbs-ip ; jbem=jbe+ip kbs =1 ; kbe =n2d ; mbs =1 ; mbe =n_ens kbsm=kbs ; kbem=kbe ; mbsm=mbs ; mbem=mbe iaemz=max(iasm,iaem) ; jaemz=max(jasm,jaem) @@ -273,8 +279,6 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & m_cvars2dw=-999 m_cvars3dw=-999 - - !! read ensembles if ( mas == mae ) then @@ -305,45 +309,56 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & allocate(en_full(1,1,1,1)) end if +! scatter to subdomains: + call mpi_allreduce(m_cvars2dw,m_cvars2d,nc2d,mpi_integer4,mpi_max,mpi_comm_world,ierror) call mpi_allreduce(m_cvars3dw,m_cvars3d,nc3d,mpi_integer4,mpi_max,mpi_comm_world,ierror) - deallocate(m_cvars2dw,m_cvars3dw) -! scatter to subdomains: + ! Check hydrometeors in control variables + icw=getindex(cvars3d,'cw') + iql=getindex(cvars3d,'ql') + iqi=getindex(cvars3d,'qi') + iqr=getindex(cvars3d,'qr') + iqs=getindex(cvars3d,'qs') + iqg=getindex(cvars3d,'qg') ! en_loc=zero + allocate(en_loc(ibsm:ibemz,jbsm:jbemz,kbsm:kbemz,mbsm:mbemz)) call genex(s_a2b,en_full,en_loc) deallocate(en_full) + if(ntindex == ntlevs_ens)call genex_destroy_info(s_a2b) -! call genex_destroy_info(s_a2b) ! check on actual routine name - - allocate(sloc(lat2in*lon2in*(nc2d+nc3d*nsig))) call create_grd23d_(grd3d,nc2d+nc3d*grd%nsig) - iret=0 + + allocate(sloc(grd3d%lat2,grd3d%lon2,grd3d%num_fields)) + iretx=0 +!$omp parallel do schedule(dynamic,1) private(n,k,j,i,sloc) do n=1,n_ens - ii=0 - do k=1,nc2d+nc3d*nsig - do j=jbsm,jbem - do i=ibsm,ibem - ii=ii+1 - sloc(ii)=en_loc(i,j,k,n) + do k=1,grd3d%num_fields + do j=1,grd3d%lon2 + do i=1,grd3d%lat2 + sloc(i,j,k)=en_loc(i+ibsm-1,j+jbsm-1,k,n) enddo enddo enddo - call move2bundle_(grd3d,sloc,atm_bundle(n),m_cvars2d,m_cvars3d,iret) + call move2bundle_(grd3d,sloc,atm_bundle(n),m_cvars2d,m_cvars3d,iretx(n)) enddo + iret=iretx(1) + do n=2,n_ens + iret=iret+iretx(n) + end do deallocate(en_loc,sloc) call general_sub2grid_destroy_info(grd3d,grd) end subroutine get_user_ens_gfs_fastread_ -subroutine move2bundle_(grd3d,sloc,atm_bundle,m_cvars2d,m_cvars3d,iret) +subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) !$$$ subprogram documentation block ! . . . . @@ -373,58 +388,35 @@ subroutine move2bundle_(grd3d,sloc,atm_bundle,m_cvars2d,m_cvars3d,iret) ! !$$$ - use constants, only: zero,one,two,fv use general_sub2grid_mod, only: sub2grid_info use hybrid_ensemble_parameters, only: en_perts use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d - use mpeu_util, only: getindex implicit none ! Declare passed variables type(sub2grid_info), intent(in ) :: grd3d type(gsi_bundle), intent(inout) :: atm_bundle - real(r_kind), intent(inout) :: sloc(grd3d%lat2*grd3d%lon2*(nc2d+nc3d*grd3d%nsig)) + real(r_single), intent(inout) :: en_loc3(grd3d%lat2,grd3d%lon2,grd3d%num_fields) integer(i_kind), intent(in ) :: m_cvars2d(nc2d),m_cvars3d(nc3d) integer(i_kind), intent(inout) :: iret ! Declare internal variables character(len=*),parameter :: myname_='move2bundle_' - character(len=70) :: filename - integer(i_kind) :: ierr + integer(i_kind) :: ierr,i,j integer(i_kind) :: km1,m - integer(i_kind) :: icw,iql,iqi,iqr,iqs,iqg - real(r_kind),pointer,dimension(:,:) :: ps + real(r_single),pointer,dimension(:,:) :: ps !real(r_kind),pointer,dimension(:,:) :: sst - real(r_kind),dimension(grd3d%lat2,grd3d%lon2,nc2d+nc3d*grd3d%nsig)::en_loc3 - real(r_kind),pointer,dimension(:,:,:) :: u,v,tv,q,oz,cwmr - real(r_kind),pointer,dimension(:,:,:) :: qlmr,qimr,qrmr,qsmr,qgmr - real(r_kind),parameter :: r0_001 = 0.001_r_kind - - -!--- now update halo values of all variables using general_sub2grid - call update_halos_(grd3d,sloc,en_loc3) - - ! Check hydrometeors in control variables - icw=getindex(cvars3d,'cw') - iql=getindex(cvars3d,'ql') - iqi=getindex(cvars3d,'qi') - iqr=getindex(cvars3d,'qr') - iqs=getindex(cvars3d,'qs') - iqg=getindex(cvars3d,'qg') + real(r_single),pointer,dimension(:,:,:) :: u,v,tv,q,oz,cwmr + real(r_single),pointer,dimension(:,:,:) :: qlmr,qimr,qrmr,qsmr,qgmr ! atm_bundle to zero done earlier - call gsi_bundlegetpointer(atm_bundle,'ps',ps, ierr); iret = iret+ierr + call gsi_bundlegetpointer(atm_bundle,'ps',ps, ierr); iret = ierr !call gsi_bundlegetpointer(atm_bundle,'sst',sst, ierr); iret = iret+ierr - do m=1,nc2d -! convert ps from Pa to cb - if(trim(cvars2d(m))=='ps') ps=r0_001*en_loc3(:,:,m_cvars2d(m)) -! if(trim(cvars2d(m))=='sst') sst=en_loc3(:,:,m_cvars2d(m)) !no sst for now - enddo call gsi_bundlegetpointer(atm_bundle,'sf',u , ierr); iret = ierr + iret call gsi_bundlegetpointer(atm_bundle,'vp',v , ierr); iret = ierr + iret @@ -443,19 +435,25 @@ subroutine move2bundle_(grd3d,sloc,atm_bundle,m_cvars2d,m_cvars3d,iret) write(6,'(A)') trim(myname_) // ': For now, GFS requires all MetFields: ps,u,v,(sf,vp)tv,q,oz' write(6,'(A)') trim(myname_) // ': but some have not been found. Aborting ... ' write(6,'(A)') trim(myname_) // ': WARNING!' - write(6,'(3A,I5)') trim(myname_) // ': Trouble reading ensemble file : ', trim(filename), ', IRET = ', iret endif return endif + do m=1,nc2d +! convert ps from Pa to cb + if(trim(cvars2d(m))=='ps') ps=en_loc3(:,:,m_cvars2d(m)) +! if(trim(cvars2d(m))=='sst') sst=en_loc3(:,:,m_cvars2d(m)) !no sst for now + enddo + km1 = en_perts(1,1,1)%grid%km - 1 -!$omp parallel do schedule(dynamic,1) private(m) do m=1,nc3d if(trim(cvars3d(m))=='sf')then u = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='vp') then v = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='t') then +! Note tv here is sensible temperature. Converted to virtual temperature +! later. tv = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) else if(trim(cvars3d(m))=='q') then q = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1) @@ -476,9 +474,6 @@ subroutine move2bundle_(grd3d,sloc,atm_bundle,m_cvars2d,m_cvars3d,iret) end if enddo -! convert t to virtual temperature - tv=tv*(one+fv*q) - return end subroutine move2bundle_ @@ -505,51 +500,6 @@ subroutine create_grd23d_(grd23d,nvert) end subroutine create_grd23d_ -subroutine update_halos_(grd,sloc,s) - - use general_sub2grid_mod, only: sub2grid_info,general_sub2grid,general_grid2sub - - implicit none - - ! Declare passed variables - type(sub2grid_info), intent(in ) :: grd - real(r_kind), intent( out) :: s(grd%lat2,grd%lon2,grd%num_fields) - real(r_kind), intent(inout) :: sloc(grd%lat2*grd%lon2*grd%num_fields) - - ! Declare local variables - integer(i_kind) inner_vars,lat2,lon2,nlat,nlon,nvert,kbegin_loc,kend_alloc - integer(i_kind) ii,i,j,k - real(r_kind),allocatable,dimension(:,:,:,:) :: work - - lat2=grd%lat2 - lon2=grd%lon2 - nlat=grd%nlat - nlon=grd%nlon - nvert=grd%num_fields - inner_vars=grd%inner_vars - kbegin_loc=grd%kbegin_loc - kend_alloc=grd%kend_alloc - - - - allocate(work(inner_vars,nlat,nlon,kbegin_loc:kend_alloc)) - call general_sub2grid(grd,sloc,work) - - call general_grid2sub(grd,work,sloc) - deallocate(work) - - ii=0 - do k=1,nvert - do j=1,lon2 - do i=1,lat2 - ii=ii+1 - s(i,j,k)=sloc(ii) - enddo - enddo - enddo - -end subroutine update_halos_ - subroutine ens_io_partition_(n_ens,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,io_pe0,i_ens) ! do computation on all processors, then assign final local processor @@ -605,7 +555,7 @@ subroutine ens_io_partition_(n_ens,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,io_pe0,i end subroutine ens_io_partition_ -subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig, & +subroutine parallel_read_nemsio_state_(en_full,m_cvars2dw,m_cvars3d,nlon,nlat,nsig, & ias,jas,mas, & iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz, & filename,init_head,filenamesfc) @@ -627,7 +577,7 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi integer(i_kind), intent(in ) :: nlon,nlat,nsig integer(i_kind), intent(in ) :: ias,jas,mas integer(i_kind), intent(in ) :: iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz - integer(i_kind), intent(inout) :: m_cvars2d(nc2d),m_cvars3d(nc3d) + integer(i_kind), intent(inout) :: m_cvars2dw(nc2d),m_cvars3d(nc3d) real(r_single), intent(inout) :: en_full(iasm:iaemz,jasm:jaemz,kasm:kaemz,masm:maemz) character(len=*), intent(in ) :: filename character(len=*), optional, intent(in) :: filenamesfc @@ -816,15 +766,27 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi m_cvars3d(k3)=kf+1 do k=1,nsig kf=kf+1 - jj=jas-1 + jj=jas do j=1,nlon jj=jj+1 - ii=ias-1 + ii=ias do i=1,nlat ii=ii+1 en_full(ii,jj,kf,mas)=temp3(i,j,k,k3) enddo enddo + ii=ias + do i=1,nlat + ii=ii+1 + en_full(ii,jasm,kf,mas)=en_full(ii,jaem-1,kf,mas) + en_full(ii,jaem,kf,mas)=en_full(ii,jasm+1,kf,mas) + enddo + jj=jas-1 + do j=jasm,jaem + jj=jj+1 + en_full(iasm,jj,kf,mas)=en_full(iasm+1,jj,kf,mas) + en_full(iaem,jj,kf,mas)=en_full(iaem-1,jj,kf,mas) + end do enddo enddo deallocate(temp3) @@ -853,24 +815,36 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi ! move temp2 to en_full do k2=1,nc2d - m_cvars2d(k2)=kf+1 + m_cvars2dw(k2)=kf+1 kf=kf+1 - jj=jas-1 + jj=jas do j=1,nlon jj=jj+1 - ii=ias-1 + ii=ias do i=1,nlat ii=ii+1 en_full(ii,jj,kf,mas)=temp2(i,j,k2) enddo enddo + ii=ias + do i=1,nlat + ii=ii+1 + en_full(ii,jasm,kf,mas)=en_full(ii,jaem-1,kf,mas) + en_full(ii,jaem,kf,mas)=en_full(ii,jasm+1,kf,mas) + enddo + jj=jas-1 + do j=jasm,jaem + jj=jj+1 + en_full(iasm,jj,kf,mas)=en_full(iasm+1,jj,kf,mas) + en_full(iaem,jj,kf,mas)=en_full(iaem-1,jj,kf,mas) + end do enddo deallocate(temp2) end subroutine parallel_read_nemsio_state_ -subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig, & +subroutine parallel_read_gfsnc_state_(en_full,m_cvars2dw,m_cvars3d,nlon,nlat,nsig, & ias,jas,mas, & iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz, & filename) @@ -884,7 +858,7 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig ! !$$$ - use constants, only: r60,r3600,zero,one,half,deg2rad + use constants, only: r60,r3600,zero,one,half,deg2rad,zero_single use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d use general_sub2grid_mod, only: sub2grid_info use module_ncio, only: Dataset, Variable, Dimension, open_dataset,& @@ -898,7 +872,7 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig integer(i_kind), intent(in ) :: nlon,nlat,nsig integer(i_kind), intent(in ) :: ias,jas,mas integer(i_kind), intent(in ) :: iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz - integer(i_kind), intent(inout) :: m_cvars2d(nc2d),m_cvars3d(nc3d) + integer(i_kind), intent(inout) :: m_cvars2dw(nc2d),m_cvars3d(nc3d) real(r_single), intent(inout) :: en_full(iasm:iaemz,jasm:jaemz,kasm:kaemz,masm:maemz) character(len=*), intent(in ) :: filename @@ -1021,15 +995,27 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig m_cvars3d(k3)=kf+1 do k=1,nsig kf=kf+1 - jj=jas-1 + jj=jas do j=1,nlon jj=jj+1 - ii=ias-1 + ii=ias do i=1,nlat ii=ii+1 en_full(ii,jj,kf,mas)=temp3(i,j,k,k3) enddo enddo + ii=ias + do i=1,nlat + ii=ii+1 + en_full(ii,jasm,kf,mas)=en_full(ii,jaem-1,kf,mas) + en_full(ii,jaem,kf,mas)=en_full(ii,jasm+1,kf,mas) + enddo + jj=jas-1 + do j=jasm,jaem + jj=jj+1 + en_full(iasm,jj,kf,mas)=en_full(iasm+1,jj,kf,mas) + en_full(iaem,jj,kf,mas)=en_full(iaem-1,jj,kf,mas) + end do enddo enddo @@ -1042,24 +1028,34 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig call read_vardata(atmges, 'pressfc', rwork2d) call move1_(rwork2d,temp2,nlon,nlat) call fillpoles_ss_(temp2,nlon,nlat) - else - temp2=zero - endif ! move temp2 to en_full - kf=kf+1 - m_cvars2d(k2)=kf - jj=jas-1 - do j=1,nlon - jj=jj+1 - ii=ias-1 + kf=kf+1 + m_cvars2dw(k2)=kf + jj=jas + do j=1,nlon + jj=jj+1 + ii=ias + do i=1,nlat + ii=ii+1 + en_full(ii,jj,kf,mas)=temp2(i,j) + enddo + enddo + ii=ias do i=1,nlat ii=ii+1 - en_full(ii,jj,kf,mas)=temp2(i,j) + en_full(ii,jasm,kf,mas)=en_full(ii,jaem-1,kf,mas) + en_full(ii,jaem,kf,mas)=en_full(ii,jasm+1,kf,mas) enddo - enddo + jj=jas-1 + do j=jasm,jaem + jj=jj+1 + en_full(iasm,jj,kf,mas)=en_full(iasm+1,jj,kf,mas) + en_full(iaem,jj,kf,mas)=en_full(iaem-1,jj,kf,mas) + end do + end if enddo -! call close_dataset(atmges) + call close_dataset(atmges) deallocate(rwork2d) deallocate(temp2) @@ -1158,7 +1154,7 @@ subroutine fillpoles_sv_(tempu,tempv,nlon,nlat,clons,slons) real(r_single), intent(inout) :: tempu(nlat,nlon),tempv(nlat,nlon) real(r_kind), intent(in ) :: clons(nlon),slons(nlon) - integer(i_kind) i + integer(i_kind) i,nlatm real(r_kind) polnu,polnv,polsu,polsv ! Compute mean along southern and northern latitudes @@ -1166,11 +1162,12 @@ subroutine fillpoles_sv_(tempu,tempv,nlon,nlat,clons,slons) polnv=zero polsu=zero polsv=zero + nlatm=nlat-1 do i=1,nlon - polnu=polnu+tempu(nlat-1,i)*clons(i)-tempv(nlat-1,i)*slons(i) - polnv=polnv+tempu(nlat-1,i)*slons(i)+tempv(nlat-1,i)*clons(i) - polsu=polsu+tempu(2,i )*clons(i)+tempv(2,i )*slons(i) - polsv=polsv+tempu(2,i )*slons(i)-tempv(2,i )*clons(i) + polnu=polnu+tempu(nlatm,i)*clons(i)-tempv(nlatm,i)*slons(i) + polnv=polnv+tempu(nlatm,i)*slons(i)+tempv(nlatm,i)*clons(i) + polsu=polsu+tempu(2,i )*clons(i)+tempv(2,i )*slons(i) + polsv=polsv+tempu(2,i )*slons(i)-tempv(2,i )*clons(i) end do polnu=polnu/float(nlon) polnv=polnv/float(nlon) diff --git a/src/gsi/general_specmod.f90 b/src/gsi/general_specmod.f90 index c90187bf70..439e26e431 100644 --- a/src/gsi/general_specmod.f90 +++ b/src/gsi/general_specmod.f90 @@ -64,7 +64,6 @@ module general_specmod ! set subroutines to public public :: general_init_spec_vars public :: general_destroy_spec_vars - public :: general_spec_multwgt ! set passed variables to public public :: spec_vars public :: spec_cut @@ -307,36 +306,6 @@ subroutine general_init_spec_vars(sp,jcap,jcap_test,nlat_a,nlon_a,eqspace) return end subroutine general_init_spec_vars - subroutine general_spec_multwgt(sp,spcwrk,spcwgt) -! 2017-03-30 J. Kay, X. Wang - add general_spec_multwgt for scale-dependent -! weighting of mixed resolution ensemble, -! POC: xuguang.wang@ou.edu -! - implicit none - type(spec_vars),intent(in) :: sp - real(r_kind),dimension(sp%nc),intent(inout) :: spcwrk - real(r_kind),dimension(0:sp%jcap),intent(in) :: spcwgt - - integer(i_kind) l,jmax,ks,n - -!! Code borrowed from spvar in splib - jmax=sp%jcap - - do n=0,jmax - ks=2*n - spcwrk(ks+1)=spcwrk(ks+1)*spcwgt(n) - end do - do n=0,jmax - do l=MAX(1,n-jmax),MIN(n,jmax) - ks=l*(2*jmax+(-1)*(l-1))+2*n - spcwrk(ks+1) = spcwrk(ks+1)*spcwgt(n) - spcwrk(ks+2) = spcwrk(ks+2)*spcwgt(n) - end do - end do - - return - end subroutine general_spec_multwgt - subroutine general_destroy_spec_vars(sp) !$$$ subprogram documentation block ! . . . . diff --git a/src/gsi/general_spectral_transforms.f90 b/src/gsi/general_spectral_transforms.f90 index d4f0959489..541923e450 100644 --- a/src/gsi/general_spectral_transforms.f90 +++ b/src/gsi/general_spectral_transforms.f90 @@ -368,8 +368,8 @@ subroutine sfilter(grd,sp,filter,grid) call general_sptez_s(sp,spec_work,work,-1) - gnlon=float(grd%nlon) -! gnlon=real(grd%nlon,r_kind) +! gnlon=float(grd%nlon) + gnlon=real(grd%nlon,r_kind) do i=1,sp%nc spec_work(i)=spec_work(i)*gnlon end do diff --git a/src/gsi/general_sub2grid_mod.f90 b/src/gsi/general_sub2grid_mod.f90 index f0548643bb..bacea4688b 100644 --- a/src/gsi/general_sub2grid_mod.f90 +++ b/src/gsi/general_sub2grid_mod.f90 @@ -87,6 +87,7 @@ module general_sub2grid_mod interface general_sub2grid module procedure general_sub2grid_r_single_rank11 module procedure general_sub2grid_r_single_rank14 + module procedure general_sub2grid_r_single_rank13 module procedure general_sub2grid_r_single_rank4 module procedure general_sub2grid_r_double_rank11 module procedure general_sub2grid_r_double_rank14 @@ -97,6 +98,7 @@ module general_sub2grid_mod module procedure general_grid2sub_r_single_rank11 module procedure general_grid2sub_r_single_rank41 module procedure general_grid2sub_r_single_rank4 + module procedure general_grid2sub_r_single_rank31 module procedure general_grid2sub_r_double_rank11 module procedure general_grid2sub_r_double_rank41 module procedure general_grid2sub_r_double_rank4 @@ -1019,6 +1021,93 @@ subroutine general_sub2grid_r_single_rank14(s,sub_vars,grid_vars) end subroutine general_sub2grid_r_single_rank14 + subroutine general_sub2grid_r_single_rank13(s,sub_vars,grid_vars) +!$$$ subprogram documentation block +! . . . . +! subprogram: general_sub2grid_r_single_rank4 convert from subdomains to full horizontal grid +! prgmmr: parrish org: np22 date: 2010-02-11 +! +! abstract: generalized version of sub2grid--uses only gsi module kinds. +! All information needed is contained in the structure variable +! "s", instead of various modules. This allows +! for easy adaptation for any collection/ordering of variables +! defined on subdomains, which need to be made available on +! full horizontal grid for horizontal operations. +! The structure variable is specified by subroutine general_sub2grid_setup. +! This version works with single precision (4-byte) real variables. +! Input sub_vars, the desired arrays on horizontal subdomains, has one +! halo row, for now, which is filled with zero, since for ensemble use, +! there is no need for a halo, but is easiest for now to keep it. +! A later version will have variable number of halo rows, filled with proper values. +! +! program history log: +! 2010-02-11 parrish, initial documentation +! +! input argument list: +! s - structure variable, contains all necessary information for +! moving this set of subdomain variables sub_vars to +! the corresponding set of full horizontal grid variables. +! sub_vars - input grid values in vertical subdomain mode (contains one halo row) +! +! output argument list: +! grid_vars - output grid values in horizontal slab mode. +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use mpimod, only: mpi_comm_world,mpi_real4 + implicit none + + type(sub2grid_info),intent(in ) :: s + real(r_single), intent(in ) :: sub_vars(s%lat2*s%lon2*s%num_fields) + real(r_single), intent( out) :: grid_vars(s%nlat,s%nlon,s%kbegin_loc:s%kend_alloc) + + real(r_single) :: sub_vars_r4(s%lat2,s%lon2,s%num_fields) + real(r_single) :: sub_vars0(s%lat1,s%lon1,s%num_fields) + real(r_single) :: work(s%itotsub*(s%kend_alloc-s%kbegin_loc+1)) + integer(i_kind) iloc,iskip,i,i0,j,j0,k,n,k_in,ilat,jlon,ierror,ioffset + + sub_vars_r4 = reshape(sub_vars,(/s%lat2,s%lon2,s%num_fields/)) +! remove halo row +!$omp parallel do schedule(dynamic,1) private(k,j,j0,i0,i) + do k=1,s%num_fields + do j=2,s%lon2-1 + j0=j-1 + do i=2,s%lat2-1 + i0=i-1 + sub_vars0(i0,j0,k)=sub_vars_r4(i,j,k) + end do + end do + end do + + call mpi_alltoallv(sub_vars0,s%recvcounts,s%rdispls,mpi_real4, & + work,s%sendcounts,s%sdispls,mpi_real4,mpi_comm_world,ierror) + + + k_in=s%kend_loc-s%kbegin_loc+1 + +! Load grid_vars array in desired order +!$omp parallel do schedule(dynamic,1) private(k,iskip,iloc,n,i,ilat,jlon,ioffset) + do k=s%kbegin_loc,s%kend_loc + iskip=0 + iloc=0 + do n=1,s%npe + if (n/=1) then + iskip=iskip+s%ijn(n-1)*k_in + end if + ioffset=iskip+(k-s%kbegin_loc)*s%ijn(n) + do i=1,s%ijn(n) + iloc=iloc+1 + ilat=s%ltosi(iloc) + jlon=s%ltosj(iloc) + grid_vars(ilat,jlon,k)=work(i + ioffset) + end do + end do + end do + + end subroutine general_sub2grid_r_single_rank13 subroutine general_sub2grid_r_single_rank4(s,sub_vars,grid_vars) !$$$ subprogram documentation block ! . . . . @@ -1199,6 +1288,84 @@ subroutine general_grid2sub_r_single_rank41(s,grid_vars,sub_vars) end subroutine general_grid2sub_r_single_rank41 + subroutine general_grid2sub_r_single_rank31(s,grid_vars,sub_vars) +!$$$ subprogram documentation block +! . . . . +! subprogram: general_sub2grid convert from subdomains to full horizontal grid +! prgmmr: parrish org: np22 date: 2010-02-11 +! +! abstract: generalized version of grid2sub--uses only gsi module kinds. +! All information needed is contained in the structure variable +! "s", instead of various modules. This allows +! for easy adaptation for any collection/ordering of variables +! defined on subdomains, which need to be made available on +! full horizontal grid for horizontal operations. +! The structure variable is specified by subroutine general_sub2grid_setup. +! This version works with single precision (4-byte) real variables. +! Output sub_vars, the desired arrays on horizontal subdomains, has one +! halo row, for now, which is filled with zero, since for ensemble use, +! there is no need for a halo, but is easiest for now to keep it. +! A later version will have variable number of halo rows, filled with proper values. +! +! program history log: +! 2010-02-11 parrish, initial documentation +! 2010-03-02 parrish - remove setting halo to zero in output +! 2014-12-03 derber - make similar optimization changes already in code for +! double precision. +! +! input argument list: +! s - structure variable, contains all necessary information for +! moving this set of subdomain variables sub_vars to +! the corresponding set of full horizontal grid variables. +! grid_vars - input grid values in horizontal slab mode. +! +! output argument list: +! sub_vars - output grid values in vertical subdomain mode +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use constants, only: zero + use mpimod, only: mpi_comm_world,mpi_real4 + implicit none + + type(sub2grid_info),intent(in ) :: s + real(r_single), intent(in ) :: grid_vars(s%nlat,s%nlon,s%kbegin_loc:s%kend_alloc) + real(r_single), intent( out) :: sub_vars(s%lat2*s%lon2*s%num_fields) + + real(r_single) :: sub_vars_r4(s%lat2,s%lon2,s%num_fields) + real(r_single) :: temp(s%itotsub*(s%kend_loc-s%kbegin_loc+1)) + integer(i_kind) iloc,i,ii,k,n,ilat,jlon,ierror,icount + integer(i_kind),dimension(s%npe) ::iskip + +! reorganize for eventual distribution to local domains + iskip(1)=0 + do n=2,s%npe + iskip(n)=iskip(n-1)+s%ijn_s(n-1)*(s%kend_loc-s%kbegin_loc+1) + end do +!$omp parallel do schedule(dynamic,1) private(n,k,i,jlon,ii,ilat,iloc,icount) + do k=s%kbegin_loc,s%kend_loc + icount=0 + do n=1,s%npe + iloc=iskip(n)+(k-s%kbegin_loc)*s%ijn_s(n) + do i=1,s%ijn_s(n) + iloc=iloc+1 + icount=icount+1 + ilat=s%ltosi_s(icount) + jlon=s%ltosj_s(icount) + temp(iloc)=grid_vars(ilat,jlon,k) + end do + end do + end do + + + call mpi_alltoallv(temp,s%sendcounts_s,s%sdispls_s,mpi_real4, & + sub_vars_r4,s%recvcounts_s,s%rdispls_s,mpi_real4,mpi_comm_world,ierror) + + sub_vars = reshape(sub_vars_r4,(/s%lat2*s%lon2*s%num_fields/)) + end subroutine general_grid2sub_r_single_rank31 subroutine general_grid2sub_r_single_rank4(s,grid_vars,sub_vars) !$$$ subprogram documentation block ! . . . . diff --git a/src/gsi/get_gefs_ensperts_dualres.f90 b/src/gsi/get_gefs_ensperts_dualres.f90 index e244fa9f53..bb5ee374af 100644 --- a/src/gsi/get_gefs_ensperts_dualres.f90 +++ b/src/gsi/get_gefs_ensperts_dualres.f90 @@ -26,7 +26,7 @@ subroutine get_gefs_ensperts_dualres ! ! get_gefs_ensperts_dualres.f90(182): error #6460: This is not a field name that ! is defined in the encompassing structure. [LAT2] -! call genqsat(qs,tsen,prsl,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig,ice,iderivative) +! call genqsat2(qs,tsen,prsl,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig,ice) ! 2014-11-30 todling - partially generalized to handle any control vector ! (GFS hook needs further attention) ! - also, take SST from members of ensemble @@ -69,7 +69,7 @@ subroutine get_gefs_ensperts_dualres use gsi_enscouplermod, only: gsi_enscoupler_create_sub2grid_info use gsi_enscouplermod, only: gsi_enscoupler_destroy_sub2grid_info use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info,general_sub2grid_destroy_info - use hybrid_ensemble_parameters, only: nsclgrp,sp_ens,spc_multwgt,global_spectral_filter_sd + use hybrid_ensemble_parameters, only: nsclgrp,sp_ens,global_spectral_filter_sd implicit none real(r_kind),pointer,dimension(:,:) :: ps @@ -78,24 +78,23 @@ subroutine get_gefs_ensperts_dualres ! real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon):: sst_full,dum real(r_kind),pointer,dimension(:,:,:):: p3 real(r_kind),pointer,dimension(:,:):: x2 - type(gsi_bundle),allocatable,dimension(:) :: en_read + type(gsi_bundle),allocatable,dimension(:) :: en_real8 type(gsi_bundle):: en_bar - type(gsi_bundle) :: en_pertstmp1 - type(gsi_bundle) :: en_pertstmp2 ! type(gsi_grid) :: grid_ens - real(r_kind) bar_norm,sig_norm,kapr,kap1 + real(r_kind) bar_norm,sig_norm ! real(r_kind),allocatable,dimension(:,:):: z,sst2 - real(r_kind),allocatable,dimension(:,:,:) :: tsen,prsl,pri,qs + real(r_kind),allocatable,dimension(:,:,:) :: tsen,prsl ! integer(i_kind),dimension(grd_ens%nlat,grd_ens%nlon):: idum - integer(i_kind) istatus,iret,i,ic3,j,k,n,iderivative,im,jm,km,m,ipic + integer(i_kind) istatus,iret,i,ic3,j,k,n,im,jm,km,m,ipic ! integer(i_kind) mm1 integer(i_kind) ipc3d(nc3d),ipc2d(nc2d) integer(i_kind) ier ! integer(i_kind) il,jl logical ice,hydrometeor type(sub2grid_info) :: grd_tmp - integer(i_kind) :: ig + real(r_kind),parameter :: r0_001 = 0.001_r_kind + ! Create perturbations grid and get variable names from perturbations if(en_perts(1,1,1)%grid%im/=grd_ens%lat2.or. & @@ -135,25 +134,15 @@ subroutine get_gefs_ensperts_dualres if ( istatus /= 0 ) & call die('get_gefs_ensperts_dualres',': trouble creating en_bar bundle, istatus =',istatus) -! Allocate bundle used for temporary usage - if( nsclgrp > 1 .and. global_spectral_filter_sd )then - call gsi_bundlecreate(en_pertstmp1,en_perts(1,1,1)%grid,'aux-ens-read',istatus,names2d=cvars2d,names3d=cvars3d) - call gsi_bundlecreate(en_pertstmp2,en_perts(1,1,1)%grid,'aux-ens-read',istatus,names2d=cvars2d,names3d=cvars3d) - if(istatus/=0) then - write(6,*)' get_gefs_ensperts_dualres: trouble creating en_read like tempbundle' - call stop2(999) - endif - end if - - ! Allocate bundle used for reading members - allocate(en_read(n_ens)) + ! Allocate bundle used for real*8 version of members + allocate(en_real8(n_ens)) do n=1,n_ens - call gsi_bundlecreate(en_read(n),en_perts(1,1,1)%grid,'ensemble member',istatus,names2d=cvars2d,names3d=cvars3d) + call gsi_bundlecreate(en_real8(n),en_perts(1,1,1)%grid,'ensemble member',istatus,names2d=cvars2d,names3d=cvars3d) if ( istatus /= 0 ) & - call die('get_gefs_ensperts_dualres',': trouble creating en_read bundle, istatus =',istatus) - en_read(n) = zero + call die('get_gefs_ensperts_dualres',': trouble creating en_real8 bundle, istatus =',istatus) end do + ! allocate(z(im,jm)) ! allocate(sst2(im,jm)) @@ -162,7 +151,7 @@ subroutine get_gefs_ensperts_dualres ntlevs_ens_loop: do m=1,ntlevs_ens - call gsi_enscoupler_get_user_Nens(grd_tmp,n_ens,m,en_read,iret) + call gsi_enscoupler_get_user_Nens(grd_tmp,n_ens,m,en_perts(:,1,m),iret) ! Check read return code. Revert to static B if read error detected if ( iret /= 0 ) then @@ -175,67 +164,52 @@ subroutine get_gefs_ensperts_dualres endif en_bar%values=zero + allocate(tsen(im,jm,km)) if (.not.q_hyb_ens) then !use RH - allocate(pri(im,jm,km+1)) - allocate(prsl(im,jm,km),tsen(im,jm,km)) - allocate(qs(im,jm,km)) + allocate(prsl(im,jm,km)) end if do n=1,n_ens + do i=1,nelen + en_real8(n)%values(i)=real(en_perts(n,1,m)%valuesr4(i),r_kind) + end do - call gsi_bundlegetpointer(en_read(n),'q' ,q ,ier);istatus=istatus+ier + call gsi_bundlegetpointer(en_real8(n),'q' ,q ,ier);istatus=istatus+ier + call gsi_bundlegetpointer(en_real8(n),'t' ,tv,ier);istatus=istatus+ier + call gsi_bundlegetpointer(en_real8(n),'ps',ps,ier);istatus=ier +! Convert ps to correct units + do j=1,jm + do i=1,im + ps(i,j)=r0_001*ps(i,j) + end do + end do +! Convert to real from single and convert tv to virtual temperature do k=1,km do j=1,jm do i=1,im +! Use following 3 lines for results identical to previous version +! tv(i,j,k)= tv(i,j,k)*(one+fv*q(i,j,k)) +! q(i,j,k)=max(q(i,j,k),zero) +! tsen(i,j,k)=tv(i,j,k)/(one+fv*q(i,j,k)) +! Remove following 3 lines for results identical to previous version q(i,j,k)=max(q(i,j,k),zero) + tsen(i,j,k)=tv(i,j,k) + tv(i,j,k)= tsen(i,j,k)*(one+fv*q(i,j,k)) end do end do end do if (.not.q_hyb_ens) then !use RH - call gsi_bundlegetpointer(en_read(n),'ps',ps,ier);istatus=ier - call gsi_bundlegetpointer(en_read(n),'t' ,tv,ier);istatus=istatus+ier + ! Compute RH ! Get 3d pressure field now on interfaces - call general_getprs_glb(ps,tv,pri) -! Get sensible temperature and 3d layer pressure - if (idsl5 /= 2) then - kap1=rd_over_cp+one - kapr=one/rd_over_cp -!$omp parallel do schedule(dynamic,1) private(k,j,i) - do k=1,km - do j=1,jm - do i=1,im - prsl(i,j,k)=((pri(i,j,k)**kap1-pri(i,j,k+1)**kap1)/& - (kap1*(pri(i,j,k)-pri(i,j,k+1))))**kapr - tsen(i,j,k)= tv(i,j,k)/(one+fv*q(i,j,k)) - end do - end do - end do - else -!$omp parallel do schedule(dynamic,1) private(k,j,i) - do k=1,km - do j=1,jm - do i=1,im - prsl(i,j,k)=(pri(i,j,k)+pri(i,j,k+1))*half - tsen(i,j,k)= tv(i,j,k)/(one+fv*q(i,j,k)) - end do - end do - end do - end if + call general_getprs_glb(ps,tv,prsl) ice=.true. - iderivative=0 - call genqsat(qs,tsen,prsl,im,jm,km,ice,iderivative) - do k=1,km - do j=1,jm - do i=1,im - q(i,j,k)=q(i,j,k)/qs(i,j,k) - end do - end do - end do + call genqsat2(q,tsen,prsl,ice) + end if -!$omp parallel do schedule(dynamic,1) private(i,k,j,ic3,hydrometeor,istatus,p3) +! !$omp parallel do schedule(dynamic,1) private(i,k,j,ic3,hydrometeor,istatus,p3) do ic3=1,nc3d hydrometeor = trim(cvars3d(ic3))=='cw' .or. trim(cvars3d(ic3))=='ql' .or. & @@ -246,7 +220,7 @@ subroutine get_gefs_ensperts_dualres if ( hydrometeor ) then - call gsi_bundlegetpointer(en_read(n),trim(cvars3d(ic3)),p3,istatus) + call gsi_bundlegetpointer(en_real8(n),trim(cvars3d(ic3)),p3,istatus) if(istatus/=0) then write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' from read in member ',n,m call stop2(999) @@ -260,7 +234,7 @@ subroutine get_gefs_ensperts_dualres end do else if ( trim(cvars3d(ic3)) == 'oz' .and. oz_univ_static ) then - call gsi_bundlegetpointer(en_read(n),trim(cvars3d(ic3)),p3,istatus) + call gsi_bundlegetpointer(en_real8(n),trim(cvars3d(ic3)),p3,istatus) if(istatus/=0) then write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' from read in member ',n,m call stop2(999) @@ -270,7 +244,7 @@ subroutine get_gefs_ensperts_dualres end do !c3d do i=1,nelen - en_bar%values(i)=en_bar%values(i)+en_read(n)%values(i)*bar_norm + en_bar%values(i)=en_bar%values(i)+en_real8(n)%values(i)*bar_norm end do @@ -282,10 +256,9 @@ subroutine get_gefs_ensperts_dualres end do ! end do over ensembles if (.not.q_hyb_ens) then !use RH - deallocate(pri) - deallocate(tsen,prsl) - deallocate(qs) + deallocate(prsl) end if + deallocate(tsen) ! Before converting to perturbations, get ensemble spread !!! it is not clear of the next statement is thread/$omp safe. @@ -309,7 +282,7 @@ subroutine get_gefs_ensperts_dualres !$omp parallel do schedule(dynamic,1) private(n,i,ic3,ipic,k,j) do n=1,n_ens do i=1,nelen - en_perts(n,1,m)%valuesr4(i)=en_read(n)%values(i)-en_bar%values(i) + en_perts(n,1,m)%valuesr4(i)=en_real8(n)%values(i)-en_bar%values(i) end do if(.not. q_hyb_ens) then do ic3=1,nc3d @@ -318,8 +291,8 @@ subroutine get_gefs_ensperts_dualres do k=1,km do j=1,jm do i=1,im - en_perts(n,1,m)%r3(ipic)%qr4(i,j,k) = min(en_perts(n,1,m)%r3(ipic)%qr4(i,j,k),limqens) - en_perts(n,1,m)%r3(ipic)%qr4(i,j,k) = max(en_perts(n,1,m)%r3(ipic)%qr4(i,j,k),-limqens) + en_perts(n,1,m)%r3(ipic)%qr4(i,j,k) = & + max(min(en_perts(n,1,m)%r3(ipic)%qr4(i,j,k),limqens),-limqens) end do end do end do @@ -330,33 +303,22 @@ subroutine get_gefs_ensperts_dualres en_perts(n,1,m)%valuesr4(i)=en_perts(n,1,m)%valuesr4(i)*sig_norm end do end do + if(nsclgrp > 1 .and. global_spectral_filter_sd) then + call apply_scaledepwgts(m,grd_ens,sp_ens) + end if end do ntlevs_ens_loop !end do over bins - call gsi_bundledestroy(en_bar,istatus) - if(nsclgrp > 1 .and. global_spectral_filter_sd) then - do m=1,ntlevs_ens - do n=1,n_ens - en_pertstmp1%values=en_perts(n,1,m)%valuesr4 - do ig=1,nsclgrp - call apply_scaledepwgts(grd_ens,sp_ens,en_pertstmp1,spc_multwgt(:,ig),en_pertstmp2) - en_perts(n,ig,m)%valuesr4=en_pertstmp2%values - enddo - enddo - enddo - endif - do n=n_ens,1,-1 - call gsi_bundledestroy(en_read(n),istatus) + call gsi_bundledestroy(en_real8(n),istatus) if ( istatus /= 0 ) & - call die('get_gefs_ensperts_dualres',': trouble destroying en_read bundle, istatus = ', istatus) + call die('get_gefs_ensperts_dualres',': trouble destroying en_real8 bundle, istatus = ', istatus) end do - deallocate(en_read) - if(nsclgrp > 1 .and. global_spectral_filter_sd) then - call gsi_bundledestroy(en_pertstmp1,istatus) - call gsi_bundledestroy(en_pertstmp2,istatus) - if ( istatus /= 0 ) & - call die('get_gefs_ensperts_dualres',': trouble destroying en_pertstmp2 bundle, istatus = ', istatus) - end if + deallocate(en_real8) + + call gsi_bundledestroy(en_bar,istatus) + + if(nsclgrp > 1 .and. global_spectral_filter_sd) call destroy_mult_spc_wgts + call gsi_enscoupler_destroy_sub2grid_info(grd_tmp) ! mm1=mype+1 @@ -675,7 +637,7 @@ subroutine write_spread_dualres(ibin,bundle) return end subroutine write_spread_dualres -subroutine general_getprs_glb(ps,tv,prs) +subroutine general_getprs_glb(ps,tv,prsl) ! subprogram: getprs get 3d pressure or 3d pressure deriv ! prgmmr: kleist org: np20 date: 2005-09-29 ! @@ -707,107 +669,197 @@ subroutine general_getprs_glb(ps,tv,prs) use kinds,only: r_kind,i_kind use constants,only: zero,half,one_tenth,rd_over_cp,one - use gridmod,only: nsig,ak5,bk5,ck5,tref5,idvc5 - use gridmod,only: wrf_nmm_regional,nems_nmmb_regional,eta1_ll,eta2_ll,pdtop_ll,pt_ll,& - regional,wrf_mass_regional,twodvar_regional,fv3_regional + use gridmod,only: nsig,ak5,bk5,ck5,tref5,idvc5,idsl5 use hybrid_ensemble_parameters, only: grd_ens implicit none ! Declare passed variables - real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2) ,intent(in ) :: ps - real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,nsig) ,intent(in ) :: tv - real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,nsig+1),intent( out) :: prs + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2) ,intent(in ) :: ps + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,nsig),intent(in ) :: tv + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,nsig),intent( out) :: prsl ! Declare local variables - real(r_kind) kapr,trk + real(r_kind) kapr,trk,kap1 + real(r_kind),dimension(grd_ens%lat2,nsig+1) :: prs integer(i_kind) i,j,k,k2 ! ,it -! Declare local parameter - real(r_kind),parameter:: ten = 10.0_r_kind - if (regional) then - if(wrf_nmm_regional.or.nems_nmmb_regional) then - do k=1,nsig+1 - do j=1,grd_ens%lon2 + k2=nsig+1 + kap1=rd_over_cp+one + kapr=one/rd_over_cp +!$omp parallel do schedule(dynamic,1) private(k,j,i,trk,prs) + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + prs(i,1)=ps(i,j) + prs(i,k2)=zero + end do + if (idvc5 /= 3) then + do k=2,nsig do i=1,grd_ens%lat2 - prs(i,j,k)=one_tenth* & - (eta1_ll(k)*pdtop_ll + & - eta2_ll(k)*(ten*ps(i,j)-pdtop_ll-pt_ll) + & - pt_ll) + prs(i,k)=ak5(k)+bk5(k)*ps(i,j) end do end do - end do - elseif (fv3_regional) then - do k=1,nsig+1 - do j=1,grd_ens%lon2 + else + do k=1,nsig do i=1,grd_ens%lat2 - prs(i,j,k)=eta1_ll(k)+ eta2_ll(k)*ps(i,j) + trk=(half*(tv(i,j,k-1)+tv(i,j,k))/tref5(k))**kapr + prs(i,k)=ak5(k)+(bk5(k)*ps(i,j))+(ck5(k)*trk) end do end do - end do - - elseif (twodvar_regional) then - do k=1,nsig+1 - do j=1,grd_ens%lon2 + end if +! Get sensible temperature and 3d layer pressure + if (idsl5 /= 2) then + do k=1,nsig do i=1,grd_ens%lat2 - prs(i,j,k)=one_tenth*(eta1_ll(k)*(ten*ps(i,j)-pt_ll) + pt_ll) + prsl(i,j,k)=((prs(i,k)**kap1-prs(i,k+1)**kap1)/& + (kap1*(prs(i,k)-prs(i,k+1))))**kapr end do end do - end do - elseif (wrf_mass_regional) then - do k=1,nsig+1 - do j=1,grd_ens%lon2 + else + do k=1,nsig do i=1,grd_ens%lat2 - prs(i,j,k)=one_tenth*(eta1_ll(k)*(ten*ps(i,j)-pt_ll) + & - eta2_ll(k) + pt_ll) + prsl(i,j,k)=(prs(i,k)+prs(i,k+1))*half end do end do - end do - endif - else - if (idvc5 /= 3) then -!$omp parallel do schedule(dynamic,1) private(k,j,i) - do k=1,nsig - if(k == 1)then - k2=nsig+1 - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - prs(i,j,k)=ps(i,j) - prs(i,j,k2)=zero - end do - end do - else - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - prs(i,j,k)=ak5(k)+bk5(k)*ps(i,j) - end do - end do + end if + end do + + return +end subroutine general_getprs_glb +subroutine genqsat2(q,tsen,prsl,ice) +!$$$ subprogram documentation block +! . . . . +! subprogram: genqsat +! prgmmr: derber org: np23 date: 1998-01-14 +! +! abstract: obtain saturation specific humidity for given temperature. +! +! program history log: +! 1998-01-14 derber +! 1998-04-05 weiyu yang +! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version +! 1903-10-07 Wei Gu, bug fixes,if qs<0,then set qs=0; merge w/ GSI by R Todling +! 2003-12-23 kleist, use guess pressure, adapt module framework +! 2004-05-13 kleist, documentation +! 2004-06-03 treadon, replace ggrid_g3 array with ges_* arrays +! 2005-02-23 wu, output dlnesdtv +! 2005-11-21 kleist, derber add dmax array to decouple moisture from temp and +! pressure for questionable qsat +! 2006-02-02 treadon - rename prsl as ges_prsl +! 2006-09-18 derber - modify to limit saturated values near top +! 2006-11-22 derber - correct bug: es 2._r_kind) .and. & + tsen(i,j,k) < mint(i))then + lmint(i)=k + mint(i)=tsen(i,j,k) end if end do - else - kapr=one/rd_over_cp -!$omp parallel do schedule(dynamic,1) private(k,j,i,trk) - do k=1,nsig - if(k == 1)then - k2=nsig+1 - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - prs(i,j,k)=ps(i,j) - prs(i,j,k2)=zero - end do - end do + end do + do i=1,grd_ens%lat2 + tdry = mint(i) + tr = ttp/tdry + if (tdry >= ttp .or. .not. ice) then + estmax(i) = psat * (tr**xa) * exp(xb*(one-tr)) + elseif (tdry < tmix) then + estmax(i) = psat * (tr**xai) * exp(xbi*(one-tr)) + else + w = (tdry - tmix) / (ttp - tmix) + estmax(i) = w * psat * (tr**xa) * exp(xb*(one-tr)) & + + (one-w) * psat * (tr**xai) * exp(xbi*(one-tr)) + endif + end do + + do k = 1,nsig + do i = 1,grd_ens%lat2 + tdry = tsen(i,j,k) + tr = ttp/tdry + if (tdry >= ttp .or. .not. ice) then + es = psat * (tr**xa) * exp(xb*(one-tr)) + elseif (tdry < tmix) then + es = psat * (tr**xai) * exp(xbi*(one-tr)) else - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - trk=(half*(tv(i,j,k-1)+tv(i,j,k))/tref5(k))**kapr - prs(i,j,k)=ak5(k)+(bk5(k)*ps(i,j))+(ck5(k)*trk) - end do - end do + esw = psat * (tr**xa) * exp(xb*(one-tr)) + esi = psat * (tr**xai) * exp(xbi*(one-tr)) + w = (tdry - tmix) / (ttp - tmix) + es = w * esw + (one-w) * esi +! es = w * psat * (tr**xa) * exp(xb*(one-tr)) & +! + (one-w) * psat * (tr**xai) * exp(xbi*(one-tr)) + + endif + + pw = onep3*prsl(i,j,k) + if(lmint(i) < k)then + esmax=0.1_r_kind*pw + esmax=min(esmax,estmax(i)) + es=min(es,esmax) end if - end do - end if - end if + qs = max(qmin, eps * es / (pw - omeps * es)) + q(i,j,k) = q(i,j,k)/qs + end do + end do + end do return -end subroutine general_getprs_glb +end subroutine genqsat2 + diff --git a/src/gsi/hybrid_ensemble_isotropic.F90 b/src/gsi/hybrid_ensemble_isotropic.F90 index fe2e058dff..fc87026c98 100644 --- a/src/gsi/hybrid_ensemble_isotropic.F90 +++ b/src/gsi/hybrid_ensemble_isotropic.F90 @@ -591,7 +591,7 @@ subroutine new_factorization_rf_x(f,iadvance,iback,nlevs,ig) ny=grd_loc%nlat ; nx=grd_loc%nlon ; nz=nlevs if(vvlocal)then -!$omp parallel do schedule(dynamic,1) private(k,j,i,l) +!$omp parallel do schedule(static,1) private(k,j,i,l) do k=1,nz if(iadvance == 1) then @@ -634,7 +634,7 @@ subroutine new_factorization_rf_x(f,iadvance,iback,nlevs,ig) enddo else -!$omp parallel do schedule(dynamic,1) private(k,j,i,l) +!$omp parallel do schedule(static,1) private(k,j,i,l) do k=1,nz if(iadvance == 1) then @@ -1607,7 +1607,7 @@ subroutine fix_belt(z) real(r_kind) zloc1(ny,nx) integer(i_kind) i,ii,j,jj,k -!$omp parallel do schedule(dynamic,1) private(j,k,i,jj,ii,zloc1) +!$omp parallel do schedule(static,1) private(j,k,i,jj,ii,zloc1) do j=1,nscl do k=1,nnnn1o i=0 @@ -1686,7 +1686,7 @@ subroutine rescale_ensemble_rh_perturbations end if do m=1,ntlevs_ens do ig=1,ntotensgrp -!$omp parallel do schedule(dynamic,1) private(n,i,j,k,w3,istatus) +!$omp parallel do schedule(static,1) private(n,i,j,k,w3,istatus) do n=1,n_ens call gsi_bundlegetpointer(en_perts(n,ig,m),'q',w3,istatus) if(istatus/=0) then @@ -1835,7 +1835,7 @@ subroutine ensemble_forward_model(cvec,a_en,ibin) ipx=1 -!$omp parallel do schedule(dynamic,1) private(j,n,ic3,k,i,ipic,ig,iaens) +!$omp parallel do schedule(static,1) private(j,n,ic3,k,i,ipic,ig,iaens) do k=1,km do ic3=1,nc3d ipic=ipc3d(ic3) @@ -1860,7 +1860,6 @@ subroutine ensemble_forward_model(cvec,a_en,ibin) enddo enddo -!$omp parallel do schedule(dynamic,1) private(j,n,k,i,ic2,ipic,ig,iaens) do ic2=1,nc2d ipic=ipc2d(ic2) do j=1,jm @@ -2012,7 +2011,7 @@ subroutine ensemble_forward_model_dual_res(cvec,a_en,ibin) im=work_ens%grid%im jm=work_ens%grid%jm km=work_ens%grid%km -!$omp parallel do schedule(dynamic,1) private(j,n,ic3,k,i,ipic,ig,iaens) +!$omp parallel do schedule(static,1) private(j,n,ic3,k,i,ipic,ig,iaens) do k=1,km do ic3=1,nc3d ipic=ipc3d(ic3) @@ -2036,7 +2035,6 @@ subroutine ensemble_forward_model_dual_res(cvec,a_en,ibin) enddo enddo enddo -!$omp parallel do schedule(dynamic,1) private(j,n,k,i,ic2,ipic,ig,iaens) do ic2=1,nc2d ipic=ipc2d(ic2) do j=1,jm @@ -2189,7 +2187,7 @@ subroutine ensemble_forward_model_ad(cvec,a_en,ibin) endif ipx=1 -!$omp parallel do schedule(dynamic,1) private(j,n,ic3,k,i,ic2,ipic,ig,iaens) +!$omp parallel do schedule(static,1) private(j,n,ic3,k,i,ic2,ipic,ig,iaens) do n=1,n_ens do ig=1,ntotensgrp do ic3=1,nc3d @@ -2206,6 +2204,7 @@ subroutine ensemble_forward_model_ad(cvec,a_en,ibin) enddo endif ! iaens>0 enddo + do ic2=1,nc2d iaens=ensgrp2aensgrp(ig,ic2+nc3d,ibin) if(iaens>0) then @@ -2354,7 +2353,7 @@ subroutine ensemble_forward_model_ad_dual_res(cvec,a_en,ibin) im=a_en(1,1)%grid%im jm=a_en(1,1)%grid%jm km=a_en(1,1)%grid%km -!$omp parallel do schedule(dynamic,1) private(j,n,ic3,k,i,ic2,ipic,ig,iaens) +!$omp parallel do schedule(static,1) private(j,n,ic3,k,i,ic2,ipic,ig,iaens) do n=1,n_ens do ig=1,ntotensgrp do ic3=1,nc3d @@ -2686,7 +2685,7 @@ subroutine sqrt_beta_s_mult_cvec(grady) endif ! multiply by sqrt_beta_s -!$omp parallel do schedule(dynamic,1) private(ic3,ic2,k,j,i,ii) +!$omp parallel do schedule(static,1) private(ic3,ic2,k,j,i,ii) do j=1,lon2 do ii=1,nsubwin do ic3=1,nc3d @@ -2784,7 +2783,7 @@ subroutine sqrt_beta_s_mult_bundle(grady) endif ! multiply by sqrt_beta_s -!$omp parallel do schedule(dynamic,1) private(ic3,ic2,k,j,i) +!$omp parallel do schedule(static,1) private(ic3,ic2,k,j,i) do j=1,lon2 do ic3=1,nc3d ! check for ozone and skip if oz_univ_static = true @@ -2864,12 +2863,12 @@ subroutine sqrt_beta_e_mult_cvec(grady) call timer_ini('sqrt_beta_e_mult') ! multiply by sqrt_beta_e -!$omp parallel do schedule(dynamic,1) private(nn,k,j,i,ii,ig) - do j=1,grd_ens%lon2 +!$omp parallel do schedule(static,1) private(nn,k,j,i,ii,ig) + do nn=1,n_ens do ii=1,nsubwin do ig=1,naensgrp - do nn=1,n_ens - do k=1,nsig + do k=1,nsig + do j=1,grd_ens%lon2 do i=1,grd_ens%lat2 grady%aens(ii,ig,nn)%r3(1)%q(i,j,k) = sqrt_beta_e(k)*grady%aens(ii,ig,nn)%r3(1)%q(i,j,k) enddo @@ -2931,11 +2930,11 @@ subroutine sqrt_beta_e_mult_bundle(aens) call timer_ini('sqrt_beta_e_mult') ! multiply by sqrt_beta_e -!$omp parallel do schedule(dynamic,1) private(nn,k,j,i,ig) - do j=1,grd_ens%lon2 +!$omp parallel do schedule(static,1) private(nn,k,j,i,ig) + do nn=1,n_ens do ig=1,naensgrp - do nn=1,n_ens - do k=1,nsig + do k=1,nsig + do j=1,grd_ens%lon2 do i=1,grd_ens%lat2 aens(ig,nn)%r3(1)%q(i,j,k) = sqrt_beta_e(k)*aens(ig,nn)%r3(1)%q(i,j,k) enddo @@ -2993,19 +2992,18 @@ subroutine init_sf_xy(jcap_in) integer(i_kind),intent(in ) :: jcap_in - integer(i_kind) i,ii,j,k,l,n,jcap,kk,nsigend,ig - real(r_kind),allocatable::g(:),gsave(:) + integer(i_kind) i,ii,j,igg,k,l,n,jcap,kk,nsigend,ig + real(r_kind),allocatable::g(:),gtemp(:) real(r_kind) factor real(r_kind),allocatable::rkm(:),f(:,:),f0(:,:) real(r_kind) ftest(grd_loc%nlat,grd_loc%nlon,grd_loc%kbegin_loc:grd_loc%kend_alloc) real(r_single) out1(grd_ens%nlon,grd_ens%nlat) - real(r_single),allocatable::pn0_npole(:) + real(r_single) pn0_npole real(r_kind) s_ens_h_min real(r_kind) rlats_ens_local(grd_ens%nlat) real(r_kind) rlons_ens_local(grd_ens%nlon) character(5) mapname logical make_test_maps - logical,allocatable,dimension(:)::ksame integer(i_kind) nord_sploc2ens integer(i_kind) nlon_sploc0,nlon_sploc,nlat_sploc,num_fields logical print_verbose @@ -3157,101 +3155,107 @@ subroutine init_sf_xy(jcap_in) if(.not.allocated(spectral_filter)) allocate(spectral_filter(naensloc,sp_loc%nc,grd_sploc%nsig)) if(.not.allocated(sqrt_spectral_filter)) allocate(sqrt_spectral_filter(naensloc,sp_loc%nc,grd_sploc%nsig)) - allocate(g(sp_loc%nc),gsave(sp_loc%nc)) - allocate(pn0_npole(0:sp_loc%jcap)) - allocate(ksame(grd_sploc%nsig)) + allocate(g(sp_loc%nc),gtemp(sp_loc%nc)) do ig=1,naensloc - ksame=.false. - do k=2,grd_sploc%nsig - if(s_ens_hv(k,ig) == s_ens_hv(k-1,ig))ksame(k)=.true. - enddo spectral_filter(ig,:,:)=zero - do k=1,grd_sploc%nsig - if(ksame(k))then - spectral_filter(ig,:,k)=spectral_filter(ig,:,k-1) - else + level_loop: do k=1,grd_sploc%nsig + do kk=1,k-1 + if(s_ens_hv(k,ig) == s_ens_hv(kk,ig))then + spectral_filter(ig,:,k)=spectral_filter(ig,:,k-1) + cycle level_loop + end if + end do + if(ig > 1)then + do igg=1,ig-1 + do kk=1,grd_sploc%nsig + if(s_ens_hv(k,ig) == s_ens_hv(kk,igg))then + spectral_filter(ig,:,k)=spectral_filter(igg,:,kk) + cycle level_loop + end if + end do + end do + end if + + do i=1,grd_sploc%nlat + f0(i,1)=exp(-half*(rkm(i)/s_ens_hv(k,ig))**2) + enddo + + + do j=2,grd_sploc%nlon do i=1,grd_sploc%nlat - f0(i,1)=exp(-half*(rkm(i)/s_ens_hv(k,ig))**2) + f0(i,j)=f0(i,1) enddo + end do - do j=2,grd_sploc%nlon - do i=1,grd_sploc%nlat - f0(i,j)=f0(i,1) - enddo - enddo - call general_g2s0(grd_sploc,sp_loc,g,f0) + call general_g2s0(grd_sploc,sp_loc,g,f0) - call general_s2g0(grd_sploc,sp_loc,g,f) + call general_s2g0(grd_sploc,sp_loc,g,f) -! adjust so value at np = 1 - f=f/f(grd_sploc%nlat,1) - f0=f - call general_g2s0(grd_sploc,sp_loc,g,f) - call general_s2g0(grd_sploc,sp_loc,g,f) - if(mype == 0)then - nsigend=k - do kk=k+1,grd_sploc%nsig - if(s_ens_hv(kk,ig) /= s_ens_hv(k,ig))exit - nsigend=nsigend+1 - enddo - write(6,900)k,nsigend,sp_loc%jcap,s_ens_hv(k,ig),maxval(abs(f0-f)) -900 format(' in init_sf_xy, jcap,s_ens_hv(',i5,1x,'-',i5,'), max diff(f0-f)=', & +! adjust so value at np = 1 + f=f/f(grd_sploc%nlat,1) + f0=f + call general_g2s0(grd_sploc,sp_loc,g,f) + call general_s2g0(grd_sploc,sp_loc,g,f) + if(mype == 0)then + nsigend=k + do kk=k+1,grd_sploc%nsig + if(s_ens_hv(kk,ig) /= s_ens_hv(k,ig))exit + nsigend=nsigend+1 + enddo + write(6,900)k,nsigend,sp_loc%jcap,s_ens_hv(k,ig),maxval(abs(f0-f)) +900 format(' in init_sf_xy, jcap,s_ens_hv(',i5,1x,'-',i5,'), max diff(f0-f)=', & i10,f10.2,e20.10) - end if + end if -! correct spectrum by dividing by pn0_npole - gsave=g +! correct spectrum by dividing by pn0_npole -! obtain pn0_npole - do n=0,sp_loc%jcap - g=zero - g(2*n+1)=one - call general_s2g0(grd_sploc,sp_loc,g,f) - pn0_npole(n)=f(grd_sploc%nlat,1) - enddo +! obtain pn0_npole +!$omp parallel do schedule(static,1) private(n,gtemp,f) + do n=0,sp_loc%jcap + gtemp=zero + gtemp(2*n+1)=one + call general_s2g0(grd_sploc,sp_loc,gtemp,f) + pn0_npole=f(grd_sploc%nlat,1) + g(2*n+1)=g(2*n+1)/pn0_npole + enddo - g=zero - do n=0,sp_loc%jcap - g(2*n+1)=gsave(2*n+1)/pn0_npole(n) - enddo -! obtain spectral_filter +! obtain spectral_filter - ii=0 - do l=0,sp_loc%jcap - if(ig>naensgrp) then - factor=one/g(1) + ii=0 + do l=0,sp_loc%jcap + if(ig>naensgrp) then + factor=one/g(1) + else + factor=one + if(l>0) factor=half + end if + do n=l,sp_loc%jcap + ii=ii+1 + if(sp_loc%factsml(ii)) then + spectral_filter(ig,ii,k)=zero else - factor=one - if(l>0) factor=half + spectral_filter(ig,ii,k)=factor*g(2*n+1) + end if + ii=ii+1 + if(l == 0 .or. sp_loc%factsml(ii)) then + spectral_filter(ig,ii,k)=zero + else + spectral_filter(ig,ii,k)=factor*g(2*n+1) end if - do n=l,sp_loc%jcap - ii=ii+1 - if(sp_loc%factsml(ii)) then - spectral_filter(ig,ii,k)=zero - else - spectral_filter(ig,ii,k)=factor*g(2*n+1) - end if - ii=ii+1 - if(l == 0 .or. sp_loc%factsml(ii)) then - spectral_filter(ig,ii,k)=zero - else - spectral_filter(ig,ii,k)=factor*g(2*n+1) - end if - enddo enddo - end if - enddo + enddo + enddo level_loop enddo !ig loop - deallocate(g,gsave,pn0_npole,ksame) + deallocate(g,gtemp) ! Compute sqrt(spectral_filter). Ensure spectral_filter >=0 zero -!$omp parallel do schedule(dynamic,1) private(k,i) +!$omp parallel do schedule(static,1) private(k,i) do ig=1,naensloc do k=1,grd_sploc%nsig do i=1,sp_loc%nc - if (spectral_filter(ig,i,k) < zero) spectral_filter(ig,i,k)=zero + spectral_filter(ig,i,k) = max(spectral_filter(ig,i,k),zero) sqrt_spectral_filter(ig,i,k) = sqrt(spectral_filter(ig,i,k)) end do end do @@ -3337,13 +3341,14 @@ subroutine sf_xy(ig,f,k_start,k_end) if(.not.use_localization_grid) then if(ig>naensgrp) then +!$omp parallel do schedule(static,1) private(k,g) do k=k_start,k_end call general_g2s0(grd_ens,sp_loc,g,f(:,:,k)) g(:)=g(:)*spectral_filter(ig,:,k_index(k)) call general_s2g0(grd_ens,sp_loc,g,f(:,:,k)) enddo else -!$omp parallel do schedule(dynamic,1) private(k) +!$omp parallel do schedule(static,1) private(k) do k=k_start,k_end call sfilter(grd_ens,sp_loc,spectral_filter(ig,:,k_index(k)),f(1,1,k)) enddo @@ -3353,6 +3358,7 @@ subroutine sf_xy(ig,f,k_start,k_end) vector=.false. if(ig>naensgrp) then +!$omp parallel do schedule(static,1) private(k,g,work) do k=k_start,k_end call g_agrid2egrid(p_sploc2ens,work,f(:,:,k:k),k,k,vector(k:k)) call general_g2s0(grd_ens,sp_loc,g,f(:,:,k)) @@ -3361,7 +3367,7 @@ subroutine sf_xy(ig,f,k_start,k_end) call g_egrid2agrid(p_sploc2ens,work,f(:,:,k:k),k,k,vector(k:k)) enddo else -!$omp parallel do schedule(dynamic,1) private(k,work) +!$omp parallel do schedule(static,1) private(k,work) do k=k_start,k_end call g_egrid2agrid_ad(p_sploc2ens,work,f(:,:,k:k),k,k,vector(k:k)) call sfilter(grd_ens,sp_loc,spectral_filter(ig,:,k_index(k)),f(1,1,k)) @@ -3421,6 +3427,7 @@ subroutine sqrt_sf_xy(ig,z,f,k_start,k_end) if(.not.use_localization_grid) then +!$omp parallel do schedule(static,1) private(k,g) do k=k_start,k_end g(:)=z(:,k)*sqrt_spectral_filter(ig,:,k_index(k)) call general_s2g0(grd_ens,sp_loc,g,f(:,:,k)) @@ -3429,6 +3436,7 @@ subroutine sqrt_sf_xy(ig,z,f,k_start,k_end) else vector=.false. +!$omp parallel do schedule(static,1) private(k,g,work) do k=k_start,k_end g(:)=z(:,k)*sqrt_spectral_filter(ig,:,k_index(k)) call general_s2g0(grd_sploc,sp_loc,g,work) @@ -3488,6 +3496,7 @@ subroutine sqrt_sf_xy_ad(ig,z,f,k_start,k_end) if(.not.use_localization_grid) then +!$omp parallel do schedule(static,1) private(k,g) do k=k_start,k_end call general_s2g0_ad(grd_ens,sp_loc,g,f(:,:,k)) z(:,k)=g(:)*sqrt_spectral_filter(ig,:,k_index(k)) @@ -3496,6 +3505,7 @@ subroutine sqrt_sf_xy_ad(ig,z,f,k_start,k_end) else vector=.false. +!$omp parallel do schedule(static,1) private(k,g,work) do k=k_start,k_end call g_egrid2agrid_ad(p_sploc2ens,work,f(:,:,k:k),k,k,vector(k:k)) call general_s2g0_ad(grd_sploc,sp_loc,g,work) @@ -3608,7 +3618,7 @@ subroutine bkerror_a_en(grady) ! Declare local variables integer(i_kind) ii,ip,istatus,k,ig,ig2 real(r_kind),allocatable,dimension(:,:) :: z - real(r_kind),allocatable,dimension(:) :: ztmp + real(r_kind),allocatable,dimension(:) :: z2 ! Initialize timer call timer_ini('bkerror_a_en') @@ -3624,34 +3634,29 @@ subroutine bkerror_a_en(grady) call sqrt_beta_e_mult(grady) ! Apply variances, as well as vertical & horizontal parts of background error -! !$omp parallel do schedule(dynamic,1) private(ii) - do ii=1,nsubwin - if (naensgrp==1) then + if (naensgrp==1) then + do ii=1,nsubwin call bkgcov_a_en_new_factorization(1,grady%aens(ii,1,1:n_ens)) - else - allocate(z(naensgrp,nval_lenz_en)) + end do + else + allocate(z(nval_lenz_en,naensgrp)) + allocate(z2(nval_lenz_en)) + do ii=1,nsubwin do ig=1,naensgrp - call ckgcov_a_en_new_factorization_ad(ig,z(ig,:),grady%aens(ii,ig,1:n_ens)) + call ckgcov_a_en_new_factorization_ad(ig,z(1,ig),grady%aens(ii,ig,1:n_ens)) enddo - allocate(ztmp(naensgrp)) - do k=1,nval_lenz_en - ztmp=zero - do ig=1,naensgrp - do ig2=1,naensgrp - ztmp(ig) = ztmp(ig) + z(ig2,k) * alphacvarsclgrpmat(ig,ig2) + do ig=1,naensgrp + z2=zero + do ig2=1,naensgrp + do k=1,nval_lenz_en + z2(k) = z2(k) + z(k,ig2) * alphacvarsclgrpmat(ig,ig2) enddo enddo - do ig=1,naensgrp - z(ig,k) = ztmp(ig) - enddo - enddo - deallocate(ztmp) - do ig=1,naensgrp - call ckgcov_a_en_new_factorization(ig,z(ig,:),grady%aens(ii,ig,1:n_ens)) + call ckgcov_a_en_new_factorization(ig,z2,grady%aens(ii,ig,1:n_ens)) enddo - deallocate(z) - endif - enddo + enddo + deallocate(z,z2) + endif ! multiply by sqrt_beta_e_mult call sqrt_beta_e_mult(grady) @@ -3710,11 +3715,7 @@ subroutine bkgcov_a_en_new_factorization(ig,a_en) real(r_kind) hwork(grd_loc%inner_vars,grd_loc%nlat,grd_loc%nlon,grd_loc%kbegin_loc:grd_loc%kend_alloc) real(r_kind),allocatable,dimension(:):: a_en_work - call gsi_bundlegetpointer(a_en(1),'a_en',ipnt,istatus) - if(istatus/=0) then - write(6,*)'bkgcov_a_en_new_factorization: trouble getting pointer to ensemble CV' - call stop2(999) - endif + ipnt=1 ! Apply vertical smoother on each ensemble member ! To avoid my having to touch the general sub2grid and grid2sub, @@ -3725,7 +3726,7 @@ subroutine bkgcov_a_en_new_factorization(ig,a_en) call stop2(999) endif iadvance=1 ; iback=2 -!$omp parallel do schedule(dynamic,1) private(k,ii,is,ie) +!$omp parallel do schedule(static,1) private(k,ii,is,ie) do k=1,n_ens call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) ii=(k-1)*a_en(1)%ndim @@ -3755,7 +3756,7 @@ subroutine bkgcov_a_en_new_factorization(ig,a_en) ! Retrieve ensemble components from long vector ! Apply vertical smoother on each ensemble member iadvance=2 ; iback=1 -!$omp parallel do schedule(dynamic,1) private(k,ii,is,ie) +!$omp parallel do schedule(static,1) private(k,ii,is,ie) do k=1,n_ens ii=(k-1)*a_en(1)%ndim is=ii+1 @@ -3865,9 +3866,10 @@ subroutine ckgcov_a_en_new_factorization(ig,z,a_en) deallocate(a_en_work) ! Apply vertical smoother on each ensemble member + iadvance=2 ; iback=1 +!$omp parallel do schedule(static,1) private(k) do k=1,n_ens - iadvance=2 ; iback=1 call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) enddo @@ -3937,9 +3939,10 @@ subroutine ckgcov_a_en_new_factorization_ad(ig,z,a_en) endif ! Apply vertical smoother on each ensemble member + iadvance=1 ; iback=2 +!$omp parallel do schedule(static,1) private(k) do k=1,n_ens - iadvance=1 ; iback=2 call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) enddo @@ -4125,7 +4128,7 @@ subroutine hybens_grid_setup end if if(global_spectral_filter_sd .and. nsclgrp > 1)then - allocate(spc_multwgt(0:jcap_ens,nsclgrp)) + allocate(spc_multwgt(sp_ens%nc,nsclgrp)) allocate(spcwgt_params(4,nsclgrp)) spc_multwgt=1.0 diff --git a/src/gsi/read_iasi.f90 b/src/gsi/read_iasi.f90 index 038188f92a..4e688cd36e 100644 --- a/src/gsi/read_iasi.f90 +++ b/src/gsi/read_iasi.f90 @@ -829,7 +829,11 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& ! Prevent out of bounds reference from temperature if ( bufr_index(l) == 0 ) cycle i = bufr_index(l) - data_all(l+nreal,itx) = temperature(i) ! brightness temerature + if(i /= 0)then + data_all(l+nreal,itx) = temperature(i) ! brightness temerature + else + data_all(l+nreal,itx) = tbmin + end if end do nrec(itx)=irec diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index b72e584155..9efd06418c 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -2050,9 +2050,9 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if(oelev>7000.0_r_kind) cycle loop_k_levs if(abs(diffvv)>5.0_r_kind.and.oelev<5000.0_r_kind) cycle loop_k_levs ! write(6,*)'sliu diffuu,vv::',diffuu, diffvv - uob=0.0 - vob=0.0 - oelev=0.0 + uob=zero + vob=zero + oelev=zero tkk=0 do ikkk=k,klev diffhgt=obsdat(4,ikkk)-obsdat(4,k) diff --git a/src/gsi/setupcldtot.F90 b/src/gsi/setupcldtot.F90 index a30ef92a90..694c8f1df3 100755 --- a/src/gsi/setupcldtot.F90 +++ b/src/gsi/setupcldtot.F90 @@ -45,13 +45,22 @@ subroutine setupcldtot(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_di use mpeu_util, only: die,perr use kinds, only: r_kind,r_single,r_double,i_kind + use constants, only: zero,one,r1000,r10,r100 + use constants, only: huge_single,wgtlim,three + use constants, only: tiny_r_kind,five,half,two,r0_01 + use constants, only: zero,one, h1000 + use obsmod, only: rmiss_single,time_offset + use obsmod, only: netcdf_diag, binary_diag, dirname, ianldate + use obsmod, only: luse_obsdiag + use m_obsLList, only: obsLList + use m_obsdiagNode, only: obs_diags use m_obsNode, only: obsNode use m_qNode, only: qNode use m_qNode, only: qNode_appendto + use m_dtime, only: dtime_setup, dtime_check, dtime_show use gsi_4dvar, only: nobs_bins,hr_obsbin - use obsmod, only: netcdf_diag, binary_diag, dirname, ianldate use nc_diag_write_mod,only: nc_diag_init, nc_diag_header,nc_diag_metadata, & nc_diag_write, nc_diag_data2d use nc_diag_read_mod, only: nc_diag_read_init,nc_diag_read_get_dim, & @@ -60,26 +69,18 @@ subroutine setupcldtot(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_di use guess_grids, only: geop_hgtl,hrdifsig,nfldsig,ges_tsen,ges_prsl use gridmod, only: nsig,get_ijk - use constants, only: zero,one,r1000,r10,r100 - use constants, only: huge_single,wgtlim,three - use constants, only: tiny_r_kind,five,half,two,r0_01 use qcmod, only: npres_print use jfunc, only: jiter use convinfo, only: nconvtype use convinfo, only: icsubtype - use m_dtime, only: dtime_setup, dtime_check, dtime_show use rapidrefresh_cldsurf_mod, only: i_cloud_q_innovation, & cld_bld_hgt,i_ens_mean use gsi_bundlemod, only : gsi_bundlegetpointer use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle use mpimod, only: mpi_comm_world - use constants, only: zero,one, h1000 use gsdcloudlib_pseudoq_mod, only: cloudLWC_pseudo,cloudCover_Surface_col - use m_obsLList, only: obsLList - use m_obsdiagNode, only: obs_diags - use obsmod, only: luse_obsdiag implicit none diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 index ebdd8de52a..f686e19332 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -776,6 +776,12 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& call stop2(275) end if + if (abi2km .and. regional) then + abi2km_bc = zero + abi2km_bc(2) = 233.5_r_kind + abi2km_bc(3) = 241.7_r_kind + abi2km_bc(4) = 250.5_r_kind + end if ! PROCESSING OF SATELLITE DATA ! Loop over data in this block @@ -1085,10 +1091,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif predbias=zero - abi2km_bc = zero - abi2km_bc(2) = 233.5_r_kind - abi2km_bc(3) = 241.7_r_kind - abi2km_bc(4) = 250.5_r_kind !$omp parallel do schedule(dynamic,1) private(i,mm,j,k,tlap,node,bias) do i=1,nchanl mm=ich(i) diff --git a/src/gsi/stpcalc.f90 b/src/gsi/stpcalc.f90 index dd60703ce2..849d2ff5c9 100644 --- a/src/gsi/stpcalc.f90 +++ b/src/gsi/stpcalc.f90 @@ -263,7 +263,7 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & real(r_quad),parameter:: one_tenth_quad = 0.1_r_quad ! Declare local variables - integer(i_kind) i,j,mm1,ii,iis,final_ii,ibin,ipenloc,it + integer(i_kind) i,j,mm1,ii,final_ii,ibin,ipenloc,it integer(i_kind) istp_use,nstep,nsteptot,kprt real(r_quad),dimension(4,ipen):: pbc real(r_quad),dimension(4,nobs_type):: pbcjo @@ -430,7 +430,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & pbc=zero_quad pjcalc=.false. if(iter == 0 .and. kprt >= 2 .and. ii == 1)pjcalc=.true. - iis=ii ! Delta stepsize sges(1)= stp(ii-1) From ca19008b521cccf07a84037cfece3847232025cc Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Mon, 25 Sep 2023 16:12:33 -0400 Subject: [PATCH 030/109] Intel 2022 updates (#629) **Description** This PR fixes two types of bugs discovered when cycling `gsi.x` and `enkf.x` with intel/2022 in the global workflow 1. modify variables written to netcdf diagnostic files by `gsi.x` to be consistent with codes which read netcdf diagnostic files 2. modify `lrun_subdirs=.true.` option of `gsi.x` to properly handle the case in which sub-directories already exist in the run directory Fixes #623 **Type of change** - [x] Bug fix (non-breaking change which fixes an issue) **How Has This Been Tested?** Ctests have been on Hera, Orion, and WCOSS2 (Cactus) with acceptable behavior. A global parallel covering the period 2021073106 through 2021080118 has been run on Hera, Orion, and WCOSS2 (Cactus). All global workflow jobs ran as expected. **Checklist** - [x] My code follows the style guidelines of this project - [x] I have performed a self-review of my own code - [x] New and existing tests pass with my changes --- src/gsi/obsmod.F90 | 17 +++++++++++------ src/gsi/setupaod.f90 | 2 +- src/gsi/setupoz.f90 | 5 +++-- src/gsi/setuprad.f90 | 2 +- 4 files changed, 16 insertions(+), 10 deletions(-) diff --git a/src/gsi/obsmod.F90 b/src/gsi/obsmod.F90 index 26f8ff1bbf..633bde91ab 100644 --- a/src/gsi/obsmod.F90 +++ b/src/gsi/obsmod.F90 @@ -1022,12 +1022,12 @@ subroutine init_directories(in_pe,num_pe) integer(i_kind),intent(in ) :: in_pe integer(i_kind),intent(in ) :: num_pe - logical :: l_mkdir_stat + logical :: l_mkdir_stat, l_dir_exist character(len=144):: command character(len=8):: pe_name, loc_pe_name character(len=128):: loc_dirname - integer(i_kind) :: i + integer(i_kind) :: i, ierror if (lrun_subdirs) then write(pe_name,'(i4.4)') in_pe @@ -1038,10 +1038,15 @@ subroutine init_directories(in_pe,num_pe) write(loc_pe_name,'(i4.4)') i loc_dirname = 'dir.'//trim(loc_pe_name) #ifdef __INTEL_COMPILER - l_mkdir_stat = MAKEDIRQQ(trim(loc_dirname)) - if(.not. l_mkdir_stat) then - write(6, *) "Failed to create directory ", trim(loc_dirname), " for PE ", loc_pe_name - call stop2(678) + INQUIRE(directory=trim(loc_dirname), exist=l_dir_exist) + if (.not.l_dir_exist) then + l_mkdir_stat = MAKEDIRQQ(trim(loc_dirname)) + if(.not.l_mkdir_stat) then + ierror=GETLASTERRORQQ() + write(6, *) "INIT_DIRECTORIES: ***ERROR** Failed to create directory ", & + trim(loc_dirname)," for PE ", loc_pe_name, ' ierror= ', ierror + call stop2(678) + endif endif #else command = 'mkdir -p -m 755 ' // trim(loc_dirname) diff --git a/src/gsi/setupaod.f90 b/src/gsi/setupaod.f90 index 5fe4233ada..58707acd6a 100644 --- a/src/gsi/setupaod.f90 +++ b/src/gsi/setupaod.f90 @@ -844,7 +844,7 @@ subroutine contents_netcdf_diag_ call nc_diag_metadata("Observation_Class", obsclass) call nc_diag_metadata_to_single("Latitude",(cenlat)) ! observation latitude (degrees) call nc_diag_metadata_to_single("Longitude",(cenlon)) ! observation longitude (degrees) - call nc_diag_metadata_to_single("Obs_Time",(dtime))!-time_offset)) ! observation time (hours relative to analysis time) + call nc_diag_metadata_to_single("Time",(dtime))!-time_offset)) ! observation time (hours relative to analysis time) call nc_diag_metadata_to_single("Sol_Zenith_Angle",(pangs)) ! solar zenith angle (degrees) call nc_diag_metadata_to_single("Sol_Azimuth_Angle",(data_s(isazi_ang,n))) ! solar azimuth angle (degrees) call nc_diag_metadata("Surface_type", nint(data_s(istyp,n))) diff --git a/src/gsi/setupoz.f90 b/src/gsi/setupoz.f90 index d7a85de0b2..7112e967ba 100644 --- a/src/gsi/setupoz.f90 +++ b/src/gsi/setupoz.f90 @@ -1720,6 +1720,7 @@ subroutine contents_netcdf_diag_(odiag) type(obs_diag),pointer,intent(in):: odiag ! Observation class character(7),parameter :: obsclass = ' ozlev' + integer(i_kind),parameter :: ione = 1 real(r_kind),dimension(miter) :: obsdiag_iuse call nc_diag_metadata_to_single("Latitude", data(ilate,i) ) call nc_diag_metadata_to_single("Longitude", data(ilone,i) ) @@ -1731,9 +1732,9 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",ozone_inv ) call nc_diag_metadata_to_single("Reference_Pressure", preso3l*r100 ) ! Pa if(luse(i)) then - call nc_diag_metadata_to_single("Analysis_Use_Flag", one ) + call nc_diag_metadata("Analysis_Use_Flag", ione ) else - call nc_diag_metadata_to_single("Analysis_Use_Flag", -one ) + call nc_diag_metadata("Analysis_Use_Flag", -ione ) endif call nc_diag_metadata_to_single("Input_Observation_Error",obserror ) diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 index f686e19332..20ab63456e 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -2577,7 +2577,7 @@ subroutine contents_netcdf_diag_(odiags,idv,iob) call nc_diag_metadata_to_single("Elevation",zsges ) ! model (guess) elevation at observation location - call nc_diag_metadata_to_single("Time",dtime,time_offset,'-') + call nc_diag_metadata_to_single("Obs_Time",dtime,time_offset,'-') call nc_diag_metadata_to_single("Scan_Position",data_s(iscan_pos,n) ) ! sensor scan position call nc_diag_metadata_to_single("Sat_Zenith_Angle", zasat,rad2deg,'*') ! satellite zenith angle (degrees) From 728d006c36ae6b17f08b380ff23b3422b97624fe Mon Sep 17 00:00:00 2001 From: Gang <53267411+GangZhao-NOAA@users.noreply.github.com> Date: Fri, 29 Sep 2023 09:11:39 -0400 Subject: [PATCH 031/109] Adding code to analyze the siginificant wave heigh in GSI 3D Analysis (see issue #601) (#614) Adding code to analyze the siginificant wave heigh in GSI 3D Analysis, esp. for FV3-LAM model based DA, eg. RRFS-DA, RRFS-3DRTMA. (Also see the issue in EMC GSI github repository: #601 Adding I/O for Analysis of Significant Wave Height for 3DRTMA) **Description** Significant Wave Height (hereafter as SWH) is one of the standard products provided by the operational (2D)RTMA. To continuously provide the same products in 3DRTMA, the next-generation RTMA, some efforts in GSI code need to be made in order to analyze the SWH in 3D analysis of GSI. The kernel subroutines to assimilate SWH in GSI (such as stphowv.f90, setuphowv.f90, inthowv.f90, gsi_howvOper.f90 and m_howvNode.f90) already had been added for (2D)RTMA years ago by Manuel Pondeca, so for this issue, the code work mainly focus on adding the I/O of SWH in background and analysis fields for 3DRTMA (esp. RRFS-based 3DRTMA), and some necessary modifications in background error, options, variables related to analysis of SWH, etc. Modified code in GSI: 1. rapidrefresh_cldsurf_mod.f90: adding a few variables related to the analysis of howv in 3D analysis 2. gsimod.F90: adding namelist options used for analysis of howv in 3D analysis 3. m_berror_stats_reg.f90: added some code for the special treatment to the static background error (BE) of howv 4. read_prepbufr.f90: adding code to decode the observation of howv in prepbufr file when howv is available in firstguess 5. setuphowv.f90: adding code to use obs of howv when howv is available in firstguess 6. gsi_rfv3io_mod.f90: adding I/O code to read in howv from firstguess and write out howv into analysis. No dependencies are required for this change. This PR is addressing the issue [#601](https://github.com/NOAA-EMC/GSI/issues/601): Adding code to analyze the siginificant wave heigh in GSI 3D Analysis". Fixes #601 **Type of change** Please delete options that are not relevant. - [*] New feature (non-breaking change which adds functionality) **How Has This Been Tested?** - Brief results from ctest (regression test) with the modified code (on WCOSS2 - Cactus): [gang.zhao@clogin07:build] (feature/3drtma_howv)$ ctest -N Test project /lfs/h2/emc/da/save/gang.zhao/WorkDir/WaveHgt/develop/build Test #1: global_3dvar Test #2: global_4dvar Test #3: global_4denvar Test #4: hwrf_nmm_d2 Test #5: hwrf_nmm_d3 Test #6: rtma Test #7: rrfs_3denvar_glbens Test #8: netcdf_fv3_regional Test #9: global_enkf Total Tests: 9 Test #1: global_3dvar [gang.zhao@clogin04:build] (feature/3drtma_howv)$ ctest -R global_3dvar Test project /lfs/h2/emc/da/save/gang.zhao/WorkDir/WaveHgt/develop/build Start 1: global_3dvar 1/1 Test #1: global_3dvar ..................... Passed 1631.12 sec 100% tests passed, 0 tests failed out of 1 Total Test time (real) = 1631.14 sec Test #2: global_4dvar [gang.zhao@clogin09:build] (feature/3drtma_howv)$ ctest -R global_4dvar Test project /lfs/h2/emc/da/save/gang.zhao/WorkDir/WaveHgt/develop/build Start 2: global_4dvar 1/1 Test #2: global_4dvar ..................... Passed 2462.19 sec 100% tests passed, 0 tests failed out of 1 Total Test time (real) = 2462.23 sec Test #3: global_4denvar [gang.zhao@clogin04:build] (feature/3drtma_howv)$ ctest -R global_4denvar Test project /lfs/h2/emc/da/save/gang.zhao/WorkDir/WaveHgt/develop/build Start 3: global_4denvar 1/1 Test #3: global_4denvar ................... Passed 1922.43 sec 100% tests passed, 0 tests failed out of 1 Total Test time (real) = 1922.46 sec Test #4: hwrf_nmm_d2 [gang.zhao@clogin09:build] (feature/3drtma_howv)$ ctest -R hwrf_nmm_d2 Test project /lfs/h2/emc/da/save/gang.zhao/WorkDir/WaveHgt/develop/build Start 4: hwrf_nmm_d2 1/1 Test #4: hwrf_nmm_d2 ...................... Passed 1214.10 sec 100% tests passed, 0 tests failed out of 1 Total Test time (real) = 1214.20 sec Test #5: hwrf_nmm_d3 [gang.zhao@clogin09:build] (feature/3drtma_howv)$ ctest -R hwrf_nmm_d3 Test project /lfs/h2/emc/da/save/gang.zhao/WorkDir/WaveHgt/develop/build Start 5: hwrf_nmm_d3 1/1 Test #5: hwrf_nmm_d3 ...................... Passed 736.38 sec 100% tests passed, 0 tests failed out of 1 Total Test time (real) = 736.50 sec Test #6: rtma [gang.zhao@clogin05:build] (feature/3drtma_howv)$ ctest -R rtma Test project /lfs/h2/emc/da/save/gang.zhao/WorkDir/WaveHgt/develop/build Start 6: rtma 1/1 Test #6: rtma ............................. Passed 1027.01 sec 100% tests passed, 0 tests failed out of 1 Total Test time (real) = 1027.01 sec Test #7: rrfs_3denvar_glbens [gang.zhao@clogin06:build] (feature/3drtma_howv)$ ctest -R rrfs_3denvar_glbens Test project /lfs/h2/emc/da/save/gang.zhao/WorkDir/WaveHgt/develop/build Start 7: rrfs_3denvar_glbens 1/1 Test #7: rrfs_3denvar_glbens .............. Passed 484.69 sec 100% tests passed, 0 tests failed out of 1 Total Test time (real) = 484.70 sec Test #8: netcdf_fv3_regional [gang.zhao@clogin03:build] (feature/3drtma_howv)$ ctest -R netcdf_fv3_regional Test project /lfs/h2/emc/da/save/gang.zhao/WorkDir/WaveHgt/develop/build Start 8: netcdf_fv3_regional 1/1 Test #8: netcdf_fv3_regional .............. Passed 483.08 sec 100% tests passed, 0 tests failed out of 1 Total Test time (real) = 483.11 sec Test #9: global_enkf [gang.zhao@clogin03:build] (feature/3drtma_howv)$ ctest -R global_enkf Test project /lfs/h2/emc/da/save/gang.zhao/WorkDir/WaveHgt/develop/build Start 9: global_enkf 1/1 Test #9: global_enkf ...................... Passed 488.50 sec 100% tests passed, 0 tests failed out of 1 Total Test time (real) = 488.57 sec - The modified GSI code passed the regression tests (all 9 tasks) on Hera and WCOSS2 (Cactus). - adding the analysis of howv only has very trial influences on the analyses of other variables. Here is the statistics of the differences of other variables (u/v/t/ps/q/t2m/q2m) from the runs of GSI without howv vs. with howv (from a testing case 2023-07-12_14:00:00 UTC in 3km North-American domain): comparing two netcdf files: fcst_fv3lam_hyb_betas/INPUT/fv_core.res.tile1.nc fcst_fv3lam_nodata_noinfo/INPUT/fv_core.res.tile1.nc ... Variable Group Count Sum AbsSum Min Max Range Mean StdDev u / 602135550 3926.84 25760.8 -0.1026 0.485788 0.588388 6.52152e-06 0.00115817 v / 620166777 -4891.34 32582.5 -0.835774 0.268402 1.10418 -7.88714e-06 0.00197793 T / 155987083 178.048 6497.51 -0.0246582 0.0384064 0.0630646 1.14143e-06 0.000218737 delp / 19559676 -281.532 3008.29 -0.00292969 0.00219727 0.00512695 -1.43935e-05 0.000183727 comparing two netcdf files: fcst_fv3lam_hyb_betas/INPUT/fv_tracer.res.tile1.nc fcst_fv3lam_nodata_noinfo/INPUT/fv_tracer.res.tile1.nc ... Variable Group Count Sum AbsSum Min Max Range Mean StdDev sphum / 430707614 0.594287 2.77816 -2.6139e-05 3.1759e-05 5.7898e-05 1.37979e-09 8.03072e-08 comparing two netcdf files: fcst_fv3lam_hyb_betas/INPUT/sfc_data.nc fcst_fv3lam_nodata_noinfo/INPUT/sfc_data.nc ... Variable Group Count Sum AbsSum Min Max Range Mean StdDev t2m / 10665000 43.3899 135.095 -0.00152825 0.00686629 0.00839454 4.06844e-06 5.02866e-05 q2m / 10665000 0.0192553 0.124707 -3.1476e-06 1.77554e-05 2.0903e-05 1.80547e-09 5.89657e-08 It could be seen that the differences are trivial and ignorable. The regression tests were done by following the instructions of "[GSI Ctests (regression tests)](https://github.com/NOAA-EMC/GSI/wiki/GSI-Ctests-(regression-tests))" in [GSI Wiki](https://github.com/NOAA-EMC/GSI/wiki) The modified code had also been tested with a testing case 2023-07-12_14:00:00 UTC for 3km North-American domain Here is a brief summary of the test results: 1. Here is the analysis increment of Significant Wave Height (aka howv hereafter): pure 3dvar, static background error of howv is 0.42 meters, and the de-correlation length scale is 170km. ![HOWV_var_inc_maprll_datll_reg_ncf](https://github.com/NOAA-EMC/GSI/assets/53267411/4fdeeb82-7258-4344-be69-cce747474312) 2. The following figure shows the distribution of howv in the analysis (used obs is in green, rejected in red). Obviously the location of used obs of howv match the area of non-zero analysis increments of howv. ![var_obs_2023071214_howv_maprll_datll_reg_ncf](https://github.com/NOAA-EMC/GSI/assets/53267411/d4ed6013-cfc8-486e-8f47-db07ec0e4e53) 3. The following figure is the analysis increment of howv with hybrid envar analysis (using gdas ensemble 80 members and the ensemble weight is 84%), and the static BE of howv is tuned/inflated. The analysis increments are very similar to the results from pure 3dvar run (see the first figure) ![HOWV_hyb_betas016_inc_maprll_datll_reg_ncf](https://github.com/NOAA-EMC/GSI/assets/53267411/e6e696e8-932b-42ab-9001-3472e970b21c) 4. The last figure shows the analysis increments of howv with hybrid envar analysis (using gdas ensemble 80 members and the ensemble weight is 84%), but the static BE of howv is NOT tuned. It can be observed that the analysis increments is less than the results from the hybrid run with tuning the static BE of howv. That is because the weight of static BE (16%) reduced the background error of howv (ensemble of howv is not available yet), so the impact of obs is decreased. ![HOWV_hyb_betas016_noTune_inc_maprll_datll_reg_ncf](https://github.com/NOAA-EMC/GSI/assets/53267411/ca25d068-fc86-4d47-a9d2-46e02ac22dac) **Checklist** - [*] My code follows the style guidelines of this project - [*] I have performed a self-review of my own code - [*] I have commented my code, particularly in hard-to-understand areas - [*] New and existing tests pass with my changes - [*] Any dependent changes have been merged and published **DUE DATE for this PR is 10/5/2023.** If this PR is not merged into `develop` by this date, the PR will be closed and returned to the developer. --- src/gsi/gsi_rfv3io_mod.f90 | 78 +++++++++++++++++++++++++--- src/gsi/gsimod.F90 | 13 ++++- src/gsi/m_berror_stats_reg.f90 | 41 +++++++++++---- src/gsi/rapidrefresh_cldsurf_mod.f90 | 41 ++++++++++++++- src/gsi/read_prepbufr.f90 | 7 +++ 5 files changed, 160 insertions(+), 20 deletions(-) diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 62b23ee713..6d16be7c13 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -22,6 +22,8 @@ module gsi_rfv3io_mod ! used as background for surface observation operator ! 2022-04-15 Wang - add IO for regional FV3-CMAQ (RRFS-CMAQ) model ! 2022-08-10 Wang - add IO for regional FV3-SMOKE (RRFS-SMOKE) model +! 2023-07-30 Zhao - add IO for the analysis of the significant wave height +! (SWH, aka howv in GSI) in fv3-lam based DA (eg., RRFS-3DRTMA) ! ! subroutines included: ! sub gsi_rfv3io_get_grid_specs @@ -56,6 +58,7 @@ module gsi_rfv3io_mod use rapidrefresh_cldsurf_mod, only: i_use_2mq4b,i_use_2mt4b use chemmod, only: naero_cmaq_fv3,aeronames_cmaq_fv3,imodes_cmaq_fv3,laeroana_fv3cmaq use chemmod, only: naero_smoke_fv3,aeronames_smoke_fv3,laeroana_fv3smoke + use rapidrefresh_cldsurf_mod, only: i_howv_3dda implicit none public type_fv3regfilenameg @@ -133,7 +136,7 @@ module gsi_rfv3io_mod public :: mype_u,mype_v,mype_t,mype_q,mype_p,mype_oz,mype_ql public :: mype_qi,mype_qr,mype_qs,mype_qg,mype_qnr,mype_w public :: k_slmsk,k_tsea,k_vfrac,k_vtype,k_stype,k_zorl,k_smc,k_stc - public :: k_snwdph,k_f10m,mype_2d,n2d,k_orog,k_psfc,k_t2m,k_q2m + public :: k_snwdph,k_f10m,mype_2d,n2d,k_orog,k_psfc,k_t2m,k_q2m,k_howv public :: ijns,ijns2d,displss,displss2d,ijnz,displsz_g public :: fv3lam_io_dynmetvars3d_nouv,fv3lam_io_tracermetvars3d_nouv public :: fv3lam_io_tracerchemvars3d_nouv,fv3lam_io_tracersmokevars3d_nouv @@ -144,7 +147,7 @@ module gsi_rfv3io_mod integer(i_kind) mype_qi,mype_qr,mype_qs,mype_qg,mype_qnr,mype_w integer(i_kind) k_slmsk,k_tsea,k_vfrac,k_vtype,k_stype,k_zorl,k_smc,k_stc - integer(i_kind) k_snwdph,k_f10m,mype_2d,n2d,k_orog,k_psfc,k_t2m,k_q2m + integer(i_kind) k_snwdph,k_f10m,mype_2d,n2d,k_orog,k_psfc,k_t2m,k_q2m,k_howv parameter( & k_f10m =1, & !fact10 k_stype=2, & !soil_type @@ -159,7 +162,8 @@ module gsi_rfv3io_mod k_t2m =11, & ! 2 m T k_q2m =12, & ! 2 m Q k_orog =13, & !terrain - n2d=13 ) + k_howv =14, & ! significant wave height (aka howv in GSI) + n2d=14 ) logical :: grid_reverse_flag character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_io_dynmetvars3d_nouv ! copy of cvars3d excluding uv 3-d fields @@ -767,6 +771,8 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) ! 2022-04-01 Y. Wang and X. Wang - add capability to read reflectivity ! for direct radar EnVar DA using reflectivity as state ! variable, poc: xuguang.wang@ou.edu +! 2023-07-30 Zhao - added code to read significant wave height (howv) field +! from the 2D fv3-lam firstguess file (fv3_sfcdata). ! attributes: ! language: f90 ! machine: ibm RS/6000 SP @@ -816,6 +822,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) real(r_kind),pointer,dimension(:,:,:):: ges_delp =>NULL() real(r_kind),dimension(:,:),pointer::ges_t2m=>NULL() real(r_kind),dimension(:,:),pointer::ges_q2m=>NULL() + real(r_kind),dimension(:,:),pointer::ges_howv=>NULL() real(r_kind),dimension(:,:,:),pointer::ges_ql=>NULL() real(r_kind),dimension(:,:,:),pointer::ges_qi=>NULL() @@ -1093,6 +1100,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) if(mype == 0) write(6,*)'the metvarname ',trim(vartem),' will be dealt separately' else if(trim(vartem)=='t2m') then else if(trim(vartem)=='q2m') then + else if(trim(vartem)=='howv') then else write(6,*)'the metvarname2 ',trim(vartem),' has not been considered yet, stop' call stop2(333) @@ -1110,7 +1118,8 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) do i=1,size(name_metvars2d) vartem=trim(name_metvars2d(i)) if(.not.( (trim(vartem)=='ps'.and.fv3sar_bg_opt==0).or.(trim(vartem)=="z") & - .or.(trim(vartem)=="t2m").or.(trim(vartem)=="q2m"))) then !z is treated separately + .or.(trim(vartem)=="t2m").or.(trim(vartem)=="q2m") & + .or.(trim(vartem)=="howv"))) then ! z is treated separately if (ifindstrloc(vardynvars,trim(vartem)) > 0) then jdynvar=jdynvar+1 fv3lam_io_dynmetvars2d_nouv(jdynvar)=trim(vartem) @@ -1365,6 +1374,13 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it),'t2m',ges_t2m,istatus );ier=ier+istatus if (ier/=0) call die(trim(myname),'cannot get pointers for t2m,ier=',ier) endif + +!--- significant wave height (howv) + if ( i_howv_3dda == 1 ) then + call GSI_BundleGetPointer(GSI_MetGuess_Bundle(it),'howv',ges_howv,istatus ); ier=ier+istatus + if (ier/=0) call die(trim(myname),'cannot get pointers for howv, ier=',ier) + endif + if(mype == 0 ) then call check(nf90_open(fv3filenamegin(it)%dynvars,nf90_nowrite,loc_id)) call check(nf90_inquire(loc_id,formatNum=ncfmt)) @@ -1546,7 +1562,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) endif - call gsi_fv3ncdf2d_read(fv3filenamegin(it),it,ges_z,ges_t2m,ges_q2m) + call gsi_fv3ncdf2d_read(fv3filenamegin(it),it,ges_z,ges_t2m,ges_q2m,ges_howv) if(i_use_2mq4b > 0 .and. i_use_2mt4b > 0 ) then ! Convert 2m guess mixing ratio to specific humidity @@ -1782,7 +1798,7 @@ end subroutine gsi_bundlegetpointer_fv3lam_tracerchem_nouv end subroutine read_fv3_netcdf_guess -subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) +subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) !$$$ subprogram documentation block ! . . . . ! subprogram: gsi_fv3ncdf2d_read @@ -1792,6 +1808,8 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) ! Scatter the field to each PE ! program history log: ! 2023-02-14 Hu - Bug fix for read in subdomain surface restart files +! 2023-07-30 Zhao - added IO to read significant wave height (howv) from 2D FV3-LAM +! firstguess file (fv3_sfcdata) ! ! input argument list: ! it - time index for 2d fields @@ -1805,7 +1823,8 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) ! !$$$ end documentation block use kinds, only: r_kind,i_kind - use mpimod, only: ierror,mpi_comm_world,npe,mpi_rtype,mype + use mpimod, only: ierror,mpi_comm_world,npe,mpi_rtype,mype,mpi_itype + use mpeu_util, only: die use guess_grids, only: fact10,soil_type,veg_frac,veg_type,sfc_rough, & sfct,sno,soil_temp,soil_moi,isli use gridmod, only: lat2,lon2,itotsub,ijn_s @@ -1813,8 +1832,11 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension use netcdf, only: nf90_inquire_variable + use netcdf, only: nf90_inq_varid + use netcdf, only: nf90_noerr use mod_fv3_lola, only: fv3_h_to_ll,nxa,nya use constants, only: grav + use constants, only: zero implicit none @@ -1822,6 +1844,7 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) 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 @@ -1835,6 +1858,9 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) integer(i_kind) kk,n,ns,j,ii,jj,mm1 character(len=:),allocatable :: sfcdata !='fv3_sfcdata' character(len=:),allocatable :: dynvars !='fv3_dynvars' +! for checking the existence of howv in firstguess file + integer(i_kind) id_howv + integer(i_kind) iret_bcast ! for io_layout > 1 real(r_kind),allocatable,dimension(:,:):: sfc_fulldomain @@ -1850,6 +1876,9 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) allocate(work(itotsub*n2d)) allocate( sfcn2d(lat2,lon2,n2d)) +!-- initialisation of the array for howv + sfcn2d(:,:,k_howv) = zero + if(mype==mype_2d ) then allocate(sfc_fulldomain(nx,ny)) @@ -1877,6 +1906,24 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) iret=nf90_inquire_dimension(gfile_loc,k,name,len) dim(k)=len enddo + +!--- check the existence of significant wave height (howv) in 2D FV3-LAM firstguess file +! if howv is set in anavinfo (as i_howv_3dda=1), then check its existence in firstguess, +! but if it is not found in firstguess, then stop GSI run and set i_howv_3dda = 0. + if ( i_howv_3dda == 1 ) then + iret = nf90_inq_varid(gfile_loc,'howv',id_howv) + if ( iret /= nf90_noerr ) then + iret = nf90_inq_varid(gfile_loc,'HOWV',id_howv) ! double check with name in uppercase + end if + if ( iret /= nf90_noerr ) then + i_howv_3dda = 0 ! howv does not exist in firstguess, then stop GSI run. + call die('gsi_fv3ncdf2d_read','Warning: CANNOT find howv in firstguess, aborting..., iret = ', iret) + else + write(6,'(1x,A,1x,A,1x,A,1x,I4,1x,I4,1x,A,1x,I4.4,A)') 'gsi_fv3ncdf2d_read:: Found howv in firstguess ', & + trim(sfcdata), ', iret, varid = ',iret, id_howv,' (on pe: ', mype,').' + end if + end if + !!!!!!!!!!!! read in 2d variables !!!!!!!!!!!!!!!!!!!!!!!!!! do i=ndimensions+1,nvariables iret=nf90_inquire_variable(gfile_loc,i,name,len) @@ -1904,6 +1951,8 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) k=k_t2m else if( trim(name)=='Q2M'.or.trim(name)=='q2m' ) then k=k_q2m + else if( trim(name)=='HOWV'.or.trim(name)=='howv' ) then + k=k_howv else cycle endif @@ -2036,6 +2085,8 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) if(allocated(sfc_fulldomain)) deallocate (sfc_fulldomain) endif ! mype +!-- broadcast the updated i_howv_3dda to all tasks (!!!!) + call mpi_bcast(i_howv_3dda, 1, mpi_itype, mype_2d, mpi_comm_world, iret_bcast) !!!!!!! scatter !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! call mpi_scatterv(work,ijns2d,displss2d,mpi_rtype,& @@ -2058,6 +2109,9 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m) ges_t2m(:,:)=sfcn2d(:,:,k_t2m) ges_q2m(:,:)=sfcn2d(:,:,k_q2m) endif + if ( i_howv_3dda == 1 ) then + ges_howv(:,:)=sfcn2d(:,:,k_howv) + endif deallocate (sfcn2d,a) return end subroutine gsi_fv3ncdf2d_read @@ -3192,6 +3246,8 @@ subroutine wrfv3_netcdf(fv3filenamegin) ! 2019-11-22 CAPS(C. Tong) - modify "add_saved" to properly output analyses ! 2021-01-05 x.zhang/lei - add code for updating delz analysis in regional da ! 2022-04-01 Y. Wang and X. Wang - add code for updating reflectivity +! 2023-07-30 Zhao - added code for the output of the analysis of +! significant wave height (howv) ! ! input argument list: ! @@ -3234,6 +3290,7 @@ subroutine wrfv3_netcdf(fv3filenamegin) real(r_kind),pointer,dimension(:,:,:):: ges_q =>NULL() real(r_kind),pointer,dimension(:,: ):: ges_t2m =>NULL() real(r_kind),pointer,dimension(:,: ):: ges_q2m =>NULL() + real(r_kind),pointer,dimension(:,: ):: ges_howv =>NULL() integer(i_kind) i,k @@ -3350,6 +3407,9 @@ subroutine wrfv3_netcdf(fv3filenamegin) call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'q2m',ges_q2m,istatus); ier=ier+istatus call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'t2m',ges_t2m,istatus );ier=ier+istatus endif + if ( i_howv_3dda == 1 ) then + call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'howv',ges_howv,istatus); ier=ier+istatus + endif if (ier/=0) call die('wrfv3_netcdf','cannot get pointers for fv3 met-fields, ier =',ier) if (laeroana_fv3cmaq) then @@ -3559,6 +3619,10 @@ subroutine wrfv3_netcdf(fv3filenamegin) call gsi_fv3ncdf_write_sfc(fv3filenamegin,'t2m',ges_t2m,add_saved) call gsi_fv3ncdf_write_sfc(fv3filenamegin,'q2m',ges_q2m,add_saved) endif +!-- output analysis of howv + if ( i_howv_3dda == 1 ) then + call gsi_fv3ncdf_write_sfc(fv3filenamegin,'howv',ges_howv,add_saved) + endif if(allocated(g_prsi)) deallocate(g_prsi) diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index 2656a2dce4..70618120d0 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -176,7 +176,8 @@ module gsimod i_coastline,i_gsdqc,qv_max_inc,ioption,l_precip_clear_only,l_fog_off,& cld_bld_coverage,cld_clr_coverage,& i_cloud_q_innovation,i_ens_mean,DTsTmax,& - i_T_Q_adjust,l_saturate_bkCloud,l_rtma3d,i_precip_vertical_check + i_T_Q_adjust,l_saturate_bkCloud,l_rtma3d,i_precip_vertical_check, & + corp_howv, hwllp_howv use gsi_metguess_mod, only: gsi_metguess_init,gsi_metguess_final use gsi_chemguess_mod, only: gsi_chemguess_init,gsi_chemguess_final use tcv_mod, only: init_tcps_errvals,tcp_refps,tcp_width,tcp_ermin,tcp_ermax @@ -503,6 +504,9 @@ module gsimod ! 3. fv3_cmaq_regional = .true. ! 4. berror_fv3_cmaq_regional = .true. ! 09-15-2022 yokota - add scale/variable/time-dependent localization +! 2023-07-30 Zhao - added namelist options for analysis of significant wave height +! (aka howv in GSI code): corp_howv, hwllp_howv +! (in namelist session rapidrefresh_cldsurf) ! !EOP !------------------------------------------------------------------------- @@ -1560,6 +1564,10 @@ module gsimod ! = 2(clean Qg as in 1, and adjustment to the retrieved Qr/Qs/Qnr throughout the whole profile) ! = 3(similar to 2, but adjustment to Qr/Qs/Qnr only below maximum reflectivity level ! and where the dbz_obs is missing); +! corp_howv - real, static background error of howv (stddev error) +! = 0.42 meters (default) +! hwllp_howv - real, background error de-correlation length scale of howv +! = 170,000.0 meters (default 170 km) ! namelist/rapidrefresh_cldsurf/dfi_radar_latent_heat_time_period, & metar_impact_radius,metar_impact_radius_lowcloud, & @@ -1580,7 +1588,8 @@ module gsimod i_coastline,i_gsdqc,qv_max_inc,ioption,l_precip_clear_only,l_fog_off,& cld_bld_coverage,cld_clr_coverage,& i_cloud_q_innovation,i_ens_mean,DTsTmax, & - i_T_Q_adjust,l_saturate_bkCloud,l_rtma3d,i_precip_vertical_check + i_T_Q_adjust,l_saturate_bkCloud,l_rtma3d,i_precip_vertical_check, & + corp_howv, hwllp_howv ! chem(options for gsi chem analysis) : ! berror_chem - .true. when background for chemical species that require diff --git a/src/gsi/m_berror_stats_reg.f90 b/src/gsi/m_berror_stats_reg.f90 index 2ff8a6aa94..601339e1ac 100644 --- a/src/gsi/m_berror_stats_reg.f90 +++ b/src/gsi/m_berror_stats_reg.f90 @@ -870,16 +870,17 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt hwllp(i,n)=hwllp(i,nrf2_ps) end do else if (n==nrf2_howv) then - call read_howv_stats(mlat,1,2,cov_dum) + call read_howv_stats(mlat,1,2,cov_dum,mype) do i=1,mlat corp(i,n)=cov_dum(i,1,1) !#ww3 hwllp(i,n) = cov_dum(i,1,2) end do hwllp(0,n) = hwllp(1,n) hwllp(mlat+1,n) = hwllp(mlat,n) - - if (mype==0) print*, 'corp(i,n) = ', corp(:,n) - if (mype==0) print*, ' hwllp(i,n) = ', hwllp(:,n) + if (mype==0) then + print*, myname_, ' static BE corp( :,n) (for ', trim(adjustl(cvars2d(n))), ')= ', corp(:,n) + print*, myname_, ' static BE hwllp(:,n) (for ', trim(adjustl(cvars2d(n))), ')= ', hwllp(:,n) + end if ! corp(:,n)=cov_dum(:,1) !do i=1,mlat ! corp(i,n)=0.4_r_kind !#ww3 @@ -1055,7 +1056,7 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt end subroutine berror_read_wgt_reg !++++ -subroutine read_howv_stats(nlat,nlon,npar,arrout) +subroutine read_howv_stats(nlat,nlon,npar,arrout,mype) !$$$ subprogram documentation block ! . . . . ! subprogram: read_howv_stats @@ -1090,6 +1091,9 @@ subroutine read_howv_stats(nlat,nlon,npar,arrout) ! program history log: ! 2016-08-03 stelios ! 2016-08-26 stelios : Compatible with GSI. +! 2023-07-30 Zhao - added code to set the background error +! standard deviation (corp_howv) and de-correlation +! length scale (hwllp_howv) for non-2DRTMA run ! input argument list: ! filename - The name of the file ! output argument list: @@ -1102,10 +1106,14 @@ subroutine read_howv_stats(nlat,nlon,npar,arrout) !$$$ end documentation block ! use kinds,only : r_kind, i_kind + use gridmod, only : twodvar_regional + use rapidrefresh_cldsurf_mod, only : corp_howv, hwllp_howv + use gsi_io, only : verbose ! implicit none ! Declare passed variables integer(i_kind), intent(in )::nlat,nlon,npar + integer(i_kind), intent(in ) :: mype ! "my" processor ID real(r_kind), dimension(nlat ,nlon, npar), intent( out)::arrout ! Declare local variables integer(i_kind) :: reclength,i,j,i_npar @@ -1117,12 +1125,18 @@ subroutine read_howv_stats(nlat,nlon,npar,arrout) ! filename(1) = 'howv_var_berr.bin' filename(2) = 'howv_lng_berr.bin' -! - arrout(:,:,1)=0.42_r_kind - arrout(:,:,2)=50000.0_r_kind +!-- first, assign the pre-defined values to corp and hwllp + if ( twodvar_regional ) then + arrout(:,:,1)=0.42_r_kind ! values were specified by Manuel and Stelio for 2DRTMA + arrout(:,:,2)=50000.0_r_kind ! values were specified by Manuel and Stelio for 2DRTMA + else + arrout(:,:,1) = corp_howv ! 0.42_r_kind used in 3dvar (default) if not set in namelist + arrout(:,:,2) = hwllp_howv ! 17000.0_r_kind used in 3dvar (default) if not set in namelist + end if reclength=nlat*r_kind -! +!-- secondly, if files for corp and hwllp are available, then read them in for +! corp and hwllp. If the files are not found, then use the pre-defined values. do i_npar = 1,npar inquire(file=trim(filename(i_npar)), exist=file_exists) if (file_exists)then @@ -1132,9 +1146,16 @@ subroutine read_howv_stats(nlat,nlon,npar,arrout) read(unit=lun34 ,rec=j) (arrout(i,j,i_npar), i=1,nlat) enddo close(unit=lun34) + if (verbose .and. mype .eq. 0) then + write(6,'(1x,A,1x,A2,1x,A)') trim(adjustl(myname)), '::', & + trim(filename(i_npar))//' is used for background error of howv.' + end if else - print*,myname, trim(filename(i_npar)) // ' does not exist' + if (verbose .and. mype .eq. 0) then + write(6,'(1x,A,1x,A2,1x,A)') trim(adjustl(myname)), '::', & + trim(filename(i_npar))//' does not exist for static BE of howv, using pre-defined values.' + end if end if end do end subroutine read_howv_stats diff --git a/src/gsi/rapidrefresh_cldsurf_mod.f90 b/src/gsi/rapidrefresh_cldsurf_mod.f90 index 1ee35fffba..122d2872d0 100644 --- a/src/gsi/rapidrefresh_cldsurf_mod.f90 +++ b/src/gsi/rapidrefresh_cldsurf_mod.f90 @@ -28,7 +28,11 @@ module rapidrefresh_cldsurf_mod ! option for checking and adjusting the profile of Qr/Qs/Qg/Qnr ! retrieved through cloud analysis to reduce the background ! reflectivity ghost in analysis. (default is 0) -! +! 2023-07-30 Zhao added options for analysis of significant wave height +! (SWH, aka howv in GSI code): +! corp_howv: to set the static background error of howv +! hwllp_howv: to set the de-correlation length scale +! i_howv_3dda: control the analysis of howv in 3D analysis (if howv is in anavinfo) ! ! Subroutines Included: ! sub init_rapidrefresh_cldsurf - initialize RR related variables to default values @@ -181,6 +185,18 @@ module rapidrefresh_cldsurf_mod ! = 2(clean Qg as in 1, and adjustment to the retrieved Qr/Qs/Qnr throughout the whole profile) ! = 3(similar to 2, but adjustment to Qr/Qs/Qnr only below maximum reflectivity level ! and where the dbz_obs is missing); +! corp_howv - namelist real, static BE of howv (standard error deviation) +! hwllp_howv - namelist real, static BE de-correlation length scale of howv +! i_howv_3dda - integer, control the analysis of howv in 3D analysis (either var or hybrid) +! = 0 (howv-off: default) : no analysis of howv in 3D analysis. +! = 1 (howv-on) : if variable name "howv" is found in anavinfo, +! set it to be 1 to turn on analysis of howv; +! note: in hybrid envar run, the static BE is redueced by beta_s (<1.0), +! since there is no ensemble of howv currently yet, then no ensemble +! contribution to the total BE of howv, so the total BE of howv is actually +! just the reduced static BE of howv. If to make the analysis of howv +! in hyrbid run is as similar as the analysis of howv in pure 3dvar run, +! the static BE of howv used in hybrid run needs to be tuned (inflated actually). ! ! attributes: ! language: f90 @@ -252,6 +268,8 @@ module rapidrefresh_cldsurf_mod public :: l_saturate_bkCloud public :: l_rtma3d public :: i_precip_vertical_check + public :: corp_howv, hwllp_howv + public :: i_howv_3dda logical l_hydrometeor_bkio real(r_kind) dfi_radar_latent_heat_time_period @@ -310,6 +328,8 @@ module rapidrefresh_cldsurf_mod logical l_saturate_bkCloud logical l_rtma3d integer(i_kind) i_precip_vertical_check + real(r_kind) :: corp_howv, hwllp_howv + integer(i_kind) :: i_howv_3dda contains @@ -325,6 +345,8 @@ subroutine init_rapidrefresh_cldsurf ! 2008-06-03 Hu initial build for cloud analysis ! 2010-03-29 Hu change names to init_rapidrefresh_cldsurf ! 2011--5-04 Todling inquire MetGuess for presence of hyrometeors & set default +! 2023-07-30 Zhao added code for initialization of some variables used +! in analysis of significant wave height ! ! input argument list: ! @@ -337,8 +359,12 @@ subroutine init_rapidrefresh_cldsurf !$$$ use kinds, only: i_kind use gsi_metguess_mod, only: gsi_metguess_get + use mpimod, only: mype + use state_vectors, only: ns2d,svars2d + implicit none integer(i_kind) ivar,i,ier + integer(i_kind) i2 logical have_hmeteor(5) character(len=2),parameter :: hydrometeors(5) = (/ 'qi', & 'ql', & @@ -418,6 +444,19 @@ subroutine init_rapidrefresh_cldsurf l_saturate_bkCloud= .true. l_rtma3d = .false. ! turn configuration for rtma3d off i_precip_vertical_check = 0 ! No check and adjustment to retrieved Qr/Qs/Qg (default) + corp_howv = 0.42_r_kind ! 0.42 meters (default) + hwllp_howv = 170000.0_r_kind ! 170,000.0 meters (170km as default for 3DRTMA, 50km is used in 2DRTMA) + i_howv_3dda = 0 ! no analysis of significant wave height (howv) in 3D analysis (default) + +!-- searching for specific variable in state variable list (reading from anavinfo) + do i2=1,ns2d + if ( trim(svars2d(i2))=='howv' .or. trim(svars2d(i2))=='HOWV' ) then + i_howv_3dda = 1 + if ( mype == 0 ) then + write(6,'(1x,A,1x,A8,1x,A,1x,I4)')"init_rapidrefresh_cldsurf: anavinfo svars2d (state variable): ",trim(adjustl(svars2d(i2))), " is found in anavinfo, set i_howv_3dda = ", i_howv_3dda + end if + end if + end do ! i2 : looping over 2-D anasv return end subroutine init_rapidrefresh_cldsurf diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index 9efd06418c..304fa62590 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -149,6 +149,8 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! 2020-05-04 wu - no rotate_wind for fv3_regional ! 2020-09-05 CAPS(C. Tong) - add flag for new vadwind obs to assimilate around the analysis time only ! 2023-03-23 draper - add code for processing T2m and q2m for global system +! 2023-07-30 Zhao - added code to extract obs of significant wave height (howvob) from bufr record +! in prepbufr file for 3D analysis ! input argument list: ! infile - unit from which to read BUFR data @@ -1132,6 +1134,11 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if (howvob) call ufbint(lunin,owave,1,255,levs,owavestr) if (cldchob) call ufbint(lunin,cldceilh,1,255,levs,cldceilhstr) endif +! Extract obs of howv in 3D Analysis +! (if-block is to avoid potential issue if decoding the bufr record twice in 2DRTMA run) + if ( .not. twodvar_regional ) then + if (howvob) call ufbint(lunin,owave,1,255,levs,owavestr) + endif if(kx==224 .and. newvad) then call ufbint(lunin,fcstdat,3,255,levs,'UFC VFC TFC ') end if From ba5a2ca673cc54212dc1c3d1cb2a81f96b3ce075 Mon Sep 17 00:00:00 2001 From: hongli-wang <53354098+hongli-wang@users.noreply.github.com> Date: Fri, 29 Sep 2023 11:51:33 -0600 Subject: [PATCH 032/109] Refine PM2.5 DA for the RRFS_SD model (#609) **Description** Refine the PM2.5 DA for the RRFS_SD model by use of veg_type, which is used to decide whether the obs is in urban area or not. Different thresholds for innovations outside/inside urban areas will be used. Add new namelist parameters, such as threshold for innovations, anowbufr type Read in station terrain height, PM10 et al if extended BUFR format for anow air quality data is used Fixes #606 **Type of change** Please delete options that are not relevant. - [ ] Bug fix (non-breaking change which fixes an issue) - [X ] New feature (non-breaking change which adds functionality) - [ ] Breaking change (fix or feature that would cause existing functionality to not work as expected) - [ ] This change requires a documentation update **How Has This Been Tested?** **Checklist** - [X ] My code follows the style guidelines of this project - [X] I have performed a self-review of my own code - [X] I have commented my code, particularly in hard-to-understand areas - [ ] New and existing tests pass with my changes - [ ] Any dependent changes have been merged and published **DUE DATE for this PR is 9/22/2023.** If this PR is not merged into develop by this date, the PR will be closed and returned to the developer. --- src/gsi/chemmod.f90 | 40 ++++++++++++++++++------- src/gsi/gsimod.F90 | 15 ++++++++-- src/gsi/m_berror_stats_reg.f90 | 6 ++-- src/gsi/read_anowbufr.f90 | 50 +++++++++++++++++++++++++++----- src/gsi/satthin.F90 | 7 ++++- src/gsi/setuppm2_5.f90 | 53 ++++++++++++++++++++++------------ 6 files changed, 128 insertions(+), 43 deletions(-) diff --git a/src/gsi/chemmod.f90 b/src/gsi/chemmod.f90 index 14a90c818c..06bfe6dce6 100644 --- a/src/gsi/chemmod.f90 +++ b/src/gsi/chemmod.f90 @@ -40,21 +40,23 @@ module chemmod public :: naero_cmaq_fv3,aeronames_cmaq_fv3,imodes_cmaq_fv3 ! fv3smoke - public :: naero_smoke_fv3,aeronames_smoke_fv3,pm2_5_innov_threshold + public :: naero_smoke_fv3,aeronames_smoke_fv3 + public :: pm2_5_innov_threshold,pm2_5_urban_innov_threshold,pm2_5_bg_threshold + public :: pm10_innov_threshold,pm10_urban_innov_threshold,pm10_bg_threshold,pm10_obs_threshold public :: naero_gocart_wrf,aeronames_gocart_wrf public :: pm2_5_guess,init_pm2_5_guess,& aerotot_guess,init_aerotot_guess public :: init_chem - public :: berror_chem,berror_fv3_cmaq_regional,oneobtest_chem,maginnov_chem,magoberr_chem,oneob_type_chem,conconeobs + public :: berror_chem,berror_fv3_cmaq_regional,berror_fv3_sd_regional,oneobtest_chem,maginnov_chem,magoberr_chem,oneob_type_chem,conconeobs public :: oblat_chem,oblon_chem,obpres_chem,diag_incr,oneobschem public :: site_scale,nsites public :: tunable_error public :: in_fname,out_fname,incr_fname,maxstr public :: code_pm25_ncbufr,code_pm25_anowbufr public :: code_pm10_ncbufr,code_pm10_anowbufr - + public :: anowbufr_ext public :: l_aoderr_table public :: laeroana_gocart,laeroana_fv3cmaq,laeroana_fv3smoke,crtm_aerosol_model,crtm_aerosolcoeff_format,crtm_aerosolcoeff_file, & @@ -79,7 +81,8 @@ module chemmod integer(i_kind) :: icvt_cmaq_fv3 real(r_kind) :: raod_radius_mean_scale,raod_radius_std_scale real(r_kind) :: ppmv_conv = 96.06_r_kind/28.964_r_kind*1.0e+3_r_kind - real(r_kind) :: pm2_5_innov_threshold + real(r_kind) :: pm2_5_innov_threshold,pm2_5_urban_innov_threshold,pm2_5_bg_threshold + real(r_kind) :: pm10_innov_threshold,pm10_urban_innov_threshold,pm10_bg_threshold,pm10_obs_threshold logical :: wrf_pm2_5 @@ -90,7 +93,9 @@ module chemmod logical :: aero_ratios - logical :: oneobtest_chem,diag_incr,berror_chem,berror_fv3_cmaq_regional + logical :: oneobtest_chem,diag_incr,berror_chem + logical :: berror_fv3_cmaq_regional,berror_fv3_sd_regional + logical :: anowbufr_ext character(len=max_varname_length) :: oneob_type_chem integer(i_kind), parameter :: maxstr=256 real(r_kind) :: maginnov_chem,magoberr_chem,conconeobs,& @@ -103,7 +108,7 @@ module chemmod real(r_kind),parameter :: pm2_5_teom_max=900.0_r_kind !ug/m3 !some parameters need to be put here since convinfo file won't !accomodate, stands for maximum realistic value of surface pm2.5 - real(r_kind),parameter :: pm10_teom_max=150.0_r_kind !ug/m3 + real(r_kind),parameter :: pm10_teom_max=3000.0_r_kind !ug/m3 real(r_kind),parameter :: elev_missing=-9999.0_r_kind @@ -157,10 +162,10 @@ module chemmod 'AOLGAJ', 'AISO1J', 'AISO2J', 'AISO3J', 'ATRP1J', 'ATRP2J',& 'ASQTJ', 'AOLGBJ', 'AORGCJ'] ! fv3smoke - integer(i_kind), parameter :: naero_smoke_fv3=2 + integer(i_kind), parameter :: naero_smoke_fv3=3 character(len=max_varname_length), dimension(naero_smoke_fv3), parameter :: & - aeronames_smoke_fv3=[character(len=max_varname_length) :: 'smoke','dust' ] + aeronames_smoke_fv3=[character(len=max_varname_length) :: 'smoke','dust','coarsepm'] ! FV3CMAQ integer(i_kind), parameter :: naero_cmaq_fv3=70 ! !number of cmaq aerosol species aero6 @@ -286,8 +291,15 @@ subroutine init_chem !initialiazes default values to &CHEM namelist parameters berror_chem=.false. - berror_fv3_cmaq_regional=.false. ! Set .true. to use berror for fv3_cmaq_regional, whose cv has 10 characters + berror_fv3_cmaq_regional=.false. ! .False. : Dont perform aerosal DA for the online RRFS_CMAQ model so dont need to read in B for RRFS_CMAQ. + ! .true. : Use berror for fv3_cmaq_regional, whose cv has 10 characters + berror_fv3_sd_regional=.false. ! .False. : Dont perform aerosal DA for the RRFS_SD model so dont need to read in B for RRFS_SD. + ! .true. to use berror for rrfs_sd model, whose cv has 10 characters oneobtest_chem=.false. + anowbufr_ext=.false. ! .False. : use default anowbufr data + ! .True. : use the extented bufr data + ! that includes PM10, station elevation + ! etal in addition to pm2.5. maginnov_chem=30_r_kind magoberr_chem=2_r_kind oneob_type_chem='pm2_5' @@ -307,9 +319,15 @@ subroutine init_chem laeroana_gocart = .false. laeroana_fv3cmaq = .false. ! .true. for performing aerosol analysis for regional FV3-CMAQ model(Please other parameters requred in gsimod.F90) laeroana_fv3smoke = .false. - pm2_5_innov_threshold = 20.0_r_kind + pm2_5_innov_threshold = 15.0_r_kind + pm2_5_urban_innov_threshold = 30.0_r_kind + pm2_5_bg_threshold = 2.0_r_kind + pm10_innov_threshold = 15.0_r_kind + pm10_urban_innov_threshold = 30.0_r_kind + pm10_bg_threshold = 2.0_r_kind + pm10_obs_threshold = 140.0_r_kind ! Barry's manuscript l_aoderr_table = .false. - icvt_cmaq_fv3 = 1 ! 1. Control variable is individual aerosol specie; 2: CV is total mass per I,J,K mode + icvt_cmaq_fv3 = 1 ! 1: Control variable is individual aerosol specie; 2: CV is total mass per I,J,K mode raod_radius_mean_scale = 1.0_r_kind ! Tune radius of particles when calculating AOD using CRTM raod_radius_std_scale = 1.0_r_kind ! Tune standard deviation of particles when calculating AOD using CRTM with CMAQ LUTs. aod_qa_limit = 3 diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index 70618120d0..d0ca1c0fbf 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -182,12 +182,15 @@ module gsimod use gsi_chemguess_mod, only: gsi_chemguess_init,gsi_chemguess_final use tcv_mod, only: init_tcps_errvals,tcp_refps,tcp_width,tcp_ermin,tcp_ermax use chemmod, only : init_chem,berror_chem,berror_fv3_cmaq_regional,oneobtest_chem,& + berror_fv3_sd_regional,& maginnov_chem,magoberr_chem,& oneob_type_chem,oblat_chem,& + anowbufr_ext,& oblon_chem,obpres_chem,diag_incr,elev_tolerance,tunable_error,& in_fname,out_fname,incr_fname, & laeroana_gocart, l_aoderr_table, aod_qa_limit, luse_deepblue, lread_ext_aerosol, & - laeroana_fv3cmaq,laeroana_fv3smoke,pm2_5_innov_threshold,crtm_aerosol_model,crtm_aerosolcoeff_format,crtm_aerosolcoeff_file, & + laeroana_fv3cmaq,laeroana_fv3smoke,pm2_5_innov_threshold,pm2_5_urban_innov_threshold,pm2_5_bg_threshold,& + crtm_aerosol_model,crtm_aerosolcoeff_format,crtm_aerosolcoeff_file, & icvt_cmaq_fv3, raod_radius_mean_scale,raod_radius_std_scale use chemmod, only : wrf_pm2_5,aero_ratios @@ -1594,6 +1597,12 @@ module gsimod ! chem(options for gsi chem analysis) : ! berror_chem - .true. when background for chemical species that require ! conversion to lower case and/or species names longer than 5 chars +! berror_fv3_cmaq_regional - .true. use background error stat for online +! RRFS_CMAQ model. Control variable +! names extended up to 10 chars +! berror_fv3_sd_regional - .true. use background error stat for online +! RRFS_SD model. Control variable +! names extended up to 10 chars ! oneobtest_chem - one-ob trigger for chem constituent analysis ! maginnov_chem - O-B make-believe residual for one-ob chem test ! magoberr_chem - make-believe obs error for one-ob chem test @@ -1615,13 +1624,15 @@ module gsimod ! luse_deepblue - whether to use MODIS AOD from the deepblue algorithm ! lread_ext_aerosol - if true, reads aerfNN file for aerosol arrays rather than sigfNN (NGAC NEMS IO) - namelist/chem/berror_chem,berror_fv3_cmaq_regional,oneobtest_chem,maginnov_chem,magoberr_chem,& + namelist/chem/berror_chem,berror_fv3_cmaq_regional,berror_fv3_sd_regional,& + oneobtest_chem,anowbufr_ext,maginnov_chem,magoberr_chem,& oneob_type_chem,oblat_chem,oblon_chem,obpres_chem,& diag_incr,elev_tolerance,tunable_error,& in_fname,out_fname,incr_fname,& laeroana_gocart, laeroana_fv3cmaq,laeroana_fv3smoke,l_aoderr_table, aod_qa_limit, & crtm_aerosol_model,crtm_aerosolcoeff_format,crtm_aerosolcoeff_file, & icvt_cmaq_fv3,pm2_5_innov_threshold, & + pm2_5_innov_threshold,pm2_5_urban_innov_threshold,pm2_5_bg_threshold,& raod_radius_mean_scale,raod_radius_std_scale, luse_deepblue,& aero_ratios,wrf_pm2_5, lread_ext_aerosol diff --git a/src/gsi/m_berror_stats_reg.f90 b/src/gsi/m_berror_stats_reg.f90 index 601339e1ac..bf9fb20674 100644 --- a/src/gsi/m_berror_stats_reg.f90 +++ b/src/gsi/m_berror_stats_reg.f90 @@ -12,7 +12,7 @@ module m_berror_stats_reg use kinds,only : i_kind,r_kind use constants, only: zero,one,max_varname_length,half use gridmod, only: nsig - use chemmod, only : berror_chem,berror_fv3_cmaq_regional,upper2lower,lower2upper + use chemmod, only : berror_chem,berror_fv3_cmaq_regional,berror_fv3_sd_regional,upper2lower,lower2upper use m_berror_stats, only: usenewgfsberror,berror_stats implicit none @@ -312,7 +312,7 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt use constants, only: zero,one,ten,three use mpeu_util,only: getindex use radiance_mod, only: icloud_cv,n_clouds_fwd,cloud_names_fwd - use chemmod, only: berror_fv3_cmaq_regional + use chemmod, only: berror_fv3_cmaq_regional,berror_fv3_sd_regional implicit none @@ -466,7 +466,7 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt var=upper2lower(varshort) if (trim(var) == 'pm25') var = 'pm2_5' else - if ( berror_fv3_cmaq_regional) then + if ( berror_fv3_cmaq_regional .or. berror_fv3_sd_regional) then read(inerr,iostat=istat) varlong, isig var=varlong else diff --git a/src/gsi/read_anowbufr.f90 b/src/gsi/read_anowbufr.f90 index 1873d0b877..449ce5cdf8 100644 --- a/src/gsi/read_anowbufr.f90 +++ b/src/gsi/read_anowbufr.f90 @@ -50,7 +50,9 @@ subroutine read_anowbufr(nread,ndata,nodata,gstime,& iconc,ierror,ilat,ilon,itime,iid,ielev,isite,iikx,ilate,ilone,& elev_missing,site_scale,tunable_error,& code_pm25_ncbufr,code_pm25_anowbufr,& - code_pm10_ncbufr,code_pm10_anowbufr + code_pm10_ncbufr,code_pm10_anowbufr,& + anowbufr_ext,pm2_5_teom_max,pm10_teom_max + use mpimod, only: npe implicit none @@ -71,10 +73,12 @@ subroutine read_anowbufr(nread,ndata,nodata,gstime,& nyob=3,ndhr=4,ntyp=5,ncopopm=6 !see headr input format below integer(i_kind), parameter :: nfields=6 + integer(i_kind), parameter :: nfields_b=12 !output format parameters integer(i_kind), parameter:: nchanl=0,nreal=ilone real(r_kind),parameter :: r360 = 360.0_r_kind + real(r_kind),parameter :: r90 = 90.0_r_kind real(r_kind),parameter :: percent=1.e-2_r_kind real(r_kind), parameter :: anow_missing=1.0e11_r_kind,& @@ -96,8 +100,10 @@ subroutine read_anowbufr(nread,ndata,nodata,gstime,& real(r_kind), dimension(5) :: rinc character(len=8) :: subset character(len=80) :: headr + character(len=80) :: obstr real(r_double), dimension(nfields) :: indata + real(r_double), dimension(nfields_b) :: indata_a,indata_b real(r_kind) :: tdiff,obstime,t4dv real(r_kind) :: dlat,dlon,error_1,error_2,obserror,dlat_earth,dlon_earth @@ -141,7 +147,6 @@ subroutine read_anowbufr(nread,ndata,nodata,gstime,& ! reading each report from bufr do while (ireadmg(lunin,subset,idate) == 0) - if (trim(obstype)=='pm2_5') then if ( (subset == 'NC008031') .or. (subset == 'NC008032' ) ) then @@ -149,9 +154,16 @@ subroutine read_anowbufr(nread,ndata,nodata,gstime,& ncbufr=.true. write(6,*)'READ_PM2_5: AIRNOW data type, subset=',subset else if (subset == 'ANOWPM') then - headr='SID XOB YOB DHR TYP COPOPM' - anowbufr=.true. - write(6,*)'READ_PM2_5: AIRNOW data type, subset=',subset + if (anowbufr_ext) then + headr='SID XOB YOB DHR TYP T29 SQN PROCN RPT CAT TYPO TSIG' + obstr='TPHR QCIND COPOPM ELV COPOPM10 COPOCO' + anowbufr=.true. + write(6,*)'READ_PM2_5_BUFR_EXT: AIRNOW data type, subset=',subset + else ! default ANOWBUFR Table + headr='SID XOB YOB DHR TYP COPOPM' + anowbufr=.true. + write(6,*)'READ_PM2_5: AIRNOW data type, subset=',subset + end if else cycle endif @@ -162,6 +174,17 @@ subroutine read_anowbufr(nread,ndata,nodata,gstime,& headr='PTID CLONH CLATH TPHR TYPO COPOPM' ncbufr=.true. write(6,*)'READ_PM10: AIRNOW data type, subset=',subset + else if (subset == 'ANOWPM') then + if (anowbufr_ext) then + headr='SID XOB YOB DHR TYP T29 SQN PROCN RPT CAT TYPO TSIG' + obstr='TPHR QCIND COPOPM ELV COPOPM10 COPOCO' + anowbufr=.true. + write(6,*)'READ_PM10_BUFR_EXT: AIRNOW data type, subset=',subset + else + headr='SID XOB YOB DHR TYP COPOPM' + anowbufr=.true. + write(6,*)'READ_PM10: AIRNOW data type, subset=',subset + end if else cycle endif @@ -176,8 +199,17 @@ subroutine read_anowbufr(nread,ndata,nodata,gstime,& imin=0 do while (ireadsb(lunin) == 0) - call ufbint(lunin,indata,nfields,1,iret,headr) - + if (anowbufr_ext) then + call ufbint(lunin,indata_a,nfields_b,1,iret,headr) + indata(1:5) = indata_a(1:5) + call ufbint(lunin,indata_b,nfields_b,1,iret,obstr) + if (trim(obstype)=='pm2_5') indata(ncopopm)=indata_b(3) + if (trim(obstype)=='pm10') indata(ncopopm)=indata_b(5) + site_elev = indata_b(4) + else + call ufbint(lunin,indata,nfields,1,iret,headr) + end if + if (anowbufr) then kx=indata(ntyp) read(sid,'(Z8)')site_id @@ -198,13 +230,15 @@ subroutine read_anowbufr(nread,ndata,nodata,gstime,& nread = nread + 1 conc=indata(ncopopm) - if ( iret > 0 .and. (conc < conc_missing ) .and. & (conc >= zero)) then if(indata(nxob) >= r360) indata(nxob) = indata(nxob) - r360 if(indata(nxob) < zero) indata(nxob) = indata(nxob) + r360 + if(indata(nxob) > r360)cycle + if(indata(nyob) > r90)cycle + dlon_earth_deg=indata(nxob) dlat_earth_deg=indata(nyob) diff --git a/src/gsi/satthin.F90 b/src/gsi/satthin.F90 index 02d19b198c..2018d80be7 100644 --- a/src/gsi/satthin.F90 +++ b/src/gsi/satthin.F90 @@ -134,6 +134,8 @@ module satthin use obsmod, only: time_window_max use constants, only: deg2rad,rearth_equator,zero,two,pi,half,one,& rad2deg,r1000 + use chemmod, only: laeroana_fv3smoke + implicit none ! set default to private @@ -961,7 +963,10 @@ subroutine getsfc(mype,mype_io,use_sfc,use_sfc_any) end if if (.not.lobserver) then if(allocated(veg_frac)) deallocate(veg_frac) - if(allocated(veg_type)) deallocate(veg_type) +! veg_type will be used in setuppm2_5.f90 for rrfs_sd PM2.5 DA + if(.not. laeroana_fv3smoke )then + if(allocated(veg_type)) deallocate(veg_type) + endif if(allocated(soil_type)) deallocate(soil_type) if(allocated(soil_moi)) deallocate(soil_moi) if(allocated(sfc_rough)) deallocate(sfc_rough) diff --git a/src/gsi/setuppm2_5.f90 b/src/gsi/setuppm2_5.f90 index 79e6129cd8..ad940cce78 100644 --- a/src/gsi/setuppm2_5.f90 +++ b/src/gsi/setuppm2_5.f90 @@ -94,8 +94,8 @@ subroutine setuppm2_5(obsLL,odiagLL,lunin,mype,nreal,nobs,isis,is,conv_diagsave) use gsi_4dvar, only: nobs_bins,hr_obsbin use gridmod, only : get_ij,get_ijk - use guess_grids, only : nfldsig,hrdifsig + use guess_grids, only : veg_type use gsi_bundlemod, only : gsi_bundlegetpointer,GSI_BundlePrint use gsi_chemguess_mod, only : gsi_chemguess_get,gsi_chemguess_bundle use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle @@ -115,7 +115,8 @@ subroutine setuppm2_5(obsLL,odiagLL,lunin,mype,nreal,nobs,isis,is,conv_diagsave) use chemmod, only: naero_gocart_wrf,aeronames_gocart_wrf,& upper2lower,lower2upper,laeroana_gocart,wrf_pm2_5 use chemmod, only: naero_cmaq_fv3,aeronames_cmaq_fv3,imodes_cmaq_fv3,laeroana_fv3cmaq - use chemmod, only: naero_smoke_fv3,aeronames_smoke_fv3,laeroana_fv3smoke,pm2_5_innov_threshold + use chemmod, only: naero_smoke_fv3,aeronames_smoke_fv3,laeroana_fv3smoke + use chemmod, only: pm2_5_innov_threshold,pm2_5_urban_innov_threshold,pm2_5_bg_threshold use gridmod, only : cmaq_regional,wrf_mass_regional,fv3_cmaq_regional implicit none @@ -146,7 +147,7 @@ subroutine setuppm2_5(obsLL,odiagLL,lunin,mype,nreal,nobs,isis,is,conv_diagsave) real(r_kind) :: pm2_5ges real(r_kind) :: ratio_errors,error real(r_kind) :: innov,innov_error2,rwgt,valqc,tfact,innov_error,elevges,& - elevdiff,conc,elevobs,ps_ges,site_id,tv_ges + elevdiff,conc,elevobs,ps_ges,site_id,tv_ges,veg_type_ges real(r_kind) errinv_input,errinv_adjst,errinv_final real(r_kind) err_input,err_adjst,err_final @@ -278,7 +279,7 @@ subroutine setuppm2_5(obsLL,odiagLL,lunin,mype,nreal,nobs,isis,is,conv_diagsave) call stop2(453) endif - do i=2,naero_smoke_fv3 + do i=2,naero_smoke_fv3-1 ! remove contribution from coarsepm aeroname=trim(aeronames_smoke_fv3(i)) call gsi_bundlegetpointer(gsi_chemguess_bundle(1),trim(aeroname),& rank3,ier) @@ -705,13 +706,18 @@ subroutine setuppm2_5(obsLL,odiagLL,lunin,mype,nreal,nobs,isis,is,conv_diagsave) if (wrf_mass_regional .or. fv3_cmaq_regional .or. laeroana_fv3smoke) then call tintrp2a11(ges_ps,ps_ges,dlat,dlon,dtime,hrdifsig,& mype,nfldsig) - call tintrp2a11(ges_tv(:,:,1,nfldsig),tv_ges,dlat,dlon,dtime,hrdifsig,& mype,nfldsig) conc=conc/(ps_ges*r1000/(rd*tv_ges)) endif - - +! + if (laeroana_fv3smoke) then + if (.not. allocated(veg_type)) then + print*,"VEG_TYPE NOT ALLOCATED, WILL NOT BE USED IN PM2.5 DA FOR RRFS_SD",mype + else + call intrp2a11(veg_type(:,:,1),veg_type_ges,dlat,dlon,mype) + endif + endif !if elevobs is known than calculate difference otherwise !assume that difference is acceptable @@ -740,17 +746,20 @@ subroutine setuppm2_5(obsLL,odiagLL,lunin,mype,nreal,nobs,isis,is,conv_diagsave) mype,nfldsig) innov = conc - pm2_5ges if (laeroana_fv3smoke) then - if ( -1.0*innov >= pm2_5_innov_threshold .or. & - (innov > pm2_5_innov_threshold .and. pm2_5ges >=1.0_r_kind).or. & - (conc >= 40.0_r_kind .and. pm2_5ges >=1.0_r_kind).or. & - conc >= 100.0_r_kind ) then - innov = innov + if ( veg_type_ges == 13.0_r_kind ) then + if (abs(innov) < pm2_5_urban_innov_threshold) then + muse(i)=.false. + end if else - innov = 0.0_r_kind + if (abs(innov) < pm2_5_innov_threshold) then + muse(i)=.false. + end if + end if + + if (pm2_5ges < pm2_5_bg_threshold) then muse(i)=.false. end if if (tv_ges-273.15_r_kind < 5.0_r_kind) then - innov = 0.0_r_kind muse(i)=.false. end if @@ -770,21 +779,28 @@ subroutine setuppm2_5(obsLL,odiagLL,lunin,mype,nreal,nobs,isis,is,conv_diagsave) mype,nfldsig) call tintrp2a11(pm25wc(:,:,:,2,nfldsig),pm25wc_ges(2),dlat,dlon,dtime,hrdifsig,& mype,nfldsig) - - if (pm25wc_ges(1) >= 1.0_r_kind) then + if (pm25wc_ges(1) >= pm2_5_bg_threshold) then pm25wc_ges(1)=1.0_r_kind else - pm25wc_ges(2)=0.0_r_kind + pm25wc_ges(1)=0.0_r_kind end if - if (pm25wc_ges(2) >= 1.0_r_kind) then + if (pm25wc_ges(2) >= pm2_5_bg_threshold) then pm25wc_ges(2)=1.0_r_kind else pm25wc_ges(2)=0.0_r_kind end if + if ( (pm25wc_ges(1)+pm25wc_ges(2)) < 1.0_r_kind ) then + muse(i) = .false. + end if else pm25wc_ges = 0.0_r_kind end if + if (oneobtest_chem) then + pm25wc_ges=1.0_r_kind + muse(i) = .true. + end if + error=one/data(ierror,i) ratio_errors=one/sqrt(real(dup(i))) innov_error = error*innov @@ -1115,6 +1131,7 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Latitude", data(ilate,i) ) call nc_diag_metadata("Longitude", data(ilone,i) ) call nc_diag_metadata("Station_Elevation", data(ielev,i) ) + call nc_diag_metadata("Station_Veg_Type", veg_type_ges ) call nc_diag_metadata("Pressure", ps_ges ) call nc_diag_metadata("Height", data(ielev,i) ) call nc_diag_metadata("Time", dtime-time_offset ) From c56d7bc616057054f592653a7b4fd0438deace4a Mon Sep 17 00:00:00 2001 From: shoyokota <103961291+shoyokota@users.noreply.github.com> Date: Fri, 29 Sep 2023 21:27:50 -0400 Subject: [PATCH 033/109] GitHub Issue NOAA-EMC/GSI#604 Undefined values found in radar reflectivity direct DA (#605) **Description** To prevent some undefined values found in the radar reflectivity direct DA (if_model_dbz=T and l_use_dbz_directDA=F), corresponding parts are fixed. It doesn't change the result except for the case of the execution with the debug option. Fixes #604 **Type of change** - [x] Bug fix (non-breaking change which fixes an issue) **How Has This Been Tested?** The radar reflectivity DA test with the RRFS setting was done on Orion. After this modification, EnVar was completed even with the debug option. This modification didn't change the result in the test without the debug option. **Checklist** - [x] My code follows the style guidelines of this project - [x] I have performed a self-review of my own code - [x] I have commented my code, particularly in hard-to-understand areas - [x] New and existing tests pass with my changes - [x] Any dependent changes have been merged and published **Due date for this PR is 9/15/2023.** If this PR is not merged into `develop` by this date, the PR will be closed and returned to the developer. Co-authored-by: Sho Yokota --- src/gsi/read_dbz_nc.f90 | 16 ++++++++++------ src/gsi/setupdbz.f90 | 15 +++++++++------ 2 files changed, 19 insertions(+), 12 deletions(-) diff --git a/src/gsi/read_dbz_nc.f90 b/src/gsi/read_dbz_nc.f90 index f6ac9aa112..7f8604b9d2 100644 --- a/src/gsi/read_dbz_nc.f90 +++ b/src/gsi/read_dbz_nc.f90 @@ -69,11 +69,12 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no use kinds, only: r_kind,r_double,i_kind,r_single use constants, only: zero,half,one,two,deg2rad,rad2deg, & one_tenth,r1000,r60,r60inv,r100,r400,grav_equator, & - eccentricity,somigliana,grav_ratio,grav,semi_major_axis,flattening + eccentricity,somigliana,grav_ratio,grav,semi_major_axis,flattening,r_missing 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 + 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 @@ -147,7 +148,7 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no integer(i_kind) :: maxobs,nchanl,ilat,ilon,scount real(r_kind) :: thistiltr,thisrange,this_stahgt,thishgt - real(r_kind) :: thisazimuthr,t4dv, & + real(r_kind) :: thisazimuthr, & dlat,dlon,thiserr,thislon,thislat, & timeb real(r_kind) :: radartwindow @@ -337,6 +338,7 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no call w3fs21(iadate,mins_an) !mins_an -integer number of mins snce 01/01/1978 rmins_an=mins_an !convert to real number + timeb=real(mins_an-iwinbgn,r_kind) !assume all observations are at the analysis time ivar = 1 @@ -453,7 +455,7 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no ntmp=ndata ! counting moved to map3gridS - timedif=abs(t4dv) !don't know about this + timedif=zero ! assume all observations are at the analysis time crit1 = timedif/r6+half call map3grids(1,zflag,zl_thin,nlevz,thislat,thislon,& @@ -481,7 +483,10 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no !!end modified for thinning - thisazimuthr=0.0_r_kind + thisazimuthr=r_missing + thistiltr=r_missing + this_stahgt=r_missing + thisrange=r_missing this_staid=radid !Via equivalence in declaration, value is propagated ! to rstation_id used below. cdata_all(1,iout) = thiserr ! reflectivity obs error (dB) - inflated/adjusted @@ -491,7 +496,7 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no cdata_all(5,iout) = dbzQC(i,j,k) ! radar reflectivity factor cdata_all(6,iout) = thisazimuthr ! 90deg-azimuth angle (radians) - cdata_all(7,iout) = timeb*r60inv ! obs time (analyis relative hour) + cdata_all(7,iout) = timeb*r60inv ! obs time (relative hour from beginning of the DA window) cdata_all(8,iout) = ikx ! type cdata_all(9,iout) = thistiltr ! tilt angle (radians) cdata_all(10,iout)= this_stahgt ! station elevation (m) @@ -521,7 +526,6 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no !---all looping done now print diagnostic output write(6,*)'READ_dBZ: Reached eof on radar reflectivity file' - write(6,*)'READ_dBZ: # volumes in input file =',nvol write(6,*)'READ_dBZ: # read in obs. number =',nread write(6,*)'READ_dBZ: # elevations outside time window =',numbadtime write(6,*)'READ_dBZ: # of noise obs to no precip obs =',num_nopcp diff --git a/src/gsi/setupdbz.f90 b/src/gsi/setupdbz.f90 index 068842cd6b..453c4a5f8d 100644 --- a/src/gsi/setupdbz.f90 +++ b/src/gsi/setupdbz.f90 @@ -590,14 +590,17 @@ subroutine setupdbz(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,radardbz_d ! Compute observation pressure (only used for diagnostics) dz = zges(k2)-zges(k1) dlnp = prsltmp(k2)-prsltmp(k1) - pobl = prsltmp(k1) + (dlnp/dz)*(zob-zges(k1)) - - presw = ten*exp(pobl) - if ( l_use_dbz_directDA ) then - presq = presw + pobl = prsltmp(k1) + (dlnp/dz)*(zob-zges(k1)) + presw = ten*exp(pobl) + presq = presw else - if( (k1 == k2) .and. (k1 == 1) ) presw=ten*exp(prsltmp(k1)) + if( (k1 == k2) .and. (k1 == 1) ) then + presw = ten*exp(prsltmp(k1)) + else + pobl = prsltmp(k1) + (dlnp/dz)*(zob-zges(k1)) + presw = ten*exp(pobl) + end if end if ! solution to Nan in some members only for EnKF which causes problem? From fae4bbfbb1124fe3ceced4c3639a53172ad2db26 Mon Sep 17 00:00:00 2001 From: Haidao Lin <63735768+HaidaoLin-NOAA@users.noreply.github.com> Date: Sat, 30 Sep 2023 09:26:52 -0600 Subject: [PATCH 034/109] fix a bug in read_obs.F90 missing N21 for EARS and DBnet (#630) This PR is to fix a bug in read_obs.F90 missing N21 for EARS and DBnet. Fixes #506 --- src/gsi/read_obs.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/gsi/read_obs.F90 b/src/gsi/read_obs.F90 index cb4a7c4b8f..dab159bd0a 100644 --- a/src/gsi/read_obs.F90 +++ b/src/gsi/read_obs.F90 @@ -1065,7 +1065,7 @@ subroutine read_obs(ndata,mype) obstype == 'iasi' .or. obstype == 'atms') .and. & (dplat(i) == 'n17' .or. dplat(i) == 'n18' .or. & dplat(i) == 'n19' .or. dplat(i) == 'npp' .or. & - dplat(i) == 'n20' .or. & + dplat(i) == 'n20' .or. dplat(i) == 'n21' .or. & dplat(i) == 'metop-a' .or. dplat(i) == 'metop-b' .or. & dplat(i) == 'metop-c') ! direct broadcast from NESDIS/UW @@ -1076,7 +1076,7 @@ subroutine read_obs(ndata,mype) obstype == 'iasi') .and. & (dplat(i) == 'n17' .or. dplat(i) == 'n18' .or. & dplat(i) == 'n19' .or. dplat(i) == 'npp' .or. & - dplat(i) == 'n20' .or. & + dplat(i) == 'n20' .or. dplat(i) == 'n21' .or. & dplat(i) == 'metop-a' .or. dplat(i) == 'metop-b' .or. & dplat(i) == 'metop-c') From 25306a2bcb72f1bbe572a96f1f2b6b6e83109094 Mon Sep 17 00:00:00 2001 From: ShunLiu-NOAA Date: Wed, 4 Oct 2023 16:03:47 -0400 Subject: [PATCH 035/109] Turn off enspread reg (#635) In cplr_get_fv3_regional_ensperts.f90, "write_ens_sprd=.true." is hard-coded and overwrites the values in namelist. write_ens_sprd=.true." should be removed. Fixes #634 **Type of change** Please delete options that are not relevant. - [x] Bug fix (non-breaking change which fixes an issue) --- src/gsi/cplr_get_fv3_regional_ensperts.f90 | 1 - 1 file changed, 1 deletion(-) diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 index 5a3e72970d..5b8fb153b6 100644 --- a/src/gsi/cplr_get_fv3_regional_ensperts.f90 +++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90 @@ -684,7 +684,6 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) enddo ! it 4d loop ! CALCULATE ENSEMBLE SPREAD - write_ens_sprd=.true. if(write_ens_sprd ) then call this%ens_spread_dualres_regional(mype,en_perts,nelen) call mpi_barrier(mpi_comm_world,ierror) ! do we need this mpi_barrier here? From 978b7e76a53a6d5814efac17b212f5d788c7a5c3 Mon Sep 17 00:00:00 2001 From: Ming Hu Date: Fri, 6 Oct 2023 14:08:09 -0600 Subject: [PATCH 036/109] A bug fix in setupps (#638) A bug is found in setupps and setupspd: un-used observation is also marked as 1 in "Analysis_Usage_Flag". Remove a print statement in rfv3io to simply stdout. This is PR fixes #637 --- src/gsi/gsi_rfv3io_mod.f90 | 3 --- src/gsi/setupps.f90 | 2 +- src/gsi/setupspd.f90 | 2 +- 3 files changed, 2 insertions(+), 5 deletions(-) diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 6d16be7c13..d0cbd3afbd 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -2610,9 +2610,6 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) members(mm1) = mype endif - write(6,115)mype,kbgn,kend,procuse -115 format('gsi_fv3ncdf_readuv: mype ',i6,' has kbgn,kend= ',2(i6,1x),' set procuse ',l7) - call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror) nread=0 diff --git a/src/gsi/setupps.f90 b/src/gsi/setupps.f90 index 118ccb45d2..f376f9ffde 100644 --- a/src/gsi/setupps.f90 +++ b/src/gsi/setupps.f90 @@ -904,7 +904,7 @@ subroutine contents_netcdf_diag_(odiag) if(muse(i)) then call nc_diag_metadata("Analysis_Use_Flag", 1.0_r_single ) else - call nc_diag_metadata("Analysis_Use_Flag", 1.0_r_single ) + call nc_diag_metadata("Analysis_Use_Flag", -1.0_r_single ) endif call nc_diag_metadata_to_single("Errinv_Input", errinv_input ) diff --git a/src/gsi/setupspd.f90 b/src/gsi/setupspd.f90 index 64366394cb..150799bf2c 100644 --- a/src/gsi/setupspd.f90 +++ b/src/gsi/setupspd.f90 @@ -962,7 +962,7 @@ subroutine contents_netcdf_diag_(odiag) if(muse(i)) then call nc_diag_metadata("Analysis_Use_Flag", 1.0_r_single ) else - call nc_diag_metadata("Analysis_Use_Flag", 1.0_r_single ) + call nc_diag_metadata("Analysis_Use_Flag", -1.0_r_single ) endif call nc_diag_metadata_to_single("Errinv_Input",errinv_input ) From f76d872859257bfa614d6f6395132700ca6b1b77 Mon Sep 17 00:00:00 2001 From: jderber-NOAA <75998838+jderber-NOAA@users.noreply.github.com> Date: Tue, 17 Oct 2023 10:43:33 -0400 Subject: [PATCH 037/109] Replacement of float command with real command (#631) --- src/gsi/aniso_ens_util.f90 | 44 +- src/gsi/anisofilter.f90 | 50 +-- src/gsi/anisofilter_glb.f90 | 26 +- src/gsi/atms_spatial_average_mod.f90 | 2 +- src/gsi/balmod.f90 | 10 +- src/gsi/berror.f90 | 4 +- src/gsi/bkgvar_rewgt.f90 | 2 +- src/gsi/buddycheck_mod.f90 | 2 +- src/gsi/calc_fov_crosstrk.f90 | 2 +- src/gsi/compact_diffs.f90 | 54 +-- src/gsi/compute_derived.f90 | 2 +- src/gsi/compute_qvar3d.f90 | 4 +- src/gsi/cplr_get_fv3_regional_ensperts.f90 | 4 +- src/gsi/cplr_get_pseudo_ensperts.f90 | 10 +- src/gsi/cplr_get_wrf_mass_ensperts.f90 | 4 +- src/gsi/cplr_get_wrf_nmm_ensperts.f90 | 2 +- src/gsi/cplr_gfs_ensmod.f90 | 13 +- src/gsi/cplr_read_wrf_nmm_guess.f90 | 8 +- src/gsi/cplr_wrf_netcdf_interface.f90 | 4 +- src/gsi/deter_sfc_mod.f90 | 22 +- src/gsi/ens_spread_mod.f90 | 2 +- src/gsi/general_commvars_mod.f90 | 20 +- src/gsi/general_read_fv3atm.f90 | 3 +- src/gsi/general_read_gfsatm.f90 | 33 +- src/gsi/general_read_nemsaero.f90 | 3 +- src/gsi/general_spectral_transforms.f90 | 13 +- src/gsi/general_sub2grid_mod.f90 | 4 +- src/gsi/gengrid_vars.f90 | 4 +- src/gsi/gesinfo.F90 | 11 +- src/gsi/get_gefs_ensperts_dualres.f90 | 4 +- src/gsi/get_gefs_for_regional.f90 | 10 +- src/gsi/get_nmmb_ensperts.f90 | 2 +- src/gsi/gfs_stratosphere.f90 | 12 +- src/gsi/grdcrd.f90 | 4 +- src/gsi/gsd_update_mod.f90 | 2 +- src/gsi/gsdcloudlib_pseudoq_mod.f90 | 6 +- src/gsi/guess_grids.F90 | 6 +- src/gsi/hdraobmod.f90 | 2 +- src/gsi/hybrid_ensemble_isotropic.F90 | 2 +- src/gsi/intjcmod.f90 | 4 +- src/gsi/intrp2a.f90 | 12 +- src/gsi/m_berror_stats.f90 | 4 +- src/gsi/m_extOzone.F90 | 4 +- src/gsi/mod_fv3_lola.f90 | 4 +- src/gsi/mod_vtrans.f90 | 2 +- src/gsi/mod_wrfmass_to_a.f90 | 6 +- src/gsi/mp_compact_diffs_mod1.f90 | 24 +- src/gsi/ncepgfs_ghg.f90 | 4 +- src/gsi/ncepgfs_io.f90 | 10 +- src/gsi/ncepnems_io.f90 | 19 +- src/gsi/netcdfgfs_io.f90 | 4 +- src/gsi/nlmsas_ad.f90 | 6 +- src/gsi/polcarf.f90 | 4 +- src/gsi/prewgt.f90 | 4 +- src/gsi/prewgt_reg.f90 | 12 +- src/gsi/q_diag.f90 | 2 +- src/gsi/radinfo.f90 | 6 +- src/gsi/raflib.f90 | 4 +- src/gsi/rdgrbsst.f90 | 8 +- src/gsi/read_airs.f90 | 2 +- src/gsi/read_amsr2.f90 | 2 +- src/gsi/read_atms.f90 | 8 +- src/gsi/read_bufrtovs.f90 | 6 +- src/gsi/read_cris.f90 | 8 +- src/gsi/read_dbz_netcdf.f90 | 460 ++++++++++----------- src/gsi/read_files.f90 | 19 +- src/gsi/read_gfs_ozone_for_regional.f90 | 4 +- src/gsi/read_gmi.f90 | 6 +- src/gsi/read_goesglm.f90 | 34 +- src/gsi/read_goesndr.f90 | 2 +- src/gsi/read_iasi.f90 | 6 +- src/gsi/read_lidar.f90 | 2 +- src/gsi/read_nsstbufr.f90 | 2 +- src/gsi/read_ozone.f90 | 4 +- src/gsi/read_pblh.f90 | 2 +- src/gsi/read_prepbufr.f90 | 2 +- src/gsi/read_radar_wind_ascii.f90 | 242 +++++------ src/gsi/read_saphir.f90 | 10 +- src/gsi/read_wcpbufr.f90 | 2 +- src/gsi/reorg_metar_cloud.f90 | 10 +- src/gsi/rfdpar.f90 | 2 +- src/gsi/satthin.F90 | 4 +- src/gsi/setupbend.f90 | 6 +- src/gsi/setupdw.f90 | 4 +- src/gsi/setuplag.f90 | 2 +- src/gsi/setuplight.f90 | 2 +- src/gsi/setupoz.f90 | 6 +- src/gsi/setuppcp.f90 | 4 +- src/gsi/setupq.f90 | 2 +- src/gsi/setupref.f90 | 6 +- src/gsi/setupspd.f90 | 2 +- src/gsi/setupt.f90 | 6 +- src/gsi/setuptcp.f90 | 4 +- src/gsi/setupw.f90 | 4 +- src/gsi/setupwspd10m.f90 | 2 +- src/gsi/sfcobsqc.f90 | 2 +- src/gsi/smoothzrf.f90 | 2 +- src/gsi/ssmis_spatial_average_mod.f90 | 2 +- src/gsi/statsco.f90 | 8 +- src/gsi/statsconv.f90 | 74 ++-- src/gsi/statsoz.f90 | 4 +- src/gsi/statspcp.f90 | 2 +- src/gsi/statsrad.f90 | 2 +- src/gsi/stpjcmod.f90 | 2 +- src/gsi/support_2dvar.f90 | 22 +- src/gsi/tcv_mod.f90 | 8 +- src/gsi/tintrp2a.f90 | 16 +- src/gsi/tintrp3.f90 | 12 +- src/gsi/wind_fft.f90 | 8 +- src/gsi/write_fv3_spread.f90 | 6 +- src/gsi/write_incr.f90 | 6 +- 111 files changed, 817 insertions(+), 803 deletions(-) diff --git a/src/gsi/aniso_ens_util.f90 b/src/gsi/aniso_ens_util.f90 index f118bee40f..43f81216e4 100644 --- a/src/gsi/aniso_ens_util.f90 +++ b/src/gsi/aniso_ens_util.f90 @@ -122,8 +122,8 @@ subroutine ens_uv_to_psichi(u,v,truewind) do j=1,nlon rlon=region_lon(i,j) rlat=region_lat(i,j) - dlon=float(j)*one - dlat=float(i)*one + dlon=real(j,r_kind) + dlat=real(i,r_kind) ue=u(i,j) ve=v(i,j) call rotate_wind_ll2xy(ue,ve,ug,vg,rlon,dlon,dlat) @@ -440,13 +440,13 @@ subroutine ens_intpcoeffs_reg(ngrds,igbox,iref,jref,igbox0f,ensmask,enscoeff,gbl yg=rlat+90._r_kind+one end if - dxg=xg-float(floor(xg)) - dyg=yg-float(floor(yg)) + dxg=xg-real(floor(xg),r_kind) + dyg=yg-real(floor(yg),r_kind) dxg1=one-dxg dyg1=one-dyg - if (xg>=one .and. xg<=float(jxp) .and. & - yg>=one .and. yg<=float(iy) ) then + if (xg>=one .and. xg<=real(jxp,r_kind) .and. & + yg>=one .and. yg<=real(iy,r_kind) ) then enscoeff(1,i,j,kg)=dxg1*dyg1 enscoeff(2,i,j,kg)=dxg1*dyg @@ -479,9 +479,9 @@ subroutine ens_intpcoeffs_reg(ngrds,igbox,iref,jref,igbox0f,ensmask,enscoeff,gbl endif do j=1,iy - yg=float(j)*one + yg=real(j,r_kind) do i=1,jx - xg=float(i)*one + xg=real(i,r_kind) call w3fb12(xg,yg,alat1,elon1,ds,elonv,alatan,rlat,rlon,ierr8) rlon=rlon/rad2deg rlat=rlat/rad2deg @@ -620,34 +620,34 @@ subroutine ens_intpcoeffs_reg(ngrds,igbox,iref,jref,igbox0f,ensmask,enscoeff,gbl igbox(2,kg)=iimax0(kg) igbox(3,kg)=jjmin0(kg) igbox(4,kg)=jjmax0(kg) - igbox0f(1,kg)=one+float((igbox(1,kg)-1))/pf2aP1%grid_ratio_lat + ijadjust - igbox0f(2,kg)=one+float((igbox(2,kg)-1))/pf2aP1%grid_ratio_lat - ijadjust - igbox0f(3,kg)=one+float((igbox(3,kg)-1))/pf2aP1%grid_ratio_lon + ijadjust - igbox0f(4,kg)=one+float((igbox(4,kg)-1))/pf2aP1%grid_ratio_lon - ijadjust + igbox0f(1,kg)=one+real(igbox(1,kg)-1,r_kind)/pf2aP1%grid_ratio_lat + ijadjust + igbox0f(2,kg)=one+real(igbox(2,kg)-1,r_kind)/pf2aP1%grid_ratio_lat - ijadjust + igbox0f(3,kg)=one+real(igbox(3,kg)-1,r_kind)/pf2aP1%grid_ratio_lon + ijadjust + igbox0f(4,kg)=one+real(igbox(4,kg)-1,r_kind)/pf2aP1%grid_ratio_lon - ijadjust end do !==> compute blending functions do i=1,pf2aP1%nlatf - dist1=float(igbox0f(1,1)-i) - dist2=float(i-igbox0f(2,1)) + dist1=real(igbox0f(1,1)-i,r_kind) + dist2=real(i-igbox0f(2,1),r_kind) gblend_b(i,1)=half*(one-tanh(dist1)) !relax to zero gblend_t(i,1)=half*(one-tanh(dist2)) !outside 212 grid - dist1=float(igbox0f(1,2)-i) - dist2=float(i-igbox0f(2,2)) + dist1=real(igbox0f(1,2)-i,r_kind) + dist2=real(i-igbox0f(2,2),r_kind) gblend_b(i,2)=half*(one-tanh(dist1)) !relax to zero gblend_t(i,2)=half*(one-tanh(dist2)) !outside 221 grid end do do j=1,pf2aP1%nlonf - dist1=float(igbox0f(3,1)-j) - dist2=float(j-igbox0f(4,1)) + dist1=real(igbox0f(3,1)-j,r_kind) + dist2=real(j-igbox0f(4,1),r_kind) gblend_l(j,1)=half*(one-tanh(dist1)) !relax to zero gblend_r(j,1)=half*(one-tanh(dist2)) !outside 212 grid - dist1=float(igbox0f(3,2)-j) - dist2=float(j-igbox0f(4,2)) + dist1=real(igbox0f(3,2)-j,r_kind) + dist2=real(j-igbox0f(4,2),r_kind) gblend_l(j,2)=half*(one-tanh(dist1)) !relax to zero gblend_r(j,2)=half*(one-tanh(dist2)) !outside 221 grid end do @@ -1141,10 +1141,10 @@ subroutine ens_fill(ur,na,nb,u,nxx,ny,itap,no_wgt_in) no_wgt=.false. if(no_wgt_in) no_wgt=.true. - pionp1=four*atan(one)/float(itap+1) + pionp1=four*atan(one)/real(itap+1,r_kind) do i=1,itap - xi=float(i) + xi=real(i,r_kind) wt(i)=half+half*cos(pionp1*xi) enddo diff --git a/src/gsi/anisofilter.f90 b/src/gsi/anisofilter.f90 index ec05d191ba..c05c764a05 100755 --- a/src/gsi/anisofilter.f90 +++ b/src/gsi/anisofilter.f90 @@ -596,7 +596,7 @@ subroutine anprewgt_reg(mype) do i=indices%ips,indices%ipe l =max(min(int(rllatf(i,j)),mlat),1) lp=min((l+1),mlat) - dl2=rllatf(i,j)-float(l) + dl2=rllatf(i,j)-real(l,r_kind) dl1=one-dl2 if (ivar <= nrf) then if (nrf_3d(ivar)) then @@ -1056,7 +1056,7 @@ subroutine get_aspect_reg_pt(mype) asp3=scalex3*asp3 endif - rk1=float(k1-44) + rk1=real(k1-44,r_kind) fblend=half*(one-tanh(rk1))! one if (nvar_id(k) /= nrf3_loc(nrf3_q)) then @@ -1126,7 +1126,7 @@ subroutine fact_qopt2(factk,rh,kvar) d =20.0_r_kind * rh + one n =int(d) np =n+1 - dn2=d-float(n) + dn2=d-real(n,r_kind) dn1=one-dn2 n =min0(max(1,n) ,25) np=min0(max(1,np),25) @@ -2407,7 +2407,7 @@ subroutine read_bckgstats(mype) do k=1,nsig vzimax(k,n)=maxval(one/vz(k,0:mlat+1,n)) vzimin(k,n)=minval(one/vz(k,0:mlat+1,n)) - vziavg(k,n)=sum((one/vz(k,0:mlat+1,n)))/float(mlat+2) + vziavg(k,n)=sum((one/vz(k,0:mlat+1,n)))/real(mlat+2,r_kind) end do if(print_verbose) then do k=1,nsig @@ -2428,13 +2428,13 @@ subroutine read_bckgstats(mype) do n=1,nrf3 do k=1,nsig - corzavg(k,n)=sum(corz(1:mlat,k,n))/float(mlat) - hwllavg(k,n)=sum(hwll(0:mlat+1,k,n))/float(mlat+2) + corzavg(k,n)=sum(corz(1:mlat,k,n))/real(mlat,r_kind) + hwllavg(k,n)=sum(hwll(0:mlat+1,k,n))/real(mlat+2,r_kind) end do end do do n=1,nvars-nrf3 - corpavg(n)=sum(corp(1:mlat,n))/float(mlat) - hwllpavg(n)=sum(hwllp(0:mlat+1,n))/float(mlat+2) + corpavg(n)=sum(corp(1:mlat,n))/real(mlat,r_kind) + hwllpavg(n)=sum(hwllp(0:mlat+1,n))/real(mlat+2,r_kind) end do do j=1,mlat @@ -2869,7 +2869,7 @@ subroutine isotropic_scales(scale1,scale2,scale3,k) else l =max(min(int(rllatf(i,j)),mlat),1) lp=min((l+1),mlat) - dl2=rllatf(i,j)-float(l) + dl2=rllatf(i,j)-real(l,r_kind) dl1=one-dl2 hwll_loc=dl1*hwll(l,k1,n)+dl2*hwll(lp,k1,n) end if @@ -2886,7 +2886,7 @@ subroutine isotropic_scales(scale1,scale2,scale3,k) l =max(min(int(rllatf(i,j)),mlat),1) lp=min((l+1),mlat) - dl2=rllatf(i,j)-float(l) + dl2=rllatf(i,j)-real(l,r_kind) dl1=one-dl2 hwll_loc=cc*(dl1*hwllp(l,n)+dl2*hwllp(lp,n)) scale3(i,j)=one @@ -2903,7 +2903,7 @@ subroutine isotropic_scales(scale1,scale2,scale3,k) l =max(min(int(rllatf(i,j)),mlat),1) lp=min((l+1),mlat) - dl2=rllatf(i,j)-float(l) + dl2=rllatf(i,j)-real(l,r_kind) dl1=one-dl2 hwll_loc=cc*(dl1*hwllp(l,nn)+dl2*hwllp(lp,nn)) scale3(i,j)=one @@ -3027,7 +3027,7 @@ subroutine get_theta_corrl_lenghts(mype) mcount0=lon2*lat2! It's OK to count buffer points call mpi_allreduce(pbar4a,pbar4(k),1,mpi_real8,mpi_sum,mpi_comm_world,ierror) call mpi_allreduce(mcount0,mcount,1,mpi_integer4,mpi_sum,mpi_comm_world,ierror) - pbar4(k)=pbar4(k)/float(mcount) + pbar4(k)=pbar4(k)/real(mcount,r_kind) if(print_verbose) write(6,*)'in get_theta_corrl_lenghts,k,pbar4=',k,pbar4(k) call w3fa03(pbar4(k),hgt4(k),tbar4(k),thetabar4(k)) end do @@ -3881,15 +3881,15 @@ subroutine get_aspect_reg_ens(mype) do j=1,pf2aP1%nlonf do i=1,pf2aP1%nlatf - ensv(i,j,k,1)=(ensv(i,j,k,1)+ensv(i,j,k,2)+ensv(i,j,k,3))/sqrt(float(nt1)) - ensv(i,j,k,2)= (ensv(i,j,k,2)+ensv(i,j,k,3))/sqrt(float(nt2)) - ensv(i,j,k,3)= ensv(i,j,k,3) /sqrt(float(nt3)) + ensv(i,j,k,1)=(ensv(i,j,k,1)+ensv(i,j,k,2)+ensv(i,j,k,3))/sqrt(real(nt1,r_kind)) + ensv(i,j,k,2)= (ensv(i,j,k,2)+ensv(i,j,k,3))/sqrt(real(nt2,r_kind)) + ensv(i,j,k,3)= ensv(i,j,k,3) /sqrt(real(nt3,r_kind)) if( ibldani==0 .or. ibldani==2 .or. ibldani==3 ) then do m=1,6 - c(m,1)=(aniasp(m,i,j,k,1)+aniasp(m,i,j,k,2)+aniasp(m,i,j,k,3))/float(nt1) - c(m,2)= (aniasp(m,i,j,k,2)+aniasp(m,i,j,k,3))/float(nt2) - c(m,3)= aniasp(m,i,j,k,3) /float(nt3) + c(m,1)=(aniasp(m,i,j,k,1)+aniasp(m,i,j,k,2)+aniasp(m,i,j,k,3))/real(nt1,r_kind) + c(m,2)= (aniasp(m,i,j,k,2)+aniasp(m,i,j,k,3))/real(nt2,r_kind) + c(m,3)= aniasp(m,i,j,k,3) /real(nt3,r_kind) end do do igd=1,3 qlx=max(qlxmin(ivar,k1),ensv(i,j,k,igd)) @@ -3906,9 +3906,9 @@ subroutine get_aspect_reg_ens(mype) end do else if(ibldani==1) then do m=1,6 - aniasp(m,i,j,k,1)=(aniasp(m,i,j,k,1)+aniasp(m,i,j,k,2)+aniasp(m,i,j,k,3))/float(nt1) - aniasp(m,i,j,k,2)= (aniasp(m,i,j,k,2)+aniasp(m,i,j,k,3))/float(nt2) - aniasp(m,i,j,k,3)= aniasp(m,i,j,k,3) /float(nt3) + aniasp(m,i,j,k,1)=(aniasp(m,i,j,k,1)+aniasp(m,i,j,k,2)+aniasp(m,i,j,k,3))/real(nt1,r_kind) + aniasp(m,i,j,k,2)= (aniasp(m,i,j,k,2)+aniasp(m,i,j,k,3))/real(nt2,r_kind) + aniasp(m,i,j,k,3)= aniasp(m,i,j,k,3) /real(nt3,r_kind) end do smax=real(maxval(ensv(i,j,k,1:3)),r_kind) aensv(1,k)=aensv(1,k)+max(smax ,qlxmin(ivar,k1))/nlatlonf @@ -5326,7 +5326,7 @@ subroutine get2berr_reg_subdomain_option(mype) l=max(min(int(rllatf(i,j)),mlat),1) lp=min((l+1),mlat) - dl2=rllatf(i,j)-float(l) + dl2=rllatf(i,j)-real(l,r_kind) dl1=one-dl2 if (ivar <= nrf) then if (nrf_3d(ivar)) then @@ -6520,7 +6520,7 @@ subroutine isotropic_scales_subdomain_option(scale1,scale2,scale3,k,mype) else l=int(rllat(iglob,jglob)) lp=l+1 - dl2=rllat(iglob,jglob)-float(l) + dl2=rllat(iglob,jglob)-real(l,r_kind) dl1=one-dl2 hwll_loc=dl1*hwll(l,k1,n)+dl2*hwll(lp,k1,n) scale3(i,j)=one/vz(k1,l,n) @@ -6536,7 +6536,7 @@ subroutine isotropic_scales_subdomain_option(scale1,scale2,scale3,k,mype) l=int(rllat(iglob,jglob)) lp=l+1 - dl2=rllat(iglob,jglob)-float(l) + dl2=rllat(iglob,jglob)-real(l,r_kind) dl1=one-dl2 hwll_loc=cc*(dl1*hwllp(l,n)+dl2*hwllp(lp,n)) scale3(i,j)=one @@ -6553,7 +6553,7 @@ subroutine isotropic_scales_subdomain_option(scale1,scale2,scale3,k,mype) l=int(rllat(iglob,jglob)) lp=l+1 - dl2=rllat(iglob,jglob)-float(l) + dl2=rllat(iglob,jglob)-real(l,r_kind) dl1=one-dl2 hwll_loc=cc*(dl1*hwllp(l,nn)+dl2*hwllp(lp,nn)) scale3(i,j)=one diff --git a/src/gsi/anisofilter_glb.f90 b/src/gsi/anisofilter_glb.f90 index 43e67a3baa..f79b26ab79 100644 --- a/src/gsi/anisofilter_glb.f90 +++ b/src/gsi/anisofilter_glb.f90 @@ -609,7 +609,7 @@ subroutine get_stat_factk(platf,ivar,kvar,factk,rh,dvsst) l =int(platf) lp=l+1 - dl2=platf-float(l) + dl2=platf-real(l,r_kind) dl1=one-dl2 l = min(max(1,l ),mlat) lp= min(max(1,lp),mlat) @@ -971,7 +971,7 @@ subroutine read_bckgstats_glb(mype) mcount0=lon2*lat2! It's OK to count buffer points call mpi_allreduce(pbar4a,pbar4(k),1,mpi_real8,mpi_sum,mpi_comm_world,ierror) call mpi_allreduce(mcount0,mcount,1,mpi_integer4,mpi_sum,mpi_comm_world,ierror) - pbar4(k)=pbar4(k)/float(mcount) + pbar4(k)=pbar4(k)/real(mcount,r_kind) end do psfc015=r015*pbar4(1) @@ -1160,7 +1160,7 @@ subroutine get_background_glb(mype) do ilat=1,pf2aP2%nlatf do ilon=1,pf2aP2%nlonf - if(((float(ilat)-rnf2)**2+(float(ilon)-rnf2)**2)>=rnf212) then + if(((real(ilat,r_kind)-rnf2)**2+(real(ilon,r_kind)-rnf2)**2)>=rnf212) then p2ilatf(ilat,ilon)=zero p3ilatf(ilat,ilon)=zero else @@ -1611,7 +1611,7 @@ subroutine get_aspect_pt(mype) cvar=='vp' .or. cvar=='VP' .or. & cvar=='t' .or. cvar=='T' - rk1=float(k1-kthres) + rk1=real(k1-kthres,r_kind) fblend=half*(one-tanh(rk1)) !--- zonal patch @@ -1757,7 +1757,7 @@ subroutine get_theta_corrl_lenghts_glb(mype) mcount0=lon2*lat2! It's OK to count buffer points call mpi_allreduce(pbar4a,pbar4(k),1,mpi_real8,mpi_sum,mpi_comm_world,ierror) call mpi_allreduce(mcount0,mcount,1,mpi_integer4,mpi_sum,mpi_comm_world,ierror) - pbar4(k)=pbar4(k)/float(mcount) + pbar4(k)=pbar4(k)/real(mcount,r_kind) call w3fa03(pbar4(k),hgt4(k),tbar4(k),thetabar4(k)) end do @@ -2605,9 +2605,9 @@ subroutine get_aspect_ens(mype) nt1=max(1,(nens(k)-1)) - s1=maxval(ensv_p0(:,:,k))/float(nt1) - s2=maxval(ensv_p2(:,:,k))/float(nt1) - s3=maxval(ensv_p3(:,:,k))/float(nt1) + s1=maxval(ensv_p0(:,:,k))/real(nt1,r_kind) + s2=maxval(ensv_p2(:,:,k))/real(nt1,r_kind) + s3=maxval(ensv_p3(:,:,k))/real(nt1,r_kind) smax=max(s1,s2,s3) if ( nkflag(k)==1 ) then @@ -3729,13 +3729,13 @@ subroutine ens_intpglb_coeff(iref,jref,enscoeff,mype) xg=rlon+one yg=rlat+90._r_kind+one - dxg =xg-float(floor(xg)) - dyg =yg-float(floor(yg)) + dxg =xg-real(floor(xg),r_kind) + dyg =yg-real(floor(yg),r_kind) dxg1=one-dxg dyg1=one-dyg - if (xg >= one .and. xg <= float(jxp) .and. & - yg >= one .and. yg <= float(iy) ) then + if (xg >= one .and. xg <= real(jxp,r_kind) .and. & + yg >= one .and. yg <= real(iy,r_kind) ) then enscoeff(1,i,j)=dxg1*dyg1 enscoeff(2,i,j)=dxg1*dyg enscoeff(3,i,j)=dxg *dyg1 @@ -3938,7 +3938,7 @@ subroutine ens_uv2psichi(work1,work2) vor_s = vor_s + grid_vor( 1,ix) vor_n = vor_n + grid_vor(ny,ix) end do - rnlon = one/float(nlon) + rnlon = one/real(nlon,r_kind) div_s = div_s*rnlon div_n = div_n*rnlon vor_s = vor_s*rnlon diff --git a/src/gsi/atms_spatial_average_mod.f90 b/src/gsi/atms_spatial_average_mod.f90 index b3e4aafc41..639bb8c99c 100644 --- a/src/gsi/atms_spatial_average_mod.f90 +++ b/src/gsi/atms_spatial_average_mod.f90 @@ -841,7 +841,7 @@ SUBROUTINE SFFTCB( X, N, M ) END DO J = J + K 104 CONTINUE - XT = 1.0_r_kind / FLOAT( N ) + XT = 1.0_r_kind / real( N,r_kind ) DO 99, I = 1, N X(I) = XT * X(I) 99 CONTINUE diff --git a/src/gsi/balmod.f90 b/src/gsi/balmod.f90 index 1b9fa9030b..1408530a3f 100644 --- a/src/gsi/balmod.f90 +++ b/src/gsi/balmod.f90 @@ -443,7 +443,7 @@ subroutine prebal_reg(cwcoveqqcov) do i=1,lat2 l=int(rllat1(i,j)) l2=min0(l+1,llmax) - dl2=rllat1(i,j)-float(l) + dl2=rllat1(i,j)-real(l,r_kind) dl1=one-dl2 bvk(i,j,k)=dl1*bvi(l,k)+dl2*bvi(l2,k) end do @@ -465,7 +465,7 @@ subroutine prebal_reg(cwcoveqqcov) do i=1,lat2 l=int(rllat1(i,j)) l2=min0(l+1,llmax) - dl2=rllat1(i,j)-float(l) + dl2=rllat1(i,j)-real(l,r_kind) dl1=one-dl2 agvk(i,j,m,k)=dl1*agvi(l,m,k)+dl2*agvi(l2,m,k) end do @@ -477,7 +477,7 @@ subroutine prebal_reg(cwcoveqqcov) do i=1,lat2 l=int(rllat1(i,j)) l2=min0(l+1,llmax) - dl2=rllat1(i,j)-float(l) + dl2=rllat1(i,j)-real(l,r_kind) dl1=one-dl2 wgvk(i,j,k)=dl1*wgvi(l,k)+dl2*wgvi(l2,k) end do @@ -972,7 +972,7 @@ subroutine locatelat_reg(mype) do j=1,nlon do i=1,nlat if(region_lat(i,j)>=clat_avn(mlat))then - rllat(i,j)=float(mlat) + rllat(i,j)=real(mlat,r_kind) llmax=max0(mlat,llmax) llmin=min0(mlat,llmin) else if(region_lat(i,j)=clat_avn(m)).and. & (region_lat(i,j) 0)then - skip2=float(npe)/float(nskip) + skip2=real(npe,r_kind)/real(nskip,r_kind) point=zero do i=1,nskip ipoint=min(max(0,nint(point)),npe) @@ -878,7 +878,7 @@ subroutine general_deter_subdomain_nolayout(npe,mype,nlat,nlon,regional, & ! Compute number of points on full grid and target number of ! point per mpi task (pe) npts=nlat*nlon - anperpe=float(npts)/float(npe) + anperpe=real(npts,r_kind)/real(npe,r_kind) ! Start with square subdomains nrnc=sqrt(anperpe) diff --git a/src/gsi/gengrid_vars.f90 b/src/gsi/gengrid_vars.f90 index a2d352c0b3..adbf510313 100644 --- a/src/gsi/gengrid_vars.f90 +++ b/src/gsi/gengrid_vars.f90 @@ -60,13 +60,13 @@ subroutine gengrid_vars ! This is global run, so get global lons, lats, wgtlats, wgtfactlats ! Set local constants - anlon=float(nlon) + anlon=real(nlon,r_kind) pih=half*pi dlon=two*pi/anlon ! Load grid lat,lon arrays. rbs2 is used in pcp. do i=1,nlon - rlons(i)=float(i-1)*dlon + rlons(i)=real(i-1,r_kind)*dlon coslon(i)=cos(rlons(i)) sinlon(i)=sin(rlons(i)) end do diff --git a/src/gsi/gesinfo.F90 b/src/gsi/gesinfo.F90 index 0aefd34c76..9d287de414 100644 --- a/src/gsi/gesinfo.F90 +++ b/src/gsi/gesinfo.F90 @@ -62,7 +62,8 @@ subroutine gesinfo ! nfsecondn FCST Secs (i_kind) numerator ! nfsecondd FCST Secs (i_kind) denominator ! -! %fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 +! %fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + & +! real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600 ! ! attributes: ! language: f90 @@ -312,8 +313,8 @@ subroutine gesinfo nfhour, nfminute, nfsecondn, nfsecondd call stop2(99) endif - gfshead%fhour = float(nfhour) + float(nfminute)/r60 + & - float(nfsecondn)/float(nfsecondd)/r3600 + gfshead%fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + & + real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600 gfshead%idate(1) = idate(4) !hour gfshead%idate(3) = idate(3) !day @@ -551,7 +552,7 @@ subroutine gesinfo ida(:)=0 jda(:)=0 fha(:)=zero - fha(2)=-float(int(min_offset/60)) + fha(2)=-real(int(min_offset/60),r_kind) fha(3)=-(min_offset+fha(2)*r60) ida(1:3)=iadate(1:3) ida(5:6)=iadate(4:5) @@ -582,7 +583,7 @@ subroutine gesinfo ! Get time offset call time_4dvar(ianldate,time_offset) #ifdef RR_CLOUDANALYSIS - fha(2)=float(int(min_offset/60)) + fha(2)=real(int(min_offset/60),r_kind) fha(3)=(min_offset-fha(2)*r60) time_offset=time_offset+fha(3)/r60 #endif diff --git a/src/gsi/get_gefs_ensperts_dualres.f90 b/src/gsi/get_gefs_ensperts_dualres.f90 index bb5ee374af..ca551efa21 100644 --- a/src/gsi/get_gefs_ensperts_dualres.f90 +++ b/src/gsi/get_gefs_ensperts_dualres.f90 @@ -123,7 +123,7 @@ subroutine get_gefs_ensperts_dualres im=en_perts(1,1,1)%grid%im jm=en_perts(1,1,1)%grid%jm km=en_perts(1,1,1)%grid%km - bar_norm = one/float(n_ens) + bar_norm = one/real(n_ens,r_kind) sig_norm=sqrt(one/max(one,n_ens-one)) ! Create temporary communication information for read ensemble routines @@ -444,7 +444,7 @@ subroutine ens_spread_dualres(en_bar,ibin) call stop2(999) endif - sp_norm=(one/float(n_ens)) + sp_norm=(one/real(n_ens,r_kind)) sube%values=zero do n=1,n_ens diff --git a/src/gsi/get_gefs_for_regional.f90 b/src/gsi/get_gefs_for_regional.f90 index 43a88ef300..cc5e0a2c86 100644 --- a/src/gsi/get_gefs_for_regional.f90 +++ b/src/gsi/get_gefs_for_regional.f90 @@ -304,8 +304,8 @@ subroutine get_gefs_for_regional if (nframe /= 0) call error_msg(trim(my_name),trim(filename),'nframe', & 'getfilehead',istop,nframe) - fhour = float(nfhour) + float(nfminute)/r60 + & - float(nfsecondn)/float(nfsecondd)/r3600 + fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + & + real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600 nlat_gfs=latb+2 nlon_gfs=lonb @@ -897,8 +897,8 @@ subroutine get_gefs_for_regional iimin=min(ii,iimin) jjmax=max(jj,jjmax) jjmin=min(jj,jjmin) - dlon_ens=float(jj) - dlat_ens=float(ii) + dlon_ens=real(jj,r_kind) + dlat_ens=real(ii,r_kind) dlon=one+(dlon_ens-one)*ratio_x dlat=one+(dlat_ens-one)*ratio_y call rotate_wind_ll2xy(work_sub(1,i,j,ku),work_sub(1,i,j,kv), & @@ -992,7 +992,7 @@ subroutine get_gefs_for_regional end do ! Convert to mean - bar_norm = one/float(n_ens_gfs) + bar_norm = one/real(n_ens_gfs,r_kind) do k=1,grd_mix%nsig do j=1,grd_mix%lon2 do i=1,grd_mix%lat2 diff --git a/src/gsi/get_nmmb_ensperts.f90 b/src/gsi/get_nmmb_ensperts.f90 index ece1780c03..4dc3254ccd 100644 --- a/src/gsi/get_nmmb_ensperts.f90 +++ b/src/gsi/get_nmmb_ensperts.f90 @@ -313,7 +313,7 @@ subroutine get_nmmb_ensperts end do ! end do over ensemble ! Convert to mean - bar_norm = one/float(n_ens) + bar_norm = one/real(n_ens,r_kind) en_bar%values=en_bar%values*bar_norm ! Copy pbar to module array. ps_bar may be needed for vertical localization diff --git a/src/gsi/gfs_stratosphere.f90 b/src/gsi/gfs_stratosphere.f90 index 22581b2db0..6014045c76 100644 --- a/src/gsi/gfs_stratosphere.f90 +++ b/src/gsi/gfs_stratosphere.f90 @@ -308,8 +308,8 @@ subroutine mix_gfs_nmmb_vcoords(deta1 ,aeta1 ,eta1 ,deta2 ,aeta2 ,eta2 ,pdtop,pt if (nframe /= 0) call error_msg(trim(my_name),trim(filename),'nframe', & 'getfilehead',istop,nframe) - fhour = float(nfhour) + float(nfminute)/r60 + & - float(nfsecondn)/float(nfsecondd)/r3600 + fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + & + real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600 write(6,*) ' input filename=',filename write(6,*) ' nemsio head: fhour,idate=',fhour,idate write(6,*) ' nemsio head: levs=',levs @@ -1183,8 +1183,8 @@ subroutine add_gfs_stratosphere if ( nframe /= 0 ) call error_msg(trim(my_name),trim(filename),'nframe', & 'getfilehead',istop,nframe) - fhour = float(nfhour) + float(nfminute)/r60 + & - float(nfsecondn)/float(nfsecondd)/r3600 + fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + & + real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600 if ( mype == 0 ) then write(6,*) ' input filename=',filename write(6,*) ' nemsio head: fhour,idate=',fhour,idate @@ -1545,8 +1545,8 @@ subroutine add_gfs_stratosphere jj=j+grd_mix%jstart(mm1)-2 ii=min(grd_mix%nlat,max(1,ii)) jj=min(grd_mix%nlon,max(1,jj)) - dlon=float(jj) - dlat=float(ii) + dlon=real(jj,r_kind) + dlat=real(ii,r_kind) do k=1,nsig_save xspli_r(k)=log(prsl_r(i,j,k)*ten) enddo diff --git a/src/gsi/grdcrd.f90 b/src/gsi/grdcrd.f90 index c20e02ce7f..bb655fc68b 100644 --- a/src/gsi/grdcrd.f90 +++ b/src/gsi/grdcrd.f90 @@ -63,7 +63,7 @@ subroutine grdcrd(d,nd,x,nx,flg) ix=isrchf(nx-1,x,d(id),flg)-1 end if end if - d(id)=float(ix)+(d(id)-x(ix))/(x(ix+1)-x(ix)) + d(id)=real(ix,r_kind)+(d(id)-x(ix))/(x(ix+1)-x(ix)) end do ! Treat special case of nx=1 @@ -135,7 +135,7 @@ subroutine grdcrd1(d,x,nx,flg) ix=isrchf(nx-1,x,d,flg)-1 end if end if - d=float(ix)+(d-x(ix))/(x(ix+1)-x(ix)) + d=real(ix,r_kind)+(d-x(ix))/(x(ix+1)-x(ix)) ! Treat special case of nx=1 elseif (nx==1) then diff --git a/src/gsi/gsd_update_mod.f90 b/src/gsi/gsd_update_mod.f90 index 7b43f55fb2..35f7663322 100644 --- a/src/gsi/gsd_update_mod.f90 +++ b/src/gsi/gsd_update_mod.f90 @@ -699,7 +699,7 @@ subroutine gsd_gen_coast_prox nip = nip+1 end do end do - hcoast_prox(1,i,j) = float(nco)/float (nip) + hcoast_prox(1,i,j) = real(nco,r_kind)/real(nip,r_kind) end if end do end do diff --git a/src/gsi/gsdcloudlib_pseudoq_mod.f90 b/src/gsi/gsdcloudlib_pseudoq_mod.f90 index b7544a860c..3b04558da7 100644 --- a/src/gsi/gsdcloudlib_pseudoq_mod.f90 +++ b/src/gsi/gsdcloudlib_pseudoq_mod.f90 @@ -192,9 +192,9 @@ SUBROUTINE cloudCover_Surface_col(mype,nsig, & endif ! convert cloud base observation from AGL to ASL - cl_base_ista = float(ocld(6+ic)) + Oelvtn - zh + cl_base_ista = real(ocld(6+ic),r_kind) + Oelvtn - zh if(zh < 1.0_r_kind .and. Oelvtn > 20.0_r_kind & - .and. float(ocld(6+ic)) < 250.0_r_kind) then + .and. real(ocld(6+ic),r_kind) < 250.0_r_kind) then cycle ! limit the use of METAR station over oceas for low cloud base endif @@ -267,7 +267,7 @@ SUBROUTINE cloudCover_Surface_col(mype,nsig, & ! -- Use visibility for low-level cloud whether if (wthr_type < 30 .and. wthr_type > 20 .and. & ocld(13) < 5000 .and. ocld(13) > 1 ) then - betav = 3.912_r_kind / (float(ocld(13)) / 1000._r_kind) + betav = 3.912_r_kind / (real(ocld(13),r_kind) / 1000._r_kind) vis2qc = ( (betav/144.7_r_kind) ** 1.14_r_kind) / 1000._r_kind endif ! cloud or clear diff --git a/src/gsi/guess_grids.F90 b/src/gsi/guess_grids.F90 index bf493a0628..0601959aad 100644 --- a/src/gsi/guess_grids.F90 +++ b/src/gsi/guess_grids.F90 @@ -1783,7 +1783,7 @@ subroutine load_gsdpbl_hgt(mype) k=1 DO while (abs(pbl_height(i,j,jj)) < 0.0001_r_kind) if( thetav(k) > thsfc + 1.0_r_kind ) then - pbl_height(i,j,jj) = float(k) - (thetav(k) - (thsfc + 1.0_r_kind))/ & + pbl_height(i,j,jj) = real(k,r_kind) - (thetav(k) - (thsfc + 1.0_r_kind))/ & max((thetav(k)-thetav(k-1)),0.01_r_kind) endif k=k+1 @@ -2318,7 +2318,7 @@ subroutine guess_grids_stats3d_(name,a,mype) end do end do end do - work_a(nsig+1)=float(lon1*lat1) + work_a(nsig+1)=real(lon1*lat1,r_kind) call mpi_allreduce(work_a,work_a1,nsig+1,mpi_rtype,mpi_sum,& mpi_comm_world,ierror) @@ -2386,7 +2386,7 @@ subroutine guess_grids_stats2d_(name,a,mype) work_a(1) = work_a(1) + a(i,j) end do end do - work_a(2)=float(lon1*lat1) + work_a(2)=real(lon1*lat1,r_kind) call mpi_allreduce(work_a,work_a1,2,mpi_rtype,mpi_sum,& mpi_comm_world,ierror) diff --git a/src/gsi/hdraobmod.f90 b/src/gsi/hdraobmod.f90 index 00abeb66be..c56b400909 100644 --- a/src/gsi/hdraobmod.f90 +++ b/src/gsi/hdraobmod.f90 @@ -580,7 +580,7 @@ subroutine read_hdraob(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! Add obs reference time, then subtract analysis time to get obs ! time relative to analysis - time_correction=float(minobs-minan)*r60inv + time_correction=real(minobs-minan,r_kind)*r60inv else time_correction=zero diff --git a/src/gsi/hybrid_ensemble_isotropic.F90 b/src/gsi/hybrid_ensemble_isotropic.F90 index fc87026c98..4bad129a72 100644 --- a/src/gsi/hybrid_ensemble_isotropic.F90 +++ b/src/gsi/hybrid_ensemble_isotropic.F90 @@ -247,7 +247,7 @@ subroutine init_rf_z(z_len) kap1=rd_over_cp+one kapr=one/rd_over_cp nxy=grd_ens%latlon11 - rnsig=float(nsig) + rnsig=real(nsig,r_kind) ! use new factorization: diff --git a/src/gsi/intjcmod.f90 b/src/gsi/intjcmod.f90 index 2b093312ac..f36e9e4b26 100644 --- a/src/gsi/intjcmod.f90 +++ b/src/gsi/intjcmod.f90 @@ -740,7 +740,7 @@ subroutine intjcpdry(rval,sval,nbins,pjc) it=ntguessig mass=zero_quad - rcon=(one_quad/(two_quad*float(nlon)))**2 + rcon=(one_quad/(two_quad*real(nlon,r_quad)))**2 mm1=mype+1 do n=1,nbins @@ -1020,7 +1020,7 @@ subroutine intjcpdry2(rval,nbins,mass,pjc) integer(i_kind) :: n it=ntguessig - rcon=(one_quad/(two_quad*float(nlon)))**2 + rcon=(one_quad/(two_quad*real(nlon,r_quad)))**2 mm1=mype+1 do n=1,nbins diff --git a/src/gsi/intrp2a.f90 b/src/gsi/intrp2a.f90 index 0d2926b8c7..129b48059f 100644 --- a/src/gsi/intrp2a.f90 +++ b/src/gsi/intrp2a.f90 @@ -56,8 +56,8 @@ subroutine intrp2a(f,g,dx,dy,n,nlevs,mype) ix1=int(dx(i)) iy1=int(dy(i)) ix1=max(1,min(ix1,nlat)) - delx=dx(i)-float(ix1) - dely=dy(i)-float(iy1) + delx=dx(i)-real(ix1,r_kind) + dely=dy(i)-real(iy1,r_kind) delx=max(zero,min(delx,one)) ix=ix1-istart(mm1)+2 iy=iy1-jstart(mm1)+2 @@ -135,8 +135,8 @@ subroutine intrp2a1(f,g,dx,dy,nlevs,mype) ix1=int(dx) iy1=int(dy) ix1=max(1,min(ix1,nlat)) - delx=dx-float(ix1) - dely=dy-float(iy1) + delx=dx-real(ix1,r_kind) + dely=dy-real(iy1,r_kind) delx=max(zero,min(delx,one)) ix=ix1-istart(mm1)+2 iy=iy1-jstart(mm1)+2 @@ -211,8 +211,8 @@ subroutine intrp2a11(f,g,dx,dy,mype) ix1=int(dx) iy1=int(dy) ix1=max(1,min(ix1,nlat)) - delx=dx-float(ix1) - dely=dy-float(iy1) + delx=dx-real(ix1,r_kind) + dely=dy-real(iy1,r_kind) delx=max(zero,min(delx,one)) ix=ix1-istart(mm1)+2 iy=iy1-jstart(mm1)+2 diff --git a/src/gsi/m_berror_stats.f90 b/src/gsi/m_berror_stats.f90 index 808aee9954..088a7619fe 100644 --- a/src/gsi/m_berror_stats.f90 +++ b/src/gsi/m_berror_stats.f90 @@ -646,7 +646,7 @@ subroutine setcoroz_(coroz,mype) enddo enddo enddo - work_oz(nsig+1,mm1)=float(lon1*lat1) + work_oz(nsig+1,mm1)=real(lon1*lat1,r_kind) call mpi_allreduce(work_oz,work_oz1,(nsig+1)*npe,mpi_rtype,mpi_sum,& mpi_comm_world,ierror) @@ -869,7 +869,7 @@ subroutine setcorchem_(cname,corchem,rc) enddo enddo enddo - work_chem(nsig+1,mm1)=float(lon1*lat1) + work_chem(nsig+1,mm1)=real(lon1*lat1,r_kind) call mpi_allreduce(work_chem,work_chem1,(nsig+1)*npe,mpi_rtype,mpi_sum,& mpi_comm_world,ierror) diff --git a/src/gsi/m_extOzone.F90 b/src/gsi/m_extOzone.F90 index a28209292f..bf2b137466 100644 --- a/src/gsi/m_extOzone.F90 +++ b/src/gsi/m_extOzone.F90 @@ -1111,7 +1111,7 @@ subroutine ozlev_ncread_(dfile,dtype,ozout,nmrecs,ndata,nodata, gstime,twind) ozout(8,ndata)=usage ozout(9,ndata)=pob ! pressure ozout(10,ndata)=obserr ! ozone mixing ratio precision in ppmv - ozout(11,ndata)=float(ipos(ilev)) ! pointer of obs level index in ozinfo.txt + ozout(11,ndata)=real(ipos(ilev),r_kind) ! pointer of obs level index in ozinfo.txt ozout(12,ndata)=levs ! # of vertical levels ozout(13,ndata)=ppmv ! ozone mixing ratio in ppmv endif @@ -1424,7 +1424,7 @@ subroutine ozlev_bufrread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, & ozout( 8,ndata)=usage1(k) ! ozout( 9,ndata)=mlspres(k) ! mls pressure in log(cb) ozout(10,ndata)=mlsozpc(k) ! ozone mixing ratio precision in ppmv - ozout(11,ndata)=float(ipos(k)) ! pointer of obs level index in ozinfo.txt + ozout(11,ndata)=real(ipos(k),r_kind) ! pointer of obs level index in ozinfo.txt ozout(12,ndata)=nloz ! # of mls vertical levels ozout(13,ndata)=mlsoz(k) ! ozone mixing ratio in ppmv endif diff --git a/src/gsi/mod_fv3_lola.f90 b/src/gsi/mod_fv3_lola.f90 index 84f8144968..ebe0816c4a 100644 --- a/src/gsi/mod_fv3_lola.f90 +++ b/src/gsi/mod_fv3_lola.f90 @@ -321,10 +321,10 @@ subroutine generate_anl_grid(nx,ny,grid_lon,grid_lont,grid_lat,grid_latt) !!!! define analysis A grid !!!!!!!!!!!!! do j=1,nxa - xa_a(j)=(float(j-nlonh)-cx)*grid_ratio_fv3_regional + xa_a(j)=(real(j-nlonh,r_kind)-cx)*grid_ratio_fv3_regional end do do i=1,nya - ya_a(i)=(float(i-nlath)-cy)*grid_ratio_fv3_regional + ya_a(i)=(real(i-nlath,r_kind)-cy)*grid_ratio_fv3_regional end do !!!!!compute fv3 to A grid interpolation parameters !!!!!!!!! diff --git a/src/gsi/mod_vtrans.f90 b/src/gsi/mod_vtrans.f90 index 3c7d8af8f4..f9538e0735 100644 --- a/src/gsi/mod_vtrans.f90 +++ b/src/gsi/mod_vtrans.f90 @@ -269,7 +269,7 @@ subroutine create_vtrans(mype) ! count: ! Not clear if area weighting would be better. - count=one/float(nlat*nlon) + count=one/real(nlat*nlon,r_kind) ier=0 call gsi_bundlegetpointer (gsi_metguess_bundle(ntguessig),'ps',ges_ps_nt, istatus) diff --git a/src/gsi/mod_wrfmass_to_a.f90 b/src/gsi/mod_wrfmass_to_a.f90 index 716ff37f77..594f128709 100644 --- a/src/gsi/mod_wrfmass_to_a.f90 +++ b/src/gsi/mod_wrfmass_to_a.f90 @@ -312,7 +312,7 @@ subroutine wrfmass_obs_to_a8(obsba,nreal,maxobs,ilat,ilon,numobs) i=int(ria(n)+0.5_r_kind) j=int(rja(n)+0.5_r_kind) - adist=(ria(n)-float(i))*(ria(n)-float(i))+(rja(n)-float(j))*(rja(n)-float(j)) + adist=(ria(n)-real(i,r_kind))**2+(rja(n)-real(j,r_kind))**2 if(adist < dist(i,j)) then dist(i,j)=adist ija(i,j)=n @@ -324,8 +324,8 @@ subroutine wrfmass_obs_to_a8(obsba,nreal,maxobs,ilat,ilon,numobs) do i=1,nxa if(ija(i,j) > 0) then n=n+1 - obsba(ilon,n)=float(i) - obsba(ilat,n)=float(j) + obsba(ilon,n)=real(i,r_kind) + obsba(ilat,n)=real(j,r_kind) do k=3,nreal obsba(k,n)=obsa(k,ija(i,j)) enddo diff --git a/src/gsi/mp_compact_diffs_mod1.f90 b/src/gsi/mp_compact_diffs_mod1.f90 index bb924441b7..292986a56a 100644 --- a/src/gsi/mp_compact_diffs_mod1.f90 +++ b/src/gsi/mp_compact_diffs_mod1.f90 @@ -1550,8 +1550,8 @@ subroutine mp_compact_dlon(b,dbdx,vector) polu=polu+grid3(ix)*coslon(ix) polv=polv+grid3(ix)*sinlon(ix) end do - polu=polu/float(nlon) - polv=polv/float(nlon) + polu=polu/real(nlon,r_kind) + polv=polv/real(nlon,r_kind) do ix=1,nlon grid3pol(ix)=polu*coslon(ix)+polv*sinlon(ix) end do @@ -1673,8 +1673,8 @@ subroutine mp_compact_dlon_ad(b,dbdx,vector) polu=polu+grid3pol(ix)*coslon(ix) polv=polv+grid3pol(ix)*sinlon(ix) end do - polu=polu/float(nlon) - polv=polv/float(nlon) + polu=polu/real(nlon,r_kind) + polv=polv/real(nlon,r_kind) do ix=1,nlon grid3(ix)=grid3(ix)+polu*coslon(ix)+polv*sinlon(ix) end do @@ -1977,8 +1977,8 @@ subroutine mp_uv_pole(u,v) polsu=polsu+u(2,ix,k)*coslon(ix)+v(2,ix,k)*sinlon(ix) polsv=polsv+u(2,ix,k)*sinlon(ix)-v(2,ix,k)*coslon(ix) end do - polsu=polsu/float(nlon) - polsv=polsv/float(nlon) + polsu=polsu/real(nlon,r_kind) + polsv=polsv/real(nlon,r_kind) do ix=1,nlon u(1,ix,k)=polsu*coslon(ix)+polsv*sinlon(ix) v(1,ix,k)=polsu*sinlon(ix)-polsv*coslon(ix) @@ -1993,8 +1993,8 @@ subroutine mp_uv_pole(u,v) polnu=polnu+u(1,ix,k)*coslon(ix)-v(1,ix,k)*sinlon(ix) polnv=polnv+u(1,ix,k)*sinlon(ix)+v(1,ix,k)*coslon(ix) end do - polnu=polnu/float(nlon) - polnv=polnv/float(nlon) + polnu=polnu/real(nlon,r_kind) + polnv=polnv/real(nlon,r_kind) do ix=1,nlon u(2,ix,k)= polnu*coslon(ix)+polnv*sinlon(ix) v(2,ix,k)=-polnu*sinlon(ix)+polnv*coslon(ix) @@ -2055,8 +2055,8 @@ subroutine mp_uv_pole_ad(u,v) u(1,ix,k)=zero v(1,ix,k)=zero end do - polsu=polsu/float(nlon) - polsv=polsv/float(nlon) + polsu=polsu/real(nlon,r_kind) + polsv=polsv/real(nlon,r_kind) do ix=1,nlon u(2,ix,k)=u(2,ix,k)+polsu*coslon(ix)+polsv*sinlon(ix) v(2,ix,k)=v(2,ix,k)+polsu*sinlon(ix)-polsv*coslon(ix) @@ -2073,8 +2073,8 @@ subroutine mp_uv_pole_ad(u,v) u(2,ix,k)=zero v(2,ix,k)=zero end do - polnu=polnu/float(nlon) - polnv=polnv/float(nlon) + polnu=polnu/real(nlon,r_kind) + polnv=polnv/real(nlon,r_kind) do ix=1,nlon u(1,ix,k)=u(1,ix,k)+polnu*coslon(ix)+polnv*sinlon(ix) v(1,ix,k)=v(1,ix,k)-polnu*sinlon(ix)+polnv*coslon(ix) diff --git a/src/gsi/ncepgfs_ghg.f90 b/src/gsi/ncepgfs_ghg.f90 index 6c5fa7bb9d..9b34d8aa6e 100644 --- a/src/gsi/ncepgfs_ghg.f90 +++ b/src/gsi/ncepgfs_ghg.f90 @@ -326,7 +326,7 @@ subroutine read_gfsco2 & do i=1,nmxlon co2diff= co2_sav2(i,j,k)-co2_sav1(i,j,k) co2rate= co2diff/ndmax - co2_Tintrp(i,j,k)= co2_sav1(i,j,k)+ co2rate*float(idd-1) + co2_Tintrp(i,j,k)= co2_sav1(i,j,k)+ co2rate*real(idd-1,r_kind) enddo enddo enddo @@ -558,7 +558,7 @@ subroutine read_ch4n2oco & do i=1,nmaxlon ghgdiff= ghg_sav2(1,j,k)-ghg_sav1(1,j,k) ghgrate= ghgdiff/ndmax - ghg_Tintrp(1,j,k)= ghg_sav1(1,j,k)+ ghgrate*float(idd-1) + ghg_Tintrp(1,j,k)= ghg_sav1(1,j,k)+ ghgrate*real(idd-1,r_kind) enddo enddo enddo diff --git a/src/gsi/ncepgfs_io.f90 b/src/gsi/ncepgfs_io.f90 index 59be6d3925..dd46916039 100644 --- a/src/gsi/ncepgfs_io.f90 +++ b/src/gsi/ncepgfs_io.f90 @@ -2640,9 +2640,9 @@ subroutine write_ens_sfc_nst(mype_so,dsfct) allocate(slatx(jmax),wlatx(jmax)) allocate(rlats_ens_sfc(nlat_ens_sfc),rlons_ens_sfc(nlon_ens_sfc)) call splat(4,jmax,slatx,wlatx) - dlon=two*pi/float(nlon_ens_sfc) + dlon=two*pi/real(nlon_ens_sfc,r_kind) do i=1,nlon_ens_sfc - rlons_ens_sfc(i)=float(i-1)*dlon + rlons_ens_sfc(i)=real(i-1,r_kind)*dlon end do do i=1,(nlat_ens_sfc-1)/2 rlats_ens_sfc(i+1)=-asin(slatx(i)) @@ -3074,9 +3074,9 @@ subroutine write_ens_dsfct(mype_so,dsfct) allocate(slatx(jmax),wlatx(jmax)) allocate(rlats_ens_sfc(nlat_ens_sfc),rlons_ens_sfc(nlon_ens_sfc)) call splat(4,jmax,slatx,wlatx) - dlon=two*pi/float(nlon_ens_sfc) + dlon=two*pi/real(nlon_ens_sfc,r_kind) do i=1,nlon_ens_sfc - rlons_ens_sfc(i)=float(i-1)*dlon + rlons_ens_sfc(i)=real(i-1,r_kind)*dlon end do do i=1,(nlat_ens_sfc-1)/2 rlats_ens_sfc(i+1)=-asin(slatx(i)) @@ -3247,7 +3247,7 @@ subroutine glbave(fld,ave) enddo enddo enddo - xave=xave/(two_quad*float(nlon)) + xave=xave/(two_quad*real(nlon,r_quad)) call mpl_allreduce(size(ave,1),qpvals=xave) ave=xave deallocate(xave) diff --git a/src/gsi/ncepnems_io.f90 b/src/gsi/ncepnems_io.f90 index 73f06ffd07..595f07e152 100755 --- a/src/gsi/ncepnems_io.f90 +++ b/src/gsi/ncepnems_io.f90 @@ -82,7 +82,8 @@ module ncepnems_io ! nfsecondn FCST Secs (i_kind) numerator ! nfsecondd FCST Secs (i_kind) denominator ! -! %fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 +! %fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + & +! real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600 ! ! nframe - nframe is the number of grids extend outward from the ! edge of modeling domain. @@ -835,7 +836,8 @@ subroutine read_atm_ (grd,filename,sp_a,uvflag,vordivflag,zflag, & call stop2(101) end if - fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 + fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + & + real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600 odate(1) = idate(4) !hour odate(2) = idate(2) !month odate(3) = idate(3) !day @@ -1300,7 +1302,8 @@ subroutine read_sfc_(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, & call stop2(102) end if - fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 + fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + & + real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600 odate(1) = idate(4) !hour odate(2) = idate(2) !month odate(3) = idate(3) !day @@ -1699,7 +1702,8 @@ subroutine read_sfc_anl_(isli_anl) call stop2(102) end if - fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 + fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + & + real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600 odate(1) = idate(4) !hour odate(2) = idate(2) !month odate(3) = idate(3) !day @@ -2029,7 +2033,8 @@ subroutine read_nst_ (tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d) call stop2(istop) end if - fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600 + fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + & + real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600 odate(1) = idate(4) !hour odate(2) = idate(2) !month odate(3) = idate(3) !day @@ -5469,8 +5474,8 @@ subroutine tran_gfssfc(ain,aout,lonb,latb) sumn = ain(i,1) + sumn sums = ain(i,latb) + sums end do - sumn = sumn/float(lonb) - sums = sums/float(lonb) + sumn = sumn/real(lonb,r_kind) + sums = sums/real(lonb,r_kind) ! Transfer from local work array to surface guess array do j = 1,lonb aout(1,j)=sums diff --git a/src/gsi/netcdfgfs_io.f90 b/src/gsi/netcdfgfs_io.f90 index 41e8f33e03..8aa6c4cc6a 100644 --- a/src/gsi/netcdfgfs_io.f90 +++ b/src/gsi/netcdfgfs_io.f90 @@ -3202,8 +3202,8 @@ subroutine tran_gfsncsfc(ain,aout,lonb,latb) sumn = ain(i,1) + sumn sums = ain(i,latb) + sums end do - sumn = sumn/float(lonb) - sums = sums/float(lonb) + sumn = sumn/real(lonb,r_kind) + sums = sums/real(lonb,r_kind) ! Transfer from local work array to surface guess array do j = 1,lonb aout(1,j)=sums diff --git a/src/gsi/nlmsas_ad.f90 b/src/gsi/nlmsas_ad.f90 index be8213b340..7ad413aa6b 100644 --- a/src/gsi/nlmsas_ad.f90 +++ b/src/gsi/nlmsas_ad.f90 @@ -707,10 +707,10 @@ subroutine nlmsas_ad_im_ix_(im,ix,km,jcap,delt,del,sl,rcs,& pdpdwn = zero pdetrn = 200._r_kind xlambu = 1.e-4_r_kind - fjcap = (float(jcap) / 126._r_kind) ** 2 + fjcap = (real(jcap,r_kind) / 126._r_kind) ** 2 val = one fjcap = max(fjcap,val) - fkm = (float(km) / 28._r_kind) ** 2 + fkm = (real(km,r_kind) / 28._r_kind) ** 2 fkm = max(fkm,one) w1l = -8.e-3_r_kind w2l = -4.e-2_r_kind @@ -1058,7 +1058,7 @@ subroutine nlmsas_ad_im_ix_(im,ix,km,jcap,delt,del,sl,rcs,& ! Select cloud from ensemble do i=1,im - kt2(i) = nint(xkt2(i)*float(ktcon(i)-jmin(i))-half) + jmin(i) + 1 + kt2(i) = nint(xkt2(i)*real(ktcon(i)-jmin(i),r_kind)-half) + jmin(i) + 1 tem1 = hcko(jmin(i),i) - hesol(kt2(i),i) tem2 = sumz(kt2(i),i) * hesol(kt2(i),i) - sumh(kt2(i),i) if (abs(tem2) > 0.000001_r_kind) then diff --git a/src/gsi/polcarf.f90 b/src/gsi/polcarf.f90 index 4ed450daa1..f2038d9d95 100644 --- a/src/gsi/polcarf.f90 +++ b/src/gsi/polcarf.f90 @@ -617,7 +617,7 @@ subroutine polcas(afg,axr,nxem,norm,naxr,wtaxs,wtxrs,inaxs,inxrs,nf,mr,nr) do i=0,naxr-1 valp=valp+axr(i,mr+1) end do - valp=valp/float(naxr) + valp=valp/real(naxr,r_kind) do i=0,naxr-1 axr(i,mr)=valp end do @@ -692,7 +692,7 @@ subroutine polcasa(afg,axr,nxem,norm,naxr,wtaxs,wtxrs,inaxs,inxrs,nf,mr,nr) do i=0,naxr-1 valp=valp+axr(i,mr) end do - valp=valp/float(naxr) + valp=valp/real(naxr,r_kind) do i=0,naxr-1 axr(i,mr)=zero axr(i,mr+1)=axr(i,mr+1)+valp diff --git a/src/gsi/prewgt.f90 b/src/gsi/prewgt.f90 index 38d61050fe..7f3d2fc091 100644 --- a/src/gsi/prewgt.f90 +++ b/src/gsi/prewgt.f90 @@ -273,7 +273,7 @@ subroutine prewgt(mype) end do do j=1,lon2 do i=1,lat2 - temp(i,j)=float(isli2(i,j)) + temp(i,j)=real(isli2(i,j),r_kind) end do end do @@ -585,7 +585,7 @@ subroutine prewgt(mype) ! rearth_equator is the equatorial radius from a 1999 IAG report. The ! horizontal scales are defined at the equator, hence the need for the ! equatorial radius. - s2u=(two*pi*rearth_equator)/float(nlon) + s2u=(two*pi*rearth_equator)/real(nlon,r_kind) allocate(sli(ny,nx,2,nnnn1o),sli1(-nf:nf,-nf:nf,2,nnnn1o), & diff --git a/src/gsi/prewgt_reg.f90 b/src/gsi/prewgt_reg.f90 index bde1c9dece..1da89a703b 100644 --- a/src/gsi/prewgt_reg.f90 +++ b/src/gsi/prewgt_reg.f90 @@ -452,7 +452,7 @@ subroutine prewgt_reg(mype) d=region_lat(il,jl)*rad2deg+90._r_kind l=int(d) l2=l+1 - dl2=d-float(l) + 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) @@ -581,7 +581,7 @@ subroutine prewgt_reg(mype) do i=1,lon2 l=int(rllat1(j,i)) l2=min0(l+1,llmax) - dl2=rllat1(j,i)-float(l) + dl2=rllat1(j,i)-real(l,r_kind) dl1=one-dl2 do k=1,nsig dssv(j,i,k,n)=dl1*dsv(i,k,l)+dl2*dsv(i,k,l2) @@ -604,7 +604,7 @@ subroutine prewgt_reg(mype) do i=1,lon2 l=int(rllat1(j,i)) l2=min0(l+1,llmax) - dl2=rllat1(j,i)-float(l) + dl2=rllat1(j,i)-real(l,r_kind) dl1=one-dl2 do k=1,nsig dssv(j,i,k,n)=dl1*dsv(i,k,l)+dl2*dsv(i,k,l2) @@ -662,7 +662,7 @@ subroutine prewgt_reg(mype) do i=1,lon2 l=int(rllat1(j,i)) l2=min0(l+1,llmax) - dl2=rllat1(j,i)-float(l) + dl2=rllat1(j,i)-real(l,r_kind) dl1=one-dl2 dssvs(j,i,n)=dl1*dsvs(i,l)+dl2*dsvs(i,l2) if (mvars>=2.and.n==nrf2_sst) then @@ -738,7 +738,7 @@ subroutine prewgt_reg(mype) do j=1,ny l=int(rllat(j,i)) lp=min0(l+1,llmax) - dl2=rllat(j,i)-float(l) + dl2=rllat(j,i)-real(l,r_kind) dl1=one-dl2 fact=one/(dl1*hwll(l,k1,nn)+dl2*hwll(lp,k1,nn)) slw((i-1)*ny+j,k)=slw((i-1)*ny+j,1)*fact**2 @@ -778,7 +778,7 @@ subroutine prewgt_reg(mype) do j=1,ny l=int(rllat(j,i)) lp=min0(l+1,llmax) - dl2=rllat(j,i)-float(l) + dl2=rllat(j,i)-real(l,r_kind) dl1=one-dl2 fact=cc/(dl1*hwllp(l,nn)+dl2*hwllp(lp,nn)) slw((i-1)*ny+j,k)=slw((i-1)*ny+j,1)*fact**2 diff --git a/src/gsi/q_diag.f90 b/src/gsi/q_diag.f90 index 15ef49c6b5..fe5f2f0e94 100644 --- a/src/gsi/q_diag.f90 +++ b/src/gsi/q_diag.f90 @@ -147,7 +147,7 @@ subroutine q_diag(it,mype) call load_grid(work_pw,grid_pw) globps=zero globpw=zero - rlon=one/float(nlon) + rlon=one/real(nlon,r_kind) do jj=2,nlat-1 j=jj-1 fmeanps=zero diff --git a/src/gsi/radinfo.f90 b/src/gsi/radinfo.f90 index ffc4641696..ede58b9bca 100644 --- a/src/gsi/radinfo.f90 +++ b/src/gsi/radinfo.f90 @@ -1454,7 +1454,7 @@ real(r_kind) function rnad_pos(isis,iscan,jch) piece=-0.625_r_kind if (mod(iscan,2) == 1) piece = 0.625_r_kind - rnad_pos=radstart(jch)+radstep(jch)*float((iscan-1)/2)+piece + rnad_pos=radstart(jch)+radstep(jch)*real((iscan-1)/2,r_kind)+piece else @@ -1466,7 +1466,7 @@ real(r_kind) function rnad_pos(isis,iscan,jch) else ifov=iscan end if - rnad_pos=radstart(jch)+radstep(jch)*float(ifov-1) + rnad_pos=radstart(jch)+radstep(jch)*real(ifov-1,r_kind) end if @@ -2034,7 +2034,7 @@ subroutine init_predx tlap2(jj) = tlap0(jj) + tlap1(jj)/tsum(jj) count_tlapmean(jj)=count_tlapmean(jj)+one elseif (tcnt(jj)>0) then - ratio = max(zero,min(tcnt(jj)/float(nthreshold),one)) + ratio = max(zero,min(tcnt(jj)/real(nthreshold,r_kind),one)) tsum(jj)=ratio*tsum(jj)+tsum0(jj) ! tlap2(jj) = tlap0(jj) + ratio*wgtlap*tlap1(jj)/tsum(jj) tlap2(jj) = tlap0(jj) + ratio*tlap1(jj)/tsum(jj) diff --git a/src/gsi/raflib.f90 b/src/gsi/raflib.f90 index 227bda3cb1..eb6d399d21 100644 --- a/src/gsi/raflib.f90 +++ b/src/gsi/raflib.f90 @@ -4488,14 +4488,14 @@ SUBROUTINE EIGEN(A,R,N,MV) end do if(anorm>zero) then ANORM=1.414_r_kind*SQRT(ANORM) - ANRMX=ANORM*RANGE/FLOAT(N) + ANRMX=ANORM*RANGE/real(N,r_kind) ! ! INITIALIZE INDICATORS AND COMPUTE THRESHOLD, THR ! IND=0 THR=ANORM loop1: do - THR=THR/FLOAT(N) + THR=THR/real(N,r_kind) loop2: do L=1 loop3: do diff --git a/src/gsi/rdgrbsst.f90 b/src/gsi/rdgrbsst.f90 index 8be85ad608..29e5346eae 100644 --- a/src/gsi/rdgrbsst.f90 +++ b/src/gsi/rdgrbsst.f90 @@ -132,14 +132,14 @@ subroutine rdgrbsst(file_sst,mlat_sst,mlon_sst,& ! Get lat_sst & lon_sst do i = 2, nlat_sst - 1 - rlats_sst(i) = (xsst0 + float(i-2)*dres)*deg2rad + rlats_sst(i) = (xsst0 + real(i-2,r_kind)*dres)*deg2rad enddo rlats_sst(1) = -90.0_r_kind*deg2rad rlats_sst(nlat_sst) = 90.0_r_kind*deg2rad do j = 2, nlon_sst - 1 - rlons_sst(j) = (ysst0 + float(j-2)*dres)*deg2rad + rlons_sst(j) = (ysst0 + real(j-2,r_kind)*dres)*deg2rad enddo rlons_sst(1) = -half*dres*deg2rad ! 1 @@ -184,8 +184,8 @@ subroutine rdgrbsst(file_sst,mlat_sst,mlon_sst,& sums = sums + sst(j,2) sumn = sumn + sst(j,nlat_sst-1) end do - sums = sums / float(i) - sumn = sumn / float(i) + sums = sums / real(i,r_kind) + sumn = sumn / real(i,r_kind) do j = 2,nlon_sst-1 sst(j,1) = sums sst(j,nlat_sst) = sumn diff --git a/src/gsi/read_airs.f90 b/src/gsi/read_airs.f90 index 16e890abd1..8dd22ffd5e 100644 --- a/src/gsi/read_airs.f90 +++ b/src/gsi/read_airs.f90 @@ -790,7 +790,7 @@ subroutine read_airs(mype,val_airs,ithin,isfcalc,rmesh,jsatid,gstime,& endif sol_aziang = aquaspot(2) - lza = (start + float(ifov-1)*step)*deg2rad + lza = (start + real(ifov-1,r_kind)*step)*deg2rad ! ! interpolate NSST variables to Obs. location and get dtw, dtc, tz_tr ! diff --git a/src/gsi/read_amsr2.f90 b/src/gsi/read_amsr2.f90 index a7b27abccc..9d8d4944d9 100644 --- a/src/gsi/read_amsr2.f90 +++ b/src/gsi/read_amsr2.f90 @@ -566,7 +566,7 @@ subroutine read_amsr2(mype,val_amsr2,ithin,rmesh,jsatid,gstime,& if(.not. regional .and. dist1 > 0.75_r_kind) cycle obsloop endif - crit1 = crit1 + 10._r_kind * float(iskip) + crit1 = crit1 + 10._r_kind * real(iskip,r_kind) call checkob(dist1,crit1,itx,iuse) if(.not. iuse) then cycle obsloop diff --git a/src/gsi/read_atms.f90 b/src/gsi/read_atms.f90 index 47b675b3a3..c6ed159068 100644 --- a/src/gsi/read_atms.f90 +++ b/src/gsi/read_atms.f90 @@ -401,7 +401,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& ! inflate selection value for ears_db data crit0 = 0.01_r_kind - if ( llll > 1 ) crit0 = crit0 + r100 * float(llll) + if ( llll > 1 ) crit0 = crit0 + r100 * real(llll,r_kind) call ufbint(lnbufr,bfr1bhdr,n1bhdr,1,iret,hdr1b) @@ -455,7 +455,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& lza = bfr2bhdr(1)*deg2rad ! local zenith angle if(ifov <= 48) lza=-lza - panglr=(start+float(ifov-1)*step)*deg2rad + panglr=(start+real(ifov-1,r_kind)*step)*deg2rad satellite_height=bfr1bhdr(13) ! Ensure orbit height is reasonable if (satellite_height < 780000.0_r_kind .OR. & @@ -648,7 +648,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& idomsfc(1),sfcpct,ts,tsavg,vty,vfr,sty,stp,sm,sn,zz,ff10,sfcr) endif - crit1 = crit1 + rlndsea(isflg) + 10._r_kind*float(iskip) + 0.01_r_kind * abs(zz) + crit1 = crit1 + rlndsea(isflg) + 10._r_kind*real(iskip,r_kind) + 0.01_r_kind * abs(zz) call checkob(dist1,crit1,itx,iuse) if(.not. iuse)cycle ObsLoop @@ -726,7 +726,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& endif ! Re-calculate look angle - panglr=(start+float(ifov-1)*step)*deg2rad + panglr=(start+real(ifov-1,r_kind)*step)*deg2rad ! Load selected observation into data array diff --git a/src/gsi/read_bufrtovs.f90 b/src/gsi/read_bufrtovs.f90 index a819acd2c3..2fc14b5cdf 100644 --- a/src/gsi/read_bufrtovs.f90 +++ b/src/gsi/read_bufrtovs.f90 @@ -673,7 +673,7 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& terrain = 50._r_kind if(llll == 1)terrain = 0.01_r_kind*abs(bfr1bhdr(13)) crit0 = 0.01_r_kind + terrain - if (llll > 1 ) crit0 = crit0 + r100 * float(llll) + if (llll > 1 ) crit0 = crit0 + r100 * real(llll,r_kind) timeinflat=two call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) @@ -699,7 +699,7 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& if(hirs .and. ((jsatid == 'n16') .or. (jsatid == 'n17'))) & ifovmod=ifovmod+1 - panglr=(start+float(ifovmod-1)*step)*deg2rad + panglr=(start+real(ifovmod-1,r_kind)*step)*deg2rad lzaest = asin(rato*sin(panglr)) if( msu .or. hirs2 .or. ssu)then lza = lzaest @@ -821,7 +821,7 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& end do if (iskip >= nchanl) cycle read_loop ! Map obs to thinning grid - crit1 = crit1 + 10._r_kind*float(iskip) + crit1 = crit1 + 10._r_kind*real(iskip,r_kind) call checkob(dist1,crit1,itx,iuse) if(.not. iuse)cycle read_loop diff --git a/src/gsi/read_cris.f90 b/src/gsi/read_cris.f90 index a257480c9a..9843f919d7 100644 --- a/src/gsi/read_cris.f90 +++ b/src/gsi/read_cris.f90 @@ -582,7 +582,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& ! Increment nread counter by bufr_nchan (should be changed to number of channels in satinfo file? (satinfo_nchan)) nread = nread + satinfo_nchan crit0 = 0.01_r_kind - if( llll > 1 ) crit0 = crit0 + r100 * float(llll) + if( llll > 1 ) crit0 = crit0 + r100 * real(llll,r_kind) timeinflat=6.0_r_kind call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) @@ -600,8 +600,8 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& if( ifor <= 15 ) sat_zenang = -sat_zenang ! Compute scan angle including sensor twist. - look_angle_est = (start + float((ifor-1))*step) * deg2rad + & - fov_dist(ifov) * sin(fov_ang(ifov) - float(ifor-1)*step*deg2rad) + look_angle_est = (start + real((ifor-1),r_kind)*step) * deg2rad + & + fov_dist(ifov) * sin(fov_ang(ifov) - real(ifor-1,r_kind)*step*deg2rad) sat_look_angle=asin(rato*sin(sat_zenang*deg2rad)) if(abs(sat_look_angle)*rad2deg > MAX_SENSOR_ZENITH_ANGLE) then @@ -763,7 +763,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& if(iskip > 0 .and. print_verbose)write(6,*) ' READ_CRIS : iskip > 0 ',iskip ! if( iskip >= 10 )cycle read_loop - crit1=crit1 + ten*float(iskip) + crit1=crit1 + ten*real(iskip,r_kind) ! Final map obs to grids if ( clear ) then diff --git a/src/gsi/read_dbz_netcdf.f90 b/src/gsi/read_dbz_netcdf.f90 index 6ea03afaff..ecfb9169c4 100644 --- a/src/gsi/read_dbz_netcdf.f90 +++ b/src/gsi/read_dbz_netcdf.f90 @@ -170,9 +170,9 @@ subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nob integer(i_kind) :: num_missing=0,num_nopcp=0, & !counts numbadtime=0,num_badtilt=0, & num_badrange=0,num_m2nopcp=0, & - num_noise=0,num_limmax=0 ,num_limmin=0 - - + num_noise=0,num_limmax=0 ,num_limmin=0 + + !--General declarations integer(i_kind) :: ierror,lunrad,i,j,k,v,na,nb,nelv,nvol, & @@ -185,7 +185,7 @@ subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nob real(r_kind) :: thistiltr,selev0,celev0,thisrange,this_stahgt,thishgt real(r_kind) :: celev,selev,gamma,thisazimuthr,rlon0, & clat0,slat0,dlat,dlon,thiserr,thislon,thislat, & - rlonloc,rlatloc,rlonglob,rlatglob,timeb,rad_per_meter + rlonloc,rlatloc,rlonglob,rlatglob,timeb,rad_per_meter real(r_kind) :: radartwindow real(r_kind) :: dbzerr,rmins_an,rmins_ob real(r_kind),allocatable,dimension(:,:):: cdata_all @@ -203,7 +203,7 @@ subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nob !---------SETTINGS FOR FUTURE NAMELIST---------! integer(i_kind) :: maxobrange=999000 ! Range (m) *within* which to use observations - obs *outside* this range are not used integer(i_kind) :: minobrange=-999 ! Range (m) *outside* of which to use observatons - obs *inside* this range are not used - real(r_kind) :: mintilt=0.0_r_kind ! Only use tilt(elevation) angles (deg) >= this number + real(r_kind) :: mintilt=0.0_r_kind ! Only use tilt(elevation) angles (deg) >= this number real(r_kind) :: maxtilt=20.0_r_kind ! Do no use tilt(elevation) angles (deg) >= this number logical :: missing_to_nopcp=.false. ! Set missing observations to 'no precipitation' observations -> dbznoise (See Aksoy et al. 2009, MWR) real(r_kind) :: dbznoise=2.0_r_kind ! dBZ obs must be >= dbznoise for assimilation @@ -241,13 +241,13 @@ subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nob if(trim(obstype) == trim(ioctype(i)) .and. abs(icuse(i))== 1) then ikx=i radartwindow=ctwind(ikx)*r60 !Time window units converted to minutes - ! (default setting for dbz within convinfo is 0.05 hours) - dbzerr=5_r_kind !Ob error (dB) to use for radar reflectivity factor - exit !Exit loop when finished with initial convinfo fields + ! (default setting for dbz within convinfo is 0.05 hours) + dbzerr=5_r_kind !Ob error (dB) to use for radar reflectivity factor + exit !Exit loop when finished with initial convinfo fields else if ( i==nconvtype ) then write(6,*) 'READ_dBZ: ERROR - OBSERVATION TYPE IS NOT PRESENT IN CONVINFO OR USE FLAG IS ZERO' - write(6,*) 'READ_dBZ: ABORTTING read_dbz.f90 - NO REFLECTIVITY OBS READ!' - return + write(6,*) 'READ_dBZ: ABORTTING read_dbz.f90 - NO REFLECTIVITY OBS READ!' + return endif end do @@ -420,12 +420,12 @@ subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nob obdate(1)=strct_in_dbz(v,k)%year obdate(2)=strct_in_dbz(v,k)%month - obdate(3)=strct_in_dbz(v,k)%day + obdate(3)=strct_in_dbz(v,k)%day obdate(4)=strct_in_dbz(v,k)%hour obdate(5)=strct_in_dbz(v,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_dbz(v,k)%second*r60inv) !convert seconds to minutes and add to ob time + rmins_ob=mins_ob !convert to real number + rmins_ob=rmins_ob+(strct_in_dbz(v,k)%second*r60inv) !convert seconds to minutes and add to ob time !-Comparison is done in units of minutes @@ -439,139 +439,139 @@ subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nob if (thistilt <= maxtilt .and. thistilt >= mintilt) then gates: do i=1,strct_in_dbz(v,k)%num_gate - - thisrange=strct_in_dbz(v,k)%fstgatdis + float(i-1)*strct_in_dbz(v,k)%gateWidth + + thisrange=strct_in_dbz(v,k)%fstgatdis + real(i-1,r_kind)*strct_in_dbz(v,k)%gateWidth !-Check to make sure observations are within specified range - if (thisrange <= maxobrange .and. thisrange >= minobrange) then - azms: do j=1,strct_in_dbz(v,k)%num_beam - - !-Check to see if this is a missing observation - - nread=nread+1 - + if (thisrange <= maxobrange .and. thisrange >= minobrange) then + azms: do j=1,strct_in_dbz(v,k)%num_beam + + !-Check to see if this is a missing observation + + nread=nread+1 + if ( abs(strct_in_dbz(v,k)%field(i,j)) >= 99.0_r_kind ) then - - !--Extend no precip observations to missing data fields? + + !--Extend no precip observations to missing data fields? ! May help suppress spurious convection if a problem. - + if (missing_to_nopcp) then - strct_in_dbz(v,k)%field(i,j) = dbznoise - num_m2nopcp = num_m2nopcp+1 - else - num_missing=num_missing+1 - cycle azms !No reason to process the ob if it is missing + strct_in_dbz(v,k)%field(i,j) = dbznoise + num_m2nopcp = num_m2nopcp+1 + else + num_missing=num_missing+1 + cycle azms !No reason to process the ob if it is missing end if - + end if - - - if (l_limmax) then - if ( strct_in_dbz(v,k)%field(i,j) > 60_r_kind ) then - strct_in_dbz(v,k)%field(i,j) = 60_r_kind - num_limmax=num_limmax+1 - end if - end if - if (l_limmin) then - if ( strct_in_dbz(v,k)%field(i,j) < 0_r_kind ) then - strct_in_dbz(v,k)%field(i,j) = 0_r_kind - num_limmin=num_limmin+1 - end if - end if - - !--Find observation height using method from read_l2bufr_mod.f90 - - this_stahgt=strct_in_dbz(v,k)%radhgt + + + if (l_limmax) then + if ( strct_in_dbz(v,k)%field(i,j) > 60_r_kind ) then + strct_in_dbz(v,k)%field(i,j) = 60_r_kind + num_limmax=num_limmax+1 + end if + end if + if (l_limmin) then + if ( strct_in_dbz(v,k)%field(i,j) < 0_r_kind ) then + strct_in_dbz(v,k)%field(i,j) = 0_r_kind + num_limmin=num_limmin+1 + end if + end if + + !--Find observation height using method from read_l2bufr_mod.f90 + + this_stahgt=strct_in_dbz(v,k)%radhgt aactual=rearth+this_stahgt a43=four_thirds*aactual thistiltr=thistilt*deg2rad selev0=sin(thistiltr) - celev0=cos(thistiltr) - b=thisrange*(thisrange+two*aactual*selev0) + celev0=cos(thistiltr) + b=thisrange*(thisrange+two*aactual*selev0) c=sqrt(aactual*aactual+b) ha=b/(aactual+c) epsh=(thisrange*thisrange-ha*ha)/(r8*aactual) h=ha-epsh - thishgt=this_stahgt+h - - !--Find observation location using method from read_l2bufr_mod.f90 - - !-Get corrected tilt angle - celev=celev0 - selev=selev0 - celev=a43*celev0/(a43+h) - selev=(thisrange*thisrange+h*h+two*a43*h)/(two*thisrange*(a43+h)) - - gamma=half*thisrange*(celev0+celev) - + thishgt=this_stahgt+h + + !--Find observation location using method from read_l2bufr_mod.f90 + + !-Get corrected tilt angle + celev=celev0 + selev=selev0 + celev=a43*celev0/(a43+h) + selev=(thisrange*thisrange+h*h+two*a43*h)/(two*thisrange*(a43+h)) + + gamma=half*thisrange*(celev0+celev) + !-Get earth lat lon of observation - + rlon0=deg2rad*strct_in_dbz(v,k)%radlon - clat0=cos(deg2rad*strct_in_dbz(v,k)%radlat) - slat0=sin(deg2rad*strct_in_dbz(v,k)%radlat) - thisazimuthr=(90.0_r_kind-strct_in_dbz(v,k)%azim(j))*deg2rad !Storing as 90-azm to - ! be consistent with - ! read_l2bufr_mod.f90 - rad_per_meter=one/rearth - rlonloc=rad_per_meter*gamma*cos(thisazimuthr) + clat0=cos(deg2rad*strct_in_dbz(v,k)%radlat) + slat0=sin(deg2rad*strct_in_dbz(v,k)%radlat) + thisazimuthr=(90.0_r_kind-strct_in_dbz(v,k)%azim(j))*deg2rad !Storing as 90-azm to + ! be consistent with + ! read_l2bufr_mod.f90 + rad_per_meter=one/rearth + rlonloc=rad_per_meter*gamma*cos(thisazimuthr) rlatloc=rad_per_meter*gamma*sin(thisazimuthr) - - call invtllv(rlonloc,rlatloc,rlon0,clat0,slat0,rlonglob,rlatglob) + + call invtllv(rlonloc,rlatloc,rlon0,clat0,slat0,rlonglob,rlatglob) - thislat=rlatglob*rad2deg + thislat=rlatglob*rad2deg thislon=rlonglob*rad2deg !-Check format of longitude and correct if necessary - if(thislon>=r360) thislon=thislon-r360 + if(thislon>=r360) thislon=thislon-r360 if(thislon= this number + real(r_kind) :: mintilt=0.0_r_kind ! Only use tilt(elevation) angles (deg) >= this number real(r_kind) :: maxtilt=20.0_r_kind ! Do no use tilt(elevation) angles (deg) >= this number logical :: missing_to_nopcp=.false. ! Set missing observations to 'no precipitation' observations -> dbznoise (See Aksoy et al. 2009, MWR) real(r_kind) :: dbznoise=2_r_kind ! dBZ obs must be >= dbznoise for assimilation @@ -863,13 +863,13 @@ subroutine read_dbz_mrms_sparse_netcdf(nread,ndata,nodata,infile,obstype,lunout, if(trim(obstype) == trim(ioctype(i)) .and. abs(icuse(i))== 1) then ikx=i radartwindow=ctwind(ikx)*r60 !Time window units converted to minutes - ! (default setting for dbz within convinfo is 0.05 hours) - dbzerr=5_r_kind !Ob error (dB) to use for radar reflectivity factor - exit !Exit loop when finished with initial convinfo fields + ! (default setting for dbz within convinfo is 0.05 hours) + dbzerr=5_r_kind !Ob error (dB) to use for radar reflectivity factor + exit !Exit loop when finished with initial convinfo fields else if ( i==nconvtype ) then write(6,*) 'READ_dBZ: ERROR - OBSERVATION TYPE IS NOT PRESENT IN CONVINFO OR USE FLAG IS ZERO' - write(6,*) 'READ_dBZ: ABORTTING read_dbz.f90 - NO REFLECTIVITY OBS READ!' - return + write(6,*) 'READ_dBZ: ABORTTING read_dbz.f90 - NO REFLECTIVITY OBS READ!' + return endif end do @@ -1017,20 +1017,20 @@ subroutine read_dbz_mrms_sparse_netcdf(nread,ndata,nodata,infile,obstype,lunout, ! transform the read-in ob to the intermidate obs variables( radar obs to be used in GSI - strct_in_dbz(v,k)%radid=radarsite_nc - strct_in_dbz(v,k)%vcpnum=vcp_nc - strct_in_dbz(v,k)%year=iyear ! to be defind from infile name + strct_in_dbz(v,k)%radid=radarsite_nc + strct_in_dbz(v,k)%vcpnum=vcp_nc + strct_in_dbz(v,k)%year=iyear ! to be defind from infile name strct_in_dbz(v,k)%month=imon strct_in_dbz(v,k)%day=iday strct_in_dbz(v,k)%hour=ihour strct_in_dbz(v,k)%minute=imin strct_in_dbz(v,k)%second=isec - strct_in_dbz(v,k)%radlat=lat_nc + strct_in_dbz(v,k)%radlat=lat_nc strct_in_dbz(v,k)%radlon=lon_nc strct_in_dbz(v,k)%radhgt=height_nc - strct_in_dbz(v,k)%fstgatdis =firstgate_nc + strct_in_dbz(v,k)%fstgatdis =firstgate_nc strct_in_dbz(v,k)%gateWidth=gatewidth_nc(1) ! always the same ??) - strct_in_dbz(v,k)%elev_angle=elev_nc + strct_in_dbz(v,k)%elev_angle=elev_nc strct_in_dbz(v,k)%num_beam=numazim_nc strct_in_dbz(v,k)%num_gate=numgate_nc na=strct_in_dbz(v,k)%num_beam @@ -1065,8 +1065,8 @@ subroutine read_dbz_mrms_sparse_netcdf(nread,ndata,nodata,infile,obstype,lunout, obdate(5)=strct_in_dbz(v,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_dbz(v,k)%second*r60inv) !convert seconds to minutes and add to ob time + rmins_ob=mins_ob !convert to real number + rmins_ob=rmins_ob+(strct_in_dbz(v,k)%second*r60inv) !convert seconds to minutes and add to ob time !-Comparison is done in units of minutes @@ -1088,139 +1088,139 @@ subroutine read_dbz_mrms_sparse_netcdf(nread,ndata,nodata,infile,obstype,lunout, pixel: do ipix=1,real_numpixel j=pixel_x_nc(ipix)+1 i=pixel_y_nc(ipix)+1 - - thisrange=strct_in_dbz(v,k)%fstgatdis + float(i-1)*strct_in_dbz(v,k)%gateWidth + + thisrange=strct_in_dbz(v,k)%fstgatdis + real(i-1,r_kind)*strct_in_dbz(v,k)%gateWidth !-Check to make sure observations are within specified range - if (thisrange <= maxobrange .and. thisrange >= minobrange) then - - - nread=nread+1 + if (thisrange <= maxobrange .and. thisrange >= minobrange) then + + + nread=nread+1 if ( abs(obdata_pixel_nc(ipix)) >= 999.0_r_kind ) then - - !--Extend no precip observations to missing data fields? + + !--Extend no precip observations to missing data fields? ! May help suppress spurious convection if a problem. - + if (missing_to_nopcp) then - obdata_pixel_nc(ipix) = dbznoise - num_m2nopcp = num_m2nopcp+1 - else - num_missing=num_missing+1 - cycle pixel !No reason to process the ob if it is missing + obdata_pixel_nc(ipix) = dbznoise + num_m2nopcp = num_m2nopcp+1 + else + num_missing=num_missing+1 + cycle pixel !No reason to process the ob if it is missing end if - + + end if + + + if (l_limmax) then + if ( obdata_pixel_nc(ipix) > 60_r_kind ) then + obdata_pixel_nc(ipix) = 60_r_kind + num_limmax=num_limmax+1 + end if end if - - - if (l_limmax) then - if ( obdata_pixel_nc(ipix) > 60_r_kind ) then - obdata_pixel_nc(ipix) = 60_r_kind - num_limmax=num_limmax+1 - end if - end if - if (l_limmin) then - if ( obdata_pixel_nc(ipix) < 0_r_kind ) then - obdata_pixel_nc(ipix) = 0_r_kind - num_limmin=num_limmin+1 - end if - end if - - !-Special treatment for no-precip obs? - - - !--Find observation height using method from read_l2bufr_mod.f90 - - this_stahgt=strct_in_dbz(v,k)%radhgt + if (l_limmin) then + if ( obdata_pixel_nc(ipix) < 0_r_kind ) then + obdata_pixel_nc(ipix) = 0_r_kind + num_limmin=num_limmin+1 + end if + end if + + !-Special treatment for no-precip obs? + + + !--Find observation height using method from read_l2bufr_mod.f90 + + this_stahgt=strct_in_dbz(v,k)%radhgt aactual=rearth+this_stahgt a43=four_thirds*aactual thistiltr=thistilt*deg2rad selev0=sin(thistiltr) - celev0=cos(thistiltr) - b=thisrange*(thisrange+two*aactual*selev0) + celev0=cos(thistiltr) + b=thisrange*(thisrange+two*aactual*selev0) c=sqrt(aactual*aactual+b) ha=b/(aactual+c) epsh=(thisrange*thisrange-ha*ha)/(r8*aactual) h=ha-epsh - thishgt=this_stahgt+h - - !--Find observation location using method from read_l2bufr_mod.f90 - - !-Get corrected tilt angle - celev=celev0 - selev=selev0 - celev=a43*celev0/(a43+h) - selev=(thisrange*thisrange+h*h+two*a43*h)/(two*thisrange*(a43+h)) - - gamma=half*thisrange*(celev0+celev) - + thishgt=this_stahgt+h + + !--Find observation location using method from read_l2bufr_mod.f90 + + !-Get corrected tilt angle + celev=celev0 + selev=selev0 + celev=a43*celev0/(a43+h) + selev=(thisrange*thisrange+h*h+two*a43*h)/(two*thisrange*(a43+h)) + + gamma=half*thisrange*(celev0+celev) + !-Get earth lat lon of observation - + rlon0=deg2rad*strct_in_dbz(v,k)%radlon - clat0=cos(deg2rad*strct_in_dbz(v,k)%radlat) - slat0=sin(deg2rad*strct_in_dbz(v,k)%radlat) - thisazimuthr=(90.0_r_kind-strct_in_dbz(v,k)%azim(j))*deg2rad !Storing as 90-azm to - ! be consistent with - ! read_l2bufr_mod.f90 - rad_per_meter=one/rearth - rlonloc=rad_per_meter*gamma*cos(thisazimuthr) + clat0=cos(deg2rad*strct_in_dbz(v,k)%radlat) + slat0=sin(deg2rad*strct_in_dbz(v,k)%radlat) + thisazimuthr=(90.0_r_kind-strct_in_dbz(v,k)%azim(j))*deg2rad !Storing as 90-azm to + ! be consistent with + ! read_l2bufr_mod.f90 + rad_per_meter=one/rearth + rlonloc=rad_per_meter*gamma*cos(thisazimuthr) rlatloc=rad_per_meter*gamma*sin(thisazimuthr) - - call invtllv(rlonloc,rlatloc,rlon0,clat0,slat0,rlonglob,rlatglob) + + call invtllv(rlonloc,rlatloc,rlon0,clat0,slat0,rlonglob,rlatglob) - thislat=rlatglob*rad2deg + thislat=rlatglob*rad2deg thislon=rlonglob*rad2deg !-Check format of longitude and correct if necessary - if(thislon>=r360) thislon=thislon-r360 + if(thislon>=r360) thislon=thislon-r360 if(thislon 0.75_r_kind) cycle obsloop endif - crit1 = crit1 + 10._r_kind * float(iskip) + crit1 = crit1 + 10._r_kind * real(iskip,r_kind) call checkob(dist1,crit1,itx,iuse) if(.not. iuse) then cycle obsloop @@ -819,7 +819,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& if(pos_max==0) then j2=1 else - j2=nint(float(pos_statis(i))/pos_max) + j2=nint(real(pos_statis(i),r_kind)/pos_max) j2=max(1,j2) endif do j=1,pos_statis(i),j2 @@ -835,7 +835,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& if(pos_max==0) then j2=1 else - j2=nint(float(pos_statis(i))/pos_max) + j2=nint(real(pos_statis(i),r_kind)/pos_max) j2=max(1,j2) endif do j=1,pos_statis(i),j2 diff --git a/src/gsi/read_goesglm.f90 b/src/gsi/read_goesglm.f90 index bf8639c72d..f087430092 100644 --- a/src/gsi/read_goesglm.f90 +++ b/src/gsi/read_goesglm.f90 @@ -224,7 +224,7 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis) call w3fs21(idate5,minan) ! analysis ref time in seconds relative to historic date ! Add obs reference time, then subtract analysis time to get obs time relative to analysis - time_correction=float(minobs-minan)*r60inv + time_correction=real(minobs-minan,r_kind)*r60inv else time_correction=zero end if @@ -512,13 +512,13 @@ subroutine convert_to_flash_rate & end do !! do iobs=2,ndata_strike - darea=darea_sum/float(ndata_strike) + darea=darea_sum/real(ndata_strike,r_kind) else !! ndata_strike=0 darea=zero end if !! if(ndata_strike>0) then - dtime=float(nhr_assimilation) + dtime=real(nhr_assimilation,r_kind) ! Regional @@ -574,8 +574,8 @@ subroutine convert_to_flash_rate & !! find lightning strikes near the (ii0,jj0) point - xbound=float(ii0) - ybound=float(jj0) + xbound=real(ii0,r_kind) + ybound=real(jj0,r_kind) xflag=(xx>xbound) .AND. (xxybound) .AND. (yy0) then - glon_central(index)=glon_central(index)/float(lcount(index)) - glat_central(index)=glat_central(index)/float(lcount(index)) - lon_central(index)= lon_central(index)/float(lcount(index)) - lat_central(index)= lat_central(index)/float(lcount(index)) + glon_central(index)=glon_central(index)/real(lcount(index),r_kind) + glat_central(index)=glat_central(index)/real(lcount(index),r_kind) + lon_central(index)= lon_central(index)/real(lcount(index),r_kind) + lat_central(index)= lat_central(index)/real(lcount(index),r_kind) endif !! if(lcount(index)>0) then enddo !! do index=1,ngridh @@ -653,7 +653,7 @@ subroutine convert_to_flash_rate & cdata_flash_h( 3,icount)=glat_central(index) if (darea>0._r_kind) then - cdata_flash_h( 4,icount)=float(lcount(index))/(darea*dtime) + cdata_flash_h( 4,icount)=real(lcount(index),r_kind)/(darea*dtime) else cdata_flash_h( 4,icount)=0. end if @@ -727,22 +727,22 @@ subroutine convert_time (date_old,date_new,nmax) jdd=INT(0.0001_r_kind*xdate(i)) idd=INT(xdate(i))-jdd*10000 - ysumidd=float(idd) - dd=float(INT(0.01_r_kind*ysumidd)) + ysumidd=real(idd,r_kind) + dd=real(INT(0.01_r_kind*ysumidd),r_kind) hh=ysumidd-dd*100._r_kind sumidd=sumidd+dd*24._r_kind+hh enddo !! do i=1,nmax - xsumidd=float(sumidd)/nmax - ysumidd=float(INT(xsumidd)) + xsumidd=real(sumidd,r_kind)/nmax + ysumidd=real(INT(xsumidd),r_kind) kdd=INT(xsumidd/24._r_kind) - xdd=float(kdd) - xhh=ysumidd-float(kdd)*24._r_kind + xdd=real(kdd,r_kind) + xhh=ysumidd-real(kdd,r_kind)*24._r_kind - ydate=float(jdd)*10000._r_kind+xdd*100._r_kind+xhh+xccyy + ydate=real(jdd,r_kind)*10000._r_kind+xdd*100._r_kind+xhh+xccyy date_old=ydate diff --git a/src/gsi/read_goesndr.f90 b/src/gsi/read_goesndr.f90 index 86fc1f0a5c..7c55b6ab4c 100644 --- a/src/gsi/read_goesndr.f90 +++ b/src/gsi/read_goesndr.f90 @@ -382,7 +382,7 @@ subroutine read_goesndr(mype,val_goes,ithin,rmesh,jsatid,infile,& nread=nread+nchanl crit0=0.01_r_kind - if(ifov < mfov .and. ifov > 0) crit0 = crit0+two*float(mfov-ifov) + if(ifov < mfov .and. ifov > 0) crit0 = crit0+two*real(mfov-ifov,r_kind) timeinflat=6.0_r_kind call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) diff --git a/src/gsi/read_iasi.f90 b/src/gsi/read_iasi.f90 index 4e688cd36e..9ab1d5446f 100644 --- a/src/gsi/read_iasi.f90 +++ b/src/gsi/read_iasi.f90 @@ -577,7 +577,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& nread = nread + satinfo_nchan crit0 = 0.01_r_kind - if( llll > 1 ) crit0 = crit0 + r100 * float(llll) + if( llll > 1 ) crit0 = crit0 + r100 * real(llll,r_kind) timeinflat=6.0_r_kind call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh) call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh) @@ -598,7 +598,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& ! Compare IASI satellite scan angle and zenith angle piece = -step_adjust if ( mod(ifovn,2) == 1) piece = step_adjust - lza = ((start + float((ifov-1)/4)*step) + piece)*deg2rad + lza = ((start + real((ifov-1)/4,r_kind)*step) + piece)*deg2rad sat_height_ratio = (earth_radius + linele(4))/earth_radius lzaest = asin(sat_height_ratio*sin(lza))*rad2deg if (abs(sat_zenang - lzaest) > one) then @@ -748,7 +748,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& cycle read_loop end if -! crit1=crit1 + ten*float(iskip) +! crit1=crit1 + ten*real(iskip,r_kind) ! If the surface channel exists (~960.0 cm-1) and the AVHRR cloud information is missing, use an ! estimate of the surface temperature to determine if the profile may be clear. diff --git a/src/gsi/read_lidar.f90 b/src/gsi/read_lidar.f90 index 6d74de0802..ad5b27b784 100644 --- a/src/gsi/read_lidar.f90 +++ b/src/gsi/read_lidar.f90 @@ -172,7 +172,7 @@ subroutine read_lidar(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) ! add obs reference time, then subtract analysis time to get obs time relative to analysis - time_correction=float(minobs-minan)*r60inv + time_correction=real(minobs-minan,r_kind)*r60inv else time_correction=zero diff --git a/src/gsi/read_nsstbufr.f90 b/src/gsi/read_nsstbufr.f90 index adfdee4f13..d7a3472dd0 100644 --- a/src/gsi/read_nsstbufr.f90 +++ b/src/gsi/read_nsstbufr.f90 @@ -367,7 +367,7 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & if ( rsc > 60.0_r_kind .or. rsc < zero ) rsc = zero !second in real call w3fs21(idate5,nmind) - sstime=float(nmind) + sstime=real(nmind,r_kind) tdiff=(sstime-gstime)*r60inv diff --git a/src/gsi/read_ozone.f90 b/src/gsi/read_ozone.f90 index 43dd16d5c8..2ad95a858e 100644 --- a/src/gsi/read_ozone.f90 +++ b/src/gsi/read_ozone.f90 @@ -1056,7 +1056,7 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & ozout(8,ndata)=usage1(k) ! ozout(9,ndata)=mlspres(k) ! mls pressure in log(cb) ozout(10,ndata)=mlsozpc(k) ! ozone mixing ratio precision in ppmv - ozout(11,ndata)=float(ipos(k)) ! pointer of obs level index in ozinfo.txt + ozout(11,ndata)=real(ipos(k),r_kind) ! pointer of obs level index in ozinfo.txt ozout(12,ndata)=nloz ! # of mls vertical levels ozout(nreal+1,ndata)=mlsoz(k) ! ozone mixing ratio in ppmv end do @@ -1220,7 +1220,7 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & ozout(8,ndata)=usage1(k) ! ozout(9,ndata)=log(press(k)) ! ompslp pressure in log(cb) ozout(10,ndata)=omrstd(k)*ompslp_mult_fact ! ozone mixing ratio precision in ppmv - ozout(11,ndata)=float(ipos(k)) ! pointer of obs level index in + ozout(11,ndata)=real(ipos(k),r_kind) ! pointer of obs level index in ! ozinfo.txt ozout(12,ndata)=j !nloz ! # of ompslp vertical levels ozout(13,ndata)=omr(k) ! ozone mixing ratio in ppmv diff --git a/src/gsi/read_pblh.f90 b/src/gsi/read_pblh.f90 index a7b7c066a2..1ff2cd2c23 100644 --- a/src/gsi/read_pblh.f90 +++ b/src/gsi/read_pblh.f90 @@ -343,7 +343,7 @@ subroutine read_pblh(nread,ndata,nodata,infile,obstype,lunout,twindin,& ! Add obs reference time, then subtract analysis time to get obs time relative to analysis - time_correction=float(minobs-minan)/60._r_kind + time_correction=real(minobs-minan,r_kind)/60._r_kind else time_correction=zero diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index 304fa62590..eaece05451 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -1070,7 +1070,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! Add obs reference time, then subtract analysis time to get obs time relative to analysis - time_correction=float(minobs-minan)*r60inv + time_correction=real(minobs-minan,r_kind)*r60inv else time_correction=zero diff --git a/src/gsi/read_radar_wind_ascii.f90 b/src/gsi/read_radar_wind_ascii.f90 index 604d9d0eca..9d92699b6e 100644 --- a/src/gsi/read_radar_wind_ascii.f90 +++ b/src/gsi/read_radar_wind_ascii.f90 @@ -173,19 +173,19 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg end type radar !--Counters for diagnostics - integer(i_kind) :: num_missing=0,numbadtime=0, & !counts - num_badtilt=0,num_badrange=0, & - ibadazm=0 + integer(i_kind) :: num_missing=0,numbadtime=0, & !counts + num_badtilt=0,num_badrange=0, & + ibadazm=0 -integer(i_kind) :: ithin,zflag,nlevz,icntpnt,klon1,klat1,kk,klatp1,klonp1 -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 + real(r_kind) :: rmesh,xmesh,zmesh,dx,dy,dx1,dy1,w00,w01,w10,w11 + 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 real(r_kind) crit1,timedif real(r_kind),parameter:: r16000 = 16000.0_r_kind -logical :: luse + logical :: luse integer(i_kind) maxout,maxdata integer(i_kind),allocatable,dimension(:):: isort @@ -201,7 +201,7 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg real(r_kind) :: thistiltr,selev0,celev0,thisrange,this_stahgt,thishgt real(r_kind) :: celev,selev,gamma,thisazimuthr,rlon0,t4dv, & clat0,slat0,dlat,dlon,thiserr,thislon,thislat, & - rlonloc,rlatloc,rlonglob,rlatglob,timeb,rad_per_meter + 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) :: rmins_an,rmins_ob @@ -217,7 +217,7 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg type(radar),allocatable :: strct_in_vel(:,:) -real(r_kind) :: mintilt,maxtilt,maxobrange,minobrange + real(r_kind) :: mintilt,maxtilt,maxobrange,minobrange integer(i_kind) :: thin_freq=1 @@ -228,10 +228,10 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg !-Check if radial velocity is in the convinfo file and extract necessary attributes - ithin=1 !number of obs to keep per grid box - if(radar_no_thinning) then - ithin=-1 - endif + ithin=1 !number of obs to keep per grid box + if(radar_no_thinning) then + ithin=-1 + endif errmax=-huge(errmax) errmin=huge(errmin) @@ -241,13 +241,13 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg if(trim(obstype) == trim(ioctype(i)) .and. abs(icuse(i))== 1) then ikx=i radartwindow=ctwind(ikx)*r60 !Time window units converted to minutes - ! (default setting for dbz within convinfo is 0.05 hours) - thiserr= 2_r_kind !1.75_r_kind !2_r_kind !Ob error (m/s) to use for radial velocity - exit !Exit loop when finished with initial convinfo fields + ! (default setting for dbz within convinfo is 0.05 hours) + thiserr= 2_r_kind !1.75_r_kind !2_r_kind !Ob error (m/s) to use for radial velocity + exit !Exit loop when finished with initial convinfo fields else if ( i==nconvtype ) then write(6,*) 'READ_RADAR_WIND_ASCII: ERROR - OBSERVATION TYPE IS NOT PRESENT IN CONVINFO OR USE FLAG IS ZERO' - write(6,*) 'READ_RADAR_WIND_ASCII: ABORTING read_radar_wind_ascii.f90 - NO VELOCITY OBS READ!' - return + write(6,*) 'READ_RADAR_WIND_ASCII: ABORTING read_radar_wind_ascii.f90 - NO VELOCITY OBS READ!' + return endif end do @@ -362,12 +362,12 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg 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(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 + 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 @@ -377,70 +377,70 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg 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 + 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 + float(i-1)*strct_in_vel(1,k)%gateWidth - + 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 + 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 + + !--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) - b=thisrange*(thisrange+two*aactual*selev0) + celev0=cos(thistiltr) + b=thisrange*(thisrange+two*aactual*selev0) c=sqrt(aactual*aactual+b) ha=b/(aactual+c) epsh=(thisrange*thisrange-ha*ha)/(r8*aactual) h=ha-epsh - thishgt=this_stahgt+h + thishgt=this_stahgt+h height=thishgt - !--Find observation location using method from read_l2bufr_mod.f90 - - !-Get corrected tilt angle - celev=celev0 - selev=selev0 - celev=a43*celev0/(a43+h) - selev=(thisrange*thisrange+h*h+two*a43*h)/(two*thisrange*(a43+h)) - - gamma=half*thisrange*(celev0+celev) - + !--Find observation location using method from read_l2bufr_mod.f90 + + !-Get corrected tilt angle + celev=celev0 + selev=selev0 + celev=a43*celev0/(a43+h) + selev=(thisrange*thisrange+h*h+two*a43*h)/(two*thisrange*(a43+h)) + + gamma=half*thisrange*(celev0+celev) + !-Get earth lat lon of observation - + rlon0=deg2rad*strct_in_vel(1,k)%radlon - clat0=cos(deg2rad*strct_in_vel(1,k)%radlat) - slat0=sin(deg2rad*strct_in_vel(1,k)%radlat) - thisazimuthr=(90.0_r_kind-strct_in_vel(1,k)%azim(j))*deg2rad !Storing as 90-azm to - ! be consistent with - ! read_l2bufr_mod.f90 - rad_per_meter=one/rearth - rlonloc=rad_per_meter*gamma*cos(thisazimuthr) + clat0=cos(deg2rad*strct_in_vel(1,k)%radlat) + slat0=sin(deg2rad*strct_in_vel(1,k)%radlat) + thisazimuthr=(90.0_r_kind-strct_in_vel(1,k)%azim(j))*deg2rad !Storing as 90-azm to + ! be consistent with + ! read_l2bufr_mod.f90 + rad_per_meter=one/rearth + rlonloc=rad_per_meter*gamma*cos(thisazimuthr) rlatloc=rad_per_meter*gamma*sin(thisazimuthr) - - call invtllv(rlonloc,rlatloc,rlon0,clat0,slat0,rlonglob,rlatglob) + + call invtllv(rlonloc,rlatloc,rlon0,clat0,slat0,rlonglob,rlatglob) - thislat=rlatglob*rad2deg + thislat=rlatglob*rad2deg thislon=rlonglob*rad2deg if(doradaroneob) then @@ -450,21 +450,21 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg 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. - - ! 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) + + 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. + + 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 + + ! Determines land surface type based on surrounding land ! surface types - t4dv=timeb*r60inv - - call deter_sfc2(thislat,thislon,t4dv,idomsfc,skint,ff10,sfcr) - + t4dv=timeb*r60inv + + call deter_sfc2(thislat,thislon,t4dv,idomsfc,skint,ff10,sfcr) + !#################### Data thinning ################### @@ -573,37 +573,37 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg 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 + 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 + 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 diff --git a/src/gsi/read_saphir.f90 b/src/gsi/read_saphir.f90 index 3547f2cf5c..06e992b03d 100644 --- a/src/gsi/read_saphir.f90 +++ b/src/gsi/read_saphir.f90 @@ -360,10 +360,10 @@ subroutine read_saphir(mype,val_tovs,ithin,isfcalc,& ! compute look angle (panglr) and check against max angle -! panglr=(start+float(ifov-1)*step)*deg2rad +! panglr=(start+real(ifov-1,r_kind)*step)*deg2rad ! Use this calculation for now: step = .6660465 - panglr = (42.96 - float(ifov-1)*step)*deg2rad + panglr = (42.96 - real(ifov-1,r_kind)*step)*deg2rad if(abs(lza)*rad2deg > MAX_SENSOR_ZENITH_ANGLE) then write(6,*)'READ_SAPHIR WARNING lza error ',lza,panglr @@ -508,7 +508,7 @@ subroutine read_saphir(mype,val_tovs,ithin,isfcalc,& - crit1 = crit1 + rlndsea(isflg) + 10._r_kind*float(iskip) + 0.01_r_kind * abs(zz) + crit1 = crit1 + rlndsea(isflg) + 10._r_kind*real(iskip,r_kind) + 0.01_r_kind * abs(zz) call checkob(dist1,crit1,itx,iuse) if(.not. iuse)cycle ObsLoop @@ -529,10 +529,10 @@ subroutine read_saphir(mype,val_tovs,ithin,isfcalc,& endif ! Re-calculate look angle -! panglr=(start+float(ifov-1)*step)*deg2rad +! panglr=(start+real(ifov-1,r_kind)*step)*deg2rad ! Use this calculation for now: step = .6660465 - panglr = (42.96 - float(ifov-1)*step)*deg2rad + panglr = (42.96 - real(ifov-1,r_kind)*step)*deg2rad ! Load selected observation into data array diff --git a/src/gsi/read_wcpbufr.f90 b/src/gsi/read_wcpbufr.f90 index 41dc36f3f6..f3daa5de43 100644 --- a/src/gsi/read_wcpbufr.f90 +++ b/src/gsi/read_wcpbufr.f90 @@ -430,7 +430,7 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! Add obs reference time, then subtract analysis time to get obs time relative to analysis - time_correction=float(minobs-minan)*r60inv + time_correction=real(minobs-minan,r_kind)*r60inv else time_correction=zero diff --git a/src/gsi/reorg_metar_cloud.f90 b/src/gsi/reorg_metar_cloud.f90 index 2d947f2ef3..478d1ab363 100644 --- a/src/gsi/reorg_metar_cloud.f90 +++ b/src/gsi/reorg_metar_cloud.f90 @@ -264,9 +264,9 @@ subroutine reorg_metar_cloud(cdata,nreal,ndata,cdata_all,maxobs,ngrid) min_dist = 1.e10_r_kind do ic= 1,nsta_cld ista = sta_cld(ic) - dist = (float(i1)-cdata(2,ista))*(float(i1)-cdata(2,ista)) & - +(float(j1)-cdata(3,ista))*(float(j1)-cdata(3,ista)) - if (dist < min_dist .and. dist < float(isprd2)) then + dist = (real(i1,r_kind)-cdata(2,ista))*(real(i1,r_kind)-cdata(2,ista)) & + +(real(j1,r_kind)-cdata(3,ista))*(real(j1,r_kind)-cdata(3,ista)) + if (dist < min_dist .and. dist < real(isprd2,r_kind)) then min_dist = dist ista_min = ista end if @@ -318,8 +318,8 @@ subroutine reorg_metar_cloud(cdata,nreal,ndata,cdata_all,maxobs,ngrid) enddo cdata_all(24,iout) = cdata_all(2,iout) ! save observaion station i cdata_all(25,iout) = cdata_all(3,iout) ! save observaion station j - cdata_all(2,iout) = float(i1) ! grid index i - cdata_all(3,iout) = float(j1) ! grid index j + cdata_all(2,iout) = real(i1,r_kind) ! grid index i + cdata_all(3,iout) = real(j1,r_kind) ! grid index j cdata_all(23,iout)= min_dist ! distance from station endif endif diff --git a/src/gsi/rfdpar.f90 b/src/gsi/rfdpar.f90 index 79fa959bcb..b679ed6448 100644 --- a/src/gsi/rfdpar.f90 +++ b/src/gsi/rfdpar.f90 @@ -71,7 +71,7 @@ subroutine rfdpar1(be,rate,m) cof=zero cof(0)=one do i=1,m - cof(i)=half*cof(i-1)/float(i) + cof(i)=half*cof(i-1)/real(i,r_kind) enddo ! Locate the m roots of this polynomial: call zroots(cof,m,croot,polish) diff --git a/src/gsi/satthin.F90 b/src/gsi/satthin.F90 index 2018d80be7..93f193014f 100644 --- a/src/gsi/satthin.F90 +++ b/src/gsi/satthin.F90 @@ -614,9 +614,9 @@ subroutine getsfc(mype,mype_io,use_sfc,use_sfc_any) jmax=nlat_sfc-2 allocate(slatx(jmax),wlatx(jmax)) call splat(idrt,jmax,slatx,wlatx) - dlon=two*pi/float(nlon_sfc) + dlon=two*pi/real(nlon_sfc,r_kind) do i=1,nlon_sfc - rlons_sfc(i)=float(i-1)*dlon + rlons_sfc(i)=real(i-1,r_kind)*dlon end do do i=1,(nlat_sfc-1)/2 rlats_sfc(i+1)=-asin(slatx(i)) diff --git a/src/gsi/setupbend.f90 b/src/gsi/setupbend.f90 index 9bc856d67a..e82aa3dec9 100644 --- a/src/gsi/setupbend.f90 +++ b/src/gsi/setupbend.f90 @@ -331,9 +331,9 @@ subroutine setupbend(obsLL,odiagLL, & ! Intialize variables nsig_up=nsig+nsig_ext ! extend nsig_ext levels above interface level nsig - rsig=float(nsig) + rsig=real(nsig,r_kind) rdog=rd/grav - rsig_up=float(nsig_up) + rsig_up=real(nsig_up,r_kind) nobs_out=0 hob_s_top=one mm1=mype+1 @@ -618,7 +618,7 @@ subroutine setupbend(obsLL,odiagLL, & ihob=hob k1=min(max(1,ihob),nsig) k2=max(1,min(ihob+1,nsig)) - delz=hob-float(k1) + delz=hob-real(k1,r_kind) delz=max(zero,min(delz,one)) trefges=tges_o(k1,i)*(one-delz)+tges_o(k2,i)*delz qrefges=qges_o(k1)*(one-delz)+qges_o(k2)*delz !Lidia diff --git a/src/gsi/setupdw.f90 b/src/gsi/setupdw.f90 index 63c0df4b19..6ca68e4cae 100644 --- a/src/gsi/setupdw.f90 +++ b/src/gsi/setupdw.f90 @@ -298,7 +298,7 @@ subroutine setupdw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa end if scale=one - rsig=float(nsig) + rsig=real(nsig,r_kind) mm1=mype+1 call dtime_setup() @@ -496,7 +496,7 @@ subroutine setupdw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa dwwind=(ugesindw*sinazm+vgesindw*cosazm)*factw iz = max(1, min( int(dpres), nsig)) - delz = max(zero, min(dpres - float(iz), one)) + delz = max(zero, min(dpres - real(iz,r_kind), one)) if (save_jacobian) then u_ind = getindex(svars3d, 'u') diff --git a/src/gsi/setuplag.f90 b/src/gsi/setuplag.f90 index 0bad754a0c..01692d8164 100644 --- a/src/gsi/setuplag.f90 +++ b/src/gsi/setuplag.f90 @@ -171,7 +171,7 @@ subroutine setuplag(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diags allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) end if scale=one - rsig=float(nsig) + rsig=real(nsig,r_kind) mm1=mype+1 call dtime_setup() diff --git a/src/gsi/setuplight.f90 b/src/gsi/setuplight.f90 index 040ef19bc6..b1118dd1f8 100644 --- a/src/gsi/setuplight.f90 +++ b/src/gsi/setuplight.f90 @@ -534,7 +534,7 @@ subroutine setuplight(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,light_di ! eps0 - guess value of lightning flash rate if(nobs_gbl > 0) then - eps=eps0*exp( (one/ float(nobs_gbl))*sum_gbl/(one+r0/w0) ) + eps=eps0*exp( (one/ real(nobs_gbl,r_kind))*sum_gbl/(one+r0/w0) ) else eps=eps0 endif !! if(nobs_gbl .gt. 0) then diff --git a/src/gsi/setupoz.f90 b/src/gsi/setupoz.f90 index 7112e967ba..b16a33b414 100644 --- a/src/gsi/setupoz.f90 +++ b/src/gsi/setupoz.f90 @@ -1361,13 +1361,13 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& ! Check if observation above model top or below model surface rlow=max(sfcchk-dpres,zero) - rhgh=max(dpres-0.001_r_kind-float(nsig),zero) + rhgh=max(dpres-0.001_r_kind-real(nsig,r_kind),zero) ! calculate factor for error adjustment if too (high,low) ratio_errors=obserror/(obserror+1.0e6_r_kind*rhgh+four*rlow) ! Check to see if observations is above the top of the model - if (dpres > float(nsig)) then + if (dpres > real(nsig,r_kind)) then ratio_errors=zero obserror=1.0e6_r_kind end if @@ -1379,7 +1379,7 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& call tintrp31(ges_oz,o3ges,dlat,dlon,dpres,dtime, & hrdifsig,mype,nfldsig) iz = max(1, min( int(dpres), nsig)) - delz = max(zero, min(dpres - float(iz), one)) + delz = max(zero, min(dpres - real(iz,r_kind), one)) if (save_jacobian) then oz_ind = getindex(svars3d, 'oz') if (oz_ind < 0) then diff --git a/src/gsi/setuppcp.f90 b/src/gsi/setuppcp.f90 index 8a6c8c0d80..7a89ccb6ca 100644 --- a/src/gsi/setuppcp.f90 +++ b/src/gsi/setuppcp.f90 @@ -416,8 +416,8 @@ subroutine setuppcp(obsLL,odiagLL,lunin,mype,aivals,nele,nobs,& elseif (amsu) then itype = 8 endif - rterm1=one/float(nsig) - rterm2=one/float(nsig*(nsig-1)) + rterm1=one/real(nsig,r_kind) + rterm2=one/real(nsig*(nsig-1),r_kind) call dtime_setup() do n = 1,nobs diff --git a/src/gsi/setupq.f90 b/src/gsi/setupq.f90 index aa557b72c2..cebdeecd7b 100644 --- a/src/gsi/setupq.f90 +++ b/src/gsi/setupq.f90 @@ -674,7 +674,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav error=one/(error*qsges) iz = max(1, min( int(dpres), nsig)) - delz = max(zero, min(dpres - float(iz), one)) + delz = max(zero, min(dpres - real(iz,r_kind), one)) if (save_jacobian) then diff --git a/src/gsi/setupref.f90 b/src/gsi/setupref.f90 index 752cce7e7b..4f240d756b 100644 --- a/src/gsi/setupref.f90 +++ b/src/gsi/setupref.f90 @@ -301,7 +301,7 @@ subroutine setupref(obsLL,odiagLL,lunin,mype,awork,nele,nobs,toss_gps_sub,is,ini ilate=15 ! index of earth relative latitude (degrees) ! Initialize variables - rsig=float(nsig) + rsig=real(nsig,r_kind) mm1=mype+1 ! Check to see if required guess fields are available @@ -967,11 +967,11 @@ subroutine setupref(obsLL,odiagLL,lunin,mype,awork,nele,nobs,toss_gps_sub,is,ini end do end if -! delz=dpres-float(k1) +! delz=dpres-real(k1,r_kind) kl=dpresl(i) k1l=min(max(1,kl),nsig) k2l=max(1,min(kl+1,nsig)) - delz=dpresl(i)-float(k1l) + delz=dpresl(i)-real(k1l,r_kind) delz=max(zero,min(delz,one)) my_head%jac_t(k1l)=my_head%jac_t(k1l)+termt(i)*(one-delz) my_head%jac_t(k2l)=my_head%jac_t(k2l)+termt(i)*delz diff --git a/src/gsi/setupspd.f90 b/src/gsi/setupspd.f90 index 150799bf2c..2437ea63ce 100644 --- a/src/gsi/setupspd.f90 +++ b/src/gsi/setupspd.f90 @@ -504,7 +504,7 @@ subroutine setupspd(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diags spdges=sqrt(ugesin*ugesin+vgesin*vgesin) iz = max(1, min( int(dpres), nsig)) - delz = max(zero, min(dpres - float(iz), one)) + delz = max(zero, min(dpres - real(iz,r_kind), one)) if (save_jacobian) then diff --git a/src/gsi/setupt.f90 b/src/gsi/setupt.f90 index 5467a6dec9..d0ec421f06 100644 --- a/src/gsi/setupt.f90 +++ b/src/gsi/setupt.f90 @@ -515,7 +515,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav if(netcdf_diag) call init_netcdf_diag_ end if scale=one - rsig=float(nsig) + rsig=real(nsig,r_kind) mm1=mype+1 ! rsli=isli @@ -770,7 +770,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav hrdifsig,mype,nfldsig) iz = max(1, min( int(dpres), nsig)) - delz = max(zero, min(dpres - float(iz), one)) + delz = max(zero, min(dpres - real(iz,r_kind), one)) if (save_jacobian) then t_ind = getindex(svars3d, 'tv') @@ -792,7 +792,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav hrdifsig,mype,nfldsig) iz = max(1, min( int(dpres), nsig)) - delz = max(zero, min(dpres - float(iz), one)) + delz = max(zero, min(dpres - real(iz,r_kind), one)) if (save_jacobian) then t_ind = getindex(svars3d, 'tsen') diff --git a/src/gsi/setuptcp.f90 b/src/gsi/setuptcp.f90 index 3d13c5fe8e..68428175b1 100644 --- a/src/gsi/setuptcp.f90 +++ b/src/gsi/setuptcp.f90 @@ -255,9 +255,9 @@ subroutine setuptcp(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diags lb=dlat-tcp_box le=dlat+tcp_box do j=jb,je - lj=float(j) + lj=real(j,r_kind) do l=lb,le - li=float(l) + li=real(l,r_kind) call tintrp2a11(ges_ps,psges,li,lj,dtime,hrdifsig,mype,nfldsig) if(pmin>psges)then imin=l diff --git a/src/gsi/setupw.f90 b/src/gsi/setupw.f90 index 784df1dfbe..6e653a9db0 100644 --- a/src/gsi/setupw.f90 +++ b/src/gsi/setupw.f90 @@ -677,7 +677,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav hrdifsig,mype,nfldsig) iz = max(1, min( int(dpres), nsig)) - delz = max(zero, min(dpres - float(iz), one)) + delz = max(zero, min(dpres - real(iz,r_kind), one)) if (save_jacobian) then @@ -805,7 +805,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav hrdifsig,mype,nfldsig) iz = max(1, min( int(dpres), nsig)) - delz = max(zero, min(dpres - float(iz), one)) + delz = max(zero, min(dpres - real(iz,r_kind), one)) if (save_jacobian) then u_ind = getindex(svars3d, 'u') diff --git a/src/gsi/setupwspd10m.f90 b/src/gsi/setupwspd10m.f90 index ad50c5b0c1..c702faaecf 100644 --- a/src/gsi/setupwspd10m.f90 +++ b/src/gsi/setupwspd10m.f90 @@ -449,7 +449,7 @@ subroutine setupwspd10m(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_d hrdifsig,mype,nfldsig) iz = max(1, min( int(dpres), nsig)) - delz = max(zero, min(dpres - float(iz), one)) + delz = max(zero, min(dpres - real(iz,r_kind), one)) if (save_jacobian) then diff --git a/src/gsi/sfcobsqc.f90 b/src/gsi/sfcobsqc.f90 index 8327b532e7..880e584b1b 100644 --- a/src/gsi/sfcobsqc.f90 +++ b/src/gsi/sfcobsqc.f90 @@ -1162,7 +1162,7 @@ subroutine get_wbinid(udbl,vdbl,nbins,ibin) endif else do n=1,nbins - if ( wdir >= float(n-1)*binwidth .and. wdir < float(n)*binwidth ) then + if ( wdir >= real(n-1,r_kind)*binwidth .and. wdir < real(n,r_kind)*binwidth ) then ibin=n exit endif diff --git a/src/gsi/smoothzrf.f90 b/src/gsi/smoothzrf.f90 index 06e877ee68..dae656ca1b 100644 --- a/src/gsi/smoothzrf.f90 +++ b/src/gsi/smoothzrf.f90 @@ -81,7 +81,7 @@ subroutine frfhvo(p1,iv) do k=1,lat2 l=int(rllat1(k,j)) l2=min0(l+1,llmax) - dl2(k,j)=rllat1(k,j)-float(l) + dl2(k,j)=rllat1(k,j)-real(l,r_kind) dl1(k,j)=one-dl2(k,j) end do end do diff --git a/src/gsi/ssmis_spatial_average_mod.f90 b/src/gsi/ssmis_spatial_average_mod.f90 index 24ac91d3f1..64dd5c6cf7 100644 --- a/src/gsi/ssmis_spatial_average_mod.f90 +++ b/src/gsi/ssmis_spatial_average_mod.f90 @@ -1551,7 +1551,7 @@ SUBROUTINE SFFTCB( X, N, M ) END DO J = J + K 104 CONTINUE - XT = 1.0 / FLOAT( N ) + XT = 1.0 / real( N,r_kind ) DO 99 I = 1, N X(I) = XT * X(I) 99 CONTINUE diff --git a/src/gsi/statsco.f90 b/src/gsi/statsco.f90 index ebef4a31e4..54f28ccfd9 100644 --- a/src/gsi/statsco.f90 +++ b/src/gsi/statsco.f90 @@ -119,7 +119,7 @@ subroutine statsco(stats_co,bwork,awork,ndata) if (iasim > 0) then svar = error_co(i) if (iuse_co(i)/=1) svar = -svar - rsum = one/float(iasim) + rsum = one/real(iasim,r_kind) icerr = nint(stats_co(2,i)) do j=3,6 ! j=3=obs-mod(w_biascor) ! j=4=(obs-mod(w_biascor))**2 @@ -145,7 +145,7 @@ subroutine statsco(stats_co,bwork,awork,ndata) do i=1,ndat if (idisplay(i)) then cpen=zero - if (icount_asim(i)>0) cpen=rpenal(i)/float(icount_asim(i)) + if (icount_asim(i)>0) cpen=rpenal(i)/real(icount_asim(i),r_kind) write(iout_co,1115) jiter,dplat(i),dtype(i),ndata(i,2), & ndata(i,3),icount_asim(i),rpenal(i),cpen,qcpenal(i),iqccount_asim(i) endif @@ -184,8 +184,8 @@ subroutine statsco(stats_co,bwork,awork,ndata) num(k)=nint(awork(5*nsig+k+100)) rat=zero ; rat3=zero if(num(k) > 0) then - rat=awork(6*nsig+k+100)/float(num(k)) - rat3=awork(3*nsig+k+100)/float(num(k)) + rat=awork(6*nsig+k+100)/real(num(k),r_kind) + rat3=awork(3*nsig+k+100)/real(num(k),r_kind) end if ntot=ntot+num(k); o3plty=o3plty+awork(6*nsig+k+100) o3qcplty=o3qcplty+awork(3*nsig+k+100) diff --git a/src/gsi/statsconv.f90 b/src/gsi/statsconv.f90 index 0da8606f24..3011fdefea 100644 --- a/src/gsi/statsconv.f90 +++ b/src/gsi/statsconv.f90 @@ -204,8 +204,8 @@ subroutine statsconv(mype,& rat1=zero rat2=zero if(num(k) > 0)then - rat1=awork(4*nsig+k+100,i_uv)/float(num(k)) - rat2=awork(5*nsig+k+100,i_uv)/float(num(k)) + rat1=awork(4*nsig+k+100,i_uv)/real(num(k),r_kind) + rat2=awork(5*nsig+k+100,i_uv)/real(num(k),r_kind) end if umplty=umplty+awork(4*nsig+k+100,i_uv) vmplty=vmplty+awork(5*nsig+k+100,i_uv) @@ -218,8 +218,8 @@ subroutine statsconv(mype,& rat1=zero rat3=zero if(num(k) > 0)then - rat1=(awork(4*nsig+k+100,i_uv)+awork(5*nsig+k+100,i_uv))/float(num(k)) - rat3=awork(3*nsig+k+100,i_uv)/float(num(k)) + rat1=(awork(4*nsig+k+100,i_uv)+awork(5*nsig+k+100,i_uv))/real(num(k),r_kind) + rat3=awork(3*nsig+k+100,i_uv)/real(num(k),r_kind) end if uvqcplty=uvqcplty+awork(3*nsig+k+100,i_uv) write(iout_uv,240) 'w',num(k),k,awork(4*nsig+k+100,i_uv)+awork(5*nsig+k+100,i_uv), & @@ -231,9 +231,9 @@ subroutine statsconv(mype,& write(iout_uv,925) 'wind',numgross,numfailqc ! Write statistics regarding penalties if(ntot > 0)then - tu=umplty/float(ntot) - tv=vmplty/float(ntot) - tuv=uvqcplty/float(ntot) + tu=umplty/real(ntot,r_kind) + tv=vmplty/real(ntot,r_kind) + tuv=uvqcplty/real(ntot,r_kind) end if if(numssm > 0)then tssm=awork(5,i_uv)/awork(6,i_uv) @@ -286,8 +286,8 @@ subroutine statsconv(mype,& rat=zero rat3=zero if(num(k)>0) then - rat=awork(6*nsig+k+100,i_gps)/float(num(k)) - rat3=awork(3*nsig+k+100,i_gps)/float(num(k)) + rat=awork(6*nsig+k+100,i_gps)/real(num(k),r_kind) + rat3=awork(3*nsig+k+100,i_gps)/real(num(k),r_kind) end if ntot=ntot+num(k); gpsmplty=gpsmplty+awork(6*nsig+k+100,i_gps) gpsqcplty=gpsqcplty+awork(3*nsig+k+100,i_gps) @@ -352,8 +352,8 @@ subroutine statsconv(mype,& rat=zero rat3=zero if(num(k) > 0)then - rat=awork(5*nsig+k+100,i_q)/float(num(k)) - rat3=awork(3*nsig+k+100,i_q)/float(num(k)) + rat=awork(5*nsig+k+100,i_q)/real(num(k),r_kind) + rat3=awork(3*nsig+k+100,i_q)/real(num(k),r_kind) end if qmplty=qmplty+awork(5*nsig+k+100,i_q) qqcplty=qqcplty+awork(3*nsig+k+100,i_q) @@ -371,8 +371,8 @@ subroutine statsconv(mype,& numhgh = nint(awork(3,i_q)) write(iout_q,900) 'q',numhgh,numlow if(ntot > 0) then - tq=qmplty/float(ntot) - qctq=qqcplty/float(ntot) + tq=qmplty/real(ntot,r_kind) + qctq=qqcplty/real(ntot,r_kind) end if end if @@ -414,8 +414,8 @@ subroutine statsconv(mype,& numfailqc=nint(awork(21,i_ps)) write(iout_ps,925) 'psfc',numgross,numfailqc if(nump > 0)then - pw=awork(4,i_ps)/float(nump) - pw3=awork(22,i_ps)/float(nump) + pw=awork(4,i_ps)/real(nump,r_kind) + pw3=awork(22,i_ps)/real(nump,r_kind) end if end if @@ -1116,8 +1116,8 @@ subroutine statsconv(mype,& num(k)=nint(awork(5*nsig+k+100,i_t)) rat=zero ; rat3=zero if(num(k) > 0) then - rat=awork(6*nsig+k+100,i_t)/float(num(k)) - rat3=awork(3*nsig+k+100,i_t)/float(num(k)) + rat=awork(6*nsig+k+100,i_t)/real(num(k),r_kind) + rat3=awork(3*nsig+k+100,i_t)/real(num(k),r_kind) end if ntot=ntot+num(k); tmplty=tmplty+awork(6*nsig+k+100,i_t) tqcplty=tqcplty+awork(3*nsig+k+100,i_t) @@ -1176,8 +1176,8 @@ subroutine statsconv(mype,& rat=zero rat3=zero if(num(k) > 0) then - rat=awork(6*nsig+k+100,i_dw)/float(num(k)) - rat3=awork(3*nsig+k+100,i_dw)/float(num(k)) + rat=awork(6*nsig+k+100,i_dw)/real(num(k),r_kind) + rat3=awork(3*nsig+k+100,i_dw)/real(num(k),r_kind) end if ntot=ntot+num(k) dwmplty=dwmplty+awork(6*nsig+k+100,i_dw) @@ -1188,8 +1188,8 @@ subroutine statsconv(mype,& numgross=nint(awork(4,i_dw)) numfailqc=nint(awork(21,i_dw)) if(ntot > 0) then - tdw=dwmplty/float(ntot) - qctdw=dwqcplty/float(ntot) + tdw=dwmplty/real(ntot,r_kind) + qctdw=dwqcplty/real(ntot,r_kind) end if write(iout_dw,925) 'dw',numgross,numfailqc numlow = nint(awork(2,i_dw)) @@ -1238,8 +1238,8 @@ subroutine statsconv(mype,& rat=zero rat3=zero if(num(k) > 0) then - rat=awork(6*nsig+k+100,i_rw)/float(num(k)) - rat3=awork(3*nsig+k+100,i_rw)/float(num(k)) + rat=awork(6*nsig+k+100,i_rw)/real(num(k),r_kind) + rat3=awork(3*nsig+k+100,i_rw)/real(num(k),r_kind) end if ntot=ntot+num(k) rwmplty=rwmplty+awork(6*nsig+k+100,i_rw) @@ -1248,8 +1248,8 @@ subroutine statsconv(mype,& awork(3*nsig+k+100,i_rw),rat,rat3 end do if(ntot > 0) then - trw=rwmplty/float(ntot) - qctrw=rwqcplty/float(ntot) + trw=rwmplty/real(ntot,r_kind) + qctrw=rwqcplty/real(ntot,r_kind) end if write(iout_rw,925) 'rw',numgross,numfailqc numlow = nint(awork(2,i_rw)) @@ -1299,8 +1299,8 @@ subroutine statsconv(mype,& rat=zero rat3=zero if(num(k) > 0) then - rat=awork(6*nsig+k+100,i_dbz)/float(num(k)) - rat3=awork(3*nsig+k+100,i_dbz)/float(num(k)) + rat=awork(6*nsig+k+100,i_dbz)/real(num(k),r_kind) + rat3=awork(3*nsig+k+100,i_dbz)/real(num(k),r_kind) end if ntot=ntot+num(k) dbzmplty=dbzmplty+awork(6*nsig+k+100,i_dbz) @@ -1309,8 +1309,8 @@ subroutine statsconv(mype,& awork(3*nsig+k+100,i_dbz),rat,rat3 end do if(ntot > 0) then - tdbz=dbzmplty/float(ntot) - qctdbz=dbzqcplty/float(ntot) + tdbz=dbzmplty/real(ntot,r_kind) + qctdbz=dbzqcplty/real(ntot,r_kind) end if write(iout_dbz,925) 'dbz',numgross,numfailqc numlow = nint(awork(2,i_dbz)) @@ -1360,8 +1360,8 @@ subroutine statsconv(mype,& rat=zero rat3=zero if(num(k) > 0) then - rat=awork(6*nsig+k+100,i_fed)/float(num(k)) - rat3=awork(3*nsig+k+100,i_fed)/float(num(k)) + rat=awork(6*nsig+k+100,i_fed)/real(num(k),r_kind) + rat3=awork(3*nsig+k+100,i_fed)/real(num(k),r_kind) end if ntot=ntot+num(k) fedmplty=fedmplty+awork(6*nsig+k+100,i_fed) @@ -1370,8 +1370,8 @@ subroutine statsconv(mype,& awork(3*nsig+k+100,i_fed),rat,rat3 end do if(ntot > 0) then - tfed=fedmplty/float(ntot) - qctfed=fedqcplty/float(ntot) + tfed=fedmplty/real(ntot,r_kind) + qctfed=fedqcplty/real(ntot,r_kind) end if write(iout_fed,925) 'fed',numgross,numfailqc numlow = nint(awork(2,i_fed)) @@ -1419,8 +1419,8 @@ subroutine statsconv(mype,& write(iout_tcp,925) 'psfc',numgross,numfailqc if(nump > 0)then - pw=awork(4,i_tcp)/float(nump) - pw3=awork(22,i_tcp)/float(nump) + pw=awork(4,i_tcp)/real(nump,r_kind) + pw3=awork(22,i_tcp)/real(nump,r_kind) end if end if @@ -1460,8 +1460,8 @@ subroutine statsconv(mype,& num(k)=nint(awork(6*nsig+k+100,i_lag)) rat=zero ; rat3=zero if(num(k) > 0) then - rat=awork(4*nsig+k+100,i_lag)/float(num(k)) - rat3=awork(3*nsig+k+100,i_lag)/float(num(k)) + rat=awork(4*nsig+k+100,i_lag)/real(num(k),r_kind) + rat3=awork(3*nsig+k+100,i_lag)/real(num(k),r_kind) end if ntot=ntot+num(k); tmplty=tmplty+awork(4*nsig+k+100,i_lag) tqcplty=tqcplty+awork(3*nsig+k+100,i_lag) diff --git a/src/gsi/statsoz.f90 b/src/gsi/statsoz.f90 index 069082d6b7..fb5f536914 100644 --- a/src/gsi/statsoz.f90 +++ b/src/gsi/statsoz.f90 @@ -101,7 +101,7 @@ subroutine statsoz(stats_oz,ndata) if (iasim > 0) then svar = error_oz(i) if (iuse_oz(i)/=1) svar = -svar - rsum = one/float(iasim) + rsum = one/real(iasim,r_kind) icerr = nint(stats_oz(2,i)) do j=3,6 ! j=3=obs-mod(w_biascor) ! j=4=(obs-mod(w_biascor))**2 @@ -127,7 +127,7 @@ subroutine statsoz(stats_oz,ndata) do i=1,ndat if (idisplay(i)) then cpen=zero - if (icount_asim(i)>0) cpen=rpenal(i)/float(icount_asim(i)) + if (icount_asim(i)>0) cpen=rpenal(i)/real(icount_asim(i),r_kind) write(iout_oz,1115) jiter,dplat(i),dtype(i),ndata(i,2), & ndata(i,3),icount_asim(i),rpenal(i),cpen,qcpenal(i),iqccount_asim(i) endif diff --git a/src/gsi/statspcp.f90 b/src/gsi/statspcp.f90 index e16f6dfbe5..ad79aed67d 100644 --- a/src/gsi/statspcp.f90 +++ b/src/gsi/statspcp.f90 @@ -210,7 +210,7 @@ subroutine statspcp(aivals,ndata) if (isum > 0 .and. display(is)) then rpen(is) = aivals(15,is) qcpen(is) = aivals(39,is) - rsum = one/float(isum) + rsum = one/real(isum,r_kind) icerr = nint(aivals(12,is)) do j=13,16 aivals(j,is)=aivals(j,is)*rsum diff --git a/src/gsi/statsrad.f90 b/src/gsi/statsrad.f90 index 121761fa76..d42a53f7d6 100644 --- a/src/gsi/statsrad.f90 +++ b/src/gsi/statsrad.f90 @@ -120,7 +120,7 @@ subroutine statsrad(aivals,stats,ndata) if (iasim > 0) then svar = varch(i) if (iuse_rad(i) < 1) svar=-svar - rsum = one/float(iasim) + rsum = one/real(iasim,r_kind) icerr = nint(stats(2,i)) do j=3,6 ! j=3=obs-mod(w_biascor) ! j=4=(obs-mod(w_biascor))**2 diff --git a/src/gsi/stpjcmod.f90 b/src/gsi/stpjcmod.f90 index 2c811912a0..1cdabe60eb 100644 --- a/src/gsi/stpjcmod.f90 +++ b/src/gsi/stpjcmod.f90 @@ -871,7 +871,7 @@ subroutine stpjcpdry(rval,sval,pen,b,c,nbins) it=ntguessig dmass=zero_quad - rcon=one_quad/(two_quad*float(nlon)) + rcon=one_quad/(two_quad*real(nlon,r_quad)) mm1=mype+1 return_now = .false. do n=1,nbins diff --git a/src/gsi/support_2dvar.f90 b/src/gsi/support_2dvar.f90 index 35599ba548..0a83e96942 100644 --- a/src/gsi/support_2dvar.f90 +++ b/src/gsi/support_2dvar.f90 @@ -2465,19 +2465,19 @@ subroutine relocsfcob(rlon8,rlat8,cobtypein,cstationin,kxin) js=max(1,(jstart-jneighbour)) je=min((jstart+jneighbour),ny) - ris=float(is) - rie=float(ie) - rjs=float(js) - rje=float(je) + ris=real(is,r_single) + rie=real(ie,r_single) + rjs=real(js,r_single) + rje=real(je,r_single) distmin=1.e+20_r_single lfound=.false. do j=1,npts - rj=rjs+float(j-1)*dy + rj=rjs+real(j-1,r_single)*dy if (rj > rje) cycle do i=1,npts - ri=ris+float(i-1)*dx + ri=ris+real(i-1,r_single)*dx if (ri > rie) cycle call bilinear_2d0(slmask,nx,ny,slmask0,rj,ri) @@ -2655,7 +2655,7 @@ subroutine mkvalley_file endif enddo enddo - hmean=hmean/max(1._r_single,float(ncount)) + hmean=hmean/max(1._r_single,real(ncount,r_single)) if ((hmax-hmin)>=hdiff0 .and. terrain(i,j) stdout 2>&1" -rc=$? - -exit $rc diff --git a/regression/global_4dvar.sh b/regression/global_4dvar.sh deleted file mode 100755 index cac0d28e6b..0000000000 --- a/regression/global_4dvar.sh +++ /dev/null @@ -1,338 +0,0 @@ -set -x - -# Set experiment name and analysis date - -exp=$jobname - -# Set the JCAP resolution which you want. -export JCAP=48 -export LEVS=127 -export JCAP_B=48 - -# Set runtime directories -tmpdir=$tmpdir/$tmpregdir/${exp} - -# Specify GSI fixed field and data directories. -fixcrtm=${fixcrtm:-$CRTM_FIX} - - -# Set variables used in script -UNCOMPRESS=gunzip -CLEAN=NO -ncp=/bin/cp -nln="/bin/ln -fs" - - -# Given the requested resolution, set dependent resolution parameters -if [[ "$JCAP" = "96" ]]; then - export LONA=384 - export LATA=192 - export DELTIM=1200 -elif [[ "$JCAP" = "48" ]]; then - export LONA=192 - export LATA=96 - export DELTIM=1200 -else - echo "INVALID JCAP = $JCAP" - exit -fi -export NLON=$LONA -export NLAT=$((${LATA}+2)) - - -# Given the analysis date, compute the date from which the -# first guess comes. Extract cycle and set prefix and suffix -# for guess and observation data files -gdate=`date +%Y%m%d%H -d "${global_adate:0:8} ${global_adate:8:2} - 6 hours"` -PDYa=`echo $global_adate | cut -c1-8` -cyca=`echo $global_adate | cut -c9-10` -PDYg=`echo $gdate | cut -c1-8` -cycg=`echo $gdate | cut -c9-10` - -dumpobs=gdas -prefix_obs=${dumpobs}.t${cyca}z -prefix_ges=gdas.t${cycg}z -prefix_ens=gdas.t${cycg}z -suffix=tm00.bufr_d - -dumpges=gdas -COMROOTgfs=$casesdir/gfs/prod -datobs=$COMROOTgfs/$dumpobs.$PDYa/${cyca}/atmos -datges=$COMROOTgfs/$dumpges.$PDYg/${cycg}/atmos -datens=$COMROOTgfs/enkfgdas.$PDYg/${cycg}/atmos - - -# Set up $tmpdir -rm -rf $tmpdir -mkdir -p $tmpdir -cd $tmpdir - -# Make gsi namelist - -SETUP="" -GRIDOPTS="" -BKGVERR="" -ANBKGERR="" -JCOPTS="" -STRONGOPTS="" -OBSQC="" -OBSINPUT="" -SUPERRAD="" -SINGLEOB="" - - -# Set fixed files -# berror = forecast model background error statistics -# specoef = CRTM spectral coefficients -# trncoef = CRTM transmittance coefficients -# emiscoef = CRTM coefficients for IR sea surface emissivity model -# aerocoef = CRTM coefficients for aerosol effects -# cldcoef = CRTM coefficients for cloud effects -# satinfo = text file with information about assimilation of brightness temperatures -# satangl = angle dependent bias correction file (fixed in time) -# pcpinfo = text file with information about assimilation of prepcipitation rates -# ozinfo = text file with information about assimilation of ozone data -# errtable = text file with obs error for conventional data (optional) -# convinfo = text file with information about assimilation of conventional data -# bufrtable= text file ONLY needed for single obs test (oneobstest=.true.) -# bftab_sst= bufr table for sst ONLY needed for sst retrieval (retrieval=.true.) -# aeroinfo = text file with information about assimilation of aerosol data - -anavinfo=$fixgsi/global_anavinfo_qlqi.l${LEVS}.txt -berror=$fixgsi/Big_Endian/global_berror.l${LEVS}y${NLAT}.f77 -locinfo=$fixgsi/global_hybens_info.l${LEVS}.txt -satinfo=$fixgsi/global_satinfo.txt -scaninfo=$fixgsi/global_scaninfo.txt -satangl=$fixgsi/global_satangbias.txt -pcpinfo=$fixgsi/global_pcpinfo.txt -ozinfo=$fixgsi/global_ozinfo.txt -convinfo=$fixgsi/global_convinfo.txt -vqcdat=$fixgsi/vqctp001.dat -insituinfo=$fixgsi/global_insituinfo.txt -errtable=$fixgsi/prepobs_errtable.global -aeroinfo=$fixgsi/global_aeroinfo.txt -atmsbeaminfo=$fixgsi/atms_beamwidth.txt -cloudyinfo=$fixgsi/cloudy_radiance_info.txt - -emiscoef_IRwater=$fixcrtm/Nalli.IRwater.EmisCoeff.bin -emiscoef_IRice=$fixcrtm/NPOESS.IRice.EmisCoeff.bin -emiscoef_IRland=$fixcrtm/NPOESS.IRland.EmisCoeff.bin -emiscoef_IRsnow=$fixcrtm/NPOESS.IRsnow.EmisCoeff.bin -emiscoef_VISice=$fixcrtm/NPOESS.VISice.EmisCoeff.bin -emiscoef_VISland=$fixcrtm/NPOESS.VISland.EmisCoeff.bin -emiscoef_VISsnow=$fixcrtm/NPOESS.VISsnow.EmisCoeff.bin -emiscoef_VISwater=$fixcrtm/NPOESS.VISwater.EmisCoeff.bin -emiscoef_MWwater=$fixcrtm/FASTEM6.MWwater.EmisCoeff.bin -aercoef=$fixcrtm/AerosolCoeff.bin -cldcoef=$fixcrtm/CloudCoeff.bin -#cldcoef=$fixcrtm/CloudCoeff.GFDLFV3.-109z-1.bin # use with crtm/2.4.0 - -# Only need this file for single obs test -bufrtable=$fixgsi/prepobs_prep.bufrtable - -# Only need this file for sst retrieval -bftab_sst=$fixgsi/bufrtab.012 - -# Copy executable and fixed files to $tmpdir -if [[ $exp == *"updat"* ]]; then - $ncp $gsiexec_updat ./gsi.x -elif [[ $exp == *"contrl"* ]]; then - $ncp $gsiexec_contrl ./gsi.x -fi - -$ncp $anavinfo ./anavinfo -$ncp $berror ./berror_stats -$ncp $locinfo ./hybens_info -$ncp $satinfo ./satinfo -$ncp $scaninfo ./scaninfo -##$ncp $satangl ./satbias_angle -$ncp $pcpinfo ./pcpinfo -$ncp $ozinfo ./ozinfo -$ncp $convinfo ./convinfo -$ncp $vqcdat ./vqctp001.dat -$ncp $insituinfo ./insituinfo -$ncp $errtable ./errtable -$ncp $aeroinfo ./aeroinfo -$ncp $atmsbeaminfo ./atms_beamwidth.txt -$ncp $cloudyinfo ./cloudy_radiance_info.txt - -$ncp $bufrtable ./prepobs_prep.bufrtable -$ncp $bftab_sst ./bftab_sstphr - -#If using correlated error, get the covariance files -if grep -q "Rcov" $anavinfo ; -then - if ls ${fixgsi}/Rcov* 1> /dev/null 2>&1; - then - $ncp ${fixgsi}/Rcov* $tmpdir - -# Correlated error utlizes mkl lapack. Found it necesary to fix the -# number of mkl threads to ensure reproducible results independent -# of the job configuration. - export MKL_NUM_THREADS=1 - - else - echo "Warning: Satellite error covariance files are missing." - echo "Check for the required Rcov files in " $ANAVINFO - exit 1 - fi -fi - -# Copy CRTM coefficient files based on entries in satinfo file -export CRTM_PATH="./crtm_coeffs/" -mkdir -p ${CRTM_PATH} -for file in `awk '{if($1!~"!"){print $1}}' satinfo | sort | uniq` ;do - $nln $fixcrtm/${file}.SpcCoeff.bin ${CRTM_PATH}/${file}.SpcCoeff.bin - $nln $fixcrtm/${file}.TauCoeff.bin ${CRTM_PATH}/${file}.TauCoeff.bin -done -$nln $fixcrtm/amsua_metop-a_v2.SpcCoeff.bin ${CRTM_PATH}/amsua_metop-a_v2.SpcCoeff.bin - -$nln $emiscoef_IRwater ${CRTM_PATH}Nalli.IRwater.EmisCoeff.bin -$nln $emiscoef_IRice ${CRTM_PATH}NPOESS.IRice.EmisCoeff.bin -$nln $emiscoef_IRsnow ${CRTM_PATH}NPOESS.IRsnow.EmisCoeff.bin -$nln $emiscoef_IRland ${CRTM_PATH}NPOESS.IRland.EmisCoeff.bin -$nln $emiscoef_VISice ${CRTM_PATH}NPOESS.VISice.EmisCoeff.bin -$nln $emiscoef_VISland ${CRTM_PATH}NPOESS.VISland.EmisCoeff.bin -$nln $emiscoef_VISsnow ${CRTM_PATH}NPOESS.VISsnow.EmisCoeff.bin -$nln $emiscoef_VISwater ${CRTM_PATH}NPOESS.VISwater.EmisCoeff.bin -$nln $emiscoef_MWwater ${CRTM_PATH}FASTEM6.MWwater.EmisCoeff.bin -$nln $aercoef ${CRTM_PATH}AerosolCoeff.bin -$nln $cldcoef ${CRTM_PATH}CloudCoeff.bin - -# Copy observational data -$nln $datobs/${prefix_obs}.prepbufr ./prepbufr -$nln $datobs/${prefix_obs}.prepbufr.acft_profiles ./prepbufr_profl -$nln $datobs/${prefix_obs}.nsstbufr ./nsstbufr -$nln $datobs/${prefix_obs}.syndata.tcvitals.tm00 ./tcvitl -$nln $datobs/${prefix_obs}.gpsro.${suffix} ./gpsrobufr -$nln $datobs/${prefix_obs}.satwnd.${suffix} ./satwndbufr -$nln $datobs/${prefix_obs}.hdob.${suffix} ./hdobbufr - -$nln $datobs/${prefix_obs}.osbuv8.${suffix} ./sbuvbufr -$nln $datobs/${prefix_obs}.gome.${suffix} ./gomebufr -$nln $datobs/${prefix_obs}.omi.${suffix} ./omibufr -$nln $datobs/${prefix_obs}.mls.${suffix} ./mlsbufr -$nln $datobs/${prefix_obs}.ompsn8.${suffix} ./ompsnpbufr -$nln $datobs/${prefix_obs}.ompst8.${suffix} ./ompstcbufr -$nln $datobs/${prefix_obs}.ompslp.${suffix} ./ompslpbufr - -$nln $datobs/${prefix_obs}.goesfv.${suffix} ./gsnd1bufr -$nln $datobs/${prefix_obs}.hrs3db.${suffix} ./hirs3bufr_db -$nln $datobs/${prefix_obs}.airsev.${suffix} ./airsbufr -$nln $datobs/${prefix_obs}.sevcsr.${suffix} ./seviribufr -$nln $datobs/${prefix_obs}.saphir.${suffix} ./saphirbufr -$nln $datobs/${prefix_obs}.avcsam.${suffix} ./avhambufr -$nln $datobs/${prefix_obs}.avcspm.${suffix} ./avhpmbufr -$nln $datobs/${prefix_obs}.1bhrs4.${suffix} ./hirs4bufr -$nln $datobs/${prefix_obs}.1bhrs2.${suffix} ./hirs2bufr -$nln $datobs/${prefix_obs}.1bhrs3.${suffix} ./hirs3bufr -$nln $datobs/${prefix_obs}.eshrs3.${suffix} ./hirs3bufrears -$nln $datobs/${prefix_obs}.hrs3db.${suffix} ./hirs3bufr_db -$nln $datobs/${prefix_obs}.mtiasi.${suffix} ./iasibufr -$nln $datobs/${prefix_obs}.esiasi.${suffix} ./iasibufrears -$nln $datobs/${prefix_obs}.iasidb.${suffix} ./iasibufr_db -$nln $datobs/${prefix_obs}.crisf4.${suffix} ./crisfsbufr -$nln $datobs/${prefix_obs}.escrsf.${suffix} ./crisfsbufrears -$nln $datobs/${prefix_obs}.crsfdb.${suffix} ./crisfsbufr_db -$nln $datobs/${prefix_obs}.ahicsr.${suffix} ./ahibufr -$nln $datobs/${prefix_obs}.gsrcsr.${suffix} ./abibufr -$nln $datobs/${prefix_obs}.sstvcw.${suffix} ./sstviirs - -$nln $datobs/${prefix_obs}.1bmhs.${suffix} ./mhsbufr -$nln $datobs/${prefix_obs}.1bmsu.${suffix} ./msubufr -$nln $datobs/${prefix_obs}.gmi1cr.${suffix} ./gmibufr -$nln $datobs/${prefix_obs}.ssmit.${suffix} ./ssmitbufr -$nln $datobs/${prefix_obs}.ssmisu.${suffix} ./ssmisbufr -$nln $datobs/${prefix_obs}.1bamua.${suffix} ./amsuabufr -$nln $datobs/${prefix_obs}.esamua.${suffix} ./amsuabufrears -$nln $datobs/${prefix_obs}.amuadb.${suffix} ./amsuabufr_db -$nln $datobs/${prefix_obs}.1bamub.${suffix} ./amsubbufr -$nln $datobs/${prefix_obs}.esamub.${suffix} ./amsubbufrears -$nln $datobs/${prefix_obs}.amubdb.${suffix} ./amsubbufr_db -$nln $datobs/${prefix_obs}.atms.${suffix} ./atmsbufr -$nln $datobs/${prefix_obs}.atmsdb.${suffix} ./atmsbufr_db -$nln $datobs/${prefix_obs}.esatms.${suffix} ./atmsbufrears - -# Do not process -## $nln $datobs/${prefix_obs}.amsre.${suffix} ./amsrebufr -## $nln $datobs/${prefix_obs}.amsr2.tm00.bufr_d ./amsr2bufr - -# Copy bias correction, atmospheric and surface files -##$nln $datges/${prefix_ges}.abias ./satbias_in -##$nln $datges/${prefix_ges}.abias_pc ./satbias_pc -##$nln $datges/${prefix_ges}.abias_air ./aircftbias_in - - -#$nln $datges/${prefix_ges}.abias.4dvar ./satbias_in -$nln $datges/${prefix_ges}.satang.4dvar ./satbias_angle - -$nln $datges/${prefix_ges}.radstat ./radstat.gdas - -member=mem001 -$nln $datens/$member/${prefix_ges}.sfcf003.nc ./sfcf03 -##$nln $datens/$member/${prefix_ges}.sfcf004.nc ./sfcf04 -##$nln $datens/$member/${prefix_ges}.sfcf005.nc ./sfcf05 -$nln $datens/$member/${prefix_ges}.sfcf006.nc ./sfcf06 -##$nln $datens/$member/${prefix_ges}.sfcf007.nc ./sfcf07 -##$nln $datens/$member/${prefix_ges}.sfcf008.nc ./sfcf08 -$nln $datens/$member/${prefix_ges}.sfcf009.nc ./sfcf09 - -$nln $datens/$member/${prefix_ges}.atmf003.nc ./sigf03 -##$nln $datens/$member/${prefix_ges}.atmf004.nc ./sigf04 -##$nln $datens/$member/${prefix_ges}.atmf005.nc ./sigf05 -$nln $datens/$member/${prefix_ges}.atmf006.nc ./sigf06 -##$nln $datens/$member/${prefix_ges}.atmf007.nc ./sigf07 -##$nln $datens/$member/${prefix_ges}.atmf008.nc ./sigf08 -$nln $datens/$member/${prefix_ges}.atmf009.nc ./sigf09 - -$nln $datens/${prefix_ens}.sfcf006.ensmean.nc ./sfcf06_anlgrid - -listdiag=`tar xvf radstat.gdas | cut -d' ' -f2 | grep _ges` -for type in $listdiag; do - diag_file=`echo $type | cut -d',' -f1` - fname=`echo $diag_file | cut -d'.' -f1` - date=`echo $diag_file | cut -d'.' -f2` - $UNCOMPRESS $diag_file - fnameanl=$(echo $fname|sed 's/_ges//g') - mv $fname.$date $fnameanl -done - - -# Run GSI in observer mode -SETUP="l4dvar=.true.,jiterstart=1,lobserver=.true.,iwrtinc=1,nhr_assimilation=6,nhr_obsbin=1," -if [ "$debug" = ".false." ]; then - . $scripts/regression_namelists.sh global_lanczos -else - . $scripts/regression_namelists_db.sh global_lanczos -fi -rm gsiparm.anl -cat << EOF > gsiparm.anl -$gsi_namelist -EOF -cp gsiparm.anl gsiparm.anl.obsvr - -echo "run gsi observer" -eval "$APRUN $tmpdir/gsi.x < gsiparm.anl > stdout.obsvr 2>&1" -ra=$? - -# Run gsi identity model 4dvar under Parallel Operating Environment (poe) on NCEP IBM -rm -f siganl sfcanl.gsi satbias_out fort.2* -rm -rf dir.0* - -# Create namelist for identity model 4dvar run -SETUP="l4dvar=.true.,jiterstart=1,nhr_assimilation=6,nhr_obsbin=1,idmodel=.true.,iwrtinc=1,lanczosave=.true.," -if [ "$debug" = ".false." ]; then - . $scripts/regression_namelists.sh global_lanczos -else - . $scripts/regression_namelists_db.sh global_lanczos -fi -rm gsiparm.anl -cat < gsiparm.anl -$gsi_namelist -EOF - -echo "run gsi 4dvar" -eval "$APRUN $tmpdir/gsi.x < gsiparm.anl > stdout 2>&1" -rb=$? -rc=$((ra+rb)) -exit $rc diff --git a/regression/hafs_3denvar_hybens.sh b/regression/hafs_3denvar_hybens.sh new file mode 100755 index 0000000000..bd1c5b886d --- /dev/null +++ b/regression/hafs_3denvar_hybens.sh @@ -0,0 +1,455 @@ +set -x +# Set variables used in script +# CLEAN up $tmpdir when finished (YES=remove, NO=leave alone) +# ncp is cp replacement, currently keep as /bin/cp + +UNCOMPRESS=gunzip +CLEAN=NO +ncp=/bin/cp +nln="/bin/ln -sf" + +# HAFS test cases set up +RUN_FGAT=YES # use FGAT or not +RUN_ENSDA=YES +l4densvar=.false. +nhr_obsbin=-1 +l_both_fv3sar_gfs_ens=.true. +n_ens_gfs=5 +n_ens_fv3sar=5 + +# +# Set experiment name +# +exp=$jobname + +#----------------------------------------------------------------------- +# +# Extract from ADATE the starting year, month, day, and hour of the +# forecast. These are needed below for various operations. +# +#----------------------------------------------------------------------- +# +adate=${hafs_envar_adate} +YYYYMMDDHH=$(date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2}") +JJJ=$(date +%j -d "${adate:0:8} ${adate:8:2}") + +YYYY=${YYYYMMDDHH:0:4} +MM=${YYYYMMDDHH:4:2} +DD=${YYYYMMDDHH:6:2} +HH=${YYYYMMDDHH:8:2} +YYYYMMDD=${YYYYMMDDHH:0:8} +PDY=${YYYYMMDD} +cyc=${HH} +# prior date and hour +adateprior=`date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2} - 6 hours"` + +ymdprior=$(echo ${adateprior} | cut -c1-8) +hhprior=$(echo ${adateprior} | cut -c9-10) + +CDATEtm03=`date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2} - 3 hours"` +ymdtm03=$(echo ${CDATEtm03} | cut -c1-8) +hhtm03=$(echo ${CDATEtm03} | cut -c9-10) + +CDATEtp03=`date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2} + 3 hours"` +ymdtp03=$(echo ${CDATEtp03} | cut -c1-8) +hhtp03=$(echo ${CDATEtp03} | cut -c9-10) + +# +#----------------------------------------------------------------------- +# +# go to working directory and save directory. +# define fix and background path +# +#----------------------------------------------------------------------- +# Set runtime and save directories +tmpdir=$tmpdir/tmpreg_hafs_3denvar_hybens/${exp} +savdir=$savdir/outreg_hafs_3denvar_hybens/${exp} + +# Set up $tmpdir +rm -rf $tmpdir +mkdir -p $tmpdir +chgrp rstprod $tmpdir +chmod 750 $tmpdir +cd $tmpdir + +bkpath=${hafs_envar_ges} +fixcrtm=${fixcrtm:-$CRTM_FIX} + +################################################################ +##### input data and fix directory ####################### +inputdata=${hafs_envar_ges} +COMINgdas=${hafs_envar_ens} +COMINobs=${hafs_envar_obs} +COMINgfs=${hafs_envar_obs} +WORKhafs=${hafs_envar_obs} +########################################################## + +# use FGAT or not +if [ ${RUN_FGAT} = "YES" ]; then + ln -sf ${inputdata}/coupler.res_03 . + ln -sf ${inputdata}/fv3_akbk_03 . + ln -sf ${inputdata}/fv3_sfcdata_03 . + ln -sf ${inputdata}/fv3_srfwnd_03 . + ln -sf ${inputdata}/fv3_dynvars_03 . + ln -sf ${inputdata}/fv3_tracer_03 . + + ln -sf ${inputdata}/coupler.res_09 . + ln -sf ${inputdata}/fv3_akbk_09 . + ln -sf ${inputdata}/fv3_sfcdata_09 . + ln -sf ${inputdata}/fv3_srfwnd_09 . + ln -sf ${inputdata}/fv3_dynvars_09 . + ln -sf ${inputdata}/fv3_tracer_09 . +fi + +# copy background and grib configuration files +cp ${bkpath}/${YYYYMMDD}.${HH}0000.coupler.res ./coupler.res +cp ${bkpath}/${YYYYMMDD}.${HH}0000.fv_core.res.nc ./fv3_akbk +cp ${bkpath}/${YYYYMMDD}.${HH}0000.sfc_data.nc ./fv3_sfcdata +cp ${bkpath}/${YYYYMMDD}.${HH}0000.fv_srf_wnd.res.tile1.nc ./fv3_srfwnd +cp ${bkpath}/${YYYYMMDD}.${HH}0000.fv_core.res.tile1.nc ./fv3_dynvars +cp ${bkpath}/${YYYYMMDD}.${HH}0000.fv_tracer.res.tile1.nc ./fv3_tracer + +cp ${bkpath}/oro_data.nc ./fv3_oro_data +cp ${bkpath}/atmos_static.nc ./fv3_atmos_static +cp ${bkpath}/grid_spec.nc ./fv3_grid_spec + +# create ensemble member file list +if [ ${RUN_ENSDA} != "YES" ] || [ $l_both_fv3sar_gfs_ens = .true. ]; then +# Link gdas ensemble members + mkdir -p ensemble_data + GSUFFIX=${GSUFFIX:-.nc} + if [ ${l4densvar:-.false.} = ".true." ]; then + fhrs="03 06 09" + else + fhrs="06" + fi + for fhh in $fhrs; do + rm -f filelist${fhh} + for mem in $(seq -f '%03g' 1 ${n_ens_gfs}); do + if [ -s ${COMINgdas}/enkfgdas.${ymdprior}/${hhprior}/atmos/mem${mem}/gdas.t${hhprior}z.atmf0${fhh}s${GSUFFIX:-.nc} ]; then + ${nln} ${COMINgdas}/enkfgdas.${ymdprior}/${hhprior}/atmos/mem${mem}/gdas.t${hhprior}z.atmf0${fhh}s${GSUFFIX:-.nc} ./ensemble_data/enkfgdas.${ymdprior}${hhprior}.atmf0${fhh}_ens_${mem} + elif [ -s ${COMINgdas}/enkfgdas.${ymdprior}/${hhprior}/atmos/mem${mem}/gdas.t${hhprior}z.atmf0${fhh}${GSUFFIX:-.nc} ]; then + ${nln} ${COMINgdas}/enkfgdas.${ymdprior}/${hhprior}/atmos/mem${mem}/gdas.t${hhprior}z.atmf0${fhh}${GSUFFIX:-.nc} ./ensemble_data/enkfgdas.${ymdprior}${hhprior}.atmf0${fhh}_ens_${mem} + fi + echo "./ensemble_data/enkfgdas.${ymdprior}${hhprior}.atmf0${fhh}_ens_${mem}" >> filelist${fhh} + done + done +fi + +if [ ${RUN_ENSDA} = "YES" ]; then + for mem in $(seq -f '%03g' 1 ${n_ens_fv3sar}) + do + RESTARTens=${inputdata} + fhh="06" + ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-coupler.res . + ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-fv3_akbk . + ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-fv3_sfcdata . + ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-fv3_srfwnd . + ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-fv3_dynvars . + ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-fv3_tracer . + if [ ! -s ./fv3_ens_grid_spec ]; then + ln -sf ${RESTARTens}/grid_spec.nc ./fv3_ens_grid_spec + fi + if [ ${l4densvar:-.false.} = ".true." ]; then + export ENS_NSTARTHR=3 + fhh="03" + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-coupler.res . + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_akbk . + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_sfcdata . + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_srfwnd . + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_dynvars . + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_tracer . + fhh="09" + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-coupler.res . + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_akbk . + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_sfcdata . + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_srfwnd . + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_dynvars . + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_tracer . + fi + done +fi +if [ ${RUN_ENSDA} != "YES" ]; then + export N_ENS=${n_ens_gfs} + export BETA_S0=${BETA_S0:-0.2} + export GRID_RATIO_ENS=1 + export REGIONAL_ENSEMBLE_OPTION=1 +elif [ ${RUN_ENSDA} = "YES" ]; then + if [ $l_both_fv3sar_gfs_ens = .false. ]; then + export N_ENS=${n_ens_fv3sar} + export BETA_S0=${BETA_S0:-0.0} + export GRID_RATIO_ENS=2 + export grid_ratio_fv3_regional=2 + export REGIONAL_ENSEMBLE_OPTION=5 + elif [ $l_both_fv3sar_gfs_ens = .true. ]; then + export N_ENS=$((${n_ens_gfs} + ${n_ens_fv3sar})) + export BETA_S0=${BETA_S0:-0.0} + export GRID_RATIO_ENS=2 + export grid_ratio_fv3_regional=2 + export REGIONAL_ENSEMBLE_OPTION=5 + fi +fi + +#----------------------------------------------------------------------- +# +# link observation files +# copy observation files to working directory +# +#----------------------------------------------------------------------- + +# Link GFS/GDAS input and observation files +COMIN_OBS=${COMIN_OBS:-${COMINobs}} +COMIN_GFS=${COMIN_GFS:-${COMINgfs}} + +OPREFIX=${OPREFIX:-"gfs.t${cyc}z."} +OSUFFIX=${OSUFFIX:-""} +PREPQC=${PREPQC:-${COMIN_OBS}/${OPREFIX}prepbufr${OSUFFIX}} +PREPQCPF=${PREPQCPF:-${COMIN_OBS}/${OPREFIX}prepbufr.acft_profiles${OSUFFIX}} +NSSTBF=${NSSTBF:-${COMIN_OBS}/${OPREFIX}nsstbufr${OSUFFIX}} +SATWND=${SATWND:-${COMIN_OBS}/${OPREFIX}satwnd.tm00.bufr_d${OSUFFIX}} +SATWHR=${SATWHR:-${COMIN_OBS}/${OPREFIX}satwhr.tm00.bufr_d${OSUFFIX}} +OSCATBF=${OSCATBF:-${COMIN_OBS}/${OPREFIX}oscatw.tm00.bufr_d${OSUFFIX}} +RAPIDSCATBF=${RAPIDSCATBF:-${COMIN_OBS}/${OPREFIX}rapidscatw.tm00.bufr_d${OSUFFIX}} +GSNDBF=${GSNDBF:-${COMIN_OBS}/${OPREFIX}goesnd.tm00.bufr_d${OSUFFIX}} +GSNDBF1=${GSNDBF1:-${COMIN_OBS}/${OPREFIX}goesfv.tm00.bufr_d${OSUFFIX}} +B1HRS2=${B1HRS2:-${COMIN_OBS}/${OPREFIX}1bhrs2.tm00.bufr_d${OSUFFIX}} +B1MSU=${B1MSU:-${COMIN_OBS}/${OPREFIX}1bmsu.tm00.bufr_d${OSUFFIX}} +B1HRS3=${B1HRS3:-${COMIN_OBS}/${OPREFIX}1bhrs3.tm00.bufr_d${OSUFFIX}} +B1HRS4=${B1HRS4:-${COMIN_OBS}/${OPREFIX}1bhrs4.tm00.bufr_d${OSUFFIX}} +B1AMUA=${B1AMUA:-${COMIN_OBS}/${OPREFIX}1bamua.tm00.bufr_d${OSUFFIX}} +B1AMUB=${B1AMUB:-${COMIN_OBS}/${OPREFIX}1bamub.tm00.bufr_d${OSUFFIX}} +B1MHS=${B1MHS:-${COMIN_OBS}/${OPREFIX}1bmhs.tm00.bufr_d${OSUFFIX}} +ESHRS3=${ESHRS3:-${COMIN_OBS}/${OPREFIX}eshrs3.tm00.bufr_d${OSUFFIX}} +ESAMUA=${ESAMUA:-${COMIN_OBS}/${OPREFIX}esamua.tm00.bufr_d${OSUFFIX}} +ESAMUB=${ESAMUB:-${COMIN_OBS}/${OPREFIX}esamub.tm00.bufr_d${OSUFFIX}} +ESMHS=${ESMHS:-${COMIN_OBS}/${OPREFIX}esmhs.tm00.bufr_d${OSUFFIX}} +HRS3DB=${HRS3DB:-${COMIN_OBS}/${OPREFIX}hrs3db.tm00.bufr_d${OSUFFIX}} +AMUADB=${AMUADB:-${COMIN_OBS}/${OPREFIX}amuadb.tm00.bufr_d${OSUFFIX}} +AMUBDB=${AMUBDB:-${COMIN_OBS}/${OPREFIX}amubdb.tm00.bufr_d${OSUFFIX}} +MHSDB=${MHSDB:-${COMIN_OBS}/${OPREFIX}mhsdb.tm00.bufr_d${OSUFFIX}} +AIRSBF=${AIRSBF:-${COMIN_OBS}/${OPREFIX}airsev.tm00.bufr_d${OSUFFIX}} +IASIBF=${IASIBF:-${COMIN_OBS}/${OPREFIX}mtiasi.tm00.bufr_d${OSUFFIX}} +ESIASI=${ESIASI:-${COMIN_OBS}/${OPREFIX}esiasi.tm00.bufr_d${OSUFFIX}} +IASIDB=${IASIDB:-${COMIN_OBS}/${OPREFIX}iasidb.tm00.bufr_d${OSUFFIX}} +AMSREBF=${AMSREBF:-${COMIN_OBS}/${OPREFIX}amsre.tm00.bufr_d${OSUFFIX}} +AMSR2BF=${AMSR2BF:-${COMIN_OBS}/${OPREFIX}amsr2.tm00.bufr_d${OSUFFIX}} +GMI1CRBF=${GMI1CRBF:-${COMIN_OBS}/${OPREFIX}gmi1cr.tm00.bufr_d${OSUFFIX}} +SAPHIRBF=${SAPHIRBF:-${COMIN_OBS}/${OPREFIX}saphir.tm00.bufr_d${OSUFFIX}} +SEVIRIBF=${SEVIRIBF:-${COMIN_OBS}/${OPREFIX}sevcsr.tm00.bufr_d${OSUFFIX}} +AHIBF=${AHIBF:-${COMIN_OBS}/${OPREFIX}ahicsr.tm00.bufr_d${OSUFFIX}} +ABIBF=${ABIBF:-${COMIN_OBS}/${OPREFIX}gsrcsr.tm00.bufr_d${OSUFFIX}} +CRISBF=${CRISBF:-${COMIN_OBS}/${OPREFIX}cris.tm00.bufr_d${OSUFFIX}} +ESCRIS=${ESCRIS:-${COMIN_OBS}/${OPREFIX}escris.tm00.bufr_d${OSUFFIX}} +CRISDB=${CRISDB:-${COMIN_OBS}/${OPREFIX}crisdb.tm00.bufr_d${OSUFFIX}} +CRISFSBF=${CRISFSBF:-${COMIN_OBS}/${OPREFIX}crisf4.tm00.bufr_d${OSUFFIX}} +ESCRISFS=${ESCRISFS:-${COMIN_OBS}/${OPREFIX}escrsf.tm00.bufr_d${OSUFFIX}} +CRISFSDB=${CRISFSDB:-${COMIN_OBS}/${OPREFIX}crsfdb.tm00.bufr_d${OSUFFIX}} +ATMSBF=${ATMSBF:-${COMIN_OBS}/${OPREFIX}atms.tm00.bufr_d${OSUFFIX}} +ESATMS=${ESATMS:-${COMIN_OBS}/${OPREFIX}esatms.tm00.bufr_d${OSUFFIX}} +ATMSDB=${ATMSDB:-${COMIN_OBS}/${OPREFIX}atmsdb.tm00.bufr_d${OSUFFIX}} +ESATMS=${ESATMS:-${COMIN_OBS}/${OPREFIX}esatms.tm00.bufr_d${OSUFFIX}} +ATMSDB=${ATMSDB:-${COMIN_OBS}/${OPREFIX}atmsdb.tm00.bufr_d${OSUFFIX}} +SSMITBF=${SSMITBF:-${COMIN_OBS}/${OPREFIX}ssmit.tm00.bufr_d${OSUFFIX}} +SSMISBF=${SSMISBF:-${COMIN_OBS}/${OPREFIX}ssmisu.tm00.bufr_d${OSUFFIX}} +SBUVBF=${SBUVBF:-${COMIN_OBS}/${OPREFIX}osbuv8.tm00.bufr_d${OSUFFIX}} +OMPSNPBF=${OMPSNPBF:-${COMIN_OBS}/${OPREFIX}ompsn8.tm00.bufr_d${OSUFFIX}} +OMPSTCBF=${OMPSTCBF:-${COMIN_OBS}/${OPREFIX}ompst8.tm00.bufr_d${OSUFFIX}} +GOMEBF=${GOMEBF:-${COMIN_OBS}/${OPREFIX}gome.tm00.bufr_d${OSUFFIX}} +OMIBF=${OMIBF:-${COMIN_OBS}/${OPREFIX}omi.tm00.bufr_d${OSUFFIX}} +MLSBF=${MLSBF:-${COMIN_OBS}/${OPREFIX}mls.tm00.bufr_d${OSUFFIX}} +OMPSLPBF=${OMPSLPBF:-${COMIN_OBS}/${OPREFIX}ompslp.tm00.bufr_d${OSUFFIX}} +SMIPCP=${SMIPCP:-${COMIN_OBS}/${OPREFIX}spssmi.tm00.bufr_d${OSUFFIX}} +TMIPCP=${TMIPCP:-${COMIN_OBS}/${OPREFIX}sptrmm.tm00.bufr_d${OSUFFIX}} +if [[ ${use_bufr_nr:-no} = "no" ]]; then + GPSROBF=${GPSROBF:-${COMIN_OBS}/${OPREFIX}gpsro.tm00.bufr_d${OSUFFIX}} +else + GPSROBF=${GPSROBF:-${COMIN_OBS}/${OPREFIX}gpsro.tm00.bufr_d.nr} +fi +TCVITL=${TCVITL:-${COMIN_GFS}/${OPREFIX}syndata.tcvitals.tm00} +B1AVHAM=${B1AVHAM:-${COMIN_OBS}/${OPREFIX}avcsam.tm00.bufr_d${OSUFFIX}} +B1AVHPM=${B1AVHPM:-${COMIN_OBS}/${OPREFIX}avcspm.tm00.bufr_d${OSUFFIX}} + +# Observational data +if [[ ${use_bufr_nr:-no} = "no" ]] && [ -s $PREPQC ]; then + $ncp -Lp $PREPQC prepbufr +else + touch prepbufr +fi +ln -sf $SATWND satwndbufr +ln -sf $SATWHR satwhrbufr +ln -sf $GSNDBF1 gsnd1bufr +ln -sf $B1HRS3 hirs3bufr +ln -sf $B1HRS4 hirs4bufr +ln -sf $B1AMUA amsuabufr +ln -sf $B1MHS mhsbufr +ln -sf $ESHRS3 hirs3bufrears +ln -sf $ESAMUA amsuabufrears +ln -sf $HRS3DB hirs3bufr_db +ln -sf $SBUVBF sbuvbufr +ln -sf $OMPSNPBF ompsnpbufr +ln -sf $OMPSTCBF ompstcbufr +ln -sf $GOMEBF gomebufr +ln -sf $OMIBF omibufr +ln -sf $MLSBF mlsbufr +ln -sf $AIRSBF airsbufr +ln -sf $IASIBF iasibufr +ln -sf $ESIASI iasibufrears +ln -sf $IASIDB iasibufr_db +ln -sf $AMSR2BF amsr2bufr +ln -sf $GMI1CRBF gmibufr +ln -sf $SAPHIRBF saphirbufr +ln -sf $SEVIRIBF seviribufr +ln -sf $CRISBF crisbufr +ln -sf $ESCRIS crisbufrears +ln -sf $CRISDB crisbufr_db +ln -sf $CRISFSBF crisfsbufr +ln -sf $ESCRISFS crisfsbufrears +ln -sf $CRISFSDB crisfsbufr_db +ln -sf $ATMSBF atmsbufr +ln -sf $ESATMS atmsbufrears +ln -sf $ATMSDB atmsbufr_db +ln -sf $SSMISBF ssmisbufr +ln -sf $GPSROBF gpsrobufr +ln -sf $TCVITL tcvitl +ln -sf $B1AVHAM avhambufr +ln -sf $B1AVHPM avhpmbufr + +if [[ ${use_bufr_nr:-no} = "yes" ]]; then + + if [ -s ${PREPQC}.nr ]; then + $ncp -L ${PREPQC}.nr prepbufr + fi + ln -sf ${SAPHIRBF}.nr saphirbufr + +fi +# HAFS specific observations +INTCOMobs=${WORKhafs}/obs_prep +# Use updated prepbufr if exists +if [ -s ${INTCOMobs}/hafs.t${cyc}z.prepbufr ]; then + ln -s ${INTCOMobs}/hafs.t${cyc}z.prepbufr prepbufr +fi +# cat tempdrop.prepbufr with drifting correction into prepbufr +if [ -s ${INTCOMobs}/hafs.t${cyc}z.tempdrop.prepbufr ]; then + cat ${INTCOMobs}/hafs.t${cyc}z.tempdrop.prepbufr >> prepbufr +fi +if [ -s ${INTCOMobs}/hafs.t${cyc}z.tldplr.tm00.bufr_d ]; then + ln -s ${INTCOMobs}/hafs.t${cyc}z.tldplr.tm00.bufr_d tldplrbufr +fi +if [ -s ${INTCOMobs}/hafs.t${cyc}z.hdob.tm00.bufr_d ]; then + ln -s ${INTCOMobs}/hafs.t${cyc}z.hdob.tm00.bufr_d hdobbufr +fi +if [ -s ${INTCOMobs}/hafs.t${cyc}z.nexrad.tm00.bufr_d ]; then + ln -s ${INTCOMobs}/hafs.t${cyc}z.nexrad.tm00.bufr_d l2rwbufr +fi + + +# +#----------------------------------------------------------------------- +# +# Create links to fix files in the FIXgsi directory. +# +#----------------------------------------------------------------------- + +ln -sf ${inputdata}/berror_stats . +ln -sf ${inputdata}/satinfo . +ln -sf ${inputdata}/atms_beamwidth.txt . +ln -sf ${inputdata}/anavinfo . +ln -sf ${inputdata}/convinfo . +ln -sf ${inputdata}/ozinfo . +ln -sf ${inputdata}/pcpinfo . +ln -sf ${inputdata}/scaninfo . +ln -sf ${inputdata}/errtable . +ln -sf ${inputdata}/prepobs_prep.bufrtable . +ln -sf ${inputdata}/bftab_sstphr . + +#----------------------------------------------------------------------- +# +# CRTM Spectral and Transmittance coefficients +# +#----------------------------------------------------------------------- +emiscoef_IRwater=${fixcrtm}/Nalli.IRwater.EmisCoeff.bin +emiscoef_IRice=${fixcrtm}/NPOESS.IRice.EmisCoeff.bin +emiscoef_IRland=${fixcrtm}/NPOESS.IRland.EmisCoeff.bin +emiscoef_IRsnow=${fixcrtm}/NPOESS.IRsnow.EmisCoeff.bin +emiscoef_VISice=${fixcrtm}/NPOESS.VISice.EmisCoeff.bin +emiscoef_VISland=${fixcrtm}/NPOESS.VISland.EmisCoeff.bin +emiscoef_VISsnow=${fixcrtm}/NPOESS.VISsnow.EmisCoeff.bin +emiscoef_VISwater=${fixcrtm}/NPOESS.VISwater.EmisCoeff.bin +emiscoef_MWwater=${fixcrtm}/FASTEM6.MWwater.EmisCoeff.bin +aercoef=${fixcrtm}/AerosolCoeff.bin +cldcoef=${fixcrtm}/CloudCoeff.bin + +ln -sf ${emiscoef_IRwater} Nalli.IRwater.EmisCoeff.bin +ln -sf $emiscoef_IRice ./NPOESS.IRice.EmisCoeff.bin +ln -sf $emiscoef_IRsnow ./NPOESS.IRsnow.EmisCoeff.bin +ln -sf $emiscoef_IRland ./NPOESS.IRland.EmisCoeff.bin +ln -sf $emiscoef_VISice ./NPOESS.VISice.EmisCoeff.bin +ln -sf $emiscoef_VISland ./NPOESS.VISland.EmisCoeff.bin +ln -sf $emiscoef_VISsnow ./NPOESS.VISsnow.EmisCoeff.bin +ln -sf $emiscoef_VISwater ./NPOESS.VISwater.EmisCoeff.bin +ln -sf $emiscoef_MWwater ./FASTEM6.MWwater.EmisCoeff.bin +ln -sf $aercoef ./AerosolCoeff.bin +ln -sf $cldcoef ./CloudCoeff.bin + + +# Copy CRTM coefficient files based on entries in satinfo file +for file in $(awk '{if($1!~"!"){print $1}}' ./satinfo | sort | uniq) ;do + ln -sf ${fixcrtm}/${file}.SpcCoeff.bin ./ + ln -sf ${fixcrtm}/${file}.TauCoeff.bin ./ +done + +# Read from previous cycles for satbias predictors (no online satbias) +PASSIVE_BC=.false. +UPD_PRED=0 +ln -sf ${COMINgdas}/gdas.t${hhprior}z.abias satbias_in +ln -sf ${COMINgdas}/gdas.t${hhprior}z.abias_pc satbias_pc + +#----------------------------------------------------------------------- +# +# Build the GSI namelist on-the-fly +# +#----------------------------------------------------------------------- +# + +. $scripts/regression_nl_update.sh + +SETUP="$SETUP_update" +GRIDOPTS="$GRIDOPTS_update" +BKGVERR="$BKGVERR_update" +ANBKGERR="$ANBKERR_update" +JCOPTS="$JCOPTS_update" +STRONGOPTS="$STRONGOPTS_update" +OBSQC="$OBSQC_update" +OBSINPUT="$OBSINPUT_update" +SUPERRAD="$SUPERRAD_update" +HYBRID_ENSEMBLE='ensemble_path="",' +SINGLEOB="$SINGLEOB_update" + +if [ "$debug" = ".false." ]; then + . $scripts/regression_namelists.sh hafs_envar +else + . $scripts/regression_namelists_db.sh hafs_envar +fi + +cat << EOF > gsiparm.anl + +$gsi_namelist + +EOF + +# Copy executable and fixed files to $tmpdir +if [[ $exp == *"updat"* ]]; then + $ncp $gsiexec_updat ./gsi.x +elif [[ $exp == *"contrl"* ]]; then + $ncp $gsiexec_contrl ./gsi.x +fi + +# Run GSI +cd $tmpdir +echo "run gsi now" +eval "$APRUN $tmpdir/gsi.x > stdout 2>&1" +rc=$? +exit $rc + + + diff --git a/regression/hafs_4denvar_glbens.sh b/regression/hafs_4denvar_glbens.sh new file mode 100755 index 0000000000..e19519e8fa --- /dev/null +++ b/regression/hafs_4denvar_glbens.sh @@ -0,0 +1,455 @@ +set -x +# Set variables used in script +# CLEAN up $tmpdir when finished (YES=remove, NO=leave alone) +# ncp is cp replacement, currently keep as /bin/cp + +UNCOMPRESS=gunzip +CLEAN=NO +ncp=/bin/cp +nln="/bin/ln -sf" + +# HAFS test cases set up +RUN_FGAT=YES # use FGAT or not +RUN_ENSDA=NO +l4densvar=.true. +nhr_obsbin=3 +l_both_fv3sar_gfs_ens=.false. +n_ens_gfs=5 +n_ens_fv3sar=5 + +# +# Set experiment name +# +exp=$jobname + +#----------------------------------------------------------------------- +# +# Extract from ADATE the starting year, month, day, and hour of the +# forecast. These are needed below for various operations. +# +#----------------------------------------------------------------------- +# +adate=${hafs_envar_adate} +YYYYMMDDHH=$(date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2}") +JJJ=$(date +%j -d "${adate:0:8} ${adate:8:2}") + +YYYY=${YYYYMMDDHH:0:4} +MM=${YYYYMMDDHH:4:2} +DD=${YYYYMMDDHH:6:2} +HH=${YYYYMMDDHH:8:2} +YYYYMMDD=${YYYYMMDDHH:0:8} +PDY=${YYYYMMDD} +cyc=${HH} +# prior date and hour +adateprior=`date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2} - 6 hours"` + +ymdprior=$(echo ${adateprior} | cut -c1-8) +hhprior=$(echo ${adateprior} | cut -c9-10) + +CDATEtm03=`date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2} - 3 hours"` +ymdtm03=$(echo ${CDATEtm03} | cut -c1-8) +hhtm03=$(echo ${CDATEtm03} | cut -c9-10) + +CDATEtp03=`date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2} + 3 hours"` +ymdtp03=$(echo ${CDATEtp03} | cut -c1-8) +hhtp03=$(echo ${CDATEtp03} | cut -c9-10) + +# +#----------------------------------------------------------------------- +# +# go to working directory and save directory. +# define fix and background path +# +#----------------------------------------------------------------------- +# Set runtime and save directories +tmpdir=$tmpdir/tmpreg_hafs_4denvar_glbens/${exp} +savdir=$savdir/outreg_hafs_4denvar_glbens/${exp} + +# Set up $tmpdir +rm -rf $tmpdir +mkdir -p $tmpdir +chgrp rstprod $tmpdir +chmod 750 $tmpdir +cd $tmpdir + +bkpath=${hafs_envar_ges} +fixcrtm=${fixcrtm:-$CRTM_FIX} + +################################################################ +##### input data and fix directory ####################### +inputdata=${hafs_envar_ges} +COMINgdas=${hafs_envar_ens} +COMINobs=${hafs_envar_obs} +COMINgfs=${hafs_envar_obs} +WORKhafs=${hafs_envar_obs} +########################################################## + +# use FGAT or not +if [ ${RUN_FGAT} = "YES" ]; then + ln -sf ${inputdata}/coupler.res_03 . + ln -sf ${inputdata}/fv3_akbk_03 . + ln -sf ${inputdata}/fv3_sfcdata_03 . + ln -sf ${inputdata}/fv3_srfwnd_03 . + ln -sf ${inputdata}/fv3_dynvars_03 . + ln -sf ${inputdata}/fv3_tracer_03 . + + ln -sf ${inputdata}/coupler.res_09 . + ln -sf ${inputdata}/fv3_akbk_09 . + ln -sf ${inputdata}/fv3_sfcdata_09 . + ln -sf ${inputdata}/fv3_srfwnd_09 . + ln -sf ${inputdata}/fv3_dynvars_09 . + ln -sf ${inputdata}/fv3_tracer_09 . +fi + +# copy background and grib configuration files +cp ${bkpath}/${YYYYMMDD}.${HH}0000.coupler.res ./coupler.res +cp ${bkpath}/${YYYYMMDD}.${HH}0000.fv_core.res.nc ./fv3_akbk +cp ${bkpath}/${YYYYMMDD}.${HH}0000.sfc_data.nc ./fv3_sfcdata +cp ${bkpath}/${YYYYMMDD}.${HH}0000.fv_srf_wnd.res.tile1.nc ./fv3_srfwnd +cp ${bkpath}/${YYYYMMDD}.${HH}0000.fv_core.res.tile1.nc ./fv3_dynvars +cp ${bkpath}/${YYYYMMDD}.${HH}0000.fv_tracer.res.tile1.nc ./fv3_tracer + +cp ${bkpath}/oro_data.nc ./fv3_oro_data +cp ${bkpath}/atmos_static.nc ./fv3_atmos_static +cp ${bkpath}/grid_spec.nc ./fv3_grid_spec + +# create ensemble member file list +if [ ${RUN_ENSDA} != "YES" ] || [ $l_both_fv3sar_gfs_ens = .true. ]; then +# Link gdas ensemble members + mkdir -p ensemble_data + GSUFFIX=${GSUFFIX:-.nc} + if [ ${l4densvar:-.false.} = ".true." ]; then + fhrs="03 06 09" + else + fhrs="06" + fi + for fhh in $fhrs; do + rm -f filelist${fhh} + for mem in $(seq -f '%03g' 1 ${n_ens_gfs}); do + if [ -s ${COMINgdas}/enkfgdas.${ymdprior}/${hhprior}/atmos/mem${mem}/gdas.t${hhprior}z.atmf0${fhh}s${GSUFFIX:-.nc} ]; then + ${nln} ${COMINgdas}/enkfgdas.${ymdprior}/${hhprior}/atmos/mem${mem}/gdas.t${hhprior}z.atmf0${fhh}s${GSUFFIX:-.nc} ./ensemble_data/enkfgdas.${ymdprior}${hhprior}.atmf0${fhh}_ens_${mem} + elif [ -s ${COMINgdas}/enkfgdas.${ymdprior}/${hhprior}/atmos/mem${mem}/gdas.t${hhprior}z.atmf0${fhh}${GSUFFIX:-.nc} ]; then + ${nln} ${COMINgdas}/enkfgdas.${ymdprior}/${hhprior}/atmos/mem${mem}/gdas.t${hhprior}z.atmf0${fhh}${GSUFFIX:-.nc} ./ensemble_data/enkfgdas.${ymdprior}${hhprior}.atmf0${fhh}_ens_${mem} + fi + echo "./ensemble_data/enkfgdas.${ymdprior}${hhprior}.atmf0${fhh}_ens_${mem}" >> filelist${fhh} + done + done +fi + +if [ ${RUN_ENSDA} = "YES" ]; then + for mem in $(seq -f '%03g' 1 ${n_ens_fv3sar}) + do + RESTARTens=${inputdata} + fhh="06" + ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-coupler.res . + ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-fv3_akbk . + ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-fv3_sfcdata . + ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-fv3_srfwnd . + ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-fv3_dynvars . + ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-fv3_tracer . + if [ ! -s ./fv3_ens_grid_spec ]; then + ln -sf ${RESTARTens}/grid_spec.nc ./fv3_ens_grid_spec + fi + if [ ${l4densvar:-.false.} = ".true." ]; then + export ENS_NSTARTHR=3 + fhh="03" + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-coupler.res . + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_akbk . + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_sfcdata . + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_srfwnd . + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_dynvars . + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_tracer . + fhh="09" + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-coupler.res . + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_akbk . + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_sfcdata . + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_srfwnd . + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_dynvars . + ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_tracer . + fi + done +fi +if [ ${RUN_ENSDA} != "YES" ]; then + export N_ENS=${n_ens_gfs} + export BETA_S0=${BETA_S0:-0.2} + export GRID_RATIO_ENS=1 + export REGIONAL_ENSEMBLE_OPTION=1 +elif [ ${RUN_ENSDA} = "YES" ]; then + if [ $l_both_fv3sar_gfs_ens = .false. ]; then + export N_ENS=${n_ens_fv3sar} + export BETA_S0=${BETA_S0:-0.0} + export GRID_RATIO_ENS=2 + export grid_ratio_fv3_regional=2 + export REGIONAL_ENSEMBLE_OPTION=5 + elif [ $l_both_fv3sar_gfs_ens = .true. ]; then + export N_ENS=$((${n_ens_gfs} + ${n_ens_fv3sar})) + export BETA_S0=${BETA_S0:-0.0} + export GRID_RATIO_ENS=2 + export grid_ratio_fv3_regional=2 + export REGIONAL_ENSEMBLE_OPTION=5 + fi +fi + +#----------------------------------------------------------------------- +# +# link observation files +# copy observation files to working directory +# +#----------------------------------------------------------------------- + +# Link GFS/GDAS input and observation files +COMIN_OBS=${COMIN_OBS:-${COMINobs}} +COMIN_GFS=${COMIN_GFS:-${COMINgfs}} + +OPREFIX=${OPREFIX:-"gfs.t${cyc}z."} +OSUFFIX=${OSUFFIX:-""} +PREPQC=${PREPQC:-${COMIN_OBS}/${OPREFIX}prepbufr${OSUFFIX}} +PREPQCPF=${PREPQCPF:-${COMIN_OBS}/${OPREFIX}prepbufr.acft_profiles${OSUFFIX}} +NSSTBF=${NSSTBF:-${COMIN_OBS}/${OPREFIX}nsstbufr${OSUFFIX}} +SATWND=${SATWND:-${COMIN_OBS}/${OPREFIX}satwnd.tm00.bufr_d${OSUFFIX}} +SATWHR=${SATWHR:-${COMIN_OBS}/${OPREFIX}satwhr.tm00.bufr_d${OSUFFIX}} +OSCATBF=${OSCATBF:-${COMIN_OBS}/${OPREFIX}oscatw.tm00.bufr_d${OSUFFIX}} +RAPIDSCATBF=${RAPIDSCATBF:-${COMIN_OBS}/${OPREFIX}rapidscatw.tm00.bufr_d${OSUFFIX}} +GSNDBF=${GSNDBF:-${COMIN_OBS}/${OPREFIX}goesnd.tm00.bufr_d${OSUFFIX}} +GSNDBF1=${GSNDBF1:-${COMIN_OBS}/${OPREFIX}goesfv.tm00.bufr_d${OSUFFIX}} +B1HRS2=${B1HRS2:-${COMIN_OBS}/${OPREFIX}1bhrs2.tm00.bufr_d${OSUFFIX}} +B1MSU=${B1MSU:-${COMIN_OBS}/${OPREFIX}1bmsu.tm00.bufr_d${OSUFFIX}} +B1HRS3=${B1HRS3:-${COMIN_OBS}/${OPREFIX}1bhrs3.tm00.bufr_d${OSUFFIX}} +B1HRS4=${B1HRS4:-${COMIN_OBS}/${OPREFIX}1bhrs4.tm00.bufr_d${OSUFFIX}} +B1AMUA=${B1AMUA:-${COMIN_OBS}/${OPREFIX}1bamua.tm00.bufr_d${OSUFFIX}} +B1AMUB=${B1AMUB:-${COMIN_OBS}/${OPREFIX}1bamub.tm00.bufr_d${OSUFFIX}} +B1MHS=${B1MHS:-${COMIN_OBS}/${OPREFIX}1bmhs.tm00.bufr_d${OSUFFIX}} +ESHRS3=${ESHRS3:-${COMIN_OBS}/${OPREFIX}eshrs3.tm00.bufr_d${OSUFFIX}} +ESAMUA=${ESAMUA:-${COMIN_OBS}/${OPREFIX}esamua.tm00.bufr_d${OSUFFIX}} +ESAMUB=${ESAMUB:-${COMIN_OBS}/${OPREFIX}esamub.tm00.bufr_d${OSUFFIX}} +ESMHS=${ESMHS:-${COMIN_OBS}/${OPREFIX}esmhs.tm00.bufr_d${OSUFFIX}} +HRS3DB=${HRS3DB:-${COMIN_OBS}/${OPREFIX}hrs3db.tm00.bufr_d${OSUFFIX}} +AMUADB=${AMUADB:-${COMIN_OBS}/${OPREFIX}amuadb.tm00.bufr_d${OSUFFIX}} +AMUBDB=${AMUBDB:-${COMIN_OBS}/${OPREFIX}amubdb.tm00.bufr_d${OSUFFIX}} +MHSDB=${MHSDB:-${COMIN_OBS}/${OPREFIX}mhsdb.tm00.bufr_d${OSUFFIX}} +AIRSBF=${AIRSBF:-${COMIN_OBS}/${OPREFIX}airsev.tm00.bufr_d${OSUFFIX}} +IASIBF=${IASIBF:-${COMIN_OBS}/${OPREFIX}mtiasi.tm00.bufr_d${OSUFFIX}} +ESIASI=${ESIASI:-${COMIN_OBS}/${OPREFIX}esiasi.tm00.bufr_d${OSUFFIX}} +IASIDB=${IASIDB:-${COMIN_OBS}/${OPREFIX}iasidb.tm00.bufr_d${OSUFFIX}} +AMSREBF=${AMSREBF:-${COMIN_OBS}/${OPREFIX}amsre.tm00.bufr_d${OSUFFIX}} +AMSR2BF=${AMSR2BF:-${COMIN_OBS}/${OPREFIX}amsr2.tm00.bufr_d${OSUFFIX}} +GMI1CRBF=${GMI1CRBF:-${COMIN_OBS}/${OPREFIX}gmi1cr.tm00.bufr_d${OSUFFIX}} +SAPHIRBF=${SAPHIRBF:-${COMIN_OBS}/${OPREFIX}saphir.tm00.bufr_d${OSUFFIX}} +SEVIRIBF=${SEVIRIBF:-${COMIN_OBS}/${OPREFIX}sevcsr.tm00.bufr_d${OSUFFIX}} +AHIBF=${AHIBF:-${COMIN_OBS}/${OPREFIX}ahicsr.tm00.bufr_d${OSUFFIX}} +ABIBF=${ABIBF:-${COMIN_OBS}/${OPREFIX}gsrcsr.tm00.bufr_d${OSUFFIX}} +CRISBF=${CRISBF:-${COMIN_OBS}/${OPREFIX}cris.tm00.bufr_d${OSUFFIX}} +ESCRIS=${ESCRIS:-${COMIN_OBS}/${OPREFIX}escris.tm00.bufr_d${OSUFFIX}} +CRISDB=${CRISDB:-${COMIN_OBS}/${OPREFIX}crisdb.tm00.bufr_d${OSUFFIX}} +CRISFSBF=${CRISFSBF:-${COMIN_OBS}/${OPREFIX}crisf4.tm00.bufr_d${OSUFFIX}} +ESCRISFS=${ESCRISFS:-${COMIN_OBS}/${OPREFIX}escrsf.tm00.bufr_d${OSUFFIX}} +CRISFSDB=${CRISFSDB:-${COMIN_OBS}/${OPREFIX}crsfdb.tm00.bufr_d${OSUFFIX}} +ATMSBF=${ATMSBF:-${COMIN_OBS}/${OPREFIX}atms.tm00.bufr_d${OSUFFIX}} +ESATMS=${ESATMS:-${COMIN_OBS}/${OPREFIX}esatms.tm00.bufr_d${OSUFFIX}} +ATMSDB=${ATMSDB:-${COMIN_OBS}/${OPREFIX}atmsdb.tm00.bufr_d${OSUFFIX}} +ESATMS=${ESATMS:-${COMIN_OBS}/${OPREFIX}esatms.tm00.bufr_d${OSUFFIX}} +ATMSDB=${ATMSDB:-${COMIN_OBS}/${OPREFIX}atmsdb.tm00.bufr_d${OSUFFIX}} +SSMITBF=${SSMITBF:-${COMIN_OBS}/${OPREFIX}ssmit.tm00.bufr_d${OSUFFIX}} +SSMISBF=${SSMISBF:-${COMIN_OBS}/${OPREFIX}ssmisu.tm00.bufr_d${OSUFFIX}} +SBUVBF=${SBUVBF:-${COMIN_OBS}/${OPREFIX}osbuv8.tm00.bufr_d${OSUFFIX}} +OMPSNPBF=${OMPSNPBF:-${COMIN_OBS}/${OPREFIX}ompsn8.tm00.bufr_d${OSUFFIX}} +OMPSTCBF=${OMPSTCBF:-${COMIN_OBS}/${OPREFIX}ompst8.tm00.bufr_d${OSUFFIX}} +GOMEBF=${GOMEBF:-${COMIN_OBS}/${OPREFIX}gome.tm00.bufr_d${OSUFFIX}} +OMIBF=${OMIBF:-${COMIN_OBS}/${OPREFIX}omi.tm00.bufr_d${OSUFFIX}} +MLSBF=${MLSBF:-${COMIN_OBS}/${OPREFIX}mls.tm00.bufr_d${OSUFFIX}} +OMPSLPBF=${OMPSLPBF:-${COMIN_OBS}/${OPREFIX}ompslp.tm00.bufr_d${OSUFFIX}} +SMIPCP=${SMIPCP:-${COMIN_OBS}/${OPREFIX}spssmi.tm00.bufr_d${OSUFFIX}} +TMIPCP=${TMIPCP:-${COMIN_OBS}/${OPREFIX}sptrmm.tm00.bufr_d${OSUFFIX}} +if [[ ${use_bufr_nr:-no} = "no" ]]; then + GPSROBF=${GPSROBF:-${COMIN_OBS}/${OPREFIX}gpsro.tm00.bufr_d${OSUFFIX}} +else + GPSROBF=${GPSROBF:-${COMIN_OBS}/${OPREFIX}gpsro.tm00.bufr_d.nr} +fi +TCVITL=${TCVITL:-${COMIN_GFS}/${OPREFIX}syndata.tcvitals.tm00} +B1AVHAM=${B1AVHAM:-${COMIN_OBS}/${OPREFIX}avcsam.tm00.bufr_d${OSUFFIX}} +B1AVHPM=${B1AVHPM:-${COMIN_OBS}/${OPREFIX}avcspm.tm00.bufr_d${OSUFFIX}} + +# Observational data +if [[ ${use_bufr_nr:-no} = "no" ]] && [ -s $PREPQC ]; then + $ncp -Lp $PREPQC prepbufr +else + touch prepbufr +fi +ln -sf $SATWND satwndbufr +ln -sf $SATWHR satwhrbufr +ln -sf $GSNDBF1 gsnd1bufr +ln -sf $B1HRS3 hirs3bufr +ln -sf $B1HRS4 hirs4bufr +ln -sf $B1AMUA amsuabufr +ln -sf $B1MHS mhsbufr +ln -sf $ESHRS3 hirs3bufrears +ln -sf $ESAMUA amsuabufrears +ln -sf $HRS3DB hirs3bufr_db +ln -sf $SBUVBF sbuvbufr +ln -sf $OMPSNPBF ompsnpbufr +ln -sf $OMPSTCBF ompstcbufr +ln -sf $GOMEBF gomebufr +ln -sf $OMIBF omibufr +ln -sf $MLSBF mlsbufr +ln -sf $AIRSBF airsbufr +ln -sf $IASIBF iasibufr +ln -sf $ESIASI iasibufrears +ln -sf $IASIDB iasibufr_db +ln -sf $AMSR2BF amsr2bufr +ln -sf $GMI1CRBF gmibufr +ln -sf $SAPHIRBF saphirbufr +ln -sf $SEVIRIBF seviribufr +ln -sf $CRISBF crisbufr +ln -sf $ESCRIS crisbufrears +ln -sf $CRISDB crisbufr_db +ln -sf $CRISFSBF crisfsbufr +ln -sf $ESCRISFS crisfsbufrears +ln -sf $CRISFSDB crisfsbufr_db +ln -sf $ATMSBF atmsbufr +ln -sf $ESATMS atmsbufrears +ln -sf $ATMSDB atmsbufr_db +ln -sf $SSMISBF ssmisbufr +ln -sf $GPSROBF gpsrobufr +ln -sf $TCVITL tcvitl +ln -sf $B1AVHAM avhambufr +ln -sf $B1AVHPM avhpmbufr + +if [[ ${use_bufr_nr:-no} = "yes" ]]; then + + if [ -s ${PREPQC}.nr ]; then + $ncp -L ${PREPQC}.nr prepbufr + fi + ln -sf ${SAPHIRBF}.nr saphirbufr + +fi +# HAFS specific observations +INTCOMobs=${WORKhafs}/obs_prep +# Use updated prepbufr if exists +if [ -s ${INTCOMobs}/hafs.t${cyc}z.prepbufr ]; then + ln -s ${INTCOMobs}/hafs.t${cyc}z.prepbufr prepbufr +fi +# cat tempdrop.prepbufr with drifting correction into prepbufr +if [ -s ${INTCOMobs}/hafs.t${cyc}z.tempdrop.prepbufr ]; then + cat ${INTCOMobs}/hafs.t${cyc}z.tempdrop.prepbufr >> prepbufr +fi +if [ -s ${INTCOMobs}/hafs.t${cyc}z.tldplr.tm00.bufr_d ]; then + ln -s ${INTCOMobs}/hafs.t${cyc}z.tldplr.tm00.bufr_d tldplrbufr +fi +if [ -s ${INTCOMobs}/hafs.t${cyc}z.hdob.tm00.bufr_d ]; then + ln -s ${INTCOMobs}/hafs.t${cyc}z.hdob.tm00.bufr_d hdobbufr +fi +if [ -s ${INTCOMobs}/hafs.t${cyc}z.nexrad.tm00.bufr_d ]; then + ln -s ${INTCOMobs}/hafs.t${cyc}z.nexrad.tm00.bufr_d l2rwbufr +fi + + +# +#----------------------------------------------------------------------- +# +# Create links to fix files in the FIXgsi directory. +# +#----------------------------------------------------------------------- + +ln -sf ${inputdata}/berror_stats . +ln -sf ${inputdata}/satinfo . +ln -sf ${inputdata}/atms_beamwidth.txt . +ln -sf ${inputdata}/anavinfo . +ln -sf ${inputdata}/convinfo . +ln -sf ${inputdata}/ozinfo . +ln -sf ${inputdata}/pcpinfo . +ln -sf ${inputdata}/scaninfo . +ln -sf ${inputdata}/errtable . +ln -sf ${inputdata}/prepobs_prep.bufrtable . +ln -sf ${inputdata}/bftab_sstphr . + +#----------------------------------------------------------------------- +# +# CRTM Spectral and Transmittance coefficients +# +#----------------------------------------------------------------------- +emiscoef_IRwater=${fixcrtm}/Nalli.IRwater.EmisCoeff.bin +emiscoef_IRice=${fixcrtm}/NPOESS.IRice.EmisCoeff.bin +emiscoef_IRland=${fixcrtm}/NPOESS.IRland.EmisCoeff.bin +emiscoef_IRsnow=${fixcrtm}/NPOESS.IRsnow.EmisCoeff.bin +emiscoef_VISice=${fixcrtm}/NPOESS.VISice.EmisCoeff.bin +emiscoef_VISland=${fixcrtm}/NPOESS.VISland.EmisCoeff.bin +emiscoef_VISsnow=${fixcrtm}/NPOESS.VISsnow.EmisCoeff.bin +emiscoef_VISwater=${fixcrtm}/NPOESS.VISwater.EmisCoeff.bin +emiscoef_MWwater=${fixcrtm}/FASTEM6.MWwater.EmisCoeff.bin +aercoef=${fixcrtm}/AerosolCoeff.bin +cldcoef=${fixcrtm}/CloudCoeff.bin + +ln -sf ${emiscoef_IRwater} Nalli.IRwater.EmisCoeff.bin +ln -sf $emiscoef_IRice ./NPOESS.IRice.EmisCoeff.bin +ln -sf $emiscoef_IRsnow ./NPOESS.IRsnow.EmisCoeff.bin +ln -sf $emiscoef_IRland ./NPOESS.IRland.EmisCoeff.bin +ln -sf $emiscoef_VISice ./NPOESS.VISice.EmisCoeff.bin +ln -sf $emiscoef_VISland ./NPOESS.VISland.EmisCoeff.bin +ln -sf $emiscoef_VISsnow ./NPOESS.VISsnow.EmisCoeff.bin +ln -sf $emiscoef_VISwater ./NPOESS.VISwater.EmisCoeff.bin +ln -sf $emiscoef_MWwater ./FASTEM6.MWwater.EmisCoeff.bin +ln -sf $aercoef ./AerosolCoeff.bin +ln -sf $cldcoef ./CloudCoeff.bin + + +# Copy CRTM coefficient files based on entries in satinfo file +for file in $(awk '{if($1!~"!"){print $1}}' ./satinfo | sort | uniq) ;do + ln -sf ${fixcrtm}/${file}.SpcCoeff.bin ./ + ln -sf ${fixcrtm}/${file}.TauCoeff.bin ./ +done + +# Read from previous cycles for satbias predictors (no online satbias) +PASSIVE_BC=.false. +UPD_PRED=0 +ln -sf ${COMINgdas}/gdas.t${hhprior}z.abias satbias_in +ln -sf ${COMINgdas}/gdas.t${hhprior}z.abias_pc satbias_pc + +#----------------------------------------------------------------------- +# +# Build the GSI namelist on-the-fly +# +#----------------------------------------------------------------------- +# + +. $scripts/regression_nl_update.sh + +SETUP="$SETUP_update" +GRIDOPTS="$GRIDOPTS_update" +BKGVERR="$BKGVERR_update" +ANBKGERR="$ANBKERR_update" +JCOPTS="$JCOPTS_update" +STRONGOPTS="$STRONGOPTS_update" +OBSQC="$OBSQC_update" +OBSINPUT="$OBSINPUT_update" +SUPERRAD="$SUPERRAD_update" +HYBRID_ENSEMBLE='ensemble_path="",' +SINGLEOB="$SINGLEOB_update" + +if [ "$debug" = ".false." ]; then + . $scripts/regression_namelists.sh hafs_envar +else + . $scripts/regression_namelists_db.sh hafs_envar +fi + +cat << EOF > gsiparm.anl + +$gsi_namelist + +EOF + +# Copy executable and fixed files to $tmpdir +if [[ $exp == *"updat"* ]]; then + $ncp $gsiexec_updat ./gsi.x +elif [[ $exp == *"contrl"* ]]; then + $ncp $gsiexec_contrl ./gsi.x +fi + +# Run GSI +cd $tmpdir +echo "run gsi now" +eval "$APRUN $tmpdir/gsi.x > stdout 2>&1" +rc=$? +exit $rc + + + diff --git a/regression/hwrf_nmm_d2.sh b/regression/hwrf_nmm_d2.sh deleted file mode 100755 index 2b4d2e1bfe..0000000000 --- a/regression/hwrf_nmm_d2.sh +++ /dev/null @@ -1,339 +0,0 @@ - -set -x - -# Set analysis date -adate=$hwrf_nmm_adate - -io_format=netcdf - -if [[ "$io_format" = "binary" ]]; then - NETCDF=.false. - FORMAT=binary -elif [[ "$io_format" = "netcdf" ]]; then - NETCDF=.true. - FORMAT=netcdf -else - echo "***ERRROR*** INVALID io_format = $io_format" - exit -fi - -# Set experiment name and analysis date - -exp=$jobname - -# Set path/file for gsi executable -#gsiexec=$gsiexec - -# Set the JCAP resolution which you want. -# All resolutions use LEVS=64 -#export JCAP=62 -export LEVS=60 -export JCAP_B=$JCAP -export DELTIM=1200 - -# Set runtime and save directories -tmpdir=$tmpdir/tmpreg_hwrf_nmm_d2/${exp} -savdir=$savdir/outreg_hwrf_nmm_d2/${exp} - -# Specify GSI fixed field and data directories. -fixcrtm=${fixcrtm:-$CRTM_FIX} - -#datobs=$datobs - -# Set variables used in script -# CLEAN up $tmpdir when finished (YES=remove, NO=leave alone) -# ncp is cp replacement, currently keep as /bin/cp - -CLEAN=NO -ncp=/bin/cp -lnsf='ln -sf' - -NX2=166 -NY2=336 -export NLAT=$(( NY2 - 1 )) -export NLON=$(( NX2 - 1 )) - -# Given the analysis date, compute the date from which the -# first guess comes. Extract cycle and set prefix and suffix -# for guess and observation data files -gdate=`date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2} - 6 hours"` -hha=`echo $adate | cut -c9-10` -hhg=`echo $gdate | cut -c9-10` -prefixa=gfs.t${hha}z -prefixo=gdas1.t${hha}z -suffix=tm00.bufr_d - - -# Set up $tmpdir -rm -rf $tmpdir -mkdir -p $tmpdir -cd $tmpdir -rm -rf core* - -# Make gsi namelist - -. $scripts/regression_nl_update.sh - -GRIDOPTS="$GRIDOPTS_update" -BKGVERR="$BKGVERR_update" -ANBKGERR="$ANBKERR_update" -JCOPTS="$JCOPTS_update" -STRONGOPTS="$STRONGOPTS_update" -OBSQC="$OBSQC_update" -OBSINPUT="$OBSINPUT_update" -SUPERRAD="$SUPERRAD_update" -SINGLEOB="$SINGLEOB_update" - -# parameters for radiance data assimilation -export SETUP="newpc4pred=.true., adp_anglebc=.true., angord=4, \ - passive_bc=.false., use_edges=.false., emiss_bc=.true., \ - diag_precon=.true., step_start=1.e-3, upd_pred(1)=0, \ - upd_pred(2)=0,upd_pred(3)=0,upd_pred(4)=0, \ - upd_pred(5)=0,upd_pred(6)=0,upd_pred(7)=0, \ - upd_pred(8)=0,upd_pred(9)=0,upd_pred(10)=0, \ - upd_pred(11)=0,upd_pred(12)=0," - -export USE_GFS_STRATOSPHERE=".true." -export USE_GFS_OZONE=".true." -export REGIONAL_OZONE=".false." - -if [ "$debug" = ".false." ]; then - . $scripts/regression_namelists.sh hwrf_nmm_d2 -else - . $scripts/regression_namelists_db.sh hwrf_nmm_d2 -fi - -cat << EOF > gsiparm.anl - -$gsi_namelist - -EOF - -# Set fixed files -# berror = forecast model background error statistics -# specoef = CRTM spectral coefficients -# trncoef = CRTM transmittance coefficients -# emiscoef = CRTM coefficients for IR sea surface emissivity model -# aerocoef = CRTM coefficients for aerosol effects -# cldcoef = CRTM coefficients for cloud effects -# satinfo = text file with information about assimilation of brightness temperatures -# cloudyinfo = text file with information about assimilation of cloudy radiance -# pcpinfo = text file with information about assimilation of prepcipitation rates -# ozinfo = text file with information about assimilation of ozone data -# errtable = text file with obs error for conventional data (optional) -# convinfo = text file with information about assimilation of conventional data -# bufrtable= text file ONLY needed for single obs test (oneobstest=.true.) -# bftab_sst= bufr table for sst ONLY needed for sst retrieval (retrieval=.true.) - -anavinfo=$fixgsi/anavinfo_hwrf_L75 -berror=$fixgsi/$endianness/nam_glb_berror.f77.gcv -emiscoef_IRwater=$fixcrtm/Nalli.IRwater.EmisCoeff.bin -emiscoef_IRice=$fixcrtm/NPOESS.IRice.EmisCoeff.bin -emiscoef_IRland=$fixcrtm/NPOESS.IRland.EmisCoeff.bin -emiscoef_IRsnow=$fixcrtm/NPOESS.IRsnow.EmisCoeff.bin -emiscoef_VISice=$fixcrtm/NPOESS.VISice.EmisCoeff.bin -emiscoef_VISland=$fixcrtm/NPOESS.VISland.EmisCoeff.bin -emiscoef_VISsnow=$fixcrtm/NPOESS.VISsnow.EmisCoeff.bin -emiscoef_VISwater=$fixcrtm/NPOESS.VISwater.EmisCoeff.bin -emiscoef_MWwater=$fixcrtm/FASTEM6.MWwater.EmisCoeff.bin -aercoef=$fixcrtm/AerosolCoeff.bin -cldcoef=$fixcrtm/CloudCoeff.bin -satinfo=$fixgsi/hwrf_satinfo.txt -cloudyinfo=$fixgsi/cloudy_radiance_info.txt -atmsbeaminfo=$fixgsi/atms_beamwidth.txt -scaninfo=$fixgsi/global_scaninfo.txt -pcpinfo=$fixgsi/nam_global_pcpinfo.txt -ozinfo=$fixgsi/global_ozinfo.txt -errtable=$fixgsi/hwrf_nam_errtable.r3dv -convinfo=$fixgsi/hwrf_convinfo.txt -### add 9 tables -errtable_pw=$fixgsi/prepobs_errtable_pw.global -errtable_ps=$fixgsi/prepobs_errtable_ps.global_nqcf -errtable_t=$fixgsi/prepobs_errtable_t.global_nqcf -errtable_q=$fixgsi/prepobs_errtable_q.global_nqcf -errtable_uv=$fixgsi/prepobs_errtable_uv.global_nqcf -btable_ps=$fixgsi/nqc_b_ps.global_nqcf -btable_t=$fixgsi/nqc_b_t.global_nqcf -btable_q=$fixgsi/nqc_b_q.global_nqcf -btable_uv=$fixgsi/nqc_b_uv.global_nqcf - -# add vertical profile of localization and beta_s,beta_e weights for hybrid ensemble runs -hybens_info=$fixgsi/hwrf_hybens_d2_info - - -# Only need this file for single obs test -bufrtable=$fixgsi/prepobs_prep.bufrtable - -# Only need this file for sst retrieval -bftab_sst=$fixgsi/bufrtab.012 - -# Copy executable and fixed files to $tmpdir -if [[ $exp == *"updat"* ]]; then - $ncp $gsiexec_updat ./gsi.x -elif [[ $exp == *"contrl"* ]]; then - $ncp $gsiexec_contrl ./gsi.x -fi - -$ncp $anavinfo ./anavinfo -$ncp $berror ./berror_stats -$ncp $emiscoef_IRwater ./Nalli.IRwater.EmisCoeff.bin -$ncp $emiscoef_IRice ./NPOESS.IRice.EmisCoeff.bin -$ncp $emiscoef_IRsnow ./NPOESS.IRsnow.EmisCoeff.bin -$ncp $emiscoef_IRland ./NPOESS.IRland.EmisCoeff.bin -$ncp $emiscoef_VISice ./NPOESS.VISice.EmisCoeff.bin -$ncp $emiscoef_VISland ./NPOESS.VISland.EmisCoeff.bin -$ncp $emiscoef_VISsnow ./NPOESS.VISsnow.EmisCoeff.bin -$ncp $emiscoef_VISwater ./NPOESS.VISwater.EmisCoeff.bin -$ncp $emiscoef_MWwater ./FASTEM6.MWwater.EmisCoeff.bin -$ncp $aercoef ./AerosolCoeff.bin -$ncp $cldcoef ./CloudCoeff.bin -$ncp $satinfo ./satinfo -$ncp $cloudyinfo ./cloudy_radiance_info.txt -$ncp $scaninfo ./scaninfo -$ncp $pcpinfo ./pcpinfo -$ncp $ozinfo ./ozinfo -$ncp $convinfo ./convinfo -$ncp $errtable ./errtable -$ncp $atmsbeaminfo ./atms_beamwidth.txt - -#add 9 tables for new varqc -$ncp $errtable_pw ./errtable_pw -$ncp $errtable_ps ./errtable_ps -$ncp $errtable_t ./errtable_t -$ncp $errtable_q ./errtable_q -$ncp $errtable_uv ./errtable_uv -$ncp $btable_ps ./btable_ps -$ncp $btable_t ./btable_t -$ncp $btable_q ./btable_q -$ncp $btable_uv ./btable_uv - -$ncp $hybens_info ./hybens_info - -$ncp $bufrtable ./prepobs_prep.bufrtable -$ncp $bftab_sst ./bftab_sstphr - -# Copy CRTM coefficient files based on entries in satinfo file -for file in `awk '{if($1!~"!"){print $1}}' ./satinfo | sort | uniq` ;do - $ncp $fixcrtm/${file}.SpcCoeff.bin ./ - $ncp $fixcrtm/${file}.TauCoeff.bin ./ -done - - -# Copy observational data to $tmpdir -$lnsf $hwrf_nmm_obs/${prefixa}.prepbufr ./prepbufr -$lnsf $hwrf_nmm_obs/${prefixa}.satwnd.${suffix} ./satwndbufr -$lnsf $hwrf_nmm_obs/${prefixa}.gpsro.${suffix} ./gpsrobufr -#$lnsf $hwrf_nmm_obs/${prefixa}.spssmi.${suffix} ./ssmirrbufr -#$lnsf $hwrf_nmm_obs/${prefixa}.sptrmm.${suffix} ./tmirrbufr -#$lnsf $hwrf_nmm_obs/${prefixa}.gome.${suffix} ./gomebufr -#$lnsf $hwrf_nmm_obs/${prefixa}.omi.${suffix} ./omibufr -#$lnsf $hwrf_nmm_obs/${prefixa}.mls.${suffix} ./mlsbufr -#$lnsf $hwrf_nmm_obs/${prefixa}.osbuv8.${suffix} ./sbuvbufr -$lnsf $hwrf_nmm_obs/${prefixa}.goesfv.${suffix} ./gsnd1bufr -$lnsf $hwrf_nmm_obs/${prefixa}.1bamua.${suffix} ./amsuabufr -#$lnsf $hwrf_nmm_obs/${prefixa}.1bamub.${suffix} ./amsubbufr -#$lnsf $hwrf_nmm_obs/${prefixa}.1bhrs2.${suffix} ./hirs2bufr -#$lnsf $hwrf_nmm_obs/${prefixa}.1bhrs3.${suffix} ./hirs3bufr -$lnsf $hwrf_nmm_obs/${prefixa}.1bhrs4.${suffix} ./hirs4bufr -$lnsf $hwrf_nmm_obs/${prefixa}.1bmhs.${suffix} ./mhsbufr -#$lnsf $hwrf_nmm_obs/${prefixa}.1bmsu.${suffix} ./msubufr -$lnsf $hwrf_nmm_obs/${prefixa}.airsev.${suffix} ./airsbufr -$lnsf $hwrf_nmm_obs/${prefixa}.sevcsr.${suffix} ./seviribufr -$lnsf $hwrf_nmm_obs/${prefixa}.mtiasi.${suffix} ./iasibufr -$lnsf $hwrf_nmm_obs/${prefixa}.esamua.${suffix} ./amsuabufrears -$lnsf $hwrf_nmm_obs/${prefixa}.esamub.${suffix} ./amsubbufrears -$lnsf $hwrf_nmm_obs/${prefixa}.eshrs3.${suffix} ./hirs3bufrears -#$lnsf $hwrf_nmm_obs/${prefixa}.ssmit.${suffix} ./ssmitbufr -#$lnsf $hwrf_nmm_obs/${prefixa}.amsre.${suffix} ./amsrebufr -#$lnsf $hwrf_nmm_obs/${prefixa}.ssmis.${suffix} ./ssmisbufr -$lnsf $hwrf_nmm_obs/${prefixa}.atms.${suffix} ./atmsbufr -$lnsf $hwrf_nmm_obs/${prefixa}.cris.${suffix} ./crisbufr -$lnsf $hwrf_nmm_obs/${prefixa}.crisf4.${suffix} ./crisfsbufr -#$lnsf $hwrf_nmm_obs/${prefixa}.syndata.tcvitals.tm00 ./tcvitl -$lnsf $hwrf_nmm_obs/${prefixo}.tldplr.${suffix} ./tldplrbufr - - -# Copy bias correction, atmospheric and surface files -$lnsf $hwrf_nmm_obs/gdas1.t${hhg}z.abias ./satbias_in -$lnsf $hwrf_nmm_obs/gdas1.t${hhg}z.abias_pc ./satbias_pc - -$ncp $hwrf_nmm_ges/wrfghost_d02_03 ./wrf_inou3 -$ncp $hwrf_nmm_ges/wrfghost_d02_06 ./wrf_inout -$ncp $hwrf_nmm_ges/wrfghost_d02_09 ./wrf_inou9 - -$ncp $hwrf_nmm_ges/gdas1.t${hhg}z.sf03 ./gfs_sigf03 -$ncp $hwrf_nmm_ges/gdas1.t${hhg}z.sf06 ./gfs_sigf06 -$ncp $hwrf_nmm_ges/gdas1.t${hhg}z.sf09 ./gfs_sigf09 - -# Copy ensemble forecast files for hybrid analysis -export ENSEMBLE_SIZE_REGIONAL=10 ->filelist06 -n=1 -while [[ $n -le ${ENSEMBLE_SIZE_REGIONAL} ]]; do - $lnsf $hwrf_nmm_ges/$( printf sfg_${gdate}_fhr06s_mem%03d $n ) \ - ./$( printf sfg_${gdate}_fhr06s_mem%03d $n ) - ls ./$( printf sfg_${gdate}_fhr06s_mem%03d $n ) >> filelist06 - n=$((n + 1)) -done - -# Run GSI -cd $tmpdir -echo "run gsi now" -eval "$APRUN $tmpdir/gsi.x > stdout 2>&1" -rc=$? -exit $rc - - - - -# Loop over first and last outer loops to generate innovation -# diagnostic files for indicated observation types (groups) -# -# NOTE: Since we set miter=2 in GSI namelist SETUP, outer -# loop 03 will contain innovations with respect to -# the analysis. Creation of o-a innovation files -# is triggered by write_diag(3)=.true. The setting -# write_diag(1)=.true. turns on creation of o-g -# innovation files. -# - - -echo "Time before diagnostic loop is `date` " -cd $tmpdir -loops="01 03" -for loop in $loops; do - -case $loop in - 01) string=ges;; - 03) string=anl;; - *) string=$loop;; -esac - -# Collect diagnostic files for obs types (groups) below - listall="hirs2_n14 msu_n14 sndr_g08 sndr_g11 sndr_g11 sndr_g12 sndr_g13 sndr_g08_prep sndr_g11_prep sndr_g12_prep sndr_g13_prep sndrd1_g11 sndrd2_g11 sndrd3_g11 sndrd4_g11 sndrd1_g12 sndrd2_g12 sndrd3_g12 sndrd4_g12 sndrd1_g13 sndrd2_g13 sndrd3_g13 sndrd4_g13 hirs3_n15 hirs3_n16 hirs3_n17 amsua_n15 amsua_n16 amsua_n17 amsub_n15 amsub_n16 amsub_n17 hsb_aqua airs_aqua amsua_aqua imgr_g08 imgr_g11 imgr_g12 pcp_ssmi_dmsp pcp_tmi_trmm conv sbuv2_n16 sbuv2_n17 sbuv2_n18 gome_metop-a omi_aura ssmi_f13 ssmi_f15 hirs4_n18 hirs4_metop-a amsua_n18 amsua_metop-a mhs_n18 mhs_metop-a amsre_low_aqua amsre_mid_aqua amsre_hig_aqua ssmis_las_f16 ssmis_uas_f16 ssmis_img_f16 ssmis_env_f16 iasi_metop-a" - for type in $listall; do - count=`ls dir.*/${type}_${loop}* | wc -l` - if [[ $count -gt 0 ]]; then - cat dir.*/${type}_${loop}* > diag_${type}_${string}.${hwrf_nmm_adate} - compress diag_${type}_${string}.${hwrf_nmm_adate} - $ncp diag_${type}_${string}.${hwrf_nmm_adate}.Z $savdir/ - fi - done -done -echo "Time after diagnostic loop is `date` " - - - -# If requested, clean up $tmpdir -if [[ "$CLEAN" = "YES" ]];then - if [[ $rc -eq 0 ]];then - rm -rf $tmpdir - cd $tmpdir - cd ../ - rmdir $tmpdir - fi -fi - - -# End of script -exit diff --git a/regression/hwrf_nmm_d3.sh b/regression/hwrf_nmm_d3.sh deleted file mode 100755 index 7b6746b741..0000000000 --- a/regression/hwrf_nmm_d3.sh +++ /dev/null @@ -1,337 +0,0 @@ - -set -x - -# Set analysis date -adate=$hwrf_nmm_adate - -io_format=netcdf - -if [[ "$io_format" = "binary" ]]; then - NETCDF=.false. - FORMAT=binary -elif [[ "$io_format" = "netcdf" ]]; then - NETCDF=.true. - FORMAT=netcdf -else - echo "***ERRROR*** INVALID io_format = $io_format" - exit -fi - -# Set experiment name and analysis date - -exp=$jobname - -# Set path/file for gsi executable -#gsiexec=$gsiexec - -# Set the JCAP resolution which you want. -# All resolutions use LEVS=64 -#export JCAP=62 -export LEVS=60 -export JCAP_B=$JCAP -export DELTIM=1200 - -# Set runtime and save directories -tmpdir=$tmpdir/tmpreg_hwrf_nmm_d3/${exp} -savdir=$savdir/outreg_hwrf_nmm_d3/${exp} - -# Specify GSI fixed field and data directories. -fixcrtm=${fixcrtm:-$CRTM_FIX} - -#datobs=$datobs - -# Set variables used in script -# CLEAN up $tmpdir when finished (YES=remove, NO=leave alone) -# ncp is cp replacement, currently keep as /bin/cp - -CLEAN=NO -ncp=/bin/cp -lnsf='ln -sf' - -NX3=250 -NY3=500 -export NLAT=$(( NY3 - 1 )) -export NLON=$(( NX3 - 1 )) - -# Given the analysis date, compute the date from which the -# first guess comes. Extract cycle and set prefix and suffix -# for guess and observation data files -gdate=`date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2} - 6 hours"` -hha=`echo $adate | cut -c9-10` -hhg=`echo $gdate | cut -c9-10` -prefixa=gfs.t${hha}z -prefixo=gdas1.t${hha}z -suffix=tm00.bufr_d - - -# Set up $tmpdir -rm -rf $tmpdir -mkdir -p $tmpdir -cd $tmpdir -rm -rf core* - -# Make gsi namelist - -. $scripts/regression_nl_update.sh - -GRIDOPTS="$GRIDOPTS_update" -BKGVERR="$BKGVERR_update" -ANBKGERR="$ANBKERR_update" -JCOPTS="$JCOPTS_update" -STRONGOPTS="$STRONGOPTS_update" -OBSQC="$OBSQC_update" -OBSINPUT="$OBSINPUT_update" -SUPERRAD="$SUPERRAD_update" -SINGLEOB="$SINGLEOB_update" - -# parameters for radiance data assimilation -export SETUP="newpc4pred=.true., adp_anglebc=.true., angord=4, \ - passive_bc=.false., use_edges=.false., emiss_bc=.true., \ - diag_precon=.true., step_start=1.e-3, upd_pred(1)=0, \ - upd_pred(2)=0,upd_pred(3)=0,upd_pred(4)=0, \ - upd_pred(5)=0,upd_pred(6)=0,upd_pred(7)=0, \ - upd_pred(8)=0,upd_pred(9)=0,upd_pred(10)=0, \ - upd_pred(11)=0,upd_pred(12)=0," - -export USE_GFS_STRATOSPHERE=".false." -export USE_GFS_OZONE=".false." -export REGIONAL_OZONE=".false." - -if [ "$debug" = ".false." ]; then - . $scripts/regression_namelists.sh hwrf_nmm_d3 -else - . $scripts/regression_namelists_db.sh hwrf_nmm_d3 -fi - -cat << EOF > gsiparm.anl - -$gsi_namelist - -EOF - -# Set fixed files -# berror = forecast model background error statistics -# specoef = CRTM spectral coefficients -# trncoef = CRTM transmittance coefficients -# emiscoef = CRTM coefficients for IR sea surface emissivity model -# aerocoef = CRTM coefficients for aerosol effects -# cldcoef = CRTM coefficients for cloud effects -# satinfo = text file with information about assimilation of brightness temperatures -# cloudyinfo = text file with information about assimilation of cloudy radiance -# pcpinfo = text file with information about assimilation of prepcipitation rates -# ozinfo = text file with information about assimilation of ozone data -# errtable = text file with obs error for conventional data (optional) -# convinfo = text file with information about assimilation of conventional data -# bufrtable= text file ONLY needed for single obs test (oneobstest=.true.) -# bftab_sst= bufr table for sst ONLY needed for sst retrieval (retrieval=.true.) - -anavinfo=$fixgsi/anavinfo_hwrf_L60_nooz -berror=$fixgsi/$endianness/nam_glb_berror.f77.gcv -emiscoef_IRwater=$fixcrtm/Nalli.IRwater.EmisCoeff.bin -emiscoef_IRice=$fixcrtm/NPOESS.IRice.EmisCoeff.bin -emiscoef_IRland=$fixcrtm/NPOESS.IRland.EmisCoeff.bin -emiscoef_IRsnow=$fixcrtm/NPOESS.IRsnow.EmisCoeff.bin -emiscoef_VISice=$fixcrtm/NPOESS.VISice.EmisCoeff.bin -emiscoef_VISland=$fixcrtm/NPOESS.VISland.EmisCoeff.bin -emiscoef_VISsnow=$fixcrtm/NPOESS.VISsnow.EmisCoeff.bin -emiscoef_VISwater=$fixcrtm/NPOESS.VISwater.EmisCoeff.bin -emiscoef_MWwater=$fixcrtm/FASTEM6.MWwater.EmisCoeff.bin -aercoef=$fixcrtm/AerosolCoeff.bin -cldcoef=$fixcrtm/CloudCoeff.bin -satinfo=$fixgsi/hwrf_satinfo.txt -cloudyinfo=$fixgsi/cloudy_radiance_info.txt -atmsbeaminfo=$fixgsi/atms_beamwidth.txt -scaninfo=$fixgsi/global_scaninfo.txt -pcpinfo=$fixgsi/nam_global_pcpinfo.txt -ozinfo=$fixgsi/global_ozinfo.txt -errtable=$fixgsi/hwrf_nam_errtable.r3dv -convinfo=$fixgsi/hwrf_convinfo.txt -### add 9 tables -errtable_pw=$fixgsi/prepobs_errtable_pw.global -errtable_ps=$fixgsi/prepobs_errtable_ps.global_nqcf -errtable_t=$fixgsi/prepobs_errtable_t.global_nqcf -errtable_q=$fixgsi/prepobs_errtable_q.global_nqcf -errtable_uv=$fixgsi/prepobs_errtable_uv.global_nqcf -btable_ps=$fixgsi/nqc_b_ps.global_nqcf -btable_t=$fixgsi/nqc_b_t.global_nqcf -btable_q=$fixgsi/nqc_b_q.global_nqcf -btable_uv=$fixgsi/nqc_b_uv.global_nqcf - -# add vertical profile of localization and beta_s,beta_e weights for hybrid ensemble runs -hybens_info=$fixgsi/hwrf_hybens_d3_info - - -# Only need this file for single obs test -bufrtable=$fixgsi/prepobs_prep.bufrtable - -# Only need this file for sst retrieval -bftab_sst=$fixgsi/bufrtab.012 - -# Copy executable and fixed files to $tmpdir -if [[ $exp == *"updat"* ]]; then - $ncp $gsiexec_updat ./gsi.x -elif [[ $exp == *"contrl"* ]]; then - $ncp $gsiexec_contrl ./gsi.x -fi - -$ncp $anavinfo ./anavinfo -$ncp $berror ./berror_stats -$ncp $emiscoef_IRwater ./Nalli.IRwater.EmisCoeff.bin -$ncp $emiscoef_IRice ./NPOESS.IRice.EmisCoeff.bin -$ncp $emiscoef_IRsnow ./NPOESS.IRsnow.EmisCoeff.bin -$ncp $emiscoef_IRland ./NPOESS.IRland.EmisCoeff.bin -$ncp $emiscoef_VISice ./NPOESS.VISice.EmisCoeff.bin -$ncp $emiscoef_VISland ./NPOESS.VISland.EmisCoeff.bin -$ncp $emiscoef_VISsnow ./NPOESS.VISsnow.EmisCoeff.bin -$ncp $emiscoef_VISwater ./NPOESS.VISwater.EmisCoeff.bin -$ncp $emiscoef_MWwater ./FASTEM6.MWwater.EmisCoeff.bin -$ncp $aercoef ./AerosolCoeff.bin -$ncp $cldcoef ./CloudCoeff.bin -$ncp $satinfo ./satinfo -$ncp $cloudyinfo ./cloudy_radiance_info.txt -$ncp $scaninfo ./scaninfo -$ncp $pcpinfo ./pcpinfo -$ncp $ozinfo ./ozinfo -$ncp $convinfo ./convinfo -$ncp $errtable ./errtable -$ncp $atmsbeaminfo ./atms_beamwidth.txt -#add 9 tables for new varqc -$ncp $errtable_pw ./errtable_pw -$ncp $errtable_ps ./errtable_ps -$ncp $errtable_t ./errtable_t -$ncp $errtable_q ./errtable_q -$ncp $errtable_uv ./errtable_uv -$ncp $btable_ps ./btable_ps -$ncp $btable_t ./btable_t -$ncp $btable_q ./btable_q -$ncp $btable_uv ./btable_uv - -$ncp $hybens_info ./hybens_info - -$ncp $bufrtable ./prepobs_prep.bufrtable -$ncp $bftab_sst ./bftab_sstphr - -# Copy CRTM coefficient files based on entries in satinfo file -for file in `awk '{if($1!~"!"){print $1}}' ./satinfo | sort | uniq` ;do - $ncp $fixcrtm/${file}.SpcCoeff.bin ./ - $ncp $fixcrtm/${file}.TauCoeff.bin ./ -done - - -# Copy observational data to $tmpdir -$lnsf $hwrf_nmm_obs/${prefixa}.prepbufr ./prepbufr -#$lnsf $hwrf_nmm_obs/${prefixa}.satwnd.${suffix} ./satwndbufr -#$lnsf $hwrf_nmm_obs/${prefixa}.gpsro.${suffix} ./gpsrobufr -#$lnsf $hwrf_nmm_obs/${prefixa}.spssmi.${suffix} ./ssmirrbufr -#$lnsf $hwrf_nmm_obs/${prefixa}.sptrmm.${suffix} ./tmirrbufr -#$lnsf $hwrf_nmm_obs/${prefixa}.gome.${suffix} ./gomebufr -#$lnsf $hwrf_nmm_obs/${prefixa}.omi.${suffix} ./omibufr -#$lnsf $hwrf_nmm_obs/${prefixa}.mls.${suffix} ./mlsbufr -#$lnsf $hwrf_nmm_obs/${prefixa}.osbuv8.${suffix} ./sbuvbufr -#$lnsf $hwrf_nmm_obs/${prefixa}.goesfv.${suffix} ./gsnd1bufr -#$lnsf $hwrf_nmm_obs/${prefixa}.1bamua.${suffix} ./amsuabufr -#$lnsf $hwrf_nmm_obs/${prefixa}.1bamub.${suffix} ./amsubbufr -#$lnsf $hwrf_nmm_obs/${prefixa}.1bhrs2.${suffix} ./hirs2bufr -#$lnsf $hwrf_nmm_obs/${prefixa}.1bhrs3.${suffix} ./hirs3bufr -#$lnsf $hwrf_nmm_obs/${prefixa}.1bhrs4.${suffix} ./hirs4bufr -#$lnsf $hwrf_nmm_obs/${prefixa}.1bmhs.${suffix} ./mhsbufr -#$lnsf $hwrf_nmm_obs/${prefixa}.1bmsu.${suffix} ./msubufr -#$lnsf $hwrf_nmm_obs/${prefixa}.airsev.${suffix} ./airsbufr -#$lnsf $hwrf_nmm_obs/${prefixa}.sevcsr.${suffix} ./seviribufr -#$lnsf $hwrf_nmm_obs/${prefixa}.mtiasi.${suffix} ./iasibufr -#$lnsf $hwrf_nmm_obs/${prefixa}.esamua.${suffix} ./amsuabufrears -#$lnsf $hwrf_nmm_obs/${prefixa}.esamub.${suffix} ./amsubbufrears -#$lnsf $hwrf_nmm_obs/${prefixa}.eshrs3.${suffix} ./hirs3bufrears -#$lnsf $hwrf_nmm_obs/${prefixa}.ssmit.${suffix} ./ssmitbufr -#$lnsf $hwrf_nmm_obs/${prefixa}.amsre.${suffix} ./amsrebufr -#$lnsf $hwrf_nmm_obs/${prefixa}.ssmis.${suffix} ./ssmisbufr -#$lnsf $hwrf_nmm_obs/${prefixa}.atms.${suffix} ./atmsbufr -#$lnsf $hwrf_nmm_obs/${prefixa}.cris.${suffix} ./crisbufr -#$lnsf $hwrf_nmm_obs/${prefixa}.syndata.tcvitals.tm00 ./tcvitl -$lnsf $hwrf_nmm_obs/${prefixo}.tldplr.${suffix} ./tldplrbufr - - -# Copy bias correction, atmospheric and surface files -$lnsf $hwrf_nmm_obs/gdas1.t${hhg}z.abias ./satbias_in -$lnsf $hwrf_nmm_obs/gdas1.t${hhg}z.abias_pc ./satbias_pc - -$ncp $hwrf_nmm_ges/wrfghost_d03_03 ./wrf_inou3 -$ncp $hwrf_nmm_ges/wrfghost_d03_06 ./wrf_inout -$ncp $hwrf_nmm_ges/wrfghost_d03_09 ./wrf_inou9 - -$ncp $hwrf_nmm_ges/gdas1.t${hhg}z.sf03 ./gfs_sigf03 -$ncp $hwrf_nmm_ges/gdas1.t${hhg}z.sf06 ./gfs_sigf06 -$ncp $hwrf_nmm_ges/gdas1.t${hhg}z.sf09 ./gfs_sigf09 - -# Copy ensemble forecast files for hybrid analysis -export ENSEMBLE_SIZE_REGIONAL=10 ->filelist06 -n=1 -while [[ $n -le ${ENSEMBLE_SIZE_REGIONAL} ]]; do - $lnsf $hwrf_nmm_ges/$( printf sfg_${gdate}_fhr06s_mem%03d $n ) \ - ./$( printf sfg_${gdate}_fhr06s_mem%03d $n ) - ls ./$( printf sfg_${gdate}_fhr06s_mem%03d $n ) >> filelist06 - n=$((n + 1)) -done - -# Run GSI -cd $tmpdir -echo "run gsi now" -eval "$APRUN $tmpdir/gsi.x > stdout 2>&1" -rc=$? -exit $rc - - - - -# Loop over first and last outer loops to generate innovation -# diagnostic files for indicated observation types (groups) -# -# NOTE: Since we set miter=2 in GSI namelist SETUP, outer -# loop 03 will contain innovations with respect to -# the analysis. Creation of o-a innovation files -# is triggered by write_diag(3)=.true. The setting -# write_diag(1)=.true. turns on creation of o-g -# innovation files. -# - - -echo "Time before diagnostic loop is `date` " -cd $tmpdir -loops="01 03" -for loop in $loops; do - -case $loop in - 01) string=ges;; - 03) string=anl;; - *) string=$loop;; -esac - -# Collect diagnostic files for obs types (groups) below - listall="hirs2_n14 msu_n14 sndr_g08 sndr_g11 sndr_g11 sndr_g12 sndr_g13 sndr_g08_prep sndr_g11_prep sndr_g12_prep sndr_g13_prep sndrd1_g11 sndrd2_g11 sndrd3_g11 sndrd4_g11 sndrd1_g12 sndrd2_g12 sndrd3_g12 sndrd4_g12 sndrd1_g13 sndrd2_g13 sndrd3_g13 sndrd4_g13 hirs3_n15 hirs3_n16 hirs3_n17 amsua_n15 amsua_n16 amsua_n17 amsub_n15 amsub_n16 amsub_n17 hsb_aqua airs_aqua amsua_aqua imgr_g08 imgr_g11 imgr_g12 pcp_ssmi_dmsp pcp_tmi_trmm conv sbuv2_n16 sbuv2_n17 sbuv2_n18 gome_metop-a omi_aura ssmi_f13 ssmi_f15 hirs4_n18 hirs4_metop-a amsua_n18 amsua_metop-a mhs_n18 mhs_metop-a amsre_low_aqua amsre_mid_aqua amsre_hig_aqua ssmis_las_f16 ssmis_uas_f16 ssmis_img_f16 ssmis_env_f16 iasi_metop-a" - for type in $listall; do - count=`ls dir.*/${type}_${loop}* | wc -l` - if [[ $count -gt 0 ]]; then - cat dir.*/${type}_${loop}* > diag_${type}_${string}.${hwrf_nmm_adate} - compress diag_${type}_${string}.${hwrf_nmm_adate} - $ncp diag_${type}_${string}.${hwrf_nmm_adate}.Z $savdir/ - fi - done -done -echo "Time after diagnostic loop is `date` " - - - -# If requested, clean up $tmpdir -if [[ "$CLEAN" = "YES" ]];then - if [[ $rc -eq 0 ]];then - rm -rf $tmpdir - cd $tmpdir - cd ../ - rmdir $tmpdir - fi -fi - - -# End of script -exit diff --git a/regression/multi_regression.sh b/regression/multi_regression.sh index b850863d69..4df5581097 100755 --- a/regression/multi_regression.sh +++ b/regression/multi_regression.sh @@ -1,22 +1,18 @@ #!/bin/sh --login -regtests_all="global_3dvar - global_4dvar - global_4denvar +regtests_all="global_4denvar netcdf_fv3_regional rrfs_3denvar_glbens - hwrf_nmm_d2 - hwrf_nmm_d3 + hafs_4denvar_glbens + hafs_3denvar_hybens rtma global_enkf" -regtests_debug="global_3dvar - global_4dvar - global_4denvar +regtests_debug="global_4denvar netcdf_fv3_regional rrfs_3denvar_glbens - hwrf_nmm_d2 - hwrf_nmm_d3 + hafs_4denvar_glbens + hafs_3denvar_hybens rtma global_enkf" diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh index 3668a6f8c1..2448bd155e 100755 --- a/regression/regression_namelists.sh +++ b/regression/regression_namelists.sh @@ -2,14 +2,14 @@ regtest=$1 case $regtest in - global_3dvar) + global_4denvar) -# Define namelist for global run (pcgsoi minimization) +# Define namelist for global hybrid run export gsi_namelist=" &SETUP - miter=2,niter(1)=5,niter(2)=10, + miter=2,niter(1)=5,niter(2)=5, niter_no_qc(1)=2,niter_no_qc(2)=0, write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., qoption=2, @@ -26,9 +26,12 @@ export gsi_namelist=" verbose=.false.,imp_physics=11,lupp=.true., binary_diag=.false.,netcdf_diag=.true., lobsdiag_forenkf=.false., - nhr_anal=3,6,9,nhr_obsbin=3, + nhr_anal=3,6,9,nhr_obsbin=1, + l4densvar=.true.,ens_nstarthr=3,nhr_assimilation=6,lwrite4danl=.true., optconv=0.05,cao_check=.true.,ta2tb=.false., - tzr_qc=1,sfcnst_comb=.true., write_fv3_incr=.true.,incvars_to_zero= 'liq_wat_inc','icmr_inc','rwmr_inc','snmr_inc','grle_inc',incvars_zero_strat='sphum_inc','liq_wat_inc','icmr_inc','rwmr_inc','snmr_inc','grle_inc',incvars_efold=5, use_gfs_ncio=.true., + tzr_qc=1,sfcnst_comb=.true., + write_fv3_incr=.true.,incvars_to_zero= 'liq_wat_inc','icmr_inc','rwmr_inc','snmr_inc','grle_inc', + incvars_zero_strat='sphum_inc','liq_wat_inc','icmr_inc','rwmr_inc','snmr_inc','grle_inc',incvars_efold=5, use_gfs_ncio=.true., $SETUP / &GRIDOPTS @@ -56,7 +59,8 @@ export gsi_namelist=" $JCOPTS / &STRONGOPTS - tlnmc_option=2,nstrong=1,nvmodes_keep=8,period_max=6.,period_width=1.5, + tlnmc_option=3,nstrong=1,nvmodes_keep=8,period_max=6.,period_width=1.5, + baldiag_full=.false.,baldiag_inc=.false., $STRONGOPTS / @@ -195,7 +199,11 @@ OBS_INPUT:: / &HYBRID_ENSEMBLE - $HYBRIDENSEMBLE + l_hyb_ens=.true.,n_ens=$NMEM_ENKF,beta_s0=0.125,readin_beta=.false.,s_ens_h=800,s_ens_v=-0.8, + generate_ens=.false.,uv_hyb_ens=.true.,jcap_ens=48,nlat_ens=98,nlon_ens=192, + ANISO_A_EN=.false.,jcap_ens_test=48,oz_univ_static=.false.,readin_localization=.true., + ensemble_path='./ensemble_data/',ens_fast_read=.true.,write_ens_sprd=.false., + $HYBRID_ENSEMBLE / &RAPIDREFRESH_CLDSURF dfi_radar_latent_heat_time_period=30.0, @@ -214,151 +222,85 @@ OBS_INPUT:: / " ;; + RTMA) - global_lanczos) - -# Define namelist for global run (lanczos minimization) +# Define namelist for RTMA runs -export gsi_namelist=" +export gsi_namelist=" &SETUP - miter=2,niter(1)=50,niter(2)=50, - niter_no_qc(1)=500,niter_no_qc(2)=500, - write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - gencode=82,qoption=2, - factqmin=0.005,factqmax=0.005,deltim=$DELTIM, + miter=2,niter(1)=5,niter(2)=5, + write_diag(1)=.true.,write_diag(2)=.true.,write_diag(3)=.true., + gencode=78,qoption=1,tsensible=.true. + factqmin=1.0,factqmax=1.0,factv=0.0,factcldch=0.0,factw10m=1.0,deltim=$DELTIM, iguess=-1, - oneobtest=.false.,retrieval=.false.,l_foto=.false., - use_pbl=.false.,use_compress=.false.,nsig_ext=10,gpstop=30., - crtm_coeffs_path='./crtm_coeffs/', - lsqrtb=.true.,lcongrad=.true.,ltlint=.true.,ladtest=.true.,lgrtest=.false., - use_gfs_nemsio=.false.,lrun_subdirs=.true.,use_gfs_ncio=.true., + oneobtest=.false.,retrieval=.false., + diag_rad=.false.,diag_pcp=.false.,diag_ozone=.false.,diag_aero=.false., + nhr_assimilation=6,min_offset=180,use_compress=.false.,lrun_subdirs=.true., + use_similarity_2dvar=.true., + neutral_stability_windfact_2dvar=.false., + use_prepb_satwnd=.false., $SETUP / &GRIDOPTS JCAP=$JCAP,JCAP_B=$JCAP_B,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS, - regional=.false.,nlayers(63)=3,nlayers(64)=6, - $GRIDOPTS + wrf_nmm_regional=.false.,wrf_mass_regional=.false.,twodvar_regional=.true., + diagnostic_reg=.false., + filled_grid=.false.,half_grid=.true.,netcdf=.false., / &BKGERR - vs=0.7, - hzscl=1.7,0.8,0.5, - hswgt=0.45,0.3,0.25, - bw=0.0,norsp=4, - bkgv_flowdep=.true.,bkgv_rewgtfct=1.5, - $BKGVERR + hzscl=1.414,1.000,0.707, + vs=0.5,bw=0.0, / &ANBKGERR - anisotropic=.false., - $ANBKGERR + anisotropic=.true.,an_vs=0.5,ngauss=1, + an_flen_u=-5.,an_flen_t=3.,an_flen_z=-200., + ifilt_ord=2,npass=3,normal=-200,grid_ratio=1.,nord_f2a=4, + rtma_subdomain_option=.true.,triad4=.true.,nsmooth=0,nsmooth_shapiro=0,lreadnorm=.true., / &JCOPTS - ljcpdry=.false.,bamp_jcpdry=2.5e7, - $JCOPTS / &STRONGOPTS - tlnmc_option=1,nstrong=1,nvmodes_keep=8,period_max=6.,period_width=1.5, + nstrong=1,nvmodes_keep=20,period_max=3., baldiag_full=.true.,baldiag_inc=.true., - $STRONGOPTS / &OBSQC - dfact=0.75,dfact1=3.0,noiqc=.false.,oberrflg=.false.,c_varqc=0.02, - use_poq7=.true.,njqc=.false.,vqc=.true., + dfact=0.75,dfact1=3.0,noiqc=.true.,c_varqc=0.02,vadfile='prepbufr',hilbert_curve=.true., + buddycheck_t=.false.,buddydiag_save=.false.,oberrflg=.true.,njqc=.true.,vqc=.false., $OBSQC / &OBS_INPUT - dmesh(1)=180.0,dmesh(2)=145.0,dmesh(3)=240.0,dmesh(4)=160.0,dmesh(5)=180.0,dmesh(6)=150.0,dmesh(7)=145.0,time_window_max=3.0, - $OBSINPUT + dmesh(1)=60.0,dmesh(2)=60.0,dmesh(3)=60.0,dmesh(4)=60.0,time_window_max=3.0, / OBS_INPUT:: -! dfile dtype dplat dsis dval dthin dsfcalc - prepbufr ps null ps 1.0 0 0 - prepbufr t null t 1.0 0 0 - prepbufr q null q 1.0 0 0 - prepbufr pw null pw 1.0 0 0 - satwndbufr uv null uv 1.0 0 0 - prepbufr uv null uv 1.0 0 0 - prepbufr spd null spd 1.0 0 0 - prepbufr dw null dw 1.0 0 0 - radarbufr rw null l3rw 1.0 0 0 - l2rwbufr rw null l2rw 1.0 0 0 - prepbufr sst null sst 1.0 0 0 - gpsrobufr $gps_dtype null gps 1.0 0 0 - ssmirrbufr pcp_ssmi dmsp pcp_ssmi 1.0 -1 0 - tmirrbufr pcp_tmi trmm pcp_tmi 1.0 -1 0 - sbuvbufr sbuv2 n16 sbuv8_n16 1.0 0 0 - sbuvbufr sbuv2 n17 sbuv8_n17 1.0 0 0 - sbuvbufr sbuv2 n18 sbuv8_n18 1.0 0 0 - hirs2bufr hirs2 n14 hirs2_n14 6.0 1 1 - hirs3bufr hirs3 n16 hirs3_n16 0.0 1 1 - hirs3bufr hirs3 n17 hirs3_n17 6.0 1 1 - hirs4bufr hirs4 n18 hirs4_n18 0.0 1 1 - hirs4bufr hirs4 metop-a hirs4_metop-a 6.0 1 1 - gsndrbufr sndr g11 sndr_g11 0.0 1 0 - gsndrbufr sndr g12 sndr_g12 0.0 1 0 - gimgrbufr goes_img g11 imgr_g11 0.0 1 0 - gimgrbufr goes_img g12 imgr_g12 0.0 1 0 - airsbufr airs aqua airs_aqua 20.0 1 1 - msubufr msu n14 msu_n14 2.0 2 1 - amsuabufr amsua n15 amsua_n15 10.0 2 1 - amsuabufr amsua n16 amsua_n16 0.0 2 1 - amsuabufr amsua n17 amsua_n17 0.0 2 1 - amsuabufr amsua n18 amsua_n18 10.0 2 1 - amsuabufr amsua metop-a amsua_metop-a 10.0 2 1 - airsbufr amsua aqua amsua_aqua 5.0 2 1 - amsubbufr amsub n15 amsub_n15 3.0 3 1 - amsubbufr amsub n16 amsub_n16 3.0 3 1 - amsubbufr amsub n17 amsub_n17 3.0 3 1 - mhsbufr mhs n18 mhs_n18 3.0 3 1 - mhsbufr mhs metop-a mhs_metop-a 3.0 3 1 - ssmitbufr ssmi f13 ssmi_f13 0.0 4 0 - ssmitbufr ssmi f15 ssmi_f15 0.0 4 0 - amsrebufr amsre_low aqua amsre_aqua 0.0 4 1 - amsrebufr amsre_mid aqua amsre_aqua 0.0 4 1 - amsrebufr amsre_hig aqua amsre_aqua 0.0 4 1 - ssmisbufr ssmis f16 ssmis_f16 0.0 4 1 - gsnd1bufr sndrd1 g12 sndrD1_g12 1.5 5 0 - gsnd1bufr sndrd2 g12 sndrD2_g12 1.5 5 0 - gsnd1bufr sndrd3 g12 sndrD3_g12 1.5 5 0 - gsnd1bufr sndrd4 g12 sndrD4_g12 1.5 5 0 - gsnd1bufr sndrd1 g11 sndrD1_g11 1.5 5 0 - gsnd1bufr sndrd2 g11 sndrD2_g11 1.5 5 0 - gsnd1bufr sndrd3 g11 sndrD3_g11 1.5 5 0 - gsnd1bufr sndrd4 g11 sndrD4_g11 1.5 5 0 - gsnd1bufr sndrd1 g13 sndrD1_g13 1.5 5 0 - gsnd1bufr sndrd2 g13 sndrD2_g13 1.5 5 0 - gsnd1bufr sndrd3 g13 sndrD3_g13 1.5 5 0 - gsnd1bufr sndrd4 g13 sndrD4_g13 1.5 5 0 - iasibufr iasi metop-a iasi_metop-a 20.0 1 1 - gomebufr gome metop-a gome_metop-a 1.0 6 0 - omibufr omi aura omi_aura 1.0 6 0 - sbuvbufr sbuv2 n19 sbuv8_n19 1.0 0 0 - hirs4bufr hirs4 n19 hirs4_n19 6.0 1 1 - amsuabufr amsua n19 amsua_n19 10.0 2 1 - mhsbufr mhs n19 mhs_n19 3.0 3 1 - tcvitl tcp null tcp 1.0 0 0 - mlsbufr mls30 aura mls30_aura 1.0 0 0 - seviribufr seviri m08 seviri_m08 0.0 7 0 - seviribufr seviri m09 seviri_m09 0.0 7 0 - seviribufr seviri m10 seviri_m10 0.0 7 0 - seviribufr seviri m11 seviri_m11 0.0 7 0 - oscatbufr uv null uv 1.0 0 0 - ompsnpbufr ompsnp npp ompsnp_npp 1.0 0 0 - ompstcbufr ompstc8 npp ompstc8_npp 1.0 6 0 - abibufr abi g16 abi_g16 0.0 7 0 - ahibufr ahi himawari8 ahi_himawari8 0.0 7 0 - abibufr abi g17 abi_g17 0.0 7 0 - abibufr abi g18 abi_g18 0.0 7 0 - ahibufr ahi himawari9 ahi_himawari9 0.0 7 0 - atmsbufr atms n21 atms_n21 0.0 7 1 - crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 7 0 - sstviirs viirs-m j2 viirs-m_j2 0.0 4 0 - ompsnpbufr ompsnp n21 ompsnp_n21 0.0 0 0 - ompstcbufr ompstc8 n21 ompstc8_n21 0.0 6 0 - gomebufr gome metop-c gome_metop-c 0.0 6 0 +! dfile dtype dplat dsis dval dthin dsfcalc + prepbufr ps null ps 1.0 0 0 + prepbufr t null t 1.0 0 0 + prepbufr q null q 1.0 0 0 + prepbufr uv null uv 1.0 0 0 + satwndbufr uv null uv 1.0 0 0 + prepbufr spd null spd 1.0 0 0 + prepbufr wspd10m null wspd10m 1.0 0 0 + satwnd wspd10m null wspd10m 1.0 0 0 + prepbufr uwnd10m null uwnd10m 1.0 0 0 + satwnd uwnd10m null uwnd10m 1.0 0 0 + prepbufr vwnd10m null vwnd10m 1.0 0 0 + satwnd vwnd10m null vwnd10m 1.0 0 0 + prepbufr gust null gust 1.0 0 0 + prepbufr vis null vis 1.0 0 0 + prepbufr td2m null td2m 1.0 0 0 + mxtmdat mxtm null mxtm 1.0 0 0 + mitmdat mitm null mitm 1.0 0 0 + prepbufr mxtm null mxtm 1.0 0 0 + prepbufr mitm null mitm 1.0 0 0 + prepbufr pmsl null pmsl 1.0 0 0 + prepbufr howv null howv 1.0 0 0 + satmar howv null howv 1.0 0 0 + prepbufr tcamt null tcamt 1.0 0 0 + goessky tcamt null tcamt 1.0 0 0 + prepbufr cldch null cldch 1.0 0 0 :: - &SUPEROB_RADAR - $SUPERRAD + &SUPEROB_RADAR / &LAG_DATA / @@ -366,908 +308,264 @@ OBS_INPUT:: / &RAPIDREFRESH_CLDSURF dfi_radar_latent_heat_time_period=30.0, + l_closeobs=.true. / &CHEM / &SINGLEOB_TEST maginnov=0.1,magoberr=0.1,oneob_type='t', - oblat=45.,oblon=180.,obpres=1000.,obdattim=${adate}, + oblat=36.,oblon=260.,obpres=1000.,obdattim=${adate}, obhourset=0., - $SINGLEOB / &NST / " - ;; + rrfs_3denvar_glbens) - global_hybrid_T126) - -# Define namelist for global hybrid run +# Define namelist for rrfs 3d hybrid envar run with global ensembles export gsi_namelist=" &SETUP - miter=1,niter(1)=5,niter(2)=150, - niter_no_qc(1)=50,niter_no_qc(2)=0, + miter=2,niter(1)=5,niter(2)=5, write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - qoption=2,cwoption=3, - gencode=82,factqmin=0.1,factqmax=0.1,deltim=$DELTIM, + qoption=2,print_obs_para=.true.,diag_radardbz=.false., + if_model_dbz=.false., static_gsi_nopcp_dbz=0.0, + rmesh_dbz=4.0,rmesh_vr=4.0,zmesh_dbz=1000.0,zmesh_vr=1000.0, + missing_to_nopcp=.false.,radar_no_thinning=.true., + gencode=78,factqmin=0.0,factqmax=0.0, iguess=-1, - oneobtest=.false.,retrieval=.false.,l_foto=.false., + lread_obs_save=.false.,lread_obs_skip=.false., + oneobtest=.false.,retrieval=.false., + nhr_assimilation=3,l_foto=.false., use_pbl=.false.,use_prepb_satwnd=.false., - nhr_assimilation=6,lrun_subdirs=.true., - $SETUP + newpc4pred=.true.,adp_anglebc=.true.,angord=4, + passive_bc=.true.,use_edges=.false.,emiss_bc=.true., + diag_precon=.true.,step_start=1.e-3, + l4densvar=.false.,nhr_obsbin=3, + use_gfs_nemsio=.false.,use_gfs_ncio=.true.,reset_bad_radbc=.true., + netcdf_diag=.false.,binary_diag=.true., + l_obsprvdiag=.false., / &GRIDOPTS - JCAP_B=$JCAP_B,JCAP=$JCAP,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS, - regional=.false.,nlayers(63)=3,nlayers(64)=6, - $GRIDOPTS + fv3_regional=.true.,grid_ratio_fv3_regional=2.0,nvege_type=20, + fv3_io_layout_y=1, / &BKGERR - hzscl=1.7,0.8,0.5, - hswgt=0.45,0.3,0.25, - - bw=0.0,norsp=4, - bkgv_flowdep=.true.,bkgv_rewgtfct=1.5, - bkgv_write=.false., - $BKGVERR - / + vs=1.0, + hzscl=0.7,1.4,2.80, + bw=0.,fstat=.true., + usenewgfsberror=.true., +/ &ANBKGERR anisotropic=.false., - $ANBKGERR / &JCOPTS - ljcdfi=.false.,alphajc=0.0,ljcpdry=.true.,bamp_jcpdry=2.5e7, - $JCOPTS / &STRONGOPTS - tlnmc_option=1,nstrong=1,nvmodes_keep=8,period_max=6.,period_width=1.5, - baldiag_full=.true.,baldiag_inc=.true., - $STRONGOPTS / &OBSQC - dfact=0.75,dfact1=3.0,noiqc=.true.,oberrflg=.false.,c_varqc=0.02, - use_poq7=.true.,njqc=.false.,vqc=.true.,aircraft_t_bc=.true.,biaspredt=1000.0,upd_aircraft=.true., - $OBSQC + dfact=0.75,dfact1=3.0,noiqc=.false.,c_varqc=0.02,vadfile='prepbufr', + vadwnd_l2rw_qc=.true., / &OBS_INPUT - dmesh(1)=145.0,dmesh(2)=150.0,time_window_max=3.0, - $OBSINPUT + dmesh(1)=120.0,dmesh(2)=60.0,dmesh(3)=30,time_window_max=1.5,time_window_rad=1.0,ext_sonde=.true., / OBS_INPUT:: -! dfile dtype dplat dsis dval dthin dsfcalc - prepbufr ps null ps 0.0 0 0 - prepbufr t null t 0.0 0 0 - prepbufr_profl t null t 0.0 0 0 - prepbufr q null q 0.0 0 0 - prepbufr_profl q null q 0.0 0 0 - prepbufr pw null pw 0.0 0 0 - prepbufr uv null uv 0.0 0 0 - prepbufr_profl uv null uv 0.0 0 0 - satwndbufr uv null uv 0.0 0 0 - prepbufr spd null spd 0.0 0 0 - prepbufr dw null dw 0.0 0 0 - radarbufr rw null l3rw 0.0 0 0 - l2rwbufr rw null l2rw 0.0 0 0 - prepbufr sst null sst 0.0 0 0 - gpsrobufr gps_bnd null gps 0.0 0 0 - ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0 - tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0 - sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 - sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 - sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1 - gimgrbufr goes_img g11 imgr_g11 0.0 1 0 - gimgrbufr goes_img g12 imgr_g12 0.0 1 0 - airsbufr airs aqua airs_aqua 0.0 1 1 - amsuabufr amsua n15 amsua_n15 0.0 1 1 - amsuabufr amsua n18 amsua_n18 0.0 1 1 - amsuabufr amsua metop-a amsua_metop-a 0.0 1 1 - airsbufr amsua aqua amsua_aqua 0.0 1 1 - amsubbufr amsub n17 amsub_n17 0.0 1 1 - mhsbufr mhs n18 mhs_n18 0.0 1 1 - mhsbufr mhs metop-a mhs_metop-a 0.0 1 1 - ssmitbufr ssmi f15 ssmi_f15 0.0 1 0 - amsrebufr amsre_low aqua amsre_aqua 0.0 1 0 - amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0 - amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0 - ssmisbufr ssmis_las f16 ssmis_f16 0.0 1 0 - ssmisbufr ssmis_uas f16 ssmis_f16 0.0 1 0 - ssmisbufr ssmis_img f16 ssmis_f16 0.0 1 0 - ssmisbufr ssmis_env f16 ssmis_f16 0.0 1 0 - gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 1 0 - gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 1 0 - gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 1 0 - gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 1 0 - gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 1 0 - gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 1 0 - gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 1 0 - gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 1 0 - gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 1 0 - gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 1 0 - gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 1 0 - gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 1 0 - iasibufr iasi metop-a iasi_metop-a 0.0 1 1 - gomebufr gome metop-a gome_metop-a 0.0 2 0 - omibufr omi aura omi_aura 0.0 2 0 - sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1 - amsuabufr amsua n19 amsua_n19 0.0 1 1 - mhsbufr mhs n19 mhs_n19 0.0 1 1 - tcvitl tcp null tcp 0.0 0 0 - seviribufr seviri m08 seviri_m08 0.0 1 0 - seviribufr seviri m09 seviri_m09 0.0 1 0 - seviribufr seviri m10 seviri_m10 0.0 1 0 - seviribufr seviri m11 seviri_m11 0.0 1 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 - amsuabufr amsua metop-b amsua_metop-b 0.0 1 0 - mhsbufr mhs metop-b mhs_metop-b 0.0 1 0 - iasibufr iasi metop-b iasi_metop-b 0.0 1 0 - gomebufr gome metop-b gome_metop-b 0.0 2 0 - atmsbufr atms npp atms_npp 0.0 1 0 - atmsbufr atms n20 atms_n20 0.0 1 0 - crisbufr cris npp cris_npp 0.0 1 0 - crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 - crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0 - gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 1 0 - gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 1 0 - gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 1 0 - gsnd1bufr sndrd4 g14 sndrD4_g14 0.0 1 0 - gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 1 0 - gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0 - gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0 - gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0 - ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 - ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 - abibufr abi g16 abi_g16 0.0 1 0 - ahibufr ahi himawari8 ahi_himawari8 0.0 1 0 - abibufr abi g17 abi_g17 0.0 1 0 - abibufr abi g18 abi_g18 0.0 1 0 - ahibufr ahi himawari9 ahi_himawari9 0.0 1 0 - atmsbufr atms n21 atms_n21 0.0 1 1 - crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 1 0 - sstviirs viirs-m j2 viirs-m_j2 0.0 4 0 - ompsnpbufr ompsnp n21 ompsnp_n21 0.0 0 0 - ompstcbufr ompstc8 n21 ompstc8_n21 0.0 2 0 - gomebufr gome metop-c gome_metop-c 0.0 2 0 +! dfile dtype dplat dsis dval dthin dsfcalc + dbzobs.nc dbz null dbz 1.0 0 0 + prepbufr ps null ps 1.0 0 0 + prepbufr t null t 1.0 0 0 + prepbufr q null q 1.0 0 0 + prepbufr pw null pw 1.0 0 0 + satwndbufr uv null uv 1.0 0 0 + prepbufr uv null uv 1.0 0 0 + prepbufr spd null spd 1.0 0 0 + prepbufr dw null dw 1.0 0 0 + l2rwbufr rw null l2rw 1.0 0 0 + prepbufr sst null sst 1.0 0 0 + gpsrobufr gps_ref null gps 1.0 0 0 + ssmirrbufr pcp_ssmi dmsp pcp_ssmi 1.0 -1 0 + tmirrbufr pcp_tmi trmm pcp_tmi 1.0 -1 0 + sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 + sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 + sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 + hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 + hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 + hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 2 0 + hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0 + hirs4bufr hirs4 n19 hirs4_n19 0.0 2 0 + hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 2 0 + gimgrbufr goes_img g11 imgr_g11 0.0 1 0 + gimgrbufr goes_img g12 imgr_g12 0.0 1 0 + airsbufr airs aqua airs_aqua 0.0 2 0 + amsuabufr amsua n15 amsua_n15 0.0 2 0 + amsuabufr amsua n18 amsua_n18 0.0 2 0 + amsuabufr amsua n19 amsua_n19 0.0 2 0 + amsuabufr amsua metop-a amsua_metop-a 0.0 2 0 + amsuabufr amsua metop-b amsua_metop-b 0.0 2 0 + airsbufr amsua aqua amsua_aqua 0.0 2 0 + amsubbufr amsub n17 amsub_n17 0.0 1 0 + mhsbufr mhs n18 mhs_n18 0.0 2 0 + mhsbufr mhs n19 mhs_n19 0.0 2 0 + mhsbufr mhs metop-a mhs_metop-a 0.0 2 0 + mhsbufr mhs metop-b mhs_metop-b 0.0 2 0 + ssmitbufr ssmi f13 ssmi_f13 0.0 2 0 + ssmitbufr ssmi f14 ssmi_f14 0.0 2 0 + ssmitbufr ssmi f15 ssmi_f15 0.0 2 0 + amsrebufr amsre_low aqua amsre_aqua 0.0 2 0 + amsrebufr amsre_mid aqua amsre_aqua 0.0 2 0 + amsrebufr amsre_hig aqua amsre_aqua 0.0 2 0 + ssmisbufr ssmis f16 ssmis_f16 0.0 2 0 + ssmisbufr ssmis f17 ssmis_f17 0.0 2 0 + ssmisbufr ssmis f18 ssmis_f18 0.0 2 0 + ssmisbufr ssmis f19 ssmis_f19 0.0 2 0 + gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 1 0 + gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 1 0 + gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 1 0 + gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 1 0 + gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 1 0 + gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 1 0 + gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 1 0 + gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 1 0 + gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 1 0 + gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 1 0 + gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 1 0 + gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 1 0 + gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 2 0 + gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 2 0 + gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 2 0 + gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 2 0 + iasibufr iasi metop-a iasi_metop-a 0.0 2 0 + gomebufr gome metop-a gome_metop-a 0.0 2 0 + atmsbufr atms npp atms_npp 0.0 2 0 + atmsbufr atms n20 atms_n20 0.0 2 0 + crisbufr cris npp cris_npp 0.0 2 0 + crisfsbufr cris-fsr npp cris-fsr_npp 0.0 2 0 + crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 2 0 + abibufr abi g16 abi_g16 0.0 2 0 + mlsbufr mls30 aura mls30_aura 0.0 0 0 + oscatbufr uv null uv 0.0 0 0 + prepbufr mta_cld null mta_cld 1.0 0 0 + prepbufr gos_ctp null gos_ctp 1.0 0 0 + refInGSI rad_ref null rad_ref 1.0 0 0 + lghtInGSI lghtn null lghtn 1.0 0 0 + larcInGSI larccld null larccld 1.0 0 0 :: - &SUPEROB_RADAR - $SUPERRAD + &SUPEROB_RADAR + del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., l2superob_only=.false., / &LAG_DATA - $LAGDATA / &HYBRID_ENSEMBLE - l_hyb_ens=.true.,n_ens=$ENS_NUM_ANAL,beta_s0=0.25,readin_beta=.false.,s_ens_h=800,s_ens_v=-0.7,generate_ens=.false.,uv_hyb_ens=.true.,jcap_ens=62, - nlat_ens=96,nlon_ens=192,ANISO_A_EN=.false.,jcap_ens_test=62,oz_univ_static=.true.,readin_localization=.true., - write_ens_sprd=.false., - $HYBRID_ENSEMBLE + l_hyb_ens=${ifhyb}, + uv_hyb_ens=.true., + q_hyb_ens=.false., + aniso_a_en=.false.,generate_ens=.false., + n_ens=${nummem}, + beta_s0=0.15,s_ens_h=110,s_ens_v=3, + regional_ensemble_option=1, + pseudo_hybens = .false., + grid_ratio_ens = 3, + l_ens_in_diff_time=.true., + ensemble_path='', + i_en_perts_io=1, + jcap_ens=574, + fv3sar_bg_opt=0, + readin_localization=.true., + ens_fast_read=.false., / &RAPIDREFRESH_CLDSURF - dfi_radar_latent_heat_time_period=30.0, - / - &CHEM - - / - &SINGLEOB_TEST - maginnov=0.1,magoberr=0.1,oneob_type='t', - oblat=45.,oblon=180.,obpres=1000.,obdattim=${global_hybrid_T126_adate}, - obhourset=0., - $SINGLEOB - / - &NST - / -" -;; - - global_4denvar ) - -# Define namelist for global hybrid run - -export gsi_namelist=" - - &SETUP - miter=2,niter(1)=5,niter(2)=10, - niter_no_qc(1)=2,niter_no_qc(2)=0, - write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - qoption=2, - gencode=0,factqmin=0.5,factqmax=0.0002,deltim=$DELTIM, - iguess=-1, - oneobtest=.false.,retrieval=.false.,l_foto=.false., - use_pbl=.false.,use_compress=.true.,nsig_ext=45,gpstop=50., - commgpstop=45.,commgpserrinf=1.0, - use_gfs_nemsio=.false.,lrun_subdirs=.true., - use_readin_anl_sfcmask=.true., - crtm_coeffs_path='./crtm_coeffs/', - newpc4pred=.true.,adp_anglebc=.true.,angord=4,passive_bc=.true.,use_edges=.false., - diag_precon=.true.,step_start=1.e-3,emiss_bc=.true.,thin4d=.true.,cwoption=3, - verbose=.false.,imp_physics=11,lupp=.true., - binary_diag=.false.,netcdf_diag=.true., - lobsdiag_forenkf=.false., - nhr_anal=3,6,9,nhr_obsbin=1, - l4densvar=.true.,ens_nstarthr=3,nhr_assimilation=6,lwrite4danl=.true., - optconv=0.05,cao_check=.true.,ta2tb=.false., - tzr_qc=1,sfcnst_comb=.true., - write_fv3_incr=.true.,incvars_to_zero= 'liq_wat_inc','icmr_inc','rwmr_inc','snmr_inc','grle_inc', - incvars_zero_strat='sphum_inc','liq_wat_inc','icmr_inc','rwmr_inc','snmr_inc','grle_inc',incvars_efold=5, use_gfs_ncio=.true., - $SETUP - / - &GRIDOPTS - JCAP=$JCAP,JCAP_B=$JCAP_B,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS, - regional=.false., - $GRIDOPTS - / - &BKGERR - vs=0.7, - hzscl=1.7,0.8,0.5, - hswgt=0.45,0.3,0.25, - bw=0.0,norsp=4, - bkgv_flowdep=.true.,bkgv_rewgtfct=1.5, - bkgv_write=.false., - cwcoveqqcov=.false., - $BKGVERR - / - &ANBKGERR - anisotropic=.false., - $ANBKGERR - / - &JCOPTS - ljcdfi=.false.,alphajc=0.0,ljcpdry=.true.,bamp_jcpdry=5.0e7, - ljc4tlevs=.true., - $JCOPTS - / - &STRONGOPTS - tlnmc_option=3,nstrong=1,nvmodes_keep=8,period_max=6.,period_width=1.5, - - baldiag_full=.false.,baldiag_inc=.false., - $STRONGOPTS - / - &OBSQC - dfact=0.75,dfact1=3.0,noiqc=.true.,oberrflg=.false.,c_varqc=0.04, - use_poq7=.true.,qc_noirjaco3_pole=.true.,vqc=.false.,nvqc=.true.,hub_norm=.true., - aircraft_t_bc=.true.,biaspredt=1.0e5,upd_aircraft=.true.,cleanup_tail=.true., - tcp_width=70.0,tcp_ermax=7.35, - $OBSQC - / - &OBS_INPUT - dmesh(1)=1450.0,dmesh(2)=1500.0,dmesh(3)=1000.0,dmesh(4)=500.0,time_window_max=3.0, - $OBSINPUT - / -OBS_INPUT:: -! dfile dtype dplat dsis dval dthin dsfcalc - prepbufr ps null ps 0.0 0 0 - prepbufr t null t 0.0 0 0 - prepbufr_profl t null t 0.0 0 0 - hdobbufr t null t 0.0 0 0 - prepbufr q null q 0.0 0 0 - prepbufr_profl q null q 0.0 0 0 - hdobbufr q null q 0.0 0 0 - prepbufr pw null pw 0.0 0 0 - prepbufr uv null uv 0.0 0 0 - prepbufr_profl uv null uv 0.0 0 0 - satwndbufr uv null uv 0.0 0 0 - hdobbufr uv null uv 0.0 0 0 - prepbufr spd null spd 0.0 0 0 - hdobbufr spd null spd 0.0 0 0 - prepbufr dw null dw 0.0 0 0 - radarbufr rw null rw 0.0 0 0 - nsstbufr sst nsst sst 0.0 0 0 - gpsrobufr gps_bnd null gps 0.0 0 0 - sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 - sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 - sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1 - gimgrbufr goes_img g11 imgr_g11 0.0 1 0 - gimgrbufr goes_img g12 imgr_g12 0.0 1 0 - airsbufr airs aqua airs_aqua 0.0 1 1 - amsuabufr amsua n15 amsua_n15 0.0 1 1 - amsuabufr amsua n18 amsua_n18 0.0 1 1 - amsuabufr amsua metop-a amsua_metop-a 0.0 1 1 - airsbufr amsua aqua amsua_aqua 0.0 1 1 - amsubbufr amsub n17 amsub_n17 0.0 1 1 - mhsbufr mhs n18 mhs_n18 0.0 1 1 - mhsbufr mhs metop-a mhs_metop-a 0.0 1 1 - ssmitbufr ssmi f15 ssmi_f15 0.0 1 0 - amsrebufr amsre_low aqua amsre_aqua 0.0 1 0 - amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0 - amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0 - ssmisbufr ssmis f16 ssmis_f16 0.0 1 0 - ssmisbufr ssmis f17 ssmis_f17 0.0 1 0 - ssmisbufr ssmis f18 ssmis_f18 0.0 1 0 - gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 1 0 - gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 1 0 - gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 1 0 - gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 1 0 - gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 1 0 - gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 1 0 - gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 1 0 - gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 1 0 - gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 1 0 - gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 1 0 - gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 1 0 - gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 1 0 - iasibufr iasi metop-a iasi_metop-a 0.0 1 1 - gomebufr gome metop-a gome_metop-a 0.0 2 0 - omibufr omi aura omi_aura 0.0 2 0 - sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1 - amsuabufr amsua n19 amsua_n19 0.0 1 1 - mhsbufr mhs n19 mhs_n19 0.0 1 1 - tcvitl tcp null tcp 0.0 0 0 - seviribufr seviri m08 seviri_m08 0.0 1 0 - seviribufr seviri m09 seviri_m09 0.0 1 0 - seviribufr seviri m10 seviri_m10 0.0 1 0 - seviribufr seviri m11 seviri_m11 0.0 1 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 1 - amsuabufr amsua metop-b amsua_metop-b 0.0 1 1 - mhsbufr mhs metop-b mhs_metop-b 0.0 1 1 - iasibufr iasi metop-b iasi_metop-b 0.0 1 1 - gomebufr gome metop-b gome_metop-b 0.0 2 0 - atmsbufr atms npp atms_npp 0.0 1 1 - atmsbufr atms n20 atms_n20 0.0 1 1 - crisbufr cris npp cris_npp 0.0 1 0 - crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 - crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0 - gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 1 0 - gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 1 0 - gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 1 0 - gsnd1bufr sndrd4 g14 sndrD4_g14 0.0 1 0 - gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 1 0 - gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0 - gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0 - gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0 - oscatbufr uv null uv 0.0 0 0 - mlsbufr mls30 aura mls30_aura 0.0 0 0 - avhambufr avhrr metop-a avhrr3_metop-a 0.0 4 0 - avhpmbufr avhrr n18 avhrr3_n18 0.0 4 0 - avhambufr avhrr metop-b avhrr3_metop-b 0.0 4 0 - avhambufr avhrr metop-c avhrr3_metop-c 0.0 4 0 - avhpmbufr avhrr n19 avhrr3_n19 0.0 4 0 - amsr2bufr amsr2 gcom-w1 amsr2_gcom-w1 0.0 3 0 - gmibufr gmi gpm gmi_gpm 0.0 1 0 - saphirbufr saphir meghat saphir_meghat 0.0 3 0 - ahibufr ahi himawari8 ahi_himawari8 0.0 1 0 - abibufr abi g16 abi_g16 0.0 1 0 - abibufr abi g17 abi_g17 0.0 1 0 - rapidscatbufr uv null uv 0.0 0 0 - ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 - ompslpbufr ompslp npp ompslp_npp 0.0 0 0 - ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 - ompsnpbufr ompsnp n20 ompsnp_n20 0.0 0 0 - ompstcbufr ompstc8 n20 ompstc8_n20 0.0 2 0 - amsuabufr amsua metop-c amsua_metop-c 0.0 1 1 - mhsbufr mhs metop-c mhs_metop-c 0.0 1 1 - iasibufr iasi metop-c iasi_metop-c 0.0 1 1 - sstviirs viirs-m npp viirs-m_npp 0.0 4 0 - sstviirs viirs-m j1 viirs-m_j1 0.0 4 0 - abibufr abi g18 abi_g18 0.0 1 0 - ahibufr ahi himawari9 ahi_himawari9 0.0 1 0 - atmsbufr atms n21 atms_n21 0.0 1 1 - crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 1 0 - sstviirs viirs-m j2 viirs-m_j2 0.0 4 0 - ompsnpbufr ompsnp n21 ompsnp_n21 0.0 0 0 - ompstcbufr ompstc8 n21 ompstc8_n21 0.0 2 0 - gomebufr gome metop-c gome_metop-c 0.0 2 0 -:: - &SUPEROB_RADAR - $SUPERRAD - / - &LAG_DATA - - / - &HYBRID_ENSEMBLE - l_hyb_ens=.true.,n_ens=$NMEM_ENKF,beta_s0=0.125,readin_beta=.false.,s_ens_h=800,s_ens_v=-0.8, - generate_ens=.false.,uv_hyb_ens=.true.,jcap_ens=48,nlat_ens=98,nlon_ens=192, - ANISO_A_EN=.false.,jcap_ens_test=48,oz_univ_static=.false.,readin_localization=.true., - ensemble_path='./ensemble_data/',ens_fast_read=.true.,write_ens_sprd=.false., - $HYBRID_ENSEMBLE - / - &RAPIDREFRESH_CLDSURF - dfi_radar_latent_heat_time_period=30.0, - - / - &CHEM - - / - &NST - nst_gsi=3,nstinfo=4,zsea1=0,zsea2=0,fac_dtl=1,fac_tsl=1, - / - &SINGLEOB_TEST - maginnov=0.1,magoberr=0.1,oneob_type='t', - oblat=5.,oblon=180.,obpres=850.,obdattim=2022110900, - obhourset=0., - / -" -;; - - global_fv3_4denvar_C192 ) - -# Define namelist for global hybrid run - -export gsi_namelist=" - - &SETUP - miter=2,niter(1)=5,niter(2)=5, - niter_no_qc(1)=2,niter_no_qc(2)=0, - write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - qoption=2, - gencode=82,factqmin=0.5,factqmax=0.0002,deltim=400 - iguess=-1, - oneobtest=.false.,retrieval=.false.,l_foto=.false., - use_pbl=.false.,use_compress=.true.,nsig_ext=56,gpstop=55., - use_gfs_nemsio=.false.,lrun_subdirs=.true.,use_readin_anl_sfcmask=.true., - crtm_coeffs_path='./crtm_coeffs/', - newpc4pred=.true.,adp_anglebc=.true.,angord=4,passive_bc=.true.,use_edges=.false., - diag_precon=.true.,step_start=1.e-3,emiss_bc=.true.,thin4d=.true.,cwoption=3, - verbose=.false.,imp_physics=11,lupp=.true., - binary_diag=.false.,netcdf_diag=.true., - lobsdiag_forenkf=.false., - nhr_anal=3,6,9, - l4densvar=.true.,ens_nstarthr=3,nhr_obsbin=1,nhr_assimilation=6,lwrite4danl=.true., - tzr_qc=1,sfcnst_comb=.true., - write_fv3_incr=.true.,incvars_to_zero= 'liq_wat_inc','icmr_inc',incvars_zero_strat='sphum_inc','liq_wat_inc','icmr_inc', - incvars_efold=5, - use_gfs_ncio=.true., - $SETUP - / - &GRIDOPTS - JCAP_B=$JCAP_B,JCAP=$JCAP,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS, - regional=.false., - $GRIDOPTS - / - &BKGERR - vs=0.7, - hzscl=1.7,0.8,0.5, - hswgt=0.45,0.3,0.25, - bw=0.0,norsp=4, - bkgv_flowdep=.true.,bkgv_rewgtfct=1.5, - bkgv_write=.false., - cwcoveqqcov=.false., - $BKGVERR - / - &ANBKGERR - anisotropic=.false., - $ANBKGERR - / - &JCOPTS - ljcdfi=.false.,alphajc=0.0,ljcpdry=.true.,bamp_jcpdry=5.0e7, - ljc4tlevs=.true., - $JCOPTS - / - &STRONGOPTS - tlnmc_option=3,nstrong=1,nvmodes_keep=8,period_max=6.,period_width=1.5, - baldiag_full=.false.,baldiag_inc=.false., - $STRONGOPTS - / - &OBSQC - dfact=0.75,dfact1=3.0,noiqc=.true.,oberrflg=.false.,c_varqc=0.04, - use_poq7=.true.,qc_noirjaco3_pole=.true.,vqc=.false., - aircraft_t_bc=.true.,biaspredt=1.0e5,upd_aircraft=.true.,cleanup_tail=.true. - nvqc=.true., - $OBSQC - / - &OBS_INPUT - dmesh(1)=1450.0,dmesh(2)=1500.0,dmesh(3)=1000.0,time_window_max=3.0, - $OBSINPUT - / -OBS_INPUT:: -! dfile dtype dplat dsis dval dthin dsfcalc - prepbufr ps null ps 0.0 0 0 - prepbufr t null t 0.0 0 0 - prepbufr_profl t null t 0.0 0 0 - prepbufr q null q 0.0 0 0 - prepbufr_profl q null q 0.0 0 0 - prepbufr pw null pw 0.0 0 0 - prepbufr uv null uv 0.0 0 0 - prepbufr_profl uv null uv 0.0 0 0 - satwndbufr uv null uv 0.0 0 0 - prepbufr spd null spd 0.0 0 0 - prepbufr dw null dw 0.0 0 0 - radarbufr rw null rw 0.0 0 0 - nsstbufr sst nsst sst 0.0 0 0 - gpsrobufr gps_bnd null gps 0.0 0 0 - ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0 - tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0 - sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 - sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 - sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1 - gimgrbufr goes_img g11 imgr_g11 0.0 1 0 - gimgrbufr goes_img g12 imgr_g12 0.0 1 0 - airsbufr airs aqua airs_aqua 0.0 1 1 - amsuabufr amsua n15 amsua_n15 0.0 1 1 - amsuabufr amsua n18 amsua_n18 0.0 1 1 - amsuabufr amsua metop-a amsua_metop-a 0.0 1 1 - airsbufr amsua aqua amsua_aqua 0.0 1 1 - amsubbufr amsub n17 amsub_n17 0.0 1 1 - mhsbufr mhs n18 mhs_n18 0.0 1 1 - mhsbufr mhs metop-a mhs_metop-a 0.0 1 1 - ssmitbufr ssmi f15 ssmi_f15 0.0 1 0 - amsrebufr amsre_low aqua amsre_aqua 0.0 1 0 - amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0 - amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0 - ssmisbufr ssmis f16 ssmis_f16 0.0 1 0 - ssmisbufr ssmis f17 ssmis_f17 0.0 1 0 - ssmisbufr ssmis f18 ssmis_f18 0.0 1 0 - gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 1 0 - gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 1 0 - gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 1 0 - gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 1 0 - gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 1 0 - gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 1 0 - gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 1 0 - gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 1 0 - gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 1 0 - gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 1 0 - gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 1 0 - gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 1 0 - iasibufr iasi metop-a iasi_metop-a 0.0 1 1 - gomebufr gome metop-a gome_metop-a 0.0 2 0 - omibufr omi aura omi_aura 0.0 2 0 - sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1 - amsuabufr amsua n19 amsua_n19 0.0 1 1 - mhsbufr mhs n19 mhs_n19 0.0 1 1 - tcvitl tcp null tcp 0.0 0 0 - seviribufr seviri m08 seviri_m08 0.0 1 0 - seviribufr seviri m09 seviri_m09 0.0 1 0 - seviribufr seviri m10 seviri_m10 0.0 1 0 - seviribufr seviri m11 seviri_m11 0.0 1 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 1 - amsuabufr amsua metop-b amsua_metop-b 0.0 1 1 - mhsbufr mhs metop-b mhs_metop-b 0.0 1 1 - iasibufr iasi metop-b iasi_metop-b 0.0 1 1 - gomebufr gome metop-b gome_metop-b 0.0 2 0 - atmsbufr atms npp atms_npp 0.0 1 1 - atmsbufr atms n20 atms_n20 0.0 1 1 - crisbufr cris npp cris_npp 0.0 1 0 - crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 - crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0 - gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 1 0 - gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 1 0 - gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 1 0 - gsnd1bufr sndrd4 g14 sndrD4_g14 0.0 1 0 - gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 1 0 - gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0 - gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0 - gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0 - oscatbufr uv null uv 0.0 0 0 - mlsbufr mls30 aura mls30_aura 0.0 0 0 - avhambufr avhrr metop-a avhrr3_metop-a 0.0 1 0 - avhpmbufr avhrr n18 avhrr3_n18 0.0 1 0 - avhambufr avhrr metop-b avhrr3_metop-b 0.0 1 0 - avhpmbufr avhrr n19 avhrr3_n19 0.0 1 0 - amsr2bufr amsr2 gcom-w1 amsr2_gcom-w1 0.0 3 0 - gmibufr gmi gpm gmi_gpm 0.0 3 0 - saphirbufr saphir meghat saphir_meghat 0.0 3 0 - ahibufr ahi himawari8 ahi_himawari8 0.0 1 0 - abibufr abi g16 abi_g16 0.0 1 0 - abibufr abi g17 abi_g17 0.0 1 0 - rapidscatbufr uv null uv 0.0 0 0 - ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 - ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 - amsuabufr amsua metop-c amsua_metop-c 0.0 1 1 - mhsbufr mhs metop-c mhs_metop-c 0.0 1 1 - iasibufr iasi metop-c iasi_metop-c 0.0 1 1 - ompslpbufr ompslp npp ompslp_npp 0.0 1 1 - abibufr abi g18 abi_g18 0.0 1 0 - ahibufr ahi himawari9 ahi_himawari9 0.0 1 0 - atmsbufr atms n21 atms_n21 0.0 1 1 - crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 1 0 - sstviirs viirs-m j2 viirs-m_j2 0.0 4 0 - ompsnpbufr ompsnp n21 ompsnp_n21 0.0 0 0 - ompstcbufr ompstc8 n21 ompstc8_n21 0.0 2 0 - gomebufr gome metop-c gome_metop-c 0.0 2 0 -:: - &SUPEROB_RADAR - $SUPERRAD - / - &LAG_DATA - $LAGDATA - / - &HYBRID_ENSEMBLE - l_hyb_ens=.true.,n_ens=20,beta_s0=0.125,readin_beta=.false.,s_ens_h=800,s_ens_v=-0.8,generate_ens=.false.,uv_hyb_ens=.true.,jcap_ens=190, - nlat_ens=194,nlon_ens=384,aniso_a_en=.false.,jcap_ens_test=62,oz_univ_static=.false.,readin_localization=.true.,ensemble_path='./ensemble_data/', - ens_fast_read=.true.,write_ens_sprd=.false., - $HYBRID_ENSEMBLE - / - &RAPIDREFRESH_CLDSURF - dfi_radar_latent_heat_time_period=30.0, - / - &CHEM - - / - &SINGLEOB_TEST - maginnov=0.1,magoberr=0.1,oneob_type='t', - oblat=45.,oblon=180.,obpres=1000.,obdattim=${global_4denvar_T670_adate}, - obhourset=0., - $SINGLEOB - / - &NST - nst_gsi=3,nstinfo=4,fac_dtl=1,fac_tsl=1,zsea1=0,zsea2=0, - $NST - / -" -;; - - RTMA) - -# Define namelist for RTMA runs - -export gsi_namelist=" - - &SETUP - miter=2,niter(1)=10,niter(2)=10, - write_diag(1)=.true.,write_diag(2)=.true.,write_diag(3)=.true., - gencode=78,qoption=1,tsensible=.true. - factqmin=1.0,factqmax=1.0,factv=0.0,factcldch=0.0,factw10m=1.0,deltim=$DELTIM, - iguess=-1, - oneobtest=.false.,retrieval=.false., - diag_rad=.false.,diag_pcp=.false.,diag_ozone=.false.,diag_aero=.false., - nhr_assimilation=6,min_offset=180,use_compress=.false.,lrun_subdirs=.true., - use_similarity_2dvar=.true., - neutral_stability_windfact_2dvar=.false., - use_prepb_satwnd=.false., - $SETUP - / - &GRIDOPTS - JCAP=$JCAP,JCAP_B=$JCAP_B,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS, - wrf_nmm_regional=.false.,wrf_mass_regional=.false.,twodvar_regional=.true., - diagnostic_reg=.false., - filled_grid=.false.,half_grid=.true.,netcdf=.false., - / - &BKGERR - hzscl=1.414,1.000,0.707, - vs=0.5,bw=0.0, - / - &ANBKGERR - anisotropic=.true.,an_vs=0.5,ngauss=1, - an_flen_u=-5.,an_flen_t=3.,an_flen_z=-200., - ifilt_ord=2,npass=3,normal=-200,grid_ratio=1.,nord_f2a=4, - rtma_subdomain_option=.true.,triad4=.true.,nsmooth=0,nsmooth_shapiro=0,lreadnorm=.true., - / - &JCOPTS - / - &STRONGOPTS - nstrong=1,nvmodes_keep=20,period_max=3., - baldiag_full=.true.,baldiag_inc=.true., - / - &OBSQC - dfact=0.75,dfact1=3.0,noiqc=.true.,c_varqc=0.02,vadfile='prepbufr',hilbert_curve=.true., - buddycheck_t=.false.,buddydiag_save=.false.,oberrflg=.true.,njqc=.true.,vqc=.false., - $OBSQC - / - &OBS_INPUT - dmesh(1)=60.0,dmesh(2)=60.0,dmesh(3)=60.0,dmesh(4)=60.0,time_window_max=3.0, - / -OBS_INPUT:: -! dfile dtype dplat dsis dval dthin dsfcalc - prepbufr ps null ps 1.0 0 0 - prepbufr t null t 1.0 0 0 - prepbufr q null q 1.0 0 0 - prepbufr uv null uv 1.0 0 0 - satwndbufr uv null uv 1.0 0 0 - prepbufr spd null spd 1.0 0 0 - prepbufr wspd10m null wspd10m 1.0 0 0 - satwnd wspd10m null wspd10m 1.0 0 0 - prepbufr uwnd10m null uwnd10m 1.0 0 0 - satwnd uwnd10m null uwnd10m 1.0 0 0 - prepbufr vwnd10m null vwnd10m 1.0 0 0 - satwnd vwnd10m null vwnd10m 1.0 0 0 - prepbufr gust null gust 1.0 0 0 - prepbufr vis null vis 1.0 0 0 - prepbufr td2m null td2m 1.0 0 0 - mxtmdat mxtm null mxtm 1.0 0 0 - mitmdat mitm null mitm 1.0 0 0 - prepbufr mxtm null mxtm 1.0 0 0 - prepbufr mitm null mitm 1.0 0 0 - prepbufr pmsl null pmsl 1.0 0 0 - prepbufr howv null howv 1.0 0 0 - satmar howv null howv 1.0 0 0 - prepbufr tcamt null tcamt 1.0 0 0 - goessky tcamt null tcamt 1.0 0 0 - prepbufr cldch null cldch 1.0 0 0 -:: - &SUPEROB_RADAR - / - &LAG_DATA - / - &HYBRID_ENSEMBLE - / - &RAPIDREFRESH_CLDSURF - dfi_radar_latent_heat_time_period=30.0, - l_closeobs=.true. + dfi_radar_latent_heat_time_period=20.0, + metar_impact_radius=10.0, + metar_impact_radius_lowCloud=4.0, + l_gsd_terrain_match_surfTobs=.true., + l_sfcobserror_ramp_t=.true., + l_sfcobserror_ramp_q=.true., + l_PBL_pseudo_SurfobsT=.false., + l_PBL_pseudo_SurfobsQ=.false., + l_PBL_pseudo_SurfobsUV=.false., + pblH_ration=0.4, + pps_press_incr=40.0, + l_gsd_limit_ocean_q=.true., + l_pw_hgt_adjust=.true., + l_limit_pw_innov=.true., + max_innov_pct=0.1, + l_cleanSnow_WarmTs=.true., + r_cleanSnow_WarmTs_threshold=5.0, + l_conserve_thetaV=.true., + i_conserve_thetaV_iternum=3, + l_gsd_soilTQ_nudge=.false., + l_cld_bld=.true., + l_numconc=.true., + l_closeobs=.true., + cld_bld_hgt=1200.0, + build_cloud_frac_p=0.50, + clear_cloud_frac_p=0.10, + iclean_hydro_withRef_allcol=1, + i_use_2mQ4B=2, + i_use_2mT4B=1, + i_gsdcldanal_type=0, + i_gsdsfc_uselist=1, + i_lightpcp=1, + i_sfct_gross=1, + i_coastline=3, + i_gsdqc=2, / &CHEM / - &SINGLEOB_TEST - maginnov=0.1,magoberr=0.1,oneob_type='t', - oblat=36.,oblon=260.,obpres=1000.,obdattim=${adate}, - obhourset=0., - / &NST / -" -;; - - arw_binary) - -# Define namelist for arw binary run - -export gsi_namelist=" - - &SETUP - miter=2,niter(1)=50,niter(2)=50, - write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - gencode=78,qoption=2, - factqmin=0.0,factqmax=0.0,deltim=$DELTIM, - iguess=-1, - oneobtest=.false.,retrieval=.false., - nhr_assimilation=3,l_foto=.false., - use_pbl=.false.,use_compress=.false.,nsig_ext=13,gpstop=30., - lrun_subdirs=.true., - $SETUP - / - &GRIDOPTS - JCAP=$JCAP,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS, - wrf_nmm_regional=.false.,wrf_mass_regional=.true.,diagnostic_reg=.false., - filled_grid=.false.,half_grid=.true.,netcdf=$NETCDF, - / - &BKGERR - hzscl=0.373,0.746,1.50, - vs=1.0,bw=0.,fstat=.true., - / - &ANBKGERR - anisotropic=.false.,an_vs=1.0,ngauss=1, - an_flen_u=-5.,an_flen_t=3.,an_flen_z=-200., - ifilt_ord=2,npass=3,normal=-200,grid_ratio=4.,nord_f2a=4, - / - &JCOPTS - / - &STRONGOPTS - nstrong=0,nvmodes_keep=20,period_max=3., - baldiag_full=.true.,baldiag_inc=.true., - / - &OBSQC - dfact=0.75,dfact1=3.0,noiqc=.true.,c_varqc=0.02,vadfile='prepbufr',oberrflg=.false.,njqc=.false.,vqc=.true., - / - &OBS_INPUT - dmesh(1)=120.0,dmesh(2)=60.0,dmesh(3)=60.0,dmesh(4)=60.0,dmesh(5)=120,time_window_max=1.5, - / -OBS_INPUT:: -! dfile dtype dplat dsis dval dthin dsfcalc - prepbufr ps null ps 1.0 0 0 - prepbufr t null t 1.0 0 0 - prepbufr q null q 1.0 0 0 - prepbufr uv null uv 1.0 0 0 - satwndbufr uv null uv 1.0 0 0 - prepbufr spd null spd 1.0 0 0 - radarbufr rw null l3rw 1.0 0 0 - l2rwbufr rw null l2rw 1.0 0 0 - prepbufr dw null dw 1.0 0 0 - prepbufr sst null sst 1.0 0 0 - prepbufr pw null pw 1.0 0 0 - gpsrobufr $gps_dtype null gps 1.0 0 0 - ssmirrbufr pcp_ssmi dmsp pcp_ssmi 1.0 -1 0 - tmirrbufr pcp_tmi trmm pcp_tmi 1.0 -1 0 - sbuvbufr sbuv2 n16 sbuv8_n16 1.0 0 0 - sbuvbufr sbuv2 n17 sbuv8_n17 1.0 0 0 - sbuvbufr sbuv2 n18 sbuv8_n18 1.0 0 0 - omi omi aura omi_aura 1.0 6 0 - hirs2bufr hirs2 n14 hirs2_n14 6.0 1 1 - hirs3bufr hirs3 n16 hirs3_n16 0.0 1 1 - hirs3bufr hirs3 n17 hirs3_n17 6.0 1 1 - hirs4bufr hirs4 n18 hirs4_n18 0.0 1 1 - hirs4bufr hirs4 metop-a hirs4_metop-a 6.0 1 1 - gsndrbufr sndr g11 sndr_g11 0.0 1 0 - gsndrbufr sndr g12 sndr_g12 0.0 1 0 - gimgrbufr goes_img g11 imgr_g11 0.0 1 0 - gimgrbufr goes_img g12 imgr_g12 0.0 1 0 - airsbufr airs aqua airs_aqua 20.0 1 1 - msubufr msu n14 msu_n14 2.0 2 1 - amsuabufr amsua n15 amsua_n15 10.0 2 1 - amsuabufr amsua n16 amsua_n16 0.0 2 1 - amsuabufr amsua n17 amsua_n17 0.0 2 1 - amsuabufr amsua n18 amsua_n18 10.0 2 1 - amsuabufr amsua metop-a amsua_metop-a 10.0 2 1 - airsbufr amsua aqua amsua_aqua 5.0 2 1 - amsubbufr amsub n15 amsub_n15 3.0 3 1 - amsubbufr amsub n16 amsub_n16 3.0 3 1 - amsubbufr amsub n17 amsub_n17 3.0 3 1 - mhsbufr mhs n18 mhs_n18 3.0 3 1 - mhsbufr mhs metop-a mhs_metop-a 3.0 3 1 - ssmitbufr ssmi f13 ssmi_f13 0.0 4 0 - ssmitbufr ssmi f15 ssmi_f15 0.0 4 0 - amsrebufr amsre_low aqua amsre_aqua 0.0 4 1 - amsrebufr amsre_mid aqua amsre_aqua 0.0 4 1 - amsrebufr amsre_hig aqua amsre_aqua 0.0 4 1 - ssmisbufr ssmis f16 ssmis_f16 0.0 4 1 - gsnd1bufr sndrd1 g12 sndrD1_g12 1.5 5 0 - gsnd1bufr sndrd2 g12 sndrD2_g12 1.5 5 0 - gsnd1bufr sndrd3 g12 sndrD3_g12 1.5 5 0 - gsnd1bufr sndrd4 g12 sndrD4_g12 1.5 5 0 - gsnd1bufr sndrd1 g11 sndrD1_g11 1.5 5 0 - gsnd1bufr sndrd2 g11 sndrD2_g11 1.5 5 0 - gsnd1bufr sndrd3 g11 sndrD3_g11 1.5 5 0 - gsnd1bufr sndrd4 g11 sndrD4_g11 1.5 5 0 - gsnd1bufr sndrd1 g13 sndrD1_g13 1.5 5 0 - gsnd1bufr sndrd2 g13 sndrD2_g13 1.5 5 0 - gsnd1bufr sndrd3 g13 sndrD3_g13 1.5 5 0 - gsnd1bufr sndrd4 g13 sndrD4_g13 1.5 5 0 - iasibufr iasi metop-a iasi_metop-a 20.0 1 1 - gomebufr gome metop-a gome_metop-a 1.0 6 0 - mlsbufr mls30 aura mls30_aura 1.0 0 0 - oscatbufr uv null uv 1.0 0 0 - ompsnpbufr ompsnp npp ompsnp_npp 1.0 0 0 - ompstcbufr ompstc8 npp ompstc8_npp 1.0 6 0 -:: - &SUPEROB_RADAR - del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., - l2superob_only=.false., - / - &LAG_DATA - / - &HYBRID_ENSEMBLE - l_hyb_ens=${HYBENS_REGIONAL}, - n_ens=${ENSEMBLE_SIZE_REGIONAL}, - uv_hyb_ens=${HYBENS_UV_REGIONAL}, - beta_s0=${BETA_S0_REGIONAL}, - readin_beta=.false., - s_ens_h=${HYBENS_HOR_SCALE_REGIONAL}, - s_ens_v=${HYBENS_VER_SCALE_REGIONAL}, - generate_ens=${GENERATE_ENS_REGIONAL}, - aniso_a_en=${HYBENS_ANISO_REGIONAL}, - nlon_ens=${NLON_ENS_REGIONAL}, - nlat_ens=${NLAT_ENS_REGIONAL}, - jcap_ens=${JCAP_ENS_REGIONAL}, - jcap_ens_test=${JCAP_ENS_TEST_REGIONAL}, - / - &RAPIDREFRESH_CLDSURF - dfi_radar_latent_heat_time_period=30.0, - / - &CHEM - / &SINGLEOB_TEST - maginnov=0.1,magoberr=0.1,oneob_type='t', - oblat=45.,oblon=270.,obpres=850.,obdattim=${adate}, + maginnov=1.0,magoberr=0.8,oneob_type='t', + oblat=38.,oblon=279.,obpres=500.,obdattim=2020040500, obhourset=0., / - &NST - / " ;; - - arw_netcdf) - -# Define namelist for arw netcdf run - + hafs_envar) +# Define namelist for hafs 3denvar run with global ensembles export gsi_namelist=" &SETUP - miter=2,niter(1)=50,niter(2)=50, + miter=2,niter(1)=5,niter(2)=5, + niter_no_qc(1)=2,niter_no_qc(2)=0, write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - gencode=78,qoption=2, - factqmin=0.0,factqmax=0.0,deltim=$DELTIM, + qoption=2, + gencode=78,deltim=1200, + factqmin=0.0,factqmax=0.0, iguess=-1, - oneobtest=.false.,retrieval=.false., - nhr_assimilation=3,l_foto=.false., - use_pbl=.false.,use_compress=.false.,nsig_ext=13,gpstop=30., + aircraft_recon=.true., + oneobtest=.false.,retrieval=.false.,l_foto=.false., + nhr_assimilation=6, + use_pbl=.true.,use_compress=.false.,nsig_ext=14,gpstop=50., + use_gfs_nemsio=.false.,use_gfs_ncio=.true., + print_diag_pcg=.true.,l2rwthin=.false.,hurricane_radar=.true., + use_gfs_ozone=.false.,l4densvar=${l4densvar},nhr_obsbin=${nhr_obsbin}, lrun_subdirs=.true., - $SETUP + netcdf_diag=.true.,binary_diag=.false., + newpc4pred=.true., adp_anglebc=.true., angord=4, + passive_bc=.false., use_edges=.false., emiss_bc=.true., + diag_precon=.true., step_start=1.e-3, upd_pred(1)=0, + upd_pred(2)=0,upd_pred(3)=0,upd_pred(4)=0, + upd_pred(5)=0,upd_pred(6)=0,upd_pred(7)=0, + upd_pred(8)=0,upd_pred(9)=0,upd_pred(10)=0, + upd_pred(11)=0,upd_pred(12)=0, + lread_obs_save=.false., + lread_obs_skip=.false., + ens_nstarthr=6, + lwrite_predterms=.false.,lwrite_peakwt=.false.,reduce_diag=.false., / &GRIDOPTS - JCAP=$JCAP,JCAP_B=$JCAP_B,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS, - wrf_nmm_regional=.false.,wrf_mass_regional=.true.,diagnostic_reg=.false., - filled_grid=.false.,half_grid=.true.,netcdf=$NETCDF, + fv3_regional=.true.,grid_ratio_fv3_regional=1,nvege_type=20, / &BKGERR - hzscl=0.373,0.746,1.50, - vs=1.0,bw=0.,fstat=.true., - / + vs=1.0, + hzscl=0.2,0.4,0.8, + bw=0., + fstat=.false., +/ &ANBKGERR anisotropic=.false.,an_vs=1.0,ngauss=1, an_flen_u=-5.,an_flen_t=3.,an_flen_z=-200., @@ -1276,309 +574,209 @@ export gsi_namelist=" &JCOPTS / &STRONGOPTS - nstrong=0,nvmodes_keep=20,period_max=3., - baldiag_full=.true.,baldiag_inc=.true., - / - &OBSQC - dfact=0.75,dfact1=3.0,noiqc=.true.,c_varqc=0.02,vadfile='prepbufr',oberrflg=.false.,njqc=.false.,vqc=.true., - / - &OBS_INPUT - dmesh(1)=120.0,dmesh(2)=60.0,dmesh(3)=60.0,dmesh(4)=60.0,dmesh(5)=120,time_window_max=1.5, - / -OBS_INPUT:: -! dfile dtype dplat dsis dval dthin dsfcalc - prepbufr ps null ps 1.0 0 0 - prepbufr t null t 1.0 0 0 - prepbufr q null q 1.0 0 0 - prepbufr uv null uv 1.0 0 0 - satwndbufr uv null uv 1.0 0 0 - prepbufr spd null spd 1.0 0 0 - radarbufr rw null l3rw 1.0 0 0 - l2rwbufr rw null l2rw 1.0 0 0 - prepbufr dw null dw 1.0 0 0 - prepbufr sst null sst 1.0 0 0 - prepbufr pw null pw 1.0 0 0 - gpsrobufr $gps_dtype null gps 1.0 0 0 - ssmirrbufr pcp_ssmi dmsp pcp_ssmi 1.0 -1 0 - tmirrbufr pcp_tmi trmm pcp_tmi 1.0 -1 0 - sbuvbufr sbuv2 n16 sbuv8_n16 1.0 0 0 - sbuvbufr sbuv2 n17 sbuv8_n17 1.0 0 0 - sbuvbufr sbuv2 n18 sbuv8_n18 1.0 0 0 - omi omi aura omi_aura 1.0 6 0 - hirs2bufr hirs2 n14 hirs2_n14 6.0 1 1 - hirs3bufr hirs3 n16 hirs3_n16 0.0 1 1 - hirs3bufr hirs3 n17 hirs3_n17 6.0 1 1 - hirs4bufr hirs4 n18 hirs4_n18 0.0 1 1 - hirs4bufr hirs4 metop-a hirs4_metop-a 6.0 1 1 - gsndrbufr sndr g11 sndr_g11 0.0 1 0 - gsndrbufr sndr g12 sndr_g12 0.0 1 0 - gimgrbufr goes_img g11 imgr_g11 0.0 1 0 - gimgrbufr goes_img g12 imgr_g12 0.0 1 0 - airsbufr airs aqua airs_aqua 20.0 1 1 - msubufr msu n14 msu_n14 2.0 2 1 - amsuabufr amsua n15 amsua_n15 10.0 2 1 - amsuabufr amsua n16 amsua_n16 0.0 2 1 - amsuabufr amsua n17 amsua_n17 0.0 2 1 - amsuabufr amsua n18 amsua_n18 10.0 2 1 - amsuabufr amsua metop-a amsua_metop-a 10.0 2 1 - airsbufr amsua aqua amsua_aqua 5.0 2 1 - amsubbufr amsub n15 amsub_n15 3.0 3 1 - amsubbufr amsub n16 amsub_n16 3.0 3 1 - amsubbufr amsub n17 amsub_n17 3.0 3 1 - mhsbufr mhs n18 mhs_n18 3.0 3 1 - mhsbufr mhs metop-a mhs_metop-a 3.0 3 1 - ssmitbufr ssmi f13 ssmi_f13 0.0 4 0 - ssmitbufr ssmi f15 ssmi_f15 0.0 4 0 - amsrebufr amsre_low aqua amsre_aqua 0.0 4 1 - amsrebufr amsre_mid aqua amsre_aqua 0.0 4 1 - amsrebufr amsre_hig aqua amsre_aqua 0.0 4 1 - ssmisbufr ssmis f16 ssmis_f16 0.0 4 1 - gsnd1bufr sndrd1 g12 sndrD1_g12 1.5 5 0 - gsnd1bufr sndrd2 g12 sndrD2_g12 1.5 5 0 - gsnd1bufr sndrd3 g12 sndrD3_g12 1.5 5 0 - gsnd1bufr sndrd4 g12 sndrD4_g12 1.5 5 0 - gsnd1bufr sndrd1 g11 sndrD1_g11 1.5 5 0 - gsnd1bufr sndrd2 g11 sndrD2_g11 1.5 5 0 - gsnd1bufr sndrd3 g11 sndrD3_g11 1.5 5 0 - gsnd1bufr sndrd4 g11 sndrD4_g11 1.5 5 0 - gsnd1bufr sndrd1 g13 sndrD1_g13 1.5 5 0 - gsnd1bufr sndrd2 g13 sndrD2_g13 1.5 5 0 - gsnd1bufr sndrd3 g13 sndrD3_g13 1.5 5 0 - gsnd1bufr sndrd4 g13 sndrD4_g13 1.5 5 0 - iasibufr iasi metop-a iasi_metop-a 20.0 1 1 - gomebufr gome metop-a gome_metop-a 1.0 6 0 - mlsbufr mls30 aura mls30_aura 1.0 0 0 - oscatbufr uv null uv 1.0 0 0 - ompsnpbufr ompsnp npp ompsnp_npp 1.0 0 0 - ompstcbufr ompstc8 npp ompstc8_npp 1.0 6 0 -:: - &SUPEROB_RADAR - del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., - l2superob_only=.false., - / - &LAG_DATA - / - &HYBRID_ENSEMBLE - l_hyb_ens=${HYBENS_REGIONAL}, - n_ens=${ENSEMBLE_SIZE_REGIONAL}, - uv_hyb_ens=${HYBENS_UV_REGIONAL}, - beta_s0=${BETA_S0_REGIONAL}, - readin_beta=.false., - s_ens_h=${HYBENS_HOR_SCALE_REGIONAL}, - s_ens_v=${HYBENS_VER_SCALE_REGIONAL}, - generate_ens=${GENERATE_ENS_REGIONAL}, - aniso_a_en=${HYBENS_ANISO_REGIONAL}, - nlon_ens=${NLON_ENS_REGIONAL}, - nlat_ens=${NLAT_ENS_REGIONAL}, - jcap_ens=${JCAP_ENS_REGIONAL}, - jcap_ens_test=${JCAP_ENS_TEST_REGIONAL}, - / - &RAPIDREFRESH_CLDSURF - dfi_radar_latent_heat_time_period=30.0, - / - &CHEM - / - &SINGLEOB_TEST - maginnov=0.1,magoberr=0.1,oneob_type='t', - oblat=45.,oblon=270.,obpres=850.,obdattim=${adate}, - obhourset=0., - / - &NST - / -" -;; - - rrfs_3denvar_glbens) - -# Define namelist for rrfs 3d hybrid envar run with global ensembles - -export gsi_namelist=" - - &SETUP - miter=2,niter(1)=25,niter(2)=25, - write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - qoption=2,print_obs_para=.true.,diag_radardbz=.false., - if_model_dbz=.false., static_gsi_nopcp_dbz=0.0, - rmesh_dbz=4.0,rmesh_vr=4.0,zmesh_dbz=1000.0,zmesh_vr=1000.0, - missing_to_nopcp=.false.,radar_no_thinning=.true., - gencode=78,factqmin=0.0,factqmax=0.0, - iguess=-1, - lread_obs_save=.false.,lread_obs_skip=.false., - oneobtest=.false.,retrieval=.false., - nhr_assimilation=3,l_foto=.false., - use_pbl=.false.,use_prepb_satwnd=.false., - newpc4pred=.true.,adp_anglebc=.true.,angord=4, - passive_bc=.true.,use_edges=.false.,emiss_bc=.true., - diag_precon=.true.,step_start=1.e-3, - l4densvar=.false.,nhr_obsbin=3, - use_gfs_nemsio=.false.,use_gfs_ncio=.true.,reset_bad_radbc=.true., - netcdf_diag=.false.,binary_diag=.true., - l_obsprvdiag=.false., - / - &GRIDOPTS - fv3_regional=.true.,grid_ratio_fv3_regional=2.0,nvege_type=20, - fv3_io_layout_y=1, - / - &BKGERR - vs=1.0, - hzscl=0.7,1.4,2.80, - bw=0.,fstat=.true., - usenewgfsberror=.true., -/ - &ANBKGERR - anisotropic=.false., - / - &JCOPTS - / - &STRONGOPTS + tlnmc_option=0,reg_tlnmc_type=1,nstrong=1,nvmodes_keep=8,period_max=6., + period_width=1.5,baldiag_full=.false.,baldiag_inc=.false., / &OBSQC - dfact=0.75,dfact1=3.0,noiqc=.false.,c_varqc=0.02,vadfile='prepbufr', - vadwnd_l2rw_qc=.true., + dfact=0.75,dfact1=3.0,erradar_inflate=1.0,tdrerr_inflate=.true., + noiqc=.true.,c_varqc=0.03333,vadfile='prepbufr',njqc=.false.,vqc=.true.,vadwnd_l2rw_qc=.false., + q_doe_a_136=0.65, + q_doe_b_136=0.0003, + q_doe_a_137=0.75, + q_doe_b_137=0.0003, + t_doe_a_136=0.75, + t_doe_b_136=0.2, + t_doe_a_137=0.7, + t_doe_b_137=0.2, + uv_doe_a_236=0.5, + uv_doe_b_236=0.85, + uv_doe_a_237=0.5, + uv_doe_b_237=0.85, + uv_doe_a_213=0.4, + uv_doe_b_213=1.0, / &OBS_INPUT - dmesh(1)=120.0,dmesh(2)=60.0,dmesh(3)=30,time_window_max=1.5,time_window_rad=1.0,ext_sonde=.true., + dmesh(1)=90.0,dmesh(2)=45.0,dmesh(3)=45.0,dmesh(4)=45.0,dmesh(5)=90,time_window_max=3.0,l_foreaft_thin=.false., / OBS_INPUT:: ! dfile dtype dplat dsis dval dthin dsfcalc - dbzobs.nc dbz null dbz 1.0 0 0 - prepbufr ps null ps 1.0 0 0 - prepbufr t null t 1.0 0 0 - prepbufr q null q 1.0 0 0 - prepbufr pw null pw 1.0 0 0 - satwndbufr uv null uv 1.0 0 0 - prepbufr uv null uv 1.0 0 0 - prepbufr spd null spd 1.0 0 0 - prepbufr dw null dw 1.0 0 0 - l2rwbufr rw null l2rw 1.0 0 0 - prepbufr sst null sst 1.0 0 0 - gpsrobufr gps_ref null gps 1.0 0 0 - ssmirrbufr pcp_ssmi dmsp pcp_ssmi 1.0 -1 0 - tmirrbufr pcp_tmi trmm pcp_tmi 1.0 -1 0 - sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 - sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 - sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 2 0 - hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 2 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 2 0 - gimgrbufr goes_img g11 imgr_g11 0.0 1 0 - gimgrbufr goes_img g12 imgr_g12 0.0 1 0 - airsbufr airs aqua airs_aqua 0.0 2 0 - amsuabufr amsua n15 amsua_n15 0.0 2 0 - amsuabufr amsua n18 amsua_n18 0.0 2 0 - amsuabufr amsua n19 amsua_n19 0.0 2 0 - amsuabufr amsua metop-a amsua_metop-a 0.0 2 0 - amsuabufr amsua metop-b amsua_metop-b 0.0 2 0 - airsbufr amsua aqua amsua_aqua 0.0 2 0 - amsubbufr amsub n17 amsub_n17 0.0 1 0 - mhsbufr mhs n18 mhs_n18 0.0 2 0 - mhsbufr mhs n19 mhs_n19 0.0 2 0 - mhsbufr mhs metop-a mhs_metop-a 0.0 2 0 - mhsbufr mhs metop-b mhs_metop-b 0.0 2 0 - ssmitbufr ssmi f13 ssmi_f13 0.0 2 0 - ssmitbufr ssmi f14 ssmi_f14 0.0 2 0 - ssmitbufr ssmi f15 ssmi_f15 0.0 2 0 - amsrebufr amsre_low aqua amsre_aqua 0.0 2 0 - amsrebufr amsre_mid aqua amsre_aqua 0.0 2 0 - amsrebufr amsre_hig aqua amsre_aqua 0.0 2 0 - ssmisbufr ssmis f16 ssmis_f16 0.0 2 0 - ssmisbufr ssmis f17 ssmis_f17 0.0 2 0 - ssmisbufr ssmis f18 ssmis_f18 0.0 2 0 - ssmisbufr ssmis f19 ssmis_f19 0.0 2 0 - gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 1 0 - gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 1 0 - gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 1 0 - gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 1 0 - gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 1 0 - gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 1 0 - gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 1 0 - gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 1 0 - gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 1 0 - gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 1 0 - gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 1 0 - gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 1 0 - gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 2 0 - gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 2 0 - gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 2 0 - gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 2 0 - iasibufr iasi metop-a iasi_metop-a 0.0 2 0 - gomebufr gome metop-a gome_metop-a 0.0 2 0 - atmsbufr atms npp atms_npp 0.0 2 0 - atmsbufr atms n20 atms_n20 0.0 2 0 - crisbufr cris npp cris_npp 0.0 2 0 - crisfsbufr cris-fsr npp cris-fsr_npp 0.0 2 0 - crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 2 0 - abibufr abi g16 abi_g16 0.0 2 0 - mlsbufr mls30 aura mls30_aura 0.0 0 0 - oscatbufr uv null uv 0.0 0 0 - prepbufr mta_cld null mta_cld 1.0 0 0 - prepbufr gos_ctp null gos_ctp 1.0 0 0 - refInGSI rad_ref null rad_ref 1.0 0 0 - lghtInGSI lghtn null lghtn 1.0 0 0 - larcInGSI larccld null larccld 1.0 0 0 + prepbufr ps null ps 0.0 0 0 + prepbufr t null t 0.0 0 0 + prepbufr_profl t null t 0.0 0 0 + prepbufr q null q 0.0 0 0 + prepbufr_profl q null q 0.0 0 0 + prepbufr pw null pw 0.0 0 0 + prepbufr uv null uv 0.0 0 0 + prepbufr_profl uv null uv 0.0 0 0 + satwndbufr uv null uv 0.0 0 0 + satwhrbufr uv null uv 0.0 0 0 + prepbufr spd null spd 0.0 0 0 + prepbufr dw null dw 0.0 0 0 + radarbufr rw null rw 0.0 0 0 + prepbufr sst null sst 0.0 0 0 + tcvitl tcp null tcp 0.0 0 0 + tldplrbufr rw null rw 0.0 0 0 + l2rwbufr rw null l2rw 0.0 0 0 + hdobbufr uv null uv 0.0 0 0 + hdobbufr t null t 0.0 0 0 + hdobbufr q null q 0.0 0 0 + hdobbufr spd null spd 0.0 0 0 + gpsrobufr gps_bnd null gps 0.0 0 0 + ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0 + tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0 + sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 + sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 + sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 + hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 + hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1 + gimgrbufr goes_img g11 imgr_g11 0.0 1 0 + gimgrbufr goes_img g12 imgr_g12 0.0 1 0 + airsbufr airs aqua airs_aqua 0.0 1 1 + amsuabufr amsua n15 amsua_n15 0.0 2 1 + amsuabufr amsua n18 amsua_n18 0.0 2 1 + amsuabufr amsua metop-a amsua_metop-a 0.0 2 1 + airsbufr amsua aqua amsua_aqua 0.0 2 1 + amsubbufr amsub n17 amsub_n17 0.0 3 1 + mhsbufr mhs n18 mhs_n18 0.0 3 1 + mhsbufr mhs metop-a mhs_metop-a 0.0 3 1 + ssmitbufr ssmi f15 ssmi_f15 0.0 1 0 + amsrebufr amsre_low aqua amsre_aqua 0.0 4 0 + amsrebufr amsre_mid aqua amsre_aqua 0.0 4 0 + amsrebufr amsre_hig aqua amsre_aqua 0.0 4 0 + ssmisbufr ssmis f16 ssmis_f16 0.0 4 0 + ssmisbufr ssmis f17 ssmis_f17 0.0 4 0 + ssmisbufr ssmis f18 ssmis_f18 0.0 4 0 + ssmisbufr ssmis f19 ssmis_f19 0.0 4 0 + gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 5 0 + gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 5 0 + gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 5 0 + gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 5 0 + gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 5 0 + gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 5 0 + gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 5 0 + gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 5 0 + gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 5 0 + gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 5 0 + gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 5 0 + gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 5 0 + iasibufr iasi metop-a iasi_metop-a 0.0 1 1 + gomebufr gome metop-a gome_metop-a 0.0 2 0 + omibufr omi aura omi_aura 0.0 2 0 + sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 + hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1 + amsuabufr amsua n19 amsua_n19 0.0 2 1 + mhsbufr mhs n19 mhs_n19 0.0 3 1 + seviribufr seviri m08 seviri_m08 0.0 1 0 + seviribufr seviri m09 seviri_m09 0.0 1 0 + seviribufr seviri m10 seviri_m10 0.0 1 0 + hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 + amsuabufr amsua metop-b amsua_metop-b 0.0 2 0 + mhsbufr mhs metop-b mhs_metop-b 0.0 3 0 + iasibufr iasi metop-b iasi_metop-b 0.0 1 0 + gomebufr gome metop-b gome_metop-b 0.0 2 0 + atmsbufr atms npp atms_npp 0.0 2 0 + atmsbufr atms n20 atms_n20 0.0 2 0 + crisbufr cris npp cris_npp 0.0 1 0 + crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 + crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0 + gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 5 0 + gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 5 0 + gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 5 0 + gsnd1bufr sndrd4 g14 sndrD4_g14 0.0 5 0 + gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 5 0 + gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 5 0 + gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 5 0 + gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 5 0 + oscatbufr uv null uv 0.0 0 0 + mlsbufr mls30 aura mls30_aura 0.0 0 0 + amsr2bufr amsr2 gcom-w1 amsr2_gcom-w1 0.0 3 0 + gmibufr gmi gpm gmi_gpm 0.0 3 0 + saphirbufr saphir meghat saphir_meghat 0.0 3 0 + ahibufr ahi himawari8 ahi_himawari8 0.0 3 0 :: &SUPEROB_RADAR - del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., l2superob_only=.false., - / + del_azimuth=5.,del_elev=.25,del_range=10000.,del_time=1.0,elev_angle_max=5.,minnum=1,range_max=200000., + l2superob_only=.false.,radar_sites=.false., + radar_box=.true.,radar_rmesh=10,radar_zmesh=500, + / +SUPEROB_RADAR:: + KBRO 1 + KCRP 1 + KEWX 1 + KGRX 1 + KDFX 1 + KHGX 1 + KLCH 1 + KLIX 1 + KPOE 1 + KSHV 1 + KDGX 1 + KMOB 1 + KEVX 1 + KEOX 1 + KMXX 1 + KBMX 1 + KTLH 1 + KTBW 1 + KBYX 1 + KAMX 1 + KMLB 1 + KJAX 1 + KVAX 1 + KJGX 1 + KFFC 1 + KCLX 1 + KCAE 1 + KGSP 1 + KLTX 1 + KMHX 1 + KRAX 1 + KAKQ 1 + KFCX 1 + KLWX 1 + KDOX 1 + KCCX 1 + KDIX 1 + KOKX 1 + KENX 1 + KBGM 1 + KCXX 1 + KBOX 1 + KGYX 1 + KCBW 1 + TJUA 1 + PHWA 1 + PHKI 1 + PHMO 1 + PHKM 1 +:: +/ &LAG_DATA / &HYBRID_ENSEMBLE - l_hyb_ens=${ifhyb}, + l_hyb_ens=.true., + n_ens=${N_ENS}, uv_hyb_ens=.true., - q_hyb_ens=.false., - aniso_a_en=.false.,generate_ens=.false., - n_ens=${nummem}, - beta_s0=0.15,s_ens_h=110,s_ens_v=3, - regional_ensemble_option=1, - pseudo_hybens = .false., - grid_ratio_ens = 3, - l_ens_in_diff_time=.true., - ensemble_path='', - i_en_perts_io=1, - jcap_ens=574, - fv3sar_bg_opt=0, - readin_localization=.true., - ens_fast_read=.false., + beta_s0=${BETA_S0}, + s_ens_h=150, + s_ens_v=-0.5, + readin_localization=.false., + generate_ens=.false., + regional_ensemble_option=${REGIONAL_ENSEMBLE_OPTION}, + grid_ratio_ens=${GRID_RATIO_ENS}, + pseudo_hybens=.false., + merge_two_grid_ensperts=F, + pwgtflg=F, + aniso_a_en=.false., + nlon_ens=387, + nlat_ens=777, + write_ens_sprd=F, + l_both_fv3sar_gfs_ens=${l_both_fv3sar_gfs_ens}, + n_ens_gfs=${n_ens_gfs}, + n_ens_fv3sar=${n_ens_fv3sar}, / &RAPIDREFRESH_CLDSURF - dfi_radar_latent_heat_time_period=20.0, - metar_impact_radius=10.0, - metar_impact_radius_lowCloud=4.0, - l_gsd_terrain_match_surfTobs=.true., - l_sfcobserror_ramp_t=.true., - l_sfcobserror_ramp_q=.true., - l_PBL_pseudo_SurfobsT=.false., - l_PBL_pseudo_SurfobsQ=.false., - l_PBL_pseudo_SurfobsUV=.false., - pblH_ration=0.4, - pps_press_incr=40.0, - l_gsd_limit_ocean_q=.true., - l_pw_hgt_adjust=.true., - l_limit_pw_innov=.true., - max_innov_pct=0.1, - l_cleanSnow_WarmTs=.true., - r_cleanSnow_WarmTs_threshold=5.0, - l_conserve_thetaV=.true., - i_conserve_thetaV_iternum=3, - l_gsd_soilTQ_nudge=.false., - l_cld_bld=.true., - l_numconc=.true., - l_closeobs=.true., - cld_bld_hgt=1200.0, - build_cloud_frac_p=0.50, - clear_cloud_frac_p=0.10, - iclean_hydro_withRef_allcol=1, - i_use_2mQ4B=2, - i_use_2mT4B=1, - i_gsdcldanal_type=0, - i_gsdsfc_uselist=1, - i_lightpcp=1, - i_sfct_gross=1, - i_coastline=3, - i_gsdqc=2, + dfi_radar_latent_heat_time_period=30.0, / &CHEM / @@ -1598,7 +796,7 @@ OBS_INPUT:: export gsi_namelist=" &SETUP - miter=2,niter(1)=50,niter(2)=50,niter_no_qc(1)=20, + miter=2,niter(1)=5,niter(2)=5,niter_no_qc(1)=2, write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., qoption=2, factqmin=0.0,factqmax=0.0,deltim=$DELTIM, @@ -1724,428 +922,6 @@ OBS_INPUT:: / " ;; - - cmaq_binary) - -# Define namelist for cmaq binary run - -export gsi_namelist=" - - &SETUP - miter=2,niter(1)=50,niter(2)=50, - write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - gencode=78,qoption=2, - factqmin=0.0,factqmax=0.0,deltim=$DELTIM, - iguess=-1, - oneobtest=.false.,retrieval=.false., - nhr_assimilation=3,l_foto=.false., - use_pbl=.false.,use_compress=.false., - diag_conv=.true.,lrun_subdirs=.true., - $SETUP - / - &GRIDOPTS - JCAP=$JCAP,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS, - wrf_nmm_regional=.false.,wrf_mass_regional=.false., - cmaq_regional=.true.,diagnostic_reg=.false., - filled_grid=.false.,half_grid=.true.,netcdf=.false., - / - &BKGERR - hzscl=0.373,0.746,1.50, - vs=1.0,bw=0.,fstat=.true., - / - &ANBKGERR - anisotropic=.false.,an_vs=1.0,ngauss=1, - an_flen_u=-5.,an_flen_t=3.,an_flen_z=-200., - ifilt_ord=2,npass=3,normal=-200,grid_ratio=4.,nord_f2a=4, - / - &JCOPTS - / - &STRONGOPTS - nstrong=0,nvmodes_keep=20, - period_max=3.,baldiag_full=.true.,baldiag_inc=.true., - / - &OBSQC - dfact=0.75,dfact1=3.0,noiqc=.true.,c_varqc=0.02,vadfile='prepbufr',oberrflg=.false.,njqc=.false.,vqc=.true., - / - &OBS_INPUT - dmesh(1)=120.0,dmesh(2)=60.0,dmesh(3)=60.0,dmesh(4)=60.0, - dmesh(5)=120,time_window_max=1.5, - / -OBS_INPUT:: -! dfile dtype dplat dsis dval dthin dsfcalc - anowbufr pm2_5 null TEOM 1.0 0 0 - / -!max name length for dfile=13 -!max name length for dtype=10 - &SUPEROB_RADAR - del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., - l2superob_only=.false., -:: - &LAG_DATA - / - &HYBRID_ENSEMBLE - / - &RAPIDREFRESH_CLDSURF - dfi_radar_latent_heat_time_period=30.0, - / - &CHEM - berror_chem=.true., - oneobtest_chem=.false., - maginnov_chem=60,magoberr_chem=2.,oneob_type_chem='pm2_5', - oblat_chem=45.,oblon_chem=270.,obpres_chem=1000., - diag_incr=.true.,elev_tolerance=500.,tunable_error=0.5, - in_fname="\""${cmaq_input}"\"",out_fname="\""${cmaq_output}"\"", - incr_fname="\""${chem_increment}"\"", -!diag_incr for diagnostic increment output - / - &SINGLEOB_TEST - maginnov=5,magoberr=0.1,oneob_type='t', - oblat=45.,oblon=270.,obpres=1000.,obdattim=${adate}, - obhourset=0., - / - &NST - / -" -;; - - hwrf_nmm_d2) - -# Define namelist for hwrf nmm d2 run - -export gsi_namelist=" - - &SETUP - miter=2,niter(1)=50,niter(2)=50,niter_no_qc(1)=20,niter_no_qc(2)=0, - write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - gencode=78,qoption=2, - factqmin=0.0,factqmax=0.0,deltim=$DELTIM, - iguess=-1, - oneobtest=.false.,retrieval=.false., - nhr_assimilation=6,l_foto=.false., - use_pbl=.true.,use_compress=.false., - print_diag_pcg=.true., - use_gfs_stratosphere=$USE_GFS_STRATOSPHERE, - use_gfs_ozone=$USE_GFS_OZONE, - regional_ozone=$REGIONAL_OZONE, - nsig_ext=12,gpstop=50., - $SETUP - / - &GRIDOPTS - JCAP=$JCAP,JCAP_B=$JCAP_B,NLAT=$NLAT,NLON=$NLON,nsig=$LEVS, - wrf_nmm_regional=.true.,wrf_mass_regional=.false., - diagnostic_reg=.false., - filled_grid=.false.,half_grid=.true.,netcdf=$NETCDF, - / - &BKGERR - hzscl=0.25,0.5,1.0, - vs=0.6,bw=0.,fstat=.false., - / - &ANBKGERR - anisotropic=.false.,an_vs=1.0,ngauss=1, - an_flen_u=-5.,an_flen_t=3.,an_flen_z=-200., - ifilt_ord=2,npass=3,normal=-200,grid_ratio=4.,nord_f2a=4, - / - &JCOPTS - / - &STRONGOPTS - tlnmc_option=0,reg_tlnmc_type=1,nstrong=1,nvmodes_keep=8,period_max=6., - period_width=1.5,baldiag_full=.false.,baldiag_inc=.false., - / - &OBSQC - dfact=0.75,dfact1=3.0,erradar_inflate=1.0,tdrerr_inflate=.true., - noiqc=.true.,c_varqc=0.02,vadfile='prepbufr',oberrflg=.false.,njqc=.false.,vqc=.true., - / - &OBS_INPUT - dmesh(1)=90.0,dmesh(2)=45.0,dmesh(3)=45.0,dmesh(4)=45.0,dmesh(5)=90,time_window_max=3.0,l_foreaft_thin=.false., - / -OBS_INPUT:: -! dfile dtype dplat dsis dval dthin dsfcalc - prepbufr ps null ps 0.0 0 0 - prepbufr t null t 0.0 0 0 - prepbufr q null q 0.0 0 0 - prepbufr pw null pw 0.0 0 0 - prepbufr uv null uv 0.0 0 0 - satwndbufr uv null uv 0.0 0 0 - prepbufr spd null spd 0.0 0 0 - prepbufr dw null dw 0.0 0 0 - radarbufr rw null l3rw 0.0 0 0 - l2rwbufr rw null l2rw 0.0 0 0 - prepbufr sst null sst 0.0 0 0 - tcvitl tcp null tcp 0.0 0 0 - tldplrbufr rw null rw 0.0 0 0 - hdobbufr uv null uv 0.0 0 0 - hdobbufr t null t 0.0 0 0 - hdobbufr q null q 0.0 0 0 - hdobbufr spd null spd 0.0 0 0 - gpsrobufr gps_bnd null gps 0.0 0 0 - ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0 - tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0 - sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 - sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 - sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1 - gimgrbufr goes_img g11 imgr_g11 0.0 1 0 - gimgrbufr goes_img g12 imgr_g12 0.0 1 0 - airsbufr airs aqua airs_aqua 0.0 1 1 - amsuabufr amsua n15 amsua_n15 0.0 2 1 - amsuabufr amsua n18 amsua_n18 0.0 2 1 - amsuabufr amsua metop-a amsua_metop-a 0.0 2 1 - airsbufr amsua aqua amsua_aqua 0.0 2 1 - amsubbufr amsub n17 amsub_n17 0.0 3 1 - mhsbufr mhs n18 mhs_n18 0.0 3 1 - mhsbufr mhs metop-a mhs_metop-a 0.0 3 1 - ssmitbufr ssmi f15 ssmi_f15 0.0 1 0 - amsrebufr amsre_low aqua amsre_aqua 0.0 4 0 - amsrebufr amsre_mid aqua amsre_aqua 0.0 4 0 - amsrebufr amsre_hig aqua amsre_aqua 0.0 4 0 - ssmisbufr ssmis f16 ssmis_f16 0.0 4 0 - ssmisbufr ssmis f17 ssmis_f17 0.0 4 0 - ssmisbufr ssmis f18 ssmis_f18 0.0 4 0 - ssmisbufr ssmis f19 ssmis_f19 0.0 4 0 - gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 5 0 - gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 5 0 - gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 5 0 - gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 5 0 - gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 5 0 - gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 5 0 - gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 5 0 - gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 5 0 - gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 5 0 - gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 5 0 - gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 5 0 - gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 5 0 - iasibufr iasi metop-a iasi_metop-a 0.0 1 1 - gomebufr gome metop-a gome_metop-a 0.0 2 0 - omibufr omi aura omi_aura 0.0 2 0 - sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1 - amsuabufr amsua n19 amsua_n19 0.0 2 1 - mhsbufr mhs n19 mhs_n19 0.0 3 1 - seviribufr seviri m08 seviri_m08 0.0 1 0 - seviribufr seviri m09 seviri_m09 0.0 1 0 - seviribufr seviri m10 seviri_m10 0.0 1 0 - seviribufr seviri m11 seviri_m11 0.0 1 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 - amsuabufr amsua metop-b amsua_metop-b 0.0 2 0 - mhsbufr mhs metop-b mhs_metop-b 0.0 3 0 - iasibufr iasi metop-b iasi_metop-b 0.0 1 0 - gomebufr gome metop-b gome_metop-b 0.0 2 0 - atmsbufr atms npp atms_npp 0.0 2 0 - atmsbufr atms n20 atms_n20 0.0 2 0 - crisbufr cris npp cris_npp 0.0 1 0 - crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 - crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0 - gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 5 0 - gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 5 0 - gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 5 0 - gsnd1bufr sndrd4 g14 sndrD4_g14 0.0 5 0 - gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 5 0 - gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 5 0 - gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 5 0 - gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 5 0 - ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 - ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 -:: - &SUPEROB_RADAR - del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., - l2superob_only=.false., - / - &LAG_DATA - / - &HYBRID_ENSEMBLE - l_hyb_ens=.true.,n_ens=10,uv_hyb_ens=.true.,beta_s0=0.2, - readin_beta=.true., - s_ens_h=300,s_ens_v=-0.5,readin_localization=.false., - generate_ens=.false.,regional_ensemble_option=1,grid_ratio_ens=1, - pseudo_hybens=.false.,merge_two_grid_ensperts=.false., - pwgtflg=.false.,aniso_a_en=.false., - nlon_ens=165,nlat_ens=335,jcap_ens=0,jcap_ens_test=0, - / - &RAPIDREFRESH_CLDSURF - dfi_radar_latent_heat_time_period=30.0, - / - &CHEM - / - &SINGLEOB_TEST - maginnov=1.0,magoberr=0.8,oneob_type='t', - oblat=38.,oblon=279.,obpres=500.,obdattim=${adate}, - obhourset=0., - / - &NST - / -" -;; - - hwrf_nmm_d3) - -# Define namelist for hwrf nmm d3 run - -export gsi_namelist=" - - &SETUP - miter=2,niter(1)=50,niter(2)=50,niter_no_qc(1)=20,niter_no_qc(2)=0, - write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - gencode=78,qoption=2, - factqmin=0.0,factqmax=0.0,deltim=$DELTIM, - iguess=-1, - oneobtest=.false.,retrieval=.false., - nhr_assimilation=6,l_foto=.false., - use_pbl=.true.,use_compress=.false., - print_diag_pcg=.true., - use_gfs_stratosphere=$USE_GFS_STRATOSPHERE, - use_gfs_ozone=$USE_GFS_OZONE, - regional_ozone=$REGIONAL_OZONE, - nsig_ext=12,gpstop=50., - $SETUP - / - &GRIDOPTS - JCAP=$JCAP,JCAP_B=$JCAP_B,NLAT=$NLAT,NLON=$NLON,nsig=$LEVS, - wrf_nmm_regional=.true.,wrf_mass_regional=.false., - diagnostic_reg=.false., - filled_grid=.false.,half_grid=.true.,netcdf=$NETCDF, - / - &BKGERR - hzscl=0.2,0.4,0.8, - vs=0.6,bw=0.,fstat=.false., - / - &ANBKGERR - anisotropic=.false.,an_vs=1.0,ngauss=1, - an_flen_u=-5.,an_flen_t=3.,an_flen_z=-200., - ifilt_ord=2,npass=3,normal=-200,grid_ratio=4.,nord_f2a=4, - / - &JCOPTS - / - &STRONGOPTS - tlnmc_option=0,reg_tlnmc_type=1,nstrong=1,nvmodes_keep=8,period_max=6., - period_width=1.5,baldiag_full=.false.,baldiag_inc=.false., - / - &OBSQC - dfact=0.75,dfact1=3.0,erradar_inflate=1.0,tdrerr_inflate=.true., - noiqc=.true.,c_varqc=0.02,vadfile='prepbufr',oberrflg=.false.,njqc=.false.,vqc=.true., - / - &OBS_INPUT - dmesh(1)=90.0,dmesh(2)=45.0,dmesh(3)=45.0,dmesh(4)=45.0,dmesh(5)=90,time_window_max=3.0,l_foreaft_thin=.false., - / -OBS_INPUT:: -! dfile dtype dplat dsis dval dthin dsfcalc - prepbufr ps null ps 0.0 0 0 - prepbufr t null t 0.0 0 0 - prepbufr q null q 0.0 0 0 - prepbufr pw null pw 0.0 0 0 - prepbufr uv null uv 0.0 0 0 - satwndbufr uv null uv 0.0 0 0 - prepbufr spd null spd 0.0 0 0 - prepbufr dw null dw 0.0 0 0 - radarbufr rw null l3rw 0.0 0 0 - l2rwbufr rw null l2rw 0.0 0 0 - prepbufr sst null sst 0.0 0 0 - tcvitl tcp null tcp 0.0 0 0 - tldplrbufr rw null rw 0.0 0 0 - hdobbufr uv null uv 0.0 0 0 - hdobbufr t null t 0.0 0 0 - hdobbufr q null q 0.0 0 0 - hdobbufr spd null spd 0.0 0 0 - gpsrobufr gps_bnd null gps 0.0 0 0 - ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0 - tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0 - sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 - sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 - sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1 - gimgrbufr goes_img g11 imgr_g11 0.0 1 0 - gimgrbufr goes_img g12 imgr_g12 0.0 1 0 - airsbufr airs aqua airs_aqua 0.0 1 1 - amsuabufr amsua n15 amsua_n15 0.0 2 1 - amsuabufr amsua n18 amsua_n18 0.0 2 1 - amsuabufr amsua metop-a amsua_metop-a 0.0 2 1 - airsbufr amsua aqua amsua_aqua 0.0 2 1 - amsubbufr amsub n17 amsub_n17 0.0 3 1 - mhsbufr mhs n18 mhs_n18 0.0 3 1 - mhsbufr mhs metop-a mhs_metop-a 0.0 3 1 - ssmitbufr ssmi f15 ssmi_f15 0.0 1 0 - amsrebufr amsre_low aqua amsre_aqua 0.0 4 0 - amsrebufr amsre_mid aqua amsre_aqua 0.0 4 0 - amsrebufr amsre_hig aqua amsre_aqua 0.0 4 0 - ssmisbufr ssmis f16 ssmis_f16 0.0 4 0 - ssmisbufr ssmis f17 ssmis_f17 0.0 4 0 - ssmisbufr ssmis f18 ssmis_f18 0.0 4 0 - ssmisbufr ssmis f19 ssmis_f19 0.0 4 0 - gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 5 0 - gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 5 0 - gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 5 0 - gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 5 0 - gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 5 0 - gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 5 0 - gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 5 0 - gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 5 0 - gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 5 0 - gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 5 0 - gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 5 0 - gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 5 0 - iasibufr iasi metop-a iasi_metop-a 0.0 1 1 - gomebufr gome metop-a gome_metop-a 0.0 2 0 - omibufr omi aura omi_aura 0.0 2 0 - sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1 - amsuabufr amsua n19 amsua_n19 0.0 2 1 - mhsbufr mhs n19 mhs_n19 0.0 3 1 - seviribufr seviri m08 seviri_m08 0.0 1 0 - seviribufr seviri m09 seviri_m09 0.0 1 0 - seviribufr seviri m10 seviri_m10 0.0 1 0 - seviribufr seviri m11 seviri_m11 0.0 1 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 - amsuabufr amsua metop-b amsua_metop-b 0.0 2 0 - mhsbufr mhs metop-b mhs_metop-b 0.0 3 0 - iasibufr iasi metop-b iasi_metop-b 0.0 1 0 - gomebufr gome metop-b gome_metop-b 0.0 2 0 - atmsbufr atms npp atms_npp 0.0 2 0 - atmsbufr atms n20 atms_n20 0.0 2 0 - crisbufr cris npp cris_npp 0.0 1 0 - crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 - crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0 - gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 5 0 - gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 5 0 - gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 5 0 - gsnd1bufr sndrd4 g14 sndrD4_g14 0.0 5 0 - gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 5 0 - gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 5 0 - gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 5 0 - gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 5 0 - ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 - ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 -:: - &SUPEROB_RADAR - del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., - l2superob_only=.false., - / - &LAG_DATA - / - &HYBRID_ENSEMBLE - l_hyb_ens=.true.,n_ens=10,uv_hyb_ens=.true.,beta_s0=0.2, - readin_beta=.true., - s_ens_h=150,s_ens_v=-0.5,readin_localization=.false., - generate_ens=.false.,regional_ensemble_option=1,grid_ratio_ens=1, - pseudo_hybens=.false.,merge_two_grid_ensperts=.false., - pwgtflg=.false.,aniso_a_en=.false., - nlon_ens=249,nlat_ens=499,jcap_ens=0,jcap_ens_test=0, - / - &RAPIDREFRESH_CLDSURF - dfi_radar_latent_heat_time_period=30.0, - / - &CHEM - / - &SINGLEOB_TEST - maginnov=1.0,magoberr=0.8,oneob_type='t', - oblat=38.,oblon=279.,obpres=500.,obdattim=${adate}, - obhourset=0., - / - &NST - / -" -;; - global_enkf) # Define namelist for global enkf run diff --git a/regression/regression_namelists_db.sh b/regression/regression_namelists_db.sh index 59962a587b..1558779e3e 100755 --- a/regression/regression_namelists_db.sh +++ b/regression/regression_namelists_db.sh @@ -2,173 +2,7 @@ job_name=$1 case $job_name in -global_3dvar) - -# Define namelist for global run (pcgsoi minimization) - -export gsi_namelist=" - - &SETUP - miter=2,niter(1)=2,niter(2)=1, - niter_no_qc(1)=1,niter_no_qc(2)=0, - write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - gencode=82,qoption=2,cwoption=3, - factqmin=5.0,factqmax=5.0,deltim=$DELTIM, - iguess=-1, - oneobtest=.false.,retrieval=.false.,l_foto=.false., - use_pbl=.false.,use_compress=.true.,nsig_ext=12,gpstop=50., - use_gfs_nemsio=.false.,lrun_subdirs=.true., - $SETUP - / - &GRIDOPTS - JCAP=$JCAP,JCAP_B=$JCAP_B,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS, - regional=.false.,nlayers(63)=3,nlayers(64)=6, - $GRIDOPTS - / - &BKGERR - vs=0.7, - hzscl=1.7,0.8,0.5, - hswgt=0.45,0.3,0.25, - bw=0.0,norsp=4, - bkgv_flowdep=.true.,bkgv_rewgtfct=1.5, - $BKGVERR - / - &ANBKGERR - anisotropic=.false., - $ANBKGERR - / - &JCOPTS - ljcdfi=.false.,alphajc=0.0,ljcpdry=.true.,bamp_jcpdry=5.0e7, - $JCOPTS - / - &STRONGOPTS - tlnmc_option=1,nstrong=1,nvmodes_keep=8,period_max=6.,period_width=1.5, - baldiag_full=.true.,baldiag_inc=.true., - $STRONGOPTS - / - &OBSQC - dfact=0.75,dfact1=3.0,noiqc=.true.,oberrflg=.false.,c_varqc=0.02, - use_poq7=.true.,njqc=.false.,vqc=.true., - $OBSQC - / - &OBS_INPUT - dmesh(1)=1450.0,dmesh(2)=1500.0,time_window_max=0.5, - $OBSINPUT - / -OBS_INPUT:: -! dfile dtype dplat dsis dval dthin dsfcalc - prepbufr ps null ps 0.0 0 0 - prepbufr t null t 0.0 0 0 - prepbufr q null q 0.0 0 0 - prepbufr pw null pw 0.0 0 0 - prepbufr uv null uv 0.0 0 0 - satwndbufr uv null uv 0.0 0 0 - prepbufr spd null spd 0.0 0 0 - prepbufr dw null dw 0.0 0 0 - radarbufr rw null rw 0.0 0 0 - prepbufr sst null sst 0.0 0 0 - gpsrobufr $gps_dtype null gps 0.0 0 0 - ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0 - tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0 - sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 - sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 - sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 1 - hirs4bufr_skip hirs4 metop-a hirs4_metop-a 0.0 1 1 - gimgrbufr goes_img g11 imgr_g11 0.0 1 0 - gimgrbufr goes_img g12 imgr_g12 0.0 1 0 - airsbufr airs aqua airs_aqua 0.0 1 1 - amsuabufr_skip amsua n15 amsua_n15 0.0 1 1 - amsuabufr_skip amsua n18 amsua_n18 0.0 1 1 - amsuabufr_skip amsua metop-a amsua_metop-a 0.0 1 1 - airsbufr_skip amsua aqua amsua_aqua 0.0 1 1 - amsubbufr amsub n17 amsub_n17 0.0 1 1 - mhsbufr_skip mhs n18 mhs_n18 0.0 1 1 - mhsbufr_skip mhs metop-a mhs_metop-a 0.0 1 1 - ssmitbufr ssmi f15 ssmi_f15 0.0 1 0 - amsrebufr amsre_low aqua amsre_aqua 0.0 1 0 - amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0 - amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0 - ssmisbufr ssmis_las f16 ssmis_f16 0.0 1 0 - ssmisbufr ssmis_uas f16 ssmis_f16 0.0 1 0 - ssmisbufr ssmis_img f16 ssmis_f16 0.0 1 0 - ssmisbufr ssmis_env f16 ssmis_f16 0.0 1 0 - gsnd1bufr_skip sndrd1 g12 sndrD1_g12 0.0 1 0 - gsnd1bufr_skip sndrd2 g12 sndrD2_g12 0.0 1 0 - gsnd1bufr_skip sndrd3 g12 sndrD3_g12 0.0 1 0 - gsnd1bufr_skip sndrd4 g12 sndrD4_g12 0.0 1 0 - gsnd1bufr_skip sndrd1 g11 sndrD1_g11 0.0 1 0 - gsnd1bufr_skip sndrd2 g11 sndrD2_g11 0.0 1 0 - gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 1 0 - gsnd1bufr_skip sndrd4 g11 sndrD4_g11 0.0 1 0 - gsnd1bufr_skip sndrd1 g13 sndrD1_g13 0.0 1 0 - gsnd1bufr_skip sndrd2 g13 sndrD2_g13 0.0 1 0 - gsnd1bufr_skip sndrd3 g13 sndrD3_g13 0.0 1 0 - gsnd1bufr_skip sndrd4 g13 sndrD4_g13 0.0 1 0 - iasibufr iasi metop-a iasi_metop-a 0.0 1 1 - gomebufr gome metop-a gome_metop-a 0.0 2 0 - omibufr omi aura omi_aura 0.0 2 0 - sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1 - amsuabufr amsua n19 amsua_n19 0.0 1 1 - mhsbufr mhs n19 mhs_n19 0.0 1 1 - tcvitl tcp null tcp 0.0 0 0 - mlsbufr mls30 aura mls30_aura 1.0 0 0 - seviribufr seviri m08 seviri_m08 0.0 1 0 - seviribufr seviri m09 seviri_m09 0.0 1 0 - seviribufr seviri m10 seviri_m10 0.0 1 0 - seviribufr seviri m11 seviri_m11 0.0 1 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 - amsuabufr amsua metop-b amsua_metop-b 0.0 1 0 - mhsbufr mhs metop-b mhs_metop-b 0.0 1 0 - iasibufr iasi metop-b iasi_metop-b 0.0 1 0 - gomebufr gome metop-b gome_metop-b 0.0 2 0 - atmsbufr atms npp atms_npp 0.0 1 0 - atmsbufr atms n20 atms_n20 0.0 1 0 - crisbufr cris npp cris_npp 0.0 1 0 - crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 - crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0 - ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 - ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 -:: - / - &SUPEROB_RADAR - $SUPERRAD - / - &LAG_DATA - / - &HYBRID_ENSEMBLE - l_hyb_ens=${HYBENS_GLOBAL}, - n_ens=${ENSEMBLE_SIZE_GLOBAL}, - uv_hyb_ens=${HYBENS_UV_GLOBAL}, - beta_s0=${BETA_S0_GLOBAL}, - readin_beta=.false., - s_ens_h=${HYBENS_HOR_SCALE_GLOBAL}, - s_ens_v=${HYBENS_VER_SCALE_GLOBAL}, - generate_ens=${GENERATE_ENS_GLOBAL}, - aniso_a_en=${HYBENS_ANISO_GLOBAL}, - nlon_ens=${LONA}, - nlat_ens=${NLAT}, - jcap_ens=${JCAP}, - jcap_ens_test=${JCAP}, - / - &RAPIDREFRESH_CLDSURF - dfi_radar_latent_heat_time_period=30.0, - / - &CHEM - / - &SINGLEOB_TEST - maginnov=0.1,magoberr=0.1,oneob_type='t', - oblat=45.,oblon=180.,obpres=1000.,obdattim=${adate}, - obhourset=0., - $SINGLEOB - / - &NST - / -" -;; - - global_4denvar ) + global_4denvar) # Define namelist for global hybrid run @@ -670,6 +504,274 @@ OBS_INPUT:: obhourset=0., / " +;; + + hafs_envar) + +# Define namelist for hafs 3d hybrid envar run with global ensembles + +export gsi_namelist=" + + &SETUP + miter=1,niter(1)=2,niter(2)=2, + niter_no_qc(1)=1,niter_no_qc(2)=0, + write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., + qoption=2, + gencode=78,deltim=1200, + factqmin=0.0,factqmax=0.0, + iguess=-1, + aircraft_recon=.true., + oneobtest=.false.,retrieval=.false.,l_foto=.false., + nhr_assimilation=6, + use_pbl=.true.,use_compress=.false.,nsig_ext=14,gpstop=50., + use_gfs_nemsio=.false.,use_gfs_ncio=.true., + print_diag_pcg=.true.,l2rwthin=.false.,hurricane_radar=.true., + use_gfs_ozone=.false.,l4densvar=${l4densvar},nhr_obsbin=${nhr_obsbin}, + lrun_subdirs=.true., + netcdf_diag=.true.,binary_diag=.false., + newpc4pred=.true., adp_anglebc=.true., angord=4, + passive_bc=.false., use_edges=.false., emiss_bc=.true., + diag_precon=.true., step_start=1.e-3, upd_pred(1)=0, + upd_pred(2)=0,upd_pred(3)=0,upd_pred(4)=0, + upd_pred(5)=0,upd_pred(6)=0,upd_pred(7)=0, + upd_pred(8)=0,upd_pred(9)=0,upd_pred(10)=0, + upd_pred(11)=0,upd_pred(12)=0, + lread_obs_save=.false., + lread_obs_skip=.false., + ens_nstarthr=6, + lwrite_predterms=.false.,lwrite_peakwt=.false.,reduce_diag=.false., + / + &GRIDOPTS + fv3_regional=.true.,grid_ratio_fv3_regional=1,nvege_type=20, + / + &BKGERR + vs=1.0, + hzscl=0.2,0.4,0.8, + bw=0., + fstat=.false., +/ + &ANBKGERR + anisotropic=.false.,an_vs=1.0,ngauss=1, + an_flen_u=-5.,an_flen_t=3.,an_flen_z=-200., + ifilt_ord=2,npass=3,normal=-200,grid_ratio=4.,nord_f2a=4, + / + &JCOPTS + / + &STRONGOPTS + tlnmc_option=0,reg_tlnmc_type=1,nstrong=1,nvmodes_keep=8,period_max=6., + period_width=1.5,baldiag_full=.false.,baldiag_inc=.false., + / + &OBSQC + dfact=0.75,dfact1=3.0,erradar_inflate=1.0,tdrerr_inflate=.true., + noiqc=.true.,c_varqc=0.03333,vadfile='prepbufr',njqc=.false.,vqc=.true.,vadwnd_l2rw_qc=.false., + q_doe_a_136=0.65, + q_doe_b_136=0.0003, + q_doe_a_137=0.75, + q_doe_b_137=0.0003, + t_doe_a_136=0.75, + t_doe_b_136=0.2, + t_doe_a_137=0.7, + t_doe_b_137=0.2, + uv_doe_a_236=0.5, + uv_doe_b_236=0.85, + uv_doe_a_237=0.5, + uv_doe_b_237=0.85, + uv_doe_a_213=0.4, + uv_doe_b_213=1.0, + / + &OBS_INPUT + dmesh(1)=90.0,dmesh(2)=45.0,dmesh(3)=45.0,dmesh(4)=45.0,dmesh(5)=90,time_window_max=3.0,l_foreaft_thin=.false., + / +OBS_INPUT:: +! dfile dtype dplat dsis dval dthin dsfcalc + prepbufr ps null ps 0.0 0 0 + prepbufr t null t 0.0 0 0 + prepbufr_profl t null t 0.0 0 0 + prepbufr q null q 0.0 0 0 + prepbufr_profl q null q 0.0 0 0 + prepbufr pw null pw 0.0 0 0 + prepbufr uv null uv 0.0 0 0 + prepbufr_profl uv null uv 0.0 0 0 + satwndbufr uv null uv 0.0 0 0 + satwhrbufr uv null uv 0.0 0 0 + prepbufr spd null spd 0.0 0 0 + prepbufr dw null dw 0.0 0 0 + radarbufr rw null rw 0.0 0 0 + prepbufr sst null sst 0.0 0 0 + tcvitl tcp null tcp 0.0 0 0 + tldplrbufr rw null rw 0.0 0 0 + l2rwbufr rw null l2rw 0.0 0 0 + hdobbufr uv null uv 0.0 0 0 + hdobbufr t null t 0.0 0 0 + hdobbufr q null q 0.0 0 0 + hdobbufr spd null spd 0.0 0 0 + gpsrobufr gps_bnd null gps 0.0 0 0 + ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0 + tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0 + sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 + sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 + sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 + hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 + hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1 + gimgrbufr goes_img g11 imgr_g11 0.0 1 0 + gimgrbufr goes_img g12 imgr_g12 0.0 1 0 + airsbufr airs aqua airs_aqua 0.0 1 1 + amsuabufr amsua n15 amsua_n15 0.0 2 1 + amsuabufr amsua n18 amsua_n18 0.0 2 1 + amsuabufr amsua metop-a amsua_metop-a 0.0 2 1 + airsbufr amsua aqua amsua_aqua 0.0 2 1 + amsubbufr amsub n17 amsub_n17 0.0 3 1 + mhsbufr mhs n18 mhs_n18 0.0 3 1 + mhsbufr mhs metop-a mhs_metop-a 0.0 3 1 + ssmitbufr ssmi f15 ssmi_f15 0.0 1 0 + amsrebufr amsre_low aqua amsre_aqua 0.0 4 0 + amsrebufr amsre_mid aqua amsre_aqua 0.0 4 0 + amsrebufr amsre_hig aqua amsre_aqua 0.0 4 0 + ssmisbufr ssmis f16 ssmis_f16 0.0 4 0 + ssmisbufr ssmis f17 ssmis_f17 0.0 4 0 + ssmisbufr ssmis f18 ssmis_f18 0.0 4 0 + ssmisbufr ssmis f19 ssmis_f19 0.0 4 0 + gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 5 0 + gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 5 0 + gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 5 0 + gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 5 0 + gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 5 0 + gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 5 0 + gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 5 0 + gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 5 0 + gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 5 0 + gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 5 0 + gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 5 0 + gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 5 0 + iasibufr iasi metop-a iasi_metop-a 0.0 1 1 + gomebufr gome metop-a gome_metop-a 0.0 2 0 + omibufr omi aura omi_aura 0.0 2 0 + sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 + hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1 + amsuabufr amsua n19 amsua_n19 0.0 2 1 + mhsbufr mhs n19 mhs_n19 0.0 3 1 + seviribufr seviri m08 seviri_m08 0.0 1 0 + seviribufr seviri m09 seviri_m09 0.0 1 0 + seviribufr seviri m10 seviri_m10 0.0 1 0 + hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 + amsuabufr amsua metop-b amsua_metop-b 0.0 2 0 + mhsbufr mhs metop-b mhs_metop-b 0.0 3 0 + iasibufr iasi metop-b iasi_metop-b 0.0 1 0 + gomebufr gome metop-b gome_metop-b 0.0 2 0 + atmsbufr atms npp atms_npp 0.0 2 0 + atmsbufr atms n20 atms_n20 0.0 2 0 + crisbufr cris npp cris_npp 0.0 1 0 + crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 + crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0 + gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 5 0 + gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 5 0 + gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 5 0 + gsnd1bufr sndrd4 g14 sndrD4_g14 0.0 5 0 + gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 5 0 + gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 5 0 + gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 5 0 + gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 5 0 + oscatbufr uv null uv 0.0 0 0 + mlsbufr mls30 aura mls30_aura 0.0 0 0 + amsr2bufr amsr2 gcom-w1 amsr2_gcom-w1 0.0 3 0 + gmibufr gmi gpm gmi_gpm 0.0 3 0 + saphirbufr saphir meghat saphir_meghat 0.0 3 0 + ahibufr ahi himawari8 ahi_himawari8 0.0 3 0 +:: + &SUPEROB_RADAR + del_azimuth=5.,del_elev=.25,del_range=10000.,del_time=1.0,elev_angle_max=5.,minnum=1,range_max=200000., + l2superob_only=.false.,radar_sites=.false., + radar_box=.true.,radar_rmesh=10,radar_zmesh=500, + / +SUPEROB_RADAR:: + KBRO 1 + KCRP 1 + KEWX 1 + KGRX 1 + KDFX 1 + KHGX 1 + KLCH 1 + KLIX 1 + KPOE 1 + KSHV 1 + KDGX 1 + KMOB 1 + KEVX 1 + KEOX 1 + KMXX 1 + KBMX 1 + KTLH 1 + KTBW 1 + KBYX 1 + KAMX 1 + KMLB 1 + KJAX 1 + KVAX 1 + KJGX 1 + KFFC 1 + KCLX 1 + KCAE 1 + KGSP 1 + KLTX 1 + KMHX 1 + KRAX 1 + KAKQ 1 + KFCX 1 + KLWX 1 + KDOX 1 + KCCX 1 + KDIX 1 + KOKX 1 + KENX 1 + KBGM 1 + KCXX 1 + KBOX 1 + KGYX 1 + KCBW 1 + TJUA 1 + PHWA 1 + PHKI 1 + PHMO 1 + PHKM 1 +:: +/ + &LAG_DATA + / + &HYBRID_ENSEMBLE + l_hyb_ens=.true., + n_ens=${N_ENS}, + uv_hyb_ens=.true., + beta_s0=${BETA_S0}, + s_ens_h=150, + s_ens_v=-0.5, + readin_localization=.false., + generate_ens=.false., + regional_ensemble_option=${REGIONAL_ENSEMBLE_OPTION}, + grid_ratio_ens=${GRID_RATIO_ENS}, + pseudo_hybens=.false., + merge_two_grid_ensperts=F, + pwgtflg=F, + aniso_a_en=.false., + nlon_ens=387, + nlat_ens=777, + write_ens_sprd=F, + l_both_fv3sar_gfs_ens=${l_both_fv3sar_gfs_ens}, + n_ens_gfs=${n_ens_gfs}, + n_ens_fv3sar=${n_ens_fv3sar}, + / + &RAPIDREFRESH_CLDSURF + dfi_radar_latent_heat_time_period=30.0, + / + &CHEM + / + &NST + / + &SINGLEOB_TEST + maginnov=1.0,magoberr=0.8,oneob_type='t', + oblat=38.,oblon=279.,obpres=500.,obdattim=2020040500, + obhourset=0., + / +" ;; netcdf_fv3_regional) @@ -679,7 +781,7 @@ OBS_INPUT:: export gsi_namelist=" &SETUP - miter=2,niter(1)=50,niter(2)=50,niter_no_qc(1)=20, + miter=2,niter(1)=2,niter(2)=1,niter_no_qc(1)=1, write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., qoption=2, factqmin=0.0,factqmax=0.0,deltim=$DELTIM, @@ -806,358 +908,6 @@ OBS_INPUT:: " ;; -cmaq_binary) - -# Define namelist for cmaq binary run - - export gsi_namelist=" - - &SETUP - miter=2,niter(1)=1,niter(2)=2, - write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - gencode=78,qoption=2, - factqmin=0.0,factqmax=0.0,deltim=$DELTIM, - iguess=-1, - oneobtest=.false.,retrieval=.false., - nhr_assimilation=3,l_foto=.false., - use_pbl=.false.,use_compress=.false., - diag_conv=.true.,lrun_subdirs=.true., - $SETUP - / - &GRIDOPTS - JCAP=$JCAP,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS, - wrf_nmm_regional=.false.,wrf_mass_regional=.false., - cmaq_regional=.true.,diagnostic_reg=.true., - filled_grid=.false.,half_grid=.true.,netcdf=.false., - / - &BKGERR - hzscl=0.373,0.746,1.50, - vs=1.0,bw=0.,fstat=.true., - / - &ANBKGERR - anisotropic=.false.,an_vs=1.0,ngauss=1, - an_flen_u=-5.,an_flen_t=3.,an_flen_z=-200., - ifilt_ord=2,npass=3,normal=-200,grid_ratio=4.,nord_f2a=4, - / - &JCOPTS - / - &STRONGOPTS - tlnmc_option=0,nstrong=0,nvmodes_keep=20, - period_max=3.,baldiag_full=.true.,baldiag_inc=.true., - / - &OBSQC - dfact=0.75,dfact1=3.0,noiqc=.true.,c_varqc=0.02,vadfile='prepbufr',njqc=.false.,vqc=.true., - / - &OBS_INPUT - dmesh(1)=120.0,dmesh(2)=60.0,dmesh(3)=60.0,dmesh(4)=60.0, - dmesh(5)=120,time_window_max=1.5, - / -OBS_INPUT:: -! dfile dtype dplat dsis dval dthin dsfcalc - anowbufr pm2_5 null TEOM 1.0 0 0 -:: -!max name length for dfile=13 -!max name length for dtype=10 - &SUPEROB_RADAR - del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., - l2superob_only=.false., - / - &LAG_DATA - / - &HYBRID_ENSEMBLE - / - &RAPIDREFRESH_CLDSURF - dfi_radar_latent_heat_time_period=30.0, - / - &CHEM - berror_chem=.true., - oneobtest_chem=.false., - maginnov_chem=60,magoberr_chem=2.,oneob_type_chem='pm2_5', - oblat_chem=45.,oblon_chem=270.,obpres_chem=1000., - diag_incr=.true.,elev_tolerance=500.,tunable_error=0.5, - in_fname="\""${cmaq_input}"\"",out_fname="\""${cmaq_output}"\"", - incr_fname="\""${chem_increment}"\"", -!diag_incr for diagnostic increment output - / - &SINGLEOB_TEST - maginnov=5,magoberr=0.1,oneob_type='t', - oblat=45.,oblon=270.,obpres=1000.,obdattim=${adate}, - obhourset=0., - / - &NST - / -" -;; - -hwrf_nmm_d2) - -export gsi_namelist=" - - &SETUP - miter=2,niter(1)=1,niter(2)=2,niter_no_qc(1)=20, - write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - gencode=78,qoption=2, - factqmin=0.0,factqmax=0.0,deltim=$DELTIM, - iguess=-1, - oneobtest=.false.,retrieval=.false., - nhr_assimilation=6,l_foto=.false., - use_pbl=.true.,use_compress=.false., - print_diag_pcg=.true., - use_gfs_stratosphere=$USE_GFS_STRATOSPHERE, - use_gfs_ozone=$USE_GFS_OZONE, - regional_ozone=$REGIONAL_OZONE, - nsig_ext=12,gpstop=50., - $SETUP - / - &GRIDOPTS - JCAP=$JCAP,JCAP_B=$JCAP_B,NLAT=$NLAT,NLON=$NLON,nsig=$LEVS, - wrf_nmm_regional=.true.,wrf_mass_regional=.false., - diagnostic_reg=.true., - filled_grid=.false.,half_grid=.true.,netcdf=$NETCDF, - / - &BKGERR - hzscl=0.25,0.5,1.0, - vs=0.6,bw=0.,fstat=.false., - / - &ANBKGERR - anisotropic=.false.,an_vs=1.0,ngauss=1, - an_flen_u=-5.,an_flen_t=3.,an_flen_z=-200., - ifilt_ord=2,npass=3,normal=-200,grid_ratio=4.,nord_f2a=4, - / - &JCOPTS - / - &STRONGOPTS - tlnmc_option=0,reg_tlnmc_type=1,nstrong=1,nvmodes_keep=8,period_max=6., - period_width=1.5,baldiag_full=.false.,baldiag_inc=.false., - / - &OBSQC - dfact=0.75,dfact1=3.0,erradar_inflate=1.0,tdrerr_inflate=.true., - noiqc=.true.,c_varqc=0.02,vadfile='prepbufr',njqc=.false.,vqc=.true., - / - &OBS_INPUT - dmesh(1)=90.0,dmesh(2)=45.0,dmesh(3)=45.0,dmesh(4)=45.0,dmesh(5)=90,dmesh(7)=9.0,time_window_max=3.0,l_foreaft_thin=.false., - / -OBS_INPUT:: -! dfile dtype dplat dsis dval dthin dsfcalc - prepbufr ps null ps 0.0 0 0 - prepbufr t null t 0.0 0 0 - prepbufr q null q 0.0 0 0 - prepbufr pw null pw 0.0 0 0 - prepbufr uv null uv 0.0 0 0 - satwndbufr uv null uv 0.0 0 0 - prepbufr spd null spd 0.0 0 0 - prepbufr dw null dw 0.0 0 0 - radarbufr rw null rw 0.0 0 0 - prepbufr sst null sst 0.0 0 0 - tcvitl tcp null tcp 0.0 0 0 - tldplrbufr rw null rw 0.0 7 0 - hdobbufr uv null uv 0.0 0 0 - hdobbufr t null t 0.0 0 0 - hdobbufr q null q 0.0 0 0 - hdobbufr spd null spd 0.0 0 0 - gpsrobufr gps_bnd null gps 0.0 0 0 - ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0 - tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0 - sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 - sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 - sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs3bufr_skip hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1 - gimgrbufr goes_img g11 imgr_g11 0.0 1 0 - gimgrbufr goes_img g12 imgr_g12 0.0 1 0 - airsbufr airs aqua airs_aqua 0.0 1 1 - amsuabufr_skip amsua n15 amsua_n15 0.0 2 1 - amsuabufr_skip amsua n18 amsua_n18 0.0 2 1 - amsuabufr amsua metop-a amsua_metop-a 0.0 2 1 - airsbufr_skip amsua aqua amsua_aqua 0.0 2 1 - amsubbufr amsub n17 amsub_n17 0.0 3 1 - mhsbufr_skip mhs n18 mhs_n18 0.0 3 1 - mhsbufr mhs metop-a mhs_metop-a 0.0 3 1 - ssmitbufr ssmi f15 ssmi_f15 0.0 1 0 - amsrebufr amsre_low aqua amsre_aqua 0.0 4 0 - amsrebufr amsre_mid aqua amsre_aqua 0.0 4 0 - amsrebufr amsre_hig aqua amsre_aqua 0.0 4 0 - ssmisbufr ssmis f16 ssmis_f16 0.0 4 0 - ssmisbufr ssmis f17 ssmis_f17 0.0 4 0 - ssmisbufr ssmis f18 ssmis_f18 0.0 4 0 - ssmisbufr ssmis f19 ssmis_f19 0.0 4 0 - gsnd1bufr_skip sndrd1 g12 sndrD1_g12 0.0 5 0 - gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 5 0 - gsnd1bufr_skip sndrd3 g12 sndrD3_g12 0.0 5 0 - gsnd1bufr_skip sndrd4 g12 sndrD4_g12 0.0 5 0 - gsnd1bufr_skip sndrd1 g11 sndrD1_g11 0.0 5 0 - gsnd1bufr_skip sndrd2 g11 sndrD2_g11 0.0 5 0 - gsnd1bufr_skip sndrd3 g11 sndrD3_g11 0.0 5 0 - gsnd1bufr_skip sndrd4 g11 sndrD4_g11 0.0 5 0 - gsnd1bufr_skip sndrd1 g13 sndrD1_g13 0.0 5 0 - gsnd1bufr_skip sndrd2 g13 sndrD2_g13 0.0 5 0 - gsnd1bufr_skip sndrd3 g13 sndrD3_g13 0.0 5 0 - gsnd1bufr_skip sndrd4 g13 sndrD4_g13 0.0 5 0 - iasibufr iasi metop-a iasi_metop-a 0.0 1 1 - gomebufr gome metop-a gome_metop-a 0.0 2 0 - omibufr omi aura omi_aura 0.0 2 0 - sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1 - amsuabufr amsua n19 amsua_n19 0.0 2 1 - mhsbufr mhs n19 mhs_n19 0.0 3 1 - seviribufr seviri m08 seviri_m08 0.0 1 0 - seviribufr seviri m09 seviri_m09 0.0 1 0 - seviribufr seviri m10 seviri_m10 0.0 1 0 - seviribufr seviri m11 seviri_m11 0.0 1 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 - amsuabufr amsua metop-b amsua_metop-b 0.0 2 0 - mhsbufr mhs metop-b mhs_metop-b 0.0 3 0 - iasibufr iasi metop-b iasi_metop-b 0.0 1 0 - gomebufr gome metop-b gome_metop-b 0.0 2 0 - atmsbufr atms npp atms_npp 0.0 2 0 - atmsbufr atms n20 atms_n20 0.0 2 0 - crisbufr cris npp cris_npp 0.0 1 0 - crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 - crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0 - gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 5 0 - gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 5 0 - gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 5 0 - gsnd1bufr sndrd4 g14 sndrD4_g14 0.0 5 0 - gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 5 0 - gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 5 0 - gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 5 0 - gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 5 0 - ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 - ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 -:: - &SUPEROB_RADAR - del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., - l2superob_only=.false., - / - &LAG_DATA - / - &HYBRID_ENSEMBLE - l_hyb_ens=.true.,n_ens=10,uv_hyb_ens=.true.,beta_s0=0.2, - readin_beta=.true., - s_ens_h=300,s_ens_v=-0.5,readin_localization=.false., - generate_ens=.false.,regional_ensemble_option=1,grid_ratio_ens=1, - pseudo_hybens=.false.,merge_two_grid_ensperts=.false., - pwgtflg=.false.,aniso_a_en=.false., - nlon_ens=165,nlat_ens=335,jcap_ens=0,jcap_ens_test=0, - / - &RAPIDREFRESH_CLDSURF - dfi_radar_latent_heat_time_period=30.0, - / - &CHEM - / - &SINGLEOB_TEST - maginnov=1.0,magoberr=0.8,oneob_type='t', - oblat=38.,oblon=279.,obpres=500.,obdattim=${adate}, - obhourset=0., - / - &NST - / -" -;; - -hwrf_nmm_d3) - -export gsi_namelist=" - - &SETUP - miter=2,niter(1)=1,niter(2)=2,niter_no_qc(1)=20, - write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - gencode=78,qoption=2, - factqmin=0.0,factqmax=0.0,deltim=$DELTIM, - iguess=-1, - oneobtest=.false.,retrieval=.false., - nhr_assimilation=6,l_foto=.false., - use_pbl=.true.,use_compress=.false., - print_diag_pcg=.true., - use_gfs_stratosphere=$USE_GFS_STRATOSPHERE, - use_gfs_ozone=$USE_GFS_OZONE, - regional_ozone=$REGIONAL_OZONE, - nsig_ext=12,gpstop=50., - $SETUP - / - &GRIDOPTS - JCAP=$JCAP,JCAP_B=$JCAP_B,NLAT=$NLAT,NLON=$NLON,nsig=$LEVS, - wrf_nmm_regional=.true.,wrf_mass_regional=.false., - diagnostic_reg=.true., - filled_grid=.false.,half_grid=.true.,netcdf=$NETCDF, - / - &BKGERR - hzscl=0.2,0.4,0.8, - vs=0.6,bw=0.,fstat=.false., - / - &ANBKGERR - anisotropic=.false.,an_vs=1.0,ngauss=1, - an_flen_u=-5.,an_flen_t=3.,an_flen_z=-200., - ifilt_ord=2,npass=3,normal=-200,grid_ratio=4.,nord_f2a=4, - / - &JCOPTS - / - &STRONGOPTS - tlnmc_option=0,reg_tlnmc_type=1,nstrong=1,nvmodes_keep=8,period_max=6., - period_width=1.5,baldiag_full=.false.,baldiag_inc=.false., - / - &OBSQC - dfact=0.75,dfact1=3.0,erradar_inflate=1.0,tdrerr_inflate=.true., - noiqc=.true.,c_varqc=0.02,vadfile='prepbufr',njqc=.false.,vqc=.true., - / - &OBS_INPUT - dmesh(1)=90.0,dmesh(2)=45.0,dmesh(3)=45.0,dmesh(4)=45.0,dmesh(5)=90,dmesh(7)=9.0,time_window_max=3.0,l_foreaft_thin=.false., - / -OBS_INPUT:: -! dfile dtype dplat dsis dval dthin dsfcalc - prepbufr ps null ps 0.0 0 0 - prepbufr t null t 0.0 0 0 - prepbufr q null q 0.0 0 0 - prepbufr pw null pw 0.0 0 0 - prepbufr uv null uv 0.0 0 0 - satwndbufr uv null uv 0.0 0 0 - prepbufr spd null spd 0.0 0 0 - prepbufr dw null dw 0.0 0 0 - radarbufr rw null rw 0.0 0 0 - prepbufr sst null sst 0.0 0 0 - tcvitl tcp null tcp 0.0 0 0 - tldplrbufr rw null rw 0.0 7 0 - hdobbufr uv null uv 0.0 0 0 - hdobbufr t null t 0.0 0 0 - hdobbufr q null q 0.0 0 0 - hdobbufr spd null spd 0.0 0 0 - gpsrobufr gps_bnd null gps 0.0 0 0 - ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0 - tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0 - sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 - sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 - sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 -:: - &SUPEROB_RADAR - del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., - l2superob_only=.false., - / - &LAG_DATA - / - &HYBRID_ENSEMBLE - l_hyb_ens=.true.,n_ens=10,uv_hyb_ens=.true.,beta_s0=0.2, - readin_beta=.true., - s_ens_h=150,s_ens_v=-0.5,readin_localization=.false., - generate_ens=.false.,regional_ensemble_option=1,grid_ratio_ens=1, - pseudo_hybens=.false.,merge_two_grid_ensperts=.false., - pwgtflg=.false.,aniso_a_en=.false., - nlon_ens=249,nlat_ens=499,jcap_ens=0,jcap_ens_test=0, - / - &RAPIDREFRESH_CLDSURF - dfi_radar_latent_heat_time_period=30.0, - / - &CHEM - / - &SINGLEOB_TEST - maginnov=1.0,magoberr=0.8,oneob_type='t', - oblat=38.,oblon=279.,obpres=500.,obdattim=${adate}, - obhourset=0., - / - &NST - / -" -;; - *) # EXIT out for unresolved job_name diff --git a/regression/regression_param.sh b/regression/regression_param.sh index ea27521251..87a21dc0f1 100755 --- a/regression/regression_param.sh +++ b/regression/regression_param.sh @@ -51,125 +51,106 @@ export maxmem=$((($memnode*1024*1024)/$numcore)) # Kb / core case $regtest in - global_3dvar) + global_4denvar) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="12/5/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="12/9/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:15:00" ; popts[1]="12/5/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="12/9/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/12/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:15:00" ; popts[1]="12/5/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="12/9/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2" + elif [[ "$machine" = "Discover" ]]; then + topts[1]="0:30:00" ; popts[1]="48/2" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="60/3" ; ropts[2]="/2" elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:15:00" ; popts[1]="16/2/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="16/4/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:15:00" ; popts[1]="18/2/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="18/4/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="18/8/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="18/10/" ; ropts[2]="/2" elif [[ "$machine" = "wcoss2" ]]; then - topts[1]="0:15:00" ; popts[1]="12/5/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="12/9/" ; ropts[2]="/2" - elif [[ "$machine" = "Discover" ]]; then - topts[1]="0:30:00" ; popts[1]="36/2" ; ropts[1]="/1" - topts[2]="0:30:00" ; popts[2]="72/3" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2" fi if [ "$debug" = ".true." ] ; then - topts[1]="0:45:00" + topts[1]="1:30:00" fi scaling[1]=10; scaling[2]=8; scaling[3]=4 ;; - global_4dvar) + rrfs_3denvar_glbens) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:15:00" ; popts[1]="18/2/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="18/4/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then - topts[1]="0:15:00" ; popts[1]="28/2/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="28/4/" ; ropts[2]="/2" - elif [[ "$machine" = "Discover" ]]; then - topts[1]="2:00:00" ; popts[1]="48/2" ; ropts[1]="/1" - topts[2]="2:00:00" ; popts[2]="60/3" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" fi if [ "$debug" = ".true." ] ; then - topts[1]="0:45:00" - if [[ "$machine" = "Hera" ]]; then - popts[1]="12/5/" - elif [[ "$machine" = "Orion" ]]; then - popts[1]="12/5/" - elif [[ "$machine" = "Jet" ]]; then - popts[1]="12/5/" - elif [[ "$machine" = "Gaea" ]]; then - popts[1]="18/5/" - elif [[ "$machine" = "wcoss2" ]]; then - popts[1]="28/4/" - topts[1]="3:00:00" - fi + topts[1]="0:30:00" fi - scaling[1]=5; scaling[2]=8; scaling[3]=2 + scaling[1]=2; scaling[2]=10; scaling[3]=4 ;; - global_4denvar) + hafs_3denvar_hybens) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" - topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" - topts[2]="0:10:00" ; popts[2]="12/12/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" - topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2" - elif [[ "$machine" = "Discover" ]]; then - topts[1]="0:30:00" ; popts[1]="48/2" ; ropts[1]="/1" - topts[2]="0:30:00" ; popts[2]="60/3" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" - topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:10:00" ; popts[1]="18/8/" ; ropts[1]="/1" - topts[2]="0:10:00" ; popts[2]="18/10/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then - topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" - topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" fi if [ "$debug" = ".true." ] ; then - topts[1]="1:30:00" + topts[1]="0:30:00" fi - scaling[1]=10; scaling[2]=8; scaling[3]=4 + scaling[1]=2; scaling[2]=10; scaling[3]=4 ;; - rrfs_3denvar_glbens) - + hafs_4denvar_glbens) if [[ "$machine" = "Hera" ]]; then topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:20:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:20:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Jet" ]]; then topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" @@ -185,10 +166,10 @@ case $regtest in fi if [ "$debug" = ".true." ] ; then - topts[1]="0:30:00" + topts[1]="0:45:00" fi - scaling[1]=2; scaling[2]=10; scaling[3]=4 + scaling[1]=10; scaling[2]=8; scaling[3]=4 ;; @@ -252,36 +233,6 @@ case $regtest in ;; - hwrf_nmm_d2 | hwrf_nmm_d3) - - if [[ "$machine" = "Hera" ]]; then - topts[1]="0:20:00" ; popts[1]="6/6/" ; ropts[1]="/1" - topts[2]="0:20:00" ; popts[2]="8/8/" ; ropts[2]="/1" - elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:20:00" ; popts[1]="6/6/" ; ropts[1]="/1" - topts[2]="0:20:00" ; popts[2]="8/8/" ; ropts[2]="/1" - elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:20:00" ; popts[1]="6/6/" ; ropts[1]="/1" - topts[2]="0:20:00" ; popts[2]="8/8/" ; ropts[2]="/1" - elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:20:00" ; popts[1]="6/6/" ; ropts[1]="/1" - topts[2]="0:20:00" ; popts[2]="8/8/" ; ropts[2]="/1" - elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:20:00" ; popts[1]="6/6/" ; ropts[1]="/1" - topts[2]="0:20:00" ; popts[2]="8/8/" ; ropts[2]="/1" - elif [[ "$machine" = "wcoss2" ]]; then - topts[1]="0:15:00" ; popts[1]="10/10/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="14/14/" ; ropts[2]="/2" - fi - - if [ "$debug" = ".true." ] ; then - topts[1]="1:00:00" - fi - - scaling[1]=5; scaling[2]=10; scaling[3]=2 - - ;; - global_enkf) if [[ "$machine" = "Hera" ]]; then diff --git a/regression/regression_test.sh b/regression/regression_test.sh index 0bcb9f4d90..263761052a 100755 --- a/regression/regression_test.sh +++ b/regression/regression_test.sh @@ -33,7 +33,6 @@ cd $tmpdir # Other required constants for regression testing maxtime=1200 -maxmem=${maxmem:-3400000} # set in regression_param # Copy stdout and fort.220 files # from $savdir to $tmpdir @@ -182,24 +181,6 @@ fi } >> $output - # Next, maximum residence set size (both harware limitation and percent difference) - # First, hardware limitation - - { - - if [[ $(awk '{ print $8 }' memory.$exp1.txt) -gt $maxmem ]]; then - echo 'The memory for '$exp1' is '$(awk '{ print $8 }' memory.$exp1.txt)' KBs. This has exceeded maximum allowable hardware memory limit of '$maxmem' KBs,' - echo 'resulting in Failure maxmem of the regression test.' - echo - failed_test=1 - else - echo 'The memory for '$exp1' is '$(awk '{ print $8 }' memory.$exp1.txt)' KBs and is within the maximum allowable hardware memory limit of '$maxmem' KBs,' - echo 'continuing with regression test.' - echo - fi - - } >> $output - # Next, maximum residence set size { @@ -348,7 +329,7 @@ fi } >> $output fi - elif [[ `expr substr $exp1 1 4` = "rrfs" ]]; then + elif [[ `expr substr $exp1 1 4` = "rrfs" ]] || [[ `expr substr $exp1 1 4` = "hafs" ]]; then { fv3_failed_test=0 if cmp -s fv3_dynvars.${exp1} fv3_dynvars.${exp2} @@ -520,7 +501,7 @@ elif [[ `expr substr $exp1 1 6` = "global" ]]; then fi -elif [[ `expr substr $exp1 1 4` = "rrfs" ]]; then +elif [[ `expr substr $exp1 1 4` = "rrfs" ]] || [[ `expr substr $exp1 1 4` = "hafs" ]]; then { fv3_failed_test=0 if cmp -s fv3_dynvars.${exp1} fv3_dynvars.${exp3} @@ -556,21 +537,6 @@ elif [[ `expr substr $exp1 1 4` = "rrfs" ]]; then fi - # Finally, scalability - - { - - timelogic=$( echo "$scale1thresh >= $scale2" | bc ) - if [[ "$timelogic" = 1 ]]; then - echo 'The case has passed the scalability regression test.' - echo 'The slope for the update ('$scale1thresh' seconds per node) is greater than or equal to that for the control ('$scale2' seconds per node).' - else - echo 'The case has Failed the scalability test.' - echo 'The slope for the update ('$scale1thresh' seconds per node) is less than that for the control ('$scale2' seconds per node).' - fi - - } >> $output - # Copy select results to $savdir mkdir -p $vfydir diff --git a/regression/regression_test_enkf.sh b/regression/regression_test_enkf.sh index f52a5d451f..38ee20ce99 100755 --- a/regression/regression_test_enkf.sh +++ b/regression/regression_test_enkf.sh @@ -31,8 +31,6 @@ cd $tmpdir # Other required constants for regression testing maxtime=1200 -maxmem=${maxmem:-3400000} # set in regression_param -maxmem=$((${memnode:-64}*1024*1024)) # Copy stdout and incr files # from $savdir to $tmpdir @@ -177,20 +175,6 @@ fi # Next, maximum residence set size (both harware limitation and percent difference) # First, hardware limitation - { - - if [[ $(awk '{ print $8 }' memory.$exp1.txt) -gt $maxmem ]]; then - echo 'The memory for '$exp1' is '$(awk '{ print $8 }' memory.$exp1.txt)' KBs. This has exceeded maximum allowable hardware memory limit of '$maxmem' KBs,' - echo 'resulting in Failure maxmem of the regression test.' - echo - failed_test=1 - else - echo 'The memory for '$exp1' is '$(awk '{ print $8 }' memory.$exp1.txt)' KBs and is within the maximum allowable hardware memory limit of '$maxmem' KBs,' - echo 'continuing with regression test.' - echo - fi - - } >> $output # Next, maximum residence set size @@ -397,21 +381,6 @@ else fi fi - # Finally, scalability - - { - - timelogic=$( echo "$scale1thresh >= $scale2" | bc ) - if [[ "$timelogic" = 1 ]]; then - echo 'The case has passed the scalability regression test.' - echo 'The slope for the update ('$scale1thresh' seconds per node) is greater than or equal to that for the control ('$scale2' seconds per node).' - else - echo 'The case has Failed the scalability test.' - echo 'The slope for the update ('$scale1thresh' seconds per node) is less than that for the control ('$scale2' seconds per node).' - fi - - } >> $output - # Copy select results to $savdir mkdir -p $vfydir diff --git a/regression/regression_var.sh b/regression/regression_var.sh index 3176372a3b..7403d89ec0 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -199,21 +199,23 @@ export JCAP="62" # Case Study analysis dates export global_adate="2022110900" export rtma_adate="2020022420" -export hwrf_nmm_adate="2012102812" export fv3_netcdf_adate="2017030100" export rrfs_3denvar_glbens_adate="2021072518" +export hafs_envar_adate="2020082512" # Paths for canned case data. export global_data="$casesdir/gfs/prod" export rtma_obs="$casesdir/regional/rtma_binary/$rtma_adate" export rtma_ges="$casesdir/regional/rtma_binary/$rtma_adate" -export hwrf_nmm_obs="$casesdir/regional/hwrf_nmm/$hwrf_nmm_adate" -export hwrf_nmm_ges="$casesdir/regional/hwrf_nmm/$hwrf_nmm_adate" export fv3_netcdf_obs="$casesdir/regional/fv3_netcdf/$fv3_netcdf_adate" export fv3_netcdf_ges="$casesdir/regional/fv3_netcdf/$fv3_netcdf_adate" export rrfs_3denvar_glbens_obs="$casesdir/regional/rrfs/$rrfs_3denvar_glbens_adate/obs" export rrfs_3denvar_glbens_ges="$casesdir/regional/rrfs/$rrfs_3denvar_glbens_adate/ges" export rrfs_3denvar_glbens_ens="$casesdir/regional/rrfs/$rrfs_3denvar_glbens_adate/ens" +export hafs_envar_obs="$casesdir/regional/hafs_RTdata/$hafs_envar_adate/obs" +export hafs_envar_ges="$casesdir/regional/hafs_RTdata/$hafs_envar_adate/ges" +export hafs_envar_ens="$casesdir/regional/hafs_RTdata/$hafs_envar_adate/ens" + # Define type of GPSRO data to be assimilated (refractivity or bending angle) export gps_dtype="gps_bnd" @@ -224,7 +226,7 @@ export regression_vfydir="$noscrub/regression" # Define debug variable - If you want to run the debug tests, set this variable to .true. Default is .false. export debug=".false." -# Define parameters for global_3dvar, global_4dvar, global_4denvar +# Define parameters for global_4denvar export minimization="lanczos" # If "lanczos", use sqrtb lanczos minimization algorithm. Otherwise use "pcgsoi". export nhr_obsbin="6" # Time window for observation binning. Use "6" for 3d4dvar test. Otherwise use "1" From acfe56d095319e962342d98a59b681c2858aeac4 Mon Sep 17 00:00:00 2001 From: hongli-wang <53354098+hongli-wang@users.noreply.github.com> Date: Tue, 31 Oct 2023 09:47:19 -0600 Subject: [PATCH 039/109] Add FED EnVar DA Capability (#632) - This PR supports RRFS_B GSI FED assimilation. - This PR adds a new GSI EnVar FED assimilation capability. The summary of the changes: - Read FED background and ensemble from restart phy files - Add new control/state variable of fed ( in anavinfo, section: metguess, state and control variable) - Create intfed.f90 and sfpfed.f90 for minimization. - Other related codes. For example, update hydrometers when either dbz or fed is assimilated, or both are assimilated. Previously the update of hydrometers is done only when dbz is assimilated. Please see Fixes #622 This PR was tested with: - One FED obs DA test - Real FED DA with pseudo ensemble for code development and debug - Real FED DA with real ensemble --------- Co-authored-by: David Dowell --- src/gsi/cplr_get_fv3_regional_ensperts.f90 | 235 ++++++++--- src/gsi/gsi_fedOper.F90 | 10 + src/gsi/gsi_files.cmake | 2 + src/gsi/gsi_rfv3io_mod.f90 | 89 +++-- src/gsi/gsimod.F90 | 39 +- src/gsi/intfed.f90 | 187 +++++++++ src/gsi/m_berror_stats_reg.f90 | 13 +- src/gsi/obsmod.F90 | 22 +- src/gsi/read_dbz_netcdf.f90 | 3 +- src/gsi/read_fed.f90 | 445 ++++++++------------- src/gsi/setupfed.f90 | 229 ++++++----- src/gsi/stpfed.f90 | 171 ++++++++ src/gsi/wrf_vars_mod.f90 | 39 +- 13 files changed, 997 insertions(+), 487 deletions(-) create mode 100644 src/gsi/intfed.f90 create mode 100644 src/gsi/stpfed.f90 diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 index 2645723c62..2382ff1286 100644 --- a/src/gsi/cplr_get_fv3_regional_ensperts.f90 +++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90 @@ -74,7 +74,7 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) use netcdf , only: nf90_open, nf90_close,nf90_nowrite,nf90_inquire,nf90_format_netcdf4 use netcdf_mod , only: nc_check use gsi_rfv3io_mod, only: fv3lam_io_phymetvars3d_nouv - use obsmod, only: if_model_dbz + use obsmod, only: if_model_dbz,if_model_fed implicit none @@ -85,10 +85,10 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig):: u,v,tv,oz,rh real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2):: ps - real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig)::w,ql,qi,qr,qg,qs,qnr,dbz + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig)::w,ql,qi,qr,qg,qs,qnr,dbz,fed real(r_kind),dimension(:,:,:),allocatable :: gg_u,gg_v,gg_tv,gg_rh real(r_kind),dimension(:,:,:),allocatable :: gg_w,gg_dbz,gg_qr,gg_qs, & - gg_qi,gg_qg,gg_oz,gg_cwmr + gg_qi,gg_qg,gg_oz,gg_cwmr,gg_fed real(r_kind),dimension(:,:),allocatable :: gg_ps real(r_single),pointer,dimension(:,:,:):: w3 =>NULL() @@ -117,6 +117,8 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) type(type_fv3regfilenameg)::fv3_filename integer(i_kind):: imem_start,n_fv3sar + integer(i_kind):: i_caseflag + if(n_ens/=(n_ens_gfs+n_ens_fv3sar)) then write(6,*)'wrong, the sum of n_ens_gfs and n_ens_fv3sar not equal n_ens, stop' write(6,*)"n_ens, n_ens_gfs and n_ens_fv3sar are",n_ens, n_ens_gfs , n_ens_fv3sar @@ -317,7 +319,6 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) fv3_filename%sfcdata=trim(ensfilenam_str)//"-fv3_sfcdata" fv3_filename%couplerres=trim(ensfilenam_str)//"-coupler.res" - if( mype==iope) then allocate(gg_u(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) allocate(gg_v(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) @@ -325,20 +326,35 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) allocate(gg_rh(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) allocate(gg_oz(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) allocate(gg_ps(grd_ens%nlat,grd_ens%nlon)) - if ( .not. if_model_dbz ) then - call this%general_read_fv3_regional_parallel_over_ens(iope,fv3_filename,gg_ps,gg_u,gg_v,gg_tv,gg_rh,gg_oz) - else + + if ( if_model_dbz .or. if_model_fed ) then allocate(gg_w(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) - allocate(gg_dbz(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) allocate(gg_qr(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) allocate(gg_qs(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) allocate(gg_qi(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) allocate(gg_qg(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) allocate(gg_cwmr(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) - call this%general_read_fv3_regional_parallel_over_ens(iope,fv3_filename,gg_ps,gg_u,gg_v,gg_tv,gg_rh,gg_oz, & - g_ql=gg_cwmr,g_qi=gg_qi,g_qr=gg_qr,g_qs=gg_qs,g_qg=gg_qg,g_w=gg_w,g_dbz=gg_dbz) end if - end if + if ( if_model_dbz) then + allocate(gg_dbz(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + end if + if ( if_model_fed) then + allocate(gg_fed(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + end if + + if ( if_model_dbz .and. if_model_fed) then + call this%general_read_fv3_regional_parallel_over_ens(iope,fv3_filename,gg_ps,gg_u,gg_v,gg_tv,gg_rh,gg_oz,& + g_ql=gg_cwmr,g_qi=gg_qi,g_qr=gg_qr,g_qs=gg_qs,g_qg=gg_qg,g_w=gg_w,g_dbz=gg_dbz,g_fed=gg_fed) + elseif ( if_model_dbz ) then + call this%general_read_fv3_regional_parallel_over_ens(iope,fv3_filename,gg_ps,gg_u,gg_v,gg_tv,gg_rh,gg_oz,& + g_ql=gg_cwmr,g_qi=gg_qi,g_qr=gg_qr,g_qs=gg_qs,g_qg=gg_qg,g_w=gg_w,g_dbz=gg_dbz) + elseif ( if_model_fed ) then + call this%general_read_fv3_regional_parallel_over_ens(iope,fv3_filename,gg_ps,gg_u,gg_v,gg_tv,gg_rh,gg_oz,& + g_ql=gg_cwmr,g_qi=gg_qi,g_qr=gg_qr,g_qs=gg_qs,g_qg=gg_qg,g_w=gg_w,g_fed=gg_fed) + else + call this%general_read_fv3_regional_parallel_over_ens(iope,fv3_filename,gg_ps,gg_u,gg_v,gg_tv,gg_rh,gg_oz) + end if + end if !mype end do if(mype==0) then write(6,'(I0,A)') mype,': reading ensemble data in parallel is done (parallelization_over_ensmembers=.true.)' @@ -390,47 +406,129 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) endif ! ! READ ENEMBLE MEMBERS DATA + ! + ! There are three options to control the list of variables that + ! will be read in along with the basic variables, ps,u,v,tv,rh,oz. + + ! parallelization_over_ensmembers=.True. only works for cases when l_use_dbz_directDA=.False. + ! Noted that l_use_dbz_directDA and if_modle_dbz couldn't be true at the same time + + ! + ! I_CASEFLAG defination + ! + + ! default: all the three options ( l_use_dbz_directDA, if_model_dbz, if_model_fed) are turned off .i.e., + ! if(.not. (l_use_dbz_directDA .or. if_model_dbz .or. if_model_fed )) + ! read in ps,u,v,tv,rh,oz + i_caseflag=0 + + ! only l_use_dbz_directDA is true + if (l_use_dbz_directDA .and. .not.if_model_dbz .and. .not.if_model_fed) i_caseflag=1 + + ! only if_model_dbz is true + if(.not.l_use_dbz_directDA .and. if_model_dbz .and. .not.if_model_fed) i_caseflag=2 + + ! only if_model_fed is true + if(.not.l_use_dbz_directDA .and. .not.if_model_dbz .and. .not.if_model_fed) i_caseflag=3 + + ! l_use_dbz_directDA=.true. and if_model_fed=.true. + if(l_use_dbz_directDA .and. .not.if_model_dbz .and. if_model_fed) i_caseflag=4 + + ! if_model_dbz=.true. and if_model_fed=.true. + if(.not. l_use_dbz_directDA.and. if_model_dbz .and. if_model_fed) i_caseflag=5 + + + !-------------------------------------------------- + ! When .not. parallelization_over_ensmembers=.True. + ! All the above 6 cases (i_caseflag=0,1,2,3,4,5) are valid in + ! the current applications as of Oct 20 2023. + + !-------------------------------------------- + ! When parallelization_over_ensmembers=.True. + ! Only i_flagcase=0,2,3,5 are vaild choices. + + if( .not. parallelization_over_ensmembers )then if (mype == 0) write(6,'(a,a)') & 'CALL READ_FV3_REGIONAL_ENSPERTS FOR ENS DATA with the filename str : ',trim(ensfilenam_str) - if (.not. (l_use_dbz_directDA .or. if_model_dbz) ) then ! Read additional hydrometers and w for dirZDA - call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz) - else - if( l_use_dbz_directDA ) then - call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz, & - g_ql=ql,g_qi=qi,g_qr=qr,g_qs=qs,g_qg=qg,g_qnr=qnr,g_w=w) - else if( if_model_dbz )then - call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz, & - g_ql=ql,g_qi=qi,g_qr=qr,g_qs=qs,g_qg=qg,g_qnr=qnr,g_w=w,g_dbz=dbz) - end if - end if + + select case (i_caseflag) + case (0) + call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz) + case (1) + call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz, & + g_ql=ql,g_qi=qi,g_qr=qr,g_qs=qs,g_qg=qg,g_qnr=qnr,g_w=w) + case (2) + call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz, & + g_ql=ql,g_qi=qi,g_qr=qr,g_qs=qs,g_qg=qg,g_qnr=qnr,g_w=w,g_dbz=dbz) + case (3) + call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz, & + g_ql=ql,g_qi=qi,g_qr=qr,g_qs=qs,g_qg=qg,g_w=w,g_fed=fed) + case (4) + call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz, & + g_ql=ql,g_qi=qi,g_qr=qr,g_qs=qs,g_qg=qg,g_qnr=qnr,g_w=w,g_fed=fed) + case (5) + call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz, & + g_ql=ql,g_qi=qi,g_qr=qr,g_qs=qs,g_qg=qg,g_qnr=qnr,g_w=w,g_dbz=dbz,g_fed=fed) + end select end if - + if( parallelization_over_ensmembers )then iope=(n_fv3sar-1)*npe/n_ens_fv3sar if(mype==iope) then write(0,'(I0,A,I0,A)') mype,': scatter member ',n_fv3sar,' to other ranks...' - if( if_model_dbz )then - call this%parallel_read_fv3_step2(mype,iope,& + select case (i_caseflag) + case (0) + call this%parallel_read_fv3_step2(mype,iope,& + g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,g_oz=oz, & + gg_ps=gg_ps,gg_tv=gg_tv,gg_u=gg_u,gg_v=gg_v,gg_rh=gg_rh) + case (2) + call this%parallel_read_fv3_step2(mype,iope,& g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,& g_oz=oz,g_w=w,g_qr=qr,g_qs=qs,g_qi=qi,g_qg=qg,g_dbz=dbz,& gg_ps=gg_ps,gg_tv=gg_tv,gg_u=gg_u,gg_v=gg_v,& gg_rh=gg_rh,gg_w=gg_w,gg_dbz=gg_dbz,gg_qr=gg_qr,& gg_qs=gg_qs,gg_qi=gg_qi,gg_qg=gg_qg,gg_ql=gg_cwmr) - else - call this%parallel_read_fv3_step2(mype,iope,& - g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,g_oz=oz, & - gg_ps=gg_ps,gg_tv=gg_tv,gg_u=gg_u,gg_v=gg_v,gg_rh=gg_rh) - end if + case (3) + call this%parallel_read_fv3_step2(mype,iope,& + g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,& + g_oz=oz,g_w=w,g_qr=qr,g_qs=qs,g_qi=qi,g_qg=qg,g_fed=fed,& + gg_ps=gg_ps,gg_tv=gg_tv,gg_u=gg_u,gg_v=gg_v,& + gg_rh=gg_rh,gg_w=gg_w,gg_fed=gg_fed,gg_qr=gg_qr,& + gg_qs=gg_qs,gg_qi=gg_qi,gg_qg=gg_qg,gg_ql=gg_cwmr) + case (5) + call this%parallel_read_fv3_step2(mype,iope,& + g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,& + g_oz=oz,g_w=w,g_qr=qr,g_qs=qs,g_qi=qi,g_qg=qg,g_dbz=dbz,g_fed=fed,& + gg_ps=gg_ps,gg_tv=gg_tv,gg_u=gg_u,gg_v=gg_v,& + gg_rh=gg_rh,gg_w=gg_w,gg_dbz=gg_dbz,gg_fed=gg_fed,gg_qr=gg_qr,& + gg_qs=gg_qs,gg_qi=gg_qi,gg_qg=gg_qg,gg_ql=gg_cwmr) + case (1,4) + write(6,*)'i_case_flag=1 or 4 is not a valid choice for parallelization_over_ensmembers=.T. Stop(8880) ' + call stop2(8880) + end select else - if( if_model_dbz )then - call this%parallel_read_fv3_step2(mype,iope,& + select case (i_caseflag) + case (0) + call this%parallel_read_fv3_step2(mype,iope,& + g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,g_oz=oz) + case (2) + call this%parallel_read_fv3_step2(mype,iope,& g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,& g_oz=oz,g_w=w,g_qr=qr,g_qs=qs,g_qi=qi,g_qg=qg,g_dbz=dbz) - else - call this%parallel_read_fv3_step2(mype,iope,& - g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,g_oz=oz) - endif + case (3) + call this%parallel_read_fv3_step2(mype,iope,& + g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,& + g_oz=oz,g_w=w,g_qr=qr,g_qs=qs,g_qi=qi,g_qg=qg,g_fed=fed) + case (5) + call this%parallel_read_fv3_step2(mype,iope,& + g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,& + g_oz=oz,g_w=w,g_qr=qr,g_qs=qs,g_qi=qi,g_qg=qg,g_dbz=dbz,g_fed=fed) + case (1,4) + write(6,*)'i_case_flag=1 or 4 is not a valid choice for parallelization_over_ensmembers=.T. Stop(8880) ' + call stop2(8880) + end select + endif call MPI_Barrier(mpi_comm_world,ierror) @@ -601,6 +699,16 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) end do end do end do + + case('fed','FED') + do k=1,grd_ens%nsig + do i=1,grd_ens%lon2 + do j=1,grd_ens%lat2 + w3(j,i,k) = fed(j,i,k) + x3(j,i,k)=x3(j,i,k)+fed(j,i,k) + end do + end do + end do end select @@ -709,7 +817,7 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) end subroutine get_fv3_regional_ensperts_run subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g_rh,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,g_qnr,g_w,g_dbz) + g_ql,g_qi,g_qr,g_qs,g_qg,g_qnr,g_w,g_dbz,g_fed) !$$$ subprogram documentation block ! first compied from general_read_arw_regional . . . . ! subprogram: general_read_fv3_regional read fv3sar model ensemble members @@ -760,7 +868,7 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g use hybrid_ensemble_parameters, only: grd_ens use directDA_radaruse_mod, only: l_use_cvpqx, cvpqx_pval, cld_nt_updt use directDA_radaruse_mod, only: l_cvpnr, cvpnr_pval - use obsmod, only:if_model_dbz + use obsmod, only:if_model_dbz,if_model_fed implicit none @@ -769,7 +877,7 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g class(get_fv3_regional_ensperts_class), intent(inout) :: this type (type_fv3regfilenameg) , intent (in) :: fv3_filenameginput real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),intent(out)::g_u,g_v,g_tv,g_rh,g_oz - real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),optional,intent(out)::g_ql,g_qi,g_qr,g_dbz + real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),optional,intent(out)::g_ql,g_qi,g_qr,g_dbz,g_fed real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),optional,intent(out)::g_qs,g_qg,g_qnr,g_w real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2),intent(out):: g_ps @@ -857,7 +965,7 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g fv3_filenameginput%dynvars,fv3_filenameginput) call gsi_fv3ncdf_read(grd_fv3lam_ens_tracer_io_nouv,gsibundle_fv3lam_ens_tracer_nouv,& fv3_filenameginput%tracers,fv3_filenameginput) - if( if_model_dbz ) then + if( if_model_dbz .or. if_model_fed ) then call gsi_fv3ncdf_read(grd_fv3lam_ens_phyvar_io_nouv,gsibundle_fv3lam_ens_phyvar_nouv,& fv3_filenameginput%phyvars,fv3_filenameginput) end if @@ -869,9 +977,9 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g endif ier=0 call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_dynvar_nouv, 'tsen' ,g_tsen ,istatus );ier=ier+istatus - call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'q' ,g_q ,istatus );ier=ier+istatus - call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'oz' ,g_oz ,istatus );ier=ier+istatus - if (l_use_dbz_directDA .or. if_model_dbz) then + call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'q' ,g_q ,istatus );ier=ier+istatus + call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'oz' ,g_oz ,istatus );ier=ier+istatus + if (l_use_dbz_directDA .or. if_model_dbz .or. if_model_fed) then call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'ql' ,g_ql ,istatus );ier=ier+istatus call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'qi' ,g_qi ,istatus );ier=ier+istatus call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'qr' ,g_qr ,istatus );ier=ier+istatus @@ -882,6 +990,8 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_dynvar_nouv, 'w' , g_w ,istatus );ier=ier+istatus if( if_model_dbz )& call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_phyvar_nouv, 'dbz' , g_dbz ,istatus );ier=ier+istatus + if( if_model_fed )& + call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_phyvar_nouv, 'fed' , g_fed, istatus );ier=ier+istatus end if @@ -990,7 +1100,7 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g end subroutine general_read_fv3_regional subroutine general_read_fv3_regional_parallel_over_ens(this,iope,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g_rh,g_oz, & - g_ql,g_qi,g_qr,g_qs,g_qg,g_qnr,g_w,g_dbz) + g_ql,g_qi,g_qr,g_qs,g_qg,g_qnr,g_w,g_dbz,g_fed) !$$$ subprogram documentation block ! first compied from general_read_arw_regional . . . . ! subprogram: general_read_fv3_regional read fv3sar model ensemble members @@ -1039,7 +1149,7 @@ subroutine general_read_fv3_regional_parallel_over_ens(this,iope,fv3_filenamegin use gsi_bundlemod, only: gsi_grid use gsi_bundlemod, only: gsi_bundlecreate,gsi_bundledestroy use gsi_bundlemod, only: gsi_bundlegetvar - use obsmod, only: if_model_dbz + use obsmod, only: if_model_dbz,if_model_fed use gsi_rfv3io_mod, only: gsi_fv3ncdf_read_ens_parallel_over_ens,gsi_fv3ncdf_readuv_ens_parallel_over_ens @@ -1051,7 +1161,7 @@ subroutine general_read_fv3_regional_parallel_over_ens(this,iope,fv3_filenamegin integer(i_kind), intent (in) :: iope type (type_fv3regfilenameg) , intent (in) :: fv3_filenameginput real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig),intent(out)::g_u,g_v,g_tv,g_rh,g_oz - real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig),optional,intent(out)::g_ql,g_qi,g_qr,g_dbz + real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig),optional,intent(out)::g_ql,g_qi,g_qr,g_dbz,g_fed real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig),optional,intent(out)::g_qs,g_qg,g_qnr,g_w real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon),intent(out):: g_ps @@ -1102,11 +1212,17 @@ subroutine general_read_fv3_regional_parallel_over_ens(this,iope,fv3_filenamegin endif if(fv3sar_ensemble_opt == 0) then - if (if_model_dbz) then + if (if_model_dbz .or. if_model_fed) then call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%dynvars,fv3_filenameginput,delp=g_delp,tsen=g_tsen,w=g_w,iope=iope) call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%tracers,fv3_filenameginput,q=g_q,oz=g_oz,ql=g_ql,qr=g_qr,& qs=g_qs,qi=g_qi,qg=g_qg,iope=iope) - call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%phyvars,fv3_filenameginput,dbz=g_dbz,iope=iope) + if(if_model_dbz .and. if_model_fed) then + call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%phyvars,fv3_filenameginput,dbz=g_dbz,fed=g_fed,iope=iope) + elseif(if_model_dbz) then + call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%phyvars,fv3_filenameginput,dbz=g_dbz,iope=iope) + elseif(if_model_fed) then + call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%phyvars,fv3_filenameginput,fed=g_fed,iope=iope) + end if else call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%dynvars,fv3_filenameginput,delp=g_delp,tsen=g_tsen,iope=iope) call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%tracers,fv3_filenameginput,q=g_q,oz=g_oz,iope=iope) @@ -1169,8 +1285,8 @@ end subroutine general_read_fv3_regional_parallel_over_ens subroutine parallel_read_fv3_step2(this,mype,iope, & g_ps,g_u,g_v,g_tv,g_rh,g_ql,g_oz,g_w,g_qr,g_qs,g_qi,& - g_qg,g_dbz, & - gg_ps,gg_tv,gg_u,gg_v,gg_rh,gg_w,gg_dbz,gg_qr,& + g_qg,g_dbz,g_fed, & + gg_ps,gg_tv,gg_u,gg_v,gg_rh,gg_w,gg_dbz,gg_fed,gg_qr,& gg_qs,gg_qi,gg_qg,gg_ql) !$$$ subprogram documentation block @@ -1210,7 +1326,7 @@ subroutine parallel_read_fv3_step2(this,mype,iope, & real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),intent(out):: & g_u,g_v,g_tv,g_rh,g_ql,g_oz real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),intent(out),optional::& - g_w,g_qr,g_qs,g_qi,g_qg,g_dbz + g_w,g_qr,g_qs,g_qi,g_qg,g_dbz,g_fed integer(i_kind), intent(in) :: mype, iope real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2),intent(out):: g_ps @@ -1219,7 +1335,7 @@ subroutine parallel_read_fv3_step2(this,mype,iope, & gg_u,gg_v,gg_tv,gg_rh real(r_kind),optional,dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig) :: & - gg_w,gg_dbz,gg_qr,gg_qs,gg_qi,gg_qg,gg_ql + gg_w,gg_dbz,gg_fed,gg_qr,gg_qs,gg_qi,gg_qg,gg_ql real(r_kind),optional,dimension(grd_ens%nlat,grd_ens%nlon):: gg_ps ! Declare local variables @@ -1250,13 +1366,10 @@ subroutine parallel_read_fv3_step2(this,mype,iope, & if (mype==iope) call this%fill_regional_2d(gg_rh(1,1,k),wrk_send_2d) call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & g_rh(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) - if( present(g_dbz) )then + if( present(g_dbz) .or. present(g_fed) )then if (mype==iope) call this%fill_regional_2d(gg_w(1,1,k),wrk_send_2d) call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, & g_w(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) - if (mype==iope) call this%fill_regional_2d(gg_dbz(1,1,k),wrk_send_2d) - call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype,& - g_dbz(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) if (mype==iope) call this%fill_regional_2d(gg_qr(1,1,k),wrk_send_2d) call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype,& g_qr(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) @@ -1272,6 +1385,16 @@ subroutine parallel_read_fv3_step2(this,mype,iope, & if (mype==iope) call this%fill_regional_2d(gg_ql(1,1,k),wrk_send_2d) call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype,& g_ql(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) + if( present(g_dbz)) then + if (mype==iope) call this%fill_regional_2d(gg_dbz(1,1,k),wrk_send_2d) + call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype,& + g_dbz(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) + end if + if( present(g_fed)) then + if (mype==iope) call this%fill_regional_2d(gg_fed(1,1,k),wrk_send_2d) + call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype,& + g_fed(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror) + end if end if enddo deallocate(wrk_send_2d) diff --git a/src/gsi/gsi_fedOper.F90 b/src/gsi/gsi_fedOper.F90 index b2b2400ff0..e704a1c056 100644 --- a/src/gsi/gsi_fedOper.F90 +++ b/src/gsi/gsi_fedOper.F90 @@ -9,6 +9,7 @@ module gsi_fedOper ! 2023-07-10 D. Dowell - created new module for FED (flash extent ! density); gsi_dbzOper.F90 code used as a ! starting point for developing this new module +! 2023-08-24 H. Wang - Turned on intfed and stpfed ! ! input argument list: see Fortran 90 style document below ! @@ -128,6 +129,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass, last_pass) end subroutine setup_ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) + use intfedmod, only: intjo => intfed use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors use m_obsNode , only: obsNode @@ -145,9 +147,14 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) character(len=*),parameter:: myname_=myname//"::intjo1_" class(obsNode),pointer:: headNode + headNode => obsLList_headNode(self%obsLL(ibin)) + call intjo(headNode, rval,sval) + headNode => null() + end subroutine intjo1_ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) + use stpfedmod, only: stpjo => stpfed use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors use m_obsNode , only: obsNode @@ -169,6 +176,9 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) character(len=*),parameter:: myname_=myname//"::stpjo1_" class(obsNode),pointer:: headNode + headNode => obsLList_headNode(self%obsLL(ibin)) + call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + headNode => null() end subroutine stpjo1_ end module gsi_fedOper diff --git a/src/gsi/gsi_files.cmake b/src/gsi/gsi_files.cmake index b514e11c1e..5a7d29c208 100644 --- a/src/gsi/gsi_files.cmake +++ b/src/gsi/gsi_files.cmake @@ -274,6 +274,7 @@ intaod.f90 intcldch.f90 intco.f90 intdbz.f90 +intfed.f90 intdw.f90 intgps.f90 intgust.f90 @@ -594,6 +595,7 @@ stpcalc.f90 stpcldch.f90 stpco.f90 stpdbz.f90 +stpfed.f90 stpdw.f90 stpgps.f90 stpgust.f90 diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index d0cbd3afbd..e62cc06f2b 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -97,7 +97,7 @@ module gsi_rfv3io_mod type(sub2grid_info) :: grd_fv3lam_tracersmoke_ionouv type(sub2grid_info) :: grd_fv3lam_phyvar_ionouv type(sub2grid_info) :: grd_fv3lam_uv - integer(i_kind) ,parameter:: ndynvarslist=13, ntracerslist=8, nphyvarslist=1 + integer(i_kind) ,parameter:: ndynvarslist=13, ntracerslist=8, nphyvarslist=2 character(len=max_varname_length), dimension(ndynvarslist), parameter :: & vardynvars = [character(len=max_varname_length) :: & @@ -106,13 +106,13 @@ module gsi_rfv3io_mod vartracers = [character(len=max_varname_length) :: & 'q','oz','ql','qi','qr','qs','qg','qnr',aeronames_cmaq_fv3,'pm25at','pm25ac','pm25co','pm2_5','amassi','amassj','amassk',aeronames_smoke_fv3] character(len=max_varname_length), dimension(nphyvarslist), parameter :: & - varphyvars = [character(len=max_varname_length) :: 'dbz'] - character(len=max_varname_length), dimension(16+naero_cmaq_fv3+7+naero_smoke_fv3), parameter :: & + varphyvars = [character(len=max_varname_length) :: 'dbz','fed'] + character(len=max_varname_length), dimension(16+naero_cmaq_fv3+7+naero_smoke_fv3+1), parameter :: & varfv3name = [character(len=max_varname_length) :: & - 'u','v','W','T','delp','sphum','o3mr','liq_wat','ice_wat','rainwat','snowwat','graupel','rain_nc','ref_f3d','ps','DZ', & + 'u','v','W','T','delp','sphum','o3mr','liq_wat','ice_wat','rainwat','snowwat','graupel','rain_nc','ref_f3d','flash_extent_density','ps','DZ', & aeronames_cmaq_fv3,'pm25at','pm25ac','pm25co','pm2_5','amassi','amassj','amassk',aeronames_smoke_fv3], & vgsiname = [character(len=max_varname_length) :: & - 'u','v','w','tsen','delp','q','oz','ql','qi','qr','qs','qg','qnr','dbz','ps','delzinc', & + 'u','v','w','tsen','delp','q','oz','ql','qi','qr','qs','qg','qnr','dbz','fed','ps','delzinc', & aeronames_cmaq_fv3,'pm25at','pm25ac','pm25co','pm2_5','amassi','amassj','amassk',aeronames_smoke_fv3] character(len=max_varname_length),dimension(:),allocatable:: name_metvars2d character(len=max_varname_length),dimension(:),allocatable:: name_metvars3d @@ -801,7 +801,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) use gsi_metguess_mod, only: gsi_metguess_get use netcdf, only:nf90_open,nf90_close,nf90_inquire,nf90_nowrite, nf90_format_netcdf4 use gsi_chemguess_mod, only: gsi_chemguess_get - use obsmod, only: if_model_dbz + use obsmod, only: if_model_dbz,if_model_fed implicit none @@ -809,7 +809,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) integer(i_kind) :: it character(len=24),parameter :: myname = 'read_fv3_netcdf_guess' integer(i_kind) k,i,j - integer(i_kind) ier,istatus + integer(i_kind) ier,istatus,ivar real(r_kind),dimension(:,:),pointer::ges_ps=>NULL() real(r_kind),dimension(:,:),pointer::ges_ps_readin=>NULL() real(r_kind),dimension(:,:),pointer::ges_z=>NULL() @@ -833,6 +833,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) real(r_kind),dimension(:,:,:),pointer::ges_qnr=>NULL() real(r_kind),dimension(:,:,:),pointer::ges_w=>NULL() real(r_kind),dimension(:,:,:),pointer::ges_dbz=>NULL() + real(r_kind),dimension(:,:,:),pointer::ges_fed=>NULL() real(r_kind),dimension(:,:,:),pointer::ges_aalj=>NULL() real(r_kind),dimension(:,:,:),pointer::ges_acaj=>NULL() @@ -1016,12 +1017,13 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) write(6,*)"the set up for met variable is not as expected, abort" call stop2(222) endif - if ( if_model_dbz ) then - if( nphyvario3d<=0 ) then - write(6,*)"the set up for met variable (phyvar) is not as expected, abort" - call stop2(223) - end if - endif + + ivar=0 ; if (if_model_dbz) ivar=ivar+1; if(if_model_fed) ivar=ivar+1 + if ( ivar > nphyvario3d ) then + write(6,*)"the set up for met variable (dbz and fed in phyvar) is not as expected,abort" + call stop2(223) + end if + if (fv3sar_bg_opt == 0.and.ifindstrloc(name_metvars3d,'delp') <= 0)then ndynvario3d=ndynvario3d+1 ! for delp endif @@ -1217,7 +1219,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) ntracerio2d=0 endif - if( if_model_dbz )then + if( allocated(fv3lam_io_phymetvars3d_nouv) )then call gsi_bundlecreate(gsibundle_fv3lam_phyvar_nouv,GSI_MetGuess_Bundle(it)%grid,'gsibundle_fv3lam_phyvar_nouv',istatus, & names3d=fv3lam_io_phymetvars3d_nouv) end if @@ -1311,7 +1313,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) endif - if ( if_model_dbz )then + if ( if_model_dbz .or. if_model_fed )then inner_vars=1 numfields=inner_vars*(nphyvario3d*grd_a%nsig) deallocate(lnames,names) @@ -1352,7 +1354,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'tv' ,ges_tv ,istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'q' ,ges_q ,istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'oz' ,ges_oz ,istatus );ier=ier+istatus - if (l_use_dbz_directDA .or. if_model_dbz) then + if (l_use_dbz_directDA .or. nphyvario3d > 0) then call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'ql' ,ges_ql ,istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qi' ,ges_qi ,istatus );ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qr' ,ges_qr ,istatus );ier=ier+istatus @@ -1365,6 +1367,8 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) end if if(if_model_dbz) & call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'dbz' , ges_dbz ,istatus );ier=ier+istatus + if(if_model_fed) & + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'fed' , ges_fed ,istatus );ier=ier+istatus end if if (ier/=0) call die(trim(myname),'cannot get pointers for fv3 met-fields, ier =',ier) @@ -1427,7 +1431,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) & ,fv3filenamegin(it)%dynvars,fv3filenamegin(it)) call gsi_fv3ncdf_read(grd_fv3lam_tracer_ionouv,gsibundle_fv3lam_tracer_nouv & & ,fv3filenamegin(it)%tracers,fv3filenamegin(it)) - if( if_model_dbz )then + if( nphyvario3d > 0 )then call gsi_fv3ncdf_read(grd_fv3lam_phyvar_ionouv,gsibundle_fv3lam_phyvar_nouv & & ,fv3filenamegin(it)%phyvars,fv3filenamegin(it)) end if @@ -1526,8 +1530,9 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) if (laeroana_fv3smoke) then call gsi_copy_bundle(gsibundle_fv3lam_tracersmoke_nouv,GSI_ChemGuess_Bundle(it)) endif - - if(if_model_dbz) call gsi_copy_bundle(gsibundle_fv3lam_phyvar_nouv,GSI_MetGuess_Bundle(it)) + if ( nphyvario3d > 0 ) then + call gsi_copy_bundle(gsibundle_fv3lam_phyvar_nouv,GSI_MetGuess_Bundle(it)) + end if call GSI_BundleGetPointer ( gsibundle_fv3lam_dynvar_nouv, 'tsen' ,ges_tsen_readin ,istatus );ier=ier+istatus !! tsen2tv !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! do k=1,nsig @@ -2354,7 +2359,7 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) countloc=(/nxcase,nycase,1/) ! Variable ref_f3d in phy_data.nc has a smaller domain size than ! dynvariables and tracers as well as a reversed order in vertical - if ( trim(adjustl(varname)) == 'ref_f3d' )then + if ( trim(adjustl(varname)) == 'ref_f3d' .or. trim(adjustl(varname)) == 'flash_extent_density' )then iret=nf90_inquire_dimension(gfile_loc,1,name,len) if(trim(name)=='xaxis_1') nx_phy=len if( nx_phy == nxcase )then @@ -2380,7 +2385,7 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) enddo else iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname)),var_id) - if ( trim(adjustl(varname)) == 'ref_f3d' )then + if ( trim(adjustl(varname)) == 'ref_f3d'.or. trim(adjustl(varname)) == 'flash_extent_density' )then uu2d = 0.0_r_kind iret=nf90_get_var(gfile_loc,var_id,uu2d_tmp,start=startloc_tmp,count=countloc_tmp) where(uu2d_tmp < 0.0_r_kind) @@ -2845,7 +2850,7 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin) end subroutine gsi_fv3ncdf_readuv_v1 subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & - delp,tsen,w,q,oz,ql,qr,qs,qi,qg,dbz,iope) + delp,tsen,w,q,oz,ql,qr,qs,qi,qg,dbz,fed,iope) !$$$ subprogram documentation block ! . . . . ! subprogram: gsi_fv3ncdf_read_ens_parallel_over_ens @@ -2887,7 +2892,7 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & integer(i_kind) ,intent(in ) :: iope 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 + 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 @@ -2932,11 +2937,18 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & varname_files = (/'sphum',' o3mr'/) end if end if - if( present(dbz) )then ! phyvars: dbz + if( present(dbz) .and. present(fed) )then ! phyvars: dbz, fed + allocate(varname_files(2)) + varname_files = (/'ref_f3d ','flash_extent_density'/) + elseif( present(dbz) )then ! phyvars: dbz allocate(varname_files(1)) varname_files = (/'ref_f3d'/) + elseif( present(fed) )then ! phyvars: fed + allocate(varname_files(1)) + varname_files = (/'flash_extent_density'/) end if + if(fv3_io_layout_y > 1) then allocate(gfile_loc_layout(0:fv3_io_layout_y-1)) do nio=0,fv3_io_layout_y-1 @@ -2967,7 +2979,7 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & varname = trim(varname_files(ivar)) ! Variable ref_f3d in phy_data.nc has a smaller domain size than ! dynvariables and tracers as well as a reversed order in vertical - if ( trim(adjustl(varname)) == 'ref_f3d' )then + if ( trim(adjustl(varname)) == 'ref_f3d' .or. trim(adjustl(varname)) == 'flash_extent_density' )then iret=nf90_inquire_dimension(gfile_loc,1,name,len) if(trim(name)=='xaxis_1') nx_phy=len if( nx_phy == nxcase )then @@ -2993,7 +3005,7 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & enddo else iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname)),var_id) - if ( trim(adjustl(varname)) == 'ref_f3d' )then + if ( trim(adjustl(varname)) == 'ref_f3d' .or. trim(adjustl(varname)) == 'flash_extent_density' )then uu2d = 0.0_r_kind iret=nf90_get_var(gfile_loc,var_id,uu2d_tmp,start=startloc_tmp,count=countloc_tmp) where(uu2d_tmp < 0.0_r_kind) @@ -3041,8 +3053,13 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & end if end if end if - if( present(dbz) )then ! phyvars: dbz + if( present(dbz) .and. present(fed) )then ! phyvars: dbz,fed + if(ivar == 1) dbz = hwork + if(ivar == 2) fed = hwork + elseif( present(dbz) )then ! phyvars: dbz dbz = hwork + elseif( present(fed) )then ! phyvars: fed + fed = hwork end if end do @@ -3271,7 +3288,7 @@ subroutine wrfv3_netcdf(fv3filenamegin) use directDA_radaruse_mod, only: l_cvpnr, cvpnr_pval use gridmod, only: eta1_ll,eta2_ll use constants, only: one - use obsmod, only: if_model_dbz + use obsmod, only: if_model_dbz,if_model_fed implicit none @@ -3299,6 +3316,7 @@ subroutine wrfv3_netcdf(fv3filenamegin) real(r_kind),pointer,dimension(:,:,:):: ges_qnr =>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_w =>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_dbz =>NULL() + real(r_kind),pointer,dimension(:,:,:):: ges_fed =>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_delzinc =>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_delp =>NULL() real(r_kind),dimension(:,: ),allocatable:: ges_ps_write @@ -3388,7 +3406,7 @@ subroutine wrfv3_netcdf(fv3filenamegin) call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'u' , ges_u ,istatus);ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'v' , ges_v ,istatus);ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'q' ,ges_q ,istatus);ier=ier+istatus - if (l_use_dbz_directDA .or. if_model_dbz) then + if (l_use_dbz_directDA .or. if_model_dbz .or.if_model_fed) then call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'ql' ,ges_ql ,istatus);ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qi' ,ges_qi ,istatus);ier=ier+istatus call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qr' ,ges_qr ,istatus);ier=ier+istatus @@ -3399,6 +3417,8 @@ subroutine wrfv3_netcdf(fv3filenamegin) call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'w' , ges_w ,istatus);ier=ier+istatus if( if_model_dbz )& call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'dbz' , ges_dbz ,istatus);ier=ier+istatus + if( if_model_fed )& + call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'fed' , ges_fed ,istatus);ier=ier+istatus end if if(i_use_2mq4b > 0 .and. i_use_2mt4b > 0 ) then call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'q2m',ges_q2m,istatus); ier=ier+istatus @@ -3532,7 +3552,7 @@ subroutine wrfv3_netcdf(fv3filenamegin) call gsi_copy_bundle(GSI_MetGuess_Bundle(it),gsibundle_fv3lam_dynvar_nouv) call gsi_copy_bundle(GSI_MetGuess_Bundle(it),gsibundle_fv3lam_tracer_nouv) - if( if_model_dbz ) call gsi_copy_bundle(GSI_MetGuess_Bundle(it),gsibundle_fv3lam_phyvar_nouv) + if( if_model_dbz .or. if_model_fed ) call gsi_copy_bundle(GSI_MetGuess_Bundle(it),gsibundle_fv3lam_phyvar_nouv) if (laeroana_fv3cmaq) then call gsi_copy_bundle(GSI_ChemGuess_Bundle(it),gsibundle_fv3lam_tracerchem_nouv) end if @@ -3581,10 +3601,11 @@ subroutine wrfv3_netcdf(fv3filenamegin) add_saved,fv3filenamegin%dynvars,fv3filenamegin) call gsi_fv3ncdf_write(grd_fv3lam_tracer_ionouv,gsibundle_fv3lam_tracer_nouv, & add_saved,fv3filenamegin%tracers,fv3filenamegin) - if( if_model_dbz ) then + if( if_model_dbz .or. if_model_fed ) then call gsi_fv3ncdf_write(grd_fv3lam_phyvar_ionouv,gsibundle_fv3lam_phyvar_nouv,& add_saved,fv3filenamegin%phyvars,fv3filenamegin) end if + call gsi_fv3ncdf_writeuv(grd_fv3lam_uv,ges_u,ges_v,add_saved,fv3filenamegin) if (laeroana_fv3cmaq) then call gsi_fv3ncdf_write(grd_fv3lam_tracerchem_ionouv,gsibundle_fv3lam_tracerchem_nouv, & @@ -4343,7 +4364,7 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file work_a=hwork(1,:,:,ilevtot) - if( trim(varname) == 'ref_f3d' )then + if( trim(varname) == 'ref_f3d' .or. trim(adjustl(varname)) == 'flash_extent_density' )then iret=nf90_inquire_dimension(gfile_loc,1,name,len) if(trim(name)=='xaxis_1') nx_phy=len if( nx_phy == nxcase )then @@ -4386,7 +4407,7 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file deallocate(work_b_layout) enddo else - if( trim(varname) == 'ref_f3d' )then + if( trim(varname) == 'ref_f3d' .or. trim(varname) == 'flash_extent_density' )then work_b = 0.0_r_kind call check( nf90_get_var(gfile_loc,VarId,work_b_tmp,start = startloc_tmp, count = countloc_tmp) ) where(work_b_tmp < 0.0_r_kind) @@ -4419,7 +4440,7 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file deallocate(work_b_layout) enddo else - if( trim(varname) == 'ref_f3d' )then + if( trim(varname) == 'ref_f3d' .or. trim(varname) == 'flash_extent_density' )then if(phy_smaller_domain)then work_b_tmp = work_b(4:nxcase-3,4:nycase-3) else diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index d0ca1c0fbf..5a06eff27a 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -23,12 +23,13 @@ module gsimod use gsi_dbzOper, only: diag_radardbz use gsi_fedOper, only: diag_fed - use obsmod, only: doradaroneob,oneoblat,oneoblon,oneobheight,oneobvalue,oneobddiff,oneobradid,& + use obsmod, only: doradaroneob,dofedoneob,oneoblat,oneoblon,oneobheight,oneobvalue,oneobddiff,oneobradid,& radar_no_thinning,ens_hx_dbz_cut,static_gsi_nopcp_dbz,rmesh_dbz,& - rmesh_vr,zmesh_dbz,zmesh_vr,if_vterminal, if_model_dbz,if_vrobs_raw,if_use_w_vr,& + rmesh_vr,zmesh_dbz,zmesh_vr,if_vterminal, if_model_dbz,if_model_fed,innov_use_model_fed,if_vrobs_raw,if_use_w_vr,& minobrangedbz,maxobrangedbz,maxobrangevr,maxtiltvr,missing_to_nopcp,& ntilt_radarfiles,whichradar,& - minobrangevr,maxtiltdbz,mintiltvr,mintiltdbz,l2rwthin,hurricane_radar + minobrangevr,maxtiltdbz,mintiltvr,mintiltdbz,l2rwthin,hurricane_radar,& + r_hgt_fed use obsmod, only: lwrite_predterms, & lwrite_peakwt,use_limit,lrun_subdirs,l_foreaft_thin,lobsdiag_forenkf,& @@ -202,7 +203,7 @@ module gsimod use gsi_nstcouplermod, only: gsi_nstcoupler_init_nml use gsi_nstcouplermod, only: nst_gsi,nstinfo,zsea1,zsea2,fac_dtl,fac_tsl use ncepnems_io, only: init_nems,imp_physics,lupp - use wrf_vars_mod, only: init_wrf_vars + use wrf_vars_mod, only: init_wrf_vars,fed_exist,dbz_exist use gsi_rfv3io_mod,only : fv3sar_bg_opt use radarz_cst, only: mphyopt, MFflg use radarz_iface, only: init_mphyopt @@ -510,6 +511,15 @@ module gsimod ! 2023-07-30 Zhao - added namelist options for analysis of significant wave height ! (aka howv in GSI code): corp_howv, hwllp_howv ! (in namelist session rapidrefresh_cldsurf) +! +! 2023-09-14 H. Wang - add namelist option for FED EnVar DA. +! - if_model_fed=.true. : FED in background and ens. If +! perform FED DA, this has to be true along with fed in +! control/analysis and metguess vectors. If only run GSI observer, +! it can be false. +! - innov_use_model_fed=.true. : Use FED from BG to calculate innovation. +! this requires if_model_fed=.true. +! it works either an EnVar DA run or a GSI observer run. ! !EOP !------------------------------------------------------------------------- @@ -770,16 +780,17 @@ module gsimod use_sp_eqspace,lnested_loops,lsingleradob,thin4d,use_readin_anl_sfcmask,& luse_obsdiag,id_drifter,id_ship,verbose,print_obs_para,lsingleradar,singleradar,lnobalance, & missing_to_nopcp,minobrangedbz,minobrangedbz,maxobrangedbz,& - maxobrangevr,maxtiltvr,whichradar,doradaroneob,oneoblat,& + maxobrangevr,maxtiltvr,whichradar,doradaroneob,dofedoneob,oneoblat,& oneoblon,oneobheight,oneobvalue,oneobddiff,oneobradid,& rmesh_vr,zmesh_dbz,zmesh_vr, ntilt_radarfiles, whichradar,& radar_no_thinning,ens_hx_dbz_cut,static_gsi_nopcp_dbz,rmesh_dbz,& minobrangevr, maxtiltdbz, mintiltvr,mintiltdbz,if_vterminal,if_vrobs_raw,if_use_w_vr,& - if_model_dbz,imp_physics,lupp,netcdf_diag,binary_diag,l_wcp_cwm,aircraft_recon,diag_version,& + if_model_dbz,if_model_fed,innov_use_model_fed,imp_physics,lupp,netcdf_diag,binary_diag,l_wcp_cwm,aircraft_recon,diag_version,& write_fv3_incr,incvars_to_zero,incvars_zero_strat,incvars_efold,diag_version,& cao_check,lcalc_gfdl_cfrac,tau_fcst,efsoi_order,lupdqc,lqcoef,cnvw_option,l2rwthin,hurricane_radar,& l_reg_update_hydro_delz, l_obsprvdiag,& - l_use_dbz_directDA, l_use_rw_columntilt, ta2tb, optconv + l_use_dbz_directDA, l_use_rw_columntilt, ta2tb, optconv, & + r_hgt_fed ! GRIDOPTS (grid setup variables,including regional specific variables): ! jcap - spectral resolution @@ -1978,6 +1989,20 @@ subroutine gsimain_initialize endif endif + if (innov_use_model_fed .and. .not.if_model_fed) then + if(mype==0) write(6,*)' GSIMOD: invalid innov_use_model_fed=.true. but if_model_fed=.false.' + call die(myname_,'invalid innov_use_model_fed,if_model_fed, check namelist settings',330) + end if + + if (.not. (miter == 0 .or. lobserver) .and. if_model_fed .and. .not. fed_exist) then + if(mype==0) write(6,*)' GSIMOD: .not. (miter == 0 .or. lobserver) and if_model_fed=.true. but fed is not in anavinfo file' + call die(myname_,'Please check namelist parameters and/or add fed in anavinfo (contro/state_vector and met_guess) when miter > 0 and if_model_fed=.true.',332) + end if + + if (.not. (miter == 0 .or. lobserver) .and. if_model_dbz .and. .not. dbz_exist) then + if(mype==0) write(6,*)' GSIMOD: .not. (miter == 0 .or. lobserver) and if_model_dbz=.true. but dbz is not in anavinfo file' + call die(myname_,'Please check namelist parameters and/or add dbz in anavinfo (contro/state_vector and met_guess) when miter > 0 and if_model_fed=.true.',334) + end if ! Ensure valid number of horizontal scales if (nhscrf<0 .or. nhscrf>3) then diff --git a/src/gsi/intfed.f90 b/src/gsi/intfed.f90 new file mode 100644 index 0000000000..8cb16eba10 --- /dev/null +++ b/src/gsi/intfed.f90 @@ -0,0 +1,187 @@ +module intfedmod +!$$$ module documentation block +! . . . . +! module: intfedmod module for intfed and its tangent linear intfed_tl +! prgmmr: +! +! abstract: module for intfed and its tangent linear intfed_tl +! +! program history log: +! 2023-08-24 H. Wang - add tangent linear of fed operator to directly assimilate FED +! +! subroutines included: +! sub intfed_ +! +! variable definitions: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use m_obsNode, only: obsNode +use m_fedNode, only: fedNode +use m_fedNode, only: fedNode_typecast +use m_fedNode, only: fedNode_nextcast +use m_obsdiagNode, only: obsdiagNode_set +implicit none + +PRIVATE +PUBLIC intfed + +interface intfed; module procedure & + intfed_ +end interface + +contains + +subroutine intfed_(fedhead,rval,sval) +!$$$ subprogram documentation block +! . . . . +! subprogram: intfed apply nonlin qc operator for GLM FED +! +! abstract: apply observation operator for radar winds +! with nonlinear qc operator +! +! program history log: +! 2023-08-24 H.Wang - modified based on intdbz.f90 +! - using tangent linear fed operator + +! +! input argument list: +! fedhead - obs type pointer to obs structure +! sfed - current fed solution increment +! +! output argument list: +! rfed - fed results from fed observation operator +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,i_kind + use constants, only: half,one,tiny_r_kind,cg_term,r3600 + use obsmod, only: lsaveobsens,l_do_adjoint,luse_obsdiag + use qcmod, only: nlnqc_iter,varqc_iter + use jfunc, only: jiter + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use gsi_4dvar, only: ladtest_obs + use wrf_vars_mod, only : fed_exist + implicit none + +! Declare passed variables + class(obsNode), pointer, intent(in ) :: fedhead + type(gsi_bundle), intent(in ) :: sval + type(gsi_bundle), intent(inout) :: rval + +! Declare local variables + integer(i_kind) j1,j2,j3,j4,j5,j6,j7,j8,ier,istatus +! real(r_kind) penalty + real(r_kind) val,w1,w2,w3,w4,w5,w6,w7,w8,valfed + real(r_kind) cg_fed,p0,grad,wnotgross,wgross,pg_fed + real(r_kind),pointer,dimension(:) :: sfed + real(r_kind),pointer,dimension(:) :: rfed + type(fedNode), pointer :: fedptr + +! If no fed obs type data return + if(.not. associated(fedhead))return + +! Retrieve pointers +! Simply return if any pointer not found + ier=0 + if(fed_exist)then + call gsi_bundlegetpointer(sval,'fed',sfed,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'fed',rfed,istatus);ier=istatus+ier + else + return + end if + + if(ier/=0)return + + + fedptr => fedNode_typecast(fedhead) + do while (associated(fedptr)) + j1=fedptr%ij(1) + j2=fedptr%ij(2) + j3=fedptr%ij(3) + j4=fedptr%ij(4) + j5=fedptr%ij(5) + j6=fedptr%ij(6) + j7=fedptr%ij(7) + j8=fedptr%ij(8) + w1=fedptr%wij(1) + w2=fedptr%wij(2) + w3=fedptr%wij(3) + w4=fedptr%wij(4) + w5=fedptr%wij(5) + w6=fedptr%wij(6) + w7=fedptr%wij(7) + w8=fedptr%wij(8) + + +! Forward model + if( fed_exist )then + val = w1* sfed(j1)+w2* sfed(j2)+w3* sfed(j3)+w4* sfed(j4)+ & + w5* sfed(j5)+w6* sfed(j6)+w7* sfed(j7)+w8* sfed(j8) + end if + + if(luse_obsdiag)then + if (lsaveobsens) then + grad = val*fedptr%raterr2*fedptr%err2 + !-- fedptr%diags%obssen(jiter) = grad + call obsdiagNode_set(fedptr%diags,jiter=jiter,obssen=grad) + + else + !-- if (fedptr%luse) fedptr%diags%tldepart(jiter)=val + if (fedptr%luse) call obsdiagNode_set(fedptr%diags,jiter=jiter,tldepart=val) + endif + endif + + if (l_do_adjoint) then + if (.not. lsaveobsens) then + if( .not. ladtest_obs ) val=val-fedptr%res + +! gradient of nonlinear operator + if (nlnqc_iter .and. fedptr%pg > tiny_r_kind .and. & + fedptr%b > tiny_r_kind) then + pg_fed=fedptr%pg*varqc_iter + cg_fed=cg_term/fedptr%b + wnotgross= one-pg_fed + wgross = pg_fed*cg_fed/wnotgross + p0 = wgross/(wgross+exp(-half*fedptr%err2*val**2)) + val = val*(one-p0) + endif + + if( ladtest_obs) then + grad = val + else + grad = val*fedptr%raterr2*fedptr%err2 + end if + + endif + +! Adjoint + if(fed_exist)then + valfed = grad + rfed(j1)=rfed(j1)+w1*valfed + rfed(j2)=rfed(j2)+w2*valfed + rfed(j3)=rfed(j3)+w3*valfed + rfed(j4)=rfed(j4)+w4*valfed + rfed(j5)=rfed(j5)+w5*valfed + rfed(j6)=rfed(j6)+w6*valfed + rfed(j7)=rfed(j7)+w7*valfed + rfed(j8)=rfed(j8)+w8*valfed + end if + + endif + + !fedptr => fedptr%llpoint + fedptr => fedNode_nextcast(fedptr) + end do + return +end subroutine intfed_ + +end module intfedmod diff --git a/src/gsi/m_berror_stats_reg.f90 b/src/gsi/m_berror_stats_reg.f90 index bf9fb20674..8730e56c3b 100644 --- a/src/gsi/m_berror_stats_reg.f90 +++ b/src/gsi/m_berror_stats_reg.f90 @@ -400,7 +400,7 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt integer(i_kind) :: nrf2_td2m,nrf2_mxtm,nrf2_mitm,nrf2_pmsl,nrf2_howv,nrf2_tcamt,nrf2_lcbas,nrf2_cldch integer(i_kind) :: nrf2_uwnd10m,nrf2_vwnd10m integer(i_kind) :: nrf3_sfwter,nrf3_vpwter - integer(i_kind) :: nrf3_dbz + integer(i_kind) :: nrf3_dbz,nrf3_fed integer(i_kind) :: nrf3_ql,nrf3_qi,nrf3_qr,nrf3_qs,nrf3_qg,nrf3_qnr,nrf3_w integer(i_kind) :: inerr,istat integer(i_kind) :: nsigstat,nlatstat,isig @@ -624,6 +624,7 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt nrf3_sf =getindex(cvars3d,'sf') nrf3_vp =getindex(cvars3d,'vp') nrf3_dbz=getindex(cvars3d,'dbz') + nrf3_fed=getindex(cvars3d,'fed') nrf2_sst=getindex(cvars2d,'sst') nrf2_gust=getindex(cvars2d,'gust') nrf2_vis=getindex(cvars2d,'vis') @@ -671,6 +672,16 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt vz(:,:,nrf3_dbz)=vz(:,:,nrf3_t) endif + if( nrf3_fed>0 )then + if(.not. nrf3_t>0) then + write(6,*)'not as expect,stop' + stop + endif + corz(:,:,nrf3_fed)=10.0_r_kind + hwll(:,:,nrf3_fed)=hwll(:,:,nrf3_t) + vz(:,:,nrf3_fed)=vz(:,:,nrf3_t) + endif + if (nrf3_oz>0) then factoz = 0.0002_r_kind*r25 corz(:,:,nrf3_oz)=factoz diff --git a/src/gsi/obsmod.F90 b/src/gsi/obsmod.F90 index 633bde91ab..c43a23c1e6 100644 --- a/src/gsi/obsmod.F90 +++ b/src/gsi/obsmod.F90 @@ -161,6 +161,7 @@ module obsmod ! observation provider and sub-provider information into ! obsdiags files (used for AutoObsQC) ! 2023-07-10 Y. Wang, D. Dowell - add variables for flash extent density +! 2023-10-10 H. Wang (GSL) - add variables for flash extent density EnVar DA ! ! Subroutines Included: ! sub init_obsmod_dflts - initialize obs related variables to default values @@ -188,6 +189,12 @@ module obsmod ! def diag_radardbz- namelist logical to compute/write (=true) radar ! reflectiivty diag files ! def diag_fed - namelist logical to compute/write (=true) flash extent density diag files +! def innov_use_model_fed - namelist logical. True: use (the FEB in background to calculate innovation +! False: calculate innvation use +! the obs operator in GSI +! def if_model_fed - namelist logical. True: Read in FED from background +! including from ensemble. +! def r_hgt_fed - height of fed observations ! def reduce_diag - namelist logical to produce reduced radiance diagnostic files ! def use_limit - parameter set equal to -1 if diag files produced or 0 if not diag files or reduce_diag ! def obs_setup - prefix for files passing pe relative obs data to setup routines @@ -487,7 +494,12 @@ module obsmod public :: iout_dbz, mype_dbz ! --- DBZ DA --- + ! ==== FED DA === + public :: if_model_fed, innov_use_model_fed + public :: r_hgt_fed public :: iout_fed, mype_fed + public :: dofedoneob + ! --- FED DA --- public :: obsmod_init_instr_table public :: obsmod_final_instr_table @@ -577,7 +589,7 @@ module obsmod real(r_kind) perturb_fact,time_window_max,time_offset,time_window_rad real(r_kind),dimension(50):: dmesh - + real(r_kind) r_hgt_fed integer(i_kind) nchan_total,ianldate integer(i_kind) ndat,ndat_types,ndat_times,nprof_gps integer(i_kind) lunobs_obs,nloz_v6,nloz_v8,nobskeep,nloz_omi @@ -621,8 +633,8 @@ module obsmod integer(i_kind) ntilt_radarfiles,tcp_posmatch,tcp_box logical :: ta2tb - logical :: doradaroneob - logical :: vr_dealisingopt, if_vterminal, if_model_dbz, inflate_obserr, if_vrobs_raw, if_use_w_vr, l2rwthin + logical :: doradaroneob,dofedoneob + logical :: vr_dealisingopt, if_vterminal, if_model_dbz,if_model_fed, innov_use_model_fed,inflate_obserr, if_vrobs_raw, if_use_w_vr, l2rwthin character(4) :: whichradar,oneobradid real(r_kind) :: oneoblat,oneoblon,oneobddiff,oneobvalue,oneobheight logical :: radar_no_thinning @@ -755,11 +767,15 @@ subroutine init_obsmod_dflts if_vrobs_raw=.false. if_use_w_vr=.true. if_model_dbz=.false. + if_model_fed=.false. + innov_use_model_fed=.false. inflate_obserr=.false. whichradar="KKKK" oneobradid="KKKK" doradaroneob=.false. + r_hgt_fed=6500_r_kind + dofedoneob=.false. oneoblat=-999_r_kind oneoblon=-999_r_kind oneobddiff=-999_r_kind diff --git a/src/gsi/read_dbz_netcdf.f90 b/src/gsi/read_dbz_netcdf.f90 index ecfb9169c4..845660168a 100644 --- a/src/gsi/read_dbz_netcdf.f90 +++ b/src/gsi/read_dbz_netcdf.f90 @@ -526,7 +526,8 @@ subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nob if(thislon>=r360) thislon=thislon-r360 if(thislon=r360 .or. thislat >90.0_r_kind) cycle + !-Convert back to radians thislat = thislat*deg2rad diff --git a/src/gsi/read_fed.f90 b/src/gsi/read_fed.f90 index c478b3d93f..3d3d098b08 100644 --- a/src/gsi/read_fed.f90 +++ b/src/gsi/read_fed.f90 @@ -9,6 +9,12 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) ! 2019-09-20 Yaping Wang (CIMMS/OU) ! 2021-07-01 David Dowell (DCD; NOAA GSL) - added maximum flashes/min for observed FED ! +! 2023-10-18 Hongli Wang (NOAA GSL) +! - cleanup code, removed hardcoded obs height (6500m) +! - use height fron obs file if they are avaiable, otherwise +! use default value or value from namelist variable r_hgt_fed +! - return if NetCDF file open status /= nf90_noerror +! ! input argument list: ! infile - unit from which to read observation information file ! obstype - observation type to process @@ -29,13 +35,13 @@ 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 + use constants, only: zero,one,deg2rad,r60inv use convinfo, only: nconvtype,ctwind,icuse,ioctype - use gsi_4dvar, only: l4dvar,l4densvar,winlen + use gsi_4dvar, only: iwinbgn use gridmod, only: tll2xy use mod_wrfmass_to_a, only: wrfmass_obs_to_a8 use mpimod, only: npe - use obsmod, only: perturb_obs,iadatemn + use obsmod, only: perturb_obs,iadatemn,dofedoneob,oneoblat,oneoblon,r_hgt_fed use netcdf implicit none @@ -72,7 +78,6 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) real(r_kind),allocatable,dimension(:,:):: cdata_out real(r_kind) :: federr, thiserr real(r_kind) :: hgt_fed(1) - data hgt_fed / 6500.0 / real(r_kind) :: i_maxloc,j_maxloc,k_maxloc integer(i_kind) :: kint_maxloc @@ -80,70 +85,55 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) integer(i_kind) :: ndata2 integer(i_kind) :: ppp -! -! for read in bufr -! - real(r_kind) :: hdr(5),obs(1,3) - character(80):: hdrstr='SID XOB YOB DHR TYP' - character(80):: obsstr='FED' - - character(8) subset - character(8) station_id - real(r_double) :: rstation_id - equivalence(rstation_id,station_id) - integer(i_kind) :: lunin,idate - integer(i_kind) :: ireadmg,ireadsb + 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) :: nmsg,ntb + integer(i_kind) :: maxlvl + integer(i_kind) :: numlvl,numfed,nmsgmax,maxobs + integer(i_kind) :: k,iret - real(r_kind),allocatable,dimension(:,:) :: fed3d_column ! 3D fed in column - real(r_kind),allocatable,dimension(:) :: utime ! time + real(r_kind),allocatable,dimension(:,:) :: fed3d_column ! 3D fed in column + real(r_kind),allocatable,dimension(:) :: fed3d_hgt ! fed height + real(r_kind),allocatable,dimension(:) :: utime ! time - integer(i_kind) :: ikx - real(r_kind) :: timeo,t4dv + integer(i_kind) :: ikx - character*128 :: myname='read_fed' + character*128 :: myname='read_fed' - real(r_kind) :: dlat, dlon ! rotated corrdinate - real(r_kind) :: dlat_earth, dlon_earth ! in unit of degree - real(r_kind) :: rlat00, rlon00 ! in unit of rad + real(r_kind) :: dlat, dlon ! rotated corrdinate + real(r_kind) :: dlat_earth, dlon_earth ! in unit of degree + real(r_kind) :: rlat00, rlon00 ! in unit of rad - logical :: l_psot_fed - logical :: l_latlon_fedobs - logical :: outside - integer :: unit_table + logical :: l_psot_fed + logical :: l_latlon_fedobs + logical :: outside ! for read netcdf - integer(i_kind) :: sec70,mins_an - integer(i_kind) :: varID, ncdfID, status - real(r_kind) :: timeb,twindm,rmins_an,rmins_ob - + integer(i_kind) :: sec70,mins_an + integer(i_kind) :: varID, ncdfID, status + real(r_kind) :: timeb,twindm,rmins_an,rmins_ob - unit_table = 23 -!********************************************************************** -! -! END OF DECLARATIONS....start of program -! - write(6,*) "r_kind=",r_kind - l_psot_fed = .FALSE. - l_latlon_fedobs = .TRUE. - - fedob = obstype == 'fed' - if(fedob) then - nreal=25 - else - write(6,*) ' illegal obs type in read_fed : obstype=',obstype - call stop2(94) - end if - if(perturb_obs .and. fedob)nreal=nreal+1 - write(6,*)'read_fed: nreal=',nreal - fedobs = .false. - ikx=0 - do i=1,nconvtype + hgt_fed = r_hgt_fed + + write(6,*) "r_kind=",r_kind + l_psot_fed = .FALSE. + l_latlon_fedobs = .TRUE. + + fedob = obstype == 'fed' + if (fedob) then + nreal=25 + else + write(6,*) ' illegal obs type in read_fed : obstype=',obstype + call stop2(94) + end if + if(perturb_obs .and. fedob)nreal=nreal+1 + write(6,*)'read_fed: nreal=',nreal + + fedobs = .false. + ikx=0 + do i=1,nconvtype if(trim(obstype) == trim(ioctype(i)) .and. abs(icuse(i))== 1) then fedobs=.true. ikx=i @@ -156,150 +146,24 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) write(6,*) 'read_fed: abort read_fed !' return endif - end do - write(6,'(1x,A,A30,I4,A15,F7.3,A7)') & + end do + write(6,'(1x,A,A30,I4,A15,F7.3,A7)') & trim(myname),': fed in convinfo-->ikx=',ikx,' fed ob err:',thiserr," (fed)" - nread=0 - ndata=0 - nchanl=0 - ifn = 15 + nread=0 + ndata=0 + nchanl=0 + ifn = 15 - if(fedobs) then - maxlvl= 1 ! fed only has one level + if (fedobs) then + maxlvl= 1 ! fed only has one level - if(trim(infile) .eq. "fedbufr") then ! prebufr or netcdf format - !! get message and subset counts - ! nmsgmax and maxobs are read in from BUFR data file, not pre-set. - call getcount_bufr(infile,nmsgmax,maxobs) - write(6,*)'read_fed: nmsgmax=',nmsgmax,' maxobs=',maxobs - -! read in fed obs in bufr code format - lunin = 10 - allocate(fed3d_column(maxlvl+2+2,maxobs)) - - open ( unit = lunin, file = trim(infile),form='unformatted',err=200) - call openbf ( lunin, 'IN', lunin ) - open(unit_table,file='prepobs_kr.bufrtable') !temporily dump the bufr table, which is already saved in file - call dxdump(lunin,unit_table) - call datelen ( 10 ) - - nmsg=0 - ntb = 0 - - ndata =0 - ppp = 0 - msg_report: do while (ireadmg(lunin,subset,idate) == 0) - nmsg=nmsg+1 - if (nmsg>nmsgmax) then - write(6,*)'read_fed: messages exceed maximum ',nmsgmax - call stop2(50) - endif - loop_report: do while (ireadsb(lunin) == 0) - ntb = ntb+1 - if (ntb>maxobs) then - write(6,*)'read_fed: reports exceed maximum ',maxobs - call stop2(50) - endif - - ! Extract type, date, and location information from BUFR file - call ufbint(lunin,hdr,5,1,iret,hdrstr) - if(hdr(3) .gt. r90 ) write(6,*) "Inside read_fed.f90, hdr(2)=",hdr(2),"hdr(3)=",hdr(3) - if ( l_latlon_fedobs ) then - if(abs(hdr(3))>r90 .or. abs(hdr(2))>r360) cycle loop_report - if(hdr(2)== r360)hdr(2)=hdr(2)-r360 - if(hdr(2) < zero)hdr(2)=hdr(2)+r360 - end if - -! check time window in subset - if (l4dvar.or.l4densvar) then - t4dv=hdr(4) - if (t4dvwinlen) then - write(6,*)'read_fed: time outside window ',& - t4dv,' skip this report' - cycle loop_report - endif - else - timeo=hdr(4) - if (abs(timeo)>ctwind(ikx) .or. abs(timeo) > twind) then - write(6,*)'read_fed: time outside window ',& - timeo,' skip this report' - cycle loop_report - endif - endif -! read in observations - call ufbint(lunin,obs,1,3,iret,obsstr) !Single level bufr data, Rong Kong - if(obs(1,1) .gt. 5 ) write(6,*) "Inside read_fed.f90, obs(1,1)=",obs(1,1) - numlvl=min(iret,maxlvl) - if (numlvl .ne. maxlvl) then - write(6,*)' read_fed: numlvl is not equalt to maxlvl:',numlvl,maxlvl - end if - if(hdr(3) .gt. 90) write(6,*) "hdr(3)=",hdr(3) - if ( l_latlon_fedobs ) then - if(hdr(2)>= r360)hdr(2)=hdr(2)-r360 - if(hdr(2) < zero)hdr(2)=hdr(2)+r360 - fed3d_column(1,ntb)=hdr(2) ! observation location, earth lon - fed3d_column(2,ntb)=hdr(3) ! observation location, earth lat -! write(6,*) "Inside read_fed.f90, fed3d_column(1,ntb)=",fed3d_column(1,ntb),"fed3d_column(2,ntb)=",fed3d_column(2,ntb) - else - fed3d_column(1,ntb)=hdr(2)*10.0_r_kind ! observation location, grid index i - fed3d_column(2,ntb)=hdr(3)*10.0_r_kind ! observation location, grid index j - end if - - if (l_psot_fed .and. .NOT. l_latlon_fedobs ) then - do k=1,numlvl - if (NINT(fed3d_column(1,ntb)) .eq. 175 .and. NINT(fed3d_column(2,ntb)) .eq. 105 .and. & - NINT(hgt_fed(k)) .ge. 100 ) then - write(6,*) 'read_fed: single point/column obs run on grid: 175 105' - write(6,*) 'read_fed: found the pseudo single(column) fed obs:',fed3d_column(1:2,ntb),hgt_fed(k) - else - obs(1,1) = -999.0 - end if - end do - end if - - fed3d_column(3,ntb)=obs(1,1) - fed3d_column(4,ntb)=obs(1,2) - fed3d_column(5,ntb)=obs(1,3) - if (obs(1,1) == fed_lowbnd .or. obs(1,1) >= fed_lowbnd2 ) then - if (obs(1,1) == 0.0) then - ppp = ppp + 1 - endif - ndata = ndata + 1 - endif - - enddo loop_report - enddo msg_report - - write(6,*)'read_fed: messages/reports = ',nmsg,'/',ntb - print*,'number of Z that is less than 0 is ppp = ', ppp - numfed=ntb - -! - Finished reading fed observations from BUFR format data file -! - call closbf(lunin) - close(lunin) - - else ! NETCDF format !!!! Start reading fed observations from NETCDF format data file - ! CHECK IF DATA FILE EXISTS - + ! CHECK IF DATA FILE EXISTS ! OPEN NETCDF FILE status = nf90_open(TRIM(infile), NF90_NOWRITE, ncdfID) print*, '*** OPENING GOES FED OBS NETCDF FILE: ', infile, status - - - !------------------------ - ! Get date information - !------------------------- - ! status = nf90_get_att( ncdfID, nf90_global, 'year', idate5s(1) ) - ! print*, 'year ',status - ! status = nf90_get_att( ncdfID, nf90_global, 'month', idate5s(2) ) - ! status = nf90_get_att( ncdfID, nf90_global, 'day', idate5s(3) ) - ! status = nf90_get_att( ncdfID, nf90_global, 'hour', idate5s(4) ) - ! status = nf90_get_att( ncdfID, nf90_global, 'minute', idate5s(5) ) - ! read(idate5s(:) , *) idate5(:) - ! print*, idate5 + if(status/=nf90_noerr)return !------------------------ ! Get Dimension Info (1-D) @@ -307,72 +171,75 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) status = nf90_inq_varid( ncdfID, 'numobs', varID ) status = nf90_get_var( ncdfID, varID, maxobs ) - !------------------------ - ! Allocate data arrays - !------------------------- - ALLOCATE( fed3d_column( 5, maxobs ) ) - ALLOCATE( utime( 1 ) ) ! seconds since from 2000-01-01 12:00 - - !------------------------ - ! Get useful data arrays - !------------------------- - ! LON - status = nf90_inq_varid( ncdfID, 'lon', varID ) - status = nf90_get_var( ncdfID, varID, fed3d_column(1, :) ) - ! LAT - status = nf90_inq_varid( ncdfID, 'lat', varID ) - status = nf90_get_var( ncdfID, varID, fed3d_column(2, :) ) - ! FED value - status = nf90_inq_varid( ncdfID, 'value', varID ) - status = nf90_get_var( ncdfID, varID, fed3d_column(3, :) ) - ! TIME - status = nf90_inq_varid( ncdfID, 'time', varID ) - status = nf90_get_var( ncdfID, varID, utime ) - - ! CLOSE NETCDF FILE - status = nf90_close( ncdfID ) - - - !-Obtain analysis time in minutes since reference date - sec70 = 694267200.0 ! seconds since from 1978-01-01 00:00 to 2000-01-01 12:00 - ! because the official GOES prescribed epoch time for GLM data is 2000-01-01 12:00:00 - - call w3fs21(iadatemn,mins_an) !mins_an -integer number of mins snce 01/01/1978 - rmins_an=mins_an !convert to real number - - ! SINCE ALL OBS WILL HAVE THE SAME TIME, CHECK TIME HERE: - rmins_ob = ( utime(1) + sec70 )/60 !Convert to Minutes from seconds - twindm = twind*60. !Convert to Minutes from hours - timeb = rmins_ob-rmins_an - - if(abs(timeb) > abs(twindm)) then + !------------------------ + ! Allocate data arrays + !------------------------- + ALLOCATE( fed3d_column( 5, maxobs ) ) + allocate( fed3d_hgt(maxobs) ) + ALLOCATE( utime( 1 ) ) ! seconds since from 2000-01-01 12:00 + fed3d_hgt = -999.0_r_kind + + !------------------------ + ! Get useful data arrays + !------------------------- + ! LON + status = nf90_inq_varid( ncdfID, 'lon', varID ) + status = nf90_get_var( ncdfID, varID, fed3d_column(1, :) ) + ! LAT + status = nf90_inq_varid( ncdfID, 'lat', varID ) + status = nf90_get_var( ncdfID, varID, fed3d_column(2, :) ) + ! FED value + status = nf90_inq_varid( ncdfID, 'value', varID ) + status = nf90_get_var( ncdfID, varID, fed3d_column(3, :) ) + ! TIME + status = nf90_inq_varid( ncdfID, 'time', varID ) + status = nf90_get_var( ncdfID, varID, utime ) + + ! FED height, optional variable + status = nf90_inq_varid( ncdfID, 'height', varID ) + if(status==nf90_noerr)& + status = nf90_get_var( ncdfID, varID, fed3d_hgt ) + + ! CLOSE NETCDF FILE + status = nf90_close( ncdfID ) + + + !-Obtain analysis time in minutes since reference date + sec70 = 694267200.0 ! seconds since from 1978-01-01 00:00 to 2000-01-01 12:00 + ! because the official GOES prescribed epoch time for GLM data is 2000-01-01 12:00:00 + + call w3fs21(iadatemn,mins_an) !mins_an -integer number of mins snce 01/01/1978 + rmins_an=mins_an !convert to real number + + ! SINCE ALL OBS WILL HAVE THE SAME TIME, CHECK TIME HERE: + rmins_ob = ( utime(1) + sec70 )/60 !Convert to Minutes from seconds + twindm = twind*60. !Convert to Minutes from hours + timeb = rmins_ob-rmins_an + + if(abs(timeb) > abs(twindm)) then print*, 'WARNING: ALL FED OBSERVATIONS OUTSIDE ASSIMILATION TIME WINDOW: ', timeb, twindm - ! goto 314 - endif - numfed = maxobs - do i=1,numfed + endif + + !time relative to the beginning of the da time window + timeb=real(rmins_ob-iwinbgn,r_kind) + + numfed = maxobs + do i=1,numfed if (fed3d_column( 3, i ) >= fed_lowbnd2 .or. fed3d_column( 3, i ) == fed_lowbnd ) then ndata = ndata + 1 end if - end do - end if ! end if prebufr or netcdf format + end do write(6,*)'read_fed: total no. of obs = ',ndata nread=ndata nodata=ndata !!! - Finished reading fed observations from NETCDF format data file - - allocate(cdata_out(nreal,ndata)) -! ! do i=1,numfed do k=1,maxlvl - -! DCD 1 July 2021 if (fed3d_column(k+2,i) .gt. fed_highbnd) fed3d_column(k+2,i) = fed_highbnd - end do end do @@ -382,38 +249,56 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) write(6,*) k,maxval(fed3d_column(k+2,:)),minval(fed3d_column(k+2,:)) end do - i_maxloc=-1.0 j_maxloc=-1.0 k_maxloc=-1.0 kint_maxloc=-1 fed_max=-999.99 ndata2=0 + + ILOOP : & do i=1,numfed + if(fed3d_hgt(i) > 0.0_r_kind)then + hgt_fed=fed3d_hgt(i) + else + hgt_fed = r_hgt_fed + end if do k=1,maxlvl - if( fed3d_column(k+2,i) >= fed_lowbnd2 .or. fed3d_column(k+2,i) == fed_lowbnd) then !Rong Kong + if( fed3d_column(k+2,i) >= fed_lowbnd2 .or. fed3d_column(k+2,i) == fed_lowbnd .or. dofedoneob) then !Rong Kong dlon_earth = fed3d_column(1,i) ! longitude (degrees) of observation ! ilone=18 ! index of longitude (degrees) dlat_earth = fed3d_column(2,i) ! latitude (degrees) of observation ! ilate=19 ! index of latitude (degrees) - !-Check format of longitude and correct if necessary - if(dlon_earth>=r360) dlon_earth=dlon_earth-r360 - if(dlon_earth=r360 .or. dlat_earth >90.0_r_kind) cycle - !-Convert back to radians + if (dofedoneob) then + dlat_earth=oneoblat + dlon_earth=oneoblon + endif + + !-Check format of longitude and correct if necessary + if(dlon_earth>=r360) dlon_earth=dlon_earth-r360 + if(dlon_earth=r360 .or. dlat_earth >90.0_r_kind) cycle + + !-Convert back to radians rlon00 = dlon_earth*deg2rad rlat00 = dlat_earth*deg2rad call tll2xy(rlon00,rlat00,dlon,dlat,outside) + if (dofedoneob) then + if (outside) then + write(6,*)'READ_FED: ONE OB OUTSIDE; STOP2(61) ',dlat_earth,dlon_earth + call stop2(61) + end if + end if if (outside) cycle - !If observation is outside the domain - ! then cycle, but don't increase - ! range right away. - ! Domain could be rectangular, so ob - ! may be out of - ! range at one end, but not the - ! other. + !If observation is outside the domain + ! then cycle, but don't increase + ! range right away. + ! Domain could be rectangular, so ob + ! may be out of + ! range at one end, but not the + ! other. ndata2=ndata2+1 cdata_out( 1,ndata2) = thiserr ! obs error (flashes/min) - inflated/adjusted @@ -425,11 +310,11 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) cdata_out( 4,ndata2) = hgt_fed(k) ! obs absolute height (m) above MSL ! ipres=4 ! index of pressure cdata_out( 5,ndata2) = fed3d_column(k+2,i) ! FED value - ! idbzob=5 ! index of dbz observation + cdata_out( 6,ndata2) = rstation_id ! station id (charstring equivalent to real double) ! id=6 ! index of station id - cdata_out( 7,ndata2) = 0.0_r_kind ! observation time in data array + cdata_out( 7,ndata2) = timeb*r60inv ! observation time in data array ! itime=7 ! index of observation time in data array cdata_out( 8,ndata2) = ikx ! ob type ! ikxx=8 ! index of ob type @@ -472,7 +357,9 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) cdata_out(26,ndata2) = 1.0_r_kind ! obs perturbation ! iptrb=26 ! index of q perturbation end if -! print*,'cdata_out(:,ndata2)=',cdata_out(:,ndata2) + + if( dofedoneob ) exit ILOOP + if(fed3d_column(k+2,i) > fed_max)then kint_maxloc=k k_maxloc=real(k,r_kind) @@ -480,29 +367,27 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) i_maxloc=fed3d_column(1,i) fed_max =fed3d_column(k+2,i) end if + endif - enddo - enddo + enddo ! k + enddo ILOOP ! i !---all looping done now print diagnostic output - write(6,*)'READ_FED: Reached eof on FED file' - write(6,*)'READ_FED: # read in obs. number =',nread - write(6,*)'READ_FED: # read in obs. number for further processing =',ndata2 - ! write(6,*)'READ_FED: dlon_earth', cdata_out(18,10:15) + write(6,*)'READ_FED: Reached eof on FED file' + write(6,*)'READ_FED: # read in obs. number =',nread + write(6,*)'READ_FED: # read in obs. number for further processing =',ndata2 +! write(6,*)'READ_FED: dlon_earth', cdata_out(18,10:15) ilon=2 ! array index for longitude ilat=3 ! array index for latitude in obs information array ndata=ndata2 nodata=ndata2 - !---Write observations to scratch file---! +!---Write observations to scratch file---! -! if(ndata > 0 ) then - call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs) - write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata - write(lunout) ((cdata_out(k,i),k=1,nreal),i=1,ndata) - ! print*,'cdata_out',cdata_out -! endif + call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs) + write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata + write(lunout) ((cdata_out(k,i),k=1,nreal),i=1,ndata) deallocate(cdata_out) if (allocated(fed3d_column)) deallocate(fed3d_column) @@ -511,15 +396,9 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) 'read_fed: max fed =',fed_max, '@ i j k =', & i_maxloc,j_maxloc,k_maxloc,kint_maxloc - end if -! close(lunout) ! ???? - return - -200 continue - write(6,*) 'read_fed, Warning : cannot find or open bufr fed data file: ', trim(infile) + end if + return -314 continue -print* ,'FINISHED WITH READ_FED' end subroutine read_fed ! ! diff --git a/src/gsi/setupfed.f90 b/src/gsi/setupfed.f90 index cf6334e567..dbb2f56111 100644 --- a/src/gsi/setupfed.f90 +++ b/src/gsi/setupfed.f90 @@ -17,7 +17,9 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa ! - added a second option (tanh) for observation operator, based on the ! work of Sebok and Back (2021, unpublished) ! - capped maximum model FED -! +! Hongli Wang NOAA GSL 2023-09-14 +! - Add option to use fed from background file to calculate fed innov +! - cleanup code, removed hardcoded obs height (6500m) ! use mpeu_util, only: die,perr use kinds, only: r_kind,r_single,r_double,i_kind @@ -30,6 +32,7 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa use obsmod, only: rmiss_single,& lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset use obsmod, only: oberror_tune + use obsmod, only: if_model_fed,innov_use_model_fed,dofedoneob,oneobddiff,oneobvalue use m_obsNode, only: obsNode use m_fedNode, only: fedNode use m_fedNode, only: fedNode_appendto @@ -93,7 +96,6 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa real(r_kind),parameter:: d_coeff = -1.215e9_r_kind ! d (kg) in tanh operator real(r_kind),parameter:: fed_highbnd = 8.0_r_kind ! DCD: Back (2023, unpublished) for FV3 - real(r_kind),parameter:: fed_height = 6500.0_r_kind ! assumed height (m) of FED observations real(r_kind),parameter:: r0_001 = 0.001_r_kind real(r_kind),parameter:: r8 = 8.0_r_kind real(r_kind),parameter:: ten = 10.0_r_kind @@ -135,7 +137,7 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q real(r_kind),allocatable,dimension(:,:,:,:) :: ges_qg,ges_qg_mask - + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_fed real(r_kind) :: presq real(r_kind) :: T1D,RHO real(r_kind) :: glmcoeff = 2.088_r_kind*10.0**(-8.0) ! Allen et al. (2016,MWR) @@ -230,6 +232,10 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa muse(i)=nint(data(iuse,i)) <= jiter end do + if (dofedoneob) then + muse=.true. + end if + numequal=0 numnotequal=0 @@ -293,10 +299,10 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa print*, 'nsig = ', nsig print*, 'lon2 = ', lon2 print*, 'lat2 = ', lat2 - + if (.not. innov_use_model_fed .or. .not. if_model_fed) then ! compute graupel mass, in kg per 15 km x 15 km column - do jj=1,nfldsig - do k=1,nsig + do jj=1,nfldsig + do k=1,nsig do i=1,lon2 do j=1,lat2 !How to handle MPI???? do igx=1,2*ngx+1 !horizontal integration of qg around point to calculate FED @@ -312,12 +318,12 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa end do !jgy end do !j end do !i - end do !k - end do !jj + end do !k + end do !jj ! compute FED, in flashes/min - do jj=1,nfldsig - do i=1,lon2 + do jj=1,nfldsig + do i=1,lon2 do j=1,lat2 if (fed_obs_ob_shape .eq. 1) then rp(j,i,jj) = CM * glmcoeff * rp(j,i,jj) @@ -331,9 +337,8 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa end if if (rp(j,i,jj) .gt. fed_highbnd) rp(j,i,jj) = fed_highbnd end do !j - end do !i - end do !jj - + end do !i + end do !jj !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! write(6,*) 'fed_obs_ob_shape=',fed_obs_ob_shape if (fed_obs_ob_shape .eq. 2) then @@ -344,7 +349,7 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa end if write(6,*) 'fed_highbnd=',fed_highbnd write(6,*) 'maxval(ges_qg)=',maxval(ges_qg),'pe=',mype - + end if ! .not. innov_use_model_fed .or. .not. if_model_fed !============================================================================================ @@ -352,28 +357,21 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa nlon_ll=size(ges_qg,2) nsig_ll=size(ges_qg,3) nfld_ll=size(ges_qg,4) - -! - Observation times are checked in read routine - comment out for now - -! call dtime_setup() - -!print*,"maxval(data(ifedob,:)),mmaxval(data(ilat,:))=",minval(data(ifedob,:)),maxval(data(ifedob,:)),maxval(data(ilat,:)) -!write(6,*) "OKOKOKOKOK, nobs=", nobs do i=1,nobs - dtime=data(itime,i) - dlat=data(ilat,i) - dlon=data(ilon,i) - - dlon8km=data(iprvd,i) !iprvd=23 - dlat8km=data(isprvd,i) !isprvd=24 - - dpres=data(ipres,i) ! from rdararef_mosaic2: this height abv MSL - ikx = nint(data(ikxx,i)) - error=data(ier2,i) - slat=data(ilate,i)*deg2rad ! needed when converting geophgt to - dlon_earth = data(ilone,i) !the lontitude and latitude on the obs pts. - dlat_earth = data(ilate,i) + dtime=data(itime,i) + dlat=data(ilat,i) + dlon=data(ilon,i) + + dlon8km=data(iprvd,i) !iprvd=23 + dlat8km=data(isprvd,i) !isprvd=24 + + dpres=data(ipres,i) ! from rdararef_mosaic2: this height abv MSL + ikx = nint(data(ikxx,i)) + error=data(ier2,i) + slat=data(ilate,i)*deg2rad ! needed when converting geophgt to + dlon_earth = data(ilone,i) !the lontitude and latitude on the obs pts. + dlat_earth = data(ilate,i) ! geometric hgh (hges --> zges below) if (nobs_bins>1) then @@ -382,7 +380,7 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa ibin = 1 end if - IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin + if (ibin<1.or.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin if (luse_obsdiag) my_diagLL => odiagLL(ibin) @@ -402,28 +400,28 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa end if ! Interpolate terrain height(model elevation) to obs location. - call tintrp2a11(ges_z,zsges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) + call tintrp2a11(ges_z,zsges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) ! print*,'i,after tintrp2all',i,mype,dlat,zsges ! 1. dpres (MRMS obs height is height above MSL) is adjusted by zsges, so it ! is changed to height relative to model elevation (terrain). ! because in GSI, geop_hgtl is the height relative to terrain (ges_z) ! (subroutine guess_grids) - dpres=dpres-zsges - if (dpres 0_r_kind) then + data(ifedob,i) = oneobvalue + ddiff = data(ifedob,i) - FEDMdiag(i) + else + ddiff = oneobddiff + data(ifedob,i) = FEDMdiag(i)+ddiff + oneobvalue = data(ifedob,i) + endif + write(6,*)"FED_ONEOB: O_Val,B_Val= ",data(ifedob,i),FEDMdiag(i) + write(6,*)"FED_ONEOB: Innov,Error= ",ddiff,magoberr + else + data(ifedob,i) = oneobvalue + ddiff = data(ifedob,i) - FEDMdiag(i) + end if + end if !oneob ! Gross error checks obserror = one/max(ratio_errors*error,tiny_r_kind) obserrlm = max(cermin(ikx),min(cermax(ikx),obserror)) - residual = abs(ddiff) != y-H(xb) ratio = residual/obserrlm != y-H(xb)/sqrt(R) @@ -782,7 +788,7 @@ end subroutine check_vars_ subroutine init_vars_ ! use radaremul_cst, only: mphyopt - + use obsmod, only: if_model_fed real(r_kind),dimension(:,: ),pointer:: rank2=>NULL() real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL() character(len=5) :: varname @@ -822,6 +828,28 @@ subroutine init_vars_ call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus) ges_z(:,:,ifld)=rank2 end do + + if(if_model_fed)then + ! get fed .... + varname='fed' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_fed))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_fed(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_fed(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_fed(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + endif + else write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus call stop2(999) @@ -938,7 +966,7 @@ subroutine contents_binary_diag_(odiag) rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters) rdiagbuf(6,ii) = presq ! observation pressure (hPa) - rdiagbuf(7,ii) = fed_height ! observation height (meters) + rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters) rdiagbuf(8,ii) = (dtime*r60)-time_offset ! obs time (sec relative to analysis time) rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark @@ -1006,7 +1034,7 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) ) call nc_diag_metadata("Pressure", sngl(presq) ) - call nc_diag_metadata("Height", sngl(fed_height) ) + call nc_diag_metadata("Height", sngl(data(iobshgt,i)) ) call nc_diag_metadata("Time", sngl(dtime*r60-time_offset)) call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) ) call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) ) @@ -1048,6 +1076,7 @@ subroutine final_vars_ ! if(allocated(ges_tv)) deallocate(ges_tv) if(allocated(ges_ps)) deallocate(ges_ps) if(allocated(ges_qg)) deallocate(ges_qg) + if(allocated(ges_fed)) deallocate(ges_fed) end subroutine final_vars_ subroutine init_qcld(t_cld, qxmin_cld, icat_cld, t_dpnd) diff --git a/src/gsi/stpfed.f90 b/src/gsi/stpfed.f90 new file mode 100644 index 0000000000..2a69dd08ec --- /dev/null +++ b/src/gsi/stpfed.f90 @@ -0,0 +1,171 @@ +module stpfedmod + +!$$$ module documentation block +! . . . . +! module: stpfedmod module for stpfed and its tangent linear stpfed_tl +! prgmmr: +! +! abstract: module for stpfed and its tangent linear stpfed_tl +! +! program history log: +! 2023-08-23 H. Wang - Modified based on sftdbzmod +! - add adjoint of fed operator +! +! subroutines included: +! sub stpfed +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +implicit none + +PRIVATE +PUBLIC stpfed + +contains + +subroutine stpfed(fedhead,rval,sval,out,sges,nstep) +!$$$ subprogram documentation block +! . . . . +! subprogram: stpfed calculate penalty and contribution to +! stepsize with nonlinear qc added. +! prgmmr: derber org: np23 date: 1991-02-26 +! +! +! program history log: +! 2019-08-23 H.Wang - added for FED DA +! input argument list: +! fedhead +! sges - step size estimates (nstep) +! nstep - number of step sizes (== 0 means use outer iteration value) +! +! output argument list - output for step size calculation +! out(1:nstep) - penalty from fed sges(1:nstep) +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use kinds, only: r_kind,i_kind,r_quad + use qcmod, only: nlnqc_iter,varqc_iter + use constants, only: half,one,two,tiny_r_kind,cg_term,zero_quad,r3600 + use gsi_bundlemod, only: gsi_bundle + 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 + +! Declare passed variables + class(obsNode), pointer ,intent(in ) :: fedhead + integer(i_kind) ,intent(in ) :: nstep + real(r_quad),dimension(max(1,nstep)),intent(inout) :: out + type(gsi_bundle) ,intent(in ) :: rval,sval + real(r_kind),dimension(max(1,nstep)),intent(in ) :: sges + +! Declare local variables + integer(i_kind) ier,istatus + integer(i_kind) j1,j2,j3,j4,j5,j6,j7,j8,kk + real(r_kind) w1,w2,w3,w4,w5,w6,w7,w8 + real(r_kind) valfed + real(r_kind) fedcur + real(r_kind) cg_fed,fed,wgross,wnotgross + real(r_kind),dimension(max(1,nstep))::pen + real(r_kind) pg_fed + real(r_kind),pointer,dimension(:) :: sfed + real(r_kind),pointer,dimension(:) :: rfed + type(fedNode), pointer :: fedptr + + out=zero_quad + +! If no fed data return + if(.not. associated(fedhead))return + +! Retrieve pointers +! Simply return if any pointer not found + ier=0 + if(fed_exist)then + call gsi_bundlegetpointer(sval,'fed',sfed,istatus);ier=istatus+ier + call gsi_bundlegetpointer(rval,'fed',rfed,istatus);ier=istatus+ier + else + return + end if + + if(ier/=0)return + + fedptr => fedNode_typecast(fedhead) + do while (associated(fedptr)) + if(fedptr%luse)then + if(nstep > 0)then + j1=fedptr%ij(1) + j2=fedptr%ij(2) + j3=fedptr%ij(3) + j4=fedptr%ij(4) + j5=fedptr%ij(5) + j6=fedptr%ij(6) + j7=fedptr%ij(7) + j8=fedptr%ij(8) + w1=fedptr%wij(1) + w2=fedptr%wij(2) + w3=fedptr%wij(3) + w4=fedptr%wij(4) + w5=fedptr%wij(5) + w6=fedptr%wij(6) + w7=fedptr%wij(7) + w8=fedptr%wij(8) + + if( fed_exist )then + valfed= w1* rfed(j1)+w2*rfed(j2)+w3*rfed(j3)+w4*rfed(j4)+ & + w5* rfed(j5)+w6*rfed(j6)+w7*rfed(j7)+w8*rfed(j8) + + fedcur= w1* sfed(j1)+w2* sfed(j2)+w3* sfed(j3)+w4*sfed(j4)+ & + w5* sfed(j5)+w6* sfed(j6)+w7* sfed(j7)+w8* sfed(j8)- & + fedptr%res + end if + + + do kk=1,nstep + fed=fedcur+sges(kk)*valfed + pen(kk)=fed*fed*fedptr%err2 + end do + else + pen(1)=fedptr%res*fedptr%res*fedptr%err2 + end if + +! Modify penalty term if nonlinear QC + if (nlnqc_iter .and. fedptr%pg > tiny_r_kind .and. & + fedptr%b > tiny_r_kind) then + + pg_fed=fedptr%pg*varqc_iter + cg_fed=cg_term/fedptr%b + wnotgross= one-pg_fed + wgross = pg_fed*cg_fed/wnotgross + do kk=1,max(1,nstep) + pen(kk)= -two*log((exp(-half*pen(kk)) + wgross)/(one+wgross)) + end do + end if + + out(1) = out(1)+pen(1)*fedptr%raterr2 + kk=1 + do kk=2,nstep + out(kk) = out(kk)+(pen(kk)-pen(1))*fedptr%raterr2 + end do + end if + + fedptr => fedNode_nextcast(fedptr) + + end do + return +end subroutine stpfed + +end module stpfedmod diff --git a/src/gsi/wrf_vars_mod.f90 b/src/gsi/wrf_vars_mod.f90 index 97c36c43cf..f7a5e6c83d 100644 --- a/src/gsi/wrf_vars_mod.f90 +++ b/src/gsi/wrf_vars_mod.f90 @@ -39,6 +39,8 @@ module wrf_vars_mod use mpimod, only: mype use control_vectors, only: nc3d,cvars3d use kinds, only: i_kind +use gsi_metguess_mod, only: gsi_metguess_get +use constants, only: max_varname_length implicit none private ! public methods @@ -46,21 +48,54 @@ module wrf_vars_mod ! common block variables public :: w_exist public :: dbz_exist +public :: fed_exist -logical,save :: w_exist, dbz_exist +logical,save :: w_exist, dbz_exist, fed_exist contains subroutine init_wrf_vars -integer(i_kind) ii +integer(i_kind) ii,istatus +character(max_varname_length),allocatable,dimension(:) :: cloud +integer(i_kind) ncloud +logical :: dbz_cloud_exist,fed_cloud_exist w_exist=.false. dbz_exist=.false. +fed_exist=.false. +dbz_cloud_exist=.false. +fed_cloud_exist=.false. + do ii=1,nc3d if(mype == 0 ) write(6,*)"anacv cvars3d is ",cvars3d(ii) if(trim(cvars3d(ii)) == 'w'.or.trim(cvars3d(ii))=='W') w_exist=.true. if(trim(cvars3d(ii))=='dbz'.or.trim(cvars3d(ii))=='DBZ') dbz_exist=.true. + if(trim(cvars3d(ii))=='fed'.or.trim(cvars3d(ii))=='FED') fed_exist=.true. enddo +! Inquire about clouds + +call gsi_metguess_get('clouds::3d',ncloud,istatus) +if (ncloud>0) then + allocate(cloud(ncloud)) + call gsi_metguess_get('clouds::3d',cloud,istatus) +endif + +do ii=1,ncloud + if(mype == 0 ) write(6,*)"metguess cloud3d is ",cloud(ii) + if(trim(cloud(ii))=='fed'.or.trim(cloud(ii))=='FED')fed_cloud_exist=.true. + if(trim(cloud(ii))=='dbz'.or.trim(cloud(ii))=='DBZ')dbz_cloud_exist=.true. +end do + +if(.not.fed_exist .or. .not.fed_cloud_exist )then + fed_exist=.false. +endif + +if(.not.dbz_exist .or. .not.dbz_cloud_exist )then + dbz_exist=.false. +endif + +if(ncloud>0) deallocate(cloud) + end subroutine init_wrf_vars end module wrf_vars_mod From a3e13da942572e7a819182d7c3401df22d3dcf49 Mon Sep 17 00:00:00 2001 From: daviddowellNOAA <72174157+daviddowellNOAA@users.noreply.github.com> Date: Tue, 7 Nov 2023 09:08:22 -0600 Subject: [PATCH 040/109] Modified observation errors for radar-reflectivity observations in precipitation (#650) This PR addresses issue 649: Reflectivity high bias resulting from EnVar radar-reflectivity data assimilation. Observation errors for radar-reflectivity observations are changed as follows: (1) Increase default observation error standard deviation from 5.0 dBZ to 10.0 dBZ for reflectivity observations in precipitation (i.e., observations >= 5 dBZ). For non-precipitation observations (< 5 dBZ), keep the existing 5.0 dBZ error standard deviation. (2) For reflectivity observations in precipitation, further inflate the error for observations that fail the gross error check by a factor of 1.0-2.0. This change will be combined with a stricter gross error check, implemented through a separate PR to the regional workflow. Also, the gross error check won't be applied to non-precipitation reflectivity observations. The changes described above were initially discussed by David Dowell, Jacob Carley, and Sho Yokota in emails on 11 August 2023. The proposed changes were tested in a prototype CONUS RRFSv1 for a summer 2022 retrospective period. --- src/gsi/gsimod.F90 | 8 ++++++-- src/gsi/obsmod.F90 | 8 +++++--- src/gsi/read_dbz_nc.f90 | 12 +++++++++--- src/gsi/setupdbz.f90 | 9 ++++++--- 4 files changed, 26 insertions(+), 11 deletions(-) diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index 5a06eff27a..c24c485ce1 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -26,7 +26,7 @@ module gsimod use obsmod, only: doradaroneob,dofedoneob,oneoblat,oneoblon,oneobheight,oneobvalue,oneobddiff,oneobradid,& radar_no_thinning,ens_hx_dbz_cut,static_gsi_nopcp_dbz,rmesh_dbz,& rmesh_vr,zmesh_dbz,zmesh_vr,if_vterminal, if_model_dbz,if_model_fed,innov_use_model_fed,if_vrobs_raw,if_use_w_vr,& - minobrangedbz,maxobrangedbz,maxobrangevr,maxtiltvr,missing_to_nopcp,& + minobrangedbz,maxobrangedbz,maxobrangevr,maxtiltvr,inflate_dbz_obserr,missing_to_nopcp,& ntilt_radarfiles,whichradar,& minobrangevr,maxtiltdbz,mintiltvr,mintiltdbz,l2rwthin,hurricane_radar,& r_hgt_fed @@ -744,6 +744,10 @@ module gsimod ! optconv - downweighting option for iasi and cris for moisture channels to ! improve convergence. default 0.0 (no change). Larger number improves ! convergence. +! inflate_dbz_obserr - logical that controls inflation of reflectivity ob error +! for obs that exceed gross error magnitude +! if true, inflate ob error +! if false, reject ob ! ! NOTE: for now, if in regional mode, then iguess=-1 is forced internally. ! add use of guess file later for regional mode. @@ -779,7 +783,7 @@ module gsimod use_gfs_stratosphere,pblend0,pblend1,step_start,diag_precon,lrun_subdirs,& use_sp_eqspace,lnested_loops,lsingleradob,thin4d,use_readin_anl_sfcmask,& luse_obsdiag,id_drifter,id_ship,verbose,print_obs_para,lsingleradar,singleradar,lnobalance, & - missing_to_nopcp,minobrangedbz,minobrangedbz,maxobrangedbz,& + inflate_dbz_obserr,missing_to_nopcp,minobrangedbz,minobrangedbz,maxobrangedbz,& maxobrangevr,maxtiltvr,whichradar,doradaroneob,dofedoneob,oneoblat,& oneoblon,oneobheight,oneobvalue,oneobddiff,oneobradid,& rmesh_vr,zmesh_dbz,zmesh_vr, ntilt_radarfiles, whichradar,& diff --git a/src/gsi/obsmod.F90 b/src/gsi/obsmod.F90 index c43a23c1e6..4f1a8c76bf 100644 --- a/src/gsi/obsmod.F90 +++ b/src/gsi/obsmod.F90 @@ -480,7 +480,8 @@ module obsmod ! ==== DBZ DA === public :: ntilt_radarfiles public :: whichradar - public :: vr_dealisingopt, if_vterminal, if_model_dbz, inflate_obserr, if_vrobs_raw, if_use_w_vr, l2rwthin + public :: vr_dealisingopt, if_vterminal, if_model_dbz, if_vrobs_raw, if_use_w_vr, l2rwthin + public :: inflate_dbz_obserr public :: doradaroneob,oneoblat,oneoblon public :: oneobddiff,oneobvalue,oneobheight,oneobradid @@ -634,7 +635,8 @@ module obsmod logical :: ta2tb logical :: doradaroneob,dofedoneob - logical :: vr_dealisingopt, if_vterminal, if_model_dbz,if_model_fed, innov_use_model_fed,inflate_obserr, if_vrobs_raw, if_use_w_vr, l2rwthin + logical :: vr_dealisingopt, if_vterminal, if_model_dbz,if_model_fed, innov_use_model_fed, if_vrobs_raw, if_use_w_vr, l2rwthin + logical :: inflate_dbz_obserr character(4) :: whichradar,oneobradid real(r_kind) :: oneoblat,oneoblon,oneobddiff,oneobvalue,oneobheight logical :: radar_no_thinning @@ -769,7 +771,7 @@ subroutine init_obsmod_dflts if_model_dbz=.false. if_model_fed=.false. innov_use_model_fed=.false. - inflate_obserr=.false. + inflate_dbz_obserr=.false. whichradar="KKKK" oneobradid="KKKK" diff --git a/src/gsi/read_dbz_nc.f90 b/src/gsi/read_dbz_nc.f90 index 7f8604b9d2..f4bf288c9a 100644 --- a/src/gsi/read_dbz_nc.f90 +++ b/src/gsi/read_dbz_nc.f90 @@ -412,9 +412,15 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no ! changed to hard-coded value for now; dbznoise used for two different purposes in this subroutine: ! (1) threshold for lowest reflectivity value considered to be an observation and ! (2) ob error - thiserr = 5.0_r_kind - - + +! Specify a larger error standard deviation for reflectivity observations in precipitation +! than for reflectivity observations that indicate a lack of preciptation. + if( dbzQC(i,j,k) < 5.0_r_kind ) then + thiserr = 5.0_r_kind + else + thiserr = 10.0_r_kind + end if + nread = nread + 1 !#################### Data thinning ################### diff --git a/src/gsi/setupdbz.f90 b/src/gsi/setupdbz.f90 index 453c4a5f8d..90b7d183b6 100644 --- a/src/gsi/setupdbz.f90 +++ b/src/gsi/setupdbz.f90 @@ -150,7 +150,7 @@ subroutine setupdbz(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,radardbz_d use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype use convinfo, only: icsubtype use m_dtime, only: dtime_setup, dtime_check - use obsmod, only : if_model_dbz, inflate_obserr + use obsmod, only : if_model_dbz, inflate_dbz_obserr use setupdbz_lib, only:hx_dart,jqr_dart,jqs_dart,jqg_dart use gridmod, only: wrf_mass_regional,nems_nmmb_regional, fv3_regional use sparsearr, only: sparr2, new, size, writearray, fullarray @@ -1260,8 +1260,11 @@ subroutine setupdbz(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,radardbz_d end if else - if (ratio > cgross(ikx) .or. ratio_errors < tiny_r_kind) then - if ( inflate_obserr .and. (ratio-cgross(ikx)) <= cgross(ikx) .and. ratio_errors >= tiny_r_kind) then + +! Apply gross error check only to reflectivity observations in precipitation (>= 5 dBZ). + if ( ( (data(idbzob,i) >= 5_r_kind) .and. (ratio > cgross(ikx)) ) .or. (ratio_errors < tiny_r_kind) ) then + + if ( inflate_dbz_obserr .and. (ratio-cgross(ikx)) <= cgross(ikx) .and. ratio_errors >= tiny_r_kind) then ! Since radar reflectivity can be very different from the model background ! good observations may be rejected during this QC step. However, if these observations ! are allowed through, they can yield problems with convergence. Therefore the error From 57e45c4db1463057ab7a6800047ec269054c8a06 Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Thu, 9 Nov 2023 22:47:27 +0000 Subject: [PATCH 041/109] Fix cool layer output --- src/gsi/setupsst.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/gsi/setupsst.f90 b/src/gsi/setupsst.f90 index 27d08daa86..994638142a 100644 --- a/src/gsi/setupsst.f90 +++ b/src/gsi/setupsst.f90 @@ -612,7 +612,7 @@ subroutine contents_netcdf_diag_(odiag) if (nst_gsi>0) then call nc_diag_metadata_to_single("FoundationTempBG",data(itref,i) ) call nc_diag_metadata_to_single("DiurnalWarming_at_zob",data(idtw,i) ) - call nc_diag_metadata_to_single("SkinLayerCooling_at_zob",data(idtw,i) ) + call nc_diag_metadata_to_single("SkinLayerCooling_at_zob",data(idtc,i) ) call nc_diag_metadata_to_single("Sensitivity_Tzob_Tr",data(itz_tr,i) ) endif From 47f35eea5f1d3f9b85cc78b841536d723bea83e2 Mon Sep 17 00:00:00 2001 From: Andrew Collard <40322596+ADCollard@users.noreply.github.com> Date: Mon, 20 Nov 2023 10:53:56 -0500 Subject: [PATCH 042/109] Fix typo in array index used to write SkinLayerCooling to netcdf diagnostic file (#656) --- src/gsi/setupsst.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/gsi/setupsst.f90 b/src/gsi/setupsst.f90 index 27d08daa86..994638142a 100644 --- a/src/gsi/setupsst.f90 +++ b/src/gsi/setupsst.f90 @@ -612,7 +612,7 @@ subroutine contents_netcdf_diag_(odiag) if (nst_gsi>0) then call nc_diag_metadata_to_single("FoundationTempBG",data(itref,i) ) call nc_diag_metadata_to_single("DiurnalWarming_at_zob",data(idtw,i) ) - call nc_diag_metadata_to_single("SkinLayerCooling_at_zob",data(idtw,i) ) + call nc_diag_metadata_to_single("SkinLayerCooling_at_zob",data(idtc,i) ) call nc_diag_metadata_to_single("Sensitivity_Tzob_Tr",data(itz_tr,i) ) endif From 1076cf778dcd02f8e3a9cd16e3736acace584218 Mon Sep 17 00:00:00 2001 From: shoyokota <103961291+shoyokota@users.noreply.github.com> Date: Wed, 29 Nov 2023 01:37:13 +0900 Subject: [PATCH 043/109] Fix bugs with undefined variable and thread safety in intrad.f90 (#659) Co-authored-by: Sho Yokota --- src/gsi/intrad.f90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/gsi/intrad.f90 b/src/gsi/intrad.f90 index 19bb400034..b062ec953a 100644 --- a/src/gsi/intrad.f90 +++ b/src/gsi/intrad.f90 @@ -444,7 +444,8 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) i4n(k) = i4n(k-1)+latlon11 enddo -!$omp parallel do schedule(dynamic,1) private(k,i1,i2,i3,i4,mm) + tdir=zero +!$omp parallel do schedule(dynamic,1) private(k,i1,i2,i3,i4) do k=1,nsig i1 = i1n(k) i2 = i2n(k) @@ -525,7 +526,7 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) end do end if -!$omp parallel do schedule(dynamic,1) private(nn,k,ncr1) +!$omp parallel do schedule(dynamic,1) private(nn,k,ncr1,val_quad,mm) do nn=1,radptr%nchan ! include observation increment and lapse rate contributions to bias correction From c94bc72ff410b48c325abbfe92c9fcb601d89aed Mon Sep 17 00:00:00 2001 From: David Huber <69919478+DavidHuber-NOAA@users.noreply.github.com> Date: Thu, 30 Nov 2023 11:52:16 -0500 Subject: [PATCH 044/109] Upgrade to spack-stack libraries on non-production machines (#624) Co-authored-by: Natalie Perlin Co-authored-by: DavidHuber-NOAA Co-authored-by: RussTreadon-NOAA --- .github/workflows/gcc.yml | 31 +++--- .github/workflows/intel.yml | 47 ++++---- ci/spack.yaml | 4 +- modulefiles/gsi_cheyenne.gnu.lua | 36 +++--- modulefiles/gsi_cheyenne.intel.lua | 32 +++--- modulefiles/gsi_common.lua | 16 +-- modulefiles/gsi_gaea.lua | 24 ++-- modulefiles/gsi_hera.gnu.lua | 22 ++-- modulefiles/gsi_hera.intel.lua | 21 ++-- modulefiles/gsi_hercules.lua | 26 +++++ modulefiles/gsi_jet.lua | 22 ++-- modulefiles/gsi_orion.lua | 21 ++-- modulefiles/gsi_s4.lua | 23 ++-- modulefiles/gsi_wcoss2.lua | 28 ++++- regression/regression_param.sh | 137 ++++++++++++++--------- regression/regression_var.sh | 19 +++- ush/detect_machine.sh | 2 + ush/module-setup.sh | 7 ++ ush/sub_hercules | 170 +++++++++++++++++++++++++++++ ush/sub_orion | 2 + 20 files changed, 485 insertions(+), 205 deletions(-) create mode 100644 modulefiles/gsi_hercules.lua create mode 100755 ush/sub_hercules diff --git a/.github/workflows/gcc.yml b/.github/workflows/gcc.yml index 6ba8ef3295..1f6fa3afcd 100644 --- a/.github/workflows/gcc.yml +++ b/.github/workflows/gcc.yml @@ -15,9 +15,9 @@ env: # The jobs are split into: # 1. a dependency build step (setup), and -# 2. a GSI build step (build) +# 2. a GSI build step (gsi) # The setup is run once and the environment is cached, -# so each build of GSI can reuse the cached dependencies to save time (and compute). +# so each subsequent build of GSI can reuse the cached dependencies to save time (and compute). jobs: setup: @@ -25,11 +25,11 @@ jobs: steps: # Checkout the GSI to get the ci/spack.yaml file - - name: checkout-gsi + - name: checkout if: steps.cache-env.outputs.cache-hit != 'true' - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: - path: GSI + path: gsi # Cache spack, compiler and dependencies - name: cache-env @@ -39,33 +39,34 @@ jobs: path: | spack ~/.spack - key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('GSI/ci/spack.yaml') }} + key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('gsi/ci/spack.yaml') }} # Install dependencies using Spack - name: install-dependencies-with-spack if: steps.cache-env.outputs.cache-hit != 'true' run: | sudo apt-get install cmake - git clone -c feature.manyFiles=true https://github.com/NOAA-EMC/spack.git + git clone -c feature.manyFiles=true https://github.com/JCSDA/spack.git source spack/share/spack/setup-env.sh - spack env create gsi-env GSI/ci/spack.yaml + spack env create gsi-env gsi/ci/spack.yaml spack env activate gsi-env spack compiler find + sudo apt install cmake spack external find spack add mpich@3.4.2 spack concretize spack install -v --fail-fast --dirty spack clean -a - build: + gsi: needs: setup runs-on: ubuntu-latest steps: - - name: checkout-gsi - uses: actions/checkout@v3 + - name: checkout + uses: actions/checkout@v4 with: - path: GSI + path: gsi - name: cache-env id: cache-env @@ -74,13 +75,13 @@ jobs: path: | spack ~/.spack - key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('GSI/ci/spack.yaml') }} + key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('gsi/ci/spack.yaml') }} - - name: build-gsi + - name: build run: | source spack/share/spack/setup-env.sh spack env activate gsi-env - cd GSI + cd gsi mkdir -p build && cd build cmake -DCMAKE_INSTALL_PREFIX=../install -DGSI_MODE=Regional -DENKF_MODE=GFS -DBUILD_REG_TESTING=OFF .. make -j2 VERBOSE=1 diff --git a/.github/workflows/intel.yml b/.github/workflows/intel.yml index d48c00a21e..d21420687a 100644 --- a/.github/workflows/intel.yml +++ b/.github/workflows/intel.yml @@ -18,21 +18,30 @@ env: # The jobs are split into: # 1. a dependency build step (setup), and -# 2. a GSI build step (build) +# 2. a GSI build step (gsi) # The setup is run once and the environment is cached, -# so each build of GSI can reuse the cached dependencies to save time (and compute). +# so each subsequent build of GSI can reuse the cached dependencies to save time (and compute). jobs: setup: runs-on: ubuntu-latest steps: + # Free up disk space + - name: free-disk-spack + run: | + df -h + sudo swapoff -a + sudo rm -f /swapfile + sudo apt clean + docker rmi $(docker image ls -aq) + # Checkout the GSI to get the ci/spack.yaml file - - name: checkout-gsi + - name: checkout if: steps.cache-env.outputs.cache-hit != 'true' - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: - path: GSI + path: gsi # Cache spack, compiler and dependencies - name: cache-env @@ -43,16 +52,15 @@ jobs: spack ~/.spack /opt/intel - key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('GSI/ci/spack.yaml') }} + key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('gsi/ci/spack.yaml') }} - name: install-intel-compilers - if: steps.cache-env.outputs.cache-hit != 'true' run: | wget https://apt.repos.intel.com/intel-gpg-keys/GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB sudo apt-key add GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB echo "deb https://apt.repos.intel.com/oneapi all main" | sudo tee /etc/apt/sources.list.d/oneAPI.list sudo apt-get update - sudo apt-get install intel-oneapi-dev-utilities intel-oneapi-mpi-devel intel-oneapi-openmp intel-oneapi-compiler-fortran intel-oneapi-compiler-dpcpp-cpp-and-cpp-classic + sudo apt-get install intel-oneapi-dev-utilities intel-oneapi-mpi-devel intel-oneapi-openmp intel-oneapi-compiler-fortran-2023.2.1 intel-oneapi-compiler-dpcpp-cpp-and-cpp-classic-2023.2.1 sudo apt-get clean echo "source /opt/intel/oneapi/setvars.sh" >> ~/.bash_profile @@ -62,31 +70,32 @@ jobs: run: | sudo mv /usr/local/ /usr_local_mv sudo apt-get install cmake - git clone -c feature.manyFiles=true https://github.com/NOAA-EMC/spack.git + git clone -c feature.manyFiles=true https://github.com/JCSDA/spack.git source spack/share/spack/setup-env.sh - spack env create gsi-env GSI/ci/spack.yaml + spack env create gsi-env gsi/ci/spack.yaml spack env activate gsi-env spack compiler find + sudo apt install cmake spack external find spack add intel-oneapi-mpi spack concretize spack install -v --fail-fast --dirty spack clean -a - build: + gsi: needs: setup runs-on: ubuntu-latest steps: - - name: checkout-gsi - uses: actions/checkout@v3 - with: - path: GSI - - name: install-intel run: | echo "source /opt/intel/oneapi/setvars.sh" >> ~/.bash_profile + - name: checkout + uses: actions/checkout@v4 + with: + path: gsi + - name: cache-env id: cache-env uses: actions/cache@v3 @@ -95,13 +104,13 @@ jobs: spack ~/.spack /opt/intel - key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('GSI/ci/spack.yaml') }} + key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('gsi/ci/spack.yaml') }} - - name: build-gsi + - name: build run: | source spack/share/spack/setup-env.sh spack env activate gsi-env - cd GSI + cd gsi mkdir -p build && cd build cmake -DCMAKE_INSTALL_PREFIX=../install -DGSI_MODE=Regional -DENKF_MODE=GFS -DBUILD_REG_TESTING=OFF .. make -j2 VERBOSE=1 diff --git a/ci/spack.yaml b/ci/spack.yaml index 0fc66547e5..deacdff0b5 100644 --- a/ci/spack.yaml +++ b/ci/spack.yaml @@ -6,8 +6,8 @@ spack: - intel - gcc@10:10 specs: - - netcdf-c@4.7.4 - - netcdf-fortran@4.5.3 + - netcdf-c@4.9.2 + - netcdf-fortran@4.6.0 - bufr@11.7.0 - bacio@2.4.1 - w3emc@2.9.2 diff --git a/modulefiles/gsi_cheyenne.gnu.lua b/modulefiles/gsi_cheyenne.gnu.lua index 43e6aaf02c..1d903082a8 100644 --- a/modulefiles/gsi_cheyenne.gnu.lua +++ b/modulefiles/gsi_cheyenne.gnu.lua @@ -1,30 +1,32 @@ help([[ ]]) -load("cmake/3.22.0") -load("python/3.7.9") -load("ncarenv/1.3") -load("gnu/11.2.0") -load("mpt/2.25") -load("ncarcompilers/0.5.0") -unload("intel") -unload("netcdf") -prepend_path("MODULEPATH", "/glade/work/epicufsrt/contrib/hpc-stack/gnu11.2.0/modulefiles/stack") +unload("ncarenv/1.3") +unload("intel/19.1.1") +unload("ncarcompilers/0.5.0") +unload("mpt/2.25") +unload("netcdf/4.8.1") -load("hpc/1.2.0") -load("hpc-gnu/11.2.0") -load("hpc-mpt/2.25") +prepend_path("MODULEPATH", "/glade/work/epicufsrt/contrib/spack-stack/cheyenne/spack-stack-1.4.1/envs/unified-env/install/modulefiles/Core") +prepend_path("MODULEPATH", "/glade/work/jedipara/cheyenne/spack-stack/modulefiles/misc") -load("gsi_common") +local stack_python_ver=os.getenv("stack_python_ver") or "3.9.12" +local stack_gnu_ver=os.getenv("stack_gnu_ver") or "10.1.0" +local stack_openmpi_ver=os.getenv("stack_openmpi_ver") or "4.1.1" +local cmake_ver=os.getenv("cmake_ver") or "3.22.0" +load(pathJoin("stack-gcc", stack_gnu_ver)) +load(pathJoin("stack-openmpi", stack_openmpi_ver)) +load(pathJoin("stack-python", stack_python_ver)) +load(pathJoin("cmake", cmake_ver)) load(pathJoin("prod_util", os.getenv("prod_util_ver") or "1.2.2")) load(pathJoin("openblas", os.getenv("openblas_ver") or "0.3.23")) -pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_fix/fix") +load("gsi_common") -pushenv("CC", "mpicc") -pushenv("FC", "mpif90") -pushenv("CXX", "mpicxx") +pushenv("CFLAGS", "-xHOST") +pushenv("FFLAGS", "-xHOST") +pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_data/fix/20230601") whatis("Description: GSI environment on Cheyenne with GNU Compilers") diff --git a/modulefiles/gsi_cheyenne.intel.lua b/modulefiles/gsi_cheyenne.intel.lua index 26ed666695..8c328e2b34 100644 --- a/modulefiles/gsi_cheyenne.intel.lua +++ b/modulefiles/gsi_cheyenne.intel.lua @@ -1,26 +1,32 @@ help([[ ]]) -load("cmake/3.22.0") -load("python/3.7.9") -load("ncarenv/1.3") -load("intel/2022.1") -load("mpt/2.25") -load("ncarcompilers/0.5.0") +unload("ncarenv/1.3") +unload("intel/19.1.1") +unload("ncarcompilers/0.5.0") +unload("mpt/2.25") +unload("netcdf/4.8.1") -prepend_path("MODULEPATH", "/glade/work/epicufsrt/contrib/hpc-stack/intel2022.1/modulefiles/stack") +prepend_path("MODULEPATH", "/glade/work/epicufsrt/contrib/spack-stack/cheyenne/spack-stack-1.4.1/envs/unified-env/install/modulefiles/Core") +prepend_path("MODULEPATH", "/glade/work/jedipara/cheyenne/spack-stack/modulefiles/misc") -load("hpc/1.2.0") -load("hpc-intel/2022.1") -load("hpc-mpt/2.25") -load("mkl/2022.1") +local stack_python_ver=os.getenv("stack_python_ver") or "3.9.12" +local stack_intel_ver=os.getenv("stack_intel_ver") or "19.1.1.217" +local stack_mpi_ver=os.getenv("stack_mpi_ver") or "2019.7.217" +local cmake_ver=os.getenv("cmake_ver") or "3.22.0" -load("gsi_common") +load(pathJoin("stack-intel", stack_intel_ver)) +load(pathJoin("stack-intel-mpi", stack_mpi_ver)) +load(pathJoin("stack-python", stack_python_ver)) +load(pathJoin("cmake", cmake_ver)) -load(pathJoin("prod_util", os.getenv("prod_util_ver") or "1.2.2")) +load("gsi_common") +load(pathJoin("prod-util", os.getenv("prod_util_ver") or "1.2.2")) pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_data/fix/20230911") pushenv("CFLAGS", "-xHOST") pushenv("FFLAGS", "-xHOST") +pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_data/fix/20230601") + whatis("Description: GSI environment on Cheyenne with Intel Compilers") diff --git a/modulefiles/gsi_common.lua b/modulefiles/gsi_common.lua index c54f6ddb92..d3365a98dc 100644 --- a/modulefiles/gsi_common.lua +++ b/modulefiles/gsi_common.lua @@ -2,22 +2,24 @@ help([[ Load common modules to build GSI on all machines ]]) -local netcdf_ver=os.getenv("netcdf_ver") or "4.7.4" +local netcdf_c_ver=os.getenv("netcdf_c_ver") or "4.9.2" +local netcdf_fortran_ver=os.getenv("netcdf_fortran_ver") or "4.6.0" local bufr_ver=os.getenv("bufr_ver") or "11.7.0" local bacio_ver=os.getenv("bacio_ver") or "2.4.1" -local w3emc_ver=os.getenv("w3emc_ver") or "2.9.2" +local w3emc_ver=os.getenv("w3emc_ver") or "2.10.0" local sp_ver=os.getenv("sp_ver") or "2.3.3" -local ip_ver=os.getenv("ip_ver") or "3.3.3" +local ip_ver=os.getenv("ip_ver") or "4.3.0" local sigio_ver=os.getenv("sigio_ver") or "2.3.2" local sfcio_ver=os.getenv("sfcio_ver") or "1.4.1" local nemsio_ver=os.getenv("nemsio_ver") or "2.5.4" local wrf_io_ver=os.getenv("wrf_io_ver") or "1.2.0" local ncio_ver=os.getenv("ncio_ver") or "1.1.2" local crtm_ver=os.getenv("crtm_ver") or "2.4.0" -local ncdiag_ver=os.getenv("ncdiag_ver") or "1.1.1" +local ncdiag_ver=os.getenv("ncdiag_ver") or "1.1.2" -load(pathJoin("netcdf", netcdf_ver)) +load(pathJoin("netcdf-c", netcdf_c_ver)) +load(pathJoin("netcdf-fortran", netcdf_fortran_ver)) load(pathJoin("bufr", bufr_ver)) load(pathJoin("bacio", bacio_ver)) @@ -27,7 +29,7 @@ load(pathJoin("ip", ip_ver)) load(pathJoin("sigio", sigio_ver)) load(pathJoin("sfcio", sfcio_ver)) load(pathJoin("nemsio", nemsio_ver)) -load(pathJoin("wrf_io", wrf_io_ver)) +load(pathJoin("wrf-io", wrf_io_ver)) load(pathJoin("ncio", ncio_ver)) load(pathJoin("crtm", crtm_ver)) -load(pathJoin("ncdiag",ncdiag_ver)) +load(pathJoin("gsi-ncdiag",ncdiag_ver)) diff --git a/modulefiles/gsi_gaea.lua b/modulefiles/gsi_gaea.lua index a7a2454eff..ef6b9ddba7 100644 --- a/modulefiles/gsi_gaea.lua +++ b/modulefiles/gsi_gaea.lua @@ -1,20 +1,28 @@ help([[ ]]) -load("cmake/3.20.1") +unload("intel") +unload("cray-mpich") +unload("cray-python") +unload("darshan") -prepend_path("MODULEPATH","/lustre/f2/dev/role.epic/contrib/hpc-stack/intel-classic-2022.0.2/modulefiles/stack") -load(pathJoin("hpc", os.getenv("hpc_ver") or "1.2.0")) +prepend_path("MODULEPATH", "/lustre/f2/dev/wpo/role.epic/contrib/spack-stack/spack-stack-1.4.1-c4/envs/unified-env/install/modulefiles/Core") +prepend_path("MODULEPATH", "/lustre/f2/pdata/esrl/gsd/spack-stack/modulefiles") -load(pathJoin("intel-classic", os.getenv("intel_classic_ver") or "2022.0.2")) -load(pathJoin("cray-mpich", os.getenv("cray_mpich_ver") or "7.7.20")) -load(pathJoin("hpc-intel-classic", os.getenv("hpc_intel_classic_ver") or "2022.0.2")) -load(pathJoin("hpc-cray-mpich", os.getenv("hpc_cray_mpich_ver") or "7.7.20")) +local stack_python_ver=os.getenv("stack_python_ver") or "3.9.12" +local stack_intel_ver=os.getenv("stack_intel_ver") or "2022.0.2" +local stack_cray_mpich_ver=os.getenv("stack_cray_mpich_ver") or "7.7.20" +local cmake_ver=os.getenv("cmake_ver") or "3.23.1" + +load(pathJoin("stack-intel", stack_intel_ver)) +load(pathJoin("stack-cray-mpich", stack_cray_mpich_ver)) +load(pathJoin("stack-python", stack_python_ver)) +load(pathJoin("cmake", cmake_ver)) load("gsi_common") local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" -load(pathJoin("prod_util", prod_util_ver)) +load(pathJoin("prod-util", prod_util_ver)) -- Needed at runtime: load("alps") diff --git a/modulefiles/gsi_hera.gnu.lua b/modulefiles/gsi_hera.gnu.lua index 37504485e3..550b01ee7b 100644 --- a/modulefiles/gsi_hera.gnu.lua +++ b/modulefiles/gsi_hera.gnu.lua @@ -1,20 +1,20 @@ help([[ ]]) -prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/hpc-stack/libs/gnu-9.2/modulefiles/stack") +prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/spack-stack/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") +--Needed for openmpi build +prepend_path("MODULEPATH", "/scratch1/NCEPDEV/jcsda/jedipara/spack-stack/modulefiles") -local hpc_ver=os.getenv("hpc_ver") or "1.2.0" -local gnu_ver=os.getenv("gnu_ver") or "9.2.0" -local hpc_gnu_ver=os.getenv("hpc_gnu_ver") or "9.2" -local hpc_mpich_ver=os.getenv("hpc_mpich_ver") or "3.3.2" -local cmake_ver=os.getenv("cmake_ver") or "3.20.1" +local python_ver=os.getenv("python_ver") or "3.10.8" +local stack_gnu_ver=os.getenv("stack_gnu_ver") or "9.2.0" +local stack_openmpi_ver=os.getenv("stack_openmpi_ver") or "4.1.5" +local cmake_ver=os.getenv("cmake_ver") or "3.23.1" local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" -local openblas_ver=os.getenv("openblas_ver") or "0.3.23" +local openblas_ver=os.getenv("openblas_ver") or "0.3.19" -load(pathJoin("hpc", hpc_ver)) -load(pathJoin("gnu", gnu_ver)) -load(pathJoin("hpc-gnu", hpc_gnu_ver)) -load(pathJoin("hpc-mpich", hpc_mpich_ver)) +load(pathJoin("stack-gcc", stack_gnu_ver)) +load(pathJoin("stack-openmpi", stack_openmpi_ver)) +load(pathJoin("python", python_ver)) load(pathJoin("cmake", cmake_ver)) load("gsi_common") diff --git a/modulefiles/gsi_hera.intel.lua b/modulefiles/gsi_hera.intel.lua index 619d0e76c9..abdc6e5623 100644 --- a/modulefiles/gsi_hera.intel.lua +++ b/modulefiles/gsi_hera.intel.lua @@ -1,25 +1,20 @@ help([[ ]]) -prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/miniconda3/modulefiles") -miniconda3_ver=os.getenv("miniconda3_ver") or "4.12.0" -load(pathJoin("miniconda3", miniconda3_ver)) +prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/spack-stack/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") -prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/hpc-stack/libs/intel-2022.1.2/modulefiles/stack") - -local hpc_ver=os.getenv("hpc_ver") or "1.2.0" -local hpc_intel_ver=os.getenv("hpc_intel_ver") or "2022.1.2" -local hpc_impi_ver=os.getenv("hpc_impi_ver") or "2022.1.2" -local cmake_ver=os.getenv("cmake_ver") or "3.20.1" +local python_ver=os.getenv("python_ver") or "3.10.8" +local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.5.0" +local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.1" +local cmake_ver=os.getenv("cmake_ver") or "3.23.1" local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" -load(pathJoin("hpc", hpc_ver)) -load(pathJoin("hpc-intel", hpc_intel_ver)) -load(pathJoin("hpc-impi", hpc_impi_ver)) +load(pathJoin("stack-intel", stack_intel_ver)) +load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) +load(pathJoin("python", python_ver)) load(pathJoin("cmake", cmake_ver)) load("gsi_common") - load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-xHOST") diff --git a/modulefiles/gsi_hercules.lua b/modulefiles/gsi_hercules.lua new file mode 100644 index 0000000000..bf29bc21db --- /dev/null +++ b/modulefiles/gsi_hercules.lua @@ -0,0 +1,26 @@ +help([[ +]]) + +prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/spack-stack/hercules/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") + +local stack_python_ver=os.getenv("stack_python_ver") or "3.10.8" +local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.9.0" +local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.9.0" +local cmake_ver=os.getenv("cmake_ver") or "3.23.1" +local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" + +load(pathJoin("stack-intel", stack_intel_ver)) +load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) +load(pathJoin("python", stack_python_ver)) +load(pathJoin("cmake", cmake_ver)) + +load("gsi_common") +load(pathJoin("prod_util", prod_util_ver)) +load("intel-oneapi-mkl/2022.2.1") + +pushenv("CFLAGS", "-xHOST") +pushenv("FFLAGS", "-xHOST") + +pushenv("GSI_BINARY_SOURCE_DIR", "/work/noaa/global/glopara/fix/gsi/20230911") + +whatis("Description: GSI environment on Hercules with Intel Compilers") diff --git a/modulefiles/gsi_jet.lua b/modulefiles/gsi_jet.lua index c9e5e90680..20b80ff61a 100644 --- a/modulefiles/gsi_jet.lua +++ b/modulefiles/gsi_jet.lua @@ -1,31 +1,25 @@ help([[ ]]) -prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/miniconda3/modulefiles") -miniconda3_ver=os.getenv("miniconda3_ver") or "4.12.0" -load(pathJoin("miniconda3", miniconda3_ver)) +prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/spack-stack/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") -prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/hpc-stack/libs/intel-2022.1.2/modulefiles/stack") - -local hpc_ver=os.getenv("hpc_ver") or "1.2.0" -local hpc_intel_ver=os.getenv("hpc_intel_ver") or "2022.1.2" -local hpc_impi_ver=os.getenv("hpc_impi_ver") or "2022.1.2" -local cmake_ver=os.getenv("cmake_ver") or "3.20.1" +local python_ver=os.getenv("python_ver") or "3.10.8" +local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.5.0" +local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.1" +local cmake_ver=os.getenv("cmake_ver") or "3.23.1" local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" -load(pathJoin("hpc", hpc_ver)) -load(pathJoin("hpc-intel", hpc_intel_ver)) -load(pathJoin("hpc-impi", hpc_impi_ver)) +load(pathJoin("stack-intel", stack_intel_ver)) +load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) +load(pathJoin("python", python_ver)) load(pathJoin("cmake", cmake_ver)) load("gsi_common") - load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-axSSE4.2,AVX,CORE-AVX2") pushenv("FFLAGS", "-axSSE4.2,AVX,CORE-AVX2") - pushenv("GSI_BINARY_SOURCE_DIR", "/mnt/lfs4/HFIP/hfv3gfs/glopara/git/fv3gfs/fix/gsi/20230911") whatis("Description: GSI environment on Jet with Intel Compilers") diff --git a/modulefiles/gsi_orion.lua b/modulefiles/gsi_orion.lua index e75a01ef5e..80ec342c93 100644 --- a/modulefiles/gsi_orion.lua +++ b/modulefiles/gsi_orion.lua @@ -1,25 +1,20 @@ help([[ ]]) -prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/contrib/orion/miniconda3/modulefiles") -miniconda3_ver=os.getenv("miniconda3_ver") or "4.12.0" -load(pathJoin("miniconda3", miniconda3_ver)) +prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/spack-stack/orion/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") -prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/contrib/orion/hpc-stack/intel-2022.1.2/modulefiles/stack") - -local hpc_ver=os.getenv("hpc_ver") or "1.2.0" -local hpc_intel_ver=os.getenv("hpc_intel_ver") or "2022.1.2" -local hpc_impi_ver=os.getenv("hpc_impi_ver") or "2022.1.2" -local cmake_ver=os.getenv("cmake_ver") or "3.22.1" +local stack_python_ver=os.getenv("python_ver") or "3.10.8" +local stack_intel_ver=os.getenv("stack_intel_ver") or "2022.0.2" +local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.1" +local cmake_ver=os.getenv("cmake_ver") or "3.23.1" local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" -load(pathJoin("hpc", hpc_ver)) -load(pathJoin("hpc-intel", hpc_intel_ver)) -load(pathJoin("hpc-impi", hpc_impi_ver)) +load(pathJoin("stack-intel", stack_intel_ver)) +load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) +load(pathJoin("python", stack_python_ver)) load(pathJoin("cmake", cmake_ver)) load("gsi_common") - load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-xHOST") diff --git a/modulefiles/gsi_s4.lua b/modulefiles/gsi_s4.lua index 03c21e708d..a60ea3c16e 100644 --- a/modulefiles/gsi_s4.lua +++ b/modulefiles/gsi_s4.lua @@ -1,23 +1,20 @@ help([[ ]]) -local hpc_ver=os.getenv("hpc_ver") or "1.2.0" -local hpc_intel_ver=os.getenv("hpc_intel_ver") or "2022.1" -local hpc_impi_ver=os.getenv("hpc_impi_ver") or "2022.1" -local miniconda_ver=os.getenv("miniconda_ver") or "3.8-s4" -local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" - -prepend_path("MODULEPATH", "/data/prod/hpc-stack/modulefiles/stack") +prepend_path("MODULEPATH", "/data/prod/jedi/spack-stack/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") -load("license_intel/S4") -load(pathJoin("hpc", hpc_ver)) -load(pathJoin("hpc-intel", hpc_intel_ver)) -load(pathJoin("hpc-impi", hpc_impi_ver)) +local python_ver=os.getenv("python_ver") or "3.10.8" +local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.5.0" +local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.0" +local cmake_ver=os.getenv("cmake_ver") or "3.23.1" +local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" -load(pathJoin("miniconda", miniconda_ver)) +load(pathJoin("stack-intel", stack_intel_ver)) +load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) +load(pathJoin("python", python_ver)) +load(pathJoin("cmake", cmake_ver)) load("gsi_common") - load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-march=ivybridge") diff --git a/modulefiles/gsi_wcoss2.lua b/modulefiles/gsi_wcoss2.lua index e5f4c7b812..8dde986e58 100644 --- a/modulefiles/gsi_wcoss2.lua +++ b/modulefiles/gsi_wcoss2.lua @@ -9,6 +9,20 @@ local cmake_ver= os.getenv("cmake_ver") or "3.20.2" local python_ver=os.getenv("python_ver") or "3.8.6" local prod_util_ver=os.getenv("prod_util_ver") or "2.0.10" +local netcdf_ver=os.getenv("netcdf_ver") or "4.7.4" +local bufr_ver=os.getenv("bufr_ver") or "11.7.0" +local bacio_ver=os.getenv("bacio_ver") or "2.4.1" +local w3emc_ver=os.getenv("w3emc_ver") or "2.9.2" +local sp_ver=os.getenv("sp_ver") or "2.3.3" +local ip_ver=os.getenv("ip_ver") or "3.3.3" +local sigio_ver=os.getenv("sigio_ver") or "2.3.2" +local sfcio_ver=os.getenv("sfcio_ver") or "1.4.1" +local nemsio_ver=os.getenv("nemsio_ver") or "2.5.4" +local wrf_io_ver=os.getenv("wrf_io_ver") or "1.2.0" +local ncio_ver=os.getenv("ncio_ver") or "1.1.2" +local crtm_ver=os.getenv("crtm_ver") or "2.4.0" +local ncdiag_ver=os.getenv("ncdiag_ver") or "1.1.1" + load(pathJoin("PrgEnv-intel", PrgEnv_intel_ver)) load(pathJoin("intel", intel_ver)) load(pathJoin("craype", craype_ver)) @@ -18,7 +32,19 @@ load(pathJoin("python", python_ver)) load(pathJoin("prod_util", prod_util_ver)) -load("gsi_common") +load(pathJoin("netcdf", netcdf_ver)) +load(pathJoin("bufr", bufr_ver)) +load(pathJoin("bacio", bacio_ver)) +load(pathJoin("w3emc", w3emc_ver)) +load(pathJoin("sp", sp_ver)) +load(pathJoin("ip", ip_ver)) +load(pathJoin("sigio", sigio_ver)) +load(pathJoin("sfcio", sfcio_ver)) +load(pathJoin("nemsio", nemsio_ver)) +load(pathJoin("wrf_io", wrf_io_ver)) +load(pathJoin("ncio", ncio_ver)) +load(pathJoin("crtm", crtm_ver)) +load(pathJoin("ncdiag",ncdiag_ver)) pushenv("GSI_BINARY_SOURCE_DIR", "/lfs/h2/emc/global/noscrub/emc.global/FIX/fix/gsi/20230911") diff --git a/regression/regression_param.sh b/regression/regression_param.sh index 87a21dc0f1..46d2647ac0 100755 --- a/regression/regression_param.sh +++ b/regression/regression_param.sh @@ -9,10 +9,15 @@ case $machine in memnode=96 numcore=40 ;; - Orion) + Orion) sub_cmd="sub_orion" memnode=192 numcore=40 + ;; + Hercules) + sub_cmd="sub_hercules" + memnode=512 + numcore=40 ;; Jet) sub_cmd="sub_jet" @@ -59,6 +64,9 @@ case $regtest in elif [[ "$machine" = "Orion" ]]; then topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="12/12/" ; ropts[2]="/2" + elif [[ "$machine" = "Hercules" ]]; then + topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/12/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2" @@ -87,20 +95,23 @@ case $regtest in rrfs_3denvar_glbens) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" + elif [[ "$machine" = "Hercules" ]]; then + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Cheyenne" ]]; then topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" @@ -117,20 +128,23 @@ case $regtest in hafs_3denvar_hybens) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" + elif [[ "$machine" = "Hercules" ]]; then + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Cheyenne" ]]; then topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" @@ -146,20 +160,23 @@ case $regtest in hafs_4denvar_glbens) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:20:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:20:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:20:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:20:00" ; popts[2]="20/2/" ; ropts[2]="/1" + elif [[ "$machine" = "Hercules" ]]; then + topts[1]="0:20:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:20:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Cheyenne" ]]; then topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" @@ -176,20 +193,23 @@ case $regtest in netcdf_fv3_regional) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" + elif [[ "$machine" = "Hercules" ]]; then + topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" elif [[ "$machine" = "Cheyenne" ]]; then topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="28/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="28/2/" ; ropts[2]="/1" @@ -206,20 +226,23 @@ case $regtest in rtma) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" - topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" + topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" - topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" + topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" + elif [[ "$machine" = "Hercules" ]]; then + topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" - topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" + topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" - topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" + topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:30:00" ; popts[1]="8/6/" ; ropts[1]="/1" - topts[2]="0:30:00" ; popts[2]="8/8/" ; ropts[2]="/1" + topts[1]="0:30:00" ; popts[1]="8/6/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="8/8/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:30:00" ; popts[1]="14/8/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="14/14/" ; ropts[2]="/2" @@ -236,20 +259,23 @@ case $regtest in global_enkf) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" + elif [[ "$machine" = "Hercules" ]]; then + topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:10:00" ; popts[1]="16/2/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="16/4/" ; ropts[2]="/2" @@ -300,7 +326,10 @@ if [[ "$machine" = "Hera" ]]; then export APRUN="srun" elif [[ "$machine" = "Orion" ]]; then export OMP_STACKSIZE=2048M - export APRUN="srun -n \$ntasks" + export APRUN="srun -n \$ntasks --cpus-per-task=\$threads" +elif [[ "$machine" = "Hercules" ]]; then + export OMP_STACKSIZE=2048M + export APRUN="srun -n \$ntasks --cpus-per-task=\$threads" elif [[ "$machine" = "Jet" ]]; then export OMP_STACKSIZE=1024M export MPI_BUFS_PER_PROC=256 diff --git a/regression/regression_var.sh b/regression/regression_var.sh index 7403d89ec0..02ffb24b12 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -42,8 +42,10 @@ elif [[ -d /sw/gaea ]]; then # Gaea export machine="Gaea" elif [[ -d /data/prod ]]; then # S4 export machine="S4" -elif [[ -d /work ]]; then # Orion +elif [[ -d /work && $(hostname) =~ "Orion" ]]; then # Orion export machine="Orion" +elif [[ -d /work && $(hostname) =~ "hercules" ]]; then # Hercules + export machine="Hercules" elif [[ -d /lfs/h2 ]]; then # wcoss2 export machine="wcoss2" fi @@ -98,18 +100,25 @@ case $machine in export check_resource="no" export accnt="${accnt:-GFS-DEV}" ;; - Orion) + Orion | Hercules) export local_or_default="${local_or_default:-/work/noaa/da/$LOGNAME}" if [ -d $local_or_default ]; then - export noscrub="$local_or_default/noscrub" + export noscrub="$local_or_default/noscrub" elif [ -d /work/noaa/global/$LOGNAME ]; then - export noscrub="/work/noaa/global/$LOGNAME/noscrub" + export noscrub="/work/noaa/global/$LOGNAME/noscrub" fi export queue="${queue:-batch}" + + if [[ "${machine}" == "Orion" ]]; then + export partition="${partition:-orion}" + else + export partition="${partition:-hercules}" + fi + export group="${group:-global}" if [[ "$cmaketest" = "false" ]]; then - export basedir="/work/noaa/da/$LOGNAME/gsi" + export basedir="/work/noaa/da/$LOGNAME/gsi" fi export ptmp="${ptmp:-/work/noaa/stmp/$LOGNAME/$ptmpName}" diff --git a/ush/detect_machine.sh b/ush/detect_machine.sh index 6f0673ce29..ac6c7f58d1 100755 --- a/ush/detect_machine.sh +++ b/ush/detect_machine.sh @@ -25,6 +25,8 @@ case $(hostname -f) in Orion-login-[1-4].HPC.MsState.Edu) MACHINE_ID=orion ;; ### orion1-4 + Hercules-login-[1-4].HPC.MsState.Edu) MACHINE_ID=hercules ;; ### hercules1-4 + cheyenne[1-6].cheyenne.ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6 cheyenne[1-6].ib0.cheyenne.ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6 chadmin[1-6].ib0.cheyenne.ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6 diff --git a/ush/module-setup.sh b/ush/module-setup.sh index ab92477a56..d13da1efa3 100755 --- a/ush/module-setup.sh +++ b/ush/module-setup.sh @@ -15,6 +15,13 @@ elif [[ $MACHINE_ID = hera* ]] ; then fi module purge +elif [[ $MACHINE_ID = hercules* ]] ; then + # We are on Hercules + if ( ! eval module help > /dev/null 2>&1 ) ; then + source /apps/other/lmod/lmod/init/bash + fi + module purge + elif [[ $MACHINE_ID = orion* ]] ; then # We are on Orion if ( ! eval module help > /dev/null 2>&1 ) ; then diff --git a/ush/sub_hercules b/ush/sub_hercules new file mode 100755 index 0000000000..573378fdb6 --- /dev/null +++ b/ush/sub_hercules @@ -0,0 +1,170 @@ +#!/bin/sh --login +set -x +usage="\ +Usage: $0 [options] executable [args] + where the options are: + -a account account (default: none) + -b binding run smt binding or not (default:NO) + -d dirin initial directory (default: cwd) + -e envars copy comma-separated environment variables + -g group group name + -i append standard input to command file + -j jobname specify jobname (default: executable basename) + -m machine machine on which to run (default: current) + -n write command file to stdout rather than submitting it + -o output specify output file (default: jobname.out) + -p procs[/nodes[/ppreq] + number of MPI tasks and optional nodes or Bblocking and + ppreq option (N or S) (defaults: serial, Bunlimited, S) + -q queue[/qpreq] queue name and optional requirement, e.g. dev/P + (defaults: 1 if serial or dev if parallel and none) + (queue 3 or 4 is dev or prod with twice tasks over ip) + (options: P=parallel, B=bigmem, b=batch) + -r rmem[/rcpu] resources memory and cpus/task (default: '1024 mb', 1) + -t timew wall time limit in [[hh:]mm:]ss format (default: 900) + -u userid userid to run under (default: self) + -v verbose mode + -w when when to run, in yyyymmddhh[mm], +hh[mm], thh[mm], or + Thh[mm] (full, incremental, today or tomorrow) format + (default: now) +Function: This command submits a job to the batch queue." +subcmd="$*" +stdin=NO +nosub=NO +account="" +binding="NO" +dirin="" +envars="" +group="" +jobname="" +machine="" +output="" +procs=0 +nodes="" +ppreq="" +queue="" +qpreq="" +rmem="1024" +rcpu="1" +timew="900" +userid="" +verbose=NO +when="" +while getopts a:b:d:e:g:ij:m:no:p:q:r:t:u:vw: opt;do + case $opt in + a) account="$OPTARG";; + b) binding="$OPTARG";; + d) dirin="$OPTARG";; + e) envars="$OPTARG";; + g) group="$OPTARG";; + i) stdin=YES;; + j) jobname=$OPTARG;; + m) machine="$OPTARG";; + n) nosub=YES;; + o) output=$OPTARG;; + p) procs=$(echo $OPTARG/|cut -d/ -f1);nodes=$(echo $OPTARG/|cut -d/ -f2);ppreq=$(echo $OPTARG/|cut -d/ -f3);; + q) queue=$(echo $OPTARG/|cut -d/ -f1);qpreq=$(echo $OPTARG/|cut -d/ -f2);; + r) rmem=$(echo $OPTARG/|cut -d/ -f1);rcpu=$(echo $OPTARG/|cut -d/ -f2);; + t) timew=$OPTARG;; + u) userid=$OPTARG;; + v) verbose=YES;; + w) when=$OPTARG;; + \?) echo $0: invalid option >&2;echo "$usage" >&2;exit 1;; + esac +done +shift $(($OPTIND-1)) +if [[ $# -eq 0 ]];then + echo $0: missing executable name >&2;echo "$usage" >&2;exit 1 +fi +exec=$1 +if [[ ! -s $exec ]]&&which $exec >/dev/null 2>&1;then + exec=$(which $exec) +fi +shift +args="$*" +bn=$(basename $exec) +export jobname=${jobname:-$bn} +output=${output:-$jobname.out} +myuser=$LOGNAME +myhost=$(hostname) +exp=${jobname} + +DATA=${ptmp:-/work/noaa/da/stmp/$LOGNAME/tmp} +mkdir -p $DATA + +#partition=${partition:-c1ms} +queue=${queue:-batch} +timew=${timew:-01:20:00} +task_node=${task_node:-$procs} +size=$((nodes*task_node)) +envars=$envars +threads=${rcpu:-1} + +export TZ=GMT +cfile=$DATA/sub$$ +> $cfile +#echo "#PBS -S /bin/sh" >> $cfile +echo "#!/bin/sh --login" >> $cfile +echo "" >> $cfile +echo "#SBATCH --output=$output" >> $cfile +echo "#SBATCH --job-name=$jobname" >> $cfile +echo "#SBATCH --qos=$queue" >> $cfile +echo "#SBATCH --partition=$partition" >> $cfile +echo "#SBATCH --time=$timew" >> $cfile +echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile +echo "#SBATCH --account=$accnt" >> $cfile + +echo "" >>$cfile +echo "export ntasks=$(( $nodes * $procs ))" >> $cfile +echo "export ppn=$procs" >> $cfile +echo "export threads=$threads" >> $cfile +echo "export OMP_NUM_THREADS=$threads" >> $cfile +##echo "export OMP_STACKSIZE=2048M" >> $cfile +echo "ulimit -s unlimited" >> $cfile + +echo "" >>$cfile +echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile +echo "" >>$cfile + +echo ". /apps/other/lmod/lmod/init/sh" >> $cfile +echo "module purge" >> $cfile +echo "module use $modulefiles" >> $cfile +echo "module load gsi_hercules" >> $cfile +echo "module list" >> $cfile +echo "" >> $cfile +cat $exec >> $cfile + +if [[ $nosub = YES ]];then + cat $cfile + exit +elif [[ $verbose = YES ]];then + set -x + cat $cfile +fi + + +if [[ $stdin = YES ]];then + cat +fi >>$cfile +if [[ $nosub = YES ]];then + cat $cfile + exit +elif [[ $verbose = YES ]];then + set -x + cat $cfile +fi +sbatch=${sbatch:-sbatch} + +ofile=$DATA/subout$$ +>$ofile +chmod 777 $ofile +$sbatch --export=ALL $cfile >$ofile +rc=$? +cat $ofile +if [[ -w $SUBLOG ]];then + jobn=$(grep -i submitted $ofile|head -n1|cut -d\" -f2) + date -u +"%Y%m%d%H%M%S : $subcmd : $jobn" >>$SUBLOG +fi +rm $cfile $ofile +[[ $MKDATA = YES ]] && rmdir $DATA +exit $rc diff --git a/ush/sub_orion b/ush/sub_orion index 1bcce5cc4f..e5844474db 100755 --- a/ush/sub_orion +++ b/ush/sub_orion @@ -87,6 +87,7 @@ export jobname=${jobname:-$bn} output=${output:-$jobname.out} myuser=$LOGNAME myhost=$(hostname) +exp=${jobname} DATA=${ptmp:-/work/noaa/da/stmp/$LOGNAME/tmp} mkdir -p $DATA @@ -108,6 +109,7 @@ echo "" echo "#SBATCH --output=$output" >> $cfile echo "#SBATCH --job-name=$jobname" >> $cfile echo "#SBATCH --qos=$queue" >> $cfile +echo "#SBATCH --partition=$partition" >> $cfile echo "#SBATCH --time=$timew" >> $cfile echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile echo "#SBATCH --account=$accnt" >> $cfile From ea667d9995a63e50bdf67de6ac630ef587e34e1b Mon Sep 17 00:00:00 2001 From: James Jung Date: Mon, 4 Dec 2023 12:38:26 -0500 Subject: [PATCH 045/109] Cads for andrew (#616) --- src/gsi/cads.f90 | 2230 ++++++++++++++++++++++++++++++++++++ src/gsi/crtm_interface.f90 | 18 +- src/gsi/gsi_files.cmake | 1 + src/gsi/gsimod.F90 | 55 +- src/gsi/qcmod.f90 | 418 +++++-- src/gsi/read_airs.f90 | 1 - src/gsi/read_cris.f90 | 214 +++- src/gsi/read_iasi.f90 | 165 ++- src/gsi/setupaod.f90 | 3 +- src/gsi/setuprad.f90 | 71 +- 10 files changed, 2980 insertions(+), 196 deletions(-) create mode 100644 src/gsi/cads.f90 diff --git a/src/gsi/cads.f90 b/src/gsi/cads.f90 new file mode 100644 index 0000000000..6d7e584ef1 --- /dev/null +++ b/src/gsi/cads.f90 @@ -0,0 +1,2230 @@ +module cads +!$$$ module documentation block +! +! module: cads +! prgmmr: Jung +! +! abstract: module containing subroutines for the cloud and aerosol detection software +! +! program history log: +! +! +! +! subroutines included: +! +! +! remarks: variable definitions +! +! +!$$$ end documentation block + + + use kinds, only: i_kind, r_kind + implicit none + save + +! set default to private + private +! set routines to public + public :: cloud_aerosol_detection + public :: cads_setup_cloud + public :: Cloud_Detect_Type + public :: cads_imager_calc + + public :: M__Sensor,N__Num_Bands,N__GradChkInterval,N__Band_Size,N__Bands,N__Window_Width, & + N__Window_Bounds,R__BT_Threshold,R__Grad_Threshold,R__Window_Grad_Threshold, L__Do_Quick_Exit, & + L__Do_CrossBand, N__BandToUse,L__Do_Imager_Cloud_Detection, N__Num_Imager_Chans, & + N__Num_Imager_Clusters,N__Imager_Chans,R__Stddev_Threshold,R__Coverage_Threshold, & + R__FG_Departure_Threshold + + INTEGER(i_kind) :: M__Sensor ! Unique ID for sensor + INTEGER(i_kind) :: N__Num_Bands ! Number of channel bands + INTEGER(i_kind), POINTER :: N__GradChkInterval(:) ! Window width used in gradient calculation + INTEGER(i_kind), POINTER :: N__Band_Size(:) ! Number of channels in each band + INTEGER(i_kind), POINTER :: N__Bands(:,:) ! Channel lists + INTEGER(i_kind), POINTER :: N__Window_Width(:) ! Smoothing filter window widths per band + INTEGER(i_kind), POINTER :: N__Window_Bounds(:,:) ! Channels in the spectral window gradient check + INTEGER(i_kind), POINTER :: N__BandToUse(:) ! Band number assignment for each channel + LOGICAL :: L__Do_Quick_Exit ! On/off switch for the Quick Exit scenario + LOGICAL :: L__Do_CrossBand ! On/off switch for the cross-band method + REAL(r_kind), POINTER :: R__BT_Threshold(:) ! BT threshold for cloud contamination + REAL(r_kind), POINTER :: R__Grad_Threshold(:) ! Gradient threshold for cloud contamination + REAL(r_kind), POINTER :: R__Window_Grad_Threshold(:) ! Threshold for window gradient check in QE + + LOGICAL :: L__Do_Imager_Cloud_Detection ! On/off switch for the imager cloud detection + INTEGER(i_kind) :: N__Num_Imager_Chans ! No. of imager channels + INTEGER(i_kind) :: N__Num_Imager_Clusters ! No. of clusters to be expected + INTEGER(i_kind),POINTER :: N__Imager_Chans(:) ! List of imager channels + REAL(r_kind),POINTER :: R__Stddev_Threshold(:) ! St. Dev. threshold, one for each imager channel + REAL(r_kind) :: R__Coverage_Threshold ! Threshold for fractional coverage of a cluster + REAL(r_kind) :: R__FG_Departure_Threshold ! Threshold for imager FG departure + + +! set passed variables to public + +! This software was developed within the context of the EUMETSAT +! Satellite Application Facility on Numerical Weather Prediction +! (NWP SAF), under the Cooperation Agreement dated 7 December 2016, +! between EUMETSAT and the Met Office, UK, by one or more partners +! within the NWP SAF. The partners in the NWP SAF are the Met +! Office, ECMWF, DWD and MeteoFrance. +! +! Copyright 2020, EUMETSAT, All Rights Reserved. + +! * CADS_Module * +! A. Collard ECMWF 01/02/06 + +! * PURPOSE * +! ----------- +! Sets up structures to be used in processing of advanced IR sounders. + +! * MODIFICATIONS * +! ----------------- +! 01/02/06 A.Collard 1.0 Original export version. +! 17/11/09 R.Eresmaa 1.1 Include parameters of the Quick Exit / +! long-wave window gradient check. +! 11/11/11 R.Eresmaa 1.2 Add processing capability for CrIS. +! 03/12/13 R.Eresmaa 2.0 Add imager-assisted cloud detection. +! 10/11/15 R.Eresmaa 2.2 Changed instrument ID naming convention. +! Changed aerosol detection parameters. +! 20/12/16 R.Eresmaa 2.3 Remove aerosol detection parameters. +! 05/02/19 R.Eresmaa 2.4 Explicit KIND specifications. +! 16/04/20 R.Eresmaa 3.0 Combine cloud and aerosol detection, rename. +! Include aerosol type recognition. +! Include land sensitivity parameters. +! Include trace gas detection. Rename. + + + INTEGER(i_kind), PARAMETER :: INST_ID_AIRS = 11 + INTEGER(i_kind), PARAMETER :: INST_ID_IASI = 16 + INTEGER(i_kind), PARAMETER :: INST_ID_CRIS = 27 + INTEGER(i_kind), PARAMETER :: INST_ID_IRS = 57 + INTEGER(i_kind), PARAMETER :: INST_ID_IASING = 59 + INTEGER(i_kind), PARAMETER :: INST_ID_IKFS2 = 94 + INTEGER(i_kind), PARAMETER :: INST_ID_HIRAS = 97 + INTEGER(i_kind), PARAMETER :: INST_ID_GIIRS = 98 + + INTEGER(i_kind), PARAMETER :: JP__MIN_SENSOR_INDEX = INST_ID_AIRS + INTEGER(i_kind), PARAMETER :: JP__MAX_SENSOR_INDEX = INST_ID_GIIRS + + TYPE Aerosol_Detect_Type + INTEGER(i_kind) :: M__Sensor ! Unique ID for sensor + INTEGER(i_kind) :: N__Num_Aerosol_Tests ! Number of aerosol detection tests + INTEGER(i_kind), POINTER :: N__Num_Regression(:) ! Number of conversion coefficients for AOD + INTEGER(i_kind), POINTER :: N__Num_Aerosol_Chans(:) ! Number of aerosol detection channels + INTEGER(i_kind), POINTER :: N__Aerosol_Chans(:,:) ! List of aerosol detection channels + INTEGER(i_kind) :: N__Mean_Aerosol_Chans ! Boxcar averaging window width + REAL(r_kind), POINTER :: R__Aerosol_TBD(:,:) ! Aerosol detection thresholds + REAL(r_kind), POINTER :: R__coef_AOD(:,:) ! Coefficients for conversion to AOD + REAL(r_kind) :: R__Rank_Thres_Coeff(3) ! Coefficients to restrict rejections to affected channels + REAL(r_kind) :: R__Unclassified_Thres ! Rejection threshold for unclassified aerosol + REAL(r_kind) :: R__Land_Fraction_Thres ! Threshold for land fraction in FOV + END TYPE Aerosol_Detect_Type + + TYPE Cloud_Detect_Type + INTEGER(i_kind) :: M__Sensor ! Unique ID for sensor + INTEGER(i_kind) :: N__Num_Bands ! Number of channel bands + INTEGER(i_kind), POINTER :: N__GradChkInterval(:) ! Window width used in gradient calculation + INTEGER(i_kind), POINTER :: N__Band_Size(:) ! Number of channels in each band + INTEGER(i_kind), POINTER :: N__Bands(:,:) ! Channel lists + INTEGER(i_kind), POINTER :: N__Window_Width(:) ! Smoothing filter window widths per band + INTEGER(i_kind), POINTER :: N__Window_Bounds(:,:) ! Channels in the spectral window gradient check + INTEGER(i_kind), POINTER :: N__BandToUse(:) ! Band number assignment for each channel + LOGICAL :: L__Do_Quick_Exit ! On/off switch for the Quick Exit scenario + LOGICAL :: L__Do_CrossBand ! On/off switch for the cross-band method + REAL(r_kind), POINTER :: R__BT_Threshold(:) ! BT threshold for cloud contamination + REAL(r_kind), POINTER :: R__Grad_Threshold(:) ! Gradient threshold for cloud contamination + REAL(r_kind), POINTER :: R__Window_Grad_Threshold(:) ! Threshold for window gradient check in QE + + LOGICAL :: L__Do_Imager_Cloud_Detection ! On/off switch for the imager cloud detection + INTEGER(i_kind) :: N__Num_Imager_Chans ! No. of imager channels + INTEGER(i_kind) :: N__Num_Imager_Clusters ! No. of clusters to be expected + INTEGER(i_kind),POINTER :: N__Imager_Chans(:) ! List of imager channels + REAL(r_kind),POINTER :: R__Stddev_Threshold(:) ! St. Dev. threshold, one for each imager channel + REAL(r_kind) :: R__Coverage_Threshold ! Threshold for fractional coverage of a cluster + REAL(r_kind) :: R__FG_Departure_Threshold ! Threshold for imager FG departure + END TYPE Cloud_Detect_Type + + TYPE Land_Sensitivity_Type + INTEGER(r_kind) :: M__Sensor ! Unique ID for sensor + REAL(r_kind) :: R__Land_Fraction_Thres ! Threshold on land fraction + REAl(r_kind) :: R__Level_Thres ! Threshold on normalized channel height assignment + END TYPE Land_Sensitivity_Type + + TYPE Trace_Gas_Detect_Type + INTEGER(i_kind) :: M__Sensor ! Unique ID for sensor + INTEGER(i_kind) :: N__Num_Trace_Gas_Checks ! Number of trace gases to be checked + INTEGER(i_kind),POINTER :: N__Num_Tracer_Channels(:) ! Number of gas-sensitive channels + INTEGER(i_kind),POINTER :: N__Tracer_Channels(:,:) ! Gas-sensitive channels + INTEGER(i_kind),POINTER :: N__Num_Control_Channels(:) ! Number of control channels + INTEGER(i_kind),POINTER :: N__Control_Channels(:,:) ! Control channels + INTEGER(i_kind),POINTER :: N__Num_Flagged_Channels(:) ! Number of affected channels + INTEGER(i_kind),POINTER :: N__Flagged_Channels(:,:) ! Affected channels + REAL(r_kind),POINTER :: R__D_Obs_Threshold(:) ! Observed Tb difference threshold + REAL(r_kind),POINTER :: R__D_Dep_Threshold(:) ! Departure difference threshold + END TYPE Trace_Gas_Detect_Type + + + TYPE(Aerosol_Detect_Type) :: & + S__CADS_Setup_Aerosol(JP__Min_Sensor_Index:JP__Max_Sensor_Index) + + TYPE(Cloud_Detect_Type) :: & + S__CADS_Setup_Cloud(JP__Min_Sensor_Index:JP__Max_Sensor_Index) + + TYPE(Land_Sensitivity_Type) :: & + S__CADS_Setup_Land(JP__Min_Sensor_Index:JP__Max_Sensor_Index) + + TYPE(Trace_Gas_Detect_Type) :: & + S__CADS_Setup_Trace_Gas(JP__Min_Sensor_Index:JP__Max_Sensor_Index) + + +contains + +SUBROUTINE CADS_Abort(String) + +! This software was developed within the context of the EUMETSAT +! Satellite Application Facility on Numerical Weather Prediction +! (NWP SAF), under the Cooperation Agreement dated 7 December 2016, +! between EUMETSAT and the Met Office, UK, by one or more partners +! within the NWP SAF. The partners in the NWP SAF are the Met +! Office, ECMWF, DWD and MeteoFrance. +! +! Copyright 2020, EUMETSAT, All Rights Reserved. + +! *CADS_Abort* +! R. Eresmaa ECMWF 16/04/20 + +! * PURPOSE * +! ----------- +! Controlled abortion of running CADS when facing exceptions such as +! necessary input files missing or they are corrupt. + +! * INTERFACE * +! ------------- +! *CALL* * CADS_Abort()* from +! CADS_Main, CADS_Setup_Aerosol, CADS_Setup_Cloud, +! CADS_Setup_Land_Sensitivity, or CADS_Setup_Trace_Gas. + + IMPLICIT NONE + CHARACTER(LEN=*) :: String + + WRITE(*,*) String + STOP + +END SUBROUTINE CADS_Abort + +subroutine cloud_aerosol_detection( I__Sensor_ID, I__Num_Chans, I__Chan_ID, & + I__Min_Level, I__Max_Level, Z__BT_Obser, Z__BT_Model, Z__Chan_Height, K__Chan_ID_Imager, & + Z__Cluster_Fraction, Z__BT_in_Cluster, Z__BT_Overall_SDev, Z__BT_Model_Imager, & + I__Flag_Cloud, Z__Cloud_Level ) + +!$$$ subprogram documentation block +! . . . +! subprogram: cloud_aerosol_detection determine clear/cloudy profiles from hyperspectral IR instruments +! +! prgmmr: jung org: cimss date: 2022-10-17 +! +! abstract: determine if a profile is clear/cloudy. If cloudy, determine which channels are affected +! This subroutine is designed for infrared hyperspectral sounders. Current code supports AIRS, IASI and CrIS.a +! This subroutine is based on the Cloud and Aerosol Detection Software Version 3 developed within the context +! of the EUMETSAT and Met Office, UK, by one or more partners within the Numerical Weather Predicion's +! Satellite Application Facilities. A version of this code is operational at ECMWF. +! COPYRIGHT 2020, EUMETSAT, ALL RIGHTS RESERVED. +! +! program history log: +! 2022-10-17 jung Initial coding +! +! input argument list: +! I_Sensor_ID - internal sensor identification. +! I__Num_Chans - number of channels per obs +! I__Chan_ID - array of actual channel numbers +! Z__Longitude - FOV longitude +! Z__Latitude - FOV latitude +! Z__Land_Fraction - FOV land fraction +! I__Min_Level - model tropopause height (start of cloud detection) +! I__Max_Level - model top of boundary layer ( stop of cloud detection) +! Z__BT_Obser - observaton brightness temperature +! Z__BT_Model - model derived brightness temperature +! Z__Chan_Height - model derived height where an opaque cloud influences the radiance. +! also used to re-organize channels +! Z__Cloud_Level - Cloud height assignment +! +! output argument list: +! icloud_layer - model layer where cloud is detected +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use kinds, only: i_kind, r_kind + implicit none + + integer(i_kind), intent(in ) :: I__Sensor_ID + integer(i_kind), intent(in ) :: I__Num_Chans + integer(i_kind),dimension(I__Num_Chans),intent(in ) :: I__Chan_ID + integer(i_kind), intent(in ) :: I__Min_Level !tropopause pressure + integer(i_kind), intent(in ) :: I__Max_Level !boundary layer pressure + real(r_kind), intent(in ) :: Z__BT_Obser(:) !Observation BT + real(r_kind), intent(in ) :: Z__BT_Model(:) !Model derived BT + real(r_kind), intent(in ) :: Z__Chan_Height(:) !Channel height assignmenta + integer(i_kind), intent(in ) :: K__Chan_ID_Imager(:) ! imager channel numbers + real(r_kind), intent(in ) :: Z__Cluster_Fraction(:) + real(r_kind), intent(in ) :: Z__BT_in_Cluster(:,:) + real(r_kind), intent(in ) :: Z__BT_Overall_SDev(:) + real(r_kind), intent(in ) :: Z__BT_Model_Imager(:) + real(r_kind), intent( out) :: Z__Cloud_Level ! cloud height assignment + integer(i_kind),dimension(I__Num_Chans),intent( out) :: I__Flag_Cloud ! cloud use flag + +! Interim prodcts + +! Diagnostics: percentages of positive detections +! Input/Output file management + + N__Num_Imager_Chans = S__CADS_Setup_Cloud(I__Sensor_ID) % N__Num_Imager_Chans + N__Num_Imager_Clusters = S__CADS_Setup_Cloud(I__Sensor_ID) % N__Num_Imager_Clusters + + CALL CADS_Detect_Cloud( I__Sensor_ID, I__Num_Chans, I__Chan_ID,I__Min_Level, I__Max_Level, N__Num_Imager_Chans, & + K__Chan_ID_Imager, N__Num_Imager_Clusters, I__Flag_Cloud, Z__BT_Obser, Z__BT_Model, Z__Chan_Height, & + Z__Cluster_Fraction, Z__BT_in_Cluster, Z__BT_Overall_SDev, Z__BT_Model_Imager, Z__Cloud_Level ) + +end subroutine cloud_aerosol_detection + +SUBROUTINE CADS_Setup_Cloud + +! This software was developed within the context of the EUMETSAT +! Satellite Application Facility on Numerical Weather Prediction +! (NWP SAF), under the Cooperation Agreement dated 7 December 2016, +! between EUMETSAT and the Met Office, UK, by one or more partners +! within the NWP SAF. The partners in the NWP SAF are the Met +! Office, ECMWF, DWD and Meteo France. +! +! Copyright 2020, EUMETSAT, All Rights Reserved. + + +! * Cloud detection setup * +! A. Collard ECMWF 01/02/06 + +! * PURPOSE * +! ----------- +! Initialise cloud detection parameters for advanced infrared sounders. + +! * INTERFACE * +! ------------- +! CADS_Setup_Cloud is called from CADS_Main. + +! * METHOD * +! ---------- +! Default values are assigned to the cloud detections setup structure. + +! MODIFICATIONS +! ------------- +! 01/02/06 A.Collard 1.0 Original code. +! 19/10/06 A.Collard 1.1 Use IASI 300 Subset Channels. +! 17/11/09 R.Eresmaa 1.2 Use IASI 366 Subset Channels. +! Include parameters of the Quick Exit / +! long-wave window gradient check parameters. +! 11/11/11 R.Eresmaa 1.3 Default channel list for AIRS bands 3-5 +! modified. +! Processing capability for CrIS added +! assuming a selection of 320 channels. +! 03/12/13 R,Eresmaa 2.0 Imager-assisted cloud detection added for +! IASI. +! Updated setup for CrIS. +! 19/01/15 R.Eresmaa 2.1 Remove unused variable specifications and +! switch aerosol detection on by default for +! AIRS and IASI. +! 10/11/15 R.Eresmaa 2.2 Changed instrument ID naming convention. +! Changed parameters of aerosol detection. +! 20/12/16 R.Eresmaa 2.3 Remove settings for aerosol detection. +! 05/02/19 R.Eresmaa 2.4 Explicit KIND specifications. +! Add HIRAS, GIIRS (IASING + IRS added earlier) +! 16/04/20 R.Eresmaa 3.0 Rename, tidy up. + + use kinds, only: i_kind, r_kind + use gsi_io, only: verbose + IMPLICIT NONE + +! Local variables + + CHARACTER(LEN=6) :: CL__InstrumentName + CHARACTER(LEN=20) :: CL__Cloud_Detection_File + + INTEGER(i_kind) :: J, J__Sensor ! Loop variables + INTEGER(i_kind) :: INIU1, IOS + +!----------------------- +! Namelist variables +!----------------------- + +! N.B. Max_Bands must be greater than 5 + INTEGER(i_kind), PARAMETER :: JP__Max_Bands = 8 + INTEGER(i_kind), PARAMETER :: JP__Max_Channels = 8461 + + INTEGER(i_kind) :: M__Sensor + INTEGER(i_kind) :: N__Num_Bands + INTEGER(i_kind) :: N__GradChkInterval(JP__Max_Bands) + INTEGER(i_kind) :: N__Band_Size(JP__Max_Bands) + INTEGER(i_kind) :: N__Bands(JP__Max_Channels,JP__Max_Bands) + INTEGER(i_kind) :: N__Window_Width(JP__Max_Bands) + INTEGER(i_kind) :: N__Window_Bounds(JP__Max_Bands,2) + REAL(r_kind) :: R__BT_Threshold(JP__Max_Bands) + REAL(r_kind) :: R__Grad_Threshold(JP__Max_Bands) + REAL(r_kind) :: R__Window_Grad_Threshold(JP__Max_Bands) + LOGICAL :: L__Do_Quick_Exit + LOGICAL :: L__Do_CrossBand + INTEGER(i_kind) :: N__BandToUse(JP__Max_Bands) + +! Imager-based cloud detection + LOGICAL :: L__Do_Imager_Cloud_Detection + INTEGER(i_kind) :: N__Num_Imager_Chans + INTEGER(i_kind) :: N__Num_Imager_Clusters + INTEGER(i_kind) :: N__Imager_Chans(JP__Max_Bands) + REAL(r_kind) :: R__Stddev_Threshold(JP__Max_Bands) + REAL(r_kind) :: R__Coverage_Threshold + REAL(r_kind) :: R__FG_Departure_Threshold + +! Namelist + NAMELIST / Cloud_Detect_Coeffs / M__Sensor, N__Num_Bands, & + N__Band_Size, N__Bands, N__Window_Width, N__Window_Bounds, & + N__GradChkInterval, R__BT_Threshold, R__Grad_Threshold, & + R__Window_Grad_Threshold, L__Do_Quick_Exit, & + L__Do_CrossBand, N__BandToUse, & + L__Do_Imager_Cloud_Detection, N__Num_Imager_Chans, & + N__Num_Imager_Clusters, N__Imager_Chans, & + R__Stddev_Threshold, R__Coverage_Threshold, & + R__FG_Departure_Threshold + +!============================================================================ +! Loop through sensors setting up cloud detection +!============================================================================ + + SensorLoop : DO J__Sensor = JP__Min_Sensor_Index, JP__Max_Sensor_Index + +! SELECT CASE (I__Sensor_ID) + SELECT CASE (J__Sensor) + + CASE(INST_ID_AIRS) + !==================== + ! Set up AIRS + !==================== + + CL__InstrumentName='AIRS' + CL__Cloud_Detection_File = 'AIRS_CLDDET.NL' + + N__Num_Bands = 5 + + N__Band_Size(:) = 0 + N__Band_Size(1:N__Num_Bands) =(/138, 36, 54, 23, 65 /) + + N__Bands(:,:)= 0 + + N__Bands(1:N__Band_Size(1),1) = & + (/ 1, 6, 7, 10, 11, 15, 16, 17, 20, 21, & + 22, 24, 27, 28, 30, 36, 39, 40, 42, 51, & + 52, 54, 55, 56, 59, 62, 63, 68, 69, 71, & + 72, 73, 74, 75, 76, 77, 78, 79, 80, 82, & + 83, 84, 86, 92, 93, 98, 99, 101, 104, 105, & + 108, 110, 111, 113, 116, 117, 123, 124, 128, 129, & + 138, 139, 144, 145, 150, 151, 156, 157, 159, 162, & + 165, 168, 169, 170, 172, 173, 174, 175, 177, 179, & + 180, 182, 185, 186, 190, 192, 193, 198, 201, 204, & + 207, 210, 213, 215, 216, 218, 221, 224, 226, 227, & + 232, 239, 248, 250, 251, 252, 253, 256, 257, 261, & + 262, 267, 272, 295, 299, 305, 308, 309, 310, & + 318, 321, 333, 338, 355, 362, 375, 475, & + 484, 497, 528, 587, 672, 787, 791, 843, 870, 914, & + 950 /) + + N__Bands(1:N__Band_Size(2),2) = & + (/ 1003, 1012, 1019, 1024, 1030, 1038, 1048, 1069, 1079, 1082, & + 1083, 1088, 1090, 1092, 1095, 1104, 1111, 1115, 1116, 1119, & + 1120, 1123, 1130, 1138, 1142, 1178, 1199, 1206, 1221, 1237, & + 1252, 1260, 1263, 1266, 1278, 1285 /) + + N__Bands(1:N__Band_Size(3),3) = & + (/ 1290, 1301, 1304, 1329, 1371, 1382, 1415, 1424, 1449, 1455, & + 1466, 1471, 1477, 1479, 1488, 1500, 1519, 1520, 1538, 1545, & + 1565, 1574, 1583, 1593, 1614, 1627, 1636, 1644, 1652, 1669, & + 1674, 1681, 1694, 1708, 1717, 1723, 1740, 1748, 1751, 1756, & + 1763, 1766, 1771, 1777, 1780, 1783, 1794, 1800, 1803, 1806, & + 1812, 1826, 1843, 1852 /) + + N__Bands(1:N__Band_Size(4),4) = & + (/ 1865, 1866, 1867, 1868, 1869, 1872, 1873, 1875, 1876, 1877, & + 1881, 1882, 1883, 1884, 1897, 1901, 1911, 1917, 1918, 1921, & + 1923, 1924, 1928 /) + + N__Bands(1:N__Band_Size(5),5) = & + (/ 1937, 1938, 1939, 1941, 1946, 1947, 1948, 1958, 1971, 1973, & + 1988, 1995, 2084, 2085, 2097, 2098, 2099, 2100, 2101, 2103, & + 2104, 2106, 2107, 2108, 2109, 2110, 2111, 2112, 2113, 2114, & + 2115, 2116, 2117, 2118, 2119, 2120, 2121, 2122, 2123, 2128, & + 2134, 2141, 2145, 2149, 2153, 2164, 2189, 2197, 2209, 2226, & + 2234, 2280, 2318, 2321, 2325, 2328, 2333, 2339, 2348, 2353, & + 2355, 2363, 2370, 2371, 2377 /) + + N__GradChkInterval(:) = 0 + N__GradChkInterval(1:N__Num_Bands) = (/ 5,5,5,5,5 /) + + N__Window_Width(:) = 0 + N__Window_Width(1:N__Num_Bands) = (/ 14,6,8,5,8 /) + + N__Window_Bounds(:,:) = 0 + N__Window_Bounds(1,1) = 475 + N__Window_Bounds(1,2) = 950 + + R__BT_Threshold(:) = 0.0_r_kind + R__BT_Threshold(1:N__Num_Bands) = (/ 0.43_r_kind, 0.5_r_kind, 0.5_r_kind, 0.5_r_kind, 0.5_r_kind/) + + R__Grad_Threshold(:) = 0.0_r_kind + R__Grad_Threshold(1:N__Num_Bands) = (/ 0.02_r_kind, 0.02_r_kind, 0.02_r_kind, 0.02_r_kind, 0.02_r_kind /) + + R__Window_Grad_Threshold(:) = 0.0_r_kind + R__Window_Grad_Threshold(1) = 0.4_r_kind + + L__Do_Quick_Exit = .TRUE. + + + ! This is cross-band: + + L__Do_CrossBand = .TRUE. + + N__BandToUse(:) = 0 + N__BandToUse(1:N__Num_Bands) = (/ 1,1,1,4,1 /) + + + ! This is the setup for imager cloud detection + + L__Do_Imager_Cloud_Detection = .FALSE. + + N__Num_Imager_Chans = 0 + N__Num_Imager_Clusters = 0 + N__Imager_Chans(:) = 0 + + R__Stddev_Threshold(:) = 0.0_r_kind + R__Coverage_Threshold = 0.0_r_kind + R__FG_Departure_Threshold = 0.0_r_kind + + + CASE(INST_ID_IASI) + !==================== + ! Set up IASI + !==================== + + CL__InstrumentName='IASI' + CL__Cloud_Detection_File = 'IASI_CLDDET.NL' + + N__Num_Bands = 5 + + N__Band_Size(:) = 0 + N__Band_Size(1:N__Num_Bands) =(/ 184, 15, 116, 4, 15 /) + + N__Bands(:,:)= 0 + + ! Use the "IASI 366" Subset + N__Bands(1:N__Band_Size(1),1) = & + (/ 16, 38, 49, 51, 55, 57, 59, 61, 63, 66, & + 70, 72, 74, 79, 81, 83, 85, 87, 89, 92, & + 95, 97, 99, 101, 104, 106, 109, 111, 113, 116, & + 119, 122, 125, 128, 131, 133, 135, 138, 141, 144, & + 146, 148, 151, 154, 157, 159, 161, 163, 165, 167, & + 170, 173, 176, 178, 179, 180, 183, 185, 187, 189, & + 191, 193, 195, 197, 199, 201, 203, 205, 207, 210, & + 212, 214, 217, 219, 222, 224, 226, 228, 230, 232, & + 234, 236, 239, 241, 242, 243, 246, 249, 252, 254, & + 256, 258, 260, 262, 265, 267, 269, 271, 272, 273, & + 275, 278, 280, 282, 284, 286, 288, 290, 292, 294, & + 296, 299, 301, 303, 306, 308, 310, 312, 314, 316, & + 318, 320, 323, 325, 327, 329, 331, 333, 335, 341, & + 347, 350, 352, 354, 356, 358, 360, 362, 364, 366, & + 369, 371, 373, 375, 377, 379, 381, 386, 389, 404, & + 407, 410, 414, 416, 426, 428, 432, 434, 445, 457, & + 515, 546, 552, 566, 571, 573, 646, 662, 668, 756, & + 867, 921, 1027, 1090, 1133, 1191, 1194, 1271, 1805, 1884, & + 1946, 1991, 2094, 2239 /) + + N__Bands(1:N__Band_Size(2),2) = & + (/ 1479, 1509, 1513, 1521, 1536, 1574, 1579, 1585, 1587, 1626, & + 1639, 1643, 1652, 1658, 1671 /) + + N__Bands(1:N__Band_Size(3),3) = & + (/ 2119, 2213, 2271, 2321, 2398, 2701, 2741, 2819, 2889, 2907, & + 2910, 2919, 2939, 2944, 2948, 2951, 2958, 2977, 2985, 2988, & + 2991, 2993, 3002, 3008, 3014, 3027, 3029, 3036, 3047, 3049, & + 3053, 3058, 3064, 3069, 3087, 3093, 3098, 3105, 3107, 3110, & + 3127, 3136, 3151, 3160, 3165, 3168, 3175, 3178, 3207, 3228, & + 3244, 3248, 3252, 3256, 3263, 3281, 3303, 3309, 3312, 3322, & + 3375, 3378, 3411, 3438, 3440, 3442, 3444, 3446, 3448, 3450, & + 3452, 3454, 3458, 3467, 3476, 3484, 3491, 3497, 3499, 3504, & + 3506, 3509, 3518, 3527, 3555, 3575, 3577, 3580, 3582, 3586, & + 3589, 3599, 3653, 3658, 3661, 4032, 5368, 5371, 5379, 5381, & + 5383, 5397, 5399, 5401, 5403, 5405, 5455, 5480, 5483, 5485, & + 5492, 5502, 5507, 5509, 5517, 5558 /) + + N__Bands(1:N__Band_Size(4),4) = & + (/ 5988, 5992, 5994, 6003 /) + + N__Bands(1:N__Band_Size(5),5) = & + (/ 6982, 6985, 6987, 6989, 6991, 6993, 6995, 6997, 7267, 7269, & + 7424, 7426, 7428, 7885, 8007 /) + + N__GradChkInterval(:) = 0 + N__GradChkInterval(1:N__Num_Bands) = (/12,5,5,5,5 /) + + N__Window_Width(:) = 0 + N__Window_Width(1:N__Num_Bands) = (/ 10,6,8,5,8 /) + + N__Window_Bounds(:,:) = 0 + N__Window_Bounds(1,1) = 573 + N__Window_Bounds(1,2) = 2239 + + R__BT_Threshold(:) = 0.0_r_kind + R__BT_Threshold(1:N__Num_Bands) = (/ 0.5_r_kind, 0.5_r_kind, 0.5_r_kind, 0.5_r_kind, 0.5_r_kind /) + + R__Grad_Threshold(:) = 0.0_r_kind + R__Grad_Threshold(1:N__Num_Bands) = (/ 0.02_r_kind, 0.02_r_kind, 0.02_r_kind, 0.02_r_kind, 0.02_r_kind /) + + R__Window_Grad_Threshold(:) = 0.0_r_kind + R__Window_Grad_Threshold(1) = 0.4_r_kind + + L__Do_Quick_Exit = .TRUE. + + + ! This is cross-band: + + L__Do_CrossBand = .TRUE. + + N__BandToUse(:) = 0 + N__BandToUse(1:N__Num_Bands) = (/ 1,1,1,1,1 /) + + + ! This is the setup for imager cloud detection + + L__Do_Imager_Cloud_Detection = .TRUE. + + N__Num_Imager_Chans = 2 + N__Num_Imager_Clusters = 7 + + N__Imager_Chans(1:N__Num_Imager_Chans) = (/ 2, 3 /) + + R__Stddev_Threshold(1:N__Num_Imager_Chans) = (/ 0.75_r_kind, 0.80_r_kind /) + + R__Coverage_Threshold = 0.03_r_kind + R__FG_Departure_Threshold = 1.0_r_kind + + + CASE(INST_ID_CRIS) + !==================== + ! Set up CRIS + !==================== + + CL__InstrumentName='CRIS' + CL__Cloud_Detection_File = 'CRIS_CLDDET.NL' + + N__Num_Bands = 5 + + N__Band_Size(:) = 0 + + N__Band_Size(1:N__Num_Bands) =(/ 137, 123, 76, 12, 6 /) + + N__Bands(:,:)= 0 + + ! Use the "CRIS 300" Subset + N__Bands(1:N__Band_Size(1),1) = & + (/ 1, 5, 9, 13, 17, 18, 19, 20, 21, 22, & + 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, & + 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, & + 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, & + 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, & + 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, & + 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, & + 83, 84, 85, 86, 87, 88, 91, 92, 93, 94, & + 95, 96, 97, 99, 101, 105, 107, 109, 111, 113, & + 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, & + 125, 133, 135, 137, 139, 141, 144, 147, 161, 173, & + 177, 181, 185, 195, 210, 221, 225, 229, 249, 257, & + 269, 273, 293, 301, 317, 333, 349, 369, 409, 433, & + 457, 481, 501, 549, 701, 705, 709 /) + + N__Bands(1:N__Band_Size(2),2) = & + (/ 3, 6, 7, 8, 10, 12, 14, 15, 16, 89, & + 90, 102, 103, 104, 106, 108, 110, 114, 126, 127, & + 129, 132, 134, 138, 140, 143, 145, 146, 148, 149, & + 150, 151, 153, 155, 156, 157, 158, 159, 162, 163, & + 164, 165, 166, 169, 170, 171, 172, 175, 180, 189, & + 200, 201, 205, 206, 214, 217, 218, 226, 228, 230, & + 231, 233, 236, 237, 240, 241, 245, 248, 252, 264, & + 265, 281, 285, 297, 324, 327, 361, 378, 389, 392, & + 400, 473, 493, 500, 503, 511, 527, 528, 529, 530, & + 531, 534, 538, 542, 544, 545, 547, 550, 553, 555, & + 590, 594, 598, 602, 606, 610, 614, 618, 622, 626, & + 645, 649, 653, 657, 661, 665, 685, 702, 703, 704, & + 706, 707, 713 /) + + N__Bands(1:N__Band_Size(3),3) = & + (/ 717, 725, 728, 729, 730, 731, 732, 733, 734, 735, & + 736, 741, 749, 757, 765, 773, 781, 789, 794, 797, & + 805, 806, 815, 822, 829, 839, 845, 853, 861, 868, & + 869, 872, 877, 885, 887, 893, 898, 900, 909, 912, & + 915, 917, 921, 929, 933, 941, 949, 957, 963, 965, & + 973, 975, 978, 981, 989, 991, 993, 996, 1005, 1014, & + 1025, 1029, 1037, 1042, 1053, 1061, 1073, 1077, 1085, 1093, & + 1101, 1109, 1117, 1125, 1133, 1141 /) + + N__Bands(1:N__Band_Size(4),4) = & + (/ 1149, 1157, 1164, 1165, 1173, 1181, 1189, 1197, 1205, 1213, & + 1221, 1251 /) + + N__Bands(1:N__Band_Size(5),5) = & + (/ 1189, 1197, 1205, 1213, 1221, 1251 /) + + + N__GradChkInterval(:) = 0 + N__GradChkInterval(1:N__Num_Bands) = (/ 5,5,5,3,3 /) + + N__Window_Width(:) = 0 + N__Window_Width(1:N__Num_Bands) = (/ 6,6,8,3,3 /) + + N__Window_Bounds(:,:) = 0 + N__Window_Bounds(1,1) = 229 + N__Window_Bounds(1,2) = 549 + + R__BT_Threshold(:) = 0.0_r_kind + R__BT_Threshold(1:N__Num_Bands) = (/ 0.5_r_kind, 0.5_r_kind, 0.5_r_kind, 0.5_r_kind, 0.5_r_kind /) + + R__Grad_Threshold(:) = 0.0_r_kind + R__Grad_Threshold(1:N__Num_Bands) = (/ 0.02_r_kind, 0.02_r_kind, 0.02_r_kind, 0.02_r_kind, 0.02_r_kind /) + + R__Window_Grad_Threshold(:) = 0.0_r_kind + R__Window_Grad_Threshold(1) = 0.4_r_kind + + L__Do_Quick_Exit = .TRUE. + + + ! This is cross-band: + + L__Do_CrossBand = .TRUE. + + N__BandToUse(:) = 0 + N__BandToUse(1:N__Num_Bands) = (/ 1,1,1,1,1 /) + + + ! This is the setup for imager cloud detection + + L__Do_Imager_Cloud_Detection = .FALSE. + + N__Num_Imager_Chans = 0 + N__Num_Imager_Clusters = 0 + N__Imager_Chans(:) = 0 + + R__Stddev_Threshold(:) = 0.0_r_kind + R__Coverage_Threshold = 0.0_r_kind + R__FG_Departure_Threshold = 0.0_r_kind + + + CASE(INST_ID_IRS) + !==================== + ! Set up IRS + !==================== + + CL__InstrumentName='IRS' + CL__Cloud_Detection_File = 'IRS_CLDDET.NL' + + N__Num_Bands = 1 + + N__Band_Size(:) = 0 + + N__Band_Size(1:N__Num_Bands) =(/ 138 /) + + N__Bands(:,:)= 0 + + N__Bands(1:N__Band_Size(1),1) = & + (/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, & + 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, & + 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, & + 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, & + 41, 42, 43, 44, 45, 46, 48, 53, 54, 55, & + 56, 57, 58, 60, 61, 62, 63, 65, 70, 74, & + 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, & + 85, 86, 87, 89, 90, 91, 92, 93, 94, 95, & + 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, & + 106, 107, 108, 109, 118, 119, 131, 145, 163, 169, & + 177, 180, 190, 195, 199, 209, 215, 221, 231, 237, & + 252, 262, 268, 281, 289, 298, 312, 322, 328, 341, & + 347, 359, 375, 384, 390, 404, 412, 421, 648, 656, & + 667, 678, 686, 692, 709, 750, 792, 808 /) + + N__GradChkInterval(:) = 0 + N__GradChkInterval(1:N__Num_Bands) = (/ 12 /) + + N__Window_Width(:) = 0 + N__Window_Width(1:N__Num_Bands) = (/ 10 /) + + N__Window_Bounds(:,:) = 0 + N__Window_Bounds(1,1) = 131 + N__Window_Bounds(1,2) = 808 + + R__BT_Threshold(:) = 0.0_r_kind + R__BT_Threshold(1:N__Num_Bands) = (/ 0.4_r_kind /) + + R__Grad_Threshold(:) = 0.0_r_kind + R__Grad_Threshold(1:N__Num_Bands) = (/ 0.02_r_kind /) + + R__Window_Grad_Threshold(:) = 0.0_r_kind + R__Window_Grad_Threshold(1) = 0.4_r_kind + + L__Do_Quick_Exit = .TRUE. + + + ! This is cross-band: + + L__Do_CrossBand = .TRUE. + + N__BandToUse(:) = 0 + N__BandToUse(1:N__Num_Bands) = (/ 1 /) + + + ! This is the setup for imager cloud detection + + L__Do_Imager_Cloud_Detection = .FALSE. + + N__Num_Imager_Chans = 0 + N__Num_Imager_Clusters = 0 + N__Imager_Chans(:) = 0 + + R__Stddev_Threshold(:) = 0.0_r_kind + R__Coverage_Threshold = 0.0_r_kind + R__FG_Departure_Threshold = 0.0_r_kind + + + CASE(INST_ID_IASING) + !==================== + ! Set up IASING + !==================== + + CL__InstrumentName='IASING' + CL__Cloud_Detection_File = 'IASING_CLDDET.NL' + + N__Num_Bands = 1 + + N__Band_Size(:) = 0 + + N__Band_Size(1:N__Num_Bands) =(/ 254 /) + + N__Bands(:,:)= 0 + + N__Bands(1:N__Band_Size(1),1) = & + (/ 31, 75, 97, 101, 109, 113, 117, 121, 125, 131, & + 139, 143, 147, 157, 161, 165, 169, 173, 177, 183, & + 189, 193, 197, 201, 207, 211, 217, 221, 225, 231, & + 237, 243, 249, 255, 261, 265, 269, 275, 281, 287, & + 291, 295, 301, 307, 313, 317, 321, 325, 329, 333, & + 339, 345, 351, 355, 357, 359, 365, 369, 373, 377, & + 381, 385, 389, 393, 397, 401, 403, 405, 407, 409, & + 411, 413, 415, 417, 419, 421, 423, 425, 427, 429, & + 431, 433, 435, 437, 439, 441, 443, 445, 447, 449, & + 451, 453, 455, 457, 459, 461, 463, 465, 467, 469, & + 471, 473, 475, 477, 479, 481, 483, 485, 487, 489, & + 491, 493, 495, 497, 499, 501, 503, 505, 507, 509, & + 511, 513, 515, 517, 519, 521, 523, 525, 527, 529, & + 531, 533, 535, 537, 539, 541, 543, 545, 547, 549, & + 551, 553, 555, 557, 559, 561, 563, 565, 567, 569, & + 571, 573, 575, 577, 579, 581, 583, 585, 587, 589, & + 591, 593, 595, 597, 601, 603, 605, 607, 609, 611, & + 613, 615, 617, 619, 621, 623, 625, 627, 629, 631, & + 633, 635, 637, 639, 641, 643, 645, 647, 649, 651, & + 653, 655, 657, 659, 661, 663, 665, 667, 669, 681, & + 693, 699, 703, 707, 711, 715, 719, 723, 727, 731, & + 737, 741, 745, 749, 753, 757, 761, 771, 777, 807, & + 813, 819, 827, 831, 851, 855, 863, 867, 889, 913, & + 1029, 1091, 1103, 1131, 1141, 1145, 1291, 1323, 1335, 1511, & + 1733, 1841, 2053, 2179, 2265, 2381, 2387, 2541, 3609, 3767, & + 3891, 3981, 4187, 4477 /) + + N__GradChkInterval(:) = 0 + N__GradChkInterval(1:N__Num_Bands) = (/ 25 /) + + N__Window_Width(:) = 0 + N__Window_Width(1:N__Num_Bands) = (/ 20 /) + + N__Window_Bounds(:,:) = 0 + N__Window_Bounds(1,1) = 1145 + N__Window_Bounds(1,2) = 4477 + + R__BT_Threshold(:) = 0.0_r_kind + R__BT_Threshold(1:N__Num_Bands) = (/ 0.27_r_kind /) + + R__Grad_Threshold(:) = 0.0_r_kind + R__Grad_Threshold(1:N__Num_Bands) = (/ 0.02_r_kind /) + + R__Window_Grad_Threshold(:) = 0.0_r_kind + R__Window_Grad_Threshold(1) = 0.4_r_kind + + L__Do_Quick_Exit = .TRUE. + + + ! This is cross-band: + + L__Do_CrossBand = .TRUE. + + N__BandToUse(:) = 0 + N__BandToUse(1:N__Num_Bands) = (/ 1 /) + + ! This is the setup for imager cloud detection + + L__Do_Imager_Cloud_Detection = .FALSE. + + N__Num_Imager_Chans = 0 + N__Num_Imager_Clusters = 0 + N__Imager_Chans(:) = 0 + + R__Stddev_Threshold(:) = 0.0_r_kind + R__Coverage_Threshold = 0.0_r_kind + R__FG_Departure_Threshold = 0.0_r_kind + + + END SELECT + + !------------------------------------------------------------------ + ! Open and read file containing cloud detection setup for the + ! current instrument + !------------------------------------------------------------------ + + INIU1=107 + OPEN(INIU1,STATUS='OLD',FORM='FORMATTED', & + FILE=TRIM(CL__Cloud_Detection_File), IOSTAT=IOS) + IF (IOS == 0) THEN + READ(INIU1,nml=Cloud_Detect_Coeffs,IOSTAT=IOS) + IF (IOS == 0) THEN + if ( verbose ) WRITE(*,'(3X,A)') TRIM(CL__InstrumentName) // & + ' CLOUD DETECTION FILE READ OK' + ELSE + CALL CADS_Abort('PROBLEM READING '//TRIM(CL__InstrumentName)//& + 'CLOUD DETECTION FILE') + ENDIF + CLOSE(INIU1) + ELSE + if ( verbose ) WRITE(*,'(3X,A)') 'NO '//TRIM(CL__InstrumentName) // & + ' CLOUD DETECTION FILE : Using Default Values' + ENDIF + + IF (MAXVAL(N__Band_Size(:)) > JP__Max_Channels) & + CALL CADS_Abort('Too many channels specified in cloud '//& + 'detection - increase JP__Max_Channels') + + + M__Sensor = J__SENSOR + + !------------------------------------------------------------------ + ! Set up the S__CADS_Setup_Cloud structure for current sensor + !------------------------------------------------------------------ + + S__CADS_Setup_Cloud(J__SENSOR) % M__SENSOR = M__Sensor + + S__CADS_Setup_Cloud(J__SENSOR) % N__Num_Bands = N__Num_Bands + + ALLOCATE( S__CADS_Setup_Cloud(J__SENSOR) % N__Band_Size(N__Num_Bands) ) + + S__CADS_Setup_Cloud(J__SENSOR) % N__Band_Size(:) = & + N__Band_Size(1:N__Num_Bands) + + ALLOCATE(S__CADS_Setup_Cloud(J__SENSOR) % N__Bands & + (MAXVAL(N__Band_Size(:)), N__Num_Bands)) + + S__CADS_Setup_Cloud(J__SENSOR) % N__Bands(:,:) = 0 + + DO J = 1, N__Num_Bands + S__CADS_Setup_Cloud(J__SENSOR) % N__Bands(1:N__Band_Size(J),J) = & + N__Bands(1:N__Band_Size(J),J) + ENDDO + + ALLOCATE( S__CADS_Setup_Cloud(J__SENSOR) % N__Window_Width(N__Num_Bands) ) + + S__CADS_Setup_Cloud(J__SENSOR) % N__Window_Width(:) = & + N__Window_Width(1:N__Num_Bands) + + ALLOCATE( S__CADS_Setup_Cloud(J__SENSOR) % R__BT_Threshold(N__Num_Bands) ) + S__CADS_Setup_Cloud(J__SENSOR) % R__BT_Threshold(:) = & + R__BT_Threshold(1:N__Num_Bands) + + ALLOCATE(S__CADS_Setup_Cloud(J__SENSOR) % R__Grad_Threshold(N__Num_Bands)) + S__CADS_Setup_Cloud(J__SENSOR) % R__Grad_Threshold(:) = & + R__Grad_Threshold(1:N__Num_Bands) + + ALLOCATE(S__CADS_Setup_Cloud(J__SENSOR) % & + R__Window_Grad_Threshold(N__Num_Bands)) + + S__CADS_Setup_Cloud(J__SENSOR) % R__Window_Grad_Threshold(:) = & + R__Window_Grad_Threshold(1:N__Num_Bands) + + ALLOCATE(S__CADS_Setup_Cloud(J__SENSOR) % N__GradChkInterval(N__Num_Bands)) + S__CADS_Setup_Cloud(J__SENSOR) % N__GradChkInterval(:) = & + N__GradChkInterval(1:N__Num_Bands) + + ALLOCATE(S__CADS_Setup_Cloud(J__SENSOR) % N__Window_Bounds(N__Num_Bands,2)) + S__CADS_Setup_Cloud(J__SENSOR) % N__Window_Bounds(:,:) = & + N__Window_Bounds(1:N__Num_Bands,:) + + S__CADS_Setup_Cloud(J__SENSOR) % L__Do_Quick_Exit = L__Do_Quick_Exit + + + !------------- + ! Cross Band + !------------- + + S__CADS_Setup_Cloud(J__SENSOR) % L__Do_CrossBand = L__Do_CrossBand + + ALLOCATE( S__CADS_Setup_Cloud(J__SENSOR) % N__BandToUse(N__Num_Bands) ) + S__CADS_Setup_Cloud(J__SENSOR) % N__BandToUse(:) = & + N__BandToUse(1:N__Num_Bands) + + + !------------- + ! Imager cloud detection + !------------- + + S__CADS_Setup_Cloud(J__SENSOR) % L__Do_Imager_Cloud_Detection = & + L__Do_Imager_Cloud_Detection + + S__CADS_Setup_Cloud(J__SENSOR) % N__Num_Imager_Chans = & + N__Num_Imager_Chans + + S__CADS_Setup_Cloud(J__SENSOR) % N__Num_Imager_Clusters = & + N__Num_Imager_Clusters + + ALLOCATE( S__CADS_Setup_Cloud(J__SENSOR) % & + N__Imager_Chans(N__Num_Imager_Chans)) + S__CADS_Setup_Cloud(J__SENSOR) % N__Imager_Chans(:) = & + N__Imager_Chans(1:N__Num_Imager_Chans) + + ALLOCATE( S__CADS_Setup_Cloud(J__SENSOR) % & + R__Stddev_Threshold(N__Num_Imager_Chans)) + S__CADS_Setup_Cloud(J__SENSOR) % R__Stddev_Threshold(:) = & + R__Stddev_Threshold(1:N__Num_Imager_Chans) + + S__CADS_Setup_Cloud(J__SENSOR) % R__Coverage_Threshold = & + R__Coverage_Threshold + + S__CADS_Setup_Cloud(J__SENSOR) % R__FG_Departure_Threshold = & + R__FG_Departure_Threshold + + ENDDO SensorLoop + +END SUBROUTINE CADS_SETUP_CLOUD + +SUBROUTINE CADS_Detect_Cloud( K__Sensor, K__NChans, K__ChanID, K__Minlev, K__Maxlev, & + K__Num_Imager_Chans, K__Chan_ID_Imager, K__Num_Imager_Clusters, & + K__Cloud_Flag, P__ObsBTs, P__ModelBTs, P__Chan_Level, P__Cluster_Fraction,& + P__BT_in_Cluster, P__BT_Overall_SDev, P__BT_Model_Imager, Z__Cloud_Level ) + +! This software was developed within the context of the EUMETSAT +! Satellite Application Facility on Numerical Weather Prediction +! (NWP SAF), under the Cooperation Agreement dated 7 December 2016, +! between EUMETSAT and the Met Office, UK, by one or more partners +! within the NWP SAF. The partners in the NWP SAF are the Met +! Office, ECMWF, DWD and MeteoFrance. + +! Copyright 2020, EUMETSAT, All Rights Reserved. + +! * CADS_Detect_Cloud * +! Phil Watts ECMWF 21/01/02 + +! * PURPOSE * +! ----------- +! Flag the presence or otherwise of cloud contamination in AIRS/IASI +! channels using a rank-sorted/model difference method. Currently +! only a digital filter is supported. + + +! * INTERFACE * +! ------------- +! *CALL* * CADS_Detect_Cloud( )* (from CADS_Main) +! WHERE K__Sensor : Satellite sensor (AIRS/IASI/CrIS) +! K__NChans : Number of channels +! K__ChanID : Channel indices of input channels +! K__Minlev : Highest allowed starting point for the cloud search +! K__Maxlev : Lowest allowed starting point in the initial cloud search +! K__Num_Imager_Chans : Number of collocated imager channels +! K__Chan_ID_Imager : Collocated imager channel indices +! K__Num_Imager_Clusters : Number of collocated clusters +! K__Cloud_Flag : Cloud flag by channel; 0=clear, 1=cloudy +! P__ObsBTs : Potentially cloud-affected observed BTs +! P__ModelBTs : Clear background brightness temperatures (BTs) +! P__Chan_Level : Channel height assignments +! P__Cluster_Fraction : Fractional coverage of each cluster within FOV +! P__BT_in_Cluster : Cluster-mean brightness temperature (BT) on each channel +! P__BT_Overall_SDev : Overall BT standard deviation on each channel +! P__BT_Model_Imager : Forward-modelled BT on each channel +! Z__Cloud_Level : Cloud height assignment + +! * EXTERNALS * +! ------------- +! CADS_Detect_Cloud_Imager, CADS_Detect_Cloud_Heapsort, +! CADS_Detect_Cloud_Smooth, CADS_Detect_Cloud_Scenario, +! CADS_Detect_Cloud_Separator + +! * MODIFICATIONS * +! ----------------- +! A.Collard 1.0 01/02/06 Original export version +! A.Collard 1.0.1 03/05/06 Allow for missing channels +! A.Collard 1.0.2 04/05/06 Allow cross-band cloud detection +! A.Collard 1.0.3 15/01/07 Initialise with automatic cross-band for +! all channels from band 1 for IASI +! R.Eresmaa 1.1 17/11/09 Include parameters of the Quick Exit / +! long-wave window gradient check. +! Pass K__Chan_Low to CF_DIGITAL to allow +! detecting cirrus in case of compensating +! humidity bg error in PBL. +! R.Eresmaa 1.2 11/11/11 Modify the cross-band option to be based +! on the lowest clear channel rather than +! on the highest cloud-contaminated one +! R.Eresmaa 2.0 27/11/13 Add input cloud flag based on collocated +! imager data +! R.Eresmaa 2.1 13/01/15 Make array size specifications implicit. +! R.Eresmaa 2.2 10/11/15 Instrument ID naming convention made +! consistent with RTTOV. +! Changed setting of the aerosol flag. +! R.Eresmaa 2.2.1 13/11/15 Don't allow flagging missing channels clear +! through the cross-band option. +! R.Eresmaa 2.3 20/12/16 Remove the call to aerosol detection. +! R.Eresmaa 2.4 05/02/19 Explicit KIND specifications. +! R.Eresmaa 3.0 16/04/20 Move the call to imager-based detection here. + + use kinds, only: i_kind, r_kind + use gsi_io, only: verbose + IMPLICIT NONE + +!* 0.1 Global arrays + INTEGER(i_kind), INTENT(IN) :: K__Sensor ! Sensor + INTEGER(i_kind), INTENT(IN) :: K__NChans ! No. of channels + INTEGER(i_kind), INTENT(IN) :: K__ChanID(:) ! Channel IDs + INTEGER(i_kind), INTENT(IN) :: K__Minlev ! Highest starting point for cloud search + INTEGER(i_kind), INTENT(IN) :: K__Maxlev ! Lowest starting point in the initial search + INTEGER(i_kind), INTENT(IN) :: K__Num_Imager_Chans ! No. of imager channels + INTEGER(i_kind), INTENT(IN) :: K__Chan_ID_Imager(:) ! Imager channel IDs + INTEGER(i_kind), INTENT(IN) :: K__Num_Imager_Clusters ! No. of imager clusters + INTEGER(i_kind), INTENT(OUT) :: K__Cloud_Flag(:) ! Output cloud flags + REAL(r_kind), INTENT(IN) :: P__ObsBTs(:) ! Observed BTs + REAL(r_kind), INTENT(IN) :: P__ModelBTs(:) ! Model clear BTs + REAL(r_kind), INTENT(IN) :: P__Chan_Level(:) ! Channel height assignments + REAL(r_kind), INTENT(IN) :: P__Cluster_Fraction(:) ! Cluster coverages + REAL(r_kind), INTENT(IN) :: P__BT_in_Cluster(:,:) ! Mean BT in cluster / channel + REAL(r_kind), INTENT(IN) :: P__BT_Overall_Sdev(:) ! St.Dev of imager BT in FOV + REAL(r_kind), INTENT(IN) :: P__BT_Model_Imager(:) ! Model-based estimate of imager BT + REAL(r_kind), INTENT(OUT) :: Z__Cloud_Level ! Cloud hight assignment + +!* 0.2 local variables + INTEGER(i_kind) :: IST,ICOUNT,J,I_K,JBAND,JBAND2 + INTEGER(i_kind) :: I__Imager_Flag ! Preliminary cloud flag from collocated imager data + +!* 0.3 Local variables - band splitting details + INTEGER(i_kind), POINTER :: I__Bands(:,:) ! Channel bands + INTEGER(i_kind), POINTER :: I__Band_Size(:) ! Number of channels per band + INTEGER(i_kind), POINTER :: I__BandToUse(:) ! Cross-band definitions + INTEGER(i_kind) :: I__Num_Bands ! Number of bands + INTEGER(i_kind) :: I__NumFoundChans ! Number of usable channels + INTEGER(i_kind) :: I__BandNumber(K__NChans) ! Channel band indicator + INTEGER(i_kind) :: I__WindowBounds(2) ! Boundary of window + INTEGER(i_kind) :: I__Window_Chans(2) ! Boundary of long-wave window + INTEGER(i_kind), ALLOCATABLE :: I__INDEX(:) ! Channel ranking within a band + INTEGER(i_kind), ALLOCATABLE :: IDCHAN(:) ! Overall channel ranking + INTEGER(i_kind), ALLOCATABLE :: I__Cloud_Flag(:) ! Rank-sorted output cloud flags + INTEGER(i_kind) :: I__Scenario_Index ! 1--Quick Exit, 2--Warm Start, 3--Cold Start + INTEGER(i_kind) :: I__Start_Channel ! Final starting channel in the cloud search + + LOGICAL :: LL__Do_CrossBand + +! Input array projections (handling one detection band at a time) + REAL(r_kind), ALLOCATABLE :: Z__DBT(:) ! Original departures + REAL(r_kind), ALLOCATABLE :: Z__Smooth_DBT(:) ! Smoothed departures + REAL(r_kind), ALLOCATABLE :: Z__LEVEL(:) ! Channel height assignments + +!* 0.4 Local variables - digital filter parameters + INTEGER(i_kind) :: I__CHAN_HIGH ! Channel at K__Minlev + INTEGER(i_kind) :: I__CHAN_LOW ! Channel at K__Maxlev + INTEGER(i_kind) :: I__FirstCloudyChannel ! Highest cloud-affected channel + INTEGER(i_kind) :: I__LastClearChannel ! Lowest clear channel + INTEGER(i_kind),POINTER :: I__Window_Width(:) ! Box-car filter width + INTEGER(i_kind),POINTER :: I__GradChkInterval(:) ! Gradient-check interval + +!====================================================================== + + +! Get correct processing parameters for this sensor: + I__Num_Bands = S__CADS_Setup_Cloud(K__Sensor) % N__Num_Bands + I__Band_Size => S__CADS_Setup_Cloud(K__Sensor) % N__Band_Size + I__Bands => S__CADS_Setup_Cloud(K__Sensor) % N__Bands + I__Window_Width => S__CADS_Setup_Cloud(K__Sensor) % N__Window_Width + I__BandToUse => S__CADS_Setup_Cloud(K__Sensor) % N__BandToUse + LL__Do_CrossBand = S__CADS_Setup_Cloud(K__Sensor) % L__Do_CrossBand + I__GradChkInterval => S__CADS_Setup_Cloud(K__Sensor) % N__GradChkInterval + + +! Initialise + K__Cloud_Flag(:)=1 ! intialise ALL channels to cloudy + + +! Imager-based cloud detection + I__Imager_Flag=0 ! Default assumption: no cloud affecting collocated imager data + CALL CADS_Detect_Cloud_Imager( K__Sensor, K__Num_Imager_Chans, K__Chan_ID_Imager, K__Num_Imager_Clusters, & + I__Imager_Flag, P__Cluster_Fraction, P__BT_in_Cluster, P__BT_Overall_SDev, P__BT_Model_Imager ) + +! If using cross-band, set up an array indicating which channels correspond +! to which bands in K__ChanID + IF (LL__Do_CrossBand) THEN + I__BandNumber(:)=-1 ! Initialise + DO JBAND = 1, I__Num_Bands + DO I_K=1,K__NChans + IF (ANY(I__BANDS(:,JBAND) == K__ChanID(I_K))) & + I__BandNumber(I_K)=JBand + ENDDO + ENDDO + ENDIF + + +!1 Loop over bands + Band_Loop: DO JBAND = 1, I__Num_Bands + + ! Don't bother doing the cloud detection if we're just going to use + ! the results from another band anyway: + IF (LL__Do_CrossBand) THEN + IF (.NOT.(ANY(I__BandToUse(:) == JBAND))) CYCLE + ENDIF + + ALLOCATE (Z__DBT(I__Band_Size(JBAND))) + Z__DBT(:) = 0.0_r_kind + + ALLOCATE (Z__LEVEL(I__Band_Size(JBAND))) + Z__LEVEL(:) = REAL(K__Maxlev) + + ALLOCATE (I__Cloud_Flag(I__Band_Size(JBAND))) + ALLOCATE (I__INDEX(I__Band_Size(JBAND))) + + ALLOCATE (IDCHAN(I__Band_Size(JBAND))) + IDCHAN(:) = 1 + + + I__WindowBounds(:) = & + S__CADS_Setup_Cloud(K__Sensor) % N__Window_Bounds(JBand,:) + +!1.1 find channels within current band -------------------------------------- + I__NumFoundChans = 0 + I__Window_Chans(:) = -1 + + DO J=1,I__Band_Size(JBAND) + DO I_K=1,K__NChans + IF (K__ChanID(I_K) == I__BANDS(J,JBAND)) THEN +! IF (P__ObsBTs(I_K) < 0. .OR. P__ModelBTs(I_K) < 0.) CYCLE + IF (P__ObsBTs(I_K) < 60.0_r_kind .OR. P__ModelBTs(I_K) < 60.0_r_kind) CYCLE ! Missing channels are set to 50.0K + I__NumFoundChans = I__NumFoundChans + 1 + Z__DBT(I__NumFoundChans)=P__ObsBTs(I_K)-P__ModelBTs(I_K) + Z__LEVEL(I__NumFoundChans)=P__Chan_Level(I_K) + I__INDEX(I__NumFoundChans)=I__NumFoundChans + IDCHAN(I__NumFoundChans)=I_K + IF (K__ChanID(I_K) == I__WindowBounds(1)) & + I__Window_Chans(1) = I__NumFoundChans + IF (K__ChanID(I_K) == I__WindowBounds(2)) & + I__Window_Chans(2) = I__NumFoundChans + ENDIF + ENDDO + ENDDO + IF ( I__NumFoundChans == 0 ) THEN + if (verbose) WRITE(*,*) & + '**CADS_Detect_Cloud - WARNING: ' // & + 'CHANNELS NOT FOUND CYCLING BAND: **', JBAND + IF (ALLOCATED(Z__DBT)) DEALLOCATE (Z__DBT) + IF (ALLOCATED(Z__LEVEL)) DEALLOCATE (Z__LEVEL) + IF (ALLOCATED(I__Cloud_Flag)) DEALLOCATE (I__Cloud_Flag) + IF (ALLOCATED(I__INDEX)) DEALLOCATE (I__INDEX) + IF (ALLOCATED(IDCHAN)) DEALLOCATE (IDCHAN) + CYCLE Band_Loop + ENDIF + +!---------------------------------------------------------------------------- + IST=0 + ICOUNT=I__NumFoundChans + I__Cloud_Flag(:)=1 + +!2. Sort according to channel height assignments + CALL CADS_Detect_Cloud_Heapsort(I__NumFoundChans,Z__Level,I__Index) + +!2.1 Find I__CHAN_LOW - lowest channel considered in the initial cloud search + J=1 + DO WHILE (J < I__NumFoundChans .AND. Z__Level(I__Index(J)) < REAL(K__Maxlev)) + J=J+1 + ENDDO + + IF (J == I__NumFoundChans) THEN + I__CHAN_LOW = I__NumFoundChans-1 + ELSE + I__CHAN_LOW = J + ENDIF + IF(I__CHAN_LOW <= 1)I__CHAN_LOW=1 + +!2.1a Find I__CHAN_HIGH - highest allowed channel for starting the cloud search + J=1 + DO WHILE (J < I__NumFoundChans .AND. Z__Level(I__Index(J)) < REAL(K__Minlev)) + J=J+1 + ENDDO + I__CHAN_HIGH=J + + +! Smoothing + ALLOCATE (Z__Smooth_DBT(I__NumFoundChans)) + Z__Smooth_DBT(:) = 0.0_r_kind + + CALL CADS_Detect_Cloud_Smooth( I__NumFoundChans, I__Window_Width(JBAND), Z__DBT(I__INDEX(1:I__NumFoundChans)), & + Z__Smooth_DBT(1:I__NumFoundChans) ) + + +!3. Choice of cloud detection scenario + + CALL CADS_Detect_Cloud_Scenario( K__Sensor, JBAND, I__NumFoundChans, I__GradChkInterval(JBAND), I__Index(1:I__NumFoundChans), & + I__CHAN_HIGH, I__CHAN_LOW, I__Window_Chans, I__Imager_Flag, I__Scenario_Index, I__Start_Channel, Z__Smooth_DBT(1:I__NumFoundChans)) + + +!4. Identify the separation between clear/cloudy channels + + CALL CADS_Detect_Cloud_Separator( K__Sensor, JBAND, I__NumFoundChans, I__GradChkInterval(JBAND), I__Index(1:I__NumFoundChans), & + I__Cloud_Flag, I__FirstCloudyChannel, I__LastClearChannel, I__Scenario_Index, I__Start_Channel, Z__Smooth_DBT(1:I__NumFoundChans)) + + K__Cloud_Flag(IDCHAN(1:I__NumFoundChans)) = & + I__Cloud_Flag(1:I__NumFoundChans) + + ! Set cloud level for cross-band: + IF (I__FirstCloudyChannel == 0) THEN ! FOV is completely clear + Z__Cloud_Level = 1.e20_r_kind ! Large value + ELSE + Z__Cloud_Level = P__Chan_Level(IDCHAN(I__LastClearChannel)) + ENDIF + + ! Automatically do cross band cloud detection for all + ! interferometer channels (whether assigned a band or not) if + ! JBand == 1. This can be over-ridden for the other bands. + + IF (K__Sensor /= INST_ID_AIRS .AND. JBand == 1) & + WHERE(P__Chan_Level(:) < Z__Cloud_Level) K__Cloud_Flag(:) = 0 + + CrossBand : IF (LL__Do_CrossBand) THEN + ! Cross Band: + ! Loop through bands applying cloud detection to those that take their + ! cloud detection information from the current band JBAND. + DO JBand2 = 1, I__Num_Bands + IF (I__BandToUse(JBand2) == JBand) THEN + WHERE(P__Chan_Level(:) < Z__Cloud_Level .AND. & + I__BandNumber == JBand2 .AND. & + P__OBSBTs(:)>0.0_r_kind ) K__Cloud_Flag(:) = 0 + ENDIF + ENDDO + ENDIF CrossBand + +! Deallocate arrays + IF (ALLOCATED(Z__DBT)) DEALLOCATE (Z__DBT) + IF (ALLOCATED(Z__Smooth_DBT)) DEALLOCATE (Z__Smooth_DBT) + IF (ALLOCATED(Z__LEVEL)) DEALLOCATE (Z__LEVEL) + IF (ALLOCATED(I__Cloud_Flag)) DEALLOCATE (I__Cloud_Flag) + IF (ALLOCATED(I__INDEX)) DEALLOCATE (I__INDEX) + IF (ALLOCATED(IDCHAN)) DEALLOCATE (IDCHAN) + + ENDDO Band_Loop + +! Nullify pointers + NULLIFY(I__Band_Size, I__Bands, I__Window_Width, I__BandToUse) + +END SUBROUTINE CADS_Detect_Cloud + +SUBROUTINE CADS_Detect_Cloud_Imager( K__Sensor, K__Nchans, K__Chanid, K__Nclust, K__Cloud_Flag, P__Cl_Fraction, & + P__Cl_Mean, P__Ov_Stddev, P__FG_BT ) + +! This software was developed within the context of the EUMETSAT +! Satellite Application Facility on Numerical Weather Prediction +! (NWP SAF), under the Cooperation Agreement dated 7 December 2016, +! between EUMETSAT and the Met Office, UK, by one or more partners +! within the NWP SAF. The partners in the NWP SAF are the Met +! Office, ECMWF, DWD and MeteoFrance. +! +! Copyright 2020, EUMETSAT, All Rights Reserved. + +! *CADS_Detect_Cloud_Imager* +! R.Eresmaa ECMWF 12/02/13 + +! * PURPOSE * +! ----------- +! Provide additional information for the cloud detection by making use +! of collocated imager data, such as AVHRR collocated with IASI. + +! * INTERFACE * +! ------------- +! *CALL* * CADS_Detect_Cloud_Imager( )* (from CADS_Detect_Cloud) +! WHERE K__Sensor : Satellite sensor id +! K__Nchans : Number of channels received as input +! K__Chanid : Provided channel IDs +! K__Nclust : Highest possible number of clusters +! K__Cloud_Flag : Output cloud flag (0-7, 0=clear) +! P__Cl_Fraction : Fractional coverage of each cluster within FOV +! P__Cl_Mean : Cluster-mean brightness temperature (BT) on each +! channel +! P__Ov_Stddev : Overall BT standard deviation on each channel +! P__FG_BT : Forward-modelled BT on each channel + +! * METHOD * +! ---------- +! A preliminary indicator of presence of clouds in the sounder +! field-of-view (FOV) is derived using statistical radiance information +! within collocated clusters of imager pixels. + +! * MODIFICATIONS * +! ----------------- +! 03/12/13 R.Eresmaa 2.0 Original export version. +! 19/01/15 R.Eresmaa 2.1 Make array size specifications implicit. +! Verify that channels intended to be used +! are received as input. +! 05/02/19 R.Eresmaa 2.4 Explicit kind specifications. +! 16/04/20 R.Eresmaa 3.0 Rename and tidy up. + + use kinds, only: i_kind, r_kind + IMPLICIT NONE + +!* Global arrays + INTEGER(i_kind), INTENT(IN) :: K__Sensor ! Sensor id + INTEGER(i_kind), INTENT(IN) :: K__Nchans ! No. of channels + INTEGER(i_kind), INTENT(IN) :: K__Chanid(:) ! Channel IDs + INTEGER(i_kind), INTENT(IN) :: K__Nclust ! No. of clusters + INTEGER(i_kind), INTENT(OUT) :: K__Cloud_Flag ! Output cloud flag + REAL(r_kind), INTENT(IN) :: P__Cl_Fraction(:) ! Cluster fractions + REAL(r_kind), INTENT(IN) :: P__Cl_Mean(:,:) ! Cluster-mean BTs + REAL(r_kind), INTENT(IN) :: P__Ov_Stddev(:) ! Overall BT st.devs. + REAL(r_kind), INTENT(IN) :: P__FG_BT(:) ! First guess BT + +!* Local variables - Setup of the imager cloud detection + INTEGER(i_kind) :: I__Num_Imager_Chans ! No. of used channels + INTEGER(i_kind), POINTER :: I__Imager_Chans(:) ! List of used channels + REAL(r_kind), POINTER :: Z__Stddev_Threshold(:) ! Homogeneity thresholds + REAL(r_kind) :: Z__Coverage_Threshold ! Coverage threshold + REAL(r_kind) :: Z__FG_Departure_Threshold ! FG departure threshold + +!* Additional local variables + INTEGER(i_kind) :: I, J, IK, I_Temp_Flag, ICOUNT + INTEGER(i_kind) :: I__Chan_Index(K__Nchans) + REAL(r_kind) :: Z__Wsqdev, Z__Intercluster + REAL(r_kind),dimension(K__Nclust) :: Z__Sqdev + + + +!* 1.0 Initialize cloud flags as clear + + K__Cloud_Flag=0 + + IF (S__CADS_Setup_Cloud(K__Sensor) % L__Do_Imager_Cloud_Detection) THEN + + +!* 1.1 Setup + + I__Num_Imager_Chans = & + S__CADS_Setup_Cloud(K__Sensor) % N__Num_Imager_Chans + I__Imager_Chans => & + S__CADS_Setup_Cloud(K__Sensor) % N__Imager_Chans + Z__Stddev_Threshold => & + S__CADS_Setup_Cloud(K__Sensor) % R__Stddev_Threshold + Z__Coverage_Threshold = & + S__CADS_Setup_Cloud(K__Sensor) % R__Coverage_Threshold + Z__FG_Departure_Threshold = & + S__CADS_Setup_Cloud(K__Sensor) % R__FG_Departure_Threshold + + + +!* 1.2 Channel indexing + I__Chan_Index(:) = 0 + ICOUNT=0 + DO I=1,K__Nchans + IK=0 + DO J=1,I__Num_Imager_Chans + IF (K__Chanid(I)==I__Imager_Chans(J)) THEN + ICOUNT=ICOUNT+1 + IK=ICOUNT + EXIT + ENDIF + ENDDO + I__Chan_Index(I)=IK + ENDDO + + +!* 2.0 Compute squared first guess departures for each cluster + + DO J=1,K__Nclust + Z__Sqdev(J) = 0.0_r_kind + DO I=1,K__Nchans + IF (I__Chan_Index(I)==0) CYCLE + Z__Sqdev(J) = Z__Sqdev(J) + (P__Cl_Mean(I,J)-P__FG_BT(I))**2 + ENDDO + ENDDO + +!* 2.1 Homogeneity check: Do not diagnose presence of cloud if BT +! standard deviation falls below given threshold on at least one +! channel. + + I_Temp_Flag=1 + DO I=1,K__Nchans + IF (I__Chan_Index(I)==0) CYCLE + IF (P__Ov_Stddev(I)Z__Sqdev(J) .OR. Z__Intercluster>Z__Sqdev(IK)) THEN + K__Cloud_Flag=K__Cloud_Flag+2 + Exit Consistency_Check + ENDIF + ENDDO + ENDDO Consistency_Check + + +!* 2.3 First guess departure check: Do not diagnose presence of cloud +! if fraction-weighted first guess departure falls below given +! threshold. + + Z__Wsqdev = SUM(P__Cl_Fraction(:)*Z__Sqdev(:)) + IF (Z__Wsqdev>=Z__FG_Departure_Threshold) K__Cloud_Flag=K__Cloud_Flag+1 + + ENDIF ! L__Do_Imager_Cloud_Detection + +END SUBROUTINE CADS_Detect_Cloud_Imager + + +SUBROUTINE CADS_Detect_Cloud_Heapsort(N, A, K_Index) + +! This software was developed within the context of the EUMETSAT +! Satellite Application Facility on Numerical Weather Prediction +! (NWP SAF), under the Cooperation Agreement dated 7 December 2016, +! between EUMETSAT and the Met Office, UK, by one or more partners +! within the NWP SAF. The partners in the NWP SAF are the Met +! Office, ECMWF, DWD and MeteoFrance. +! +! Copyright 2020, EUMETSAT, All Rights Reserved. + +! * CADS_Detect_Cloud_Heapsort * +! A.Collard ECMWF 01/02/06 + +! * PURPOSE * +! ----------- +! Basic heapsort algorithm. + +! * INTERFACE * +! ------------- +! *CALL* * CADS_Detect_Cloud_Heapsort( )* (from CADS_Detect_Cloud) +! WHERE N : Length of input array +! A : Real input array +! K_Index : Output ranked array + +! * MODIFICATIONS * +! ----------------- +! 16/05/06 A.Collard 1.0 Original version. +! 05/02/19 R.Eresmaa 2.4 Explicit KIND specifications +! 16/04/20 R.Eresmaa 3.0 Rename as part of the big clean for CADS V3 + + + use kinds, only: i_kind, r_kind + IMPLICIT NONE + +! Subroutine arguments + INTEGER(i_kind), INTENT(IN) :: N + REAL(r_kind), INTENT(IN) :: A(:) + INTEGER(i_kind), INTENT(INOUT) :: K_Index(:) + + INTEGER(i_kind) :: I,J,RIGHT,LEFT,IDX + REAL(r_kind) :: TMP + +!------------------------------------------ + + IF (N <= 1) RETURN + LEFT = N/2+1 + RIGHT = N + + DO + IF (LEFT > 1) THEN + LEFT = LEFT - 1 + IDX = K_Index(LEFT) + ELSE + IDX = K_Index(RIGHT) + K_Index(RIGHT) = K_Index(1) + RIGHT = RIGHT - 1 + IF (RIGHT == 1) THEN + K_Index(1) = IDX + EXIT + ENDIF + ENDIF + TMP = A(IDX) + I = LEFT + J = 2*LEFT + DO WHILE (J <= RIGHT) + IF (J < RIGHT) THEN + IF (A(K_Index(J)) < A(K_Index(J+1))) J = J + 1 + ENDIF + IF (TMP < A(K_Index(J))) THEN + K_Index(I) = K_Index(J) + I = J + J = 2*J + ELSE + J = RIGHT + 1 + ENDIF + ENDDO + K_Index(I) = IDX + ENDDO + +END SUBROUTINE CADS_Detect_Cloud_Heapsort + +SUBROUTINE CADS_Detect_Cloud_Smooth(KV,KW,PV,PVA) + +! This software was developed within the context of the EUMETSAT +! Satellite Application Facility on Numerical Weather Prediction +! (NWP SAF), under the Cooperation Agreement dated 7 December 2016, +! between EUMETSAT and the Met Office, UK, by one or more partners +! within the NWP SAF. The partners in the NWP SAF are the Met +! Office, ECMWF, DWD and MeteoFrance. +! +! Copyright 2020, EUMETSAT, All Rights Reserved. + +! * CADS_Detect_Cloud_Smooth * - Boxcar-averaging in a REAL array +! * Phil Watts ECMWF 24/01/02 + +! * PURPOSE * +! ----------- +! Calculate the moving average (smoothing filter) of array +! No error checking supplied. + +! * INTERFACE * +! ------------- +! *CALL* * CADS_Detect_Cloud_Smooth( )* (from CADS_Detect_Cloud) +! WHERE KV : Number of elements in V +! KW : Window width for filter +! PV : Input array to be averaged +! PVA : Averaged array + +! * MODIFICATIONS * +! ----------------- +! 01/02/06 A.Collard 1.0 Original export version. +! 13/01/15 R.Eresmaa 2.1 Make array size specifications implicit. +! 05/02/19 R.Eresmaa 2.4 Explicit KIND specifications. +! 16/04/20 R.Eresmaa 3.0 Rename and tidy up. + + use kinds, only: i_kind, r_kind + IMPLICIT NONE + +!* 0.1 global variables + INTEGER(i_kind), INTENT(IN) :: KV ! length of V + INTEGER(i_kind), INTENT(IN) :: KW ! length of averaging window + REAL(r_kind), INTENT(IN) :: PV(:) ! original array + REAL(r_kind), INTENT(INOUT) :: PVA(:) ! averaged array + +!* 0.2 local variables + INTEGER(i_kind) :: INJ,J,I + + PVA(:)=0.0_r_kind + + DO I = 1,KV ! loop over array elements + INJ=0 + DO J=I-KW/2,I+KW/2,1 ! loop over window + IF (J > 0 .AND. J < (KV+1)) THEN ! if window element exists in + ! original array + INJ=INJ+1 + PVA(I)=PVA(I)+PV(J) ! add value + ENDIF + ENDDO + PVA(I)=PVA(I)/REAL(INJ) ! mean value + ENDDO + +END SUBROUTINE CADS_Detect_Cloud_Smooth + +SUBROUTINE CADS_Detect_Cloud_Scenario( K__Sensor, K__Band, K__NumChans, K__GradChkInterval, K__Index, K__Chan_High, & + K__Chan_Low, K__Chan_Windows, K__Imager_Flag, K__Scen_Index, K__Start_Channel, P__DBT) + +! This software was developed within the context of the EUMETSAT +! Satellite Application Facility on Numerical Weather Prediction +! (NWP SAF), under the Cooperation Agreement dated 7 December 2016, +! between EUMETSAT and the Met Office, UK, by one or more partners +! within the NWP SAF. The partners in the NWP SAF are the Met +! Office, ECMWF, DWD and MeteoFrance. +! +! Copyright 2020, EUMETSAT, All Rights Reserved. + +! * CADS_Detect_Cloud_Scenario * +! PHIL WATTS ECMWF 21/01/02 + +! * PURPOSE * +! ----------- +! Determine which of the three possible scenarios best describes +! the input data. +! Quick Exit - no cloud in the FOV +! Warm Start - warm cloud above relatively colder surface +! Cold Start - cold cloud above relatively warmer surface (most common) + +! * INTERFACE * +! ------------- +! * CALL* * CADS_Detect_Cloud_Scenario( )* (from CADS_Detect_Cloud) +! WHERE K__Sensor : Satellite sensor (AIRS/IASI/CrIS) +! K__Band : Band number +! K__NumChans : Number of channels in this band +! K__GradChkInterval : Gradient-checking interval +! K__Index : Ranking index for the input dBT signal +! K__Chan_High : High channel considered in initial minimum search +! K__Chan_Low : Low channel considered in initial minimum search +! K__Chan_Windows : Two channels defining longwave window +! K__Imager_Flag : Input flag from collocated imager data +! K__Scen_Index : Choice of cloud detection scenario (1, 2, or 3) +! K__Start_Channel : Channel index for the start of final search +! P__DBT : Input dBT signal + +! * MODIFICATIONS * +! ----------------- +! 03/02/06 A.Collard 1.0 Tidy up in preparation for IASI +! 03/05/06 A.Collard 1.0.1 Band size is now passed in (allows for +! missing channels). +! 04/05/06 A.Collard 1.0.2 The index of the first cloudy channel is now +! returned to allow cross-band cloud detection +! 16/02/07 A.Collard 1.0.3 Change to the padding to allow the bottom +! channel to be flagged as clear in a +! non-quickstart situation. +! 16/01/09 A.Collard 1.1 Gradient check on quick exit +! Start channel for cold start moved to highest +! channel where BT threshold exceeded +! 11/11/11 R.Eresmaa 1,2 Index of the lowest clear channel added to +! the output parameters. +! Change of the starting channel is no longer +! allowed in cases where gradient > -threshold. +! 04/12/13 R.Eresmaa 2.0 Allow quick exit only if collocated imager +! data supports hypothesis of a clear FOV +! 13/01/15 R.Eresmaa 2.1 Remove the need to create temporary array in +! the call to MOVINGA. +! the call to MOVINGA. +! 04/02/19 R.Eresmaa 2.4 Explicit KIND specifications. +! 16/04/20 R.Eresmaa 3.0 Divide the previous CF_Digital in two: +! Cloud_Scenario (here) and Cloud_Separator. + + + use kinds, only: i_kind, r_kind + IMPLICIT NONE + +!* 0.1 Global arrays + INTEGER(i_kind), INTENT(IN) :: K__SENSOR ! Sensor + INTEGER(i_kind), INTENT(IN) :: K__Band ! Band number + INTEGER(i_kind), INTENT(IN) :: K__NumChans ! Number of usable channels in band + INTEGER(i_kind), INTENT(IN) :: K__GradChkInterval ! Gradient-check interval + INTEGER(i_kind), INTENT(IN) :: K__INDEX(:) ! Ranking index for dBT + INTEGER(i_kind), INTENT(IN) :: K__Chan_High ! First channel clear of high stratospheric model errors + INTEGER(i_kind), INTENT(IN) :: K__Chan_Low ! Last channel clear of PBL humidity errors + INTEGER(i_kind), INTENT(IN) :: K__Chan_Windows(2) ! Two channels defining long-wave window bounds + INTEGER(i_kind), INTENT(IN) :: K__Imager_Flag ! Input imager cloud flag + INTEGER(i_kind), INTENT(OUT) :: K__Scen_Index ! Choice of scenario + INTEGER(i_kind), INTENT(OUT) :: K__Start_Channel ! Final starting channel + REAL(r_kind), INTENT(IN) :: P__DBT(:) ! Input ranked-smoothed dBT signal + +! Local variables + REAL(r_kind), ALLOCATABLE :: Z__DBT_w_Buffer(:) ! Smoothed-ranked DBT + INTEGER(i_kind) :: I__Buffer ! No. of buffer channels + INTEGER(i_kind) :: I__Start_Channel ! Primary starting channel for cloud search + INTEGER(i_kind) :: I__Start_Channel_Surf ! Secondary starting channel for cloud search + INTEGER(i_kind) :: I__Max_Channel ! Channel corresponding to maximum of the smoothed dBT + INTEGER(i_kind) :: JCH,JMIN(1),JMAX(1),I + + LOGICAL :: LLCOLD, LL__WINDOW_GRAD_CHECK, LL__StartChannelChanged + LOGICAL :: LL__Search_for_Cloud_Top + +! These carry the values in S__CADS_Setup_Cloud + REAL(r_kind) :: Z__BT_Threshold ! Solution contaminated threshold + REAL(r_kind) :: Z__Grad_Threshold ! Gradient threshold at which to stop filter procession + REAL(r_kind) :: Z__Window_Grad_Threshold ! Gradient threshold for window check + + +!============================================================================= + + + Z__BT_Threshold = & + S__CADS_Setup_Cloud(K__SENSOR) % R__BT_Threshold(K__Band) + Z__Grad_Threshold = & + S__CADS_Setup_Cloud(K__SENSOR) % R__Grad_Threshold(K__Band) + Z__Window_Grad_Threshold = & + S__CADS_Setup_Cloud(K__SENSOR) % R__Window_Grad_Threshold(K__Band) + + +!1. Include buffer channels at the start and end of the input smoothed +! departure array + + I__BUFFER = K__GradChkInterval + ALLOCATE(Z__DBT_w_Buffer(-I__Buffer+1:K__NumChans+1)) + + Z__DBT_w_Buffer(1:K__NumChans) = P__DBT(:) + Z__DBT_w_Buffer(-I__BUFFER+1:0) = Z__DBT_w_Buffer(1) + Z__DBT_w_Buffer(K__NumChans+1) = Z__DBT_w_Buffer(K__NumChans) + + +!2. Prepare for the cloud search + +! First define a set of key channels + + JMIN=MINLOC(Z__DBT_w_Buffer(K__Chan_High:K__NumChans)) + I__Start_Channel_Surf = K__Chan_High+JMIN(1)-1 + + JMIN=MINLOC(Z__DBT_w_Buffer(K__Chan_High:K__Chan_Low)) + I__Start_Channel = K__Chan_High+JMIN(1)-1 + +! Look for highest channel with DBT<-BT_Threshold and move I__Start_Channel +! there if higher than current I__Start_Channel: + JCH = I__Start_Channel + StartChanLoop : DO I=K__Chan_High,K__NumChans + IF (Z__DBT_w_Buffer(I) < -Z__BT_Threshold .OR. I == I__Start_Channel) THEN + JCH = I + Exit StartChanLoop + ENDIF + ENDDO StartChanLoop + I__Start_Channel = JCH + +! Do the same with I__Start_Channel_Surf + JCH = I__Start_Channel_Surf + StartChanLoop_Surf : DO I=K__Chan_High,K__NumChans + IF (Z__DBT_w_Buffer(I) < -Z__BT_Threshold .OR. I == I__Start_Channel_Surf) THEN + JCH = I + Exit StartChanLoop_Surf + ENDIF + ENDDO StartChanLoop_Surf + I__Start_Channel_Surf = JCH + +! Find the position of the equivalent maximum departure (for quick exit test) + JMAX=MAXLOC(Z__DBT_w_Buffer(K__Chan_High:K__NumChans)) + I__Max_Channel = K__Chan_High+JMAX(1)-1 + +! Long-wave window gradient check + LL__WINDOW_GRAD_CHECK=.TRUE. + IF (ALL(K__Chan_Windows > 0)) LL__WINDOW_GRAD_CHECK = & + (ABS(Z__DBT_w_Buffer(K__INDEX(K__Chan_Windows(1))) - & + Z__DBT_w_Buffer(K__INDEX(K__Chan_Windows(2)))) & + < Z__Window_Grad_Threshold) + +! Choose scenario to be followed + LL__Search_for_Cloud_Top=.TRUE. + IF (ABS(Z__DBT_w_Buffer(I__Start_Channel_Surf)) < Z__BT_Threshold .AND. & + ABS(Z__DBT_w_Buffer(I__Start_Channel)) < Z__BT_Threshold .AND. & + ABS(Z__DBT_w_Buffer(I__Max_Channel)) < Z__BT_Threshold .AND. & + ABS(Z__DBT_w_Buffer(K__NumChans)) < Z__BT_Threshold .AND. & + LL__WINDOW_GRAD_CHECK .AND. & + K__Imager_Flag==0 .AND. & + S__CADS_Setup_Cloud(K__SENSOR) % L__Do_Quick_Exit) THEN + !Quick exit + LL__Search_for_Cloud_Top=.FALSE. + ELSEIF (ABS(Z__DBT_w_Buffer(I__Start_Channel)) < Z__BT_Threshold .AND. & + Z__DBT_w_Buffer(K__NumChans) > Z__BT_Threshold ) THEN + !Warm cloud start at next-to-bottom channel (allowing one channel for + !gradient calculations). + LLCOLD = .FALSE. + I__Start_Channel = K__NumChans-1 + ELSEIF (Z__DBT_w_Buffer(I__Start_Channel) < -Z__BT_Threshold ) THEN + LLCOLD = .TRUE. + ELSEIF (Z__DBT_w_Buffer(I__Start_Channel) > Z__BT_Threshold ) THEN + LLCOLD = .FALSE. + ELSE + LLCOLD = .TRUE. + ENDIF + + IF (LL__Search_for_Cloud_Top) THEN ! Either cold or warm start + ! (but not quick exit) + + JCH=I__Start_Channel + +! Re-evaluate the choice of scenario: +! If the primary starting channel appears clear, and the secondary +! starting channel is lower, start from the latter. In that case +! re-evaluate whether cold or warm start is more appropriate. + IF (I__Start_Channel /= I__Start_Channel_Surf) THEN + + LL__StartChannelChanged = .FALSE. + IF (LLCOLD .AND. ( (Z__DBT_w_Buffer(JCH-1)-Z__DBT_w_Buffer(JCH+1)) < & + Z__Grad_Threshold .AND. & + Z__DBT_w_Buffer(JCH-K__GradChkInterval)-Z__DBT_w_Buffer(JCH+1) < & + Z__Grad_Threshold .AND. & + ABS(Z__DBT_w_Buffer(JCH)) < Z__BT_Threshold)) THEN + I__Start_Channel = I__Start_Channel_Surf + LL__StartChannelChanged = .TRUE. + ENDIF + + IF (LL__StartChannelChanged) THEN + + IF (ABS(Z__DBT_w_Buffer(I__Start_Channel)) < Z__BT_Threshold .AND. & + Z__DBT_w_Buffer(K__NumChans) > Z__BT_Threshold ) THEN + !Warm cloud start at next-to-bottom channel (allowing one channel for + !gradient calculations). + LLCOLD = .FALSE. + I__Start_Channel = K__NumChans-1 + ELSEIF (Z__DBT_w_Buffer(I__Start_Channel) < -Z__BT_Threshold ) THEN + LLCOLD = .TRUE. + ELSEIF (Z__DBT_w_Buffer(I__Start_Channel) > Z__BT_Threshold ) THEN + LLCOLD = .FALSE. + ELSE + LLCOLD = .TRUE. + ENDIF + JCH = I__Start_Channel + + ENDIF + ENDIF + + IF (LLCOLD) THEN + K__Scen_Index=3 + ELSE + K__Scen_Index=2 + ENDIF + K__Start_Channel = JCH + + ELSE + + K__Scen_Index=1 + K__Start_Channel=0 + + ENDIF ! Search for cloud top + + IF (ALLOCATED(Z__DBT_w_Buffer)) DEALLOCATE(Z__DBT_w_Buffer) + +END SUBROUTINE CADS_Detect_Cloud_Scenario + +SUBROUTINE CADS_Detect_Cloud_Separator( K__Sensor, K__Band, K__NumChans, K__GradChkInterval, K__Index, K__Cloud_Flag, & + K__Cloud_Level, K__Clear_Level, K__Scen_Index, K__Start_Channel, P__DBT) + +! This software was developed within the context of the EUMETSAT +! Satellite Application Facility on Numerical Weather Prediction +! (NWP SAF), under the Cooperation Agreement dated 7 December 2016, +! between EUMETSAT and the Met Office, UK, by one or more partners +! within the NWP SAF. The partners in the NWP SAF are the Met +! Office, ECMWF, DWD and MeteoFrance. +! +! Copyright 2020, EUMETSAT, All Rights Reserved. + +! * CADS_Detect_Cloud_Separator * +! PHIL WATTS ECMWF 21/01/02 + +! * PURPOSE * +! ----------- +! Along the vertically-ranked and smoothed array of departures, find +! the separating point at which all cloud-affected channels are on +! one side and all clear channels are on the other side. + +! * INTERFACE * +! ------------ +! * CALL* * CADS_Detect_Cloud_Separator( )* (from CADS_Detect_Cloud) +! WHERE K__Sensor : Satellite sensor (AIRS/IASI/CrIS) +! K__Band : Band number +! K__NumChans : Number of channels in this band +! K__GradChkInterval : Gradient-checking interval +! K__Index : Ranking index for the input dBT signal +! K__Cloud_Flag : Cloud flag by channel; 0=clear, 1=cloudy +! K__Cloud_Level : Index of the highest cloud-contaminated channel +! K__Clear_Level : Index of the lowest clear channel +! K__Scen_Index : Choice of cloud detection scenario (1, 2, or 3) +! K__Start_Channel : Starting channel for the cloud search +! P__DBT : Input dBT signal + +! MODIFICATIONS +! 03/02/06 A.Collard 1.0 Tidy up in preparation for IASI +! 03/05/06 A.Collard 1.0.1 Band size is now passed in (allows for +! missing channels). +! 04/05/06 A.Collard 1.0.2 The index of the first cloudy channel is now +! returned to allow cross-band cloud detection +! 16/02/07 A.Collard 1.0.3 Change to the padding to allow the bottom +! channel to be flagged as clear in a +! non-quickstart situation. +! 16/01/09 A.Collard 1.1 Gradient check on quick exit +! Start channel for cold start moved to highest +! channel where BT threshold exceeded +! 11/11/11 R.Eresmaa 1,2 Index of the lowest clear channel added to +! the output parameters. +! Change of the starting channel is no longer +! allowed in cases where gradient > -threshold. +! 04/12/13 R.Eresmaa 2.0 Allow quick exit only if collocated imager +! data supports hypothesis of a clear FOV +! 13/01/15 R.Eresmaa 2.1 Remove the need to create temporary array in +! the call to MOVINGA. +! 04/02/19 R.Eresmaa 2.4 Explicit KIND specifications. +! 16/04/20 R.Eresmaa 3.0 Divide the previous CF_Digital in two: +! Cloud_Scenario and Cloud_Separator (here). + + use kinds, only: i_kind, r_kind + IMPLICIT NONE + +!* 0.1 Global arrays + INTEGER(i_kind), INTENT(IN ) :: K__SENSOR ! Sensor + INTEGER(i_kind), INTENT(IN ) :: K__Band ! Band number + INTEGER(i_kind), INTENT(IN ) :: K__NumChans ! Number of usable channels in band + INTEGER(i_kind), INTENT(IN ) :: K__GradChkInterval ! Gradient-check interval + INTEGER(i_kind), INTENT(IN ) :: K__INDEX(:) ! Ranking index for dBT + INTEGER(i_kind), INTENT(INOUT) :: K__Cloud_Flag(:) ! Cloud flags + INTEGER(i_kind), INTENT( OUT) :: K__Cloud_Level ! Index of highest cloudy channel + INTEGER(i_kind), INTENT( OUT) :: K__Clear_Level ! Index of lowest clear channel + INTEGER(i_kind), INTENT(IN ) :: K__Scen_Index ! Choice of scenario + INTEGER(i_kind), INTENT(IN ) :: K__Start_Channel ! Choice of scenario + REAL(r_kind), INTENT(IN ) :: P__DBT(:) ! Input ranked dBT signal + + +! Local variables + REAL(r_kind), ALLOCATABLE :: Z__DBT_w_Buffer(:) ! Smoothed-ranked DBT + INTEGER(i_kind) :: I__Buffer ! No. of buffer channels + INTEGER(i_kind) :: JCH + +! These carry the values in S__CADS_Setup_Cloud + REAL(r_kind) :: Z__BT_Threshold ! Solution contaminated threshold + REAL(r_kind) :: Z__Grad_Threshold ! Gradient threshold at which to stop + ! filter procession + +!============================================================================= + + + Z__BT_Threshold = & + S__CADS_Setup_Cloud(K__SENSOR) % R__BT_Threshold(K__Band) + Z__Grad_Threshold = & + S__CADS_Setup_Cloud(K__SENSOR) % R__Grad_Threshold(K__Band) + + K__Cloud_Flag(:)=1 + +!1. Include buffer channels at the start and end of the input smoothed +! departure array + + I__BUFFER = K__GradChkInterval + ALLOCATE(Z__DBT_w_Buffer(-I__Buffer+1:K__NumChans+1)) + + Z__DBT_w_Buffer(1:K__NumChans) = P__DBT(:) + Z__DBT_w_Buffer(-I__BUFFER+1:0) = Z__DBT_w_Buffer(1) + Z__DBT_w_Buffer(K__NumChans+1) = Z__DBT_w_Buffer(K__NumChans) + + +!2. Search for the lowest non-contaminated channel + + JCH = K__Start_Channel + + SELECT CASE (K__Scen_Index) + + CASE (1) ! Quick Exit + K__Cloud_Level = 0 + + CASE (2) ! Warm Start +! In the case of Warm Start, progress towards higher channels whilst +! -ve difference is decreasing + DO WHILE ( ((Z__DBT_w_Buffer(JCH-1)-Z__DBT_w_Buffer(JCH+1)) < & + -1.0_r_kind * Z__Grad_Threshold .OR. & + (Z__DBT_w_Buffer(JCH-K__GradChkInterval)-Z__DBT_w_Buffer(JCH+1)) < & + -1.0_r_kind * Z__Grad_Threshold .OR. & + ABS(Z__DBT_w_Buffer(JCH)) > Z__BT_Threshold) .AND. JCH > 1 ) + JCH = JCH-1 + ENDDO + K__Cloud_Level = JCH + + CASE (3) ! Cold Start +! In the case of Cold Start, progress towards higher channels whilst +! -ve difference is decreasing + DO WHILE (( (Z__DBT_w_Buffer(JCH-1)-Z__DBT_w_Buffer(JCH+1)) > & + Z__Grad_Threshold .OR. & + (Z__DBT_w_Buffer(JCH-K__GradChkInterval)-Z__DBT_w_Buffer(JCH+1)) > & + Z__Grad_Threshold .OR. & + ABS(Z__DBT_w_Buffer(JCH)) > Z__BT_Threshold) .AND. JCH > 1 ) + JCH = JCH-1 + ENDDO + K__Cloud_Level = JCH + + CASE DEFAULT + RETURN + + END SELECT + +!3. Output channel indices for the highest cloud and lowest clear levels + IF (K__Cloud_Level > 1) THEN + K__Cloud_Flag(K__INDEX(1:K__Cloud_Level-1))=0 + K__Clear_Level=K__INDEX(K__Cloud_Level-1) + K__Cloud_Level=K__INDEX(K__Cloud_Level) + ELSEIF (K__Cloud_Level>0) THEN + K__Clear_Level=K__INDEX(K__Cloud_Level) + K__Cloud_Level=K__INDEX(K__Cloud_Level) + ELSE + K__Cloud_Flag(:)=0 + ENDIF + + IF (ALLOCATED(Z__DBT_w_Buffer)) DEALLOCATE(Z__DBT_w_Buffer) + +END SUBROUTINE CADS_Detect_Cloud_Separator + +subroutine cads_imager_calc(obstype,isis,nobs,nreal,nchanl,nsig,data_s,init_pass,mype, & + imager_cluster_fraction,imager_cluster_bt,imager_chan_stdev, imager_model_bt) + +!$$$ subprogram documentation block +! +! subprogram: cads_imager_calc compute model equivalent to the imager channels used by CADS +! prgmmr: Jung +! +! abstract: accumulate the data necessary to derive the model equivalent brightness temperatures +! used by the cloud and aerosol detection software for the imager cloud tests. +! +! program history log: +! +! +! +! subroutines included: +! +! +! input argument list: +! +! obstype - type of tb observation +! isis - sensor/instrument/satellite id +! nobs - number of observations +! nreal - number of pieces of info (location, time, etc) per obs +! nchanl - number of channels per obs +! nsig - number of model layers +! data_s - array containing input data information for a specific sensor +! init_pass - state of "setup" processing +! mype - mpi task id +! +! output argument list: + +! imager_cluster_fraction - CADS cluster fraction ( dimension 7) +! imager_cluster_bt - avreage brightness temperature of a cluster +! imager_chan stdev - brightness temperature standard deviation of the cluster +! imager_model_bt - model derived brightness temperature +! +! +!$$$ end documentation block + + use kinds, only: i_kind, r_kind + use constants, only: zero + use radiance_mod, only: rad_obs_type + use radinfo, only: jpch_rad, nusis, crtm_coeffs_path, nsigradjac + use crtm_interface, only: init_crtm, call_crtm, destroy_crtm, itime + use obsmod, only: dval_use + use gsi_nstcouplermod, only: nstinfo + + implicit none + + logical, intent(in) :: init_pass + character(len=10), intent(in) :: obstype + character(len=20), intent(in) :: isis + integer(i_kind), intent(in) :: nobs, nreal, nchanl, nsig + integer(i_kind), intent(in) :: mype + real(r_kind),dimension(nreal+nchanl,nobs),intent(in) :: data_s + real(r_kind),dimension(7,nobs), intent(out) :: imager_cluster_fraction + real(r_kind),dimension(2,7,nobs), intent(out) :: imager_cluster_bt + real(r_kind),dimension(2,nobs), intent(out) :: imager_chan_stdev, imager_model_bt + +! local variables + integer(i_kind) :: jc, i, n + integer(i_kind) :: itmp1_cads, itmp2_cads, nchanl_cads, maxinfo, dval_info, cads_info, error_status + integer(i_kind),allocatable,dimension(:) :: ich_cads + logical :: imager_spccoeff, imager_taucoeff + real(r_kind) :: dtime, clw_guess, ciw_guess, rain_guess, snow_guess + real(r_kind) :: trop5, tzbgr, dtsavg, sfc_speed + real(r_kind),dimension(nsig) :: qvp, tvp, qs, prsltmp + real(r_kind),dimension(nsig+1) :: prsitmp + real(r_kind),allocatable,dimension(:) :: tsim_cads, emissivity_cads, chan_level_cads + real(r_kind),allocatable,dimension(:) :: ts_cads, emissivity_k_cads,data_s_cads + real(r_kind),allocatable,dimension(:,:) :: ptau5_cads, temp_cads, wmix_cads, jacobian_cads + character(len=80) :: spc_filename, tau_filename + character(len=20) :: isis_cads + character(len=10) :: obstype_cads + + type(rad_obs_type) :: radmod + + cads_info = 23 + dval_info = 0 + if (dval_use) dval_info = 2 + + itmp1_cads = len(trim(obstype)) + itmp2_cads = len(trim(isis)) + + if ( obstype == 'iasi' ) then + isis_cads = 'avhrr3'//isis(itmp1_cads+1:itmp2_cads) + obstype_cads = 'avhrr' +! nchanl_cads = 3 !channels 3 - 5 + elseif ( obstype == 'cris' .or. obstype == 'cris-fsr' ) then +! isis_cads = 'viirs-m'//isis(itmp1+1:itmp2) When naming convention becomes standarized with CrIS + if ( isis == 'cris-fsr_npp' .or. isis == 'cris_npp' ) then + isis_cads = 'viirs-m_npp' + elseif ( isis == 'cris-fsr_n20' ) then + isis_cads = 'viirs-m_n20' + spc_filename = trim(crtm_coeffs_path)//trim(isis_cads)//'.SpcCoeff.bin' + inquire(file=trim(spc_filename), exist=imager_spccoeff) + if ( .not. imager_spccoeff ) isis_cads = 'viirs-m_j1' + elseif ( isis == 'cris-fsr_n21' ) then + isis_cads = 'viirs-m_n21' + spc_filename = trim(crtm_coeffs_path)//trim(isis_cads)//'.SpcCoeff.bin' + inquire(file=trim(spc_filename), exist=imager_spccoeff) + if ( .not. imager_spccoeff ) isis_cads = 'viirs-m_j2' + endif + obstype_cads = 'viirs-m' +! nchanl_cads = 5 ! channels 12 - 16 + endif + + spc_filename = trim(crtm_coeffs_path)//trim(isis_cads)//'.SpcCoeff.bin' + inquire(file=trim(spc_filename), exist=imager_spccoeff) + tau_filename = trim(crtm_coeffs_path)//trim(isis_cads)//'.TauCoeff.bin' + inquire(file=trim(tau_filename), exist=imager_taucoeff) + +! IF the RTM files exist allocate and setup various arrays for the RTM + if ( imager_spccoeff .and. imager_taucoeff) then + nchanl_cads = 0 + do i=1,jpch_rad + if (trim(isis_cads) == nusis(i)) then + nchanl_cads = nchanl_cads +1 + endif + end do + + allocate( ich_cads(nchanl_cads) ) + jc = 0 + do i=1,jpch_rad + if (trim(isis_cads) == nusis(i)) then + jc = jc +1 + ich_cads(jc) = i + endif + end do + + call init_crtm(init_pass,-99,mype,nchanl_cads,nreal,isis_cads,obstype_cads,radmod) + +! Initialize variables needed for the infrared cloud and aerosol detection software + allocate(data_s_cads(nreal+nchanl_cads),tsim_cads(nchanl_cads),emissivity_cads(nchanl_cads), & + chan_level_cads(nchanl_cads),ptau5_cads(nsig,nchanl_cads),ts_cads(nchanl_cads),emissivity_k_cads(nchanl_cads), & + temp_cads(nsig,nchanl_cads),wmix_cads(nsig,nchanl_cads), jacobian_cads(nsigradjac,nchanl_cads)) + + do n = 1,nobs ! loop to derive imager BTs for CADS +! Extract analysis relative observation time. + dtime = data_s(itime,n) + maxinfo = nreal - cads_info - dval_info - nstinfo + if ( sum(data_s(maxinfo+1:maxinfo+7,n)) > 0.90_r_kind ) then ! imager cluster information exists for this profile + data_s_cads = data_s(1:nreal+nchanl_cads,n) + call call_crtm(obstype_cads,dtime,data_s_cads,nchanl_cads,nreal,ich_cads, & + tvp,qvp,qs,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, & + trop5,tzbgr,dtsavg,sfc_speed,tsim_cads,emissivity_cads,chan_level_cads, & + ptau5_cads,ts_cads,emissivity_k_cads,temp_cads,wmix_cads,jacobian_cads,error_status) + +! Transfer imager data to arrays for qc_irsnd + imager_cluster_fraction(1:7,n) = data_s(maxinfo+1:maxinfo+7,n) + imager_cluster_bt(1,1:7,n) = data_s(maxinfo+8:maxinfo+14,n) + imager_cluster_bt(2,1:7,n) = data_s(maxinfo+15:maxinfo+21,n) + imager_chan_stdev(1:2,n) = data_s(maxinfo+22:maxinfo+23,n) + imager_model_bt(1:2,n) = tsim_cads(nchanl_cads-1:nchanl_cads) + endif ! imager information exists + end do ! End loop to derive imager BTs + + call destroy_crtm + deallocate(data_s_cads,tsim_cads,emissivity_cads, ich_cads,chan_level_cads,ptau5_cads,& + ts_cads,emissivity_k_cads, temp_cads,wmix_cads, jacobian_cads) + endif ! RTM files exist + + end subroutine cads_imager_calc + +end module cads diff --git a/src/gsi/crtm_interface.f90 b/src/gsi/crtm_interface.f90 index 2305c84340..4bb1191001 100644 --- a/src/gsi/crtm_interface.f90 +++ b/src/gsi/crtm_interface.f90 @@ -977,7 +977,7 @@ end subroutine destroy_crtm subroutine call_crtm(obstype,obstime,data_s,nchanl,nreal,ich, & h,q,qs,clw_guess,ciw_guess,rain_guess,snow_guess,prsl,prsi, & trop5,tzbgr,dtsavg,sfc_speed,& - tsim,emissivity,ptau5,ts, & + tsim,emissivity,chan_level,ptau5,ts, & emissivity_k,temp,wmix,jacobian,error_status,tsim_clr,tcc, & tcwv,hwp_ratio,stability,layer_od,jacobian_aero) !$$$ subprogram documentation block @@ -1097,6 +1097,7 @@ subroutine call_crtm(obstype,obstime,data_s,nchanl,nreal,ich, & real(r_kind) ,intent( out) :: sfc_speed,dtsavg real(r_kind),dimension(nchanl+nreal) ,intent(in ) :: data_s real(r_kind),dimension(nchanl) ,intent( out) :: tsim,emissivity,ts,emissivity_k + real(r_kind),dimension(nchanl) ,intent( out) :: chan_level character(10) ,intent(in ) :: obstype integer(i_kind) ,intent( out) :: error_status real(r_kind),dimension(nsig,nchanl) ,intent( out) :: temp,ptau5,wmix @@ -1150,6 +1151,7 @@ subroutine call_crtm(obstype,obstime,data_s,nchanl,nreal,ich, & real(r_kind):: sno00,sno01,sno10,sno11,secant_term real(r_kind):: hwp_total,theta_700,theta_sfc,hs real(r_kind):: dlon,dlat,dxx,dyy,yy,zz,garea + real(r_kind):: radiance, radiance_overcast, radiance_ratio real(r_kind),dimension(0:3):: wgtavg real(r_kind),dimension(nsig,nchanl):: omix real(r_kind),dimension(nsig,nchanl,n_aerosols_jac):: jaero @@ -2217,8 +2219,10 @@ subroutine call_crtm(obstype,obstime,data_s,nchanl,nreal,ich, & end do end if + chan_level = zero + !$omp parallel do schedule(dynamic,1) private(i) & -!$omp private(total_od,k,kk,m,term,ii,cwj) +!$omp private(total_od,k,kk,m,term,ii,cwj,radiance,radiance_overcast,radiance_ratio) do i=1,nchanl ! Zero jacobian and transmittance arrays do k=1,nsig @@ -2228,6 +2232,16 @@ subroutine call_crtm(obstype,obstime,data_s,nchanl,nreal,ich, & wmix(k,i)=zero end do + radiance=rtsolution(i,1)%radiance + do k=msig, 1, -1 + radiance_overcast = rtsolution(i,1)%upwelling_overcast_radiance(k) + radiance_ratio = abs(radiance_overcast/radiance) + if (radiance_ratio < 0.99_r_kind) then + chan_level(i) = atmosphere(1)%pressure(k) / r10 + exit + endif + enddo + ! Simulated brightness temperatures tsim(i)=rtsolution(i,1)%brightness_temperature diff --git a/src/gsi/gsi_files.cmake b/src/gsi/gsi_files.cmake index 5a7d29c208..ce74d91c63 100644 --- a/src/gsi/gsi_files.cmake +++ b/src/gsi/gsi_files.cmake @@ -101,6 +101,7 @@ bkgvar_rewgt.f90 blacklist.f90 blendmod.f90 buddycheck_mod.f90 +cads.f90 calc_fov_conical.f90 calc_fov_crosstrk.f90 calctends.f90 diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index c24c485ce1..45d88887a3 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -93,8 +93,14 @@ module gsimod erradar_inflate,tdrerr_inflate,use_poq7,qc_satwnds,& init_qcvars,vadfile,noiqc,c_varqc,gps_jacqc,qc_noirjaco3,qc_noirjaco3_pole,& buddycheck_t,buddydiag_save,njqc,vqc,nvqc,hub_norm,vadwnd_l2rw_qc, & - pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres,cao_check + pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres,cao_check, & + cris_cads, iasi_cads, airs_cads use qcmod, only: troflg,lat_c,nrand + use cads, only: M__Sensor,N__Num_Bands,N__GradChkInterval,N__Band_Size,N__Bands,N__Window_Width, & + N__Window_Bounds,R__BT_Threshold,R__Grad_Threshold,R__Window_Grad_Threshold, L__Do_Quick_Exit, & + L__Do_CrossBand, N__BandToUse,L__Do_Imager_Cloud_Detection, N__Num_Imager_Chans, & + N__Num_Imager_Clusters,N__Imager_Chans,R__Stddev_Threshold,R__Coverage_Threshold, & + R__FG_Departure_Threshold, CADS_Setup_Cloud use pcpinfo, only: npredp,diag_pcp,dtphys,deltim,init_pcp use jfunc, only: iout_iter,iguess,miter,factqmin,factqmax,superfact,limitqobs, & factql,factqi,factqr,factqs,factqg, & @@ -507,6 +513,9 @@ module gsimod ! 2. fv3_regional = .true. ! 3. fv3_cmaq_regional = .true. ! 4. berror_fv3_cmaq_regional = .true. +! 09-02-2022 Jung Added namelist entries to call a new IR cloud detection routine +! the original cloud detection routine is the default. To use the new +! cloud detection routine, set the flags to .true. ! 09-15-2022 yokota - add scale/variable/time-dependent localization ! 2023-07-30 Zhao - added namelist options for analysis of significant wave height ! (aka howv in GSI code): corp_howv, hwllp_howv @@ -1051,6 +1060,13 @@ module gsimod ! wind observations. ! vad_near_analtime - assimilate newvadwnd obs around analysis time only +! +! Flags to use the new IR cloud detection routine. Flag must be set to true to use the new routine. The default +! (no flag or .false.) will use the default. +! airs_cads: use the clod and aerosool detection software for the AIRS instrument +! cris_cads: use the cloud and aerosol detection software for CrIS instruments +! iasi_cads: use the cloud and aerosol detection software for IASI instruments +! namelist/obsqc/dfact,dfact1,erradar_inflate,tdrerr_inflate,oberrflg,& vadfile,noiqc,c_varqc,blacklst,use_poq7,hilbert_curve,tcp_refps,tcp_width,& @@ -1061,7 +1077,7 @@ module gsimod q_doe_a_136,q_doe_a_137,q_doe_b_136,q_doe_b_137, & t_doe_a_136,t_doe_a_137,t_doe_b_136,t_doe_b_137, & uv_doe_a_236,uv_doe_a_237,uv_doe_a_213,uv_doe_b_236,uv_doe_b_237,uv_doe_b_213, & - vad_near_analtime + vad_near_analtime,airs_cads,cris_cads,iasi_cads ! OBS_INPUT (controls input data): ! dmesh(max(dthin))- thinning mesh for each group @@ -1663,6 +1679,40 @@ module gsimod ! fac_tsl - index to apply thermal skin layer or not: 0 = no; 1 = yes. namelist/nst/nst_gsi,nstinfo,zsea1,zsea2,fac_dtl,fac_tsl +! Initialize the Cloud and Aerosol Detection Software (CADS) +! +! M__Sensor Unique ID for sensor +! N__Num_Bands Number of channel bands +! N__Band_Size(:) Number of channels in each band +! N__Bands(:,:) Channel lists +! N__Window_Width(:) Smoothing filter window widths per band +! N__Window_Bounds(:,:) Channels in the spectral window gradient check +! N__GradChkInterval(:) Window width used in gradient calculation +! R__BT_Threshold(:) BT threshold for cloud contamination +! R__Grad_Threshold(:) Gradient threshold for cloud contamination +! R__Window_Grad_Threshold(:) Threshold for window gradient check in QE +! L__Do_Quick_Exit On/off switch for the Quick Exit scenario +! L__Do_CrossBand On/off switch for the cross-band method +! N__BandToUse(:) Band number assignment for each channel +! L__Do_Imager_Cloud_Detection On/off switch for the imager cloud detection +! N__Num_Imager_Chans No. of imager channels +! N__Num_Imager_Clusters No. of clusters to be expected +! N__Imager_Chans(:) List of imager channels +! R__Stddev_Threshold(:) St. Dev. threshold, one for each imager channel +! R__Coverage_Threshold Threshold for fractional coverage of a cluster +! R__FG_Departure_Threshold Threshold for imager FG departure + + NAMELIST / Cloud_Detect_Coeffs / M__Sensor, N__Num_Bands, & + N__Band_Size, N__Bands, N__Window_Width, N__Window_Bounds, & + N__GradChkInterval, R__BT_Threshold, R__Grad_Threshold, & + R__Window_Grad_Threshold, L__Do_Quick_Exit, & + L__Do_CrossBand, N__BandToUse, & + L__Do_Imager_Cloud_Detection, N__Num_Imager_Chans, & + N__Num_Imager_Clusters, N__Imager_Chans, & + R__Stddev_Threshold, R__Coverage_Threshold, & + R__FG_Departure_Threshold + + !EOC !--------------------------------------------------------------------------- @@ -1749,6 +1799,7 @@ subroutine gsimain_initialize call set_fgrid2agrid call gsi_nstcoupler_init_nml call init_radaruse_directDA + call CADS_Setup_Cloud if(mype==0) write(6,*)' at 0 in gsimod, use_gfs_stratosphere,nems_nmmb_regional = ', & use_gfs_stratosphere,nems_nmmb_regional diff --git a/src/gsi/qcmod.f90 b/src/gsi/qcmod.f90 index 7146ceff3e..9804965573 100644 --- a/src/gsi/qcmod.f90 +++ b/src/gsi/qcmod.f90 @@ -115,6 +115,9 @@ module qcmod ! def vadfile - local name of bufr file containing vad winds (used by read_radar) ! def use_poq7 - if true, accept sbuv/2 obs with profile ozone quality flag 7 ! def cao_check - if true, turn on cold-air-outbreak screening +! def airs_cads - if true, use the cloud and aerosol detection routine for Aqua/AIRS instrument +! def cris_cads - if true, use the cloud and aerosol detection routine for CrIS instruments +! def iasi_cads - if true, use the cloud and aerosol detection routine for IASI instruments ! ! following used for nonlinear qc: ! @@ -152,7 +155,7 @@ module qcmod use constants, only: r0_01,r0_02,r0_03,r0_04,r0_05,r10,r60,r100,h300,r400,r1000,r2000,r2400,r4000 use constants, only: deg2rad,rad2deg,t0c,one_tenth,rearth_equator use obsmod, only: rmiss_single - use radinfo, only: iuse_rad,passive_bc + use radinfo, only: iuse_rad,passive_bc,nuchan use radinfo, only: tzr_qc use radiance_mod, only: rad_obs_type implicit none @@ -183,6 +186,7 @@ module qcmod public :: qc_gmi public :: qc_amsr2 public :: qc_saphir + ! set passed variables to public public :: npres_print,nlnqc_iter,varqc_iter,pbot,ptop,c_varqc,njqc,vqc,nvqc,hub_norm public :: use_poq7,noiqc,vadfile,dfact1,dfact,erradar_inflate,gps_jacqc @@ -200,6 +204,7 @@ module qcmod public :: troflg public :: lat_c public :: nrand + public :: airs_cads, cris_cads, iasi_cads logical nlnqc_iter,njqc,vqc,nvqc,hub_norm logical noiqc @@ -215,6 +220,7 @@ module qcmod logical vadwnd_l2rw_qc logical troflg logical cao_check + logical airs_cads, cris_cads, iasi_cads character(10):: vadfile integer(i_kind) npres_print @@ -455,6 +461,10 @@ subroutine init_qcvars lat_c=21.0_r_kind nrand=13 + airs_cads = .false. + cris_cads = .false. + iasi_cads = .false. + return end subroutine init_qcvars @@ -2065,10 +2075,11 @@ subroutine qc_saphir(nchanl,sfchgt,luse,sea, & return end subroutine qc_saphir -subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & - cris, hirs, zsges,cenlat,frac_sea,pangs,trop5,zasat,tzbgr,tsavg5,tbc,tb_obs,tbcnob,tnoise, & - wavenumber,ptau5,prsltmp,tvp,temp,wmix,emissivity_k,ts, & - id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,zero_irjaco3_pole) +subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr,airs, & + cris,iasi,hirs,zsges,cenlat,frac_sea,pangs,trop5,zasat,tzbgr,tsavg5,tbc,tb_obs,tbcnob,tnoise, & + wavenumber,ptau5,prsltmp,tvp,temp,wmix,chan_level,emissivity_k,ts,tsim, & + id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,zero_irjaco3_pole,cluster_fraction, & + cluster_bt, chan_stdev, model_bt) ! id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,zero_irjaco3_pole,radmod) ! all-sky !$$$ subprogram documentation block @@ -2108,6 +2119,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & ! tzbgr - Tz over water ! tsavg5 - surface skin temperature ! tbc - simulated - observed BT with bias correction +! tsim - simulated BT ! tb_obs - observed Brightness temperatures ! tnoise - channel noise array ! wavenumber - array of channel wavenumbers @@ -2133,6 +2145,10 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & ! cld - cloud fraction ! cldp - cloud pressure ! zero_irjaco3_pole - logical to control use of ozone jacobians near poles +! cluster_fraction - size of imager derived cluster to determine clear cloudy profiles, used by CADS +! cluster_bt - imager brightness temperature of each cluster, used by CADS +! chan_stdev - standard deviation of cluster mean temperatures, used by CADS +! model_bt _ brightness temperature derived from the model's clear profile. used by CADS ! ! attributes: ! language: f90 @@ -2142,11 +2158,13 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & use kinds, only: r_kind, i_kind use radinfo, only: iomg_det, itopo_det, isst_det + use crtm_planck_functions, only: crtm_planck_radiance + use cads, only: cloud_aerosol_detection implicit none ! Declare passed variables - logical, intent(in ) :: sea,land,ice,snow,luse,goessndr, cris, hirs + logical, intent(in ) :: sea,land,ice,snow,luse,goessndr,airs,cris,hirs,iasi logical, intent(inout) :: zero_irjaco3_pole integer(i_kind), intent(in ) :: nsig,nchanl,ndat,is integer(i_kind),dimension(nchanl), intent(in ) :: ich @@ -2157,10 +2175,14 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & real(r_kind), intent( out) :: cld,cldp real(r_kind),dimension(40,ndat), intent(inout) :: aivals real(r_kind),dimension(nchanl), intent(in ) :: tbc,emissivity_k,ts,wavenumber,tb_obs,tbcnob - real(r_kind),dimension(nchanl), intent(in ) :: tnoise + real(r_kind),dimension(nchanl), intent(in ) :: chan_level + real(r_kind),dimension(nchanl), intent(in ) :: tnoise,tsim real(r_kind),dimension(nsig,nchanl),intent(in ) :: ptau5,temp,wmix real(r_kind),dimension(nsig), intent(in ) :: prsltmp,tvp real(r_kind),dimension(nchanl), intent(inout) :: errf,varinv,varinv_use + real(r_kind),dimension(7), intent(in ) :: cluster_fraction + real(r_kind),dimension(2,7), intent(in ) :: cluster_bt + real(r_kind),dimension(2), intent(in ) :: chan_stdev, model_bt ! Declare local parameters @@ -2168,21 +2190,29 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & real(r_kind) :: demisf,dtempf,efact,dtbf,term,cenlatx,sfchgtfact - real(r_kind) :: sum,sum2,sum3,cloudp,tmp,dts,delta - real(r_kind),dimension(nchanl) :: dtb - integer(i_kind) :: i,j,k,kk,lcloud,m + real(r_kind) :: sum1,sum2,sum3,tmp,dts,delta + integer(i_kind) :: i,j,lcloud,m,isurface_chan integer(i_kind), dimension(nchanl) :: irday real(r_kind) :: dtz,ts_ave,xindx,tzchks real(r_kind),parameter:: tbmax = 550._r_kind real(r_kind),parameter:: tbmin = 50._r_kind +! for cloud_aerosol_detect + integer(i_kind) :: I_Sensor_ID + integer(i_kind),dimension(nchanl) :: chan_array, i_flag_cloud + integer(i_kind),dimension(2) :: imager_chans + integer(i_kind) :: boundary_layer_pres, tropopause_height + integer(i_kind) :: ichan_10_micron, ichan_12_micron + real(r_kind),dimension(nchanl) :: tb_bc + real(r_kind) :: cloud_temperature, radiance_chan, radiance_model, radiance_cloud + real(r_kind) :: tb_obs_10, tb_obs_12, tb_obs_diff ! Reduce weight given to obs for shortwave ir if ! solar zenith angle tiny_r_kind irday = 1 if (pangs <= 89.0_r_kind .and. frac_sea > zero) then ! QC2 in statsrad - if(luse)aivals(9,is) = aivals(9,is) + one + if(luse) aivals(9,is) = aivals(9,is) + one do i=1,nchanl if(wavenumber(i) > r2000)then if(wavenumber(i) > r2400)then @@ -2225,7 +2255,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & ! If GOES and lza > 60. do not use if( goessndr .and. zasat*rad2deg > r60) then ! QC5 in statsrad - if(luse)aivals(12,is) = aivals(12,is) + one + if(luse) aivals(12,is) = aivals(12,is) + one do i=1,nchanl varinv(i) = zero varinv_use(i)=zero @@ -2237,7 +2267,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & sfchgtfact=one if (zsges > r2000) then ! QC1 in statsrad - if(luse)aivals(8,is) = aivals(8,is) + one + if(luse) aivals(8,is) = aivals(8,is) + one sfchgtfact = (r2000/zsges)**4 endif @@ -2265,114 +2295,196 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & cld=zero cldp=r10*prsltmp(1) - do k=1,nsig - if(prsltmp(k) > trop5)then - do i=1,nchanl - dtb(i)=(tvp(k)-tsavg5)*ts(i) - end do - do kk=1,k-1 - do i=1,nchanl - dtb(i)=dtb(i)+(tvp(k)-tvp(kk))*temp(kk,i) - end do - end do - sum=zero - sum2=zero - do i=1,nchanl - if(varinv_use(i) > tiny_r_kind)then - sum=sum+tbc(i)*dtb(i)*varinv_use(i) - sum2=sum2+dtb(i)*dtb(i)*varinv_use(i) - end if - end do - if (abs(sum2) < tiny_r_kind) sum2 = sign(tiny_r_kind,sum2) - cloudp=min(max(sum/sum2,zero),one) - sum=zero - do i=1,nchanl - if(varinv_use(i) > tiny_r_kind)then - tmp=tbc(i)-cloudp*dtb(i) - sum=sum+tmp*tmp*varinv_use(i) - end if - end do - if(sum < sum3)then - sum3=sum - lcloud=k - cld=cloudp - cldp=r10*prsltmp(k) - end if - end if +! Cloud and aerosol detection routines (ECMWF) + if (cris .and. cris_cads) then + I_Sensor_ID = 27 + chan_array = nuchan(ich) ! channel numbers + tb_bc = tbc + tsim ! observation BT with bias correction + boundary_layer_pres = nint(0.8_r_kind*prsltmp(1)) ! boundary layer set to be 80% of surface pressure + tropopause_height = nint(trop5) + imager_chans = (/15,16/) ! imager channel numbers (from satinfo) + isurface_chan = 501 ! surface channel + ichan_10_micron = 458 ! ~10.7 micron channel for low level cloud test + ichan_12_micron = 295 ! ~12.0 micron channel for low level cloud test + + call cloud_aerosol_detection( I_Sensor_ID, nchanl, chan_array, & + tropopause_height, boundary_layer_pres, tb_bc, tsim, chan_level, imager_chans, cluster_fraction, & + cluster_bt, chan_stdev, model_bt, i_flag_cloud, cldp ) + + elseif ( iasi .and. iasi_cads ) then + I_Sensor_ID = 16 + chan_array = nuchan(ich) ! channel numbers + tb_bc = tbc + tsim ! observation BT with bias correction + boundary_layer_pres = nint(0.8_r_kind*prsltmp(1)) ! boundary layer set to be 80% of surface pressure + tropopause_height = nint(trop5) + imager_chans = (/2,3/) ! imager channel numbers (from satinfo) + isurface_chan = 1271 ! surface channel + ichan_10_micron = 1173 ! ~10.7 micron channel for low level cloud test + ichan_12_micron = 756 ! ~12.0 micron channel for low level cloud test + + call cloud_aerosol_detection( I_Sensor_ID, nchanl, chan_array, & + tropopause_height, boundary_layer_pres, tb_bc, tsim, chan_level, imager_chans, cluster_fraction, & + cluster_bt, chan_stdev, model_bt, i_flag_cloud, cldp ) + + elseif ( airs .and. airs_cads ) then + I_Sensor_ID = 11 + chan_array = nuchan(ich) ! channel numbers + tb_bc = tbc + tsim ! observation BT with bias correction + boundary_layer_pres = nint(0.8_r_kind*prsltmp(1)) ! boundary layer set to be 80% of surface pressure + tropopause_height = nint(trop5) + isurface_chan = 914 ! surface channel + imager_chans = (/0,0/) ! imager channel numbers (from satinfo) + ichan_10_micron = 843 ! ~10.7 micron channel for low level cloud test + ichan_12_micron = 587 ! ~12.0 micron channel for low level cloud test + + call cloud_aerosol_detection( I_Sensor_ID, nchanl, chan_array, & + tropopause_height, boundary_layer_pres, tb_bc, tsim, chan_level, imager_chans, cluster_fraction, & + cluster_bt, chan_stdev, model_bt, i_flag_cloud, cldp ) - end do - if ( lcloud > 0 ) then ! If cloud detected, reject channels affected by it. + else + call emc_legacy_cloud_detect(nchanl,nsig,tsavg5,trop5,prsltmp,tvp,ts,tbc,temp,varinv_use,lcloud,cld,cldp) - do i=1,nchanl + endif ! end of which cloud test to use +! compute cloud stats +! If using CADS + if ((cris .and. cris_cads) .or. (iasi .and. iasi_cads) .or. (airs .and. airs_cads)) then + +! Reject channels affected by clouds + do i=1, nchanl + if ( i_flag_cloud(i) == 1) then +! QC4 in statsrad + if(luse) aivals(11,is) = aivals(11,is) + one + varinv(i) = zero + varinv_use(i) = zero + if(id_qc(i) == igood_qc) id_qc(i) = ifail_cloud_qc + endif + end do + +! Derive cloud amount for CADS + cld = zero + if ( cldp < prsltmp(1) ) then ! if cloud in this profile exists + cloud_layer: do i=2, nsig ! determine which layer the cloud exists. + if (prsltmp(i) < cldp) then + lcloud = i + do j=1, nchanl ! use surface channel to derive cloud amount + m = nuchan(ich(j)) + if ( m == isurface_chan ) then ! interpolate cloud top temperature + cloud_temperature = ((tvp(lcloud) -tvp(lcloud -1)/ log(prsltmp(lcloud) / prsltmp(lcloud - 1))) & + * log(cldp/prsltmp(lcloud-1))) + tvp(lcloud-1) + call crtm_planck_radiance(1,m,tb_bc(j),radiance_chan) ! observation radiance. same as tb_obs + bias correction + call crtm_planck_radiance(1,m,tsim(j),radiance_model) ! model derived radiance + call crtm_planck_radiance(1,m,cloud_temperature,radiance_cloud) ! cloud top temperature radiance + cld = (radiance_chan - radiance_model) / (radiance_cloud - radiance_model) + cld = min(max(cld,zero),one) + cldp = cldp * r10 + exit cloud_layer ! cloud layer foound and cloud amount computed + endif ! surface channel found + end do !surface_chan + endif ! cloud found (prsltmp(i) < cldp) + end do cloud_layer + +! If clear, do a 10.7 - 12 micron test for low level clouds + else ! lcloud = 0 + do i=1, nchanl + if ( nuchan(ich(i)) == ichan_10_micron ) tb_obs_10 = tb_obs(i) + if ( nuchan(ich(i)) == ichan_12_micron ) tb_obs_12 = tb_obs(i) + end do + if ( tb_obs_10 > zero .and. tb_obs_12 > zero ) then + tb_obs_diff = tb_obs_10 - tb_obs_12 + if ( tb_obs_diff > 2.20_r_kind ) then ! Assume a cloud exists + cldp = prsltmp(1) * r10 ! Assume near surface cloud + cld = one ! Assume overcast cloud + lcloud = 1 + endif + endif + endif + +! If more than 2% of the transmittance comes from the cloud layer, reject the channel (0.02 is a tunable parameter). +! or CADS flagged a channel to have cloud. + if ( lcloud > 0 ) then + do i=1, nchanl + if ( ptau5(lcloud,i) > 0.02_r_kind ) then + if(luse) aivals(11,is) = aivals(11,is) + one ! QC4 in statsrad + varinv(i) = zero + varinv_use(i) = zero + if(id_qc(i) == igood_qc) id_qc(i) = ifail_cloud_qc + end if + end do + endif + +! default compute cloud stats, emc_legacy_cloud_detect + else + if ( lcloud > 0 ) then + + do i=1,nchanl ! reject channels with iuse_rad(j)=-1 when they are peaking below the cloud j=ich(i) if (passive_bc .and. iuse_rad(j)==-1) then - if (lcloud .ge. kmax(i)) then - if(luse)aivals(11,is) = aivals(11,is) + one - varinv(i) = zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_cloud_qc - cycle - end if + if (lcloud .ge. kmax(i)) then + if(luse)aivals(11,is) = aivals(11,is) + one + varinv(i) = zero + varinv_use(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_cloud_qc + cycle + end if end if ! If more than 2% of the transmittance comes from the cloud layer, ! reject the channel (0.02 is a tunable parameter) if ( ptau5(lcloud,i) > 0.02_r_kind) then -! QC4 in statsrad - if(luse)aivals(11,is) = aivals(11,is) + one - varinv(i) = zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_cloud_qc +! QC4 in statsrad + if(luse) aivals(11,is) = aivals(11,is) + one + varinv(i) = zero + varinv_use(i) = zero + if(id_qc(i) == igood_qc) id_qc(i) = ifail_cloud_qc end if - end do - -! If no clouds check surface temperature/emissivity + end do - else ! If no cloud was detected, do surface temp/emiss checks - sum=zero - sum2=zero - do i=1,nchanl + else ! surface consistency and sensitivity chacks. ( if lcoud = 0 ) + sum1=zero + sum2=zero + do i=1,nchanl if ( varinv_use(i) > tiny_r_kind .and. ts(i) > 0.0001_r_kind) then - sum=sum+tbc(i)*ts(i)*varinv_use(i) - sum2=sum2+ts(i)*ts(i)*varinv_use(i) + sum1 = sum1 +tbc(i)*ts(i)*varinv_use(i) + sum2 = sum2+ts(i)*ts(i)*varinv_use(i) endif - end do - if (abs(sum2) < tiny_r_kind) sum2 = sign(tiny_r_kind,sum2) - dts=abs(sum/sum2) - if(abs(dts) > one)then + end do + if (abs(sum2) < tiny_r_kind) sum2 = sign(tiny_r_kind,sum2) + dts=abs(sum1/sum2) + if(abs(dts) > one)then if(.not. sea)then - dts=min(dtempf,dts) + dts=min(dtempf,dts) else - dts=min(three,dts) + dts=min(three,dts) end if do i=1,nchanl - delta=max(r0_05*tnoise(i),r0_02) - if(abs(dts*ts(i)) > delta)then -! QC3 in statsrad - if(luse .and. varinv(i) > zero) aivals(10,is) = aivals(10,is) + one - varinv(i) = zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_sfcir_qc - end if - end do - end if - endif + delta=max(r0_05*tnoise(i),r0_02) + if(abs(dts*ts(i)) > delta)then +! QC3 in statsrad + if(luse .and. varinv(i) > zero) aivals(10,is) = aivals(10,is) + one + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_sfcir_qc + endif + enddo + endif + endif -! ! Temporary additional check for CrIS to reduce influence of land points on window channels (particularly important for bias correction) -! - if (cris .and. .not. sea) then - do i=1,nchanl - if (ts(i) > 0.2_r_kind) then + if (cris .and. .not. sea) then + do i=1,nchanl + if (ts(i) > 0.2_r_kind) then ! QC3 in statsrad - if(luse .and. varinv(i) > zero) aivals(10,is) = aivals(10,is) + one - varinv(i) = zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_sfcir_qc - end if - end do - end if - + if(luse .and. varinv(i) > zero) & + aivals(10,is) = aivals(10,is) + one + varinv(i) = zero + if(id_qc(i) == igood_qc) id_qc(i) = ifail_sfcir_qc + end if + end do + end if + endif ! derive cloud stats ! ! Apply Tz retrieval ! @@ -2402,7 +2514,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & cenlatx=abs(cenlat)*r0_04 if (cenlatx < one) then - if(luse)aivals(6,is) = aivals(6,is) + one + if(luse) aivals(6,is) = aivals(6,is) + one efact = half*(cenlatx+one) do i=1,nchanl if(varinv(i) > tiny_r_kind) errf(i)=efact*errf(i) @@ -2414,7 +2526,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & if(varinv(i) > tiny_r_kind)then dtbf = demisf*abs(emissivity_k(i))+dtempf*abs(ts(i)) term = dtbf*dtbf - if(term > tiny_r_kind)varinv(i)=varinv(i)/(one+varinv(i)*term) + if(term > tiny_r_kind) varinv(i) = varinv(i)/(one+varinv(i)*term) end if end do @@ -2497,12 +2609,113 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & endif !! if (hirs) !---mkim + return +end subroutine qc_irsnd +subroutine emc_legacy_cloud_detect(nchanl,nsig,tsavg5,trop5,prsltmp,tvp,ts,tbc,temp,varinv_use,lcloud,cld,cldp) + +!$$$ subprogram documentation block +! . . . +! subprogram: emc_legacy_cloud_detect determine clear/cloudy profiles from hirs,goessndr,airs,iasi,cris instruments +! +! prgmmr: derber ??? org: np23 date: ??? +! +! abstract: determine if a profile is clear/cloudy. If cloudy, determine model layer of the lcoud. +! This subroutine is designed for infrared sounders. +! +! program history log: +! 2022-06-20 jung moved into a subroutine +! +! input argument list: +! nchanl - number of channels per obs +! nsig - number of model layers +! tsavg5 - surface skin temperature +! trop5 - tropopause pressure +! prsltmp - array of layer pressure in vertical (surface to toa) +! tvp - array of temperatures in vertical (surface to toa) +! ts - skin temperature sensitivity +! tbc - simulated - observed BT with bias correction +! temp - temperature sensitivity array +! varinv_use - observation weight used (modified obs var error inverse) +! +! output argument list: +! lcloud - model layer of cloud +! cld - derived cloud amount +! cldp - model layer pressure (hPa) of cloud +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + +use kinds, only: i_kind, r_kind +use constants, only: tiny_r_kind, zero, r10 +implicit none + +integer(i_kind), intent(in ) :: nchanl, nsig +integer(i_kind), intent( out) :: lcloud +real(r_kind), intent(in ) :: tsavg5, trop5 +real(r_kind), intent( out) :: cld, cldp +real(r_kind), dimension(nchanl), intent(in ) :: tbc, ts, varinv_use +real(r_kind), dimension(nsig,nchanl), intent(in ) :: temp +real(r_kind), dimension(nsig), intent(in ) :: tvp, prsltmp + +integer(i_kind) :: i, k, kk + +real(r_kind) :: sum,sum2,sum3,cloudp,tmp +real(r_kind),dimension(nchanl) :: dtb + + sum3=zero + do i=1,nchanl + sum3=sum3+tbc(i)*tbc(i)*varinv_use(i) + end do + sum3=0.75_r_kind*sum3 + lcloud=0 + cld=zero + cldp=r10*prsltmp(1) + + do k=1,nsig + if(prsltmp(k) > trop5)then + do i=1,nchanl + dtb(i)=(tvp(k)-tsavg5)*ts(i) + end do + do kk=1,k-1 + do i=1,nchanl + dtb(i)=dtb(i)+(tvp(k)-tvp(kk))*temp(kk,i) + end do + end do + sum=zero + sum2=zero + do i=1,nchanl + if(varinv_use(i) > tiny_r_kind)then + sum=sum+tbc(i)*dtb(i)*varinv_use(i) + sum2=sum2+dtb(i)*dtb(i)*varinv_use(i) + end if + end do + if (abs(sum2) < tiny_r_kind) sum2 = sign(tiny_r_kind,sum2) + cloudp=min(max(sum/sum2,zero),one) + sum=zero + do i=1,nchanl + if(varinv_use(i) > tiny_r_kind)then + tmp=tbc(i)-cloudp*dtb(i) + sum=sum+tmp*tmp*varinv_use(i) + end if + end do + if(sum < sum3)then + sum3=sum + lcloud=k + cld=cloudp + cldp=r10*prsltmp(k) + end if + end if + + end do + +end subroutine emc_legacy_cloud_detect - return -end subroutine qc_irsnd subroutine qc_avhrr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, & zsges,cenlat,frac_sea,pangs,trop5,tzbgr,tsavg5,tbc,tb_obs,tnoise, & @@ -2593,7 +2806,6 @@ subroutine qc_avhrr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, & real(r_kind),parameter:: oneover400=1.0_r_kind/400.0_r_kind - real(r_kind) :: demisf,dtempf,efact,dtbf,term,cenlatx,sfchgtfact real(r_kind) :: sum1,sum2,sum3,cloudp,tmp,dts real(r_kind),dimension(nchanl,nsig) :: dtb @@ -4304,7 +4516,7 @@ subroutine qc_geocsr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, & integer(i_kind), intent(in ) :: nchanl,ndat,nsig,is integer(i_kind),dimension(nchanl),intent(in ) :: ich integer(i_kind),dimension(nchanl),intent(inout) :: id_qc - integer(i_kind),dimension(nchanl), intent(in ) :: kmax + integer(i_kind),dimension(nchanl),intent(in ) :: kmax real(r_kind), intent(in ) :: zsges real(r_kind), intent(in ) :: tzbgr real(r_kind),dimension(40,ndat), intent(inout) :: aivals diff --git a/src/gsi/read_airs.f90 b/src/gsi/read_airs.f90 index 8dd22ffd5e..c5392dad14 100644 --- a/src/gsi/read_airs.f90 +++ b/src/gsi/read_airs.f90 @@ -622,7 +622,6 @@ subroutine read_airs(mype,val_airs,ithin,isfcalc,rmesh,jsatid,gstime,& end do bufr_chans end if - ! Channel based quality control if(amsua)then diff --git a/src/gsi/read_cris.f90 b/src/gsi/read_cris.f90 index 9843f919d7..b8bf4ff92b 100644 --- a/src/gsi/read_cris.f90 +++ b/src/gsi/read_cris.f90 @@ -93,6 +93,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& use gsi_nstcouplermod, only: gsi_nstcoupler_skindepth,gsi_nstcoupler_deter use mpimod, only: npe use gsi_io, only: verbose + use qcmod, only: cris_cads ! use radiance_mod, only: rad_obs_type implicit none @@ -145,7 +146,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& character(len=40) :: infile2 integer(i_kind) :: kidsat, ksatid integer(i_kind) :: iret,ireadsb,ireadmg,irec,next, nrec_startx - integer(i_kind) :: bufr_nchan,maxinfo + integer(i_kind) :: bufr_nchan,maxinfo,dval_info integer(i_kind),allocatable,dimension(:)::nrec @@ -178,8 +179,8 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& logical :: outside,iuse,assim,valid,clear logical :: cris,quiet - integer(i_kind) :: ifov, ifor, iscn, instr, ioff, ilat, ilon, sensorindex - integer(i_kind) :: i, l, iskip, bad_line, llll + integer(i_kind) :: ifov, ifor, iscn, instr, ioff, ilat, ilon, sensorindex_cris + integer(i_kind) :: i, j, l, iskip, bad_line, llll integer(i_kind) :: nreal, isflg integer(i_kind) :: itx, k, nele, itt, n integer(i_kind):: idomsfc(1) @@ -187,7 +188,23 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& integer(i_kind):: error_status, irecx,ierr integer(i_kind):: radedge_min, radedge_max integer(i_kind):: bufr_size - character(len=20),dimension(1):: sensorlist + character(len=20),allocatable,dimension(:) :: sensorlist + +! Imager cluster information for CADS + integer(i_kind) :: iexponent, sensorindex_imager, cads_info + integer(i_kind),dimension(7) :: imager_cluster_index + logical :: imager_coeff + logical,dimension(7) :: imager_cluster_flag + character(len=80) :: spc_filename + character(len=20) :: sensorlist_imager + real(r_kind),dimension(83,7) :: imager_info + real(r_kind),dimension(7) :: imager_cluster_size + real(r_kind),dimension(2) :: imager_mean, imager_std_dev, imager_conversion + real(r_kind) :: imager_cluster_tot + +! bufr error codes +! real(r_kind),dimension(7,3) :: error_codes + ! scan angle calculation geometry based on: ! C. Root 2014: JPSS Ground Project Code 474-00032 @@ -209,6 +226,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& ! Set standard parameters character(8),parameter:: fov_flag="crosstrk" integer(i_kind),parameter:: sfc_channel=501 !used in thinning routine if cloud informatino is not available + integer(i_kind),parameter:: band_2_start=714 !for CADS, if any of band 1 (chans 1 - 713) are missing, reject profile integer(i_kind),parameter:: ichan=-999 ! fov-based surface code is not channel specific for cris real(r_kind),parameter:: expansion=one ! exansion factor for fov-based surface code. ! use one for ir sensors. @@ -227,8 +245,12 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& maxinfo = 31 disterrmax=zero ntest=0 - if(dval_use) maxinfo = maxinfo + 2 - nreal = maxinfo + nstinfo + dval_info = 0 + if(dval_use) dval_info = 2 + cads_info = 0 + if(cris_cads) cads_info = 23 + nreal = maxinfo + cads_info + dval_info + nstinfo + ndata = 0 nodata = 0 cris= obstype == 'cris' .or. obstype == 'cris-fsr' @@ -301,46 +323,89 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& 'SAID YEAR MNTH DAYS HOUR MINU SECO CLATH CLONH SAZA BEARAZ SOZA SOLAZI' ! Load spectral coefficient structure - sensorlist(1)=sis quiet=.not. verbose + + imager_coeff = .false. +!TODO spc_filename = trim(crtm_coeffs_path)//'viirs-m_'//trim(jsatid)//'.SpcCoeff.bin' ! when viirs naming convention becomes standarized + if ( trim(jsatid) == 'npp' ) then + spc_filename = trim(crtm_coeffs_path)//'viirs-m_npp.SpcCoeff.bin' + sensorlist_imager = 'viirs-m_npp' + elseif ( trim(jsatid) == 'n20' ) then + spc_filename = trim(crtm_coeffs_path)//'viirs-m_n20.SpcCoeff.bin' + sensorlist_imager = 'viirs-m_n20' + inquire(file=trim(spc_filename), exist=imager_coeff) + if ( .not. imager_coeff ) spc_filename = trim(crtm_coeffs_path)//'viirs-m_j1.SpcCoeff.bin' + sensorlist_imager = 'viirs-m_j1' + elseif ( trim(jsatid) == 'n21' ) then + spc_filename = trim(crtm_coeffs_path)//'viirs-m_n21.SpcCoeff.bin' + sensorlist_imager = 'viirs-m_n21' + inquire(file=trim(spc_filename), exist=imager_coeff) + if ( .not. imager_coeff ) spc_filename = trim(crtm_coeffs_path)//'viirs-m_j2.SpcCoeff.bin' + sensorlist_imager = 'viirs-m_j2' + endif + inquire(file=trim(spc_filename), exist=imager_coeff) + if ( imager_coeff ) then + allocate( sensorlist(2)) + sensorlist(1) = sis +!TODO sensorlist(2) = 'viirs-m_'//trim(jsatid) !when viirs naming conventions becomes standardized + sensorlist(2) = trim(sensorlist_imager) + else + allocate( sensorlist(1)) + sensorlist(1) = sis + endif + if( crtm_coeffs_path /= "" ) then if(mype_sub==mype_root .and. print_verbose) write(6,*)'READ_CRIS: crtm_spccoeff_load() on path "'//trim(crtm_coeffs_path)//'"' error_status = crtm_spccoeff_load(sensorlist,& - File_Path = crtm_coeffs_path,quiet=quiet ) + File_Path = crtm_coeffs_path,quiet=quiet) else error_status = crtm_spccoeff_load(sensorlist,quiet=quiet) endif if (error_status /= success) then write(6,*)'READ_CRIS: ***ERROR*** crtm_spccoeff_load error_status=',error_status,& - ' TERMINATE PROGRAM EXECUTION' + ' TERMINATE PROGRAM EXECUTION' call stop2(71) endif +! find CRIS sensorindex. + sensorindex_cris = 0 + if ( sc(1)%sensor_id(1:4) == 'cris' )then + sensorindex_cris = 1 + else + write(6,*)'READ_CRIS: ***ERROR*** sensorindex_cris not set NO CRIS DATA USED' + write(6,*)'READ_CRIS: We are looking for ', sc(1)%sensor_id, ' TERMINATE PROGRAM EXECUTION' + call stop2(71) + end if + +! find imager sensorindex. + sensorindex_imager = 0 + if ( cris_cads .and. imager_coeff ) then + if ( sc(2)%sensor_id(1:4) == 'viir' )then + sensorindex_imager = 2 + else + write(6,*)'READ_CRIS: ***ERROR*** sensorindex_viirs not set NO VIIRS CLUSTER INFO USED BY CADS' + write(6,*)'READ_CRIS: We are looking for ', sc(2)%sensor_id, ' TERMINATE PROGRAM EXECUTION' + imager_coeff = .false. + end if + else + imager_coeff = .false. + end if + ! Find the channels being used (from satinfo file) in the spectral coef. structure. do i=subset_start,subset_end channel_number(i -subset_start +1) = nuchan(i) end do sc_index(:) = 0 satinfo_chan: do i=1,satinfo_nchan - spec_coef: do l=1,sc(1)%n_channels - if ( channel_number(i) == sc(1)%sensor_channel(l) ) then + spec_coef: do l=1,sc(sensorindex_cris)%n_channels + if ( channel_number(i) == sc(sensorindex_cris)%sensor_channel(l) ) then sc_index(i) = l exit spec_coef endif end do spec_coef end do satinfo_chan -! find CRIS sensorindex. - sensorindex = 0 - if ( sc(1)%sensor_id(1:4) == 'cris' )then - sensorindex = 1 - else - write(6,*)'READ_CRIS: ***ERROR*** sensorindex not set NO CRIS DATA USED' - write(6,*)'READ_CRIS: We are looking for ', sc(1)%sensor_id, ' TERMINATE PROGRAM EXECUTION' - call stop2(71) - end if - ! Calculate parameters needed for FOV-based surface calculation. if (isfcalc==1)then instr=17 ! CrIS is similar to AIRS for this purpose. @@ -687,7 +752,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& clear = .false. pred = zero -! Cloud information may be missing depending on how the VIIRS granules align +! Cloud information may be missing depending on how the imager granules align ! with the CrIS granules. ! Cloud Amount, TOCC is total cloud cover [%], HOCT is cloud height [m] call ufbint(lnbufr,cloud_properties,2,1,iret,'TOCC HOCT') @@ -699,7 +764,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& else pred1 = cloud_properties(2) *7.0_r_kind / r1000 ! Assume a lapse rate to convert hgt to delta TB. radiance = allchan(2,sfc_channel_index) * r1000 ! Conversion from W to mW - call crtm_planck_temperature(sensorindex,sfc_channel,radiance,temperature(sfc_channel_index)) ! radiance to BT calculation + call crtm_planck_temperature(sensorindex_cris,sfc_channel,radiance,temperature(sfc_channel_index)) ! radiance to BT calculation pred2 = tsavg *0.98_r_kind - temperature(sfc_channel_index) pred = max(pred1,pred2) ! use the largest of lapse rate (pred1) or sfc channel-surface difference (pred2) endif @@ -709,7 +774,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& ! the surface channel is fixed and set earlier in the code (501). radiance = allchan(2,sfc_channel_index) * r1000 ! Conversion from W to mW - call crtm_planck_temperature(sensorindex,sfc_channel,radiance,temperature(sfc_channel_index)) ! radiance to BT calculation + call crtm_planck_temperature(sensorindex_cris,sfc_channel,radiance,temperature(sfc_channel_index)) ! radiance to BT calculation if (temperature(sfc_channel_index) > tbmin .and. temperature(sfc_channel_index) < tbmax ) then if ( tsavg*0.98_r_kind <= temperature(sfc_channel_index)) then ! 0.98 is a crude estimate of the surface emissivity clear = .true. @@ -743,7 +808,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& ! now such spectra are rejected. if (( allchan(2,bufr_chan) > zero .and. allchan(2,bufr_chan) < 99999._r_kind)) then ! radiance bounds radiance = allchan(2,bufr_chan) * r1000 ! Conversion from W to mW - call crtm_planck_temperature(sensorindex,sc_chan,radiance,temperature(bufr_chan)) ! radiance to BT calculation + call crtm_planck_temperature(sensorindex_cris,sc_chan,radiance,temperature(bufr_chan)) ! radiance to BT calculation else ! error with channel number or radiance temperature(bufr_chan) = tbmin endif @@ -756,12 +821,12 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& bufr_chan = bufr_index(i) if(temperature(bufr_chan) <= tbmin .or. temperature(bufr_chan) >= tbmax ) then temperature(bufr_chan) = tbmin - if(iuse_rad(ioff+i) >= 0) iskip = iskip + 1 + if(iuse_rad(ioff+i) >= 0 .or. (cris_cads .and. sc_index(i) < band_2_start)) iskip = iskip + 1 endif end do skip_loop if(iskip > 0 .and. print_verbose)write(6,*) ' READ_CRIS : iskip > 0 ',iskip -! if( iskip >= 10 )cycle read_loop + if( iskip >= 10 .and. cris_cads ) cycle read_loop crit1=crit1 + ten*real(iskip,r_kind) @@ -772,9 +837,86 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& call finalcheck(one,crit1,itx,iuse) endif if(.not. iuse)cycle read_loop -! + +! Read the imager cluster information for the Cloud and Aerosol Detection Software. +! Only channels 15 and 16 are used. + + if ( cris_cads ) then + call ufbseq(lnbufr,imager_info,83,7,iret,'CRISCS') + if ( iret == 7 .and. imager_info(3,1) <= 100.0_r_kind .and. & + imager_info(3,1) >= zero .and. imager_coeff ) then ! if imager cluster info exists + imager_mean = zero + imager_std_dev = zero + imager_cluster_tot = zero + imager_cluster_flag = .TRUE. + imager_cluster_size = imager_info(3,1:7) + imager_cluster_size(:) = imager_cluster_size(:) / sum(imager_cluster_size(:)) + imager_conversion(1) = one / (sc(sensorindex_imager)%wavenumber(4) **2) + imager_conversion(2) = one / (sc(sensorindex_imager)%wavenumber(5) **2) + +! Order clusters from largest (1) to smallest (7) + imager_cluster_sort: do i=1,7 + j = maxloc(imager_cluster_size,dim=1,mask=imager_cluster_flag) + imager_cluster_index(i) = j + imager_cluster_flag(j) = .FALSE. + end do imager_cluster_sort + +! Convert from radiance to brightness temperature for mean and standard devation used by CADS +! Imager cluster info added to data_all array. + + imager_cluster_info: do j=1,7 + i = imager_cluster_index(j) + + data_all(maxinfo+j,itx) = imager_cluster_size(i) ! Imager cluster fraction + imager_cluster_tot = imager_cluster_tot + imager_info(3,i) + + iexponent = -(nint(imager_info(75,i)) -11) ! channel 15 radiance for each cluster + imager_info(76,i) = imager_info(76,i) * imager_conversion(1) * (ten ** iexponent) + + iexponent = -(nint(imager_info(77,i)) -11) ! channel 15 radiance std dev for each cluster. + imager_info(78,i) = imager_info(78,i) * imager_conversion(1) * (ten ** iexponent) + + call crtm_planck_temperature(sensorindex_imager,4,imager_info(76,i),data_all(maxinfo+7+j,itx)) + data_all(maxinfo+7+j,itx) = max(data_all(maxinfo+7+j,itx),zero) + + iexponent = -(nint(imager_info(80,i)) -11) ! channel 16 radiance for each cluster + imager_info(81,i) = imager_info(81,i) * imager_conversion(2) * (ten ** iexponent) + + iexponent = -(nint(imager_info(82,i))-5 ) ! channel 16 radiance std dev for each cluster. + iexponent = -(nint(imager_info(82,i)) -11) ! channel 16 radiance std dev for each cluster. + imager_info(83,i) = imager_info(83,i) * imager_conversion(2) * (ten ** iexponent) + + call crtm_planck_temperature(sensorindex_imager,5,imager_info(81,i),data_all(maxinfo+14+j,itx)) + data_all(maxinfo+14+j,itx) = max(data_all(maxinfo+14+j,itx),zero) + + + end do imager_cluster_info + +! Compute cluster averages for each channel + + imager_mean(1) = sum(imager_cluster_size(:) * imager_info(76,:)) ! Channel 15 radiance cluster average + imager_std_dev(1) = sum(imager_cluster_size(:) * (imager_info(76,:)**2 + imager_info(78,:)**2)) - imager_mean(1)**2 + imager_std_dev(1) = sqrt(max(imager_std_dev(1),zero)) ! Channel 15 radiance RMSE + call crtm_planck_temperature(sensorindex_imager,4,(imager_std_dev(1) + imager_mean(1)),imager_std_dev(1)) + call crtm_planck_temperature(sensorindex_imager,4,imager_mean(1),imager_mean(1)) ! Channel 15 average BT + imager_std_dev(1) = imager_std_dev(1) - imager_mean(1) ! Channel 15 BT std dev + data_all(maxinfo+22,itx) = imager_std_dev(1) + + imager_mean(2) = sum(imager_cluster_size(:) * imager_info(81,:)) ! Channel 16 radiance cluster average + imager_std_dev(2) = sum(imager_cluster_size(:) * (imager_info(81,:)**2 + imager_info(83,:)**2)) - imager_mean(1)**2 + imager_std_dev(2) = sqrt(max(imager_std_dev(1),zero)) ! Channel 16 radiance RMSE + call crtm_planck_temperature(sensorindex_imager,5,(imager_std_dev(2) + imager_mean(2)),imager_std_dev(2)) + call crtm_planck_temperature(sensorindex_imager,5,imager_mean(2),imager_mean(2)) ! Channel 16 average BT + imager_std_dev(2) = imager_std_dev(2) - imager_mean(2) ! Channel 16 BT std dev + data_all(maxinfo+23,itx) = imager_std_dev(2) + + else ! Imager cluster information is missing. Set everything to zero + data_all(maxinfo+1 : maxinfo+25,itx) = zero + endif + endif ! cris_cads + ! interpolate NSST variables to Obs. location and get dtw, dtc, tz_tr -! + if ( nst_gsi > 0 ) then tref = ts(0) dtw = zero @@ -818,15 +960,17 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& data_all(31,itx)= dlat_earth_deg ! earth relative latitude (degrees) if(dval_use) then - data_all(32,itx)= val_cris - data_all(33,itx)= itt + data_all(maxinfo+cads_info+1,itx)= val_cris + data_all(maxinfo+cads_info+2,itx)= itt +! data_all(32+cads_info,itx)= val_cris +! data_all(33+cads_info,itx)= itt end if if ( nst_gsi > 0 ) then - data_all(maxinfo+1,itx) = tref ! foundation temperature - data_all(maxinfo+2,itx) = dtw ! dt_warm at zob - data_all(maxinfo+3,itx) = dtc ! dt_cool at zob - data_all(maxinfo+4,itx) = tz_tr ! d(Tz)/d(Tr) + data_all(maxinfo+cads_info+dval_info+1,itx) = tref ! foundation temperature + data_all(maxinfo+cads_info+dval_info+2,itx) = dtw ! dt_warm at zob + data_all(maxinfo+cads_info+dval_info+3,itx) = dtc ! dt_cool at zob + data_all(maxinfo+cads_info+dval_info+4,itx) = tz_tr ! d(Tz)/d(Tr) endif ! Put satinfo defined channel temperatures into data array diff --git a/src/gsi/read_iasi.f90 b/src/gsi/read_iasi.f90 index 9ab1d5446f..edd7a9b50e 100644 --- a/src/gsi/read_iasi.f90 +++ b/src/gsi/read_iasi.f90 @@ -127,6 +127,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& use gsi_nstcouplermod, only: gsi_nstcoupler_skindepth, gsi_nstcoupler_deter use mpimod, only: npe use gsi_io, only: verbose + use qcmod, only: iasi_cads ! use radiance_mod, only: rad_obs_type implicit none @@ -208,11 +209,11 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& logical :: outside,iuse,assim,valid logical :: iasi,quiet,cloud_info - integer(i_kind) :: ifov, instr, iscn, ioff, sensorindex + integer(i_kind) :: ifov, instr, iscn, ioff, sensorindex_iasi integer(i_kind) :: i, j, l, iskip, ifovn, bad_line, ksatid, kidsat, llll integer(i_kind) :: nreal, isflg integer(i_kind) :: itx, k, nele, itt, n - integer(i_kind):: iexponent,maxinfo, bufr_nchan + integer(i_kind):: iexponent,maxinfo, bufr_nchan, dval_info integer(i_kind):: idomsfc(1) integer(i_kind):: ntest integer(i_kind):: error_status, irecx,ierr @@ -221,8 +222,18 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& integer(i_kind) :: sfc_channel_index integer(i_kind),allocatable, dimension(:) :: channel_number, sc_index, bufr_index integer(i_kind),allocatable, dimension(:) :: bufr_chan_test - character(len=20),dimension(1):: sensorlist - + character(len=20),allocatable, dimension(:):: sensorlist + +! Imager clouser information for CADS + integer(i_kind) :: sensorindex_imager, cads_info + integer(i_kind),dimension(7) :: imager_cluster_index + logical :: imager_coeff + logical,dimension(7) :: imager_cluster_flag + character(len=80) :: spc_filename + real(r_kind),dimension(33,7) :: imager_info + real(r_kind),dimension(7) :: imager_cluster_size + real(r_kind),dimension(2) :: imager_mean, imager_std_dev + real(r_kind) :: imager_cluster_tot ! Set standard parameters character(8),parameter:: fov_flag="crosstrk" @@ -248,8 +259,11 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& maxinfo = 31 disterrmax=zero ntest=0 - if(dval_use) maxinfo=maxinfo+2 - nreal = maxinfo + nstinfo + dval_info = 0 + if(dval_use) dval_info = 2 + cads_info = 0 + if(iasi_cads) cads_info = 23 + nreal = maxinfo + cads_info + dval_info + nstinfo ndata = 0 nodata = 0 @@ -315,7 +329,19 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& ! load spectral coefficient structure quiet=.not. verbose - sensorlist(1)=sis + + imager_coeff = .false. + spc_filename =trim(crtm_coeffs_path)//'avhrr3_'//trim(jsatid)//'.SpcCoeff.bin' + inquire(file=trim(spc_filename), exist=imager_coeff) + if ( imager_coeff ) then + allocate( sensorlist(2)) + sensorlist(1) = sis + sensorlist(2) = 'avhrr3_'//trim(jsatid) + else + allocate( sensorlist(1)) + sensorlist(1) = sis + endif + if( crtm_coeffs_path /= "" ) then if(mype_sub==mype_root .and. print_verbose) write(6,*)'READ_IASI: crtm_spccoeff_load() on path "'//trim(crtm_coeffs_path)//'"' error_status = crtm_spccoeff_load(sensorlist,& @@ -330,6 +356,31 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& call stop2(71) endif +! find IASI sensorindex + sensorindex_iasi = 0 + if ( sc(1)%sensor_id(1:4) == 'iasi' ) then + sensorindex_iasi = 1 + else + write(6,*)'READ_IASI: ***ERROR*** sensorindex_iasi not set NO IASI DATA USED' + write(6,*)'READ_IASI: We are looking for ', sc(1)%sensor_id, ' TERMINATE PROGRAM EXECUTION' + call stop2(71) + end if + +! find imager sensorindex + sensorindex_imager = 0 + if ( iasi_cads .and. imager_coeff ) then + if ( sc(2)%sensor_id(1:4) == 'avhr' ) then + sensorindex_imager = 2 + imager_coeff = .true. + else + write(6,*)'READ_IASI: ***ERROR*** sensorindex_imager is not set NO IASI DATA USED' + write(6,*)'READ_IASI: We are looking for ', sc(2)%sensor_id + imager_coeff = .false. + end if + else + imager_coeff = .false. + end if + ! Find the channels being used (from satinfo file) in the spectral coef. structure. do i=subset_start,subset_end channel_number(i -subset_start +1) = nuchan(i) @@ -337,23 +388,13 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& sc_index(:) = 0 satinfo_chan: do i=1,satinfo_nchan spec_coef: do l=1,sc(1)%n_channels - if ( channel_number(i) == sc(1)%sensor_channel(l) ) then + if ( channel_number(i) == sc(sensorindex_iasi)%sensor_channel(l) ) then sc_index(i) = l exit spec_coef endif end do spec_coef end do satinfo_chan -! find IASI sensorindex - sensorindex = 0 - if ( sc(1)%sensor_id(1:4) == 'iasi' ) then - sensorindex = 1 - else - write(6,*)'READ_IASI: sensorindex not set NO IASI DATA USED' - write(6,*)'READ_IASI: We are looking for ', sc(1)%sensor_id, ' TERMINATE PROGRAM EXECUTION' - call stop2(71) - end if - ! Calculate parameters needed for FOV-based surface calculation. if (isfcalc==1)then instr=18 @@ -725,7 +766,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& if (( allchan(2,bufr_chan) > zero .and. allchan(2,bufr_chan) < 99999._r_kind)) then ! radiance bounds radiance = allchan(2,bufr_chan)*scalef(bufr_chan) sc_chan = sc_index(i) - call crtm_planck_temperature(sensorindex,sc_chan,radiance,temperature(bufr_chan)) + call crtm_planck_temperature(sensorindex_iasi,sc_chan,radiance,temperature(bufr_chan)) else temperature(bufr_chan) = tbmin endif @@ -750,7 +791,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& ! crit1=crit1 + ten*real(iskip,r_kind) -! If the surface channel exists (~960.0 cm-1) and the AVHRR cloud information is missing, use an +! If the surface channel exists (~960.0 cm-1) and the imager cloud information is missing, use an ! estimate of the surface temperature to determine if the profile may be clear. if (.not. cloud_info) then pred = tsavg*0.98_r_kind - temperature(sfc_channel_index) @@ -766,6 +807,78 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& endif if(.not. iuse)cycle read_loop +! Read the imager cluster information for the Cloud and Aerosol Detection Software. +! Only channels 4 and 5 are used. + + if ( iasi_cads ) then + call ufbseq(lnbufr,imager_info,33,7,iret,'IASIL1CS') + if (iret == 7 .and. imager_info(3,1) <= 100.0_r_kind .and. & + imager_info(3,1) >= zero .and. imager_coeff ) then ! if imager cluster info exists + imager_mean = zero + imager_std_dev = zero + imager_cluster_tot = zero + imager_cluster_flag = .TRUE. + imager_cluster_size = imager_info(3,1:7) + imager_cluster_size(:) = imager_cluster_size(:) / sum(imager_cluster_size(:)) + +! Order clusters from largest (1) to smallest (7) + imager_cluster_sort: do i=1,7 + j = maxloc(imager_cluster_size,dim=1,mask=imager_cluster_flag) + imager_cluster_index(i) = j + imager_cluster_flag(j) = .FALSE. + end do imager_cluster_sort + +! Convert from radiance to brightness temperature for mean and standard deviation used by CADS. +! Imager cluster info added to data_all array + + imager_cluster_info: do j=1,7 + i = imager_cluster_index(j) + + data_all(maxinfo+j,itx) = imager_cluster_size(i) ! Imager cluster fraction + imager_cluster_tot = imager_cluster_tot + imager_info(3,i) + + iexponent = -(nint(imager_info(25,i))-5 ) ! channel 4 radiance for each cluster. + imager_info(26,i) = imager_info(26,i) * (ten ** iexponent) + + iexponent = -(nint(imager_info(27,i))-5 ) ! channel 4 radiance std dev for each cluster. + imager_info(28,i) = imager_info(28,i) * (ten ** iexponent) + + call crtm_planck_temperature(sensorindex_imager,2,imager_info(26,i),data_all(maxinfo+7+j,itx)) + data_all(maxinfo+7+j,itx) = max(data_all(maxinfo+7+j,itx),zero) + + iexponent = -(nint(imager_info(30,i))-5 ) ! channel 5 radiance for each cluster + imager_info(31,i) = imager_info(31,i) * (ten ** iexponent) + + iexponent = -(nint(imager_info(32,i))-5 ) ! channel 5 radiance std dev for each cluser. + imager_info(33,i) = imager_info(33,i) * (ten ** iexponent) + + call crtm_planck_temperature(sensorindex_imager,3,imager_info(31,i),data_all(maxinfo+14+j,itx)) + data_all(maxinfo+14+j,itx) = max(data_all(maxinfo+14+j,itx),zero) + + end do imager_cluster_info + +! Compute cluster averages for each channel + + imager_mean(1) = sum(imager_cluster_size(:) * imager_info(26,:)) ! Channel 4 radiance cluster average + imager_std_dev(1) = sum(imager_cluster_size(:) * (imager_info(26,:)**2 + imager_info(28,:)**2)) - imager_mean(1)**2 + imager_std_dev(1) = sqrt(max(imager_std_dev(1),zero)) ! Channel 4 radiance RMSE + call crtm_planck_temperature(sensorindex_imager,2,(imager_std_dev(1) + imager_mean(1)),imager_std_dev(1)) + call crtm_planck_temperature(sensorindex_imager,2,imager_mean(1),imager_mean(1)) ! Channel 4 average BT + imager_std_dev(1) = imager_std_dev(1) - imager_mean(1) ! Channel 4 BT std dev + data_all(maxinfo+22,itx) = imager_std_dev(1) + + imager_mean(2) = sum(imager_cluster_size(:) * imager_info(31,:)) ! Channel 5 radiance cluster average + imager_std_dev(2) = sum(imager_cluster_size(:) * (imager_info(31,:)**2 + imager_info(33,:)**2)) - imager_mean(1)**2 + imager_std_dev(2) = sqrt(max(imager_std_dev(1),zero)) ! Channel 5 radiance RMSE + call crtm_planck_temperature(sensorindex_imager,3,(imager_std_dev(2) + imager_mean(2)),imager_std_dev(2)) + call crtm_planck_temperature(sensorindex_imager,3,imager_mean(2),imager_mean(2)) ! Channel 5 average BT + imager_std_dev(2) = imager_std_dev(2) - imager_mean(2) ! Channel 5 BT std dev + data_all(maxinfo+23,itx) = imager_std_dev(2) + + else ! Imager cluster information is missing. Set everything to zero + data_all(maxinfo+1 : maxinfo+25,itx) = zero + endif + endif ! iasi_cads = .true. ! ! interpolate NSST variables to Obs. location and get dtw, dtc, tz_tr ! @@ -813,15 +926,15 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& data_all(31,itx)= dlat_earth_deg ! earth relative latitude (degrees) if(dval_use)then - data_all(32,itx)= val_iasi - data_all(33,itx)= itt + data_all(maxinfo+cads_info+1,itx)= val_iasi + data_all(maxinfo+cads_info+2,itx)= itt end if if ( nst_gsi > 0 ) then - data_all(maxinfo+1,itx) = tref ! foundation temperature - data_all(maxinfo+2,itx) = dtw ! dt_warm at zob - data_all(maxinfo+3,itx) = dtc ! dt_cool at zob - data_all(maxinfo+4,itx) = tz_tr ! d(Tz)/d(Tr) + data_all(maxinfo+cads_info+dval_info+1,itx) = tref ! foundation temperature + data_all(maxinfo+cads_info+dval_info+2,itx) = dtw ! dt_warm at zob + data_all(maxinfo+cads_info+dval_info+3,itx) = dtc ! dt_cool at zob + data_all(maxinfo+cads_info+dval_info+4,itx) = tz_tr ! d(Tz)/d(Tr) endif ! Put satinfo defined channel temperatures into data array diff --git a/src/gsi/setupaod.f90 b/src/gsi/setupaod.f90 index 58707acd6a..e0964ee972 100644 --- a/src/gsi/setupaod.f90 +++ b/src/gsi/setupaod.f90 @@ -180,6 +180,7 @@ subroutine setupaod(obsLL,odiagLL,lunin,mype,nchanl,nreal,nobs,& real(r_kind) :: qcall, smask real(r_kind) :: styp, dbcf + real(r_kind),dimension(nchanl):: chan_level real(r_kind),dimension(nchanl):: emissivity,ts,emissivity_k real(r_kind),dimension(nchanl):: tsim real(r_kind),dimension(nsig,nchanl):: wmix,temp,ptau5 @@ -409,7 +410,7 @@ subroutine setupaod(obsLL,odiagLL,lunin,mype,nchanl,nreal,nobs,& call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, & tvp,qvp,qsat,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, & trop5,tzbgr,dtsavg,sfc_speed, & - tsim,emissivity,ptau5,ts,emissivity_k, & + tsim,emissivity,chan_level,ptau5,ts,emissivity_k, & temp,wmix,jacobian,error_status,layer_od=layer_od,jacobian_aero=jacobian_aero) ! interpolate aerosols at observation locations for diag files here if (aero_diagsave) then diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 index 20ab63456e..1ff2474e20 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -297,12 +297,14 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& use radinfo, only: iland_det, isnow_det, iwater_det, imix_det, iice_det, & iomg_det, itopo_det, isst_det,iwndspeed_det, optconv use qcmod, only: setup_tzr_qc,ifail_scanedge_qc,ifail_outside_range + use qcmod, only: iasi_cads, cris_cads use state_vectors, only: svars3d, levels, svars2d, ns3d use oneobmod, only: lsingleradob,obchan,oblat,oblon,oneob_type use correlated_obsmod, only: corr_adjust_jacobian, idnames use radiance_mod, only: rad_obs_type,radiance_obstype_search,radiance_ex_obserr,radiance_ex_biascor use sparsearr, only: sparr2, new, writearray, size, fullarray use radiance_mod, only: radiance_ex_obserr_gmi,radiance_ex_biascor_gmi + use cads, only: cads_imager_calc implicit none @@ -400,6 +402,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& real(r_kind),dimension(nsig):: qvp,tvp,qs real(r_kind),dimension(nsig):: prsltmp real(r_kind),dimension(nsig+1):: prsitmp + real(r_kind),dimension(nchanl):: chan_level real(r_kind),dimension(nchanl):: weightmax real(r_kind),dimension(nchanl):: cld_rbc_idx,cld_rbc_idx2 real(r_kind),dimension(nchanl):: tcc @@ -440,6 +443,11 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& logical:: muse_ii +! variables added for CADS + real(r_kind),dimension(7,nobs) :: imager_cluster_fraction + real(r_kind),dimension(2,7,nobs) :: imager_cluster_bt + real(r_kind),dimension(2,nobs) :: imager_chan_stdev, imager_model_bt + ! Notations in use: for a single obs. or a single obs. type ! nchanl : a known channel count of a given type obs stream ! nchanl_diag : a subset of "iuse" @@ -591,6 +599,26 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& return endif +! Load data array for current satellite + read(lunin) data_s,luse,ioid + + if (nobskeep>0) then +! write(6,*)'setuprad: nobskeep',nobskeep + call stop2(275) + end if + + call dtime_setup() +! If using CADS setup arrays and calculate imager BTs + imager_cluster_fraction=zero + imager_cluster_bt=zero + imager_chan_stdev=zero + imager_model_bt=zero + if ((iasi_cads .and. iasi) .or. (cris_cads .and. cris)) then + + call cads_imager_calc(obstype,isis,nobs,nreal,nchanl,nsig,data_s,init_pass,mype, & + imager_cluster_fraction,imager_cluster_bt,imager_chan_stdev, imager_model_bt) + endif ! using cads + if ( mype == 0 .and. .not.l_may_be_passive) write(6,*)mype,'setuprad: passive obs',is,isis ! Logic to turn off print of reading coefficients if not first interation or not mype_diaghdr or not init_pass @@ -697,8 +725,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif endif - - ! Find number of channels written to diag file if(reduce_diag)then nchanl_diag=0 @@ -768,24 +794,9 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& if (netcdf_diag) call init_netcdf_diag_ endif -! Load data array for current satellite - read(lunin) data_s,luse,ioid - - if (nobskeep>0) then -! write(6,*)'setuprad: nobskeep',nobskeep - call stop2(275) - end if - - if (abi2km .and. regional) then - abi2km_bc = zero - abi2km_bc(2) = 233.5_r_kind - abi2km_bc(3) = 241.7_r_kind - abi2km_bc(4) = 250.5_r_kind - end if ! PROCESSING OF SATELLITE DATA ! Loop over data in this block - call dtime_setup() do n = 1,nobs ! Extract analysis relative observation time. dtime = data_s(itime,n) @@ -911,7 +922,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, & tvp,qvp,qs,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, & trop5,tzbgr,dtsavg,sfc_speed, & - tsim,emissivity,ptau5,ts,emissivity_k, & + tsim,emissivity,chan_level,ptau5,ts,emissivity_k, & temp,wmix,jacobian,error_status,tsim_clr=tsim_clr,tcc=tcc, & tcwv=tcwv,hwp_ratio=hwp_ratio,stability=stability) if(gmi) then @@ -922,7 +933,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, & tvp,qvp,qs,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, & trop5,tzbgr,dtsavg,sfc_speed, & - tsim2,emissivity2,ptau52,ts2,emissivity_k2, & + tsim2,emissivity2,chan_level,ptau52,ts2,emissivity_k2, & temp2,wmix2,jacobian2,error_status,tsim_clr=tsim_clr2,tcc=tcc,& tcwv=tcwv,hwp_ratio=hwp_ratio,stability=stability) ! merge @@ -946,7 +957,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, & tvp,qvp,qs,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, & trop5,tzbgr,dtsavg,sfc_speed, & - tsim,emissivity,ptau5,ts,emissivity_k, & + tsim,emissivity,chan_level,ptau5,ts,emissivity_k, & temp,wmix,jacobian,error_status) if(gmi) then gmi_low_angles(1:3)=data_s(ilzen_ang:iscan_ang,n) @@ -956,7 +967,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, & tvp,qvp,qs,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, & trop5,tzbgr,dtsavg,sfc_speed, & - tsim2,emissivity2,ptau52,ts2,emissivity_k2, & + tsim2,emissivity2,chan_level,ptau52,ts2,emissivity_k2, & temp2,wmix2,jacobian2,error_status) ! merge emissivity(10:13) = emissivity2(10:13) @@ -1091,6 +1102,11 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif predbias=zero + abi2km_bc = zero + abi2km_bc(2) = 233.5_r_kind + abi2km_bc(3) = 241.7_r_kind + abi2km_bc(4) = 250.5_r_kind + !$omp parallel do schedule(dynamic,1) private(i,mm,j,k,tlap,node,bias) do i=1,nchanl mm=ich(i) @@ -1376,10 +1392,12 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& varinv_use(i) = zero end if end do - call qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse(n),goessndr, & - cris,hirs,zsges,cenlat,frac_sea,pangs,trop5,zasat,tzbgr,tsavg5,tbc,tb_obs,tbcnob,tnoise, & - wavenumber,ptau5,prsltmp,tvp,temp,wmix,emissivity_k,ts, & - id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,zero_irjaco3_pole(n)) + + call qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse(n),goessndr,airs,cris,iasi, & + hirs,zsges,cenlat,frac_sea,pangs,trop5,zasat,tzbgr,tsavg5,tbc,tb_obs,tbcnob,tnoise, & + wavenumber,ptau5,prsltmp,tvp,temp,wmix,chan_level,emissivity_k,ts,tsim, & + id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,zero_irjaco3_pole(n), & + imager_cluster_fraction(:,n), imager_cluster_bt(:,:,n), imager_chan_stdev(:,n),imager_model_bt(:,n)) ! --------- MSU ------------------- ! QC MSU data @@ -2745,9 +2763,10 @@ subroutine contents_netcdf_diag_(odiags,idv,iob) deallocate(predbias_angord) endif end subroutine contents_netcdf_diag_ - subroutine final_binary_diag_ close(4) end subroutine final_binary_diag_ end subroutine setuprad + + end module rad_setup From 44a8f59ef5cb6def27ba27fcc6a35c074a30332b Mon Sep 17 00:00:00 2001 From: Xu Lu Date: Tue, 5 Dec 2023 09:43:40 -0600 Subject: [PATCH 046/109] Dual-resolution EnVar capability for HAFS ensemble (#652) **Description** Add Dual-resolution EnVar capability for HAFS ensemble By Xu Lu and Xuguang Wang from OU. POC: xuguang.wang@ou.edu Fixes #603 **Type of change** - [Y] New feature (non-breaking change which adds functionality) **How Has This Been Tested?** Did a single observation test to ensure the capability works and the increments look reasonable compared to the single-resolution increment on Orion. **Checklist** - [Y] My code follows the style guidelines of this project - [Y] I have performed a self-review of my own code - [Y] I have commented my code, particularly in hard-to-understand areas - [Y] Any dependent changes have been merged and published **DUE DATE for this PR is 12/15/2023**. If this PR is not merged into `develop` by this date, the PR will be closed and returned to the developer. --------- Co-authored-by: Bin.Liu Co-authored-by: YongzuoLi-NOAA --- src/gsi/cplr_get_fv3_regional_ensperts.f90 | 17 +- src/gsi/gridmod.F90 | 6 +- src/gsi/gsi_rfv3io_mod.f90 | 345 +++++++++++-- src/gsi/hybrid_ensemble_isotropic.F90 | 11 +- src/gsi/mod_fv3_lola.f90 | 556 +++++++++++++++++++++ 5 files changed, 875 insertions(+), 60 deletions(-) diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 index 2382ff1286..81fb684a73 100644 --- a/src/gsi/cplr_get_fv3_regional_ensperts.f90 +++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90 @@ -38,6 +38,7 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) ! ! 2021-08-10 lei - modify for fv3-lam ensemble spread output ! 2021-11-01 lei - modify for fv3-lam parallel IO + ! 2022-03-01 X.Lu & X.Wang - modify for hafs dual ens. POC: xuguang.wang@ou.edu ! input argument list: ! ! output argument list: @@ -848,7 +849,7 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g use gridmod, only: eta1_ll,eta2_ll use constants, only: zero,one,fv,zero_single,one_tenth,h300 use hybrid_ensemble_parameters, only: grd_ens,q_hyb_ens - use hybrid_ensemble_parameters, only: fv3sar_ensemble_opt + use hybrid_ensemble_parameters, only: fv3sar_ensemble_opt,dual_res use mpimod, only: mpi_comm_world,mpi_rtype use gsi_rfv3io_mod,only: type_fv3regfilenameg @@ -956,24 +957,24 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g if(fv3sar_ensemble_opt == 0 ) then - call gsi_fv3ncdf_readuv(grd_fv3lam_ens_uv,g_u,g_v,fv3_filenameginput) + call gsi_fv3ncdf_readuv(grd_fv3lam_ens_uv,g_u,g_v,fv3_filenameginput,dual_res) else - call gsi_fv3ncdf_readuv_v1(grd_fv3lam_ens_uv,g_u,g_v,fv3_filenameginput) + call gsi_fv3ncdf_readuv_v1(grd_fv3lam_ens_uv,g_u,g_v,fv3_filenameginput,dual_res) endif if(fv3sar_ensemble_opt == 0) then call gsi_fv3ncdf_read(grd_fv3lam_ens_dynvar_io_nouv,gsibundle_fv3lam_ens_dynvar_nouv,& - fv3_filenameginput%dynvars,fv3_filenameginput) + fv3_filenameginput%dynvars,fv3_filenameginput,dual_res) call gsi_fv3ncdf_read(grd_fv3lam_ens_tracer_io_nouv,gsibundle_fv3lam_ens_tracer_nouv,& - fv3_filenameginput%tracers,fv3_filenameginput) + fv3_filenameginput%tracers,fv3_filenameginput,dual_res) if( if_model_dbz .or. if_model_fed ) then call gsi_fv3ncdf_read(grd_fv3lam_ens_phyvar_io_nouv,gsibundle_fv3lam_ens_phyvar_nouv,& - fv3_filenameginput%phyvars,fv3_filenameginput) + fv3_filenameginput%phyvars,fv3_filenameginput,dual_res) end if else call gsi_fv3ncdf_read_v1(grd_fv3lam_ens_dynvar_io_nouv,gsibundle_fv3lam_ens_dynvar_nouv,& - fv3_filenameginput%dynvars,fv3_filenameginput) + fv3_filenameginput%dynvars,fv3_filenameginput,dual_res) call gsi_fv3ncdf_read_v1(grd_fv3lam_ens_tracer_io_nouv,gsibundle_fv3lam_ens_tracer_nouv,& - fv3_filenameginput%tracers,fv3_filenameginput) + fv3_filenameginput%tracers,fv3_filenameginput,dual_res) endif ier=0 call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_dynvar_nouv, 'tsen' ,g_tsen ,istatus );ier=ier+istatus diff --git a/src/gsi/gridmod.F90 b/src/gsi/gridmod.F90 index 559a3f576d..2367899ea5 100644 --- a/src/gsi/gridmod.F90 +++ b/src/gsi/gridmod.F90 @@ -93,6 +93,7 @@ module gridmod ! 2019-09-23 martin - add use_gfs_ncio to read global first guess from netCDF file ! 2020-12-18 Hu - add grid_type_fv3_regional ! 2021-12-30 Hu - add fv3_io_layout_y +! 2022-03-01 X.Lu & X.Wang - add corresponding variables for dual ens for HAFS. POC: xuguang.wang@ou.edu ! ! ! @@ -146,6 +147,7 @@ module gridmod public :: regional_fhr,region_dyi,coeffx,region_dxi,coeffy,nsig_hlf,regional_fmin public :: nsig2,wgtlats,corlats,rbs2,ncepgfs_headv,regional_time,wgtfactlats public :: nlat_regional,nlon_regional,update_regsfc,half_grid,gencode + public :: nlat_regionalens,nlon_regionalens public :: diagnostic_reg,nmmb_reference_grid,filled_grid public :: grid_ratio_nmmb,isd_g,isc_g,dx_gfs,lpl_gfs,nsig5,nmmb_verttype public :: grid_ratio_fv3_regional,fv3_io_layout_y,fv3_regional,fv3_cmaq_regional,grid_type_fv3_regional @@ -329,7 +331,7 @@ module gridmod real(r_kind) rlon_min_dd,rlon_max_dd,rlat_min_dd,rlat_max_dd real(r_kind) dt_ll,pdtop_ll,pt_ll - integer(i_kind) nlon_regional,nlat_regional + integer(i_kind) nlon_regional,nlat_regional,nlon_regionalens,nlat_regionalens real(r_kind) regional_fhr,regional_fmin integer(i_kind) regional_time(6) integer(i_kind) jcap_gfs,nlat_gfs,nlon_gfs @@ -485,6 +487,8 @@ subroutine init_grid update_regsfc = .false. nlon_regional = 0 nlat_regional = 0 + nlon_regionalens = 0 + nlat_regionalens = 0 msig = nsig do k=1,size(nlayers) diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index e62cc06f2b..8158f35e11 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -18,6 +18,7 @@ module gsi_rfv3io_mod ! This function is needed when fv3 model sets ! io_layout(2)>1 ! 2022-02-15 Lu @ Wang - add time label it for FGAT. POC: xuguang.wang@ou.edu +! 2022-03-01 X.Lu @ X.Wang - add gsi_rfv3io_get_ens_grid_specs for dual ens HAFS. POC: xuguang.wang@ou.edu ! 2022-03-15 Hu - add code to read/write 2m T and Q for they will be ! used as background for surface observation operator ! 2022-04-15 Wang - add IO for regional FV3-CMAQ (RRFS-CMAQ) model @@ -27,6 +28,7 @@ module gsi_rfv3io_mod ! ! subroutines included: ! sub gsi_rfv3io_get_grid_specs +! sub gsi_rfv3io_get_ens_grid_specs ! sub read_fv3_files ! sub read_fv3_netcdf_guess ! sub gsi_fv3ncdf2d_read @@ -49,7 +51,7 @@ module gsi_rfv3io_mod !$$$ end documentation block use kinds, only: r_kind,i_kind - use gridmod, only: nlon_regional,nlat_regional + use gridmod, only: nlon_regional,nlat_regional,nlon_regionalens,nlat_regionalens use constants, only:max_varname_length,max_filename_length use gsi_bundlemod, only : gsi_bundle use general_sub2grid_mod, only: sub2grid_info @@ -82,7 +84,9 @@ module gsi_rfv3io_mod type(type_fv3regfilenameg),allocatable:: bg_fv3regfilenameg(:) integer(i_kind) nx,ny,nz + integer(i_kind) nxens,nyens integer(i_kind),dimension(:),allocatable :: ny_layout_len,ny_layout_b,ny_layout_e + integer(i_kind),dimension(:),allocatable :: ny_layout_lenens,ny_layout_bens,ny_layout_eens real(r_kind),allocatable:: grid_lon(:,:),grid_lont(:,:),grid_lat(:,:),grid_latt(:,:) real(r_kind),allocatable:: ak(:),bk(:) integer(i_kind),allocatable:: ijns2d(:),displss2d(:),ijns(:),displss(:) @@ -122,6 +126,7 @@ module gsi_rfv3io_mod private ! set subroutines to public public :: gsi_rfv3io_get_grid_specs + public :: gsi_rfv3io_get_ens_grid_specs public :: gsi_fv3ncdf_read public :: gsi_fv3ncdf_read_v1 public :: gsi_fv3ncdf_readuv @@ -500,6 +505,165 @@ subroutine gsi_rfv3io_get_grid_specs(ierr) return end subroutine gsi_rfv3io_get_grid_specs +subroutine gsi_rfv3io_get_ens_grid_specs(grid_spec,ierr) +!$$$ subprogram documentation block +! . . . . +! subprogram: gsi_rfv3io_get_ens_grid_specs +! modified from gsi_rfv3io_get_grid_specs +! pgrmmr: parrish org: np22 date: 2017-04-03 +! +! abstract: obtain grid dimensions nx,ny and grid definitions +! grid_x,grid_xt,grid_y,grid_yt,grid_lon,grid_lont,grid_lat,grid_latt +! nz,ak(nz),bk(nz) +! +! program history log: +! 2017-04-03 parrish - initial documentation +! 2017-10-10 wu - setup A grid and interpolation coeff with generate_anl_grid +! 2018-02-16 wu - read in time info from file coupler.res +! read in lat, lon at the center and corner of the grid cell +! from file fv3_grid_spec, and vertical grid infor from file +! fv3_akbk +! setup A grid and interpolation/rotation coeff +! input argument list: +! grid_spec +! ak_bk +! lendian_out +! +! output argument list: +! ierr +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr + use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_inquire_variable + use mpimod, only: mype + use mod_fv3_lola, only: definecoef_regular_grids + use gridmod, only:nsig,regional_time,regional_fhr,regional_fmin,aeta1_ll,aeta2_ll + use gridmod, only:nlon_regionalens,nlat_regionalens + use gridmod, only:grid_type_fv3_regional + use kinds, only: i_kind,r_kind + use constants, only: half,zero + use mpimod, only: mpi_comm_world,mpi_itype,mpi_rtype + implicit none + character(:),allocatable,intent(in) :: grid_spec + + integer(i_kind) gfile_grid_spec + integer(i_kind),intent( out) :: ierr + integer(i_kind) i,k,ndimensions,iret,nvariables,nattributes,unlimiteddimid + integer(i_kind) gfile_loc,len + character(len=128) :: name + integer(i_kind) :: nio,nylen + integer(i_kind),allocatable :: gfile_loc_layout(:) + character(len=180) :: filename_layout + integer(i_kind) imiddle,jmiddle,grid_ens_type_fv3_regional + + + iret=nf90_open(trim(grid_spec),nf90_nowrite,gfile_grid_spec) + if(iret/=nf90_noerr) then + write(6,*)' problem opening1 ',trim(grid_spec),', Status = ',iret + ierr=1 + return + endif + iret=nf90_inquire(gfile_grid_spec,ndimensions,nvariables,nattributes,unlimiteddimid) + gfile_loc=gfile_grid_spec + do k=1,ndimensions + iret=nf90_inquire_dimension(gfile_loc,k,name,len) + if(trim(name)=='grid_xt') nxens=len + if(trim(name)=='grid_yt') nyens=len + enddo + allocate(grid_lat(nxens+1,nyens+1)) + allocate(grid_lon(nxens+1,nyens+1)) + allocate(grid_latt(nxens,nyens)) + allocate(grid_lont(nxens,nyens)) + do k=ndimensions+1,nvariables + iret=nf90_inquire_variable(gfile_loc,k,name,len) + if(trim(name)=='grid_lat') then + iret=nf90_get_var(gfile_loc,k,grid_lat) + endif + if(trim(name)=='grid_lon') then + iret=nf90_get_var(gfile_loc,k,grid_lon) + endif + if(trim(name)=='grid_latt') then + iret=nf90_get_var(gfile_loc,k,grid_latt) + endif + if(trim(name)=='grid_lont') then + iret=nf90_get_var(gfile_loc,k,grid_lont) + endif + enddo + iret=nf90_close(gfile_loc) + + nlon_regionalens=nxens + nlat_regionalens=nyens + allocate(ny_layout_lenens(0:fv3_io_layout_y-1)) + allocate(ny_layout_bens(0:fv3_io_layout_y-1)) + allocate(ny_layout_eens(0:fv3_io_layout_y-1)) + ny_layout_lenens=nyens + ny_layout_bens=0 + ny_layout_eens=0 + if(fv3_io_layout_y > 1) then + allocate(gfile_loc_layout(0:fv3_io_layout_y-1)) + do nio=0,fv3_io_layout_y-1 + write(filename_layout,'(a,a,I4.4)') trim(grid_spec),'.',nio + iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio)) + if(iret/=nf90_noerr) then + write(6,*)' problem opening ',trim(filename_layout),', Status =',iret + ierr=1 + return + endif + iret=nf90_inquire(gfile_loc_layout(nio),ndimensions,nvariables,nattributes,unlimiteddimid) + do k=1,ndimensions + iret=nf90_inquire_dimension(gfile_loc_layout(nio),k,name,len) + if(trim(name)=='grid_yt') ny_layout_lenens(nio)=len + enddo + iret=nf90_close(gfile_loc_layout(nio)) + enddo + deallocate(gfile_loc_layout) +! figure out begin and end of each subdomain restart file + nylen=0 + do nio=0,fv3_io_layout_y-1 + ny_layout_bens(nio)=nylen + 1 + nylen=nylen+ny_layout_lenens(nio) + ny_layout_eens(nio)=nylen + enddo + endif + if(mype==0)write(6,*),'nxens,nyens=',nxens,nyens + if(mype==0)write(6,*),'ny_layout_lenens=',ny_layout_lenens + if(mype==0)write(6,*),'ny_layout_bens=',ny_layout_bens + if(mype==0)write(6,*),'ny_layout_eens=',ny_layout_eens + + imiddle=nxens/2 + jmiddle=nyens/2 + if( (grid_latt(imiddle,1) < grid_latt(imiddle,nyens)) .and. & + (grid_lont(1,jmiddle) < grid_lont(nxens,jmiddle)) ) then + grid_ens_type_fv3_regional = 2 + else + grid_ens_type_fv3_regional = 1 + endif +! check the grid type + if( grid_type_fv3_regional == grid_ens_type_fv3_regional ) then + if(mype==0) write(6,*) 'Ensemble has the same orientation as the control, Cool!' + else + write(6,*) 'Warning! Ensemble has a different orientation as the control. This case needs further tests, Abort!' + call stop2(678) + endif +! + if(grid_type_fv3_regional == 2) then + call reverse_grid_r(grid_lont,nxens,nyens,1) + call reverse_grid_r(grid_latt,nxens,nyens,1) + call reverse_grid_r(grid_lon,nxens+1,nyens+1,1) + call reverse_grid_r(grid_lat,nxens+1,nyens+1,1) + endif + + call definecoef_regular_grids(nxens,nyens,grid_lon,grid_lont,grid_lat,grid_latt) + deallocate (grid_lon,grid_lat,grid_lont,grid_latt) + return +end subroutine gsi_rfv3io_get_ens_grid_specs + + subroutine read_fv3_files(mype) !$$$ subprogram documentation block ! . . . . @@ -1110,7 +1274,9 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) endif end do if (ndynvario2d > 0) then - allocate(fv3lam_io_dynmetvars2d_nouv(ndynvario2d)) + if (.not. allocated(fv3lam_io_dynmetvars2d_nouv)) then + allocate(fv3lam_io_dynmetvars2d_nouv(ndynvario2d)) + end if endif if (ntracerio2d > 0) then allocate(fv3lam_io_tracermetvars2d_nouv(ntracerio2d)) @@ -1421,40 +1587,40 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) end if if( fv3sar_bg_opt == 0) then - call gsi_fv3ncdf_readuv(grd_fv3lam_uv,ges_u,ges_v,fv3filenamegin(it)) + call gsi_fv3ncdf_readuv(grd_fv3lam_uv,ges_u,ges_v,fv3filenamegin(it),.false.) else - call gsi_fv3ncdf_readuv_v1(grd_fv3lam_uv,ges_u,ges_v,fv3filenamegin(it)) + call gsi_fv3ncdf_readuv_v1(grd_fv3lam_uv,ges_u,ges_v,fv3filenamegin(it),.false.) endif if( fv3sar_bg_opt == 0) then call gsi_fv3ncdf_read(grd_fv3lam_dynvar_ionouv,gsibundle_fv3lam_dynvar_nouv & - & ,fv3filenamegin(it)%dynvars,fv3filenamegin(it)) + & ,fv3filenamegin(it)%dynvars,fv3filenamegin(it),.false.) call gsi_fv3ncdf_read(grd_fv3lam_tracer_ionouv,gsibundle_fv3lam_tracer_nouv & - & ,fv3filenamegin(it)%tracers,fv3filenamegin(it)) + & ,fv3filenamegin(it)%tracers,fv3filenamegin(it),.false.) if( nphyvario3d > 0 )then call gsi_fv3ncdf_read(grd_fv3lam_phyvar_ionouv,gsibundle_fv3lam_phyvar_nouv & - & ,fv3filenamegin(it)%phyvars,fv3filenamegin(it)) + & ,fv3filenamegin(it)%phyvars,fv3filenamegin(it),.false.) end if if (laeroana_fv3cmaq) then call gsi_fv3ncdf_read(grd_fv3lam_tracerchem_ionouv,gsibundle_fv3lam_tracerchem_nouv & - & ,fv3filenamegin(it)%tracers,fv3filenamegin(it)) + & ,fv3filenamegin(it)%tracers,fv3filenamegin(it),.false.) endif if (laeroana_fv3smoke) then call gsi_fv3ncdf_read(grd_fv3lam_tracersmoke_ionouv,gsibundle_fv3lam_tracersmoke_nouv & - & ,fv3filenamegin(it)%tracers,fv3filenamegin(it)) + & ,fv3filenamegin(it)%tracers,fv3filenamegin(it),.false.) endif else call gsi_fv3ncdf_read_v1(grd_fv3lam_dynvar_ionouv,gsibundle_fv3lam_dynvar_nouv & - & ,fv3filenamegin(it)%dynvars,fv3filenamegin(it)) + & ,fv3filenamegin(it)%dynvars,fv3filenamegin(it),.false.) call gsi_fv3ncdf_read_v1(grd_fv3lam_tracer_ionouv,gsibundle_fv3lam_tracer_nouv & - & ,fv3filenamegin(it)%tracers,fv3filenamegin(it)) + & ,fv3filenamegin(it)%tracers,fv3filenamegin(it),.false.) if (laeroana_fv3cmaq) then call gsi_fv3ncdf_read_v1(grd_fv3lam_tracerchem_ionouv,gsibundle_fv3lam_tracerchem_nouv & - & ,fv3filenamegin(it)%tracers,fv3filenamegin(it)) + & ,fv3filenamegin(it)%tracers,fv3filenamegin(it),.false.) endif if (laeroana_fv3smoke) then call gsi_fv3ncdf_read_v1(grd_fv3lam_tracersmoke_ionouv,gsibundle_fv3lam_tracersmoke_nouv & - & ,fv3filenamegin(it)%tracers,fv3filenamegin(it)) + & ,fv3filenamegin(it)%tracers,fv3filenamegin(it),.false.) endif endif @@ -2220,7 +2386,7 @@ subroutine gsi_fv3ncdf2d_read_v1(filenamein,varname,varname2,work_sub,mype_io) return end subroutine gsi_fv3ncdf2d_read_v1 -subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) +subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ensgrid) !$$$ subprogram documentation block ! . . . . ! subprogram: gsi_fv3ncdf_read @@ -2253,7 +2419,7 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension use netcdf, only: nf90_inquire_variable use netcdf, only: nf90_inq_varid - use mod_fv3_lola, only: fv3_h_to_ll + use mod_fv3_lola, only: fv3_h_to_ll,fv3_h_to_ll_ens use gsi_bundlemod, only: gsi_bundle use general_sub2grid_mod, only: sub2grid_info,general_grid2sub @@ -2262,6 +2428,7 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) type(gsi_bundle),intent(inout) :: cstate_nouv character(*),intent(in):: filenamein type (type_fv3regfilenameg),intent(in) ::fv3filenamegin + logical, intent(in ) :: ensgrid real(r_kind),allocatable,dimension(:,:):: uu2d real(r_kind),dimension(1,grd_ionouv%nlat,grd_ionouv%nlon,grd_ionouv%kbegin_loc:grd_ionouv%kend_alloc):: hwork character(len=max_varname_length) :: varname,vgsiname @@ -2290,8 +2457,13 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) mm1=mype+1 nloncase=grd_ionouv%nlon nlatcase=grd_ionouv%nlat - nxcase=nx - nycase=ny + if (ensgrid) then + nxcase=nxens + nycase=nyens + else + nxcase=nx + nycase=ny + end if kbgn=grd_ionouv%kbegin_loc kend=grd_ionouv%kend_loc allocate(uu2d(nxcase,nycase)) @@ -2376,11 +2548,20 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 - countloc=(/nxcase,ny_layout_len(nio),1/) - allocate(uu2d_layout(nxcase,ny_layout_len(nio))) + if (ensgrid) then + countloc=(/nxcase,ny_layout_lenens(nio)+1,1/) + allocate(uu2d_layout(nxcase,ny_layout_lenens(nio)+1)) + else + countloc=(/nxcase,ny_layout_len(nio),1/) + allocate(uu2d_layout(nxcase,ny_layout_len(nio))) + end if iret=nf90_inq_varid(gfile_loc_layout(nio),trim(adjustl(varname)),var_id) iret=nf90_get_var(gfile_loc_layout(nio),var_id,uu2d_layout,start=startloc,count=countloc) - uu2d(:,ny_layout_b(nio):ny_layout_e(nio))=uu2d_layout + if (ensgrid) then + uu2d(:,ny_layout_bens(nio):ny_layout_eens(nio))=uu2d_layout + else + uu2d(:,ny_layout_b(nio):ny_layout_e(nio))=uu2d_layout + end if deallocate(uu2d_layout) enddo else @@ -2403,7 +2584,11 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) end if endif - call fv3_h_to_ll(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + if (ensgrid) then + call fv3_h_to_ll_ens(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + else + call fv3_h_to_ll(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + endif enddo ! ilevtot if(fv3_io_layout_y > 1) then @@ -2423,7 +2608,7 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) return end subroutine gsi_fv3ncdf_read -subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) +subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ensgrid) !$$$ subprogram documentation block ! . . . . @@ -2458,13 +2643,14 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension use netcdf, only: nf90_inquire_variable use netcdf, only: nf90_inq_varid - use mod_fv3_lola, only: fv3_h_to_ll + use mod_fv3_lola, only: fv3_h_to_ll,fv3_h_to_ll_ens use gsi_bundlemod, only: gsi_bundle use general_sub2grid_mod, only: sub2grid_info,general_grid2sub implicit none type(sub2grid_info), intent(in):: grd_ionouv character(*),intent(in):: filenamein + logical, intent(in ) :: ensgrid type (type_fv3regfilenameg) :: fv3filenamegin type(gsi_bundle),intent(inout) :: cstate_nouv real(r_kind),allocatable,dimension(:,:):: uu2d @@ -2484,8 +2670,13 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) nloncase=grd_ionouv%nlon nlatcase=grd_ionouv%nlat - nxcase=nx - nycase=ny + if (ensgrid) then + nxcase=nxens + nycase=nyens + else + nxcase=nx + nycase=ny + end if kbgn=grd_ionouv%kbegin_loc kend=grd_ionouv%kend_loc allocate(uu2d(nxcase,nycase)) @@ -2519,7 +2710,11 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) iret=nf90_get_var(gfile_loc,var_id,uu2d,start=startloc,count=countloc) - call fv3_h_to_ll(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + if (ensgrid) then + call fv3_h_to_ll_ens(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + else + call fv3_h_to_ll(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + end if enddo ! i call general_grid2sub(grd_ionouv,hwork,cstate_nouv%values) @@ -2531,7 +2726,7 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) return end subroutine gsi_fv3ncdf_read_v1 -subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) +subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) !$$$ subprogram documentation block ! . . . . ! subprogram: gsi_fv3ncdf_readuv @@ -2558,7 +2753,7 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension use netcdf, only: nf90_inquire_variable use netcdf, only: nf90_inq_varid - use mod_fv3_lola, only: fv3_h_to_ll,fv3uv2earth + use mod_fv3_lola, only: fv3_h_to_ll,fv3uv2earth,fv3_h_to_ll_ens,fv3uv2earthens use general_sub2grid_mod, only: sub2grid_info,general_grid2sub implicit none @@ -2566,6 +2761,7 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) real(r_kind),dimension(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig),intent(inout)::ges_u real(r_kind),dimension(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig),intent(inout)::ges_v type (type_fv3regfilenameg),intent (in) :: fv3filenamegin + logical, intent(in ) :: ensgrid real(r_kind),dimension(2,grd_uv%nlat,grd_uv%nlon,grd_uv%kbegin_loc:grd_uv%kend_alloc):: hwork character(:), allocatable:: filenamein real(r_kind),allocatable,dimension(:,:):: u2d,v2d @@ -2596,8 +2792,13 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) mm1=mype+1 nloncase=grd_uv%nlon nlatcase=grd_uv%nlat - nxcase=nx - nycase=ny + if (ensgrid) then + nxcase=nxens + nycase=nyens + else + nxcase=nx + nycase=ny + end if kbgn=grd_uv%kbegin_loc kend=grd_uv%kend_loc allocate(u2d(nxcase,nycase+1)) @@ -2667,19 +2868,35 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) v_startloc=(/1,1,inative/) if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 - u_countloc=(/nxcase,ny_layout_len(nio)+1,1/) - allocate(u2d_layout(nxcase,ny_layout_len(nio)+1)) + if (ensgrid) then + u_countloc=(/nxcase,ny_layout_lenens(nio)+1,1/) + allocate(u2d_layout(nxcase,ny_layout_lenens(nio)+1)) + else + u_countloc=(/nxcase,ny_layout_len(nio)+1,1/) + allocate(u2d_layout(nxcase,ny_layout_len(nio)+1)) + end if call check( nf90_inq_varid(gfile_loc_layout(nio),'u',u_grd_VarId) ) iret=nf90_get_var(gfile_loc_layout(nio),u_grd_VarId,u2d_layout,start=u_startloc,count=u_countloc) - u2d(:,ny_layout_b(nio):ny_layout_e(nio))=u2d_layout(:,1:ny_layout_len(nio)) - if(nio==fv3_io_layout_y-1) u2d(:,ny_layout_e(nio)+1)=u2d_layout(:,ny_layout_len(nio)+1) - deallocate(u2d_layout) - - v_countloc=(/nxcase+1,ny_layout_len(nio),1/) - allocate(v2d_layout(nxcase+1,ny_layout_len(nio))) + if (ensgrid) then + u2d(:,ny_layout_bens(nio):ny_layout_eens(nio))=u2d_layout(:,1:ny_layout_lenens(nio)) + if(nio==fv3_io_layout_y-1) u2d(:,ny_layout_eens(nio)+1)=u2d_layout(:,ny_layout_lenens(nio)+1) + deallocate(u2d_layout) + v_countloc=(/nxcase+1,ny_layout_lenens(nio),1/) + allocate(v2d_layout(nxcase+1,ny_layout_lenens(nio))) + else + u2d(:,ny_layout_b(nio):ny_layout_e(nio))=u2d_layout(:,1:ny_layout_len(nio)) + if(nio==fv3_io_layout_y-1) u2d(:,ny_layout_e(nio)+1)=u2d_layout(:,ny_layout_len(nio)+1) + deallocate(u2d_layout) + v_countloc=(/nxcase+1,ny_layout_len(nio),1/) + allocate(v2d_layout(nxcase+1,ny_layout_len(nio))) + end if call check( nf90_inq_varid(gfile_loc_layout(nio),'v',v_grd_VarId) ) iret=nf90_get_var(gfile_loc_layout(nio),v_grd_VarId,v2d_layout,start=v_startloc,count=v_countloc) - v2d(:,ny_layout_b(nio):ny_layout_e(nio))=v2d_layout + if (ensgrid) then + v2d(:,ny_layout_bens(nio):ny_layout_eens(nio))=v2d_layout + else + v2d(:,ny_layout_b(nio):ny_layout_e(nio))=v2d_layout + end if deallocate(v2d_layout) enddo else @@ -2693,7 +2910,11 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) call reverse_grid_r_uv (u2d,nxcase,nycase+1,1) call reverse_grid_r_uv (v2d,nxcase+1,nycase,1) endif - call fv3uv2earth(u2d(:,:),v2d(:,:),nxcase,nycase,uc2d,vc2d) + if (ensgrid) then + call fv3uv2earthens(u2d(:,:),v2d(:,:),nxcase,nycase,uc2d,vc2d) + else + call fv3uv2earth(u2d(:,:),v2d(:,:),nxcase,nycase,uc2d,vc2d) + end if ! NOTE on transfor to earth u/v: ! The u and v before transferring need to be in E-W/N-S grid, which is @@ -2711,8 +2932,13 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) ! and the last input parameter for fv3_h_to_ll is alway true: ! ! - call fv3_h_to_ll(uc2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) - call fv3_h_to_ll(vc2d,hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) + if (ensgrid) then + call fv3_h_to_ll_ens(uc2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) + call fv3_h_to_ll_ens(vc2d,hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) + else + call fv3_h_to_ll(uc2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) + call fv3_h_to_ll(vc2d,hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) + end if enddo ! i if(fv3_io_layout_y > 1) then @@ -2734,7 +2960,7 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin) deallocate(worksub) end subroutine gsi_fv3ncdf_readuv -subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin) +subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) !$$$ subprogram documentation block ! subprogram: gsi_fv3ncdf_readuv_v1 ! prgmmr: wu w org: np22 date: 2017-11-22 @@ -2762,7 +2988,7 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin) use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension use netcdf, only: nf90_inquire_variable use netcdf, only: nf90_inq_varid - use mod_fv3_lola, only: fv3_h_to_ll,fv3uv2earth + use mod_fv3_lola, only: fv3_h_to_ll,fv3_h_to_ll_ens use general_sub2grid_mod, only: sub2grid_info,general_grid2sub implicit none @@ -2770,6 +2996,7 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin) real(r_kind) ,intent(out ) :: ges_u(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig) real(r_kind) ,intent(out ) :: ges_v(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig) type (type_fv3regfilenameg),intent (in) :: fv3filenamegin + logical, intent(in ) :: ensgrid real(r_kind),dimension(2,grd_uv%nlat,grd_uv%nlon,grd_uv%kbegin_loc:grd_uv%kend_alloc):: hwork character(len=:),allocatable :: filenamein real(r_kind),allocatable,dimension(:,:):: us2d,vw2d @@ -2792,8 +3019,13 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin) mm1=mype+1 nloncase=grd_uv%nlon nlatcase=grd_uv%nlat - nxcase=nx - nycase=ny + if (ensgrid) then + nxcase=nxens + nycase=nyens + else + nxcase=nx + nycase=ny + end if kbgn=grd_uv%kbegin_loc kend=grd_uv%kend_loc allocate (us2d(nxcase,nycase+1),vw2d(nxcase+1,nycase)) @@ -2818,8 +3050,13 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin) nz=grd_uv%nsig nzp1=nz+1 inative=nzp1-ilev - us_countloc= (/nlon_regional,nlat_regional+1,1/) - vw_countloc= (/nlon_regional+1,nlat_regional,1/) + if (ensgrid) then + us_countloc= (/nlon_regionalens,nlat_regionalens+1,1/) + vw_countloc= (/nlon_regionalens+1,nlat_regionalens,1/) + else + us_countloc= (/nlon_regional,nlat_regional+1,1/) + vw_countloc= (/nlon_regional+1,nlat_regional,1/) + end if us_startloc=(/1,1,inative+1/) vw_startloc=(/1,1,inative+1/) @@ -2834,11 +3071,19 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin) uorv2d(:,j)=half*(us2d(:,j)+us2d(:,j+1)) enddo - call fv3_h_to_ll(uorv2d(:,:),hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + if (ensgrid) then + call fv3_h_to_ll_ens(uorv2d(:,:),hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) + else + call fv3_h_to_ll(uorv2d(:,:),hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + end if do j=1,nx uorv2d(j,:)=half*(vw2d(j,:)+vw2d(j+1,:)) enddo - call fv3_h_to_ll(uorv2d(:,:),hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + if (ensgrid) then + call fv3_h_to_ll_ens(uorv2d(:,:),hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.) + else + call fv3_h_to_ll(uorv2d(:,:),hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag) + end if enddo ! iilevtoto call general_grid2sub(grd_uv,hwork,worksub) diff --git a/src/gsi/hybrid_ensemble_isotropic.F90 b/src/gsi/hybrid_ensemble_isotropic.F90 index 4bad129a72..ef6b53119c 100644 --- a/src/gsi/hybrid_ensemble_isotropic.F90 +++ b/src/gsi/hybrid_ensemble_isotropic.F90 @@ -4001,7 +4001,8 @@ subroutine hybens_grid_setup ! 2010-02-20 parrish, adapt for dual resolution ! 2011-01-30 parrish, fix so regional application depends only on parameters regional ! and dual_res. Rename subroutine get_regional_gefs_grid to get_regional_dual_res_grid. -! +! +! 2022-03-01 X.Lu & X.Wang - add vars for hafs dual ens. POC: xuguang.wang@ou.edu ! input argument list: ! ! output argument list: @@ -4027,6 +4028,8 @@ subroutine hybens_grid_setup use control_vectors, only: cvars3d,nc2d,nc3d use gridmod, only: region_lat,region_lon,region_dx,region_dy use hybrid_ensemble_parameters, only:nsclgrp,spc_multwgt,spcwgt_params,global_spectral_filter_sd + use hybrid_ensemble_parameters, only:regional_ensemble_option + use gsi_rfv3io_mod,only:gsi_rfv3io_get_ens_grid_specs implicit none @@ -4035,6 +4038,8 @@ subroutine hybens_grid_setup logical,allocatable::vector(:) real(r_kind) eps,r_e real(r_kind) rlon_a(nlon),rlat_a(nlat),rlon_e(nlon),rlat_e(nlat) + character(:),allocatable:: fv3_ens_spec_grid_filename + integer :: ierr nord_e2a=4 ! soon, move this to hybrid_ensemble_parameters @@ -4121,6 +4126,10 @@ subroutine hybens_grid_setup else if(dual_res) then call get_region_dx_dy_ens(region_dx_ens,region_dy_ens) + if(regional_ensemble_option == 5) then + fv3_ens_spec_grid_filename="fv3_ens_grid_spec" + call gsi_rfv3io_get_ens_grid_specs(fv3_ens_spec_grid_filename,ierr) + endif else region_dx_ens=region_dx region_dy_ens=region_dy diff --git a/src/gsi/mod_fv3_lola.f90 b/src/gsi/mod_fv3_lola.f90 index ebe0816c4a..4ec3c0cb93 100644 --- a/src/gsi/mod_fv3_lola.f90 +++ b/src/gsi/mod_fv3_lola.f90 @@ -18,12 +18,17 @@ module mod_fv3_lola ! fv3_ll_to_h ! 2019-11-01 wu - add checks in generate_anl_grid to present the mean ! longitude correctly to fix problem near lon=0 +! 2022-03-01 X.Lu & X.Wang - add functions for HAFS dual ens capability. POC: +! xuguang.wang@ou.edu ! ! subroutines included: ! sub generate_anl_grid +! sub definecoef_regular_grids ! sub earthuv2fv3 ! sub fv3uv2earth +! sub fv3uv2earthens ! sub fv3_h_to_ll +! sub fv3_h_to_ll_ens ! sub fv3_ll_to_h ! sub rotate2deg ! sub unrotate2deg @@ -65,6 +70,9 @@ module mod_fv3_lola public :: generate_anl_grid,fv3_h_to_ll,fv3_ll_to_h,fv3uv2earth,earthuv2fv3 public :: fv3dx,fv3dx1,fv3dy,fv3dy1,fv3ix,fv3ixp,fv3jy,fv3jyp,a3dx,a3dx1,a3dy,a3dy1,a3ix,a3ixp,a3jy,a3jyp public :: nxa,nya,cangu,sangu,cangv,sangv,nx,ny,bilinear + public :: definecoef_regular_grids,fv3_h_to_ll_ens,fv3uv2earthens + public :: fv3dxens,fv3dx1ens,fv3dyens,fv3dy1ens,fv3ixens,fv3ixpens,fv3jyens,fv3jypens,a3dxens,a3dx1ens,a3dyens,a3dy1ens,a3ixens,a3ixpens,a3jyens,a3jypens + public :: nxe,nye,canguens,sanguens,cangvens,sangvens logical bilinear integer(i_kind) nxa,nya,nx,ny @@ -73,6 +81,12 @@ module mod_fv3_lola real(r_kind) ,allocatable,dimension(:,:):: a3dx,a3dx1,a3dy,a3dy1 real(r_kind) ,allocatable,dimension(:,:):: cangu,sangu,cangv,sangv integer(i_kind),allocatable,dimension(:,:):: a3ix,a3ixp,a3jy,a3jyp + integer(i_kind) nxe,nye + real(r_kind) ,allocatable,dimension(:,:):: fv3dxens,fv3dx1ens,fv3dyens,fv3dy1ens + integer(i_kind),allocatable,dimension(:,:):: fv3ixens,fv3ixpens,fv3jyens,fv3jypens + real(r_kind) ,allocatable,dimension(:,:):: a3dxens,a3dx1ens,a3dyens,a3dy1ens + real(r_kind) ,allocatable,dimension(:,:):: canguens,sanguens,cangvens,sangvens + integer(i_kind),allocatable,dimension(:,:):: a3ixens,a3ixpens,a3jyens,a3jypens contains @@ -574,8 +588,425 @@ subroutine generate_anl_grid(nx,ny,grid_lon,grid_lont,grid_lat,grid_latt) enddo enddo deallocate( xc,yc,zc,gclat,gclon,gcrlat,gcrlon) + deallocate(rlat_in,rlon_in) end subroutine generate_anl_grid +subroutine definecoef_regular_grids(nxen,nyen,grid_lon,grid_lont,grid_lat,grid_latt) +!$$$ subprogram documentation block +! . . . . +! subprogram: generate_??ens_grid +!clt modified from generate_regular_grid +! prgmmr: parrish +! +! abstract: define rotated lat-lon analysis grid which is centered on fv3 tile +! and oriented to completely cover the tile. +! +! program history log: +! 2017-05-02 parrish +! 2017-10-10 wu - 1. setup analysis A-grid, +! 2. compute/setup FV3 to A grid interpolation parameters +! 3. compute/setup A to FV3 grid interpolation parameters +! 4. setup weightings for wind conversion from FV3 to earth +! 2021-02-01 Lu & Wang - modify variable intent for HAFS dual ens. POC: +! xuguang.wang@ou.edu +! +! input argument list: +! nxen, nyen - number of cells = nxen*nyen +! grid_lon ,grid_lat - longitudes and latitudes of fv3 grid cell corners +! grid_lont,grid_latt - longitudes and latitudes of fv3 grid cell centers +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + use kinds, only: r_kind,i_kind + use constants, only: quarter,one,two,half,zero,deg2rad,rearth,rad2deg + use gridmod, only:grid_ratio_fv3_regional + use mpimod, only: mype + use hybrid_ensemble_parameters, only: nlon_ens,nlat_ens,region_lon_ens,region_lat_ens + implicit none + real(r_kind),allocatable,dimension(:)::xbh_a,xa_a,xa_b + real(r_kind),allocatable,dimension(:)::ybh_a,ya_a,ya_b,yy + real(r_kind),allocatable,dimension(:,:)::xbh_b,ybh_b + real(r_kind) dlat,dlon,dyy,dxx,dyyi,dxxi + real(r_kind) dyyh,dxxh + + real(r_kind),allocatable:: region_lat_tmp(:,:),region_lon_tmp(:,:) + integer(i_kind), intent(in ) :: nxen,nyen ! fv3 tile x- and y-dimensions + real(r_kind) , intent(inout) :: grid_lon(nxen+1,nyen+1) ! fv3 cell corner longitudes + real(r_kind) , intent(inout) :: grid_lont(nxen,nyen) ! fv3 cell center longitudes + real(r_kind) , intent(inout) :: grid_lat(nxen+1,nyen+1) ! fv3 cell corner latitudes + real(r_kind) , intent(inout) :: grid_latt(nxen,nyen) ! fv3 cell center latitudes + integer(i_kind) i,j,ir,jr,n + real(r_kind),allocatable,dimension(:,:) :: xc,yc,zc,gclat,gclon,gcrlat,gcrlon,rlon_in,rlat_in + real(r_kind),allocatable,dimension(:,:) :: glon_an,glat_an + real(r_kind) xcent,ycent,zcent,rnorm,centlat,centlon + integer(i_kind) nlonh,nlath,nxh,nyh + integer(i_kind) ib1,ib2,jb1,jb2,jj + integer (i_kind):: index0 + real(r_kind) region_lat_in(nlat_ens,nlon_ens),region_lon_in(nlat_ens,nlon_ens) + integer(i_kind) nord_e2a + real(r_kind)gxa,gya + + real(r_kind) x(nxen+1,nyen+1),y(nxen+1,nyen+1),z(nxen+1,nyen+1),xr,yr,zr,xu,yu,zu,rlat,rlon + real(r_kind) xv,yv,zv,vval + real(r_kind) cx,cy + real(r_kind) uval,ewval,nsval + + real(r_kind) d(4),ds + integer(i_kind) kk,k + real(r_kind) diff,sq180 + + nord_e2a=4 + bilinear=.false. + +! create xc,yc,zc for the cell centers. + allocate(xc(nxen,nyen)) + allocate(yc(nxen,nyen)) + allocate(zc(nxen,nyen)) + allocate(gclat(nxen,nyen)) + allocate(gclon(nxen,nyen)) + allocate(gcrlat(nxen,nyen)) + allocate(gcrlon(nxen,nyen)) + do j=1,nyen + do i=1,nxen + xc(i,j)=cos(grid_latt(i,j)*deg2rad)*cos(grid_lont(i,j)*deg2rad) + yc(i,j)=cos(grid_latt(i,j)*deg2rad)*sin(grid_lont(i,j)*deg2rad) + zc(i,j)=sin(grid_latt(i,j)*deg2rad) + enddo + enddo + +! compute center as average x,y,z coordinates of corners of domain -- + + xcent=quarter*(xc(1,1)+xc(1,nyen)+xc(nxen,1)+xc(nxen,nyen)) + ycent=quarter*(yc(1,1)+yc(1,nyen)+yc(nxen,1)+yc(nxen,nyen)) + zcent=quarter*(zc(1,1)+zc(1,nyen)+zc(nxen,1)+zc(nxen,nyen)) + + rnorm=one/sqrt(xcent**2+ycent**2+zcent**2) + xcent=rnorm*xcent + ycent=rnorm*ycent + zcent=rnorm*zcent + centlat=asin(zcent)*rad2deg + centlon=atan2(ycent,xcent)*rad2deg + +!! compute new lats, lons + call rotate2deg(grid_lont,grid_latt,gcrlon,gcrlat, & + centlon,centlat,nxen,nyen) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! compute analysis A-grid lats, lons +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!--------------------------obtain analysis grid dimensions nxe,nye + nxe=nlon_ens + nye=nlat_ens + if(mype==0) print *,'nlat,nlon=nye,nxe= ',nlat_ens,nlon_ens + + allocate(rlat_in(nlat_ens,nlon_ens),rlon_in(nlat_ens,nlon_ens)) + allocate(region_lon_tmp(nlat_ens,nlon_ens),region_lat_tmp(nlat_ens,nlon_ens)) + region_lon_tmp=region_lon_ens*rad2deg + region_lat_tmp=region_lat_ens*rad2deg + call rotate2deg(region_lon_tmp,region_lat_tmp,rlon_in,rlat_in, & + centlon,centlat,nlat_ens,nlon_ens) + +!--------------------------obtain analysis grid spacing + dlat=(maxval(gcrlat)-minval(gcrlat))/(nyen-1) + dlon=(maxval(gcrlon)-minval(gcrlon))/(nxen-1) + + +!-----setup analysis A-grid from center of the domain +!--------------------compute all combinations of relative coordinates + + allocate(xbh_a(nxen),xbh_b(nxen,nyen),xa_a(nxe),xa_b(nxe)) + allocate(ybh_a(nyen),ybh_b(nxen,nyen),ya_a(nye),ya_b(nye)) + + nxh=nxen/2 + nyh=nyen/2 + + +!!!!!! fv3 rotated grid; not equal spacing, non_orthogonal !!!!!! + do j=1,nyen + jr=nyen+1-j + do i=1,nxen + ir=nxen+1-i + xbh_b(ir,jr)=gcrlon(i,j)/dlon + end do + end do + do j=1,nyen + jr=nyen+1-j + do i=1,nxen + ir=nxen+1-i + ybh_b(ir,jr)=gcrlat(i,j)/dlat + end do + end do + +!!!! define analysis A grid !!!!!!!!!!!!! + + index0=1 + do j=1,nxe + xa_a(j)= rlon_in(index0,j)/dlon + end do + do i=1,nye + ya_a(i)= rlat_in(i,index0)/dlat + end do + +!!!!!compute fv3 to A grid interpolation parameters !!!!!!!!! + allocate (fv3dxens(nxe,nye),fv3dx1ens(nxe,nye),fv3dyens(nxe,nye),fv3dy1ens(nxe,nye)) + allocate (fv3ixens(nxe,nye),fv3ixpens(nxe,nye),fv3jyens(nxe,nye),fv3jypens(nxe,nye)) + allocate(yy(nyen)) + +! iteration to find the fv3 grid cell + jb1=1 + ib1=1 + do j=1,nye + do i=1,nxe + do n=1,3 + gxa=xa_a(i) + if(gxa < xbh_b(1,jb1))then + gxa= 1 + else if(gxa > xbh_b(nxen,jb1))then + gxa= nxen + else + call grdcrd1(gxa,xbh_b(1,jb1),nxen,1) + endif + ib2=ib1 + ib1=gxa + do jj=1,nyen + yy(jj)=ybh_b(ib1,jj) + enddo + gya=ya_a(j) + if(gya < yy(1))then + gya= 1 + else if(gya > yy(nyen))then + gya= nyen + else + call grdcrd1(gya,yy,nyen,1) + endif + jb2=jb1 + jb1=gya + if(ib1+1 > nxen)then !this block( 6 lines) is copied from GSL gsi repository + ib1=ib1-1 + endif + if(jb1+1 > nyen)then + jb1=jb1-1 + endif + + if((ib1 == ib2) .and. (jb1 == jb2)) exit + if(n==3 ) then +!!!!!!! if not converge, find the nearest corner point + d(1)=(xa_a(i)-xbh_b(ib1,jb1))**2+(ya_a(j)-ybh_b(ib1,jb1))**2 + d(2)=(xa_a(i)-xbh_b(ib1+1,jb1))**2+(ya_a(j)-ybh_b(ib1+1,jb1))**2 + d(3)=(xa_a(i)-xbh_b(ib1,jb1+1))**2+(ya_a(j)-ybh_b(ib1,jb1+1))**2 + d(4)=(xa_a(i)-xbh_b(ib1+1,jb1+1))**2+(ya_a(j)-ybh_b(ib1+1,jb1+1))**2 + kk=1 + do k=2,4 + if(d(k) xa_a(nxe))then + gxa= nxe + else + call grdcrd1(gxa,xa_a,nxe,1) + endif + a3ixens(j,i)=int(gxa) + a3ixens(j,i)=min(max(1,a3ixens(j,i)),nxe) + a3dxens(j,i)=max(zero,min(one,gxa-a3ixens(j,i))) + a3dx1ens(j,i)=one-a3dxens(j,i) + a3ixpens(j,i)=min(nxe,a3ixens(j,i)+1) + end do + end do + + do i=1,nxen + do j=1,nyen + gya=ybh_b(i,j) + if(gya < ya_a(1))then + gya= 1 + else if(gya > ya_a(nye))then + gya= nye + else + call grdcrd1(gya,ya_a,nye,1) + endif + a3jyens(j,i)=int(gya) + a3jyens(j,i)=min(max(1,a3jyens(j,i)),nye) + a3dyens(j,i)=max(zero,min(one,gya-a3jyens(j,i))) + a3dy1ens(j,i)=one-a3dyens(j,i) + a3jypens(j,i)=min(nye,a3jyens(j,i)+1) + end do + end do + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!! find coefficients for wind conversion btw FV3 & earth +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + allocate (canguens(nxen,nyen+1),sanguens(nxen,nyen+1),cangvens(nxen+1,nyen),sangvens(nxen+1,nyen)) + +! 1. compute x,y,z at cell cornor from grid_lon, grid_lat + + do j=1,nyen+1 + do i=1,nxen+1 + x(i,j)=cos(grid_lat(i,j)*deg2rad)*cos(grid_lon(i,j)*deg2rad) + y(i,j)=cos(grid_lat(i,j)*deg2rad)*sin(grid_lon(i,j)*deg2rad) + z(i,j)=sin(grid_lat(i,j)*deg2rad) + enddo + enddo + +! 2 find angles to E-W and N-S for U edges + + sq180=180._r_kind**2 + do j=1,nyen+1 + do i=1,nxen +! center lat/lon of the edge + rlat=half*(grid_lat(i,j)+grid_lat(i+1,j)) +! rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)) + diff=(grid_lon(i,j)-grid_lon(i+1,j))**2 + if(diff < sq180)then + rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)) + else + rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)-360._r_kind) + endif +! vector to center of the edge + xr=cos(rlat*deg2rad)*cos(rlon*deg2rad) + yr=cos(rlat*deg2rad)*sin(rlon*deg2rad) + zr=sin(rlat*deg2rad) +! vector of the edge + xu= x(i+1,j)-x(i,j) + yu= y(i+1,j)-y(i,j) + zu= z(i+1,j)-z(i,j) +! find angle with cross product + uval=sqrt((xu**2+yu**2+zu**2)) + ewval=sqrt((xr**2+yr**2)) + nsval=sqrt((xr*zr)**2+(zr*yr)**2+(xr*xr+yr*yr)**2) + canguens(i,j)=(-yr*xu+xr*yu)/ewval/uval + sanguens(i,j)=(-xr*zr*xu-zr*yr*yu+(xr*xr+yr*yr)*zu) / nsval/uval + enddo + enddo + +! 3 find angles to E-W and N-S for V edges + do j=1,nyen + do i=1,nxen+1 + rlat=half*(grid_lat(i,j)+grid_lat(i,j+1)) +! rlon=half*(grid_lon(i,j)+grid_lon(i,j+1)) + diff=(grid_lon(i,j)-grid_lon(i+1,j))**2 + if(diff < sq180)then + rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)) + else + rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)-360._r_kind) + endif + xr=cos(rlat*deg2rad)*cos(rlon*deg2rad) + yr=cos(rlat*deg2rad)*sin(rlon*deg2rad) + zr=sin(rlat*deg2rad) + xv= x(i,j+1)-x(i,j) + yv= y(i,j+1)-y(i,j) + zv= z(i,j+1)-z(i,j) + vval=sqrt((xv**2+yv**2+zv**2)) + ewval=sqrt((xr**2+yr**2)) + nsval=sqrt((xr*zr)**2+(zr*yr)**2+(xr*xr+yr*yr)**2) + cangvens(i,j)=(-yr*xv+xr*yv)/ewval/vval + sangvens(i,j)=(-xr*zr*xv-zr*yr*yv+(xr*xr+yr*yr)*zv) / nsval/vval + enddo + enddo + deallocate( xc,yc,zc,gclat,gclon,gcrlat,gcrlon) + deallocate(rlat_in,rlon_in) +end subroutine definecoef_regular_grids + subroutine earthuv2fv3(u,v,nx,ny,u_out,v_out) !$$$ subprogram documentation block ! . . . . @@ -679,6 +1110,51 @@ subroutine fv3uv2earth(u,v,nx,ny,u_out,v_out) return end subroutine fv3uv2earth +subroutine fv3uv2earthens(u,v,nxen,nyen,u_out,v_out) +!$$$ subprogram documentation block +! . . . . +! subprogram: fv3uv2earthens +! prgmmr: wu 2017-06-15 +! +! abstract: project fv3 UV to earth UV and interpolate to the center of the +! cells +! +! program history log: +! +! +! input argument list: +! u,v - fv3 winds on the cell boundaries +! nx,ny - dimensions +! +! output argument list: +! u_out,v_out - output earth wind components at center of the cell +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use kinds, only: r_kind,i_kind + use constants, only: half + implicit none + + integer(i_kind), intent(in ) :: nxen,nyen ! fv3 tile x- and y-dimensions + real(r_kind),intent(in ) :: u(nxen,nyen+1),v(nxen+1,nyen) + real(r_kind),intent( out) :: u_out(nxen,nyen),v_out(nxen,nyen) + integer(i_kind) i,j + + do j=1,nyen + do i=1,nxen + u_out(i,j)=half *((u(i,j)*sangvens(i,j)-v(i,j)*sanguens(i,j))/(canguens(i,j)*sangvens(i,j)-sanguens(i,j)*cangvens(i,j)) & + +(u(i,j+1)*sangvens(i+1,j)-v(i+1,j)*sanguens(i,j+1))/(canguens(i,j+1)*sangvens(i+1,j)-sanguens(i,j+1)*cangvens(i+1,j))) + v_out(i,j)=half *((u(i,j)*cangvens(i,j)-v(i,j)*canguens(i,j))/(sanguens(i,j)*cangvens(i,j)-canguens(i,j)*sangvens(i,j)) & + +(u(i,j+1)*cangvens(i+1,j)-v(i+1,j)*canguens(i,j+1))/(sanguens(i,j+1)*cangvens(i+1,j)-canguens(i,j+1)*sangvens(i+1,j))) + end do + end do + return +end subroutine fv3uv2earthens + subroutine fv3_h_to_ll(b_in,a,nb,mb,na,ma,rev_flg) !$$$ subprogram documentation block ! . . . . @@ -753,6 +1229,86 @@ subroutine fv3_h_to_ll(b_in,a,nb,mb,na,ma,rev_flg) return end subroutine fv3_h_to_ll +subroutine fv3_h_to_ll_ens(b_in,a,nb,mb,na,ma,rev_flg) +!$$$ subprogram documentation block +! . . . . +! subprogram: fv3_h_to_ll +! prgmmr: wu 2017-05-30 +! +! abstract: interpolate from rotated fv3 grid to A grid. +! Interpolation choices 1)bilinear both ways +! 2)inverse-distance weighting average +! reverse E-W and N-S directions & reverse i,j for output array a(nlat,nlon) +! +! program history log: +! +! +! input argument list: +! mb,nb - fv3 dimensions +! ma,na - a dimensions +! b - input variable b +! xb,yb - b array x and y coordinates +! xa,ya - a array coordinates (xa in xb units, ya in yb units) +! +! output argument list: +! a - output interpolated array +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + use mpimod, only: mype + use constants, only: zero,one + implicit none + + integer(i_kind),intent(in ) :: mb,nb,ma,na + real(r_kind) ,intent(in ) :: b_in(nb,mb) + logical ,intent(in ) :: rev_flg + real(r_kind) ,intent( out) :: a(ma,na) + + integer(i_kind) i,j,ir,jr,mbp,nbp + real(r_kind) b(nb,mb) + + mbp=mb+1 + nbp=nb+1 + bilinear=.false. + if(rev_flg) then +!!!!!!!!! reverse E-W and N-S + do j=1,mb + jr=mbp-j + do i=1,nb + ir=nbp-i + b(ir,jr)=b_in(i,j) + end do + end do + else + b(:,:)=b_in(:,:) + endif +!!!!!!!!! interpolate to A grid & reverse ij for array a(lat,lon) + if(bilinear)then ! bilinear interpolation + do j=1,ma + do i=1,na + a(j,i)=fv3dx1ens(i,j)*(fv3dy1ens(i,j)*b(fv3ixens(i,j),fv3jyens(i,j)) & + +fv3dyens(i,j)*b(fv3ixens(i,j),fv3jypens(i,j))) & + +fv3dxens(i,j)*(fv3dy1ens(i,j)*b(fv3ixpens(i,j),fv3jyens(i,j)) & + +fv3dyens(i,j)*b(fv3ixpens(i,j),fv3jypens(i,j))) + end do + end do + else ! inverse-distance weighting average + do j=1,ma + do i=1,na + a(j,i)=fv3dxens(i,j)*b(fv3ixens(i,j),fv3jyens(i,j)) & + +fv3dyens(i,j)*b(fv3ixens(i,j),fv3jypens(i,j)) & + +fv3dx1ens(i,j)*b(fv3ixpens(i,j),fv3jyens(i,j)) & + +fv3dy1ens(i,j)*b(fv3ixpens(i,j),fv3jypens(i,j)) + end do + end do + endif + + return +end subroutine fv3_h_to_ll_ens + subroutine fv3_ll_to_h(a,b,nxa,nya,nxb,nyb,rev_flg) !$$$ subprogram documentation block ! . . . . From 2353eaa7ed753db84c8e3fbaad6927cd54c2f893 Mon Sep 17 00:00:00 2001 From: daviddowellNOAA <72174157+daviddowellNOAA@users.noreply.github.com> Date: Thu, 7 Dec 2023 10:02:04 -0600 Subject: [PATCH 047/109] Add assimilation of GLM flash-extent density (FED) observations to EnKF (#654) **Description** Fixes https://github.com/NOAA-EMC/GSI/issues/653 The proposed code changes (1) add a new "fed" observation type to the EnKF (2) add localization parameters, with namelist control, for FED observations (3) output basic statistics for FED observations. In the RRFS, the FED observations will be assimilated together with radar-reflectivity observations. The localization parameters for the reflectivity observations in RRFS are corrlength=18 and lnsigcutoff=0.5. However, these tight localization distances don't work well for the sparse FED observations. Therefore, localization parameters for FED observations, with namelist control, were added to allow the FED observations to influence the model state over longer distances. The default localization parameters for FED observations (corrlength=30 and lnsigcutoff=2.0) were determined through experimentation with WRF and FV3 convection-allowing (3-km horizontal grid spacing) ensembles. **Type of change** - [X] New feature (non-breaking change which adds functionality) **How Has This Been Tested?** Hourly cycling with simultaneous EnKF assimilation of FED and radar-reflectivity observations has been tested for a CONUS version of the prototype RRFSv1 for two short (1-2 days) retrospective periods, one in July 2022 and the other in August 2023. The impacts of the FED observations on the analyses are greatest over the oceans far from land, where the radar network does not provide observations. --- src/enkf/enkf.f90 | 2 +- src/enkf/enkf_obs_sensitivity.f90 | 3 +++ src/enkf/enkf_obsmod.f90 | 7 +++++++ src/enkf/innovstats.f90 | 16 ++++++++++++++++ src/enkf/params.f90 | 15 +++++++++++++++ src/enkf/readconvobs.f90 | 12 +++++++++--- 6 files changed, 51 insertions(+), 4 deletions(-) diff --git a/src/enkf/enkf.f90 b/src/enkf/enkf.f90 index d35613b585..479f60c019 100644 --- a/src/enkf/enkf.f90 +++ b/src/enkf/enkf.f90 @@ -51,7 +51,7 @@ module enkf ! NH, tropics and SH, and in the horizontal, vertical and time dimensions, ! using the namelist parameters corrlengthnh, corrlengthtr, corrlengthsh, ! lnsigcutoffnh, lnsigcutofftr, lnsigcutoffsh (lnsigcutoffsatnh, -! lnsigcutoffsattr, lnsigcutoffsatsh for satellite obs, similar for ps obs) +! lnsigcutoffsattr, lnsigcutoffsatsh for satellite obs, similar for ps and fed obs) ! obtimelnh, obtimeltr, obtimelsh. The length scales should be given in km for the ! horizontal, hours for time, and 'scale heights' (units of -log(p/pref)) in the ! vertical. The function used for localization (function taper) diff --git a/src/enkf/enkf_obs_sensitivity.f90 b/src/enkf/enkf_obs_sensitivity.f90 index 6c37936f31..72296d5934 100644 --- a/src/enkf/enkf_obs_sensitivity.f90 +++ b/src/enkf/enkf_obs_sensitivity.f90 @@ -36,6 +36,7 @@ module enkf_obs_sensitivity use params, only: efsoi_flag,latbound,nlevs,nanals,datestring, & lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh, & lnsigcutoffpsnh,lnsigcutoffpstr,lnsigcutoffpssh, & + lnsigcutofffednh,lnsigcutofffedtr,lnsigcutofffedsh, & lnsigcutoffnh,lnsigcutofftr,lnsigcutoffsh, & corrlengthnh,corrlengthtr,corrlengthsh, & obtimelnh,obtimeltr,obtimelsh,letkf_flag, & @@ -292,6 +293,8 @@ subroutine read_ob_sens lnsigl(nob) = latval(deglat,lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh) else if (obtype(nob)(1:3) == ' ps') then lnsigl(nob) = latval(deglat,lnsigcutoffpsnh,lnsigcutoffpstr,lnsigcutoffpssh) + else if (obtype(nob)(1:3) == 'fed') then + lnsigl(nob) = latval(deglat,lnsigcutofffednh,lnsigcutofffedtr,lnsigcutofffedsh) else lnsigl(nob)=latval(deglat,lnsigcutoffnh,lnsigcutofftr,lnsigcutoffsh) end if diff --git a/src/enkf/enkf_obsmod.f90 b/src/enkf/enkf_obsmod.f90 index ea8f6446fb..eb4f9c8e58 100644 --- a/src/enkf/enkf_obsmod.f90 +++ b/src/enkf/enkf_obsmod.f90 @@ -109,6 +109,8 @@ module enkf_obsmod lnsigcutoffnh, lnsigcutoffsh, lnsigcutofftr, corrlengthnh,& corrlengthtr, corrlengthsh, obtimelnh, obtimeltr, obtimelsh,& lnsigcutoffsatnh, lnsigcutoffsatsh, lnsigcutoffsattr,& + lnsigcutofffednh, lnsigcutofffedsh, lnsigcutofffedtr,& + corrlengthfednh, corrlengthfedtr, corrlengthfedsh, & varqc, huber, zhuberleft, zhuberright, modelspace_vloc, & lnsigcutoffpsnh, lnsigcutoffpssh, lnsigcutoffpstr, neigv, & lnsigcutoffrdrnh, lnsigcutoffrdrsh, lnsigcutoffrdrtr,& @@ -276,6 +278,8 @@ subroutine readobs() lnsigl(nob) = latval(deglat,lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh) else if (obtype(nob)(1:3) == ' ps') then lnsigl(nob) = latval(deglat,lnsigcutoffpsnh,lnsigcutoffpstr,lnsigcutoffpssh) + else if (obtype(nob)(1:3) == 'fed') then + lnsigl(nob) = latval(deglat,lnsigcutofffednh,lnsigcutofffedtr,lnsigcutofffedsh) else if ( (obtype(nob)(1:3) == 'dbz' .or. obtype(nob)(1:3) == ' rw') .and. l_use_enkf_directZDA ) then lnsigl(nob) = latval(deglat,lnsigcutoffrdrnh,lnsigcutoffrdrtr,lnsigcutoffrdrsh) else @@ -293,6 +297,9 @@ subroutine readobs() if ( (obtype(nob)(1:3) == 'dbz' .or. obtype(nob)(1:3) == ' rw') .and. l_use_enkf_directZDA ) then corrlengthsq(nob)=latval(deglat,corrlengthrdrnh,corrlengthrdrtr,corrlengthrdrsh)**2 end if + if (obtype(nob)(1:3) == 'fed') then + corrlengthsq(nob)=latval(deglat,corrlengthfednh,corrlengthfedtr,corrlengthfedsh)**2 + end if obtimel(nob)=latval(deglat,obtimelnh,obtimeltr,obtimelsh) end do diff --git a/src/enkf/innovstats.f90 b/src/enkf/innovstats.f90 index 68668218fc..853532c9b9 100644 --- a/src/enkf/innovstats.f90 +++ b/src/enkf/innovstats.f90 @@ -45,6 +45,7 @@ subroutine print_innovstats(obfit,obsprd) nobsspd_nh,nobsspd_sh,nobsspd_tr,& nobsgps_nh,nobsgps_sh,nobsgps_tr,& nobsdbz_nh,nobsdbz_sh,nobsdbz_tr,& + nobsfed_nh,nobsfed_sh,nobsfed_tr,& nobsrw_nh,nobsrw_sh,nobsrw_tr,& nobsq_nh,nobsq_sh,nobsq_tr,nobswnd_nh,nobswnd_sh,nobswnd_tr,& nobsoz_nh,nobsoz_sh,nobsoz_tr,nobsps_sh,nobsps_nh,nobsps_tr,nob @@ -67,6 +68,9 @@ subroutine print_innovstats(obfit,obsprd) sumdbz_nh,biasdbz_nh,sumdbz_spread_nh,sumdbz_oberr_nh,& sumdbz_sh,biasdbz_sh,sumdbz_spread_sh,sumdbz_oberr_sh,& sumdbz_tr,biasdbz_tr,sumdbz_spread_tr,sumdbz_oberr_tr,& + sumfed_nh,biasfed_nh,sumfed_spread_nh,sumfed_oberr_nh,& + sumfed_sh,biasfed_sh,sumfed_spread_sh,sumfed_oberr_sh,& + sumfed_tr,biasfed_tr,sumfed_spread_tr,sumfed_oberr_tr,& sumrw_nh,biasrw_nh,sumrw_spread_nh,sumrw_oberr_nh,& sumrw_sh,biasrw_sh,sumrw_spread_sh,sumrw_oberr_sh,& sumrw_tr,biasrw_tr,sumrw_spread_tr,sumrw_oberr_tr,& @@ -112,6 +116,9 @@ subroutine print_innovstats(obfit,obsprd) nobsdbz_nh = 0 nobsdbz_sh = 0 nobsdbz_tr = 0 + nobsfed_nh = 0 + nobsfed_sh = 0 + nobsfed_tr = 0 nobsrw_nh = 0 nobsrw_sh = 0 nobsrw_tr = 0 @@ -168,6 +175,12 @@ subroutine print_innovstats(obfit,obsprd) sumdbz_nh,biasdbz_nh,sumdbz_spread_nh,sumdbz_oberr_nh,nobsdbz_nh,& sumdbz_sh,biasdbz_sh,sumdbz_spread_sh,sumdbz_oberr_sh,nobsdbz_sh,& sumdbz_tr,biasdbz_tr,sumdbz_spread_tr,sumdbz_oberr_tr,nobsdbz_tr) + else if (obtype(nob)(1:3) == 'fed') then + call obstats(obfit(nob),oberrvar_orig(nob),& + obsprd(nob),obloclat(nob),& + sumfed_nh,biasfed_nh,sumfed_spread_nh,sumfed_oberr_nh,nobsfed_nh,& + sumfed_sh,biasfed_sh,sumfed_spread_sh,sumfed_oberr_sh,nobsfed_sh,& + sumfed_tr,biasfed_tr,sumfed_spread_tr,sumfed_oberr_tr,nobsfed_tr) else if (obtype(nob)(1:3) == ' rw') then call obstats(obfit(nob),oberrvar_orig(nob),& obsprd(nob),obloclat(nob),& @@ -216,6 +229,9 @@ subroutine print_innovstats(obfit,obsprd) call printstats(' all dbz',sumdbz_nh,biasdbz_nh,sumdbz_spread_nh,sumdbz_oberr_nh,nobsdbz_nh,& sumdbz_sh,biasdbz_sh,sumdbz_spread_sh,sumdbz_oberr_sh,nobsdbz_sh,& sumdbz_tr,biasdbz_tr,sumdbz_spread_tr,sumdbz_oberr_tr,nobsdbz_tr) + call printstats(' all fed',sumfed_nh,biasfed_nh,sumfed_spread_nh,sumfed_oberr_nh,nobsfed_nh,& + sumfed_sh,biasfed_sh,sumfed_spread_sh,sumfed_oberr_sh,nobsfed_sh,& + sumfed_tr,biasfed_tr,sumfed_spread_tr,sumfed_oberr_tr,nobsfed_tr) call printstats(' all rw',sumrw_nh,biasq_nh,sumrw_spread_nh,sumrw_oberr_nh,nobsrw_nh,& sumrw_sh,biasrw_sh,sumrw_spread_sh,sumrw_oberr_sh,nobsrw_sh,& sumrw_tr,biasrw_tr,sumrw_spread_tr,sumrw_oberr_tr,nobsrw_tr) diff --git a/src/enkf/params.f90 b/src/enkf/params.f90 index 62701c24a7..36b0c9c207 100644 --- a/src/enkf/params.f90 +++ b/src/enkf/params.f90 @@ -124,6 +124,8 @@ module params real(r_single),public :: lnsigcutoffnh,lnsigcutofftr,lnsigcutoffsh,& lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh,& lnsigcutoffpsnh,lnsigcutoffpstr,lnsigcutoffpssh +real(r_single),public :: corrlengthfednh,corrlengthfedtr,corrlengthfedsh, & + lnsigcutofffednh,lnsigcutofffedtr,lnsigcutofffedsh real(r_single),public :: corrlengthrdrnh,corrlengthrdrtr,corrlengthrdrsh, & lnsigcutoffrdrnh,lnsigcutoffrdrtr,lnsigcutoffrdrsh real(r_single),public :: analpertwtnh,analpertwtsh,analpertwttr,sprd_tol,saterrfact @@ -261,6 +263,8 @@ module params lnsigcutoffnh,lnsigcutofftr,lnsigcutoffsh,& lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh,& lnsigcutoffpsnh,lnsigcutoffpstr,lnsigcutoffpssh,& + corrlengthfednh,corrlengthfedsh,corrlengthfedtr,& + lnsigcutofffednh,lnsigcutofffedsh,lnsigcutofffedtr,& fgfileprefixes,fgsfcfileprefixes,anlfileprefixes, & anlsfcfileprefixes,incfileprefixes,incsfcfileprefixes,& statefileprefixes,statesfcfileprefixes, & @@ -317,6 +321,10 @@ subroutine read_namelist() corrlengthrdrnh = 10 corrlengthrdrtr = 10 corrlengthrdrsh = 10 +! corrlength (km) for GLM flash extent density +corrlengthfednh = 30_r_single +corrlengthfedtr = 30_r_single +corrlengthfedsh = 30_r_single ! read in localization length scales from an external file. readin_localization = .false. ! min and max inflation. @@ -341,6 +349,9 @@ subroutine read_namelist() lnsigcutoffrdrnh = 0.2_r_single ! value for radar lnsigcutoffrdrtr = 0.2_r_single ! value for radar lnsigcutoffrdrsh = 0.2_r_single ! value for radar +lnsigcutofffednh = 2._r_single ! value for GLM flash extent density +lnsigcutofffedtr = 2._r_single ! value for GLM flash extent density +lnsigcutofffedsh = 2._r_single ! value for GLM flash extent density ! ob time localization obtimelnh = 1.e10_r_single obtimeltr = 1.e10_r_single @@ -813,6 +824,10 @@ subroutine read_namelist() corrlengthrdrnh = corrlengthrdrnh * 1.e3_r_single/rearth corrlengthrdrtr = corrlengthrdrtr * 1.e3_r_single/rearth corrlengthrdrsh = corrlengthrdrsh * 1.e3_r_single/rearth +! rescale covariance localization length for GLM FED +corrlengthfednh = corrlengthfednh * 1.e3_r_single/rearth +corrlengthfedtr = corrlengthfedtr * 1.e3_r_single/rearth +corrlengthfedsh = corrlengthfedsh * 1.e3_r_single/rearth ! convert targe area boundary into radians tar_minlat = tar_minlat * deg2rad diff --git a/src/enkf/readconvobs.f90 b/src/enkf/readconvobs.f90 index d1f4ec3ff8..a5383069a1 100644 --- a/src/enkf/readconvobs.f90 +++ b/src/enkf/readconvobs.f90 @@ -42,9 +42,9 @@ module readconvobs !> observation types to read from netcdf files -integer(i_kind), parameter :: nobtype = 11 +integer(i_kind), parameter :: nobtype = 12 character(len=3), dimension(nobtype), parameter :: obtypes = (/' t', ' q', ' ps', ' uv', 'tcp', & - 'gps', 'spd', ' pw', ' dw', ' rw', 'dbz' /) + 'gps', 'spd', ' pw', ' dw', ' rw', 'dbz', 'fed' /) contains @@ -79,7 +79,7 @@ subroutine get_num_convobs_bin(obspath,datestring,num_obs_tot,num_obs_totdiag,id integer(i_kind) :: iunit, nchar, nreal, ii, mype, ios, idate, i, ipe, ioff0 integer(i_kind),dimension(2) :: nn,nobst, nobsps, nobsq, nobsuv, nobsgps, & nobstcp,nobstcx,nobstcy,nobstcz,nobssst, nobsspd, nobsdw, nobsrw, nobspw, & - nobsdbz + nobsdbz, nobsfed character(8),allocatable,dimension(:):: cdiagbuf real(r_single),allocatable,dimension(:,:)::rdiagbuf real(r_kind) :: errorlimit,errorlimit2,error,pres,obmax @@ -104,6 +104,7 @@ subroutine get_num_convobs_bin(obspath,datestring,num_obs_tot,num_obs_totdiag,id nobspw = 0 nobsgps = 0 nobsdbz = 0 + nobsfed = 0 nobstcp = 0; nobstcx = 0; nobstcy = 0; nobstcz = 0 init_pass = .true. peloop: do ipe=0,npefiles @@ -187,6 +188,9 @@ subroutine get_num_convobs_bin(obspath,datestring,num_obs_tot,num_obs_totdiag,id else if (obtype == 'dbz') then nobsdbz = nobsdbz + nn num_obs_tot = num_obs_tot + nn(2) + else if (obtype == 'fed') then + nobsfed = nobsfed + nn + num_obs_tot = num_obs_tot + nn(2) else if (obtype == 'gps') then nobsgps = nobsgps + nn num_obs_tot = num_obs_tot + nn(2) @@ -231,6 +235,7 @@ subroutine get_num_convobs_bin(obspath,datestring,num_obs_tot,num_obs_totdiag,id write(6,100) 'dw',nobsdw(1),nobsdw(2) write(6,100) 'rw',nobsrw(1),nobsrw(2) write(6,100) 'dbz',nobsdbz(1),nobsdbz(2) + write(6,100) 'fed',nobsfed(1),nobsfed(2) write(6,100) 'tcp',nobstcp(1),nobstcp(2) if (nobstcx(2) .gt. 0) then write(6,100) 'tcx',nobstcx(1),nobstcx(2) @@ -1075,6 +1080,7 @@ subroutine get_convobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, & if (obtype == ' t' .or. obtype == ' uv' .or. obtype == ' ps' .or. & obtype == 'tcp' .or. obtype == ' q' .or. obtype == 'spd' .or. & obtype == 'sst' .or. obtype == ' rw' .or. obtype == 'dbz' .or. & + obtype == 'fed' .or. & obtype == 'gps' .or. obtype == ' dw' .or. obtype == ' pw') then ! direct reflectivitiy DA has a different routine for dbz obs. From 275ee0dc7d9ae7c506729920b9fdab2d0ce2e578 Mon Sep 17 00:00:00 2001 From: Xiaoyan Zhang <45010998+xyzemc@users.noreply.github.com> Date: Wed, 20 Dec 2023 13:58:14 -0500 Subject: [PATCH 048/109] restore the line to initialize 'raterr2' as zero (#668) --- src/gsi/setuprad.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 index 1ff2474e20..856715d4c2 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -1801,6 +1801,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& diagadd=zero account_for_corr_obs = .false. varinv0=zero + raterr2 = zero !$omp parallel do schedule(dynamic,1) private(ii,m,k,asum) do ii=1,nchanl m=ich(ii) From 336d6fb1f25a039df3cace73b531d0eff19562ff Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Thu, 21 Dec 2023 19:04:16 +0000 Subject: [PATCH 049/109] Remove HIRS from regression tests --- regression/global_4denvar.sh | 6 ------ regression/hafs_3denvar_hybens.sh | 4 ---- regression/hafs_4denvar_glbens.sh | 4 ---- regression/netcdf_fv3_regional.sh | 1 - regression/regression_namelists.sh | 21 --------------------- regression/regression_namelists_db.sh | 21 --------------------- 6 files changed, 57 deletions(-) diff --git a/regression/global_4denvar.sh b/regression/global_4denvar.sh index 7212b819e9..08a62f5eb0 100755 --- a/regression/global_4denvar.sh +++ b/regression/global_4denvar.sh @@ -230,17 +230,11 @@ $nln $datobs/${prefix_obs}.ompst8.${suffix} ./ompstcbufr $nln $datobs/${prefix_obs}.ompslp.${suffix} ./ompslpbufr $nln $datobs/${prefix_obs}.goesfv.${suffix} ./gsnd1bufr -$nln $datobs/${prefix_obs}.hrs3db.${suffix} ./hirs3bufr_db $nln $datobs/${prefix_obs}.airsev.${suffix} ./airsbufr $nln $datobs/${prefix_obs}.sevcsr.${suffix} ./seviribufr $nln $datobs/${prefix_obs}.saphir.${suffix} ./saphirbufr $nln $datobs/${prefix_obs}.avcsam.${suffix} ./avhambufr $nln $datobs/${prefix_obs}.avcspm.${suffix} ./avhpmbufr -$nln $datobs/${prefix_obs}.1bhrs4.${suffix} ./hirs4bufr -$nln $datobs/${prefix_obs}.1bhrs2.${suffix} ./hirs2bufr -$nln $datobs/${prefix_obs}.1bhrs3.${suffix} ./hirs3bufr -$nln $datobs/${prefix_obs}.eshrs3.${suffix} ./hirs3bufrears -$nln $datobs/${prefix_obs}.hrs3db.${suffix} ./hirs3bufr_db $nln $datobs/${prefix_obs}.mtiasi.${suffix} ./iasibufr $nln $datobs/${prefix_obs}.esiasi.${suffix} ./iasibufrears $nln $datobs/${prefix_obs}.iasidb.${suffix} ./iasibufr_db diff --git a/regression/hafs_3denvar_hybens.sh b/regression/hafs_3denvar_hybens.sh index bd1c5b886d..fa128b8efa 100755 --- a/regression/hafs_3denvar_hybens.sh +++ b/regression/hafs_3denvar_hybens.sh @@ -278,13 +278,9 @@ fi ln -sf $SATWND satwndbufr ln -sf $SATWHR satwhrbufr ln -sf $GSNDBF1 gsnd1bufr -ln -sf $B1HRS3 hirs3bufr -ln -sf $B1HRS4 hirs4bufr ln -sf $B1AMUA amsuabufr ln -sf $B1MHS mhsbufr -ln -sf $ESHRS3 hirs3bufrears ln -sf $ESAMUA amsuabufrears -ln -sf $HRS3DB hirs3bufr_db ln -sf $SBUVBF sbuvbufr ln -sf $OMPSNPBF ompsnpbufr ln -sf $OMPSTCBF ompstcbufr diff --git a/regression/hafs_4denvar_glbens.sh b/regression/hafs_4denvar_glbens.sh index e19519e8fa..ddbd53dcf9 100755 --- a/regression/hafs_4denvar_glbens.sh +++ b/regression/hafs_4denvar_glbens.sh @@ -278,13 +278,9 @@ fi ln -sf $SATWND satwndbufr ln -sf $SATWHR satwhrbufr ln -sf $GSNDBF1 gsnd1bufr -ln -sf $B1HRS3 hirs3bufr -ln -sf $B1HRS4 hirs4bufr ln -sf $B1AMUA amsuabufr ln -sf $B1MHS mhsbufr -ln -sf $ESHRS3 hirs3bufrears ln -sf $ESAMUA amsuabufrears -ln -sf $HRS3DB hirs3bufr_db ln -sf $SBUVBF sbuvbufr ln -sf $OMPSNPBF ompsnpbufr ln -sf $OMPSTCBF ompstcbufr diff --git a/regression/netcdf_fv3_regional.sh b/regression/netcdf_fv3_regional.sh index 747794fae0..e6188f51c6 100755 --- a/regression/netcdf_fv3_regional.sh +++ b/regression/netcdf_fv3_regional.sh @@ -171,7 +171,6 @@ cp $fv3_netcdf_obs/ndas.t06z.radwnd.tm06.bufr_d ./radarbufr cp $fv3_netcdf_obs/ndas.t06z.prepbufr.tm06 ./prepbufr cp $fv3_netcdf_obs/ndas.t06z.1bamua.tm06.bufr_d ./amsuabufr cp $fv3_netcdf_obs/ndas.t06z.1bmhs.tm06.bufr_d ./mhsbufr -cp $fv3_netcdf_obs/ndas.t06z.1bhrs4.tm06.bufr_d ./hirs4bufr cp $fv3_netcdf_obs/ndas.t06z.goesfv.tm06.bufr_d ./gsnd1bufr cp $fv3_netcdf_obs/ndas.t06z.airsev.tm06.bufr_d ./airsbufr cp $fv3_netcdf_obs/ndas.t06z.satwnd.tm06.bufr_d ./satwndbufr diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh index 2448bd155e..552bc1ba59 100755 --- a/regression/regression_namelists.sh +++ b/regression/regression_namelists.sh @@ -98,8 +98,6 @@ OBS_INPUT:: sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1 gimgrbufr goes_img g11 imgr_g11 0.0 1 0 gimgrbufr goes_img g12 imgr_g12 0.0 1 0 airsbufr airs aqua airs_aqua 0.0 1 1 @@ -133,7 +131,6 @@ OBS_INPUT:: gomebufr gome metop-a gome_metop-a 0.0 2 0 omibufr omi aura omi_aura 0.0 2 0 sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1 amsuabufr amsua n19 amsua_n19 0.0 1 1 mhsbufr mhs n19 mhs_n19 0.0 1 1 tcvitl tcp null tcp 0.0 0 0 @@ -141,7 +138,6 @@ OBS_INPUT:: seviribufr seviri m09 seviri_m09 0.0 1 0 seviribufr seviri m10 seviri_m10 0.0 1 0 seviribufr seviri m11 seviri_m11 0.0 1 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 1 amsuabufr amsua metop-b amsua_metop-b 0.0 1 1 mhsbufr mhs metop-b mhs_metop-b 0.0 1 1 iasibufr iasi metop-b iasi_metop-b 0.0 1 1 @@ -391,12 +387,6 @@ OBS_INPUT:: sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 2 0 - hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 2 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 2 0 gimgrbufr goes_img g11 imgr_g11 0.0 1 0 gimgrbufr goes_img g12 imgr_g12 0.0 1 0 airsbufr airs aqua airs_aqua 0.0 2 0 @@ -627,8 +617,6 @@ OBS_INPUT:: sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1 gimgrbufr goes_img g11 imgr_g11 0.0 1 0 gimgrbufr goes_img g12 imgr_g12 0.0 1 0 airsbufr airs aqua airs_aqua 0.0 1 1 @@ -663,13 +651,11 @@ OBS_INPUT:: gomebufr gome metop-a gome_metop-a 0.0 2 0 omibufr omi aura omi_aura 0.0 2 0 sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1 amsuabufr amsua n19 amsua_n19 0.0 2 1 mhsbufr mhs n19 mhs_n19 0.0 3 1 seviribufr seviri m08 seviri_m08 0.0 1 0 seviribufr seviri m09 seviri_m09 0.0 1 0 seviribufr seviri m10 seviri_m10 0.0 1 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 amsuabufr amsua metop-b amsua_metop-b 0.0 2 0 mhsbufr mhs metop-b mhs_metop-b 0.0 3 0 iasibufr iasi metop-b iasi_metop-b 0.0 1 0 @@ -846,12 +832,6 @@ OBS_INPUT:: sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs2bufr hirs2 n14 hirs2_n14 0.0 1 0 - hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 gsndrbufr sndr g11 sndr_g11 0.0 1 0 gsndrbufr sndr g12 sndr_g12 0.0 1 0 gimgrbufr goes_img g11 imgr_g11 0.0 1 0 @@ -883,7 +863,6 @@ OBS_INPUT:: iasibufr iasi metop-b iasi_metop-b 0.0 1 0 omibufr omi aura omi_aura 0.0 1 0 sbuvbufr sbuv2 n19 sbuv8_n19 0.0 1 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 1 0 amsuabufr amsua n19 amsua_n19 0.0 1 0 mhsbufr mhs n19 mhs_n19 0.0 1 0 tcvitl tcp null tcp 0.0 0 0 diff --git a/regression/regression_namelists_db.sh b/regression/regression_namelists_db.sh index 1558779e3e..e03917e888 100755 --- a/regression/regression_namelists_db.sh +++ b/regression/regression_namelists_db.sh @@ -90,8 +90,6 @@ OBS_INPUT:: sbuvbufr_ sbuv2 n16 sbuv8_n16 0.0 0 0 sbuvbufr_ sbuv2 n17 sbuv8_n17 0.0 0 0 sbuvbufr_ sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs3bufr_ hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr_skip hirs4 metop-a hirs4_metop-a 0.0 1 1 gimgrbufr_ goes_img g11 imgr_g11 0.0 1 0 gimgrbufr_ goes_img g12 imgr_g12 0.0 1 0 airsbufr_ airs aqua airs_aqua 0.0 1 1 @@ -125,7 +123,6 @@ OBS_INPUT:: gomebufr gome metop-a gome_metop-a 0.0 2 0 omibufr omi aura omi_aura 0.0 2 0 sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1 amsuabufr amsua n19 amsua_n19 0.0 1 1 mhsbufr mhs n19 mhs_n19 0.0 1 1 tcvitl tcp null tcp 0.0 0 0 @@ -133,7 +130,6 @@ OBS_INPUT:: seviribufr seviri m09 seviri_m09 0.0 1 0 seviribufr seviri m10 seviri_m10 0.0 1 0 seviribufr seviri m11 seviri_m11 0.0 1 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 1 amsuabufr amsua metop-b amsua_metop-b 0.0 1 1 mhsbufr mhs metop-b mhs_metop-b 0.0 1 1 iasibufr iasi metop-b iasi_metop-b 0.0 1 1 @@ -372,12 +368,6 @@ OBS_INPUT:: sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 2 0 - hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 2 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 2 0 gimgrbufr goes_img g11 imgr_g11 0.0 1 0 gimgrbufr goes_img g12 imgr_g12 0.0 1 0 airsbufr airs aqua airs_aqua 0.0 2 0 @@ -611,8 +601,6 @@ OBS_INPUT:: sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1 gimgrbufr goes_img g11 imgr_g11 0.0 1 0 gimgrbufr goes_img g12 imgr_g12 0.0 1 0 airsbufr airs aqua airs_aqua 0.0 1 1 @@ -647,13 +635,11 @@ OBS_INPUT:: gomebufr gome metop-a gome_metop-a 0.0 2 0 omibufr omi aura omi_aura 0.0 2 0 sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1 amsuabufr amsua n19 amsua_n19 0.0 2 1 mhsbufr mhs n19 mhs_n19 0.0 3 1 seviribufr seviri m08 seviri_m08 0.0 1 0 seviribufr seviri m09 seviri_m09 0.0 1 0 seviribufr seviri m10 seviri_m10 0.0 1 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 amsuabufr amsua metop-b amsua_metop-b 0.0 2 0 mhsbufr mhs metop-b mhs_metop-b 0.0 3 0 iasibufr iasi metop-b iasi_metop-b 0.0 1 0 @@ -831,12 +817,6 @@ OBS_INPUT:: sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs2bufr hirs2 n14 hirs2_n14 0.0 1 0 - hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 gsndrbufr sndr g11 sndr_g11 0.0 1 0 gsndrbufr sndr g12 sndr_g12 0.0 1 0 gimgrbufr goes_img g11 imgr_g11 0.0 1 0 @@ -868,7 +848,6 @@ OBS_INPUT:: iasibufr iasi metop-b iasi_metop-b 0.0 1 0 omibufr omi aura omi_aura 0.0 1 0 sbuvbufr sbuv2 n19 sbuv8_n19 0.0 1 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 1 0 amsuabufr amsua n19 amsua_n19 0.0 1 0 mhsbufr mhs n19 mhs_n19 0.0 1 0 tcvitl tcp null tcp 0.0 0 0 From 7f37de38be7b7ad37db96eff570071e91006e1f6 Mon Sep 17 00:00:00 2001 From: Andrew Collard <40322596+ADCollard@users.noreply.github.com> Date: Thu, 18 Jan 2024 11:27:08 -0500 Subject: [PATCH 050/109] Remove HIRS from GSI regression tests (#672) --- regression/global_4denvar.sh | 6 ------ regression/hafs_3denvar_hybens.sh | 4 ---- regression/hafs_4denvar_glbens.sh | 4 ---- regression/netcdf_fv3_regional.sh | 1 - regression/regression_namelists.sh | 21 --------------------- regression/regression_namelists_db.sh | 21 --------------------- 6 files changed, 57 deletions(-) diff --git a/regression/global_4denvar.sh b/regression/global_4denvar.sh index 7212b819e9..08a62f5eb0 100755 --- a/regression/global_4denvar.sh +++ b/regression/global_4denvar.sh @@ -230,17 +230,11 @@ $nln $datobs/${prefix_obs}.ompst8.${suffix} ./ompstcbufr $nln $datobs/${prefix_obs}.ompslp.${suffix} ./ompslpbufr $nln $datobs/${prefix_obs}.goesfv.${suffix} ./gsnd1bufr -$nln $datobs/${prefix_obs}.hrs3db.${suffix} ./hirs3bufr_db $nln $datobs/${prefix_obs}.airsev.${suffix} ./airsbufr $nln $datobs/${prefix_obs}.sevcsr.${suffix} ./seviribufr $nln $datobs/${prefix_obs}.saphir.${suffix} ./saphirbufr $nln $datobs/${prefix_obs}.avcsam.${suffix} ./avhambufr $nln $datobs/${prefix_obs}.avcspm.${suffix} ./avhpmbufr -$nln $datobs/${prefix_obs}.1bhrs4.${suffix} ./hirs4bufr -$nln $datobs/${prefix_obs}.1bhrs2.${suffix} ./hirs2bufr -$nln $datobs/${prefix_obs}.1bhrs3.${suffix} ./hirs3bufr -$nln $datobs/${prefix_obs}.eshrs3.${suffix} ./hirs3bufrears -$nln $datobs/${prefix_obs}.hrs3db.${suffix} ./hirs3bufr_db $nln $datobs/${prefix_obs}.mtiasi.${suffix} ./iasibufr $nln $datobs/${prefix_obs}.esiasi.${suffix} ./iasibufrears $nln $datobs/${prefix_obs}.iasidb.${suffix} ./iasibufr_db diff --git a/regression/hafs_3denvar_hybens.sh b/regression/hafs_3denvar_hybens.sh index bd1c5b886d..fa128b8efa 100755 --- a/regression/hafs_3denvar_hybens.sh +++ b/regression/hafs_3denvar_hybens.sh @@ -278,13 +278,9 @@ fi ln -sf $SATWND satwndbufr ln -sf $SATWHR satwhrbufr ln -sf $GSNDBF1 gsnd1bufr -ln -sf $B1HRS3 hirs3bufr -ln -sf $B1HRS4 hirs4bufr ln -sf $B1AMUA amsuabufr ln -sf $B1MHS mhsbufr -ln -sf $ESHRS3 hirs3bufrears ln -sf $ESAMUA amsuabufrears -ln -sf $HRS3DB hirs3bufr_db ln -sf $SBUVBF sbuvbufr ln -sf $OMPSNPBF ompsnpbufr ln -sf $OMPSTCBF ompstcbufr diff --git a/regression/hafs_4denvar_glbens.sh b/regression/hafs_4denvar_glbens.sh index e19519e8fa..ddbd53dcf9 100755 --- a/regression/hafs_4denvar_glbens.sh +++ b/regression/hafs_4denvar_glbens.sh @@ -278,13 +278,9 @@ fi ln -sf $SATWND satwndbufr ln -sf $SATWHR satwhrbufr ln -sf $GSNDBF1 gsnd1bufr -ln -sf $B1HRS3 hirs3bufr -ln -sf $B1HRS4 hirs4bufr ln -sf $B1AMUA amsuabufr ln -sf $B1MHS mhsbufr -ln -sf $ESHRS3 hirs3bufrears ln -sf $ESAMUA amsuabufrears -ln -sf $HRS3DB hirs3bufr_db ln -sf $SBUVBF sbuvbufr ln -sf $OMPSNPBF ompsnpbufr ln -sf $OMPSTCBF ompstcbufr diff --git a/regression/netcdf_fv3_regional.sh b/regression/netcdf_fv3_regional.sh index 747794fae0..e6188f51c6 100755 --- a/regression/netcdf_fv3_regional.sh +++ b/regression/netcdf_fv3_regional.sh @@ -171,7 +171,6 @@ cp $fv3_netcdf_obs/ndas.t06z.radwnd.tm06.bufr_d ./radarbufr cp $fv3_netcdf_obs/ndas.t06z.prepbufr.tm06 ./prepbufr cp $fv3_netcdf_obs/ndas.t06z.1bamua.tm06.bufr_d ./amsuabufr cp $fv3_netcdf_obs/ndas.t06z.1bmhs.tm06.bufr_d ./mhsbufr -cp $fv3_netcdf_obs/ndas.t06z.1bhrs4.tm06.bufr_d ./hirs4bufr cp $fv3_netcdf_obs/ndas.t06z.goesfv.tm06.bufr_d ./gsnd1bufr cp $fv3_netcdf_obs/ndas.t06z.airsev.tm06.bufr_d ./airsbufr cp $fv3_netcdf_obs/ndas.t06z.satwnd.tm06.bufr_d ./satwndbufr diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh index 2448bd155e..552bc1ba59 100755 --- a/regression/regression_namelists.sh +++ b/regression/regression_namelists.sh @@ -98,8 +98,6 @@ OBS_INPUT:: sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1 gimgrbufr goes_img g11 imgr_g11 0.0 1 0 gimgrbufr goes_img g12 imgr_g12 0.0 1 0 airsbufr airs aqua airs_aqua 0.0 1 1 @@ -133,7 +131,6 @@ OBS_INPUT:: gomebufr gome metop-a gome_metop-a 0.0 2 0 omibufr omi aura omi_aura 0.0 2 0 sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1 amsuabufr amsua n19 amsua_n19 0.0 1 1 mhsbufr mhs n19 mhs_n19 0.0 1 1 tcvitl tcp null tcp 0.0 0 0 @@ -141,7 +138,6 @@ OBS_INPUT:: seviribufr seviri m09 seviri_m09 0.0 1 0 seviribufr seviri m10 seviri_m10 0.0 1 0 seviribufr seviri m11 seviri_m11 0.0 1 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 1 amsuabufr amsua metop-b amsua_metop-b 0.0 1 1 mhsbufr mhs metop-b mhs_metop-b 0.0 1 1 iasibufr iasi metop-b iasi_metop-b 0.0 1 1 @@ -391,12 +387,6 @@ OBS_INPUT:: sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 2 0 - hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 2 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 2 0 gimgrbufr goes_img g11 imgr_g11 0.0 1 0 gimgrbufr goes_img g12 imgr_g12 0.0 1 0 airsbufr airs aqua airs_aqua 0.0 2 0 @@ -627,8 +617,6 @@ OBS_INPUT:: sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1 gimgrbufr goes_img g11 imgr_g11 0.0 1 0 gimgrbufr goes_img g12 imgr_g12 0.0 1 0 airsbufr airs aqua airs_aqua 0.0 1 1 @@ -663,13 +651,11 @@ OBS_INPUT:: gomebufr gome metop-a gome_metop-a 0.0 2 0 omibufr omi aura omi_aura 0.0 2 0 sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1 amsuabufr amsua n19 amsua_n19 0.0 2 1 mhsbufr mhs n19 mhs_n19 0.0 3 1 seviribufr seviri m08 seviri_m08 0.0 1 0 seviribufr seviri m09 seviri_m09 0.0 1 0 seviribufr seviri m10 seviri_m10 0.0 1 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 amsuabufr amsua metop-b amsua_metop-b 0.0 2 0 mhsbufr mhs metop-b mhs_metop-b 0.0 3 0 iasibufr iasi metop-b iasi_metop-b 0.0 1 0 @@ -846,12 +832,6 @@ OBS_INPUT:: sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs2bufr hirs2 n14 hirs2_n14 0.0 1 0 - hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 gsndrbufr sndr g11 sndr_g11 0.0 1 0 gsndrbufr sndr g12 sndr_g12 0.0 1 0 gimgrbufr goes_img g11 imgr_g11 0.0 1 0 @@ -883,7 +863,6 @@ OBS_INPUT:: iasibufr iasi metop-b iasi_metop-b 0.0 1 0 omibufr omi aura omi_aura 0.0 1 0 sbuvbufr sbuv2 n19 sbuv8_n19 0.0 1 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 1 0 amsuabufr amsua n19 amsua_n19 0.0 1 0 mhsbufr mhs n19 mhs_n19 0.0 1 0 tcvitl tcp null tcp 0.0 0 0 diff --git a/regression/regression_namelists_db.sh b/regression/regression_namelists_db.sh index 1558779e3e..e03917e888 100755 --- a/regression/regression_namelists_db.sh +++ b/regression/regression_namelists_db.sh @@ -90,8 +90,6 @@ OBS_INPUT:: sbuvbufr_ sbuv2 n16 sbuv8_n16 0.0 0 0 sbuvbufr_ sbuv2 n17 sbuv8_n17 0.0 0 0 sbuvbufr_ sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs3bufr_ hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr_skip hirs4 metop-a hirs4_metop-a 0.0 1 1 gimgrbufr_ goes_img g11 imgr_g11 0.0 1 0 gimgrbufr_ goes_img g12 imgr_g12 0.0 1 0 airsbufr_ airs aqua airs_aqua 0.0 1 1 @@ -125,7 +123,6 @@ OBS_INPUT:: gomebufr gome metop-a gome_metop-a 0.0 2 0 omibufr omi aura omi_aura 0.0 2 0 sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1 amsuabufr amsua n19 amsua_n19 0.0 1 1 mhsbufr mhs n19 mhs_n19 0.0 1 1 tcvitl tcp null tcp 0.0 0 0 @@ -133,7 +130,6 @@ OBS_INPUT:: seviribufr seviri m09 seviri_m09 0.0 1 0 seviribufr seviri m10 seviri_m10 0.0 1 0 seviribufr seviri m11 seviri_m11 0.0 1 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 1 amsuabufr amsua metop-b amsua_metop-b 0.0 1 1 mhsbufr mhs metop-b mhs_metop-b 0.0 1 1 iasibufr iasi metop-b iasi_metop-b 0.0 1 1 @@ -372,12 +368,6 @@ OBS_INPUT:: sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 2 0 - hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 2 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 2 0 gimgrbufr goes_img g11 imgr_g11 0.0 1 0 gimgrbufr goes_img g12 imgr_g12 0.0 1 0 airsbufr airs aqua airs_aqua 0.0 2 0 @@ -611,8 +601,6 @@ OBS_INPUT:: sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1 gimgrbufr goes_img g11 imgr_g11 0.0 1 0 gimgrbufr goes_img g12 imgr_g12 0.0 1 0 airsbufr airs aqua airs_aqua 0.0 1 1 @@ -647,13 +635,11 @@ OBS_INPUT:: gomebufr gome metop-a gome_metop-a 0.0 2 0 omibufr omi aura omi_aura 0.0 2 0 sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1 amsuabufr amsua n19 amsua_n19 0.0 2 1 mhsbufr mhs n19 mhs_n19 0.0 3 1 seviribufr seviri m08 seviri_m08 0.0 1 0 seviribufr seviri m09 seviri_m09 0.0 1 0 seviribufr seviri m10 seviri_m10 0.0 1 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 amsuabufr amsua metop-b amsua_metop-b 0.0 2 0 mhsbufr mhs metop-b mhs_metop-b 0.0 3 0 iasibufr iasi metop-b iasi_metop-b 0.0 1 0 @@ -831,12 +817,6 @@ OBS_INPUT:: sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - hirs2bufr hirs2 n14 hirs2_n14 0.0 1 0 - hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 - hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 - hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0 - hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 0 - hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 gsndrbufr sndr g11 sndr_g11 0.0 1 0 gsndrbufr sndr g12 sndr_g12 0.0 1 0 gimgrbufr goes_img g11 imgr_g11 0.0 1 0 @@ -868,7 +848,6 @@ OBS_INPUT:: iasibufr iasi metop-b iasi_metop-b 0.0 1 0 omibufr omi aura omi_aura 0.0 1 0 sbuvbufr sbuv2 n19 sbuv8_n19 0.0 1 0 - hirs4bufr hirs4 n19 hirs4_n19 0.0 1 0 amsuabufr amsua n19 amsua_n19 0.0 1 0 mhsbufr mhs n19 mhs_n19 0.0 1 0 tcvitl tcp null tcp 0.0 0 0 From 12f8d3ef5c9292e48655365b269833574a81b61d Mon Sep 17 00:00:00 2001 From: AmandaBack-NOAA <55004295+AmandaBack-NOAA@users.noreply.github.com> Date: Wed, 24 Jan 2024 12:09:07 -0700 Subject: [PATCH 051/109] add clipping treatment for negative values of non-negative tracers (#682) **Description** Clips negative values from fields in the tracer file before writing. Fixes #680. **Type of change** - [ ] Bug fix (non-breaking change which fixes an issue) **How Has This Been Tested?** Tested on Hera in a RRFS CONUS workflow with both hybrid_radar_ref and anal_gsi_input tasks. See run directory at /scratch2/BMC/zrtrr/aback/hydrometeors_test/ For one hour of the control run without this change, and one hour using the change contained in this PR, the INPUT directory was saved for reference/rerunning before each of the tasks: anal_gsi_input_spinup, hybrid_radar_ref_spinup, cldanl_nonvar_spinup, and run_fcst spinup. Those directories are at, for example /scratch2/BMC/zrtrr/aback/hydrometeors_test/INPUT_after_anal_gsi_input_spinup_before_hybrid_radar_ref_spinup ("control") and /scratch2/BMC/zrtrr/aback/hydrometeors_test/clipped_INPUT_after_anal_gsi_input_spinup_before_hybrid_radar_ref_spinup (using the code in the PR). Logs are at /scratch2/BMC/zrtrr/aback/hydrometeors_test/v0.7.9/logs/rrfs.20230610/08/, including new logs produced between all the above-listed tasks, showing all the min and max values in fv_tracer. **Checklist** The code is Ting Lei's. It looks stylish and understandable to me (Amanda) but maybe Ting should weigh in on this section. - [ ] My code follows the style guidelines of this project - [ ] I have performed a self-review of my own code - [ ] I have commented my code, particularly in hard-to-understand areas - [ ] New and existing tests pass with my changes - [ ] Any dependent changes have been merged and published **DUE DATE for merger of this PR into `develop` is 2/22/2024 (six weeks after PR creation).** --------- Co-authored-by: Ting.Lei-NOAA --- src/gsi/gsi_rfv3io_mod.f90 | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 8158f35e11..c8a2775863 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -118,6 +118,11 @@ module gsi_rfv3io_mod vgsiname = [character(len=max_varname_length) :: & 'u','v','w','tsen','delp','q','oz','ql','qi','qr','qs','qg','qnr','dbz','fed','ps','delzinc', & aeronames_cmaq_fv3,'pm25at','pm25ac','pm25co','pm2_5','amassi','amassj','amassk',aeronames_smoke_fv3] + + integer(i_kind) ,parameter:: nnonnegtracer=7 + character(len=max_varname_length), dimension(nnonnegtracer), parameter :: & + vnames_nonnegativetracers = [character(len=max_varname_length) :: & + "sphum","o3mr","liq_wat","ice_wat","rainwat","snowwat","graupel"] character(len=max_varname_length),dimension(:),allocatable:: name_metvars2d character(len=max_varname_length),dimension(:),allocatable:: name_metvars3d character(len=max_varname_length),dimension(:),allocatable:: name_chemvars3d @@ -4676,6 +4681,9 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file call fv3_ll_to_h(work_a(:,:),work_b(:,:),nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag) endif endif + if (ifindstrloc(vnames_nonnegativetracers,trim(varname))> 0) then + where (work_b <0.0_r_kind) work_b=0.0_r_kind + endif if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 countloc=(/nxcase,ny_layout_len(nio),1/) @@ -4835,6 +4843,9 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f else call fv3_ll_to_h(work_a(:,:),work_b(:,:),nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag) endif + if (ifindstrloc(vnames_nonnegativetracers,trim(varname))> 0) then + where (work_b <0.0_r_kind) work_b=0.0_r_kind + endif call check( nf90_put_var(gfile_loc,VarId,work_b,start=startloc,count=countloc) ) enddo !ilevtot call check(nf90_close(gfile_loc)) 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 052/109] 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 From a8986684a815a9f2602a11e962f8443b78169012 Mon Sep 17 00:00:00 2001 From: "Henry R. Winterbottom" <49202169+HenryWinterbottom-NOAA@users.noreply.github.com> Date: Wed, 31 Jan 2024 09:00:33 -0700 Subject: [PATCH 053/109] Updated detect_machine.sh to be consistent with UFSWM. (#691) Co-authored-by: henrywinterbottom-wxdev --- .../{gsi_discover => gsi_discover.intel} | 0 .../{gsi_gaea.lua => gsi_gaea.intel.lua} | 0 ...si_hercules.lua => gsi_hercules.intel.lua} | 0 .../{gsi_jet.lua => gsi_jet.intel.lua} | 0 .../{gsi_orion.lua => gsi_orion.intel.lua} | 0 modulefiles/{gsi_s4.lua => gsi_s4.intel.lua} | 0 .../{gsi_wcoss2.lua => gsi_wcoss2.intel.lua} | 0 ush/build.sh | 2 +- ush/detect_machine.sh | 76 +++++++++++++++---- ush/sub_discover | 2 +- ush/sub_gaea | 2 +- ush/sub_hercules | 2 +- ush/sub_jet | 2 +- ush/sub_orion | 2 +- ush/sub_wcoss2 | 2 +- 15 files changed, 67 insertions(+), 23 deletions(-) rename modulefiles/{gsi_discover => gsi_discover.intel} (100%) rename modulefiles/{gsi_gaea.lua => gsi_gaea.intel.lua} (100%) rename modulefiles/{gsi_hercules.lua => gsi_hercules.intel.lua} (100%) rename modulefiles/{gsi_jet.lua => gsi_jet.intel.lua} (100%) rename modulefiles/{gsi_orion.lua => gsi_orion.intel.lua} (100%) rename modulefiles/{gsi_s4.lua => gsi_s4.intel.lua} (100%) rename modulefiles/{gsi_wcoss2.lua => gsi_wcoss2.intel.lua} (100%) diff --git a/modulefiles/gsi_discover b/modulefiles/gsi_discover.intel similarity index 100% rename from modulefiles/gsi_discover rename to modulefiles/gsi_discover.intel diff --git a/modulefiles/gsi_gaea.lua b/modulefiles/gsi_gaea.intel.lua similarity index 100% rename from modulefiles/gsi_gaea.lua rename to modulefiles/gsi_gaea.intel.lua diff --git a/modulefiles/gsi_hercules.lua b/modulefiles/gsi_hercules.intel.lua similarity index 100% rename from modulefiles/gsi_hercules.lua rename to modulefiles/gsi_hercules.intel.lua diff --git a/modulefiles/gsi_jet.lua b/modulefiles/gsi_jet.intel.lua similarity index 100% rename from modulefiles/gsi_jet.lua rename to modulefiles/gsi_jet.intel.lua diff --git a/modulefiles/gsi_orion.lua b/modulefiles/gsi_orion.intel.lua similarity index 100% rename from modulefiles/gsi_orion.lua rename to modulefiles/gsi_orion.intel.lua diff --git a/modulefiles/gsi_s4.lua b/modulefiles/gsi_s4.intel.lua similarity index 100% rename from modulefiles/gsi_s4.lua rename to modulefiles/gsi_s4.intel.lua diff --git a/modulefiles/gsi_wcoss2.lua b/modulefiles/gsi_wcoss2.intel.lua similarity index 100% rename from modulefiles/gsi_wcoss2.lua rename to modulefiles/gsi_wcoss2.intel.lua diff --git a/ush/build.sh b/ush/build.sh index 9a280c4e55..a133889eac 100755 --- a/ush/build.sh +++ b/ush/build.sh @@ -24,7 +24,7 @@ source $DIR_ROOT/ush/detect_machine.sh set +x source $DIR_ROOT/ush/module-setup.sh module use $DIR_ROOT/modulefiles -module load gsi_$MACHINE_ID +module load "gsi_${MACHINE_ID}.${COMPILER}" module list set -x diff --git a/ush/detect_machine.sh b/ush/detect_machine.sh index ac6c7f58d1..683ee0db7f 100755 --- a/ush/detect_machine.sh +++ b/ush/detect_machine.sh @@ -1,20 +1,30 @@ #!/bin/bash +# The authoritative copy of this script lives in the ufs-weather-model at: +# https://github.com/ufs-community/ufs-weather-model/blob/develop/tests/detect_machine.sh +# If any local modifications are made or new platform support added, +# please consider opening an issue and a PR to the ufs-weather-model +# so that this copy remains in sync with its authoritative source +# +# Thank you for your contribution + +# If the MACHINE_ID variable is set, skip this script. +[[ -n ${MACHINE_ID:-} ]] && return + +# First detect w/ hostname case $(hostname -f) in - adecflow0[12].acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### acorn - alogin0[1-3].acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### acorn + adecflow0[12].acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=acorn ;; ### acorn + alogin0[12].acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=acorn ;; ### acorn clogin0[1-9].cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus01-9 clogin10.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus10 dlogin0[1-9].dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dogwood01-9 dlogin10.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dogwood10 - gaea9) MACHINE_ID=gaea ;; ### gaea9 - gaea1[0-6]) MACHINE_ID=gaea ;; ### gaea10-16 - gaea9.ncrc.gov) MACHINE_ID=gaea ;; ### gaea9 - gaea1[0-6].ncrc.gov) MACHINE_ID=gaea ;; ### gaea10-16 + gaea5[1-8]) MACHINE_ID=gaea ;; ### gaea51-58 + gaea5[1-8].ncrc.gov) MACHINE_ID=gaea ;; ### gaea51-58 - hfe0[1-9]) MACHINE_ID=hera ;; ### hera01-9 + hfe0[1-9]) MACHINE_ID=hera ;; ### hera01-09 hfe1[0-2]) MACHINE_ID=hera ;; ### hera10-12 hecflow01) MACHINE_ID=hera ;; ### heraecflow01 @@ -25,24 +35,58 @@ case $(hostname -f) in Orion-login-[1-4].HPC.MsState.Edu) MACHINE_ID=orion ;; ### orion1-4 - Hercules-login-[1-4].HPC.MsState.Edu) MACHINE_ID=hercules ;; ### hercules1-4 - - cheyenne[1-6].cheyenne.ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6 - cheyenne[1-6].ib0.cheyenne.ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6 - chadmin[1-6].ib0.cheyenne.ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6 - chadmin[1-6].ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6 + [Hh]ercules-login-[1-4].[Hh][Pp][Cc].[Mm]s[Ss]tate.[Ee]du) MACHINE_ID=hercules ;; ### hercules1-4 login[1-4].stampede2.tacc.utexas.edu) MACHINE_ID=stampede ;; ### stampede1-4 login0[1-2].expanse.sdsc.edu) MACHINE_ID=expanse ;; ### expanse1-2 discover3[1-5].prv.cube) MACHINE_ID=discover ;; ### discover31-35 + *) MACHINE_ID=UNKNOWN ;; # Unknown platform esac +if [[ ${MACHINE_ID} == "UNKNOWN" ]]; then + case ${PW_CSP:-} in + "aws" | "google" | "azure") MACHINE_ID=noaacloud ;; + *) PW_CSP="UNKNOWN" + esac +fi + # Overwrite auto-detect with MACHINE if set MACHINE_ID=${MACHINE:-${MACHINE_ID}} -# Append compiler (only on machines that have multiple compilers) -if [ $MACHINE_ID = hera ] || [ $MACHINE_ID = cheyenne ]; then - MACHINE_ID=${MACHINE_ID}.${COMPILER} +# If MACHINE_ID is no longer UNKNNOWN, return it +if [[ "${MACHINE_ID}" != "UNKNOWN" ]]; then + return +fi + +# Try searching based on paths since hostname may not match on compute nodes +if [[ -d /lfs/h3 ]]; then + # We are on NOAA Cactus or Dogwood + MACHINE_ID=wcoss2 +elif [[ -d /lfs/h1 && ! -d /lfs/h3 ]]; then + # We are on NOAA TDS Acorn + MACHINE_ID=acorn +elif [[ -d /mnt/lfs1 ]]; then + # We are on NOAA Jet + MACHINE_ID=jet +elif [[ -d /scratch1 ]]; then + # We are on NOAA Hera + MACHINE_ID=hera +elif [[ -d /work ]]; then + # We are on MSU Orion or Hercules + if [[ -d /apps/other ]]; then + # We are on Hercules + MACHINE_ID=hercules + else + MACHINE_ID=orion + fi +elif [[ -d /gpfs && -d /ncrc ]]; then + # We are on GAEA. + MACHINE_ID=gaea +elif [[ -d /data/prod ]]; then + # We are on SSEC's S4 + MACHINE_ID=s4 +else + echo WARNING: UNKNOWN PLATFORM 1>&2 fi diff --git a/ush/sub_discover b/ush/sub_discover index 583ffbef86..5d6364be97 100755 --- a/ush/sub_discover +++ b/ush/sub_discover @@ -130,7 +130,7 @@ echo "" >>$cfile echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile echo "" >>$cfile echo "module use -a $modulefiles" >> $cfile -echo "module load gsi_discover" >> $cfile +echo "module load gsi_discover.intel" >> $cfile echo "" >>$cfile echo "jobname=$jobname" >>$cfile echo "" >>$cfile diff --git a/ush/sub_gaea b/ush/sub_gaea index 6fed1b3c10..afad6aa7ab 100755 --- a/ush/sub_gaea +++ b/ush/sub_gaea @@ -129,7 +129,7 @@ echo "" >>$cfile echo "source /lustre/f2/dev/role.epic/contrib/Lmod_init.sh" >> $cfile echo "module use $modulefiles" >> $cfile -echo "module load gsi_gaea" >> $cfile +echo "module load gsi_gaea.intel" >> $cfile echo "module list" >> $cfile echo "" >>$cfile diff --git a/ush/sub_hercules b/ush/sub_hercules index 573378fdb6..e854d5727b 100755 --- a/ush/sub_hercules +++ b/ush/sub_hercules @@ -129,7 +129,7 @@ echo "" >>$cfile echo ". /apps/other/lmod/lmod/init/sh" >> $cfile echo "module purge" >> $cfile echo "module use $modulefiles" >> $cfile -echo "module load gsi_hercules" >> $cfile +echo "module load gsi_hercules.intel" >> $cfile echo "module list" >> $cfile echo "" >> $cfile cat $exec >> $cfile diff --git a/ush/sub_jet b/ush/sub_jet index d30c566ce3..9bd60486f6 100755 --- a/ush/sub_jet +++ b/ush/sub_jet @@ -127,7 +127,7 @@ echo "" >>$cfile echo ". /apps/lmod/lmod/init/sh" >> $cfile echo "module purge" >> $cfile echo "module use $modulefiles" >> $cfile -echo "module load gsi_jet" >> $cfile +echo "module load gsi_jet.intel" >> $cfile echo "module list" >> $cfile echo "" >>$cfile diff --git a/ush/sub_orion b/ush/sub_orion index e5844474db..5a13f54845 100755 --- a/ush/sub_orion +++ b/ush/sub_orion @@ -129,7 +129,7 @@ echo "" >>$cfile echo ". /apps/lmod/lmod/init/sh" >> $cfile echo "module purge" >> $cfile echo "module use $modulefiles" >> $cfile -echo "module load gsi_orion" >> $cfile +echo "module load gsi_orion.intel" >> $cfile echo "module list" >> $cfile echo "" >> $cfile cat $exec >> $cfile diff --git a/ush/sub_wcoss2 b/ush/sub_wcoss2 index f2df099f23..cd21e932f8 100755 --- a/ush/sub_wcoss2 +++ b/ush/sub_wcoss2 @@ -125,7 +125,7 @@ echo "" >> $cfile echo "module reset" >> $cfile echo "module use $modulefiles" >> $cfile -echo "module load gsi_wcoss2" >> $cfile +echo "module load gsi_wcoss2.intel" >> $cfile echo "module load envvar/1.0" >> $cfile echo "module load cray-pals/1.2.2" >> $cfile echo "module -t list 2>&1 | while read line;do module show $line 2>&1 | sed -n -e '2p';done | sort" >> $cfile From 94c6a7c2e917f5edb08d899845711427258f9733 Mon Sep 17 00:00:00 2001 From: Clara Draper <33430543+ClaraDraper-NOAA@users.noreply.github.com> Date: Wed, 7 Feb 2024 10:26:19 -0700 Subject: [PATCH 054/109] Updates for soil moisture and soil temperature analysis (#675) Co-authored-by: jswhit2 Co-authored-by: guoqing.ge --- src/enkf/gridinfo_gfs.f90 | 1 + src/enkf/gridio_gfs.f90 | 53 +++++++++++++++++++++------------------ src/enkf/inflation.f90 | 34 ++++++++++++++++++++++--- src/enkf/readconvobs.f90 | 1 - src/enkf/statevec.f90 | 4 +-- src/gsi/read_prepbufr.f90 | 19 +++++++------- src/gsi/setupq.f90 | 2 +- src/gsi/setupt.f90 | 5 +--- 8 files changed, 75 insertions(+), 44 deletions(-) diff --git a/src/enkf/gridinfo_gfs.f90 b/src/enkf/gridinfo_gfs.f90 index 317ca2221c..de71153c69 100644 --- a/src/enkf/gridinfo_gfs.f90 +++ b/src/enkf/gridinfo_gfs.f90 @@ -67,6 +67,7 @@ module gridinfo character(len=max_varname_length),public, dimension(13) :: vars3d_supported = (/'u ', 'v ', 'tv ', 'q ', 'oz ', 'cw ', 'tsen', 'prse', & 'ql ', 'qi ', 'qr ', 'qs ', 'qg '/) character(len=max_varname_length),public, dimension(13) :: vars2d_supported = (/'ps ', 'pst', 'sst', 't2m', 'q2m', 'st1', 'st2', 'st3', 'st4', 'sl1', 'sl2', 'sl3', 'sl4' /) +character(len=max_varname_length),public, dimension(8) :: vars2d_landonly = (/'st1', 'st2', 'st3', 'st4', 'sl1', 'sl2', 'sl3', 'sl4' /) ! supported variable names in anavinfo contains diff --git a/src/enkf/gridio_gfs.f90 b/src/enkf/gridio_gfs.f90 index e4631f4e2d..8afb012fcf 100644 --- a/src/enkf/gridio_gfs.f90 +++ b/src/enkf/gridio_gfs.f90 @@ -926,6 +926,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, endif ! use_full_hydro enddo else if (use_gfs_ncio) then + clip=tiny_r_kind call read_vardata(dset, 'ugrd', ug3d,errcode=iret) if (iret /= 0) then print *,'error reading ugrd' @@ -1203,36 +1204,36 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, call copytogrdin(ug,grdin(:,levels(n3d) + soilt4_ind,nb,ne)) endif if (slc1_ind > 0) then - call read_vardata(dset_sfc, 'slc1', values_2d, errcode=iret) + call read_vardata(dset_sfc, 'soill1', values_2d, errcode=iret) if (iret /= 0) then - print *,'error reading slc1' + print *,'error reading soill1' call stop2(22) endif ug = reshape(values_2d,(/nlons*nlats/)) call copytogrdin(ug,grdin(:,levels(n3d) + slc1_ind,nb,ne)) endif if (slc2_ind > 0) then - call read_vardata(dset_sfc, 'slc2', values_2d, errcode=iret) + call read_vardata(dset_sfc, 'soill2', values_2d, errcode=iret) if (iret /= 0) then - print *,'error reading slc2' + print *,'error reading soill2' call stop2(22) endif ug = reshape(values_2d,(/nlons*nlats/)) call copytogrdin(ug,grdin(:,levels(n3d) + slc2_ind,nb,ne)) endif if (slc3_ind > 0) then - call read_vardata(dset_sfc, 'slc3', values_2d, errcode=iret) + call read_vardata(dset_sfc, 'soill3', values_2d, errcode=iret) if (iret /= 0) then - print *,'error reading slc3' + print *,'error reading soill3' call stop2(22) endif ug = reshape(values_2d,(/nlons*nlats/)) call copytogrdin(ug,grdin(:,levels(n3d) + slc3_ind,nb,ne)) endif if (slc4_ind > 0) then - call read_vardata(dset_sfc, 'slc4', values_2d, errcode=iret) + call read_vardata(dset_sfc, 'soill4', values_2d, errcode=iret) if (iret /= 0) then - print *,'error reading slc2' + print *,'error reading soill4' call stop2(22) endif ug = reshape(values_2d,(/nlons*nlats/)) @@ -2122,6 +2123,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n character(nemsio_charkind) :: field character(len=nf90_max_name) :: time_units logical :: hasfield + character(len=max_varname_length), dimension(n3d) :: no_vars3d real(r_kind) kap,kapr,kap1,clip real(r_single) compress_err @@ -2143,10 +2145,12 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, write_sfc_file, write_atm_file) - if (write_sfc_file .and. nproc==0 ) then + if (write_sfc_file ) then ! adding the sfc increments requires adjusting several other variables. This is done is a separate ! program. - write(6,*)'gridio/writegriddata: not coded to write sfc analysis, use separate add_incr program instead' + if (nproc == 0) write(6,*)'gridio/writegriddata: not coded to write sfc analysis, will write increment for sfc fields' + no_vars3d='' + call writeincrement(nanal1,nanal2,no_vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag) endif nocompress = .true. @@ -3584,7 +3588,7 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, integer :: ql_ind, qi_ind, qr_ind, qs_ind, qg_ind ! netcdf things - integer(i_kind) :: dimids3(3), ncstart(3), nccount(3) + integer(i_kind) :: dimids3(3), ncstart(3), nccount(3), dimids2(2) integer(i_kind) :: ncid_out, lon_dimid, lat_dimid, lev_dimid, ilev_dimid integer(i_kind) :: lonvarid, latvarid, levvarid, pfullvarid, ilevvarid, & hyaivarid, hybivarid, uvarid, vvarid, delpvarid, delzvarid, & @@ -3615,7 +3619,6 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, write_sfc_file, write_atm_file) - if ( write_atm_file) then use_full_hydro = .false. clip = tiny_r_kind read(datestring,*) iadateout @@ -3623,6 +3626,7 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, ncstart = (/1, 1, 1/) nccount = (/nlons, nlats, nlevs/) + if ( write_atm_file) then ne = 0 ensmemloop: do nanal=nanal1,nanal2 ne = ne + 1 @@ -3978,20 +3982,21 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, ! create dimensions based on analysis resolution, not guess call nccheck_incr(nf90_def_dim(ncid_out, "longitude", nlons, lon_dimid)) call nccheck_incr(nf90_def_dim(ncid_out, "latitude", nlats, lat_dimid)) + dimids2 = (/ lon_dimid, lat_dimid /) ! create variables call nccheck_incr(nf90_def_var(ncid_out, "longitude", nf90_real, (/lon_dimid/), lonvarid)) call nccheck_incr(nf90_def_var(ncid_out, "latitude", nf90_real, (/lat_dimid/), latvarid)) - call nccheck_incr(nf90_def_var(ncid_out, "tmp2m_inc", nf90_real, dimids3(1:2), tmp2mvarid)) - call nccheck_incr(nf90_def_var(ncid_out, "spfh2m_inc", nf90_real, dimids3(1:2), spfh2mvarid)) - call nccheck_incr(nf90_def_var(ncid_out, "soilt1_inc", nf90_real, dimids3(1:2), soilt1varid)) - call nccheck_incr(nf90_def_var(ncid_out, "soilt2_inc", nf90_real, dimids3(1:2), soilt2varid)) - call nccheck_incr(nf90_def_var(ncid_out, "soilt3_inc", nf90_real, dimids3(1:2), soilt3varid)) - call nccheck_incr(nf90_def_var(ncid_out, "soilt4_inc", nf90_real, dimids3(1:2), soilt4varid)) - call nccheck_incr(nf90_def_var(ncid_out, "slc1_inc", nf90_real, dimids3(1:2), slc1varid)) - call nccheck_incr(nf90_def_var(ncid_out, "slc2_inc", nf90_real, dimids3(1:2), slc2varid)) - call nccheck_incr(nf90_def_var(ncid_out, "slc3_inc", nf90_real, dimids3(1:2), slc3varid)) - call nccheck_incr(nf90_def_var(ncid_out, "slc4_inc", nf90_real, dimids3(1:2), slc4varid)) - call nccheck_incr(nf90_def_var(ncid_out, "soilsnow_mask", nf90_int, dimids3(1:2), maskvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "tmp2m_inc", nf90_real, dimids2, tmp2mvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "spfh2m_inc", nf90_real, dimids2, spfh2mvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt1_inc", nf90_real, dimids2, soilt1varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt2_inc", nf90_real, dimids2, soilt2varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt3_inc", nf90_real, dimids2, soilt3varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt4_inc", nf90_real, dimids2, soilt4varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc1_inc", nf90_real, dimids2, slc1varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc2_inc", nf90_real, dimids2, slc2varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc3_inc", nf90_real, dimids2, slc3varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc4_inc", nf90_real, dimids2, slc4varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilsnow_mask", nf90_int, dimids2, maskvarid)) ! place global attributes to serial calc_increment output call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "source", "GSI EnKF")) call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "comment", & @@ -4036,7 +4041,7 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, ! note: same logic/threshold used in global_cycle to produce ! mask on model grid. - call read_vardata(dsfg, 'slc1', values_2d, errcode=iret) + call read_vardata(dsfg, 'soill1', values_2d, errcode=iret) mask = 0 do j=1,nlats diff --git a/src/enkf/inflation.f90 b/src/enkf/inflation.f90 index 225967028c..51d1dd1106 100644 --- a/src/enkf/inflation.f90 +++ b/src/enkf/inflation.f90 @@ -77,7 +77,8 @@ module inflation use constants, only: one, zero, rad2deg, deg2rad use covlocal, only: latval, taper use controlvec, only: ncdim, cvars3d, cvars2d, nc3d, nc2d, clevels -use gridinfo, only: latsgrd, logp, npts, nlevs_pres +! note: vars2d_landonly currently only defined for gridio_gfs, but smoothing only coded for gfs. +use gridinfo, only: latsgrd, logp, npts, nlevs_pres, vars2d_landonly use loadbal, only: indxproc, numptsperproc, npts_max, anal_chunk, anal_chunk_prior use smooth_mod, only: smooth @@ -101,9 +102,10 @@ subroutine inflate_ens() real(r_single),dimension(ndiag) :: sumcoslat,suma,suma2,sumi,sumf,sumitot,sumatot, & sumcoslattot,suma2tot,sumftot real(r_single) fnanalsml,coslat -integer(i_kind) i,nn,iunit,ierr,nb,nnlvl,ps_ind +integer(i_kind) i,nn,iunit,ierr,nb,nnlvl,ps_ind, this_ind, ind +integer(i_kind), dimension(8) :: soil_index character(len=500) filename -real(r_single), allocatable, dimension(:,:) :: tmp_chunk2,covinfglobal +real(r_single), allocatable, dimension(:,:) :: tmp_chunk2,covinfglobal,store_presmooth real(r_single) r fnanalsml = one/(real(nanals-1,r_single)) @@ -231,7 +233,33 @@ subroutine inflate_ens() do nn=1,ncdim call mpi_allreduce(mpi_in_place,covinfglobal(1,nn),npts,mpi_real4,mpi_sum,mpi_comm_world,ierr) enddo + ! do not apply smoothing to soil temp. or soil moisture (not globally defined) + + ind = 0 + do i = 1,8 + this_ind = getindex(cvars2d, vars2d_landonly(i)) + if (this_ind>0) then + ind=ind+1 + soil_index(ind)=this_ind + endif + enddo + + if (ind>0) then + allocate(store_presmooth(npts,ind)) + do i = 1, ind + store_presmooth(:,i) = covinfglobal(:,clevels(nc3d)+soil_index(i)) + enddo + endif + call smooth(covinfglobal) + + if (ind>0) then + do i = 1, ind + covinfglobal(:,clevels(nc3d) + soil_index(i)) = store_presmooth(:,i) + enddo + deallocate(store_presmooth) + endif + where (covinfglobal < covinflatemin) covinfglobal = covinflatemin where (covinfglobal > covinflatemax) covinfglobal = covinflatemax do i=1,numptsperproc(nproc+1) diff --git a/src/enkf/readconvobs.f90 b/src/enkf/readconvobs.f90 index a5383069a1..65db770b6d 100644 --- a/src/enkf/readconvobs.f90 +++ b/src/enkf/readconvobs.f90 @@ -24,7 +24,6 @@ module readconvobs ! reflectivity and radial velocity assimilation. POC: xuguang.wang@ou.edu ! 2017-12-13 shlyaeva - added netcdf diag read/write capability ! 2019-03-21 CAPS(C. Tong) - added direct reflectivity DA capability -! 2022-03-23 draper - added option to not scale qobs by forecast qsat. ! ! attributes: ! language: f95 diff --git a/src/enkf/statevec.f90 b/src/enkf/statevec.f90 index 5ad70346aa..44ad5df9b4 100644 --- a/src/enkf/statevec.f90 +++ b/src/enkf/statevec.f90 @@ -136,7 +136,7 @@ subroutine init_statevec() do i = 1, ns2d if (getindex(vars2d_supported, svars2d(i))<0) then if (nproc .eq. 0) then - print *,'Error: 2D variable ', svars2d(i), ' is not supported in current version.' + print *,'Error: state 2D variable ', svars2d(i), ' is not supported in current version.' print *,'Supported variables: ', vars2d_supported endif call stop2(502) @@ -145,7 +145,7 @@ subroutine init_statevec() do i = 1, ns3d if (getindex(vars3d_supported, svars3d(i))<0) then if (nproc .eq. 0) then - print *,'Error: 3D variable ', svars3d(i), ' is not supported in current version.' + print *,'Error: state 3D variable ', svars3d(i), ' is not supported in current version.' print *,'Supported variables: ', vars3d_supported endif call stop2(502) diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index 87d5aa4bd8..526dc9ee78 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -1669,13 +1669,15 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& pmq(k)=nint(qcmark(8,k)) end do -! 181, 183, 187, and 188 are the screen-level obs over land - global_2m_land = ( (kx==181 .or. kx==183 .or. kx==188 .or. kx==188 ) .and. hofx_2m_sfcfile ) +! 187, 181, and 183 are the screen-level obs over land +! note: don't need the hofx_2m_sfcfile if set usage in convinfo, and qm updated in the input file + global_2m_land = ( (kx==187 .or. kx==181 .or. kx==183) .and. hofx_2m_sfcfile ) ! If temperature ob, extract information regarding virtual ! versus sensible temperature if(tob) then ! use tvirtual if tsensible flag not set, and not in either 2Dregional or global_2m DA mode + ! for now, keeping 2m obs as sensible, for global system. if ( (.not. tsensible) .and. .not. (twodvar_regional .or. global_2m_land) ) then do k=1,levs @@ -1979,18 +1981,17 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& pqm(k)=2 ! otherwise, type 183 will be discarded. qm=2 tqm(k)=2 - if (kx==187) obserr(3,k)=2.2 - if (kx==181) obserr(3,k)=1.5 - if (kx==183) obserr(3,k)=2.6 + if (kx==187) obserr(3,k)=2.0_r_double + if (kx==181) obserr(3,k)=2.0_r_double + if (kx==183) obserr(3,k)=2.0_r_double endif if (qob .and. qm == 9 ) then qm = 2 ! qob err specified as fraction of qsat, multiplied by 10. - if (kx==187) obserr(2,k)=1.0 - if (kx==181) obserr(2,k)=1.0 - if (kx==183) obserr(2,k)=1.0 + if (kx==187) obserr(2,k)=1.0_r_double + if (kx==181) obserr(2,k)=1.0_r_double + if (kx==183) obserr(2,k)=1.0_r_double endif - endif ! Set usage variable usage = zero diff --git a/src/gsi/setupq.f90 b/src/gsi/setupq.f90 index ad6d727ce9..993d57046a 100644 --- a/src/gsi/setupq.f90 +++ b/src/gsi/setupq.f90 @@ -376,7 +376,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav do k=1,nobs ikx=nint(data(ikxx,k)) itype=ictype(ikx) - landsfctype =( itype==181 .or. itype==183 .or. itype==187 .or. itype==188 ) + landsfctype =( itype==181 .or. itype==183 .or. itype==187 ) do l=k+1,nobs if (twodvar_regional .or. (hofx_2m_sfcfile .and. landsfctype) ) then duplogic=data(ilat,k) == data(ilat,l) .and. & diff --git a/src/gsi/setupt.f90 b/src/gsi/setupt.f90 index 8d1c308d7f..2f1f57f583 100644 --- a/src/gsi/setupt.f90 +++ b/src/gsi/setupt.f90 @@ -448,7 +448,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav do k=1,nobs ikx=nint(data(ikxx,k)) itype=ictype(ikx) - landsfctype =( itype==181 .or. itype==183 .or. itype==187 .or. itype==188 ) + landsfctype =( itype==181 .or. itype==183 .or. itype==187 ) do l=k+1,nobs if (twodvar_regional .or. (hofx_2m_sfcfile .and. landsfctype) ) then duplogic=data(ilat,k) == data(ilat,l) .and. & @@ -483,9 +483,6 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav ! Run a buddy-check ! Note: buddy check crashes for hofx_2m_sfcfile option. -! Ccurrent params have buddy radius of 108 km, max diff of 8 K. -! The gross error check removes O-F > 7., so this is probably removing -! most obs that fail the buddy check already if (twodvar_regional .and. buddycheck_t) call buddy_check_t(is,data,luse,mype,nele,nobs,muse,buddyuse) ! If requested, save select data for output to diagnostic file From 291568517c8ff8ef6f0979377207ba555b104085 Mon Sep 17 00:00:00 2001 From: TingLei-NOAA Date: Thu, 8 Feb 2024 11:31:11 -0500 Subject: [PATCH 055/109] =?UTF-8?q?a=20quick=20fix=20for=20Issue:A=20index?= =?UTF-8?q?ing=20out=20of=20bounds=20issue=20shown=20in=20the=20global=5F4?= =?UTF-8?q?denvar=20regr=E2=80=A6=20(#681)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit In response to Issue:" A indexing out of bounds issue shown in the global_4denvar regression test in setuprad.f90 #676" (https://github.com/NOAA-EMC/GSI/issues/676) and following both online and off-line discussions, it is decided to retain the abi2km part in setuprad.f90 ( for potential future development/improvement), while a simple index-related checks are added to prevent the indexing error when GSI is built with debug mode. It is important to note that this indexing error does not impact GSI results (when GSI is built with optimization options) since abi2km is currently hardwire consfigured to be not used. Fixes #676 **DUE DATE for merger of this PR into `develop` is 2/22/2024 (six weeks after PR creation).** --------- Co-authored-by: Russ-Treadon-NOAA --- src/gsi/setuprad.f90 | 21 --------------------- 1 file changed, 21 deletions(-) diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 index 935366650c..ad8ccbc4e6 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -376,7 +376,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& logical in_curbin, in_anybin, save_jacobian logical account_for_corr_obs logical,dimension(nobs):: zero_irjaco3_pole - logical abi2km ! use 2km abi data (not CSR/ASR) ! Declare local arrays @@ -410,7 +409,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& real(r_kind) :: clw_guess,clw_guess_retrieval,ciw_guess,rain_guess,snow_guess,clw_avg real(r_kind),dimension(:), allocatable :: rsqrtinv real(r_kind),dimension(:), allocatable :: rinvdiag - real(r_kind),dimension(nchanl) :: abi2km_bc !for GMI (dual scan angles) real(r_kind),dimension(nchanl):: emissivity2,ts2, emissivity_k2,tsim2 @@ -529,7 +527,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& atms = obstype == 'atms' saphir = obstype == 'saphir' abi = obstype == 'abi' - abi2km = .false. ssmis=ssmis_las.or.ssmis_uas.or.ssmis_img.or.ssmis_env.or.ssmis @@ -1102,13 +1099,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif predbias=zero - 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 mm=ich(i) @@ -1187,17 +1177,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& end do end if - if (abi2km .and. regional) then - pred(:,i) = zero - if (i>=2 .and. i<=4) then - if (tb_obs(i) > 190.0_r_kind .and. tb_obs(i) < 300.0_r_kind) then - pred(1,i)=1.0_r_kind - pred(2,i)=tb_obs(i)-abi2km_bc(i) - pred(3,i)=(tb_obs(i)-abi2km_bc(i))**2 - pred(4,i)=(tb_obs(i)-abi2km_bc(i))**3 - end if - end if - end if do j = 1,npred predbias(j,i) = predchan(j,i)*pred(j,i) From bae0342fc9f30d40364d371460b8422adf10dee7 Mon Sep 17 00:00:00 2001 From: Xiaoyan Zhang <45010998+xyzemc@users.noreply.github.com> Date: Fri, 9 Feb 2024 14:13:45 -0500 Subject: [PATCH 056/109] =?UTF-8?q?Fix=20=20soil=20temperature/mositure=20?= =?UTF-8?q?read=20=20from=20RRFS=20warm-start=20r=E2=80=A6=20(#683)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit **DUE DATE for merger of this PR into `develop` is 2/27/2024 (six weeks after PR creation).** **Description** - Undefined soil_temp and soil_moist for regional because they are not correctly read in from the RRFS' warm-sart restart file as described in the issue#677. - Undefined or zero value of soil temp and moist will affect the calculation of surface emissivity. Surface emissivity is a factor to calculate the microwave surface channel radiance. Resolves #677 **Fix** In gsi_rfv3io_mod.f90, replace 'STC' with 'tslb', replace 'SMC' as 'smois **How has this need tested?** - This has been tested on Hera. The values of soil_temp and soil_moisture have been verified are correct now from the RRFS restart file. --- src/gsi/gsi_rfv3io_mod.f90 | 55 +++++++++++++++++++++++++++----------- 1 file changed, 39 insertions(+), 16 deletions(-) diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 7f0f00ac84..51c32eb7aa 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -25,6 +25,7 @@ module gsi_rfv3io_mod ! 2022-08-10 Wang - add IO for regional FV3-SMOKE (RRFS-SMOKE) model ! 2023-07-30 Zhao - add IO for the analysis of the significant wave height ! (SWH, aka howv in GSI) in fv3-lam based DA (eg., RRFS-3DRTMA) +! 2024-01-24 X.Zhang - bug fix for reading the soil temp and mois from the wram start file ! ! subroutines included: ! sub gsi_rfv3io_get_grid_specs @@ -2048,6 +2049,9 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) integer(i_kind),allocatable :: gfile_loc_layout(:) character(len=180) :: filename_layout +! for sfc 2d vaiable exist or not + logical, dimension(n2d) :: sfc_var_exist + sfcdata= fv3filenamegin%sfcdata dynvars= fv3filenamegin%dynvars @@ -2059,6 +2063,9 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) !-- initialisation of the array for howv sfcn2d(:,:,k_howv) = zero +!-- initialisation of the array for sfc_var_exist + sfc_var_exist = .false. + if(mype==mype_2d ) then allocate(sfc_fulldomain(nx,ny)) @@ -2109,30 +2116,43 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) iret=nf90_inquire_variable(gfile_loc,i,name,len) if( trim(name)=='f10m'.or.trim(name)=='F10M' ) then k=k_f10m + sfc_var_exist(k) = .true. else if( trim(name)=='stype'.or.trim(name)=='STYPE' ) then k=k_stype + sfc_var_exist(k) = .true. else if( trim(name)=='vfrac'.or.trim(name)=='VFRAC' ) then k=k_vfrac + sfc_var_exist(k) = .true. else if( trim(name)=='vtype'.or.trim(name)=='VTYPE' ) then k=k_vtype + sfc_var_exist(k) = .true. else if( trim(name)=='zorl'.or.trim(name)=='ZORL' ) then k=k_zorl + sfc_var_exist(k) = .true. else if( trim(name)=='tsea'.or.trim(name)=='TSEA' ) then k=k_tsea + sfc_var_exist(k) = .true. else if( trim(name)=='sheleg'.or.trim(name)=='SHELEG' ) then k=k_snwdph - else if( trim(name)=='stc'.or.trim(name)=='STC' ) then + sfc_var_exist(k) = .true. + else if( trim(name)=='stc'.or.trim(name)=='tslb' ) then k=k_stc - else if( trim(name)=='smc'.or.trim(name)=='SMC' ) then + sfc_var_exist(k) = .true. + else if( trim(name)=='smc'.or.trim(name)=='smois' ) then k=k_smc + sfc_var_exist(k) = .true. else if( trim(name)=='SLMSK'.or.trim(name)=='slmsk' ) then k=k_slmsk + sfc_var_exist(k) = .true. else if( trim(name)=='T2M'.or.trim(name)=='t2m' ) then k=k_t2m + sfc_var_exist(k) = .true. else if( trim(name)=='Q2M'.or.trim(name)=='q2m' ) then k=k_q2m + sfc_var_exist(k) = .true. else if( trim(name)=='HOWV'.or.trim(name)=='howv' ) then k=k_howv + sfc_var_exist(k) = .true. else cycle endif @@ -2268,29 +2288,32 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) !-- broadcast the updated i_howv_3dda to all tasks (!!!!) call mpi_bcast(i_howv_3dda, 1, mpi_itype, mype_2d, mpi_comm_world, iret_bcast) +!-- broadcast the updated sfc_var_exist to all tasks (!!!!) + call mpi_bcast(sfc_var_exist, n2d, mpi_itype, mype_2d, mpi_comm_world, iret_bcast) + !!!!!!! scatter !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! call mpi_scatterv(work,ijns2d,displss2d,mpi_rtype,& sfcn2d,ijns2d(mm1),mpi_rtype,mype_2d,mpi_comm_world,ierror) deallocate ( work ) - fact10(:,:,it)=sfcn2d(:,:,k_f10m) - soil_type(:,:,it)=sfcn2d(:,:,k_stype) - veg_frac(:,:,it)=sfcn2d(:,:,k_vfrac) - veg_type(:,:,it)=sfcn2d(:,:,k_vtype) - sfc_rough(:,:,it)=sfcn2d(:,:,k_zorl) - sfct(:,:,it)=sfcn2d(:,:,k_tsea) - sno(:,:,it)=sfcn2d(:,:,k_snwdph) - soil_temp(:,:,it)=sfcn2d(:,:,k_stc) - soil_moi(:,:,it)=sfcn2d(:,:,k_smc) - ges_z(:,:)=sfcn2d(:,:,k_orog)/grav - isli(:,:,it)=nint(sfcn2d(:,:,k_slmsk)) + if ( sfc_var_exist(k_f10m) ) fact10(:,:,it)=sfcn2d(:,:,k_f10m) + if ( sfc_var_exist(k_stype) ) soil_type(:,:,it)=sfcn2d(:,:,k_stype) + if ( sfc_var_exist(k_vfrac) ) veg_frac(:,:,it)=sfcn2d(:,:,k_vfrac) + if ( sfc_var_exist(k_vtype) ) veg_type(:,:,it)=sfcn2d(:,:,k_vtype) + if ( sfc_var_exist(k_zorl) ) sfc_rough(:,:,it)=sfcn2d(:,:,k_zorl) + if ( sfc_var_exist(k_tsea) ) sfct(:,:,it)=sfcn2d(:,:,k_tsea) + if ( sfc_var_exist(k_snwdph)) sno(:,:,it)=sfcn2d(:,:,k_snwdph) + if ( sfc_var_exist(k_stc) ) soil_temp(:,:,it)=sfcn2d(:,:,k_stc) + if ( sfc_var_exist(k_smc) ) soil_moi(:,:,it)=sfcn2d(:,:,k_smc) + if ( sfc_var_exist(k_orog) ) ges_z(:,:)=sfcn2d(:,:,k_orog)/grav + if ( sfc_var_exist(k_slmsk) ) isli(:,:,it)=nint(sfcn2d(:,:,k_slmsk)) if(i_use_2mq4b > 0 .and. i_use_2mt4b > 0 ) then - ges_t2m(:,:)=sfcn2d(:,:,k_t2m) - ges_q2m(:,:)=sfcn2d(:,:,k_q2m) + if ( sfc_var_exist(k_t2m) ) ges_t2m(:,:)=sfcn2d(:,:,k_t2m) + if ( sfc_var_exist(k_q2m) ) ges_q2m(:,:)=sfcn2d(:,:,k_q2m) endif if ( i_howv_3dda == 1 ) then - ges_howv(:,:)=sfcn2d(:,:,k_howv) + if ( sfc_var_exist(k_howv) ) ges_howv(:,:)=sfcn2d(:,:,k_howv) endif deallocate (sfcn2d,a) return From cd620030dc33c45381daceaa82e0b598a404076f Mon Sep 17 00:00:00 2001 From: Gang Zhao <53267411+GangZhao-NOAA@users.noreply.github.com> Date: Tue, 13 Feb 2024 14:06:33 -0500 Subject: [PATCH 057/109] Adding the dry-bulb air temperature and tv flag in the observation diagnostic file of conventional Q obs (for 3D RTMA run only) (#688) - Motivation: In the Auto-QC utility of 3D-RTMA, the dry-bulb air temperature (hereafter as T_dry) which is accompanied with moisture observation is required in the procedure of the quality control for conventional moisture observations (Q obs). Since this auto-qc of 3DRTMA retrieves many information from the observation diagnostic files (output of GSI run), it should be convenient for the sake of auto-qc of Q obs, if the required T_dry could be output into the observation diagnostics file of Q obs in the GSI run. - Modifications to the code: **_read_prepbufr.f90_**: for qob and rtma run, add lines to use tpc to identify the sensible temp and virtual temp, and mark with tvflag, then get tdry with the temp obs in different ways w.r.t the associated tvflag; **_setupq.f90_**: add line to use l_rtma3d from module rapidrefresh_cldsurf_mod variable nreal (the length of obs diag information record for each obs) needs to be increased by 2 (for tdry and tvflag, when running GSI for 3DRTMA only) in subroutine contents_binary_diag_, add line to put tdry into the array rdiagbuff (for binary format obsdaig file) in subroutine contents_netcdf_diag_, add line to put tdry into metadata (for netcdf format obsdiag file) This PR is to address the issue #666 : Adding the (calculated) dry-bulb temperature in the observation diagnostic file for conventional Q obs (only for 3D RTMA) --- src/gsi/read_prepbufr.f90 | 46 ++++++++++++++++++++++++++++++++++++--- src/gsi/setupq.f90 | 25 +++++++++++++++++++++ 2 files changed, 68 insertions(+), 3 deletions(-) diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index 526dc9ee78..f281573a4e 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -149,8 +149,10 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! 2020-05-04 wu - no rotate_wind for fv3_regional ! 2020-09-05 CAPS(C. Tong) - add flag for new vadwind obs to assimilate around the analysis time only ! 2023-03-23 draper - add code for processing T2m and q2m for global system -! 2023-07-30 Zhao - added code to extract obs of significant wave height (howvob) from bufr record +! 2023-07-30 zhao - added code to extract obs of significant wave height (howvob) from bufr record ! in prepbufr file for 3D analysis +! 2024-01-11 zhao - added code to extract sensible temp (tdry) and tv flag +! for moisture obs(qob) when running (2D/3D)RTMA ! input argument list: ! infile - unit from which to read BUFR data @@ -225,6 +227,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& use adjust_cloudobs_mod, only: adjust_convcldobs,adjust_goescldobs use mpimod, only: npe use rapidrefresh_cldsurf_mod, only: i_gsdsfc_uselist,i_gsdqc,i_ens_mean + use rapidrefresh_cldsurf_mod, only: l_rtma3d use gsi_io, only: verbose use phil2, only: denest ! hilbert curve @@ -390,6 +393,10 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& logical, allocatable,dimension(:) :: rusage,rthin ! end of block +! for extracting sensible-vs-virtual temp obs + integer(i_kind),dimension(1,255):: tqm4q + real(r_kind),dimension(1,255):: tvflg4q + real(r_double),dimension(1,255):: tobs4q ! equivalence to handle character names equivalence(r_prvstg(1,1),c_prvstg) @@ -876,6 +883,9 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& glcd=-999._r_double endif + if(print_verbose) write(6,'(1x,A,A,A,2(A,1x,F8.3))') 'read_prepbufr:', & + trim(adjustl(obstype)),':', ' vtcd= ',vtcd,' glcd= ',glcd + call init_rjlists call init_aircraft_rjlists if(i_gsdsfc_uselist==1) call init_gsd_sfcuselist @@ -1503,6 +1513,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if(driftl)call ufbint(lunin,drfdat,8,255,iret,drift) ! raob level enhancement on temp and q obs +! (note: levs is increased by sonde_ext, and not same as original value read from prepbufr) if(ext_sonde .and. kx==120) call sonde_ext(obsdat,tpc,qcmark,obserr,drfdat,levs,kx,vtcd) nread=nread+levs @@ -1713,6 +1724,25 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& end if end if +! If moisture ob (qob) and (2D/3D)RTMA, set tv flag information (based on tpc) +! regarding virtual vs. sensible temperaure, to get tdry (if virtual temp +! then compute tdry; if sensible temp, then tdry= tsen), then save tdry +! in q-obsdaig file for RTMA offline Auto-QC. + if (qob .and. (l_rtma3d .or. twodvar_regional)) then + tobs4q(1,:) = bmiss + tqm4q(1,:) = bmiss + tvflg4q(1,:)= -one + do k=1,levs + tvflg4q(1,k)=one ! initialize as sensible + tobs4q(1,k)=obsdat(3,k) ! temp obs read in prepbufr + tqm4q(1,k)=tqm(k) + do j=1,20 + if (tpc(k,j)==vtcd) tvflg4q(1,k)=zero ! reset flag if virtual + if (tpc(k,j)>=bmiss) exit ! end of stack + end do + end do + end if ! if qob & rtma + if(i_gsdqc==2) then ! AMV acceptance for all obs (E. James) if (kx >= 240 .and. kx <= 260) then @@ -2398,7 +2428,15 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& end if qobcon=obsdat(2,k)*convert tdry=r999 - if (tqm(k) Date: Tue, 13 Feb 2024 14:29:45 -0500 Subject: [PATCH 058/109] update fix submodule for GFS v16.3.12 and soil analysis changes (#695) --- fix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fix b/fix index 5722cd4d25..298bdc0f56 160000 --- a/fix +++ b/fix @@ -1 +1 @@ -Subproject commit 5722cd4d2519222137c5b356bdbc01bb34c5f1f4 +Subproject commit 298bdc0f56692ad25141a946177e5d88884e367a From 74ac5942118d2a83ca84d3a629ec3aaffdb36fc5 Mon Sep 17 00:00:00 2001 From: David Huber <69919478+DavidHuber-NOAA@users.noreply.github.com> Date: Wed, 14 Feb 2024 18:07:15 +0000 Subject: [PATCH 059/109] Upgrade the GSI to Spack-Stack version 1.6.0 (#684) --- ci/spack.yaml | 12 +- modulefiles/gsi_cheyenne.gnu.lua | 32 ------ modulefiles/gsi_cheyenne.intel.lua | 32 ------ modulefiles/gsi_common.lua | 6 +- modulefiles/gsi_hera.gnu.lua | 8 +- modulefiles/gsi_hera.intel.lua | 6 +- modulefiles/gsi_hercules.intel.lua | 6 +- modulefiles/gsi_jet.intel.lua | 6 +- modulefiles/gsi_orion.intel.lua | 6 +- modulefiles/gsi_s4.intel.lua | 6 +- modulefiles/gsi_wcoss2.intel.lua | 2 +- regression/regression_param.sh | 32 ------ regression/regression_var.sh | 18 +-- ush/module-setup.sh | 7 -- ush/sub_cheyenne | 169 ----------------------------- ush/sub_hercules | 4 +- 16 files changed, 32 insertions(+), 320 deletions(-) delete mode 100644 modulefiles/gsi_cheyenne.gnu.lua delete mode 100644 modulefiles/gsi_cheyenne.intel.lua delete mode 100644 ush/sub_cheyenne diff --git a/ci/spack.yaml b/ci/spack.yaml index deacdff0b5..647904108e 100644 --- a/ci/spack.yaml +++ b/ci/spack.yaml @@ -7,19 +7,19 @@ spack: - gcc@10:10 specs: - netcdf-c@4.9.2 - - netcdf-fortran@4.6.0 + - netcdf-fortran@4.6.1 - bufr@11.7.0 - bacio@2.4.1 - - w3emc@2.9.2 - - sp@2.3.3 - - ip@3.3.3 + - w3emc@2.10.0 + - sp@2.5.0 + - ip@4.3.0 - sigio@2.3.2 - sfcio@1.4.1 - nemsio@2.5.4 - wrf-io@1.2.0 - ncio@1.1.2 - - crtm@2.4.0 - - gsi-ncdiag@1.1.1 + - crtm@2.4.0.1 + - gsi-ncdiag@1.1.2 view: true concretizer: unify: true diff --git a/modulefiles/gsi_cheyenne.gnu.lua b/modulefiles/gsi_cheyenne.gnu.lua deleted file mode 100644 index 1d903082a8..0000000000 --- a/modulefiles/gsi_cheyenne.gnu.lua +++ /dev/null @@ -1,32 +0,0 @@ -help([[ -]]) - - -unload("ncarenv/1.3") -unload("intel/19.1.1") -unload("ncarcompilers/0.5.0") -unload("mpt/2.25") -unload("netcdf/4.8.1") - -prepend_path("MODULEPATH", "/glade/work/epicufsrt/contrib/spack-stack/cheyenne/spack-stack-1.4.1/envs/unified-env/install/modulefiles/Core") -prepend_path("MODULEPATH", "/glade/work/jedipara/cheyenne/spack-stack/modulefiles/misc") - -local stack_python_ver=os.getenv("stack_python_ver") or "3.9.12" -local stack_gnu_ver=os.getenv("stack_gnu_ver") or "10.1.0" -local stack_openmpi_ver=os.getenv("stack_openmpi_ver") or "4.1.1" -local cmake_ver=os.getenv("cmake_ver") or "3.22.0" - -load(pathJoin("stack-gcc", stack_gnu_ver)) -load(pathJoin("stack-openmpi", stack_openmpi_ver)) -load(pathJoin("stack-python", stack_python_ver)) -load(pathJoin("cmake", cmake_ver)) -load(pathJoin("prod_util", os.getenv("prod_util_ver") or "1.2.2")) -load(pathJoin("openblas", os.getenv("openblas_ver") or "0.3.23")) - -load("gsi_common") - -pushenv("CFLAGS", "-xHOST") -pushenv("FFLAGS", "-xHOST") -pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_data/fix/20230601") - -whatis("Description: GSI environment on Cheyenne with GNU Compilers") diff --git a/modulefiles/gsi_cheyenne.intel.lua b/modulefiles/gsi_cheyenne.intel.lua deleted file mode 100644 index 8c328e2b34..0000000000 --- a/modulefiles/gsi_cheyenne.intel.lua +++ /dev/null @@ -1,32 +0,0 @@ -help([[ -]]) - -unload("ncarenv/1.3") -unload("intel/19.1.1") -unload("ncarcompilers/0.5.0") -unload("mpt/2.25") -unload("netcdf/4.8.1") - -prepend_path("MODULEPATH", "/glade/work/epicufsrt/contrib/spack-stack/cheyenne/spack-stack-1.4.1/envs/unified-env/install/modulefiles/Core") -prepend_path("MODULEPATH", "/glade/work/jedipara/cheyenne/spack-stack/modulefiles/misc") - -local stack_python_ver=os.getenv("stack_python_ver") or "3.9.12" -local stack_intel_ver=os.getenv("stack_intel_ver") or "19.1.1.217" -local stack_mpi_ver=os.getenv("stack_mpi_ver") or "2019.7.217" -local cmake_ver=os.getenv("cmake_ver") or "3.22.0" - -load(pathJoin("stack-intel", stack_intel_ver)) -load(pathJoin("stack-intel-mpi", stack_mpi_ver)) -load(pathJoin("stack-python", stack_python_ver)) -load(pathJoin("cmake", cmake_ver)) - -load("gsi_common") -load(pathJoin("prod-util", os.getenv("prod_util_ver") or "1.2.2")) -pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_data/fix/20230911") - -pushenv("CFLAGS", "-xHOST") -pushenv("FFLAGS", "-xHOST") - -pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_data/fix/20230601") - -whatis("Description: GSI environment on Cheyenne with Intel Compilers") diff --git a/modulefiles/gsi_common.lua b/modulefiles/gsi_common.lua index d3365a98dc..cb49a43878 100644 --- a/modulefiles/gsi_common.lua +++ b/modulefiles/gsi_common.lua @@ -3,19 +3,19 @@ Load common modules to build GSI on all machines ]]) local netcdf_c_ver=os.getenv("netcdf_c_ver") or "4.9.2" -local netcdf_fortran_ver=os.getenv("netcdf_fortran_ver") or "4.6.0" +local netcdf_fortran_ver=os.getenv("netcdf_fortran_ver") or "4.6.1" local bufr_ver=os.getenv("bufr_ver") or "11.7.0" local bacio_ver=os.getenv("bacio_ver") or "2.4.1" local w3emc_ver=os.getenv("w3emc_ver") or "2.10.0" -local sp_ver=os.getenv("sp_ver") or "2.3.3" +local sp_ver=os.getenv("sp_ver") or "2.5.0" local ip_ver=os.getenv("ip_ver") or "4.3.0" local sigio_ver=os.getenv("sigio_ver") or "2.3.2" local sfcio_ver=os.getenv("sfcio_ver") or "1.4.1" local nemsio_ver=os.getenv("nemsio_ver") or "2.5.4" local wrf_io_ver=os.getenv("wrf_io_ver") or "1.2.0" local ncio_ver=os.getenv("ncio_ver") or "1.1.2" -local crtm_ver=os.getenv("crtm_ver") or "2.4.0" +local crtm_ver=os.getenv("crtm_ver") or "2.4.0.1" local ncdiag_ver=os.getenv("ncdiag_ver") or "1.1.2" load(pathJoin("netcdf-c", netcdf_c_ver)) diff --git a/modulefiles/gsi_hera.gnu.lua b/modulefiles/gsi_hera.gnu.lua index 550b01ee7b..d85e79b005 100644 --- a/modulefiles/gsi_hera.gnu.lua +++ b/modulefiles/gsi_hera.gnu.lua @@ -1,16 +1,16 @@ help([[ ]]) -prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/spack-stack/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") +prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/spack-stack/spack-stack-1.6.0/envs/gsi-addon-dev/install/modulefiles/Core") --Needed for openmpi build prepend_path("MODULEPATH", "/scratch1/NCEPDEV/jcsda/jedipara/spack-stack/modulefiles") -local python_ver=os.getenv("python_ver") or "3.10.8" +local python_ver=os.getenv("python_ver") or "3.11.6" local stack_gnu_ver=os.getenv("stack_gnu_ver") or "9.2.0" local stack_openmpi_ver=os.getenv("stack_openmpi_ver") or "4.1.5" local cmake_ver=os.getenv("cmake_ver") or "3.23.1" -local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" -local openblas_ver=os.getenv("openblas_ver") or "0.3.19" +local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1" +local openblas_ver=os.getenv("openblas_ver") or "0.3.24" load(pathJoin("stack-gcc", stack_gnu_ver)) load(pathJoin("stack-openmpi", stack_openmpi_ver)) diff --git a/modulefiles/gsi_hera.intel.lua b/modulefiles/gsi_hera.intel.lua index abdc6e5623..b967c32f74 100644 --- a/modulefiles/gsi_hera.intel.lua +++ b/modulefiles/gsi_hera.intel.lua @@ -1,13 +1,13 @@ help([[ ]]) -prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/spack-stack/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") +prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/spack-stack/spack-stack-1.6.0/envs/gsi-addon-dev/install/modulefiles/Core") -local python_ver=os.getenv("python_ver") or "3.10.8" +local python_ver=os.getenv("python_ver") or "3.11.6" local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.5.0" local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.1" local cmake_ver=os.getenv("cmake_ver") or "3.23.1" -local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" +local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1" load(pathJoin("stack-intel", stack_intel_ver)) load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) diff --git a/modulefiles/gsi_hercules.intel.lua b/modulefiles/gsi_hercules.intel.lua index bf29bc21db..c72323cbad 100644 --- a/modulefiles/gsi_hercules.intel.lua +++ b/modulefiles/gsi_hercules.intel.lua @@ -1,13 +1,13 @@ help([[ ]]) -prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/spack-stack/hercules/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") +prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/spack-stack/hercules/spack-stack-1.6.0/envs/gsi-addon-env/install/modulefiles/Core") -local stack_python_ver=os.getenv("stack_python_ver") or "3.10.8" +local stack_python_ver=os.getenv("stack_python_ver") or "3.11.6" local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.9.0" local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.9.0" local cmake_ver=os.getenv("cmake_ver") or "3.23.1" -local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" +local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1" load(pathJoin("stack-intel", stack_intel_ver)) load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) diff --git a/modulefiles/gsi_jet.intel.lua b/modulefiles/gsi_jet.intel.lua index 20b80ff61a..b2b98be7ff 100644 --- a/modulefiles/gsi_jet.intel.lua +++ b/modulefiles/gsi_jet.intel.lua @@ -1,13 +1,13 @@ help([[ ]]) -prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/spack-stack/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") +prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/spack-stack/spack-stack-1.6.0/envs/gsi-addon-dev/install/modulefiles/Core") -local python_ver=os.getenv("python_ver") or "3.10.8" +local python_ver=os.getenv("python_ver") or "3.11.6" local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.5.0" local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.1" local cmake_ver=os.getenv("cmake_ver") or "3.23.1" -local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" +local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1" load(pathJoin("stack-intel", stack_intel_ver)) load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) diff --git a/modulefiles/gsi_orion.intel.lua b/modulefiles/gsi_orion.intel.lua index 80ec342c93..114e5f8ad1 100644 --- a/modulefiles/gsi_orion.intel.lua +++ b/modulefiles/gsi_orion.intel.lua @@ -1,13 +1,13 @@ help([[ ]]) -prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/spack-stack/orion/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") +prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/spack-stack/orion/spack-stack-1.6.0/envs/gsi-addon-env/install/modulefiles/Core") -local stack_python_ver=os.getenv("python_ver") or "3.10.8" +local stack_python_ver=os.getenv("python_ver") or "3.11.6" local stack_intel_ver=os.getenv("stack_intel_ver") or "2022.0.2" local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.1" local cmake_ver=os.getenv("cmake_ver") or "3.23.1" -local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" +local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1" load(pathJoin("stack-intel", stack_intel_ver)) load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) diff --git a/modulefiles/gsi_s4.intel.lua b/modulefiles/gsi_s4.intel.lua index a60ea3c16e..08e3d38516 100644 --- a/modulefiles/gsi_s4.intel.lua +++ b/modulefiles/gsi_s4.intel.lua @@ -1,13 +1,13 @@ help([[ ]]) -prepend_path("MODULEPATH", "/data/prod/jedi/spack-stack/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") +prepend_path("MODULEPATH", "/data/prod/jedi/spack-stack/spack-stack-1.6.0/envs/gsi-addon-env/install/modulefiles/Core") -local python_ver=os.getenv("python_ver") or "3.10.8" +local python_ver=os.getenv("python_ver") or "3.11.6" local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.5.0" local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.0" local cmake_ver=os.getenv("cmake_ver") or "3.23.1" -local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" +local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1" load(pathJoin("stack-intel", stack_intel_ver)) load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) diff --git a/modulefiles/gsi_wcoss2.intel.lua b/modulefiles/gsi_wcoss2.intel.lua index 8dde986e58..28b2f0d09d 100644 --- a/modulefiles/gsi_wcoss2.intel.lua +++ b/modulefiles/gsi_wcoss2.intel.lua @@ -20,7 +20,7 @@ local sfcio_ver=os.getenv("sfcio_ver") or "1.4.1" local nemsio_ver=os.getenv("nemsio_ver") or "2.5.4" local wrf_io_ver=os.getenv("wrf_io_ver") or "1.2.0" local ncio_ver=os.getenv("ncio_ver") or "1.1.2" -local crtm_ver=os.getenv("crtm_ver") or "2.4.0" +local crtm_ver=os.getenv("crtm_ver") or "2.4.0.1" local ncdiag_ver=os.getenv("ncdiag_ver") or "1.1.1" load(pathJoin("PrgEnv-intel", PrgEnv_intel_ver)) diff --git a/regression/regression_param.sh b/regression/regression_param.sh index 46d2647ac0..2ac615fc4a 100755 --- a/regression/regression_param.sh +++ b/regression/regression_param.sh @@ -36,11 +36,6 @@ case $machine in ;; Discover) sub_cmd="sub_discover" - ;; - Cheyenne) - sub_cmd="sub_cheyenne" - memnode=128 - numcore=36 ;; *) # EXIT out for unresolved machine echo "unknown $machine" @@ -73,9 +68,6 @@ case $regtest in elif [[ "$machine" = "Discover" ]]; then topts[1]="0:30:00" ; popts[1]="48/2" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="60/3" ; ropts[2]="/2" - elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" - topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then topts[1]="0:10:00" ; popts[1]="18/8/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="18/10/" ; ropts[2]="/2" @@ -106,9 +98,6 @@ case $regtest in elif [[ "$machine" = "Jet" ]]; then topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" - elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" @@ -139,9 +128,6 @@ case $regtest in elif [[ "$machine" = "Jet" ]]; then topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" - elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" @@ -171,9 +157,6 @@ case $regtest in elif [[ "$machine" = "Jet" ]]; then topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" - elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" @@ -204,9 +187,6 @@ case $regtest in elif [[ "$machine" = "Jet" ]]; then topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" - elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" @@ -237,9 +217,6 @@ case $regtest in elif [[ "$machine" = "Jet" ]]; then topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" - elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" - topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then topts[1]="0:30:00" ; popts[1]="8/6/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="8/8/" ; ropts[2]="/1" @@ -270,9 +247,6 @@ case $regtest in elif [[ "$machine" = "Jet" ]]; then topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" - elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" @@ -342,12 +316,6 @@ elif [[ "$machine" = "Gaea" ]]; then export MPI_BUFS_PER_HOST=256 export MPI_GROUP_MAX=256 export APRUN="srun --export=ALL --mpi=pmi2 -n \$ntasks" -elif [[ "$machine" = "Cheyenne" ]]; then - export OMP_STACKSIZE=1024M - export MPI_BUFS_PER_PROC=256 - export MPI_BUFS_PER_HOST=256 - export MPI_GROUP_MAX=256 - export APRUN="mpirun -v -np \$ntasks" elif [[ "$machine" = "wcoss2" ]]; then export OMP_PLACES=cores export OMP_STACKSIZE=2G diff --git a/regression/regression_var.sh b/regression/regression_var.sh index 02ffb24b12..9d91b2c41f 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -30,9 +30,7 @@ else fi # Determine the machine -if [[ -d /glade ]]; then # Cheyenne - export machine="Cheyenne" -elif [[ -d /scratch1 ]]; then # Hera +if [[ -d /scratch1 ]]; then # Hera export machine="Hera" elif [[ -d /mnt/lfs4 || -d /jetmon || -d /mnt/lfs1 ]]; then # Jet export machine="Jet" @@ -66,20 +64,6 @@ case $machine in export check_resource="no" export accnt="nggps_emc" ;; - Cheyenne) - export queue="regular" - export noscrub="/glade/scratch/$LOGNAME/noscrub" - export group="global" - if [[ "$cmaketest" = "false" ]]; then - export basedir="/glade/scratch/$LOGNAME" - fi - export ptmp="/glade/scratch/$LOGNAME/$ptmpName" - - export casesdir="/glade/work/epicufsrt/contrib/GSI_data/CASES/regtest" - - export check_resource="no" - export accnt="NRAL0032" - ;; wcoss2) export local_or_default="${local_or_default:-/lfs/h2/emc/da/noscrub/$LOGNAME}" if [ -d $local_or_default ]; then diff --git a/ush/module-setup.sh b/ush/module-setup.sh index d13da1efa3..c1893ab4ee 100755 --- a/ush/module-setup.sh +++ b/ush/module-setup.sh @@ -40,13 +40,6 @@ elif [[ $MACHINE_ID = wcoss2 ]]; then # We are on WCOSS2 module reset -elif [[ $MACHINE_ID = cheyenne* ]] ; then - # We are on NCAR Cheyenne - if ( ! eval module help > /dev/null 2>&1 ) ; then - source /glade/u/apps/ch/modulefiles/default/localinit/localinit.sh - fi - module purge - elif [[ $MACHINE_ID = stampede* ]] ; then # We are on TACC Stampede if ( ! eval module help > /dev/null 2>&1 ) ; then diff --git a/ush/sub_cheyenne b/ush/sub_cheyenne deleted file mode 100644 index 7389bfeb24..0000000000 --- a/ush/sub_cheyenne +++ /dev/null @@ -1,169 +0,0 @@ -#!/bin/sh --login -set -x -echo "starting sub_cheyenne" -usage="\ -Usage: $0 [options] executable [args] - where the options are: - -a account account (default: none) - -b binding run smt binding or not (default:NO) - -d dirin initial directory (default: cwd) - -e envars copy comma-separated environment variables - -g group group name - -i append standard input to command file - -j jobname specify jobname (default: executable basename) - -m machine machine on which to run (default: current) - -n write command file to stdout rather than submitting it - -o output specify output file (default: jobname.out) - -p procs[/nodes[/ppreq] - number of MPI tasks and optional nodes or Bblocking and - ppreq option (N or S) (defaults: serial, Bunlimited, S) - -q queue[/qpreq] queue name and optional requirement, e.g. dev/P - (defaults: 1 if serial or dev if parallel and none) - (queue 3 or 4 is dev or prod with twice tasks over ip) - (options: P=parallel, B=bigmem, b=batch) - -r rmem[/rcpu] resources memory and cpus/task (default: '1024 mb', 1) - -t timew wall time limit in [[hh:]mm:]ss format (default: 900) - -u userid userid to run under (default: self) - -v verbose mode - -w when when to run, in yyyymmddhh[mm], +hh[mm], thh[mm], or - Thh[mm] (full, incremental, today or tomorrow) format - (default: now) -Function: This command submits a job to the batch queue." -subcmd="$*" -stdin=NO -nosub=NO -account="" -binding="NO" -dirin="" -envars="" -group="" -jobname="" -machine="" -output="" -procs=0 -nodes="" -ppreq="" -queue="" -qpreq="" -rmem="1024" -rcpu="1" -timew="900" -userid="" -verbose=NO -when="" -while getopts a:b:d:e:g:ij:m:no:p:q:r:t:u:vw: opt;do - case $opt in - a) account="$OPTARG";; - b) binding="$OPTARG";; - d) dirin="$OPTARG";; - e) envars="$OPTARG";; - g) group="$OPTARG";; - i) stdin=YES;; - j) jobname=$OPTARG;; - m) machine="$OPTARG";; - n) nosub=YES;; - o) output=$OPTARG;; - p) procs=$(echo $OPTARG/|cut -d/ -f1);nodes=$(echo $OPTARG/|cut -d/ -f2);ppreq=$(echo $OPTARG/|cut -d/ -f3);; - q) queue=$(echo $OPTARG/|cut -d/ -f1);qpreq=$(echo $OPTARG/|cut -d/ -f2);; - r) rmem=$(echo $OPTARG/|cut -d/ -f1);rcpu=$(echo $OPTARG/|cut -d/ -f2);; - t) timew=$OPTARG;; - u) userid=$OPTARG;; - v) verbose=YES;; - w) when=$OPTARG;; - \?) echo $0: invalid option >&2;echo "$usage" >&2;exit 1;; - esac -done -shift $(($OPTIND-1)) -if [[ $# -eq 0 ]];then - echo $0: missing executable name >&2;echo "$usage" >&2;exit 1 -fi -exec=$1 -if [[ ! -s $exec ]]&&which $exec >/dev/null 2>&1;then - exec=$(which $exec) -fi -shift -args="$*" -bn=$(basename $exec) -export jobname=${jobname:-$bn} -output=${output:-$jobname.out} -myuser=$LOGNAME -myhost=$(hostname) - -DATA=/glade/scratch/$LOGNAME/tmp -mkdir -p $DATA - -timew=${timew:-01:20:00} -task_node=${task_node:-$procs} -size=$((nodes*task_node)) -envars=$envars -threads=${rcpu:-1} - -export TZ=GMT -cfile=$DATA/sub$$ -> $cfile -echo "#!/bin/sh --login" >> $cfile -echo "" >> $cfile -echo "#PBS -o $output" >> $cfile -echo "#PBS -N $jobname" >> $cfile -echo "#PBS -q $queue" >> $cfile -echo "#PBS -l walltime=$timew" >> $cfile -echo "#PBS -l select=$nodes:ncpus=$procs:mpiprocs=$procs" >> $cfile -echo "#PBS -j oe" >> $cfile -echo "#PBS -A $accnt" >> $cfile -echo "#PBS -V" >> $cfile - -echo "" >>$cfile -echo "export ntasks=$(( $nodes * $procs ))" >> $cfile -echo "export ppn=$procs" >> $cfile -echo "export threads=$threads" >> $cfile -echo "export OMP_NUM_THREADS=$threads" >> $cfile -echo "ulimit -s unlimited" >> $cfile -echo "" >>$cfile -echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile -echo "" >>$cfile - -echo "cfile = $cfile" -echo "source /glade/u/apps/ch/modulefiles/default/localinit/localinit.sh >> $cfile" -echo "module purge" >> $cfile -echo "module use $modulefiles" >> $cfile -echo "module load gsi_cheyenne.intel" >> $cfile -echo "module list" >> $cfile - -cat $exec >> $cfile - -if [[ $nosub = YES ]];then - cat $cfile - exit -elif [[ $verbose = YES ]];then - set -x - cat $cfile -fi - - -if [[ $stdin = YES ]];then - cat -fi >>$cfile -if [[ $nosub = YES ]];then - cat $cfile - exit -elif [[ $verbose = YES ]];then - set -x - cat $cfile -fi -qsub=${qsub:-qsub} - -ofile=$DATA/subout$$ ->$ofile -chmod 777 $ofile -$qsub $cfile >$ofile -rc=$? -cat $ofile -if [[ -w $SUBLOG ]];then - jobn=$(grep -i submitted $ofile|head -n1|cut -d\" -f2) - date -u +"%Y%m%d%H%M%S : $subcmd : $jobn" >>$SUBLOG -fi -rm $cfile $ofile -[[ $MKDATA = YES ]] && rmdir $DATA -echo "ending sub_cheyenne" -exit $rc - diff --git a/ush/sub_hercules b/ush/sub_hercules index e854d5727b..459b480559 100755 --- a/ush/sub_hercules +++ b/ush/sub_hercules @@ -119,7 +119,6 @@ echo "export ntasks=$(( $nodes * $procs ))" >> $cfile echo "export ppn=$procs" >> $cfile echo "export threads=$threads" >> $cfile echo "export OMP_NUM_THREADS=$threads" >> $cfile -##echo "export OMP_STACKSIZE=2048M" >> $cfile echo "ulimit -s unlimited" >> $cfile echo "" >>$cfile @@ -130,7 +129,8 @@ echo ". /apps/other/lmod/lmod/init/sh" >> $cfile echo "module purge" >> $cfile echo "module use $modulefiles" >> $cfile echo "module load gsi_hercules.intel" >> $cfile -echo "module list" >> $cfile +#TODO reenable I_MPI_EXTRA_FILESYSTEM once regional ctests can properly handle parallel I/O on Hercules +echo "unset I_MPI_EXTRA_FILESYSTEM" >> $cfile echo "" >> $cfile cat $exec >> $cfile From 7c4a57188ce33752e3be8721012cc5686ae56e17 Mon Sep 17 00:00:00 2001 From: Ming Hu Date: Fri, 23 Feb 2024 09:30:50 -0700 Subject: [PATCH 060/109] Fix three bugs found in RRFS test (#705) **DUE DATE for merger of this PR into `develop` is 4/2/2024 (six weeks after PR creation).** **Description** We found three bugs in RRFS test: 1) add "vars2d_landonly" to regional gridinfo files for compiling. 2) add terrain to "sfc_var_exist" check 3) fix case selection bug for FED GSI DA. Resolves #704 Resolves #702 Resolves #703 **Type of change** Bug fix (non-breaking change which fixes an issue) **How Has This Been Tested?** Those fixes are tested with full RRFS cases and with several cycles of RRFS retro. **Checklist** - [x ] My code follows the style guidelines of this project - [x ] I have performed a self-review of my own code - [x ] I have commented my code, particularly in hard-to-understand areas - [ ] New and existing tests pass with my changes - [ ] Any dependent changes have been merged and published --- src/enkf/gridinfo_fv3reg.f90 | 2 ++ src/enkf/gridinfo_nmmb.f90 | 2 ++ src/enkf/gridinfo_wrf.f90 | 2 ++ src/gsi/cplr_get_fv3_regional_ensperts.f90 | 2 +- src/gsi/gsi_rfv3io_mod.f90 | 1 + 5 files changed, 8 insertions(+), 1 deletion(-) diff --git a/src/enkf/gridinfo_fv3reg.f90 b/src/enkf/gridinfo_fv3reg.f90 index 4eff63c003..9a16f0ca03 100644 --- a/src/enkf/gridinfo_fv3reg.f90 +++ b/src/enkf/gridinfo_fv3reg.f90 @@ -79,6 +79,8 @@ module gridinfo character(len=max_varname_length),public, dimension(3) :: & vars2d_supported = [character(len=max_varname_length) :: & 'ps', 'pst', 'sst'] +character(len=max_varname_length),public, dimension(8) :: & + vars2d_landonly = (/'', '', '', '', '', '', '', '' /) real(r_single), allocatable, dimension(:) :: ak,bk,eta1_ll,eta2_ll integer (i_kind),public,allocatable,dimension(:,:):: nxlocgroup,nylocgroup integer(i_kind):: numproc_io_sub diff --git a/src/enkf/gridinfo_nmmb.f90 b/src/enkf/gridinfo_nmmb.f90 index d60b077f36..df6c22ee1e 100644 --- a/src/enkf/gridinfo_nmmb.f90 +++ b/src/enkf/gridinfo_nmmb.f90 @@ -25,6 +25,8 @@ module gridinfo 'cw', 'prse', 'ql', 'qr', 'qi', & 'qli', 'dbz', 'w'/) character(len=max_varname_length),public, dimension(2) :: vars2d_supported = (/ 'ps', 'sst' /) +character(len=max_varname_length),public, dimension(8) :: vars2d_landonly = (/'', '', '', '', '', '', '', '' /) + contains subroutine getgridinfo(fileprefix, reducedgrid) diff --git a/src/enkf/gridinfo_wrf.f90 b/src/enkf/gridinfo_wrf.f90 index f4f68a64c4..e67b827b41 100644 --- a/src/enkf/gridinfo_wrf.f90 +++ b/src/enkf/gridinfo_wrf.f90 @@ -77,6 +77,8 @@ module gridinfo ! supported variable names in anavinfo character(len=max_varname_length),public, dimension(19) :: vars3d_supported = (/'u ', 'v ', 'tv ', 'q ', 'w ', 'cw ', 'ph ', 'ql ', 'qr ', 'qs ', 'qg ', 'qi ', 'qni ', 'qnr ', 'qnc ', 'dbz ', 'oz ', 'tsen', 'prse' /) character(len=max_varname_length),public, dimension(2) :: vars2d_supported = (/ 'ps ', 'sst' /) + character(len=max_varname_length),public, dimension(8) :: vars2d_landonly = (/'', '', '', '', '', '', '', '' /) + contains diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 index 512560f278..9b841f012c 100644 --- a/src/gsi/cplr_get_fv3_regional_ensperts.f90 +++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90 @@ -430,7 +430,7 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) if(.not.l_use_dbz_directDA .and. if_model_dbz .and. .not.if_model_fed) i_caseflag=2 ! only if_model_fed is true - if(.not.l_use_dbz_directDA .and. .not.if_model_dbz .and. .not.if_model_fed) i_caseflag=3 + if(.not.l_use_dbz_directDA .and. .not.if_model_dbz .and. if_model_fed) i_caseflag=3 ! l_use_dbz_directDA=.true. and if_model_fed=.true. if(l_use_dbz_directDA .and. .not.if_model_dbz .and. if_model_fed) i_caseflag=4 diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 51c32eb7aa..b3f3488a70 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -2239,6 +2239,7 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) do k=ndimensions+1,nvariables iret=nf90_inquire_variable(gfile_loc,k,name,len) if(trim(name)=='PHIS' .or. trim(name)=='phis' ) then + sfc_var_exist(k_orog) = .true. iret=nf90_inquire_variable(gfile_loc,k,ndims=ndim) if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 From fca6bea4e5c737efe53fd053ca9cc69033f847f7 Mon Sep 17 00:00:00 2001 From: James Jung Date: Tue, 27 Feb 2024 13:08:05 -0500 Subject: [PATCH 061/109] CrIS viirs bug fix (#708) --- src/gsi/read_cris.f90 | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/gsi/read_cris.f90 b/src/gsi/read_cris.f90 index b8bf4ff92b..d5668f8864 100644 --- a/src/gsi/read_cris.f90 +++ b/src/gsi/read_cris.f90 @@ -334,14 +334,18 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& spc_filename = trim(crtm_coeffs_path)//'viirs-m_n20.SpcCoeff.bin' sensorlist_imager = 'viirs-m_n20' inquire(file=trim(spc_filename), exist=imager_coeff) - if ( .not. imager_coeff ) spc_filename = trim(crtm_coeffs_path)//'viirs-m_j1.SpcCoeff.bin' - sensorlist_imager = 'viirs-m_j1' + if ( .not. imager_coeff ) then + spc_filename = trim(crtm_coeffs_path)//'viirs-m_j1.SpcCoeff.bin' + sensorlist_imager = 'viirs-m_j1' + endif elseif ( trim(jsatid) == 'n21' ) then spc_filename = trim(crtm_coeffs_path)//'viirs-m_n21.SpcCoeff.bin' sensorlist_imager = 'viirs-m_n21' inquire(file=trim(spc_filename), exist=imager_coeff) - if ( .not. imager_coeff ) spc_filename = trim(crtm_coeffs_path)//'viirs-m_j2.SpcCoeff.bin' - sensorlist_imager = 'viirs-m_j2' + if ( .not. imager_coeff ) then + spc_filename = trim(crtm_coeffs_path)//'viirs-m_j2.SpcCoeff.bin' + sensorlist_imager = 'viirs-m_j2' + endif endif inquire(file=trim(spc_filename), exist=imager_coeff) if ( imager_coeff ) then From f282a9447e9d3c37e7866a7c9cebb96c0bb5068b Mon Sep 17 00:00:00 2001 From: xincjin-NOAA <122945910+xincjin-NOAA@users.noreply.github.com> Date: Tue, 12 Mar 2024 14:02:12 -0400 Subject: [PATCH 062/109] Assimilate GMI in GSI (#692) --- regression/global_4denvar.sh | 55 +++++----- regression/global_enkf.sh | 19 ++-- regression/regression_namelists.sh | 2 +- regression/regression_var.sh | 2 +- src/gsi/clw_mod.f90 | 2 +- src/gsi/deter_sfc_mod.f90 | 138 +++++++++----------------- src/gsi/radiance_mod.f90 | 6 +- src/gsi/read_gmi.f90 | 6 +- src/gsi/setuprad.f90 | 13 +-- src/gsi/ssmis_spatial_average_mod.f90 | 29 ++---- 10 files changed, 106 insertions(+), 166 deletions(-) diff --git a/regression/global_4denvar.sh b/regression/global_4denvar.sh index 08a62f5eb0..056815228b 100755 --- a/regression/global_4denvar.sh +++ b/regression/global_4denvar.sh @@ -55,14 +55,15 @@ cycg=`echo $gdate | cut -c9-10` dumpobs=gdas prefix_obs=${dumpobs}.t${cyca}z prefix_ges=gdas.t${cycg}z -prefix_ens=gdas.t${cycg}z +prefix_ens=enkfgdas.t${cycg}z suffix=tm00.bufr_d dumpges=gdas COMROOTgfs=$casesdir/gfs/prod -datobs=$COMROOTgfs/$dumpobs.$PDYa/${cyca}/atmos -datges=$COMROOTgfs/$dumpges.$PDYg/${cycg}/atmos -datens=$COMROOTgfs/enkfgdas.$PDYg/${cycg}/atmos +datobs=$COMROOTgfs/$dumpobs.$PDYa/${cyca}/obs +dathis=$COMROOTgfs/$dumpges.$PDYg/${cycg}/model_data/atmos/history +datanl=$COMROOTgfs/gdas.$PDYg/${cycg}/analysis/atmos +datens=$COMROOTgfs/enkfgdas.$PDYg/${cycg} # Set up $tmpdir @@ -265,28 +266,28 @@ $nln $datobs/${prefix_obs}.esatms.${suffix} ./atmsbufrears ## $nln $datobs/${prefix_obs}.amsr2.tm00.bufr_d ./amsr2bufr # Copy bias correction, atmospheric and surface files -$nln $datges/${prefix_ges}.abias ./satbias_in -$nln $datges/${prefix_ges}.abias_pc ./satbias_pc -$nln $datges/${prefix_ges}.abias_air ./aircftbias_in -$nln $datges/${prefix_ges}.radstat ./radstat.gdas - -$nln $datges/${prefix_ges}.sfcf003.nc ./sfcf03 -$nln $datges/${prefix_ges}.sfcf004.nc ./sfcf04 -$nln $datges/${prefix_ges}.sfcf005.nc ./sfcf05 -$nln $datges/${prefix_ges}.sfcf006.nc ./sfcf06 -$nln $datges/${prefix_ges}.sfcf007.nc ./sfcf07 -$nln $datges/${prefix_ges}.sfcf008.nc ./sfcf08 -$nln $datges/${prefix_ges}.sfcf009.nc ./sfcf09 - -$nln $datges/${prefix_ges}.atmf003.nc ./sigf03 -$nln $datges/${prefix_ges}.atmf004.nc ./sigf04 -$nln $datges/${prefix_ges}.atmf005.nc ./sigf05 -$nln $datges/${prefix_ges}.atmf006.nc ./sigf06 -$nln $datges/${prefix_ges}.atmf007.nc ./sigf07 -$nln $datges/${prefix_ges}.atmf008.nc ./sigf08 -$nln $datges/${prefix_ges}.atmf009.nc ./sigf09 - -$nln $datens/${prefix_ens}.sfcf006.ensmean.nc ./sfcf06_anlgrid +$nln $datanl/${prefix_ges}.abias ./satbias_in +$nln $datanl/${prefix_ges}.abias_pc ./satbias_pc +$nln $datanl/${prefix_ges}.abias_air ./aircftbias_in +$nln $datanl/${prefix_ges}.radstat ./radstat.gdas + +$nln $dathis/${prefix_ges}.sfcf003.nc ./sfcf03 +$nln $dathis/${prefix_ges}.sfcf004.nc ./sfcf04 +$nln $dathis/${prefix_ges}.sfcf005.nc ./sfcf05 +$nln $dathis/${prefix_ges}.sfcf006.nc ./sfcf06 +$nln $dathis/${prefix_ges}.sfcf007.nc ./sfcf07 +$nln $dathis/${prefix_ges}.sfcf008.nc ./sfcf08 +$nln $dathis/${prefix_ges}.sfcf009.nc ./sfcf09 + +$nln $dathis/${prefix_ges}.atmf003.nc ./sigf03 +$nln $dathis/${prefix_ges}.atmf004.nc ./sigf04 +$nln $dathis/${prefix_ges}.atmf005.nc ./sigf05 +$nln $dathis/${prefix_ges}.atmf006.nc ./sigf06 +$nln $dathis/${prefix_ges}.atmf007.nc ./sigf07 +$nln $dathis/${prefix_ges}.atmf008.nc ./sigf08 +$nln $dathis/${prefix_ges}.atmf009.nc ./sigf09 + +$nln $datens/ensstat/model_data/atmos/history/${prefix_ens}.sfcf006.ensmean.nc ./sfcf06_anlgrid export ENS_PATH='./ensemble_data/' mkdir -p ${ENS_PATH} @@ -296,7 +297,7 @@ for fh in $flist; do imem=1 while [[ $imem -le $NMEM_ENKF ]]; do member="mem"`printf %03i $imem` - $nln $datens/$member/$sigens ${ENS_PATH}sigf${fh}_ens_${member} + $nln $datens/$member/model_data/atmos/history/$sigens ${ENS_PATH}sigf${fh}_ens_${member} (( imem = $imem + 1 )) done done diff --git a/regression/global_enkf.sh b/regression/global_enkf.sh index e458c5830d..ca40abda52 100755 --- a/regression/global_enkf.sh +++ b/regression/global_enkf.sh @@ -51,17 +51,14 @@ cyca=`echo $global_adate | cut -c9-10` PDYg=`echo $gdate | cut -c1-8` cycg=`echo $gdate | cut -c9-10` -dumpobs=gdas -prefix_obs=${dumpobs}.t${cyca}z -prefix_ges=gdas.t${cycg}z -prefix_ens=gdas.t${cycg}z +prefix_obs=enkfgdas.t${cyca}z +prefix_ens=enkfgdas.t${cycg}z suffix=tm00.bufr_d dumpges=gdas COMROOTgfs=$casesdir/gfs/prod -datobs=$COMROOTgfs/enkfgdas.$PDYa/${cyca}/atmos -datges=$COMROOTgfs/$dumpges.$PDYg/${cycg}/atmos -datens=$COMROOTgfs/enkfgdas.$PDYg/${cycg}/atmos +datobs=$COMROOTgfs/enkfgdas.$PDYa/${cyca}/ensstat/analysis/atmos +datens=$COMROOTgfs/enkfgdas.$PDYg/${cycg} # Set up $tmpdir @@ -166,19 +163,19 @@ nfhrs=`echo $IAUFHRS_ENKF | sed 's/,/ /g'` for fhr in $nfhrs; do for imem in $(seq 1 $NMEM_ENKF); do memchar="mem"$(printf %03i $imem) - $nln $datens/$memchar/${prefix_ens}.atmf00${fhr}.nc sfg_${global_adate}_fhr0${fhr}_${memchar} + $nln $datens/$memchar/model_data/atmos/history/${prefix_ens}.atmf00${fhr}.nc sfg_${global_adate}_fhr0${fhr}_${memchar} if [ $cnvw_option = ".true." ]; then - $nln $datens/$memchar/${prefix_ens}sfcf00${fhr}.nc sfgsfc_${global_adate}_fhr0${fhr}_${memchar} + $nln $datens/$memchar/model_data/atmos/history/${prefix_ens}sfcf00${fhr}.nc sfgsfc_${global_adate}_fhr0${fhr}_${memchar} fi (( imem = $imem + 1 )) done - $nln $datens/${prefix_ens}.atmf00${fhr}.ensmean.nc sfg_${global_adate}_fhr0${fhr}_ensmean + $nln $datens/ensstat/model_data/atmos/history/${prefix_ens}.atmf00${fhr}.ensmean.nc sfg_${global_adate}_fhr0${fhr}_ensmean if [ $cnvw_option = ".true." ]; then $nln $datens/${prefix_ens}.sfcf00${fhr}.ensmean.nc sfgsfc_${global_adate}_fhr0${fhr}_ensmean fi done -$nln $datobs/${prefix_obs}.abias_int ./satbias_in +$nln $datobs/${prefix_obs}.abias_int.ensmean ./satbias_in cd $tmpdir diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh index 552bc1ba59..7ca183ef3e 100755 --- a/regression/regression_namelists.sh +++ b/regression/regression_namelists.sh @@ -181,7 +181,7 @@ OBS_INPUT:: sstviirs viirs-m j1 viirs-m_j1 0.0 4 0 abibufr abi g18 abi_g18 0.0 1 0 ahibufr ahi himawari9 ahi_himawari9 0.0 1 0 - atmsbufr atms n21 atms_n21 0.0 1 1 + atmsbufr atms n21 atms_n21 0.0 1 0 crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 1 0 sstviirs viirs-m j2 viirs-m_j2 0.0 4 0 ompsnpbufr ompsnp n21 ompsnp_n21 0.0 0 0 diff --git a/regression/regression_var.sh b/regression/regression_var.sh index 9d91b2c41f..315028675c 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -190,7 +190,7 @@ export savdir="$ptmp" export JCAP="62" # Case Study analysis dates -export global_adate="2022110900" +export global_adate="2024022300" export rtma_adate="2020022420" export fv3_netcdf_adate="2017030100" export rrfs_3denvar_glbens_adate="2021072518" diff --git a/src/gsi/clw_mod.f90 b/src/gsi/clw_mod.f90 index 512aaded01..49387f05eb 100644 --- a/src/gsi/clw_mod.f90 +++ b/src/gsi/clw_mod.f90 @@ -2019,7 +2019,7 @@ subroutine gmi_37pol_diff(tb37v,tb37h,tsim37v,tsim37h,clw,ierrret) clw = one - (tb37v-tb37h)/(tsim37v-tsim37h) clw=max(zero,clw) - if(tb37h > tb37v) then + if ((tb37h > tb37v) .or. (tb37h > 500_r_kind )) then ierrret = 1 clw= r1000 endif diff --git a/src/gsi/deter_sfc_mod.f90 b/src/gsi/deter_sfc_mod.f90 index 300d36cffb..271e81c5d2 100644 --- a/src/gsi/deter_sfc_mod.f90 +++ b/src/gsi/deter_sfc_mod.f90 @@ -33,7 +33,7 @@ module deter_sfc_mod use satthin, only: sno_full,isli_full,sst_full,soil_moi_full, & soil_temp_full,soil_type_full,veg_frac_full,veg_type_full, & fact10_full,zs_full,sfc_rough_full,zs_full_gfs - use constants, only: zero,one,two,one_tenth,deg2rad,rad2deg + use constants, only: zero,one,two,one_tenth,deg2rad,rad2deg, rearth use gridmod, only: nlat,nlon,regional,tll2xy,nlat_sfc,nlon_sfc,rlats_sfc,rlons_sfc, & rlats,rlons,dx_gfs,txy2ll,lpl_gfs use guess_grids, only: nfldsfc,hrdifsfc,ntguessfc @@ -1331,7 +1331,7 @@ subroutine deter_sfc_amsre_low(dlat_earth,dlon_earth,isflg,sfcpct) end subroutine deter_sfc_amsre_low -subroutine deter_sfc_gmi(dlat_earth,dlon_earth,isflg,sfcpct) +subroutine deter_sfc_gmi(dlat_earth,dlon_earth,isflg) !$$$ subprogram documentation block ! . . . . ! subprogram: deter_sfc_gmi determine land surface type @@ -1354,11 +1354,6 @@ subroutine deter_sfc_gmi(dlat_earth,dlon_earth,isflg,sfcpct) ! 2 sea ice ! 3 snow ! 4 mixed -! sfcpct(0:3)- percentage of 4 surface types -! (0) - sea percentage -! (1) - land percentage -! (2) - sea ice percentage -! (3) - snow percentage ! ! attributes: ! language: f90 @@ -1370,15 +1365,11 @@ subroutine deter_sfc_gmi(dlat_earth,dlon_earth,isflg,sfcpct) real(r_kind) ,intent(in ) :: dlat_earth,dlon_earth integer(i_kind) ,intent( out) :: isflg - real(r_kind),dimension(0:3),intent( out) :: sfcpct - - integer(i_kind) jsli,it - integer(i_kind):: klat1,klon1,klatp1,klonp1 - real(r_kind):: dx,dy,dx1,dy1,w00,w10,w01,w11 - real(r_kind) :: dlat,dlon + integer(i_kind) jsli,it, i, j + integer(i_kind):: klat1,klon1,klatp1,klonp1, ksmall, klarge, n_grid + real(r_kind) :: dlat,dlon, grid_dist + integer(i_kind):: klatn,klonn,klatpn,klonpn logical :: outside - integer(i_kind):: klat2,klon2,klatp2,klonp2 - ! ! For interpolation, we usually use o points (4points for land sea decision) ! In case of lowfreq channel (Large FOV), add the check of x points(8 points) @@ -1407,90 +1398,55 @@ subroutine deter_sfc_gmi(dlat_earth,dlon_earth,isflg,sfcpct) end if 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_sfc); klon1=min(max(0,klon1),nlon_sfc) if(klon1==0) klon1=nlon_sfc klatp1=min(nlat_sfc,klat1+1); klonp1=klon1+1 - if(klonp1==nlon_sfc+1) klonp1=1 - klonp2 = klonp1+1 - if(klonp2==nlon_sfc+1) klonp2=1 - klon2=klon1-1 - if(klon2==0)klon2=nlon_sfc - klat2=max(1,klat1-1) - klatp2=min(nlat_sfc,klatp1+1) ! Set surface type flag. Begin by assuming obs over ice-free water - sfcpct = zero - - jsli = isli_full(klat1 ,klon1 ) - if(sno_full(klat1 ,klon1 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klatp1,klon1 ) - if(sno_full(klatp1 ,klon1 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klat1 ,klonp1) - if(sno_full(klat1 ,klonp1 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klatp1,klonp1) - if(sno_full(klatp1 ,klonp1 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klatp2,klon1) - if(sno_full(klatp2 ,klon1 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klatp2,klonp1) - if(sno_full(klatp2 ,klonp1 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klatp1,klon2) - if(sno_full(klatp1 ,klon2 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klatp1,klonp2) - if(sno_full(klatp1 ,klonp2 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klat1,klon2) - if(sno_full(klat1 ,klon2 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klat1,klonp2) - if(sno_full(klat1 ,klonp2 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klat2,klon1) - if(sno_full(klat2 ,klon1 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klat2,klonp1) - if(sno_full(klat2 ,klonp1 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - sfcpct=sfcpct/12.0_r_kind - -! sfcpct(3)=min(sfcpct(3),sfcpct(1)) -! sfcpct(1)=max(zero,sfcpct(1)-sfcpct(3)) - - if(sfcpct(0) > 0.99_r_kind)then - isflg = 0 - else if(sfcpct(1) > 0.99_r_kind)then - isflg = 1 - else if(sfcpct(2) > 0.99_r_kind)then - isflg = 2 - else if(sfcpct(3) > 0.99_r_kind)then - isflg = 3 - else - isflg = 4 - end if + grid_dist=rearth * (rlats_sfc(klatp1) - rlats_sfc(klat1)) + n_grid=int(40000 / grid_dist) + 1 + klatn = max(klat1 - n_grid, 1) + klonn = klon1 - n_grid + if (klonn < 0) klonn = nlon_sfc - klonn + klatpn = min((klat1 + n_grid), nlat_sfc) + klonpn = klon1 + n_grid + if (klonpn > nlon_sfc) klonpn = klonpn - nlon_sfc + + isflg=0 + outer: do i = klatn, klatpn + ! assume n_grid > 2 + if (0 < klonpn - klonn .and. klonpn - klonn < nlon_sfc / 2) then + do j = klonn, klonpn + if (isli_full(i, j) /= 0) then + isflg = 1 + exit outer + end if + end do + else + if (klonpn < klonn) then + ksmall = klonpn + klarge = klonn + else + ksmall = klonn + klarge = klonpn + end if + do j = 1, ksmall + if (isli_full(i, j) /= 0) then + isflg = 1 + exit outer + endif + end do + do j = klarge, nlon_sfc + if (isli_full(i, j) /= 0) then + isflg = 1 + exit outer + end if + end do + end if + end do outer return end subroutine deter_sfc_gmi diff --git a/src/gsi/radiance_mod.f90 b/src/gsi/radiance_mod.f90 index 60aa0bc3cd..aae7794957 100644 --- a/src/gsi/radiance_mod.f90 +++ b/src/gsi/radiance_mod.f90 @@ -1326,11 +1326,7 @@ subroutine radiance_ex_biascor_gmi(radmod,clw_obs,clw_guess_retrieval,nchanl,cld do i=1,nchanl if (radmod%lcloud4crtm(i)<0) cycle - if (clw_obs <= cclr(i) .and. clw_guess_retrieval <= cclr(i) .and. abs(clw_obs-clw_guess_retrieval) < 0.001_r_kind) then - cld_rbc_idx(i)=one !clear/clear - else - cld_rbc_idx(i)=zero - endif + if ((clw_obs-cclr(i))*(clw_guess_retrieval-cclr(i))=0.005_r_kind) cld_rbc_idx(i)=zero end do return diff --git a/src/gsi/read_gmi.f90 b/src/gsi/read_gmi.f90 index f54263b129..6ad4d829a3 100644 --- a/src/gsi/read_gmi.f90 +++ b/src/gsi/read_gmi.f90 @@ -184,7 +184,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& integer(i_kind) :: jc,bufsat,n integer(i_kind),dimension(5):: iobsdate integer(i_kind):: method,iobs,num_obs - integer(i_kind),parameter :: maxobs=4000000 + integer(i_kind),parameter :: maxobs=6000000 !-- integer(i_kind),parameter :: nscan=74 ! after binning ifov, 221/3 + 1 integer(i_kind),parameter :: nscan=221 @@ -414,7 +414,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& call ufbrep(lnbufr,var_check1,1,nchanl,iret,'GMICHQ') !call ufbrep(lnbufr,gmirfi,1,nchanl,iret,'GMIRFI') call ufbrep(lnbufr,pixelsaza,1,ngs,iret,'SAZA') - call ufbrep(lnbufr,val_angls,n_angls,ngs,iret,'SAMA SZA SMA SGA') + call ufbrep(lnbufr,val_angls,n_angls,ngs,iret,'BEARAZ SOZA SOLAZI SSGA') call ufbint(lnbufr,pixelloc,2, 1,iret,'CLATH CLONH') if (any(var_check1 < 99999999999_r_double)) then ! 100000000000 seems to be the missing value @@ -696,7 +696,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& call deter_sfc(dlat,dlon,dlat_earth,dlon_earth,t4dv,isflg,idomsfc,sfcpct, & ts,tsavg,vty,vfr,sty,stp,sm,sn,zz,ff10,sfcr) - call deter_sfc_gmi(dlat_earth,dlon_earth,isflg,sfcpct) + call deter_sfc_gmi(dlat_earth,dlon_earth,isflg) ! Only keep obs over ocean - ej diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 index ad8ccbc4e6..136568d1f3 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -1099,6 +1099,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif predbias=zero + !$omp parallel do schedule(dynamic,1) private(i,mm,j,k,tlap,node,bias) do i=1,nchanl mm=ich(i) @@ -1177,7 +1178,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& end do end if - do j = 1,npred predbias(j,i) = predchan(j,i)*pred(j,i) end do @@ -1263,8 +1263,8 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& if(amsua.or.atms) then call ret_amsua(tsim_bc,nchanl,tsavg5,zasat,clw_guess_retrieval,ierrret) else if(gmi) then - call gmi_37pol_diff(tsim_bc(6),tsim_bc(7),tsim_clr_bc(6),tsim_clr_bc(7),clw_guess_retrieval,ierrret) - call gmi_37pol_diff(tb_obs(6),tb_obs(7),tsim_clr_bc(6),tsim_clr_bc(7),clw_obs,ierrret) + call gmi_37pol_diff(tsim(6),tsim(7),tsim_clr(6),tsim_clr(7),clw_guess_retrieval,ierrret) + call gmi_37pol_diff(tb_obs(6),tb_obs(7),tsim_clr(6),tsim_clr(7),clw_obs,ierrret) end if if (radmod%ex_obserr=='ex_obserr1') then call radiance_ex_biascor(radmod,nchanl,tsim_bc,tsavg5,zasat, & @@ -1298,11 +1298,12 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& do i=1,nchanl pred(6,i) = zero pred(7,i) = zero - clw_avg = half*(clw_obs+clw_guess_retrieval) +! Need to investigate clw_ave = half*(clw_obs+clw_guess_retrieval) + clw_avg = zero if (i > 3 .and. clw_obs > 0.05_r_kind .and. clw_guess_retrieval > 0.05_r_kind .and. & - abs(clw_obs-clw_guess_retrieval) < 0.005_r_kind .and. clw_avg < 0.5_r_kind) cld_rbc_idx2(i) = one + abs(clw_obs-clw_guess_retrieval) < 0.005_r_kind .and. clw_avg < 0.5_r_kind) cld_rbc_idx2(i) = zero if (i < 5 .and. clw_obs > 0.2_r_kind .and. clw_guess_retrieval > 0.2_r_kind .and. & - abs(clw_obs-clw_guess_retrieval) < 0.005_r_kind .and. clw_avg < 0.5_r_kind) cld_rbc_idx2(i) = one + abs(clw_obs-clw_guess_retrieval) < 0.005_r_kind .and. clw_avg < 0.5_r_kind) cld_rbc_idx2(i) = zero if( i > 3 .and. clw_obs > 0.05_r_kind .and. clw_guess_retrieval > 0.05_r_kind .and. cld_rbc_idx(i) == zero) then pred(6,i) = clw_avg*clw_avg diff --git a/src/gsi/ssmis_spatial_average_mod.f90 b/src/gsi/ssmis_spatial_average_mod.f90 index 64dd5c6cf7..30b69c6223 100644 --- a/src/gsi/ssmis_spatial_average_mod.f90 +++ b/src/gsi/ssmis_spatial_average_mod.f90 @@ -682,26 +682,15 @@ SUBROUTINE SSMIS_Spatial_Average(BufrSat, Method, Num_Obs, NChanl, & ! Define grid box by channel - ! Ch 1-2: 1 scan direction, 1 track direction ! Ch 3-13: 3 scan direction, 3 track direction - if ((ic == 1) .or. (ic == 2)) then - ns1 = iscan - ns2 = iscan - if (ns1 < 1) ns1=1 - if (ns2 > max_scan) ns2=max_scan - np1 = ifov - np2 = ifov - if (np1 < 1) np1=1 - if (np2 > max_fov_gmi) np2=max_fov_gmi - else if ((ic > 2) .and. (ic < 14)) then - ns1 = iscan-1 - ns2 = iscan+1 - if (ns1 < 1) ns1=1 - if (ns2 > max_scan) ns2=max_scan - np1 = ifov-1 - np2 = ifov+1 - if (np1 < 1) np1=1 - if (np2 > max_fov_gmi) np2=max_fov_gmi - endif + ns1 = iscan-4 + ns2 = iscan+4 + if (ns1 < 1) ns1=1 + if (ns2 > max_scan) ns2=max_scan + np1 = ifov-8 + np2 = ifov+8 + if (np1 < 1) np1=1 + if (np2 > max_fov_gmi) np2=max_fov_gmi xnum = 0.0_r_kind mta = 0.0_r_kind if (any(bt_image_orig(np1:np2,ns1:ns2,ic) < btmin .or. & @@ -716,7 +705,7 @@ SUBROUTINE SSMIS_Spatial_Average(BufrSat, Method, Num_Obs, NChanl, & lat2 = latitude(ip,is) lon2 = longitude(ip,is) dist = distance(lat1,lon1,lat2,lon2) - if (dist > 50.0_r_kind) cycle gmi_box_x1 ! outside the box + if (dist > 20.0_r_kind) cycle gmi_box_x1 ! outside the box if (gaussian_wgt) then wgt = exp(-0.5_r_kind*(dist/sigma)*(dist/sigma)) else From a8d670c9f7096b2c7ac81801d6f2146b6c08bf4c Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Thu, 14 Mar 2024 11:55:05 -0400 Subject: [PATCH 063/109] Update fix submodule (Rcov_crisn21) & GSI_BINARY_SOURCE_DIR (#718) --- fix | 2 +- modulefiles/gsi_gaea.intel.lua | 2 +- modulefiles/gsi_hera.gnu.lua | 2 +- modulefiles/gsi_hera.intel.lua | 2 +- modulefiles/gsi_hercules.intel.lua | 2 +- modulefiles/gsi_jet.intel.lua | 2 +- modulefiles/gsi_orion.intel.lua | 2 +- modulefiles/gsi_s4.intel.lua | 2 +- modulefiles/gsi_wcoss2.intel.lua | 2 +- 9 files changed, 9 insertions(+), 9 deletions(-) diff --git a/fix b/fix index 298bdc0f56..92de100c4d 160000 --- a/fix +++ b/fix @@ -1 +1 @@ -Subproject commit 298bdc0f56692ad25141a946177e5d88884e367a +Subproject commit 92de100c4d5893e9d6409afbdda6937b0de1cb3b diff --git a/modulefiles/gsi_gaea.intel.lua b/modulefiles/gsi_gaea.intel.lua index ef6b9ddba7..96643202a7 100644 --- a/modulefiles/gsi_gaea.intel.lua +++ b/modulefiles/gsi_gaea.intel.lua @@ -31,7 +31,7 @@ local MKLROOT="/opt/intel/oneapi/mkl/2022.0.2/" prepend_path("LD_LIBRARY_PATH",pathJoin(MKLROOT,"lib/intel64")) pushenv("MKLROOT", MKLROOT) -pushenv("GSI_BINARY_SOURCE_DIR", "/lustre/f2/dev/role.epic/contrib/GSI_data/fix/20230911") +pushenv("GSI_BINARY_SOURCE_DIR", "/lustre/f2/dev/role.epic/contrib/GSI_data/fix/20240208") setenv("CC","cc") setenv("FC","ftn") diff --git a/modulefiles/gsi_hera.gnu.lua b/modulefiles/gsi_hera.gnu.lua index d85e79b005..eab352553f 100644 --- a/modulefiles/gsi_hera.gnu.lua +++ b/modulefiles/gsi_hera.gnu.lua @@ -22,6 +22,6 @@ load("gsi_common") load(pathJoin("prod_util", prod_util_ver)) load(pathJoin("openblas", openblas_ver)) -pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20230911") +pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20240208") whatis("Description: GSI environment on Hera with GNU Compilers") diff --git a/modulefiles/gsi_hera.intel.lua b/modulefiles/gsi_hera.intel.lua index b967c32f74..2d36f375e0 100644 --- a/modulefiles/gsi_hera.intel.lua +++ b/modulefiles/gsi_hera.intel.lua @@ -20,6 +20,6 @@ load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-xHOST") pushenv("FFLAGS", "-xHOST") -pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20230911") +pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20240208") whatis("Description: GSI environment on Hera with Intel Compilers") diff --git a/modulefiles/gsi_hercules.intel.lua b/modulefiles/gsi_hercules.intel.lua index c72323cbad..66ec9b03e1 100644 --- a/modulefiles/gsi_hercules.intel.lua +++ b/modulefiles/gsi_hercules.intel.lua @@ -21,6 +21,6 @@ load("intel-oneapi-mkl/2022.2.1") pushenv("CFLAGS", "-xHOST") pushenv("FFLAGS", "-xHOST") -pushenv("GSI_BINARY_SOURCE_DIR", "/work/noaa/global/glopara/fix/gsi/20230911") +pushenv("GSI_BINARY_SOURCE_DIR", "/work/noaa/global/glopara/fix/gsi/20240208") whatis("Description: GSI environment on Hercules with Intel Compilers") diff --git a/modulefiles/gsi_jet.intel.lua b/modulefiles/gsi_jet.intel.lua index b2b98be7ff..cc43e98260 100644 --- a/modulefiles/gsi_jet.intel.lua +++ b/modulefiles/gsi_jet.intel.lua @@ -20,6 +20,6 @@ load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-axSSE4.2,AVX,CORE-AVX2") pushenv("FFLAGS", "-axSSE4.2,AVX,CORE-AVX2") -pushenv("GSI_BINARY_SOURCE_DIR", "/mnt/lfs4/HFIP/hfv3gfs/glopara/git/fv3gfs/fix/gsi/20230911") +pushenv("GSI_BINARY_SOURCE_DIR", "/mnt/lfs4/HFIP/hfv3gfs/glopara/git/fv3gfs/fix/gsi/20240208") whatis("Description: GSI environment on Jet with Intel Compilers") diff --git a/modulefiles/gsi_orion.intel.lua b/modulefiles/gsi_orion.intel.lua index 114e5f8ad1..03ea22018d 100644 --- a/modulefiles/gsi_orion.intel.lua +++ b/modulefiles/gsi_orion.intel.lua @@ -20,6 +20,6 @@ load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-xHOST") pushenv("FFLAGS", "-xHOST") -pushenv("GSI_BINARY_SOURCE_DIR", "/work/noaa/global/glopara/fix/gsi/20230911") +pushenv("GSI_BINARY_SOURCE_DIR", "/work/noaa/global/glopara/fix/gsi/20240208") whatis("Description: GSI environment on Orion with Intel Compilers") diff --git a/modulefiles/gsi_s4.intel.lua b/modulefiles/gsi_s4.intel.lua index 08e3d38516..04945eef3e 100644 --- a/modulefiles/gsi_s4.intel.lua +++ b/modulefiles/gsi_s4.intel.lua @@ -20,6 +20,6 @@ load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-march=ivybridge") pushenv("FFLAGS", "-march=ivybridge") -pushenv("GSI_BINARY_SOURCE_DIR", "/data/prod/glopara/fix/gsi/20230911") +pushenv("GSI_BINARY_SOURCE_DIR", "/data/prod/glopara/fix/gsi/20240208") whatis("Description: GSI environment on S4 with Intel Compilers") diff --git a/modulefiles/gsi_wcoss2.intel.lua b/modulefiles/gsi_wcoss2.intel.lua index 28b2f0d09d..c3bfd1156c 100644 --- a/modulefiles/gsi_wcoss2.intel.lua +++ b/modulefiles/gsi_wcoss2.intel.lua @@ -46,6 +46,6 @@ load(pathJoin("ncio", ncio_ver)) load(pathJoin("crtm", crtm_ver)) load(pathJoin("ncdiag",ncdiag_ver)) -pushenv("GSI_BINARY_SOURCE_DIR", "/lfs/h2/emc/global/noscrub/emc.global/FIX/fix/gsi/20230911") +pushenv("GSI_BINARY_SOURCE_DIR", "/lfs/h2/emc/global/noscrub/emc.global/FIX/fix/gsi/20240208") whatis("Description: GSI environment on WCOSS2") From 8d740a764d1b9d32e11cf1d0b4dd0ca26873871f Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Mon, 18 Mar 2024 15:26:36 -0400 Subject: [PATCH 064/109] Update read_ozone.f90 to handle GOME data before and after 20240131 18Z (#721) --- src/gsi/read_ozone.f90 | 61 +++++++++++++++++++++++++++++------------- 1 file changed, 42 insertions(+), 19 deletions(-) diff --git a/src/gsi/read_ozone.f90 b/src/gsi/read_ozone.f90 index 2ad95a858e..e6d3411d97 100644 --- a/src/gsi/read_ozone.f90 +++ b/src/gsi/read_ozone.f90 @@ -138,7 +138,7 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & character(8) subset,subset6,subset8,subset8_ompsnp character(49) ozstr,ozostr character(63) lozstr - character(51) ozgstr + character(51) ozgstr_v1,ozgstr_v2 character(27) ozgstr2 character(42) ozostr2 character(64) mlstr @@ -165,11 +165,12 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & ! maximum number of observations set to real(r_kind),allocatable,dimension(:,:):: ozout - real(r_double) toq,poq + real(r_double) toq,poq,orbn real(r_double),dimension(nloz_v6):: ozone_v6 real(r_double),dimension(29,nloz_v8):: ozone_v8 real(r_double),dimension(10):: hdroz - real(r_double),dimension(10):: hdrozg + integer(i_kind):: nhdrozg + real(r_double),allocatable,dimension(:):: hdrozg real(r_double),dimension(5):: hdrozg2 real(r_double),dimension(10):: hdrozo real(r_double),dimension(8) :: hdrozo2 @@ -195,8 +196,10 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & data lozstr & / 'OSP12 OSP11 OSP10 OSP9 OSP8 OSP7 OSP6 OSP5 OSP4 OSP3 OSP2 OSP1 ' / - data ozgstr & - / 'SAID CLAT CLON YEAR DOYR HOUR MINU SECO SOZA SOLAZI' / + data ozgstr_v1 & + / 'SAID CLAT CLON SOZA SOLAZI YEAR DOYR HOUR MINU SECO' / + data ozgstr_v2 & + / 'SAID CLAT CLON SOZA SOLAZI YEAR MNTH DAYS HOUR MINU SECO' / data ozgstr2 & / 'CLDMNT SNOC ACIDX STKO FOVN' / data ozostr & @@ -482,8 +485,19 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & cycle obsloop endif -! extract header information - call ufbint(lunin,hdrozg,10,1,iret,ozgstr) +! Test for BUFR version using ORBN mnemonic + call ufbint(lunin,orbn,1,1,iret,'ORBN') + if (orbn > 100000000.0_r_kind) then + nhdrozg = 11 + else + nhdrozg = 10 + endif + if (.not.allocated(hdrozg)) allocate(hdrozg(nhdrozg)) + if (nhdrozg == 11) then + call ufbint(lunin,hdrozg,nhdrozg,1,iret,ozgstr_v2) + else + call ufbint(lunin,hdrozg,nhdrozg,1,iret,ozgstr_v1) + endif call ufbint(lunin,hdrozg2,5,1,iret,ozgstr2) rsat = hdrozg(1); ksatid=rsat @@ -494,7 +508,7 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & if (ksatid /= kidsat) cycle obsloop ! NESDIS does not put a flag for high SZA gome-2 data (SZA > 84 degree) - if ( hdrozg(9) > r84 ) cycle obsloop + if ( hdrozg(4) > r84 ) cycle obsloop nmrecs=nmrecs+nloz+1 @@ -520,15 +534,24 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & endif ! Convert observation time to relative time - idate5(1) = hdrozg(4) !year - IDAYYR = hdrozg(5) ! Day of year - JULIAN = -31739 + 1461 * (idate5(1) + 4799) /4 & - -3 * ((idate5(1) + 4899) / 100) / 4 + IDAYYR - call w3fs26(JULIAN,idate5(1),idate5(2),idate5(3),IDAYWK,IDAYYR) -! idate5(2) month -! idate5(3) day - idate5(4) = hdrozg(6) !hour - idate5(5) = hdrozg(7) !minute + if (nhdrozg == 11) then + idate5(1) = hdrozg(6) !year + idate5(2) = hdrozg(7) !month + idate5(3) = hdrozg(8) !day + idate5(4) = hdrozg(9) !hour + idate5(5) = hdrozg(10) !minute + else + idate5(1) = hdrozg(6) !year + IDAYYR = hdrozg(7) ! Day of year + JULIAN = -31739 + 1461 * (idate5(1) + 4799) /4 & + -3 * ((idate5(1) + 4899) / 100) / 4 + IDAYYR + call w3fs26(JULIAN,idate5(1),idate5(2),idate5(3),IDAYWK,IDAYYR) +! idate5(2) month +! idate5(3) day + idate5(4) = hdrozg(8) !hour + idate5(5) = hdrozg(9) !minute + endif + call w3fs21(idate5,nmind) t4dv=real((nmind-iwinbgn),r_kind)*r60inv sstime=real(nmind,r_kind) @@ -574,8 +597,8 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & ozout(5,itx)=dlon_earth_deg ! earth relative longitude (degrees) ozout(6,itx)=dlat_earth_deg ! earth relative latitude (degrees) ozout(7,itx)=toq ! total ozone error flag - ozout(8,itx)=hdrozg(9) ! solar zenith angle - ozout(9,itx)=hdrozg(10) ! solar azimuth angle + ozout(8,itx)=hdrozg(4) ! solar zenith angle + ozout(9,itx)=hdrozg(5) ! solar azimuth angle ozout(10,itx)=hdrozg2(1) ! CLOUD AMOUNT IN SEGMENT ozout(11,itx)=hdrozg2(2) ! SNOW COVER ozout(12,itx)=hdrozg2(3) ! AEROSOL CONTAMINATION INDEX From dfb958fa9372c10c808d20e64f2955652017ee32 Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Mon, 18 Mar 2024 15:27:23 -0400 Subject: [PATCH 065/109] Update Hera intel modulefile to Rocky 8 (#715) --- modulefiles/gsi_hera.intel.lua | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modulefiles/gsi_hera.intel.lua b/modulefiles/gsi_hera.intel.lua index 2d36f375e0..d21b9195c3 100644 --- a/modulefiles/gsi_hera.intel.lua +++ b/modulefiles/gsi_hera.intel.lua @@ -1,7 +1,7 @@ help([[ ]]) -prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/spack-stack/spack-stack-1.6.0/envs/gsi-addon-dev/install/modulefiles/Core") +prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/spack-stack/spack-stack-1.6.0/envs/gsi-addon-dev-rocky8/install/modulefiles/Core") local python_ver=os.getenv("python_ver") or "3.11.6" local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.5.0" From 4e8107c0ae054bc9dcc7b9a2684479d97a1e4261 Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Tue, 19 Mar 2024 12:44:32 -0600 Subject: [PATCH 066/109] Add parallel netcdf read/write from EnKF for sfc files (paranc option) (#709) --- src/enkf/controlvec.f90 | 16 +- src/enkf/gridio_gfs.f90 | 453 +++++++++++++++++++++++++++++++++++++++- 2 files changed, 452 insertions(+), 17 deletions(-) diff --git a/src/enkf/controlvec.f90 b/src/enkf/controlvec.f90 index 808eae2e28..0961549634 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,ne +integer(i_kind) :: nb,nlev,ne integer(i_kind) :: q_ind integer(i_kind) :: ierr @@ -218,19 +218,23 @@ subroutine read_control() if (nproc == 0) t1 = mpi_wtime() call readgriddata_pnc(cvars3d,cvars2d,nc3d,nc2d,clevels,ncdim,nbackgrounds, & fgfileprefixes,fgsfcfileprefixes,reducedgrid,grdin,qsat) + if (nproc == 0) then + t2 = mpi_wtime() + print *,'time in readgrid_pnc on root',t2-t1,'secs' + end if end if if (nproc <= ntasks_io-1) then if (.not. paranc) then if (nproc == 0) t1 = mpi_wtime() call readgriddata(nanal1(nproc),nanal2(nproc),cvars3d,cvars2d,nc3d,nc2d,clevels,ncdim,nbackgrounds, & fgfileprefixes,fgsfcfileprefixes,reducedgrid,grdin,qsat) + if (nproc == 0) then + t2 = mpi_wtime() + print *,'time in readgrid on root',t2-t1,'secs' + end if end if !print *,'min/max qsat',nanal,'=',minval(qsat),maxval(qsat) q_ind = getindex(cvars3d, 'q') - if (nproc == 0) then - t2 = mpi_wtime() - print *,'time in readgridata on root',t2-t1,'secs' - end if if (pseudo_rh .and. q_ind > 0) then do ne=1,nanals_per_iotask do nb=1,nbackgrounds @@ -357,7 +361,7 @@ subroutine write_control(no_inflate_flag) endif deallocate(grdin_mean) t2 = mpi_wtime() - print *,'time in write_control on root',t2-t1,'secs' + print *,'time in write_control paranc on root',t2-t1,'secs' endif end if diff --git a/src/enkf/gridio_gfs.f90 b/src/enkf/gridio_gfs.f90 index 8afb012fcf..35a0c3fbe4 100644 --- a/src/enkf/gridio_gfs.f90 +++ b/src/enkf/gridio_gfs.f90 @@ -89,15 +89,21 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & real(r_kind), dimension(ndimspec) :: vrtspec,divspec real(r_kind), allocatable, dimension(:) :: psg,pstend,ak,bk real(r_single),allocatable,dimension(:,:,:) :: ug3d,vg3d - type(Dataset) :: dset + type(Dataset) :: dset, dset_sfc type(Dimension) :: londim,latdim,levdim integer(i_kind) :: u_ind, v_ind, tv_ind, q_ind, oz_ind, cw_ind integer(i_kind) :: qr_ind, qs_ind, qg_ind integer(i_kind) :: tsen_ind, ql_ind, qi_ind, prse_ind integer(i_kind) :: ps_ind, pst_ind, sst_ind + ! surface + integer(i_kind) :: tmp2m_ind, spfh2m_ind, soilt1_ind, soilt2_ind, soilt3_ind + integer(i_kind) :: soilt4_ind,slc1_ind, slc2_ind, slc3_ind, slc4_ind integer(i_kind) :: k,iret,nb,i,imem,idvc,nlonsin,nlatsin,nlevsin,ne,nanal + ! surface + integer(i_kind) :: nlonsin_sfc,nlatsin_sfc + logical ice logical use_full_hydro integer(i_kind), allocatable, dimension(:) :: mem_pe, lev_pe1, lev_pe2, iocomms @@ -111,12 +117,6 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, read_sfc_file, read_atm_file) - if (read_sfc_file) then - print *,'paranc not supported for reading surface files' - call mpi_barrier(mpi_comm_world,ierr) - call mpi_finalize(ierr) - endif - ! figure out what member to read and do MPI sub-communicator things allocate(mem_pe(0:numproc-1)) allocate(iocomms(nanals)) @@ -152,6 +152,7 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & displs(i+1) = ((lev_pe1(i)-1)*nlons*nlats) end do + if (read_atm_file) then ! loop through times and do the read ne = 1 @@ -159,7 +160,6 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & write(charnanal,'(a3, i3.3)') 'mem', nanal filename = trim(adjustl(datapath))//trim(adjustl(fileprefixes(nb)))//trim(charnanal) - sfcfilename = trim(adjustl(datapath))//trim(adjustl(filesfcprefixes(nb)))//trim(charnanal) if (use_gfs_ncio) then dset = open_dataset(filename, paropen=.true., mpicomm=iocomms(mem_pe(nproc))) londim = get_dim(dset,'grid_xt'); nlonsin = londim%len @@ -496,6 +496,141 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & end do backgroundloop ! loop over backgrounds to read in + end if !read_atm_file + + if (read_sfc_file) then + ! loop through times and do the read + ne = 1 + sfcbackgroundloop: do nb=1,ntimes + + write(charnanal,'(a3, i3.3)') 'mem', nanal + sfcfilename = trim(adjustl(datapath))//trim(adjustl(filesfcprefixes(nb)))//trim(charnanal) + if (use_gfs_ncio) then + dset_sfc = open_dataset(sfcfilename, paropen=.true., mpicomm=iocomms(mem_pe(nproc))) + else + write(6,*)'READGRIDDATA_PNC sfc: ***FATAL ERROR*** parallel read only supported for netCDF' , ' PROGRAM STOPS' + call mpi_barrier(mpi_comm_world,ierr) + call mpi_finalize(ierr) + end if + if ( reducedgrid ) then + write(6,*) "READGRIDDATA_PNC sfc: reducedgrid=T interpolation not valid for writing sfc files" + call mpi_barrier(mpi_comm_world,ierr) + call mpi_finalize(ierr) + endif + + ! land sfc DA variables + tmp2m_ind = getindex(vars2d, 't2m') + spfh2m_ind = getindex(vars2d, 'q2m') + soilt1_ind = getindex(vars2d, 'st1') + slc1_ind = getindex(vars2d, 'sl1') + soilt2_ind = getindex(vars2d, 'st2') + slc2_ind = getindex(vars2d, 'sl2') + soilt3_ind = getindex(vars2d, 'st3') + slc3_ind = getindex(vars2d, 'sl3') + soilt4_ind = getindex(vars2d, 'st4') + slc4_ind = getindex(vars2d, 'sl4') + + ! read in sfc vars, if requested + if (tmp2m_ind > 0) then + call read_vardata(dset_sfc, 'tmp2m', values_2d, errcode=iret) + if (iret /= 0) then + print *,'READGRIDDATA_PNC: error reading tmp2m' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + tmp2m_ind,nb,ne)) + endif + if (spfh2m_ind > 0) then + call read_vardata(dset_sfc, 'spfh2m', values_2d, errcode=iret) + if (iret /= 0) then + print *,'READGRIDDATA_PNC: error reading spfh2m' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + spfh2m_ind,nb,ne)) + endif + if (soilt1_ind > 0) then + call read_vardata(dset_sfc, 'soilt1', values_2d, errcode=iret) + if (iret /= 0) then + print *,'READGRIDDATA_PNC: error reading soilt1' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + soilt1_ind,nb,ne)) + endif + if (soilt2_ind > 0) then + call read_vardata(dset_sfc, 'soilt2', values_2d, errcode=iret) + if (iret /= 0) then + print *,'READGRIDDATA_PNC: error reading soilt2' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + soilt2_ind,nb,ne)) + endif + if (soilt3_ind > 0) then + call read_vardata(dset_sfc, 'soilt3', values_2d, errcode=iret) + if (iret /= 0) then + print *,'READGRIDDATA_PNC: error reading soilt3' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + soilt3_ind,nb,ne)) + endif + if (soilt4_ind > 0) then + call read_vardata(dset_sfc, 'soilt4', values_2d, errcode=iret) + if (iret /= 0) then + print *,'READGRIDDATA_PNC: error reading soilt2' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + soilt4_ind,nb,ne)) + endif + if (slc1_ind > 0) then + call read_vardata(dset_sfc, 'soill1', values_2d, errcode=iret) + if (iret /= 0) then + print *,'READGRIDDATA_PNC: error reading soill1' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + slc1_ind,nb,ne)) + endif + if (slc2_ind > 0) then + call read_vardata(dset_sfc, 'soill2', values_2d, errcode=iret) + if (iret /= 0) then + print *,'READGRIDDATA_PNC: error reading soill2' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + slc2_ind,nb,ne)) + endif + if (slc3_ind > 0) then + call read_vardata(dset_sfc, 'soill3', values_2d, errcode=iret) + if (iret /= 0) then + print *,'READGRIDDATA_PNC: error reading soill3' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + slc3_ind,nb,ne)) + endif + if (slc4_ind > 0) then + call read_vardata(dset_sfc, 'soill4', values_2d, errcode=iret) + if (iret /= 0) then + print *,'READGRIDDATA_PNC: error reading soill4' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + slc4_ind,nb,ne)) + endif + + ! bring all the subdomains back to the main PE + call mpi_barrier(iocomms(mem_pe(nproc)), iret) + if (allocated(values_2d)) deallocate(values_2d) + call close_dataset(dset_sfc) + call mpi_barrier(iocomms(mem_pe(nproc)), iret) + + end do sfcbackgroundloop ! loop over backgrounds to read in + end if !if (read_sfc_file) + ! remove the sub communicators call mpi_barrier(iocomms(mem_pe(nproc)), iret) call mpi_comm_free(iocomms(mem_pe(nproc)), iret) @@ -1322,6 +1457,20 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_ integer(i_kind) :: ncstart(4), nccount(4) logical :: nocompress + logical :: write_sfc_file, write_atm_file + character(len=max_varname_length), dimension(n3d) :: no_vars3d + character(len=max_varname_length), dimension(n2d) :: no_vars2d + + call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, write_sfc_file, write_atm_file) + + if (write_sfc_file ) then + ! adding the sfc increments requires adjusting several other variables. + ! This is done is a separate program. + if (nproc == 0) write(6,*) 'gridio/writegriddata_pnc: not coded to write sfc analysis, will write increment for sfc fields' + no_vars3d='' + call writeincrement_pnc(no_vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag) + endif + nocompress = .true. if (nccompress) nocompress = .false. @@ -3616,6 +3765,7 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, ! soil / snow mask (not fixed) integer(i_kind), dimension(nlons,nlats) :: mask logical :: write_sfc_file, write_atm_file + real(r_double) :: t1,t2 call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, write_sfc_file, write_atm_file) @@ -3627,6 +3777,7 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, nccount = (/nlons, nlats, nlevs/) if ( write_atm_file) then + if (nproc == 0) t1 = mpi_wtime() ne = 0 ensmemloop: do nanal=nanal1,nanal2 ne = ne + 1 @@ -3954,10 +4105,15 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, end do backgroundloop ! loop over backgrounds to read in end do ensmemloop ! loop over ens members to read in + if (nproc == 0) then + t2 = mpi_wtime() + print *,'time in writeincrement atm_file on root',t2-t1,'secs' + endif endif ! write_atm_file if (write_sfc_file) then + if (nproc == 0) t1 = mpi_wtime() ne = 0 sfcensmemloop: do nanal=nanal1,nanal2 ne = ne + 1 @@ -4199,6 +4355,10 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, end do sfcbackgroundloop ! loop over backgrounds to read in end do sfcensmemloop ! loop over ens members to read in + if (nproc == 0) then + t2 = mpi_wtime() + print *,'time in writeincrement sfc_file on root',t2-t1,'secs' + endif endif ! write_sfc_file @@ -4225,7 +4385,8 @@ end subroutine writeincrement subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag) use netcdf use params, only: nbackgrounds,incfileprefixes,fgfileprefixes,reducedgrid,& - datestring,nhr_anal + datestring,nhr_anal, & + incsfcfileprefixes,fgsfcfileprefixes use constants, only: grav,qcmin use mpi use module_ncio, only: Dataset, Variable, Dimension, open_dataset,& @@ -4257,12 +4418,17 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate integer :: ql_ind, qi_ind, qr_ind, qs_ind, qg_ind ! netcdf things - integer(i_kind) :: dimids3(3),nccount(3),ncstart(3) + integer(i_kind) :: dimids3(3),nccount(3),ncstart(3), dimids2(2) integer(i_kind) :: ncid_out, lon_dimid, lat_dimid, lev_dimid, ilev_dimid integer(i_kind) :: lonvarid, latvarid, levvarid, pfullvarid, ilevvarid, & hyaivarid, hybivarid, uvarid, vvarid, delpvarid, delzvarid, & tvarid, sphumvarid, liqwatvarid, o3varid, icvarid, & - rwmrvarid, snmrvarid, grlevarid + rwmrvarid, snmrvarid, grlevarid, & + tmp2mvarid, spfh2mvarid, soilt1varid, soilt2varid, & + soilt3varid, soilt4varid, slc1varid, slc2varid, & + slc3varid, slc4varid, maskvarid + integer(i_kind) :: tmp2m_ind, spfh2m_ind, soilt1_ind, soilt2_ind,soilt3_ind, & + soilt4_ind,slc1_ind, slc2_ind, slc3_ind, slc4_ind integer(i_kind) :: iadateout ! fixed fields such as lat, lon, levs @@ -4274,11 +4440,20 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate ! increment real(r_kind), dimension(nlons*nlats) :: psinc, inc, ug, vg, work real(r_single), allocatable, dimension(:,:,:) :: inc3d, inc3d2, inc3dout + real(r_single), allocatable, dimension(:,:) :: inc2d, inc2dout real(r_single), allocatable, dimension(:,:,:) :: tv, tvanl, tmp, tmpanl, q, qanl real(r_single), allocatable, dimension(:,:,:) :: q2, qanl2 real(r_kind), allocatable, dimension(:,:) :: values_2d real(r_kind), allocatable, dimension(:) :: psges, delzb, values_1d + ! soil / snow mask (not fixed) + integer(i_kind), dimension(nlons,nlats) :: mask + + logical :: write_sfc_file, write_atm_file + real(r_double) :: t1,t2 + + call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, write_sfc_file, write_atm_file) + use_full_hydro = .false. clip = tiny_r_kind read(datestring,*) iadateout @@ -4317,6 +4492,9 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate call mpi_bcast(grdin(1,1,nb,1),npts*ndim, mpi_real4, 0, iocomms(mem_pe(nproc)), iret) enddo + if (write_atm_file ) then + + if (nproc == 0) t1 = mpi_wtime() ! loop through times and do the read ne = 1 backgroundloop: do nb=1,nbackgrounds @@ -4772,8 +4950,261 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate if (allocated(delzb)) deallocate(delzb) if (allocated(psges)) deallocate(psges) + !closing file + call nccheck_incr(nf90_close(ncid_out)) end do backgroundloop ! loop over backgrounds to write out + if (nproc == 0) then + t2 = mpi_wtime() + print *,'time in writeincrement_pnc atm_file on root',t2-t1,'secs' + endif + end if ! if (write_atm_file) + + if (write_sfc_file ) then + + if (nproc == 0) t1 = mpi_wtime() + + tmp2m_ind = getindex(vars2d, 't2m') !< indices in the state or control var arrays + spfh2m_ind = getindex(vars2d, 'q2m') + soilt1_ind = getindex(vars2d, 'st1') + slc1_ind = getindex(vars2d, 'sl1') + soilt2_ind = getindex(vars2d, 'st2') + slc2_ind = getindex(vars2d, 'sl2') + soilt3_ind = getindex(vars2d, 'st3') + slc3_ind = getindex(vars2d, 'sl3') + soilt4_ind = getindex(vars2d, 'st4') + slc4_ind = getindex(vars2d, 'sl4') + + ! loop through times and do the read + ne = 1 + write(charnanal,'(i3.3)') nanal + sfcbackgroundloop: do nb=1,nbackgrounds + + if(no_inflate_flag) then + filenameout = trim(adjustl(datapath))//trim(adjustl(incsfcfileprefixes(nb)))//"nimem"//charnanal + else + filenameout = trim(adjustl(datapath))//trim(adjustl(incsfcfileprefixes(nb)))//"mem"//charnanal + end if + filenamein = trim(adjustl(datapath))//trim(adjustl(fgsfcfileprefixes(nb)))//"mem"//charnanal + + !! note: only iope=0 is writing the outputs. Having all pes in iocomm write to a file slows it down. + !! + if (iope==0) then + dsfg = open_dataset(filenamein) + ! create the output netCDF increment file + call nccheck_incr(nf90_create(path=trim(filenameout), cmode=nf90_netcdf4,ncid=ncid_out)) + + ! create dimensions based on analysis resolution, not guess + call nccheck_incr(nf90_def_dim(ncid_out, "longitude", nlons, lon_dimid)) + call nccheck_incr(nf90_def_dim(ncid_out, "latitude", nlats, lat_dimid)) + dimids2 = (/ lon_dimid, lat_dimid /) + ! create variables + call nccheck_incr(nf90_def_var(ncid_out, "longitude", nf90_real,(/lon_dimid/), lonvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "latitude", nf90_real,(/lat_dimid/), latvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "tmp2m_inc", nf90_real, dimids2,tmp2mvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "spfh2m_inc", nf90_real, dimids2,spfh2mvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt1_inc", nf90_real, dimids2,soilt1varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt2_inc", nf90_real, dimids2,soilt2varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt3_inc", nf90_real, dimids2,soilt3varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt4_inc", nf90_real, dimids2,soilt4varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc1_inc", nf90_real, dimids2,slc1varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc2_inc", nf90_real, dimids2,slc2varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc3_inc", nf90_real, dimids2,slc3varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc4_inc", nf90_real, dimids2,slc4varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilsnow_mask", nf90_int,dimids2, maskvarid)) + ! place global attributes to serial calc_increment output + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "source", "GSI EnKF")) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "comment", & + "global landsfc anal increment from writeincrement")) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "analysis_time",iadateout)) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global,"IAU_hour_from_guess", nhr_anal(nb))) + ! add units to lat/lon because that's what the calc_increment utility has + call nccheck_incr(nf90_put_att(ncid_out, lonvarid, "units","degrees_east")) + call nccheck_incr(nf90_put_att(ncid_out, latvarid, "units","degrees_north")) + ! end the netCDF file definition + call nccheck_incr(nf90_enddef(ncid_out)) + + ! longitudes + call read_vardata(dsfg, 'grid_xt', values_1d, errcode=iret) + deglons(:) = values_1d + call nccheck_incr(nf90_put_var(ncid_out, lonvarid, deglons, & + start = (/1/), count = (/nlons/))) + + call read_vardata(dsfg, 'grid_yt', values_1d, errcode=iret) + ! latitudes + do j=1,nlats + deglats(nlats-j+1) = values_1d(j) + end do + call nccheck_incr(nf90_put_var(ncid_out, latvarid, deglats, & + start = (/1/), count = (/nlats/))) + ! construct mask (1 - soil, 2 - snow, 0 - not snow) + ! note: same logic/threshold used in global_cycle to produce + ! mask on model grid. + call read_vardata(dsfg, 'soill1', values_2d, errcode=iret) + mask = 0 + do j=1,nlats + do i = 1, nlons + if (values_2d(i,j) .LT. 1.0) then + mask(i,nlats-j+1) = 1 + endif + enddo + end do + call read_vardata(dsfg, 'weasd', values_2d, errcode=iret) + do j=1,nlats + do i = 1, nlons + if (values_2d(i,j) .GT. 0.001) then + mask(i,nlats-j+1) = 2 + endif + enddo + end do + call nccheck_incr(nf90_put_var(ncid_out, maskvarid, mask, & + start = ncstart(1:2), count = nccount(1:2))) + + allocate(inc2d(nlons,nlats)) + allocate(inc2dout(nlons,nlats)) + + ! tmp2m increment + inc(:) = zero + if (tmp2m_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d) + tmp2m_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, tmp2mvarid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! spfh2m increment + inc(:) = zero + if (spfh2m_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+spfh2m_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, spfh2mvarid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! soilt1 increment + inc(:) = zero + if (soilt1_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+soilt1_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + inc2dout=0. + do j=1,nlats + do i = 1, nlons + if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j) + enddo + end do + call nccheck_incr(nf90_put_var(ncid_out, soilt1varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! soilt2 increment + inc(:) = zero + if (soilt2_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+soilt2_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + inc2dout=0. + do j=1,nlats + do i = 1, nlons + if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j) + enddo + end do + call nccheck_incr(nf90_put_var(ncid_out, soilt2varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! soilt3 increment + inc(:) = zero + if (soilt3_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+soilt3_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + inc2dout=0. + do j=1,nlats + do i = 1, nlons + if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j) + enddo + end do + call nccheck_incr(nf90_put_var(ncid_out, soilt3varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! soilt4 increment + inc(:) = zero + if (soilt4_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+soilt4_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + inc2dout=0. + do j=1,nlats + do i = 1, nlons + if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j) + enddo + end do + call nccheck_incr(nf90_put_var(ncid_out, soilt4varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! slc1 increment + inc(:) = zero + if (slc1_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+slc1_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, slc1varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! slc2 increment + inc(:) = zero + if (slc2_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+slc2_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, slc2varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! slc3 increment + inc(:) = zero + if (slc3_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+slc3_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, slc3varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! slc4 increment + inc(:) = zero + if (slc4_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+slc4_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, slc4varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + + call close_dataset(dsfg,errcode=iret) + if (iret/=0) then + write(6,*)'gridio/writeincrement_par: problem closing netcdf sfc fg dataset, iret=',iret + call stop2(23) + endif + ! deallocate things + deallocate(inc2d,inc2dout) + + call nccheck_incr(nf90_close(ncid_out)) + + end if + + end do sfcbackgroundloop ! loop over backgrounds to read in + if (nproc == 0) then + t2 = mpi_wtime() + print *,'time in writeincrement_pnc sfc_file on root',t2-t1,'secs' + endif + endif !write_Sfc + ! remove the sub communicators call mpi_barrier(iocomms(mem_pe(nproc)), iret) call mpi_comm_free(iocomms(mem_pe(nproc)), iret) From 2167bc93fe2b1e84657822a323666ccc61f9a339 Mon Sep 17 00:00:00 2001 From: TingLei-NOAA Date: Wed, 20 Mar 2024 12:16:42 -0400 Subject: [PATCH 067/109] =?UTF-8?q?Issue=20694:=20Upgrade/refactoring=20fo?= =?UTF-8?q?r=20U=20and=20V=20write-out=20sub=20for=20FV3REG=20GSI=20failur?= =?UTF-8?q?e=20=E2=80=A6=20(#698)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit **DUE DATE for merger of this PR into `develop` is 3/27/2024 (six weeks after PR creation).** Resolves #693 (Thanks to @edwardhartnett 's suggestions) Resolves # 694 ( this PR is not able to provide a stable solution, more details would be given on the issue page) Resolves # 697: With larger requested memory for each mpi task, it still showed, for some time, the differences in the analysis files between loproc vs hiproc for the control runs on hercules. whether integrating this with the refactored IO part would provide a stable solution remains to be seen. This PR resolved the newly emerged issue with IO of netcdf files in the continuous storage, with upgraded FV3REG IO for the cold start options. (Co author Ming Hu @hu5970 ) This PR is being worked on in collaboration with Pete Johnson through RDHPCS help desk, @RussTreadon-NOAA @DavidHuber-NOAA and thanks to help from @ed Raghue Reddy through RDHPCS help desk. --------- Co-authored-by: Ting Lei Co-authored-by: Ting.Lei-NOAA --- regression/regression_driver.sh | 2 + regression/regression_param.sh | 48 +-- src/gsi/gsi_rfv3io_mod.f90 | 542 ++++++++++++++++++++------------ ush/sub_hera | 5 +- ush/sub_hercules | 4 +- ush/sub_jet | 2 +- ush/sub_orion | 2 +- 7 files changed, 365 insertions(+), 240 deletions(-) diff --git a/regression/regression_driver.sh b/regression/regression_driver.sh index 821cc7cedb..38329778a4 100755 --- a/regression/regression_driver.sh +++ b/regression/regression_driver.sh @@ -36,10 +36,12 @@ for jn in `seq ${RSTART} ${REND}`; do export scripts=${scripts_updat:-$scripts} export fixgsi=${fixgsi_updat:-$fixgsi} export modulefiles=${modulefiles_updat:-$modulefiles} + export ush=${ush_update:-$ush} else export scripts=${scripts_contrl:-$scripts} export fixgsi=${fixgsi_contrl:-$fixgsi} export modulefiles=${modulefiles_contrl:-$modulefiles} + export ush=${ush_cntrl:-$ush} fi rm -f ${job[$jn]}.out diff --git a/regression/regression_param.sh b/regression/regression_param.sh index 2ac615fc4a..a4f5d7035c 100755 --- a/regression/regression_param.sh +++ b/regression/regression_param.sh @@ -87,17 +87,17 @@ case $regtest in rrfs_3denvar_glbens) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/2" elif [[ "$machine" = "Hercules" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" @@ -117,17 +117,17 @@ case $regtest in hafs_3denvar_hybens) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/2" elif [[ "$machine" = "Hercules" ]]; then topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" + topts[2]="0:15:00" ; popts[2]="5/8/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" @@ -146,17 +146,17 @@ case $regtest in hafs_4denvar_glbens) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:20:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[1]="0:20:00" ; popts[1]="5/4/" ; ropts[1]="/1" topts[2]="0:20:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Hercules" ]]; then - topts[1]="0:20:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:20:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:20:00" ; popts[1]="5/4/" ; ropts[1]="/1" + topts[2]="0:20:00" ; popts[2]="10/4/" ; ropts[2]="/1" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" @@ -300,10 +300,10 @@ if [[ "$machine" = "Hera" ]]; then export APRUN="srun" elif [[ "$machine" = "Orion" ]]; then export OMP_STACKSIZE=2048M - export APRUN="srun -n \$ntasks --cpus-per-task=\$threads" + export APRUN="srun -n \$ntasks --mem=0 --cpus-per-task=\$threads" elif [[ "$machine" = "Hercules" ]]; then export OMP_STACKSIZE=2048M - export APRUN="srun -n \$ntasks --cpus-per-task=\$threads" + export APRUN="srun -n \$ntasks --mem=0 --cpus-per-task=\$threads" elif [[ "$machine" = "Jet" ]]; then export OMP_STACKSIZE=1024M export MPI_BUFS_PER_PROC=256 diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index b3f3488a70..652bad9a33 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -547,7 +547,7 @@ subroutine gsi_rfv3io_get_ens_grid_specs(grid_spec,ierr) ! !$$$ end documentation block use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr - use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_nowrite,nf90_mpiio,nf90_inquire,nf90_inquire_dimension use netcdf, only: nf90_inquire_variable use mpimod, only: mype use mod_fv3_lola, only: definecoef_regular_grids @@ -1238,7 +1238,6 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) fv3lam_io_phymetvars3d_nouv(jphyvar)=trim(vartem) else write(6,*)'the metvarname ',vartem,' is not expected, stop' - call flush(6) call stop2(333) endif endif @@ -1253,7 +1252,6 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) endif if(jdynvar /= ndynvario3d.or.jtracer /= ntracerio3d.or.jphyvar /= nphyvario3d ) then write(6,*)'ndynvario3d is not as expected, stop' - call flush(6) call stop2(333) endif if(mype == 0) then @@ -1361,7 +1359,6 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) else if (trim(vartem) /= "pm2_5")then write(6,*)'the chemvarname ',vartem,' is not in aeronames_smoke_fv3 !!!' - call flush(6) endif endif enddo @@ -1598,7 +1595,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) if( fv3sar_bg_opt == 0) then call gsi_fv3ncdf_readuv(grd_fv3lam_uv,ges_u,ges_v,fv3filenamegin(it),.false.) else - call gsi_fv3ncdf_readuv_v1(grd_fv3lam_uv,ges_u,ges_v,fv3filenamegin(it),.false.) + call gsi_fv3ncdf_readuv_v1(grd_fv3lam_uv,ges_u,ges_v,fv3filenamegin(it),.false.) endif if( fv3sar_bg_opt == 0) then @@ -2449,7 +2446,7 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ens use mpimod, only: mpi_comm_world,mpi_rtype,mype,npe,setcomm,mpi_integer,mpi_max use mpimod, only: MPI_INFO_NULL use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr - use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_nowrite,nf90_mpiio,nf90_inquire,nf90_inquire_dimension use netcdf, only: nf90_inquire_variable use netcdf, only: nf90_inq_varid use mod_fv3_lola, only: fv3_h_to_ll,fv3_h_to_ll_ens @@ -2469,9 +2466,9 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ens character(len=max_varname_length) :: name character(len=max_filename_length) :: filenamein2 real(r_kind),allocatable,dimension(:,:):: uu2d_tmp - integer(i_kind) :: countloc_tmp(3),startloc_tmp(3) + integer(i_kind) :: countloc_tmp(4),startloc_tmp(4) - integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(3),startloc(3) + integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(4),startloc(4) integer(i_kind) ilev,ilevtot,inative integer(i_kind) kbgn,kend,len logical :: phy_smaller_domain @@ -2528,18 +2525,16 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ens allocate(gfile_loc_layout(0:fv3_io_layout_y-1)) do nio=0,fv3_io_layout_y-1 write(filename_layout,'(a,a,I4.4)') trim(filenamein),'.',nio - iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) !clt + iret=nf90_open(filename_layout,ior(nf90_nowrite,nf90_mpiio),gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) !clt if(iret/=nf90_noerr) then write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filename_layout),gfile_loc_layout(nio),', Status = ',iret - call flush(6) call stop2(333) endif enddo else - iret=nf90_open(filenamein,nf90_nowrite,gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) !clt + iret=nf90_open(filenamein,ior(nf90_nowrite,nf90_mpiio),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) !clt if(iret/=nf90_noerr) then write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filenamein),gfile_loc,', Status = ',iret - call flush(6) call stop2(333) endif endif @@ -2554,15 +2549,14 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ens name=trim(varname) if(trim(filenamein) /= trim(filenamein2)) then write(6,*)'filenamein and filenamein2 are not the same as expected, stop' - call flush(6) call stop2(333) endif ilev=grd_ionouv%lnames(1,ilevtot) nz=grd_ionouv%nsig nzp1=nz+1 inative=nzp1-ilev - startloc=(/1,1,inative/) - countloc=(/nxcase,nycase,1/) + startloc=(/1,1,inative,1/) + countloc=(/nxcase,nycase,1,1/) ! Variable ref_f3d in phy_data.nc has a smaller domain size than ! dynvariables and tracers as well as a reversed order in vertical if ( trim(adjustl(varname)) == 'ref_f3d' .or. trim(adjustl(varname)) == 'flash_extent_density' )then @@ -2570,23 +2564,23 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ens if(trim(name)=='xaxis_1') nx_phy=len if( nx_phy == nxcase )then allocate(uu2d_tmp(nxcase,nycase)) - countloc_tmp=(/nxcase,nycase,1/) + countloc_tmp=(/nxcase,nycase,1,1/) phy_smaller_domain = .false. else allocate(uu2d_tmp(nxcase-6,nycase-6)) - countloc_tmp=(/nxcase-6,nycase-6,1/) + countloc_tmp=(/nxcase-6,nycase-6,1,1/) phy_smaller_domain = .true. end if - startloc_tmp=(/1,1,ilev/) + startloc_tmp=(/1,1,ilev,1/) end if if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 if (ensgrid) then - countloc=(/nxcase,ny_layout_lenens(nio)+1,1/) + countloc=(/nxcase,ny_layout_lenens(nio)+1,1,1/) allocate(uu2d_layout(nxcase,ny_layout_lenens(nio)+1)) else - countloc=(/nxcase,ny_layout_len(nio),1/) + countloc=(/nxcase,ny_layout_len(nio),1,1/) allocate(uu2d_layout(nxcase,ny_layout_len(nio))) end if iret=nf90_inq_varid(gfile_loc_layout(nio),trim(adjustl(varname)),var_id) @@ -2671,10 +2665,10 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin, use kinds, only: r_kind,i_kind - use mpimod, only: mpi_rtype,mpi_comm_world,mype,MPI_INFO_NULL - use mpimod, only: mpi_comm_world,mpi_rtype,mype + use mpimod, only: npe,mpi_rtype,mpi_comm_world,mype,MPI_INFO_NULL + use mpimod, only: mpi_comm_world,mpi_rtype,mype,setcomm,mpi_integer,mpi_max use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr - use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_nowrite,nf90_mpiio,nf90_inquire,nf90_inquire_dimension use netcdf, only: nf90_inquire_variable use netcdf, only: nf90_inq_varid use mod_fv3_lola, only: fv3_h_to_ll,fv3_h_to_ll_ens @@ -2694,12 +2688,18 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin, character(len=max_varname_length) :: varname,vgsiname - integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(3),startloc(3) + integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(4),startloc(4) integer(i_kind) kbgn,kend integer(i_kind) var_id integer(i_kind) inative,ilev,ilevtot integer(i_kind) gfile_loc,iret integer(i_kind) nzp1,mm1 + + integer(i_kind):: iworld,iworld_group,nread,mpi_comm_read,i,ierror + integer(i_kind),dimension(npe):: members,members_read,mype_read_rank + logical:: procuse + + mm1=mype+1 @@ -2712,13 +2712,34 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin, nxcase=nx nycase=ny end if + allocate(uu2d(nxcase,nycase)) + kbgn=grd_ionouv%kbegin_loc kend=grd_ionouv%kend_loc - allocate(uu2d(nxcase,nycase)) - iret=nf90_open(filenamein,nf90_nowrite,gfile_loc,comm=mpi_comm_world,info=MPI_INFO_NULL) !clt + procuse = .false. + members=-1 + members_read=-1 + if (kbgn<=kend) then + procuse = .true. + members(mm1) = mype + endif + call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror) + + nread=0 + mype_read_rank=-1 + do i=1,npe + if (members_read(i) >= 0) then + nread=nread+1 + mype_read_rank(nread) = members_read(i) + endif + enddo + + call setcomm(iworld,iworld_group,nread,mype_read_rank,mpi_comm_read,ierror) + + if (procuse) then + iret=nf90_open(filenamein,ior(nf90_nowrite,nf90_mpiio),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) !clt if(iret/=nf90_noerr) then write(6,*)' gsi_fv3ncdf_read_v1: problem opening ',trim(filenamein),gfile_loc,', Status = ',iret - call flush(6) call stop2(333) endif @@ -2728,15 +2749,14 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin, call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname) if(trim(filenamein) /= trim(filenamein2)) then write(6,*)'filenamein and filenamein2 are not the same as expected, stop' - call flush(6) call stop2(333) endif ilev=grd_ionouv%lnames(1,ilevtot) nz=grd_ionouv%nsig nzp1=nz+1 inative=nzp1-ilev - startloc=(/1,1,inative+1/) - countloc=(/nxcase,nycase,1/) + startloc=(/1,1,inative+1,1/) + countloc=(/nxcase,nycase,1,1/) iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname)),var_id) if(iret/=nf90_noerr) then write(6,*)' wrong to get var_id ',var_id @@ -2752,8 +2772,9 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin, end if enddo ! i - call general_grid2sub(grd_ionouv,hwork,cstate_nouv%values) iret=nf90_close(gfile_loc) + endif + call general_grid2sub(grd_ionouv,hwork,cstate_nouv%values) deallocate (uu2d) @@ -2785,7 +2806,7 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) use kinds, only: r_kind,i_kind use mpimod, only: mpi_comm_world,mpi_rtype,mype,mpi_info_null,npe,setcomm,mpi_integer,mpi_max use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr - use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_nowrite,nf90_mpiio,nf90_inquire,nf90_inquire_dimension use netcdf, only: nf90_inquire_variable use netcdf, only: nf90_inq_varid use mod_fv3_lola, only: fv3_h_to_ll,fv3uv2earth,fv3_h_to_ll_ens,fv3uv2earthens @@ -2808,7 +2829,7 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) integer(i_kind) u_grd_VarId,v_grd_VarId integer(i_kind) nlatcase,nloncase integer(i_kind) nxcase,nycase - integer(i_kind) u_countloc(3),u_startloc(3),v_countloc(3),v_startloc(3) + integer(i_kind) u_countloc(4),u_startloc(4),v_countloc(4),v_startloc(4) integer(i_kind) inative,ilev,ilevtot integer(i_kind) kbgn,kend @@ -2873,15 +2894,13 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) if(iret/=nf90_noerr) then write(6,*)'problem opening6 ',trim(filename_layout),gfile_loc_layout(nio),', Status = ',iret - call flush(6) call stop2(333) endif enddo else - iret=nf90_open(filenamein,nf90_nowrite,gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) !clt + iret=nf90_open(filenamein,ior(nf90_nowrite,nf90_mpiio),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) !clt if(iret/=nf90_noerr) then write(6,*)' problem opening6 ',trim(filenamein),', Status = ',iret - call flush(6) call stop2(333) endif endif @@ -2891,24 +2910,23 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname) if(trim(filenamein) /= trim(filenamein2)) then write(6,*)'filenamein and filenamein2 are not the same as expected, stop' - call flush(6) call stop2(333) endif ilev=grd_uv%lnames(1,ilevtot) nz=grd_uv%nsig nzp1=nz+1 inative=nzp1-ilev - u_countloc=(/nxcase,nycase+1,1/) - v_countloc=(/nxcase+1,nycase,1/) - u_startloc=(/1,1,inative/) - v_startloc=(/1,1,inative/) + u_countloc=(/nxcase,nycase+1,1,1/) + v_countloc=(/nxcase+1,nycase,1,1/) + u_startloc=(/1,1,inative,1/) + v_startloc=(/1,1,inative,1/) if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 if (ensgrid) then - u_countloc=(/nxcase,ny_layout_lenens(nio)+1,1/) + u_countloc=(/nxcase,ny_layout_lenens(nio)+1,1,1/) allocate(u2d_layout(nxcase,ny_layout_lenens(nio)+1)) else - u_countloc=(/nxcase,ny_layout_len(nio)+1,1/) + u_countloc=(/nxcase,ny_layout_len(nio)+1,1,1/) allocate(u2d_layout(nxcase,ny_layout_len(nio)+1)) end if call check( nf90_inq_varid(gfile_loc_layout(nio),'u',u_grd_VarId) ) @@ -2917,13 +2935,13 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) u2d(:,ny_layout_bens(nio):ny_layout_eens(nio))=u2d_layout(:,1:ny_layout_lenens(nio)) if(nio==fv3_io_layout_y-1) u2d(:,ny_layout_eens(nio)+1)=u2d_layout(:,ny_layout_lenens(nio)+1) deallocate(u2d_layout) - v_countloc=(/nxcase+1,ny_layout_lenens(nio),1/) + v_countloc=(/nxcase+1,ny_layout_lenens(nio),1,1/) allocate(v2d_layout(nxcase+1,ny_layout_lenens(nio))) else u2d(:,ny_layout_b(nio):ny_layout_e(nio))=u2d_layout(:,1:ny_layout_len(nio)) if(nio==fv3_io_layout_y-1) u2d(:,ny_layout_e(nio)+1)=u2d_layout(:,ny_layout_len(nio)+1) deallocate(u2d_layout) - v_countloc=(/nxcase+1,ny_layout_len(nio),1/) + v_countloc=(/nxcase+1,ny_layout_len(nio),1,1/) allocate(v2d_layout(nxcase+1,ny_layout_len(nio))) end if call check( nf90_inq_varid(gfile_loc_layout(nio),'v',v_grd_VarId) ) @@ -3019,9 +3037,10 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) !$$$ end documentation block use constants, only: half use kinds, only: r_kind,i_kind - use mpimod, only: mpi_comm_world,mpi_rtype,mype,mpi_info_null + use mpimod, only: setcomm,mpi_integer,mpi_max, npe,mpi_comm_world,mpi_rtype,mype,mpi_info_null use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr - use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_nowrite,nf90_mpiio,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_var_par_access,nf90_netcdf4 use netcdf, only: nf90_inquire_variable use netcdf, only: nf90_inq_varid use mod_fv3_lola, only: fv3_h_to_ll,fv3_h_to_ll_ens @@ -3051,6 +3070,9 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) integer(i_kind) nxcase,nycase integer(i_kind) us_countloc(3),us_startloc(3) integer(i_kind) vw_countloc(3),vw_startloc(3) + integer(i_kind):: iworld,iworld_group,nread,mpi_comm_read,i,ierror + integer(i_kind),dimension(npe):: members,members_read,mype_read_rank + logical:: procuse allocate (worksub(2,grd_uv%lat2,grd_uv%lon2,grd_uv%nsig)) mm1=mype+1 @@ -3067,11 +3089,33 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) kend=grd_uv%kend_loc allocate (us2d(nxcase,nycase+1),vw2d(nxcase+1,nycase)) allocate (uorv2d(nxcase,nycase)) + procuse = .false. + members=-1 + members_read=-1 + if (kbgn<=kend) then + procuse = .true. + members(mm1) = mype + endif + + call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror) + + nread=0 + mype_read_rank=-1 + do i=1,npe + if (members_read(i) >= 0) then + nread=nread+1 + mype_read_rank(nread) = members_read(i) + endif + enddo + + call setcomm(iworld,iworld_group,nread,mype_read_rank,mpi_comm_read,ierror) + + if (procuse) then + filenamein=fv3filenamegin%dynvars - iret=nf90_open(filenamein,nf90_nowrite,gfile_loc,comm=mpi_comm_world,info=MPI_INFO_NULL) !clt + iret=nf90_open(filenamein,ior(nf90_netcdf4,ior(nf90_nowrite,nf90_mpiio)),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) !clt if(iret/=nf90_noerr) then write(6,*)' gsi_fv3ncdf_read_v1: problem opening ',trim(filenamein),gfile_loc,', Status = ',iret - call flush(6) call stop2(333) endif @@ -3080,7 +3124,6 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) filenamein2=fv3filenamegin%dynvars if(trim(filenamein) /= trim(filenamein2)) then write(6,*)'filenamein and filenamein2 are not the same as expected, stop' - call flush(6) call stop2(333) endif ilev=grd_uv%lnames(1,ilevtot) @@ -3099,9 +3142,9 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) ! transfor to earth u/v, interpolate to analysis grid, reverse vertical order - iret=nf90_inq_varid(gfile_loc,trim(adjustl("u_s")),var_id) - - iret=nf90_get_var(gfile_loc,var_id,us2d,start=us_startloc,count=us_countloc) + call check(nf90_inq_varid(gfile_loc,trim(adjustl("u_s")),var_id)) + + call check(nf90_get_var(gfile_loc,var_id,us2d,start=us_startloc,count=us_countloc)) iret=nf90_inq_varid(gfile_loc,trim(adjustl("v_w")),var_id) iret=nf90_get_var(gfile_loc,var_id,vw2d,start=vw_startloc,count=vw_countloc) do j=1,ny @@ -3123,10 +3166,11 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) end if enddo ! iilevtoto + iret=nf90_close(gfile_loc) + endif !procuse call general_grid2sub(grd_uv,hwork,worksub) ges_u=worksub(1,:,:,:) ges_v=worksub(2,:,:,:) - iret=nf90_close(gfile_loc) deallocate (us2d,vw2d,worksub) end subroutine gsi_fv3ncdf_readuv_v1 @@ -3160,7 +3204,7 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & use mpimod, only: mpi_comm_world,mpi_rtype,mype use mpimod, only: MPI_INFO_NULL use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr - use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_nowrite,nf90_mpiio,nf90_inquire,nf90_inquire_dimension use netcdf, only: nf90_inquire_variable use netcdf, only: nf90_inq_varid use gridmod, only: nsig,nlon,nlat @@ -3179,7 +3223,7 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & character(len=max_varname_length) :: name character(len=max_filename_length), allocatable,dimension(:) :: varname_files - integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(3),startloc(3),countloc_tmp(3),startloc_tmp(3) + integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(4),startloc(4),countloc_tmp(4),startloc_tmp(4) integer(i_kind) ilev,ilevtot,inative,ivar integer(i_kind) kbgn,kend integer(i_kind) gfile_loc,iret,var_id @@ -3238,15 +3282,13 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio),comm=mpi_comm_world,info=MPI_INFO_NULL) if(iret/=nf90_noerr) then write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filename_layout),gfile_loc_layout(nio),', Status = ',iret - call flush(6) call stop2(333) endif enddo else - iret=nf90_open(filenamein,nf90_nowrite,gfile_loc) + iret=nf90_open(filenamein,ior(nf90_nowrite,nf90_mpiio),gfile_loc) if(iret/=nf90_noerr) then write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filenamein),gfile_loc,', Status = ',iret - call flush(6) call stop2(333) endif endif @@ -3256,8 +3298,8 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & nz=nsig nzp1=nz+1 inative=nzp1-ilev - startloc=(/1,1,inative/) - countloc=(/nxcase,nycase,1/) + startloc=(/1,1,inative,1/) + countloc=(/nxcase,nycase,1,1/) varname = trim(varname_files(ivar)) ! Variable ref_f3d in phy_data.nc has a smaller domain size than ! dynvariables and tracers as well as a reversed order in vertical @@ -3266,19 +3308,19 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & if(trim(name)=='xaxis_1') nx_phy=len if( nx_phy == nxcase )then allocate(uu2d_tmp(nxcase,nycase)) - countloc_tmp=(/nxcase,nycase,1/) + countloc_tmp=(/nxcase,nycase,1,1/) phy_smaller_domain = .false. else allocate(uu2d_tmp(nxcase-6,nycase-6)) - countloc_tmp=(/nxcase-6,nycase-6,1/) + countloc_tmp=(/nxcase-6,nycase-6,1,1/) phy_smaller_domain = .true. end if - startloc_tmp=(/1,1,ilev/) + startloc_tmp=(/1,1,ilev,1/) end if if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 - countloc=(/nxcase,ny_layout_len(nio),1/) + countloc=(/nxcase,ny_layout_len(nio),1,1/) allocate(uu2d_layout(nxcase,ny_layout_len(nio))) iret=nf90_inq_varid(gfile_loc_layout(nio),trim(adjustl(varname)),var_id) iret=nf90_get_var(gfile_loc_layout(nio),var_id,uu2d_layout,start=startloc,count=countloc) @@ -3408,7 +3450,7 @@ subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens(ges_u,ges_v,fv3filenamegin,i integer(i_kind) u_grd_VarId,v_grd_VarId integer(i_kind) nlatcase,nloncase integer(i_kind) nxcase,nycase - integer(i_kind) u_countloc(3),u_startloc(3),v_countloc(3),v_startloc(3) + integer(i_kind) u_countloc(4),u_startloc(4),v_countloc(4),v_startloc(4) integer(i_kind) inative,ilev,ilevtot integer(i_kind) kbgn,kend @@ -3442,7 +3484,6 @@ subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens(ges_u,ges_v,fv3filenamegin,i iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio),comm=mpi_comm_world,info=MPI_INFO_NULL) if(iret/=nf90_noerr) then write(6,*)'problem opening ',trim(filename_layout),gfile_loc_layout(nio),', Status = ',iret - call flush(6) call stop2(333) endif enddo @@ -3450,7 +3491,6 @@ subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens(ges_u,ges_v,fv3filenamegin,i iret=nf90_open(filenamein,nf90_nowrite,gfile_loc) if(iret/=nf90_noerr) then write(6,*)' problem opening ',trim(filenamein),', Status = ',iret - call flush(6) call stop2(333) endif endif @@ -3459,14 +3499,14 @@ subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens(ges_u,ges_v,fv3filenamegin,i nz=nsig nzp1=nz+1 inative=nzp1-ilev - u_countloc=(/nxcase,nycase+1,1/) - v_countloc=(/nxcase+1,nycase,1/) - u_startloc=(/1,1,inative/) - v_startloc=(/1,1,inative/) + u_countloc=(/nxcase,nycase+1,1,1/) + v_countloc=(/nxcase+1,nycase,1,1/) + u_startloc=(/1,1,inative,1/) + v_startloc=(/1,1,inative,1/) if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 - u_countloc=(/nxcase,ny_layout_len(nio)+1,1/) + u_countloc=(/nxcase,ny_layout_len(nio)+1,1,1/) allocate(u2d_layout(nxcase,ny_layout_len(nio)+1)) call check( nf90_inq_varid(gfile_loc_layout(nio),'u',u_grd_VarId) ) iret=nf90_get_var(gfile_loc_layout(nio),u_grd_VarId,u2d_layout,start=u_startloc,count=u_countloc) @@ -3474,7 +3514,7 @@ subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens(ges_u,ges_v,fv3filenamegin,i if(nio==fv3_io_layout_y-1) u2d(:,ny_layout_e(nio)+1)=u2d_layout(:,ny_layout_len(nio)+1) deallocate(u2d_layout) - v_countloc=(/nxcase+1,ny_layout_len(nio),1/) + v_countloc=(/nxcase+1,ny_layout_len(nio),1,1/) allocate(v2d_layout(nxcase+1,ny_layout_len(nio))) call check( nf90_inq_varid(gfile_loc_layout(nio),'v',v_grd_VarId) ) iret=nf90_get_var(gfile_loc_layout(nio),v_grd_VarId,v2d_layout,start=v_startloc,count=v_countloc) @@ -3965,7 +4005,7 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) use mod_fv3_lola, only: fv3_ll_to_h,fv3_h_to_ll, & fv3uv2earth,earthuv2fv3 use netcdf, only: nf90_open,nf90_close,nf90_noerr - use netcdf, only: nf90_write,nf90_inq_varid + use netcdf, only: nf90_write,nf90_mpiio,nf90_inq_varid,nf90_var_par_access,nf90_collective use netcdf, only: nf90_put_var,nf90_get_var use general_sub2grid_mod, only: sub2grid_info,general_sub2grid @@ -3984,11 +4024,11 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) integer(i_kind) inative,ilev,ilevtot integer(i_kind) nlatcase,nloncase integer(i_kind) nxcase,nycase - integer(i_kind) u_countloc(3),u_startloc(3),v_countloc(3),v_startloc(3) + integer(i_kind) u_countloc(4),u_startloc(4),v_countloc(4),v_startloc(4) character(:),allocatable:: filenamein ,varname real(r_kind),allocatable,dimension(:,:,:,:):: worksub real(r_kind),allocatable,dimension(:,:):: work_au,work_av - real(r_kind),allocatable,dimension(:,:):: work_bu,work_bv + real(r_kind),allocatable,dimension(:,:,:):: work_bu,work_bv real(r_kind),allocatable,dimension(:,:):: u2d,v2d,workau2,workav2 real(r_kind),allocatable,dimension(:,:):: workbu2,workbv2 @@ -3997,10 +4037,12 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) logical:: procuse ! for fv3_io_layout_y > 1 - real(r_kind),allocatable,dimension(:,:):: u2d_layout,v2d_layout + real(r_kind),allocatable,dimension(:,:,:):: u2d_layout,v2d_layout integer(i_kind) :: nio integer(i_kind),allocatable :: gfile_loc_layout(:) character(len=180) :: filename_layout + integer(i_kind):: kend_native,kbgn_native + integer(i_kind):: istat mm1=mype+1 @@ -4012,8 +4054,6 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) kend=grd_uv%kend_loc allocate( u2d(nlon_regional,nlat_regional+1)) allocate( v2d(nlon_regional+1,nlat_regional)) - allocate( work_bu(nlon_regional,nlat_regional+1)) - allocate( work_bv(nlon_regional+1,nlat_regional)) allocate (worksub(2,grd_uv%lat2,grd_uv%lon2,grd_uv%nsig)) allocate( work_au(nlatcase,nloncase),work_av(nlatcase,nloncase)) do k=1,grd_uv%nsig @@ -4054,59 +4094,70 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) allocate(gfile_loc_layout(0:fv3_io_layout_y-1)) do nio=0,fv3_io_layout_y-1 write(filename_layout,'(a,a,I4.4)') trim(filenamein),".",nio - call check( nf90_open(filename_layout,nf90_write,gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) ) + call check( nf90_open(filename_layout,ior(nf90_write, nf90_mpiio),gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) ) enddo gfile_loc=gfile_loc_layout(0) else - call check( nf90_open(filenamein,nf90_write,gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) ) + call check( nf90_open(filenamein,ior(nf90_write, nf90_mpiio),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) ) + endif + nz=grd_uv%nsig + nzp1=nz+1 + kend_native=nzp1-grd_uv%lnames(1,kbgn) + kbgn_native=nzp1-grd_uv%lnames(1,kend) + allocate( work_bu(nlon_regional,nlat_regional+1,kbgn_native:kend_native)) + allocate( work_bv(nlon_regional+1,nlat_regional,kbgn_native:kend_native)) + u_startloc=(/1,1,kbgn_native,1/) + u_countloc=(/nxcase,nycase+1,kend_native-kbgn_native+1,1/) + v_startloc=(/1,1,kbgn_native,1/) + v_countloc=(/nxcase+1,nycase,kend_native-kbgn_native+1,1/) + if(fv3_io_layout_y > 1) then + do nio=0,fv3_io_layout_y-1 + allocate(u2d_layout(nxcase,ny_layout_len(nio)+1,kend_native-kbgn_native+1)) + u_countloc=(/nxcase,ny_layout_len(nio)+1,kend_native-kbgn_native+1,1/) + call check( nf90_get_var(gfile_loc_layout(nio),ugrd_VarId,u2d_layout,start=u_startloc,count=u_countloc) ) + work_bu(:,ny_layout_b(nio):ny_layout_e(nio),:)=u2d_layout(:,1:ny_layout_len(nio),:) + if(nio==fv3_io_layout_y-1) work_bu(:,ny_layout_e(nio)+1,:)=u2d_layout(:,ny_layout_len(nio)+1,:) + deallocate(u2d_layout) + + allocate(v2d_layout(nxcase+1,ny_layout_len(nio),kend_native-kbgn_native+1)) + v_countloc=(/nxcase+1,ny_layout_len(nio),kend_native-kbgn_native+1,1/) + call check( nf90_get_var(gfile_loc_layout(nio),vgrd_VarId,v2d_layout,start=v_startloc,count=v_countloc) ) + work_bv(:,ny_layout_b(nio):ny_layout_e(nio),:)=v2d_layout + deallocate(v2d_layout) + enddo + else + call check( nf90_inq_varid(gfile_loc,'u',ugrd_VarId) ) + call check( nf90_inq_varid(gfile_loc,'v',vgrd_VarId) ) + call check( nf90_var_par_access(gfile_loc, ugrd_VarId, nf90_collective)) + call check( nf90_var_par_access(gfile_loc, vgrd_VarId, nf90_collective)) + call check( nf90_get_var(gfile_loc,ugrd_VarId,work_bu,start=u_startloc,count=u_countloc) ) + call check( nf90_get_var(gfile_loc,vgrd_VarId,work_bv,start=v_startloc,count=v_countloc) ) endif + + do ilevtot=kbgn,kend varname=grd_uv%names(1,ilevtot) ilev=grd_uv%lnames(1,ilevtot) - nz=grd_uv%nsig - nzp1=nz+1 inative=nzp1-ilev - u_countloc=(/nxcase,nycase+1,1/) - v_countloc=(/nxcase+1,nycase,1/) - u_startloc=(/1,1,inative/) - v_startloc=(/1,1,inative/) work_au=hwork(1,:,:,ilevtot) work_av=hwork(2,:,:,ilevtot) - call check( nf90_inq_varid(gfile_loc,'u',ugrd_VarId) ) - call check( nf90_inq_varid(gfile_loc,'v',vgrd_VarId) ) if(add_saved)then allocate( workau2(nlatcase,nloncase),workav2(nlatcase,nloncase)) allocate( workbu2(nlon_regional,nlat_regional+1)) allocate( workbv2(nlon_regional+1,nlat_regional)) !!!!!!!! readin work_b !!!!!!!!!!!!!!!! - if(fv3_io_layout_y > 1) then - do nio=0,fv3_io_layout_y-1 - allocate(u2d_layout(nxcase,ny_layout_len(nio)+1)) - u_countloc=(/nxcase,ny_layout_len(nio)+1,1/) - call check( nf90_get_var(gfile_loc_layout(nio),ugrd_VarId,u2d_layout,start=u_startloc,count=u_countloc) ) - work_bu(:,ny_layout_b(nio):ny_layout_e(nio))=u2d_layout(:,1:ny_layout_len(nio)) - if(nio==fv3_io_layout_y-1) work_bu(:,ny_layout_e(nio)+1)=u2d_layout(:,ny_layout_len(nio)+1) - deallocate(u2d_layout) - - allocate(v2d_layout(nxcase+1,ny_layout_len(nio))) - v_countloc=(/nxcase+1,ny_layout_len(nio),1/) - call check( nf90_get_var(gfile_loc_layout(nio),vgrd_VarId,v2d_layout,start=v_startloc,count=v_countloc) ) - work_bv(:,ny_layout_b(nio):ny_layout_e(nio))=v2d_layout - deallocate(v2d_layout) - enddo - else - call check( nf90_get_var(gfile_loc,ugrd_VarId,work_bu,start=u_startloc,count=u_countloc) ) - call check( nf90_get_var(gfile_loc,vgrd_VarId,work_bv,start=v_startloc,count=v_countloc) ) - endif + +!clt for fv3_io_layout<=1 now the nf90_get_var has been moved outside of this do loop +!to avoid failure on hercules when L_MPI_EXTRA_FILESYSTEM=1 if(.not.grid_reverse_flag) then - call reverse_grid_r_uv(work_bu,nlon_regional,nlat_regional+1,1) - call reverse_grid_r_uv(work_bv,nlon_regional+1,nlat_regional,1) + call reverse_grid_r_uv(work_bu(:,:,inative),nlon_regional,nlat_regional+1,1) + call reverse_grid_r_uv(work_bv(:,:,inative),nlon_regional+1,nlat_regional,1) endif - call fv3uv2earth(work_bu,work_bv,nlon_regional,nlat_regional,u2d,v2d) + call fv3uv2earth(work_bu(:,:,inative),work_bv(:,:,inative),nlon_regional,nlat_regional,u2d,v2d) call fv3_h_to_ll(u2d,workau2,nlon_regional,nlat_regional,nloncase,nlatcase,.true.) call fv3_h_to_ll(v2d,workav2,nlon_regional,nlat_regional,nloncase,nlatcase,.true.) !!!!!!!! find analysis_inc: work_a !!!!!!!!!!!!!!!! @@ -4116,38 +4167,38 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) call fv3_ll_to_h(work_av(:,:),v2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.) call earthuv2fv3(u2d,v2d,nlon_regional,nlat_regional,workbu2,workbv2) !!!!!!!! add analysis_inc to readin work_b !!!!!!!!!!!!!!!! - work_bu(:,:)=work_bu(:,:)+workbu2(:,:) - work_bv(:,:)=work_bv(:,:)+workbv2(:,:) + work_bu(:,:,inative)=work_bu(:,:,inative)+workbu2(:,:) + work_bv(:,:,inative)=work_bv(:,:,inative)+workbv2(:,:) deallocate(workau2,workbu2,workav2,workbv2) else call fv3_ll_to_h(work_au(:,:),u2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.) call fv3_ll_to_h(work_av(:,:),v2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.) - call earthuv2fv3(u2d,v2d,nlon_regional,nlat_regional,work_bu(:,:),work_bv(:,:)) + call earthuv2fv3(u2d,v2d,nlon_regional,nlat_regional,work_bu(:,:,inative),work_bv(:,:,inative)) endif if(.not.grid_reverse_flag) then - call reverse_grid_r_uv(work_bu,nlon_regional,nlat_regional+1,1) - call reverse_grid_r_uv(work_bv,nlon_regional+1,nlat_regional,1) + call reverse_grid_r_uv(work_bu(:,:,inative),nlon_regional,nlat_regional+1,1) + call reverse_grid_r_uv(work_bv(:,:,inative),nlon_regional+1,nlat_regional,1) endif + enddo !ilevltot - if(fv3_io_layout_y > 1) then + if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 - allocate(u2d_layout(nxcase,ny_layout_len(nio)+1)) - u_countloc=(/nxcase,ny_layout_len(nio)+1,1/) - u2d_layout=work_bu(:,ny_layout_b(nio):ny_layout_e(nio)+1) + allocate(u2d_layout(nxcase,ny_layout_len(nio)+1,kend_native-kbgn_native+1)) + u_countloc=(/nxcase,ny_layout_len(nio)+1,kend_native-kbgn_native+1,1/) + u2d_layout=work_bu(:,ny_layout_b(nio):ny_layout_e(nio)+1,:) call check( nf90_put_var(gfile_loc_layout(nio),ugrd_VarId,u2d_layout,start=u_startloc,count=u_countloc) ) deallocate(u2d_layout) - allocate(v2d_layout(nxcase+1,ny_layout_len(nio))) - v_countloc=(/nxcase+1,ny_layout_len(nio),1/) - v2d_layout=work_bv(:,ny_layout_b(nio):ny_layout_e(nio)) + allocate(v2d_layout(nxcase+1,ny_layout_len(nio),kend_native-kbgn_native+1)) + v_countloc=(/nxcase+1,ny_layout_len(nio),kend_native-kbgn_native+1,1/) + v2d_layout=work_bv(:,ny_layout_b(nio):ny_layout_e(nio),:) call check( nf90_put_var(gfile_loc_layout(nio),vgrd_VarId,v2d_layout,start=v_startloc,count=v_countloc) ) deallocate(v2d_layout) enddo - else + else call check( nf90_put_var(gfile_loc,ugrd_VarId,work_bu,start=u_startloc,count=u_countloc) ) call check( nf90_put_var(gfile_loc,vgrd_VarId,work_bv,start=v_startloc,count=v_countloc) ) - endif - enddo !ilevltot + endif if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 @@ -4157,11 +4208,12 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) else call check( nf90_close(gfile_loc) ) endif + deallocate(work_bu,work_bv) endif call mpi_barrier(mpi_comm_world,ierror) - deallocate(work_bu,work_bv,u2d,v2d) + deallocate(u2d,v2d) deallocate(work_au,work_av) end subroutine gsi_fv3ncdf_writeuv @@ -4193,12 +4245,12 @@ subroutine gsi_fv3ncdf_writeuv_v1(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) !$$$ end documentation block use constants, only: half,zero - use mpimod, only: mpi_rtype,mpi_comm_world,mype,mpi_info_null + use mpimod, only: npe, setcomm,mpi_integer,mpi_max,mpi_rtype,mpi_comm_world,mype,mpi_info_null use gridmod, only: nlon_regional,nlat_regional use mod_fv3_lola, only: fv3_ll_to_h,fv3_h_to_ll, & fv3uv2earth,earthuv2fv3 use netcdf, only: nf90_open,nf90_close,nf90_noerr - use netcdf, only: nf90_write,nf90_inq_varid + use netcdf, only: nf90_write, nf90_mpiio,nf90_inq_varid,nf90_var_par_access,nf90_collective use netcdf, only: nf90_put_var,nf90_get_var use general_sub2grid_mod, only: sub2grid_info,general_sub2grid implicit none @@ -4220,14 +4272,20 @@ subroutine gsi_fv3ncdf_writeuv_v1(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) integer(i_kind) inative,ilev,ilevtot real(r_kind),allocatable,dimension(:,:,:,:):: worksub real(r_kind),allocatable,dimension(:,:):: work_au,work_av - real(r_kind),allocatable,dimension(:,:):: work_bu_s,work_bv_s - real(r_kind),allocatable,dimension(:,:):: work_bu_w,work_bv_w + real(r_kind),allocatable,dimension(:,:,:):: work_bu_s,work_bv_s + real(r_kind),allocatable,dimension(:,:,:):: work_bu_w,work_bv_w real(r_kind),allocatable,dimension(:,:):: u2d,v2d,workau2,workav2 real(r_kind),allocatable,dimension(:,:):: workbu_s2,workbv_s2 real(r_kind),allocatable,dimension(:,:):: workbu_w2,workbv_w2 integer(i_kind) nlatcase,nloncase,nxcase,nycase - integer(i_kind) uw_countloc(3),us_countloc(3),uw_startloc(3),us_startloc(3) - integer(i_kind) vw_countloc(3),vs_countloc(3),vw_startloc(3),vs_startloc(3) + integer(i_kind) uw_countloc(4),us_countloc(4),uw_startloc(4),us_startloc(4) + integer(i_kind) vw_countloc(4),vs_countloc(4),vw_startloc(4),vs_startloc(4) + integer(i_kind):: kend_native,kbgn_native,kdim_native + + + integer(i_kind):: iworld,iworld_group,nread,mpi_comm_read,ierror + integer(i_kind),dimension(npe):: members,members_read,mype_read_rank + logical:: procuse mm1=mype+1 nloncase=grd_uv%nlon @@ -4249,61 +4307,96 @@ subroutine gsi_fv3ncdf_writeuv_v1(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) allocate( u2d(nlon_regional,nlat_regional)) allocate( v2d(nlon_regional,nlat_regional)) - allocate( work_bu_s(nlon_regional,nlat_regional+1)) - allocate( work_bv_s(nlon_regional,nlat_regional+1)) - allocate( work_bu_w(nlon_regional+1,nlat_regional)) - allocate( work_bv_w(nlon_regional+1,nlat_regional)) allocate( work_au(nlatcase,nloncase),work_av(nlatcase,nloncase)) + if(add_saved) allocate( workau2(nlatcase,nloncase),workav2(nlatcase,nloncase)) - allocate( workbu_w2(nlon_regional+1,nlat_regional)) - allocate( workbv_w2(nlon_regional+1,nlat_regional)) - allocate( workbu_s2(nlon_regional,nlat_regional+1)) - allocate( workbv_s2(nlon_regional,nlat_regional+1)) + allocate( workbu_w2(nlon_regional+1,nlat_regional)) + allocate( workbv_w2(nlon_regional+1,nlat_regional)) + allocate( workbu_s2(nlon_regional,nlat_regional+1)) + allocate( workbv_s2(nlon_regional,nlat_regional+1)) filenamein=fv3filenamegin%dynvars - call check( nf90_open(filenamein,nf90_write,gfile_loc,comm=mpi_comm_world,info=MPI_INFO_NULL) ) - do ilevtot=kbgn,kend - varname=grd_uv%names(1,ilevtot) - ilev=grd_uv%lnames(1,ilevtot) - nz=grd_uv%nsig - nzp1=nz+1 - inative=nzp1-ilev + procuse = .false. + members=-1 + members_read=-1 + if (kbgn<=kend) then + procuse = .true. + members(mm1) = mype + endif + + call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror) + + nread=0 + mype_read_rank=-1 + do i=1,npe + if (members_read(i) >= 0) then + nread=nread+1 + mype_read_rank(nread) = members_read(i) + endif + enddo + + call setcomm(iworld,iworld_group,nread,mype_read_rank,mpi_comm_read,ierror) + + if (procuse) then + - uw_countloc= (/nlon_regional+1,nlat_regional,1/) - us_countloc= (/nlon_regional,nlat_regional+1,1/) - vw_countloc= (/nlon_regional+1,nlat_regional,1/) - vs_countloc= (/nlon_regional,nlat_regional+1,1/) + + + call check( nf90_open(filenamein,ior(nf90_write, nf90_mpiio),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) ) + + call check( nf90_inq_varid(gfile_loc,'u_s',u_sgrd_VarId) ) + call check( nf90_var_par_access(gfile_loc, u_sgrd_VarId, nf90_collective)) + call check( nf90_inq_varid(gfile_loc,'u_w',u_wgrd_VarId) ) + call check( nf90_var_par_access(gfile_loc, u_wgrd_VarId, nf90_collective)) + call check( nf90_inq_varid(gfile_loc,'v_s',v_sgrd_VarId) ) + call check( nf90_var_par_access(gfile_loc, v_sgrd_VarId, nf90_collective)) + call check( nf90_inq_varid(gfile_loc,'v_w',v_wgrd_VarId) ) + call check( nf90_var_par_access(gfile_loc, v_wgrd_VarId, nf90_collective)) + nz=grd_uv%nsig + nzp1=nz+1 + kend_native=nzp1-grd_uv%lnames(1,kbgn) + kbgn_native=nzp1-grd_uv%lnames(1,kend) + kdim_native=kend_native-kbgn_native+1 + + uw_countloc= (/nlon_regional+1,nlat_regional,kdim_native,1/) + us_countloc= (/nlon_regional,nlat_regional+1,kdim_native,1/) + vw_countloc= (/nlon_regional+1,nlat_regional,kdim_native,1/) + vs_countloc= (/nlon_regional,nlat_regional+1,kdim_native,1/) - uw_startloc=(/1,1,inative+1/) - us_startloc=(/1,1,inative+1/) - vw_startloc=(/1,1,inative+1/) - vs_startloc=(/1,1,inative+1/) + uw_startloc=(/1,1,kbgn_native+1,1/) !In the coldstart files, there is an extra top level + us_startloc=(/1,1,kbgn_native+1,1/) + vw_startloc=(/1,1,kbgn_native+1,1/) + vs_startloc=(/1,1,kbgn_native+1,1/) + allocate( work_bu_s(nlon_regional,nlat_regional+1,kbgn_native:kend_native)) + allocate( work_bv_s(nlon_regional,nlat_regional+1,kbgn_native:kend_native)) + allocate( work_bu_w(nlon_regional+1,nlat_regional,kbgn_native:kend_native)) + allocate( work_bv_w(nlon_regional+1,nlat_regional,kbgn_native:kend_native)) +!!!!!!!! readin work_b !!!!!!!!!!!!!!!! + call check( nf90_get_var(gfile_loc,u_sgrd_VarId,work_bu_s,start=us_startloc,count=us_countloc) ) + call check( nf90_get_var(gfile_loc,u_wgrd_VarId,work_bu_w,start=uw_startloc,count=uw_countloc) ) + call check( nf90_get_var(gfile_loc,v_sgrd_VarId,work_bv_s,start=vs_startloc,count=vs_countloc) ) + call check( nf90_get_var(gfile_loc,v_wgrd_VarId,work_bv_w,start=vw_startloc,count=vw_countloc) ) + do ilevtot=kbgn,kend + varname=grd_uv%names(1,ilevtot) + ilev=grd_uv%lnames(1,ilevtot) + inative=nzp1-ilev work_au=hwork(1,:,:,ilevtot) work_av=hwork(2,:,:,ilevtot) - call check( nf90_inq_varid(gfile_loc,'u_s',u_sgrd_VarId) ) - call check( nf90_inq_varid(gfile_loc,'u_w',u_wgrd_VarId) ) - call check( nf90_inq_varid(gfile_loc,'v_s',v_sgrd_VarId) ) - call check( nf90_inq_varid(gfile_loc,'v_w',v_wgrd_VarId) ) -!!!!!!!! readin work_b !!!!!!!!!!!!!!!! - call check( nf90_get_var(gfile_loc,u_sgrd_VarId,work_bu_s,start=us_startloc,count=us_countloc) ) - call check( nf90_get_var(gfile_loc,u_wgrd_VarId,work_bu_w,start=uw_startloc,count=uw_countloc) ) - call check( nf90_get_var(gfile_loc,v_sgrd_VarId,work_bv_s,start=vs_startloc,count=vs_countloc) ) - call check( nf90_get_var(gfile_loc,v_wgrd_VarId,work_bv_w,start=vw_startloc,count=vw_countloc) ) if(add_saved)then do j=1,nlat_regional - u2d(:,j)=half * (work_bu_s(:,j)+ work_bu_s(:,j+1)) + u2d(:,j)=half * (work_bu_s(:,j,inative)+ work_bu_s(:,j+1,inative)) enddo do i=1,nlon_regional - v2d(i,:)=half*(work_bv_w(i,:)+work_bv_w(i+1,:)) + v2d(i,:)=half*(work_bv_w(i,:,inative)+work_bv_w(i+1,:,inative)) enddo call fv3_h_to_ll(u2d,workau2,nlon_regional,nlat_regional,nloncase,nlatcase,grid_reverse_flag) call fv3_h_to_ll(v2d,workav2,nlon_regional,nlat_regional,nloncase,nlatcase,grid_reverse_flag) @@ -4333,44 +4426,46 @@ subroutine gsi_fv3ncdf_writeuv_v1(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) - work_bu_w(:,:)=work_bu_w(:,:)+workbu_w2(:,:) - work_bu_s(:,:)=work_bu_s(:,:)+workbu_s2(:,:) - work_bv_w(:,:)=work_bv_w(:,:)+workbv_w2(:,:) - work_bv_s(:,:)=work_bv_s(:,:)+workbv_s2(:,:) + work_bu_w(:,:,inative)=work_bu_w(:,:,inative)+workbu_w2(:,:) + work_bu_s(:,:,inative)=work_bu_s(:,:,inative)+workbu_s2(:,:) + work_bv_w(:,:,inative)=work_bv_w(:,:,inative)+workbv_w2(:,:) + work_bv_s(:,:,inative)=work_bv_s(:,:,inative)+workbv_s2(:,:) else call fv3_ll_to_h(work_au(:,:),u2d,nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag) call fv3_ll_to_h(work_av(:,:),v2d,nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag) do i=2,nlon_regional - work_bu_w(i,:)=half*(u2d(i-1,:)+u2d(i,:)) - work_bv_w(i,:)=half*(v2d(i-1,:)+v2d(i,:)) + work_bu_w(i,:,inative)=half*(u2d(i-1,:)+u2d(i,:)) + work_bv_w(i,:,inative)=half*(v2d(i-1,:)+v2d(i,:)) enddo - work_bu_w(1,:)=u2d(1,:) - work_bv_w(1,:)=v2d(1,:) - work_bu_w(nlon_regional+1,:)=u2d(nlon_regional,:) - work_bv_w(nlon_regional+1,:)=v2d(nlon_regional,:) + work_bu_w(1,:,inative)=u2d(1,:) + work_bv_w(1,:,inative)=v2d(1,:) + work_bu_w(nlon_regional+1,:,inative)=u2d(nlon_regional,:) + work_bv_w(nlon_regional+1,:,inative)=v2d(nlon_regional,:) do j=2,nlat_regional - work_bu_s(:,j)=half*(u2d(:,j-1)+u2d(:,j)) - work_bv_s(:,j)=half*(v2d(:,j-1)+v2d(:,j)) + work_bu_s(:,j,inative)=half*(u2d(:,j-1)+u2d(:,j)) + work_bv_s(:,j,inative)=half*(v2d(:,j-1)+v2d(:,j)) enddo - work_bu_s(:,1)=u2d(:,1) - work_bv_s(:,1)=v2d(:,1) - work_bu_s(:,nlat_regional+1)=u2d(:,nlat_regional) - work_bv_s(:,nlat_regional+1)=v2d(:,nlat_regional) + work_bu_s(:,1,inative)=u2d(:,1) + work_bv_s(:,1,inative)=v2d(:,1) + work_bu_s(:,nlat_regional+1,inative)=u2d(:,nlat_regional) + work_bv_s(:,nlat_regional+1,inative)=v2d(:,nlat_regional) endif - - call check( nf90_put_var(gfile_loc,u_wgrd_VarId,work_bu_w,start=uw_startloc,count=uw_countloc) ) - call check( nf90_put_var(gfile_loc,u_sgrd_VarId,work_bu_s,start=us_startloc,count=us_countloc) ) - call check( nf90_put_var(gfile_loc,v_wgrd_VarId,work_bv_w,start=vw_startloc,count=vw_countloc) ) - call check( nf90_put_var(gfile_loc,v_sgrd_VarId,work_bv_s,start=vs_startloc,count=vs_countloc) ) enddo ! + + call check( nf90_put_var(gfile_loc,u_wgrd_VarId,work_bu_w,start=uw_startloc,count=uw_countloc) ) + call check( nf90_put_var(gfile_loc,u_sgrd_VarId,work_bu_s,start=us_startloc,count=us_countloc) ) + call check( nf90_put_var(gfile_loc,v_wgrd_VarId,work_bv_w,start=vw_startloc,count=vw_countloc) ) + call check( nf90_put_var(gfile_loc,v_sgrd_VarId,work_bv_s,start=vs_startloc,count=vs_countloc) ) call check( nf90_close(gfile_loc) ) deallocate(work_bu_w,work_bv_w) deallocate(work_bu_s,work_bv_s) + endif !procuse + deallocate(work_au,work_av,u2d,v2d) if(add_saved) deallocate(workau2,workav2) if (allocated(workbu_w2)) then @@ -4541,8 +4636,8 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file use mod_fv3_lola, only: fv3_ll_to_h use mod_fv3_lola, only: fv3_h_to_ll use netcdf, only: nf90_open,nf90_close - use netcdf, only: nf90_write,nf90_inq_varid - use netcdf, only: nf90_put_var,nf90_get_var + use netcdf, only: nf90_write,nf90_netcdf4, nf90_mpiio,nf90_inq_varid + use netcdf, only: nf90_put_var,nf90_get_var,nf90_independent,nf90_var_par_access use netcdf, only: nf90_inquire_dimension use gsi_bundlemod, only: gsi_bundle use general_sub2grid_mod, only: sub2grid_info,general_sub2grid @@ -4558,8 +4653,8 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file character(len=max_filename_length) :: filenamein2 character(len=max_varname_length) :: varname,vgsiname,name - integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(3),startloc(3) - integer(i_kind) countloc_tmp(3),startloc_tmp(3) + integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(4),startloc(4) + integer(i_kind) countloc_tmp(4),startloc_tmp(4) integer(i_kind) kbgn,kend integer(i_kind) inative,ilev,ilevtot integer(i_kind) :: VarId,gfile_loc @@ -4621,11 +4716,11 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file allocate(gfile_loc_layout(0:fv3_io_layout_y-1)) do nio=0,fv3_io_layout_y-1 write(filename_layout,'(a,a,I4.4)') trim(filenamein),'.',nio - call check( nf90_open(filename_layout,nf90_write,gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) ) + call check( nf90_open(filename_layout,ior(nf90_netcdf4,ior(nf90_write, nf90_mpiio)),gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) ) enddo gfile_loc=gfile_loc_layout(0) else - call check( nf90_open(filenamein,nf90_write,gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) ) + call check( nf90_open(filenamein,ior(nf90_netcdf4,ior(nf90_write, nf90_mpiio)),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) ) endif do ilevtot=kbgn,kend @@ -4637,15 +4732,14 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname) if(trim(filenamein) /= trim(filenamein2)) then write(6,*)'filenamein and filenamein2 are not the same as expected, stop' - call flush(6) call stop2(333) endif ilev=grd_ionouv%lnames(1,ilevtot) nz=grd_ionouv%nsig nzp1=nz+1 inative=nzp1-ilev - countloc=(/nxcase,nycase,1/) - startloc=(/1,1,inative/) + countloc=(/nxcase,nycase,1,1/) + startloc=(/1,1,inative,1/) work_a=hwork(1,:,:,ilevtot) @@ -4654,23 +4748,24 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file if(trim(name)=='xaxis_1') nx_phy=len if( nx_phy == nxcase )then allocate(work_b_tmp(nxcase,nycase)) - countloc_tmp=(/nxcase,nycase,1/) + countloc_tmp=(/nxcase,nycase,1,1/) phy_smaller_domain = .false. else allocate(work_b_tmp(nxcase-6,nycase-6)) - countloc_tmp=(/nxcase-6,nycase-6,1/) + countloc_tmp=(/nxcase-6,nycase-6,1,1/) phy_smaller_domain = .true. end if - startloc_tmp=(/1,1,ilev/) + startloc_tmp=(/1,1,ilev,1/) end if call check( nf90_inq_varid(gfile_loc,trim(varname),VarId) ) + call check( nf90_var_par_access(gfile_loc, VarId, nf90_independent)) if(index(vgsiname,"delzinc") > 0) then if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 - countloc=(/nxcase,ny_layout_len(nio),1/) + countloc=(/nxcase,ny_layout_len(nio),1,1/) allocate(work_b_layout(nxcase,ny_layout_len(nio))) call check( nf90_get_var(gfile_loc_layout(nio),VarId,work_b_layout,start = startloc, count = countloc) ) work_b(:,ny_layout_b(nio):ny_layout_e(nio))=work_b_layout @@ -4685,7 +4780,7 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file if(add_saved)then if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 - countloc=(/nxcase,ny_layout_len(nio),1/) + countloc=(/nxcase,ny_layout_len(nio),1,1/) allocate(work_b_layout(nxcase,ny_layout_len(nio))) call check( nf90_get_var(gfile_loc_layout(nio),VarId,work_b_layout,start = startloc, count = countloc) ) work_b(:,ny_layout_b(nio):ny_layout_e(nio))=work_b_layout @@ -4721,7 +4816,7 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file endif if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 - countloc=(/nxcase,ny_layout_len(nio),1/) + countloc=(/nxcase,ny_layout_len(nio),1,1/) allocate(work_b_layout(nxcase,ny_layout_len(nio))) work_b_layout=work_b(:,ny_layout_b(nio):ny_layout_e(nio)) call check( nf90_put_var(gfile_loc_layout(nio),VarId,work_b_layout, start = startloc, count = countloc) ) @@ -4795,12 +4890,13 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f ! !$$$ end documentation block - use mpimod, only: mpi_rtype,mpi_comm_world,mype,mpi_info_null + use mpimod, only: npe, setcomm,mpi_integer,mpi_max,mpi_rtype,mpi_comm_world,mype,mpi_info_null use mod_fv3_lola, only: fv3_ll_to_h use mod_fv3_lola, only: fv3_h_to_ll use netcdf, only: nf90_open,nf90_close - use netcdf, only: nf90_write,nf90_inq_varid + use netcdf, only: nf90_write, nf90_netcdf4,nf90_mpiio,nf90_inq_varid use netcdf, only: nf90_put_var,nf90_get_var + use netcdf, only: nf90_independent,nf90_var_par_access use gsi_bundlemod, only: gsi_bundle use general_sub2grid_mod, only: sub2grid_info,general_sub2grid implicit none @@ -4824,6 +4920,10 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f character(len=max_varname_length) :: varname,vgsiname integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(3),startloc(3) + integer(i_kind):: iworld,iworld_group,nread,mpi_comm_read,i,ierror + integer(i_kind),dimension(npe):: members,members_read,mype_read_rank + logical:: procuse + mm1=mype+1 nloncase=grd_ionouv%nlon @@ -4838,7 +4938,30 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f allocate( work_b(nlon_regional,nlat_regional)) allocate( workb2(nlon_regional,nlat_regional)) allocate( worka2(nlatcase,nloncase)) - call check ( nf90_open(filenamein,nf90_write,gfile_loc,comm=mpi_comm_world,info=MPI_INFO_NULL)) !clt + + procuse = .false. + members=-1 + members_read=-1 + if (kbgn<=kend) then + procuse = .true. + members(mm1) = mype + endif + + call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror) + + nread=0 + mype_read_rank=-1 + do i=1,npe + if (members_read(i) >= 0) then + nread=nread+1 + mype_read_rank(nread) = members_read(i) + endif + enddo + + call setcomm(iworld,iworld_group,nread,mype_read_rank,mpi_comm_read,ierror) + + if (procuse) then + call check ( nf90_open(filenamein,ior(nf90_netcdf4,ior(nf90_write, nf90_mpiio)),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL)) !clt do ilevtot=kbgn,kend vgsiname=grd_ionouv%names(1,ilevtot) if(trim(vgsiname)=='amassi') cycle @@ -4848,7 +4971,6 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname) if(trim(filenamein) /= trim(filenamein2)) then write(6,*)'filenamein and filenamein2 are not the same as expected, stop' - call flush(6) call stop2(333) endif ilev=grd_ionouv%lnames(1,ilevtot) @@ -4862,6 +4984,7 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f call check( nf90_inq_varid(gfile_loc,trim(varname),VarId) ) + call check( nf90_var_par_access(gfile_loc, VarId, nf90_independent)) call check( nf90_get_var(gfile_loc,VarId,work_b,start=startloc,count=countloc) ) if(index(vgsiname,"delzinc") > 0) then write(6,*)'delz is not in the cold start fiels with this option, incompatible setup , stop' @@ -4885,6 +5008,7 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f call check( nf90_put_var(gfile_loc,VarId,work_b,start=startloc,count=countloc) ) enddo !ilevtot call check(nf90_close(gfile_loc)) + endif deallocate(work_b,work_a) deallocate(worka2,workb2) @@ -5420,7 +5544,7 @@ subroutine gsi_copy_bundle(bundi,bundo) character(len=max_varname_length),dimension(:),allocatable:: target_name_vars3d character(len=max_varname_length) ::varname real(r_kind),dimension(:,:,:),pointer:: pvar3d=>NULL() - real(r_kind),dimension(:,:,:),pointer:: pvar2d =>NULL() + real(r_kind),dimension(:,:),pointer:: pvar2d =>NULL() integer(i_kind):: src_nc3d,src_nc2d,target_nc3d,target_nc2d integer(i_kind):: ivar,jvar,istatus src_nc3d=bundi%n3d diff --git a/ush/sub_hera b/ush/sub_hera index 610756af00..c94b734596 100755 --- a/ush/sub_hera +++ b/ush/sub_hera @@ -120,10 +120,10 @@ echo "#SBATCH --output=$output" echo "#SBATCH --job-name=$jobname" >> $cfile echo "#SBATCH --qos=$queue" >> $cfile echo "#SBATCH --time=$timew" >> $cfile -echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile +echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --exclusive" >> $cfile #echo "#SBATCH -j oe" >> $cfile echo "#SBATCH --account=$accnt" >> $cfile -echo "#SBATCH --mem=0" >> $cfile +#cltorg echo "#SBATCH --mem=0" >> $cfile #echo "#SBATCH -V" >> $cfile #echo "#PBS -d" >> $cfile #. $exec >> $cfile @@ -143,7 +143,6 @@ echo "module list" >> $cfile echo "" >>$cfile cat $exec >> $cfile - if [[ $nosub = YES ]];then cat $cfile exit diff --git a/ush/sub_hercules b/ush/sub_hercules index 459b480559..78a0f5daee 100755 --- a/ush/sub_hercules +++ b/ush/sub_hercules @@ -111,7 +111,7 @@ echo "#SBATCH --job-name=$jobname" echo "#SBATCH --qos=$queue" >> $cfile echo "#SBATCH --partition=$partition" >> $cfile echo "#SBATCH --time=$timew" >> $cfile -echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile +echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --exclusive" >> $cfile echo "#SBATCH --account=$accnt" >> $cfile echo "" >>$cfile @@ -131,7 +131,7 @@ echo "module use $modulefiles" >> $cfile echo "module load gsi_hercules.intel" >> $cfile #TODO reenable I_MPI_EXTRA_FILESYSTEM once regional ctests can properly handle parallel I/O on Hercules echo "unset I_MPI_EXTRA_FILESYSTEM" >> $cfile -echo "" >> $cfile + cat $exec >> $cfile if [[ $nosub = YES ]];then diff --git a/ush/sub_jet b/ush/sub_jet index 9bd60486f6..96f3eae9b2 100755 --- a/ush/sub_jet +++ b/ush/sub_jet @@ -108,7 +108,7 @@ echo "#SBATCH --output=$output" echo "#SBATCH --job-name=$jobname" >> $cfile echo "#SBATCH --qos=$queue" >> $cfile echo "#SBATCH --time=$timew" >> $cfile -echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile +echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --exclusive" >> $cfile echo "#SBATCH --account=$accnt" >> $cfile echo "#SBATCH --mem=0" >> $cfile echo "#SBATCH --partition=kjet" >> $cfile diff --git a/ush/sub_orion b/ush/sub_orion index 5a13f54845..b810576379 100755 --- a/ush/sub_orion +++ b/ush/sub_orion @@ -111,7 +111,7 @@ echo "#SBATCH --job-name=$jobname" echo "#SBATCH --qos=$queue" >> $cfile echo "#SBATCH --partition=$partition" >> $cfile echo "#SBATCH --time=$timew" >> $cfile -echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile +echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --exclusive" >> $cfile echo "#SBATCH --account=$accnt" >> $cfile echo "" >>$cfile From f7e93abf1ff19f27aae148c74fd3d6561e49c117 Mon Sep 17 00:00:00 2001 From: TingLei-NOAA <63461756+TingLei-NOAA@users.noreply.github.com> Date: Sun, 24 Mar 2024 17:21:10 -0400 Subject: [PATCH 068/109] GSI built with debug mode failed in the global_4densvar (#722) Co-authored-by: Tinglei-daprediction --- .../cmake/gsiapp_compiler_flags_Intel_Fortran.cmake | 2 +- src/gsi/intjcmod.f90 | 2 +- src/gsi/read_nsstbufr.f90 | 12 ++++++------ 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/gsi/cmake/gsiapp_compiler_flags_Intel_Fortran.cmake b/src/gsi/cmake/gsiapp_compiler_flags_Intel_Fortran.cmake index 8ba2887da8..b1d28132dc 100644 --- a/src/gsi/cmake/gsiapp_compiler_flags_Intel_Fortran.cmake +++ b/src/gsi/cmake/gsiapp_compiler_flags_Intel_Fortran.cmake @@ -14,7 +14,7 @@ set(CMAKE_Fortran_FLAGS_RELEASE "-O3 -fp-model strict") # DEBUG FLAGS #################################################################### -set(CMAKE_Fortran_FLAGS_DEBUG "-O0 -fp-model source -debug -ftrapuv -warn all,nointerfaces -check all,noarg_temp_created -fp-stack-check -fstack-protector") +set(CMAKE_Fortran_FLAGS_DEBUG "-O0 -init=snan,arrays -fp-model source -debug -ftrapuv -warn all,nointerfaces -check all,noarg_temp_created -fp-stack-check -fstack-protector") #################################################################### # LINK FLAGS diff --git a/src/gsi/intjcmod.f90 b/src/gsi/intjcmod.f90 index 4b149da6b9..a3af642111 100644 --- a/src/gsi/intjcmod.f90 +++ b/src/gsi/intjcmod.f90 @@ -103,7 +103,7 @@ subroutine intlimq(rval,sval,itbin) call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'q',ges_q_it,ier) if(ier/=0)return -!$omp parallel do schedule(dynamic,1) private(k,j,i,q) +!$omp parallel do schedule(dynamic,1) private(k,j,i,ii,q) do k = 1,nsig do j = 2,lon1+1 do i = 2,lat1+1 diff --git a/src/gsi/read_nsstbufr.f90 b/src/gsi/read_nsstbufr.f90 index f287dbd0b8..97096f3760 100644 --- a/src/gsi/read_nsstbufr.f90 +++ b/src/gsi/read_nsstbufr.f90 @@ -542,9 +542,9 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & kx = 197 sstoe = one elseif ( trim(subset) == 'NC031002' ) then ! TESAC - if ( tpf(1,1) >= one .and. tpf(1,1) < 20.0_r_kind ) then - zob = tpf(1,1) - elseif ( tpf(1,1) >= zero .and. tpf(1,1) < one ) then + if ( tpf2(1,1) >= one .and. tpf2(1,1) < 20.0_r_kind ) then + zob = tpf2(1,1) + elseif ( tpf2(1,1) >= zero .and. tpf2(1,1) < one ) then zob = one endif kx = 198 @@ -553,9 +553,9 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & kx = 199 ! classify argo & glider to be bathy type sstoe = r0_6 elseif ( trim(subset) == 'NC031001' ) then ! BATHY - if ( tpf(1,1) >= one .and. tpf(1,1) <= 20.0_r_kind ) then - zob = tpf(1,1) - elseif ( tpf(1,1) >= zero .and. tpf(1,1) < one ) then + if ( tpf2(1,1) >= one .and. tpf2(1,1) <= 20.0_r_kind ) then + zob = tpf2(1,1) + elseif ( tpf2(1,1) >= zero .and. tpf2(1,1) < one ) then zob = one endif kx = 199 From 1cc934edaaa77bd3eee51744f1cf81810d52e2c0 Mon Sep 17 00:00:00 2001 From: shoyokota <103961291+shoyokota@users.noreply.github.com> Date: Tue, 26 Mar 2024 07:07:28 -0400 Subject: [PATCH 069/109] Add the Multigrid Beta Filter (MGBF) for ensemble localization (#699) (#700) **DUE DATE for merger of this PR into `develop` is 3/29/2024 (six weeks after PR creation).** **Description** Resolves #699 This PR is to add the option to apply Multigrid Beta Filter (MGBF; [Purser et al. 2022](https://doi.org/10.1175/MWR-D-20-0405.1)) for ensemble localization instead of Recursive Filter (RF). This work includes to add an initial version of the MGBF as a subdirectory in GSI. To apply the MGBF, set "l_mgbf_loc=true" in the namelist and additionally input "mgbf_loc01.nml". (In Scale/Variable-Dependent Localization, input also "mgbf_locXX.nml" (XX=02,03,...) with the same number of grid points.)
**How to set MGBF parameters in mgbf_locXX.nml** An example of mgbf_locXX.nml is as follows: ``` &PARAMETERS_MGBETA mg_ampl01=1.125, ! length of vertical beta filter (standard deviation; filter grid unit) mg_ampl02=2.4, ! length of horizontal beta filter (standard deviation; filter grid unit) mg_ampl03=0.85, ! length of 3D beta filter (standard deviation; filter grid unit) mg_weig1=0., ! weight of generation 1 mg_weig2=0., ! weight of generation 2 mg_weig3=0., ! weight of generation 3 mg_weig4=1., ! weight of generation 4 hx=5, ! number of halo grid points in x-direction hy=5, ! number of halo grid points in y-direction hz=3, ! number of halo grid points in z-direction p=2, ! beta filter exponent mgbf_line=.false., ! set false except for mgbf_proc=2,4,7 mgbf_proc=8, ! 1-2: 3D filter; 3-5: 2D filter for static B; 6-8: 2D filter for localization (1,3,6: radial filter; 2,4,7: line filter; 5,8: isotropic line filter) lm_a=65, ! number of vertical layers in analysis grid lm=33, ! number of vertical layers in filter grid km2=0, ! number of 2D variables (set 0 for localization) km3=1, ! number of 3D variables (set 1 for localization) n_ens=30, ! ensemble size l_loc=.true., ! set true in localization l_filt_g1=.false., ! set false in skipping generation 1 l_lin_vertical=.true., ! set true in applying linear vertical interpolation for analysis-filter mapping l_lin_horizontal=.true., ! set true in applying linear horizontal interpolation for analysis-filter mapping l_quad_horizontal=.false., ! set true in applying quadratic horizontal interpolation for analysis-filter mapping l_new_map=.true., ! set true in applying efficient vertical interpolation for analysis-filter mapping l_vertical_filter=.true., ! set true in applying vertical beta filter outside 2D filter ldelta=.false., ! (not used) lquart=.false., ! set true in applying quadratic horizontal interpolation for up/down-sending lhelm=.false., ! set true in applying Helmholtz differential operator for weighting nm0=1975, ! number of analysis grid points in x-direction mm0=1350, ! number of analysis grid points in y-direction gm_max=4, ! highest generation (max: 4) nxPE=79, ! number of MPI processors in x-direction nyPE=54, ! number of MPI processors in y-direction im_filt=8, ! number of filter grid points in each MPI processor in x-direction jm_filt=8, ! number of filter grid points in each MPI processor in y-direction / ``` Here, to make the result of MGBF-based localization similar to RF-based one, we can set the beta filter length ( mg_ampl0[12] ) from the recursive filter length in the GSI namelist ( s_ens_[vh] ) as: - $\text{mg\\_ampl01} = \left[\text{s\\_ens\\_v (grid unit)} * \frac{1}{\sqrt{2}} * \frac{\text{lm}-1}{\text{lm\\_a}-1} \right]^2$ - $\text{mg\\_ampl02} = \left[\frac{\text{s\\_ens\\_h (km)}}{\text{analysis grid interval (km)}} * \frac{1}{\sqrt{2}} * \frac{\text{im\\_filt} * \text{nxPE}}{\text{nm0}} * \frac{1}{2} * \frac{1}{2} * \frac{1}{2} \right]^2$ (in case mg_weig[1-4]=[0,0,0,1]) Please note there are some limitations for the other MGBF parameters such as: - The number of MPI processors input in GSI should be nxPE x nyPE - (nm0, mm0, lm_a) should be the same as the GSI analysis grid - nm0 should be divisible by nxPE - mm0 should be divisible by nyPE - nm0 / nxPE = mm0 / nyPE
**How to run RRFS regression tests with MGBF-based localization** Change settings in regression/ as follows, and run Test#3 (rrfs_3denvar_glbens) ```diff diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh index 7ca183ef3..671d028ff 100755 --- a/regression/regression_namelists.sh +++ b/regression/regression_namelists.sh @@ -457,7 +457,7 @@ OBS_INPUT:: beta_s0=0.15,s_ens_h=110,s_ens_v=3, regional_ensemble_option=1, pseudo_hybens = .false., - grid_ratio_ens = 3, + grid_ratio_ens = 5.1, l_ens_in_diff_time=.true., ensemble_path='', i_en_perts_io=1, @@ -465,6 +465,7 @@ OBS_INPUT:: fv3sar_bg_opt=0, readin_localization=.true., ens_fast_read=.false., + l_mgbf_loc=.true., / &RAPIDREFRESH_CLDSURF dfi_radar_latent_heat_time_period=20.0, ``` ```diff diff --git a/regression/regression_namelists_db.sh b/regression/regression_namelists_db.sh index e03917e88..36b8b6a22 100755 --- a/regression/regression_namelists_db.sh +++ b/regression/regression_namelists_db.sh @@ -438,7 +438,7 @@ OBS_INPUT:: beta_s0=0.15,s_ens_h=110,s_ens_v=3, regional_ensemble_option=1, pseudo_hybens = .false., - grid_ratio_ens = 3, + grid_ratio_ens = 5.1, l_ens_in_diff_time=.true., ensemble_path='', i_en_perts_io=1, @@ -446,6 +446,7 @@ OBS_INPUT:: fv3sar_bg_opt=0, readin_localization=.true., ens_fast_read=.false., + l_mgbf_loc=.true., / &RAPIDREFRESH_CLDSURF dfi_radar_latent_heat_time_period=20.0, ``` ```diff diff --git a/regression/regression_param.sh b/regression/regression_param.sh index 2ac615fc4..6186acdbb 100755 --- a/regression/regression_param.sh +++ b/regression/regression_param.sh @@ -87,23 +87,23 @@ case $regtest in rrfs_3denvar_glbens) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="30/2/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="15/4/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="30/2/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="15/4/" ; ropts[2]="/2" elif [[ "$machine" = "Hercules" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="30/2/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="15/4/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="15/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/6/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="15/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/6/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then - topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="60/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="30/2/" ; ropts[2]="/1" fi if [ "$debug" = ".true." ] ; then ``` ```diff diff --git a/regression/rrfs_3denvar_glbens.sh b/regression/rrfs_3denvar_glbens.sh index af5da5117..04fd73d57 100755 --- a/regression/rrfs_3denvar_glbens.sh +++ b/regression/rrfs_3denvar_glbens.sh @@ -272,6 +272,46 @@ $gsi_namelist EOF +cat << EOF > mgbf_loc01.nml +&PARAMETERS_MGBETA + mg_ampl01=1.125, ! length of vertical beta filter (standard deviation; filter grid unit) + mg_ampl02=1.615, ! length of horizontal beta filter (standard deviation; filter grid unit) + mg_ampl03=0.85, ! length of 3D beta filter (standard deviation; filter grid unit) + mg_weig1=0., ! weight of generation 1 + mg_weig2=1., ! weight of generation 2 + mg_weig3=0., ! weight of generation 3 + mg_weig4=0., ! weight of generation 4 + hx=4, ! number of halo grid points in x-direction + hy=4, ! number of halo grid points in y-direction + hz=3, ! number of halo grid points in z-direction + p=2, ! beta filter exponent + mgbf_line=.false., ! set false except for mgbf_proc=2,4,7 + mgbf_proc=8, ! 1-2: 3D filter; 3-5: 2D filter for static B; 6-8: 2D filter for localization (1,3,6: radial filter; 2,4,7: line filter; 5,8: isotropic line filter) + lm_a=65, ! number of vertical layers in analysis grid + lm=33, ! number of vertical layers in filter grid + km2=0, ! number of 2D variables (set 0 for localization) + km3=1, ! number of 3D variables (set 1 for localization) + n_ens=10, ! ensemble size + l_loc=.true., ! set true in localization + l_filt_g1=.false., ! set false in skipping generation 1 + l_lin_vertical=.true., ! set true in applying linear vertical interpolation for analysis-filter mapping + l_lin_horizontal=.true., ! set true in applying linear horizontal interpolation for analysis-filter mapping + l_quad_horizontal=.false., ! set true in applying quadratic horizontal interpolation for analysis-filter mapping + l_new_map=.true., ! set true in applying efficient vertical interpolation for analysis-filter mapping + l_vertical_filter=.true., ! set true in applying vertical beta filter outside 2D filter + ldelta=.false., ! (not used) + lquart=.false., ! set true in applying quadratic horizontal interpolation for up/down-sending + lhelm=.false., ! set true in applying Helmholtz differential operator for weighting + nm0=40, ! number of analysis grid points in x-direction + mm0=24, ! number of analysis grid points in y-direction + gm_max=2, ! highest generation (max: 4) + nxPE=10, ! number of MPI processors in x-direction + nyPE=6, ! number of MPI processors in y-direction + im_filt=4, ! number of filter grid points in each MPI processor in x-direction + jm_filt=4, ! number of filter grid points in each MPI processor in y-direction + / +EOF + # Copy executable and fixed files to $tmpdir if [[ $exp == *"updat"* ]]; then $ncp $gsiexec_updat ./gsi.x ```
**Type of change** Please delete options that are not relevant. - [ ] Bug fix (non-breaking change which fixes an issue) - [x] New feature (non-breaking change which adds functionality) - [ ] Breaking change (fix or feature that would cause existing functionality to not work as expected) - [ ] This change requires a documentation update **How Has This Been Tested?** EnVar for NA-domain RRFS was tested with "mgbf_locXX.nml" (XX=01) shown above on Orion. The resulting analysis increment was similar to the original and the computation time for localization became short. **Checklist** - [x] My code follows the style guidelines of this project - [x] I have performed a self-review of my own code - [x] I have commented my code, particularly in hard-to-understand areas - [x] New and existing tests pass with my changes - [x] Any dependent changes have been merged and published Co-authored-by: Sho Yokota --- CMakeLists.txt | 2 + INSTALL.md | 1 + src/CMakeLists.txt | 5 + src/gsi/CMakeLists.txt | 15 + src/gsi/gsimod.F90 | 18 +- src/gsi/hybrid_ensemble_isotropic.F90 | 515 +- src/gsi/hybrid_ensemble_parameters.f90 | 5 + src/mgbf/CMakeLists.txt | 98 + src/mgbf/cmake/PackageConfig.cmake.in | 19 + src/mgbf/jp_pbfil.f90 | 1119 ++++ src/mgbf/jp_pbfil2.f90 | 1173 ++++ src/mgbf/jp_pbfil3.f90 | 2620 ++++++++ src/mgbf/jp_pietc.f90 | 111 + src/mgbf/jp_pietc_s.f90 | 113 + src/mgbf/jp_pkind.f90 | 34 + src/mgbf/jp_pkind2.f90 | 25 + src/mgbf/jp_pmat.f90 | 1096 ++++ src/mgbf/jp_pmat4.f90 | 2086 ++++++ src/mgbf/kinds.f90 | 118 + src/mgbf/mg_bocos.f90 | 8016 ++++++++++++++++++++++++ src/mgbf/mg_domain.f90 | 644 ++ src/mgbf/mg_domain_loc.f90 | 796 +++ src/mgbf/mg_entrymod.f90 | 158 + src/mgbf/mg_filtering.f90 | 1629 +++++ src/mgbf/mg_generations.f90 | 1756 ++++++ src/mgbf/mg_input.f90 | 155 + src/mgbf/mg_interpolate.f90 | 972 +++ src/mgbf/mg_intstate.f90 | 1394 ++++ src/mgbf/mg_mppstuff.f90 | 190 + src/mgbf/mg_parameter.f90 | 936 +++ src/mgbf/mg_timers.f90 | 218 + src/mgbf/mg_transfer.f90 | 499 ++ src/mgbf/type_intstat_locpointer.inc | 44 + src/mgbf/type_intstat_point2this.inc | 83 + src/mgbf/type_parameter_locpointer.inc | 105 + src/mgbf/type_parameter_point2this.inc | 189 + 36 files changed, 26816 insertions(+), 141 deletions(-) create mode 100644 src/mgbf/CMakeLists.txt create mode 100644 src/mgbf/cmake/PackageConfig.cmake.in create mode 100644 src/mgbf/jp_pbfil.f90 create mode 100644 src/mgbf/jp_pbfil2.f90 create mode 100644 src/mgbf/jp_pbfil3.f90 create mode 100644 src/mgbf/jp_pietc.f90 create mode 100644 src/mgbf/jp_pietc_s.f90 create mode 100644 src/mgbf/jp_pkind.f90 create mode 100644 src/mgbf/jp_pkind2.f90 create mode 100644 src/mgbf/jp_pmat.f90 create mode 100644 src/mgbf/jp_pmat4.f90 create mode 100644 src/mgbf/kinds.f90 create mode 100644 src/mgbf/mg_bocos.f90 create mode 100644 src/mgbf/mg_domain.f90 create mode 100644 src/mgbf/mg_domain_loc.f90 create mode 100644 src/mgbf/mg_entrymod.f90 create mode 100644 src/mgbf/mg_filtering.f90 create mode 100644 src/mgbf/mg_generations.f90 create mode 100644 src/mgbf/mg_input.f90 create mode 100644 src/mgbf/mg_interpolate.f90 create mode 100644 src/mgbf/mg_intstate.f90 create mode 100644 src/mgbf/mg_mppstuff.f90 create mode 100644 src/mgbf/mg_parameter.f90 create mode 100644 src/mgbf/mg_timers.f90 create mode 100644 src/mgbf/mg_transfer.f90 create mode 100644 src/mgbf/type_intstat_locpointer.inc create mode 100644 src/mgbf/type_intstat_point2this.inc create mode 100644 src/mgbf/type_parameter_locpointer.inc create mode 100644 src/mgbf/type_parameter_point2this.inc diff --git a/CMakeLists.txt b/CMakeLists.txt index ac2a6a71c7..176a765262 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -29,6 +29,7 @@ endif() option(OPENMP "Enable OpenMP Threading" OFF) option(ENABLE_MKL "Use MKL for LAPACK implementation (if available)" ON) option(BUILD_GSDCLOUD "Build GSD Cloud Analysis Library" OFF) +option(BUILD_MGBF "Build MGBF Library" ON) option(BUILD_GSI "Build GSI" ON) option(BUILD_ENKF "Build EnKF" ON) option(BUILD_REG_TESTING "Build the Regression Testing Suite" OFF) @@ -37,6 +38,7 @@ option(BUILD_REG_TESTING "Build the Regression Testing Suite" OFF) message(STATUS "OPENMP ................. ${OPENMP}") message(STATUS "ENABLE_MKL ............. ${ENABLE_MKL}") message(STATUS "BUILD_GSDCLOUD ......... ${BUILD_GSDCLOUD}") +message(STATUS "BUILD_MGBF ............. ${BUILD_MGBF}") message(STATUS "BUILD_GSI .............. ${BUILD_GSI}") message(STATUS "BUILD_ENKF ............. ${BUILD_ENKF}") message(STATUS "BUILD_REG_TESTING ...... ${BUILD_REG_TESTING}") diff --git a/INSTALL.md b/INSTALL.md index 8e3187f603..eca09919c3 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -79,6 +79,7 @@ CMake allows for various options that can be specified on the command line via ` | `OPENMP` | Enable OpenMP Threading (`OFF`) | | `ENABLE_MKL` | Use MKL (`ON`), If not found use LAPACK | | `BUILD_GSDCLOUD` | Build GSD Cloud Library (`OFF`) | +| `BUILD_MGBF` | Build MGBF Library (`ON`) | | `BUILD_GSI` | Build GSI library and executable (`ON`) | | `BUILD_ENKF` | Build EnKF library and executable (`ON`) | | `BUILD_REG_TESTING` | Enable Regression Testing (`ON`) | diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index a2eb249456..2f88b978c6 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -3,6 +3,11 @@ if(BUILD_GSDCLOUD) add_subdirectory(GSD) endif() +if(BUILD_MGBF) + message(STATUS "Building MGBF library") + add_subdirectory(mgbf) +endif() + if(BUILD_GSI) message(STATUS "Building GSI") add_subdirectory(gsi) diff --git a/src/gsi/CMakeLists.txt b/src/gsi/CMakeLists.txt index af94224c05..f894b0a8a8 100644 --- a/src/gsi/CMakeLists.txt +++ b/src/gsi/CMakeLists.txt @@ -29,6 +29,7 @@ endif() option(OPENMP "Enable OpenMP Threading" OFF) option(ENABLE_MKL "Use MKL for LAPACK implementation (if available)" ON) option(USE_GSDCLOUD "Use GSD Cloud Analysis library" OFF) +option(USE_MGBF "Use MGBF library" ON) set(GSI_VALID_MODES "GFS" "Regional") set(GSI_MODE "GFS" CACHE STRING "Choose the GSI Application.") @@ -43,6 +44,7 @@ endif() message(STATUS "GSI: OPENMP ................. ${OPENMP}") message(STATUS "GSI: ENABLE_MKL ............. ${ENABLE_MKL}") message(STATUS "GSI: USE_GSDCLOUD ........... ${USE_GSDCLOUD}") +message(STATUS "GSI: USE_MGBF ............... ${USE_MGBF}") message(STATUS "GSI: GSI_MODE ............... ${GSI_MODE}") # Dependencies @@ -87,6 +89,13 @@ if(USE_GSDCLOUD) endif() endif() +# MGBF library dependency +if(USE_MGBF) + if(NOT TARGET mgbf) + find_package(mgbf REQUIRED) + endif() +endif() + # Get compiler flags for the GSI application include(gsiapp_compiler_flags) @@ -158,6 +167,12 @@ if(USE_GSDCLOUD) endif() target_link_libraries(gsi_fortran_obj PUBLIC gsdcloud::gsdcloud) endif() +if(USE_MGBF) + if(TARGET mgbf) + add_dependencies(gsi_fortran_obj mgbf) + endif() + target_link_libraries(gsi_fortran_obj PUBLIC mgbf::mgbf) +endif() if(OpenMP_Fortran_FOUND) target_link_libraries(gsi_fortran_obj PRIVATE OpenMP::OpenMP_Fortran) endif() diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index 45d88887a3..8a1ce896bb 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -161,7 +161,7 @@ module gsimod ntotensgrp,nsclgrp,naensgrp,ngvarloc,ntlevs_ens,naensloc, & r_ensloccov4tim,r_ensloccov4var,r_ensloccov4scl,l_timloc_opt,& vdl_scale,vloc_varlist,& - global_spectral_filter_sd,assign_vdl_nml,parallelization_over_ensmembers + global_spectral_filter_sd,assign_vdl_nml,parallelization_over_ensmembers,l_mgbf_loc use hybrid_ensemble_parameters,only : l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar,weight_ens_gfs,weight_ens_fv3sar use rapidrefresh_cldsurf_mod, only: init_rapidrefresh_cldsurf, & dfi_radar_latent_heat_time_period,metar_impact_radius,& @@ -529,6 +529,7 @@ module gsimod ! - innov_use_model_fed=.true. : Use FED from BG to calculate innovation. ! this requires if_model_fed=.true. ! it works either an EnVar DA run or a GSI observer run. +! 02-20-2024 yokota - add MGBF-based localization ! !EOP !------------------------------------------------------------------------- @@ -1452,6 +1453,7 @@ module gsimod ! ^ ^ ^ ^ ^ ! s_ens_h = v1L1 v2L1 v3L1 v1L2 v2L2 ! Then localization lengths will be assigned as above. +! l_mgbf_loc - if true, multi-grid beta filter is used for localization instead of recursive filter ! namelist/hybrid_ensemble/l_hyb_ens,uv_hyb_ens,q_hyb_ens,aniso_a_en,generate_ens,n_ens,& l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar,weight_ens_gfs,weight_ens_fv3sar,nlon_ens,nlat_ens,jcap_ens,& @@ -1462,7 +1464,7 @@ module gsimod i_en_perts_io,l_ens_in_diff_time,ensemble_path,ens_fast_read,sst_staticB,limqens, & nsclgrp,l_timloc_opt,ngvarloc,naensloc,r_ensloccov4tim,r_ensloccov4var,r_ensloccov4scl,& vdl_scale,vloc_varlist,& - global_spectral_filter_sd,assign_vdl_nml,parallelization_over_ensmembers + global_spectral_filter_sd,assign_vdl_nml,parallelization_over_ensmembers,l_mgbf_loc ! rapidrefresh_cldsurf (options for cloud analysis and surface ! enhancement for RR appilcation ): @@ -1985,6 +1987,18 @@ subroutine gsimain_initialize regional=wrf_nmm_regional.or.wrf_mass_regional.or.twodvar_regional.or.nems_nmmb_regional .or. cmaq_regional regional=regional.or.fv3_regional.or.fv3_cmaq_regional +! Force turn off MGBF-based localization except for regional application + if(.not.regional.and.l_mgbf_loc) then + l_mgbf_loc=.false. + if(mype==0) write(6,*)'GSIMOD: for global app, l_mgbf_loc is not applicable, reset l_mgbf_loc=',l_mgbf_loc + end if + +! Force turn off MGBF-based localization for lsqrtb=.true. + if(lsqrtb.and.l_mgbf_loc) then + l_mgbf_loc=.false. + if(mype==0) write(6,*)'GSIMOD: for lsqrtb=.true., l_mgbf_loc is not applicable, reset l_mgbf_loc=',l_mgbf_loc + end if + ! Currently only able to have use_gfs_stratosphere=.true. for nems_nmmb_regional=.true. use_gfs_stratosphere=use_gfs_stratosphere.and.(nems_nmmb_regional.or.wrf_nmm_regional) if(mype==0) write(6,*) 'in gsimod: use_gfs_stratosphere,nems_nmmb_regional,wrf_nmm_regional= ', & diff --git a/src/gsi/hybrid_ensemble_isotropic.F90 b/src/gsi/hybrid_ensemble_isotropic.F90 index 05b3845627..87f3605eaf 100644 --- a/src/gsi/hybrid_ensemble_isotropic.F90 +++ b/src/gsi/hybrid_ensemble_isotropic.F90 @@ -49,6 +49,7 @@ module hybrid_ensemble_isotropic ! 2016-05-13 parrish - remove beta12mult ! 2018-02-15 wu - add code for fv3_regional option ! 2022-09-15 yokota - add scale/variable/time-dependent localization +! 2024-02-20 yokota - add MGBF-based localization ! ! subroutines included: ! sub init_rf_z - initialize localization recursive filter (z direction) @@ -102,6 +103,10 @@ module hybrid_ensemble_isotropic use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d use string_utility, only: StrUpCase +! For MGBF + use mg_intstate + use mg_timers + implicit none ! set default to private @@ -174,6 +179,12 @@ module hybrid_ensemble_isotropic real(r_kind),allocatable,dimension(:,:,:) :: spectral_filter,sqrt_spectral_filter integer(i_kind),allocatable,dimension(:) :: k_index + integer(r_kind) :: nval_loc_en + +! For MGBF + type (mg_intstate_type), allocatable, dimension(:) :: obj_mgbf + real(r_kind), allocatable, dimension(:,:,:) :: work_mgbf + ! following is for special subdomain to slab variables used when internally generating ensemble members integer(i_kind) nval2f,nscl @@ -183,7 +194,6 @@ module hybrid_ensemble_isotropic logical,parameter:: debug=.false. - contains subroutine init_rf_z(z_len) @@ -1732,6 +1742,7 @@ subroutine destroy_ensemble use hybrid_ensemble_parameters, only: l_hyb_ens,n_ens,ntlevs_ens use hybrid_ensemble_parameters, only: en_perts,ps_bar use hybrid_ensemble_parameters, only: ntotensgrp + use hybrid_ensemble_parameters, only: l_mgbf_loc implicit none integer(i_kind) istatus,n,m,ig @@ -1750,6 +1761,7 @@ subroutine destroy_ensemble enddo deallocate(ps_bar) deallocate(en_perts) + if(l_mgbf_loc) call print_mg_timers("mgbf_timing_cpu.csv", print_cpu, mype) end if return @@ -3608,7 +3620,6 @@ subroutine bkerror_a_en(grady) use hybrid_ensemble_parameters, only: n_ens use hybrid_ensemble_parameters, only: naensgrp use hybrid_ensemble_parameters, only: alphacvarsclgrpmat - use hybrid_ensemble_parameters, only: nval_lenz_en use gsi_bundlemod,only: gsi_bundlegetpointer implicit none @@ -3639,8 +3650,8 @@ subroutine bkerror_a_en(grady) call bkgcov_a_en_new_factorization(1,grady%aens(ii,1,1:n_ens)) end do else - allocate(z(nval_lenz_en,naensgrp)) - allocate(z2(nval_lenz_en)) + allocate(z(nval_loc_en,naensgrp)) + allocate(z2(nval_loc_en)) do ii=1,nsubwin do ig=1,naensgrp call ckgcov_a_en_new_factorization_ad(ig,z(1,ig),grady%aens(ii,ig,1:n_ens)) @@ -3648,7 +3659,7 @@ subroutine bkerror_a_en(grady) do ig=1,naensgrp z2=zero do ig2=1,naensgrp - do k=1,nval_lenz_en + do k=1,nval_loc_en z2(k) = z2(k) + z(k,ig2) * alphacvarsclgrpmat(ig,ig2) enddo enddo @@ -3699,9 +3710,11 @@ subroutine bkgcov_a_en_new_factorization(ig,a_en) use kinds, only: r_kind,i_kind use gridmod, only: regional use hybrid_ensemble_parameters, only: n_ens,grd_loc + use hybrid_ensemble_parameters, only: l_mgbf_loc,naensgrp use general_sub2grid_mod, only: general_sub2grid,general_grid2sub use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer + use constants, only: zero implicit none @@ -3717,54 +3730,101 @@ subroutine bkgcov_a_en_new_factorization(ig,a_en) ipnt=1 +! MGBF-based localization (now available only in regional=.true.) +! (Note that MGBF is applied only in ig<=naensgrp +! because recursive filter is applied for ig>naensgrp +! to separate scales for scale-dependent localization +! even in MGBF-based localization) + if(l_mgbf_loc.and.ig<=naensgrp) then + +! Apply vertical smoother on each ensemble member + allocate(work_mgbf(obj_mgbf(1)%km_a_all,obj_mgbf(1)%nm,obj_mgbf(1)%mm)) + work_mgbf=zero + iadvance=1 ; iback=2 +!$omp parallel do schedule(static,1) private(k,ii,is,ie) + do k=1,n_ens + ii=(k-1)*grd_loc%nsig + is=ii+1 + ie=ii+grd_loc%nsig + if(.not.obj_mgbf(1)%l_vertical_filter) call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,1) + call map_work_mgbf(a_en(k)%r3(ipnt)%q,work_mgbf(is:ie,:,:),iadvance,1) + enddo + +! Mapping from analysis grid to filter grid + call obj_mgbf(1)%anal_to_filt_allmap(work_mgbf) + +! Apply horizontal smoother for number of horizontal scales + call obj_mgbf(1)%filtering_procedure(obj_mgbf(1)%mgbf_proc,0) + +! Mapping from filter grid to analysis grid + call obj_mgbf(1)%filt_to_anal_allmap(work_mgbf) + +! Apply vertical smoother on each ensemble member + iadvance=2 ; iback=1 +!$omp parallel do schedule(static,1) private(k,ii,is,ie) + do k=1,n_ens + ii=(k-1)*grd_loc%nsig + is=ii+1 + ie=ii+grd_loc%nsig + call map_work_mgbf(a_en(k)%r3(ipnt)%q,work_mgbf(is:ie,:,:),iadvance,1) + if(.not.obj_mgbf(1)%l_vertical_filter) call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,1) + enddo + deallocate(work_mgbf) + +! Recursive/Spectral filter-based localization(ig<=naensgrp) +! or scale-separation(ig>naensgrp) + else + ! Apply vertical smoother on each ensemble member ! To avoid my having to touch the general sub2grid and grid2sub, ! get copy for ensemble components to work array - allocate(a_en_work(n_ens*a_en(1)%ndim),stat=istatus) - if(istatus/=0) then - write(6,*)'bkgcov_a_en_new_factorization: trouble in alloc(a_en_work)' - call stop2(999) - endif - iadvance=1 ; iback=2 + allocate(a_en_work(n_ens*a_en(1)%ndim),stat=istatus) + if(istatus/=0) then + write(6,*)'bkgcov_a_en_new_factorization: trouble in alloc(a_en_work)' + call stop2(999) + endif + iadvance=1 ; iback=2 !$omp parallel do schedule(static,1) private(k,ii,is,ie) - do k=1,n_ens - call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) - ii=(k-1)*a_en(1)%ndim - is=ii+1 - ie=ii+a_en(1)%ndim - a_en_work(is:ie)=a_en(k)%values(1:a_en(k)%ndim) - enddo + do k=1,n_ens + call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) + ii=(k-1)*a_en(1)%ndim + is=ii+1 + ie=ii+a_en(1)%ndim + a_en_work(is:ie)=a_en(k)%values(1:a_en(k)%ndim) + enddo ! Convert from subdomain to full horizontal field distributed among processors - call general_sub2grid(grd_loc,a_en_work,hwork) + call general_sub2grid(grd_loc,a_en_work,hwork) ! Apply horizontal smoother for number of horizontal scales - if(regional) then - iadvance=1 ; iback=2 - call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) - call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) - iadvance=2 ; iback=1 - call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) - call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) - else - call sf_xy(ig,hwork,grd_loc%kbegin_loc,grd_loc%kend_loc) - end if + if(regional) then + iadvance=1 ; iback=2 + call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) + call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) + iadvance=2 ; iback=1 + call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) + call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) + else + call sf_xy(ig,hwork,grd_loc%kbegin_loc,grd_loc%kend_loc) + end if ! Put back onto subdomains - call general_grid2sub(grd_loc,hwork,a_en_work) + call general_grid2sub(grd_loc,hwork,a_en_work) ! Retrieve ensemble components from long vector ! Apply vertical smoother on each ensemble member - iadvance=2 ; iback=1 + iadvance=2 ; iback=1 !$omp parallel do schedule(static,1) private(k,ii,is,ie) - do k=1,n_ens - ii=(k-1)*a_en(1)%ndim - is=ii+1 - ie=ii+a_en(1)%ndim - a_en(k)%values(1:a_en(k)%ndim)=a_en_work(is:ie) - call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) - enddo - deallocate(a_en_work) + do k=1,n_ens + ii=(k-1)*a_en(1)%ndim + is=ii+1 + ie=ii+a_en(1)%ndim + a_en(k)%values(1:a_en(k)%ndim)=a_en_work(is:ie) + call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) + enddo + deallocate(a_en_work) + + endif return end subroutine bkgcov_a_en_new_factorization @@ -3796,7 +3856,7 @@ subroutine ckgcov_a_en_new_factorization(ig,z,a_en) use constants, only: zero use gridmod, only: regional use hybrid_ensemble_parameters, only: n_ens,grd_loc - use hybrid_ensemble_parameters, only: nval_lenz_en + use hybrid_ensemble_parameters, only: l_mgbf_loc use general_sub2grid_mod, only: general_grid2sub use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer @@ -3806,17 +3866,23 @@ subroutine ckgcov_a_en_new_factorization(ig,z,a_en) ! Passed Variables integer(i_kind),intent(in ) :: ig type(gsi_bundle),intent(inout) :: a_en(n_ens) - real(r_kind),dimension(nval_lenz_en),intent(in ) :: z + real(r_kind),dimension(nval_loc_en),intent(in ) :: z +!NOTE: +! nval_loc_en is the number of horizontally-filtered variables in the domain of each processor. +! In MGBF-based localization, it is horizontally-local and vertically-global as +! nval_loc_en = nhoriz * obj_mgbf(ig)%km_all +! and nhoriz = ( obj_mgbf(ig)%im + obj_mgbf(ig)%hx*2 ) * ( obj_mgbf(ig)%jm + obj_mgbf(ig)%hy*2 ) +! In recursive/spectral filter-based localization, it is horizontally-global and vertically-local as +! nval_loc_en = nhoriz * ( grd_loc%kend_alloc - grd_loc%kbegin_loc + 1 ) +! and nhoriz = grd_loc%nlat * grd_loc%nlon (for regional recursive filter) +! nhoriz = ( sp_loc%jcap+1 ) * ( sp_loc%jcap+2 ) (for global spectral filter) +! but internal array hwork always has +! dimension grd_loc%nlat * grd_loc%nlon * ( grd_loc%kend_alloc - grd_loc%kbegin_loc + 1 ) +! which would be used as nval_loc_en when the recursive filter is used. ! Local Variables - integer(i_kind) ii,k,iadvance,iback,is,ie,ipnt,istatus + integer(i_kind) ii,i,j,k,iadvance,iback,is,ie,ipnt,istatus real(r_kind) hwork(grd_loc%nlat*grd_loc%nlon*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1)) -!NOTE: nval_lenz_en = nhoriz*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) -! and nhoriz = grd_loc%nlat*grd_loc%nlon for regional, -! nhoriz = (sp_loc%jcap+1)*(sp_loc%jcap+2) for global -! but internal array hwork always has -! dimension grd_loc%nlat*grd_loc%nlon*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) -! which just happens to match up with nval_lenz_en for regional case, but not global. real(r_kind),allocatable,dimension(:):: a_en_work call gsi_bundlegetpointer(a_en(1),'a_en',ipnt,istatus) @@ -3825,54 +3891,90 @@ subroutine ckgcov_a_en_new_factorization(ig,z,a_en) call stop2(999) endif +! MGBF-based localization (now available only in regional=.true.) + if(l_mgbf_loc) then + +! Apply horizontal smoother for number of horizontal scales + ii=0 + do k=1,obj_mgbf(ig)%km_all + do j=1-obj_mgbf(ig)%hy,obj_mgbf(ig)%jm+obj_mgbf(ig)%hy + do i=1-obj_mgbf(ig)%hx,obj_mgbf(ig)%im+obj_mgbf(ig)%hx + ii=ii+1 + obj_mgbf(ig)%VALL(k,i,j)=z(ii) + enddo + enddo + enddo + call obj_mgbf(ig)%filtering_procedure(obj_mgbf(ig)%mgbf_proc,1) + +! Mapping from filter grid to analysis grid + allocate(work_mgbf(obj_mgbf(ig)%km_a_all,obj_mgbf(ig)%nm,obj_mgbf(ig)%mm)) + work_mgbf=zero + call obj_mgbf(ig)%filt_to_anal_allmap(work_mgbf) - if(grd_loc%kend_loc+1-grd_loc%kbegin_loc==0) then +! Apply vertical smoother on each ensemble member + iadvance=2 ; iback=1 +!$omp parallel do schedule(static,1) private(k,ii,is,ie) + do k=1,n_ens + ii=(k-1)*grd_loc%nsig + is=ii+1 + ie=ii+grd_loc%nsig + call map_work_mgbf(a_en(k)%r3(ipnt)%q,work_mgbf(is:ie,:,:),iadvance,ig) + if(.not.obj_mgbf(ig)%l_vertical_filter) call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) + enddo + deallocate(work_mgbf) + +! Recursive/Spectral filter-based localization + else + + if(grd_loc%kend_loc+1-grd_loc%kbegin_loc==0) then ! no work to be done on this processor, but hwork still has allocated space, since ! grd_loc%kend_alloc = grd_loc%kbegin_loc in this case, so set to zero. - hwork=zero - else + hwork=zero + else ! Apply horizontal smoother for number of horizontal scales - if(regional) then + if(regional) then ! Make a copy of input variable z to hwork - hwork=z - iadvance=2 ; iback=1 - call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) - call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) - else + hwork=z + iadvance=2 ; iback=1 + call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) + call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) + else #ifdef LATER - call sqrt_sf_xy(ig,z,hwork,grd_loc%kbegin_loc,grd_loc%kend_loc) + call sqrt_sf_xy(ig,z,hwork,grd_loc%kbegin_loc,grd_loc%kend_loc) #else - write(6,*) ' problem with ibm compiler with "use hybrid_ensemble_isotropic, only: sqrt_sf_xy"' + write(6,*) ' problem with ibm compiler with "use hybrid_ensemble_isotropic, only: sqrt_sf_xy"' #endif /*LATER*/ + end if end if - end if ! Put back onto subdomains - allocate(a_en_work(n_ens*a_en(1)%ndim),stat=istatus) - if(istatus/=0) then - write(6,*)'ckgcov_a_en_new_factorization: trouble in alloc(a_en_work)' - call stop2(999) - endif - call general_grid2sub(grd_loc,hwork,a_en_work) + allocate(a_en_work(n_ens*a_en(1)%ndim),stat=istatus) + if(istatus/=0) then + write(6,*)'ckgcov_a_en_new_factorization: trouble in alloc(a_en_work)' + call stop2(999) + endif + call general_grid2sub(grd_loc,hwork,a_en_work) ! Retrieve ensemble components from long vector - ii=0 - do k=1,n_ens - is=ii+1 - ie=ii+a_en(1)%ndim - a_en(k)%values(1:a_en(k)%ndim)=a_en_work(is:ie) - ii=ii+a_en(1)%ndim - enddo - deallocate(a_en_work) + ii=0 + do k=1,n_ens + is=ii+1 + ie=ii+a_en(1)%ndim + a_en(k)%values(1:a_en(k)%ndim)=a_en_work(is:ie) + ii=ii+a_en(1)%ndim + enddo + deallocate(a_en_work) ! Apply vertical smoother on each ensemble member - iadvance=2 ; iback=1 + iadvance=2 ; iback=1 !$omp parallel do schedule(static,1) private(k) - do k=1,n_ens + do k=1,n_ens - call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) + call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) - enddo + enddo + + endif return end subroutine ckgcov_a_en_new_factorization @@ -3909,7 +4011,7 @@ subroutine ckgcov_a_en_new_factorization_ad(ig,z,a_en) use constants, only: zero use gridmod, only: regional use hybrid_ensemble_parameters, only: n_ens,grd_loc - use hybrid_ensemble_parameters, only: nval_lenz_en + use hybrid_ensemble_parameters, only: l_mgbf_loc use general_sub2grid_mod, only: general_sub2grid use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer @@ -3919,17 +4021,23 @@ subroutine ckgcov_a_en_new_factorization_ad(ig,z,a_en) ! Passed Variables integer(i_kind),intent(in ) :: ig type(gsi_bundle),intent(inout) :: a_en(n_ens) - real(r_kind),dimension(nval_lenz_en),intent(inout) :: z + real(r_kind),dimension(nval_loc_en),intent(inout) :: z +!NOTE: +! nval_loc_en is the number of horizontally-filtered variables in the domain of each processor. +! In MGBF-based localization, it is horizontally-local and vertically-global as +! nval_loc_en = nhoriz * obj_mgbf(ig)%km_all +! and nhoriz = ( obj_mgbf(ig)%im + obj_mgbf(ig)%hx*2 ) * ( obj_mgbf(ig)%jm + obj_mgbf(ig)%hy*2 ) +! In recursive/spectral filter-based localization, it is horizontally-global and vertically-local as +! nval_loc_en = nhoriz * ( grd_loc%kend_alloc - grd_loc%kbegin_loc + 1 ) +! and nhoriz = grd_loc%nlat * grd_loc%nlon (for regional recursive filter) +! nhoriz = ( sp_loc%jcap+1 ) * ( sp_loc%jcap+2 ) (for global spectral filter) +! but internal array hwork always has +! dimension grd_loc%nlat * grd_loc%nlon * ( grd_loc%kend_alloc - grd_loc%kbegin_loc + 1 ) +! which would be used as nval_loc_en when the recursive filter is used. ! Local Variables - integer(i_kind) ii,k,iadvance,iback,is,ie,ipnt,istatus + integer(i_kind) ii,i,j,k,iadvance,iback,is,ie,ipnt,istatus real(r_kind) hwork(grd_loc%nlat*grd_loc%nlon*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1)) -!NOTE: nval_lenz_en = nhoriz*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) -! and nhoriz = grd_loc%nlat*grd_loc%nlon for regional, -! nhoriz = (sp_loc%jcap+1)*(sp_loc%jcap+2) for global -! but internal array hwork always has -! dimension grd_loc%nlat*grd_loc%nlon*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) -! which just happens to match up with nval_lenz_en for regional case, but not global. real(r_kind),allocatable,dimension(:):: a_en_work call gsi_bundlegetpointer(a_en(1),'a_en',ipnt,istatus) @@ -3938,53 +4046,159 @@ subroutine ckgcov_a_en_new_factorization_ad(ig,z,a_en) call stop2(999) endif +! MGBF-based localization (now available only in regional=.true.) + if(l_mgbf_loc) then + ! Apply vertical smoother on each ensemble member - iadvance=1 ; iback=2 + allocate(work_mgbf(obj_mgbf(ig)%km_a_all,obj_mgbf(ig)%nm,obj_mgbf(ig)%mm)) + work_mgbf=zero + iadvance=1 ; iback=2 +!$omp parallel do schedule(static,1) private(k,ii,is,ie) + do k=1,n_ens + ii=(k-1)*grd_loc%nsig + is=ii+1 + ie=ii+grd_loc%nsig + if(.not.obj_mgbf(ig)%l_vertical_filter) call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) + call map_work_mgbf(a_en(k)%r3(ipnt)%q,work_mgbf(is:ie,:,:),iadvance,ig) + enddo + +! Mapping from analysis grid to filter grid + call obj_mgbf(ig)%anal_to_filt_allmap(work_mgbf) + deallocate(work_mgbf) + +! Apply horizontal smoother for number of horizontal scales + call obj_mgbf(ig)%filtering_procedure(obj_mgbf(ig)%mgbf_proc,-1) + ii=0 + do k=1,obj_mgbf(ig)%km_all + do j=1-obj_mgbf(ig)%hy,obj_mgbf(ig)%jm+obj_mgbf(ig)%hy + do i=1-obj_mgbf(ig)%hx,obj_mgbf(ig)%im+obj_mgbf(ig)%hx + ii=ii+1 + z(ii)=obj_mgbf(ig)%VALL(k,i,j) + enddo + enddo + enddo + +! Recursive/Spectral filter-based localization + else + +! Apply vertical smoother on each ensemble member + iadvance=1 ; iback=2 !$omp parallel do schedule(static,1) private(k) - do k=1,n_ens + do k=1,n_ens - call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) - - enddo + call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) + + enddo ! To avoid my having to touch the general sub2grid and grid2sub, ! get copy for ensemble components to work array - allocate(a_en_work(n_ens*a_en(1)%ndim),stat=istatus) - if(istatus/=0) then - write(6,*)'ckgcov_a_en_new_factorization_ad: trouble in alloc(a_en_work)' - call stop2(999) - endif - ii=0 - do k=1,n_ens - is=ii+1 - ie=ii+a_en(1)%ndim - a_en_work(is:ie)=a_en(k)%values(1:a_en(k)%ndim) - ii=ii+a_en(1)%ndim - enddo + allocate(a_en_work(n_ens*a_en(1)%ndim),stat=istatus) + if(istatus/=0) then + write(6,*)'ckgcov_a_en_new_factorization_ad: trouble in alloc(a_en_work)' + call stop2(999) + endif + ii=0 + do k=1,n_ens + is=ii+1 + ie=ii+a_en(1)%ndim + a_en_work(is:ie)=a_en(k)%values(1:a_en(k)%ndim) + ii=ii+a_en(1)%ndim + enddo ! Convert from subdomain to full horizontal field distributed among processors - call general_sub2grid(grd_loc,a_en_work,hwork) - deallocate(a_en_work) + call general_sub2grid(grd_loc,a_en_work,hwork) + deallocate(a_en_work) - if(grd_loc%kend_loc+1-grd_loc%kbegin_loc==0) then + if(grd_loc%kend_loc+1-grd_loc%kbegin_loc==0) then ! no work to be done on this processor, but z still has allocated space, since ! grd_loc%kend_alloc = grd_loc%kbegin_loc in this case, so set to zero. - z=zero - else -! Apply horizontal smoother for number of horizontal scales - if(regional) then - iadvance=1 ; iback=2 - call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) - call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) - z=hwork + z=zero else - call sqrt_sf_xy_ad(ig,z,hwork,grd_loc%kbegin_loc,grd_loc%kend_loc) +! Apply horizontal smoother for number of horizontal scales + if(regional) then + iadvance=1 ; iback=2 + call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) + call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) + z=hwork + else + call sqrt_sf_xy_ad(ig,z,hwork,grd_loc%kbegin_loc,grd_loc%kend_loc) + end if end if - end if + + endif return end subroutine ckgcov_a_en_new_factorization_ad +subroutine map_work_mgbf(f,g,iadvance,ig) +!$$$ subprogram documentation block +! . . . +! subprogram: map_work_mgbf +! prgrmmr: yokota org: NCEP/EMC date: 2024-02-20 +! +! abstract: mapping field for MGBF +! +! program history log: +! +! input argument list: +! f - field to be filtered +! g - field for MGBF +! iadvance - =1 to map from f to g, =2 to map from g to f +! ig - number for smoothing scales +! +! output argument list: +! f - field to be filtered +! g - field for MGBF +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + + use constants, only: zero + use hybrid_ensemble_parameters, only: grd_loc + implicit none + + integer(i_kind),intent(in ) :: iadvance,ig + real(r_kind) ,intent(inout) :: f(grd_loc%lat2,grd_loc%lon2,grd_loc%nsig) + real(r_kind) ,intent(inout) :: g(grd_loc%nsig,obj_mgbf(ig)%nm,obj_mgbf(ig)%mm) + + real(r_kind) :: work_tmp(grd_loc%lon2,grd_loc%lat2) + integer(i_kind) i,j,k + + if(iadvance == 1) then + do k=1,grd_loc%nsig + do j=1,grd_loc%lat2 + do i=1,grd_loc%lon2 + work_tmp(i,j)=f(j,i,k) + enddo + enddo + do j=1,obj_mgbf(ig)%mm + do i=1,obj_mgbf(ig)%nm + g(k,i,j)=work_tmp(i+1,j+1) + enddo + enddo + enddo + elseif(iadvance == 2) then + do k=1,grd_loc%nsig + work_tmp=zero + do j=1,obj_mgbf(ig)%mm + do i=1,obj_mgbf(ig)%nm + work_tmp(i+1,j+1)=g(k,i,j) + enddo + enddo + do j=1,grd_loc%lat2 + do i=1,grd_loc%lon2 + f(j,i,k)=work_tmp(i,j) + enddo + enddo + enddo + endif + return + +end subroutine map_work_mgbf + ! ------------------------------------------------------------------------------ ! ------------------------------------------------------------------------------ @@ -4202,6 +4416,7 @@ subroutine hybens_localization_setup use hybrid_ensemble_parameters, only: ntotensgrp,naensgrp,naensloc,ntlevs_ens,nsclgrp,assign_vdl_nml use hybrid_ensemble_parameters, only: en_perts,vdl_scale,vloc_varlist,global_spectral_filter_sd use hybrid_ensemble_parameters, only: ngvarloc + use hybrid_ensemble_parameters, only: l_mgbf_loc use gsi_io, only: verbose use string_utility, only: StrLowCase @@ -4221,6 +4436,7 @@ subroutine hybens_localization_setup real(r_kind), pointer :: values(:) => NULL() integer(i_kind) :: iscl, iv, smooth_scales_num character(len=*),parameter::myname_=myname//'*hybens_localization_setup' + character(len=40) :: mgbfname='mgbf_locXX.nml' l_read_success=.false. print_verbose=.false. .and. mype == 0 @@ -4322,30 +4538,41 @@ subroutine hybens_localization_setup call normal_new_factorization_rf_z 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 - do k=1,nz - s_ens_h_gu_x(nk+k,:)=s_ens_h_gu_x(k,:) - s_ens_h_gu_y(nk+k,:)=s_ens_h_gu_y(k,:) - enddo + if ( l_mgbf_loc ) then + allocate(obj_mgbf(naensgrp)) + do ig=1,naensgrp + write(mgbfname(9:10),'(i2.2)') ig + call obj_mgbf(ig)%mg_initialize(trim(mgbfname)) enddo - 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) + ! Even for MGBF-localization, recursive filter is applied for scale-separation + ! in scale-dependent localization, so init_rf_[xy] should be called in nsclgrp>1 + if( .not. l_mgbf_loc .or. nsclgrp > 1 ) then + 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 + do k=1,nz + s_ens_h_gu_x(nk+k,:)=s_ens_h_gu_x(k,:) + s_ens_h_gu_y(nk+k,:)=s_ens_h_gu_y(k,:) + enddo + enddo + 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) + endif else call init_sf_xy(jcap_ens) endif @@ -4537,6 +4764,16 @@ subroutine hybens_localization_setup else nval_lenz_en = sp_loc%nc*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) endif + ! nval_loc_en is the number of horizontally-filtered variables in the domain of each processor, + ! which is the same as nval_lenz_en (horizontally-global and vertically-local) in recursive/spectral filter + ! but horizontally-local and vertically-global in MGBF. + if ( l_mgbf_loc ) then + nval_loc_en = maxval( obj_mgbf(1:naensgrp)%km_all & + & * (obj_mgbf(1:naensgrp)%im + obj_mgbf(1:naensgrp)%hx*2) & + & * (obj_mgbf(1:naensgrp)%jm + obj_mgbf(1:naensgrp)%hy*2) ) + else + nval_loc_en = nval_lenz_en + endif ! setup vertical weighting for ensemble contribution to psfc call setup_pwgt diff --git a/src/gsi/hybrid_ensemble_parameters.f90 b/src/gsi/hybrid_ensemble_parameters.f90 index 23065ebb5b..d31eccb7e4 100644 --- a/src/gsi/hybrid_ensemble_parameters.f90 +++ b/src/gsi/hybrid_ensemble_parameters.f90 @@ -149,6 +149,7 @@ module hybrid_ensemble_parameters ! =0.0: cross-scale covariance is decreased to zero ! =0.5: cross-scale covariance is decreased to half ! =1.0: cross-scale covariance is retained +! l_mgbf_loc: if true, multi-grid beta filter is used for localization instead of recursive filter !===================================================================================================== ! ! @@ -183,6 +184,7 @@ module hybrid_ensemble_parameters ! 2015-02-11 Hu - add flag l_ens_in_diff_time to force GSI hybrid use ensembles not available at analysis time ! 2015-09-18 todling - add sst_staticB to control use of ensemble SST error covariance ! 2022-09-15 yokota - add scale/variable/time-dependent localization +! 2024-02-20 yokota - add MGBF-based localization ! ! subroutines included: @@ -333,6 +335,7 @@ module hybrid_ensemble_parameters public :: alphacvarsclgrpmat public :: l_timloc_opt public :: r_ensloccov4tim,r_ensloccov4var,r_ensloccov4scl + public :: l_mgbf_loc public :: idaen3d,idaen2d public :: ens_fast_read public :: parallelization_over_ensmembers @@ -348,6 +351,7 @@ module hybrid_ensemble_parameters logical l_hyb_ens,uv_hyb_ens,q_hyb_ens,oz_univ_static,sst_staticB logical l_timloc_opt + logical l_mgbf_loc logical aniso_a_en logical full_ensemble,pwgtflg logical generate_ens @@ -462,6 +466,7 @@ subroutine init_hybrid_ensemble_parameters l_hyb_ens=.false. l_timloc_opt=.false. + l_mgbf_loc=.false. full_ensemble=.false. pwgtflg=.false. uv_hyb_ens=.false. diff --git a/src/mgbf/CMakeLists.txt b/src/mgbf/CMakeLists.txt new file mode 100644 index 0000000000..9ee36c8329 --- /dev/null +++ b/src/mgbf/CMakeLists.txt @@ -0,0 +1,98 @@ +cmake_minimum_required(VERSION 3.15) + +project(mgbf + VERSION 1.0.0 + LANGUAGES Fortran) + +list(APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_SOURCE_DIR}/cmake") +set(CMAKE_DIRECTORY_LABELS ${PROJECT_NAME}) + +include(GNUInstallDirs) + +if(NOT CMAKE_BUILD_TYPE MATCHES "^(Debug|Release|RelWithDebInfo|MinSizeRel)$") + message(STATUS "Setting build type to 'Release' as none was specified.") + set(CMAKE_BUILD_TYPE + "Release" + CACHE STRING "Choose the type of build." FORCE) + set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS "Debug" "Release" "MinSizeRel" "RelWithDebInfo") +endif() + +if(NOT CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU|Intel)$") + message(WARNING "${CMAKE_Fortran_COMPILER_ID} is not supported.") +endif() + +if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -g -traceback -convert big_endian") +elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -g -fbacktrace -fconvert=big-endian") +endif() + +if(NOT CMAKE_BUILD_TYPE MATCHES "Debug") + add_definitions(-DNDEBUG) +endif() + +list(APPEND MGBF_SRC +kinds.f90 +jp_pkind.f90 +jp_pkind2.f90 +jp_pietc.f90 +jp_pietc_s.f90 +jp_pmat.f90 +jp_pmat4.f90 +jp_pbfil.f90 +jp_pbfil2.f90 +jp_pbfil3.f90 +mg_mppstuff.f90 +mg_domain.f90 +mg_domain_loc.f90 +mg_parameter.f90 +mg_bocos.f90 +mg_transfer.f90 +mg_generations.f90 +mg_interpolate.f90 +mg_filtering.f90 +mg_timers.f90 +mg_entrymod.f90 +mg_intstate.f90 +mg_input.f90 +) + +set(module_dir "${CMAKE_CURRENT_BINARY_DIR}/include/mgbf") +add_library(mgbf STATIC ${MGBF_SRC}) +add_library(${PROJECT_NAME}::mgbf ALIAS mgbf) +set_target_properties(mgbf PROPERTIES Fortran_MODULE_DIRECTORY "${module_dir}") +target_include_directories(mgbf PUBLIC $ + $) + +install(DIRECTORY ${module_dir} DESTINATION ${CMAKE_INSTALL_PREFIX}/include) + +install(TARGETS mgbf + EXPORT ${PROJECT_NAME}Exports + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR} + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR}) + +# Package config +include(CMakePackageConfigHelpers) +set(CONFIG_INSTALL_DESTINATION ${CMAKE_INSTALL_LIBDIR}/cmake/${PROJECT_NAME}) + +export(EXPORT ${PROJECT_NAME}Exports + NAMESPACE ${PROJECT_NAME}:: + FILE ${PROJECT_NAME}-targets.cmake) + +configure_package_config_file( + ${CMAKE_CURRENT_SOURCE_DIR}/cmake/PackageConfig.cmake.in ${CMAKE_BINARY_DIR}/${PROJECT_NAME}-config.cmake + INSTALL_DESTINATION ${CONFIG_INSTALL_DESTINATION}) +install(FILES ${CMAKE_BINARY_DIR}/${PROJECT_NAME}-config.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) + +write_basic_package_version_file( + ${CMAKE_BINARY_DIR}/${PROJECT_NAME}-config-version.cmake + VERSION ${PROJECT_VERSION} + COMPATIBILITY AnyNewerVersion) +install(FILES ${CMAKE_BINARY_DIR}/${PROJECT_NAME}-config-version.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) + +install(EXPORT ${PROJECT_NAME}Exports + NAMESPACE ${PROJECT_NAME}:: + FILE ${PROJECT_NAME}-targets.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) diff --git a/src/mgbf/cmake/PackageConfig.cmake.in b/src/mgbf/cmake/PackageConfig.cmake.in new file mode 100644 index 0000000000..e64cb4ef87 --- /dev/null +++ b/src/mgbf/cmake/PackageConfig.cmake.in @@ -0,0 +1,19 @@ +@PACKAGE_INIT@ + +#@PROJECT_NAME@-config.cmake +# +# Imported interface targets provided: +# * @PROJECT_NAME@::MGBF - MGBF library target + +# Include targets file. This will create IMPORTED target @PROJECT_NAME@ +include("${CMAKE_CURRENT_LIST_DIR}/@PROJECT_NAME@-targets.cmake") +include("${CMAKE_CURRENT_LIST_DIR}/@PROJECT_NAME@-config-version.cmake") +include(CMakeFindDependencyMacro) + +# Get the build type from library target +get_target_property(@PROJECT_NAME@_BUILD_TYPES @PROJECT_NAME@::@PROJECT_NAME@ IMPORTED_CONFIGURATIONS) + +check_required_components("@PROJECT_NAME@") + +get_target_property(location @PROJECT_NAME@::@PROJECT_NAME@ LOCATION) +message(STATUS "Found @PROJECT_NAME@: ${location} (found version \"${PACKAGE_VERSION}\")") diff --git a/src/mgbf/jp_pbfil.f90 b/src/mgbf/jp_pbfil.f90 new file mode 100644 index 0000000000..89a9196596 --- /dev/null +++ b/src/mgbf/jp_pbfil.f90 @@ -0,0 +1,1119 @@ +submodule(mg_parameter) jp_pbfil +!$$$ submodule documentation block +! . . . . +! module: jp_pbfil +! prgmmr: purser org: NOAA/EMC date: 2019-03 +! +! abstract: Codes for the beta filters +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! cholaspect1 - +! cholaspect2 - +! cholaspect3 - +! cholaspect4 - +! getlinesum1 - +! getlinesum2 - +! getlinesum3 - +! getlinesum4 - +! rbeta1 - +! rbeta2 - +! rbeta3 - +! rbeta4 - +! vrbeta4 - +! rbeta1T - +! rbeta2T - +! rbeta3T - +! rbeta4T - +! vrbeta4t - +! vrbeta1 - +! vrbeta2 - +! vrbeta3 - +! vrbeta1T - +! vrbeta2T - +! vrbeta3T - +! +! Functions Included: +! +! remarks: +! The filters invoke the aspect tensor information encoded by the +! Cholesky lower-triangular factors, el, of the INVERSE aspect tensors. +! The routines, "cholaspect", convert (in place) the field of given +! aspect tensors A to the equivalent cholesky factors of A^(-1). +! The routines, "getlinesum" precompute the normalization coefficients +! for each line (row) of the implied matrix form of the beta filter +! so that the normalized line sum associated with each point of +! application becomes unity. +! This makes the application of each filter significantly faster +! than having to work out the normalization on the fly. +! Be sure to have run cholaspect, and then getlinesum, prior to applying +! the beta filters themselves. +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +use kinds, only: dp=>r_kind +use jp_pietc, only: u1 +implicit none + +contains + +!============================================================================= +module subroutine cholaspect1(lx,mx, el) ! [cholaspect] +!============================================================================= +! Convert the given field, el, of aspect tensors into the equivalent +! field +! of Cholesky lower-triangular factors of the inverses of the aspect +! tensors. +!============================================================================= +use jp_pmat, only: inv, l1lm +integer, intent(in ):: lx,mx +real(dp),dimension(1,1,lx:mx),intent(inout):: el +!----------------------------------------------------------------------------- +integer :: ix +!============================================================================= +do ix=lx,mx; el(1,1,ix)=u1/sqrt(el(1,1,ix)); enddo +end subroutine cholaspect1 +!============================================================================= +module subroutine cholaspect2(lx,mx, ly,my, el) ! [cholaspect] +!============================================================================= +! Convert the given field, el, of aspect tensors into the equivalent +! field +! of Cholesky lower-triangular factors of the inverses of the aspect +! tensors. +!============================================================================= +use jp_pmat, only: inv, l1lm +integer, intent(in ):: lx,mx, ly,my +real(dp),dimension(2,2,lx:mx,ly:my),intent(inout):: el +!----------------------------------------------------------------------------- +real(dp),dimension(2,2):: tel +integer :: ix,iy +!============================================================================= +do iy=ly,my; do ix=lx,mx + tel=el(:,:,ix,iy); call inv(tel); call l1lm(tel,el(:,:,ix,iy)) +enddo; enddo +end subroutine cholaspect2 +!============================================================================= +module subroutine cholaspect3(lx,mx, ly,my, lz,mz, el) ! [cholaspect] +!============================================================================= +! Convert the given field, el, of aspect tensors into the equivalent +! field +! of Cholesky lower-triangular factors of the inverses of the aspect +! tensors. +!============================================================================= +use jp_pmat, only: inv, l1lm +integer, intent(in ):: lx,mx, ly,my, lz,mz +real(dp),dimension(3,3,lx:mx,ly:my,lz:mz),intent(inout):: el +!----------------------------------------------------------------------------- +real(dp),dimension(3,3):: tel +integer :: ix,iy,iz +!============================================================================= +do iz=lz,mz; do iy=ly,my; do ix=lx,mx + tel=el(:,:,ix,iy,iz); call inv(tel); call l1lm(tel,el(:,:,ix,iy,iz)) +enddo; enddo; enddo +end subroutine cholaspect3 +!============================================================================= +module subroutine cholaspect4(lx,mx, ly,my, lz,mz, lw,mw,el) ! [cholaspect] +!============================================================================= +! Convert the given field, el, of aspect tensors into the equivalent +! field +! of Cholesky lower-triangular factors of the inverses of the aspect +! tensors. +!============================================================================= +use jp_pmat, only: inv, l1lm +integer, intent(in ):: lx,mx, ly,my, lz,mz, lw,mw +real(dp),dimension(4,4,lx:mx,ly:my,lz:mz,lw:mw),& + intent(inout):: el +!----------------------------------------------------------------------------- +real(dp),dimension(4,4):: tel +integer :: ix,iy,iz,iw +!============================================================================= +do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx + tel=el(:,:,ix,iy,iz,iw); call inv(tel); call l1lm(tel,el(:,:,ix,iy,iz,iw)) +enddo; enddo; enddo; enddo +end subroutine cholaspect4 + +!============================================================================= +module subroutine getlinesum1(this,hx,lx,mx, el, ss) ! [getlinesum] +!============================================================================= +! Get inverse of the line-sum of the matrix representing the +! unnormalized +! beta function with aspect tensor pasp=(el*el^T)^(-1), and invert the +! result +! so it can be used subsequently in the normalized version of this +! filter. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx +real(dp),dimension(1,1,Lx:Mx),intent(in ):: el +real(dp),dimension(lx:mx),intent( out):: ss +!----------------------------------------------------------------------------- +real(dp),parameter:: eps=1.e-12 +real(dp) :: s,rr,rrc,exx,x +integer :: ix,gxl,gxm,gx +!============================================================================= +do ix=Lx,Mx + s=0 + exx=el(1,1,ix)*this%rmom2_1 + x=u1/exx + gxl=ceiling(-x+eps); gxm=floor( x-eps) + if(gxl<-hx.or.gxm>hx)& + stop 'In getlinesum1; filter reach fx becomes too large for hx' + do gx=gxl,gxm + x=gx + rr=(x*exx)**2; rrc=u1-rr + s=s+rrc**this%p + enddo + ss(ix)=u1/s +enddo +end subroutine getlinesum1 +!============================================================================= +module subroutine getlinesum2(this,hx,lx,mx, hy,ly,my, el, ss) ! [getlinesum] +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx, & + hy,ly,my +real(dp),dimension(2,2,Lx:Mx,Ly:My),intent(in ):: el +real(dp),dimension( lx:mx,ly:my),intent( out):: ss +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(2,2):: tel +real(dp) :: s,rr,rrx,rrc,exx,eyy,eyx,x,y,xc +integer :: ix,gx,gxl,gxm +integer :: iy,gy,gyl,gym +!============================================================================= +do iy=Ly,My; do ix=Lx,Mx + s=0 + tel=el(:,:,ix,iy)*this%rmom2_2 ! This el, rescaled + exx=tel(1,1); eyy=tel(2,2) + eyx=tel(2,1) + y=u1/eyy + gyl=ceiling(-y+eps); gym=floor( y-eps) + if(gyl<-hy.or.gym>hy)& + stop 'In getlinesum2; filter reach becomes too large for hy' + do gy=gyl,gym + y=gy; xc=-y*eyx + rrx=(y*eyy)**2; x=sqrt(u1-rrx) + gxl=ceiling((xc-x)/exx+eps); gxm=floor((xc+x)/exx-eps) + if(gxl<-hx.or.gxm>hx)& + stop 'In getlinesum2; filter reach becomes too large for hx' + do gx=gxl,gxm + x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + s=s+rrc**this%p + enddo! gx + enddo! gy + ss(ix,iy)=u1/s +enddo; enddo! ix, iy +end subroutine getlinesum2 +!============================================================================= +module subroutine getlinesum3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el, ss) ! [getlinesum] +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx, & + hy,ly,my, & + hz,lz,mz +real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el +real(dp),dimension( lx:mx,ly:my,lz:mz),intent( out):: ss +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(3,3):: tel +real(dp) :: s,rr,rrx,rry,rrc,& + exx,eyy,ezz,eyx,ezx,ezy, x,y,z,xc,yc +integer :: ix,gx,gxl,gxm +integer :: iy,gy,gyl,gym +integer :: iz,gz,gzl,gzm +!============================================================================= +ss=0 +do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx + s=0 + tel=el(:,:,ix,iy,iz)*this%rmom2_3 + exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3) + eyx=tel(2,1); ezx=tel(3,1) + ezy=tel(3,2) + z=u1/ezz + gzl=ceiling(-z+eps); gzm=floor( z-eps) + if(gzl<-hz.or.gzm>hz)& + stop 'In getlinesum3; filter reach becomes too large for hz' + do gz=gzl,gzm + z=gz; yc=-z*ezy + rry=(z*ezz)**2; y =sqrt(u1-rry) + gyl=ceiling((yc-y)/eyy+eps); gym=floor((yc+y)/eyy-eps) + if(gyl<-hy.or.gym>hy)& + stop 'In getlinesum3; filter reach becomes too large for hy' + do gy=gyl,gym + y=gy; xc=-y*eyx-z*ezx + rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx) + gxl=ceiling((xc-x)/exx+eps); gxm=floor((xc+x)/exx-eps) + if(gxl<-hx.or.gxm>hx)& + stop 'In getlinesum3; filter reach becomes too large for hx' + do gx=gxl,gxm + x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + s=s+rrc**this%p + enddo! gx + enddo! gy + enddo! gz + ss(ix,iy,iz)=u1/s +enddo; enddo; enddo! ix, iy, iz +end subroutine getlinesum3 +!============================================================================= +module subroutine getlinesum4(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & + el, ss) ! [getlinesum] +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx, & + hy,ly,my, & + hz,lz,mz, & + hw,lw,mw +real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el +real(dp),dimension( lx:mx,ly:my,lz:mz,Lw:Mw),intent( out):: ss +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(4,4):: tel +real(dp) :: s,rr,rrx,rry,rrz,rrc, & + exx,eyy,ezz,eww,eyx,ezx,ewx,ezy,ewy,ewz, x,y,z,w,& + xc,yc,zc +integer :: ix,gx,gxl,gxm +integer :: iy,gy,gyl,gym +integer :: iz,gz,gzl,gzm +integer :: iw,gw,gwl,gwm +!============================================================================= +ss=0 +do iw=Lw,Mw; do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx + s=0 + tel=el(:,:,ix,iy,iz,iw)*this%rmom2_4 + exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3); eww=tel(4,4) + eyx=tel(2,1); ezx=tel(3,1); ewx=tel(4,1) + ezy=tel(3,2); ewy=tel(4,2) + ewz=tel(4,3) + w=u1/eww + gwl=ceiling(-w+eps); gwm=floor( w-eps) + if(gwl<-hw.or.gwm>hw)& + stop 'In getlinesum4; filter reach becomes too large for hw' + do gw=gwl,gwm + w=gw; zc=-w*ewz + rrz=(w-eww)**2; z =sqrt(u1-rrz) + gzl=ceiling((zc-z)/ezz+eps); gzm=floor((zc+z)/ezz-eps) + if(gzl<-hz.or.gzm>hz)& + stop 'In getlinesum4; filter reach becomes too large for hz' + do gz=gzl,gzm + z=gz; yc=-z*ezy-w*ewy + rry=rrz+(z*ezz-zc)**2; y =sqrt(u1-rry) + gyl=ceiling((yc-y)/eyy+eps); gym=floor((yc+y)/eyy-eps) + if(gyl<-hy.or.gym>hy)& + stop 'In getlinesum4; filter reach becomes too large for hy' + do gy=gyl,gym + y=gy; xc=-y*eyx-z*ezx-w*ewx + rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx) + gxl=ceiling((xc-x)/exx+eps); gxm=floor((xc+x)/exx-eps) + if(gxl<-hx.or.gxm>hx)& + stop 'In getlinesum4; filter reach becomes too large for hx' + do gx=gxl,gxm + x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + s=s+rrc**this%p + enddo! gx + enddo! gy + enddo! gz + enddo! gw + ss(ix,iy,iz,iw)=u1/s +enddo; enddo; enddo; enddo! ix, iy, iz, iw +end subroutine getlinesum4 + +!============================================================================= +module subroutine rbeta1(this,hx,lx,mx, el,ss, a) ! [rbeta] +!============================================================================= +! Perform a radial beta-function filter in 1D. +! It averages the surrounding density values, and so preserves the value +! (in its target region) when presented with a constant-density input +! field. +! The input data occupy the extended region: +! Lx-hx <= jx <= mx+hx. +! The output data occupy the central region +! Lx <= ix <= Mx. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx +real(dp),dimension( Lx:Mx), intent(in ):: el +real(dp),dimension( Lx:Mx), intent(in ):: ss +real(dp),dimension(lx-hx:mx+hx),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(lx-hx:mx+hx):: b +real(dp) :: x,tb,s,rr,rrc,frow,exx +integer :: ix,jx,gx +!============================================================================= +b=0 +do ix=Lx,Mx + tb=0; s=ss(ix) + exx=el(ix)*this%rmom2_1 + x=u1/exx + do gx=ceiling(-x+eps),floor( x-eps) + jx=ix+gx; x=gx + rr=(x*exx)**2; rrc=u1-rr + frow=s*rrc**this%p + tb=tb+frow*a(jx) + enddo + b(ix)=tb +enddo +a=b +end subroutine rbeta1 +!============================================================================= +module subroutine rbeta2(this,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] +!============================================================================= +! Perform a radial beta-function filter in 2D. +! It averages the surrounding density values, and so preserves the value +! (in its target region) when presented with a constant-density input +! field. +! The input data occupy the extended region: +! Lx-hx <= jx <= mx+hx, Ly-hy <= Jy <= my+hy +! The output data occupy the central region +! Lx <= ix <= Mx, Ly <= iy <= My. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx, & + hy,ly,my +real(dp),dimension(2,2,Lx:Mx,Ly:My), intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My), intent(in ):: ss +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy):: b +real(dp),dimension(2,2) :: tel +real(dp) :: tb,s,rr,rrx,rrc,& + frow,exx,eyy,eyx,x,y,xc +integer :: ix,jx,gx +integer :: iy,jy,gy +!============================================================================= +b=0 +do iy=Ly,My; do ix=Lx,Mx + tb=0; s=ss(ix,iy) + tel=el(:,:,ix,iy)*this%rmom2_2 ! This el, rescaled + exx=tel(1,1); eyy=tel(2,2) + eyx=tel(2,1) + y=u1/eyy + do gy=ceiling(-y+eps),floor( y-eps) + jy=iy+gy; y=gy; xc=-y*eyx + rrx=(y*eyy)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + tb=tb+frow*a(jx,jy) + enddo! gx + enddo! gy + b(ix,iy)=tb +enddo; enddo! ix, iy +a=b +end subroutine rbeta2 +!============================================================================= +module subroutine rbeta3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta] +!============================================================================= +! Perform a radial beta-function filter in 3D. +! It averages the surrounding density values, and so preserves the value +! (in its target region) when presented with a constant-density input +! field. +! The input data occupy the extended region: +! Lx-hx <= jx <= mx+hx, Ly-hy <= Jy <= my+hy, Lz-hz <= Jz <= mz+hz +! The output data occupy the central region +! Lx <= ix <= Mx, Ly <= iy <= My, Lz <= iz <= Mz. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx,& + hy,ly,my,& + hz,lz,mz +real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz), intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz), intent(in ):: ss +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz):: b +real(dp),dimension(3,3) :: tel +real(dp):: s,tb,rr,rrx,rry,rrc,frow,& + exx,eyy,ezz,eyx,ezx,ezy,x,y,z,xc,yc +integer :: ix,jx,gx +integer :: iy,jy,gy +integer :: iz,jz,gz +!============================================================================= +b=0 +do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx + tb=0; s=ss(ix,iy,iz) + tel=el(:,:,ix,iy,iz)*this%rmom2_3 + exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3) + eyx=tel(2,1); ezx=tel(3,1); ezy=tel(3,2) + z=u1/ezz + do gz=ceiling(-z+eps),floor( z-eps) + jz=iz+gz; z=gz; yc=-z*ezy + rry=(z*ezz)**2; y =sqrt(u1-rry) + do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps) + jy=iy+gy; y=gy; xc=-y*eyx-z*ezx + rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + tb=tb+frow*a(jx,jy,jz) + enddo! gx + enddo! gy + enddo! gz + b(ix,iy,iz)=tb +enddo; enddo; enddo! ix, iy, iz +a=b +end subroutine rbeta3 +!============================================================================= +module subroutine rbeta4(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss,a) ! [rbeta] +!============================================================================= +! Perform a radial beta-function filter in 4D. +! It averages the surrounding density values, and so preserves the value +! (in its target region) when presented with a constant-density input +! field. +! The input data occupy the extended region: +! Lx-hx <= jx <= mx+hx, Ly-hy <= Jy <= my+hy, Lz-hz <= Jz <= mz+hz, +! Lw-hw <= Jw <= mw+hw +! The output data occupy the central region +! Lx <= ix <= Mx, Ly <= iy <= My, Lz <= iz <= Mz, Lw <= iw <= Mw. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx,& + hy,ly,my,& + hz,lz,mz,& + hw,lw,mw +real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy, & + lz-hz:mz+hz,lw-hw:mw+hw), intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz,lw-hw:mw+hw) :: b +real(dp),dimension(4,4) :: tel +real(dp):: s,tb,rr,rrx,rry,rrz,rrc,frow,& + exx,eyy,ezz,eww,eyx,ezx,ewx,ezy,ewy,ewz,x,y,z,w,xc,yc,zc +integer :: ix,jx,gx +integer :: iy,jy,gy +integer :: iz,jz,gz +integer :: iw,jw,gw +!============================================================================= +b=0 +do iw=lw,mw; do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx + tb=0; s=ss(ix,iy,iz,iw) + tel=el(:,:,ix,iy,iz,iw)*this%rmom2_4 + exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3); eww=tel(4,4) + eyx=tel(2,1); ezx=tel(3,1); ewx=tel(4,1) + ezy=tel(3,2); ewy=tel(4,2) + ewz=tel(4,3) + w=u1/eww + do gw=ceiling(-w+eps),floor( w-eps) + jw=iw+gw; w=gw; zc=-w*ewz + rrz=(w*eww)**2; z =sqrt(u1-rrz) + do gz=ceiling((zc-z)/ezz+eps),floor((zc+z)/ezz-eps) + jz=iz+gz; z=gz; yc=-z*ezy-w*ewy + rry=rrz+(z*ezz-zc)**2; y =sqrt(u1-rry) + do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps) + jy=iy+gy; y=gy; xc=-y*eyx-z*ezx-w*ewx + rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + tb=tb+frow*a(jx,jy,jz,jw) + enddo! gx + enddo! gy + enddo! gz + enddo! gw + b(ix,iy,iz,iw)=tb +enddo; enddo; enddo; enddo! ix, iy, iz, iw +a=b +end subroutine rbeta4 + +!============================================================================= +! Vector versions of the above routines: +!============================================================================= +module subroutine vrbeta4(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & + el,ss,a) ! [rbeta] +!============================================================================= +! Vector version of rbeta4 filtering nv fields at once. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: nv, & + hx,Lx,mx,& + hy,ly,my,& + hz,lz,mz,& + hw,lw,mw +real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy, & + lz-hz:mz+hz,lw-hw:mw+hw), intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz,lw-hw:mw+hw) :: b +real(dp),dimension(nv) :: tb +real(dp),dimension(4,4) :: tel +real(dp):: s,rr,rrx,rry,rrz,rrc,frow,& + exx,eyy,ezz,eww, eyx,ezx,ewx, ezy,ewy, ewz,& + x,y,z,w,xc,yc,zc +integer :: ix,jx,gx +integer :: iy,jy,gy +integer :: iz,jz,gz +integer :: iw,jw,gw +!============================================================================= +b=0 +do iw=lw,mw; do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx + tb=0; s=ss(ix,iy,iz,iw) + tel=el(:,:,ix,iy,iz,iw)*this%rmom2_4 + exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3); eww=tel(4,4) + eyx=tel(2,1); ezx=tel(3,1); ewx=tel(4,1) + ezy=tel(3,2); ewy=tel(4,2) + ewz=tel(4,3) + w=u1/eww + do gw=ceiling(-w+eps),floor( w-eps) + jw=iw+gw; w=gw; zc=-w*ewz + rrz=(w*eww)**2; z =sqrt(u1-rrz) + do gz=ceiling((zc-z)/ezz+eps),floor((zc+z)/ezz-eps) + jz=iz+gz; z=gz; yc=-z*ezy-w*ewy + rry=rrz+(z*ezz-zc)**2; y =sqrt(u1-rry) + do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps) + jy=iy+gy; y=gy; xc=-y*eyx-z*ezx-w*ewx + rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + tb=tb+frow*a(:,jx,jy,jz,jw) + enddo! gx + enddo! gy + enddo! gz + enddo! gw + b(:,ix,iy,iz,iw)=tb +enddo; enddo; enddo; enddo! ix, iy, iz, iw +a=b +end subroutine vrbeta4 + +!============================================================================= +module subroutine rbeta1T(this,hx,lx,mx, el,ss, a) ! [rbetat] +!============================================================================= +! Perform an ADJOINT radial beta-function filter in 1D. +! It conserves "masses" initially distributed only at the closure of +! the central domain, +! Lx <= ix <= Mx. +! The output field of the redistributed masses occupies the +! the extended domain, +! Lx-hx <= jx <= mx+hx. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx +real(dp),dimension(1,1,Lx:Mx), intent(in ):: el +real(dp),dimension( Lx:Mx), intent(in ):: ss +real(dp),dimension(lx-hx:mx+hx),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(lx-hx:mx+hx):: b +real(dp) :: ta,s,rr,rrc,frow,exx,x +integer :: ix,jx,gx +!============================================================================= +b=0 +do ix=Lx,Mx + ta=a(ix); s=ss(ix) + exx=el(1,1,ix)*this%rmom2_1 + x=u1/exx + do gx=ceiling(-x+eps),floor( x-eps) + jx=ix+gx; x=gx + rr=(x*exx)**2; rrc=u1-rr + frow=s*rrc**this%p + b(jx)=b(jx)+frow*ta + enddo +enddo +a=b +end subroutine rbeta1t +!============================================================================= +module subroutine rbeta2T(this,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] +!============================================================================= +! Perform an ADJOINT radial beta-function filter in 2D. +! It conserved "masses" initially distributed only at the closure of +! the central domain, +! Lx <= ix <= Mx, Ly <= iy <= My. +! The output field of the redistributed masses occupies the +! the extended domain, +! Lx-hx <= jx <= mx+hx, Ly-hy <= Jy <= my+hy +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx, & + hy,ly,my +real(dp),dimension(2,2,Lx:Mx,Ly:My), intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My), intent(in ):: ss +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy):: b +real(dp),dimension(2,2) :: tel +real(dp) :: ta,s,rr,rrx,rrc, & + frow,exx,eyy,eyx,x,y,xc +integer :: ix,jx,gx +integer :: iy,jy,gy +!============================================================================= +b=0 +do iy=Ly,My; do ix=Lx,Mx + ta=a(ix,iy); s=ss(ix,iy) + tel=el(:,:,ix,iy)*this%rmom2_2 ! sThis el, rescaled + exx=tel(1,1); eyy=tel(2,2) + eyx=tel(2,1) + y=u1/eyy + do gy=ceiling(-y+eps),floor( y-eps) + jy=iy+gy; y=gy; xc=-y*eyx + rrx=(y*eyy)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + b(jx,jy)=b(jx,jy)+frow*ta + enddo! gx + enddo! gy +enddo; enddo! ix, iy +a=b +end subroutine rbeta2t +!============================================================================= +module subroutine rbeta3T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat] +!============================================================================= +! Perform an ADJOINT radial beta-function filter in 3D. +! It conserves "masses" initially distributed only at the closure of +! the central domain, +! Lx <= ix <= Mx, Ly <= iy <= My, Lz <= iz <= Mz. +! The output field of the redistributed masses occupies the +! the extended domain, +! Lx-hx <= jx <= Mx+hx, Ly-hy <= Jy <= My+hy, Lz-hz <= Jz <= Mz+hz. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx,& + hy,ly,my,& + hz,lz,mz +real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz), intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz), intent(in ):: ss +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz):: b +real(dp),dimension(3,3) :: tel +real(dp):: ta,s,rr,rrx,rry,rrc,frow,& + exx,eyy,ezz,eyx,ezx,ezy,x,y,z,xc,yc +integer :: ix,jx,gx +integer :: iy,jy,gy +integer :: iz,jz,gz +!============================================================================= +b=0 +do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx + ta=a(ix,iy,iz); s=ss(ix,iy,iz) + tel=el(:,:,ix,iy,iz)*this%rmom2_3 + exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3) + eyx=tel(2,1); ezx=tel(3,1); ezy=tel(3,2) + z=u1/ezz + do gz=ceiling(-z+eps),floor( z-eps) + jz=iz+gz; z=gz; yc=-z*ezy + rry=(z*ezz)**2; y =sqrt(u1-rry) + do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps) + jy=iy+gy; y=gy; xc=-y*eyx-z*ezx + rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + b(jx,jy,jz)=b(jx,jy,jz)+frow*ta + enddo! gx + enddo! gy + enddo ! gz +enddo; enddo; enddo ! ix, iy, iz +a=b +end subroutine rbeta3t +!============================================================================= +module subroutine rbeta4T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & + el,ss, a) ! [rbetat] +!============================================================================= +! Perform an ADJOINT radial beta-function filter in 4D. +! It conserves "masses" initially distributed only at the closure of +! the central domain, +! Lx <= ix <= Mx, Ly <= iy <= My, Lz <= iz <= Mz, Lw <= iw <= Mw. +! The output field of the redistributed masses occupies the +! the extended domain, +! Lx-hx <= jx <= Mx+hx, Ly-hy <= Jy <= My+hy, Lz-hz <= Jz <= Mz+hz, +! Lw-hw <= Jw <= Mw+hw. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx,& + hy,ly,my,& + hz,lz,mz,& + hw,lw,mw +real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz,lw-hw:mw+hw), intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz,lw-hw:mw+hw) :: b +real(dp),dimension(4,4) :: tel +real(dp):: ta,s,rr,rrx,rry,rrz,rrc,frow,& + exx,eyy,ezz,eww,eyx,ezx,ewx,ezy,ewy,ewz,x,y,z,w,xc,yc,zc +integer :: ix,jx,gx +integer :: iy,jy,gy +integer :: iz,jz,gz +integer :: iw,jw,gw +!============================================================================= +b=0 +do iw=Lw,Mw; do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx + ta=a(ix,iy,iz,iw); s=ss(ix,iy,iz,iw) + tel=el(:,:,ix,iy,iz,iw)*this%rmom2_4 + exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3); eww=tel(4,4) + eyx=tel(2,1); ezx=tel(3,1); ewx=tel(4,1) + ezy=tel(3,2); ewy=tel(4,2) + ewz=tel(4,3) + z=u1/ezz + do gw=ceiling(-w+eps),floor( w-eps) + jw=iw+gw; w=gw; zc=-w*ewz + rrz=(w*eww)**2; z =sqrt(u1-rrz) + do gz=ceiling((zc-z)/ezz+eps),floor((zc+z)/ezz-eps) + jz=iz+gz; z=gz; yc=-z*ezy-w*ewy + rry=rrz+(z*ezz-zc)**2; y =sqrt(u1-rry) + do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps) + jy=iy+gy; y=gy; xc=-y*eyx-z*ezx-w*ewx + rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + b(jx,jy,jz,jw)=b(jx,jy,jz,jw)+frow*ta + enddo! gx + enddo! gy + enddo! gz + enddo! gw +enddo; enddo; enddo; enddo! ix, iy, iz, iw +a=b +end subroutine rbeta4t + + +!============================================================================= +module subroutine vrbeta4t(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, & + hw,lw,mw, el,ss, a) ! [rbetat] +!============================================================================= +! Vector version of rbeta4t filtering nv fields at once. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: nv, & + hx,Lx,mx,& + hy,ly,my,& + hz,lz,mz,& + hw,lw,mw +real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz,lw-hw:mw+hw), intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz,lw-hw:mw+hw) :: b +real(dp),dimension(nv) :: ta +real(dp),dimension(4,4) :: tel +real(dp):: s,rr,rrx,rry,rrz,rrc,frow,& + exx,eyy,ezz,eww,eyx,ezx,ewx,ezy,ewy,ewz,x,y,z,w,xc,yc,zc +integer :: ix,jx,gx +integer :: iy,jy,gy +integer :: iz,jz,gz +integer :: iw,jw,gw +!============================================================================= +b=0 +do iw=Lw,Mw; do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx + ta=a(:,ix,iy,iz,iw); s=ss(ix,iy,iz,iw) + tel=el(:,:,ix,iy,iz,iw)*this%rmom2_4 + exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3); eww=tel(4,4) + eyx=tel(2,1); ezx=tel(3,1); ewx=tel(4,1) + ezy=tel(3,2); ewy=tel(4,2) + ewz=tel(4,3) + z=u1/ezz + do gw=ceiling(-w+eps),floor( w-eps) + jw=iw+gw; w=gw; zc=-w*ewz + rrz=(w*eww)**2; z =sqrt(u1-rrz) + do gz=ceiling((zc-z)/ezz+eps),floor((zc+z)/ezz-eps) + jz=iz+gz; z=gz; yc=-z*ezy-w*ewy + rry=rrz+(z*ezz-zc)**2; y =sqrt(u1-rry) + do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps) + jy=iy+gy; y=gy; xc=-y*eyx-z*ezx-w*ewx + rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + b(:,jx,jy,jz,jw)=b(:,jx,jy,jz,jw)+frow*ta + enddo! gx + enddo! gy + enddo! gz + enddo! gw +enddo; enddo; enddo; enddo! ix, iy, iz, iw +a=b +end subroutine vrbeta4t + +! Vector versions of the above routines: +!============================================================================= +module subroutine vrbeta1(this,nv,hx,lx,mx, el,ss, a) ! [rbeta] +!============================================================================= +! Vector version of rbeta1 filtering nv fields at once. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: nv,hx,Lx,mx +real(dp),dimension(1,1, Lx:Mx), intent(in ):: el +real(dp),dimension( Lx:Mx), intent(in ):: ss +real(dp),dimension(nv,lx-hx:mx+hx),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(nv,lx-hx:mx+hx):: b +real(dp),dimension(nv) :: tb +real(dp) :: x,s,rr,rrc,frow,exx +integer :: ix,jx,gx +!============================================================================= +b=0 +do ix=Lx,Mx + tb=0; s=ss(ix) + exx=el(1,1,ix)*this%rmom2_1 + x=u1/exx + do gx=ceiling(-x+eps),floor( x-eps) + jx=ix+gx; x=gx + rr=(x*exx)**2; rrc=u1-rr + frow=s*rrc**this%p + tb=tb+frow*a(:,jx) + enddo + b(:,ix)=tb +enddo +a=b +end subroutine vrbeta1 + +!============================================================================= +module subroutine vrbeta2(this,nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] +!============================================================================= +! Vector version of rbeta2 filtering nv fields at once. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: nv, & + hx,Lx,mx, & + hy,ly,my +real(dp),dimension( 2,2,Lx:Mx,Ly:My), intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My), intent(in ):: ss +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy):: b +real(dp),dimension(nv) :: tb +real(dp),dimension(2,2) :: tel +real(dp) :: s,rr,rrx,rrc,& + frow,exx,eyy,eyx,x,y,xc +integer :: ix,jx,gx +integer :: iy,jy,gy +!============================================================================= +b=0 +do iy=Ly,My; do ix=Lx,Mx + tb=0; s=ss(ix,iy) + tel=el(:,:,ix,iy)*this%rmom2_2 ! This el, rescaled + exx=tel(1,1); eyy=tel(2,2) + eyx=tel(2,1) + y=u1/eyy + do gy=ceiling(-y+eps),floor( y-eps) + jy=iy+gy; y=gy; xc=-y*eyx + rrx=(y*eyy)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + tb=tb+frow*a(:,jx,jy) + enddo! gx + enddo! gy + b(:,ix,iy)=tb +enddo; enddo! ix, iy +a=b +end subroutine vrbeta2 + +!============================================================================= +module subroutine vrbeta3(this,nv, hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta] +!============================================================================= +! Vector version of rbeta3 filtering nv fields at once. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: nv, & + hx,Lx,mx,& + hy,ly,my,& + hz,lz,mz +real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz), intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz), intent(in ):: ss +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz):: b +real(dp),dimension(nv) :: tb +real(dp),dimension(3,3) :: tel +real(dp):: s,rr,rrx,rry,rrc,frow,& + exx,eyy,ezz,eyx,ezx,ezy,x,y,z,xc,yc +integer :: ix,jx,gx +integer :: iy,jy,gy +integer :: iz,jz,gz +!============================================================================= +b=0 +do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx + tb=0; s=ss(ix,iy,iz) + tel=el(:,:,ix,iy,iz)*this%rmom2_3 + exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3) + eyx=tel(2,1); ezx=tel(3,1); ezy=tel(3,2) + z=u1/ezz + do gz=ceiling(-z+eps),floor( z-eps) + jz=iz+gz; z=gz; yc=-z*ezy + rry=(z*ezz)**2; y =sqrt(u1-rry) + do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps) + jy=iy+gy; y=gy; xc=-y*eyx-z*ezx + rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + tb=tb+frow*a(:,jx,jy,jz) + enddo! gx + enddo! gy + enddo! gz + b(:,ix,iy,iz)=tb +enddo; enddo; enddo! ix, iy, iz +a=b +end subroutine vrbeta3 + +! Vector versions of the above routines: +!============================================================================= +module subroutine vrbeta1T(this,nv, hx,lx,mx, el,ss, a) ! [rbetat] +!============================================================================= +! Vector version of rbeta1t filtering nv fields at once. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: nv,hx,Lx,mx +real(dp),dimension(1,1,Lx:Mx), intent(in ):: el +real(dp),dimension( Lx:Mx), intent(in ):: ss +real(dp),dimension(nv,lx-hx:mx+hx),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(nv,lx-hx:mx+hx):: b +real(dp),dimension(nv) :: ta +real(dp) :: s,rr,rrc,frow,exx,x +integer :: ix,jx,gx +!============================================================================= +b=0 +do ix=Lx,Mx + ta=a(:,ix); s=ss(ix) + exx=el(1,1,ix)*this%rmom2_1 + x=u1/exx + do gx=ceiling(-x+eps),floor( x-eps) + jx=ix+gx; x=gx + rr=(x*exx)**2; rrc=u1-rr + frow=s*rrc**this%p + b(:,jx)=b(:,jx)+frow*ta + enddo +enddo +a=b +end subroutine vrbeta1t +!============================================================================= +module subroutine vrbeta2T(this,nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] +!============================================================================= +! Vector version of rbeta2t filtering nv fields at once. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: nv, & + hx,Lx,mx, & + hy,ly,my +real(dp),dimension( 2,2,Lx:Mx,Ly:My), intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My), intent(in ):: ss +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy):: b +real(dp),dimension(nv) :: ta +real(dp),dimension(2,2) :: tel +real(dp) :: s,rr,rrx,rrc, & + frow,exx,eyy,eyx,x,y,xc +integer :: ix,jx,gx +integer :: iy,jy,gy +!============================================================================= +b=0 +do iy=Ly,My; do ix=Lx,Mx + ta=a(:,ix,iy); s=ss(ix,iy) + tel=el(:,:,ix,iy)*this%rmom2_2 ! This el, rescaled + exx=tel(1,1); eyy=tel(2,2) + eyx=tel(2,1) + y=u1/eyy + do gy=ceiling(-y+eps),floor( y-eps) + jy=iy+gy; y=gy; xc=-y*eyx + rrx=(y*eyy)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + b(:,jx,jy)=b(:,jx,jy)+frow*ta + enddo! gx + enddo! gy +enddo; enddo ! ix, iy +a=b +end subroutine vrbeta2t + +!============================================================================= +module subroutine vrbeta3T(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat] +!============================================================================= +! Vector version of rbeta3t filtering nv fields at once. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: nv, & + hx,Lx,mx,& + hy,ly,my,& + hz,lz,mz +real(dp),dimension( 3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz),intent(in ):: ss +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz):: b +real(dp),dimension(nv) :: ta +real(dp),dimension(3,3) :: tel +real(dp):: s,rr,rrx,rry,rrc,frow,& + exx,eyy,ezz,eyx,ezx,ezy,x,y,z,xc,yc +integer :: ix,jx,gx +integer :: iy,jy,gy +integer :: iz,jz,gz +!============================================================================= +b=0 +do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx + ta=a(:,ix,iy,iz); s=ss(ix,iy,iz) + tel=el(:,:,ix,iy,iz)*this%rmom2_3 + exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3) + eyx=tel(2,1); ezx=tel(3,1); ezy=tel(3,2) + z=u1/ezz + do gz=ceiling(-z+eps),floor( z-eps) + jz=iz+gz; z=gz; yc=-z*ezy + rry=(z*ezz)**2; y =sqrt(u1-rry) + do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps) + jy=iy+gy; y=gy; xc=-y*eyx-z*ezx + rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + b(:,jx,jy,jz)=b(:,jx,jy,jz)+frow*ta + enddo! gx + enddo! gy + enddo! gz +enddo; enddo; enddo! ix, iy, iz +a=b +end subroutine vrbeta3t + +end submodule jp_pbfil + diff --git a/src/mgbf/jp_pbfil2.f90 b/src/mgbf/jp_pbfil2.f90 new file mode 100644 index 0000000000..63493f9727 --- /dev/null +++ b/src/mgbf/jp_pbfil2.f90 @@ -0,0 +1,1173 @@ +module jp_pbfil2 +!$$$ module documentation block +! . . . . +! module: jp_pbfil2 +! prgmmr: purser org: NOAA/EMC date: 2019-08 +! +! abstract: Module of data defining the exact transition rules +! of the decad algorithm based on the PG(3,2) reference +! geometry +! +! module history log: +! +! Subroutines Included: +! +! Functions Included: +! +! remarks: +! An overview of this topic is given NOAA/NCEP Office Note 500. +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +use jp_pkind, only: spi,dp +implicit none +public +private :: X, A, B +integer(spi),parameter :: X=99,A=10,B=11 +!---- Items that relate to beta line filters generally: +real(dp),allocatable,dimension(:) :: bnorm,bsprds +integer(spi) :: p,nh +!---- Items that relate only to 4D "decad" line filters: +integer(spi),dimension(4,0:9) :: dec0,dodec0t +integer(spi),dimension(4,0:11) :: dodec0 +integer(spi),dimension(0:14,0:14) :: typ +integer(spi),dimension(0:3,0:3,0:9,0:11) :: umat10 +integer(spi),dimension(0:3,0:3,0:3,12:59):: umat12 +integer(spi),dimension(0:3,0:3,4:9) :: umats +integer(spi),dimension(0:9,0:59) :: nei +integer(spi),dimension(0:9,0:11) :: dcol10 +integer(spi),dimension(0:3,12:59) :: dcol12 +integer(spi),dimension(2, 0:3) :: nei0a,jcora +integer(spi),dimension(2,1:2,4:9) :: nei0b,jcorb +integer(spi),dimension(2) :: nei17,nei22,nei33,nei38 +integer(spi),dimension(4,4,0:12) :: tcors +integer(spi),dimension(0:2,0:3) :: kcor10a5 +integer(spi),dimension(0:2,4:9) :: kcor10b1,kcor10b2 +integer(spi),dimension(12:59) :: kcor12b0 +integer(spi),dimension(0:2) :: kcor17c0,kcor22c0,kcor33c0,kcor38c0, & + kcor44c0,kcor51c0,kcor53c0,kcor58c0 +integer(spi),dimension(0:9,0:2) :: twt10a5,twt10b1,twt10b2,twt12c0 +integer(spi),dimension(0:9,0:9) :: qwt10a,qwt10b,qwt10c,qwt10d,qwt10e, & + qwt12a,qwt12b +integer(spi),dimension(0:9,0:2) :: qwt12b0 +integer(spi),dimension(0:9,0:12) :: tperms +integer(spi),dimension(0:9,0:9,0:11) :: perm10 +integer(spi),dimension(0:9,0:3,12:59) :: perm12 +integer(spi),dimension(0:9,4:9) :: perms +data p/0/ +data nh/0/ +data dec0/1,0,0,0, 0,1, 0,0, 0, 0,1, 0, 0,0,0,1, -1,-1,-1,-1, & + 1,0,1,1, -1,0,-1,0, 0,-1,0,-1, 1,1,0,1, -1, 0, 0,-1/ +data dodec0t/ & + +2, 0, 0, 0, 0, 2, 0, 0, 0, 0, 2, 0, 0, 0, 0, 2, & + -1,-1,-1,-1, 1, 1,-1,-1, 1,-1, 1,-1, & + -1, 1, 1, 1, -1, 1,-1,-1, -1,-1, 1,-1 / +data dodec0/ & + +2, 0, 0, 0, 0, 2, 0, 0, 0, 0, 2, 0, 0, 0, 0, 2, & + -1,-1,-1,-1, 1, 1,-1,-1, 1,-1, 1,-1, 1,-1,-1, 1, & + -1, 1, 1, 1, -1, 1,-1,-1, -1,-1, 1,-1, -1,-1,-1, 1/ +data typ/ X,6,8,X,X,X,X,7,3,9,5,1,0,2,4, &! 3;1;1;1;9 + X,3,6,9,8,5,X,1,X,0,X,2,X,4,7, &! 6;2;2;2;3 + X,X,3,0,6,X,9,2,8,X,5,4,X,7,1, &! 1;4;4;3;3 + X,8,X,X,3,5,0,4,6,X,X,7,9,1,2, &! 2;1;6;1;5 +!--------- + X,X,X,8,6,4,X,X,7,3,9,2,1,0,5, &! 1;1;4;1;8 + X,7,X,3,X,9,8,2,6,1,4,0,X,5,X, &! 2;2;8;2;1 + X,6,7,1,X,4,3,0,X,X,9,5,8,X,2, &! 4;4;1;4;2 + X,X,6,X,7,9,1,5,X,8,4,X,3,2,0, &! 1;2;5;3;4 +!--------- + 9,X,0,5,X,4,X,7,3,X,X,1,8,6,2, &! 3;2;3;1;6 + 9,3,X,X,0,X,5,1,X,8,4,6,X,2,7, &! 1;2;3;4;5 +!--------- + X,1,5,9,6,4,2,X,7,8,3,X,0,X,X, &! 4;2;1;1;7 +!--------- + X,7,0,X,9,8,X,4,1,X,3,5,X,2,6, &! 3;3;3;3;3 +!+++++++++ + X,1,X,4,2,3,5,B,X,A,0,9,8,7,6, &! 2;6;7 + X,X,1,A,X,0,4,9,2,8,3,7,5,6,B, &! 1;3;11 +!--------- + X,0,3,B,2,X,4,7,1,5,X,8,9,6,A/ ! 5;5;5 +data umat10/& +!---------------- 0 + 1, 1, 1, 1, 0, 1,-1, 1, 0, 0, 0, 1, -1, 0, 0,-1, & + 0, 0, 1, 0, -2,-1,-1,-2, 0,-1, 0,-1, 0, 0, 0, 1, & + 0, 0, 0, 1, -1,-1,-1,-1, -1,-1, 0,-1, 2, 0, 1, 1, & + 1, 1, 1, 1, 1, 0, 0, 0, 1,-1, 1, 0, -1, 0, 0,-1, & + 1, 0, 0, 1, 0,-1, 0,-1, 1, 0, 1, 0, 0, 1,-1, 0, & + 1, 1, 0, 1, 0,-1,-1, 0, 0, 0, 0, 1, 1, 0, 1, 0, & + 1, 1, 0, 1, 0,-1,-1,-1, -1, 0,-1,-1, 0, 0, 0, 1, & + 0, 0, 1, 0, 0, 1, 0, 0, 2, 1, 1, 1, 0, 0, 0, 1, & + 1, 0, 1, 1, -1, 0, 0, 0, 0, 1, 0, 1, 0,-1,-1, 0, & + 0, 1, 0, 1, -1, 0,-1,-1, 1, 1, 0, 0, 0, 0, 1, 0, & +!---------------- 1 + 1, 1, 1, 1, 0, 1,-1, 1, 0, 0, 0, 1, -1, 0, 0,-1, & + 0, 0, 1, 0, -2,-1,-1,-2, 0,-1, 0,-1, 0, 0, 0, 1, & + 0, 0, 0, 1, -1,-1,-1,-1, -1,-1, 0,-1, 2, 0, 1, 1, & + 1, 1, 1, 1, -1, 1,-1, 0, -1, 0, 0, 0, 1, 0, 0, 1, & + 1, 0, 0, 1, -1, 0,-1, 0, 0, 1, 0, 1, 0,-1, 1, 0, & + 1, 1, 0, 1, 1, 0, 1, 0, 0, 0, 0,-1, 0,-1,-1, 0, & + 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 1, 0, 0, 0,-1, & + 0, 0, 1, 0, -2,-1,-1,-1, 0,-1, 0, 0, 0, 0, 0,-1, & + 1, 0, 1, 1, 0,-1, 0,-1, 1, 0, 0, 0, 0, 1, 1, 0, & + 0, 1, 0, 1, -1,-1, 0, 0, 1, 0, 1, 1, 0, 0,-1, 0, & +!---------------- 2 + 1, 1, 1, 1, 0, 0, 0,-1, 0,-1, 1,-1, 1, 0, 0, 1, & + 0, 0, 1, 0, 0, 1, 0, 1, 2, 1, 1, 2, 0, 0, 0,-1, & + 0, 0, 0, 1, 1, 1, 0, 1, 1, 1, 1, 1, -2, 0,-1,-1, & + 1, 1, 1, 1, -1, 1,-1, 0, -1, 0, 0, 0, 1, 0, 0, 1, & + 1, 0, 0, 1, -1, 0,-1, 0, 0, 1, 0, 1, 0,-1, 1, 0, & + 1, 1, 0, 1, 0,-1,-1, 0, 0, 0, 0, 1, 1, 0, 1, 0, & + 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 1, 0, 0, 0,-1, & + 0, 0, 1, 0, -2,-1,-1,-1, 0,-1, 0, 0, 0, 0, 0,-1, & + 1, 0, 1, 1, 0,-1, 0,-1, 1, 0, 0, 0, 0, 1, 1, 0, & + 0, 1, 0, 1, -1,-1, 0, 0, 1, 0, 1, 1, 0, 0,-1, 0, & + !---------------- 3 + 1, 1, 1, 1, 0, 0, 0,-1, 0,-1, 1,-1, 1, 0, 0, 1, & + 0, 0, 1, 0, 0, 1, 0, 1, 2, 1, 1, 2, 0, 0, 0,-1, & + 0, 0, 0, 1, 1, 1, 0, 1, 1, 1, 1, 1, -2, 0,-1,-1, & + 1, 1, 1, 1, 1, 0, 0, 0, 1,-1, 1, 0, -1, 0, 0,-1, & + 1, 0, 0, 1, 0,-1, 0,-1, 1, 0, 1, 0, 0, 1,-1, 0, & + 1, 1, 0, 1, 1, 0, 1, 0, 0, 0, 0,-1, 0,-1,-1, 0, & + 1, 1, 0, 1, 0,-1,-1,-1, -1, 0,-1,-1, 0, 0, 0, 1, & + 0, 0, 1, 0, 0, 1, 0, 0, 2, 1, 1, 1, 0, 0, 0, 1, & + 1, 0, 1, 1, -1, 0, 0, 0, 0, 1, 0, 1, 0,-1,-1, 0, & + 0, 1, 0, 1, -1, 0,-1,-1, 1, 1, 0, 0, 0, 0, 1, 0, & +!---------------- 4 + 1, 0, 1, 1, 0,-1, 0,-1, -1,-1, 0,-1, 0, 0,-1, 1, & + 1, 0, 1, 0, -1,-1,-1,-2, -1, 0, 0,-1, 1, 1, 0, 1, & + 0, 0, 0, 1, 2, 0, 1, 1, 1, 1, 0, 1, -1,-1,-1,-1, & + 0, 0, 1, 0, 0, 1, 0, 0, -2, 0,-1,-1, 0,-1, 0,-1, & + 0, 0, 0, 1, 0, 0, 1, 0, 1,-1, 1, 0, 1, 1, 0, 1, & + 1, 1, 0, 1, 1, 0, 1, 0, 0, 0, 0,-1, 0,-1,-1, 0, & + 1, 0, 0, 1, 0,-1, 0,-1, 0, 0,-1,-1, 1, 1, 1, 1, & + 1, 0, 0, 1, 1, 1, 0, 0, 1, 0, 1, 0, -1,-1,-1,-1, & + 1, 0, 1, 0, 0,-1,-1,-1, 0,-1, 0, 0, -1, 0, 0,-1, & + 0, 1, 0, 1, 0, 0,-1, 0, 1, 1, 0, 0, 1, 0, 1, 1, & +!---------------- 5 + 1, 0, 1, 1, 0,-1, 0,-1, -1,-1, 0,-1, 0, 0,-1, 1, & + 1, 0, 1, 0, 1, 1, 0, 1, 1, 0, 0, 1, -1,-1,-1,-2, & + 0, 0, 0, 1, -1,-1,-1,-1, -1,-1, 0,-1, 2, 0, 1, 1, & + 0, 0, 1, 0, 0, 1, 0, 0, -2, 0,-1,-1, 0,-1, 0,-1, & + 0, 0, 0, 1, -1, 1,-1, 0, 0, 0,-1, 0, -1,-1, 0,-1, & + 1, 1, 0, 1, 1, 0, 1, 0, 0, 0, 0,-1, 0,-1,-1, 0, & + 1, 0, 0, 1, 0, 0, 1, 1, 0, 1, 0, 1, -1,-1,-1,-1, & + 1, 0, 0, 1, 1, 1, 0, 0, 1, 0, 1, 0, -1,-1,-1,-1, & + 1, 0, 1, 0, 0, 1, 0, 0, 0, 1, 1, 1, 1, 0, 0, 1, & + 0, 1, 0, 1, -1,-1, 0, 0, 0, 0, 1, 0, -1, 0,-1,-1, & +!---------------- 6 + 1, 0, 1, 1, 1, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1,-1, & + 1, 0, 0, 0, 1, 1, 1, 1, 1, 1, 0, 2, -1, 0,-1,-1, & + 0, 0, 0, 1, 2, 0, 1, 1, 1, 1, 0, 1, -1,-1,-1,-1, & + 0, 0, 1, 0, 2, 0, 1, 1, 0,-1, 0, 0, 0, 1, 0, 1, & + 0, 0, 0, 1, -1, 1,-1, 0, 0, 0,-1, 0, -1,-1, 0,-1, & + 1, 1, 0, 1, 0, 0, 0, 1, -1, 0,-1, 0, 0, 1, 1, 0, & + 1, 0, 0, 1, 0, 0, 1, 1, 0, 1, 0, 1, -1,-1,-1,-1, & + 1, 0, 0, 1, -1, 0,-1, 0, -1,-1, 0, 0, 1, 1, 1, 1, & + 1, 0, 1, 0, 0, 1, 0, 0, 0, 1, 1, 1, 1, 0, 0, 1, & + 0, 1, 0, 1, -1,-1, 0, 0, 0, 0, 1, 0, -1, 0,-1,-1, & +!---------------- 7 + 1, 0, 1, 1, 1, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1,-1, & + 1, 0, 1, 0, 1, 1, 0, 1, 1, 0, 0, 1, -1,-1,-1,-2, & + 0, 1, 0, 1, 2, 1, 1, 1, 1, 0, 1, 1, -1, 0, 0,-1, & + 0, 0, 1, 0, 2, 0, 1, 1, 0,-1, 0, 0, 0, 1, 0, 1, & + 0, 0, 0, 1, 0, 0, 1, 0, 1,-1, 1, 0, 1, 1, 0, 1, & + 1, 1, 0, 1, 0, 0, 0, 1, -1, 0,-1, 0, 0, 1, 1, 0, & + 1, 0, 0, 1, 0,-1, 0,-1, 0, 0,-1,-1, 1, 1, 1, 1, & + 1, 0, 0, 1, -1, 0,-1, 0, -1,-1, 0, 0, 1, 1, 1, 1, & + 1, 0, 1, 0, 0,-1,-1,-1, 0,-1, 0, 0, -1, 0, 0,-1, & + 0, 1, 0, 1, 0, 0,-1, 0, 1, 1, 0, 0, 1, 0, 1, 1, & +!---------------- 8 + 1, 0, 1, 1, 1, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1,-1, & + 1, 0, 0, 0, -1,-1, 0,-2, -1,-1,-1,-1, 1, 0, 1, 1, & + 0, 0, 0, 1, -2, 0,-1,-1, -1,-1,-1,-1, 1, 1, 0, 1, & + 1, 1, 0, 1, -1, 0,-1, 0, -1, 0,-1,-1, 1,-1, 0, 0, & + 1, 0, 0, 1, 1, 0, 1, 0, 0,-1, 0,-1, 0, 1,-1, 0, & + 1, 0, 0, 0, 0,-1, 0, 0, 0, 0,-1, 1, 1, 1, 1, 1, & + 0, 1, 0, 0, 0, 0, 1, 0, 1, 1, 1, 2, 1, 0, 0, 0, & + 0, 0, 1, 0, -2,-1,-1,-1, 0,-1, 0, 0, 0, 0, 0,-1, & + 0, 0, 0, 1, -1, 1, 0, 0, 0, 0, 1, 0, -1,-1,-1,-1, & + 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0,-1, 0,-1, 1, 0, & +!---------------- 9 + 1, 0, 1, 1, 1, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1,-1, & + 1, 0, 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, -1,-1, 0,-2, & + 0, 1, 0, 0, 2, 1, 1, 2, 1, 0, 0, 0, -1, 0,-1, 0, & + 1, 1, 0, 1, -1, 0,-1, 0, -1, 0,-1,-1, 1,-1, 0, 0, & + 1, 0, 0, 1, 0, 1, 0, 1, -1, 0,-1, 0, 0,-1, 1, 0, & + 1, 0, 0, 0, 0,-1, 0, 0, 0, 0,-1, 1, 1, 1, 1, 1, & + 0, 1, 0, 0, -1,-1,-1,-2, 0, 0,-1, 0, -1, 0, 0, 0, & + 0, 0, 1, 0, 0, 1, 0, 0, 2, 1, 1, 1, 0, 0, 0, 1, & + 0, 0, 0, 1, -1, 1, 0, 0, 0, 0, 1, 0, -1,-1,-1,-1, & + 1, 1, 1, 1, 0, 0, 0, 1, -1, 0, 0, 0, 0, 1,-1, 0, & +!---------------- 10 + 0, 1, 0, 0, 1, 1, 0, 2, -1, 0,-1, 0, 0, 0, 1, 0, & + 1, 0, 1, 0, 1, 0, 0, 1, 1, 1, 1, 2, -1,-1, 0,-1, & + 0, 1, 0, 1, -2,-1,-1,-1, -1, 0,-1,-1, 1, 0, 0, 1, & + 1, 1, 1, 1, -1, 0, 0,-1, -1, 0, 0, 0, 1,-1, 1, 0, & + 0, 0, 0, 1, 1, 1, 0, 1, 0, 0,-1, 0, 1,-1, 1, 0, & + 0, 1, 0, 1, 0, 0,-1, 0, -1,-1,-1, 0, -1, 0, 0,-1, & + 0, 1, 0, 0, -1,-1,-1,-2, 1, 0, 0, 0, 0, 0, 1, 0, & + 1, 0, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, -1, 0, 0, 0, & + 1, 0, 1, 1, 0, 1, 0, 1, 0, 1, 1, 0, 1, 0, 0, 0, & + 1, 0, 1, 0, 0, 1, 0, 0, 0, 0,-1,-1, -1,-1, 0,-1, & +!---------------- 11 + 1, 1, 1, 1, -1, 0, 0,-1, 0, 0, 0,-1, 0, 1,-1, 1, & + 0, 0, 1, 0, 0, 0, 0,-1, 0,-1, 0,-1, 2, 1, 1, 2, & + 0, 1, 0, 0, -1, 0,-1, 0, -1, 0, 0, 0, 2, 1, 1, 2, & + 1, 1, 0, 1, -1, 0,-1,-1, -1, 0,-1, 0, 1,-1, 0, 0, & + 1, 0, 0, 0, 0, 1, 0, 0, -1, 0,-1,-1, 0,-1, 1,-1, & + 0, 1, 0, 1, 0, 0, 1, 0, -1, 0, 0,-1, -1,-1,-1, 0, & + 1, 0, 0, 1, 0, 1, 0, 1, 1, 1, 1, 1, 0, 0,-1,-1, & + 1, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 1, -1,-1,-1, 0, & + 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, 1, 0, 1,-1, 0, 0, & + 1, 0, 1, 0, 1, 1, 0, 1, 0, 1, 0, 0, 0, 0, 1, 1/ +data umat12/& +!---------------- 12 + 0, 2,-2, 0, 1, 1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, & + 1, 1,-1, 1, 0, 0, 2, 2, -2, 0, 0, 0, 0, 0, 0,-2, & + 1, 1,-1,-1, 0,-2, 0,-2, -2, 0, 0, 0, 0, 0, 0, 2, & + 0, 0, 2, 0, -1, 1,-1,-1, -1, 1,-1, 1, 0,-2, 0, 0, & +!---------------- 13 + 0, 0, 2, 2, -1,-1, 1,-1, 1,-1, 1,-1, 0, 2, 0, 0, & + 1, 1, 1, 1, 1,-1, 1, 1, 0, 0,-2, 0, -2, 0, 0, 0, & + 1, 1,-1, 1, 1,-1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, & + 0, 2,-2, 0, -1, 1, 1, 1, 1,-1, 1, 1, 1,-1, 1,-1, & +!---------------- 14 + 0, 2, 0, 2, 0, 0, 2, 0, -1,-1, 1, 1, -1, 1,-1,-1, & + 1,-1,-1,-1, -1,-1, 1,-1, -1, 1,-1,-1, 1, 1, 1, 1, & + 1, 1,-1,-1, 0,-2, 0,-2, 1,-1, 1, 1, -1, 1, 1, 1, & + 1,-1,-1,-1, -1,-1, 1,-1, -1,-1, 1, 1, 1, 1, 1, 1, & +!---------------- 15 + 0, 2, 0, 2, 1, 1,-1,-1, 0, 0,-2, 0, 1,-1, 1, 1, & + 1, 1,-1, 1, 1,-1, 1, 1, 0, 0, 2, 0, -2, 0, 0, 0, & + 1,-1,-1,-1, -1, 1,-1, 1, 0, 2, 0, 0, -1,-1, 1,-1, & + 1,-1,-1,-1, 1,-1, 1, 1, -1, 1,-1, 1, 0, 2, 0, 0, & +!---------------- 16 + 0, 0, 2, 2, -1,-1, 1,-1, 0,-2, 0, 0, -1, 1,-1, 1, & + 0, 0, 2, 0, 2, 0, 0, 0, 0, 0, 0, 2, -1,-1,-1,-1, & + 1, 1, 1, 1, -1,-1, 1, 1, -1, 1,-1, 1, 1,-1,-1,-1, & + 1, 1, 1, 1, -1,-1, 1, 1, -1,-1, 1,-1, 1,-1,-1,-1, & +!---------------- 17 + 0, 2, 0, 2, -1, 1,-1,-1, 0, 0,-2, 0, -1,-1, 1, 1, & + 1,-1, 1, 1, 0, 0, 2, 0, -2, 0, 0, 0, 0, 0,-2,-2, & + 1, 1,-1, 1, 0,-2, 0, 0, -2, 0, 0, 0, 0, 0, 0,-2, & + 0, 0, 2, 0, -1,-1, 1, 1, 1, 1,-1, 1, 1,-1,-1,-1, & + !---------------- 18 + 0, 2,-2, 0, -1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0,-2, & + 0, 0, 2, 2, -1,-1, 1,-1, -1, 1,-1,-1, 0, 0,-2, 0, & + 0, 2, 0, 2, 1, 1,-1,-1, 1,-1, 1,-1, 0,-2, 0, 0, & + 0, 0, 2, 0, -2, 0, 0, 0, 0, 2,-2, 0, 1,-1,-1,-1, & +!---------------- 19 + 0, 2,-2, 0, 0, 0, 0,-2, -1,-1,-1,-1, -1, 1, 1, 1, & + 1, 1,-1,-1, -1, 1, 1, 1, 0, 0, 0, 2, -1,-1,-1,-1, & + 1, 1,-1, 1, 0, 2, 0, 0, 1,-1, 1,-1, -1,-1, 1, 1, & + 1,-1, 1, 1, 1,-1, 1,-1, -1,-1,-1,-1, 0, 2,-2, 0, & +!---------------- 20 + 0, 2, 0, 2, 1,-1, 1, 1, -1,-1, 1, 1, 0, 0,-2, 0, & + 1, 1,-1,-1, 1,-1, 1,-1, -1,-1,-1,-1, 0, 0, 0, 2, & + 2, 0, 0, 0, 0,-2, 0, 0, -1, 1,-1, 1, -1, 1, 1, 1, & + 0, 2,-2, 0, -1,-1,-1,-1, 1,-1, 1,-1, 1,-1, 1, 1, & +!---------------- 21 + 0, 2,-2, 0, -1,-1,-1,-1, 1,-1,-1,-1, 0, 0, 0, 2, & + 1, 1,-1,-1, 0, 0, 2, 0, -2, 0, 0, 0, 0, 0, 0, 2, & + 1, 1,-1, 1, 0,-2, 0, 0, -2, 0, 0, 0, 0, 0, 0,-2, & + 1,-1,-1,-1, 1,-1, 1, 1, 0, 0, 2, 0, -2, 0, 0, 0, & +!---------------- 22 + 0, 0, 2, 2, 1,-1, 1,-1, 0,-2, 0, 0, 1, 1,-1, 1, & + 0, 0, 0, 2, -2, 0, 0, 0, 0, 0, 2, 0, 1, 1,-1,-1, & + 1,-1, 1,-1, 0,-2, 0, 0, -2, 0, 0, 0, 0, 2, 0, 2, & + 0, 2, 0, 0, 1, 1,-1, 1, -1,-1, 1, 1, -1,-1,-1,-1, & +!---------------- 23 + 0, 2, 0, 2, 0, 0, 2, 0, -1,-1, 1, 1, -1, 1,-1,-1, & + 1, 1,-1,-1, -1, 1,-1, 1, 0, 0, 2, 2, -1,-1, 1,-1, & + 1,-1,-1,-1, -1, 1,-1, 1, -1,-1, 1, 1, 1, 1, 1, 1, & + 1,-1, 1, 1, 1,-1,-1,-1, 0, 2,-2, 0, -2, 0, 0, 0, & +!---------------- 24 + 0, 0, 2, 2, 0, 2, 0, 0, 1, 1,-1, 1, 1,-1, 1,-1, & + 1, 1, 1, 1, -1, 1,-1,-1, 0, 0,-2, 0, -1,-1, 1, 1, & + 1, 1,-1,-1, 1,-1, 1,-1, 0,-2, 0, 0, -2, 0, 0, 0, & + 1, 1, 1, 1, 1,-1, 1,-1, -1, 1,-1,-1, 0, 0,-2, 0, & +!---------------- 25 + 0, 0, 2, 2, -1,-1, 1,-1, 0,-2, 0, 0, -1, 1,-1, 1, & + 1, 1, 1, 1, -1, 1,-1,-1, -1,-1, 1,-1, 1,-1,-1,-1, & + 0, 0, 0, 2, -1, 1, 1, 1, 1,-1, 1,-1, 1, 1,-1,-1, & + 1,-1, 1,-1, 1, 1, 1, 1, 0, 2,-2, 0, -2, 0, 0, 0, & +!---------------- 26 + 0, 2,-2, 0, 1,-1,-1,-1, 0, 0, 0,-2, 1, 1, 1, 1, & + 1, 1,-1,-1, 0, 0,-2, 0, 1,-1, 1, 1, -1,-1, 1,-1, & + 1, 1,-1, 1, -1,-1,-1,-1, 0, 0, 0,-2, -1, 1, 1, 1, & + 0, 2,-2, 0, -1, 1, 1, 1, 1,-1, 1, 1, 1,-1, 1,-1, & +!---------------- 27 + 0, 2,-2, 0, 1, 1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, & + 0, 0, 2, 0, -1,-1, 1, 1, -1, 1,-1, 1, 0, 0,-2,-2, & + 0, 2, 0, 0, 1, 1,-1, 1, 1,-1, 1, 1, 0,-2, 0,-2, & + 1,-1,-1,-1, -1, 1,-1,-1, -1, 1,-1, 1, 1, 1, 1, 1, & +!---------------- 28 + 0, 2,-2, 0, 1, 1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, & + 1, 1,-1, 1, 0, 0, 2, 2, -2, 0, 0, 0, 0, 0, 0,-2, & + 1, 1,-1,-1, 0,-2, 0,-2, -2, 0, 0, 0, 0, 0, 0, 2, & + 0, 2, 0, 0, 1,-1, 1,-1, 1,-1, 1, 1, 0, 0,-2, 0, & +!---------------- 29 + 0, 0, 2, 2, -1,-1, 1,-1, 1,-1, 1,-1, 0, 2, 0, 0, & + 1, 1, 1, 1, 1,-1, 1, 1, 0, 0,-2, 0, -2, 0, 0, 0, & + 1, 1,-1, 1, 1,-1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, & + 0, 2,-2, 0, -1, 1, 1, 1, 1,-1, 1, 1, 1,-1, 1,-1, & +!---------------- 30 + 0, 2, 0, 2, 0, 0, 2, 0, -1,-1, 1, 1, -1, 1,-1,-1, & + 1,-1,-1,-1, -1,-1, 1,-1, -1, 1,-1,-1, 1, 1, 1, 1, & + 1,-1, 1, 1, -1,-1, 1,-1, 0, 2, 0, 0, -1, 1,-1, 1, & + 1,-1,-1,-1, -1,-1, 1,-1, -1,-1, 1, 1, 1, 1, 1, 1, & +!---------------- 31 + 0, 2, 0, 2, 0, 0, 2, 0, -1,-1, 1, 1, -1, 1,-1,-1, & + 1, 1,-1, 1, 1,-1, 1, 1, 0, 0, 2, 0, -2, 0, 0, 0, & + 1,-1,-1,-1, -1, 1,-1, 1, 0, 2, 0, 0, -1,-1, 1,-1, & + 1,-1,-1,-1, 1,-1, 1, 1, -1, 1,-1, 1, 0, 2, 0, 0, & +!---------------- 32 + 0, 0, 2, 2, -1,-1, 1,-1, 0,-2, 0, 0, -1, 1,-1, 1, & + 0, 0, 0, 2, 1,-1,-1,-1, -1,-1, 1,-1, -1, 1,-1,-1, & + 1, 1, 1, 1, -1,-1, 1, 1, -1, 1,-1, 1, 1,-1,-1,-1, & + 1, 1, 1, 1, -1,-1, 1, 1, -1,-1, 1,-1, 1,-1,-1,-1, & +!---------------- 33 + 0, 2, 0, 2, -1,-1, 1, 1, 0, 0, 2, 0, -1, 1,-1,-1, & + 1,-1, 1, 1, 0, 0, 2, 0, -2, 0, 0, 0, 0, 0,-2,-2, & + 0, 0, 0, 2, 2, 0, 0, 0, 0, 2, 0, 0, -1,-1, 1,-1, & + 0, 0, 2, 0, -1,-1, 1, 1, 1, 1,-1, 1, 1,-1,-1,-1, & +!---------------- 34 + 0, 2,-2, 0, -1,-1,-1,-1, 1,-1,-1,-1, 0, 0, 0, 2, & + 0, 0, 2, 2, -1,-1, 1,-1, -1, 1,-1,-1, 0, 0,-2, 0, & + 0, 2, 0, 2, 1, 1,-1,-1, 1,-1, 1,-1, 0,-2, 0, 0, & + 1,-1, 1, 1, -1, 1, 1, 1, -1,-1, 1,-1, 1, 1,-1,-1, & +!---------------- 35 + 0, 2,-2, 0, 0, 0, 0,-2, -1,-1,-1,-1, -1, 1, 1, 1, & + 1, 1,-1,-1, -1, 1, 1, 1, 0, 0, 0, 2, -1,-1,-1,-1, & + 1, 1,-1, 1, 0, 2, 0, 0, 1,-1, 1,-1, -1,-1, 1, 1, & + 1,-1, 1, 1, 1,-1, 1,-1, -1,-1,-1,-1, 0, 2,-2, 0, & +!---------------- 36 + 0, 2, 0, 2, 1,-1, 1, 1, -1,-1, 1, 1, 0, 0,-2, 0, & + 1, 1,-1,-1, 1,-1, 1,-1, -1,-1,-1,-1, 0, 0, 0, 2, & + 2, 0, 0, 0, 0,-2, 0, 0, -1, 1,-1, 1, -1, 1, 1, 1, & + 0, 2,-2, 0, -1,-1,-1,-1, 1,-1, 1,-1, 1,-1, 1, 1, & +!---------------- 37 + 0, 2,-2, 0, -1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0,-2, & + 1, 1,-1,-1, 0, 0, 2, 0, -2, 0, 0, 0, 0, 0, 0, 2, & + 1, 1,-1, 1, 0,-2, 0, 0, -2, 0, 0, 0, 0, 0, 0,-2, & + 0, 0, 2, 0, -1,-1, 1, 1, -1,-1,-1,-1, 0, 2,-2, 0, & +!---------------- 38 + 0, 2, 0, 2, 1, 1,-1,-1, -1, 1,-1,-1, 0, 0, 2, 0, & + 1, 1,-1,-1, 0, 0, 2, 0, -2, 0, 0, 0, 0, 0, 0, 2, & + 1,-1, 1,-1, 0,-2, 0, 0, -2, 0, 0, 0, 0, 2, 0, 2, & + 0, 2, 0, 0, 1, 1,-1, 1, -1,-1, 1, 1, -1,-1,-1,-1, & +!---------------- 39 + 0, 2, 0, 2, 1, 1,-1,-1, 0, 0,-2, 0, 1,-1, 1, 1, & + 0, 0, 2, 2, -2, 0, 0, 0, 0, 0, 0,-2, 1,-1,-1,-1, & + 1,-1,-1,-1, -1, 1,-1, 1, -1,-1, 1, 1, 1, 1, 1, 1, & + 1,-1, 1, 1, 1,-1,-1,-1, 0, 2,-2, 0, -2, 0, 0, 0, & +!---------------- 40 + 0, 0, 2, 2, -1,-1, 1,-1, 0,-2, 0, 0, -1, 1,-1, 1, & + 1, 1, 1, 1, -1, 1,-1,-1, 0, 0,-2, 0, -1,-1, 1, 1, & + 1, 1,-1,-1, 1,-1, 1,-1, 0,-2, 0, 0, -2, 0, 0, 0, & + 1, 1, 1, 1, 1,-1, 1,-1, -1, 1,-1,-1, 0, 0,-2, 0, & +!---------------- 41 + 0, 0, 2, 2, 0, 2, 0, 0, 1, 1,-1, 1, 1,-1, 1,-1, & + 1, 1, 1, 1, -1, 1,-1,-1, -1,-1, 1,-1, 1,-1,-1,-1, & + 1,-1, 1,-1, 0, 2, 0, 0, 1, 1,-1, 1, -1,-1,-1,-1, & + 1,-1, 1,-1, 1, 1, 1, 1, 0, 2,-2, 0, -2, 0, 0, 0, & +!---------------- 42 + 0, 2,-2, 0, 1,-1,-1,-1, 0, 0, 0,-2, 1, 1, 1, 1, & + 1, 1,-1,-1, 0, 0,-2, 0, 1,-1, 1, 1, -1,-1, 1,-1, & + 1, 1,-1, 1, -1,-1,-1,-1, 0, 0, 0,-2, -1, 1, 1, 1, & + 0, 2,-2, 0, -1, 1, 1, 1, 1,-1, 1, 1, 1,-1, 1,-1, & + !---------------- 43 + 0, 2,-2, 0, 1, 1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, & + 0, 0, 2, 0, -1,-1, 1, 1, -1, 1,-1, 1, 0, 0,-2,-2, & + 0, 2, 0, 0, 1, 1,-1, 1, 1,-1, 1, 1, 0,-2, 0,-2, & + 1, 1, 1, 1, -1, 1,-1, 1, -1, 1,-1,-1, 1,-1,-1,-1, & +!---------------- 44 + 0, 2,-2, 0, -1, 1, 1, 1, 0, 0, 0, 2, -1,-1,-1,-1, & + 1,-1, 1,-1, 0, 0, 2, 2, -2, 0, 0, 0, 0, 0,-2, 0, & + 0, 0, 0, 2, -2, 0, 0, 0, 0,-2, 0,-2, 1, 1,-1,-1, & + 1, 1, 1, 1, 0, 2,-2, 0, -2, 0, 0, 0, 0,-2, 0, 0, & +!---------------- 45 + 0, 0, 2, 2, 0,-2, 0, 0, -1,-1, 1,-1, -1, 1,-1, 1, & + 1,-1,-1,-1, 1, 1,-1, 1, 0, 0, 2, 2, -2, 0, 0, 0, & + 2, 0, 0, 0, 0, 0, 0,-2, -1, 1, 1, 1, -1, 1,-1, 1, & + 1, 1,-1,-1, -1,-1,-1,-1, 0,-2, 2, 0, -1, 1, 1, 1, & +!---------------- 46 + 0, 2, 0, 2, 0, 0,-2, 0, 1, 1,-1,-1, 1,-1, 1, 1, & + 1, 1,-1, 1, -1, 1,-1,-1, 0, 0, 2, 0, -1,-1, 1, 1, & + 1,-1, 1, 1, 0,-2, 0,-2, 1, 1,-1,-1, -1, 1,-1, 1, & + 1, 1, 1, 1, 0, 2,-2, 0, 1,-1,-1,-1, -1,-1, 1,-1, & +!---------------- 47 + 0, 2, 0, 2, 0, 0, 2, 0, 1,-1, 1, 1, 1, 1,-1,-1, & + 1, 1,-1, 1, 0, 0, 2, 2, 1,-1, 1,-1, -1,-1,-1,-1, & + 1,-1,-1,-1, -1, 1,-1,-1, 0, 2, 0, 2, -1,-1, 1, 1, & + 1, 1, 1, 1, -1,-1, 1, 1, 0, 0,-2, 0, -1, 1,-1,-1, & +!---------------- 48 + 0, 2,-2, 0, -1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0,-2, & + 1, 1,-1,-1, 1,-1, 1,-1, 0, 0, 2, 2, -2, 0, 0, 0, & + 2, 0, 0, 0, 0, 2, 0, 2, -1, 1,-1,-1, -1,-1, 1,-1, & + 1, 1, 1, 1, 1,-1, 1,-1, -1, 1,-1,-1, 0, 0,-2, 0, & +!---------------- 49 + 0, 0, 2, 2, -1, 1,-1, 1, 1, 1,-1, 1, 0,-2, 0, 0, & + 1, 1,-1, 1, 1,-1,-1,-1, -1,-1, 1, 1, 0, 0, 2, 0, & + 2, 0, 0, 0, 0, 2, 0, 2, -1,-1, 1, 1, -1,-1,-1,-1, & + 1,-1, 1, 1, 1,-1,-1,-1, 0, 2,-2, 0, -2, 0, 0, 0, & +!---------------- 50 + 0, 2,-2, 0, 1, 1, 1, 1, 0, 0, 0, 2, 1,-1,-1,-1, & + 1,-1, 1, 1, -1,-1, 1,-1, 0, 0,-2,-2, -1, 1,-1, 1, & + 2, 0, 0, 0, 0,-2, 0, 0, -1, 1,-1, 1, -1, 1, 1, 1, & + 1,-1, 1,-1, 1, 1, 1, 1, 0, 2,-2, 0, -2, 0, 0, 0, & +!---------------- 51 + 0, 0, 2, 2, -1,-1, 1,-1, 0,-2, 0, 0, -1, 1,-1, 1, & + 1, 1,-1, 1, 0, 0, 2, 2, -2, 0, 0, 0, 0, 0, 0,-2, & + 0, 2, 0, 0, -2, 0, 0, 0, 0,-2, 0,-2, 1,-1, 1, 1, & + 0, 0, 2, 0, -2, 0, 0, 0, 0, 2,-2, 0, 1,-1,-1,-1, & +!---------------- 52 + 0, 0, 2, 2, 1, 1,-1, 1, 0, 2, 0, 0, 1,-1, 1,-1, & + 1,-1,-1,-1, 1, 1,-1, 1, 0, 0, 2, 2, -2, 0, 0, 0, & + 2, 0, 0, 0, 0, 0, 0,-2, -1, 1, 1, 1, -1, 1,-1, 1, & + 1, 1,-1,-1, -1,-1,-1,-1, 0,-2, 2, 0, -1, 1, 1, 1, & +!---------------- 53 + 0, 2,-2, 0, -1, 1, 1, 1, 0, 0, 0, 2, -1,-1,-1,-1, & + 0, 0, 2, 0, 2, 0, 0, 0, 0, 0,-2,-2, -1, 1,-1, 1, & + 0, 0, 0, 2, -2, 0, 0, 0, 0,-2, 0,-2, 1, 1,-1,-1, & + 1, 1, 1, 1, 0, 2,-2, 0, -2, 0, 0, 0, 0,-2, 0, 0, & +!---------------- 54 + 0, 2, 0, 2, -1, 1,-1,-1, 0, 0,-2, 0, -1,-1, 1, 1, & + 1, 1,-1, 1, 0, 0, 2, 2, 1,-1, 1,-1, -1,-1,-1,-1, & + 1, 1,-1,-1, 0,-2, 0,-2, 1,-1, 1, 1, -1, 1, 1, 1, & + 1, 1, 1, 1, -1,-1, 1, 1, 0, 0,-2, 0, -1, 1,-1,-1, & +!---------------- 55 + 0, 2, 0, 2, -1,-1, 1, 1, 0, 0, 2, 0, -1, 1,-1,-1, & + 1, 1,-1, 1, -1, 1,-1,-1, 0, 0, 2, 0, -1,-1, 1, 1, & + 1,-1, 1,-1, -1,-1, 1, 1, 0, 2, 0, 2, -1, 1,-1,-1, & + 1, 1, 1, 1, 0, 2,-2, 0, 1,-1,-1,-1, -1,-1, 1,-1, & +!---------------- 56 + 0, 0, 2, 2, -1,-1, 1,-1, 1,-1, 1,-1, 0, 2, 0, 0, & + 1, 1,-1, 1, 1,-1,-1,-1, -1,-1, 1, 1, 0, 0, 2, 0, & + 2, 0, 0, 0, 0, 2, 0, 2, -1,-1, 1, 1, -1,-1,-1,-1, & + 2, 0, 0, 0, 0,-2, 2, 0, -1, 1, 1, 1, -1, 1,-1,-1, & +!---------------- 57 + 0, 2,-2, 0, -1,-1,-1,-1, 1,-1,-1,-1, 0, 0, 0, 2, & + 2, 0, 0, 0, 0, 0,-2,-2, -1, 1,-1, 1, -1,-1, 1, 1, & + 2, 0, 0, 0, 0, 2, 0, 2, -1, 1,-1,-1, -1,-1, 1,-1, & + 1, 1, 1, 1, 1,-1, 1,-1, -1, 1,-1,-1, 0, 0,-2, 0, & +!---------------- 58 + 0, 2,-2, 0, 1, 1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, & + 1, 1,-1, 1, 0, 0, 2, 2, -2, 0, 0, 0, 0, 0, 0,-2, & + 0, 2, 0, 0, -2, 0, 0, 0, 0,-2, 0,-2, 1,-1, 1, 1, & + 1,-1,-1,-1, 0, 2,-2, 0, -2, 0, 0, 0, 0, 0, 2, 0, & +!---------------- 59 + 0, 2,-2, 0, 0, 0, 0,-2, -1,-1,-1,-1, -1, 1, 1, 1, & + 1,-1, 1, 1, -1,-1, 1,-1, 0, 0,-2,-2, -1, 1,-1, 1, & + 2, 0, 0, 0, 0,-2, 0, 0, -1, 1,-1, 1, -1, 1, 1, 1, & + 1,-1, 1,-1, 1, 1, 1, 1, 0, 2,-2, 0, -2, 0, 0, 0/ +data umats/& ! Divide all these elements by 2 for simplicity: + 0, 0, 0, 2, 0, 0,-2, 0, 0,-2, 0, 0, 2, 0, 0, 0, & + 0, 0, 2, 0, 0, 0, 0,-2, 2, 0, 0, 0, 0,-2, 0, 0, & + 0, 2, 0, 0, 2, 0, 0, 0, 0, 0, 0,-2, 0, 0,-2, 0, & + 0, 0, 0, 2, 0, 0, 2, 0, 0, 2, 0, 0, 2, 0, 0, 0, & + 0, 0, 2, 0, 0, 0, 0, 2, 2, 0, 0, 0, 0, 2, 0, 0, & + 0, 2, 0, 0, 2, 0, 0, 0, 0, 0, 0, 2, 0, 0, 2, 0/ + +data nei/ & +!===== 0--3: +18,12,25,43,32,56,36,37,38,42, & +34,28,41,27,14,48,13,21,17,19, & +18,12,23,43,30,49,29,37,33,35, & +34,28,39,27,16,57,20,21,22,26, & +!---- 4--7: +20,54,52,22,40,24,32,25,42,31, & +36,46,50,38,15,40,14,41,19,24, & +13,48,45,17,31,15,30,23,35,40, & +29,55,50,33,24,31,16,39,26,15, & +!---- 8--9 +26,57,48,19,43,20,33,38,13,28, & +42,56,53,35,27,36,22,17,29,12, & +!---- 10: +39,14,23,37,21,30,16,32,25,41, & +!---- 11: +34,34,18,18,18,34,34,18,34,18, & +!==== 12--27: +27, 0, 2, 9,14,13,15,16,24,20, & ! 12 +19, 8, 1, 6,15,12,14,17,25,21, & +16, 5,10, 1,12,15,13,18,26,22, & +39, 5, 7, 6,13,14,12,19,27,23, & +!-- +14,10, 7, 3,18,17,19,12,20,24, & ! 16 +55, 6, 9, 1,19,16,18,13,21,25, & +34, 0, 2,11,16,19,17,14,22,26, & +13, 1, 5, 8,17,18,16,15,23,27, & +!-- +26, 3, 8, 4,22,21,23,24,16,12, & ! 20 +37, 1, 3,10,23,20,22,25,17,13, & +46, 9, 4, 3,20,23,21,26,18,14, & +40,10, 6, 2,21,22,20,27,19,15, & +!-- +41, 5, 7, 4,26,25,27,20,12,16, & ! 24 +31, 4,10, 0,27,24,26,21,13,17, & +20, 7, 3, 8,24,27,25,22,14,18, & +12, 1, 3, 9,25,26,24,23,15,19, & +!----- 28--43: +43, 1, 3, 8,30,29,31,32,40,36, & !28 +35, 9, 2, 7,31,28,30,33,41,37, & +32, 6,10, 2,28,31,29,34,42,38, & +25, 6, 4, 7,29,30,28,35,43,39, & +!-- +30,10, 4, 0,34,33,35,28,36,40, & ! 32 +54, 7, 8, 2,35,32,34,29,37,41, & +18, 1, 3,11,32,35,33,30,38,42, & +29, 2, 6, 9,33,34,32,31,39,43, & +!-- +42, 0, 9, 5,38,37,39,40,32,28, & ! 36 +21, 2, 0,10,39,36,38,41,33,29, & +50, 8, 5, 0,36,39,37,42,34,30, & +15,10, 7, 3,37,38,36,43,35,31, & +!-- +23, 6, 4, 5,42,41,43,36,28,32, & ! 40 +24, 5,10, 1,43,40,42,37,29,33, & +36, 4, 0, 9,40,43,41,38,30,34, & +28, 2, 0, 8,41,42,40,39,31,35, & +!------ 44--59: +53, 9, 4, 6,45,46,47,56,48,52, & ! 44 +17, 6, 0, 4,44,47,46,57,49,53, & +22, 1, 9, 5,47,44,45,58,50,54, & +38, 6, 8, 2,46,45,44,59,51,55, & +!-- +17, 8, 6, 1,49,50,51,52,44,56, & ! 48 +33, 2, 7, 9,48,51,50,53,45,57, & +38, 7, 3, 5,51,48,49,54,46,58, & +58, 7, 5, 8,50,49,48,55,47,59, & +!-- +22, 4, 2, 6,53,54,55,48,56,44, & ! 52 +44, 9, 6, 4,52,55,54,49,57,45, & +33, 4, 8, 0,55,52,53,50,58,46, & +17, 3, 9, 7,54,53,52,51,59,47, & +!-- +38, 0, 5, 9,57,58,59,44,52,48, & ! 56 +22, 8, 4, 3,56,59,58,45,53,49, & +51, 5, 7, 8,59,56,57,46,54,50, & +33, 5, 1, 7,58,57,56,47,55,51/ +data dcol10/ & +!==== 0--3: + 4, 3,13, 4,14, 0, 0, 3, 2, 5, & + 8, 6,11, 8,13, 0, 0, 6, 4,10, & ! previous row *2 + 1,12, 7, 1,11, 0, 0,12, 8, 5, & ! + 2, 9,14, 2, 7, 0, 0, 9, 1,10, & ! +!---- 4--7: +13, 2, 1, 7, 1,14, 0, 0, 2, 6, & ! previous row *2, except cols 1 and 2 +11, 4, 2,14, 2,13, 0, 0, 4,12, & + 7, 3, 4,13, 4,11, 0, 0, 8, 9, & +14, 1, 3,11, 8, 7, 0, 0, 1, 3, & +!---- 8--9: + 2, 1, 4, 8, 5, 1, 9, 6, 4, 0, & + 4, 2, 3, 1,10, 2, 3,12, 8, 0, & +!---- 10: +11,14,13,10, 5,13,11, 7, 7,14, & +!---- 11: + 2, 8,13,10, 7,11,14, 1, 5, 4/ +data dcol12/ & +!===== 12--27: +10,12, 3, 0, & ! 12 + 4,11, 0, 8, & ! 13 +12, 0, 1, 2, & ! 14 +12,13,12, 4, & ! 15 +!-- + 3, 4, 0, 8, & ! 16 + 1, 2, 3,11, & ! 17 +10,11,14, 2, & ! 18 +11, 5,11, 7, & ! 19 +!-- + 1, 0,14, 2, & ! 20 + 5, 9, 6,10, & ! 21 + 4,12, 8,14, & ! 22 + 9, 2, 0, 8, & ! 23 +!-- + 3, 3, 7, 1, & ! 24 + 6, 0, 8, 2, & ! 25 +14,14, 5,13, & ! 26 + 5, 7,13, 5, & ! 27 +!------ 28--43: + 5, 9, 6, 0, & ! 28 + 8, 7, 0, 1, & ! 29 + 9, 0, 2, 4, & ! 30 + 9,11, 9, 8, & ! 31 +!-- + 6, 8, 0, 1, & ! 32 + 2, 4, 6, 7, & ! 33 + 5, 7,13, 1, & ! 34 + 7,10, 7,14, & ! 35 +!-- + 2, 0,13, 4, & ! 36 +10, 3,12, 5, & ! 37 + 3, 9, 1,13, & ! 38 + 3, 4, 0, 1, & ! 39 +!-- + 6, 6,14, 2, & ! 40 +12, 0, 1, 4, & ! 41 +13,13,10,11, & ! 42 +10,14,11,10, & ! 43 +!------- 44--59: + 1, 3, 4, 2, & ! 44 + 9,11, 5, 9, & ! 45 +11, 5, 8,11, & ! 46 + 7, 7, 1,10, & ! 47 +!-- + 4,11,12, 0, & ! 48 + 8, 0, 9, 7, & ! 49 +12,12,10,13, & ! 50 + 2, 4, 8, 6, & ! 51 +!-- + 6,14, 5, 6, & ! 52 + 4,12, 1, 8, & ! 53 +13,13, 4,10, & ! 54 +14, 5, 2,14, & ! 55 +!-- + 2, 0, 6,13, & ! 56 + 1,14, 3, 0, & ! 57 + 3, 1, 2, 9, & ! 58 + 3, 3,10, 7/ ! 59 +data nei0a/45,54, 46,59, 52,47, 55,50/ ! k=0--3 +data nei0b/57,53, 44,45, 58,56, 59,51,& ! k=4--5 + 44,47, 53,52, 51,49, 58,59,& ! k=6--7 + 54,58, 47,51, 44,46, 55,49/ ! k=8--9 +data nei17/48,45/ +data nei22/57,52/ +data nei33/59,49/ +data nei38/56,47/ +data jcora/6,3, 2,5, 6,3, 2,5/ ! k=0--3 +data jcorb/6,3,6,3, 2,5,2,5, 4,1,6,3, 2,5,6,3, 6,3,6,3, 2,5,6,3/ +data tcors/2,0,0,0, 0,2,0,0, 0,0,2,0, 0,0,0,2, & ! twice the identity + 1,1,-1,-1, 1,-1,-1,1, -1,1,-1,1, 1,1,1,1, & ! A_1 + 1,-1,-1,-1, -1,-1,-1,1, 1,-1,1,1, -1,-1,1,-1, & ! A_2 + 1,-1,1,-1, -1,-1,-1,-1, -1,-1,1,1, -1,1,1,-1, & ! B_1 + 1,-1,1,1, 1,1,-1,1, 1,-1,-1,-1, 1,1,1,-1, & ! B_2 + 1,1,1,1, -1,1,-1,1, 1,-1,-1,1, 1,1,-1,-1, & ! C_1 + 1,1,-1,1, 1,-1,1,1, -1,-1,-1,1, -1,1,1,1, & + 2,0,2,0, 2,2,0,2, 0,0,0,2, -2,-2,-2,-2, & ! to 11, jcol=1 + 2,0,2,2, 2,0,0,0, -2,-2,-2,-2, -2,0,0,-2, & ! to 11 jcol=2 + 0,2,0,0, -2,0,-2,0, 2,0,0,2, 0,-2,0,-2, & ! to 11 jcol=3 + 2,2,0,2, -2,0,-2,-2, 0,-2,0,-2, 0,0,2,0, & ! to 11 jcol=4 + 1,1,1,-1, -1,1,1,1, -1,-1,1,-1, 1,-1,1,1, & ! >11 to>43,jcol=1 + 1,-1,-1,1, 1,1,-1,-1, 1,1,1,1, -1,1,-1,1/ ! >11 to>43,jcol=2 +data kcor10a5/0,2,1, 0,1,2, 0,2,1, 0,1,2/ +data kcor10b1/0,1,2, 0,2,1, 1,2,0, 0,2,1, 1,0,2, 1,2,0/ +data kcor10b2/0,2,1, 0,1,2, 0,2,1, 1,2,0, 0,1,2, 2,1,0/ + +data kcor12b0/0,1,2,2, 1,2,0,0, 2,0,1,2, 1,1,0,0, & + 0,1,2,2, 1,2,0,0, 2,0,1,2, 1,1,0,0, & + 0,1,2,2, 0,1,0,1, 1,0,2,2, 1,0,0,0/ +data kcor17c0/0,1,2/ +data kcor22c0/2,1,0/ +data kcor33c0/0,2,1/ +data kcor38c0/0,1,2/ +data kcor44c0/1,0,2/ +data kcor51c0/2,1,0/ +data kcor53c0/1,0,2/ +data kcor58c0/1,0,2/ +data twt10a5/ & + 0,-1,-1, 0,-1, 2, 0, 0, 1,-1, & ! + 0,-1, 0,-1,-1, 2,-1, 1, 0, 0, & ! + 1, 0,-1,-1, 0, 2,-1, 0, 0,-1/ ! +data twt10b1/ & + 0, 2, 0,-1,-1,-1, 1,-1, 0, 0, & ! + 1, 2, 0,-1, 0, 0, 0,-1,-1,-1, & ! + 0, 2, 1, 0,-1,-1, 0, 0,-1,-1/ +data twt10b2/ & +-1, 0, 2, 1, 0,-1,-1, 0, 0,-1, & ! +-1, 0, 2, 0,-1, 0,-1, 1,-1, 0, & ! + 0, 1, 2, 0,-1,-1, 0, 0,-1,-1/ ! +data twt12c0/ & + 2, 0, 1, 0,-1, 0,-1,-1, 0,-1, & ! 0 + 2, 0, 0, 1, 0,-1,-1, 0,-1,-1, & ! 0 + 2, 1, 0, 0,-1,-1, 0,-1,-1, 0/ ! 0 +data qwt10a/ & +! -------------------------------------------- 0 + 2, 0,-1, 0, 1, 0,-1,-1,-1, 0, & ! 0 + 0, 2, 1, 0,-1,-1, 0, 0,-1,-1, & ! 1 +-1, 0, 2, 1, 0,-1,-1, 0, 0,-1, & ! 2 + 0,-1, 0, 2, 1,-1,-1,-1, 0, 0, & ! 3 + 0,-1,-1, 0, 2,-1, 0, 0,-1, 1, & ! 4 + 0,-1,-1, 0,-1, 2, 0, 0, 1,-1, & ! 5 +-1, 0,-1, 0,-1, 0, 2,-1, 1, 0, & ! 6 +-1, 0, 1, 0,-1, 0,-1, 2,-1, 0, & ! 7 + 0,-1,-1, 0,-1, 1, 0, 0, 2,-1, & ! 8 +-1,-1, 0,-1, 0, 0, 0, 1,-1, 2/ ! 9 +data qwt10b/ & +! -------------------------------------------- 4 + 2, 0,-1,-1, 0, 1,-1, 0, 0,-1, & ! 0 + 0, 2, 0,-1,-1,-1, 1,-1, 0, 0, & ! 1 +-1, 0, 2, 1, 0,-1,-1, 0, 0,-1, & ! 2 +-1, 0, 1, 2, 0,-1,-1, 0, 0,-1, & ! 3 + 0,-1, 0, 1, 2,-1,-1,-1, 0, 0, & ! 4 + 0,-1,-1, 0,-1, 2, 0, 0, 1,-1, & ! 5 +-1, 0,-1,-1, 0,-1, 2, 0, 0, 1, & ! 6 +-1,-1, 0,-1, 0, 0, 0, 2,-1, 1, & ! 7 +-1, 0,-1, 0,-1, 0, 1,-1, 2, 0, & ! 8 +-1,-1, 0,-1, 0, 0, 0, 1,-1, 2/ ! 9 +data qwt10c/ & +! -------------------------------------------- 8 + 2, 0,-1,-1, 0, 1,-1, 0, 0,-1, & ! 0 + 1, 2, 0,-1, 0, 0, 0,-1,-1,-1, & ! 1 +-1, 0, 2, 1, 0,-1,-1, 0, 0,-1, & ! 2 +-1,-1, 0, 2, 0, 0, 0,-1, 1,-1, & ! 3 + 0,-1,-1, 0, 2,-1, 0, 0,-1, 1, & ! 4 + 1, 0,-1,-1, 0, 2,-1, 0, 0,-1, & ! 5 + 0, 1, 0,-1,-1,-1, 2,-1, 0, 0, & ! 6 +-1, 0, 1, 0,-1, 0,-1, 2,-1, 0, & ! 7 +-1,-1, 0, 1, 0, 0, 0,-1, 2,-1, & ! 8 + 0,-1,-1, 0, 1,-1, 0, 0,-1, 2/ ! 9 +data qwt10d/ & +! -------------------------------------------- 10 + 2, 1, 0,-1, 0, 0, 0,-1,-1,-1, & ! 0 + 0, 2, 0,-1,-1,-1, 1,-1, 0, 0, & ! 1 +-1, 0, 2, 0,-1, 0,-1, 1,-1, 0, & ! 2 + 0,-1, 0, 2, 1,-1,-1,-1, 0, 0, & ! 3 + 0,-1, 0, 1, 2,-1,-1,-1, 0, 0, & ! 4 + 0,-1, 0,-1,-1, 2,-1, 1, 0, 0, & ! 5 + 0, 1, 0,-1,-1,-1, 2,-1, 0, 0, & ! 6 + 0,-1, 0,-1,-1, 1,-1, 2, 0, 0, & ! 7 + 0,-1,-1, 0,-1, 1, 0, 0, 2,-1, & ! 8 +-1, 0,-1,-1, 0,-1, 1, 0, 0, 2/ ! 9 +data qwt10e/ & +! -------------------------------------------- 11 + 2, 0,-1, 0, 1, 0,-1,-1,-1, 0, & ! 0 + 0, 2, 1, 0,-1,-1, 0, 0,-1,-1, & ! 1 + 0, 1, 2, 0,-1,-1, 0, 0,-1,-1, & ! 2 +-1,-1, 0, 2, 0, 0, 0,-1, 1,-1, & ! 3 + 1, 0,-1, 0, 2, 0,-1,-1,-1, 0, & ! 4 + 0,-1, 0,-1,-1, 2,-1, 1, 0, 0, & ! 5 +-1, 0,-1,-1, 0,-1, 2, 0, 0, 1, & ! 6 + 0,-1, 0,-1,-1, 1,-1, 2, 0, 0, & ! 7 +-1,-1, 0, 1, 0, 0, 0,-1, 2,-1, & ! 8 +-1, 0,-1,-1, 0,-1, 1, 0, 0, 2/ ! 9 +data qwt12a/ & +! -------------------------------------------- 12 + 2, 0, 0, 1, 0,-1,-1, 0,-1,-1, & ! 0 + 1, 2, 0, 0,-1,-1, 0,-1,-1, 0, & ! 1 + 1, 0, 2, 0,-1, 0,-1,-1, 0,-1, & ! 2 + 1, 0, 0, 2, 0,-1,-1, 0,-1,-1, & ! 3 +-1,-1,-1,-1, 2, 1, 1, 0, 0, 0, & ! 4 +-1,-1,-1,-1, 1, 2, 1, 0, 0, 0, & ! 5 +-1,-1,-1,-1, 1, 1, 2, 0, 0, 0, & ! 6 +-1,-1,-1,-1, 0, 0, 0, 2, 1, 1, & ! 7 +-1,-1,-1,-1, 0, 0, 0, 1, 2, 1, & ! 8 +-1,-1,-1,-1, 0, 0, 0, 1, 1, 2/ ! 9 +data qwt12b/ & +! -------------------------------------------- 44 + 2, 0, 0, 1, 0,-1,-1, 0,-1,-1, & ! 0 + 1, 2, 0, 0,-1,-1, 0,-1,-1, 0, & ! 1 + 1, 0, 2, 0,-1, 0,-1,-1, 0,-1, & ! 2 + 1, 0, 0, 2, 0,-1,-1, 0,-1,-1, & ! 3 +-1,-1,-1,-1, 2, 1, 1, 0, 0, 0, & ! 4 +-1,-1,-1,-1, 1, 2, 1, 0, 0, 0, & ! 5 +-1,-1,-1,-1, 1, 1, 2, 0, 0, 0, & ! 6 +-1,-1,-1,-1, 0, 0, 0, 2, 1, 1, & ! 7 +-1,-1,-1,-1, 0, 0, 0, 1, 2, 1, & ! 8 +-1,-1,-1,-1, 0, 0, 0, 1, 1, 2/! 9 +data qwt12b0/ & + 2, 0, 0, 1, 0,-1,-1, 0,-1,-1, & ! 0 + 2, 1, 0, 0,-1,-1, 0,-1,-1, 0, & ! 12 + 2, 0, 1, 0,-1, 0,-1,-1, 0,-1/! 0 +data tperms/ & +0,1,2,3,4,5,6,7,8,9, & +9,8,1,7,3,0,2,5,6,4, & ! 1 +6,4,5,1,9,7,8,0,2,3, & ! 2 +7,3,8,9,1,2,0,5,6,4, & ! 3 +4,6,3,5,9,7,8,2,0,1, & ! 4 +8,9,7,2,0,3,1,5,6,4, & ! 5 +5,2,6,4,9,7,8,3,1,0, & ! 6 +8,5,7,2,3,6,0,9,1,4, & ! 7 +1,6,9,7,2,0,8,4,5,3, & ! 8 +5,0,4,9,7,8,1,3,6,2, & ! 9 +6,8,3,4,9,1,5,2,0,7, & ! 10 +0,5,4,6,9,7,8,1,3,2, & ! 11 +0,7,9,8,2,1,3,5,6,4/ ! 12 +data perm10/ & +! -------------------------------- 0 +1,9,8,2,0,6,7,4,5,3, & ! 0 +9,1,0,3,7,8,6,2,4,5, & ! 1 +6,4,3,0,1,8,5,7,2,9, & ! 2 +1,9,8,2,0,6,4,7,5,3, & ! 3 +4,5,9,7,3,6,2,1,8,0, & ! 4 +9,7,5,2,8,1,3,6,0,4, & ! 5 +5,6,4,3,7,2,1,8,0,9, & ! 6 +9,1,0,3,4,8,6,2,7,5, & ! 7 +1,9,5,4,6,0,7,2,3,8, & ! 8 +9,4,3,7,8,1,5,0,6,2, & ! 9 +! -------------------------------- 1 +1,9,8,2,0,6,7,4,5,3, & ! 0 +9,1,0,3,7,8,6,2,4,5, & ! 1 +6,4,3,0,1,8,5,7,2,9, & ! 2 +2,5,6,1,0,8,7,4,9,3, & ! 3 +7,9,5,4,3,8,1,2,6,0, & ! 4 +4,6,8,2,5,3,1,7,0,9, & ! 5 +9,8,7,3,4,1,2,6,0,5, & ! 6 +5,2,0,3,7,6,8,1,4,9, & ! 7 +2,5,9,7,8,0,4,1,3,6, & ! 8 +5,7,3,4,6,2,9,0,8,1, & ! 9 +! -------------------------------- 2 +2,5,6,1,0,8,4,7,9,3, & ! 0 +5,2,0,3,4,6,8,1,7,9, & ! 1 +8,7,3,0,2,6,9,4,1,5, & ! 2 +2,5,6,1,0,8,7,4,9,3, & ! 3 +7,9,5,4,3,8,1,2,6,0, & ! 4 +9,7,5,2,8,1,3,6,0,4, & ! 5 +9,8,7,3,4,1,2,6,0,5, & ! 6 +5,2,0,3,7,6,8,1,4,9, & ! 7 +2,5,9,7,8,0,4,1,3,6, & ! 8 +5,7,3,4,6,2,9,0,8,1, & ! 9 +! -------------------------------- 3 +2,5,6,1,0,8,4,7,9,3, & ! 0 +5,2,0,3,4,6,8,1,7,9, & ! 1 +8,7,3,0,2,6,9,4,1,5, & ! 2 +1,9,8,2,0,6,4,7,5,3, & ! 3 +4,5,9,7,3,6,2,1,8,0, & ! 4 +4,6,8,2,5,3,1,7,0,9, & ! 5 +5,6,4,3,7,2,1,8,0,9, & ! 6 +9,1,0,3,4,8,6,2,7,5, & ! 7 +1,9,5,4,6,0,7,2,3,8, & ! 8 +9,4,3,7,8,1,5,0,6,2, & ! 9 +! -------------------------------- 4 +3,4,6,8,7,0,5,1,2,9, & ! 0 +9,1,6,4,8,7,0,5,3,2, & ! 1 +7,9,1,0,3,5,8,6,2,4, & ! 2 +6,1,0,2,5,7,9,3,8,4, & ! 3 +5,6,1,0,2,4,7,9,3,8, & ! 4 +4,6,8,2,5,3,1,7,0,9, & ! 5 +4,5,6,7,3,9,2,1,8,0, & ! 6 +4,8,9,7,3,6,2,1,5,0, & ! 7 +5,2,8,9,7,6,0,4,1,3, & ! 8 +7,6,1,9,8,3,5,0,4,2, & ! 9 +! -------------------------------- 5 +3,4,6,8,7,0,5,1,2,9, & ! 0 +4,3,7,9,5,6,0,8,1,2, & ! 1 +6,4,3,0,1,8,5,7,2,9, & ! 2 +6,1,0,2,5,7,9,3,8,4, & ! 3 +9,8,2,0,1,7,4,5,3,6, & ! 4 +4,6,8,2,5,3,1,7,0,9, & ! 5 +7,9,8,4,3,5,1,2,6,0, & ! 6 +4,8,9,7,3,6,2,1,5,0, & ! 7 +9,1,6,5,4,8,0,7,2,3, & ! 8 +4,8,2,5,6,3,9,0,7,1, & ! 9 +! -------------------------------- 6 +3,7,8,6,4,0,9,2,1,5, & ! 0 +0,2,8,9,1,3,5,7,4,6, & ! 1 +7,9,1,0,3,5,8,6,2,4, & ! 2 +8,2,0,1,9,4,5,3,6,7, & ! 3 +9,8,2,0,1,7,4,5,3,6, & ! 4 +7,8,6,1,9,3,2,4,0,5, & ! 5 +7,9,8,4,3,5,1,2,6,0, & ! 6 +7,6,5,4,3,8,1,2,9,0, & ! 7 +9,1,6,5,4,8,0,7,2,3, & ! 8 +4,8,2,5,6,3,9,0,7,1, & ! 9 +! -------------------------------- 7 +3,7,8,6,4,0,9,2,1,5, & ! 0 +4,3,7,9,5,6,0,8,1,2, & ! 1 +8,9,1,6,4,2,7,0,5,3, & ! 2 +8,2,0,1,9,4,5,3,6,7, & ! 3 +5,6,1,0,2,4,7,9,3,8, & ! 4 +7,8,6,1,9,3,2,4,0,5, & ! 5 +4,5,6,7,3,9,2,1,8,0, & ! 6 +7,6,5,4,3,8,1,2,9,0, & ! 7 +5,2,8,9,7,6,0,4,1,3, & ! 8 +7,6,1,9,8,3,5,0,4,2, & ! 9 +! -------------------------------- 8 +3,7,8,6,4,0,9,2,1,5, & ! 0 +0,1,6,5,2,3,9,4,7,8, & ! 1 +5,6,1,0,2,7,4,9,3,8, & ! 2 +8,6,4,3,7,2,1,5,0,9, & ! 3 +4,6,8,7,3,5,1,2,9,0, & ! 4 +0,1,6,7,3,2,9,5,8,4, & ! 5 +3,0,1,9,4,7,2,6,8,5, & ! 6 +5,2,0,3,7,6,8,1,4,9, & ! 7 +4,8,2,0,3,6,9,5,1,7, & ! 8 +1,6,8,2,0,9,4,7,5,3, & ! 9 +! -------------------------------- 9 +3,7,8,6,4,0,9,2,1,5, & ! 0 +0,3,7,8,2,1,4,9,6,5, & ! 1 +2,0,1,6,5,8,3,9,4,7, & ! 2 +8,6,4,3,7,2,1,5,0,9, & ! 3 +7,8,6,4,3,9,2,1,5,0, & ! 4 +0,1,6,7,3,2,9,5,8,4, & ! 5 +3,0,2,5,7,4,1,8,6,9, & ! 6 +9,1,0,3,4,8,6,2,7,5, & ! 7 +4,8,2,0,3,6,9,5,1,7, & ! 8 +2,8,6,1,0,5,7,4,9,3, & ! 9 +! -------------------------------- 10 +1,0,3,7,9,6,2,4,5,8, & ! 0 +5,2,8,7,6,4,0,9,3,1, & ! 1 +5,6,1,9,7,2,4,0,8,3, & ! 2 +2,5,4,3,0,8,9,6,7,1, & ! 3 +7,8,2,0,3,9,6,5,1,4, & ! 4 +8,9,1,6,7,2,4,0,5,3, & ! 5 +2,0,3,4,8,5,1,7,6,9, & ! 6 +3,7,9,8,4,0,5,1,2,6, & ! 7 +3,7,6,5,4,0,8,1,2,9, & ! 8 +6,1,9,4,5,7,0,8,3,2, & ! 9 +! -------------------------------- 11 +3,4,5,2,0,7,6,9,8,1, & ! 0 +7,3,0,1,9,8,4,2,6,5, & ! 1 +2,0,3,7,8,5,1,4,9,6, & ! 2 +9,5,4,3,7,1,2,6,0,8, & ! 3 +0,1,6,4,3,2,9,8,5,7, & ! 4 +4,6,1,9,5,3,8,0,7,2, & ! 5 +8,7,9,5,2,6,3,1,4,0, & ! 6 +1,9,7,8,6,0,5,3,2,4, & ! 7 +6,8,2,0,1,4,7,5,3,9, & ! 8 +5,2,8,6,4,9,0,7,1,3/ ! 9 +data perm12/ & +! -------------------------------- 12 +0,4,7,3,1,9,6,2,8,5, & ! 0 +2,1,7,3,8,9,6,4,5,0, & ! 1 +2,7,1,3,4,0,5,8,6,9, & ! 2 +4,3,0,9,7,5,2,6,1,8, & ! 3 +! -------------------------------- 13 +0,3,4,7,8,5,2,9,6,1, & ! 0 +3,8,2,4,0,7,5,9,1,6, & ! 1 +8,5,6,3,4,9,7,2,1,0, & ! 2 +5,8,7,0,4,9,3,1,2,6, & ! 3 +! -------------------------------- 14 +0,9,1,6,5,2,8,4,3,7, & ! 0 +9,6,7,4,3,5,8,0,2,1, & ! 1 +6,9,1,8,5,0,4,3,2,7, & ! 2 +9,6,7,4,3,2,8,0,5,1, & ! 3 +! -------------------------------- 15 +0,5,2,8,9,1,6,7,3,4, & ! 0 +3,4,2,8,6,7,9,5,1,0, & ! 1 +7,2,9,5,8,6,1,0,4,3, & ! 2 +8,3,6,5,7,9,2,0,1,4, & ! 3 +! -------------------------------- 16 +0,2,5,8,7,4,3,9,6,1, & ! 0 +1,6,0,2,3,5,8,7,4,9, & ! 1 +9,7,6,4,0,1,2,3,8,5, & ! 2 +9,7,6,4,0,1,5,3,8,2, & ! 3 +! -------------------------------- 17 +0,5,2,8,7,3,4,9,1,6, & ! 0 +2,3,1,7,5,6,8,9,0,4, & ! 1 +2,1,7,3,4,9,6,8,5,0, & ! 2 +5,7,0,8,6,1,9,3,4,2, & ! 3 +! -------------------------------- 18 +0,4,7,3,2,8,5,1,9,6, & ! 0 +4,0,3,9,7,8,5,6,2,1, & ! 1 +4,3,0,9,6,1,2,7,5,8, & ! 2 +1,6,0,2,7,5,9,3,4,8, & ! 3 +! -------------------------------- 19 +0,9,6,1,2,5,8,3,4,7, & ! 0 +7,9,5,2,3,0,4,1,8,6, & ! 1 +6,1,8,9,4,3,2,7,5,0, & ! 2 +8,6,5,3,2,7,1,4,0,9, & ! 3 +! -------------------------------- 20 +0,7,3,4,5,2,8,6,1,9, & ! 0 +8,6,5,3,2,0,1,4,7,9, & ! 1 +0,1,5,4,9,7,2,3,8,6, & ! 2 +5,7,8,0,1,6,2,4,3,9, & ! 3 +! -------------------------------- 21 +0,7,4,3,1,6,9,2,5,8, & ! 0 +2,7,1,3,8,0,5,4,6,9, & ! 1 +2,1,7,3,4,9,6,8,5,0, & ! 2 +3,8,2,4,9,7,6,0,1,5, & ! 3 +! -------------------------------- 22 +0,2,5,8,9,6,1,7,4,3, & ! 0 +1,6,2,0,5,3,8,4,7,9, & ! 1 +2,1,3,7,9,4,0,5,8,6, & ! 2 +5,0,7,8,3,2,4,6,9,1, & ! 3 +! -------------------------------- 23 +0,9,1,6,5,2,8,4,3,7, & ! 0 +7,2,5,9,6,0,1,4,8,3, & ! 1 +9,6,7,4,3,2,1,0,5,8, & ! 2 +3,8,4,2,7,9,5,1,0,6, & ! 3 +! -------------------------------- 24 +0,1,9,6,4,7,3,5,8,2, & ! 0 +7,9,2,5,0,3,4,8,1,6, & ! 1 +3,2,4,8,5,0,1,6,9,7, & ! 2 +8,6,3,5,0,4,1,7,2,9, & ! 3 +! -------------------------------- 25 +0,2,5,8,7,4,3,9,6,1, & ! 0 +9,7,6,4,0,8,5,3,1,2, & ! 1 +5,7,8,0,4,3,2,1,6,9, & ! 2 +3,4,8,2,1,6,0,7,5,9, & ! 3 +! -------------------------------- 26 +0,8,5,2,3,4,7,1,6,9, & ! 0 +6,8,1,9,7,0,5,4,2,3, & ! 1 +7,5,9,2,1,6,8,3,4,0, & ! 2 +5,8,7,0,4,9,3,1,2,6, & ! 3 +! -------------------------------- 27 +0,4,7,3,1,9,6,2,8,5, & ! 0 +4,3,0,9,7,1,2,6,5,8, & ! 1 +4,0,3,9,6,8,5,7,2,1, & ! 2 +9,7,6,4,3,8,2,0,1,5, & ! 3 +! -------------------------------- 28 +0,4,7,3,1,9,6,2,8,5, & ! 0 +2,1,7,3,8,9,6,4,5,0, & ! 1 +2,7,1,3,4,0,5,8,6,9, & ! 2 +4,0,3,9,6,8,1,7,2,5, & ! 3 +! -------------------------------- 29 +0,3,4,7,8,5,2,9,6,1, & ! 0 +3,8,2,4,0,7,5,9,1,6, & ! 1 +8,5,6,3,4,9,7,2,1,0, & ! 2 +5,8,7,0,4,9,3,1,2,6, & ! 3 +! -------------------------------- 30 +0,9,1,6,5,2,8,4,3,7, & ! 0 +9,6,7,4,3,5,8,0,2,1, & ! 1 +7,2,5,9,6,8,3,4,0,1, & ! 2 +9,6,7,4,3,2,8,0,5,1, & ! 3 +! -------------------------------- 31 +0,9,1,6,5,2,8,4,3,7, & ! 0 +3,4,2,8,6,7,9,5,1,0, & ! 1 +7,2,9,5,8,6,1,0,4,3, & ! 2 +8,3,6,5,7,9,2,0,1,4, & ! 3 +! -------------------------------- 32 +0,2,5,8,7,4,3,9,6,1, & ! 0 +5,7,8,0,4,6,9,1,3,2, & ! 1 +9,7,6,4,0,1,2,3,8,5, & ! 2 +9,7,6,4,0,1,5,3,8,2, & ! 3 +! -------------------------------- 33 +0,8,2,5,6,1,9,4,3,7, & ! 0 +2,3,1,7,5,6,8,9,0,4, & ! 1 +1,2,6,0,4,9,7,5,8,3, & ! 2 +5,7,0,8,6,1,9,3,4,2, & ! 3 +! -------------------------------- 34 +0,7,4,3,1,6,9,2,5,8, & ! 0 +4,0,3,9,7,8,5,6,2,1, & ! 1 +4,3,0,9,6,1,2,7,5,8, & ! 2 +9,7,4,6,8,3,5,1,0,2, & ! 3 +! -------------------------------- 35 +0,9,6,1,2,5,8,3,4,7, & ! 0 +7,9,5,2,3,0,4,1,8,6, & ! 1 +6,1,8,9,4,3,2,7,5,0, & ! 2 +8,6,5,3,2,7,1,4,0,9, & ! 3 +! -------------------------------- 36 +0,7,3,4,5,2,8,6,1,9, & ! 0 +8,6,5,3,2,0,1,4,7,9, & ! 1 +0,1,5,4,9,7,2,3,8,6, & ! 2 +5,7,8,0,1,6,2,4,3,9, & ! 3 +! -------------------------------- 37 +0,4,7,3,2,8,5,1,9,6, & ! 0 +2,7,1,3,8,0,5,4,6,9, & ! 1 +2,1,7,3,4,9,6,8,5,0, & ! 2 +4,9,0,3,2,1,7,8,5,6, & ! 3 +! -------------------------------- 38 +0,4,3,7,9,1,6,8,2,5, & ! 0 +2,7,1,3,8,0,5,4,6,9, & ! 1 +2,1,3,7,9,4,0,5,8,6, & ! 2 +5,0,7,8,3,2,4,6,9,1, & ! 3 +! -------------------------------- 39 +0,5,2,8,9,1,6,7,3,4, & ! 0 +1,0,6,2,7,8,5,3,9,4, & ! 1 +9,6,7,4,3,2,1,0,5,8, & ! 2 +3,8,4,2,7,9,5,1,0,6, & ! 3 +! -------------------------------- 40 +0,2,5,8,7,4,3,9,6,1, & ! 0 +7,9,2,5,0,3,4,8,1,6, & ! 1 +3,2,4,8,5,0,1,6,9,7, & ! 2 +8,6,3,5,0,4,1,7,2,9, & ! 3 +! -------------------------------- 41 +0,1,9,6,4,7,3,5,8,2, & ! 0 +9,7,6,4,0,8,5,3,1,2, & ! 1 +6,1,9,8,3,4,0,5,7,2, & ! 2 +3,4,8,2,1,6,0,7,5,9, & ! 3 +! -------------------------------- 42 +0,8,5,2,3,4,7,1,6,9, & ! 0 +6,8,1,9,7,0,5,4,2,3, & ! 1 +7,5,9,2,1,6,8,3,4,0, & ! 2 +5,8,7,0,4,9,3,1,2,6, & ! 3 +! -------------------------------- 43 +0,4,7,3,1,9,6,2,8,5, & ! 0 +4,3,0,9,7,1,2,6,5,8, & ! 1 +4,0,3,9,6,8,5,7,2,1, & ! 2 +9,6,7,4,0,5,1,3,2,8, & ! 3 +! -------------------------------- 44 +0,5,8,2,3,7,4,1,9,6, & ! 0 +2,1,3,7,5,4,0,9,8,6, & ! 1 +1,6,2,0,4,3,8,5,7,9, & ! 2 +2,3,7,1,0,5,4,6,9,8, & ! 3 +! -------------------------------- 45 +0,1,6,9,7,4,3,8,5,2, & ! 0 +3,2,8,4,9,5,7,0,6,1, & ! 1 +0,4,5,1,6,8,3,2,7,9, & ! 2 +7,9,5,2,1,0,6,3,8,4, & ! 3 +! -------------------------------- 46 +0,6,1,9,8,2,5,7,3,4, & ! 0 +7,5,2,9,6,3,8,4,1,0, & ! 1 +6,8,1,9,7,2,3,4,0,5, & ! 2 +6,8,9,1,0,4,5,2,7,3, & ! 3 +! -------------------------------- 47 +0,9,1,6,4,3,7,5,2,8, & ! 0 +6,1,9,8,3,7,2,5,4,0, & ! 1 +7,9,2,5,8,3,4,0,1,6, & ! 2 +7,9,2,5,0,1,4,8,3,6, & ! 3 +! -------------------------------- 48 +0,4,7,3,2,8,5,1,9,6, & ! 0 +3,2,4,8,6,0,1,5,9,7, & ! 1 +0,4,1,5,8,6,9,7,2,3, & ! 2 +8,6,3,5,0,4,1,7,2,9, & ! 3 +! -------------------------------- 49 +0,3,7,4,6,9,1,5,8,2, & ! 0 +8,5,3,6,9,2,7,1,4,0, & ! 1 +0,5,1,4,3,2,7,9,6,8, & ! 2 +3,8,4,2,7,9,5,1,0,6, & ! 3 +! -------------------------------- 50 +0,5,8,2,1,9,6,3,7,4, & ! 0 +7,2,5,9,4,8,3,6,0,1, & ! 1 +0,1,5,4,9,7,2,3,8,6, & ! 2 +3,4,8,2,1,6,0,7,5,9, & ! 3 +! -------------------------------- 51 +0,2,5,8,7,4,3,9,6,1, & ! 0 +2,1,7,3,8,9,6,4,5,0, & ! 1 +1,0,2,6,9,7,5,8,3,4, & ! 2 +1,6,0,2,7,5,9,3,4,8, & ! 3 +! -------------------------------- 52 +0,2,8,5,4,7,3,6,9,1, & ! 0 +3,2,8,4,9,5,7,0,6,1, & ! 1 +0,4,5,1,6,8,3,2,7,9, & ! 2 +7,9,5,2,1,0,6,3,8,4, & ! 3 +! -------------------------------- 53 +0,5,8,2,3,7,4,1,9,6, & ! 0 +1,2,0,6,8,4,3,9,5,7, & ! 1 +1,6,2,0,4,3,8,5,7,9, & ! 2 +2,3,7,1,0,5,4,6,9,8, & ! 3 +! -------------------------------- 54 +0,5,2,8,7,3,4,9,1,6, & ! 0 +6,1,9,8,3,7,2,5,4,0, & ! 1 +6,9,1,8,5,0,4,3,2,7, & ! 2 +7,9,2,5,0,1,4,8,3,6, & ! 3 +! -------------------------------- 55 +0,8,2,5,6,1,9,4,3,7, & ! 0 +7,5,2,9,6,3,8,4,1,0, & ! 1 +7,5,2,9,6,1,0,4,3,8, & ! 2 +6,8,9,1,0,4,5,2,7,3, & ! 3 +! -------------------------------- 56 +0,3,4,7,8,5,2,9,6,1, & ! 0 +8,5,3,6,9,2,7,1,4,0, & ! 1 +0,5,1,4,3,2,7,9,6,8, & ! 2 +0,5,4,1,6,9,8,2,3,7, & ! 3 +! -------------------------------- 57 +0,7,4,3,1,6,9,2,5,8, & ! 0 +0,1,4,5,7,3,2,8,9,6, & ! 1 +0,4,1,5,8,6,9,7,2,3, & ! 2 +8,6,3,5,0,4,1,7,2,9, & ! 3 +! -------------------------------- 58 +0,4,7,3,1,9,6,2,8,5, & ! 0 +2,1,7,3,8,9,6,4,5,0, & ! 1 +1,0,2,6,9,7,5,8,3,4, & ! 2 +2,7,3,1,6,8,9,0,4,5, & ! 3 +! -------------------------------- 59 +0,9,6,1,2,5,8,3,4,7, & ! 0 +7,2,5,9,4,8,3,6,0,1, & ! 1 +0,1,5,4,9,7,2,3,8,6, & ! 2 +3,4,8,2,1,6,0,7,5,9/ ! 3 +!====== +data perms/ & +3,2,1,0,4,6,5,7,8,9, & ! 4 +2,3,0,1,6,5,4,7,8,9, & ! 5 +1,0,3,2,5,4,6,7,8,9, & ! 6 +3,2,1,0,4,5,6,7,9,8, & ! 7 +2,3,0,1,4,5,6,9,8,7, & ! 8 +1,0,3,2,4,5,6,8,7,9/ ! 9 +end module jp_pbfil2 +!# diff --git a/src/mgbf/jp_pbfil3.f90 b/src/mgbf/jp_pbfil3.f90 new file mode 100644 index 0000000000..61a6932577 --- /dev/null +++ b/src/mgbf/jp_pbfil3.f90 @@ -0,0 +1,2620 @@ +module jp_pbfil3 +!$$$ module documentation block +! . . . . +! module: jp_pbfil3 +! prgmmr: purser org: NOAA/EMC date: 2021-08 +! +! abstract: Codes for the beta line filters +! +! module history log: +! +! Subroutines Included: +! t22_to_3 - +! t2_to_3 - +! t3_to_22 - +! t33_to_6 - +! t3_to_6 - +! t6_to_33 - +! t44_to_10 - +! t4_to_10 - +! t10_to_44 - +! finmomtab - +! inimomtab - +! tritform - +! tritformi - +! triad - +! gettrilu - +! querytcol - +! hextform - +! hextformi - +! hexad - +! gethexlu - +! queryhcol - +! dectform - +! dectformi - +! decad - +! getdeclu - +! querydcol - +! standardizeb - +! hstform - +! hstformi - +! blinfil - +! dibeta - +! dibetat - +! +! Functions Included: +! +! remarks: +! The routines of this module mostly involve the beta line filters. +! Versions of these routines are provided in 2D, 3D and 4D, based respectively +! on the Triad (3-lines), Hexad (6-lines), and Decad (10-lines) algorithms. +! Some technical explanations are provided in the series of office notes, +! ON498, ON499, ON500. +! +! The style of line filtering is the "Dibeta" combination of two +! nonnegatively-weighted consecutive-imteger-half-span beta filters, whose +! normalization coefficients are stored in the table, "bnorm" and whose +! second moments (spread**2) are stored in the table "bsprds"; these +! moment tables must be initialized in subr. inimomtab before any filtering +! can be done. The max-halp-span size of the table is set by the user, so +! the tables use allocatable space (in module jp_pbfil2); to deallocate this +! storage, the user must invoke fintabmom once all filtering operations +! have been completed. +! +! Aspect tensors in N dimensions are positive-definite and symmetric, and +! therefore require M=(N*(N+1))/2 independent components, which we can arrange +! into a vector of this size. The utility routines tNN_to_M do this; tM_to_NN +! do the opposite. tN_to_M put the outer-product of an N-vector into the +! corresponding M-vector. +! +! The filtering is preceded by a decomposition of the M components of the +! aspect tensor, at each grid point, into M distinct line-second-moments +! and the line-generators they each act along, at every grid point. And +! since, in the general case, the aspect tensor is no longer needed once +! the line filter specifications have been determined, it ic convenient to +! over-write the old aspect tensor components with the new line-second- +! moments ("spread**2"). In other word, we can express the needed action +! as a formal "transform" (and invert it if ever needed, to recover the +! original aspect tensor). The basic decomposition of the aspect tensor +! into its spread**2 components and line generators is done, at a single +! grid point using subroutine triad (2D), hexad (3D), decad (4D). Working +! this into "transform" for a single point, is done in tritform, hextform, +! dectform, and their respective inverse transforms in tritformi, hextfotmi, +! dectformi. In the case of the 3D hexad method, although there are 6 active +! line filters at any given point, each of those lines is associated with +! one of the 7 different "colors" (our term for the nonnull Galois field +! elements) no two of these colors in a given hexad are the same. The +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +use jp_pkind, only: spi,sp,dp; use jp_pkind2, only: fpi +use jp_pietc, only: T,F,u0,u1,u3,u4,u5,pi2 +implicit none +private +public:: t22_to_3,t2_to_3,t3_to_22,t33_to_6,t3_to_6,t6_to_33,& + t44_to_10,t4_to_10,t10_to_44, & + finmomtab,inimomtab, & + tritform,tritformi,triad,gettrilu,querytcol, & + hextform,hextformi,hexad,gethexlu,queryhcol, & + dectform,dectformi,decad,getdeclu,querydcol, & + hstform,hstformi,blinfil,dibeta,dibetat +integer(spi),dimension(2,0:2):: i2pair +integer(spi),dimension(2,6) :: i3pair +integer(spi),dimension(2,10) :: i4pair +data i2pair/1,1, 2,2, 1,2/ +data i3pair/1,1, 2,2, 3,3, 2,3, 3,1, 1,2/ +data i4pair/1,1, 2,2, 3,3, 4,4, 1,2, 1,3, 1,4, 3,4, 2,4, 2,3/ + +interface t22_to_3; module procedure i22_to_3, r22_to_3; end interface +interface t2_to_3; module procedure i2_to_3, r2_to_3; end interface +interface t3_to_22; module procedure i3_to_22, r3_to_22; end interface +interface t33_to_6; module procedure i33_to_6, r33_to_6; end interface +interface t3_to_6; module procedure i3_to_6, r3_to_6; end interface +interface t6_to_33; module procedure i6_to_33, r6_to_33; end interface +interface t44_to_10; module procedure i44_to_10,r44_to_10; end interface +interface t4_to_10; module procedure i4_to_10, r4_to_10; end interface +interface t10_to_44; module procedure i10_to_44,r10_to_44; end interface +!--- +interface finmomtab; module procedure finmomtab; end interface +interface inimomtab; module procedure inimomtab; end interface +interface tritform; module procedure tritforms,tritform; end interface +interface tritformi; module procedure tritformi; end interface +interface triad; module procedure triad; end interface +interface gettrilu; module procedure gettrilu; end interface +interface querytcol; module procedure querytcol; end interface +interface hextform; module procedure hextforms,hextform; end interface +interface hextformi; module procedure hextformi; end interface +interface hexad; module procedure hexad; end interface +interface gethexlu; module procedure gethexlu; end interface +interface queryhcol; module procedure queryhcol; end interface +interface dectform; module procedure dectforms,dectform; end interface +interface dectformi; module procedure dectformi; end interface +interface decad; module procedure decad; end interface +interface getdeclu; module procedure getdeclu; end interface +interface querydcol; module procedure querydcol; end interface +!--- +interface standardizeb;module procedure standardizeb; end interface +interface hstform; module procedure hstform; end interface +interface hstformi; module procedure hstformi; end interface +interface blinfil; module procedure blinfil; end interface +interface dibeta + module procedure dibeta1,dibeta2,dibeta3,dibeta4, dibetax3,dibetax4, & + vdibeta1,vdibeta2,vdibeta3,vdibeta4, vdibetax3,vdibetax4 +end interface +interface dibetat + module procedure dibeta1t,dibeta2t,dibeta3t,dibeta4t,dibetax3t, dibetax4t, & + vdibeta1t,vdibeta2t,vdibeta3t,vdibeta4t,vdibetax3t,vdibetax4t +end interface + +contains + +!============================================================================== +subroutine i22_to_3(i22,i3)! [t22_to_3] +!============================================================================== +use jp_pkind, only: spi +implicit none +integer(spi),dimension(2,2),intent(in ):: i22 +integer(spi),dimension(0:2),intent(out):: i3 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=0,2; i3(L)=i22(i2pair(1,L),i2pair(2,L)); enddo +end subroutine i22_to_3 +!============================================================================== +subroutine r22_to_3(r22,r3)! [t22_to_3] +!============================================================================== +use jp_pkind, only: spi,dp +implicit none +real(dp),dimension(2,2),intent(in ):: r22 +real(dp),dimension(0:2),intent(out):: r3 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=0,2; r3(L)=r22(i2pair(1,L),i2pair(2,L)); enddo +end subroutine r22_to_3 + +!============================================================================== +subroutine i2_to_3(i2,i3)! [t2_to_3] +!============================================================================== +use jp_pkind, only: spi +use jp_pmat4, only: outer_product +implicit none +integer(spi),dimension(2),intent(in ):: i2 +integer(spi),dimension(3),intent(out):: i3 +!------------------------------------------------------------------------------ +call t22_to_3(outer_product(i2,i2),i3) +end subroutine i2_to_3 +!============================================================================== +subroutine r2_to_3(r2,r3)! [t2_to_3] +!============================================================================== +use jp_pkind, only: dp +use jp_pmat4, only: outer_product +implicit none +real(dp),dimension(2),intent(in ):: r2 +real(dp),dimension(3),intent(out):: r3 +!------------------------------------------------------------------------------ +call t22_to_3(outer_product(r2,r2),r3) +end subroutine r2_to_3 + +!============================================================================== +subroutine i3_to_22(i3,i22)! [t3_to_22] +!============================================================================== +use jp_pkind, only: spi +implicit none +integer(spi),dimension(0:2),intent(in ):: i3 +integer(spi),dimension(2,2),intent(out):: i22 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=0,2 + i22(i2pair(1,L),i2pair(2,L))=i3(L) + i22(i2pair(2,L),i2pair(1,L))=i3(L) +enddo +end subroutine i3_to_22 +!============================================================================== +subroutine r3_to_22(r3,r22)! [t3_to_22] +!============================================================================== +use jp_pkind, only: spi,dp +implicit none +real(dp),dimension(0:2),intent(in ):: r3 +real(dp),dimension(2,2),intent(out):: r22 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=0,2 + r22(i2pair(1,L),i2pair(2,L))=r3(L) + r22(i2pair(2,L),i2pair(1,L))=r3(L) +enddo +end subroutine r3_to_22 + +!============================================================================== +subroutine i33_to_6(i33,i6)! [t33_to_6] +!============================================================================== +use jp_pkind, only: spi +implicit none +integer(spi),dimension(3,3),intent(in ):: i33 +integer(spi),dimension(6) ,intent(out):: i6 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=1,6; i6(L)=i33(i3pair(1,L),i3pair(2,L)); enddo +end subroutine i33_to_6 +!============================================================================== +subroutine r33_to_6(r33,r6)! [t33_to_6] +!============================================================================== +use jp_pkind, only: spi,dp +implicit none +real(dp),dimension(3,3),intent(in ):: r33 +real(dp),dimension(6) ,intent(out):: r6 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=1,6; r6(L)=r33(i3pair(1,L),i3pair(2,L)); enddo +end subroutine r33_to_6 + +!============================================================================== +subroutine i3_to_6(i3,i6)! [t3_to_6] +!============================================================================== +use jp_pkind, only: spi +use jp_pmat4, only: outer_product +implicit none +integer(spi),dimension(3),intent(in ):: i3 +integer(spi),dimension(6),intent(out):: i6 +!------------------------------------------------------------------------------ +call t33_to_6(outer_product(i3,i3),i6) +end subroutine i3_to_6 +!============================================================================== +subroutine r3_to_6(r3,r6)! [t3_to_6] +!============================================================================== +use jp_pkind, only: dp +use jp_pmat4, only: outer_product +implicit none +real(dp),dimension(3),intent(in ):: r3 +real(dp),dimension(6),intent(out):: r6 +!------------------------------------------------------------------------------ +call t33_to_6(outer_product(r3,r3),r6) +end subroutine r3_to_6 + +!============================================================================== +subroutine i6_to_33(i6,i33)! [t6_to_33] +!============================================================================== +use jp_pkind, only: spi +implicit none +integer(spi),dimension(6), intent(in ):: i6 +integer(spi),dimension(3,3),intent(out):: i33 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=1,6 + i33(i3pair(1,L),i3pair(2,L))=i6(L) + i33(i3pair(2,L),i3pair(1,L))=i6(L) +enddo +end subroutine i6_to_33 +!============================================================================== +subroutine r6_to_33(r6,r33)! [t6_to_33] +!============================================================================== +use jp_pkind, only: spi,dp +implicit none +real(dp),dimension(6), intent(in ):: r6 +real(dp),dimension(3,3),intent(out):: r33 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=1,6 + r33(i3pair(1,L),i3pair(2,L))=r6(L) + r33(i3pair(2,L),i3pair(1,L))=r6(L) +enddo +end subroutine r6_to_33 + +!============================================================================== +subroutine i44_to_10(i44,i10)! [t44_to_10] +!============================================================================== +use jp_pkind, only: spi +implicit none +integer(spi),dimension(4,4),intent(in ):: i44 +integer(spi),dimension(10) ,intent(out):: i10 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=1,10; i10(L)=i44(i4pair(1,L),i4pair(2,L)); enddo +end subroutine i44_to_10 +!============================================================================== +subroutine r44_to_10(r44,r10)! [t44_to_10] +!============================================================================== +use jp_pkind, only: spi,dp +implicit none +real(dp),dimension(4,4),intent(in ):: r44 +real(dp),dimension(10) ,intent(out):: r10 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=1,10; r10(L)=r44(i4pair(1,L),i4pair(2,L)); enddo +end subroutine r44_to_10 + +!============================================================================== +subroutine i4_to_10(i4,i10)! [t4_to_10] +!============================================================================== +use jp_pkind, only: spi +use jp_pmat4, only: outer_product +implicit none +integer(spi),dimension(4), intent(in ):: i4 +integer(spi),dimension(10),intent(out):: i10 +!------------------------------------------------------------------------------ +call t44_to_10(outer_product(i4,i4),i10) +end subroutine i4_to_10 +!============================================================================== +subroutine r4_to_10(r4,r10)! [t4_to_10] +!============================================================================== +use jp_pkind, only: dp +use jp_pmat4, only: outer_product +implicit none +real(dp),dimension(4), intent(in ):: r4 +real(dp),dimension(10),intent(out):: r10 +!------------------------------------------------------------------------------ +call t44_to_10(outer_product(r4,r4),r10) +end subroutine r4_to_10 + +!============================================================================== +subroutine i10_to_44(i10,i44)! [t10_to_44] +!============================================================================== +use jp_pkind, only: spi +implicit none +integer(spi),dimension(10), intent(in ):: i10 +integer(spi),dimension(4,4),intent(out):: i44 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=1,10 + i44(i4pair(1,L),i4pair(2,L))=i10(L) + i44(i4pair(2,L),i4pair(1,L))=i10(L) +enddo +end subroutine i10_to_44 +!============================================================================== +subroutine r10_to_44(r10,r44)! [t10_to_44] +!============================================================================== +use jp_pkind, only: spi,dp +implicit none +real(dp),dimension(10), intent(in ):: r10 +real(dp),dimension(4,4),intent(out):: r44 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=1,10 + r44(i4pair(1,L),i4pair(2,L))=r10(L) + r44(i4pair(2,L),i4pair(1,L))=r10(L) +enddo +end subroutine r10_to_44 + +!-- + +!================================================================== [finmomtab] +subroutine finmomtab +!============================================================================== +! Finalize the moments table for dibeta filter applications. +! Deallocate the space reserved for moment tables and reset p and nh to their +! zero defaults. +!============================================================================== +use jp_pbfil2, only: p,nh,bnorm,bsprds +implicit none +p=0; nh=0 +if(allocated(bnorm))deallocate(bnorm) +if(allocated(bsprds))deallocate(bsprds) +end subroutine finmomtab + +!================================================================== [inimomtab] +subroutine inimomtab(p_prescribe,nh_prescribe,ff) +!============================================================================== +! Initialize the moments table for dibeta filter applications. +! For the given beta function exponent index, p, and nh half-spans, initialize +! table of the normalizing coefficients, bnorm, and spread**2s, bsprds. +! The calculation involves computing the continuum approximations, m0 and m2, +! to the 0th and 2nd moments, and using the Euler-Maclaurin expansions +! for the correction terms hm0 and hm2 so that the final corrected moments +! cm0 and cm2 for each integer halfwidth up to nh . +!============================================================================== +use jp_pkind, only: spi,dp +use jp_pietc, only: u0,u1,u2 +use jp_pbfil2, only: p,nh,bnorm,bsprds +implicit none +integer(spi),intent(in ):: p_prescribe,nh_prescribe +logical, intent(out):: ff +!------------------------------------------------------------------------------ +integer(spi),parameter :: nk0=2,nk2=nk0+1,np=6,np2p3=np*2+3 +real(dp),dimension(-1:np2p3) :: ffac +real(dp) :: x,xx,m0,m2,hm0,hm2,cm0,cm2 +integer(spi),dimension(0:nk0,np):: n0pk +integer(spi),dimension(0:nk2,np):: n2pk +integer(spi) :: h,i,k,mk0,mk2,p2,p2m1,p2p1,p2p3 +data n0pk/ & + -1, 0, 0, & + -1, 0, 0, & + -5, 14, 0, & + -63, 240, 0, & + -1575, 6930, -2640, & + -68409, 327600, -216216/ +data n2pk/ & + 1, -5, 0, 0, & + 5, -21, 0, 0, & + 63, -285, 126, 0, & + 1575, -7623, 5280, 0, & + 68409, -348075, 306306, -34320, & + 4729725,-24969285, 25552800, -5405400/ +!============================================================================== +call finmomtab ! Table arrays bnorm and bsprds must start off deallocated +ff=(p_prescribe<1 .or. p_prescribe>np) +if(ff)then + print'(" In inimomtab; prescribed exponent p out of bounds")' + return +endif +ff=(nh_prescribe<2 .or. nh_prescribe>1000) +if(ff)then + print'(" In inimomtab; prescribed table size nh out of bounds")' + return +endif +p =p_prescribe +nh=nh_prescribe +allocate(bnorm(nh),bsprds(nh)) +! set up the ffac tables (double-factorial function) +p2=p*2; p2m1=p2-1; p2p1=p2+1; p2p3=p2+3 +ffac(-1)=u1 +ffac(0)=u1 +do i=1,np2p3 + ffac(i)=i*ffac(i-2) +enddo +mk0=(p-1)/2 +mk2=mk0+1 +do h=1,nh + x=h + xx=x*x + m0=u2*ffac(p2)*x/ffac(p2p1) + m2=u2*ffac(p2)*x**3/ffac(p2p3) + hm0=u0 + do k=0,mk0 + hm0=hm0+n0pk(k,p)*xx**k + enddo + hm2=u0 + do k=0,mk2 + hm2=hm2+n2pk(k,p)*xx**k + enddo + cm0=m0+hm0/(ffac(p2p1)*x**p2m1) + cm2=m2+hm2/(ffac(p2p3)*x**p2m1) + bnorm(h)=u1/cm0 + bsprds(h)=cm2/cm0 +enddo +end subroutine inimomtab + +!================================================================== [tritform] +subroutine tritforms(lx,mx, ly,my, aspects, dixs,diys, ff) +!============================================================================= +! Perform direct Triad and hs transforms in a proper subdomain +! domains extents in x, y, are lx:mx, ly:my +! aspects: upon input, these are the 3-vectors of grid-relative aspect tensor +! upon output, these are the 3 active line-filter half-spans. +! dixs: x-component of each of the 6 active line generators +! diys: y-component +! ff: Logical failure flag, output .true. when failure occurs. +! Note that the integer arrays, doxs, diys, are 1-byte integers. +!============================================================================== + +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +implicit none +integer(spi), intent(in ):: lx,mx,ly,my +real(dp), dimension(3,lx:mx,ly:my),intent(inout):: aspects +integer(fpi),dimension(lx:mx,ly:my,3),intent( out):: dixs,diys +logical, intent( out):: ff +!----------------------------------------------------------------------------- +integer(spi) :: ix,iy +integer(fpi),dimension(2,3):: ltri +!============================================================================= +do iy=ly,my + do ix=lx,mx + call tritform(aspects(:,ix,iy),ltri,ff) + if(ff)then + print'(" Failure in tritform at ix,iy=",2i5)',ix,iy + return + endif + dixs(ix,iy,:)=ltri(1,:) + diys(ix,iy,:)=ltri(2,:) + enddo +enddo +end subroutine tritforms + +!=================================================================== [tritform] +subroutine tritform(aspect ,ltri, ff) +!============================================================================== +! Perform the direct Triad and hs transform. +! Take a 3-vector representation of the aspect tensor and +! transform it to the vector of half-spans for the beta line filter +! and 1-byte-integer line generators. +! aspect: input as aspect tensor components, output as spread**2 +! ltri : three active line generators in ascending color order +! ff : logical failure flag. +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +implicit none +real(dp),dimension(3), intent(inout):: aspect +integer(fpi),dimension(2,3),intent( out):: ltri +logical, intent( out):: ff +!------------------------------------------------------------------------------ +real(dp), dimension( 3):: wtri +integer(fpi),dimension(2,3):: ltri3 +integer(spi) :: i +!============================================================================== +call triad(aspect, ltri3,wtri,ff) +if(ff)then + print'(" In tritform; triad failed; check aspect tensor")' + return +endif +ltri=ltri3 +aspect=wtri +do i=1,3 + call hstform(aspect(i),ff) + if(ff)then + print'(" In tritform; hstform failed at i=",i2)',i + print'(" Check that inimomtab has been called to initialize exponent")' + print'(" p, table size, nh, and the moment tables for line filters")' + return + endif +enddo +end subroutine tritform + +!================================================================== [tritformi] +subroutine tritformi(aspect ,ltri, ff) +!============================================================================== +! Perform the inverse hs and triad transform. +! Take a 3-vector of the active spreads**2, +! and their line generators, and return the implied +! aspect tensor in the same 3-vector that contained the half-spans +! aspect: input as half-spans; output as aspect tensor components +! ltri : corresponding successive line generators (using 1-byte integers) +! ff : logical failure flag. +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +use jp_pmat4, only: outer_product +implicit none +real(dp),dimension(3),intent(inout) :: aspect +integer(fpi),dimension(2,3),intent(in ):: ltri +logical, intent( out):: ff +!------------------------------------------------------------------------------ +real(dp),dimension(2,2):: a22 +real(dp),dimension(2) :: vec +integer(spi) :: i +!============================================================================== +a22=u0 +do i=1,3 + vec=ltri(:,i) + call hstformi(aspect(i),ff) + if(ff)then + print'(" In tritformi; hstformi failed at i=",i2)',i + print'(" Check that inimomtab has been called to initialize exponent")' + print'(" p, table size, nh, and the moment tables for line filters")' + return + endif + a22=a22+outer_product(vec,vec)*aspect(i) +enddo +call t22_to_3(a22,aspect) +end subroutine tritformi + +!===================================================================== [triad] +subroutine triad(aspect,ltri,wtri,ff) +!============================================================================= +! A version of the Triad iterative algorithm for resolving a given aspect +! tensor, A, rearranged as the 3-vector, +! Aspect = (/A_11, A_22, A_12/) +! onto a bisis of generator directions, the integer 2-vectors ltri, together +! with their corresponding aspect projections, or "weights", wtri. +! +! Aspect: The given aspect tensor in the form of a 3-vector (see above) +! Ltri: The three integer 2-vectors whose members define a triad +! and whose outer-products imply basis 3-vectors into which the aspect +! is resolved. This matrix of 3-vectors is denoted Lu, but only its +! inverse, Lui, is needed in this routine. +! wtri: Real nonnegative weights (projected aspect) corresponding to ltri. +! ff : Failure flag, raised on output only when iterations exceed limit. +!============================================================================= +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pmat4, only: outer_product +implicit none +real(dp), dimension(3), intent(in ):: aspect +integer(fpi),dimension(2,0:2),intent(out):: ltri +real(dp), dimension(0:2) ,intent(out):: wtri +logical, intent(out):: ff +!----------------------------------------------------------------------------- +integer(spi),parameter :: nit=200 +real(dp), parameter :: bcmins=-1.e-14_dp +real(dp), dimension(3,0:2):: rlui +real(dp) :: dwtri +integer(spi),dimension(-2:2) :: ssigns +integer(spi),dimension(0:2) :: signs +integer(fpi),dimension(2,0:2):: defltri ! <- default Ltri +integer(spi),dimension(3,0:2):: deflui ! <- default Lui +integer(spi),dimension(3,0:2):: lui +integer(spi),dimension(3) :: dlui +integer(spi),dimension(1) :: ii +integer(spi) :: it,kcol,lcol,mcol +data ssigns/1,1,-1,1,1/ +data deflui/1, 0,-1, 0, 1,-1, 0, 0, 1/ +data defltri/ 1, 0, 0,1, -1,-1/ +!============================================================================== +ltri=defltri; lui=deflui +rlui=lui; wtri=matmul(aspect,rlui) +do it=1,nit + ii=minloc(wtri)-1; kcol=ii(1); dwtri=wtri(kcol)*2; if(dwtri>=bcmins)exit + lcol=mod(kcol+1,3); mcol=mod(lcol+1,3); dlui=lui(:,kcol)*2 + Ltri(:,lcol)=-Ltri(:,Lcol); Ltri(:,kcol)=-Ltri(:,Lcol)-Ltri(:,mcol) + signs=ssigns(-kcol:2-kcol) + lui=lui+outer_product(dlui,signs) + wtri=wtri+signs*dwtri +enddo +ff=it>nit +end subroutine triad + +!=================================================================== [gettrilu] +subroutine gettrilu(ltri,lu) +!============================================================================== +use jp_pkind, only: spi; use jp_pkind2, only: fpi +implicit none +integer(fpi),dimension(2,0:2),intent(in ):: ltri +integer(fpi),dimension(2,0:2),intent(out):: lu +!----------------------------------------------------------------------------- +integer(spi):: i,L +!============================================================================== +do i=0,2; do L=1,2; lu(L,i)=Ltri(i2pair(1,L),i)*Ltri(i2pair(2,L),i);enddo;enddo +end subroutine gettrilu + +!============================================================================== +subroutine querytcol(vin,tcol)! [querytcol] +!============================================================================== +use jp_pkind, only: spi +implicit none +integer(spi),dimension(2),intent(in ):: vin +integer(spi), intent(out):: tcol +!------------------------------------------------------------------------------ +integer(spi),dimension(3):: tcols +integer(spi) :: i +data tcols/0,1,2/ +!============================================================================== +i=modulo(vin(1),2)+2*modulo(vin(2),2) +if(i==0)stop 'In querytcol; invalid 2-vector vin has all components even' +tcol=tcols(i) +end subroutine querytcol + +!=================================================================== [hextform] +subroutine hextforms(lx,mx,ly,my,lz,mz, aspects, qcols,dixs,diys,dizs, ff) +!============================================================================== +! Perform direct hexad and hs transforms in a proper subdomain +! domains extents in x, y, z, are lx:mx, ly:my, lz:mz +! aspects: upon input, these are the 6-vectors of grid-relative aspect tensor +! upon output, these are the six active-line-filter half-spans. +! qcols: outout as the Galois "colors" of each successive line-filter, listed +! in ascending order but with zeros at positions 0 and 7 of each list. +! dixs: x-component of each of the 6 active line generators +! diys: y-component +! dizs: z-component +! ff: Logical failure flag, output .true. when failure occurs. +! Note that the integer arrays, qcols, doxs, diys, dizs, are 1-byte integers. +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +implicit none +integer(spi), intent(in ):: lx,mx, & + ly,my, & + lz,mz +real(dp), dimension( 6,lx:mx,ly:my,lz:mz),intent(inout):: aspects +integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz),intent( out):: qcols +integer(fpi),dimension(lx:mx,ly:my,lz:mz,6), intent( out):: dixs,diys,dizs +logical, intent( out):: ff +!------------------------------------------------------------------------------ +integer(spi) :: ix,iy,iz +integer(fpi),dimension(3,6):: lhex +!============================================================================== +do iz=lz,mz + do iy=ly,my + do ix=lx,mx + call hextform(aspects(:,ix,iy,iz),qcols(:,ix,iy,iz),& + lhex,ff) + if(ff)then + print'(" Failure in hextform at ix,iy,iz=",3i5)',ix,iy,iz + return + endif + dixs(ix,iy,iz,:)=lhex(1,:) + diys(ix,iy,iz,:)=lhex(2,:) + dizs(ix,iy,iz,:)=lhex(3,:) + enddo + enddo +enddo +end subroutine hextforms + +!=================================================================== [hextform] +subroutine hextform(aspect, qcol,lhex, ff) +!============================================================================== +! Perform the direct Hexad and hs transform. +! Take a 6-vector representation of the aspect tensor and +! transform it to the vector of half-spans for the dibeta filter, +! and 1-byte-integer line generators, and color list. +! aspect: input as aspect tensor components, output as half-spans +! qcol : output as colors of successive active lines, but with +! "spare" null elements 0 and 7. +! lhex : six active line generators in ascending color order +! ff : logical failure flag. +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +implicit none +real(dp),dimension(6), intent(inout):: aspect +integer(fpi),dimension(0:7),intent( out):: qcol +integer(fpi),dimension(3,6),intent( out):: lhex +logical, intent( out):: ff +!------------------------------------------------------------------------------ +real(dp), dimension( 7):: whex7 +integer(fpi),dimension(3,7):: lhex7 +integer(fpi) :: i,j +!============================================================================== +call hexad(aspect, lhex7,whex7,ff) +if(ff)then + print'(" In hextform; hexad, failed; check aspect tensor")' + return +endif +qcol(0)=0; qcol(7)=0 +j=1 +do i=1,7 + if(sum(abs(lhex7(:,i)))==0)cycle + qcol(j)=i + lhex(:,j)=lhex7(:,i) + aspect(j)=whex7( i) + j=j+1_fpi +enddo +do i=1,6 + call hstform(aspect(i),ff) + if(ff)then + print'(" In hextform; hstform failed at i=",i2)',i + print'(" Check that inimomtab has been called to initialize exponent")' + print'(" p, table size, nh, and the moment tables for line filters")' + return + endif +enddo +ff=(j/=7) +if(ff)print'(" In hextform; inconsistent hexad generator set found")' +end subroutine hextform + +!================================================================== [hextformi] +subroutine hextformi(aspect, qcol,lhex, ff) +!============================================================================== +! Perform the inverse hs and hexad transform. +! Take a 6-vector of the active half-spans, their respective +! colors, and their line generators, and return the implied +! aspect tensor in the same 6-vector that contained the spreads**2 +! aspect: input as spreads**2; output as aspect tensor components +! qcol : colors of successive active hexad members (using 1-byte integers) +! lhex : corresponding successive line generators (using 1-byte integers) +! ff : logical failure flag. +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +use jp_pmat4, only: outer_product +implicit none +real(dp), dimension( 6),intent(inout):: aspect +integer(fpi),dimension(0:7),intent(in ):: qcol +integer(fpi),dimension(3,6),intent(in ):: lhex +logical, intent( out):: ff +!------------------------------------------------------------------------------ +real(dp),dimension(3,3):: a33 +real(dp),dimension(3) :: vec +integer(fpi) :: i,j +!============================================================================== +a33=u0 +j=1 +do i=1,7 + if(qcol(j)/=i)cycle + call hstformi(aspect(j),ff) + if(ff)then + print'(" In hextformi; hstformi failed at i,j=",2i2)',i,j + print'(" Check that inimomtab has been called to initialize exponent")' + print'(" p, table size, nh, and the moment tables for line filters")' + return + endif + vec=lhex(:,j) + a33=a33+outer_product(vec,vec)*aspect(j) + j=j+1_fpi +enddo +ff=(j/=7) +if(ff)print'(" In hextformi; Inconsistent qcol")' +call t33_to_6(a33,aspect) +end subroutine hextformi + +!====================================================================== [hexad] +subroutine hexad(aspect,lhex7,whex7,ff) +!============================================================================== +! A version of the Hexad iterative algorithm for resolving a given aspect +! tensor, A, rearranged as the 6-vector, +! Aspect= (/ A_11, A_22, A_33, A_23, A_31, A_12 /) +! onto a basis of generator directions, the integer 3-vectors lhex7, together +! with their corresponding aspect projections, or "weights", whex7. +! Although seven lhex vectors and weights are given (arranged by "colors" 0--6) +! only six of these -- those that do NOT equal the "color" of the hexad +! itself --- are nonzero (and are positive when the hexad is correctly +! resolving the target aspect tensor, Aspect). The style of this algorithm +! is as close as possible to the the description in documentation "Note 7". +! +! Aspect: the given aspect tensor in the form of a 6-vector (see above). +! Lhex7: The seven integer 3-vectors whose 6 non-null members define a Hexad +! and whose outer-products imply basis 6-vectors into which the aspect +! is resolved. This matrix of 6-vectors is denoted Lu, but only its +! inverse, Lui, is needed in this routine. These seven 3-vectors are +! arranged in decreasing order of "cardinality", +! meaning that the cardinal +! directions' colors define the first three vectors, the next three have +! two odd components, and the seventh has all odd components. +! whex7: Seven real nonnegative weights (projected aspect) +! corresponding to lhex +! (zero value in the case of the null vector of lhex7) +! ff : failure flag, raised only when the iterations exceed their limit. +! The algorithm here benefits from using the symmetry of the Fano plane +! and related GF(8) nonnull elements which, arranged cyclically, imply that +! the Jth "line" comprises points j+line(0), j+line(1), j+line(2), where +! Line = (/ 1, 2, 4/) and j is taken modulo 7. +! Note: the "K-set" of 3 members of the Lhex (indexed hcol+6, hcol+5, hcol+3) +! or equivalently, hcol-line(0),hcol-line(1),hclo-line(2), +! where arithmetic is modulo-7, are sufficient to form a "basis" from which +! the other ("L-set") nonnull members of Lhex are implied. To make the +! iterations efficient, we can iterate just this K-set, because the changes +! made to the effective projection operator, Lui, are, by the Woodbury +! formula, of rank-1 at each iteration, and the whex components change by +! a corresponding pattern of increments that do not need us to find the full +! set of Lhex, nor the explicit Lu, each iteration. +! Note that some integer arrays use 1-byte integer type to save space. +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +use jp_pmat4, only: outer_product +implicit none +real(dp), dimension(6), intent(in ):: aspect +integer(fpi),dimension(3,7), intent(out):: lhex7 +real(dp), dimension(7), intent(out):: whex7 +logical, intent(out):: ff +!------------------------------------------------------------------------------ +integer(spi),parameter :: nit=200 +real(dp), parameter :: bcmins=-1.e-14_dp +real(dp), dimension(6,0:6) :: rlui +real(dp), dimension(0:6) :: whex +real(dp) :: dwhex +integer(spi),dimension(0:6) :: signs +integer(fpi),dimension(3,0:6) :: deflhex +integer(spi),dimension(6,0:6) :: deflui +integer(spi),dimension(-6:6) :: sstriad +integer(spi),dimension(6) :: dlui,ttriad +integer(fpi),dimension(3,0:2) :: Kset +integer(fpi),dimension(3,3,6) :: mmats +integer(spi),dimension(0:2) :: Line +integer(spi),dimension(1) :: ii +integer(fpi),dimension(3,0:6) :: lhex +integer(spi),dimension(6,0:6) :: lui +integer(spi),dimension(0:6) :: jcol +integer(spi) :: hcol +integer(spi) :: i,ip,it,j,kcol,dcol,L +data deflhex/0,0,0, 1,-1,0, 0,1,-1, 0,0,1, -1,0,1, 0,1,0, 1,0,0/ +data deflui/ 6*0, 0, 0, 0, 0, 0,-1, 0, 0, 0,-1, 0, 0, 0, 0, 1, 1, 1, 0, & + 0, 0, 0, 0,-1, 0, 0, 1, 0, 1, 0, 1, 1, 0, 0, 0, 1, 1/ +data Mmats/1, 1,-1, 1, 0, 0, 1, 0,-1, -1, 1, 0, -1, 1, 1, 0, 1, 0, & + 0,-1, 1, 1,-1, 0, 1, 0, 0, 0, 0, 1, 0,-1, 1, 1,-1, 1, & + -1, 0, 1, 0, 0, 1, -1, 1, 0, 0, 1, 0, 1, 0,-1, 0, 1,-1/ +data ttriad/5,3,3,6,5,6/ +data sstriad/-1,-1, 1,-1, 1, 1, 1,-1,-1, 1,-1, 1, 1/ +data Line/1,2,4/ +data jcol/7,4,6,3,5,2,1/ +!============================================================================== +lhex=deflhex; lui=deflui; hcol=0 +rlui=lui; whex=matmul(aspect,rlui) +do i=0,2; Kset(:,i)=Lhex(:,modulo(hcol-line(i),7)); enddo +do it=1,nit + ii=minloc(whex)-1; kcol=ii(1); dwhex=whex(kcol); if(dwhex>=bcmins)exit + dcol=modulo(kcol-hcol,7); hcol=kcol; L=modulo(hcol+ttriad(dcol),7) + Kset=matmul(Kset,Mmats(:,:,dcol)) + dlui=lui(:,hcol) + signs=sstriad(-L:6-L) + lui =lui+outer_product(dlui,signs) + whex=whex+signs*dwhex +enddo +ff=it>nit; if(ff)return +do i=0,2; ip=modulo(i+1,3) + lhex(:,modulo(hcol-line(i),7))=Kset(:,i) + lhex(:,modulo(hcol+line(i),7))=Kset(:,i)-Kset(:,ip) +enddo +lhex(:,kcol)=0 +lhex7=0 +whex7=u0 +do i=0,6 + j=jcol(i) + lhex7(:,j)=lhex(:,i) + whex7( j)=whex( i) +enddo + +end subroutine hexad + +!=================================================================== [gethexlu] +subroutine gethexlu(lhex,lu) +!============================================================================== +use jp_pkind, only: spi; use jp_pkind2, only: fpi +implicit none +integer(fpi),dimension(3,0:6),intent(in ):: lhex +integer(fpi),dimension(6,0:6),intent(out):: lu +!------------------------------------------------------------------------------ +integer(spi):: i,L +!============================================================================== +do i=0,6; do L=1,6; lu(L,i)=Lhex(i3pair(1,L),i)*Lhex(i3pair(2,L),i);enddo;enddo +end subroutine gethexlu + +!============================================================================== +subroutine queryhcol(vin,hcol)! [queryhcol] +!============================================================================== +use jp_pkind, only: spi +implicit none +integer(spi),dimension(3),intent(in ):: vin +integer(spi), intent(out):: hcol +!------------------------------------------------------------------------------ +integer(spi),dimension(7):: hcols +integer(spi) :: i +data hcols/6,5,1,3,4,2,0/ +!============================================================================== +i=modulo(vin(1),2)+2*modulo(vin(2),2)+4*modulo(vin(3),2) +if(i==0)stop 'In queryhcol; invalid 3-vector Vin has all components even' +hcol=hcols(i) +end subroutine queryhcol + +!=================================================================== [dectform] +subroutine dectforms(lx,mx,ly,my,lz,mz,lw,mw,aspects,qcols, & + dixs,diys,dizs,diws, ff) +!============================================================================== +! Perform direct Decad and ha transforms in a proper subdomain +! domains extents in x, y, z, w, are lx:mx, ly:my, lz:mz, lw:mw +! aspects: upon input, these are the 10-vectors of grid-relative aspect tensor +! upon output, these are the ten active-line-filter half-spans. +! qcols: outout as the Galois "colors" of each successive line-filter, listed +! in ascending order, with zeros at positions 0 and 11 of each list. +! dixs: x-component of each of the 6 active line generators +! diys: y-component +! dizs: z-component +! diws: w-component +! ff: Logical failure flag, output .true. when failure occurs. +! Note that the integer arrays, qcols, doxs, diys, dizs, diws, +! are 1-byte integers. +! +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +implicit none +integer(spi), intent(in ):: lx,mx,& + ly,my,& + lz,mz,& + lw,mw +real(dp),dimension(10,lx:mx,ly:my,lz:mz,lw:mw), intent(inout):: aspects +integer(fpi),dimension(0:11,lx:mx,ly:my,lz:mz,lw:mw),intent( out):: qcols +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw,10), intent( out):: dixs,& + diys,& + dizs,& + diws +logical, intent( out):: ff +!------------------------------------------------------------------------------ +integer(spi) :: ix,iy,iz,iw +integer(fpi),dimension(4,10):: ldec +!============================================================================== +do iw=lw,mw + do iz=lz,mz + do iy=ly,my + do ix=lx,mx + call dectform(aspects(:,ix,iy,iz,iw),qcols(0:11,ix,iy,iz,iw),& + ldec,ff) + if(ff)then + print'(" Failure in dectform at ix,iy,iz,iw=",4i5)',& + ix,iy,iz,iw + return + endif + dixs(ix,iy,iz,iw,:)=ldec(1,:) + diys(ix,iy,iz,iw,:)=ldec(2,:) + dizs(ix,iy,iz,iw,:)=ldec(3,:) + diws(ix,iy,iz,iw,:)=ldec(4,:) + enddo + enddo + enddo +enddo +end subroutine dectforms + +!=================================================================== [dectform] +subroutine dectform(aspect, qcol,ldec, ff) +!============================================================================== +! Perform the direct Decad and hs transform. +! Take a 10-vector representation of the aspect tensor and +! transform it to the vector of half-spans +! and 1-byte-integer line generators, and color list. +! aspect: input as aspect tensor components, output as spread**2 +! qcol : output as colors of successive active lines, but with +! "spare" null elements 0 and 11. +! ldec : ten active line generators in ascending color order +! ff : logical failure flag. +!============================================================================= +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +implicit none +real(dp),dimension(10), intent(inout):: aspect +integer(fpi),dimension(0:11),intent( out):: qcol +integer(fpi),dimension(4,10),intent( out):: ldec +logical, intent( out):: ff +!----------------------------------------------------------------------------- +real(dp), dimension( 15):: wdec15 +integer(fpi),dimension(4,15):: ldec15 +integer(fpi) :: i,j +!============================================================================= +call decad(aspect, ldec15,wdec15,ff) +if(ff)then + print'(" In dectform; decad, failed; check aspect tensor")' + return +endif +qcol(0)=0; qcol(11)=0 +j=1 +do i=1,15 + if(sum(abs(ldec15(:,i)))==0)cycle + qcol(j)=i + ldec(:,j)=ldec15(:,i) + aspect(j)=wdec15( i) + j=j+1_fpi +enddo +do i=1,10 + call hstform(aspect(i),ff) + if(ff)then + print'(" In dectform; hstform failed at i=",i2)',i + print'(" Check that inimomtab has been called to initialize exponent")' + print'(" p, table size, nh, and the moment tables for line filters")' + return + endif +enddo + +ff=(j/=11) +if(ff)print'(" In dectform; inconsistent decad generator set found")' +end subroutine dectform + +!================================================================= [dectformi] +subroutine dectformi(aspect, qcol,ldec, ff) +!============================================================================= +! Perform the inverse hs and decad transform. +! Take a 10-vector of the active half-spans, their respective +! colors, and their line generators, and return the implied +! aspect tensor in the same 10-vector that contained the spreads**2 +! aspect: input as spreads**2; output as aspect tensor components +! qcol : colors of successive active decad members (using 1-byte integers) +! ldec : corresponding successive line generators (using 1-byte integers) +! ff : logical failure flag. +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +use jp_pmat4, only: outer_product +implicit none +real(dp), dimension( 10),intent(inout):: aspect +integer(fpi),dimension(0:11),intent(in ):: qcol +integer(fpi),dimension(4,10),intent(in ):: ldec +logical, intent( out):: ff +!------------------------------------------------------------------------------ +real(dp),dimension(4,4):: a44 +real(dp),dimension(4) :: vec +integer(spi) :: i,j +!============================================================================== +a44=u0 +j=1 +do i=1,15 + if(qcol(j)/=i)cycle + call hstformi(aspect(j),ff) + if(ff)then + print'(" In dectformi; hstformi failed at i,j=",2i3)',i,j + print'(" Check that inimomtab has been called to initialize exponent")' + print'(" p, table size, nh, and the moment tables for line filters")' + return + endif + vec=ldec(:,j) + a44=a44+outer_product(vec,vec)*aspect(j) + j=j+1 +enddo +ff=(j/=11) +if(ff)then + print'(" In dectformi; Inconsistent qcol")' + return +endif +call t44_to_10(a44,aspect) +end subroutine dectformi + +!====================================================================== [decad] +subroutine decad(aspect,ldec15,wdec15,ff) +!============================================================================== +! This version is derived from $HOMES/on500/decadf.f90 +! In this version ALWAYS start from the default decad +! Also, rearrange the 10 active line directions and weights +! into arrays of 15, ordered according the colors of the fundamental +! 3*3*3*3 cube's surface generators' degrees of "cardinality". By this +! we mean that the colors of (1,0,0,0), (0,1,0,0), (0,0,1,0), (0,0,0,1) +! come first, followed by the colors of (1,1,0,0), (1,0,1,0), (1,0,0,1), +! (0,1,1,0), (0,1,0,1), (0,0,1,1), followed by the colors of (1,1,1,0), +! (1,1,0,1), (1,0,1,1), (0,1,1,1), and followed finally by the color +! of the "least cardinal" (or "most diagonal") type of element, (1,1,1,1). +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +use jp_pbfil2,only: dec0,dodec0t,umat10,umat12,umats,nei,dcol10,dcol12,& + nei0a,jcora,nei0b,jcorb,nei17,nei22,nei33,nei38, tcors,& + kcor10a5,kcor10b1,kcor10b2,kcor12b0, & + kcor17c0,kcor22c0,kcor33c0,kcor38c0,kcor44c0,kcor51c0,kcor53c0,kcor58c0,& + twt10a5,twt10b1,twt10b2,twt12c0,qwt10a,qwt10b,qwt10c,qwt10d,qwt10e, & + qwt12a,qwt12b0,tperms,perm10,perm12,perms +use jp_pmat, only: inv +use jp_pmat4, only: outer_product,det +implicit none +real(dp),dimension(10), intent(in ):: aspect +integer(fpi),dimension(4,15),intent(out):: ldec15 +real(dp), dimension( 15),intent(out):: wdec15 +logical, intent(out):: ff +!------------------------------------------------------------------------------ +integer(spi), parameter :: nit=40 +real(dp),parameter :: bcmins=-1.e-14_dp +real(dp),dimension(10,0:9) :: rlui +real(dp),dimension(0:9) :: awdec,xwdec,newwdec,wdec +real(dp) :: dwdec +integer(spi) :: ktyp,dcol ! Redundant? +integer(spi),dimension(0:9) :: palet ! +integer(spi),dimension(4,0:9) :: eldec ! +integer(spi),dimension(10,0:9) :: lu,lui +integer(fpi),dimension(4,0:9) :: defeldec +integer(spi),dimension(4,0:9) :: neweldec +integer(spi),dimension(0:9) :: defpalet +integer(spi),dimension(1) :: ii +integer(spi),dimension(4,4) :: tcor +integer(spi) :: i,it,j,k,newktyp,newdcol,abscol,& + jcol,kcor,jcor +integer(spi),dimension(4,0:3) :: newbase +integer(spi),dimension(0:9) :: perm,qwt,tperm +integer(spi),dimension(0:14) :: icol15 +data icol15/1,2,3,4,5,8,10,12,6,9,11,14,15,13,7/ +data defeldec/ & + 0, 0, 1, 0, 0,-1, 0, 0, 1, 0, 0, 0, -1, 0,-1,-1, 0, 1, 0, 1, & + 0, 0, 0,-1, -1, 0,-1, 0, 1, 1, 1, 1, -1,-1, 0,-1, 1, 0, 0, 1/ +data defpalet/ 2, 1, 0,13, 9, 3, 8,12, 7,14/ +!============================================================================== +eldec=defeldec; palet=defpalet; ktyp=4; dcol=4 +do j=0,9; call t4_to_10(eldec(:,j),lu(:,j)); enddo +lui=transpose(lu) +call inv(lui,ff) +if(ff)then + print'(" In decad, at A; lu cannot be inverted")' + return +endif +rlui=lui +wdec=matmul(aspect,rlui) +do it=1,nit + ii=minloc(wdec)-1; k=ii(1); dwdec=wdec(k); + if(dwdec>=bcmins)exit +!-- The following is translated from the "x" block of old tdecadf: + newktyp=nei(k,ktyp) + if(ktyp<12)then + abscol=modulo(dcol+dcol10(k,ktyp),15)! Anticipated uncorrected abs col + newbase(:,:)=matmul(eldec(:,0:3),umat10(:,:,k,ktyp)) + else + if(k<4)then + abscol=modulo(dcol+dcol12(k,ktyp),15) + newbase(:,:)=matmul(eldec(:,0:3),umat12(:,:,k,ktyp))/2 + else + abscol=dcol + newbase(:,:)=matmul(eldec(:,0:3),umats(:,:,k))/2 + endif + endif + jcol=0 + jcor=0 + if(newktyp==11)then + jcol=abscol/3 + if(jcol>0)then + jcor=6+jcol + endif + abscol=modulo(abscol,3) + elseif(newktyp>=44)then + jcol=abscol/5 + if(jcol>0)then + select case(ktyp) + case(0:3) + newktyp=nei0a(jcol,ktyp) + jcor=jcora(jcol,ktyp) + case(4:9) + newktyp=nei0b(jcol,k,ktyp) + jcor=jcorb(jcol,k,ktyp) + case(17); newktyp=nei17(jcol); jcor=10+jcol + case(22); newktyp=nei22(jcol); jcor=10+jcol + case(33); newktyp=nei33(jcol); jcor=10+jcol + case(38); newktyp=nei38(jcol); jcor=10+jcol + case(44); jcor=10+jcol + case(51); jcor=10+jcol + case(53); jcor=10+jcol + case(58); jcor=10+jcol + case default + print'(" In decad. Unrecognized ktyp=",i10)',ktyp + ff=.true. + return + end select + endif + abscol=modulo(abscol,5) + if(ktyp<12)then + newdcol=modulo(abscol-dcol10(k,ktyp),15) + else + if(k<4)then + newdcol=modulo(abscol-dcol12(k,ktyp),15) + else + newdcol=dcol + endif + endif + endif + if(jcor /= 0)then + tcor=tcors(:,:,jcor) + newbase=matmul(newbase(:,:),tcor)/2 + endif + + if(ktyp<12)then + perm=perm10(:,k,ktyp) + select case(ktyp) + case(0:3) + if(k==5)then + kcor=kcor10a5(jcol,ktyp) + qwt=twt10a5(:,kcor) + else + qwt=qwt10a(:,k) + endif + case(4:7) + if(k==1)then + kcor=kcor10b1(jcol,ktyp) + qwt=twt10b1(:,kcor) + elseif(k==2)then + kcor=kcor10b2(jcol,ktyp) + qwt=twt10b2(:,kcor) + else + qwt=qwt10b(:,k) + endif + case(8:9) + if(k==1)then + kcor=kcor10b1(jcol,ktyp) + qwt=twt10b1(:,kcor) + elseif(k==2)then + kcor=kcor10b2(jcol,ktyp) + qwt=twt10b2(:,kcor) + else + qwt=qwt10c(:,k) + endif + case(10) + qwt=qwt10d(:,k) + case(11) + qwt=qwt10e(:,k) + end select + else + if(k==0)then + perm=perm12(:,k,ktyp) + kcor=kcor12b0(ktyp) + select case(ktyp) + case(17); kcor=kcor17c0(jcol); qwt=twt12c0(:,kcor) + case(22); kcor=kcor22c0(jcol); qwt=twt12c0(:,kcor) + case(33); kcor=kcor33c0(jcol); qwt=twt12c0(:,kcor) + case(38); kcor=kcor38c0(jcol); qwt=twt12c0(:,kcor) + case(44); kcor=kcor44c0(jcol); qwt=twt12c0(:,kcor) + case(51); kcor=kcor51c0(jcol); qwt=twt12c0(:,kcor) + case(53); kcor=kcor53c0(jcol); qwt=twt12c0(:,kcor) + case(58); kcor=kcor58c0(jcol); qwt=twt12c0(:,kcor) + case default + qwt=qwt12b0(:,kcor) + end select + elseif(k<4)then + perm=perm12(:,k,ktyp) + qwt=qwt12a(:,k) + else + perm=perms(:,k) + qwt=qwt12a(:,k) + endif + endif + if(jcor/=0)then + do i=0,9 + tperm(i)=tperms(perm(i),jcor) + enddo + perm=tperm + endif + call standardizeb(newbase(:,:),FF) + if(FF)then + print'(" In decad, at B; failure of subr. standardizedb")' + return + endif + +!-------- + awdec=wdec-qwt*dwdec + do i=0,9 + newwdec(perm(i))=awdec(i) + enddo + if(newktyp<12)then + neweldec=matmul(newbase,dec0) + else + neweldec=matmul(newbase,dodec0t)/2 + endif + do j=0,9 + call t4_to_10(neweldec(:,j),lu(:,j)) + enddo + lui=transpose(lu) + call inv(lui,ff) + if(ff)then + print'(" In decad, at C; lu cannot be inverted")' + return + endif + rlui=lui + xwdec=matmul(aspect,rlui) +! if(maxval(abs(xwdec-newwdec))>.001)read(*,*) + eldec=neweldec + ktyp=newktyp + dcol=abscol + wdec=xwdec +enddo +if(it>nit)then + ff=.true. + print '(" in decad, at D; failure of decad iterations to converge")' + return +endif +do j=0,9 + call querydcol(eldec(:,j),palet(j)) +enddo +print'(" departing decad having used it = ",i5," iterations.")',it +! Insert the decad into its proper color slots in order of decreasing +! "cardinality:" +wdec15=u0 +ldec15=0 +do i=0,9 + j=icol15(palet(i)) +! ldec15(:,j)=int(eldec(:,i),kind(fpi)) + ldec15(:,j)=int(eldec(:,i),fpi) + wdec15( j)= wdec( i) +enddo +end subroutine decad + +!=================================================================== [getdeclu] +subroutine getdeclu(ldec,lu) +!============================================================================== +use jp_pkind, only: spi; use jp_pkind2, only: fpi +implicit none +integer(spi),dimension( 4,0:14),intent(in ):: ldec +integer(spi),dimension(10,0:14),intent(out):: lu +!------------------------------------------------------------------------------ +integer(spi):: i,L +!============================================================================== +do i=0,14;do L=1,10;lu(L,i)=Ldec(i4pair(1,L),i)*Ldec(i4pair(2,L),i);enddo;enddo +end subroutine getdeclu + +!============================================================================== +subroutine querydcol(vin,dcol)! [querydcol] +!============================================================================== +use jp_pkind, only: spi; use jp_pkind2, only: fpi +implicit none +integer(spi),dimension(4),intent(in ):: vin +integer(spi), intent(out):: dcol +!------------------------------------------------------------------------------ +integer(spi),dimension(15):: dcols +integer(spi),dimension(4) :: bbbb +integer(spi) :: i +data dcols/ 0, 1, 4, 2, 8, 5,10, 3,14, 9, 7, 6,13,11,12/ +data bbbb/1,2,4,8/ +!============================================================================== +i=dot_product(bbbb,modulo(vin,2)) +if(i==0)stop 'In querydcol; invalid 4-vector Vin has all components even' +dcol=dcols(i) +end subroutine querydcol + +!=============================================================== [standardizeb] +subroutine standardizeb(bases,FF) +!============================================================================== +! Standardize 4*4 bases vectors by making sure the first nonzero component +! of the first column is positive in the standardized version. +! If the first column is null, raise the (logical) failure flag, FF. +!============================================================================== +use jp_pkind, only: spi +implicit none +integer(spi),dimension(4,4),intent(inout):: bases +logical, intent( out):: FF +integer(spi) :: i,b +!============================================================================== +FF=.false. +do i=1,4 + b=bases(i,1) + if(b==0)cycle + if(b<0)bases=-bases + return +enddo +print'(" WARNING! In subroutine standardizeb, first column is null:")' +FF=.true. +end subroutine standardizeb + +!==================================================================== [hstform] +subroutine hstform(hs,ff)! +!============================================================================== +! Perform the "hspan transform". For a given spread**2, replace it with the +! corresponding effective half-span corresponding to beta filters of the +! already-initialized exponent p. Generally, hs>=1, lies between consecutive +! integers, h, h+1 <=nh (nh is also already given in jp_pbfil2.mod). The linear +! interpolation weights at h and h+1 for this target, applied to the +! "interpolation" of the two standardized p-exponent beta distributions of +! half-spans h and h+1 will also be standardized (sum of gridded responses = 1) +! and will possess exactly the prescribed spread**2, the input hs. +! This transform is obviously invertible (see subr. hstformi). +! But if the given hs does not fit within the range of the +! table, bsprds, return a raised failure flag, ff. +!============================================================================== +use jp_pkind, only: spi,dp +use jp_pietc, only: u0 +use jp_pbfil2,only: nh,bsprds +implicit none +real(dp),intent(inout):: hs +logical, intent( out):: ff +!------------------------------------------------------------------------------ +integer(spi):: h +!============================================================================== +ff=hs= hs)then + hs=h-(bsprds(h)-hs)/(bsprds(h)-bsprds(h-1)) + return + endif +enddo +ff=.true. +end subroutine hstform + +!=================================================================== [hstformi] +subroutine hstformi(hs,ff) +!============================================================================== +! Perform the "inverse hspan transform" (inverse function of hstform) so that +! an effective p-exponent beta filter half-span, hs, is replaced by the second +! moment (spread**2) of the dibeta filter this half-span implies. +! If the given half-span is not accommodated by the prepared table, bsprds, of +! module jp_pbfil3, return a raised failure flag, ff. +!============================================================================== +use jp_pkind, only: spi,dp +use jp_pietc, only: u1 +use jp_pbfil2,only: nh,bsprds +implicit none +real(dp),intent(inout):: hs +logical, intent( out):: ff +!------------------------------------------------------------------------------ +real(dp) :: w +integer(spi):: h +!============================================================================== +h=1+int(hs) +ff=(h<2 .or. h>nh) +if(ff)then + print'(" In hstformi; hs out of bounds")' + return +endif +! Linearly interpolate the spread**2 from the table bsprds: +w=h-hs +hs=w*bsprds(h-1)+(u1-w)*bsprds(h) +end subroutine hstformi + +!==================================================================== [blinfil] +subroutine blinfil(nfil,hspan, h,fil,ff) +!============================================================================== +! Find the discrete halfspan h and the filtering weights, fil(0:h), of +! the normalized dibeta filter of formal real half-span, hspan. The dibeta +! filter is just a weighted combination of two consecutive-halfspan +! beta filters such that the spread**2 of the dibeta is the weighted +! intermediate of the spreads**2 of the pair of beta filters from which it +! is composed. +! +! p: beta filter exponent index +! nh: size of the table listing the normalization factors and spreads**2 +! bnorm: table of normalization factors for beta filters of integer halfspan +! bsprds: table of squared-spreads of the beta filters +! hspan: formal real half-span of the dibeta filter +! fil: a real array, [0:nh], sufficient to accommodate one half of the +! symmetric discrete dibeta filter. +! ff: logical failure flag raised when hspan lies outside the table range. +!============================================================================== +use jp_pkind, only: spi,dp +use jp_pietc, only: u1 +use jp_pbfil2,only: p,nh,bnorm +implicit none +integer(spi), intent(in ):: nfil +real(dp), intent(in ):: hspan +integer(spi), intent(out):: h +real(dp),dimension(0:nfil),intent(out):: fil +logical, intent(out):: ff +!------------------------------------------------------------------------------ +real(dp) :: wh,whp,z +integer(spi):: hp,i +!============================================================================== +h=int(hspan); hp=h+1; ff=h<1 .or. hp>nh .or. hp>nfil; if(ff)return +whp =(hspan-h)*bnorm(hp)! linear interpolation weight at hp=h+1 +wh=(hp-hspan)*bnorm(h)! linear interpolation weight at h +! start with the contribution of the filter of formal halfspan h+1: +do i=0,h; z=i; z=(z/hp)**2; fil(i)= whp*(u1-z)**p; enddo +! add the contribution of the filter of formal halfspan h: +do i=0,h-1; z=i; z=(z/h)**2; fil(i)=fil(i)+wh*(u1-z)**p; enddo +end subroutine blinfil + +!-- The following routines share the interface, dibeta: +!===================================================================== [dibeta] +subroutine dibeta1(kx,lx,mx,nx, nfil,dixs,hss,a,ff,ix) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx, nfil +integer(fpi),dimension(lx:mx),intent(in ):: dixs +real(dp), dimension(lx:mx),intent(in ):: hss +real(dp), dimension(kx:nx),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil):: fil +real(dp),dimension(kx:nx) :: b +real(dp) :: fili +integer(spi) :: h,i,dix,dixi +!============================================================================== +b=u0 +do ix=lx,mx + dix=dixs(ix) + if(dix==0)then;b(ix)=a(ix) + else + call blinfil(nfil,hss(ix),h,fil,ff); if(ff)return + b(ix)=fil(0)*a(ix) + do i=1,h + fili=fil(i); dixi=dix*i + b(ix)=b(ix)+fili*(a(ix+dixi)+a(ix-dixi)) + enddo + endif +enddo +a=b +end subroutine dibeta1 +!===================================================================== [dibeta] +subroutine dibeta2(kx,lx,mx,nx, ky,ly,my,ny, nfil, & + dixs,diys,hss, a, ff,ix,iy) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx,& + ky,ly,my,ny,& + nfil +integer(fpi),dimension(lx:mx,ly:my),intent(in ):: dixs,diys +real(dp), dimension(lx:mx,ly:my),intent(in ):: hss +real(dp), dimension(kx:nx,ky:ny),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(kx:nx,ky:ny):: b +real(dp) :: fili +integer(spi) :: h,i,dix,diy,dixi,diyi +!============================================================================== +b=u0 +do iy=ly,my; do ix=lx,mx + dix=dixs(ix,iy); diy=diys(ix,iy) + if(abs(dix)+abs(diy)==0)then;b(ix,iy)=a(ix,iy) + else + call blinfil(nfil,hss(ix,iy),h,fil,ff); if(ff)return + b(ix,iy)=fil(0)*a(ix,iy) + do i=1,h + fili=fil(i); dixi=dix*i; diyi=diy*i + b(ix,iy)=b(ix,iy)+fili*(a(ix+dixi,iy+diyi)+a(ix-dixi,iy-diyi)) + enddo + endif +enddo; enddo +a=b +end subroutine dibeta2 +!===================================================================== [dibeta] +subroutine dibeta3(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, nfil, & + dixs,diys,dizs,hss, a, ff,ix,iy,iz) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx,& + ky,ly,my,ny,& + kz,lz,mz,nz,& + nfil +integer(fpi),dimension(lx:mx,ly:my,lz:mz),intent(in ):: dixs,diys,dizs +real(dp), dimension(lx:mx,ly:my,lz:mz),intent(in ):: hss +real(dp), dimension(kx:nx,ky:ny,kz:nz),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(kx:nx,ky:ny,kz:nz):: b +real(dp) :: fili +integer(spi) :: h,i, & + dix,diy,diz, & + dixi,diyi,dizi +!============================================================================== +b=u0 +do iz=lz,mz; do iy=ly,my; do ix=lx,mx + dix=dixs(ix,iy,iz); diy=diys(ix,iy,iz); diz=dizs(ix,iy,iz) + if(abs(dix)+abs(diy)+abs(diz)==0)then;b(ix,iy,iz)=a(ix,iy,iz) + else + call blinfil(nfil,hss(ix,iy,iz),h,fil,ff); if(ff)return + b(ix,iy,iz)=fil(0)*a(ix,iy,iz) + do i=1,h + fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i + b(ix,iy,iz)=b(ix,iy,iz)+fili* & + (a(ix+dixi,iy+diyi,iz+dizi)& + +a(ix-dixi,iy-diyi,iz-dizi)) + enddo + endif +enddo; enddo; enddo +a=b +end subroutine dibeta3 +!===================================================================== [dibeta] +subroutine dibeta4(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, & + nfil, dixs,diys,dizs,diws,hss, a, ff,ix,iy,iz,iw) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx,& + ky,ly,my,ny,& + kz,lz,mz,nz,& + kw,lw,mw,nw,& + nfil +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: dixs,diys,& + dizs,diws +real(dp), dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: hss +real(dp), dimension(kx:nx,ky:ny,kz:nz,kw:nw),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz,iw +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(kx:nx,ky:ny,kz:nz,kw:nw):: b +real(dp) :: fili +integer(spi) :: h,i, & + dix,diy,diz,diw, & + dixi,diyi,dizi,diwi +!============================================================================== +b=u0 +do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx + dix=dixs(ix,iy,iz,iw);diy=diys(ix,iy,iz,iw) + diz=dizs(ix,iy,iz,iw);diw=diws(ix,iy,iz,iw) + if(abs(dix)+abs(diy)+abs(diz)+abs(diw)==0)then;b(ix,iy,iz,iw)=a(ix,iy,iz,iw) + else + call blinfil(nfil,hss(ix,iy,iz,iw),h,fil,ff); if(ff)return + b(ix,iy,iz,iw)=fil(0)*a(ix,iy,iz,iw) + do i=1,h + fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i + b(ix,iy,iz,iw)=b(ix,iy,iz,iw)+fili* & + (a(ix+dixi,iy+diyi,iz+dizi,iw+diwi)& + +a(ix-dixi,iy-diyi,iz-dizi,iw-diwi)) + enddo + endif +enddo; enddo; enddo; enddo +a=b +end subroutine dibeta4 + +!===================================================================== [dibeta] +subroutine dibetax3(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, icol,nfil,& + qcols,dixs,diys,dizs, jcol,hss,a, ff,ix,iy,iz) +!============================================================================= +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx, & + ky,ly,my,ny, & + kz,lz,mz,nz, & + icol,nfil +integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz),intent(in ):: qcols +integer(fpi),dimension(lx:mx,ly:my,lz:mz,6), intent(in ):: dixs,diys,dizs + +integer(fpi),dimension(lx:mx,ly:my,lz:mz), intent(inout):: jcol +real(dp),dimension(6,lx:mx,ly:my,lz:mz), intent(in ):: hss +real(dp),dimension(kx:nx,ky:ny,kz:nz), intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(kx:nx,ky:ny,kz:nz):: b +real(dp) :: fili,hs +integer(spi) :: h,i, & + dix,diy,diz, & + dixi,diyi,dizi +integer(fpi) :: j +!============================================================================== +b=u0 +if(icol==1)jcol=1 +do iz=lz,mz; do iy=ly,my; do ix=lx,mx + j=jcol(ix,iy,iz) + if(icol/=qcols(j,ix,iy,iz))then + b(ix,iy,iz)=a(ix,iy,iz) + cycle + else + jcol(ix,iy,iz)=j+1_fpi + dix=dixs(ix,iy,iz,j); diy=diys(ix,iy,iz,j); diz=dizs(ix,iy,iz,j) + hs=hss(j,ix,iy,iz) + call blinfil(nfil,hs,h,fil,ff); if(ff)return + b(ix,iy,iz)=fil(0)*a(ix,iy,iz) + do i=1,h + fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i + b(ix,iy,iz)=b(ix,iy,iz)+fili* & + (a(ix+dixi,iy+diyi,iz+dizi)& + +a(ix-dixi,iy-diyi,iz-dizi)) + enddo + endif +enddo; enddo; enddo +a=b +end subroutine dibetax3 +!===================================================================== [dibeta] +subroutine dibetax4(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, & + icol,nfil,& + qcols,dixs,diys,dizs,diws, jcol,hss,a, ff,ix,iy,iz,iw) +!============================================================================= +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx, & + ky,ly,my,ny, & + kz,lz,mz,nz, & + kw,lw,mw,nw, & + icol,nfil +integer(fpi),dimension(0:11,lx:mx,ly:my,lz:mz,lw:mw),& + intent(in ):: qcols +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw,10),& + intent(in ):: dixs,diys,& + dizs,diws +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(inout):: jcol +real(dp),dimension(10,lx:mx,ly:my,lz:mz,lw:mw), intent(in ):: hss +real(dp),dimension(kx:nx,ky:ny,kz:nz,kw:nw), intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz,iw +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(kx:nx,ky:ny,kz:nz,kw:nw):: b +real(dp) :: fili,hs +integer(spi) :: h,i, & + dix,diy,diz,diw, & + dixi,diyi,dizi,diwi +integer(fpi) :: j +!============================================================================== +b=u0 +if(icol==1)jcol=1 +do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx + j=jcol(ix,iy,iz,iw) + if(icol/=qcols(j,ix,iy,iz,iw))then + b(ix,iy,iz,iw)=a(ix,iy,iz,iw) + cycle + else + jcol(ix,iy,iz,iw)=j+1_fpi + dix=dixs(ix,iy,iz,iw,j); diy=diys(ix,iy,iz,iw,j) + diz=dizs(ix,iy,iz,iw,j); diw=diws(ix,iy,iz,iw,j) + hs=hss(j,ix,iy,iz,iw) + call blinfil(nfil,hs,h,fil,ff); if(ff)return + b(ix,iy,iz,iw)=fil(0)*a(ix,iy,iz,iw) + do i=1,h + fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i + b(ix,iy,iz,iw)=b(ix,iy,iz,iw)+fili* & + (a(ix+dixi,iy+diyi,iz+dizi,iw+diwi)& + +a(ix-dixi,iy-diyi,iz-dizi,iw-diwi)) + enddo + endif +enddo; enddo; enddo; enddo +a=b +end subroutine dibetax4 + +!===================================================================== [dibeta] +subroutine vdibeta1(nv,kx,lx,mx,nx, nfil,dixs,hss,a,ff,ix) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv,kx,lx,mx,nx, nfil +integer(fpi),dimension(lx:mx),intent(in ):: dixs +real(dp), dimension(lx:mx),intent(in ):: hss +real(dp), dimension(nv,kx:nx),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx) :: b +real(dp) :: fili +integer(spi) :: h,i,dix,dixi +!============================================================================== +b=u0 +do ix=lx,mx + dix=dixs(ix) + if(dix==0)then; b(:,ix)=a(:,ix) + else + call blinfil(nfil,hss(ix),h,fil,ff); if(ff)return + b(:,ix)=fil(0)*a(:,ix) + do i=1,h + fili=fil(i); dixi=dix*i + b(:,ix)=b(:,ix)+fili*(a(:,ix+dixi)+a(:,ix-dixi)) + enddo + endif +enddo +a=b +end subroutine vdibeta1 +!===================================================================== [dibeta] +subroutine vdibeta2(nv, kx,lx,mx,nx, ky,ly,my,ny, nfil, & + dixs,diys,hss, a, ff,ix,iy) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv, & + kx,lx,mx,nx,& + ky,ly,my,ny,& + nfil +integer(fpi),dimension(lx:mx,ly:my),intent(in ):: dixs,diys +real(dp), dimension(lx:mx,ly:my),intent(in ):: hss +real(dp), dimension(nv,kx:nx,ky:ny),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx,ky:ny):: b +real(dp) :: fili +integer(spi) :: h,i,dix,diy,dixi,diyi +!============================================================================== +b=u0 +do iy=ly,my; do ix=lx,mx + dix=dixs(ix,iy); diy=diys(ix,iy) + if(abs(dix)+abs(diy)==0)then;b(:,ix,iy)=a(:,ix,iy) + else + call blinfil(nfil,hss(ix,iy),h,fil,ff); if(ff)return + b(:,ix,iy)=fil(0)*a(:,ix,iy) + do i=1,h + fili=fil(i); dixi=dix*i; diyi=diy*i + b(:,ix,iy)=b(:,ix,iy)+fili* & + (a(:,ix+dixi,iy+diyi)+a(:,ix-dixi,iy-diyi)) + enddo + endif +enddo; enddo +a=b +end subroutine vdibeta2 +!===================================================================== [dibeta] +subroutine vdibeta3(nv, kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, nfil, & + dixs,diys,dizs,hss, a, ff,ix,iy,iz) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv, & + kx,lx,mx,nx,& + ky,ly,my,ny,& + kz,lz,mz,nz,& + nfil +integer(fpi),dimension(lx:mx,ly:my,lz:mz),intent(in ):: dixs,diys,dizs +real(dp), dimension(lx:mx,ly:my,lz:mz),intent(in ):: hss +real(dp), dimension(nv,kx:nx,ky:ny,kz:nz),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz):: b +real(dp) :: fili +integer(spi) :: h,i, & + dix,diy,diz, & + dixi,diyi,dizi +!============================================================================== +b=u0 +do iz=lz,mz; do iy=ly,my; do ix=lx,mx + dix=dixs(ix,iy,iz); diy=diys(ix,iy,iz); diz=dizs(ix,iy,iz) + if(abs(dix)+abs(diy)+abs(diz)==0)then;b(:,ix,iy,iz)=a(:,ix,iy,iz) + else + call blinfil(nfil,hss(ix,iy,iz),h,fil,ff); if(ff)return + b(:,ix,iy,iz)=fil(0)*a(:,ix,iy,iz) + do i=1,h + fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i + b(:,ix,iy,iz)=b(:,ix,iy,iz)+fili* & + (a(:,ix+dixi,iy+diyi,iz+dizi)& + +a(:,ix-dixi,iy-diyi,iz-dizi)) + enddo + endif +enddo; enddo; enddo +a=b +end subroutine vdibeta3 +!===================================================================== [dibeta] +subroutine vdibeta4(nv, kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, & + nfil, dixs,diys,dizs,diws,hss, a, ff,ix,iy,iz,iw) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv, & + kx,lx,mx,nx,& + ky,ly,my,ny,& + kz,lz,mz,nz,& + kw,lw,mw,nw,& + nfil +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: dixs,diys,& + dizs,diws +real(dp), dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: hss +real(dp), dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz,iw +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw):: b +real(dp) :: fili +integer(spi) :: h,i, & + dix,diy,diz,diw, & + dixi,diyi,dizi,diwi +!============================================================================== +b=u0 +do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx + dix=dixs(ix,iy,iz,iw);diy=diys(ix,iy,iz,iw) + diz=dizs(ix,iy,iz,iw);diw=diws(ix,iy,iz,iw) + if(abs(dix)+abs(diy)+abs(diz)+abs(diw)==0)then + b(:,ix,iy,iz,iw)=a(:,ix,iy,iz,iw) + else + call blinfil(nfil,hss(ix,iy,iz,iw),h,fil,ff); if(ff)return + b(:,ix,iy,iz,iw)=fil(0)*a(:,ix,iy,iz,iw) + do i=1,h + fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i + b(:,ix,iy,iz,iw)=b(:,ix,iy,iz,iw)+fili* & + (a(:,ix+dixi,iy+diyi,iz+dizi,iw+diwi)& + +a(:,ix-dixi,iy-diyi,iz-dizi,iw-diwi)) + enddo + endif +enddo; enddo; enddo; enddo +a=b +end subroutine vdibeta4 + +!===================================================================== [dibeta] +subroutine vdibetax3(nv,kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, icol,nfil,& + qcols,dixs,diys,dizs, jcol,hss,a, ff,ix,iy,iz) +!============================================================================= +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv, & + kx,lx,mx,nx, & + ky,ly,my,ny, & + kz,lz,mz,nz, & + icol,nfil +integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz),intent(in ):: qcols +integer(fpi),dimension(lx:mx,ly:my,lz:mz,6), intent(in ):: dixs,diys,dizs +integer(fpi),dimension(lx:mx,ly:my,lz:mz), intent(inout):: jcol +real(dp),dimension(6,lx:mx,ly:my,lz:mz), intent(in ):: hss +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz), intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz):: b +real(dp) :: fili,hs +integer(spi) :: h,i, & + dix,diy,diz, & + dixi,diyi,dizi +integer(fpi) :: j +!============================================================================== +b=u0 +if(icol==1)jcol=1 +do iz=lz,mz; do iy=ly,my; do ix=lx,mx + j=jcol(ix,iy,iz) + if(icol/=qcols(j,ix,iy,iz))then + b(:,ix,iy,iz)=a(:,ix,iy,iz) + cycle + else + jcol(ix,iy,iz)=j+1_fpi + dix=dixs(ix,iy,iz,j); diy=diys(ix,iy,iz,j); diz=dizs(ix,iy,iz,j) + hs=hss(j,ix,iy,iz) + call blinfil(nfil,hs,h,fil,ff); if(ff)return + b(:,ix,iy,iz)=fil(0)*a(:,ix,iy,iz) + do i=1,h + fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i + b(:,ix,iy,iz)=b(:,ix,iy,iz)+fili* & + (a(:,ix+dixi,iy+diyi,iz+dizi)& + +a(:,ix-dixi,iy-diyi,iz-dizi)) + enddo + endif +enddo; enddo; enddo +a=b +end subroutine vdibetax3 +!===================================================================== [dibeta] +subroutine vdibetax4(nv,kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, & + icol,nfil,& + qcols,dixs,diys,dizs,diws, jcol,hss,a, ff,ix,iy,iz,iw) +!============================================================================= +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv, & + kx,lx,mx,nx, & + ky,ly,my,ny, & + kz,lz,mz,nz, & + kw,lw,mw,nw, & + icol,nfil +integer(fpi),dimension(0:11,lx:mx,ly:my,lz:mz,lw:mw),& + intent(in ):: qcols +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw,10),& + intent(in ):: dixs,diys,& + dizs,diws +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(inout):: jcol +real(dp),dimension(10,lx:mx,ly:my,lz:mz,lw:mw), intent(in ):: hss +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw), intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz,iw +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw):: b +real(dp) :: fili,hs +integer(spi) :: h,i, & + dix,diy,diz,diw, & + dixi,diyi,dizi,diwi +integer(fpi) :: j +!============================================================================== +b=u0 +if(icol==1)jcol=1 +do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx + j=jcol(ix,iy,iz,iw) + if(icol/=qcols(j,ix,iy,iz,iw))then + b(:,ix,iy,iz,iw)=a(:,ix,iy,iz,iw) + cycle + else + jcol(ix,iy,iz,iw)=j+1_fpi + dix=dixs(ix,iy,iz,iw,j); diy=diys(ix,iy,iz,iw,j) + diz=dizs(ix,iy,iz,iw,j); diw=diws(ix,iy,iz,iw,j) + hs=hss(j,ix,iy,iz,iw) + call blinfil(nfil,hs,h,fil,ff); if(ff)return + b(:,ix,iy,iz,iw)=fil(0)*a(:,ix,iy,iz,iw) + do i=1,h + fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i + b(:,ix,iy,iz,iw)=b(:,ix,iy,iz,iw)+fili* & + (a(:,ix+dixi,iy+diyi,iz+dizi,iw+diwi)& + +a(:,ix-dixi,iy-diyi,iz-dizi,iw-diwi)) + enddo + endif +enddo; enddo; enddo; enddo +a=b +end subroutine vdibetax4 + +!--- The following routine share the interface, dibetat: + +!==================================================================== [dibetat] +subroutine dibeta1t(kx,lx,mx,nx, nfil, dixs,hss, a, ff,ix) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx,nfil +integer(fpi),dimension(lx:mx),intent(in ):: dixs +real(dp), dimension(lx:mx),intent(in ):: hss +real(dp), dimension(kx:nx),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil):: fil +real(dp),dimension(kx:nx) :: b +real(dp) :: filiat,at +integer(spi) :: h,i,dix,dixi +!============================================================================== +b=u0 +do ix=lx,mx + at=a(ix) + dix=dixs(ix) + if(dix==0)then;b(ix)=b(ix)+at + else + call blinfil(nfil,hss(ix),h,fil,ff); if(ff)return + b(ix)=b(ix)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i + b(ix+dixi)=b(ix+dixi)+filiat + b(ix-dixi)=b(ix-dixi)+filiat + enddo + endif +enddo +a=b +end subroutine dibeta1t +!==================================================================== [dibetat] +subroutine dibeta2t(kx,lx,mx,nx, ky,ly,my,ny, & + nfil, dixs,diys,hss, a, ff,ix,iy) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx,& + ky,ly,my,ny,& + nfil +integer(fpi),dimension(lx:mx,ly:my),intent(in ):: dixs,diys +real(dp), dimension(lx:mx,ly:my),intent(in ):: hss +real(dp), dimension(kx:nx,ky:ny),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(kx:nx,ky:ny):: b +real(dp) :: filiat,at +integer(spi) :: h,i,dix,diy,dixi,diyi +!============================================================================== +b=u0 +do iy=ly,my; do ix=lx,mx + at=a(ix,iy) + dix=dixs(ix,iy); diy=diys(ix,iy) + if(abs(dix)+abs(diy)==0)then;b(ix,iy)=b(ix,iy)+at + else + call blinfil(nfil,hss(ix,iy),h,fil,ff); if(ff)return + b(ix,iy)=b(ix,iy)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i; diyi=diy*i + b(ix+dixi,iy+diyi)=b(ix+dixi,iy+diyi)+filiat + b(ix-dixi,iy-diyi)=b(ix-dixi,iy-diyi)+filiat + enddo + endif +enddo; enddo +a=b +end subroutine dibeta2t +!==================================================================== [dibetat] +subroutine dibeta3t(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, & + nfil, dixs,diys,dizs,hss, a, ff,ix,iy,iz) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx,& + ky,ly,my,ny,& + kz,lz,mz,nz,& + nfil +integer(fpi),dimension(lx:mx,ly:my,lz:mz),intent(in ):: dixs,diys,dizs +real(dp), dimension(lx:mx,ly:my,lz:mz),intent(in ):: hss +real(dp), dimension(kx:nx,ky:ny,kz:nz),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(kx:nx,ky:ny,kz:nz):: b +real(dp) :: filiat,at +integer(spi) :: h,i, & + dix,diy,diz,& + dixi,diyi,dizi +!============================================================================== +b=u0 +do iz=lz,mz; do iy=ly,my; do ix=lx,mx + at=a(ix,iy,iz) + dix=dixs(ix,iy,iz); diy=diys(ix,iy,iz); diz=dizs(ix,iy,iz) + if(abs(dix)+abs(diy)+abs(diz)==0)then;b(ix,iy,iz)=b(ix,iy,iz)+at + else + call blinfil(nfil,hss(ix,iy,iz),h,fil,ff); if(ff)return + b(ix,iy,iz)=b(ix,iy,iz)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i + b(ix+dixi,iy+diyi,iz+dizi)=b(ix+dixi,iy+diyi,iz+dizi)+filiat + b(ix-dixi,iy-diyi,iz-dizi)=b(ix-dixi,iy-diyi,iz-dizi)+filiat + enddo + endif +enddo; enddo; enddo +a=b +end subroutine dibeta3t + +!==================================================================== [dibetat] +subroutine dibeta4t(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, & + nfil,dixs,diys,dizs,diws,hss, a,ff,ix,iy,iz,iw) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx,& + ky,ly,my,ny,& + kz,lz,mz,nz,& + kw,lw,mw,nw,& + nfil +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: dixs,diys,& + dizs,diws +real(dp), dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: hss +real(dp), dimension(kx:nx,ky:ny,kz:nz,kw:nw),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz,iw +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(kx:nx,ky:ny,kz:nz,kw:nw):: b +real(dp) :: filiat,at +integer(spi) :: h,i, & + dix,diy,diz,diw, & + dixi,diyi,dizi,diwi +!============================================================================== +b=u0 +do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx + at=a(ix,iy,iz,iw) + dix=dixs(ix,iy,iz,iw); diy=diys(ix,iy,iz,iw) + diz=dizs(ix,iy,iz,iw); diw=diws(ix,iy,iz,iw) + if(abs(dix)+abs(diy)+abs(diz)+abs(diw)==0)then + b(ix,iy,iz,iw)=b(ix,iy,iz,iw)+at + else + call blinfil(nfil,hss(ix,iy,iz,iw),h,fil,ff); if(ff)return + b(ix,iy,iz,iw)=b(ix,iy,iz,iw)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i + b(ix+dixi,iy+diyi,iz+dizi,iw+diwi)= & + b(ix+dixi,iy+diyi,iz+dizi,iw+diwi)+filiat + b(ix-dixi,iy-diyi,iz-dizi,iw-diwi)= & + b(ix-dixi,iy-diyi,iz-dizi,iw-diwi)+filiat + enddo + endif +enddo; enddo; enddo; enddo +a=b +end subroutine dibeta4t + +!==================================================================== [dibetat] +subroutine dibetax3t(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, icol,nfil,& + qcols,dixs,diys,dizs, jcol,hss,a, ff,ix,iy,iz) +!============================================================================= +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx, & + ky,ly,my,ny, & + kz,lz,mz,nz, & + icol,nfil +integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz),intent(in ):: qcols +integer(fpi),dimension(lx:mx,ly:my,lz:mz,6), intent(in ):: dixs,diys,dizs +integer(fpi),dimension(lx:mx,ly:my,lz:mz), intent(inout):: jcol +real(dp),dimension(6,lx:mx,ly:my,lz:mz), intent(in ):: hss +real(dp),dimension(kx:nx,ky:ny,kz:nz), intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(kx:nx,ky:ny,kz:nz):: b +real(dp) :: filiat,hs,at +integer(spi) :: h,i, & + dix,diy,diz, & + dixi,diyi,dizi +integer(fpi) :: j +!============================================================================== +b=u0 +if(icol==7)jcol=6 +do iz=lz,mz; do iy=ly,my; do ix=lx,mx + at=a(ix,iy,iz) + j=jcol(ix,iy,iz) + if(icol/=qcols(j,ix,iy,iz))then + b(ix,iy,iz)=b(ix,iy,iz)+at + cycle + else + jcol(ix,iy,iz)=j-1_fpi + dix=dixs(ix,iy,iz,j); diy=diys(ix,iy,iz,j); diz=dizs(ix,iy,iz,j) + hs=hss(j,ix,iy,iz) + call blinfil(nfil,hs,h,fil,ff); if(ff)return + b(ix,iy,iz)=b(ix,iy,iz)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i + b(ix+dixi,iy+diyi,iz+dizi)=b(ix+dixi,iy+diyi,iz+dizi)+filiat + b(ix-dixi,iy-diyi,iz-dizi)=b(ix-dixi,iy-diyi,iz-dizi)+filiat + enddo + endif +enddo; enddo; enddo +a=b +end subroutine dibetax3t + +!==================================================================== [dibetat] +subroutine dibetax4t(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, & + icol,nfil,& + qcols,dixs,diys,dizs,diws, jcol,hss,a, ff,ix,iy,iz,iw) +!============================================================================= +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx, & + ky,ly,my,ny, & + kz,lz,mz,nz, & + kw,lw,mw,nw, & + icol,nfil +integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: qcols +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw,6), intent(in ):: dixs,diys,& + dizs,diws +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw), intent(inout):: jcol +real(dp),dimension(6,lx:mx,ly:my,lz:mz,lw:mw), intent(in ):: hss +real(dp),dimension(kx:nx,ky:ny,kz:nz,kw:nw), intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz,iw +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(kx:nx,ky:ny,kz:nz,kw:nw):: b +real(dp) :: filiat,hs,at +integer(spi) :: h,i, & + dix,diy,diz,diw, & + dixi,diyi,dizi,diwi +integer(fpi) :: j +!============================================================================== +b=u0 +if(icol==15)jcol=10 +do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx + at=a(ix,iy,iz,iw) + j=jcol(ix,iy,iz,iw) + if(icol/=qcols(j,ix,iy,iz,iw))then + b(ix,iy,iz,iw)=b(ix,iy,iz,iw)+at + cycle + else + jcol(ix,iy,iz,iw)=j-1_fpi + dix=dixs(ix,iy,iz,iw,j); diy=diys(ix,iy,iz,iw,j) + diz=dizs(ix,iy,iz,iw,j); diw=diws(ix,iy,iz,iw,j) + hs=hss(j,ix,iy,iz,iw) + call blinfil(nfil,hs,h,fil,ff); if(ff)return + b(ix,iy,iz,iw)=b(ix,iy,iz,iw)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i + b(ix+dixi,iy+diyi,iz+dizi,iw+diwi)= & + b(ix+dixi,iy+diyi,iz+dizi,iw+diwi)+filiat + b(ix-dixi,iy-diyi,iz-dizi,iw-diwi)= & + b(ix-dixi,iy-diyi,iz-dizi,iw-diwi)+filiat + enddo + endif +enddo; enddo; enddo; enddo +a=b +end subroutine dibetax4t + +!==================================================================== [dibetat] +subroutine vdibeta1t(nv,kx,lx,mx,nx, nfil, dixs,hss, a, ff,ix) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv,kx,lx,mx,nx,nfil +integer(fpi),dimension(lx:mx),intent(in ):: dixs +real(dp), dimension(lx:mx),intent(in ):: hss +real(dp), dimension(nv,kx:nx),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx):: b +real(dp),dimension(nv) :: filiat,at +integer(spi) :: h,i,dix,dixi +!============================================================================== +b=u0 +do ix=lx,mx + at=a(:,ix) + dix=dixs(ix) + if(dix==0)then;b(:,ix)=b(:,ix)+at + else + call blinfil(nfil,hss(ix),h,fil,ff); if(ff)return + b(:,ix)=b(:,ix)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i + b(:,ix+dixi)=b(:,ix+dixi)+filiat + b(:,ix-dixi)=b(:,ix-dixi)+filiat + enddo + endif +enddo +a=b +end subroutine vdibeta1t +!==================================================================== [dibetat] +subroutine vdibeta2t(nv, kx,lx,mx,nx, ky,ly,my,ny, & + nfil, dixs,diys,hss, a, ff,ix,iy) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv,& + kx,lx,mx,nx,& + ky,ly,my,ny,& + nfil +integer(fpi),dimension(lx:mx,ly:my),intent(in ):: dixs,diys +real(dp), dimension(lx:mx,ly:my),intent(in ):: hss +real(dp), dimension(nv,kx:nx,ky:ny),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx,ky:ny):: b +real(dp),dimension(nv) :: filiat,at +integer(spi) :: h,i,dix,diy,dixi,diyi +!============================================================================== +b=u0 +do iy=ly,my; do ix=lx,mx + at=a(:,ix,iy) + dix=dixs(ix,iy); diy=diys(ix,iy) + if(abs(dix)+abs(diy)==0)then;b(:,ix,iy)=b(:,ix,iy)+at + else + call blinfil(nfil,hss(ix,iy),h,fil,ff); if(ff)return + b(:,ix,iy)=b(:,ix,iy)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i; diyi=diy*i + b(:,ix+dixi,iy+diyi)=b(:,ix+dixi,iy+diyi)+filiat + b(:,ix-dixi,iy-diyi)=b(:,ix-dixi,iy-diyi)+filiat + enddo + endif +enddo; enddo +a=b +end subroutine vdibeta2t +!==================================================================== [dibetat] +subroutine vdibeta3t(nv, kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, & + nfil, dixs,diys,dizs,hss, a, ff,ix,iy,iz) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv, & + kx,lx,mx,nx,& + ky,ly,my,ny,& + kz,lz,mz,nz,& + nfil +integer(fpi),dimension(lx:mx,ly:my,lz:mz),intent(in ):: dixs,diys,dizs +real(dp), dimension(lx:mx,ly:my,lz:mz),intent(in ):: hss +real(dp), dimension(nv,kx:nx,ky:ny,kz:nz),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz):: b +real(dp),dimension(nv) :: filiat,at +integer(spi) :: h,i, & + dix,diy,diz,& + dixi,diyi,dizi +!============================================================================== +b=u0 +do iz=lz,mz; do iy=ly,my; do ix=lx,mx + at=a(:,ix,iy,iz) + dix=dixs(ix,iy,iz); diy=diys(ix,iy,iz); diz=dizs(ix,iy,iz) + if(abs(dix)+abs(diy)+abs(diz)==0)then;b(:,ix,iy,iz)=b(:,ix,iy,iz)+at + else + call blinfil(nfil, hss(ix,iy,iz),h,fil,ff); if(ff)return + b(:,ix,iy,iz)=b(:,ix,iy,iz)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i + b(:,ix+dixi,iy+diyi,iz+dizi)=b(:,ix+dixi,iy+diyi,iz+dizi)+filiat + b(:,ix-dixi,iy-diyi,iz-dizi)=b(:,ix-dixi,iy-diyi,iz-dizi)+filiat + enddo + endif +enddo; enddo; enddo +a=b +end subroutine vdibeta3t +!==================================================================== [dibetat] +subroutine vdibeta4t(nv, kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, & + nfil, dixs,diys,dizs,diws,hss, a,ff,ix,iy,iz,iw) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv, & + kx,lx,mx,nx,& + ky,ly,my,ny,& + kz,lz,mz,nz,& + kw,lw,mw,nw,& + nfil +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: dixs,diys,& + dizs,diws +real(dp), dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: hss +real(dp), dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz,iw +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw):: b +real(dp),dimension(nv) :: filiat,at +integer(spi) :: h,i, & + dix,diy,diz,diw, & + dixi,diyi,dizi,diwi +!============================================================================== +b=u0 +do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx + at=a(:,ix,iy,iz,iw) + dix=dixs(ix,iy,iz,iw); diy=diys(ix,iy,iz,iw) + diz=dizs(ix,iy,iz,iw); diw=diws(ix,iy,iz,iw) + if(abs(dix)+abs(diy)+abs(diz)+abs(diw)==0)then + b(:,ix,iy,iz,iw)=b(:,ix,iy,iz,iw)+at + else + call blinfil(nfil, hss(ix,iy,iz,iw),h,fil,ff); if(ff)return + b(:,ix,iy,iz,iw)=b(:,ix,iy,iz,iw)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i + b(:,ix+dixi,iy+diyi,iz+dizi,iw+diwi)= & + b(:,ix+dixi,iy+diyi,iz+dizi,iw+diwi)+filiat + b(:,ix-dixi,iy-diyi,iz-dizi,iw-diwi)= & + b(:,ix-dixi,iy-diyi,iz-dizi,iw-diwi)+filiat + enddo + endif +enddo; enddo; enddo; enddo +a=b +end subroutine vdibeta4t + +!==================================================================== [dibetat] +subroutine vdibetax3t(nv,kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, icol,nfil,& + qcols,dixs,diys,dizs, jcol,hss,a, ff,ix,iy,iz) +!============================================================================= +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv, & + kx,lx,mx,nx, & + ky,ly,my,ny, & + kz,lz,mz,nz, & + icol,nfil +integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz),intent(in ):: qcols +integer(fpi),dimension(lx:mx,ly:my,lz:mz,6), intent(in ):: dixs,diys,dizs +integer(fpi),dimension(lx:mx,ly:my,lz:mz), intent(inout):: jcol +real(dp),dimension(6,lx:mx,ly:my,lz:mz), intent(in ):: hss +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz), intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz):: b +real(dp),dimension(nv) :: filiat,at +real(dp) :: hs +integer(spi) :: h,i, & + dix,diy,diz, & + dixi,diyi,dizi +integer(fpi) :: j +!============================================================================== +b=u0 +if(icol==7)jcol=6 +do iz=lz,mz; do iy=ly,my; do ix=lx,mx + at=a(:,ix,iy,iz) + j=jcol(ix,iy,iz) + if(icol/=qcols(j,ix,iy,iz))then + b(:,ix,iy,iz)=b(:,ix,iy,iz)+at + cycle + else + jcol(ix,iy,iz)=j-1_fpi + dix=dixs(ix,iy,iz,j); diy=diys(ix,iy,iz,j); diz=dizs(ix,iy,iz,j) + hs=hss(j,ix,iy,iz) + call blinfil(nfil,hs,h,fil,ff); if(ff)return + b(:,ix,iy,iz)=b(:,ix,iy,iz)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i + b(:,ix+dixi,iy+diyi,iz+dizi)=b(:,ix+dixi,iy+diyi,iz+dizi)+filiat + b(:,ix-dixi,iy-diyi,iz-dizi)=b(:,ix-dixi,iy-diyi,iz-dizi)+filiat + enddo + endif +enddo; enddo; enddo +a=b +end subroutine vdibetax3t + +!==================================================================== [dibetat] +subroutine vdibetax4t(nv,kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, & + icol,nfil,& + qcols,dixs,diys,dizs,diws, jcol,hss,a, ff,ix,iy,iz,iw) +!============================================================================= +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv, & + kx,lx,mx,nx, & + ky,ly,my,ny, & + kz,lz,mz,nz, & + kw,lw,mw,nw, & + icol,nfil +integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: qcols +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw,6), intent(in ):: dixs,diys,& + dizs,diws +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw), intent(inout):: jcol +real(dp),dimension(6,lx:mx,ly:my,lz:mz,lw:mw), intent(in ):: hss +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw), intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz,iw +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw):: b +real(dp),dimension(nv) :: filiat,at +real(dp) :: hs +integer(spi) :: h,i, & + dix,diy,diz,diw, & + dixi,diyi,dizi,diwi +integer(fpi) :: j +!============================================================================== +b=u0 +if(icol==15)jcol=10 +do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx + at=a(:,ix,iy,iz,iw) + j=jcol(ix,iy,iz,iw) + if(icol/=qcols(j,ix,iy,iz,iw))then + b(:,ix,iy,iz,iw)=b(:,ix,iy,iz,iw)+at + cycle + else + jcol(ix,iy,iz,iw)=j-1_fpi + dix=dixs(ix,iy,iz,iw,j); diy=diys(ix,iy,iz,iw,j) + diz=dizs(ix,iy,iz,iw,j); diw=diws(ix,iy,iz,iw,j) + hs=hss(j,ix,iy,iz,iw) + call blinfil(nfil,hs,h,fil,ff); if(ff)return + b(:,ix,iy,iz,iw)=b(:,ix,iy,iz,iw)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i + b(:,ix+dixi,iy+diyi,iz+dizi,iw+diwi)= & + b(:,ix+dixi,iy+diyi,iz+dizi,iw+diwi)+filiat + b(:,ix-dixi,iy-diyi,iz-dizi,iw-diwi)= & + b(:,ix-dixi,iy-diyi,iz-dizi,iw-diwi)+filiat + enddo + endif +enddo; enddo; enddo; enddo +a=b +end subroutine vdibetax4t + +end module jp_pbfil3 + +!# diff --git a/src/mgbf/jp_pietc.f90 b/src/mgbf/jp_pietc.f90 new file mode 100644 index 0000000000..b102d22b7a --- /dev/null +++ b/src/mgbf/jp_pietc.f90 @@ -0,0 +1,111 @@ +module jp_pietc +!$$$ module documentation block +! . . . . +! module: jp_pietc +! prgmmr: purser org: NOAA/EMC date: 2014 +! +! abstract: Some of the commonly used constants (pi etc) +! mainly for double-precision subroutines. +! +! module history log: +! +! Subroutines Included: +! +! Functions Included: +! +! remarks: +! ms10 etc are needed to satisfy the some (eg., gnu fortran) compilers' +! more rigorous standards regarding the way "data" statements are initialized. +! Zero and the first few units are u0,u1,u2, etc., their reciprocals being, +! o2,o3 etc and their square roots, r2,r3. Reciprocal roots are or2,or3 etc. +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +use jp_pkind, only: dp,dpc +implicit none +logical ,parameter:: T=.true.,F=.false. !<- for pain-relief in logical ops +real(dp),parameter:: & + u0=0,u1=1,mu1=-u1,u2=2,mu2=-u2,u3=3,mu3=-u3,u4=4,mu4=-u4,u5=5,mu5=-u5, & + u6=6,mu6=-u6,o2=u1/2,o3=u1/3,o4=u1/4,o5=u1/5,o6=u1/6, & + pi =3.1415926535897932384626433832795028841971693993751058209749e0_dp, & + pi2=6.2831853071795864769252867665590057683943387987502116419498e0_dp, & + pih=1.5707963267948966192313216916397514420985846996875529104874e0_dp, & + rpi=1.7724538509055160272981674833411451827975494561223871282138e0_dp, & +! Important square-roots + r2 =1.4142135623730950488016887242096980785696718753769480731766e0_dp, & + r3 =1.7320508075688772935274463415058723669428052538103806280558e0_dp, & + r5 =2.2360679774997896964091736687312762354406183596115257242708e0_dp, & + or2=u1/r2,or3=u1/r3,or5=u1/r5, & +! Golden number: + phi=1.6180339887498948482045868343656381177203091798057628621354e0_dp, & +! Euler-Mascheroni constant: + euler=0.57721566490153286060651209008240243104215933593992359880e0_dp, & +! Degree to radians; radians to degrees: + dtor=pi/180,rtod=180/pi, & +! Sines of all main fractions of 90 degrees (down to ninths): + s10=.173648177666930348851716626769314796000375677184069387236241e0_dp,& + s11=.195090322016128267848284868477022240927691617751954807754502e0_dp,& + s13=.222520933956314404288902564496794759466355568764544955311987e0_dp,& + s15=.258819045102520762348898837624048328349068901319930513814003e0_dp,& + s18=.309016994374947424102293417182819058860154589902881431067724e0_dp,& + s20=.342020143325668733044099614682259580763083367514160628465048e0_dp,& + s22=.382683432365089771728459984030398866761344562485627041433800e0_dp,& + s26=.433883739117558120475768332848358754609990727787459876444547e0_dp,& + s30=o2, & + s34=.555570233019602224742830813948532874374937190754804045924153e0_dp,& + s36=.587785252292473129168705954639072768597652437643145991072272e0_dp,& + s39=.623489801858733530525004884004239810632274730896402105365549e0_dp,& + s40=.642787609686539326322643409907263432907559884205681790324977e0_dp,& + s45=or2, & + s50=.766044443118978035202392650555416673935832457080395245854045e0_dp,& + s51=.781831482468029808708444526674057750232334518708687528980634e0_dp,& + s54=.809016994374947424102293417182819058860154589902881431067724e0_dp,& + s56=.831469612302545237078788377617905756738560811987249963446124e0_dp,& + s60=r3*o2, & + s64=.900968867902419126236102319507445051165919162131857150053562e0_dp,& + s68=.923879532511286756128183189396788286822416625863642486115097e0_dp,& + s70=.939692620785908384054109277324731469936208134264464633090286e0_dp,& + s72=.951056516295153572116439333379382143405698634125750222447305e0_dp,& + s75=.965925826289068286749743199728897367633904839008404550402343e0_dp,& + s77=.974927912181823607018131682993931217232785800619997437648079e0_dp,& + s79=.980785280403230449126182236134239036973933730893336095002916e0_dp,& + s80=.984807753012208059366743024589523013670643251719842418790025e0_dp,& +! ... and their minuses: + ms10=-s10,ms11=-s11,ms13=-s13,ms15=-s15,ms18=-s18,ms20=-s20,ms22=-s22,& + ms26=-s26,ms30=-s30,ms34=-s34,ms36=-s36,ms39=-s39,ms40=-s40,ms45=-s45,& + ms50=-s50,ms51=-s51,ms54=-s54,ms56=-s56,ms60=-s60,ms64=-s64,ms68=-s68,& + ms70=-s70,ms72=-s72,ms75=-s75,ms77=-s77,ms79=-s79,ms80=-s80 + +complex(dpc),parameter:: & + c0=(u0,u0),c1=(u1,u0),mc1=-c1,ci=(u0,u1),mci=-ci,cipi=ci*pi, & +! Main fractional rotations, as unimodualr complex numbers: + z000=c1 ,z010=( s80,s10),z011=( s79,s11),z013=( s77,s13),& + z015=( s75,s15),z018=( s72,s18),z020=( s70,s20),z022=( s68,s22),& + z026=( s64,s26),z030=( s60,s30),z034=( s56,s34),z036=( s54,s36),& + z039=( s51,s39),z040=( s50,s40),z045=( s45,s45),z050=( s40,s50),& + z051=( s39,s51),z054=( s36,s54),z056=( s34,s56),z060=( s30,s60),& + z064=( s26,s64),z068=( s22,s68),z070=( s20,s70),z072=( s18,s72),& + z075=( s15,s75),z077=( s13,s77),z079=( s11,s79),z080=( s10,s80),& + z090=ci, z100=(ms10,s80),z101=(ms11,s79),z103=(ms13,s77),& + z105=(ms15,s75),z108=(ms18,s72),z110=(ms20,s70),z112=(ms22,s68),& + z116=(ms26,s64),z120=(ms30,s60),z124=(ms34,s56),z126=(ms36,s54),& + z129=(ms39,s51),z130=(ms40,s50),z135=(ms45,s45),z140=(ms50,s40),& + z141=(ms51,s39),z144=(ms54,s36),z146=(ms56,s34),z150=(ms60,s30),& + z154=(ms64,s26),z158=(ms68,s22),z160=(ms70,s20),z162=(ms72,s18),& + z165=(ms75,s15),z167=(ms77,s13),z169=(ms79,s11),z170=(ms80,s10),& + z180=-z000,z190=-z010,z191=-z011,z193=-z013,z195=-z015,z198=-z018,& + z200=-z020,z202=-z022,z206=-z026,z210=-z030,z214=-z034,z216=-z036,& + z219=-z039,z220=-z040,z225=-z045,z230=-z050,z231=-z051,z234=-z054,& + z236=-z056,z240=-z060,z244=-z064,z248=-z068,z250=-z070,z252=-z072,& + z255=-z075,z257=-z077,z259=-z079,z260=-z080,z270=-z090,z280=-z100,& + z281=-z101,z283=-z103,z285=-z105,z288=-z108,z290=-z110,z292=-z112,& + z296=-z116,z300=-z120,z304=-z124,z306=-z126,z309=-z129,z310=-z130,& + z315=-z135,z320=-z140,z321=-z141,z324=-z144,z326=-z146,z330=-z150,& + z334=-z154,z338=-z158,z340=-z160,z342=-z162,z345=-z165,z347=-z167,& + z349=-z169,z350=-z170 +end module jp_pietc diff --git a/src/mgbf/jp_pietc_s.f90 b/src/mgbf/jp_pietc_s.f90 new file mode 100644 index 0000000000..8f3097225b --- /dev/null +++ b/src/mgbf/jp_pietc_s.f90 @@ -0,0 +1,113 @@ +module jp_pietc_s +!$$$ module documentation block +! . . . . +! module: jp_pietc_s +! prgmmr: purser org: NOAA/EMC date: 2014 +! +! abstract: Some of the commonly used constants (pi etc) +! +! module history log: +! +! Subroutines Included: +! +! Functions Included: +! +! remarks: +! ms10 etc are needed to satisfy the some (eg., gnu fortran) compilers' +! more rigorous standards regarding the way "data" statements are initialized. +! Zero and the first few units are u0,u1,u2, etc., their reciprocals being, +! o2,o3 etc and their square roots, r2,r3. Reciprocal roots are or2,or3 etc. +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +!============================================================================= +use mpi +use jp_pkind, only: sp,spc +implicit none +logical ,parameter:: T=.true.,F=.false. !<- for pain-relief in logical ops +real(sp),parameter:: & + u0=0_sp,u1=1_sp,mu1=-u1,u2=2_sp,mu2=-u2,u3=3_sp,mu3=-u3,u4=4_sp, & + mu4=-u4,u5=5_sp,mu5=-u5,u6=6_sp,mu6=-u6,o2=u1/u2,o3=u1/u3,o4=u1/u4, & + o5=u1/u5,o6=u1/u6,mo2=-o2,mo3=-o3,mo4=-o4,mo5=-o5,mo6=-06, & + pi =3.1415926535897932384626433832795028841971693993751058209749e0_sp, & + pi2=6.2831853071795864769252867665590057683943387987502116419498e0_sp, & + pih=1.5707963267948966192313216916397514420985846996875529104874e0_sp, & + rpi=1.7724538509055160272981674833411451827975494561223871282138e0_sp, & +! Important square-roots + r2 =1.4142135623730950488016887242096980785696718753769480731766e0_sp, & + r3 =1.7320508075688772935274463415058723669428052538103806280558e0_sp, & + r5 =2.2360679774997896964091736687312762354406183596115257242708e0_sp, & + or2=u1/r2,or3=u1/r3,or5=u1/r5, & +! Golden number: + phi=1.6180339887498948482045868343656381177203091798057628621354e0_sp, & +! Euler-Mascheroni constant: + euler=0.57721566490153286060651209008240243104215933593992359880e0_sp, & +! Degree to radians; radians to degrees: + dtor=pi/180,rtod=180/pi, & +! Sines of all main fractions of 90 degrees (down to ninths): + s10=.173648177666930348851716626769314796000375677184069387236241e0_sp,& + s11=.195090322016128267848284868477022240927691617751954807754502e0_sp,& + s13=.222520933956314404288902564496794759466355568764544955311987e0_sp,& + s15=.258819045102520762348898837624048328349068901319930513814003e0_sp,& + s18=.309016994374947424102293417182819058860154589902881431067724e0_sp,& + s20=.342020143325668733044099614682259580763083367514160628465048e0_sp,& + s22=.382683432365089771728459984030398866761344562485627041433800e0_sp,& + s26=.433883739117558120475768332848358754609990727787459876444547e0_sp,& + s30=o2, & + s34=.555570233019602224742830813948532874374937190754804045924153e0_sp,& + s36=.587785252292473129168705954639072768597652437643145991072272e0_sp,& + s39=.623489801858733530525004884004239810632274730896402105365549e0_sp,& + s40=.642787609686539326322643409907263432907559884205681790324977e0_sp,& + s45=or2, & + s50=.766044443118978035202392650555416673935832457080395245854045e0_sp,& + s51=.781831482468029808708444526674057750232334518708687528980634e0_sp,& + s54=.809016994374947424102293417182819058860154589902881431067724e0_sp,& + s56=.831469612302545237078788377617905756738560811987249963446124e0_sp,& + s60=r3*o2, & + s64=.900968867902419126236102319507445051165919162131857150053562e0_sp,& + s68=.923879532511286756128183189396788286822416625863642486115097e0_sp,& + s70=.939692620785908384054109277324731469936208134264464633090286e0_sp,& + s72=.951056516295153572116439333379382143405698634125750222447305e0_sp,& + s75=.965925826289068286749743199728897367633904839008404550402343e0_sp,& + s77=.974927912181823607018131682993931217232785800619997437648079e0_sp,& + s79=.980785280403230449126182236134239036973933730893336095002916e0_sp,& + s80=.984807753012208059366743024589523013670643251719842418790025e0_sp,& +! ... and their minuses: + ms10=-s10,ms11=-s11,ms13=-s13,ms15=-s15,ms18=-s18,ms20=-s20,ms22=-s22,& + ms26=-s26,ms30=-s30,ms34=-s34,ms36=-s36,ms39=-s39,ms40=-s40,ms45=-s45,& + ms50=-s50,ms51=-s51,ms54=-s54,ms56=-s56,ms60=-s60,ms64=-s64,ms68=-s68,& + ms70=-s70,ms72=-s72,ms75=-s75,ms77=-s77,ms79=-s79,ms80=-s80 + +complex(spc),parameter:: & + c0=(u0,u0),c1=(u1,u0),mc1=-c1,ci=(u0,u1),mci=-ci,cipi=ci*pi, & +! Main fractional rotations, as unimodualr complex numbers: + z000=c1 ,z010=( s80,s10),z011=( s79,s11),z013=( s77,s13),& + z015=( s75,s15),z018=( s72,s18),z020=( s70,s20),z022=( s68,s22),& + z026=( s64,s26),z030=( s60,s30),z034=( s56,s34),z036=( s54,s36),& + z039=( s51,s39),z040=( s50,s40),z045=( s45,s45),z050=( s40,s50),& + z051=( s39,s51),z054=( s36,s54),z056=( s34,s56),z060=( s30,s60),& + z064=( s26,s64),z068=( s22,s68),z070=( s20,s70),z072=( s18,s72),& + z075=( s15,s75),z077=( s13,s77),z079=( s11,s79),z080=( s10,s80),& + z090=ci, z100=(ms10,s80),z101=(ms11,s79),z103=(ms13,s77),& + z105=(ms15,s75),z108=(ms18,s72),z110=(ms20,s70),z112=(ms22,s68),& + z116=(ms26,s64),z120=(ms30,s60),z124=(ms34,s56),z126=(ms36,s54),& + z129=(ms39,s51),z130=(ms40,s50),z135=(ms45,s45),z140=(ms50,s40),& + z141=(ms51,s39),z144=(ms54,s36),z146=(ms56,s34),z150=(ms60,s30),& + z154=(ms64,s26),z158=(ms68,s22),z160=(ms70,s20),z162=(ms72,s18),& + z165=(ms75,s15),z167=(ms77,s13),z169=(ms79,s11),z170=(ms80,s10),& + z180=-z000,z190=-z010,z191=-z011,z193=-z013,z195=-z015,z198=-z018,& + z200=-z020,z202=-z022,z206=-z026,z210=-z030,z214=-z034,z216=-z036,& + z219=-z039,z220=-z040,z225=-z045,z230=-z050,z231=-z051,z234=-z054,& + z236=-z056,z240=-z060,z244=-z064,z248=-z068,z250=-z070,z252=-z072,& + z255=-z075,z257=-z077,z259=-z079,z260=-z080,z270=-z090,z280=-z100,& + z281=-z101,z283=-z103,z285=-z105,z288=-z108,z290=-z110,z292=-z112,& + z296=-z116,z300=-z120,z304=-z124,z306=-z126,z309=-z129,z310=-z130,& + z315=-z135,z320=-z140,z321=-z141,z324=-z144,z326=-z146,z330=-z150,& + z334=-z154,z338=-z158,z340=-z160,z342=-z162,z345=-z165,z347=-z167,& + z349=-z169,z350=-z170 +end module jp_pietc_s + diff --git a/src/mgbf/jp_pkind.f90 b/src/mgbf/jp_pkind.f90 new file mode 100644 index 0000000000..cdbf19f4eb --- /dev/null +++ b/src/mgbf/jp_pkind.f90 @@ -0,0 +1,34 @@ +module jp_pkind +!$$$ module documentation block +! . . . . +! module: jp_pkind +! +! abstract: Kinds for single- and double-precision +! +! module history log: +! +! Subroutines Included: +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +integer,parameter:: spi=selected_int_kind(6),& + dpi=selected_int_kind(12),& + sp =selected_real_kind(6,30),& + dp =selected_real_kind(15,300),& + spc=sp,dpc=dp +!private:: one_dpi; integer(8),parameter:: one_dpi=1 +!integer,parameter:: dpi=kind(one_dpi) +!integer,parameter:: sp=kind(1.0) +!integer,parameter:: dp=kind(1.0d0) +!integer,parameter:: spc=kind((1.0,1.0)) +!integer,parameter:: dpc=kind((1.0d0,1.0d0)) +end module jp_pkind diff --git a/src/mgbf/jp_pkind2.f90 b/src/mgbf/jp_pkind2.f90 new file mode 100644 index 0000000000..3dcecc5635 --- /dev/null +++ b/src/mgbf/jp_pkind2.f90 @@ -0,0 +1,25 @@ +module jp_pkind2 +!$$$ module documentation block +! . . . . +! module: jp_pkind2 +! +! abstract: Integer kinds for helf- and fourth-precision integers +! +! module history log: +! +! Subroutines Included: +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +integer,parameter:: hpi=selected_int_kind(3),& + fpi=selected_int_kind(2) +end module jp_pkind2 diff --git a/src/mgbf/jp_pmat.f90 b/src/mgbf/jp_pmat.f90 new file mode 100644 index 0000000000..f139feea06 --- /dev/null +++ b/src/mgbf/jp_pmat.f90 @@ -0,0 +1,1096 @@ +module jp_pmat +!$$$ module documentation block +! . . . . +! module: jp_pmat +! prgmmr: fujita org: NOAA/EMC date: 1993 +! +! abstract: Utility routines for various linear inversions and Cholesky +! +! module history log: +! 2002 purser +! 2009 purser +! 2012 purser +! +! Subroutines Included: +! swpvv - +! inv - +! ldum - +! udlmm - +! l1lm - +! ldlm - +! invu - +! invl - +! +! Functions Included: +! +! remarks: +! Originally, these routines were copies of the purely "inversion" members +! of pmat1.f90 (a most extensive collection of matrix routines -- not just +! inversions). As well as having both single and double precision versions +! of each routine, these versions also make provision for a more graceful +! termination in cases where the system matrix is detected to be +! essentially singular (and therefore noninvertible). This provision takes +! the form of an optional "failure flag", FF, which is normally returned +! as .FALSE., but is returned as .TRUE. when inversion fails. +! In Sep 2012, these routines were collected together into jp_pmat.f90 so +! that all the main matrix routines could be in the same library, jp_pmat.a. +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +use jp_pkind, only: sp,dp,spc,dpc +use jp_pietc, only: t,f +implicit none +private +public:: ldum,udlmm,inv,L1Lm,LdLm,invl,invu +interface swpvv; module procedure sswpvv,dswpvv,cswpvv; end interface +interface ldum + module procedure sldum,dldum,cldum,sldumf,dldumf,cldumf; end interface +interface udlmm + module procedure sudlmm,dudlmm,cudlmm,sudlmv,dudlmv,cudlmv; end interface +interface inv + module procedure & +sinvmt, dinvmt, cinvmt, slinmmt, dlinmmt, clinmmt, slinmvt, dlinmvt, clinmvt, & +sinvmtf,dinvmtf,cinvmtf,slinmmtf,dlinmmtf,clinmmtf,slinmvtf,dlinmvtf,clinmvtf,& +iinvf + end interface +interface L1Lm; module procedure sL1Lm,dL1Lm,sL1Lmf,dL1Lmf; end interface +interface LdLm; module procedure sLdLm,dLdLm,sLdLmf,dLdLmf; end interface +interface invl; module procedure sinvl,dinvl,slinlv,dlinlv; end interface +interface invu; module procedure sinvu,dinvu,slinuv,dlinuv; end interface + +contains + +!============================================================================= +subroutine sswpvv(d,e)! [swpvv] +!============================================================================= +! Swap vectors +!------------- +real(sp), intent(inout) :: d(:), e(:) +real(sp) :: tv(size(d)) +!============================================================================= +tv = d; d = e; e = tv +end subroutine sswpvv +!============================================================================= +subroutine dswpvv(d,e)! [swpvv] +!============================================================================= +real(dp), intent(inout) :: d(:), e(:) +real(dp) :: tv(size(d)) +!============================================================================= +tv = d; d = e; e = tv +end subroutine dswpvv +!============================================================================= +subroutine cswpvv(d,e)! [swpvv] +!============================================================================= +complex(dpc),intent(inout) :: d(:), e(:) +complex(dpc) :: tv(size(d)) +!============================================================================= +tv = d; d = e; e = tv +end subroutine cswpvv + +!============================================================================= +subroutine sinvmt(a)! [inv] +!============================================================================= +real(sp),dimension(:,:),intent(INOUT):: a +logical :: ff +call sinvmtf(a,ff) +if(ff)stop 'In sinvmt; Unable to invert matrix' +end subroutine sinvmt +!============================================================================= +subroutine dinvmt(a)! [inv] +!============================================================================= +real(dp),dimension(:,:),intent(inout):: a +logical :: ff +call dinvmtf(a,ff) +if(ff)stop 'In dinvmt; Unable to invert matrix' +end subroutine dinvmt +!============================================================================= +subroutine cinvmt(a)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(inout):: a +logical :: ff +call cinvmtf(a,ff) +if(ff)stop 'In cinvmt; Unable to invert matrix' +end subroutine cinvmt +!============================================================================= +subroutine sinvmtf(a,ff)! [inv] +!============================================================================= +! Invert matrix (or flag if can't) +!---------------- +real(sp),dimension(:,:),intent(inout):: a +logical, intent( out):: ff +integer :: m,i,j,jp,l +real(sp) :: d +integer,dimension(size(a,1)) :: ipiv +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In sinvmtf; matrix passed to sinvmtf is not square' +! Perform a pivoted L-D-U decomposition on matrix a: +call sldumf(a,ipiv,d,ff) +if(ff)then + print '(" In sinvmtf; failed call to sldumf")' + return +endif + +! Invert upper triangular portion U in place: +do i=1,m; a(i,i)=1./a(i,i); enddo +do i=1,m-1 + do j=i+1,m; a(i,j)=-a(j,j)*dot_product(a(i:j-1,j),a(i,i:j-1)); enddo +enddo + +! Invert lower triangular portion L in place: +do j=1,m-1; jp=j+1 + do i=jp,m; a(i,j)=-a(i,j)-dot_product(a(jp:i-1,j),a(i,jp:i-1)); enddo +enddo + +! Form the product of U**-1 and L**-1 in place +do j=1,m-1; jp=j+1 + do i=1,j; a(i,j)=a(i,j)+dot_product(a(jp:m,j),a(i,jp:m)); enddo + do i=jp,m; a(i,j)=dot_product(a(i:m,j),a(i,i:m)); enddo +enddo + +! Permute columns according to ipiv +do j=m-1,1,-1; l=ipiv(j); call sswpvv(a(:,j),a(:,l)); enddo +end subroutine sinvmtf +!============================================================================= +subroutine dinvmtf(a,ff)! [inv] +!============================================================================= +real(DP),dimension(:,:),intent(INOUT):: a +logical, intent( OUT):: ff +integer :: m,i,j,jp,l +real(DP) :: d +integer, dimension(size(a,1)) :: ipiv +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to dinvmtf is not square' +! Perform a pivoted L-D-U decomposition on matrix a: +call dldumf(a,ipiv,d,ff) +if(ff)then + print '(" In dinvmtf; failed call to dldumf")' + return +endif + +! Invert upper triangular portion U in place: +do i=1,m; a(i,i)=1/a(i,i); enddo +do i=1,m-1 + do j=i+1,m; a(i,j)=-a(j,j)*dot_product(a(i:j-1,j),a(i,i:j-1)); enddo +enddo + +! Invert lower triangular portion L in place: +do j=1,m-1; jp=j+1 + do i=jp,m; a(i,j)=-a(i,j)-dot_product(a(jp:i-1,j),a(i,jp:i-1)); enddo +enddo + +! Form the product of U**-1 and L**-1 in place +do j=1,m-1; jp=j+1 + do i=1,j; a(i,j)=a(i,j)+dot_product(a(jp:m,j),a(i,jp:m)); enddo + do i=jp,m; a(i,j)=dot_product(a(i:m,j),a(i,i:m)); enddo +enddo + +! Permute columns according to ipiv +do j=m-1,1,-1; l=ipiv(j); call dswpvv(a(:,j),a(:,l)); enddo +end subroutine dinvmtf +!============================================================================= +subroutine cinvmtf(a,ff)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(INOUT):: a +logical, intent( OUT):: ff +integer :: m,i,j,jp,l +complex(dpc) :: d +integer, dimension(size(a,1)) :: ipiv +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to cinvmtf is not square' +! Perform a pivoted L-D-U decomposition on matrix a: +call cldumf(a,ipiv,d,ff) +if(ff)then + print '(" In cinvmtf; failed call to cldumf")' + return +endif + +! Invert upper triangular portion U in place: +do i=1,m; a(i,i)=1/a(i,i); enddo +do i=1,m-1 + do j=i+1,m; a(i,j)=-a(j,j)*sum(a(i:j-1,j)*a(i,i:j-1)); enddo +enddo + +! Invert lower triangular portion L in place: +do j=1,m-1; jp=j+1 + do i=jp,m; a(i,j)=-a(i,j)-sum(a(jp:i-1,j)*a(i,jp:i-1)); enddo +enddo + +! Form the product of U**-1 and L**-1 in place +do j=1,m-1; jp=j+1 + do i=1,j; a(i,j)=a(i,j)+sum(a(jp:m,j)*a(i,jp:m)); enddo + do i=jp,m; a(i,j)=sum(a(i:m,j)*a(i,i:m)); enddo +enddo + +! Permute columns according to ipiv +do j=m-1,1,-1; l=ipiv(j); call cswpvv(a(:,j),a(:,l)); enddo +end subroutine cinvmtf + +!============================================================================= +subroutine slinmmt(a,b)! [inv] +!============================================================================= +real(sp),dimension(:,:),intent(inout):: a,b +logical :: ff +call slinmmtf(a,b,ff) +if(ff)stop 'In slinmmt; unable to invert linear system' +end subroutine slinmmt +!============================================================================= +subroutine dlinmmt(a,b)! [inv] +!============================================================================= +real(dp),dimension(:,:),intent(inout):: a,b +logical :: ff +call dlinmmtf(a,b,ff) +if(ff)stop 'In dlinmmt; unable to invert linear system' +end subroutine dlinmmt +!============================================================================= +subroutine clinmmt(a,b)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(inout):: a,b +logical :: ff +call clinmmtf(a,b,ff) +if(ff)stop 'In clinmmt; unable to invert linear system' +end subroutine clinmmt +!============================================================================= +subroutine slinmmtf(a,b,ff)! [inv] +!============================================================================= +real(SP), dimension(:,:),intent(INOUT):: a,b +logical, intent( OUT):: ff +integer,dimension(size(a,1)) :: ipiv +integer :: m +real(sp) :: d +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to slinmmtf is not square' +if(m /= size(b,1))& + stop 'In inv; matrix and vectors in slinmmtf have unmatched sizes' +call sldumf(a,ipiv,d,ff) +if(ff)then + print '("In slinmmtf; failed call to sldumf")' + return +endif +call sudlmm(a,b,ipiv) +end subroutine slinmmtf +!============================================================================= +subroutine dlinmmtf(a,b,ff)! [inv] +!============================================================================= +real(dp),dimension(:,:), intent(inout):: a,b +logical, intent( out):: ff +integer, dimension(size(a,1)) :: ipiv +integer :: m +real(dp) :: d +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to dlinmmtf is not square' +if(m /= size(b,1))& + stop 'In inv; matrix and vectors in dlinmmtf have unmatched sizes' +call dldumf(a,ipiv,d,ff) +if(ff)then + print '("In dlinmmtf; failed call to dldumf")' + return +endif +call dudlmm(a,b,ipiv) +end subroutine dlinmmtf +!============================================================================= +subroutine clinmmtf(a,b,ff)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(INOUT):: a,b +logical, intent( OUT):: ff +integer, dimension(size(a,1)) :: ipiv +integer :: m +complex(dpc) :: d +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to dlinmmtf is not square' +if(m /= size(b,1))& + stop 'In inv; matrix and vectors in dlinmmtf have unmatched sizes' +call cldumf(a,ipiv,d,ff) +if(ff)then + print '("In clinmmtf; failed call to cldumf")' + return +endif +call cudlmm(a,b,ipiv) +end subroutine clinmmtf + +!============================================================================= +subroutine slinmvt(a,b)! [inv] +!============================================================================= +real(sp), dimension(:,:),intent(inout):: a +real(sp), dimension(:), intent(inout):: b +logical :: ff +call slinmvtf(a,b,ff) +if(ff)stop 'In slinmvt; matrix singular, unable to continue' +end subroutine slinmvt +!============================================================================= +subroutine dlinmvt(a,b)! [inv] +!============================================================================= +real(dp), dimension(:,:),intent(inout):: a +real(dp), dimension(:), intent(inout):: b +logical :: ff +call dlinmvtf(a,b,ff) +if(ff)stop 'In dlinmvt; matrix singular, unable to continue' +end subroutine dlinmvt +!============================================================================= +subroutine clinmvt(a,b)! [inv] +!============================================================================= +complex(dpc), dimension(:,:),intent(inout):: a +complex(dpc), dimension(:), intent(inout):: b +logical :: ff +call clinmvtf(a,b,ff) +if(ff)stop 'In clinmvt; matrix singular, unable to continue' +end subroutine clinmvt +!============================================================================= +subroutine slinmvtf(a,b,ff)! [inv] +!============================================================================= +real(sp),dimension(:,:),intent(inout):: a +real(sp),dimension(:), intent(inout):: b +logical, intent( out):: ff +integer,dimension(size(a,1)) :: ipiv +real(sp) :: d +!============================================================================= +if(size(a,1) /= size(a,2).or. size(a,1) /= size(b))& + stop 'In inv; In slinmvtf; incompatible array dimensions' +call sldumf(a,ipiv,d,ff) +if(ff)then + print '("In slinmvtf; failed call to sldumf")' + return +endif +call sudlmv(a,b,ipiv) +end subroutine slinmvtf +!============================================================================= +subroutine dlinmvtf(a,b,ff)! [inv] +!============================================================================= +real(dp),dimension(:,:),intent(inout):: a +real(dp),dimension(:), intent(inout):: b +logical, intent( out):: ff +integer, dimension(size(a,1)) :: ipiv +real(dp) :: d +!============================================================================= +if(size(a,1) /= size(a,2).or. size(a,1) /= size(b))& + stop 'In inv; incompatible array dimensions passed to dlinmvtf' +call dldumf(a,ipiv,d,ff) +if(ff)then + print '("In dlinmvtf; failed call to dldumf")' + return +endif +call dudlmv(a,b,ipiv) +end subroutine dlinmvtf +!============================================================================= +subroutine clinmvtf(a,b,ff)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(inout):: a +complex(dpc),dimension(:), intent(inout):: b +logical, intent( out):: ff +integer, dimension(size(a,1)) :: ipiv +complex(dpc) :: d +!============================================================================= +if(size(a,1) /= size(a,2).or. size(a,1) /= size(b))& + stop 'In inv; incompatible array dimensions passed to clinmvtf' +call cldumf(a,ipiv,d,ff) +if(ff)then + print '("In clinmvtf; failed call to cldumf")' + return +endif +call cudlmv(a,b,ipiv) +end subroutine clinmvtf + +!============================================================================= +subroutine iinvf(imat,ff)! [inv] +!============================================================================= +! Invert integer square array, imat, if possible, but flag ff=.true. +! if not possible. (Determinant of imat must be +1 or -1 +!============================================================================= +integer,dimension(:,:),intent(INOUT):: imat +logical, intent( OUT):: ff +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-10_dp +real(dp),dimension(size(imat,1),size(imat,1)):: dmat +integer :: m,i,j +!============================================================================= +m=size(imat,1) +if(m /= size(imat,2))stop 'In inv; matrix passed to iinvf is not square' +dmat=imat; call inv(dmat,ff) +if(.not.ff)then + do j=1,m + do i=1,m + imat(i,j)=nint(dmat(i,j)); if(abs(dmat(i,j)-imat(i,j))>eps)ff=t + enddo + enddo +endif +end subroutine iinvf + +!============================================================================= +subroutine sldum(a,ipiv,d)! [ldum] +!============================================================================= +real(sp),intent(inout) :: a(:,:) +real(sp),intent(out ) :: d +integer, intent(out ) :: ipiv(:) +logical :: ff +call sldumf(a,ipiv,d,ff) +if(ff)stop 'In sldum; matrix singular, unable to continue' +end subroutine sldum +!============================================================================= +subroutine dldum(a,ipiv,d)! [ldum] +!============================================================================= +real(dp),intent(inout) :: a(:,:) +real(dp),intent(out ) :: d +integer, intent(out ) :: ipiv(:) +logical:: ff +call dldumf(a,ipiv,d,ff) +if(ff)stop 'In dldum; matrix singular, unable to continue' +end subroutine dldum +!============================================================================= +subroutine cldum(a,ipiv,d)! [ldum] +!============================================================================= +complex(dpc),intent(inout) :: a(:,:) +complex(dpc),intent(out ) :: d +integer, intent(out ) :: ipiv(:) +logical:: ff +call cldumf(a,ipiv,d,ff) +if(ff)stop 'In cldum; matrix singular, unable to continue' +end subroutine cldum +!============================================================================= +subroutine sldumf(a,ipiv,d,ff)! [ldum] +!============================================================================= +! R.J.Purser, NCEP, Washington D.C. 1996 +! SUBROUTINE LDUM +! perform l-d-u decomposition of square matrix a in place with +! pivoting. +! +! <-> a square matrix to be factorized +! <-- ipiv array encoding the pivoting sequence +! <-- d indicator for possible sign change of determinant +! <-- ff: failure flag, set to .true. when determinant of a vanishes. +!============================================================================= +real(SP),intent(INOUT) :: a(:,:) +real(SP),intent(OUT ) :: d +integer, intent(OUT ) :: ipiv(:) +logical, intent(OUT ) :: ff +integer :: m,i, j, jp, ibig, jm +real(SP) :: s(size(a,1)), aam, aa, abig, ajj, ajji, aij +!============================================================================= +ff=f +m=size(a,1) +do i=1,m + aam=0 + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == 0)then + print '("In sldumf; row ",i6," of matrix vanishes")',i + ff=t + return + endif + s(i)=1/aam +enddo +d=1. +ipiv(m)=m +do j=1,m-1 + jp=j+1 + abig=s(j)*abs(a(j,j)) + ibig=j + do i=jp,m + aa=s(i)*abs(a(i,j)) + if(aa > abig)then + ibig=i + abig=aa + endif + enddo +! swap rows, recording changed sign of determinant + ipiv(j)=ibig + if(ibig /= j)then + d=-d + call sswpvv(a(j,:),a(ibig,:)) + s(ibig)=s(j) + endif + ajj=a(j,j) + if(ajj == 0)then + jm=j-1 + print '(" failure in sldumf:"/" matrix singular, rank=",i3)',jm + ff=t + return + endif + ajji=1/ajj + do i=jp,m + aij=ajji*a(i,j) + a(i,j)=aij + a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m) + enddo +enddo +end subroutine sldumf +!============================================================================= +subroutine DLDUMf(A,IPIV,D,ff)! [ldum] +!============================================================================= +real(DP), intent(INOUT) :: a(:,:) +real(DP), intent(OUT ) :: d +integer, intent(OUT ) :: ipiv(:) +logical, intent(OUT ) :: ff +integer :: m,i, j, jp, ibig, jm +real(DP) :: s(size(a,1)), aam, aa, abig, ajj, ajji, aij +!============================================================================= +ff=f +m=size(a,1) +do i=1,m + aam=0 + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == 0)then + print '("In dldumf; row ",i6," of matrix vanishes")',i + ff=t + return + endif + s(i)=1/aam +enddo +d=1. +ipiv(m)=m +do j=1,m-1 + jp=j+1 + abig=s(j)*abs(a(j,j)) + ibig=j + do i=jp,m + aa=s(i)*abs(a(i,j)) + if(aa > abig)then + ibig=i + abig=aa + endif + enddo +! swap rows, recording changed sign of determinant + ipiv(j)=ibig + if(ibig /= j)then + d=-d + call dswpvv(a(j,:),a(ibig,:)) + s(ibig)=s(j) + endif + ajj=a(j,j) + if(ajj == 0)then + jm=j-1 + print '(" Failure in dldumf:"/" matrix singular, rank=",i3)',jm + ff=t + return + endif + ajji=1/ajj + do i=jp,m + aij=ajji*a(i,j) + a(i,j)=aij + a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m) + enddo +enddo +end subroutine DLDUMf +!============================================================================= +subroutine cldumf(a,ipiv,d,ff)! [ldum] +!============================================================================= +use jp_pietc, only: c0 +complex(dpc), intent(INOUT) :: a(:,:) +complex(dpc), intent(OUT ) :: d +integer, intent(OUT ) :: ipiv(:) +logical, intent(OUT ) :: ff +integer :: m,i, j, jp, ibig, jm +complex(dpc) :: ajj, ajji, aij +real(dp) :: aam,aa,abig +real(dp),dimension(size(a,1)):: s +!============================================================================= +ff=f +m=size(a,1) +do i=1,m + aam=0 + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == 0)then + print '("In cldumf; row ",i6," of matrix vanishes")',i + ff=t + return + endif + s(i)=1/aam +enddo +d=1. +ipiv(m)=m +do j=1,m-1 + jp=j+1 + abig=s(j)*abs(a(j,j)) + ibig=j + do i=jp,m + aa=s(i)*abs(a(i,j)) + if(aa > abig)then + ibig=i + abig=aa + endif + enddo +! swap rows, recording changed sign of determinant + ipiv(j)=ibig + if(ibig /= j)then + d=-d + call cswpvv(a(j,:),a(ibig,:)) + s(ibig)=s(j) + endif + ajj=a(j,j) + if(ajj == c0)then + jm=j-1 + print '(" Failure in cldumf:"/" matrix singular, rank=",i3)',jm + ff=t + return + endif + ajji=1/ajj + do i=jp,m + aij=ajji*a(i,j) + a(i,j)=aij + a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m) + enddo +enddo +end subroutine cldumf + +!============================================================================= +subroutine sudlmm(a,b,ipiv)! [udlmm] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1993 +! SUBROUTINE UDLMM +! use l-u factors in A to back-substitute for several rhs in B, using ipiv to +! define the pivoting permutation used in the l-u decomposition. +! +! --> A L-D-U factorization of linear system matrux +! <-> B rt-hand-sides vectors on input, corresponding solutions on return +! --> IPIV array encoding the pivoting sequence +!============================================================================= +integer, dimension(:), intent(in) :: ipiv +real(sp),dimension(:,:),intent(in) :: a +real(sp),dimension(:,:),intent(inout) :: b +integer :: m,i, k, l +real(sp) :: s,aiii +!============================================================================= +m=size(a,1) +do k=1,size(b,2) !loop over columns of b + do i=1,m + l=ipiv(i) + s=b(l,k) + b(l,k)=b(i,k) + s = s - sum(b(1:i-1,k)*a(i,1:i-1)) + b(i,k)=s + enddo + b(m,k)=b(m,k)/a(m,m) + do i=m-1,1,-1 + aiii=1/a(i,i) + b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m)) + b(i,k)=b(i,k)*aiii + enddo +enddo +end subroutine sudlmm +!============================================================================= +subroutine dudlmm(a,b,ipiv)! [udlmm] +!============================================================================= +integer, dimension(:), intent(in ) :: ipiv +real(dp), dimension(:,:),intent(in ) :: a +real(dp), dimension(:,:),intent(inout) :: b +integer :: m,i, k, l +real(dp) :: s,aiii +!============================================================================= +m=size(a,1) +do k=1, size(b,2)!loop over columns of b + do i=1,m + l=ipiv(i) + s=b(l,k) + b(l,k)=b(i,k) + s = s - sum(b(1:i-1,k)*a(i,1:i-1)) + b(i,k)=s + enddo + b(m,k)=b(m,k)/a(m,m) + do i=m-1,1,-1 + aiii=1/a(i,i) + b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m)) + b(i,k)=b(i,k)*aiii + enddo +enddo +end subroutine dudlmm +!============================================================================= +subroutine cudlmm(a,b,ipiv)! [udlmm] +!============================================================================= +integer, dimension(:), intent(in ) :: ipiv +complex(dpc),dimension(:,:),intent(in ) :: a +complex(dpc),dimension(:,:),intent(inout) :: b +integer :: m,i, k, l +complex(dpc) :: s,aiii +!============================================================================= +m=size(a,1) +do k=1, size(b,2)!loop over columns of b + do i=1,m + l=ipiv(i) + s=b(l,k) + b(l,k)=b(i,k) + s = s - sum(b(1:i-1,k)*a(i,1:i-1)) + b(i,k)=s + enddo + b(m,k)=b(m,k)/a(m,m) + do i=m-1,1,-1 + aiii=1/a(i,i) + b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m)) + b(i,k)=b(i,k)*aiii + enddo +enddo +end subroutine cudlmm + +!============================================================================= +subroutine sudlmv(a,b,ipiv)! [udlmv] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1993 +! SUBROUTINE UDLMV +! use l-u factors in A to back-substitute for 1 rhs in B, using ipiv to +! define the pivoting permutation used in the l-u decomposition. +! +! --> A L-D-U factorization of linear system matrix +! <-> B right-hand-side vector on input, corresponding solution on return +! --> IPIV array encoding the pivoting sequence +!============================================================================= +integer, dimension(:), intent(in) :: ipiv +real(sp),dimension(:,:),intent(in) :: a +real(sp),dimension(:), intent(inout) :: b +integer :: m,i, l +real(sp) :: s,aiii +!============================================================================= +m=size(a,1) +do i=1,m + l=ipiv(i) + s=b(l) + b(l)=b(i) + s = s - sum(b(1:i-1)*a(i,1:i-1)) + b(i)=s +enddo +b(m)=b(m)/a(m,m) +do i=m-1,1,-1 + aiii=1/a(i,i) + b(i) = b(i) - sum(b(i+1:m)*a(i,i+1:m)) + b(i)=b(i)*aiii +enddo +end subroutine sudlmv +!============================================================================= +subroutine dudlmv(a,b,ipiv)! [udlmv] +!============================================================================= +integer, dimension(:), intent(in ) :: ipiv(:) +real(dp), dimension(:,:),intent(in ) :: a(:,:) +real(dp), dimension(:), intent(inout) :: b(:) +integer :: m,i, l +real(dp) :: s,aiii +!============================================================================= +m=size(a,1) +do i=1,m + l=ipiv(i) + s=b(l) + b(l)=b(i) + s = s - sum(b(1:i-1)*a(i,1:i-1)) + b(i)=s +enddo +b(m)=b(m)/a(m,m) +do i=m-1,1,-1 + aiii=1/a(i,i) + b(i) = b(i) - sum(b(i+1:m)*a(i,i+1:m)) + b(i)=b(i)*aiii +enddo +end subroutine dudlmv +!============================================================================= +subroutine cudlmv(a,b,ipiv)! [udlmv] +!============================================================================= +integer, dimension(:), intent(in ) :: ipiv(:) +complex(dpc),dimension(:,:),intent(in ) :: a(:,:) +complex(dpc),dimension(:), intent(inout) :: b(:) +integer :: m,i, l +complex(dpc) :: s,aiii +!============================================================================= +m=size(a,1) +do i=1,m + l=ipiv(i) + s=b(l) + b(l)=b(i) + s = s - sum(b(1:i-1)*a(i,1:i-1)) + b(i)=s +enddo +b(m)=b(m)/a(m,m) +do i=m-1,1,-1 + aiii=1/a(i,i) + b(i) = b(i) - sum(b(i+1:m)*a(i,i+1:m)) + b(i)=b(i)*aiii +enddo +end subroutine cudlmv + +!============================================================================= +subroutine sl1lm(a,b) ! [l1lm] +!============================================================================= +! Cholesky, M -> L*U, U(i,j)=L(j,i) +!============================================================================= +real(sp), intent(in ) :: a(:,:) +real(sp), intent(inout) :: b(:,:) +!----------------------------------------------------------------------------- +logical:: ff +call sl1lmf(a,b,ff) +if(ff)stop 'In sl1lm; matrix singular, unable to continue' +end subroutine sl1lm +!============================================================================= +subroutine dl1lm(a,b) ! [l1lm] +!============================================================================= +! Cholesky, M -> L*U, U(i,j)=L(j,i) +!============================================================================= +real(dp), intent(in ) :: a(:,:) +real(dp), intent(inout) :: b(:,:) +!----------------------------------------------------------------------------- +logical:: ff +call dl1lmf(a,b,ff) +if(ff)stop 'In dl1lm; matrix singular, unable to continue' +end subroutine dl1lm + +!============================================================================= +subroutine sl1lmf(a,b,ff)! [L1Lm] +!============================================================================= +! Cholesky, M -> L*U, U(i,j)=L(j,i) +!============================================================================= +real(sp), intent(IN ) :: a(:,:) +real(sp), intent(INOUT) :: b(:,:) +logical :: ff +!----------------------------------------------------------------------------- +integer :: m,j, jm, jp, i +real(sp) :: s, bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m + jm=j-1 + jp=j+1 + s = a(j,j) - sum(b(j,1:jm)*b(j,1:jm)) + ff=(S <= 0) + if(ff)then + print '("sL1Lmf detects nonpositive a, rank=",i6)',jm + return + endif + b(j,j)=sqrt(s) + bjji=1/b(j,j) + do i=jp,m + s = a(i,j) - sum(b(i,1:jm)*b(j,1:jm)) + b(i,j)=s*bjji + enddo + b(1:jm,j) = 0 +enddo +end subroutine sl1lmf +!============================================================================= +subroutine dl1lmf(a,b,ff) ! [L1Lm] +!============================================================================= +real(dp), intent(IN ) :: a(:,:) +real(dp), intent(INOUT) :: b(:,:) +logical :: ff +!----------------------------------------------------------------------------- +integer :: m,j, jm, jp, i +real(dp) :: s, bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m + jm=j-1 + jp=j+1 + s = a(j,j) - sum(b(j,1:jm)*b(j,1:jm)) + ff=(s <= 0) + if(ff)then + print '("dL1LMF detects nonpositive A, rank=",i6)',jm + return + endif + b(j,j)=sqrt(s) + bjji=1/b(j,j) + do i=jp,m + s = a(i,j) - sum(b(i,1:jm)*b(j,1:jm)) + b(i,j)=s*bjji + enddo + b(1:jm,j) = 0 +enddo +return +end subroutine dl1lmf + +!============================================================================= +subroutine sldlm(a,b,d)! [LdLm] +!============================================================================= +! Modified Cholesky decompose Q --> L*D*U, U(i,j)=L(j,i) +!============================================================================= +real(sp), intent(IN ):: a(:,:) +real(sp), intent(INOUT):: b(:,:) +real(sp), intent( OUT):: d(:) +!----------------------------------------------------------------------------- +logical:: ff +call sldlmf(a,b,d,ff) +if(ff)stop 'In sldlm; matrix singular, unable to continue' +end subroutine sldlm +!============================================================================= +subroutine dldlm(a,b,d)! [LdLm] +!============================================================================= +real(dp), intent(IN ):: a(:,:) +real(dp), intent(INOUT):: b(:,:) +real(dp), intent( OUT):: d(:) +!----------------------------------------------------------------------------- +logical:: ff +call dldlmf(a,b,d,ff) +if(ff)stop 'In dldlm; matrix singular, unable to continue' +end subroutine dldlm + +!============================================================================= +subroutine sldlmf(a,b,d,ff) ! [LDLM] +!============================================================================= +! Modified Cholesky decompose Q --> L*D*U +!============================================================================= +real(sp), intent(IN ):: a(:,:) +real(sp), intent(INOUT):: b(:,:) +real(sp), intent( OUT):: d(:) +logical, intent( OUT):: ff +!----------------------------------------------------------------------------- +integer :: m,j, jm, jp, i +real(sp) :: bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m + jm=j-1 + jp=j+1 + d(j)=a(j,j) - sum(b(1:jm,j)*b(j,1:jm)) + b(j,j) = 1 + ff=(d(j) == 0) + if(ff)then + print '("In sldlmf; singularity of matrix detected")' + print '("Rank of matrix: ",i6)',jm + return + endif + bjji=1/d(j) + do i=jp,m + b(j,i)=a(i,j) - dot_product(b(1:jm,j),b(i,1:jm)) + b(i,j)=b(j,i)*bjji + enddo + b(1:jm,j)=0 +enddo +end subroutine sldlmf +!============================================================================= +subroutine dldlmf(a,b,d,ff) ! [LDLM] +!============================================================================= +! Modified Cholesky Q --> L*D*U, U(i,j)=L(j,i) +!============================================================================= +real(dp), intent(IN ) :: a(:,:) +real(dp), intent(INOUT) :: b(:,:) +real(dp), intent( OUT) :: d(:) +logical, intent( OUT) :: ff +!----------------------------------------------------------------------------- +integer :: m,j, jm, jp, i +real(dp) :: bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m; jm=j-1; jp=j+1 + d(j)=a(j,j) - sum(b(1:jm,j)*b(j,1:jm)) + b(j,j) = 1 + ff=(d(j) == 0) + if(ff)then + print '("In dldlmf; singularity of matrix detected")' + print '("Rank of matrix: ",i6)',jm + return + endif + bjji=1/d(j) + do i=jp,m + b(j,i)=a(i,j) - dot_product(b(1:jm,j),b(i,1:jm)) + b(i,j)=b(j,i)*bjji + enddo + b(1:jm,j)=0 +enddo +end subroutine dldlmf + +!============================================================================== +subroutine sinvu(a)! [invu] +!============================================================================== +! Invert the upper triangular matrix in place by transposing, calling +! invl, and transposing again. +!============================================================================== +real,dimension(:,:),intent(inout):: a +a=transpose(a); call sinvl(a); a=transpose(a) +end subroutine sinvu +!============================================================================== +subroutine dinvu(a)! [invu] +!============================================================================== +real(dp),dimension(:,:),intent(inout):: a +a=transpose(a); call dinvl(a); a=transpose(a) +end subroutine dinvu +!============================================================================== +subroutine sinvl(a)! [invl] +!============================================================================== +! Invert lower triangular matrix in place +!============================================================================== +real(sp), intent(inout) :: a(:,:) +integer :: m,j, i +m=size(a,1) +do j=m,1,-1 + a(1:j-1,j) = 0.0 + a(j,j)=1./a(j,j) + do i=j+1,m + a(i,j)=-a(i,i)*sum(a(j:i-1,j)*a(i,j:i-1)) + enddo +enddo +end subroutine sinvl +!============================================================================== +subroutine dinvl(a)! [invl] +!============================================================================== +real(dp), intent(inout) :: a(:,:) +integer :: m,j, i +m=size(a,1) +do j=m,1,-1 + a(1:j-1,j) = 0.0 + a(j,j)=1./a(j,j) + do i=j+1,m + a(i,j)=-a(i,i)*sum(a(j:i-1,j)*a(i,j:i-1)) + enddo +enddo +end subroutine dinvl + +!============================================================================== +subroutine slinlv(a,u)! [invl] +!============================================================================== +! Solve linear system involving lower triangular system matrix. +!============================================================================== +real, intent(in ) :: a(:,:) +real, intent(inout) :: u(:) +integer :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In slinlv; incompatible array dimensions' +do i=1,size(u); u(i)=(u(i) - sum(u(:i-1)*a(i,:i-1)))/a(i,i); enddo +end subroutine slinlv +!============================================================================== +subroutine dlinlv(a,u)! [invl] +!============================================================================== +real(dp), intent(in ) :: a(:,:) +real(dp), intent(inout) :: u(:) +integer :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In dlinlv; incompatible array dimensions' +do i=1,size(u); u(i)=(u(i) - sum(u(:i-1)*a(i,:i-1)))/a(i,i); enddo +end subroutine dlinlv + +!============================================================================== +subroutine slinuv(a,u)! [invu] +!============================================================================== +! Solve linear system involving upper triangular system matrix. +!============================================================================== +real, intent(in ) :: a(:,:) +real, intent(inout) :: u(:) +integer :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In linuv; incompatible array dimensions' +do i=size(u),1,-1; u(i)=(u(i) - sum(a(i+1:,i)*u(i+1:)))/a(i,i); enddo +end subroutine slinuv +!============================================================================== +subroutine dlinuv(a,u)! [invu] +!============================================================================== +real(dp), intent(in ) :: a(:,:) +real(dp), intent(inout) :: u(:) +integer :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In dlinuv; incompatible array dimensions' +do i=size(u),1,-1; u(i)=(u(i) - sum(a(i+1:,i)*u(i+1:)))/a(i,i); enddo +end subroutine dlinuv + +end module jp_pmat + diff --git a/src/mgbf/jp_pmat4.f90 b/src/mgbf/jp_pmat4.f90 new file mode 100644 index 0000000000..552d5efdeb --- /dev/null +++ b/src/mgbf/jp_pmat4.f90 @@ -0,0 +1,2086 @@ +module jp_pmat4 +!$$$ module documentation block +! . . . . +! module: jp_pmat4 +! prgmmr: purser org: NOAA/EMC date: 2005-10 +! +! abstract: Euclidean geometry, geometric (stereographic) projections, +! related transformations (Mobius) +! +! module history log: +! 2012-05-18 purser +! 2017-05 purser - Added routines to facilitate manipulation of 3D +! rotations, their representations by axial vectors, +! and routines to compute the exponentials of matrices +! (without resort to eigen methods). +! Also added Quaternion and spinor representations +! of 3D rotations, and their conversion routines. +! +! Subroutines Included: +! gram - Right-handed orthogonal basis and rank, nrank. The first +! nrank basis vectors span the column range of matrix given, +! OR ("plain" version) simple unpivoted Gram-Schmidt of a +! square matrix. +! +! In addition, we include routines that relate to +! stereographic projections and some associated mobius +! transformation utilities, since these complex operations +! have a strong geometrical flavor. +! dlltoxy - +! normalize - +! rowops - +! corral - +! rottoax - +! axtorot - +! spintoq - +! qtospin - +! rottoq - +! qtorot - +! axtoq - +! qtoax - +! setem - +! expmat - +! zntay - +! znfun - +! ctoz - +! ztoc - +! setmobius - +! mobius - +! mobiusi - +! +! Functions Included: +! absv - Absolute magnitude of vector as its euclidean length +! normalized - Normalized version of given real vector +! orthogonalized - Orthogonalized version of second vector rel. to first unit v. +! cross_product - Vector cross-product of the given 2 vectors +! outer_product - outer-product matrix of the given 2 vectors +! triple_product - Scalar triple product of given 3 vectors +! det - Determinant of given matrix +! axial - Convert axial-vector <--> 2-form (antisymmetric matrix) +! diag - Diagnl of given matrix, or diagonal matrix of given elements +! trace - Trace of given matrix +! identity - Identity 3*3 matrix, or identity n*n matrix for a given n +! sarea - Spherical area subtended by three vectors, or by lat-lon +! increments forming a triangle or quadrilateral +! huarea - Spherical area subtended by right-angled spherical triangle +! hav - +! mulqq - +! +! remarks: +! Package for handy vector and matrix operations in Euclidean geometry. +! This package is primarily intended for 3D operations and three of the +! functions (Cross_product, Triple_product and Axial) do not possess simple +! generalizations to a generic number N of dimensions. The others, while +! admitting such N-dimensional generalizations, have not all been provided +! with such generic forms here at the time of writing, though some of these +! may be added at a future date. +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +use jp_pkind, only: spi,sp,dp,dpc +implicit none +private +public:: absv,normalized,orthogonalized, & + cross_product,outer_product,triple_product,det,axial, & + diag,trace,identity,sarea,huarea,dlltoxy, & + normalize,gram,rowops,corral, & + axtoq,qtoax, & + rottoax,axtorot,spintoq,qtospin,rottoq,qtorot,mulqq, & + expmat,zntay,znfun, & + ctoz,ztoc,setmobius, & + mobius,mobiusi + +interface absv; module procedure absv_s,absv_d; end interface +interface normalized;module procedure normalized_s,normalized_d;end interface +interface orthogonalized + module procedure orthogonalized_s,orthogonalized_d; end interface +interface cross_product + module procedure cross_product_s,cross_product_d, & + triple_cross_product_s,triple_cross_product_d; end interface +interface outer_product + module procedure outer_product_s,outer_product_d,outer_product_i + end interface +interface triple_product + module procedure triple_product_s,triple_product_d; end interface +interface det; module procedure det_s,det_d,det_i,det_id; end interface +interface axial + module procedure axial3_s,axial3_d,axial33_s,axial33_d; end interface +interface diag + module procedure diagn_s,diagn_d,diagn_i,diagnn_s,diagnn_d,diagnn_i + end interface +interface trace; module procedure trace_s,trace_d,trace_i; end interface +interface identity; module procedure identity_i,identity3_i; end interface +interface huarea; module procedure huarea_s,huarea_d; end interface +interface sarea + module procedure sarea_s,sarea_d,dtarea_s,dtarea_d,dqarea_s,dqarea_d + end interface +interface dlltoxy; module procedure dlltoxy_s,dlltoxy_d; end interface +interface hav; module procedure hav_s, hav_d; end interface +interface normalize;module procedure normalize_s,normalize_d; end interface +interface gram + module procedure gram_s,gram_d,graml_d,plaingram_s,plaingram_d,rowgram + end interface +interface rowops; module procedure rowops; end interface +interface corral; module procedure corral; end interface +interface rottoax; module procedure rottoax; end interface +interface axtorot; module procedure axtorot; end interface +interface spintoq; module procedure spintoq; end interface +interface qtospin; module procedure qtospin; end interface +interface rottoq; module procedure rottoq; end interface +interface qtorot; module procedure qtorot; end interface +interface axtoq; module procedure axtoq; end interface +interface qtoax; module procedure qtoax; end interface +interface setem; module procedure setem; end interface +interface mulqq; module procedure mulqq; end interface +interface expmat; module procedure expmat,expmatd,expmatdd; end interface +interface zntay; module procedure zntay; end interface +interface znfun; module procedure znfun; end interface +interface ctoz; module procedure ctoz; end interface +interface ztoc; module procedure ztoc,ztocd; end interface +interface setmobius;module procedure setmobius,zsetmobius; end interface +interface mobius; module procedure zmobius,cmobius; end interface +interface mobiusi; module procedure zmobiusi; end interface + +contains + +!============================================================================= +function absv_s(a)result(s)! [absv] +!============================================================================= +implicit none +real(sp),dimension(:),intent(in):: a +real(sp) :: s +s=sqrt(dot_product(a,a)) +end function absv_s +!============================================================================= +function absv_d(a)result(s)! [absv] +!============================================================================= +implicit none +real(dp),dimension(:),intent(in):: a +real(dp) :: s +s=sqrt(dot_product(a,a)) +end function absv_d + +!============================================================================= +function normalized_s(a)result(b)! [normalized] +!============================================================================= +use jp_pietc_s, only: u0 +implicit none +real(sp),dimension(:),intent(IN):: a +real(sp),dimension(size(a)) :: b +real(sp) :: s +s=absv_s(a); if(s==u0)then; b=u0;else;b=a/s;endif +end function normalized_s +!============================================================================= +function normalized_d(a)result(b)! [normalized] +!============================================================================= +use jp_pietc, only: u0 +implicit none +real(dp),dimension(:),intent(IN):: a +real(dp),dimension(size(a)) :: b +real(dp) :: s +s=absv_d(a); if(s==u0)then; b=u0;else;b=a/s;endif +end function normalized_d + +!============================================================================= +function orthogonalized_s(u,a)result(b)! [orthogonalized] +!============================================================================= +implicit none +real(sp),dimension(:),intent(in):: u,a +real(sp),dimension(size(u)) :: b +real(sp) :: s +! Note: this routine assumes u is already normalized +s=dot_product(u,a); b=a-u*s +end function orthogonalized_s +!============================================================================= +function orthogonalized_d(u,a)result(b)! [orthogonalized] +!============================================================================= +implicit none +real(dp),dimension(:),intent(in):: u,a +real(dp),dimension(size(u)) :: b +real(dp) :: s +! Note: this routine assumes u is already normalized +s=dot_product(u,a); b=a-u*s +end function orthogonalized_d + +!============================================================================= +function cross_product_s(a,b)result(c)! [cross_product] +!============================================================================= +implicit none +real(sp),dimension(3),intent(in):: a,b +real(sp),dimension(3) :: c +c(1)=a(2)*b(3)-a(3)*b(2); c(2)=a(3)*b(1)-a(1)*b(3); c(3)=a(1)*b(2)-a(2)*b(1) +end function cross_product_s +!============================================================================= +function cross_product_d(a,b)result(c)! [cross_product] +!============================================================================= +implicit none +real(dp),dimension(3),intent(in):: a,b +real(dp),dimension(3) :: c +c(1)=a(2)*b(3)-a(3)*b(2); c(2)=a(3)*b(1)-a(1)*b(3); c(3)=a(1)*b(2)-a(2)*b(1) +end function cross_product_d +!============================================================================= +function triple_cross_product_s(u,v,w)result(x)! [cross_product] +!============================================================================= +! Deliver the triple-cross-product, x, of the +! three 4-vectors, u, v, w, with the sign convention +! that ordered, {u,v,w,x} form a right-handed quartet +! in the generic case (determinant >= 0). +!============================================================================= +implicit none +real(sp),dimension(4),intent(in ):: u,v,w +real(sp),dimension(4) :: x +!----------------------------------------------------------------------------- +real(sp):: uv12,uv13,uv14,uv23,uv24,uv34 +!============================================================================= +uv12=u(1)*v(2)-u(2)*v(1); uv13=u(1)*v(3)-u(3)*v(1); uv14=u(1)*v(4)-u(4)*v(1) + uv23=u(2)*v(3)-u(3)*v(2); uv24=u(2)*v(4)-u(4)*v(2) + uv34=u(3)*v(4)-u(4)*v(3) +x(1)=-uv23*w(4)+uv24*w(3)-uv34*w(2) +x(2)= uv13*w(4)-uv14*w(3) +uv34*w(1) +x(3)=-uv12*w(4) +uv14*w(2)-uv24*w(1) +x(4)= uv12*w(3)-uv13*w(2)+uv23*w(1) +end function triple_cross_product_s +!============================================================================= +function triple_cross_product_d(u,v,w)result(x)! [cross_product] +!============================================================================= +implicit none +real(dp),dimension(4),intent(in ):: u,v,w +real(dp),dimension(4) :: x +!----------------------------------------------------------------------------- +real(dp):: uv12,uv13,uv14,uv23,uv24,uv34 +!============================================================================= +uv12=u(1)*v(2)-u(2)*v(1); uv13=u(1)*v(3)-u(3)*v(1); uv14=u(1)*v(4)-u(4)*v(1) + uv23=u(2)*v(3)-u(3)*v(2); uv24=u(2)*v(4)-u(4)*v(2) + uv34=u(3)*v(4)-u(4)*v(3) +x(1)=-uv23*w(4)+uv24*w(3)-uv34*w(2) +x(2)= uv13*w(4)-uv14*w(3) +uv34*w(1) +x(3)=-uv12*w(4) +uv14*w(2)-uv24*w(1) +x(4)= uv12*w(3)-uv13*w(2)+uv23*w(1) +end function triple_cross_product_d + +!============================================================================= +function outer_product_s(a,b)result(c)! [outer_product] +!============================================================================= +implicit none +real(sp),dimension(:), intent(in ):: a +real(sp),dimension(:), intent(in ):: b +real(sp),DIMENSION(size(a),size(b)):: c +integer(spi) :: nb,i +nb=size(b) +do i=1,nb; c(:,i)=a*b(i); enddo +end function outer_product_s +!============================================================================= +function outer_product_d(a,b)result(c)! [outer_product] +!============================================================================= +implicit none +real(dp),dimension(:), intent(in ):: a +real(dp),dimension(:), intent(in ):: b +real(dp),dimension(size(a),size(b)):: c +integer(spi) :: nb,i +nb=size(b) +do i=1,nb; c(:,i)=a*b(i); enddo +end function outer_product_d +!============================================================================= +function outer_product_i(a,b)result(c)! [outer_product] +!============================================================================= +implicit none +integer(spi),dimension(:), intent(in ):: a +integer(spi),dimension(:), intent(in ):: b +integer(spi),dimension(size(a),size(b)):: c +integer(spi) :: nb,i +nb=size(b) +do i=1,nb; c(:,i)=a*b(i); enddo +end function outer_product_i + +!============================================================================= +function triple_product_s(a,b,c)result(tripleproduct)! [triple_product] +!============================================================================= +implicit none +real(sp),dimension(3),intent(IN ):: a,b,c +real(sp) :: tripleproduct +tripleproduct=dot_product( cross_product(a,b),c ) +end function triple_product_s +!============================================================================= +function triple_product_d(a,b,c)result(tripleproduct)! [triple_product] +!============================================================================= +implicit none +real(dp),dimension(3),intent(IN ):: a,b,c +real(dp) :: tripleproduct +tripleproduct=dot_product( cross_product(a,b),c ) +end function triple_product_d + +!============================================================================= +function det_s(a)result(det)! [det] +!============================================================================= +use jp_pietc_s, only: u0 +implicit none +real(sp),dimension(:,:),intent(IN ) :: a +real(sp) :: det +real(sp),dimension(size(a,1),size(a,1)):: b +integer(spi) :: n,nrank +n=size(a,1) +if(n==3)then + det=triple_product(a(:,1),a(:,2),a(:,3)) +else + call gram(a,b,nrank,det) + if(nranku0 +implicit none +real(sp),dimension(3),intent(IN ):: v1,v2,v3 +real(sp) :: area +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +real(sp) :: s123,a1,a2,b,d1,d2,d3 +real(sp),dimension(3) :: u0,u1,u2,u3,x,y +!============================================================================= +area=zero +u1=normalized(v1); u2=normalized(v2); u3=normalized(v3) +s123=triple_product(u1,u2,u3) +if(s123==zero)return + +d1=dot_product(u3-u2,u3-u2) +d2=dot_product(u1-u3,u1-u3) +d3=dot_product(u2-u1,u2-u1) + +! Triangle that is not degenerate. Cyclically permute, so side 3 is longest: +if(d3u0 +implicit none +real(dp),dimension(3),intent(IN ):: v1,v2,v3 +real(dp) :: area +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +real(dp) :: s123,a1,a2,b,d1,d2,d3 +real(dp),dimension(3) :: u0,u1,u2,u3,x,y +!============================================================================= +area=zero +u1=normalized(v1); u2=normalized(v2); u3=normalized(v3) +s123=triple_product(u1,u2,u3) +if(s123==zero)return + +d1=dot_product(u3-u2,u3-u2) +d2=dot_product(u1-u3,u1-u3) +d3=dot_product(u2-u1,u2-u1) + +! Triangle that is not degenerate. Cyclically permute, so side 3 is longest: +if(d3nrank)exit + ab(k:m,k:n)=matmul( transpose(a(:,k:m)),b(:,k:n) ) + ii =maxloc( abs( ab(k:m,k:n)) )+k-1 + val=maxval( abs( ab(k:m,k:n)) ) + if(val<=vcrit)then + nrank=k-1 + exit + endif + i=ii(1) + j=ii(2) + tv=b(:,j) + b(:,j)=-b(:,k) + b(:,k)=tv + tv=a(:,i) + a(:,i)=-a(:,k) + a(:,k)=tv + w(k:n)=matmul( transpose(b(:,k:n)),tv ) + b(:,k)=matmul(b(:,k:n),w(k:n) ) + s=dot_product(b(:,k),b(:,k)) + s=sqrt(s) + if(w(k)nrank)exit + ab(k:m,k:n)=matmul( transpose(a(:,k:m)),b(:,k:n) ) + ii =maxloc( abs( ab(k:m,k:n)) )+k-1 + val=maxval( abs( ab(k:m,k:n)) ) + if(val<=vcrit)then + nrank=k-1 + exit + endif + i=ii(1) + j=ii(2) + tv=b(:,j) + b(:,j)=-b(:,k) + b(:,k)=tv + tv=a(:,i) + a(:,i)=-a(:,k) + a(:,k)=tv + w(k:n)=matmul( transpose(b(:,k:n)),tv ) + b(:,k)=matmul(b(:,k:n),w(k:n) ) + s=dot_product(b(:,k),b(:,k)) + s=sqrt(s) + if(w(k)nrank)exit + ab(k:m,k:n)=matmul( transpose(a(:,k:m)),b(:,k:n) ) + ii =maxloc( abs( ab(k:m,k:n)) )+k-1 + val=maxval( abs( ab(k:m,k:n)) ) + if(val<=vcrit)then + nrank=k-1 + exit + endif + i=ii(1) + j=ii(2) + tv=b(:,j) + b(:,j)=-b(:,k) + b(:,k)=tv + tv=a(:,i) + a(:,i)=-a(:,k) + a(:,k)=tv + w(k:n)=matmul( transpose(b(:,k:n)),tv ) + b(:,k)=matmul(b(:,k:n),w(k:n) ) + s=dot_product(b(:,k),b(:,k)) + s=sqrt(s) + if(w(k)u0)then + ldet=ldet+log(s) + else + detsign=0 + endif + + b(:,k)=b(:,k)/s + do l=k,n + do j=l+1,n + s=dot_product(b(:,l),b(:,j)) + b(:,j)=normalized( b(:,j)-b(:,l)*s ) + enddo + enddo +enddo +end subroutine graml_d + +!============================================================================= +subroutine plaingram_s(b,nrank)! [gram] +!============================================================================= +! A "plain" (unpivoted) version of Gram-Schmidt, for square matrices only. +use jp_pietc_s, only: u0 +implicit none +real(sp),dimension(:,:),intent(INOUT) :: b +integer(spi), intent( OUT) :: nrank +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +real(sp),parameter :: crit=1.e-5_sp +real(sp) :: val,vcrit +integer(spi) :: j,k,n +!============================================================================= +n=size(b,1); if(n/=size(b,2))stop 'In gram; matrix needs to be square' +val=maxval(abs(b)) +nrank=0 +if(val==0)then + b=u0 + return +endif +vcrit=val*crit +do k=1,n + val=sqrt(dot_product(b(:,k),b(:,k))) + if(val<=vcrit)then + b(:,k:n)=u0 + return + endif + b(:,k)=b(:,k)/val + nrank=k + do j=k+1,n + b(:,j)=b(:,j)-b(:,k)*dot_product(b(:,k),b(:,j)) + enddo +enddo +end subroutine plaingram_s + +!============================================================================= +subroutine plaingram_d(b,nrank)! [gram] +!============================================================================= +! A "plain" (unpivoted) version of Gram-Schmidt, for square matrices only. +use jp_pietc, only: u0 +implicit none +real(dp),dimension(:,:),intent(INOUT):: b +integer(spi), intent( OUT):: nrank +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +real(dp),parameter:: crit=1.e-9_dp +real(dp) :: val,vcrit +integer(spi) :: j,k,n +!============================================================================= +n=size(b,1); if(n/=size(b,2))stop 'In gram; matrix needs to be square' +val=maxval(abs(b)) +nrank=0 +if(val==u0)then + b=u0 + return +endif +vcrit=val*crit +do k=1,n + val=sqrt(dot_product(b(:,k),b(:,k))) + if(val<=vcrit)then + b(:,k:n)=u0 + return + endif + b(:,k)=b(:,k)/val + nrank=k + do j=k+1,n + b(:,j)=b(:,j)-b(:,k)*dot_product(b(:,k),b(:,j)) + enddo +enddo +end subroutine plaingram_d + +!============================================================================= +subroutine rowgram(m,n,a,ipiv,tt,b,rank)! [gram] +!============================================================================= +! Without changing (tall) rectangular input matrix a, perform pivoted gram- +! Schmidt operations to orthogonalize the rows, until rows that remain become +! negligible. Record the pivoting sequence in ipiv, and the row-normalization +! in tt(j,j) and the row-orthogonalization in tt(i,j), for i>j. Note that +! tt(i,j)=0 for i=n please' +nepss=n*epss +rank=n +aa=a +tt=u0 +do ii=1,n + +! At this stage, all rows less than ii are already orthonormalized and are +! orthogonal to all rows at and beyond ii. Find the norms of these lower +! rows and pivot the largest of them into position ii: + maxp=u0 + maxi=ii + do i=ii,m + p(i)=dot_product(aa(i,:),aa(i,:)) + if(p(i)>maxp)then + maxp=p(i) + maxi=i + endif + enddo + if(maxpu0,one=>u1,two=>u2 +implicit none +real(dp),dimension(3,3),intent(IN ):: rot +real(dp),dimension(0:3),intent(OUT):: q +!------------------------------------------------------------------------------ +real(dp),dimension(3,3) :: t1,t2 +real(dp),dimension(3) :: u1,u2 +real(dp) :: gamma,gammah,s,ss +integer(spi) :: i,j +integer(spi),dimension(1):: ii +!============================================================================== +! construct the orthogonal matrix, t1, whose third row is the rotation axis +! of rot: +t1=rot; do i=1,3; t1(i,i)=t1(i,i)-1; u1(i)=dot_product(t1(i,:),t1(i,:)); enddo +ii=maxloc(u1); j=ii(1); ss=u1(j) +if(ss<1.e-16_dp)then + q=zero; q(0)=one; return +endif +t1(j,:)=t1(j,:)/sqrt(ss) +if(j/=1)then + u2 =t1(1,:) + t1(1,:)=t1(j,:) + t1(j,:)=u2 +endif +do i=2,3 + t1(i,:)=t1(i,:)-dot_product(t1(1,:),t1(i,:))*t1(1,:) + u1(i)=dot_product(t1(i,:),t1(i,:)) +enddo +if(u1(3)>u1(2))then + j=3 +else + j=2 +endif +ss=u1(j) +if(ss==zero)stop 'In rotov; invalid rot' +if(j/=2)t1(2,:)=t1(3,:) +t1(2,:)=t1(2,:)/sqrt(ss) + +! Form t1(3,:) as the cross product of t1(1,:) and t1(2,:) +t1(3,1)=t1(1,2)*t1(2,3)-t1(1,3)*t1(2,2) +t1(3,2)=t1(1,3)*t1(2,1)-t1(1,1)*t1(2,3) +t1(3,3)=t1(1,1)*t1(2,2)-t1(1,2)*t1(2,1) + +! Project rot into the frame whose axes are the rows of t1: +t2=matmul(t1,matmul(rot,transpose(t1))) + +! Obtain the rotation angle, gamma, implied by rot, and gammah=gamma/2: +gamma=atan2(t2(2,1),t2(1,1)); gammah=gamma/two + +! Hence deduce coefficients (in the form of a real 4-vector) of one of the two +! possible equivalent spinors: +s=sin(gammah) +q(0)=cos(gammah) +q(1:3)=t1(3,:)*s +end subroutine rottoq + +!============================================================================== +subroutine qtorot(q,rot)! [qtorot] +!============================================================================== +! Go from quaternion to rotation matrix representations +!============================================================================== +implicit none +real(dp),dimension(0:3),intent(IN ):: q +real(dp),dimension(3,3),intent(OUT):: rot +!============================================================================= +call setem(q(0),q(1),q(2),q(3),rot) +end subroutine qtorot + +!============================================================================= +subroutine axtoq(v,q)! [axtoq] +!============================================================================= +! Go from an axial 3-vector to its equivalent quaternion +!============================================================================= +implicit none +real(dp),dimension(3), intent(in ):: v +real(dp),dimension(0:3),intent(out):: q +!----------------------------------------------------------------------------- +real(dp),dimension(3,3):: rot +!============================================================================= +call axtorot(v,rot) +call rottoq(rot,q) +end subroutine axtoq + +!============================================================================= +subroutine qtoax(q,v)! [qtoax] +!============================================================================= +! Go from quaternion to axial 3-vector +!============================================================================= +implicit none +real(dp),dimension(0:3),intent(in ):: q +real(dp),dimension(3), intent(out):: v +!----------------------------------------------------------------------------- +real(dp),dimension(3,3):: rot +!============================================================================= +call qtorot(q,rot) +call rottoax(rot,v) +end subroutine qtoax + +!============================================================================= +subroutine setem(c,d,e,g,r)! [setem] +!============================================================================= +implicit none +real(dp), intent(IN ):: c,d,e,g +real(dp),dimension(3,3),intent(OUT):: r +!----------------------------------------------------------------------------- +real(dp):: cc,dd,ee,gg,de,dg,eg,dc,ec,gc +!============================================================================= +cc=c*c; dd=d*d; ee=e*e; gg=g*g +de=d*e; dg=d*g; eg=e*g +dc=d*c; ec=e*c; gc=g*c +r(1,1)=cc+dd-ee-gg; r(2,2)=cc-dd+ee-gg; r(3,3)=cc-dd-ee+gg +r(2,3)=2*(eg-dc); r(3,1)=2*(dg-ec); r(1,2)=2*(de-gc) +r(3,2)=2*(eg+dc); r(1,3)=2*(dg+ec); r(2,1)=2*(de+gc) +end subroutine setem + +!============================================================================= +function mulqq(a,b)result(c)! [mulqq] +!============================================================================= +! Multiply quaternions, a*b, assuming operation performed from right to left +!============================================================================= +implicit none +real(dp),dimension(0:3),intent(IN ):: a,b +real(dp),dimension(0:3) :: c +!------------------------------------------- +c(0)=a(0)*b(0) -a(1)*b(1) -a(2)*b(2) -a(3)*b(3) +c(1)=a(0)*b(1) +a(1)*b(0) +a(2)*b(3) -a(3)*b(2) +c(2)=a(0)*b(2) +a(2)*b(0) +a(3)*b(1) -a(1)*b(3) +c(3)=a(0)*b(3) +a(3)*b(0) +a(1)*b(2) -a(2)*b(1) +end function mulqq +!============================================================================= +subroutine expmat(n,a,b,detb)! [expmat] +!============================================================================= +! Evaluate the exponential, b, of a matrix, a, of degree n. +! Apply the iterated squaring method, m times, to the approximation to +! exp(a/(2**m)) obtained as a Taylor expansion of degree L +! See Fung, T. C., 2004, Int. J. Numer. Meth. Engng, 59, 1273--1286. +!============================================================================= +use jp_pietc, only: u0,u1,u2,o2 +implicit none +integer(spi), intent(IN ):: n +real(dp),dimension(n,n),intent(IN ):: a +real(dp),dimension(n,n),intent(OUT):: b +real(dp), intent(OUT):: detb +!----------------------------------------------------------------------------- +integer(spi),parameter :: L=5 +real(dp),dimension(n,n):: c,p +real(dp) :: t +integer(spi) :: i,m +!============================================================================= +m=10+floor(log(u1+maxval(abs(a)))/log(u2)) +t=o2**m +c=a*t +p=c +b=p +do i=2,L + p=matmul(p,c)/i + b=b+p +enddo +do i=1,m + b=b*u2+matmul(b,b) +enddo +do i=1,n + b(i,i)=b(i,i)+u1 +enddo +detb=u0; do i=1,n; detb=detb+a(i,i); enddo; detb=exp(detb) +end subroutine expmat + +!============================================================================= +subroutine expmatd(n,a,b,bd,detb,detbd)! [expmat] +!============================================================================= +! Like expmat, but for the 1st derivatives also. +!============================================================================= +use jp_pietc, only: u0,u1,u2,o2 +implicit none +integer(spi), intent(IN ):: n +real(dp),dimension(n,n), intent(IN ):: a +real(dp),dimension(n,n), intent(OUT):: b +real(dp),dimension(n,n,(n*(n+1))/2),intent(OUT):: bd +real(dp), intent(OUT):: detb +real(dp),dimension((n*(n+1))/2), intent(OUT):: detbd +!----------------------------------------------------------------------------- +integer(spi),parameter :: L=5 +real(dp),dimension(n,n) :: c,p +real(dp),dimension(n,n,(n*(n+1))/2):: pd,cd +real(dp) :: t +integer(spi) :: i,j,k,m,n1 +!============================================================================= +n1=(n*(n+1))*o2 +m=10+floor(log(u1+maxval(abs(a)))/log(u2)) +t=o2**m +c=a*t +p=c +pd=u0 +do k=1,n + pd(k,k,k)=t +enddo +k=n +do i=1,n-1 + do j=i+1,n + k=k+1 + pd(i,j,k)=t + pd(j,i,k)=t + enddo +enddo +if(k/=n1)stop 'In expmatd; n1 is inconsistent with n' +cd=pd +b=p +bd=pd + +do i=2,L + do k=1,n1 + pd(:,:,k)=(matmul(cd(:,:,k),p)+matmul(c,pd(:,:,k)))/i + enddo + p=matmul(c,p)/i + b=b+p + bd=bd+pd +enddo +do i=1,m + do k=1,n1 + bd(:,:,k)=2*bd(:,:,k)+matmul(bd(:,:,k),b)+matmul(b,bd(:,:,k)) + enddo + b=b*u2+matmul(b,b) +enddo +do i=1,n + b(i,i)=b(i,i)+u1 +enddo +detb=u0; do i=1,n; detb=detb+a(i,i); enddo; detb=exp(detb) +detbd=u0; do k=1,n; detbd(k)=detb; enddo +end subroutine expmatd + +!============================================================================= +subroutine expmatdd(n,a,b,bd,bdd,detb,detbd,detbdd)! [expmat] +!============================================================================= +! Like expmat, but for the 1st and 2nd derivatives also. +!============================================================================= +use jp_pietc, only: u0,u1,u2,o2 +implicit none +integer(spi), intent(IN ):: n +real(dp),dimension(n,n), intent(IN ):: a +real(dp),dimension(n,n), intent(OUT):: b +real(dp),dimension(n,n,(n*(n+1))/2), intent(OUT):: bd +real(dp),dimension(n,n,(n*(n+1))/2,(n*(n+1))/2),intent(OUT):: bdd +real(dp), intent(OUT):: detb +real(dp),dimension((n*(n+1))/2), intent(OUT):: detbd +real(dp),dimension((n*(n+1))/2,(n*(n+1))/2), intent(OUT):: detbdd +!----------------------------------------------------------------------------- +integer(spi),parameter :: L=5 +real(dp),dimension(n,n) :: c,p +real(dp),dimension(n,n,(n*(n+1))/2) :: pd,cd +real(dp),dimension(n,n,(n*(n+1))/2,(n*(n+1))/2):: pdd,cdd +real(dp) :: t +integer(spi) :: i,j,k,ki,kj,m,n1 +!============================================================================= +n1=(n*(n+1))/2 +m=10+floor(log(u1+maxval(abs(a)))/log(u2)) +t=o2**m +c=a*t +p=c +pd=u0 +pdd=u0 +do k=1,n + pd(k,k,k)=t +enddo +k=n +do i=1,n-1 + do j=i+1,n + k=k+1 + pd(i,j,k)=t + pd(j,i,k)=t + enddo +enddo +if(k/=n1)stop 'In expmatd; n1 is inconsistent with n' +cd=pd +cdd=u0 +b=p +bd=pd +bdd=u0 + +do i=2,L + do ki=1,n1 + do kj=1,n1 + pdd(:,:,ki,kj)=(matmul(cd(:,:,ki),pd(:,:,kj)) & + + matmul(cd(:,:,kj),pd(:,:,ki)) & + + matmul(c,pdd(:,:,ki,kj)))/i + enddo + enddo + do k=1,n1 + pd(:,:,k)=(matmul(cd(:,:,k),p)+matmul(c,pd(:,:,k)))/i + enddo + p=matmul(c,p)/i + b=b+p + bd=bd+pd + bdd=bdd+pdd +enddo +do i=1,m + do ki=1,n1 + do kj=1,n1 + bdd(:,:,ki,kj)=u2*bdd(:,:,ki,kj) & + +matmul(bdd(:,:,ki,kj),b) & + +matmul(bd(:,:,ki),bd(:,:,kj)) & + +matmul(bd(:,:,kj),bd(:,:,ki)) & + +matmul(b,bdd(:,:,ki,kj)) + enddo + enddo + do k=1,n1 + bd(:,:,k)=2*bd(:,:,k)+matmul(bd(:,:,k),b)+matmul(b,bd(:,:,k)) + enddo + b=b*u2+matmul(b,b) +enddo +do i=1,n + b(i,i)=b(i,i)+u1 +enddo +detb=u0; do i=1,n; detb=detb+a(i,i); enddo; detb=exp(detb) +detbd=u0; do k=1,n; detbd(k)=detb; enddo +detbdd=u0; do ki=1,n; do kj=1,n; detbdd(ki,kj)=detb; enddo; enddo +end subroutine expmatdd + +!============================================================================= +subroutine zntay(n,z,zn)! [zntay] +!============================================================================= +use jp_pietc, only: u2 +implicit none +integer(spi), intent(IN ):: n +real(dp), intent(IN ):: z +real(dp), intent(OUT):: zn +!----------------------------------------------------------------------------- +integer(spi),parameter:: ni=100 +real(dp),parameter :: eps0=1.e-16_dp +integer(spi) :: i,i2,n2 +real(dp) :: t,eps,z2 +!============================================================================= +z2=z*u2 +n2=n*2 +t=1 +do i=1,n + t=t/(i*2-1) +enddo +eps=t*eps0 +zn=t +do i=1,ni + i2=i*2 + t=t*z2/(i2*(i2+n2-1)) + zn=zn+t + if(abs(t)u0)then + zn=cosh(rz2) + znd=sinh(rz2)/rz2 + zndd=(zn-znd)/z2 + znddd=(znd-u3*zndd)/z2 + do i=1,n + i2p3=i*2+3 + zn=znd + znd=zndd + zndd=znddd + znddd=(znd-i2p3*zndd)/z2 + enddo + else + zn=cos(rz2) + znd=sin(rz2)/rz2 + zndd=-(zn-znd)/z2 + znddd=-(znd-u3*zndd)/z2 + do i=1,n + i2p3=i*2+3 + zn=znd + znd=zndd + zndd=znddd + znddd=-(znd-i2p3*zndd)/z2 + enddo + endif +endif +end subroutine znfun + +!============================================================================= +! Utility code for various Mobius transformations. If aa1,bb1,cc1,dd1 are +! the coefficients for one transformation, and aa2,bb2,cc2,dd2 are the +! coefficients for a second one, then the coefficients for the mapping +! of a test point, zz, by aa1 etc to zw, followed by a mapping of zw, by +! aa2 etc to zv, is equivalent to a single mapping zz-->zv by the transformatn +! with coefficients aa3,bb3,cc3,dd3, such that, as 2*2 complex matrices: +! +! [ aa3, bb3 ] [ aa2, bb2 ] [ aa1, bb1 ] +! [ ] = [ ] * [ ] +! [ cc3, dd3 ] [ cc2, dd2 ] [ cc1, dd1 ] . +! +! Note that the determinant of these matrices is always +1 +! +!============================================================================= +subroutine ctoz(v, z,infz)! [ctoz] +!============================================================================= +use jp_pietc, only: u0,u1 +implicit none +real(dp),dimension(3),intent(IN ):: v +complex(dpc), intent(OUT):: z +logical, intent(OUT):: infz +!----------------------------------------------------------------------------- +real(dp) :: rr,zzpi +!============================================================================= +infz=.false. +z=cmplx(v(1),v(2),dpc) +if(v(3)>u0)then + zzpi=u1/(u1+v(3)) +else + rr=v(1)**2+v(2)**2 + infz=(rr==u0); if(infz)return ! <- The point is mapped to infinity (90S) + zzpi=(u1-v(3))/rr +endif +z=z*zzpi +end subroutine ctoz + +!============================================================================= +subroutine ztoc(z,infz, v)! [ztoc] +!============================================================================= +implicit none +complex(dpc), intent(IN ):: z +logical, intent(IN ):: infz +real(dp),dimension(3),intent(OUT):: v +!----------------------------------------------------------------------------- +real(dp),parameter:: zero=0_dp,one=1_dp,two=2_dp +real(dp) :: r,q,rs,rsc,rsbi +!============================================================================= +if(infz)then; v=(/zero,zero,-one/); return; endif +r=real(z); q=aimag(z); rs=r*r+q*q +rsc=one-rs +rsbi=one/(one+rs) +v(1)=two*rsbi*r +v(2)=two*rsbi*q +v(3)=rsc*rsbi +end subroutine ztoc + +!============================================================================= +subroutine ztocd(z,infz, v,vd)! [ztoc] +!============================================================================= +! The convention adopted for the complex derivative is that, for a complex +! infinitesimal map displacement, delta_z, the corresponding infinitesimal +! change of cartesian vector position is delta_v given by: +! delta_v = Real(vd*delta_z). +! Thus, by a kind of Cauchy-Riemann relation, Imag(vd)=v CROSS Real(vd). +! THE DERIVATIVE FOR THE IDEAL POINT AT INFINITY HAS NOT BEEN CODED YET!!! +!============================================================================= +implicit none +complex(dpc), intent(IN ):: z +logical, intent(IN ):: infz +real(dp),dimension(3), intent(OUT):: v +complex(dpc),dimension(3),intent(OUT):: vd +!----------------------------------------------------------------------------- +real(dp),parameter :: zero=0_dp,one=1_dp,two=2_dp,four=4_dp +real(dp) :: r,q,rs,rsc,rsbi,rsbis +real(dp),dimension(3):: u1,u2 +integer(spi) :: i +!============================================================================= +if(infz)then; v=(/zero,zero,-one/); return; endif +r=real(z); q=aimag(z); rs=r*r+q*q +rsc=one-rs +rsbi=one/(one+rs) +rsbis=rsbi**2 +v(1)=two*rsbi*r +v(2)=two*rsbi*q +v(3)=rsc*rsbi +u1(1)=two*(one+q*q-r*r)*rsbis +u1(2)=-four*r*q*rsbis +u1(3)=-four*r*rsbis +u2=cross_product(v,u1) +do i=1,3 + vd(i)=cmplx(u1(i),-u2(i),dpc) +enddo +end subroutine ztocd + +!============================================================================ +subroutine setmobius(xc0,xc1,xc2, aa,bb,cc,dd)! [setmobius] +!============================================================================ +! Find the Mobius transformation complex coefficients, aa,bb,cc,dd, +! with aa*dd-bb*cc=1, for a standard (north-)polar stereographic transformation +! that takes cartesian point, xc0 to the north pole, xc1 to (lat=0,lon=0), +! xc2 to the south pole (=complex infinity). +!============================================================================ +implicit none +real(dp),dimension(3),intent(IN ):: xc0,xc1,xc2 +complex(dpc), intent(OUT):: aa,bb,cc,dd +!---------------------------------------------------------------------------- +real(dp),parameter:: zero=0_dp,one=1_dp +logical :: infz0,infz1,infz2 +complex(dpc) :: z0,z1,z2,z02,z10,z21 +!============================================================================ +call ctoz(xc0,z0,infz0) +call ctoz(xc1,z1,infz1) +call ctoz(xc2,z2,infz2) +z21=z2-z1 +z02=z0-z2 +z10=z1-z0 + +if( (z0==z1.and.infz0.eqv.infz1).or.& + (z1==z2.and.infz1.eqv.infz2).or.& + (z2==z0.and.infz2.eqv.infz0)) & + stop 'In setmobius; anchor points must be distinct' + +if(infz2 .or. (.not.infz0 .and. abs(z0)= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_S(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_N(:,i,j)=W(:,i,jmax-nby+j) + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + + end if +! +! RECEIVE boundaries from NORTH and SOUTH +! + +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( rBuf_N(1:km_in,1:imax,nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( rBuf_S(1:km_in,1:imax,nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + end if +! +! Assign received values from NORTH and SOUTH +! +! From SOUTH + + if(lsouth) then + + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=W(:,i,nby+1-j) + end do + end do + + else + + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=rBuf_S(:,i,j) + enddo + enddo + + endif + + +! --- from NORTH --- + + if( lnorth) then + + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=W(:,i,jmax+1-j) + enddo + enddo + + else + + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=rBuf_N(:,i,j) + enddo + enddo + + endif + +!---------------------------------------------------------------------- +! +! SEND extended boundaries toward WEST and EAST +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_W(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_E(:,i,j) = W(:,imax-nbx+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + + end if + +! +! RECEIVE boundaries from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( rBuf_E(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + allocate( rBuf_W(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + end if + + +! +! Assign received values from EAST and WEST +! + +! From west + + if(lwest) then + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j)= W(:,nbx+1-i,j) + end do + end do + + else + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j)= rBuf_W(:,i,j) + enddo + enddo + + + endif + +! From east + + if(least) then + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j)=W(:,imax+1-i,j) + end do + end do + + else + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j)=rBuf_E(:,i,j) + enddo + enddo + + endif + + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + end if + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + end if + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + end if + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + end if + +! +! DEALLOCATE sBufferes +! + + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_S, stat = ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_N, stat = ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_E, stat = ierr ) + end if + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_W, stat = ierr ) + end if + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine boco_2d_g1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine boco_2d_gh & +!**********************************************************************! +! ! +! Side sending subroutine: ! +! Supplies (nbx,nby) lines of halos in (x,y) directions assuming ! +! mirror boundary conditions. Version for high generations ! +! ! +! - offset version - ! +! ! +!**********************************************************************! +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max +real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_N,sBuf_E,sBuf_S,sBuf_W & + ,rBuf_N,rBuf_E,rBuf_S,rBuf_W + +integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax +logical:: lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,l,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax,ndatay +integer(i_kind) g_ind,g +logical l_sidesend +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit communications to selected number of generations +! + + if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then + g_ind=2 + g = my_hgen + l_sidesend=.true. + else + l_sidesend=.false. + endif + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +FILT_GRID: if(l_sidesend) then + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! from mg_domain +! + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + + if(least) then + imax = Fimax_in(g) + else + imax = im_in ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax_in(g) + else + jmax = jm_in + endif + + +!----------------------------------------------------------------------- + ndatay = km_in*imax*nby + ndatax = km_in*(jmax+2*nby)*nbx + + +! +! SEND boundaries to SOUTH and NORTH +! + +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_S(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_N(:,i,j)=W(:,i,jmax-nby+j) + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + + end if +! +! RECEIVE boundaries from NORTH and SOUTH +! + +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( rBuf_N(1:km_in,1:imax,nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( rBuf_S(1:km_in,1:imax,nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + end if + +! +! Assign received values from NORTH and SOUTH +! + + +! From south + + if(lsouth) then + + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=W(:,i,nby+1-j) + end do + end do + + else + + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=rBuf_S(:,i,j) + enddo + enddo + + endif + + +! --- from NORTH --- + + if( lnorth) then + + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=W(:,i,jmax+1-j) + enddo + enddo + + else + + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=rBuf_N(:,i,j) + enddo + enddo + + endif + +! +! SEND extended boundaries to WEST and EASTH +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_W(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_E(:,i,j) = W(:,imax-nbx+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + + end if + +! +! RECEIVE extended boundaries from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( rBuf_E(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + allocate( rBuf_W(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + end if + +! +! Assign received values from WEST and EAST +! + +! From west + + if(lwest) then + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j)= W(:,nbx+1-i,j) + end do + end do + + else + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j)= rBuf_W(:,i,j) + enddo + enddo + + + endif + +! From east + + if(least) then + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j)=W(:,imax+1-i,j) + end do + end do + + else + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j)=rBuf_E(:,i,j) + enddo + enddo + + endif + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + end if + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + end if + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + end if + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + end if + +! +! DEALLOCATE sBufferes +! + + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_W, stat = ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_E, stat = ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_S, stat = ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_N, stat = ierr ) + end if + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + endif FILT_GRID + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine boco_2d_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoT_2d_g1 & +!*********************************************************************** +! ! +! Adjoint of side sending subroutine: ! +! Supplies (nbx,nby) lines of halos in (x,y) directions, including ! +! values at the edges of the subdomains and assuming mirror boundary ! +! conditions just for generation 1 ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,km_in,im_in,jm_in,nbx,nby) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby +real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_N,sBuf_E,sBuf_S,sBuf_W & + ,rBuf_N,rBuf_E,rBuf_S,rBuf_W + +integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax +logical lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,L,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax,ndatay +logical l_sidesend +integer(i_kind) g_ind,g,k +!----------------------------------------------------------------------- +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +! +! Limit comminications to selected number of generations +! + + + g_ind=1 +! +! from mg_domain +! + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + imax = im_in + jmax = jm_in + + +!---------------------------------------------------------------------- + ndatax =km_in*(jmax+2*nby)*nbx + ndatay =km_in*imax*nby +! +! SEND extended halos toward WEST and EAST +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_W(:,i,j) = W(:,-nbx+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_E(:,i,j) = W(:,imax+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + + end if + +! +! RECEIVE extended halos from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + + allocate( rBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + + allocate( rBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + + end if + +! +! Assign received halos from WEST and EAST to interrior of domains +! + +! From west + + if(lwest) then + do j=1-nby,jmax+nby + do i=1,nbx + W(:,i,j)= W(:,i,j)+W(:,1-i,j) + end do + end do + else + do j=1-nby,jmax+nby + do i=1,nbx + W(:,i,j)= W(:,i,j)+rBuf_W(:,i,j) + end do + end do + endif + +! From east + + if(least) then + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+W(:,imax+1+nbx-i,j) + end do + end do + else + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+rBuf_E(:,i,j) + end do + end do + endif + +! +! SEND boundaries SOUTH and NORTH +! +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) + + do j=1-nby,0 + do i=1,imax + sBuf_S(:,i,j+nby) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_N(:,i,j)=W(:,i,jmax+j) + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + + end if + +! +! RECEIVE boundaries from NORTH and SOUTH +! +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + + allocate( rBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + + allocate( rBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + + end if + +! +! ASSIGN received values from SOUTH and NORTH +! + +! From south + + if(lsouth) then + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+W(:,i,1-j) + end do + end do + else + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+rBuf_S(:,i,j) + end do + end do + endif + +! From north + + if(lnorth) then + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+W(:,i,jmax+1+nby-j) + enddo + enddo + else + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+rBuf_N(:,i,j) + enddo + enddo + endif + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + + deallocate( rBuf_W, stat = iderr) + deallocate( rBuf_E, stat = iderr) + deallocate( rBuf_S, stat = iderr) + deallocate( rBuf_N, stat = iderr) + +! +! DEALLOCATE sBufferes +! + + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + end if + + +!----------------------------------------------------------------------- +endsubroutine bocoT_2d_g1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoT_2d_gh & +!*********************************************************************** +! ! +! Supply n-lines inside of domains, including edges, with halos from ! +! the surrounding domains. Assume mirror boundary conditions at the ! +! boundaries of the domain. For high multigrid generations. ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max +real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_N,sBuf_E,sBuf_S,sBuf_W & + ,rBuf_N,rBuf_E,rBuf_S,rBuf_W +integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax +logical lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,L,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax,ndatay +logical l_sidesend +integer(i_kind) g_ind,g,k +!----------------------------------------------------------------------- +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +! +! Limit comminications to selected number of generations +! + + + if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then + g_ind=2 + g = my_hgen + l_sidesend=.true. + else + l_sidesend=.false. + endif + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +FILT_GRID: if(l_sidesend) then + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +! +! from mg_domain +! + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + + if(least) then + imax = Fimax_in(g) + else + imax = im_in ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax_in(g) + else + jmax = jm_in + endif + + +!---------------------------------------------------------------------- + ndatax =km_in*(jmax+2*nby)*nbx + ndatay =km_in*imax*nby + +! +! SEND extended halos toward WEST and EAST +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_W(:,i,j) = W(:,-nbx+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_E(:,i,j) = W(:,imax+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + + end if + +! +! RECEIVE extended halos from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( rBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + allocate( rBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + end if +! +! Assign received values from WEST and EAST +! + +! From west + + if(lwest) then + do j=1-nby,jmax+nby + do i=1,nbx + W(:,i,j)= W(:,i,j)+W(:,1-i,j) + end do + end do + else + do j=1-nby,jmax+nby + do i=1,nbx + W(:,i,j)= W(:,i,j)+rBuf_W(:,i,j) + end do + end do + endif + +! From east + + if(least) then + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+W(:,imax+1+nbx-i,j) + end do + end do + else + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+rBuf_E(:,i,j) + end do + end do + endif + +! +! SEND halos toward SOUTH and NORTH +! +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_S(:,i,j) = W(:,i,-nby+j) + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_N(:,i,j)=W(:,i,jmax+j) + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + + end if + +! +! RECEIVE halos from NORTH and SOUTH +! +! +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + + allocate( rBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + + allocate( rBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + + end if + +! +! Assign received values from SOUTH and NORTH +! + +! From south + + if(lsouth) then + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+W(:,i,1-j) + end do + end do + else + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+rBuf_S(:,i,j) + end do + end do + endif + +! From north + + if(lnorth) then + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+W(:,i,jmax+1+nby-j) + enddo + enddo + else + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+rBuf_N(:,i,j) + enddo + enddo + endif + +!----------------------------------------------------------------------- + +! DEALLOCATE rBufferes + + deallocate( rBuf_W, stat = iderr) + deallocate( rBuf_E, stat = iderr) + deallocate( rBuf_S, stat = iderr) + deallocate( rBuf_N, stat = iderr) + +! DEALLOCATE sBufferes + + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + end if + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + endif FILT_GRID + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine bocoT_2d_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine boco_3d_g1 & +!**********************************************************************! +! ! +! Side sending subroutine: ! +! Supplies (nbx,nby) lines of halos in (x,y) directions assuming ! +! mirror boundary conditions. Version for generation 1 ! +! ! +! - offset version - ! +! ! +!**********************************************************************! +(this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz +real(r_kind),dimension(km3_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz) & + ,intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- + +real(r_kind), allocatable, dimension(:,:,:,:):: & + sBuf_N,sBuf_E,sBuf_S,sBuf_W & + ,rBuf_N,rBuf_E,rBuf_S,rBuf_W + +integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax +logical:: lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,l,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax,ndatay +integer(i_kind) g_ind,g +logical l_sidesend +!----------------------------------------------------------------------- +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +! +! Limit communications to generation one +! + g_ind=1 + + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + imax = im_in + jmax = jm_in + +!----------------------------------------------------------------------- + ndatay = km3_in*imax*nby*Lm + ndatax = km3_in*(jmax+2*nby)*nbx*Lm_in + + +! +! SEND boundaries toward SOUTH and NORTH +! + +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr ) + + do L=1,Lm_in + do j=1,nby + do i=1,imax + sBuf_S(:,i,j,L) = W(:,i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr ) + + do L=1,Lm_in + do j=1,nby + do i=1,imax + sBuf_N(:,i,j,L)=W(:,i,jmax-nby+j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + + end if +! +! RECEIVE boundaries from NORTH and SOUTH +! + +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( rBuf_N(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( rBuf_S(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + end if +! +! Assign received values from NORTH and SOUTH +! + +! --- from NORTH --- + + if( lnorth) then + + do L=1,Lm_in + do j=1,nby + do i=1,imax + W(:,i,jmax+j,L)=W(:,i,jmax+1-j,L) + enddo + enddo + enddo + + else + + do L=1,Lm_in + do j=1,nby + do i=1,imax + W(:,i,jmax+j,L)=rBuf_N(:,i,j,L) + enddo + enddo + enddo + + endif + +! From south + + if(lsouth) then + + do L=1,Lm_in + do j=1,nby + do i=1,imax + W(:,i,-nby+j,L)=W(:,i,nby+1-j,L) + end do + end do + end do + + else + + do L=1,Lm_in + do j=1,nby + do i=1,imax + W(:,i,-nby+j,L)=rBuf_S(:,i,j,L) + enddo + enddo + enddo + + endif + +! +! SEND extended boundaries toward WEST and EAST +! +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_W(:,i,j,L) = W(:,i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_E(:,i,j,L) = W(:,imax-nbx+i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + + end if + +! +! RECEIVE boundaries WEST and EAST +! + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + allocate( rBuf_W(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + end if + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( rBuf_E(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! +! Assign received values from EAST and WEST +! +! From west + + if(lwest) then + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j,L)= W(:,nbx+1-i,j,L) + end do + end do + end do + + else + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j,L)= rBuf_W(:,i,j,L) + enddo + enddo + enddo + + + endif + +! From east + + if(least) then + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j,L)=W(:,imax-i,j,L) + end do + end do + end do + + else + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j,L)=rBuf_E(:,i,j,L) + enddo + enddo + enddo + + endif + +!------------------------------------------------------------------ +! +! DEALLOCATE rBufferes +! + + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + end if + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + end if + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + end if + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + end if + +! +! DEALLOCATE sBufferes +! + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_W, stat = ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_E, stat = ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_S, stat = ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_N, stat = ierr ) + end if + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + +!----------------------------------------------------------------------- +endsubroutine boco_3d_g1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine boco_3d_gh & +!**********************************************************************! + +! Side sending subroutine: ! +! Supplies (nbx,nby) lines of halos in (x,y) directions assuming ! +! mirror boundary conditions. Version for high generations ! +! ! +! - offset version - ! +! ! +!**********************************************************************! +(this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,mygen_min,mygen_max +real(r_kind),dimension(km3_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz) & + ,intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- + +real(r_kind), allocatable, dimension(:,:,:,:):: & + sBuf_N,sBuf_E,sBuf_S,sBuf_W & + ,rBuf_N,rBuf_E,rBuf_S,rBuf_W + +integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax +logical:: lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,l,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax,ndatay +integer(i_kind) g_ind,g +logical l_sidesend +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit communications to selected number of generations +! + if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then + g_ind=2 + g = my_hgen + l_sidesend=.true. + else + l_sidesend=.false. + endif + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +FILT_GRID: if(l_sidesend) then + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! from mg_domain +! + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + if(least) then + imax = Fimax_in(g) + else + imax = im_in ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax_in(g) + else + jmax = jm_in + endif + + +!----------------------------------------------------------------------- + ndatay = km3_in*imax*nby*Lm + ndatax = km3_in*(jmax+2*nby)*nbx*Lm + +! +! SEND boundaries to SOUTH and NORTH +! + +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr ) + + do L=1,Lm_in + do j=1,nby + do i=1,imax + sBuf_S(:,i,j,L) = W(:,i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr ) + + do L=1,Lm_in + do j=1,nby + do i=1,imax + sBuf_N(:,i,j,L)=W(:,i,jmax-nby+j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + + end if +! +! RECEIVE boundaries from SOUTH and NORTH +! + +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( rBuf_N(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( rBuf_S(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + end if + +!TEST + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_N, stat = ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_S, stat = ierr ) + end if +!TEST + +! +! Assign received values from NORTH and SOUTH +! + +! --- from NORTH --- + + if( lnorth) then + + do L=1,Lm_in + do j=1,nby + do i=1,imax + W(:,i,jmax+j,L)=W(:,i,jmax+1-j,L) + enddo + enddo + enddo + + else + + do L=1,Lm_in + do j=1,nby + do i=1,imax + W(:,i,jmax+j,L)=rBuf_N(:,i,j,L) + enddo + enddo + enddo + + endif + +! From south + + if(lsouth) then + + do L=1,Lm_in + do j=1,nby + do i=1,imax + W(:,i,-nby+j,L)=W(:,i,nby+1-j,L) + end do + end do + end do + + else + + do L=1,Lm_in + do j=1,nby + do i=1,imax + W(:,i,-nby+j,L)=rBuf_S(:,i,j,L) + enddo + enddo + enddo + + endif + +!TEST + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + endif + + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + endif +!TEST + + +! +! SEND extended boundaries to WEST and EAST +! +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_W(:,i,j,L) = W(:,i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_E(:,i,j,L) = W(:,imax-nbx+i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + + end if + +! +! RECEIVE boundaries from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( rBuf_E(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + allocate( rBuf_W(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! +! Deallocate send bufferes from EAST and WEST +! + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_E, stat = ierr ) + end if + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_W, stat = ierr ) + end if + +! +! Assign received values from WEST and EAST +! +! From west + + if(lwest) then + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j,L)= W(:,nbx+1-i,j,L) + end do + end do + end do + + else + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j,L)= rBuf_W(:,i,j,L) + enddo + enddo + enddo + + + endif + +! From east + + if(least) then + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j,L)=W(:,imax+1-i,j,L) + end do + end do + end do + + else + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j,L)=rBuf_E(:,i,j,L) + enddo + enddo + enddo + + endif + +! +! Set up mirror b.c. at the bottom and top of domain +! + do L=1,nbz + W(:,:,:,1-L )=W(:,:,:, 1+L) + W(:,:,:,LM+L)=W(:,:,:,LM-L) + end do + + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + endif + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + endif + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + endif FILT_GRID + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine boco_3d_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoT_3d_g1 & +!*********************************************************************** +! * +! Supply n-lines inside of domains, including edges, with halos from * +! the surrounding domains. Assume mirror boundary conditions at the * +! boundaries of the domain * +! ! +! - offset version - ! +! * +!*********************************************************************** +(this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz +real(r_kind), dimension(km3_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz) & + ,intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- + +real(r_kind), allocatable, dimension(:,:,:,:):: & + sBuf_N,sBuf_E,sBuf_S,sBuf_W & + ,rBuf_N,rBuf_E,rBuf_S,rBuf_W + +integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax +logical lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,L,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax,ndatay +logical l_sidesend +integer(i_kind) g_ind,g,k +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit comminications to selected number of generations +! + + g_ind=1 + +! +! from mg_domain +! + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + + imax = im + jmax = jm + +!---------------------------------------------------------------------- + ndatax =km3_in*(jmax+2*nby)*nbx *Lm_in + ndatay =km3_in*imax*nby *Lm_in + +! +! SEND extended halos toward WEST and EAST +! +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km3_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + + do L=Lm_in,1,-1 + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_W(:,i,j,L) = W(:,-nbx+i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km3_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + + do L=Lm_in,1,-1 + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_E(:,i,j,L) = W(:,imax+i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + + end if +! +! RECEIVE extended halos from EAST and WEST +! +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + + allocate( rBuf_E(1:km3_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + + allocate( rBuf_W(1:km3_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + + end if +! +! Assign received extended halos from WEST and EAST to interior of domains +! + +! From west + + if(lwest) then + do L=1,lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,i,j,L)= W(:,i,j,L)+W(:,1-i,j,L) + end do + end do + end do + else + do L=1,lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,i,j,L)= W(:,i,j,L)+rBuf_W(:,i,j,L) + end do + end do + end do + endif + +! From east + + if(least) then + do L=1,lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax-nbx+i,j,L)= W(:,imax-nbx+i,j,L)+W(:,imax+nbx-i,j,L) + end do + end do + end do + else + do L=1,lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax-nbx+i,j,L)= W(:,imax-nbx+i,j,L)+rBuf_E(:,i,j,L) + end do + end do + end do + endif + +! +! Send halos SOUTH and NORTH +! + +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km3_in,1:imax,1:nby,1:Lm_in), stat = iaerr ) + + do L=Lm_in,1,-1 + do j=1-nby,0 + do i=1,imax + sBuf_S(:,i,j+nby,L) = W(:,i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km3_in,1:imax,1:nby,1:Lm_in), stat = iaerr ) + + do L=Lm_in,1,-1 + do j=1,nby + do i=1,imax + sBuf_N(:,i,j,L)=W(:,i,jmax+j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + + end if + + +! +! RECEIVE boundaries from NORTH and SOUTH +! +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + + allocate( rBuf_N(1:km3_in,1:imax,1:nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + + allocate( rBuf_S(1:km3_in,1:imax,1:nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + + end if + +! +! Assign received values from SOUTH and NORTH +! + +! From south + + if(lsouth) then + do L=1,lm_in + do j=1,nby + do i=1,imax + W(:,i,j,L)= W(:,i,j,L)+W(:,i,1-j,L) + end do + end do + end do + else + do L=1,lm_in + do j=1,nby + do i=1,imax + W(:,i,j,L)= W(:,i,j,L)+rBuf_S(:,i,j,L) + end do + end do + end do + endif + +! From north + + if(lnorth) then + do L=1,lm_in + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j,L)= W(:,i,jmax-nby+j,L)+W(:,i,jmax+nby-j,L) + enddo + enddo + enddo + else + do L=1,lm_in + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j,L)= W(:,i,jmax-nby+j,L)+rBuf_N(:,i,j,L) + enddo + enddo + enddo + endif + +!---------------------------------------------------------------------- +! +! Set up mirror b.c. at the bottom and top of domain +! + do L=1,nbz + W(:,:,:,1+L )=W(:,:,:, 1+L)+W(:,:,:, 1-L) + W(:,:,:,LM-L)=W(:,:,:,LM-L)+W(:,:,:,LM+L) + end do + + +!---------------------------------------------------------------------- +! +! DEALLOCATE sBufferes +! + + + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_W, stat = ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_E, stat = ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_S, stat = ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_N, stat = ierr ) + end if + + + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + endif + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + endif + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + endif + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + endif + + +!----------------------------------------------------------------------- +endsubroutine bocoT_3d_g1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoT_3d_gh & +!*********************************************************************** +! * +! Supply n-lines inside of domains, including edges, with halos from * +! the surrounding domains. Assume mirror boundary conditions at the * +! boundaries of the domain * +! ! +! - offset version - ! +! * +!*********************************************************************** +(this,W,km_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,Lm_in,nbx,nby,nbz,mygen_min,mygen_max +real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz) & + ,intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:,:):: & + sBuf_N,sBuf_E,sBuf_S,sBuf_W & + ,rBuf_N,rBuf_E,rBuf_S,rBuf_W + +integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax +logical lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,L,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax,ndatay +logical l_sidesend +integer(i_kind) g_ind,g,k +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit comminications to selected number of generations +! + + if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then + g_ind=2 + g = my_hgen + l_sidesend=.true. + else + l_sidesend=.false. + endif + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +FILT_GRID: if(l_sidesend) then + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +! +! from mg_domain +! + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + if(least) then + imax = Fimax_in(g) + else + imax = im_in ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax_in(g) + else + jmax = jm_in + endif + + +!---------------------------------------------------------------------- + ndatax =km_in*(jmax+2*nby)*nbx *Lm_in + ndatay =km_in*imax*nby *Lm_in + +! +! SEND extended halos toward WEST and EAST +! +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + + do L=Lm_in,1,-1 + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_W(:,i,j,L) = W(:,-nbx+i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + + do L=Lm_in,1,-1 + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_E(:,i,j,L) = W(:,imax+i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + end if + +! +! RECEIVE extended halos from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + + allocate( rBuf_E(1:km_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + + allocate( rBuf_W(1:km_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + + end if + +! +! Assign received extended halos from WEST and EAST +! + +! From west + + if(lwest) then + do L=1,lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,i,j,L)= W(:,i,j,L)+W(:,1-i,j,L) + end do + end do + end do + else + do L=1,lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,i,j,L)= W(:,i,j,L)+rBuf_W(:,i,j,L) + end do + end do + end do + endif + +! From east + + if(least) then + do L=1,lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax-nbx+i,j,L)= W(:,imax-nbx+i,j,L)+W(:,imax+1+nbx-i,j,L) + end do + end do + end do + else + do L=1,lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax-nbx+i,j,L)= W(:,imax-nbx+i,j,L)+rBuf_E(:,i,j,L) + end do + end do + end do + endif + +! +! SEND halos toward SOUTH and NORTH +! + +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,1:nby,1:Lm_in), stat = iaerr ) + + do L=Lm_in,1,-1 + do j=1-nby,0 + do i=1,imax + sBuf_S(:,i,j+nby,L) = W(:,i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,1:nby,1:Lm_in), stat = iaerr ) + + do L=Lm_in,1,-1 + do j=1,nby + do i=1,imax + sBuf_N(:,i,j,L)=W(:,i,jmax+j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + + end if + +! +! RECEIVE halos from NORTH and SOUTH +! +! +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + + allocate( rBuf_N(1:km_in,1:imax,1:nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + + allocate( rBuf_S(1:km_in,1:imax,1:nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + + end if + + +!----------------------------------------------------------------------- +! +! Assign received halos from SOUTH and NORTH +! + + if(lsouth) then + do L=1,lm_in + do j=1,nby + do i=1,imax + W(:,i,j,L)= W(:,i,j,L)+W(:,i,1-j,L) + end do + end do + end do + else + do L=1,lm_in + do j=1,nby + do i=1,imax + W(:,i,j,L)= W(:,i,j,L)+rBuf_S(:,i,j,L) + end do + end do + end do + endif + +! From north + + if(lnorth) then + do L=1,lm_in + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j,L)= W(:,i,jmax-nby+j,L)+W(:,i,jmax+1+nby-j,L) + enddo + enddo + enddo + else + do L=1,lm_in + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j,L)= W(:,i,jmax-nby+j,L)+rBuf_N(:,i,j,L) + enddo + enddo + enddo + endif + + +! +! Set up mirror b.c. at the bottom and top of domain +! + do L=1,nbz + W(:,:,:,1+L )=W(:,:,:, 1+L)+W(:,:,:, 1-L) + W(:,:,:,LM-L)=W(:,:,:,LM-L)+W(:,:,:,LM+L) + end do + + +!----------------------------------------------------------------------- +! +! DEALLOCATE sBufferes +! + + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_W, stat = ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_E, stat = ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_S, stat = ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_N, stat = ierr ) + end if +! +! DEALLOCATE rBufferes +! + + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + endif + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + endif + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + endif + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + endif + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + endif FILT_GRID + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine bocoT_3d_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsend_all_g1 & +!*********************************************************************** +! ! +! Upsend data from generation one to generation two ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,Harray,Warray,km_in) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in +real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(in):: Harray +real(r_kind), dimension(km_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Warray +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & + ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE + +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SW +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SE +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NW +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NE + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,ndata,i,j +integer(i_kind) isend,irecv,nebpe + +integer(i_kind):: mygen_dn,mygen_up +logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne,flag_up +integer(i_kind):: itarg_up +integer:: g_ind +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" + +!----------------------------------------------------------------------- + mygen_dn=1 + mygen_up=2 +! +! Define generational flags +! + g_ind=1 + + lsendup_sw=Flsendup_sw(g_ind) + lsendup_se=Flsendup_se(g_ind) + lsendup_nw=Flsendup_nw(g_ind) + lsendup_ne=Flsendup_ne(g_ind) + + + itarg_up=Fitarg_up(g_ind) + + +!----------------------------------------------------------------------- + + if(my_hgen==mygen_up) then + Warray(:,:,:) = 0.0d0 + endif + + ndata =km_in*imL*jmL + +! +! --- Send data to SW portion of processors at higher generation +! + + if( lsendup_sw ) then + + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_SW(:,i,j) = Harray(:,i,j) + enddo + enddo + + else + + allocate( sBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = Harray(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + call MPI_WAIT( sHandle(1), istat, ierr ) + + deallocate( sBuf_SW, stat = ierr ) + + endif + + endif +! +! --- Receive SW portion of data at higher generation +! + + if( my_hgen==mygen_up .and. itargdn_sw >= 0 ) then + + nebpe = itargdn_sw + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_SW, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + Warray(:,i,j)=dBuf_SW(:,i,j) + enddo + enddo + + endif + +! +! --- Send data to SE portion of processors at higher generation +! + + if( lsendup_se ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_SE(:,i,j) = Harray(:,i,j) + enddo + enddo + + else + + allocate( sBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SE(:,i,j) = Harray(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + call MPI_WAIT( sHandle(2), istat, ierr ) + + deallocate( sBuf_SE, stat = ierr ) + + endif + + end if + +! +! --- Receive SE portion of data at higher generation +! + + if( my_hgen==mygen_up .and. itargdn_se >= 0 ) then + + nebpe = itargdn_se + + if(nebpe /= mype) then + + call MPI_IRECV( dBuf_SE, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + endif + do j=1,jmL + do i=1,imL + Warray(:,imL+i,j)=dBuf_SE(:,i,j) + enddo + enddo + + endif +! +! --- Send data to NW portion of processors at higher generation +! + + if( lsendup_nw ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_NW(:,i,j) = Harray(:,i,j) + enddo + enddo + + else + + allocate( sBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NW(:,i,j) = Harray(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(3), isend) + + call MPI_WAIT( sHandle(3), istat, ierr ) + + deallocate( sBuf_NW, stat = ierr ) + + end if + + end if + +! +! --- Receive NW portion of data at higher generation +! + + if( my_hgen==mygen_up .and. itargdn_nw >= 0 ) then + + nebpe = itargdn_nw + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_NW, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + Warray(:,i,jmL+j)=dBuf_NW(:,i,j) + enddo + enddo + + endif +! +! --- Send data to NE portion of processors at higher generation +! + + if( lsendup_ne ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_NE(:,i,j) = Harray(:,i,j) + enddo + enddo + + else + + allocate( sBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = Harray(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(4), isend) + call MPI_WAIT( sHandle(4), istat, ierr ) + + deallocate( sBuf_NE, stat = ierr ) + + endif + + end if + +! +! --- Receive NE portion of data at higher generation +! + + if( my_hgen==mygen_up .and. itargdn_ne >= 0 ) then + + nebpe = itargdn_ne + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_NE, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + Warray(:,imL+i,jmL+j)=dBuf_NE(:,i,j) + enddo + enddo + + endif + + +!----------------------------------------------------------------------- +endsubroutine upsend_all_g1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsend_all_gh & +!*********************************************************************** +! * +! Upsend data from one grid generation to another * +! (Just for high grid generations) * +! ! +! - offset version - ! +! * +!*********************************************************************** +(this,Harray,Warray,km_in,mygen_dn,mygen_up) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in +real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(in):: Harray +real(r_kind), dimension(km_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Warray +integer(i_kind),intent(in):: mygen_dn,mygen_up +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & + ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE + +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SW +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SE +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NW +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NE + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,ndata,i,j,L +integer(i_kind) isend,irecv,nebpe + +logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne,flag_up +integer(i_kind):: itarg_up +integer:: g_ind +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" + +!----------------------------------------------------------------------- +! +! Define generational flags +! + + g_ind=2 + + lsendup_sw=Flsendup_sw(g_ind).and.(my_hgen==mygen_dn) + lsendup_se=Flsendup_se(g_ind).and.(my_hgen==mygen_dn) + lsendup_nw=Flsendup_nw(g_ind).and.(my_hgen==mygen_dn) + lsendup_ne=Flsendup_ne(g_ind).and.(my_hgen==mygen_dn) + + itarg_up=Fitarg_up(g_ind) + + +!----------------------------------------------------------------------- + + if(my_hgen==mygen_up) then + Warray(:,:,:)=0.0d0 + endif + + ndata =km_in*imL*jmL + + if( lsendup_sw ) then + + nebpe = itarg_up + + + allocate( sBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = Harray(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + call MPI_WAIT( sHandle(1), istat, ierr ) + + deallocate( sBuf_SW, stat = ierr ) + + + end if + +! +! --- Receive SW portion of data at higher generation +! + + if( my_hgen==mygen_up .and. itargdn_sw >= 0 ) then + + nebpe = itargdn_sw + + allocate( rBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_SW, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + do j=1,jmL + do i=1,imL + Warray(:,i,j)=Rbuf_SW(:,i,j) + enddo + enddo + + endif + +! +! --- Send data to SE portion of processors at higher generation +! + + if( lsendup_se ) then + nebpe = itarg_up + + + allocate( sBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SE(:,i,j) = Harray(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + + call MPI_WAIT( sHandle(2), istat, ierr ) + + deallocate( sBuf_SE, stat = ierr ) + + end if + +! +! --- Receive SE portion of data at higher generation + + + if( my_hgen==mygen_up .and. itargdn_se >= 0 ) then + nebpe = itargdn_se + + + allocate( rBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_SE, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + do j=1,jmL + do i=1,imL + Warray(:,imL+i,j)=Rbuf_SE(:,i,j) + enddo + enddo + + endif + + +! +! --- Send data to NW portion of processors at higher generation +! + + if( lsendup_nw ) then + nebpe = itarg_up + + allocate( sBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NW(:,i,j) = Harray(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + + call MPI_WAIT( sHandle(3), istat, ierr ) + + deallocate( sBuf_NW, stat = ierr ) + + + end if + +! +! --- Receive NW portion of data at higher generation +! + + if( my_hgen==mygen_up .and. itargdn_nw >= 0 ) then + nebpe = itargdn_nw + + + allocate( rBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_NW, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + + call MPI_WAIT( rHandle(3), istat, ierr ) + + do j=1,jmL + do i=1,imL + Warray(:,i,jmL+j)=rBuf_NW(:,i,j) + enddo + enddo + + deallocate( rBuf_NW, stat = iderr) + + end if + +! +! --- Send data to NE portion of processors at higher generation +! + + if( lsendup_ne ) then + nebpe = itarg_up + + allocate( sBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = Harray(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + + call MPI_WAIT( sHandle(4), istat, ierr ) + + deallocate( sBuf_NE, stat = ierr ) + + end if + +! +! --- Receive NE portion of data at higher generation +! + + if( my_hgen==mygen_up .and. itargdn_ne >= 0 ) then + nebpe = itargdn_ne + + allocate( rBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_NE, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + + call MPI_WAIT( rHandle(4), istat, ierr ) + + do j=1,jmL + do i=1,imL + Warray(:,imL+i,jmL+j)=rBuf_NE(:,i,j) + enddo + enddo + + deallocate( rBuf_NE, stat = iderr) + + endif + +!----------------------------------------------------------------------- +endsubroutine upsend_all_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsend_all_gh & +!*********************************************************************** +! * +! Downsending data from low resolution pes (mygen_up) * +! to the concurent high-resolution pes (mygen_dn) * +! and add the existing and the recevied values * +! ! +! - offset version - ! +! * +!*********************************************************************** +(this,Warray,Harray,km_in,mygen_up,mygen_dn) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in +real(r_kind), dimension(km_in,1:this%im,1:this%jm),intent(in):: Warray +real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(out):: Harray +integer, intent(in):: mygen_up,mygen_dn +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & + ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE + +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SW +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SE +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NW +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NE + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,ndata,i,j,L +integer(i_kind) isend,irecv,nebpe + +logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne +integer(i_kind):: itarg_up +integer(i_kind):: g_ind +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- + + Harray(:,:,:) = 0.0d0 +! +! Define generational flags +! + + g_ind=2 + lsendup_sw=Flsendup_sw(g_ind).and.(my_hgen==mygen_dn) + lsendup_se=Flsendup_se(g_ind).and.(my_hgen==mygen_dn) + lsendup_nw=Flsendup_nw(g_ind).and.(my_hgen==mygen_dn) + lsendup_ne=Flsendup_ne(g_ind).and.(my_hgen==mygen_dn) + + itarg_up=Fitarg_up(g_ind) + + ndata =km_in*imL*jmL + +! +! --- Send data from SW portion of processors at the higher generation +! to corresponding PE's at lower generation + + + if(my_hgen==mygen_up .and. itargdn_sw >= 0 ) then + nebpe = itargdn_sw + + + allocate( sBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = Warray(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_SW, stat = ierr ) + + + endif +! +! --- Receive SW portion of data at lower generation + + + if( lsendup_sw ) then + + nebpe = itarg_up + + + allocate( rBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_SW, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + do j=1,jmL + do i=1,imL + Harray(:,i,j)=rBuf_SW(:,i,j) + enddo + enddo + + deallocate( rBuf_SW, stat = iderr) + + endif + +! +! --- Send data from SE portion of processors at the higher generation +! to corresponding PE's at lower generation + + if(my_hgen==mygen_up .and. itargdn_se >= 0 ) then + nebpe = itargdn_se + + allocate( sBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SE(:,i,j) = Warray(:,imL+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_SE, stat = ierr ) + + + endif +! +! --- Receive SE portion of data at lower generation + + + if( lsendup_se ) then + nebpe = itarg_up + + + allocate( rBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_SE, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + do j=1,jmL + do i=1,imL + Harray(:,i,j)=Rbuf_SE(:,i,j) + enddo + enddo + + deallocate( rBuf_SE, stat = iderr) + + end if + +! +! --- Send data from NW portion of processors at the higher generation +! to corresponding PE's at lower generantion + + if(my_hgen==mygen_up .and. itargdn_nw >= 0 ) then + nebpe = itargdn_nw + + + allocate( sBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NW(:,i,j) = Warray(:,i,jmL+j) + enddo + enddo + + call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_NW, stat = ierr ) + + + endif +! +! --- Receive NW portion of data at lower generation + + + if( lsendup_nw ) then + + nebpe = itarg_up + + allocate( rBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_NW, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + do j=1,jmL + do i=1,imL + Harray(:,i,j)=Rbuf_NW(:,i,j) + enddo + enddo + + deallocate( rBuf_NW, stat = iderr) + + + end if + + +! --- Send data from NE portion of processors at the higher generation +! to corresponding PE's at lower generation + + if(my_hgen==mygen_up .and. itargdn_ne >= 0 ) then + nebpe = itargdn_ne + + + allocate( sBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = Warray(:,imL+i,jmL+j) + enddo + enddo + + call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_NE, stat = ierr ) + + + endif +! +! --- Receive NE portion of data at lower generation +! + + if( lsendup_ne ) then + nebpe = itarg_up + + allocate( rBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_NE, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + do j=1,jmL + do i=1,imL + Harray(:,i,j)=rBuf_NE(:,i,j) + enddo + enddo + + deallocate( rBuf_NE, stat = iderr) + + end if + +!----------------------------------------------------------------------- +endsubroutine downsend_all_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsend_all_g2 & +!*********************************************************************** +! * +! Downsending data from low resolution pes (mygen_up) * +! to the concurent high-resolution pes (mygen_dn) * +! and add the existing and the recevied values * +! * +! - offset version - * +! * +!*********************************************************************** +(this,Warray,Harray,km_in) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in +real(r_kind), dimension(km_in,1:this%im,1:this%jm),intent(in):: Warray +real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(out):: Harray +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE + +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SW +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SE +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NW +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NE + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,ndata,i,j,L +integer(i_kind) isend,irecv,nebpe + +logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne +integer:: mygen_up,mygen_dn +integer(i_kind):: itarg_up +integer(i_kind):: g_ind +!----------------------------------------------------------------------- +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +! +! Define generational flags +! + mygen_up=2 + mygen_dn=1 + + g_ind=1 + lsendup_sw=Flsendup_sw(g_ind) + lsendup_se=Flsendup_se(g_ind) + lsendup_nw=Flsendup_nw(g_ind) + lsendup_ne=Flsendup_ne(g_ind) + + itarg_up=Fitarg_up(g_ind) + + + ndata =km_in*imL*jmL + + +! +! Send data down to generation 1 +! +LSEND: if(my_hgen==mygen_up) then +! +! --- Send data from SW portion of processors at the higher generation +! to corresponding PE's at lower generation + + nebpe = itargdn_sw + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_SW(:,i,j) = Warray(:,i,j) + enddo + enddo + + else + + allocate( sBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = Warray(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_SW, stat = ierr ) + + endif +! +! --- Send data from SE portion of processors at the higher generation +! to corresponding PE's at lower generation + + nebpe = itargdn_se + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_SE(:,i,j) = Warray(:,imL+i,j) + enddo + enddo + + else + + allocate( sBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SE(:,i,j) = Warray(:,imL+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_SE, stat = ierr ) + + endif + +! --- Send data from NW portion of processors at the higher generation +! to corresponding PE's at lower generantion + + nebpe = itargdn_nw + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_NW(:,i,j) = Warray(:,i,jmL+j) + enddo + enddo + + else + + allocate( sBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NW(:,i,j) = Warray(:,i,jmL+j) + enddo + enddo + + call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(3), isend) + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_NW, stat = ierr ) + + endif + +! +! --- Send data from NE portion of processors at the higher generation +! to corresponding PE's at lower generation + + nebpe = itargdn_ne + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_NE(:,i,j) = Warray(:,imL+i,jmL+j) + enddo + enddo + + else + + allocate( sBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = Warray(:,imL+i,jmL+j) + enddo + enddo + + call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(4), isend) + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_NE, stat = ierr ) + + endif + + + endif LSEND + +! +! --- Receive SW portion of data at lower generation +! + + if( lsendup_sw .and. mype /= itarg_up ) then + + nebpe = itarg_up + + + call MPI_IRECV( dBuf_SW, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + + else & + +! +! --- Receive SE portion of data at lower generation + + + if( lsendup_se .and. mype /= itarg_up) then + + nebpe = itarg_up + + call MPI_IRECV( dBuf_SE, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + + else & + + +! +! --- Receive NW portion of data at lower generation + + + if( lsendup_nw .and. mype /= itarg_up) then + + nebpe = itarg_up + + call MPI_IRECV( dBuf_NW, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + + else & + + +! +! --- Receive NE portion of data at lower generation +! + + if( lsendup_ne .and. mype /= itarg_up) then + nebpe = itarg_up + + call MPI_IRECV( dBuf_NE, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + + end if + +! +! Assign received and prescribed values +! + if( lsendup_sw ) then + + do j=1,jmL + do i=1,imL + Harray(:,i,j)=dBuf_SW(:,i,j) + enddo + enddo + + else & + if( lsendup_se ) then + + do j=1,jmL + do i=1,imL + Harray(:,i,j)=dBuf_SE(:,i,j) + enddo + enddo + + else & + if( lsendup_nw ) then + + do j=1,jmL + do i=1,imL + Harray(:,i,j)=dBuf_NW(:,i,j) + enddo + enddo + + else & + if( lsendup_ne ) then + + do j=1,jmL + do i=1,imL + Harray(:,i,j)=dBuf_NE(:,i,j) + enddo + enddo + + endif + + +!----------------------------------------------------------------------- +endsubroutine downsend_all_g2 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocox_2d_g1 & +!**********************************************************************! +! ! +! Side sending subroutine: ! +! Supplies nbx lines of halos in x direction assuming mirror boundary ! +! conditions at the end of domain. Version for generation 1 ! +! ! +! - offset version - ! +! ! +!**********************************************************************! +(this,W,km_in,im_in,jm_in,nbx,nby) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby +real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: sBuf_E,sBuf_W & + ,rBuf_E,rBuf_W + +integer(i_kind) itarg_w,itarg_e,imax,jmax +logical:: lwest,least + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,l,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax +integer(i_kind) g_ind,g +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit communications to selected number of generations +! + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! from mg_domain +! + g_ind = 1 + + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + + imax = im_in + jmax = jm_in + + +!----------------------------------------------------------------------- + ndatax = km_in*jmax*nbx + +!---------------------------------------------------------------------- +! +! SEND extended boundaries toward WEST and EAST +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,nbx,1:jmax), stat = iaerr ) + + do j=1,jmax + do i=1,nbx + sBuf_W(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,nbx,1:jmax), stat = iaerr ) + + do j=1,jmax + do i=1,nbx + sBuf_E(:,i,j) = W(:,imax-nbx+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + + end if + +! +! RECEIVE boundaries from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( rBuf_E(1:km_in,nbx,1:jmax), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + allocate( rBuf_W(1:km_in,nbx,1:jmax), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + end if + + +! +! Assign received values from EAST and WEST +! + +! From west + + if(lwest) then + + do j=1,jmax + do i=1,nbx + W(:,-nbx+i,j)= W(:,nbx+1-i,j) + end do + end do + + else + + do j=1,jmax + do i=1,nbx + W(:,-nbx+i,j)= rBuf_W(:,i,j) + enddo + enddo + + + endif + +! From east + + if(least) then + + do j=1,jmax + do i=1,nbx + W(:,imax+i,j)=W(:,imax+1-i,j) + end do + end do + + else + + do j=1,jmax + do i=1,nbx + W(:,imax+i,j)=rBuf_E(:,i,j) + enddo + enddo + + endif + + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + endif + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + endif + +! +! DEALLOCATE sBufferes +! + + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_E, stat = ierr ) + end if + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_W, stat = ierr ) + end if + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine bocox_2d_g1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocox_2d_gh & +!**********************************************************************! +! ! +! Side sending subroutine: ! +! Supplies nbx lines of halos in x direction assuming mirror boundary ! +! conditions at the end of domain. Version for high generations ! +! ! +! - offset version - ! +! ! +!**********************************************************************! +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max +real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: sBuf_E,sBuf_W & + ,rBuf_E,rBuf_W + +integer(i_kind) itarg_w,itarg_e,imax,jmax +logical:: lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,l,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax +integer(i_kind) g_ind,g +logical l_sidesend +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit communications to selected number of generations +! + + if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then + g_ind=2 + g = my_hgen + l_sidesend=.true. + else + l_sidesend=.false. + endif + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +FILT_GRID: if(l_sidesend) then + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! from mg_domain +! + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + + if(least) then + imax = Fimax_in(g) + else + imax = im ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax_in(g) + else + jmax = jm + endif + + +!----------------------------------------------------------------------- + ndatax = km_in*jmax*nbx + +! +! SEND halos to WEST and EASTH +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,nbx,1:jmax), stat = iaerr ) + + do j=1,jmax + do i=1,nbx + sBuf_W(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,nbx,1:jmax), stat = iaerr ) + + do j=1,jmax + do i=1,nbx + sBuf_E(:,i,j) = W(:,imax-nbx+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + + end if + +! +! RECEIVE extended boundaries from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( rBuf_E(1:km_in,nbx,1:jmax), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + allocate( rBuf_W(1:km_in,nbx,1:jmax), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + end if + +! +! Assign received values from WEST and EAST +! + +! From west + + if(lwest) then + + do j=1,jmax + do i=1,nbx + W(:,-nbx+i,j)= W(:,nbx+1-i,j) + end do + end do + + else + + do j=1,jmax + do i=1,nbx + W(:,-nbx+i,j)= rBuf_W(:,i,j) + enddo + enddo + + + endif + +! From east + + if(least) then + + do j=1,jmax + do i=1,nbx + W(:,imax+i,j)=W(:,imax-i,j) + end do + end do + + else + + do j=1,jmax + do i=1,nbx + W(:,imax+i,j)=rBuf_E(:,i,j) + enddo + enddo + + endif + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + endif + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + endif + +! +! DEALLOCATE sBufferes +! + + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_E, stat = ierr ) + end if + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_W, stat = ierr ) + end if + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + endif FILT_GRID + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine bocox_2d_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoy_2d_g1 & +!**********************************************************************! +! ! +! Side sending subroutine: ! +! Supplies nby lines of halos in y direction assuming mirror boundary ! +! conditions at the end of domain. Version for generation 1 ! +! ! +! - offset version - ! +! ! +!**********************************************************************! +(this,W,km_in,im_in,jm_in,nbx,nby) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby +real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: sBuf_N,sBuf_S & + ,rBuf_N,rBuf_S + +integer(i_kind) itarg_n,itarg_s,imax,jmax +logical:: lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,l,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatay +integer(i_kind) g_ind,g +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit communications to selected number of generations +! + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! from mg_domain +! + g_ind = 1 + + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + imax = im_in + jmax = jm_in + + +!----------------------------------------------------------------------- + ndatay = km_in*imax*nby + + +! +! SEND boundaries toward SOUTH and NORTH +! + +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_S(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_N(:,i,j)=W(:,i,jmax-nby+j) + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + + end if + +! +! RECEIVE boundaries from NORTH and SOUTH +! + +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( rBuf_N(1:km_in,1:imax,nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( rBuf_S(1:km_in,1:imax,nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + end if +! +! Assign received values from NORTH and SOUTH +! + +! --- from NORTH --- + + if( lnorth) then + + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=W(:,i,jmax+1-j) + enddo + enddo + + else + + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=rBuf_N(:,i,j) + enddo + enddo + + endif + +! From SOUTH + + if(lsouth) then + + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=W(:,i,nby+1-j) + end do + end do + + else + + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=rBuf_S(:,i,j) + enddo + enddo + + endif + + + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + endif + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + endif + +! +! DEALLOCATE sBufferes +! + + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_S, stat = ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_N, stat = ierr ) + end if + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine bocoy_2d_g1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoy_2d_gh & +!**********************************************************************! +! ! +! Side sending subroutine: ! +! Supplies nby lines of halos in y direction assuming mirror boundary ! +! conditions at the end of domain. Version for high generations ! +! ! +! - offset version - ! +! ! +!**********************************************************************! +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max +real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: sBuf_N,sBuf_S & + ,rBuf_N,rBuf_S + +integer(i_kind) itarg_n,itarg_s,imax,jmax +logical:: lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,l,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatay +integer(i_kind) g_ind,g +logical l_sidesend +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit communications to selected number of generations +! + + if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then + g_ind=2 + g = my_hgen + l_sidesend=.true. + else + l_sidesend=.false. + endif + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +FILT_GRID: if(l_sidesend) then + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! from mg_domain +! + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + + if(least) then + imax = Fimax_in(g) + else + imax = im_in ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax_in(g) + else + jmax = jm_in + endif + + +!----------------------------------------------------------------------- + ndatay = km_in*imax*nby + +! +! SEND boundaries to SOUTH and NORTH +! + +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_S(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_N(:,i,j)=W(:,i,jmax-nby+j) + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + + end if +! +! RECEIVE boundaries from NORTH and SOUTH +! + +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( rBuf_N(1:km_in,1:imax,nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( rBuf_S(1:km_in,1:imax,nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + end if + +! +! Assign received values from NORTH and SOUTH +! + +! --- from NORTH --- + + if( lnorth) then + + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=W(:,i,jmax+1-j) + enddo + enddo + + else + + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=rBuf_N(:,i,j) + enddo + enddo + + endif + +! From south + + if(lsouth) then + + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=W(:,i,nby+1-j) + end do + end do + + else + + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=rBuf_S(:,i,j) + enddo + enddo + + endif + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + endif + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + endif + +! +! DEALLOCATE sBufferes +! + + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_S, stat = ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_N, stat = ierr ) + end if + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + endif FILT_GRID + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine bocoy_2d_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoTx_2d_g1 & +!*********************************************************************** +! ! +! Side sending subroutine: ! +! Supplies nbx lines close to edges of the subdomins from neighboring ! +! halos in x direction assuming mirror boundary conditions ! +! Version for generation 1 ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,km_in,im_in,jm_in,nbx,nby) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby +real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: sBuf_E,sBuf_W & + ,rBuf_E,rBuf_W + +integer(i_kind) itarg_w,itarg_e,imax,jmax +logical lwest,least + +integer(i_kind) sHandle(2),rHandle(2),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,L,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax +logical l_sidesend +integer(i_kind) g_ind,g,k +!----------------------------------------------------------------------- +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +! +! Limit comminications to selected number of generations +! + + + g_ind=1 +! +! from mg_domain +! + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + + imax = im_in + jmax = jm_in + + +!---------------------------------------------------------------------- + ndatax =km_in*jmax*nbx + +! +! SEND halos toward WEST and EAST +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,1:nbx,1:jmax), stat = iaerr ) + + do j=1,jmax + do i=1-nbx,0 + sBuf_W(:,i+nbx,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,1:nbx,1:jmax), stat = iaerr ) + + do j=1,jmax + do i=1,nbx + sBuf_E(:,i,j) = W(:,imax+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + + end if + +! +! RECEIVE halos from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + + allocate( rBuf_E(1:km_in,1:nbx,1:jmax), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + + allocate( rBuf_W(1:km_in,1:nbx,1:jmax), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + + end if + +! +! Assign received halos from WEST and EAST to interrior of domains +! + +! From west + + if(lwest) then + do j=1,jmax + do i=1,nbx + W(:,i,j)= W(:,i,j)+W(:,1-i,j) + end do + end do + else + do j=1,jmax + do i=1,nbx + W(:,i,j)= W(:,i,j)+rBuf_W(:,i,j) + end do + end do + endif + +! From east + + if(least) then + do j=1,jmax + do i=1,nbx + W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+W(:,imax+nbx+1-i,j) + end do + end do + else + do j=1,jmax + do i=1,nbx + W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+rBuf_E(:,i,j) + end do + end do + endif + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + endif + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + endif + +! +! DEALLOCATE sBufferes +! + + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + end if + +!----------------------------------------------------------------------- +endsubroutine bocoTx_2d_g1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoTx_2d_gh & +!*********************************************************************** +! ! +! Side sending subroutine: ! +! Supplies nbx lines close to edges of the subdomins from neighboring ! +! halos in x direction assuming mirror boundary conditions ! +! Version for high generations ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max +real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: sBuf_E,sBuf_W & + ,rBuf_E,rBuf_W +integer(i_kind) itarg_w,itarg_e,imax,jmax +logical lwest,least,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,L,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax,ndatay +logical l_sidesend +integer(i_kind) g_ind,g,k +!----------------------------------------------------------------------- +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +! +! Limit comminications to selected number of generations +! + + if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then + g_ind=2 + g = my_hgen + l_sidesend=.true. + else + l_sidesend=.false. + endif + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +FILT_GRID: if(l_sidesend) then + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +! +! from mg_domain +! + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + + lnorth = Flnorth(g_ind) + + + if(least) then + imax = Fimax_in(g) + else + imax = im_in ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax_in(g) + else + jmax = jm_in + endif + + +!---------------------------------------------------------------------- + ndatax =km_in*jmax*nbx +! +! SEND halos toward WEST and EAST +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,1:nbx,1:jmax), stat = iaerr ) + + do j=1,jmax + do i=1-nbx,0 + sBuf_W(:,i+nbx,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,1:nbx,1:jmax), stat = iaerr ) + + do j=1,jmax + do i=1,nbx + sBuf_E(:,i,j) = W(:,imax+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + + end if + +! +! RECEIVE halos from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( rBuf_E(1:km_in,1:nbx,1:jmax), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + allocate( rBuf_W(1:km_in,1:nbx,1:jmax), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + end if +! +! Assign received values from WEST and EAST +! + +! From west + + if(lwest) then + do j=1,jmax + do i=1,nbx + W(:,i,j)= W(:,i,j)+W(:,1-i,j) + end do + end do + else + do j=1,jmax + do i=1,nbx + W(:,i,j)= W(:,i,j)+rBuf_W(:,i,j) + end do + end do + endif + +! From east + + if(least) then + do j=1,jmax + do i=1,nbx + W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+W(:,imax+nbx+1-i,j) + end do + end do + else + do j=1,jmax + do i=1,nbx + W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+rBuf_E(:,i,j) + end do + end do + endif + +!----------------------------------------------------------------------- + +! DEALLOCATE rBufferes + + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + end if + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + end if + +! DEALLOCATE sBufferes + + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + end if + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + endif FILT_GRID + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine bocoTx_2d_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoTy_2d_g1 & +!*********************************************************************** +! ! +! Side sending subroutine: ! +! Supplies nby lines close to edges of the subdomins from neighboring ! +! halos in y direction assuming mirror boundary conditions ! +! Version for generation 1 ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,km_in,im_in,jm_in,nbx,nby) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby +real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: sBuf_N,sBuf_S & + ,rBuf_N,rBuf_S + +integer(i_kind) itarg_n,itarg_s,imax,jmax +logical lsouth,lnorth + +integer(i_kind) sHandle(2),rHandle(2),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,L,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatay +logical l_sidesend +integer(i_kind) g_ind,g,k +!----------------------------------------------------------------------- +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +! +! Limit comminications to selected number of generations +! + + g_ind=1 +! +! from mg_domain +! + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + imax = im_in + jmax = jm_in + + +!---------------------------------------------------------------------- + ndatay =km_in*imax*nby + +! +! SEND SOUTH and NORTH halos +! +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) + + do j=1-nby,0 + do i=1,imax + sBuf_S(:,i,j+nby) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_N(:,i,j)=W(:,i,jmax+j) + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + + end if + +! +! RECEIVE halos from NORTH and SOUTH +! +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + + allocate( rBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + + allocate( rBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + + end if + +! +! ASSIGN received values from SOUTH and NORTH +! + +! From south + + if(lsouth) then + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+W(:,i,1-j) + end do + end do + else + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+rBuf_S(:,i,j) + end do + end do + endif + +! From north + + if(lnorth) then + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+W(:,i,jmax+nby+1-j) + enddo + enddo + else + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+rBuf_N(:,i,j) + enddo + enddo + endif + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + end if + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + end if + +! +! DEALLOCATE sBufferes +! + + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + end if + + +!----------------------------------------------------------------------- +endsubroutine bocoTy_2d_g1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoTy_2d_gh & +!*********************************************************************** +! ! +! Side sending subroutine: ! +! Supplies nby lines close to edges of the subdomins from neighboring ! +! halos in y direction assuming mirror boundary conditions ! +! Version for high generations ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max +real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: sBuf_N,sBuf_S & + ,rBuf_N,rBuf_S +integer(i_kind) itarg_n,itarg_s,itarg_e,imax,jmax +logical least,lsouth,lnorth + +integer(i_kind) sHandle(2),rHandle(2),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,L,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatay +logical l_sidesend +integer(i_kind) g_ind,g,k +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit comminications to selected number of generations +! + + + if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then + g_ind=2 + g = my_hgen + l_sidesend=.true. + else + l_sidesend=.false. + endif + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +FILT_GRID: if(l_sidesend) then + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +! +! from mg_domain +! + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + + least = Fleast(g_ind) + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + + if(least) then + imax = Fimax_in(g) + else + imax = im_in ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax_in(g) + else + jmax = jm_in + endif + + +!---------------------------------------------------------------------- + + ndatay =km_in*imax*nby +! +! SEND halos toward SOUTH and NORTH +! +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) + + do j=1-nby,0 + do i=1,imax + sBuf_S(:,i,j+nby) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_N(:,i,j)=W(:,i,jmax+j) + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + + end if + +! +! RECEIVE halos from NORTH and SOUTH +! +! +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + + allocate( rBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + + allocate( rBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + + end if + +! +! Assign received values from SOUTH and NORTH +! + +! From south + + if(lsouth) then + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+W(:,i,1-j) + end do + end do + else + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+rBuf_S(:,i,j) + end do + end do + endif + +! From north + + if(lnorth) then + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+W(:,i,jmax+nby+1-j) + enddo + enddo + else + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+rBuf_N(:,i,j) + enddo + enddo + endif + +!----------------------------------------------------------------------- + +! DEALLOCATE rBufferes + + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + end if + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + end if + +! DEALLOCATE sBufferes + + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + end if + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + endif FILT_GRID + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine bocoTy_2d_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine boco_2d_loc & +!**********************************************************************! +! ! +! Side sending subroutine: ! +! Supplies (nbx,nby) lines of halos in (x,y) directions assuming ! +! mirror boundary conditions. Version for localiztion ! +! ! +! - offset version - ! +! ! +!**********************************************************************! +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,g) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,g +real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_N,sBuf_E,sBuf_S,sBuf_W & + ,rBuf_N,rBuf_E,rBuf_S,rBuf_W + +integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax +logical:: lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,l,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax,ndatay +integer(i_kind) g_ind +logical l_sidesend +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit communications to selected number of generations +! + + l_sidesend=.true. + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +FILT_GRID: if(l_sidesend) then + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! from mg_domain +! + itarg_n = Fitarg_n_loc(g) + itarg_s = Fitarg_s_loc(g) + itarg_w = Fitarg_w_loc(g) + itarg_e = Fitarg_e_loc(g) + + lwest = Flwest_loc(g) + least = Fleast_loc(g) + lsouth = Flsouth_loc(g) + lnorth = Flnorth_loc(g) + + +! +! Keep this for now but use only Mod(nxm,8)=Mod(nym,8)=0 +! + + if(least) then + imax = Fimax_in(g) + else + imax = im_in ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax_in(g) + else + jmax = jm_in + endif + + +!----------------------------------------------------------------------- + ndatay = km_in*imax*nby + ndatax = km_in*(jmax+2*nby)*nbx + + +! +! SEND boundaries to SOUTH and NORTH +! + +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_S(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_N(:,i,j)=W(:,i,jmax-nby+j) + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + + end if +! +! RECEIVE boundaries from NORTH and SOUTH +! + +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( rBuf_N(1:km_in,1:imax,nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( rBuf_S(1:km_in,1:imax,nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + end if + +! +! Assign received values from NORTH and SOUTH +! + + +! From south + + if(lsouth) then + + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=W(:,i,nby+1-j) + end do + end do + + else + + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=rBuf_S(:,i,j) + enddo + enddo + + endif + + +! --- from NORTH --- + + if( lnorth) then + + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=W(:,i,jmax+1-j) + enddo + enddo + + else + + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=rBuf_N(:,i,j) + enddo + enddo + + endif + +! +! SEND extended boundaries to WEST and EASTH +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_W(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_E(:,i,j) = W(:,imax-nbx+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + + end if + +! +! RECEIVE extended boundaries from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( rBuf_E(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + allocate( rBuf_W(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + end if + +! +! Assign received values from WEST and EAST +! + +! From west + + if(lwest) then + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j)= W(:,nbx+1-i,j) + end do + end do + + else + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j)= rBuf_W(:,i,j) + enddo + enddo + + + endif + +! From east + + if(least) then + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j)=W(:,imax+1-i,j) + end do + end do + + else + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j)=rBuf_E(:,i,j) + enddo + enddo + + endif + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + end if + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + end if + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + end if + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + end if + +! +! DEALLOCATE sBufferes +! + + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_W, stat = ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_E, stat = ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_S, stat = ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_N, stat = ierr ) + end if + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + endif FILT_GRID + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine boco_2d_loc + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoT_2d_loc & +!*********************************************************************** +! ! +! Supply n-lines inside of domains, including edges, with halos from ! +! the surrounding domains. Assume mirror boundary conditions at the ! +! boundaries of the domain. Vesrion for localization. ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,g) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,g +real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_N,sBuf_E,sBuf_S,sBuf_W & + ,rBuf_N,rBuf_E,rBuf_S,rBuf_W +integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax +logical lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,L,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax,ndatay +logical l_sidesend +integer(i_kind) g_ind,k +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit comminications to selected number of generations +! + + + g_ind=g + l_sidesend=.true. + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +FILT_GRID: if(l_sidesend) then + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +! +! from mg_domain +! + itarg_n = Fitarg_n_loc(g_ind) + itarg_s = Fitarg_s_loc(g_ind) + itarg_w = Fitarg_w_loc(g_ind) + itarg_e = Fitarg_e_loc(g_ind) + + lwest = Flwest_loc(g_ind) + least = Fleast_loc(g_ind) + lsouth = Flsouth_loc(g_ind) + lnorth = Flnorth_loc(g_ind) + + + if(least) then + imax = Fimax_in(g) + else + imax = im_in ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax_in(g) + else + jmax = jm_in + endif + + +!---------------------------------------------------------------------- + ndatax =km_in*(jmax+2*nby)*nbx + ndatay =km_in*imax*nby + +! +! SEND extended halos toward WEST and EAST +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_W(:,i,j) = W(:,-nbx+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_E(:,i,j) = W(:,imax+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + + end if + +! +! RECEIVE extended halos from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( rBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + allocate( rBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + end if +! +! Assign received values from WEST and EAST +! + +! From west + + if(lwest) then + do j=1-nby,jmax+nby + do i=1,nbx + W(:,i,j)= W(:,i,j)+W(:,1-i,j) + end do + end do + else + do j=1-nby,jmax+nby + do i=1,nbx + W(:,i,j)= W(:,i,j)+rBuf_W(:,i,j) + end do + end do + endif + +! From east + + if(least) then + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+W(:,imax+1+nbx-i,j) + end do + end do + else + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+rBuf_E(:,i,j) + end do + end do + endif + +! +! SEND halos toward SOUTH and NORTH +! +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_S(:,i,j) = W(:,i,-nby+j) + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_N(:,i,j)=W(:,i,jmax+j) + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + + end if + +! +! RECEIVE halos from NORTH and SOUTH +! +! +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + + allocate( rBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + + allocate( rBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + + end if + +! +! Assign received values from SOUTH and NORTH +! + +! From south + + if(lsouth) then + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+W(:,i,1-j) + end do + end do + else + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+rBuf_S(:,i,j) + end do + end do + endif + +! From north + + if(lnorth) then + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+W(:,i,jmax+1+nby-j) + enddo + enddo + else + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+rBuf_N(:,i,j) + enddo + enddo + endif + +!----------------------------------------------------------------------- + +! DEALLOCATE rBufferes + + deallocate( rBuf_W, stat = iderr) + deallocate( rBuf_E, stat = iderr) + deallocate( rBuf_S, stat = iderr) + deallocate( rBuf_N, stat = iderr) + +! DEALLOCATE sBufferes + + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + end if + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + endif FILT_GRID + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine bocoT_2d_loc + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsend_loc_g12 & +!*********************************************************************** +! ! +! Upsend data from generation one to generation two ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,V_in,H,km_4_in,flag) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_4_in,flag +real(r_kind), dimension(km_4_in,1:this%imL,1:this%jmL),intent(in):: V_in +real(r_kind), dimension(km_4_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & + ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE + +real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_SW +real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_SE +real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_NW +real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_NE + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,ndata,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind):: mygen_dn,mygen_up +integer(i_kind):: itarg_up +logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- + mygen_dn=1 + mygen_up=2 +! +! Define generational flags +! + + itarg_up=Fitargup_loc12(flag) + + lsendup_sw = lsendup_sw_loc + lsendup_se = lsendup_se_loc + lsendup_nw = lsendup_nw_loc + lsendup_ne = lsendup_ne_loc +!----------------------------------------------------------------------- + +!N if(my_hgen==mygen_up) then + H(:,:,:) = 0.0d0 +!N endif + + ndata =km_4_in*imL*jmL + +! +! --- Send data to SW portion of processors at higher generation +! + + if( lsendup_sw ) then + + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_SW(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_SW(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + call MPI_WAIT( sHandle(1), istat, ierr ) + + deallocate( sBuf_SW, stat = ierr ) + + endif + + endif +! +! --- Receive SW portion of data at higher generation +! + +!N if( my_hgen==mygen_up .and. itargdn_sw_loc21 >= 0 ) then + if( itargdn_sw_loc21 >= 0 ) then + + nebpe = itargdn_sw_loc21 + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_SW, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + H(:,i,j)=dBuf_SW(:,i,j) + enddo + enddo + + endif + +! +! --- Send data to SE portion of processors at higher generation +! + + if( lsendup_se ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_SE(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_SE(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SE(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + call MPI_WAIT( sHandle(2), istat, ierr ) + + deallocate( sBuf_SE, stat = ierr ) + + endif + + end if + +! +! --- Receive SE portion of data at higher generation +! + +!N if( my_hgen==mygen_up .and. itargdn_se_loc21 >= 0 ) then + if( itargdn_se_loc21 >= 0 ) then + + nebpe = itargdn_se_loc21 + + if(nebpe /= mype) then + + call MPI_IRECV( dBuf_SE, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + endif + do j=1,jmL + do i=1,imL + H(:,imL+i,j)=dBuf_SE(:,i,j) + enddo + enddo + + endif +! +! --- Send data to NW portion of processors at higher generation +! + + if( lsendup_nw ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_NW(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_NW(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NW(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(3), isend) + + call MPI_WAIT( sHandle(3), istat, ierr ) + + deallocate( sBuf_NW, stat = ierr ) + + end if + + end if + +! +! --- Receive NW portion of data at higher generation +! + +! if( my_hgen==mygen_up .and. itargdn_nw_loc21 >= 0 ) then + if( itargdn_nw_loc21 >= 0 ) then + + nebpe = itargdn_nw_loc21 + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_NW, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + H(:,i,jmL+j)=dBuf_NW(:,i,j) + enddo + enddo + + endif +! +! --- Send data to NE portion of processors at higher generation +! + + if( lsendup_ne ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_NE(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_NE(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(4), isend) + call MPI_WAIT( sHandle(4), istat, ierr ) + + deallocate( sBuf_NE, stat = ierr ) + + endif + + end if + +! +! --- Receive NE portion of data at higher generation +! + +!N if( my_hgen==mygen_up .and. itargdn_ne_loc21 >= 0 ) then + if( itargdn_ne_loc21 >= 0 ) then + + nebpe = itargdn_ne_loc21 + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_NE, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + H(:,imL+i,jmL+j)=dBuf_NE(:,i,j) + enddo + enddo + + endif + + +!----------------------------------------------------------------------- +endsubroutine upsend_loc_g12 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsend_loc_g23 & +!*********************************************************************** +! ! +! Upsend data from generation three to generation four ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,V_in,H,km_16_in,flag) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_16_in,flag +real(r_kind), dimension(km_16_in,1:this%imL,1:this%jmL),intent(in):: V_in +real(r_kind), dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & + ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE + +real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_SW +real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_SE +real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_NW +real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_NE + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,ndata,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind):: mygen_dn,mygen_up +integer(i_kind):: itarg_up +logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- + mygen_dn=2 + mygen_up=3 +! +! Define generational flags +! + + itarg_up=Fitargup_loc23(flag) + + lsendup_sw = lsendup_sw_loc + lsendup_se = lsendup_se_loc + lsendup_nw = lsendup_nw_loc + lsendup_ne = lsendup_ne_loc +!----------------------------------------------------------------------- + +!N if(my_hgen==mygen_up) then + H(:,:,:) = 0.0d0 +!N endif + + ndata =km_16_in*imL*jmL + +! +! --- Send data to SW portion of processors at higher generation +! + + if( lsendup_sw ) then + + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_SW(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_SW(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + call MPI_WAIT( sHandle(1), istat, ierr ) + + deallocate( sBuf_SW, stat = ierr ) + + endif + + endif +! +! --- Receive SW portion of data at higher generation +! + +!N if( my_hgen==mygen_up .and. itargdn_sw_loc32 >= 0 ) then + if( itargdn_sw_loc32 >= 0 ) then + + nebpe = itargdn_sw_loc32 + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_SW, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + H(:,i,j)=dBuf_SW(:,i,j) + enddo + enddo + + endif + +! +! --- Send data to SE portion of processors at higher generation +! + + if( lsendup_se ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_SE(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_SE(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SE(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + call MPI_WAIT( sHandle(2), istat, ierr ) + + deallocate( sBuf_SE, stat = ierr ) + + endif + + end if + +! +! --- Receive SE portion of data at higher generation +! + +!N if( my_hgen==mygen_up .and. itargdn_se_loc32 >= 0 ) then + if( itargdn_se_loc32 >= 0 ) then + + nebpe = itargdn_se_loc32 + + if(nebpe /= mype) then + + call MPI_IRECV( dBuf_SE, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + endif + do j=1,jmL + do i=1,imL + H(:,imL+i,j)=dBuf_SE(:,i,j) + enddo + enddo + + endif +! +! --- Send data to NW portion of processors at higher generation +! + + if( lsendup_nw ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_NW(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_NW(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NW(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(3), isend) + + call MPI_WAIT( sHandle(3), istat, ierr ) + + deallocate( sBuf_NW, stat = ierr ) + + end if + + end if + +! +! --- Receive NW portion of data at higher generation +! + +! if( my_hgen==mygen_up .and. itargdn_nw_loc32 >= 0 ) then + if( itargdn_nw_loc32 >= 0 ) then + + nebpe = itargdn_nw_loc32 + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_NW, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + H(:,i,jmL+j)=dBuf_NW(:,i,j) + enddo + enddo + + endif +! +! --- Send data to NE portion of processors at higher generation +! + + if( lsendup_ne ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_NE(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_NE(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(4), isend) + call MPI_WAIT( sHandle(4), istat, ierr ) + + deallocate( sBuf_NE, stat = ierr ) + + endif + + end if + +! +! --- Receive NE portion of data at higher generation +! + +!N if( my_hgen==mygen_up .and. itargdn_ne_loc32 >= 0 ) then + if( itargdn_ne_loc32 >= 0 ) then + + nebpe = itargdn_ne_loc32 + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_NE, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + H(:,imL+i,jmL+j)=dBuf_NE(:,i,j) + enddo + enddo + + endif + + +!----------------------------------------------------------------------- +endsubroutine upsend_loc_g23 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsend_loc_g34 & +!*********************************************************************** +! ! +! Upsend data from generation three to generation four ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,V_in,H,km_64_in,flag) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_64_in,flag +real(r_kind), dimension(km_64_in,1:this%imL,1:this%jmL),intent(in):: V_in +real(r_kind), dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & + ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE + +real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_SW +real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_SE +real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_NW +real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_NE + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,ndata,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind):: mygen_dn,mygen_up +integer(i_kind):: itarg_up +logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- + mygen_dn=3 + mygen_up=4 +! +! Define generational flags +! + + itarg_up=Fitargup_loc34(flag) + + lsendup_sw = lsendup_sw_loc + lsendup_se = lsendup_se_loc + lsendup_nw = lsendup_nw_loc + lsendup_ne = lsendup_ne_loc +!----------------------------------------------------------------------- + +!N if(my_hgen==mygen_up) then + H(:,:,:) = 0.0d0 +!N endif + + ndata =km_64_in*imL*jmL + +! +! --- Send data to SW portion of processors at higher generation +! + + if( lsendup_sw ) then + + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_SW(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_SW(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + call MPI_WAIT( sHandle(1), istat, ierr ) + + deallocate( sBuf_SW, stat = ierr ) + + endif + + endif +! +! --- Receive SW portion of data at higher generation +! + + if( itargdn_sw_loc43 >= 0 ) then + + nebpe = itargdn_sw_loc43 + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_SW, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + H(:,i,j)=dBuf_SW(:,i,j) + enddo + enddo + + endif + +! +! --- Send data to SE portion of processors at higher generation +! + + if( lsendup_se ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_SE(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_SE(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SE(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + call MPI_WAIT( sHandle(2), istat, ierr ) + + deallocate( sBuf_SE, stat = ierr ) + + endif + + end if + +! +! --- Receive SE portion of data at higher generation +! + + if( itargdn_se_loc43 >= 0 ) then + + nebpe = itargdn_se_loc43 + + if(nebpe /= mype) then + + call MPI_IRECV( dBuf_SE, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + endif + do j=1,jmL + do i=1,imL + H(:,imL+i,j)=dBuf_SE(:,i,j) + enddo + enddo + + endif +! +! --- Send data to NW portion of processors at higher generation +! + + if( lsendup_nw ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_NW(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_NW(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NW(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(3), isend) + + call MPI_WAIT( sHandle(3), istat, ierr ) + + deallocate( sBuf_NW, stat = ierr ) + + end if + + end if + +! +! --- Receive NW portion of data at higher generation +! + +! if( my_hgen==mygen_up .and. itargdn_nw_loc43 >= 0 ) then + if( itargdn_nw_loc43 >= 0 ) then + + nebpe = itargdn_nw_loc43 + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_NW, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + H(:,i,jmL+j)=dBuf_NW(:,i,j) + enddo + enddo + + endif +! +! --- Send data to NE portion of processors at higher generation +! + + if( lsendup_ne ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_NE(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_NE(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(4), isend) + call MPI_WAIT( sHandle(4), istat, ierr ) + + deallocate( sBuf_NE, stat = ierr ) + + endif + + end if + +! +! --- Receive NE portion of data at higher generation +! + +!N if( my_hgen==mygen_up .and. itargdn_ne_loc43 >= 0 ) then + if( itargdn_ne_loc43 >= 0 ) then + + nebpe = itargdn_ne_loc43 + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_NE, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + H(:,imL+i,jmL+j)=dBuf_NE(:,i,j) + enddo + enddo + + endif + + +!----------------------------------------------------------------------- +endsubroutine upsend_loc_g34 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsend_loc_g43 & +!*********************************************************************** +! * +! Downsending data from low resolution pes (mygen_up) * +! to the concurent high-resolution pes (mygen_dn) * +! and add the existing and the recevied values * +! ! +! - offset version - ! +! * +!*********************************************************************** +(this,W,Z,km_64_in,flag) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_64_in,flag +real(r_kind), dimension(km_64_in,1:this%im,1:this%jm),intent(in):: W +real(r_kind), dimension(km_64_in,1:this%imL,1:this%jmL),intent(out):: Z +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & + ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE + +real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_SW +real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_SE +real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_NW +real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_NE + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,ndata,i,j,L +integer(i_kind) isend,irecv,nebpe +integer(i_kind):: itarg_up +logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- + + Z(:,:,:) = 0.0d0 +! +! Define generational flags +! + + itarg_up=Fitargup_loc34(flag) + + ndata =km_64_in*imL*jmL + +! +! --- Send data from SW portion of processors at the higher generation +! to corresponding PE's at lower generation + + if(itargdn_sw_loc43 >= 0) then + + nebpe = itargdn_sw_loc43 + + + allocate( sBuf_SW(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_SW, stat = ierr ) + + endif + +! +! --- Receive SW portion of data at lower generation + + + if( lsendup_sw ) then + + nebpe = itarg_up + + + allocate( rBuf_SW(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_SW, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + do j=1,jmL + do i=1,imL + Z(:,i,j)=rBuf_SW(:,i,j) + enddo + enddo + + deallocate( rBuf_SW, stat = iderr) + + endif + +! +! --- Send data from SE portion of processors at the higher generation +! to corresponding PE's at lower generation + + if(itargdn_se_loc43 >= 0) then + + nebpe = itargdn_se_loc43 + + allocate( sBuf_SE(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SE(:,i,j) = W(:,imL+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_SE, stat = ierr ) + + endif +! +! --- Receive SE portion of data at lower generation + + + if( lsendup_se ) then + nebpe = itarg_up + + + allocate( rBuf_SE(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_SE, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + do j=1,jmL + do i=1,imL + Z(:,i,j)=Rbuf_SE(:,i,j) + enddo + enddo + + deallocate( rBuf_SE, stat = iderr) + + end if + +! +! --- Send data from NW portion of processors at the higher generation +! to corresponding PE's at lower generantion + + if(itargdn_nw_loc43 >= 0) then + + nebpe = itargdn_nw_loc43 + + + allocate( sBuf_NW(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NW(:,i,j) = W(:,i,jmL+j) + enddo + enddo + + call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_NW, stat = ierr ) + + endif + +! +! --- Receive NW portion of data at lower generation + + + if( lsendup_nw ) then + + nebpe = itarg_up + + allocate( rBuf_NW(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_NW, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + do j=1,jmL + do i=1,imL + Z(:,i,j)=Rbuf_NW(:,i,j) + enddo + enddo + + deallocate( rBuf_NW, stat = iderr) + + + end if + + +! --- Send data from NE portion of processors at the higher generation +! to corresponding PE's at lower generation + + if(itargdn_ne_loc43 >= 0) then + + nebpe = itargdn_ne_loc43 + + allocate( sBuf_NE(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = W(:,imL+i,jmL+j) + enddo + enddo + + call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_NE, stat = ierr ) + + endif + +! +! --- Receive NE portion of data at lower generation +! + + if( lsendup_ne ) then + nebpe = itarg_up + + allocate( rBuf_NE(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_NE, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + do j=1,jmL + do i=1,imL + Z(:,i,j)=rBuf_NE(:,i,j) + enddo + enddo + + deallocate( rBuf_NE, stat = iderr) + + end if + +!----------------------------------------------------------------------- +endsubroutine downsend_loc_g43 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsend_loc_g32 & +!*********************************************************************** +! * +! Downsending data from low resolution pes (mygen_up) * +! to the concurent high-resolution pes (mygen_dn) * +! and add the existing and the recevied values * +! ! +! - offset version - ! +! * +!*********************************************************************** +(this,Z,H,km_16_in,flag) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_16_in,flag +real(r_kind), dimension(km_16_in,1:this%im,1:this%jm),intent(in):: Z +real(r_kind), dimension(km_16_in,1:this%imL,1:this%jmL),intent(out):: H +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & + ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE + +real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_SW +real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_SE +real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_NW +real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_NE + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,ndata,i,j,L +integer(i_kind) isend,irecv,nebpe +integer(i_kind):: itarg_up +logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- + + H(:,:,:) = 0.0d0 +! +! Define generational flags +! + + itarg_up=Fitargup_loc23(flag) + + ndata =km_16_in*imL*jmL + +! +! --- Send data from SW portion of processors at the higher generation +! to corresponding PE's at lower generation + + + if( itargdn_sw_loc32 >= 0 ) then + + nebpe = itargdn_sw_loc32 + + + allocate( sBuf_SW(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = Z(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_SW, stat = ierr ) + + endif + +! +! --- Receive SW portion of data at lower generation + + + if( lsendup_sw ) then + + nebpe = itarg_up + + + allocate( rBuf_SW(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_SW, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + do j=1,jmL + do i=1,imL + H(:,i,j)=rBuf_SW(:,i,j) + enddo + enddo + + deallocate( rBuf_SW, stat = iderr) + + endif + +! +! --- Send data from SE portion of processors at the higher generation +! to corresponding PE's at lower generation + + if( itargdn_se_loc32 >= 0 ) then + + nebpe = itargdn_se_loc32 + + allocate( sBuf_SE(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SE(:,i,j) = Z(:,imL+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_SE, stat = ierr ) + + + endif +! +! --- Receive SE portion of data at lower generation + + + if( lsendup_se ) then + nebpe = itarg_up + + + allocate( rBuf_SE(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_SE, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + do j=1,jmL + do i=1,imL + H(:,i,j)=Rbuf_SE(:,i,j) + enddo + enddo + + deallocate( rBuf_SE, stat = iderr) + + end if + +! +! --- Send data from NW portion of processors at the higher generation +! to corresponding PE's at lower generantion + + if( itargdn_nw_loc32 >= 0 ) then + + nebpe = itargdn_nw_loc32 + + + allocate( sBuf_NW(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NW(:,i,j) = Z(:,i,jmL+j) + enddo + enddo + + call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_NW, stat = ierr ) + + + endif +! +! --- Receive NW portion of data at lower generation + + + if( lsendup_nw ) then + + nebpe = itarg_up + + allocate( rBuf_NW(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_NW, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + do j=1,jmL + do i=1,imL + H(:,i,j)=Rbuf_NW(:,i,j) + enddo + enddo + + deallocate( rBuf_NW, stat = iderr) + + + end if + + +! --- Send data from NE portion of processors at the higher generation +! to corresponding PE's at lower generation + + if( itargdn_ne_loc32 >= 0 ) then + nebpe = itargdn_ne_loc32 + + + allocate( sBuf_NE(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = Z(:,imL+i,jmL+j) + enddo + enddo + + call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_NE, stat = ierr ) + + endif +! +! --- Receive NE portion of data at lower generation +! + + if( lsendup_ne ) then + nebpe = itarg_up + + allocate( rBuf_NE(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_NE, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + do j=1,jmL + do i=1,imL + H(:,i,j)=rBuf_NE(:,i,j) + enddo + enddo + + deallocate( rBuf_NE, stat = iderr) + + end if + +!----------------------------------------------------------------------- +endsubroutine downsend_loc_g32 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsend_loc_g21 & +!*********************************************************************** +! * +! Downsending data from low resolution pes (mygen_up) * +! to the concurent high-resolution pes (mygen_dn) * +! and add the existing and the recevied values * +! ! +! - offset version - ! +! * +!*********************************************************************** +(this,H,V_out,km_4_in,flag) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_4_in,flag +real(r_kind), dimension(km_4_in,1:this%im,1:this%jm),intent(in):: H +real(r_kind), dimension(km_4_in,1:this%imL,1:this%jmL),intent(out):: V_out +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & + ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE + +real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_SW +real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_SE +real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_NW +real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_NE + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,ndata,i,j,L +integer(i_kind) isend,irecv,nebpe +integer(i_kind):: itarg_up +logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- + + V_out(:,:,:) = 0.0d0 +! +! Define generational flags +! + + itarg_up=Fitargup_loc12(flag) + + ndata =km_4_in*imL*jmL + +! +! --- Send data from SW portion of processors at the higher generation +! to corresponding PE's at lower generation + + + if( itargdn_sw_loc21 >= 0 ) then + nebpe = itargdn_sw_loc21 + + + allocate( sBuf_SW(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = H(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_SW, stat = ierr ) + + endif + +! +! --- Receive SW portion of data at lower generation +! + + + if( lsendup_sw ) then + + nebpe = itarg_up + + + allocate( rBuf_SW(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_SW, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + do j=1,jmL + do i=1,imL + V_out(:,i,j)=rBuf_SW(:,i,j) + enddo + enddo + + deallocate( rBuf_SW, stat = iderr) + + endif + +! +! --- Send data from SE portion of processors at the higher generation +! to corresponding PE's at lower generation + + if( itargdn_se_loc21 >= 0 ) then + nebpe = itargdn_se_loc21 + + allocate( sBuf_SE(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SE(:,i,j) = H(:,imL+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_SE, stat = ierr ) + + + endif +! +! --- Receive SE portion of data at lower generation + + + if( lsendup_se ) then + nebpe = itarg_up + + + allocate( rBuf_SE(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_SE, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + do j=1,jmL + do i=1,imL + V_out(:,i,j)=Rbuf_SE(:,i,j) + enddo + enddo + + deallocate( rBuf_SE, stat = iderr) + + end if + +! +! --- Send data from NW portion of processors at the higher generation +! to corresponding PE's at lower generantion + + if( itargdn_nw_loc21 >= 0 ) then + + nebpe = itargdn_nw_loc21 + + + allocate( sBuf_NW(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NW(:,i,j) = H(:,i,jmL+j) + enddo + enddo + + call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_NW, stat = ierr ) + + + endif +! +! --- Receive NW portion of data at lower generation + + + if( lsendup_nw ) then + + nebpe = itarg_up + + allocate( rBuf_NW(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_NW, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + do j=1,jmL + do i=1,imL + V_out(:,i,j)=Rbuf_NW(:,i,j) + enddo + enddo + + deallocate( rBuf_NW, stat = iderr) + + + end if + + +! --- Send data from NE portion of processors at the higher generation +! to corresponding PE's at lower generation + + if( itargdn_ne_loc21 >= 0 ) then + + nebpe = itargdn_ne_loc21 + + + allocate( sBuf_NE(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = H(:,imL+i,jmL+j) + enddo + enddo + + call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_NE, stat = ierr ) + + + endif +! +! --- Receive NE portion of data at lower generation +! + + if( lsendup_ne ) then + + nebpe = itarg_up + + allocate( rBuf_NE(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_NE, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + do j=1,jmL + do i=1,imL + V_out(:,i,j)=rBuf_NE(:,i,j) + enddo + enddo + + deallocate( rBuf_NE, stat = iderr) + + end if + +!----------------------------------------------------------------------- +endsubroutine downsend_loc_g21 + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end submodule mg_bocos diff --git a/src/mgbf/mg_domain.f90 b/src/mgbf/mg_domain.f90 new file mode 100644 index 0000000000..d56d1a5f9f --- /dev/null +++ b/src/mgbf/mg_domain.f90 @@ -0,0 +1,644 @@ +submodule(mg_parameter) mg_domain +!$$$ submodule documentation block +! . . . . +! module: mg_domain +! prgmmr: rancic org: NCEP/EMC date: 2020 +! +! abstract: Definition of a squared integration domain +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! init_mg_domain - +! init_domain - +! init_topology_2d - +! real_itarg - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +use kinds, only: i_kind + +implicit none + +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +contains +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine init_mg_domain(this) +!*********************************************************************** +! * +! Initialize square domain * +! * +!*********************************************************************** +implicit none +class(mg_parameter_type)::this + +call init_domain(this) +call init_topology_2d(this) + +!----------------------------------------------------------------------- +endsubroutine init_mg_domain + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine init_domain(this) +!*********************************************************************** +! * +! Definition of constants that control filtering domain * +! * +!*********************************************************************** +implicit none +class(mg_parameter_type),target::this + +integer(i_kind) n,nstrd,i,j +logical:: F=.false., T=.true. + +integer(i_kind):: loc_pe,g +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" +!----------------------------------------------------------------------- + + Flwest(1)=nx.eq.1 + Fleast(1)=nx.eq.nxm + Flsouth(1)=my.eq.1 + Flnorth(1)=my.eq.nym + + if(l_hgen) then + + loc_pe=mype_hgen-maxpe_fgen(my_hgen-1) + jy=loc_pe/ixm(my_hgen)+1 + ix=mod(loc_pe,ixm(my_hgen))+1 + + Flwest(2)=ix.eq.1 + Fleast(2)=ix.eq.ixm(my_hgen) + Flsouth(2)=jy.eq.1 + Flnorth(2)=jy.eq.jym(my_hgen) + + else + + jy = -1 + ix = -1 + + Flwest(2)=F + Fleast(2)=F + Flsouth(2)=F + Flnorth(2)=F + + endif + + mype_filt(1)=mype + mype_filt(2)=mype_hgen + +! +! Communication params for analysis grid +! + if(nx==1) then + itarg_wA=-1 + else + itarg_wA=mype-1 + endif + + if(nx==nxm) then + itarg_eA=-1 + else + itarg_eA=mype+1 + endif + + if(my==1) then + itarg_sA=-1 + else + itarg_sA=mype-nxm + endif + + if(my==nym) then + itarg_nA=-1 + else + itarg_nA=mype+nxm + endif + + lwestA=nx.eq.1 + leastA=nx.eq.nxm + lsouthA=my.eq.1 + lnorthA=my.eq.nym + + +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! write(100+mype,'(a)')'---------------------------------' +! write(100+mype,'(a)')'From init_domain' +! write(100+mype,'(a,2i5)')'mype=',mype +! write(100+mype,'(a,i5)')'nx=',nx +! write(100+mype,'(a,i5)')'my=',my +! write(100+mype,'(a)')'---------------------------------' +! write(100+mype_filt,'(a)')'---------------------------------' +! write(100+mype_filt,'(a,3i5)')'mype,mype_filt,mygen :',mype,mype_filt,mygen +! write(100+mype_filt,'(a,2i5)')'ix,jy= ',ix,jy +! write(100+mype_filt,'(a,l5)')'lwest = ',lwest +! write(100+mype_filt,'(a,l5)')'least = ',least +! write(100+mype_filt,'(a,l5)')'lsouth= ',lsouth +! write(100+mype_filt,'(a,l5)')'lnorth= ',lnorth +! write(100+mype_filt,'(a,l5)')'lcorner_sw ',lcorner_sw +! write(100+mype_filt,'(a,l5)')'lcorner_se ',lcorner_se +! write(100+mype_filt,'(a,l5)')'lcorner_nw ',lcorner_nw +! write(100+mype_filt,'(a,l5)')'lcorner_ne ',lcorner_ne +! write(100+mype_filt,'(a)')'----------------------------------' +! write(100+mype_filt,'(a)')' ' +!----------------------------------------------------------------------- +! if(mype==0) then +! write(27,'(a,i4)') 'nb=',nb +! write(27,'(a,i4)') 'mb=',mb +! endif +! +! call finishMPI +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + +!----------------------------------------------------------------------- +endsubroutine init_domain + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine init_topology_2d(this) +!*********************************************************************** +! * +! Define topology of filter grid * +! - Four generations - * +! * +!*********************************************************************** +implicit none +class(mg_parameter_type),target::this +!----------------------------------------------------------------------- +logical:: F=.false., T=.true. + +integer(i_kind) mx2,my2,ix_up,jy_up,ix_dn,jy_dn +integer(i_kind) g,naux,nx_up,my_up +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" +!----------------------------------------------------------------------- +! +! Topology of generations of the squared domain +! +! G1 +! _____ _____ _____ _____ _____ _____ _____ _____ +! | | | | | | | | | +! | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | +! |_____|_____|_____|_____|_____|_____|_____|_____| +! | | | | | | | | | +! | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | +! |_____|_____|_____|_____|_____|_____|_____|_____| +! | | | | | | | | | +! | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | +! |_____|_____|_____|_____|_____|_____|_____|_____| +! | | | | | | | | | +! | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | +! |_____|_____|_____|_____|_____|_____|_____|_____| +! | | | | | | | | | +! | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | +! |_____|_____|_____|_____|_____|_____|_____|_____| +! | | | | | | | | | +! | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | +! |_____|_____|_____|_____|_____|_____|_____|_____| +! | | | | | | | | | +! | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | +! |_____|_____|_____|_____|_____|_____|_____|_____| +! | | | | | | | | | +! | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | +! |_____|_____|_____|_____|_____|_____|_____|_____| +! +! +! G2 +! ___________ ___________ ___________ ___________ +! | | | | | +! | | | | | +! | 76 | 77 | 78 | 79 | +! | | | | | +! | | | | | +! |___________|___________|___________|___________| +! | | | | | +! | | | | | +! | 72 | 73 | 74 | 75 | +! | | | | | +! | | | | | +! |___________|___________|___________|___________| +! | | | | | +! | | | | | +! | 68 | 69 | 70 | 71 | +! | | | | | +! | | | | | +! |___________|___________|___________|___________| +! | | | | | +! | | | | | +! | 64 | 65 | 66 | 67 | +! | | | | | +! | | | | | +! |___________|___________|___________|___________| +! +! +! G3 +! _______________________ _______________________ +! | | | +! | | | +! | | | +! | | | +! | | | +! | 82 | 83 | +! | | | +! | | | +! | | | +! | | | +! | | | +! |_______________________|_______________________| +! | | | +! | | | +! | | | +! | | | +! | | | +! | 80 | 81 | +! | | | +! | | | +! | | | +! | | | +! | | | +! |_______________________|_______________________| +! +! +! G4 +! _______________________________________________ +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! | 84 | +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! |_______________________________________________| +! +!---------------------------------------------------------------------- + + do g = 1,2 +!*** +!*** Send WEST +!*** + if(Flwest(g)) then + Fitarg_w(g) = -1 + else + if(g==1.or.l_hgen) then + Fitarg_w(g) = mype_filt(g)-1 + else + Fitarg_w(g) = -1 + endif + endif +!*** +!*** Send EAST +!*** + if(Fleast(g)) then + Fitarg_e(g) = -1 + else + if(g==1.or.l_hgen) then + Fitarg_e(g) = mype_filt(g)+1 + else + Fitarg_e(g) = -1 + endif + endif + +!*** +!*** Send SOUTH +!*** + + if(Flsouth(g)) then + Fitarg_s(g)=-1 + else + select case(g) + case(1) + naux = nxm + case(2) + if(l_hgen) then + naux = ixm(my_hgen) + endif + endselect + if(g==1.or.l_hgen) then + Fitarg_s(g)=mype_filt(g)-naux + else + Fitarg_s(g)=-1 + endif + endif + +!*** +!*** Send NORTH +!*** + if(Flnorth(g)) then + Fitarg_n(g)=-1 + else + select case(g) + case(1) + naux = nxm + case(2) + if(l_hgen) then + naux = ixm(my_hgen) + endif + endselect + if(g==1.or.l_hgen) then + Fitarg_n(g)=mype_filt(g)+naux + else + Fitarg_n(g)=-1 + endif + endif + +!*** +!*** Send SOUTH-WEST +!*** + + if(Flsouth(g).and.Flwest(g)) then + Fitarg_sw(g)=-1 + else & + if(Flsouth(g)) then + Fitarg_sw(g)=Fitarg_w(g) + else & + if(Flwest(g)) then + Fitarg_sw(g)=Fitarg_s(g) + else + Fitarg_sw(g)=Fitarg_s(g)-1 + endif + if(g>1 .and. .not.l_hgen) then + Fitarg_sw(g)=-1 + endif + +!*** +!*** Send SOUTH-EAST +!*** + + if(Flsouth(g).and.Fleast(g)) then + Fitarg_se(g)=-1 + else & + if(Flsouth(g)) then + Fitarg_se(g)=Fitarg_e(g) + else & + if(Fleast(g)) then + Fitarg_se(g)=Fitarg_s(g) + else + Fitarg_se(g)=Fitarg_s(g)+1 + endif + if(g>1 .and. .not.l_hgen) then + Fitarg_se(g)=-1 + endif + +!*** +!*** Send NORTH-WEST +!*** + if(Flnorth(g).and.Flwest(g)) then + Fitarg_nw(g)=-1 + else & + if(Flnorth(g)) then + Fitarg_nw(g)=Fitarg_w(g) + else & + if(Flwest(g)) then + Fitarg_nw(g)=Fitarg_n(g) + else + Fitarg_nw(g)=Fitarg_n(g)-1 + endif + if(g>1 .and. .not.l_hgen) then + Fitarg_nw(g)=-1 + endif + + +!*** +!*** Send NORTH-EAST +!*** + + if(Flnorth(g).and.Fleast(g)) then + Fitarg_ne(g)=-1 + else & + if(Flnorth(g)) then + Fitarg_ne(g)=Fitarg_e(g) + else & + if(Fleast(g)) then + Fitarg_ne(g)=Fitarg_n(g) + else + Fitarg_ne(g)=Fitarg_n(g)+1 + endif + if(g>1 .and. .not.l_hgen) then + Fitarg_ne(g)=-1 + endif + + + enddo + +!----------------------------------------------------------------------- +! +! Upsending flags +! + + mx2=mod(nx,2) + my2=mod(my,2) + + if(mx2==1.and.my2==1) then + Flsendup_sw(1)=T + else & + if(mx2==0.and.my2==1) then + Flsendup_se(1)=T + else & + if(mx2==1.and.my2==0) then + Flsendup_nw(1)=T + else + Flsendup_ne(1)=T + end if + + nx_up=(nx-1)/2 !+1 + my_up=(my-1)/2 !+1 + + + Fitarg_up(1)=maxpe_fgen(1)+my_up*ixm(2)+nx_up + + + if(l_hgen.and.my_hgen < gm) then + + mx2=mod(ix,2) + my2=mod(jy,2) + + if(mx2==1.and.my2==1) then + Flsendup_sw(2)=T + else & + if(mx2==0.and.my2==1) then + Flsendup_se(2)=T + else & + if(mx2==1.and.my2==0) then + Flsendup_nw(2)=T + else + Flsendup_ne(2)=T + end if + + ix_up=(ix-1)/2 !+1 + jy_up=(jy-1)/2 !+1 + + Fitarg_up(2)=maxpe_fgen(my_hgen)+jy_up*ixm(my_hgen+1)+ix_up + + else + + Flsendup_sw(2)=F + Flsendup_se(2)=F + Flsendup_nw(2)=F + Flsendup_ne(2)=F + + Fitarg_up(2)=-1 + + endif + +! +! Downsending flags +! + + if(my_hgen > 1) then + + ix_dn = 2*ix-1 + jy_dn = 2*jy-1 + + itargdn_sw=maxpe_fgen(my_hgen-2)+(jy_dn-1)*ixm(my_hgen-1)+(ix_dn-1) + itargdn_nw=itargdn_sw+ixm(my_hgen-1) + itargdn_se=itargdn_sw+1 + itargdn_ne=itargdn_nw+1 + + if(Fimax(my_hgen) <= imL .and. Fleast(2)) then + itargdn_se=-1 + itargdn_ne=-1 + endif + if(Fjmax(my_hgen) <= jmL .and. Flnorth(2)) then + itargdn_nw=-1 + itargdn_ne=-1 + end if + + else + + itargdn_sw=-1 + itargdn_se=-1 + itargdn_nw=-1 + itargdn_ne=-1 + + end if +! +! Convert targets in higher generations into real targets +! + call real_itarg(this,Fitarg_w(2)) + call real_itarg(this,Fitarg_e(2)) + call real_itarg(this,Fitarg_s(2)) + call real_itarg(this,Fitarg_n(2)) + + call real_itarg(this,Fitarg_sw(2)) + call real_itarg(this,Fitarg_se(2)) + call real_itarg(this,Fitarg_nw(2)) + call real_itarg(this,Fitarg_ne(2)) + + if(itargdn_sw .ge. maxpe_fgen(1)) call real_itarg(this,itargdn_sw) + if(itargdn_se .ge. maxpe_fgen(1)) call real_itarg(this,itargdn_se) + if(itargdn_nw .ge. maxpe_fgen(1)) call real_itarg(this,itargdn_nw) + if(itargdn_ne .ge. maxpe_fgen(1)) call real_itarg(this,itargdn_ne) + + call real_itarg(this,Fitarg_up(1)) + call real_itarg(this,Fitarg_up(2)) + +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! write(200+mype_filt,'(a)')'---------------------------------' +! write(200+mype_filt,'(a)')'From init_topology_2d' +! write(200+mype_filt,'(a,2i5)')'mype=',mype +! write(200+mype_filt,'(a,i5)')'nx=',nx +! write(200+mype_filt,'(a,i5)')'my=',my +! write(200+mype_filt,'(a)')'---------------------------------' +! if(l_hgen ) then +! write(100+mype_filt,*)' ' +! write(100+mype_filt,'(a,2i5)')'I AM (f),(a):',mype_filt,mype +! write(100+mype_filt,'(a,i5)') 'mygen= ',mygen +! +! write(100+mype_filt,'(a,2i5)')'itarg_w=',itarg_w +! write(100+mype_filt,'(a,2i5)')'itarg_e=',itarg_e +! write(100+mype_filt,'(a,2i5)')'itarg_s=',itarg_s +! write(100+mype_filt,'(a,2i5)')'itarg_n=',itarg_n +! +! write(100+mype_filt,'(a,2i5)')'itarg_sw=',itarg_sw +! write(100+mype_filt,'(a,2i5)')'itarg_se=',itarg_se +! write(100+mype_filt,'(a,2i5)')'itarg_nw=',itarg_nw +! write(100+mype_filt,'(a,2i5)')'itarg_ne=',itarg_ne +! write(100+mype_filt,'(a)')' ' +! +! if(lsendup_sw) write(100+mype_filt,'(a,l5)')'lsendup_sw=',lsendup_sw +! if(lsendup_se) write(100+mype_filt,'(a,l5)')'lsendup_se=',lsendup_se +! if(lsendup_nw) write(100+mype_filt,'(a,l5)')'lsendup_nw=',lsendup_nw +! if(lsendup_ne) write(100+mype_filt,'(a,l5)')'lsendup_ne=',lsendup_ne +! +! write(100+mype_filt,'(a,i5)')'itarg_up=',itarg_up +! +! if(lsend_dn) write(100+mype_filt,'(a,l5)')'lsend_dn=',lsend_dn +! +! if(my_hgen > 1) then +! write(100+mype_hgen,'(a,2i5)')'mype_hgen,itargdn_sw=',mype_hgen,itargdn_sw +! write(100+mype_hgen,'(a,2i5)')'mype_hgen,itargdn_se=',mype_hgen,itargdn_se +! write(100+mype_hgen,'(a,2i5)')'mype_hgen,itargdn_nw=',mype_hgen,itargdn_nw +! write(100+mype_hgen,'(a,2i5)')'mype_hgen,itargdn_ne=',mype_hgen,itargdn_ne +! write(100+mype_hgen,'(a,2i5)')' ' +! if(Flsendup_sw(2)) then +! write(mype+600,'(a,i4,l2,i4)')'mype_hgen,Flsendup_sw(2),Fitarg_up(2)= ' & +! ,mype_hgen,Flsendup_sw(2),Fitarg_up(2) +! endif +! if(Flsendup_se(2)) then +! write(mype+600,'(a,i4,l2,i4)')'mype_hgen,Flsendup_se(2),Fitarg_up(2)= ' & +! ,mype_hgen,Flsendup_se(2),Fitarg_up(2) +! endif +! if(Flsendup_nw(2)) then +! write(mype+600,'(a,i4,l2,i4)')'mype_hgen,Flsendup_nw(2),Fitarg_up(2)= ' & +! ,mype_hgen,Flsendup_nw(2),Fitarg_up(2) +! endif +! if(Flsendup_ne(2)) then +! write(mype+600,'(a,i4,l2,i4)')'mype_hgen,Flsendup_ne(2),Fitarg_up(2)= ' & +! ,mype_hgen,Flsendup_ne(2),Fitarg_up(2) +! endif +! call finishMPI +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!----------------------------------------------------------------------- +endsubroutine init_topology_2d +!---------------------------------------------------------------------- +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine real_itarg & +!*********************************************************************** +! * +! Definite real targets for high generations * +! * +!*********************************************************************** +(this,itarg) +!----------------------------------------------------------------------- +implicit none +class(mg_parameter_type),target::this +integer(i_kind), intent(inout):: itarg +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" +!----------------------------------------------------------------------- +if(itarg>-1) then + itarg = itarg-nxy(1) +endif +!----------------------------------------------------------------------- +endsubroutine real_itarg + +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end submodule mg_domain diff --git a/src/mgbf/mg_domain_loc.f90 b/src/mgbf/mg_domain_loc.f90 new file mode 100644 index 0000000000..183a5f23d7 --- /dev/null +++ b/src/mgbf/mg_domain_loc.f90 @@ -0,0 +1,796 @@ +submodule(mg_parameter) mg_domain_loc +!$$$ submodule documentation block +! . . . . +! module: mg_domain_loc +! prgmmr: rancic org: NCEP/EMC date: 2020 +! +! abstract: Module that defines control paramters for application +! of MGBF to localization +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! init_domain_loc - +! sidesend_loc - +! targup_loc - +! targdn21_loc - +! targdn32_loc - +! targdn43_loc - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use kinds, only: i_kind +implicit none + +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +contains +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine init_domain_loc(this) +!*********************************************************************** +! ! +! Initialize localization with application of MGBF ! +! ! +!*********************************************************************** +implicit none +class(mg_parameter_type)::this +!---------------------------------------------------------------------- + +call sidesend_loc(this) +call targup_loc(this) +call targdn21_loc(this) +call targdn32_loc(this) +call targdn43_loc(this) + +!---------------------------------------------------------------------- +endsubroutine init_domain_loc + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine sidesend_loc(this) +!*********************************************************************** +! ! +! Initialize sidesending pararameters for application MGBF to ! +! localization ! +! ! +!*********************************************************************** +implicit none +class(mg_parameter_type),target::this +integer(i_kind):: ix_0,jy_0 +integer(i_kind):: ix_c,jy_c +integer(i_kind):: ix_cc,jy_cc +integer(i_kind):: ix_ccc,jy_ccc +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" +!----------------------------------------------------------------------- + +! write(10,'(a)') ' Generation 2' +! write(10,'(a)') '----------------------' +! write(10,'(a)') 'mype Flsouth_loc(1) ' + +! write(11,'(a)') ' Generation 2' +! write(11,'(a)') '----------------------' +! write(11,'(a)') 'mype Flnorth_loc(1) ' + +! write(12,'(a)') ' Generation 2' +! write(12,'(a)') '----------------------' +! write(12,'(a)') 'mype Flwest_loc(1) ' + +! write(13,'(a)') ' Generation 2' +! write(13,'(a)') '----------------------' +! write(13,'(a)') 'mype Fleast_loc(1) ' + +! write(14,'(a)') ' Generation 2' +! write(14,'(a)') '----------------------' +! write(14,'(a)') 'mype Fitarg_s_loc(1) ' + +! write(15,'(a)') ' Generation 2' +! write(15,'(a)') '----------------------' +! write(15,'(a)') 'mype Fitarg_n_loc(1) ' + +! write(16,'(a)') ' Generation 2' +! write(16,'(a)') '----------------------' +! write(16,'(a)') 'mype Fitarg_w_loc(1) ' + +! write(17,'(a)') ' Generation 2' +! write(17,'(a)') '----------------------' +! write(17,'(a)') 'mype Fitarg_e_loc(1) ' + +! do mype=0,nxm*nym-1 + +! +! Generation 1 +! + jy_0 = mype/nxm + ix_0 = mype - jy_0*nxm +1 + jy_0 = jy_0 + 1 + + Flsouth_loc(1)=jy_0==1 + Flnorth_loc(1)=jy_0==nym + Flwest_loc(1) =ix_0==1 + Fleast_loc(1) =ix_0==nxm + + if(Flsouth_loc(1)) then + Fitarg_s_loc(1) = -1 + else + Fitarg_s_loc(1) = mype-nxm + endif + + if(Flnorth_loc(1)) then + Fitarg_n_loc(1) = -1 + else + Fitarg_n_loc(1) = mype+nxm + endif + + if(Flwest_loc(1)) then + Fitarg_w_loc(1) = -1 + else + Fitarg_w_loc(1) = mype-1 + endif + + if(Fleast_loc(1)) then + Fitarg_e_loc(1) = -1 + else + Fitarg_e_loc(1) = mype+1 + endif + +! write(10,'(i5,a,l5)') mype, ' ---> ',Flsouth_loc(1) +! write(11,'(i5,a,l5)') mype, ' ---> ',Flnorth_loc(1) +! write(12,'(i5,a,l5)') mype, ' ---> ',Flwest_loc(1) +! write(13,'(i5,a,l5)') mype, ' ---> ',Fleast_loc(1) +! write(14,'(i5,a,i5)') mype, ' ---> ',Fitarg_s_loc(1) +! write(15,'(i5,a,i5)') mype, ' ---> ',Fitarg_n_loc(1) +! write(16,'(i5,a,i5)') mype, ' ---> ',Fitarg_w_loc(1) +! write(17,'(i5,a,i5)') mype, ' ---> ',Fitarg_e_loc(1) + +! +! Generation 2 +! + + if(ix_0 <= nxm/2 .and. jy_0 <= nym/2) then + ix_c = ix_0 + jy_c = jy_0 + else & + if( (nxm/2 < ix_0 .and. ix_0 <=nxm) .and. jy_0 <= nym/2) then + ix_c = ix_0 - nxm/2 + jy_c = jy_0 + else & + if(ix_0 <= nxm/2 .and. (nym/2 < jy_0 .and. jy_0 <=nym) ) then + ix_c = ix_0 + jy_c = jy_0 - nym/2 + else & + if( (nxm/2 < ix_0 .and. ix_0 <=nxm) .and. (nym/2 < jy_0 .and. jy_0 <=nym) ) then + ix_c = ix_0 - nxm/2 + jy_c = jy_0 - nym/2 + end if + + Flsouth_loc(2)=jy_c==1 + Flnorth_loc(2)=jy_c==nym/2 + Flwest_loc(2) =ix_c==1 + Fleast_loc(2) =ix_c==nxm/2 + + if(Flsouth_loc(2)) then + Fitarg_s_loc(2) = -1 + else + Fitarg_s_loc(2) = mype-nxm + endif + + if(Flnorth_loc(2)) then + Fitarg_n_loc(2) = -1 + else + Fitarg_n_loc(2) = mype+nxm + endif + + if(Flwest_loc(2)) then + Fitarg_w_loc(2) = -1 + else + Fitarg_w_loc(2) = mype-1 + endif + + if(Fleast_loc(2)) then + Fitarg_e_loc(2) = -1 + else + Fitarg_e_loc(2) = mype+1 + endif + +! write(10,'(i5,a,l5)') mype, ' ---> ',Flsouth_loc(2) +! write(11,'(i5,a,l5)') mype, ' ---> ',Flnorth_loc(2) +! write(12,'(i5,a,l5)') mype, ' ---> ',Flwest_loc(2) +! write(13,'(i5,a,l5)') mype, ' ---> ',Fleast_loc(2) +! write(14,'(i5,a,i5)') mype, ' ---> ',Fitarg_s_loc(2) +! write(15,'(i5,a,i5)') mype, ' ---> ',Fitarg_n_loc(2) + +! +! Generation 3 +! + if(ix_c <= nxm/4 .and. jy_c <= nym/4) then + ix_cc = ix_c + jy_cc = jy_c + else & + if(ix_c > nxm/4 .and. jy_c <= nym/4) then + ix_cc = ix_c-nxm/4 + jy_cc =jy_c + else & + if(ix_c <= nxm/4 .and. jy_c > nym/4) then + ix_cc = ix_c + jy_cc =jy_c-nym/4 + else & + if(ix_c > nxm/4 .and. jy_c > nym/4) then + ix_cc = ix_c-nxm/4 + jy_cc = jy_c-nym/4 + endif + + Flsouth_loc(3)=jy_cc==1 + Flnorth_loc(3)=jy_cc==nym/4 + Flwest_loc(3) =ix_cc==1 + Fleast_loc(3) =ix_cc==nxm/4 + + if(Flsouth_loc(3)) then + Fitarg_s_loc(3) = -1 + else + Fitarg_s_loc(3) = mype-nxm + endif + + if(Flnorth_loc(3)) then + Fitarg_n_loc(3) = -1 + else + Fitarg_n_loc(3) = mype+nxm + endif + + if(Flwest_loc(3)) then + Fitarg_w_loc(3) = -1 + else + Fitarg_w_loc(3) = mype-1 + endif + + if(Fleast_loc(3)) then + Fitarg_e_loc(3) = -1 + else + Fitarg_e_loc(3) = mype+1 + endif + +! write(10,'(i5,a,l5)') mype, ' ---> ',Flsouth_loc(3) +! write(11,'(i5,a,l5)') mype, ' ---> ',Flnorth_loc(3) +! write(12,'(i5,a,l5)') mype, ' ---> ',Flwest_loc(3) +! write(13,'(i5,a,l5)') mype, ' ---> ',Fleast_loc(3) +! write(14,'(i5,a,i5)') mype, ' ---> ',Fitarg_s_loc(3) +! write(15,'(i5,a,i5)') mype, ' ---> ',Fitarg_n_loc(3) + +! +! Generation 4 +! + if(ix_cc <= nxm/8 .and. jy_cc <= nym/8) then + ix_ccc = ix_cc; jy_ccc = jy_cc + else & + if(ix_cc > nxm/8 .and. jy_cc <= nym/8) then + ix_ccc = ix_cc-nxm/8; jy_ccc =jy_cc + else & + if(ix_cc <= nxm/8 .and. jy_cc > nym/8) then + ix_ccc = ix_cc; jy_ccc =jy_cc-nym/8 + else & + if(ix_cc > nxm/8 .and. jy_cc > nym/8) then + ix_ccc = ix_cc-nxm/8; jy_ccc =jy_cc-nym/8 + endif + + Flsouth_loc(4)=jy_ccc==1 + Flnorth_loc(4)=jy_ccc==nym/8 + Flwest_loc(4) =ix_ccc==1 + Fleast_loc(4) =ix_ccc==nxm/8 + + if(Flsouth_loc(4)) then + Fitarg_s_loc(4) = -1 + else + Fitarg_s_loc(4) = mype-nxm + endif + + if(Flnorth_loc(4)) then + Fitarg_n_loc(4) = -1 + else + Fitarg_n_loc(4) = mype+nxm + endif + + if(Flwest_loc(4)) then + Fitarg_w_loc(4) = -1 + else + Fitarg_w_loc(4) = mype-1 + endif + + if(Fleast_loc(4)) then + Fitarg_e_loc(4) = -1 + else + Fitarg_e_loc(4) = mype+1 + endif + +! enddo + +!---------------------------------------------------------------------- +endsubroutine sidesend_loc + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine targup_loc(this) +!*********************************************************************** +! ! +! Initialize upsending pararameters for application MGBF to ! +! localization ! +! ! +!*********************************************************************** +implicit none +class(mg_parameter_type),target::this +integer(i_kind):: ix_0,jy_0 +integer(i_kind):: ix_c,jy_c,mype_c +integer(i_kind):: ix_prox,jy_prox,targup +integer(i_kind):: n,is,js, mj2, il,jl +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" +!-------------------------------------------------------------------- + +!do mype=0,nxm*nym-1 + + jy_0 = mype/nxm+1 + ix_0 = mype-(jy_0-1)*nxm+1 + + mj2=mod(jy_0,2) + mype_c=(nxm/2)*(jy_0-2+mj2)/2+(ix_0-1)/2 + + jy_c = mype_c/(nxm/2)+1 + ix_c = mype_c-(jy_c-1)*(nxm/2)+1 + + lsendup_sw_loc=(mod(ix_0,2)==1).and.(mod(jy_0,2)==1) + lsendup_se_loc=(mod(ix_0,2)==0).and.(mod(jy_0,2)==1) + lsendup_nw_loc=(mod(ix_0,2)==1).and.(mod(jy_0,2)==0) + lsendup_ne_loc=(mod(ix_0,2)==0).and.(mod(jy_0,2)==0) + +! +! g1 --> g2 +! + + do n=1,4 + js=(n-1)/2 + is= n-1 -js*2 + ix_prox=ix_c+is*nxm/2 + jy_prox=jy_c+js*nym/2 + + Fitargup_loc12(n)=nxm*(jy_prox-1)+ix_prox-1 + enddo + +! write(12,'(i5,a,4i5)') mype,' ---> ', Fitargup_loc12(1),Fitargup_loc12(2),Fitargup_loc12(3),Fitargup_loc12(4) + +! +! g2 --> g3 +! + il = (ix_0-1)/(nxm/2) + jl = (jy_0-1)/(nym/2) + + do n=1,4 + js=(n-1)/2 + is= n-1-js*2 + ix_prox=ix_c +is*nxm/4 + il*nxm/4 + jy_prox=jy_c +js*nym/4 + jl*nym/4 + + Fitargup_loc23(n)=nxm*(jy_prox-1)+ix_prox-1 + enddo + +! write(23,'(i5,a,4i5)') mype,' ---> ', Fitargup_loc23(1),Fitargup_loc23(2),Fitargup_loc23(3),Fitargup_loc23(4) + +! +! g3 --> g4 +! + il = (ix_0-1)/(nxm/4) + jl = (jy_0-1)/(nym/4) + + do n=1,4 + js=(n-1)/2 + is= n-1-js*2 + ix_prox=ix_c +is*nxm/8 + il*nxm/8 + jy_prox=jy_c +js*nym/8 + jl*nym/8 + + Fitargup_loc34(n)=nxm*(jy_prox-1)+ix_prox-1 + enddo + +! write(34,'(i5,a,4i5)') mype,' ---> ', +!Fitargup_loc34(1),Fitargup_loc34(2),Fitargup_loc34(3),Fitargup_loc34(4) + +!enddo + +!---------------------------------------------------------------------- +endsubroutine targup_loc + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine targdn21_loc(this) +!*********************************************************************** +! ! +! Initialize downsending pararameters for application MGBF to ! +! localization from g2 go g1 ! +! ! +!*********************************************************************** +implicit none +class(mg_parameter_type),target::this +integer:: ix_t,jy_t +integer:: ix_l,jy_l +integer:: ix_sw,jy_sw +integer:: ix_se,jy_se +integer:: ix_nw,jy_nw +integer:: ix_ne,jy_ne +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" +!------------------------------------------------------------------------ + +! write(11,'(a)') 'mype itargdn_xx_loc21 nsq21 ' +! write(11,'(a)') '---------------------------------' + +! do mype=0,nxm*nym-1 + + jy_t = mype/nxm+1 + ix_t = mype-(jy_t-1)*nxm+1 + +! +! Square 1 +! + if(ix_t <= nxm/2 .and. jy_t <= nym/2) then + ix_l = ix_t + jy_l = jy_t + nsq21 = 1 + else & +! +! Square 2 +! + if( (nxm/2 < ix_t .and. ix_t <= nxm) .and. jy_t <= nym/2) then + ix_l = ix_t-nxm/2 + jy_l = jy_t + nsq21 = 2 + else & +! +! Square 3 +! + if( ix_t <= nxm/2 .and. (nym/2 < jy_t .and. jy_t <= nym)) then + ix_l = ix_t + jy_l = jy_t-nym/2 + nsq21 = 3 + else & +! +! Square 4 +! + if( (nxm/2 < ix_t .and. ix_t <= nxm) .and. (nym/2 < jy_t .and. jy_t <= nym)) then + ix_l = ix_t-nxm/2 + jy_l = jy_t-nym/2 + nsq21 = 4 + endif + + ix_sw = 2*ix_l-1 + jy_sw = 2*jy_l-1 + itargdn_sw_loc21 = nxm*(jy_sw-1)+ix_sw-1 + + ix_se = ix_sw+1 + jy_se = jy_sw + itargdn_se_loc21 = nxm*(jy_se-1)+ix_se-1 + + ix_nw = ix_sw + jy_nw = jy_sw+1 + itargdn_nw_loc21 = nxm*(jy_nw-1)+ix_nw-1 + + ix_ne = ix_nw+1 + jy_ne = jy_nw + itargdn_ne_loc21 = nxm*(jy_ne-1)+ix_ne-1 + +! write(11,'(i6,a,2i4)') mype,' <-- itargdn_sw_loc21 ',itargdn_sw_loc21,nsq +! write(11,'(i6,a,2i4)') mype,' <-- itargdn_se_loc21 ',itargdn_se_loc21,nsq +! write(11,'(i6,a,2i4)') mype,' <-- itargdn_nw_loc21 ',itargdn_nw_loc21,nsq +! write(11,'(i6,a,2i4)') mype,' <-- itargdn_ne_loc21 ',itargdn_ne_loc21,nsq + +! end do +!----------------------------------------------------------- +endsubroutine targdn21_loc + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine targdn32_loc(this) +!*********************************************************************** +! ! +! Initialize downsending pararameters for application MGBF to ! +! localization from g3 go g2 ! +! ! +!*********************************************************************** +implicit none +class(mg_parameter_type),target::this +integer(i_kind):: ix_t,jy_t +integer(i_kind):: ix_l,jy_l +integer(i_kind):: ix_sw,jy_sw +integer(i_kind):: ix_se,jy_se +integer(i_kind):: ix_nw,jy_nw +integer(i_kind):: ix_ne,jy_ne +integer(i_kind):: facx,facy +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" +!----------------------------------------------------------- + +! write(32,'(a)') 'mype itargdn_xx_loc32 nsq32 ' +! write(32,'(a)') '---------------------------------' + +! do mype=0,nxm*nym-1 + + jy_t = mype/nxm+1 + ix_t = mype-(jy_t-1)*nxm+1 + +! +! Square 1 +! + if(ix_t <= nxm/4 .and. jy_t <= nym/4) then + ix_l = ix_t + jy_l = jy_t + nsq32 = 1 + facx = 0 + facy = 0 + else & +! +! Square 2 +! + if( (nxm/4 < ix_t .and.ix_t<=nxm/2 ) .and. jy_t <= nym/4) then + ix_l = ix_t-nxm/4 + jy_l = jy_t + nsq32 = 2 + facx = 0 + facy = 0 + else & +! +! Square 3 +! + if( ix_t <= nxm/4 .and. (nym/4 < jy_t .and. jy_t <= nym/2)) then + ix_l = ix_t + jy_l = jy_t-nym/4 + nsq32 = 3 + facx = 0 + facy = 0 + else & +! +! Square 4 +! + if( (nxm/4 < ix_t .and. ix_t <= nxm/2) .and. (nym/4 < jy_t .and. jy_t <= nym/2)) then + ix_l = ix_t-nxm/4 + jy_l = jy_t-nym/4 + nsq32 = 4 + facx = 0 + facy = 0 + else & +! +! Square 5 +! + if( (nxm/2 1) call this%init_mg_MPI + +!*** +!*** Initialize integration domain +!*** +call this%init_mg_domain +if(this%l_loc) then + call this%init_domain_loc +endif + +!--------------------------------------------------------------------------- +! +! All others are function of km2,km3,km,nm,mm,im,jm +! and needs to be called separately for each application +! +!--------------------------------------------------------------------------- +!*** +!*** Define km and WORKA array based on input from mg_parameters and +!*** depending on specific application +!*** + +!*** +!*** Allocate variables, define weights, prepare mapping +!*** between analysis and filter grid +!*** + +call this%allocate_mg_intstate + +call this%def_offset_coef + +call this%def_mg_weights + +if(this%mgbf_line) then + call this%init_mg_line +endif + +call this%lsqr_mg_coef + +call this%lwq_vertical_coef(this%lm_a,this%lm,this%cvf1,this%cvf2,this%cvf3,this%cvf4,this%lref) + +!*** +!*** Just for testing of standalone version. In GSI WORKA will be given +!*** through a separate subroutine +!*** + +!call input_3d(WORKA( 1: lm,:,:),1,1, 1,mm,nm, lm,mm0,4,3) +!call input_3d(WORKA( lm+1:2*lm,:,:),1,1, lm+1,mm,nm,2*lm,mm0,6,5) +!call input_3d(WORKA(2*lm+1:3*lm,:,:),1,1,2*lm+1,mm,nm,3*lm,mm0,2,1) +!call input_3d(WORKA(3*lm+1:4*lm,:,:),1,1,3*lm+1,mm,nm,4*lm,mm0,3,2) +!call input_3d(WORKA(4*lm+1:5*lm,:,:),1,1,4*lm+1,mm,nm,5*lm,mm0,7,3) +!call input_3d(WORKA(5*lm+1:6*lm,:,:),1,1,5*lm+1,mm,nm,6*lm,mm0,4,5) + +!call input_3d(WORKA(6*lm+1:6*lm+1,:,:),1,1,6*lm+1,mm,nm,6*lm+1,mm0,2,1) +!call input_3d(WORKA(6*lm+2:6*lm+2,:,:),1,1,6*lm+2,mm,nm,6*lm+2,mm0,4,1) +!call input_3d(WORKA(6*lm+3:6*lm+3,:,:),1,1,6*lm+3,mm,nm,6*lm+3,mm0,5,1) +!call input_3d(WORKA(6*lm+4:6*lm+4,:,:),1,1,6*lm+4,mm,nm,6*lm+4,mm0,7,1) + +!----------------------------------------------------------------------- +endsubroutine mg_initialize + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine mg_finalize(this) +!**********************************************************************! +! ! +! Finalize multigrid Beta Function ! +! M. Rancic (2020) ! +!*********************************************************************** +implicit none +class (mg_intstate_type)::this + +real(r_kind), allocatable, dimension(:,:):: PA, VA +integer(i_kind):: n,m,L +integer:: nm,mm,lm +!----------------------------------------------------------------------- + +if(this%ldelta) then + ! + ! Horizontal cross-section + ! + nm=this%nm + mm=this%mm + lm=this%lm +endif + +if(this%nxm*this%nym>1) call this%barrierMPI + +call this%deallocate_mg_intstate + +!----------------------------------------------------------------------- +endsubroutine mg_finalize +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end submodule mg_entrymod diff --git a/src/mgbf/mg_filtering.f90 b/src/mgbf/mg_filtering.f90 new file mode 100644 index 0000000000..714a4b6bf4 --- /dev/null +++ b/src/mgbf/mg_filtering.f90 @@ -0,0 +1,1629 @@ +submodule(mg_intstate) mg_filtering +!$$$ submodule documentation block +! . . . . +! module: mg_filtering +! prgmmr: rancic org: NCEP/EMC date: 2020 +! +! abstract: Contains all multigrid filtering prodecures +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! filtering_procedure - +! filtering_rad3 - +! filtering_lin3 - +! filtering_rad2_bkg - +! filtering_lin2_bkg - +! filtering_fast_bkg - +! filtering_rad2_ens - +! filtering_lin2_ens - +! filtering_fast_ens - +! filtering_rad_highest - +! sup_vrbeta1 - +! sup_vrbeta1T - +! sup_vrbeta3 - +! sup_vrbeta3T - +! sup_vrbeta1_ens - +! sup_vrbeta1T_ens - +! sup_vrbeta1_bkg - +! sup_vrbeta1T_bkg - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mg_timers +use kinds, only: r_kind,i_kind +use jp_pbfil3, only: dibetat,dibeta +use mpi + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +contains +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filtering_procedure(this,mg_filt,mg_filt_flag) +!*********************************************************************** +! ! +! Driver for Multigrid filtering procedures with Helmholtz operator ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: mg_filt +integer(i_kind),intent(in):: mg_filt_flag +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +if(this%nxm*this%nym>1) then + select case(mg_filt) + case(1) + call this%filtering_rad3 + case(2) + call this%filtering_lin3 + case(3) + call this%filtering_rad2_bkg + case(4) + call this%filtering_lin2_bkg + case(5) + call this%filtering_fast_bkg + case(6) + call this%filtering_rad2_ens(mg_filt_flag) + case(7) + call this%filtering_lin2_ens(mg_filt_flag) + case(8) + call this%filtering_fast_ens(mg_filt_flag) + end select +else + call this%filtering_rad_highest +endif +!----------------------------------------------------------------------- +endsubroutine filtering_procedure + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filtering_rad3(this) +!*********************************************************************** +! ! +! Multigrid filtering procedure: ! +! ! +! - Multiple of 2D and 3D variables ! +! - 1 upsending and downsending ! +! - Applicaton of Helmholtz differential operator ! +! - 3d radial filter ! +! ! +!*********************************************************************** +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target::this +real(r_kind), allocatable, dimension(:,:,:):: VM2D +real(r_kind), allocatable, dimension(:,:,:):: HM2D +real(r_kind), allocatable, dimension(:,:,:,:):: VM3D +real(r_kind), allocatable, dimension(:,:,:,:):: HM3D +integer(i_kind) L,i,j +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- +allocate(VM3D(km3,1-hx:im+hx,1-hy:jm+hy,lm)) ; VM3D=0. +allocate(VM2D(km2,1-hx:im+hx,1-hy:jm+hy )) ; VM2D=0. +allocate(HM3D(km3,1-hx:im+hx,1-hy:jm+hy,lm)) ; HM3D=0. +allocate(HM2D(km2,1-hx:im+hx,1-hy:jm+hy )) ; HM2D=0. + +!*** +!*** Adjoint interpolate and upsend +!*** + call btim(upsend_tim) + call this%upsending_all(VALL,HALL,lquart) + call etim(upsend_tim) +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + call btim(hfiltT_tim) + call this%stack_to_composite(VALL,VM2D,VM3D) + call this%rbetaT(km2,hx,1,im,hy,1,jm,pasp2,ss2,VM2D) + call this%sup_vrbeta3T(km3,hx,hy,hz,im,jm,lm,pasp3,ss3,VM3D) + call this%composite_to_stack(VM2D,VM3D,VALL) + + if(l_hgen) then + call this%stack_to_composite(HALL,HM2D,HM3D) + call this%rbetaT(km2,hx,1,im,hy,1,jm,pasp2,ss2,HM2D) + call this%sup_vrbeta3T(km3,hx,hy,hz,im,jm,lm,pasp3,ss3,HM3D) + call this%composite_to_stack(HM2D,HM3D,HALL) + endif + call etim(hfiltT_tim) + + call btim(bocoT_tim) + call this%bocoT_2d(VALL,km,im,jm,hx,hy) + call this%bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) +!*** +!*** Apply (a-b\nabla^2) +!*** + call btim(weight_tim) + call this%weighting_all(VALL,HALL,lhelm) + call etim(weight_tim) +!*** +!*** Apply Beta filter at all generations +!*** + call btim(boco_tim) + call this%boco_2d(VALL,km,im,jm,hx,hy) + call this%boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(boco_tim) + + call btim(hfilt_tim) + call this%stack_to_composite(VALL,VM2D,VM3D) + call this%rbeta(km2,hx,1,im,hy,1,jm,pasp2,ss2,VM2D(:,:,:)) + call this%sup_vrbeta3(km3,hx,hy,hz,im,jm,lm,pasp3,ss3,VM3D) + call this%composite_to_stack(VM2D,VM3D,VALL) + if(l_hgen) then + call this%stack_to_composite(HALL,HM2D,HM3D) + call this%rbeta(km2,hx,1,im,hy,1,jm,pasp2,ss2,HM2D(:,:,:)) + call this%sup_vrbeta3(km3,hx,hy,hz,im,jm,lm,pasp3,ss3,HM3D) + call this%composite_to_stack(HM2D,HM3D,HALL) + endif + call etim(hfilt_tim) +!*** +!*** Downsend, interpolate and add +!*** Then zero high generations +!*** + call btim(dnsend_tim) + call this%downsending_all(HALL,VALL,lquart) + call etim(dnsend_tim) + +deallocate(VM3D) +deallocate(VM2D) +deallocate(HM3D) +deallocate(HM2D) +!----------------------------------------------------------------------- +endsubroutine filtering_rad3 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filtering_lin3(this) +!*********************************************************************** +! ! +! Multigrid filtering procedure: ! +! ! +! - Multiple of 2D line filter ! +! - 1 upsending and downsending ! +! - Applicaton of Helmholtz differential operator ! +! - 3d line filter ! +! ! +!*********************************************************************** +!TEST +use, intrinsic :: ieee_arithmetic +!TEST +use jp_pkind2, only: fpi +implicit none +class (mg_intstate_type),target::this +integer(i_kind) k,i,j,L +integer(i_kind) icol,iout,jout,lout +logical:: ff +real(r_kind), allocatable, dimension(:,:,:):: VM2D +real(r_kind), allocatable, dimension(:,:,:):: HM2D +real(r_kind), allocatable, dimension(:,:,:,:):: VM3D +real(r_kind), allocatable, dimension(:,:,:,:):: HM3D +real(r_kind), allocatable, dimension(:,:,:,:):: W +real(r_kind), allocatable, dimension(:,:,:,:):: H +integer(fpi), allocatable, dimension(:,:,:):: JCOL +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +allocate(VM3D(km3,1-hx:im+hx,1-hy:jm+hy,lm)) ; VM3D=0. +allocate(VM2D(km2,1-hx:im+hx,1-hy:jm+hy )) ; VM2D=0. +allocate(HM3D(km3,1-hx:im+hx,1-hy:jm+hy,lm)) ; HM3D=0. +allocate(HM2D(km2,1-hx:im+hx,1-hy:jm+hy )) ; HM2D=0. +allocate(W(km3,1-hx:im+hx,1-hy:jm+hy,1-hz:lm+hz)) ; W=0. +allocate(H(km3,1-hx:im+hx,1-hy:jm+hy,1-hz:lm+hz)) ; H=0. +allocate(JCOL(1:im,1:jm,1:Lm)) ; JCOL=0 + +!*** +!*** Adjoint interpolate and upsend +!*** + call btim(upsend_tim) + call this%upsending_all(VALL,HALL,lquart) + call etim(upsend_tim) +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + +! +! From single stack to composite variables +! + call btim(hfiltT_tim) + call this%stack_to_composite(VALL,VM2D,VM3D) + if(l_hgen) then + call this%stack_to_composite(HALL,HM2D,HM3D) + endif + call etim(hfiltT_tim) +! +! Apply adjoint filter to 2D variables first +! + do icol=3,1,-1 + call btim(hfiltT_tim) + call dibetat(km2,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VM2D, ff, iout,jout) + call etim(hfiltT_tim) + call btim(bocoT_tim) + call this%bocoT_2d(VM2D,km2,im,jm,hx,hy) + call etim(bocoT_tim) + enddo + + do icol=3,1,-1 + if(l_hgen) then + call btim(hfiltT_tim) + call dibetat(km2,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HM2D, ff, iout,jout) + call etim(hfiltT_tim) + endif + call btim(bocoT_tim) + call this%bocoT_2d(HM2D,km2,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) + enddo +! +! Create and apply adjoint filter to extended 3D variables +! + W(:,:,:,1:lm)=VM3D(:,:,:,1:lm) + do icol=7,1,-1 + call btim(hfiltT_tim) + do L=1,hz + W(:,:,:,1-L )=W(:,:,:,1+L ) + W(:,:,:,LM+L)=W(:,:,:,LM-L) + enddo + call dibetat(km3,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil & + ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, W, ff, iout,jout,lout) + call etim(hfiltT_tim) + call btim(bocoT_tim) + call this%bocoT_3d(W,km3,im,jm,Lm,hx,hy,hz,Fimax,Fjmax) + call etim(bocoT_tim) + enddo + + if(l_hgen) then + H(:,:,:,1:lm)=HM3D(:,:,:,1:lm) + endif + do icol=7,1,-1 + if(l_hgen) then + call btim(hfiltT_tim) + do L=1,hz + H(:,:,:,1-L )=H(:,:,:,1+L ) + H(:,:,:,LM+L)=H(:,:,:,LM-L) + end do + call dibetat(km3,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil & + ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, H, ff, iout,jout,lout) + call etim(hfiltT_tim) + endif + call btim(bocoT_tim) + call this%bocoT_3d(H,km3,im,jm,Lm,hx,hy,hz,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) + enddo +! +! Go back from extended 3D variables and combine them with 2D variables in one stacked variable +! + call btim(hfiltT_tim) + VM3D(:,:,:,1:lm)=W(:,:,:,1:lm) + call this%composite_to_stack(VM2D,VM3D,VALL) + if(l_hgen) then + HM3D(:,:,:,1:lm)=H(:,:,:,1:lm) + call this%composite_to_stack(HM2D,HM3D,HALL) + endif + call etim(hfiltT_tim) +!*** +!*** Apply (a-b\nabla^2) +!*** + call btim(weight_tim) + call this%weighting_all(VALL,HALL,lhelm) + call etim(weight_tim) +!*** +!*** Apply Beta filter at all generations +!*** + +! +! From single stacked to composite variables +! + call btim(hfilt_tim) + call this%stack_to_composite(VALL,VM2D,VM3D) + if(l_hgen) then + call this%stack_to_composite(HALL,HM2D,HM3D) + endif + call etim(hfilt_tim) +! +! Apply filter to 2D variables first +! + do icol=1,3 + call btim(boco_tim) + call this%boco_2d(VM2D,km2,im,jm,hx,hy) + call etim(boco_tim) + call btim(hfilt_tim) + call dibeta(km2,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VM2D, ff, iout,jout) + call etim(hfilt_tim) + enddo + + do icol=1,3 + call btim(boco_tim) + call this%boco_2d(HM2D,km2,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(boco_tim) + if(l_hgen) then + call btim(hfilt_tim) + call dibeta(km2,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HM2D, ff, iout,jout) + call etim(hfilt_tim) + endif + enddo +! +! Create and apply filter to extended 3D variables +! + W(:,:,:,1:lm)=VM3D(:,:,:,1:lm) + do L=1,hz + do j=1-hy,jm+hy + do i=1-hx,im+hx + W(:,i,j,1-L )=W(:,i,j,1+L ) + W(:,i,j,LM+L)=W(:,i,j,LM-L) + enddo + enddo + enddo + + do icol=1,7 + call btim(boco_tim) + call this%boco_3d(W,km3,im,jm,lm,hx,hy,hz,Fimax,Fjmax) + call etim(boco_tim) + call btim(hfilt_tim) + call dibeta(km3,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil & + ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, W, ff, iout,jout,lout) + call etim(hfilt_tim) + enddo + + if(l_hgen) then + H(:,:,:,1:lm)=HM3D(:,:,:,1:lm) + do L=1,hz + do j=1-hy,jm+hy + do i=1-hx,im+hx + H(:,i,j,1-L )=H(:,i,j,1+L ) + H(:,i,j,LM+L)=H(:,i,j,LM-L) + enddo + enddo + enddo + endif + do icol=1,7 + call btim(boco_tim) + call this%boco_3d(H,km3,im,jm,lm,hx,hy,hz,Fimax,Fjmax,2,gm) + call etim(boco_tim) + if(l_hgen) then + call btim(hfilt_tim) + call dibeta(km3,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil & + ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, H, ff, iout,jout,lout) + call etim(hfilt_tim) + endif + enddo +! +! Go back from extended 3D variables and combine them with 2D variables in one stacked variable +! + call btim(hfilt_tim) + VM3D(:,:,:,1:lm)=W(:,:,:,1:lm) + call this%composite_to_stack(VM2D,VM3D,VALL) + if(l_hgen) then + HM3D(:,:,:,1:lm)=H(:,:,:,1:lm) + call this%composite_to_stack(HM2D,HM3D,HALL) + endif + call etim(hfilt_tim) +!*** +!*** Downsend, interpolate and add, then zero high generations +!*** + call btim(dnsend_tim) + call this%downsending_all(HALL,VALL,lquart) + call etim(dnsend_tim) + +deallocate(VM3D) +deallocate(VM2D) +deallocate(HM3D) +deallocate(HM2D) +deallocate(W) +deallocate(H) +deallocate(JCOL) +!----------------------------------------------------------------------- +endsubroutine filtering_lin3 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filtering_rad2_bkg(this) +!*********************************************************************** +! ! +! Multigrid filtering procedure: ! +! ! +! - Apply vertical filter before and after horizontal ! +! - 2d radial filter ! +! ! +!*********************************************************************** +implicit none +class (mg_intstate_type),target::this +integer(i_kind) L,i,j +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +!*** +!*** Adjoint of beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfiltT_tim) + call this%sup_vrbeta1T_bkg(km,km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfiltT_tim) + endif +!*** +!*** Adjoint interpolate and upsend +!*** + call btim(upsend_tim) + call this%upsending_all(VALL,HALL,lquart) + call etim(upsend_tim) +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + call btim(hfiltT_tim) + call this%rbetaT(km,hx,1,im,hy,1,jm,pasp2,ss2,VALL(:,:,:)) + if(l_hgen) then + call this%rbetaT(km,hx,1,im,hy,1,jm,pasp2,ss2,HALL(:,:,:)) + endif + call etim(hfiltT_tim) + + call btim(bocoT_tim) + call this%bocoT_2d(VALL,km,im,jm,hx,hy) + call this%bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) +!*** +!*** Apply (a-b\nabla^2) +!*** + call btim(weight_tim) + call this%weighting_all(VALL,HALL,lhelm) + call etim(weight_tim) +!*** +!*** Apply Beta filter at all generations +!*** + call btim(boco_tim) + call this%boco_2d(VALL,km,im,jm,hx,hy) + call this%boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(boco_tim) + + call btim(hfilt_tim) + call this%rbeta(km,hx,1,im,hy,1,jm,pasp2,ss2,VALL(:,:,:)) + if(l_hgen) then + call this%rbeta(km,hx,1,im,hy,1,jm,pasp2,ss2,HALL(:,:,:)) + endif + call etim(hfilt_tim) +!*** +!*** Downsend, interpolate and add, then zero high generations +!*** + call btim(dnsend_tim) + call this%downsending_all(HALL,VALL,lquart) + call etim(dnsend_tim) +!*** +!*** Apply beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfilt_tim) + call this%sup_vrbeta1_bkg(km,km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfilt_tim) + endif +!----------------------------------------------------------------------- +endsubroutine filtering_rad2_bkg + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filtering_lin2_bkg(this) +!*********************************************************************** +! ! +! Multigrid filtering procedure: ! +! ! +! - Apply vertical filter before and after horizontal ! +! - 2d line filter ! +! ! +!*********************************************************************** +implicit none +class (mg_intstate_type),target::this +integer(i_kind) L,i,j +integer(i_kind) icol,iout,jout +logical:: ff +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- +!*** +!*** Adjoint of beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfiltT_tim) + call this%sup_vrbeta1T_bkg(km,km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfiltT_tim) + endif +!*** +!*** Adjoint interpolate and upsend +!*** + + call btim(upsend_tim) + call this%upsending_all(VALL,HALL,lquart) + call etim(upsend_tim) +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + do icol=3,1,-1 + call btim(hfiltT_tim) + call dibetat(km,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),VALL,ff,iout,jout) + call etim(hfiltT_tim) + call btim(bocoT_tim) + call this%bocoT_2d(VALL,km,im,jm,hx,hy) + call etim(bocoT_tim) + enddo + + do icol=3,1,-1 + if(l_hgen) then + call btim(hfiltT_tim) + call dibetat(km,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),HALL,ff,iout,jout) + call etim(hfiltT_tim) + endif + call btim(bocoT_tim) + call this%bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) + enddo +!*** +!*** Apply (a-b\nabla^2) +!*** + call btim(weight_tim) + call this%weighting_all(VALL,HALL,lhelm) + call etim(weight_tim) +!*** +!*** Apply Beta filter at all generations +!*** + do icol=1,3 + call btim(boco_tim) + call this%boco_2d(VALL,km,im,jm,hx,hy) + call etim(boco_tim) + call btim(hfilt_tim) + call dibeta(km,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),VALL,ff,iout,jout) + call etim(hfilt_tim) + enddo + + do icol=1,3 + call btim(boco_tim) + call this%boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(boco_tim) + if(l_hgen) then + call btim(hfilt_tim) + call dibeta(km,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),HALL,ff,iout,jout) + call etim(hfilt_tim) + endif + enddo +!*** +!*** Downsend, interpolate and add, then zero high generations +!*** + call btim(dnsend_tim) + call this%downsending_all(HALL,VALL,lquart) + call etim(dnsend_tim) +!*** +!*** Apply beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfilt_tim) + call this%sup_vrbeta1_bkg(km,km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfilt_tim) + endif +!----------------------------------------------------------------------- +endsubroutine filtering_lin2_bkg + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filtering_fast_bkg(this) +!*********************************************************************** +! ! +! Fast multigrid filtering procedure: ! +! ! +! - Apply adjoint of vertical filter before and directec vertical ! +! filter after horizontal ! +! - 1d+1d horizontal filter ! +! ! +!*********************************************************************** +implicit none +class (mg_intstate_type),target::this +integer(i_kind) L,i,j +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +!*** +!*** Adjoint of beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfiltT_tim) + call this%sup_vrbeta1T_bkg(km,km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfiltT_tim) + endif +!*** +!*** Adjoint interpolate and upsend +!*** + call btim(upsend_tim) + call this%upsending_all(VALL,HALL,lquart) + call etim(upsend_tim) +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + call btim(hfiltT_tim) + do i=im,1,-1 + call this%rbetaT(km,hy,1,jm,paspy,ssy,VALL(:,i,:)) + enddo + call etim(hfiltT_tim) + call btim(bocoT_tim) + call this%bocoTy(VALL,km,im,jm,hx,hy) + call etim(bocoT_tim) + call btim(hfiltT_tim) + do j=jm,1,-1 + call this%rbetaT(km,hx,1,im,paspx,ssx,VALL(:,:,j)) + enddo + call etim(hfiltT_tim) + call btim(bocoT_tim) + call this%bocoTx(VALL,km,im,jm,hx,hy) + call etim(bocoT_tim) + if(l_hgen) then + call btim(hfiltT_tim) + do i=im,1,-1 + call this%rbetaT(km,hy,1,jm,paspy,ssy,HALL(:,i,:)) + enddo + call etim(hfiltT_tim) + endif + call btim(bocoT_tim) + call this%bocoTy(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) + if(l_hgen) then + call btim(hfiltT_tim) + do j=jm,1,-1 + call this%rbetaT(km,hx,1,im,paspx,ssx,HALL(:,:,j)) + enddo + call etim(hfiltT_tim) + endif + call btim(bocoT_tim) + call this%bocoTx(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) +!*** +!*** Apply (a-b\nabla^2) +!*** + call btim(weight_tim) + call this%weighting_all(VALL,HALL,lhelm) + call etim(weight_tim) +!*** +!*** Apply Beta filter at all generations +!*** + call btim(boco_tim) + call this%bocox(VALL,km,im,jm,hx,hy) + call etim(boco_tim) + call btim(hfilt_tim) + do j=1,jm + call this%rbeta(km,hx,1,im,paspx,ssx,VALL(:,:,j)) + enddo + call etim(hfilt_tim) + call btim(boco_tim) + call this%bocoy(VALL,km,im,jm,hx,hy) + call etim(boco_tim) + call btim(hfilt_tim) + do i=1,im + call this%rbeta(km,hy,1,jm,paspy,ssy,VALL(:,i,:)) + enddo + call etim(hfilt_tim) + call btim(boco_tim) + call this%bocox(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(boco_tim) + if(l_hgen) then + call btim(hfilt_tim) + do j=1,jm + call this%rbeta(km,hx,1,im,paspx,ssx,HALL(:,:,j)) + enddo + call etim(hfilt_tim) + endif + call btim(boco_tim) + call this%bocoy(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(boco_tim) + if(l_hgen) then + call btim(hfilt_tim) + do i=1,im + call this%rbeta(km,hy,1,jm,paspy,ssy,HALL(:,i,:)) + enddo + call etim(hfilt_tim) + endif +!*** +!*** Downsend, interpolate and add, then zero high generations +!*** + call btim(dnsend_tim) + call this%downsending_all(HALL,VALL,lquart) + call etim(dnsend_tim) +!*** +!*** Apply beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfilt_tim) + call this%sup_vrbeta1_bkg(km,km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfilt_tim) + endif +!----------------------------------------------------------------------- +endsubroutine filtering_fast_bkg + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filtering_rad2_ens(this,mg_filt_flag) +!*********************************************************************** +! ! +! Multigrid filtering procedure for ensemble: ! +! ! +! - Apply vertical filter before and after horizontal ! +! - 2d radial filter ! +! - Version for localization of ensemble ! +! ! +!*********************************************************************** +implicit none +class (mg_intstate_type),target::this +integer(i_kind),intent(in):: mg_filt_flag +integer(i_kind) L,i,j +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +if(mg_filt_flag==1) then + call btim(upsend_tim) + call this%upsending_ens_nearest(VALL,HALL,km_all) + call etim(upsend_tim) +else +!*** +!*** Adjoint of beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfiltT_tim) + call this%sup_vrbeta1T_ens(km3_all,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfiltT_tim) + endif +!*** +!*** Adjoint interpolate and upsend +!*** + call btim(upsend_tim) + if(lquart) then + call this%upsending2_ens(VALL,HALL,km_all) + else + call this%upsending_ens(VALL,HALL,km_all) + endif + call etim(upsend_tim) +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + call btim(hfiltT_tim) + if(l_filt_g1) then + call this%rbetaT(km_all,hx,1,im,hy,1,jm,pasp2,ss2,VALL(:,:,:)) + endif + if(l_hgen) then + call this%rbetaT(km_all,hx,1,im,hy,1,jm,pasp2,ss2,HALL(:,:,:)) + endif + call etim(hfiltT_tim) + + call btim(bocoT_tim) + if(l_filt_g1) then + call this%bocoT_2d(VALL,km_all,im,jm,hx,hy) + endif + call this%bocoT_2d(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) +endif +!*** +!*** Apply (a-b\nabla^2) +!*** + call btim(weight_tim) + call this%weighting_ens(VALL,HALL,km_all) + call etim(weight_tim) + +if(mg_filt_flag==-1) then + call btim(dnsend_tim) + call this%downsending_ens_nearest(HALL,VALL,km_all) + call etim(dnsend_tim) +else +!*** +!*** Apply Beta filter at all generations +!*** + call btim(boco_tim) + if(l_filt_g1) then + call this%boco_2d(VALL,km_all,im,jm,hx,hy) + endif + call this%boco_2d(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(boco_tim) + + call btim(hfilt_tim) + if(l_filt_g1) then + call this%rbeta(km_all,hx,1,im,hy,1,jm,pasp2,ss2,VALL(:,:,:)) + endif + if(l_hgen) then + call this%rbeta(km_all,hx,1,im,hy,1,jm,pasp2,ss2,HALL(:,:,:)) + endif + call etim(hfilt_tim) +!*** +!*** Downsend, interpolate and add, then zero high generations +!*** + call btim(dnsend_tim) + if(lquart) then + call this%downsending2_ens(HALL,VALL,km_all) + else + call this%downsending_ens(HALL,VALL,km_all) + endif + call etim(dnsend_tim) +!*** +!*** Apply beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfilt_tim) + call this%sup_vrbeta1_ens(km3_all,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfilt_tim) + endif +endif +!----------------------------------------------------------------------- +endsubroutine filtering_rad2_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filtering_lin2_ens(this,mg_filt_flag) +!*********************************************************************** +! ! +! Multigrid filtering procedure for ensemble: ! +! ! +! - Vertical filter before and after horizontal ! +! - Line filters in horizontal ! +! - Version for localization of ensemble ! +! ! +!*********************************************************************** +implicit none +class (mg_intstate_type),target::this +integer(i_kind),intent(in):: mg_filt_flag +integer(i_kind) L,i,j +integer(i_kind) icol,iout,jout +logical:: ff +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- +if(mg_filt_flag==1) then + call btim(upsend_tim) + call this%upsending_ens_nearest(VALL,HALL,km_all) + call etim(upsend_tim) +else +!*** +!*** Adjoint of beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfiltT_tim) + call this%sup_vrbeta1T_ens(km3_all,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfiltT_tim) + endif +!*** +!*** Adjoint interpolate and upsend +!*** + call btim(upsend_tim) + if(lquart) then + call this%upsending2_ens(VALL,HALL,km_all) + else + call this%upsending_ens(VALL,HALL,km_all) + endif + call etim(upsend_tim) +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + if(l_filt_g1) then + do icol=3,1,-1 + call btim(hfiltT_tim) + call dibetat(km_all,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),VALL,ff,iout,jout) + call etim(hfiltT_tim) + call btim(bocoT_tim) + call this%bocoT_2d(VALL,km_all,im,jm,hx,hy) + call etim(bocoT_tim) + enddo + endif + + do icol=3,1,-1 + if(l_hgen) then + call btim(hfiltT_tim) + call dibetat(km_all,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),HALL,ff,iout,jout) + call etim(hfiltT_tim) + endif + call btim(bocoT_tim) + call this%bocoT_2d(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) + enddo +endif +!*** +!*** Apply (a-b\nabla^2) +!*** + call btim(weight_tim) + call this%weighting_ens(VALL,HALL,km_all) + call etim(weight_tim) + +if(mg_filt_flag==-1) then + call btim(dnsend_tim) + call this%downsending_ens_nearest(HALL,VALL,km_all) + call etim(dnsend_tim) +else +!*** +!*** Apply Beta filter at all generations +!*** + if(l_filt_g1) then + do icol=1,3 + call btim(boco_tim) + call this%boco_2d(VALL,km_all,im,jm,hx,hy) + call etim(boco_tim) + call btim(hfilt_tim) + call dibeta(km_all,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),VALL,ff,iout,jout) + call etim(hfilt_tim) + enddo + endif + + do icol=1,3 + call btim(boco_tim) + call this%boco_2d(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(boco_tim) + if(l_hgen) then + call btim(hfilt_tim) + call dibeta(km_all,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),HALL,ff,iout,jout) + call etim(hfilt_tim) + endif + enddo +!*** +!*** Downsend, interpolate and add, then zero high generations +!*** + call btim(dnsend_tim) + if(lquart) then + call this%downsending2_ens(HALL,VALL,km_all) + else + call this%downsending_ens(HALL,VALL,km_all) + endif + call etim(dnsend_tim) +!*** +!*** Apply beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfilt_tim) + call this%sup_vrbeta1_ens(km3_all,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfilt_tim) + endif +endif +!----------------------------------------------------------------------- +endsubroutine filtering_lin2_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filtering_fast_ens(this,mg_filt_flag) +!*********************************************************************** +! ! +! Fast multigrid filtering procedure for ensemble: ! +! ! +! - Apply vertical filter before and after horizontal ! +! - 1d+1d horizontal filter + 1d vertical filter ! +! - Version for localizaiton of ensemble ! +! ! +!*********************************************************************** +implicit none +class (mg_intstate_type),target::this +integer(i_kind),intent(in):: mg_filt_flag +integer(i_kind) L,i,j +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +if(mg_filt_flag==1) then + call btim(upsend_tim) + call this%upsending_ens_nearest(VALL,HALL,km_all) + call etim(upsend_tim) +else +!*** +!*** Adjoint of beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfiltT_tim) + call this%sup_vrbeta1T_ens(km3_all,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfiltT_tim) + endif +!*** +!*** Adjoint interpolate and upsend +!*** + call btim(upsend_tim) + if(lquart) then + call this%upsending2_ens(VALL,HALL,km_all) + else + call this%upsending_ens(VALL,HALL,km_all) + endif + call etim(upsend_tim) +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + if(l_filt_g1) then + call btim(hfiltT_tim) + do i=im,1,-1 + call this%rbetaT(km_all,hy,1,jm,paspy,ssy,VALL(:,i,:)) + enddo + call etim(hfiltT_tim) + call btim(bocoT_tim) + call this%bocoTy(VALL,km_all,im,jm,hx,hy) + call etim(bocoT_tim) + call btim(hfiltT_tim) + do j=jm,1,-1 + call this%rbetaT(km_all,hx,1,im,paspx,ssx,VALL(:,:,j)) + enddo + call etim(hfiltT_tim) + call btim(bocoT_tim) + call this%bocoTx(VALL,km_all,im,jm,hx,hy) + call etim(bocoT_tim) + endif + if(l_hgen) then + call btim(hfiltT_tim) + do i=im,1,-1 + call this%rbetaT(km_all,hy,1,jm,paspy,ssy,HALL(:,i,:)) + enddo + call etim(hfiltT_tim) + endif + call btim(bocoT_tim) + call this%bocoTy(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) + if(l_hgen) then + call btim(hfiltT_tim) + do j=jm,1,-1 + call this%rbetaT(km_all,hx,1,im,paspx,ssx,HALL(:,:,j)) + enddo + call etim(hfiltT_tim) + endif + call btim(bocoT_tim) + call this%bocoTx(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) +endif +!*** +!*** Apply (a-b\nabla^2) +!*** + call btim(weight_tim) + call this%weighting_ens(VALL,HALL,km_all) + call etim(weight_tim) + +if(mg_filt_flag==-1) then + call btim(dnsend_tim) + call this%downsending_ens_nearest(HALL,VALL,km_all) + call etim(dnsend_tim) +else +!*** +!*** Apply Beta filter at all generations +!*** + if(l_filt_g1) then + call btim(boco_tim) + call this%bocox(VALL,km_all,im,jm,hx,hy) + call etim(boco_tim) + call btim(hfilt_tim) + do j=1,jm + call this%rbeta(km_all,hx,1,im,paspx,ssx,VALL(:,:,j)) + enddo + call etim(hfilt_tim) + call btim(boco_tim) + call this%bocoy(VALL,km_all,im,jm,hx,hy) + call etim(boco_tim) + call btim(hfilt_tim) + do i=1,im + call this%rbeta(km_all,hy,1,jm,paspy,ssy,VALL(:,i,:)) + enddo + call etim(hfilt_tim) + endif + call btim(boco_tim) + call this%bocox(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(boco_tim) + if(l_hgen) then + call btim(hfilt_tim) + do j=1,jm + call this%rbeta(km_all,hx,1,im,paspx,ssx,HALL(:,:,j)) + enddo + call etim(hfilt_tim) + endif + call btim(boco_tim) + call this%bocoy(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(boco_tim) + if(l_hgen) then + call btim(hfilt_tim) + do i=1,im + call this%rbeta(km_all,hy,1,jm,paspy,ssy,HALL(:,i,:)) + enddo + call etim(hfilt_tim) + endif +!*** +!*** Downsend, interpolate and add, then zero high generations +!*** + call btim(dnsend_tim) + if(lquart) then + call this%downsending2_ens(HALL,VALL,km_all) + else + call this%downsending_ens(HALL,VALL,km_all) + endif + call etim(dnsend_tim) +!*** +!*** Apply beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfilt_tim) + call this%sup_vrbeta1_ens(km3_all,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfilt_tim) + endif +endif +!----------------------------------------------------------------------- +endsubroutine filtering_fast_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filtering_rad_highest(this) +!*********************************************************************** +! ! +! Multigrid filtering procedure: ! +! ! +! - 2d radial filter only for the highest generation ! +! - Without horizontal parallelization ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target:: this +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- + +!*** +!*** Adjoint interpolate and upsend +!*** + call btim(upsend_tim) + call this%upsending_highest(VALL,HALL) + call etim(upsend_tim) +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + call btim(hfiltT_tim) + call this%rbetaT(km,hx,1,imH,hy,1,jmH,& + &pasp2(:,:,1:imH,1:jmH),ss2(1:imH,1:jmH),HALL(:,1-hx:imH+hx,1-hy:jmH+hy)) + call etim(hfiltT_tim) +!*** +!*** Apply (a-b\nabla^2) +!*** + call btim(weight_tim) + call this%weighting_highest(HALL(:,1-hx:imH+hx,1-hy:jmH+hy)) + call etim(weight_tim) +!*** +!*** Apply Beta filter at all generations +!*** + call btim(hfilt_tim) + call this%rbeta(km,hx,1,imH,hy,1,jmH,& + &pasp2(:,:,1:imH,1:jmH),ss2(1:imH,1:jmH),HALL(:,1-hx:imH+hx,1-hy:jmH+hy)) + call etim(hfilt_tim) +!*** +!*** Downsend, interpolate and add, then zero high generations +!*** + call btim(dnsend_tim) + call this%downsending_highest(HALL,VALL) + call etim(dnsend_tim) + +!----------------------------------------------------------------------- +endsubroutine filtering_rad_highest + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine sup_vrbeta1 & +!********************************************************************** +! * +! conversion of vrbeta1 * +! * +!********************************************************************** +(this,kmax,hx,hy,hz,im,jm,lm,pasp,ss,V) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V +real(r_kind),dimension(1,1,1:lm), intent(in):: pasp +real(r_kind),dimension(1:lm), intent(in):: ss +real(r_kind),dimension(1:kmax,1-hz:lm+hz):: W +integer(i_kind):: i,j,L +!---------------------------------------------------------------------- + + do j=1,jm + do i=1,im + do L=1,Lm + W(:,L)=V(:,i,j,L) + end do + do L=1,hz + W(:,1-L)=W(:,1+L) + W(:,LM+L)=W(:,LM-L) + end do + call this%rbeta(kmax,hz,1,lm, pasp,ss,W) + do l=1,Lm + V(:,i,j,L)=W(:,L) + end do + end do + end do + +!---------------------------------------------------------------------- +endsubroutine sup_vrbeta1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine sup_vrbeta1T & +!********************************************************************** +! * +! Adjoint of sup_vrbeta1 * +! * +!********************************************************************** +(this,kmax,hx,hy,hz,im,jm,lm,pasp,ss,V) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V +real(r_kind),dimension(1,1,1:lm), intent(in):: pasp +real(r_kind),dimension(1:lm), intent(in):: ss +real(r_kind),dimension(1:kmax,1-hz:lm+hz):: W +integer(i_kind):: i,j,L +!---------------------------------------------------------------------- + + do j=1,jm + do i=1,im + do L=1,Lm + W(:,L)=V(:,i,j,L) + end do + do L=1,hz + W(:,1-L )=W(:,1+L ) + W(:,LM+L)=W(:,LM-L) + end do + call this%rbetaT(kmax,hz,1,lm, pasp,ss,W) +! +! Apply adjoint at the edges of domain +! + do L=1,hz + W(:,1+L)=W(:,1+L)+W(:,1-L) + W(:,LM-L)=W(:,LM-L)+W(:,LM+L) + enddo + do l=1,Lm + V(:,i,j,L)=W(:,L) + end do + end do + end do + +!---------------------------------------------------------------------- +endsubroutine sup_vrbeta1T + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine sup_vrbeta3 & +!********************************************************************** +! * +! conversion of vrbeta3 * +! * +!********************************************************************** +(this,kmax,hx,hy,hz,im,jm,lm,pasp,ss,V) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V +real(r_kind),dimension(3,3,1:im,1:jm,1:lm), intent(in):: pasp +real(r_kind),dimension(1:im,1:jm,1:lm), intent(in):: ss +real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1-hz:lm+hz):: W +integer(i_kind):: i,j,L +!---------------------------------------------------------------------- + + do L=1,Lm + do j=1-hy,jm+hy + do i=1-hx,im+hx + W(:,i,j,L)=V(:,i,j,L) + end do + end do + end do + + do L=1,hz + do j=1-hy,jm+hy + do i=1-hx,im+hx + W(:,i,j,1-L )=W(:,i,j,1+L ) + W(:,i,j,LM+L)=W(:,i,j,LM-L) + end do + end do + end do + + + call this%rbeta(kmax,hx,1,im, hy,1,jm, hz,1,lm, pasp,ss,W) + + + do l=1,Lm + do j=1,jm + do i=1,im + V(:,i,j,L)=W(:,i,j,L) + end do + end do + end do + +!---------------------------------------------------------------------- +endsubroutine sup_vrbeta3 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine sup_vrbeta3T & +!********************************************************************** +! * +! Adjoint of sup_vrbeta3 * +! * +!********************************************************************** +(this,kmax,hx,hy,hz,im,jm,lm,pasp,ss,V) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V +real(r_kind),dimension(3,3,1:im,1:jm,1:lm), intent(in):: pasp +real(r_kind),dimension(1:im,1:jm,1:lm), intent(in):: ss +real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1-hz:lm+hz):: W +integer(i_kind):: i,j,l +!---------------------------------------------------------------------- + + do L=1,Lm + do j=1-hy,jm+hy + do i=1-hx,im+hx + W(:,i,j,L)=V(:,i,j,L) + end do + end do + end do + + do L=1,hz + do j=1-hy,jm+hy + do i=1-hx,im+hx + W(:,i,j,1-L )=W(:,i,j, 1+L) + W(:,i,j,LM+L)=W(:,i,j,LM-L) + end do + end do + end do + + + call this%rbetaT(kmax,hx,1,im, hy,1,jm, hz,1,lm, pasp,ss,W) + +! +! Apply adjoint at the edges of domain +! + do L=1,hz + do j=1-hy,jm+hy + do i=1-hx,im+hx + W(:,i,j,1+L )=W(:,i,j, 1+L)+W(:,i,j, 1-L) + W(:,i,j,LM-L)=W(:,i,j,LM-L)+W(:,i,j,LM+L) + end do + end do + end do + + do l=1,lm + do j=1,jm + do i=1,im + V(:,i,j,l)=W(:,i,j,l) + end do + end do + end do + +!---------------------------------------------------------------------- +endsubroutine sup_vrbeta3T + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine sup_vrbeta1_ens & +!********************************************************************** +! * +! conversion of vrbeta1 * +! * +!********************************************************************** +(this,km_en,hx,hy,hz,im,jm,lm,pasp,ss,VALL) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: km_en,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:km_en*lm,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL +real(r_kind),dimension(1,1,1:lm), intent(in):: pasp +real(r_kind),dimension(1:lm), intent(in):: ss +real(r_kind),dimension(1:km_en,1-hz:lm+hz):: W +integer(i_kind):: i,j,L,k,k_ind,kloc +!---------------------------------------------------------------------- + + do j=1,jm + do i=1,im + do k=1,km_en + k_ind =(k-1)*Lm + do L=1,Lm + kloc=k_ind+L + W(k,L)=VALL(kloc,i,j) + end do + enddo + do L=1,hz + W(:,1-L )=W(:,1+L ) + W(:,LM+L)=W(:,LM-L) + end do + + call this%rbeta(km_en,hz,1,lm, pasp,ss,W) + + do k=1,km_en + k_ind =(k-1)*Lm + do L=1,Lm + kloc=k_ind+L + VALL(kloc,i,j)= W(k,L) + end do + enddo + enddo + enddo + +!---------------------------------------------------------------------- +endsubroutine sup_vrbeta1_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine sup_vrbeta1T_ens & +!********************************************************************** +! * +! Adjoint of sup_vrbeta1_ens * +! * +!********************************************************************** +(this,km_en,hx,hy,hz,im,jm,lm,pasp,ss,VALL) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: km_en,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:km_en*lm,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL +real(r_kind),dimension(1,1,1:lm), intent(in):: pasp +real(r_kind),dimension(1:lm), intent(in):: ss +real(r_kind),dimension(1:km_en,1-hz:lm+hz):: W +integer(i_kind):: i,j,L,k,k_ind,kloc +!---------------------------------------------------------------------- + + do j=1,jm + do i=1,im + + do k=1,km_en + k_ind = (k-1)*Lm + do L=1,Lm + kloc=k_ind+L + W(k,L)=VALL(kloc,i,j) + end do + enddo + do L=1,hz + W(:,1-L )=W(:,1+L ) + W(:,LM+L)=W(:,LM-L) + end do + + call this%rbetaT(km_en,hz,1,lm, pasp,ss,W) +! +! Apply adjoint at the edges of domain +! + do L=1,hz + W(:,1+L )=W(:,1+L )+W(:,1-L) + W(:,LM-L)=W(:,LM-L)+W(:,LM+L) + enddo + + do k=1,km_en + k_ind = (k-1)*Lm + do l=1,Lm + kloc=k_ind+L + VALL(kloc,i,j)=W(k,L) + enddo + end do + + end do + end do + +!---------------------------------------------------------------------- +endsubroutine sup_vrbeta1T_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine sup_vrbeta1_bkg & +!********************************************************************** +! * +! conversion of vrbeta1 * +! * +!********************************************************************** +(this,km,km3,hx,hy,hz,im,jm,lm,pasp,ss,VALL) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: km,km3,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:km,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL +real(r_kind),dimension(1,1,1:lm), intent(in):: pasp +real(r_kind),dimension(1:lm), intent(in):: ss +real(r_kind),dimension(1:km3,1-hz:lm+hz):: W +integer(i_kind):: i,j,L,k,k_ind,kloc +!---------------------------------------------------------------------- + + do j=1,jm + do i=1,im + do k=1,km3 + k_ind =(k-1)*Lm + do L=1,Lm + kloc=k_ind+L + W(k,L)=VALL(kloc,i,j) + end do + enddo + do L=1,hz + W(:,1-L )=W(:,1+L ) + W(:,LM+L)=W(:,LM-L) + end do + + call this%rbeta(km3,hz,1,lm, pasp,ss,W) + + do k=1,km3 + k_ind =(k-1)*Lm + do L=1,Lm + kloc=k_ind+L + VALL(kloc,i,j)= W(k,L) + end do + enddo + enddo + enddo + +!---------------------------------------------------------------------- +endsubroutine sup_vrbeta1_bkg + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine sup_vrbeta1T_bkg & +!********************************************************************** +! * +! Adjoint of sup_vrbeta1_bkg * +! * +!********************************************************************** +(this,km,km3,hx,hy,hz,im,jm,lm,pasp,ss,VALL) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: km,km3,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:km,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL +real(r_kind),dimension(1,1,1:lm), intent(in):: pasp +real(r_kind),dimension(1:lm), intent(in):: ss +real(r_kind),dimension(1:km3,1-hz:lm+hz):: W +integer(i_kind):: i,j,L,k,k_ind,kloc +!---------------------------------------------------------------------- + + do j=1,jm + do i=1,im + + do k=1,km3 + k_ind = (k-1)*Lm + do L=1,Lm + kloc=k_ind+L + W(k,L)=VALL(kloc,i,j) + end do + enddo + do L=1,hz + W(:,1-L )=W(:,1+L ) + W(:,LM+L)=W(:,LM-L) + end do + + call this%rbetaT(km3,hz,1,lm, pasp,ss,W) +! +! Apply adjoint at the edges of domain +! + do L=1,hz + W(:,1+L )=W(:,1+L )+W(:,1-L) + W(:,LM-L)=W(:,LM-L)+W(:,LM+L) + enddo + + do k=1,km3 + k_ind = (k-1)*Lm + do l=1,Lm + kloc=k_ind+L + VALL(kloc,i,j)=W(k,L) + enddo + end do + + end do + end do + +!---------------------------------------------------------------------- +endsubroutine sup_vrbeta1T_bkg + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end submodule mg_filtering diff --git a/src/mgbf/mg_generations.f90 b/src/mgbf/mg_generations.f90 new file mode 100644 index 0000000000..2008a75289 --- /dev/null +++ b/src/mgbf/mg_generations.f90 @@ -0,0 +1,1756 @@ +submodule(mg_intstate) mg_generations +!$$$ submodule documentation block +! . . . . +! module: mg_generations +! prgmmr: rancic org: NCEP/EMC date: 2022 +! +! abstract: Contains procedures that include differrent generations +! (offset version) +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! upsending_all - +! downsending_all - +! weighting_all - +! upsending - +! downsending - +! upsending_highest - +! downsending_highest - +! upsending2 - +! downsending2 - +! upsending_ens - +! downsending_ens - +! upsending_ens_nearest - +! downsending_ens_nearest - +! upsending2_ens - +! downsending2_ens - +! upsending_loc_g3 - +! upsending_loc_g4 - +! downsending_loc_g3 - +! downsending_loc_g4 - +! weighting_helm - +! weighting - +! weighting_highest - +! weighting_ens - +! weighting_loc_g3 - +! weighting_loc_g4 - +! adjoint - +! direct1 - +! adjoint2 - +! direct2 - +! adjoint_nearest - +! direct_nearest - +! adjoint_highest - +! direct_highest - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +!*********************************************************************** +! ! +! ! +! M. Rancic (2022) ! +!*********************************************************************** +use mpi +use kinds, only: r_kind,i_kind +use mg_timers +!TEST +use, intrinsic:: ieee_arithmetic +!TEST + +interface weighting_loc + module procedure weighting_loc_g3 + module procedure weighting_loc_g4 +endinterface + +interface upsending_loc + module procedure upsending_loc_g3 + module procedure upsending_loc_g4 +endinterface + +interface downsending_loc + module procedure downsending_loc_g3 + module procedure downsending_loc_g4 +endinterface +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +contains + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsending_all & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend: ! +! ! +!*********************************************************************** +(this,V,H,lquart) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +logical, intent(in):: lquart +!----------------------------------------------------------------------- + + if(lquart) then + call this%upsending2(V,H) + else + call this%upsending(V,H) + endif + +!----------------------------------------------------------------------- +endsubroutine upsending_all + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsending_all & +!*********************************************************************** +! ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! +! ! +!*********************************************************************** +(this,H,V,lquart) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +logical, intent(in):: lquart +!----------------------------------------------------------------------- + + if(lquart) then + call this%downsending2(H,V) + else + call this%downsending(H,V) + endif + +!----------------------------------------------------------------------- +endsubroutine downsending_all + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine weighting_all & +!*********************************************************************** +! ! +! Apply 2D differential operator to compound variable ! +! ! +!*********************************************************************** +(this,V,H,lhelm) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +logical, intent(in):: lhelm +!----------------------------------------------------------------------- + + if(lhelm) then + call this%weighting_helm(V,H) + else + call this%weighting(V,H) + endif + +!----------------------------------------------------------------------- +endsubroutine weighting_all + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsending & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend: ! +! First from g1->g2 (V -> H) ! +! Then from g2->...->gn (H -> H) ! +! ! +!*********************************************************************** +(this,V,H) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: H_INT +integer(i_kind):: g,L +!----------------------------------------------------------------------- +! +! From generation 1 to generation 2 +! + + call this%adjoint(V(1:this%km,1:this%im,1:this%jm),V_INT,this%km,1) + + call this%bocoT_2d(V_INT,this%km,this%imL,this%jmL,2,2) + + call this%upsend_all(V_INT(1:this%km,1:this%imL,1:this%jmL),H,this%km) +! +! From generation 2 sequentially to higher generations +! + do g=2,this%gm-1 + + if(g==this%my_hgen) then + call this%adjoint(H(1:this%km,1:this%im,1:this%jm),H_INT,this%km,g) + endif + + call this%bocoT_2d(H_INT,this%km,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g,g) + + call this%upsend_all(H_INT(1:this%km,1:this%imL,1:this%jmL),H,this%km,g,g+1) + + end do + +!----------------------------------------------------------------------- +endsubroutine upsending + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsending & +!*********************************************************************** +! ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! +! ! +!*********************************************************************** +(this,H,V) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: H_INT +real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(this%km,1:this%im,1:this%jm):: H_PROX +real(r_kind),dimension(this%km,1:this%im,1:this%jm):: V_PROX +integer(i_kind):: g,l,k +integer(i_kind):: iL,jL,i,j +!----------------------------------------------------------------------- +! +! Upper generations +! + do g=this%gm,3,-1 + + call this%downsend_all(H(1:this%km,1:this%im,1:this%jm),H_INT(1:this%km,1:this%imL,1:this%jmL),this%km,g,g-1) + call this%boco_2d(H_INT,this%km,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g-1,g-1) + + if(this%my_hgen==g-1) then + call this%direct1(H_INT,H_PROX,this%km,g-1) + H(1:this%km,1:this%im,1:this%jm)=H (1:this%km,1:this%im,1:this%jm) & + +H_PROX(1:this%km,1:this%im,1:this%jm) + endif + + enddo + +! +! From geneartion 2 to generation 1 +! + + call this%downsend_all(H(1:this%km,1:this%im,1:this%jm),V_INT(1:this%km,1:this%imL,1:this%jmL),this%km) + H(:,:,:)=0. + + call this%boco_2d(V_INT,this%km,this%imL,this%jmL,2,2) + + call this%direct1(V_INT,V_PROX,this%km,1) + + V(1:this%km,1:this%im,1:this%jm)=V (1:this%km,1:this%im,1:this%jm) & + +V_PROX(1:this%km,1:this%im,1:this%jm) + +!----------------------------------------------------------------------- +endsubroutine downsending + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsending_highest & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend: ! +! First from g1->g2 (V -> H) ! +! Then from g2->...->gn (H -> H) ! +! ! +!*********************************************************************** +(this,V,H) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: H_INT +integer(i_kind):: g +!----------------------------------------------------------------------- +! +! From generation 1 to higher generations +! + H(:,:,:)=0. + H(1:this%km,1:this%im0(1),1:this%jm0(1))=V(1:this%km,1:this%im0(1),1:this%jm0(1)) + do g=1,this%gm-1 + call this%adjoint_highest(H(1:this%km,1:this%im0(g),1:this%jm0(g)),& + & H_INT(1:this%km,-1:this%im0(g+1)+2,-1:this%jm0(g+1)+2),this%km,g) + H(1:this%km,1:this%im0(g),1:this%jm0(g))=0. + H(1:this%km,1:this%im0(g+1),1:this%jm0(g+1))=H_INT(1:this%km,1:this%im0(g+1),1:this%jm0(g+1)) + H_INT(1:this%km,-1:this%im0(g+1)+2,-1:this%jm0(g+1)+2)=0. + end do + +!----------------------------------------------------------------------- +endsubroutine upsending_highest + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsending_highest & +!*********************************************************************** +! ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! +! ! +!*********************************************************************** +(this,H,V) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: H_INT +integer(i_kind):: g +!----------------------------------------------------------------------- +! +! Upper generations +! + do g=this%gm,2,-1 + H_INT(1:this%km,-1:this%im0(g)+2,-1:this%jm0(g)+2)=0. + H_INT(1:this%km,1:this%im0(g),1:this%jm0(g))=H(1:this%km,1:this%im0(g),1:this%jm0(g)) + H(1:this%km,1:this%im0(g-1),1:this%jm0(g-1))=0. + call this%direct_highest(H_INT(1:this%km,-1:this%im0(g)+2,-1:this%jm0(g)+2),& + & H(1:this%km,1:this%im0(g-1),1:this%jm0(g-1)),this%km,g-1) + enddo + V(:,:,:)=0. + V(1:this%km,1:this%im0(1),1:this%jm0(1))=H(1:this%km,1:this%im0(1),1:this%jm0(1)) + H(:,:,:)=0. + +!----------------------------------------------------------------------- +endsubroutine downsending_highest + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsending2 & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend: ! +! First from g1->g2 (V -> H) ! +! Then from g2->...->gn (H -> H) ! +! ! +!*********************************************************************** +(this,V,H) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +real(r_kind),dimension(this%km,0:this%imL+1,0:this%jmL+1):: V_INT +real(r_kind),dimension(this%km,0:this%imL+1,0:this%jmL+1):: H_INT +integer(i_kind):: g,L +!----------------------------------------------------------------------- +! +! From generation 1 to generation 2 +! + + call this%adjoint2(V(1:this%km,1:this%im,1:this%jm),V_INT,this%km,1) + + call this%bocoT_2d(V_INT,this%km,this%imL,this%jmL,1,1) + + call this%upsend_all(V_INT(1:this%km,1:this%imL,1:this%jmL),H,this%km) +! +! From generation 2 sequentially to higher generations +! + do g=2,this%gm-1 + + if(g==this%my_hgen) then + call this%adjoint2(H(1:this%km,1:this%im,1:this%jm),H_INT,this%km,g) + endif + + call this%bocoT_2d(H_INT,this%km,this%imL,this%jmL,1,1,this%FimaxL,this%FjmaxL,g,g) + + call this%upsend_all(H_INT(1:this%km,1:this%imL,1:this%jmL),H,this%km,g,g+1) + + end do + +!----------------------------------------------------------------------- +endsubroutine upsending2 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsending2 & +!*********************************************************************** +! ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! +! ! +!*********************************************************************** +(this,H,V) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(this%km,0:this%imL+1,0:this%jmL+1):: H_INT +real(r_kind),dimension(this%km,0:this%imL+1,0:this%jmL+1):: V_INT +real(r_kind),dimension(this%km,1:this%im,1:this%jm):: H_PROX +real(r_kind),dimension(this%km,1:this%im,1:this%jm):: V_PROX +integer(i_kind):: g,l,k +integer(i_kind):: iL,jL,i,j +!----------------------------------------------------------------------- +! +! Upper generations +! + do g=this%gm,3,-1 + + call this%downsend_all(H(1:this%km,1:this%im,1:this%jm),H_INT(1:this%km,1:this%imL,1:this%jmL),this%km,g,g-1) + call this%boco_2d(H_INT,this%km,this%imL,this%jmL,1,1,this%FimaxL,this%FjmaxL,g-1,g-1) + + if(this%my_hgen==g-1) then + call this%direct2(H_INT,H_PROX,this%km,g-1) + H(1:this%km,1:this%im,1:this%jm)=H (1:this%km,1:this%im,1:this%jm) & + +H_PROX(1:this%km,1:this%im,1:this%jm) + endif + + enddo + +! +! From generation 2 to generation 1 +! + + call this%downsend_all(H(1:this%km,1:this%im,1:this%jm),V_INT(1:this%km,1:this%imL,1:this%jmL),this%km) + H(:,:,:)=0. + + call this%boco_2d(V_INT,this%km,this%imL,this%jmL,1,1) + + call this%direct2(V_INT,V_PROX,this%km,1) + + V(1:this%km,1:this%im,1:this%jm)=V (1:this%km,1:this%im,1:this%jm) & + +V_PROX(1:this%km,1:this%im,1:this%jm) + +!----------------------------------------------------------------------- +endsubroutine downsending2 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsending_ens & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend: ! +! First from g1->g2 (V -> H) ! +! Then from g2->...->gn (H -> H) ! +! ! +!*********************************************************************** +(this,V,H,kmx) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind), intent(in):: kmx +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: H_INT +integer(i_kind):: g,L +!----------------------------------------------------------------------- +! +! From generation 1 to generation 2 +! + + call this%adjoint(V(1:kmx,1:this%im,1:this%jm),V_INT,kmx,1) + + call this%bocoT_2d(V_INT,kmx,this%imL,this%jmL,2,2) + + call this%upsend_all(V_INT(1:kmx,1:this%imL,1:this%jmL),H,kmx) +! +! From generation 2 sequentially to higher generations +! + do g=2,this%gm-1 + + if(g==this%my_hgen) then + call this%adjoint(H(1:kmx,1:this%im,1:this%jm),H_INT,kmx,g) + endif + + call this%bocoT_2d(H_INT,kmx,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g,g) + + call this%upsend_all(H_INT(1:kmx,1:this%imL,1:this%jmL),H,kmx,g,g+1) + + end do + +!----------------------------------------------------------------------- +endsubroutine upsending_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsending_ens & +!*********************************************************************** +! ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! +! ! +!*********************************************************************** +(this,H,V,kmx) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind), intent(in):: kmx +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: H_INT +real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(kmx,1:this%im,1:this%jm):: H_PROX +real(r_kind),dimension(kmx,1:this%im,1:this%jm):: V_PROX +integer(i_kind):: g,l,k +integer(i_kind):: iL,jL,i,j +!----------------------------------------------------------------------- +! +! Upper generations +! + do g=this%gm,3,-1 + + call this%downsend_all(H(1:kmx,1:this%im,1:this%jm),H_INT(1:kmx,1:this%imL,1:this%jmL),kmx,g,g-1) + + call this%boco_2d(H_INT,kmx,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g-1,g-1) + + if(this%my_hgen==g-1) then + call this%direct1(H_INT,H_PROX,kmx,g-1) + H(1:kmx,1:this%im,1:this%jm)=H (1:kmx,1:this%im,1:this%jm) & + +H_PROX(1:kmx,1:this%im,1:this%jm) + endif + + enddo + +! +! From geneartion 2 to generation 1 +! + + call this%downsend_all(H(1:kmx,1:this%im,1:this%jm),V_INT(1:kmx,1:this%imL,1:this%jmL),kmx) + H(:,:,:)=0. + + call this%boco_2d(V_INT,kmx,this%imL,this%jmL,2,2) + + call this%direct1(V_INT,V_PROX,kmx,1) + + V(1:kmx,1:this%im,1:this%jm)=V (1:kmx,1:this%im,1:this%jm) & + +V_PROX(1:kmx,1:this%im,1:this%jm) + +!----------------------------------------------------------------------- +endsubroutine downsending_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsending_ens_nearest & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend: ! +! First from g1->g2 (V -> H) ! +! Then from g2->...->gn (H -> H) ! +! ! +!*********************************************************************** +(this,V,H,kmx) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind), intent(in):: kmx +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: H_INT +integer(i_kind):: g,L +!----------------------------------------------------------------------- +! +! From generation 1 to generation 2 +! + + call this%adjoint_nearest(V(1:kmx,1:this%im,1:this%jm),V_INT,kmx,1) + + call this%bocoT_2d(V_INT,kmx,this%imL,this%jmL,2,2) + + call this%upsend_all(V_INT(1:kmx,1:this%imL,1:this%jmL),H,kmx) +! +! From generation 2 sequentially to higher generations +! + do g=2,this%gm-1 + + if(g==this%my_hgen) then + call this%adjoint_nearest(H(1:kmx,1:this%im,1:this%jm),H_INT,kmx,g) + endif + + call this%bocoT_2d(H_INT,kmx,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g,g) + + call this%upsend_all(H_INT(1:kmx,1:this%imL,1:this%jmL),H,kmx,g,g+1) + + end do + +!----------------------------------------------------------------------- +endsubroutine upsending_ens_nearest + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsending_ens_nearest & +!*********************************************************************** +! ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! +! ! +!*********************************************************************** +(this,H,V,kmx) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind), intent(in):: kmx +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: H_INT +real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(kmx,1:this%im,1:this%jm):: H_PROX +real(r_kind),dimension(kmx,1:this%im,1:this%jm):: V_PROX +integer(i_kind):: g,l,k +integer(i_kind):: iL,jL,i,j +!----------------------------------------------------------------------- +! +! Upper generations +! + do g=this%gm,3,-1 + + call this%downsend_all(H(1:kmx,1:this%im,1:this%jm),H_INT(1:kmx,1:this%imL,1:this%jmL),kmx,g,g-1) + + call this%boco_2d(H_INT,kmx,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g-1,g-1) + + if(this%my_hgen==g-1) then + call this%direct_nearest(H_INT,H_PROX,kmx,g-1) + H(1:kmx,1:this%im,1:this%jm)=H (1:kmx,1:this%im,1:this%jm) & + +H_PROX(1:kmx,1:this%im,1:this%jm) + endif + + enddo + +! +! From geneartion 2 to generation 1 +! + + call this%downsend_all(H(1:kmx,1:this%im,1:this%jm),V_INT(1:kmx,1:this%imL,1:this%jmL),kmx) + H(:,:,:)=0. + + call this%boco_2d(V_INT,kmx,this%imL,this%jmL,2,2) + + call this%direct_nearest(V_INT,V_PROX,kmx,1) + + V(1:kmx,1:this%im,1:this%jm)=V (1:kmx,1:this%im,1:this%jm) & + +V_PROX(1:kmx,1:this%im,1:this%jm) + +!----------------------------------------------------------------------- +endsubroutine downsending_ens_nearest + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsending2_ens & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend: ! +! First from g1->g2 (V -> H) ! +! Then from g2->...->gn (H -> H) ! +! ! +!*********************************************************************** +(this,V,H,kmx) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind), intent(in):: kmx +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +real(r_kind),dimension(kmx,0:this%imL+1,0:this%jmL+1):: V_INT +real(r_kind),dimension(kmx,0:this%imL+1,0:this%jmL+1):: H_INT +integer(i_kind):: g,L +!----------------------------------------------------------------------- +! +! From generation 1 to generation 2 +! + + call this%adjoint2(V(1:kmx,1:this%im,1:this%jm),V_INT,kmx,1) + + call this%bocoT_2d(V_INT,kmx,this%imL,this%jmL,1,1) + + call this%upsend_all(V_INT(1:kmx,1:this%imL,1:this%jmL),H,kmx) +! +! From generation 2 sequentially to higher generations +! + do g=2,this%gm-1 + + if(g==this%my_hgen) then + call this%adjoint2(H(1:kmx,1:this%im,1:this%jm),H_INT,kmx,g) + endif + + call this%bocoT_2d(H_INT,kmx,this%imL,this%jmL,1,1,this%FimaxL,this%FjmaxL,g,g) + + call this%upsend_all(H_INT(1:kmx,1:this%imL,1:this%jmL),H,kmx,g,g+1) + + end do + +!----------------------------------------------------------------------- +endsubroutine upsending2_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsending2_ens & +!*********************************************************************** +! ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! +! ! +!*********************************************************************** +(this,H,V,kmx) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind), intent(in):: kmx +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(kmx,0:this%imL+1,0:this%jmL+1):: H_INT +real(r_kind),dimension(kmx,0:this%imL+1,0:this%jmL+1):: V_INT +real(r_kind),dimension(kmx,1:this%im,1:this%jm):: H_PROX +real(r_kind),dimension(kmx,1:this%im,1:this%jm):: V_PROX +integer(i_kind):: g,l,k +integer(i_kind):: iL,jL,i,j +!----------------------------------------------------------------------- +! +! Upper generations +! + do g=this%gm,3,-1 + + call this%downsend_all(H(1:kmx,1:this%im,1:this%jm),H_INT(1:kmx,1:this%imL,1:this%jmL),kmx,g,g-1) + + call this%boco_2d(H_INT,kmx,this%imL,this%jmL,1,1,this%FimaxL,this%FjmaxL,g-1,g-1) + + if(this%my_hgen==g-1) then + call this%direct2(H_INT,H_PROX,kmx,g-1) + H(1:kmx,1:this%im,1:this%jm)=H (1:kmx,1:this%im,1:this%jm) & + +H_PROX(1:kmx,1:this%im,1:this%jm) + endif + + enddo + +! +! From geneartion 2 to generation 1 +! + + call this%downsend_all(H(1:kmx,1:this%im,1:this%jm),V_INT(1:kmx,1:this%imL,1:this%jmL),kmx) + H(:,:,:)=0. + + call this%boco_2d(V_INT,kmx,this%imL,this%jmL,1,1) + + call this%direct2(V_INT,V_PROX,kmx,1) + + V(1:kmx,1:this%im,1:this%jm)=V (1:kmx,1:this%im,1:this%jm) & + +V_PROX(1:kmx,1:this%im,1:this%jm) + +!----------------------------------------------------------------------- +endsubroutine downsending2_ens + + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsending_loc_g3 & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend for localization: ! +! ! +! First from g1->g2: V(km ) -> H(km_4) ! +! Then from g2->g3: H(km_4 ) -> Z(km_16) ! +! ! +!*********************************************************************** +(this,V,H,Z,km_in,km_4_in,km_16_in) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: km_in,km_4_in,km_16_in +real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V +real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Z +real(r_kind),dimension(km_in ,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(km_4_in ,-1:this%imL+2,-1:this%jmL+2):: H_INT +real(r_kind),dimension(km_16_in,-1:this%imL+2,-1:this%jmL+2):: Z_INT +integer(i_kind):: g,L,ind,k_low,k_hgh +!----------------------------------------------------------------------- +! +! From generation 1 to generation 2 +! + + call this%adjoint(V(1:km_in,1:this%im,1:this%jm),V_INT,km_in,1) + call this%bocoT_2d(V_INT,km_in,this%imL,this%jmL,2,2) !????? + + do ind=1,1 + k_low=km_4_in*(ind-1)+1 + k_hgh=km_4_in*ind + call this%upsend_loc_g12(V_INT(k_low:k_hgh,1:this%imL,1:this%jmL),H,km_4_in,ind) + enddo + +! +! From generation 2 to generation 3 +! + + call this%adjoint(H(1:km_4_in,1:this%im,1:this%jm),H_INT,km_4_in,2) + call this%bocoT_2d_loc(H_INT,km_4_in,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,2) + + do ind=1,4 + k_low=km_16_in*(ind-1)+1 + k_hgh=km_16_in*ind + call this%upsend_loc_g23(H_INT(k_low:k_hgh,1:this%imL,1:this%jmL),Z,km_16_in,ind) + enddo + +!----------------------------------------------------------------------- +endsubroutine upsending_loc_g3 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsending_loc_g4 & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend for localization: ! +! ! +! First from g1->g2: V(km ) -> H(km_4) ! +! Then from g2->g3: H(km_4 ) -> Z(km_16) ! +! Then from g3->g4: Z(km_16) -> W(km_64) ! +! ! +!*********************************************************************** +(this,V,H,Z,W,km_in,km_4_in,km_16_in,km_64_in) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: km_in,km_4_in,km_16_in,km_64_in +real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V +real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Z +real(r_kind),dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: W +real(r_kind),dimension(km_in ,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(km_4_in ,-1:this%imL+2,-1:this%jmL+2):: H_INT +real(r_kind),dimension(km_16_in,-1:this%imL+2,-1:this%jmL+2):: Z_INT +real(r_kind),dimension(km_64_in,-1:this%imL+2,-1:this%jmL+2):: W_INT +integer(i_kind):: g,L,ind,k_low,k_hgh +!----------------------------------------------------------------------- +! +! From generation 1 to generation 2 +! + + call this%adjoint(V(1:km_in,1:this%im,1:this%jm),V_INT,km_in,1) + call this%bocoT_2d(V_INT,km_in,this%imL,this%jmL,2,2) !????? + + do ind=1,4 + k_low=km_4_in*(ind-1)+1 + k_hgh=km_4_in*ind + call this%upsend_loc_g12(V_INT(k_low:k_hgh,1:this%imL,1:this%jmL),H,km_4_in,ind) + enddo + +! +! From generation 2 to generation 3 +! + + call this%adjoint(H(1:km_4_in,1:this%im,1:this%jm),H_INT,km_4_in,2) + call this%bocoT_2d_loc(H_INT,km_4_in,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,2) + + do ind=1,4 + k_low=km_16_in*(ind-1)+1 + k_hgh=km_16_in*ind + call this%upsend_loc_g23(H_INT(k_low:k_hgh,1:this%imL,1:this%jmL),Z,km_16_in,ind) + enddo + +! +! From generation 3 to generation 4 +! + + call this%adjoint(Z(1:km_16_in,1:this%im,1:this%jm),Z_INT,km_16_in,3) + call this%bocoT_2d_loc(H_INT,km_4_in,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,3) + + do ind=1,4 + k_low=km_64_in*(ind-1)+1 + k_hgh=km_64_in*ind + call this%upsend_loc_g34(Z_INT(k_low:k_hgh,1:this%imL,1:this%jmL),W,km_64_in,ind) + enddo + +!----------------------------------------------------------------------- +endsubroutine upsending_loc_g4 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsending_loc_g3 & +!*********************************************************************** +! ! +! Downsend, interpolate and add for localization: ! +! ! +! Then from g3->g2: Z(km_16) -> H(km_4 ) ! +! Then from g2->g1: H(km_4 ) -> V(km ) ! +! ! +!*********************************************************************** +(this,Z,H,V,km_in,km_4_in,km_16_in) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: km_in,km_4_in,km_16_in +real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: Z +real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(km_16_in,-1:this%imL+2,-1:this%jmL+2):: Z_INT +real(r_kind),dimension(km_4_in ,-1:this%imL+2,-1:this%jmL+2):: H_INT +real(r_kind),dimension(km_in ,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(km_16_in,1:this%im,1:this%jm):: Z_PROX +real(r_kind),dimension(km_4_in ,1:this%im,1:this%jm):: H_PROX +real(r_kind),dimension(km_in ,1:this%im,1:this%jm):: V_PROX +integer(i_kind):: g,l,k +integer(i_kind):: iL,jL,i,j,ind,k_low,k_hgh +!----------------------------------------------------------------------- +! +! From generation 3 to generation 2 +! + do ind=1,4 + k_low=km_16_in*(ind-1)+1 + k_hgh=km_16_in*ind + call this%downsend_loc_g32(Z(1:km_16_in,1:this%im,1:this%jm),H_INT(k_low:k_hgh,1:this%imL,1:this%jmL),km_16_in,ind) + enddo + Z(:,:,:)=0. + + call this%boco_2d_loc(H_INT,km_4_in ,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,2) + call this%direct1(H_INT,H_PROX,km_4_in,2) + + H(1:km_4_in ,1:this%im,1:this%jm)=H (1:km_4_in ,1:this%im,1:this%jm) & + +H_PROX(1:km_4_in ,1:this%im,1:this%jm) + +! +! From geneartion 2 to generation 1 +! + do ind=1,4 + k_low=km_4_in*(ind-1)+1 + k_hgh=km_4_in*ind + call this%downsend_loc_g21(H(1:km_4_in,1:this%im,1:this%jm),V_INT(k_low:k_hgh,1:this%imL,1:this%jmL),km_4_in,ind) + enddo + H(:,:,:)=0. + + call this%boco_2d(V_INT,km_in,this%imL,this%jmL,2,2) + call this%direct1(V_INT,V_PROX,km_in,1) + + V(1:km_in,1:this%im,1:this%jm)=V (1:km_in,1:this%im,1:this%jm) & + +V_PROX(1:km_in,1:this%im,1:this%jm) + +!----------------------------------------------------------------------- +endsubroutine downsending_loc_g3 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsending_loc_g4 & +!*********************************************************************** +! ! +! Downsend, interpolate and add for localization: ! +! ! +! First from g4->g3: W(km_16) -> Z(km_64) ! +! Then from g3->g2: Z(km_16) -> H(km_4 ) ! +! Then from g2->g1: H(km_4 ) -> V(km ) ! +! ! +!*********************************************************************** +(this,W,Z,H,V,km_in,km_4_in,km_16_in,km_64_in) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: km_in,km_4_in,km_16_in,km_64_in +real(r_kind),dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: W +real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: Z +real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(km_64_in,-1:this%imL+2,-1:this%jmL+2):: W_INT +real(r_kind),dimension(km_16_in,-1:this%imL+2,-1:this%jmL+2):: Z_INT +real(r_kind),dimension(km_4_in ,-1:this%imL+2,-1:this%jmL+2):: H_INT +real(r_kind),dimension(km_in ,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(km_16_in,1:this%im,1:this%jm):: Z_PROX +real(r_kind),dimension(km_4_in ,1:this%im,1:this%jm):: H_PROX +real(r_kind),dimension(km_in ,1:this%im,1:this%jm):: V_PROX +integer(i_kind):: g,l,k +integer(i_kind):: iL,jL,i,j,ind,k_low,k_hgh +!----------------------------------------------------------------------- +! +! From generation 4 to generation 3 +! + do ind=1,4 + k_low=km_64_in*(ind-1)+1 + k_hgh=km_64_in*ind + call this%downsend_loc_g43(W(1:km_64_in,1:this%im,1:this%jm),Z_INT(k_low:k_hgh,1:this%imL,1:this%jmL),km_64_in,ind) + enddo + W(:,:,:)=0. + + call this%boco_2d_loc(Z_INT,km_16_in,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,3) + call this%direct1(Z_INT,Z_PROX,km_16_in,3) + + Z(1:km_16_in,1:this%im,1:this%jm)=Z (1:km_16_in,1:this%im,1:this%jm) & + +Z_PROX(1:km_16_in,1:this%im,1:this%jm) + +! +! From generation 3 to generation 2 +! + do ind=1,4 + k_low=km_16_in*(ind-1)+1 + k_hgh=km_16_in*ind + call this%downsend_loc_g32(Z(1:km_16_in,1:this%im,1:this%jm),H_INT(k_low:k_hgh,1:this%imL,1:this%jmL),km_16_in,ind) + enddo + Z(:,:,:)=0. + + call this%boco_2d_loc(H_INT,km_4_in ,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,2) + call this%direct1(H_INT,H_PROX,km_4_in,2) + + H(1:km_4_in ,1:this%im,1:this%jm)=H (1:km_4_in ,1:this%im,1:this%jm) & + +H_PROX(1:km_4_in ,1:this%im,1:this%jm) + +! +! From geneartion 2 to generation 1 +! + do ind=1,4 + k_low=km_4_in*(ind-1)+1 + k_hgh=km_4_in*ind + call this%downsend_loc_g21(H(1:km_4_in,1:this%im,1:this%jm),V_INT(k_low:k_hgh,1:this%imL,1:this%jmL),km_4_in,ind) + enddo + H(:,:,:)=0. + + + call this%boco_2d(V_INT,km_in,this%imL,this%jmL,2,2) + call this%direct1(V_INT,V_PROX,km_in,1) + + V(1:km_in,1:this%im,1:this%jm)=V (1:km_in,1:this%im,1:this%jm) & + +V_PROX(1:km_in,1:this%im,1:this%jm) + +!----------------------------------------------------------------------- +endsubroutine downsending_loc_g4 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine weighting_helm & +!*********************************************************************** +! ! +! Apply 2D differential operator to compound variable ! +! ! +!*********************************************************************** +(this,V,H) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(this%km,0:this%im, 1:this%jm):: DIFX +real(r_kind),dimension(this%km,1:this%im ,0:this%jm):: DIFY +real(r_kind),dimension(this%km,0:this%im, 1:this%jm):: DIFXH +real(r_kind),dimension(this%km,1:this%im ,0:this%jm):: DIFYH +integer(i_kind):: i,j,l,k,imx,jmx +!----------------------------------------------------------------------- + + do j=1,this%jm + do i=0,this%im + DIFX(:,i,j)=V(:,i+1,j)-V(:,i,j) + enddo + enddo + do j=0,this%jm + do i=1,this%im + DIFY(:,i,j)=V(:,i,j+1)-V(:,i,j) + enddo + enddo + + do j=1,this%jm + do i=1,this%im + V(:,i,j)=this%a_diff_f(:,i,j)*V(:,i,j) & + -this%b_diff_f(:,i,j)*(DIFX(:,i,j)-DIFX(:,i-1,j) & + +DIFY(:,i,j)-DIFY(:,i,j-1)) + enddo + enddo + +if(this%l_hgen) then + +! imx = Fimax(my_hgen) +! jmx = Fjmax(my_hgen) + + imx = this%im + jmx = this%jm + + do j=1,jmx + do i=0,imx + DIFXH(:,i,j)=H(:,i+1,j)-H(:,i,j) + enddo + enddo + do j=0,jmx + do i=1,imx + DIFYH(:,i,j)=H(:,i,j+1)-H(:,i,j) + enddo + enddo + + do j=1,jmx + do i=1,imx + H(:,i,j)=this%a_diff_h(:,i,j)*H(:,i,j) & + -this%b_diff_h(:,i,j)*(DIFXH(:,i,j)-DIFXH(:,i-1,j) & + +DIFYH(:,i,j)-DIFYH(:,i,j-1)) + enddo + enddo + +endif + +!----------------------------------------------------------------------- +endsubroutine weighting_helm + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine weighting & +!*********************************************************************** +! ! +! Apply 2D differential operator to compound variable ! +! ! +!*********************************************************************** +(this,V,H) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +integer(i_kind):: i,j,l,k,imx,jmx +!----------------------------------------------------------------------- + + do j=1,this%jm + do i=1,this%im + V(:,i,j)=this%a_diff_f(:,i,j)*V(:,i,j) + enddo + enddo + +if(this%l_hgen) then + + imx = this%im + jmx = this%jm + + do j=1,jmx + do i=1,imx + H(:,i,j)=this%a_diff_h(:,i,j)*H(:,i,j) + enddo + enddo + +endif + +!----------------------------------------------------------------------- +endsubroutine weighting + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine weighting_highest & +!*********************************************************************** +! ! +! Apply 2D differential operator to compound variable ! +! ! +!*********************************************************************** +(this,H) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%imH+this%hx,1-this%hy:this%jmH+this%hy),intent(inout):: H +integer(i_kind):: i,j,imx,jmx +!----------------------------------------------------------------------- + + imx = this%imH + jmx = this%jmH + + do j=1,jmx + do i=1,imx + H(:,i,j)=this%a_diff_h(:,i,j)*H(:,i,j) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine weighting_highest + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine weighting_ens & +!*********************************************************************** +! ! +! Apply 2D differential operator to compound variable for ensemble ! +! ! +!*********************************************************************** +(this,V,H,kmx) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: kmx +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +integer(i_kind):: i,j,l,k,imx,jmx +!----------------------------------------------------------------------- + +if(this%l_filt_g1) then + do j=1,this%jm + do i=1,this%im + V(:,i,j)=this%a_diff_f(:,i,j)*V(:,i,j) + enddo + enddo +else + V(:,:,:)=0. +endif + +if(this%l_hgen) then + + imx = this%im + jmx = this%jm + + do j=1,jmx + do i=1,imx + H(:,i,j)=this%a_diff_h(:,i,j)*H(:,i,j) + enddo + enddo + +endif + +!----------------------------------------------------------------------- +endsubroutine weighting_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine weighting_loc_g3 & +!*********************************************************************** +! ! +! Apply 2D differential operator to compound variable in the case ! +! of localization ! +! ! +!*********************************************************************** +(this,V,H04,H16,km_in,km_4_in,km_16_in) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind), intent(in):: km_in,km_4_in,km_16_in +real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H04 +real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H16 +integer(i_kind):: i,j,l,k +!----------------------------------------------------------------------- + + do j=1,this%jm + do i=1,this%im + V (1:km_in ,i,j)=this%w1_loc(1:km_in ,i,j)*V (1:km_in ,i,j) + H04(1:km_4_in ,i,j)=this%w2_loc(1:km_4_in ,i,j)*H04(1:km_4_in ,i,j) + H16(1:km_16_in,i,j)=this%w3_loc(1:km_16_in,i,j)*H16(1:km_16_in,i,j) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine weighting_loc_g3 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine weighting_loc_g4 & +!*********************************************************************** +! ! +! Apply 2D differential operator to compound variable in the case ! +! of localization ! +! ! +!*********************************************************************** +(this,V,H04,H16,H64,km_in,km_4_in,km_16_in,km_64_in) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind), intent(in):: km_in,km_4_in,km_16_in,km_64_in +real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H04 +real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H16 +real(r_kind),dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H64 +integer(i_kind):: i,j,l,k +!----------------------------------------------------------------------- + + do j=1,this%jm + do i=1,this%im + V (1:km_in ,i,j)=this%w1_loc(1:km_in ,i,j)*V (1:km_in ,i,j) + H04(1:km_4_in ,i,j)=this%w2_loc(1:km_4_in ,i,j)*H04(1:km_4_in ,i,j) + H16(1:km_16_in,i,j)=this%w3_loc(1:km_16_in,i,j)*H16(1:km_16_in,i,j) + H64(1:km_64_in,i,j)=this%w4_loc(1:km_64_in,i,j)*H64(1:km_64_in,i,j) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine weighting_loc_g4 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine adjoint & +!*********************************************************************** +! ! +! Mapping from the high to low resolution grid ! +! using linearly squared interpolations ! +! - offset version - ! +! ! +!*********************************************************************** +(this,F,W,km_in,g) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: g +integer(i_kind),intent(in):: km_in +real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(in):: F +real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(out):: W +real(r_kind), dimension(km_in,1:this%im,-1:this%jmL+2):: W_AUX +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- +! +! 3) +! + W_AUX(:,:,:)= 0. + + do j=this%jm-mod(this%jm,2),2,-2 + jL = j/2 + do i=this%im,1,-1 + W_AUX(:,i,jL+2)=W_AUX(:,i,jL+2)+this%p_coef(4)*F(:,i,j) + W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+this%p_coef(3)*F(:,i,j) + W_AUX(:,i,jL )=W_AUX(:,i,jL )+this%p_coef(2)*F(:,i,j) + W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+this%p_coef(1)*F(:,i,j) + enddo + enddo +! +! 2) +! + do j=this%jm-1+mod(this%jm,2),1,-2 + jL=j/2 + do i=this%im,1,-1 + W_AUX(:,i,jL+2)=W_AUX(:,i,jL+2)+this%q_coef(4)*F(:,i,j) + W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+this%q_coef(3)*F(:,i,j) + W_AUX(:,i,jL )=W_AUX(:,i,jL )+this%q_coef(2)*F(:,i,j) + W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+this%q_coef(1)*F(:,i,j) + enddo + enddo + + W(:,:,:)=0. +! +! 1) +! + do jL=this%jmL+2,-1,-1 + do i=this%im-1+mod(this%im,2),1,-2 + iL = i/2 + W(:,iL+2,jL)=W(:,iL+2,jL)+this%q_coef(4)*W_AUX(:,i,jL) + W(:,iL+1,jL)=W(:,iL+1,jL)+this%q_coef(3)*W_AUX(:,i,jL) + W(:,iL ,jL)=W(:,iL ,jL)+this%q_coef(2)*W_AUX(:,i,jL) + W(:,iL-1,jL)=W(:,iL-1,jL)+this%q_coef(1)*W_AUX(:,i,jL) + enddo + do i=this%im-mod(this%im,2),2,-2 + iL=i/2 + W(:,iL+2,jL)=W(:,iL+2,jL)+this%p_coef(4)*W_AUX(:,i,jL) + W(:,iL+1,jL)=W(:,iL+1,jL)+this%p_coef(3)*W_AUX(:,i,jL) + W(:,iL ,jL)=W(:,iL ,jL)+this%p_coef(2)*W_AUX(:,i,jL) + W(:,iL-1,jL)=W(:,iL-1,jL)+this%p_coef(1)*W_AUX(:,i,jL) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine adjoint + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine direct1 & +!*********************************************************************** +! ! +! Mapping from the low to high resolution grid ! +! using linearly squared interpolations ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,F,km_in,g) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: g +integer(i_kind),intent(in):: km_in +real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(in):: W +real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(out):: F +real(r_kind), dimension(km_in,1:this%im,-1:this%jmL+2):: W_AUX +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- +! +! 1) +! + do jL=-1,this%jmL+2 + do i=1,this%im-1+mod(this%im,2),2 + iL=i/2 + W_AUX(:,i,jL)=this%q_coef(1)*W(:,iL-1,jL)+this%q_coef(2)*W(:,iL ,jL) & + +this%q_coef(3)*W(:,iL+1,jL)+this%q_coef(4)*W(:,iL+2,jL) + enddo + do i=2,this%im-mod(this%im,2),2 + iL=i/2 + W_AUX(:,i,jL)=this%p_coef(1)*W(:,iL-1,jL)+this%p_coef(2)*w(:,iL ,jL) & + +this%p_coef(3)*W(:,iL+1,jL)+this%p_coef(4)*W(:,iL+2,jL) + enddo + enddo +! +! 2) +! + do j=1,this%jm-1+mod(this%jm,2),2 + jL=j/2 + do i=1,this%im + F(:,i,j)=this%q_coef(1)*W_AUX(:,i,jL-1)+this%q_coef(2)*W_AUX(:,i,jL ) & + +this%q_coef(3)*W_AUX(:,i,jL+1)+this%q_coef(4)*W_AUX(:,i,jL+2) + enddo + enddo +! +! 3) +! + do j=2,this%jm-mod(this%jm,2),2 + jL=j/2 + do i=1,this%im + F(:,i,j)=this%p_coef(1)*W_AUX(:,i,jL-1)+this%p_coef(2)*W_AUX(:,i,jL ) & + +this%p_coef(3)*W_AUX(:,i,jL+1)+this%p_coef(4)*W_AUX(:,i,jL+2) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine direct1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine adjoint2 & +!*********************************************************************** +! ! +! Mapping from the high to low resolution grid ! +! using quadratics interpolations ! +! - offset version - ! +! ! +!*********************************************************************** +(this,F,W,km_in,g) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: g +integer(i_kind),intent(in):: km_in +real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(in):: F +real(r_kind), dimension(km_in,0:this%imL+1,0:this%jmL+1), intent(out):: W +real(r_kind), dimension(km_in,1:this%im,0:this%jmL+1):: W_AUX +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- +! +! 3) +! + W_AUX(:,:,:)= 0. + + do j=this%jm-mod(this%jm,2),2,-2 + jL = j/2 + do i=this%im,1,-1 + W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+this%b_coef(3)*F(:,i,j) + W_AUX(:,i,jL )=W_AUX(:,i,jL )+this%b_coef(2)*F(:,i,j) + W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+this%b_coef(1)*F(:,i,j) + enddo + enddo +! +! 2) +! + do j=this%jm-1+mod(this%jm,2),1,-2 + jL=(j+1)/2 + do i=this%im,1,-1 + W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+this%a_coef(3)*F(:,i,j) + W_AUX(:,i,jL )=W_AUX(:,i,jL )+this%a_coef(2)*F(:,i,j) + W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+this%a_coef(1)*F(:,i,j) + enddo + enddo + + W(:,:,:)=0. +! +! 1) +! + do jL=this%jmL+1,0,-1 + do i=this%im-1+mod(this%im,2),1,-2 + iL = (i+1)/2 + W(:,iL+1,jL)=W(:,iL+1,jL)+this%a_coef(3)*W_AUX(:,i,jL) + W(:,iL ,jL)=W(:,iL ,jL)+this%a_coef(2)*W_AUX(:,i,jL) + W(:,iL-1,jL)=W(:,iL-1,jL)+this%a_coef(1)*W_AUX(:,i,jL) + enddo + do i=this%im-mod(this%im,2),2,-2 + iL=i/2 + W(:,iL+1,jL)=W(:,iL+1,jL)+this%b_coef(3)*W_AUX(:,i,jL) + W(:,iL ,jL)=W(:,iL ,jL)+this%b_coef(2)*W_AUX(:,i,jL) + W(:,iL-1,jL)=W(:,iL-1,jL)+this%b_coef(1)*W_AUX(:,i,jL) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine adjoint2 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine direct2 & +!*********************************************************************** +! ! +! Mapping from the low to high resolution grid ! +! using quadratic interpolations ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,F,km_in,g) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: g +integer(i_kind),intent(in):: km_in +real(r_kind), dimension(km_in,0:this%imL+1,0:this%jmL+1), intent(in):: W +real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(out):: F +real(r_kind), dimension(km_in,1:this%im,0:this%jmL+1):: W_AUX +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- +! +! 1) +! + do jL=0,this%jmL+1 + do i=1,this%im-1+mod(this%im,2),2 + iL=(i+1)/2 + W_AUX(:,i,jL)=this%a_coef(1)*W(:,iL-1,jL)+this%a_coef(2)*W(:,iL ,jL) & + +this%a_coef(3)*W(:,iL+1,jL) + enddo + do i=2,this%im-mod(this%im,2),2 + iL=i/2 + W_AUX(:,i,jL)=this%b_coef(1)*W(:,iL-1,jL)+this%b_coef(2)*w(:,iL ,jL) & + +this%b_coef(3)*W(:,iL+1,jL) + enddo + enddo +! +! 2) +! + do j=1,this%jm-1+mod(this%jm,2),2 + jL=(j+1)/2 + do i=1,this%im + F(:,i,j)=this%a_coef(1)*W_AUX(:,i,jL-1)+this%a_coef(2)*W_AUX(:,i,jL ) & + +this%a_coef(3)*W_AUX(:,i,jL+1) + enddo + enddo +! +! 3) +! + do j=2,this%jm-mod(this%jm,2),2 + jL=j/2 + do i=1,this%im + F(:,i,j)=this%b_coef(1)*W_AUX(:,i,jL-1)+this%b_coef(2)*W_AUX(:,i,jL ) & + +this%b_coef(3)*W_AUX(:,i,jL+1) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine direct2 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine adjoint_nearest & +!*********************************************************************** +! ! +! Mapping from the high to low resolution grid ! +! selecting the nearest point ! +! - offset version - ! +! ! +!*********************************************************************** +(this,F,W,km_in,g) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: g +integer(i_kind),intent(in):: km_in +real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(in):: F +real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(out):: W +real(r_kind), dimension(km_in,1:this%im,-1:this%jmL+2):: W_AUX +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- +! +! 3) +! + W_AUX(:,:,:)= 0. + + do j=this%jm-mod(this%jm,2),2,-2 + jL = j/2 + do i=this%im,1,-1 + W_AUX(:,i,jL )=W_AUX(:,i,jL )+0.5**0.5*F(:,i,j) + enddo + enddo +! +! 2) +! + do j=this%jm-1+mod(this%jm,2),1,-2 + jL=j/2 + do i=this%im,1,-1 + W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+0.5**0.5*F(:,i,j) + enddo + enddo + + W(:,:,:)=0. +! +! 1) +! + do jL=this%jmL+2,-1,-1 + do i=this%im-1+mod(this%im,2),1,-2 + iL = i/2 + W(:,iL+1,jL)=W(:,iL+1,jL)+0.5**0.5*W_AUX(:,i,jL) + enddo + do i=this%im-mod(this%im,2),2,-2 + iL=i/2 + W(:,iL ,jL)=W(:,iL ,jL)+0.5**0.5*W_AUX(:,i,jL) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine adjoint_nearest + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine direct_nearest & +!*********************************************************************** +! ! +! Mapping from the low to high resolution grid ! +! selecting the nearest point ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,F,km_in,g) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: g +integer(i_kind),intent(in):: km_in +real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(in):: W +real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(out):: F +real(r_kind), dimension(km_in,1:this%im,-1:this%jmL+2):: W_AUX +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- +! +! 1) +! + do jL=-1,this%jmL+2 + do i=1,this%im-1+mod(this%im,2),2 + iL=i/2 + W_AUX(:,i,jL)=0.5**0.5*W(:,iL+1,jL) + enddo + do i=2,this%im-mod(this%im,2),2 + iL=i/2 + W_AUX(:,i,jL)=0.5**0.5*w(:,iL ,jL) + enddo + enddo +! +! 2) +! + do j=1,this%jm-1+mod(this%jm,2),2 + jL=j/2 + do i=1,this%im + F(:,i,j)=0.5**0.5*W_AUX(:,i,jL+1) + enddo + enddo +! +! 3) +! + do j=2,this%jm-mod(this%jm,2),2 + jL=j/2 + do i=1,this%im + F(:,i,j)=0.5**0.5*W_AUX(:,i,jL ) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine direct_nearest + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine adjoint_highest & +!*********************************************************************** +! ! +! Mapping from the high to low resolution grid ! +! using linearly squared interpolations ! +! - offset version - ! +! ! +!*********************************************************************** +(this,F,W,km_in,g) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: g +integer(i_kind),intent(in):: km_in +real(r_kind), dimension(km_in,1:this%im0(g),1:this%jm0(g)), intent(in):: F +real(r_kind), dimension(km_in,-1:this%im0(g+1)+2,-1:this%jm0(g+1)+2), intent(out):: W +real(r_kind), dimension(km_in,1:this%im0(g),-1:this%jm0(g+1)+2):: W_AUX +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- +! +! 3) +! + W_AUX(:,:,:)= 0. + + do j=this%jm0(g)-mod(this%jm0(g),2),2,-2 + jL = j/2 + do i=this%im0(g),1,-1 + W_AUX(:,i,jL+2)=W_AUX(:,i,jL+2)+this%p_coef(4)*F(:,i,j) + W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+this%p_coef(3)*F(:,i,j) + W_AUX(:,i,jL )=W_AUX(:,i,jL )+this%p_coef(2)*F(:,i,j) + W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+this%p_coef(1)*F(:,i,j) + enddo + enddo +! +! 2) +! + do j=this%jm0(g)-1+mod(this%jm0(g),2),1,-2 + jL=j/2 + do i=this%im0(g),1,-1 + W_AUX(:,i,jL+2)=W_AUX(:,i,jL+2)+this%q_coef(4)*F(:,i,j) + W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+this%q_coef(3)*F(:,i,j) + W_AUX(:,i,jL )=W_AUX(:,i,jL )+this%q_coef(2)*F(:,i,j) + W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+this%q_coef(1)*F(:,i,j) + enddo + enddo + + W(:,:,:)=0. +! +! 1) +! + do jL=this%jm0(g+1)+2,-1,-1 + do i=this%im0(g)-1+mod(this%im0(g),2),1,-2 + iL = i/2 + W(:,iL+2,jL)=W(:,iL+2,jL)+this%q_coef(4)*W_AUX(:,i,jL) + W(:,iL+1,jL)=W(:,iL+1,jL)+this%q_coef(3)*W_AUX(:,i,jL) + W(:,iL ,jL)=W(:,iL ,jL)+this%q_coef(2)*W_AUX(:,i,jL) + W(:,iL-1,jL)=W(:,iL-1,jL)+this%q_coef(1)*W_AUX(:,i,jL) + enddo + do i=this%im0(g)-mod(this%im0(g),2),2,-2 + iL=i/2 + W(:,iL+2,jL)=W(:,iL+2,jL)+this%p_coef(4)*W_AUX(:,i,jL) + W(:,iL+1,jL)=W(:,iL+1,jL)+this%p_coef(3)*W_AUX(:,i,jL) + W(:,iL ,jL)=W(:,iL ,jL)+this%p_coef(2)*W_AUX(:,i,jL) + W(:,iL-1,jL)=W(:,iL-1,jL)+this%p_coef(1)*W_AUX(:,i,jL) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine adjoint_highest + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine direct_highest & +!*********************************************************************** +! ! +! Mapping from the low to high resolution grid ! +! using linearly squared interpolations ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,F,km_in,g) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: g +integer(i_kind),intent(in):: km_in +real(r_kind), dimension(km_in,-1:this%im0(g+1)+2,-1:this%jm0(g+1)+2), intent(in):: W +real(r_kind), dimension(km_in,1:this%im0(g),1:this%jm0(g)), intent(out):: F +real(r_kind), dimension(km_in,1:this%im0(g),-1:this%jm0(g+1)+2):: W_AUX +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- +! +! 1) +! + do jL=-1,this%jm0(g+1)+2 + do i=1,this%im0(g)-1+mod(this%im0(g),2),2 + iL=i/2 + W_AUX(:,i,jL)=this%q_coef(1)*W(:,iL-1,jL)+this%q_coef(2)*W(:,iL ,jL) & + +this%q_coef(3)*W(:,iL+1,jL)+this%q_coef(4)*W(:,iL+2,jL) + enddo + do i=2,this%im0(g)-mod(this%im0(g),2),2 + iL=i/2 + W_AUX(:,i,jL)=this%p_coef(1)*W(:,iL-1,jL)+this%p_coef(2)*w(:,iL ,jL) & + +this%p_coef(3)*W(:,iL+1,jL)+this%p_coef(4)*W(:,iL+2,jL) + enddo + enddo +! +! 2) +! + do j=1,this%jm0(g)-1+mod(this%jm0(g),2),2 + jL=j/2 + do i=1,this%im0(g) + F(:,i,j)=this%q_coef(1)*W_AUX(:,i,jL-1)+this%q_coef(2)*W_AUX(:,i,jL ) & + +this%q_coef(3)*W_AUX(:,i,jL+1)+this%q_coef(4)*W_AUX(:,i,jL+2) + enddo + enddo +! +! 3) +! + do j=2,this%jm0(g)-mod(this%jm0(g),2),2 + jL=j/2 + do i=1,this%im0(g) + F(:,i,j)=this%p_coef(1)*W_AUX(:,i,jL-1)+this%p_coef(2)*W_AUX(:,i,jL ) & + +this%p_coef(3)*W_AUX(:,i,jL+1)+this%p_coef(4)*W_AUX(:,i,jL+2) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine direct_highest + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end submodule mg_generations diff --git a/src/mgbf/mg_input.f90 b/src/mgbf/mg_input.f90 new file mode 100644 index 0000000000..80b0772c12 --- /dev/null +++ b/src/mgbf/mg_input.f90 @@ -0,0 +1,155 @@ +module mg_input +!$$$ submodule documentation block +! . . . . +! module: mg_input +! prgmmr: rancic org: NCEP/EMC date: +! +! abstract: Module for data input +! (Here will be defined uniform decomposition and padding +! with zeros of control variables, required by the filter) +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! input_2d - +! input_spec1_2d - +! input_3d - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi + +use mg_intstate, only : mg_intstate_type +public input_2d +public input_spec1_2d +public input_3d + +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +contains +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +subroutine input_2d & +!*********************************************************************** +! ! +! Define some function for testing redecomposition ! +! (for analysis grid) ! +! ! +!*********************************************************************** +(obj_intstate,V,imin,jmin,imax,jmax,imax0,ampl) +!----------------------------------------------------------------------- +use kinds, only: r_kind,i_kind +implicit none +class (mg_intstate_type):: obj_intstate +integer(i_kind),intent(in):: imax,jmax +integer(i_kind),intent(in):: imin,jmin +integer(i_kind),intent(in):: imax0 +integer(i_kind),intent(in):: ampl +real(r_kind),dimension(imin:imax,jmin:jmax),intent(out):: V +real(i_kind):: ng,mg,L,m,n +!----------------------------------------------------------------------- + + do m=imin,jmax + mg = (obj_intstate%my-1)*jmax+m + do n=jmin,imax + ng = (obj_intstate%nx-1)*imax+n + V(n,m)=ampl*(mg*imax0+ng) +! V(n,m)=0. + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine input_2d + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +subroutine input_spec1_2d & +!*********************************************************************** +! ! +! Define some function for testing redecomposition ! +! (for analysis grid) ! +! ! +!*********************************************************************** +(obj_intstate,V,nx0,my0,flag) +!----------------------------------------------------------------------- +use kinds, only: r_kind,i_kind +implicit none +class (mg_intstate_type):: obj_intstate +integer(i_kind),intent(in):: nx0,my0 +real(r_kind),dimension(1:obj_intstate%nm,1:obj_intstate%mm),intent(out):: V +character(len=2), intent(in):: flag +integer(r_kind):: v0=1. +!----------------------------------------------------------------------- + + V(:,:)=0. + +if(flag=='md') then + if(obj_intstate%nx==nx0.and.obj_intstate%my==my0) then + V(obj_intstate%nm/2,obj_intstate%mm/2)=v0 + endif +else & +if(flag=='rt') then + if(obj_intstate%nx==nx0.and.obj_intstate%my==my0) then + V(obj_intstate%nm,obj_intstate%mm)=v0 + endif + if(obj_intstate%nx==nx0+1.and.obj_intstate%my==my0) then + V(1,obj_intstate%mm)=v0 + endif + if(obj_intstate%nx==nx0.and.obj_intstate%my==my0+1) then + V(obj_intstate%nm,1)=v0 + endif + if(obj_intstate%nx==nx0+1.and.obj_intstate%my==my0+1) then + V(1,1)=v0 + endif +endif + +!----------------------------------------------------------------------- +endsubroutine input_spec1_2d + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +subroutine input_3d & +!*********************************************************************** +! ! +! Define some function for testing redecomposition ! +! (for analysis grid) ! +! ! +!*********************************************************************** +(obj_intstate,V,imin,jmin,lmin,imax,jmax,lmax,imax0,ampl,incrm) +!----------------------------------------------------------------------- +use kinds, only: r_kind,i_kind +implicit none +class (mg_intstate_type):: obj_intstate +integer(i_kind),intent(in):: imin,jmin,lmin +integer(i_kind),intent(in):: imax,jmax,lmax +integer(i_kind),intent(in):: imax0 +integer(i_kind),intent(in):: ampl,incrm +real(r_kind),dimension(lmin:lmax,imin:imax,jmin:jmax),intent(out):: V +real(i_kind):: ng,mg,L,m,n +!----------------------------------------------------------------------- + + do l=lmin,lmax + do m=imin,jmax + mg = (obj_intstate%my-1)*jmax+m + do n=jmin,imax + ng = (obj_intstate%nx-1)*imax+n + V(l,n,m)=ampl*(mg*imax0+ng) +(l-1)*incrm +! V(l,n,m)=0. + enddo + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine input_3d + +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end module mg_input diff --git a/src/mgbf/mg_interpolate.f90 b/src/mgbf/mg_interpolate.f90 new file mode 100644 index 0000000000..5346792581 --- /dev/null +++ b/src/mgbf/mg_interpolate.f90 @@ -0,0 +1,972 @@ +submodule(mg_intstate) mg_interpolate +!$$$ submodule documentation block +! . . . . +! module: mg_interpolate +! prgmmr: rancic org: NCEP/EMC date: 2020 +! +! abstract: General mapping between 2d arrays using linerly squared +! interpolations +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! def_offset_coef - +! lsqr_mg_coef - +! lwq_vertical_coef - +! lwq_vertical_adjoint - +! lwq_vertical_direct - +! lwq_vertical_adjoint_spec - +! lwq_vertical_direct_spec - +! l_vertical_adjoint_spec - +! l_vertical_direct_spec - +! lsqr_direct_offset - +! lsqr_adjoint_offset - +! quad_direct_offset - +! quad_adjoint_offset - +! lin_direct_offset - +! lin_adjoint_offset - +! l_vertical_adjoint_spec2 - +! l_vertical_direct_spec2 - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use kinds +use jp_pkind2, only: fpi + +implicit none +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +contains +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine def_offset_coef (this) +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this + +real(r_kind):: r64,r32,r128 +!----------------------------------------------------------------------- + r64 = 1.0d0/64.0d0 + r32 = 1.0d0/32.0d0 + r128= 1.0d0/128.0d0 + +! p_coef =(/-3.,51,29,-3/) +! q_coef =(/-3.,19.0d0,51.0d0,-3.0d0/) +! p_coef = p_coef*r64 +! q_coef = q_coef*r64 + + this%p_coef =(/-9.,111.,29.,-3./) + this%q_coef =(/-3.,29.,111.,-9./) + this%p_coef = this%p_coef*r128 + this%q_coef = this%q_coef*r128 + + this%a_coef =(/5.,30.,-3./) + this%b_coef =(/-3.,30.,5./) + this%a_coef=this%a_coef*r32 + this%b_coef=this%b_coef*r32 +!----------------------------------------------------------------------- +endsubroutine def_offset_coef + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine lsqr_mg_coef (this) +!*********************************************************************** +! ! +! Prepare coeficients for mapping between: ! +! filter grid on analysis decomposition: W(1-ib:im+ib,1-jb:jm+jb) ! +! and analysis grid: V(1:nm,1:mm) ! +! - offset version - ! +! ! +! ( im < nm and jm < mm ) ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this +real(r_kind), dimension(1:this%nm):: xa +real(r_kind), dimension(1-this%ib:this%im+this%ib):: xf +real(r_kind), dimension(1:this%mm):: ya +real(r_kind), dimension(1-this%jb:this%jm+this%jb):: yf +integer(i_kind):: i,j,n,m +real(r_kind) x1,x2,x3,x4,x +real(r_kind) x1x,x2x,x3x,x4x +real(r_kind) rx2x1,rx3x1,rx4x1,rx3x2,rx4x2,rx4x3 +real(r_kind) y1,y2,y3,y4,y +real(r_kind) y1y,y2y,y3y,y4y +real(r_kind) ry2y1,ry3y1,ry4y1,ry3y2,ry4y2,ry4y3 +real(r_kind) cfl1,cfl2,cfl3,cll +real(r_kind) cfr1,cfr2,cfr3,crr +real(r_kind) x1_x,x2_x,x3_x +real(r_kind) y1_y,y2_y,y3_y +!----------------------------------------------------------------------- +! +! Initialize +! + + do n=1,this%nm + xa(n)=this%xa0+this%dxa*(n-1) + enddo + + do i=1-this%ib,this%im+this%ib + xf(i)=this%xf0+this%dxf*(i-1) + enddo + + do m=1,this%mm + ya(m)=this%ya0+this%dya*(m-1) + enddo + + do j=1-this%jb,this%jm+this%jb + yf(j)=this%yf0+this%dyf*(j-1) + enddo + +! +! Find iref and jref +! + do n=1,this%nm + do i=1-this%ib,this%im+this%ib-1 + if( xa(n)< xf(i)) then + this%iref(n)=i-2 + this%irefq(n)=i-1 + this%irefL(n)=i-1 + exit + endif + enddo + enddo + + do m=1,this%mm + do j=1-this%jb,this%jm+this%jb-1 + if(ya(m) < yf(j)) then + this%jref(m)=j-2 + this%jrefq(m)=j-1 + this%jrefL(m)=j-1 + exit + endif + enddo + enddo + + do n=1,this%nm + i=this%iref(n) + x1=xf(i) + x2=xf(i+1) + x3=xf(i+2) + x4=xf(i+3) + x = xa(n) + x1x = x1-x + x2x = x2-x + x3x = x3-x + x4x = x4-x + rx2x1 = 1./(x2-x1) + rx3x1 = 1./(x3-x1) + rx4x1 = 1./(x4-x1) + rx3x2 = 1./(x3-x2) + rx4x2 = 1./(x4-x2) + rx4x3 = 1./(x4-x3) + CFL1 = x2x*x3x*rx2x1*rx3x1 + CFL2 =-x1x*x3x*rx2x1*rx3x2 + CFL3 = x1x*x2x*rx3x1*rx3x2 + CLL = x3x*rx3x2 + CFR1 = x3x*x4x*rx3x2*rx4x2 + CFR2 =-x2x*x4x*rx3x2*rx4x3 + CFR3 = x2x*x3x*rx4x2*rx4x3 + CRR =-x2x*rx3x2 + this%cx0(n)=CFL1*CLL + this%cx1(n)=CFL2*CLL+CFR1*CRR + this%cx2(n)=CFL3*CLL+CFR2*CRR + this%cx3(n)=CFR3*CRR + enddo + + do m=1,this%mm + j=this%jref(m) + y1=yf(j) + y2=yf(j+1) + y3=yf(j+2) + y4=yf(j+3) + y = ya(m) + y1y = y1-y + y2y = y2-y + y3y = y3-y + y4y = y4-y + ry2y1 = 1./(y2-y1) + ry3y1 = 1./(y3-y1) + ry4y1 = 1./(y4-y1) + ry3y2 = 1./(y3-y2) + ry4y2 = 1./(y4-y2) + ry4y3 = 1./(y4-y3) + CFL1 = y2y*y3y*ry2y1*ry3y1 + CFL2 =-y1y*y3y*ry2y1*ry3y2 + CFL3 = y1y*y2y*ry3y1*ry3y2 + CLL = y3y*ry3y2 + CFR1 = y3y*y4y*ry3y2*ry4y2 + CFR2 =-y2y*y4y*ry3y2*ry4y3 + CFR3 = y2y*y3y*ry4y2*ry4y3 + CRR =-y2y*ry3y2 + this%cy0(m)=CFL1*CLL + this%cy1(m)=CFL2*CLL+CFR1*CRR + this%cy2(m)=CFL3*CLL+CFR2*CRR + this%cy3(m)=CFR3*CRR + enddo + +! +! Quadratic interpolations +! + do n=1,this%nm + i=this%irefq(n) + x1=xf(i) + x2=xf(i+1) + x3=xf(i+2) + x = xa(n) + x1_x = x1-x + x2_x = x2-x + x3_x = x3-x + rx2x1 = 1./(x2-x1) + rx3x1 = 1./(x3-x1) + rx3x2 = 1./(x3-x2) + this%qx0(n) = x2_x*x3_x*rx2x1*rx3x1 + this%qx1(n) =-x1_x*x3_x*rx2x1*rx3x2 + this%qx2(n) = x1_x*x2_x*rx3x1*rx3x2 + enddo + + do m=1,this%mm + i=this%jrefq(m) + y1=yf(i) + y2=yf(i+1) + y3=yf(i+2) + y = ya(m) + y1_y = y1-y + y2_y = y2-y + y3_y = y3-y + ry2y1 = 1./(y2-y1) + ry3y1 = 1./(y3-y1) + ry3y2 = 1./(y3-y2) + this%qy0(m) = y2_y*y3_y*ry2y1*ry3y1 + this%qy1(m) =-y1_y*y3_y*ry2y1*ry3y2 + this%qy2(m) = y1_y*y2_y*ry3y1*ry3y2 + enddo + +! +! Linear interpolations +! + do n=1,this%nm + i=this%irefL(n) + x1=xf(i) + x2=xf(i+1) + x = xa(n) + x1_x = x1-x + x2_x = x2-x + rx2x1 = 1./(x2-x1) + this%Lx0(n) = x2_x*rx2x1 + this%Lx1(n) =-x1_x*rx2x1 + enddo + + do m=1,this%mm + j=this%jrefL(m) + y1=yf(j) + y2=yf(j+1) + y = ya(m) + y1_y = y1-y + y2_y = y2-y + ry2y1 = 1./(y2-y1) + this%Ly0(m) = y2_y*ry2y1 + this%Ly1(m) =-y1_y*ry2y1 + enddo +!----------------------------------------------------------------------- +endsubroutine lsqr_mg_coef + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine lwq_vertical_coef & +!*********************************************************************** +! ! +! Prepare coeficients for vertical mapping between: ! +! analysis grid vertical resolution (nm) and ! +! generation one of filter grid vertical resoluition (im) ! +! ! +! ( im <= nm ) ! +! ! +!*********************************************************************** +(this,nm_in,im_in,c1,c2,c3,c4,iref_out) +implicit none +class(mg_intstate_type),target::this + +integer(i_kind), intent(in):: nm_in,im_in +real(r_kind), dimension(1:nm_in), intent(out):: c1,c2,c3,c4 +integer(i_kind), dimension(1:nm_in), intent(out):: iref_out + +real(r_kind), dimension(1:nm_in):: y +real(r_kind), dimension(0:im_in+1):: x +real(r_kind):: dy,x1,x2,x3,x4,dx1,dx2,dx3,dx4 +real(r_kind):: dx13,dx23,dx24 + +integer(i_kind):: i,n +!----------------------------------------------------------------------- + + do i=0,im_in+1 + x(i)=(i-1)*1. + enddo + + dy = 1.*(im_in-1)/(nm_in-1) + do n=1,nm_in + y(n)=(n-1)*dy + enddo + y(nm_in)=x(im_in) + + do n=2,nm_in-1 + i = y(n)+1 + x1 = x(i-1) + x2 = x(i) + x3 = x(i+1) + x4 = x(i+2) + iref_out(n)=i + dx1 = y(n)-x1 + dx2 = y(n)-x2 + dx3 = y(n)-x3 + dx4 = y(n)-x4 + dx13 = dx1*dx3 + dx23 = 0.5*dx2*dx3 + dx24 = dx2*dx4 + c1(n) = -dx23*dx3 + c2(n) = ( dx13+0.5*dx24)*dx3 + c3(n) = -(0.5*dx13+ dx24)*dx2 + c4(n) = dx23*dx2 + + if(iref_out(n)==1) then + c3(n)=c3(n)+c1(n) + c1(n)=0. + endif + if(iref_out(n)==im_in-1) then + c2(n)=c2(n)+c4(n) + c4(n)=0. + endif + enddo + iref_out(1)=1; c1(1)=0.; c2(1)=1.; c3(1)=0.; c4(1)=0. + iref_out(nm_in)=im_in; c1(nm_in)=0.; c2(nm_in)=1.; c3(nm_in)=0.; c4(n)=0. + +!----------------------------------------------------------------------- +endsubroutine lwq_vertical_coef + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine lwq_vertical_adjoint & +!*********************************************************************** +! ! +! Direct linerly weighted quadratic adjoint interpolation in vertical ! +! from reslution nm to resolution km ! +! ! +! ( km <= nm ) ! +! ! +!*********************************************************************** +(this,nm_in,km_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,w,f) +implicit none +!----------------------------------------------------------------------- +class(mg_intstate_type),target::this +integer(i_kind), intent(in):: nm_in,km_in,imin,imax,jmin,jmax +real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4 +integer(i_kind), dimension(1:nm_in), intent(in):: kref +real(r_kind), dimension(1:nm_in,imin:imax,jmin:jmax), intent(in):: w +real(r_kind), dimension(1:km_in,imin:imax,jmin:jmax), intent(out):: f +integer(i_kind):: k,n +!----------------------------------------------------------------------- + f = 0. +do n=2,nm_in-1 + k = kref(n) + if( k==1 ) then + f(1,:,:) = f(1,:,:)+c2(n)*w(n,:,:) + f(2,:,:) = f(2,:,:)+c3(n)*w(n,:,:) + f(3,:,:) = f(3,:,:)+c4(n)*w(n,:,:) + elseif & + ( k==km_in-1) then + f(km_in-2,:,:) = f(km_in-2,:,:)+c1(n)*w(n,:,:) + f(km_in-1,:,:) = f(km_in-1,:,:)+c2(n)*w(n,:,:) + f(km_in ,:,:) = f(km_in ,:,:)+c3(n)*w(n,:,:) + elseif( k==km_in) then + f(k ,:,:) = f(k ,:,:)+c2(n)*w(n,:,:) + else + f(k-1,:,:) = f(k-1,:,:)+c1(n)*w(n,:,:) + f(k ,:,:) = f(k ,:,:)+c2(n)*w(n,:,:) + f(k+1,:,:) = f(k+1,:,:)+c3(n)*w(n,:,:) + f(k+2,:,:) = f(k+2,:,:)+c4(n)*w(n,:,:) + endif +enddo + f(1,:,:)=f(1,:,:)+w(1,:,:) + f(km_in,:,:)=f(km_in,:,:)+w(nm_in,:,:) + +!----------------------------------------------------------------------- +endsubroutine lwq_vertical_adjoint + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine lwq_vertical_direct & +!*********************************************************************** +! ! +! Linerly weighted direct quadratic interpolation in vertical ! +! from reslouion km to resolution nm ! +! ! +! ( km <= nm ) ! +! ! +!*********************************************************************** +(this,km_in,nm_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,f,w) +implicit none +!----------------------------------------------------------------------- +class(mg_intstate_type),target::this +integer(i_kind), intent(in):: km_in,nm_in,imin,imax,jmin,jmax +real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4 +integer(i_kind), dimension(1:nm_in), intent(in):: kref +real(r_kind), dimension(1:km_in,imin:imax,jmin:jmax), intent(in):: f +real(r_kind), dimension(1:nm_in,imin:imax,jmin:jmax), intent(out):: w +integer(i_kind):: k,n +!----------------------------------------------------------------------- +do n=2,nm_in-1 + k = kref(n) + if( k==1 ) then + w(n,:,:) = c2(n)*f(k,:,:)+c3(n)*f(k+1,:,:)+c4(n)*f(k+2,:,:) + elseif & + ( k==km_in-1) then + w(n,:,:) =c1(n)*f(k-1,:,:)+c2(n)*f(k,:,:)+c3(n)*f(k+1,:,:) + elseif & + ( k==km_in) then + w(n,:,:) = c2(n)*f(k,:,:) + else + w(n,:,:) =c1(n)*f(k-1,:,:)+c2(n)*f(k,:,: )+c3(n)*f(k+1,:,:)+c4(n)*f(k+2,:,:) + endif +enddo + w(1,:,:)=f(1,:,:) + w(nm_in,:,:)=f(km_in,:,:) + +!----------------------------------------------------------------------- +endsubroutine lwq_vertical_direct + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine lwq_vertical_adjoint_spec & +!*********************************************************************** +! ! +! Direct linerly weighted quadratic adjoint interpolation in vertical ! +! from reslution nm to resolution km ! +! ! +! ( km <= nm ) ! +! ! +!*********************************************************************** +(this,km3_in,nm_in,km_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,W,F) +implicit none +!----------------------------------------------------------------------- +class(mg_intstate_type),target::this +integer(i_kind), intent(in):: km3_in,nm_in,km_in,imin,imax,jmin,jmax +real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4 +integer(i_kind), dimension(1:nm_in), intent(in):: kref +real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(in):: W +real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(out):: F +integer(i_kind):: k,n +!----------------------------------------------------------------------- + F = 0. +do n=2,nm_in-1 + k = kref(n) + if( k==1 ) then + F(:,:,:,1) = F(:,:,:,1)+c2(n)*W(:,:,:,n) + F(:,:,:,2) = F(:,:,:,2)+c3(n)*W(:,:,:,n) + F(:,:,:,3) = F(:,:,:,3)+c4(n)*W(:,:,:,n) + elseif & + ( k==km_in-1) then + F(:,:,:,km_in-2) = F(:,:,:,km_in-2)+c1(n)*W(:,:,:,n) + F(:,:,:,km_in-1) = F(:,:,:,km_in-1)+c2(n)*W(:,:,:,n) + F(:,:,:,km_in ) = F(:,:,:,km_in )+c3(n)*W(:,:,:,n) + elseif( k==km_in) then + F(:,:,:,k ) = F(:,:,:,k )+c2(n)*W(:,:,:,n) + else + F(:,:,:,k-1) = F(:,:,:,k-1)+c1(n)*W(:,:,:,n) + F(:,:,:,k ) = F(:,:,:,k )+c2(n)*W(:,:,:,n) + F(:,:,:,k+1) = F(:,:,:,k+1)+c3(n)*W(:,:,:,n) + F(:,:,:,k+2) = F(:,:,:,k+2)+c4(n)*W(:,:,:,n) + endif +enddo + F(:,:,:,1 )=F(:,:,:,1 )+W(:,:,:,1 ) + F(:,:,:,km_in)=F(:,:,:,km_in)+W(:,:,:,nm_in) +!----------------------------------------------------------------------- +endsubroutine lwq_vertical_adjoint_spec + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine lwq_vertical_direct_spec & +!*********************************************************************** +! ! +! Linerly weighted direct quadratic interpolation in vertical ! +! from reslouion im to resolution nm ! +! ! +! ( km <= nm ) ! +! ! +!*********************************************************************** +(this,km3_in,km_in,nm_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,F,W) +implicit none +!----------------------------------------------------------------------- +class(mg_intstate_type),target::this +integer(i_kind), intent(in):: km3_in,km_in,nm_in,imin,imax,jmin,jmax +real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4 +integer(i_kind), dimension(1:nm_in), intent(in):: kref +real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(in):: F +real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(out):: W +integer(i_kind):: k,n +!----------------------------------------------------------------------- +do n=2,nm_in-1 + k = kref(n) + if( k==1 ) then + W(:,:,:,n) = c2(n)*F(:,:,:,k)+c3(n)*F(:,:,:,k+1)+c4(n)*F(:,:,:,k+2) + elseif & + ( k==km_in-1) then + W(:,:,:,n) =c1(n)*F(:,:,:,k-1)+c2(n)*F(:,:,:,k)+c3(n)*F(:,:,:,k+1) + elseif & + ( k==km_in) then + W(:,:,:,n) = c2(n)*F(:,:,:,k) + else + W(:,:,:,n) =c1(n)*F(:,:,:,k-1)+c2(n)*F(:,:,:,k)+c3(n)*F(:,:,:,k+1)+c4(n)*F(:,:,:,k+2) + endif +enddo + W(:,:,:,1 )=F(:,:,:,1 ) + W(:,:,:,nm_in)=F(:,:,:,km_in) +!----------------------------------------------------------------------- +endsubroutine lwq_vertical_direct_spec + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine l_vertical_adjoint_spec & +!*********************************************************************** +! ! +! Adjoint of linear interpolations in vertical ! +! from reslution nm to resolution km ! +! ! +! ( nm = 2*km-1 ) ! +! ! +!*********************************************************************** +(this,km3_in,nm_in,km_in,imin,imax,jmin,jmax,W,F) +implicit none +!----------------------------------------------------------------------- +class(mg_intstate_type),target::this +integer(i_kind), intent(in):: km3_in,nm_in,km_in,imin,imax,jmin,jmax +real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(in):: W +real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(out):: F +integer(i_kind):: k,n +!----------------------------------------------------------------------- + F = 0. + + k=1 + do n=2,nm_in-1,2 + F(:,:,:,k ) = F(:,:,:,k )+0.5*W(:,:,:,n) + F(:,:,:,k+1) = F(:,:,:,k+1)+0.5*W(:,:,:,n) + k=k+1 + enddo + + k=1 + do n=1,nm_in,2 + F(:,:,:,k ) = F(:,:,:,k )+ W(:,:,:,n) + k=k+1 + enddo +!----------------------------------------------------------------------- +endsubroutine l_vertical_adjoint_spec + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine l_vertical_direct_spec & +!*********************************************************************** +! ! +! ! +! Direct linear interpolations in vertical ! +! from reslution nm to resolution km ! +! ! +! ( nm = 2*km-1 ) ! +! ! +!*********************************************************************** +(this,km3_in,km_in,nm_in,imin,imax,jmin,jmax,F,W) +implicit none +!----------------------------------------------------------------------- +class(mg_intstate_type),target::this +integer(i_kind), intent(in):: km3_in,km_in,nm_in,imin,imax,jmin,jmax +real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(in):: F +real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(out):: W +integer(i_kind):: k,n +!----------------------------------------------------------------------- + k=1 + do n=1,nm_in,2 + W(:,:,:,n) =F (:,:,:,k) + k=k+1 + enddo + + k=1 + do n=2,nm_in-1,2 + W(:,:,:,n) = 0.5*(F(:,:,:,k)+F(:,:,:,k+1)) + k=k+1 + enddo +!----------------------------------------------------------------------- +endsubroutine l_vertical_direct_spec + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine lsqr_direct_offset & +!*********************************************************************** +! ! +! Given a source array V(km,1-ib:im+ib,1-jb:jm+jb) perform ! +! direct interpolations to get target array W(km,1:nm,1:mm) ! +! using two passes of 1d interpolator ! +! ! +!*********************************************************************** +(this,V_in,W,km_in,ibm,jbm) +!----------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: km_in,ibm,jbm +real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(in):: V_in +real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(out):: W + +real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX +integer(i_kind):: i,j,n,m +real(r_kind),dimension(km_in):: v0,v1,v2,v3 +!----------------------------------------------------------------------- + do j=1-jbm,this%jm+jbm + do n=1,this%nm + i = this%iref(n) + v0(:)=V_in(:,i ,j) + v1(:)=V_in(:,i+1,j) + v2(:)=V_in(:,i+2,j) + v3(:)=V_in(:,i+3,j) + VX(:,n,j) = this%cx0(n)*v0(:)+this%cx1(n)*v1(:)+this%cx2(n)*v2(:)+this%cx3(n)*v3(:) + enddo + enddo + + do m=1,this%mm + j = this%jref(m) + do n=1,this%nm + v0(:)=VX(:,n,j ) + v1(:)=VX(:,n,j+1) + v2(:)=VX(:,n,j+2) + v3(:)=VX(:,n,j+3) + W(:,n,m) = this%cy0(m)*v0(:)+this%cy1(m)*v1(:)+this%cy2(m)*v2(:)+this%cy3(m)*v3(:) + enddo + enddo +!----------------------------------------------------------------------- +endsubroutine lsqr_direct_offset + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine lsqr_adjoint_offset & +!*********************************************************************** +! ! +! Given a target array W(km,1:nm,1:mm) perform adjoint ! +! interpolations to get source array V(km,1-ib:im+ib,1-jb:jm+jb) ! +! using two passes of 1d interpolator ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,V_out,km_in,ibm,jbm) +!----------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind):: km_in,ibm,jbm +real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W +real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(out):: V_out +real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX +real(r_kind), dimension(km_in):: wk +real(r_kind), dimension(km_in):: vxk +integer(i_kind):: i,j,n,m,l,k +real(r_kind):: c0,c1,c2,c3 +!----------------------------------------------------------------------- + V_out(:,:,:)=0. + VX(:,:,:)=0. + + do m=1,this%mm + j = this%jref(m) + c0 = this%cy0(m) + c1 = this%cy1(m) + c2 = this%cy2(m) + c3 = this%cy3(m) + do n=1,this%nm + wk(:)=W(:,n,m) + VX(:,n,j ) = VX(:,n,j )+wk(:)*c0 + VX(:,n,j+1) = VX(:,n,j+1)+wk(:)*c1 + VX(:,n,j+2) = VX(:,n,j+2)+wk(:)*c2 + VX(:,n,j+3) = VX(:,n,j+3)+wk(:)*c3 + enddo + enddo + + do n=1,this%nm + i = this%iref(n) + c0 = this%cx0(n) + c1 = this%cx1(n) + c2 = this%cx2(n) + c3 = this%cx3(n) + do j=1-jbm,this%jm+jbm + vxk(:)=VX(:,n,j) + V_out(:,i ,j) = V_out(:,i ,j)+vxk(:)*c0 + V_out(:,i+1,j) = V_out(:,i+1,j)+vxk(:)*c1 + V_out(:,i+2,j) = V_out(:,i+2,j)+vxk(:)*c2 + V_out(:,i+3,j) = V_out(:,i+3,j)+vxk(:)*c3 + enddo + enddo +!----------------------------------------------------------------------- +endsubroutine lsqr_adjoint_offset + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine quad_direct_offset & +!*********************************************************************** +! ! +! Given a source array V(km,1-ib:im+ib,1-jb:jm+jb) perform ! +! direct interpolations to get target array W(km,1:nm,1:mm) ! +! using two passes of 1d interpolator ! +! ! +!*********************************************************************** +(this,V_in,W,km_in,ibm,jbm) +!----------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: km_in,ibm,jbm +real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(in):: V_in +real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(out):: W +real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX +integer(i_kind):: i,j,n,m +real(r_kind),dimension(km_in):: v0,v1,v2 +!----------------------------------------------------------------------- + do n=1,this%nm + i = this%irefq(n) + do j=1-jbm,this%jm+jbm + v0(:)=V_in(:,i ,j) + v1(:)=V_in(:,i+1,j) + v2(:)=V_in(:,i+2,j) + VX(:,n,j) = this%qx0(n)*v0(:)+this%qx1(n)*v1(:)+this%qx2(n)*v2(:) + enddo + enddo + + do m=1,this%mm + j = this%jrefq(m) + do n=1,this%nm + v0(:)=VX(:,n,j ) + v1(:)=VX(:,n,j+1) + v2(:)=VX(:,n,j+2) + W(:,n,m) = this%qy0(m)*v0(:)+this%qy1(m)*v1(:)+this%qy2(m)*v2(:) + enddo + enddo +!----------------------------------------------------------------------- +endsubroutine quad_direct_offset + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine quad_adjoint_offset & +!*********************************************************************** +! ! +! Given a target array W(km,1:nm,1:mm) perform adjoint ! +! interpolations to get source array V(km,1-ib:im+ib,1-jb:jm+jb) ! +! using two passes of 1d interpolator ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,V_out,km_in,ibm,jbm) +!----------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind):: km_in,ibm,jbm +real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W +real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(out):: V_out +real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX +real(r_kind), dimension(km_in):: wk +real(r_kind), dimension(km_in):: vxk +integer(i_kind):: i,j,n,m,l,k +real(r_kind):: c0,c1,c2 +!----------------------------------------------------------------------- + V_out(:,:,:)=0. + VX(:,:,:)=0. + + do m=1,this%mm + j = this%jrefq(m) + c0 = this%qy0(m) + c1 = this%qy1(m) + c2 = this%qy2(m) + do n=1,this%nm + wk(:)=W(:,n,m) + VX(:,n,j ) = VX(:,n,j )+wk(:)*c0 + VX(:,n,j+1) = VX(:,n,j+1)+wk(:)*c1 + VX(:,n,j+2) = VX(:,n,j+2)+wk(:)*c2 + enddo + enddo + + + do n=1,this%nm + i = this%irefq(n) + c0 = this%qx0(n) + c1 = this%qx1(n) + c2 = this%qx2(n) + do j=1-jbm,this%jm+jbm + vxk(:)=VX(:,n,j) + V_out(:,i ,j) = V_out(:,i ,j)+vxk(:)*c0 + V_out(:,i+1,j) = V_out(:,i+1,j)+vxk(:)*c1 + V_out(:,i+2,j) = V_out(:,i+2,j)+vxk(:)*c2 + enddo + enddo +!----------------------------------------------------------------------- +endsubroutine quad_adjoint_offset + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine lin_direct_offset & +!*********************************************************************** +! ! +! Given a source array V(km,1-ib:im+ib,1-jb:jm+jb) perform ! +! direct interpolations to get target array W(km,1:nm,1:mm) ! +! using two passes of 1d linear interpolator ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,V_in,W,km_in,ibm,jbm) +!----------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: km_in,ibm,jbm +real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(in):: V_in +real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(out):: W +real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX +integer(i_kind):: i,j,n,m +real(r_kind),dimension(km_in):: v0,v1 +!----------------------------------------------------------------------- + do n=1,this%nm + i = this%irefL(n) + do j=1-jbm,this%jm+jbm + v0(:)=V_in(:,i ,j) + v1(:)=V_in(:,i+1,j) + VX(:,n,j) = this%Lx0(n)*v0(:)+this%Lx1(n)*v1(:) + enddo + enddo + + do m=1,this%mm + j = this%jrefL(m) + do n=1,this%nm + v0(:)=VX(:,n,j ) + v1(:)=VX(:,n,j+1) + W(:,n,m) = this%Ly0(m)*v0(:)+this%Ly1(m)*v1(:) + enddo + enddo +!----------------------------------------------------------------------- +endsubroutine lin_direct_offset + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine lin_adjoint_offset & +!*********************************************************************** +! ! +! Given a target array W(km,1:nm,1:mm) perform adjoint ! +! interpolations to get source array V(km,1-ib:im+ib,1-jb:jm+jb) ! +! using two passes of 1d linear interpolator ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,V_out,km_in,ibm,jbm) +!----------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind):: km_in,ibm,jbm +real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W +real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(out):: V_out +real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX +real(r_kind), dimension(km_in):: wk +real(r_kind), dimension(km_in):: vxk +integer(i_kind):: i,j,n,m,l,k +real(r_kind):: c0,c1 +!----------------------------------------------------------------------- + V_out(:,:,:)=0. + VX(:,:,:)=0. + + do m=1,this%mm + j = this%jrefL(m) + c0 = this%Ly0(m) + c1 = this%Ly1(m) + do n=1,this%nm + wk(:)=W(:,n,m) + VX(:,n,j ) = VX(:,n,j )+wk(:)*c0 + VX(:,n,j+1) = VX(:,n,j+1)+wk(:)*c1 + enddo + enddo + + do n=1,this%nm + i = this%irefL(n) + c0 = this%Lx0(n) + c1 = this%Lx1(n) + do j=1-jbm,this%jm+jbm + vxk(:)=VX(:,n,j) + V_out(:,i ,j) = V_out(:,i ,j)+vxk(:)*c0 + V_out(:,i+1,j) = V_out(:,i+1,j)+vxk(:)*c1 + enddo + enddo +!----------------------------------------------------------------------- +endsubroutine lin_adjoint_offset + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine l_vertical_adjoint_spec2 & +!*********************************************************************** +! ! +! Adjoint of linear interpolations in vertical ! +! from reslution nm to resolution km ! +! ! +! ( nm = 2*km-1 ) ! +! ! +!*********************************************************************** +(this,en,nm_in,km_in,imin,imax,jmin,jmax,W,F) +implicit none +!----------------------------------------------------------------------- +class(mg_intstate_type),target::this +integer(i_kind), intent(in):: en,nm_in,km_in,imin,imax,jmin,jmax +real(r_kind), dimension(1:nm_in*en,imin:imax,jmin:jmax), intent(in):: W +real(r_kind), dimension(1:km_in*en,imin:imax,jmin:jmax), intent(out):: F +integer(i_kind):: k,n,e,enm,ekm +!----------------------------------------------------------------------- + F = 0. + +do e=0,en-1 + enm = e*nm_in + ekm = e*km_in + k=1 + do n=2,nm_in-1,2 + F(ekm+k ,:,:) = F(ekm+k ,:,:)+0.5*W(enm+n,:,:) + F(ekm+k+1,:,:) = F(ekm+k+1,:,:)+0.5*W(enm+n,:,:) + k=k+1 + enddo + + k=1 + do n=1,nm_in,2 + F(ekm+k,:,:) = F(ekm+k,:,:) + W(enm+n,:,:) + k=k+1 + enddo +enddo +!----------------------------------------------------------------------- +endsubroutine l_vertical_adjoint_spec2 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine l_vertical_direct_spec2 & +!*********************************************************************** +! ! +! ! +! Direct linear interpolations in vertical ! +! from reslution nm to resolution km ! +! ! +! ( nmax = 2*kmax-1 ) ! +! ! +!*********************************************************************** +(this,en,km_in,nm_in,imin,imax,jmin,jmax,F,W) +implicit none +!----------------------------------------------------------------------- +class(mg_intstate_type),target::this +integer(i_kind), intent(in):: en,km_in,nm_in,imin,imax,jmin,jmax +real(r_kind), dimension(1:km_in*en,imin:imax,jmin:jmax), intent(in):: F +real(r_kind), dimension(1:nm_in*en,imin:imax,jmin:jmax), intent(out):: W +integer(i_kind):: k,n,e,enm,ekm +!----------------------------------------------------------------------- +do e=0,en-1 + enm = e*nm_in + ekm = e*km_in + k=1 + do n=1,nm_in,2 + W(enm+n,:,:) =F (ekm+k,:,:) + k=k+1 + enddo + k=1 + do n=2,nm_in-1,2 + W(enm+n,:,:) = 0.5*(F(ekm+k,:,:)+F(ekm+k+1,:,:)) + k=k+1 + enddo +enddo +!----------------------------------------------------------------------- +endsubroutine l_vertical_direct_spec2 + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end submodule mg_interpolate diff --git a/src/mgbf/mg_intstate.f90 b/src/mgbf/mg_intstate.f90 new file mode 100644 index 0000000000..932084c705 --- /dev/null +++ b/src/mgbf/mg_intstate.f90 @@ -0,0 +1,1394 @@ +module mg_intstate +!$$$ submodule documentation block +! . . . . +! module: mg_intstate +! prgmmr: rancic org: NCEP/EMC date: 2020 +! +! abstract: Contains declarations and allocations of internal +! state variables use for filtering (offset version) +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! allocate_mg_intstate - +! def_mg_weights - +! init_mg_line - +! deallocate_mg_intstate - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +use kinds, only: r_kind,i_kind +use jp_pkind2, only: fpi +use jp_pbfil3, only: inimomtab,t22_to_3,tritform,t33_to_6,hextform +use mg_parameter,only: mg_parameter_type +implicit none +type,extends( mg_parameter_type):: mg_intstate_type +real(r_kind), allocatable,dimension(:,:,:):: V +! +! Composite control variable on first generation of filter grid +! +real(r_kind), allocatable,dimension(:,:,:):: VALL +! +! Composite control variable on high generations of filter grid +! +real(r_kind), allocatable,dimension(:,:,:):: HALL + +real(r_kind), allocatable,dimension(:,:,:):: a_diff_f +real(r_kind), allocatable,dimension(:,:,:):: a_diff_h +real(r_kind), allocatable,dimension(:,:,:):: b_diff_f +real(r_kind), allocatable,dimension(:,:,:):: b_diff_h + +! +! Localization weights +! +real(r_kind), allocatable,dimension(:,:,:):: w1_loc +real(r_kind), allocatable,dimension(:,:,:):: w2_loc +real(r_kind), allocatable,dimension(:,:,:):: w3_loc +real(r_kind), allocatable,dimension(:,:,:):: w4_loc + +real(r_kind), allocatable,dimension(:,:):: p_eps +real(r_kind), allocatable,dimension(:,:):: p_del +real(r_kind), allocatable,dimension(:,:):: p_sig +real(r_kind), allocatable,dimension(:,:):: p_rho + +real(r_kind), allocatable,dimension(:,:,:):: paspx +real(r_kind), allocatable,dimension(:,:,:):: paspy +real(r_kind), allocatable,dimension(:,:,:):: pasp1 +real(r_kind), allocatable,dimension(:,:,:,:):: pasp2 +real(r_kind), allocatable,dimension(:,:,:,:,:):: pasp3 + +real(r_kind), allocatable,dimension(:,:,:):: vpasp2 +real(r_kind), allocatable,dimension(:,:,:):: hss2 +real(r_kind), allocatable,dimension(:,:,:,:):: vpasp3 +real(r_kind), allocatable,dimension(:,:,:,:):: hss3 + +real(r_kind), allocatable,dimension(:):: ssx +real(r_kind), allocatable,dimension(:):: ssy +real(r_kind), allocatable,dimension(:):: ss1 +real(r_kind), allocatable,dimension(:,:):: ss2 +real(r_kind), allocatable,dimension(:,:,:):: ss3 + +integer(fpi), allocatable,dimension(:,:,:):: dixs +integer(fpi), allocatable,dimension(:,:,:):: diys +integer(fpi), allocatable,dimension(:,:,:):: dizs + +integer(fpi), allocatable,dimension(:,:,:,:):: dixs3 +integer(fpi), allocatable,dimension(:,:,:,:):: diys3 +integer(fpi), allocatable,dimension(:,:,:,:):: dizs3 + +integer(fpi), allocatable,dimension(:,:,:,:):: qcols + +integer(i_kind),allocatable,dimension(:):: iref,jref +integer(i_kind),allocatable,dimension(:):: irefq,jrefq +integer(i_kind),allocatable,dimension(:):: irefL,jrefL + +integer(i_kind),allocatable,dimension(:):: Lref,Lref_h +real(r_kind),allocatable,dimension(:):: cvf1,cvf2,cvf3,cvf4 +real(r_kind),allocatable,dimension(:):: cvh1,cvh2,cvh3,cvh4 + +real(r_kind),allocatable,dimension(:):: cx0,cx1,cx2,cx3 +real(r_kind),allocatable,dimension(:):: cy0,cy1,cy2,cy3 + +real(r_kind),allocatable,dimension(:):: qx0,qx1,qx2 +real(r_kind),allocatable,dimension(:):: qy0,qy1,qy2 + +real(r_kind),allocatable,dimension(:):: Lx0,Lx1 +real(r_kind),allocatable,dimension(:):: Ly0,Ly1 + +real(r_kind),allocatable,dimension(:):: p_coef,q_coef +real(r_kind),allocatable,dimension(:):: a_coef,b_coef + +real(r_kind),allocatable,dimension(:,:):: cf00,cf01,cf02,cf03 & + ,cf10,cf11,cf12,cf13 & + ,cf20,cf21,cf22,cf23 & + ,cf30,cf31,cf32,cf33 +contains + procedure :: allocate_mg_intstate,deallocate_mg_intstate + procedure :: def_mg_weights,init_mg_line +!from mg_interpolate.f90 + procedure :: def_offset_coef + procedure :: lsqr_mg_coef,lwq_vertical_coef + procedure :: lwq_vertical_direct,lwq_vertical_adjoint + procedure :: lwq_vertical_direct_spec,lwq_vertical_adjoint_spec + procedure :: l_vertical_direct_spec,l_vertical_adjoint_spec + procedure :: l_vertical_direct_spec2,l_vertical_adjoint_spec2 + procedure :: lsqr_direct_offset,lsqr_adjoint_offset + procedure :: quad_direct_offset,quad_adjoint_offset + procedure :: lin_direct_offset,lin_adjoint_offset +!from mg_bocos.f90 + generic :: boco_2d => boco_2d_g1,boco_2d_gh + procedure :: boco_2d_g1,boco_2d_gh + generic :: boco_3d => boco_3d_g1,boco_3d_gh + procedure :: boco_3d_g1,boco_3d_gh + generic :: bocoT_2d => bocoT_2d_g1,bocoT_2d_gh + procedure :: bocoT_2d_g1,bocoT_2d_gh + generic :: bocoTx => bocoTx_2d_g1,bocoTx_2d_gh + procedure :: bocoTx_2d_g1,bocoTx_2d_gh + generic :: bocoTy => bocoTy_2d_g1,bocoTy_2d_gh + procedure :: bocoTy_2d_g1,bocoTy_2d_gh + generic :: bocoT_3d => bocoT_3d_g1,bocoT_3d_gh + procedure :: bocoT_3d_g1,bocoT_3d_gh + generic :: bocox => bocox_2d_g1,bocox_2d_gh + procedure :: bocox_2d_g1,bocox_2d_gh + generic :: bocoy => bocoy_2d_g1,bocoy_2d_gh + procedure :: bocoy_2d_g1,bocoy_2d_gh + generic :: upsend_all => upsend_all_g1,upsend_all_gh + procedure :: upsend_all_g1,upsend_all_gh + generic :: downsend_all => downsend_all_g2,downsend_all_gh + procedure :: downsend_all_g2,downsend_all_gh + procedure :: boco_2d_loc + procedure :: bocoT_2d_loc + procedure :: upsend_loc_g12 + procedure :: upsend_loc_g23 + procedure :: upsend_loc_g34 + procedure :: downsend_loc_g43 + procedure :: downsend_loc_g32 + procedure :: downsend_loc_g21 +!from mg_generation.f90 + procedure:: upsending_all,downsending_all,weighting_all + procedure:: upsending,downsending + procedure:: upsending_highest,downsending_highest + procedure:: upsending2,downsending2 + procedure:: upsending_ens,downsending_ens + procedure:: upsending2_ens,downsending2_ens + procedure:: upsending_ens_nearest,downsending_ens_nearest + generic :: upsending_loc => upsending_loc_g3,upsending_loc_g4 + procedure:: upsending_loc_g3,upsending_loc_g4 + generic :: downsending_loc => downsending_loc_g3,downsending_loc_g4 + procedure:: downsending_loc_g3,downsending_loc_g4 + procedure:: weighting_helm,weighting,weighting_highest,weighting_ens + generic :: weighting_loc => weighting_loc_g3,weighting_loc_g4 + procedure:: weighting_loc_g3,weighting_loc_g4 + procedure:: adjoint,direct1 + procedure:: adjoint2,direct2 + procedure:: adjoint_nearest,direct_nearest + procedure:: adjoint_highest,direct_highest +!from mg_filtering.f90 + procedure :: filtering_procedure + procedure :: filtering_rad3,filtering_lin3 + procedure :: filtering_rad2_bkg,filtering_lin2_bkg,filtering_fast_bkg + procedure :: filtering_rad2_ens,filtering_lin2_ens,filtering_fast_ens + procedure :: filtering_rad_highest + procedure :: sup_vrbeta1T,sup_vrbeta1,sup_vrbeta3T,sup_vrbeta3 + procedure :: sup_vrbeta1_ens,sup_vrbeta1T_ens + procedure :: sup_vrbeta1_bkg,sup_vrbeta1T_bkg +!from mg_transfer.f90 + procedure :: anal_to_filt_allmap,filt_to_anal_allmap + procedure :: anal_to_filt_all,filt_to_anal_all + procedure :: anal_to_filt_all2,filt_to_anal_all2 + procedure :: composite_to_stack,stack_to_composite + procedure :: C2S_ens,S2C_ens + procedure :: anal_to_filt,filt_to_anal +!from mg_entrymod.f90 + procedure :: mg_initialize + procedure :: mg_finalize +end type mg_intstate_type +interface +!from mg_interpolate.f90 + module subroutine def_offset_coef(this) + class(mg_intstate_type),target::this + end subroutine + module subroutine lsqr_mg_coef(this) + class(mg_intstate_type),target::this + end subroutine + module subroutine lwq_vertical_coef & + (this,nm_in,im_in,c1,c2,c3,c4,iref_out) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: nm_in,im_in + real(r_kind), dimension(1:nm_in), intent(out):: c1,c2,c3,c4 + integer(i_kind), dimension(1:nm_in), intent(out):: iref_out + end subroutine + module subroutine lwq_vertical_direct & + (this,km_in,nm_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,f,w) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,nm_in,imin,imax,jmin,jmax + real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4 + integer(i_kind), dimension(1:nm_in), intent(in):: kref + real(r_kind), dimension(1:km_in,imin:imax,jmin:jmax), intent(in):: f + real(r_kind), dimension(1:nm_in,imin:imax,jmin:jmax), intent(out):: w + end subroutine + module subroutine lwq_vertical_adjoint & + (this,nm_in,km_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,w,f) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: nm_in,km_in,imin,imax,jmin,jmax + real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4 + integer(i_kind), dimension(1:nm_in), intent(in):: kref + real(r_kind), dimension(1:nm_in,imin:imax,jmin:jmax), intent(in):: w + real(r_kind), dimension(1:km_in,imin:imax,jmin:jmax), intent(out):: f + end subroutine + module subroutine lwq_vertical_direct_spec & + (this,km3_in,km_in,nm_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,F,W) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km3_in,km_in,nm_in,imin,imax,jmin,jmax + real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4 + integer(i_kind), dimension(1:nm_in), intent(in):: kref + real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(in):: F + real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(out):: W + end subroutine + module subroutine lwq_vertical_adjoint_spec & + (this,km3_in,nm_in,km_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,W,F) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km3_in,nm_in,km_in,imin,imax,jmin,jmax + real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4 + integer(i_kind), dimension(1:nm_in), intent(in):: kref + real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(in):: W + real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(out):: F + end subroutine + module subroutine l_vertical_direct_spec & + (this,km3_in,km_in,nm_in,imin,imax,jmin,jmax,F,W) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km3_in,km_in,nm_in,imin,imax,jmin,jmax + real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(in):: F + real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(out):: W + end subroutine + module subroutine l_vertical_adjoint_spec & + (this,km3_in,nm_in,km_in,imin,imax,jmin,jmax,W,F) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km3_in,nm_in,km_in,imin,imax,jmin,jmax + real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(in):: W + real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(out):: F + end subroutine + module subroutine l_vertical_direct_spec2 & + (this,en,km_in,nm_in,imin,imax,jmin,jmax,f,w) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: en,km_in,nm_in,imin,imax,jmin,jmax + real(r_kind), dimension(1:km_in*en,imin:imax,jmin:jmax), intent(in):: F + real(r_kind), dimension(1:nm_in*en,imin:imax,jmin:jmax), intent(out):: W + end subroutine + module subroutine l_vertical_adjoint_spec2 & + (this,en,nm_in,km_in,imin,imax,jmin,jmax,w,f) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: en,nm_in,km_in,imin,imax,jmin,jmax + real(r_kind), dimension(1:nm_in*en,imin:imax,jmin:jmax), intent(in):: W + real(r_kind), dimension(1:km_in*en,imin:imax,jmin:jmax), intent(out):: F + end subroutine + module subroutine lsqr_direct_offset & + (this,V_in,W,km_in,ibm,jbm) + implicit none + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: km_in,ibm,jbm + real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(in):: V_in + real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(out):: W + real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX + end subroutine + module subroutine lsqr_adjoint_offset & + (this,W,V_out,km_in,ibm,jbm) + implicit none + class(mg_intstate_type),target::this + integer(i_kind):: km_in,ibm,jbm + real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W + real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(out):: V_out + real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX + end subroutine + module subroutine quad_direct_offset & + (this,V_in,W,km_in,ibm,jbm) + implicit none + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: km_in,ibm,jbm + real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(in):: V_in + real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(out):: W + real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX + end subroutine + module subroutine quad_adjoint_offset & + (this,W,V_out,km_in,ibm,jbm) + implicit none + class(mg_intstate_type),target::this + integer(i_kind):: km_in,ibm,jbm + real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W + real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(out):: V_out + real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX + end subroutine + module subroutine lin_direct_offset & + (this,V_in,W,km_in,ibm,jbm) + implicit none + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: km_in,ibm,jbm + real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(in):: V_in + real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(out):: W + end subroutine + module subroutine lin_adjoint_offset & + (this,W,V_out,km_in,ibm,jbm) + implicit none + class(mg_intstate_type),target::this + integer(i_kind):: km_in,ibm,jbm + real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W + real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(out):: V_out + end subroutine +!from mg_bocos.f90 + module subroutine boco_2d_g1 & + (this,W,km_in,im_in,jm_in,nbx,nby) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby + real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + end subroutine + module subroutine boco_2d_gh & + (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max + real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine boco_3d_g1 & + (this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz + real(r_kind),dimension(km3_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine boco_3d_gh & + (this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in,mygen_min,mygen_max) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,mygen_min,mygen_max + real(r_kind),dimension(km3_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine bocoT_2d_g1 & + (this,W,km_in,im_in,jm_in,nbx,nby) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby + real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + end subroutine + module subroutine bocoT_2d_gh & + (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max + real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine bocoTx_2d_g1 & + (this,W,km_in,im_in,jm_in,nbx,nby) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby + real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + end subroutine + module subroutine bocoTx_2d_gh & + (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max + real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine bocoTy_2d_g1 & + (this,W,km_in,im_in,jm_in,nbx,nby) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby + real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + end subroutine + module subroutine bocoTy_2d_gh & + (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max + real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine bocoT_3d_g1 & + (this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz + real(r_kind), dimension(km3_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine bocoT_3d_gh & + (this,W,km_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in,mygen_min,mygen_max) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,Lm_in,nbx,nby,nbz,mygen_min,mygen_max + real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine bocox_2d_gh & + (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max + real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine bocox_2d_g1 & + (this,W,km_in,im_in,jm_in,nbx,nby) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby + real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + end subroutine + module subroutine bocoy_2d_g1 & + (this,W,km_in,im_in,jm_in,nbx,nby) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby + real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + end subroutine + module subroutine bocoy_2d_gh & + (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max + real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine upsend_all_g1 & + (this,Harray,Warray,km_in) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in + real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(in):: Harray + real(r_kind), dimension(km_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Warray + end subroutine + module subroutine upsend_all_gh & + (this,Harray,Warray,km_in,mygen_dn,mygen_up) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in + real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(in):: Harray + real(r_kind), dimension(km_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Warray + integer(i_kind),intent(in):: mygen_dn,mygen_up + end subroutine + module subroutine downsend_all_gh & + (this,Warray,Harray,km_in,mygen_up,mygen_dn) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in + real(r_kind), dimension(km_in,1:this%im,1:this%jm),intent(in):: Warray + real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(out):: Harray + integer, intent(in):: mygen_up,mygen_dn + end subroutine + module subroutine downsend_all_g2 & + (this,Warray,Harray,km_in) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in + real(r_kind), dimension(km_in,1:this%im,1:this%jm),intent(in):: Warray + real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(out):: Harray + end subroutine + module subroutine boco_2d_loc & + (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,g) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,g + real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine bocoT_2d_loc & + (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,g) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,g + real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine upsend_loc_g12 & + (this,V_in,H,km_4_in,flag) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_4_in,flag + real(r_kind), dimension(km_4_in,1:this%imL,1:this%jmL),intent(in):: V_in + real(r_kind), dimension(km_4_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + end subroutine + module subroutine upsend_loc_g23 & + (this,V_in,H,km_16_in,flag) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_16_in,flag + real(r_kind), dimension(km_16_in,1:this%imL,1:this%jmL),intent(in):: V_in + real(r_kind), dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + end subroutine + module subroutine upsend_loc_g34 & + (this,V_in,H,km_64_in,flag) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_64_in,flag + real(r_kind), dimension(km_64_in,1:this%imL,1:this%jmL),intent(in):: V_in + real(r_kind), dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + end subroutine + module subroutine downsend_loc_g43 & + (this,W,Z,km_64_in,flag) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_64_in,flag + real(r_kind), dimension(km_64_in,1:this%im,1:this%jm),intent(in):: W + real(r_kind), dimension(km_64_in,1:this%imL,1:this%jmL),intent(out):: Z + end subroutine + module subroutine downsend_loc_g32 & + (this,Z,H,km_16_in,flag) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_16_in,flag + real(r_kind), dimension(km_16_in,1:this%im,1:this%jm),intent(in):: Z + real(r_kind), dimension(km_16_in,1:this%imL,1:this%jmL),intent(out):: H + end subroutine + module subroutine downsend_loc_g21 & + (this,H,V_out,km_4_in,flag) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_4_in,flag + real(r_kind), dimension(km_4_in,1:this%im,1:this%jm),intent(in):: H + real(r_kind), dimension(km_4_in,1:this%imL,1:this%jmL),intent(out):: V_out + end subroutine +!from mg_generations.f90 + module subroutine upsending_all & + (this,V,H,lquart) + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + logical, intent(in):: lquart + end subroutine + module subroutine downsending_all & + (this,H,V,lquart) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + logical, intent(in):: lquart + end subroutine + module subroutine weighting_all & + (this,V,H,lhelm) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + logical, intent(in):: lhelm + end subroutine + module subroutine upsending & + (this,V,H) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: V_INT + real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: H_INT + end subroutine + module subroutine downsending & + (this,H,V) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + end subroutine + module subroutine upsending2 & + (this,V,H) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + end subroutine + module subroutine downsending2 & + (this,H,V) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + end subroutine + module subroutine upsending_highest & + (this,V,H) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + end subroutine + module subroutine downsending_highest & + (this,H,V) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + end subroutine + module subroutine upsending_ens & + (this,V,H,kmx) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind), intent(in):: kmx + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + end subroutine + module subroutine downsending_ens & + (this,H,V,kmx) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind), intent(in):: kmx + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + end subroutine + module subroutine upsending2_ens & + (this,V,H,kmx) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind), intent(in):: kmx + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + end subroutine + module subroutine downsending2_ens & + (this,H,V,kmx) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind), intent(in):: kmx + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + end subroutine + module subroutine upsending_ens_nearest & + (this,V,H,kmx) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind), intent(in):: kmx + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + end subroutine + module subroutine downsending_ens_nearest & + (this,H,V,kmx) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind), intent(in):: kmx + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + end subroutine + module subroutine upsending_loc_g3 & + (this,V,H,Z,km_in,km_4_in,km_16_in) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: km_in,km_4_in,km_16_in + real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V + real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Z + end subroutine + module subroutine upsending_loc_g4 & + (this,V,H,Z,W,km_in,km_4_in,km_16_in,km_64_in) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: km_in,km_4_in,km_16_in,km_64_in + real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V + real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Z + real(r_kind),dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: W + end subroutine + module subroutine downsending_loc_g3 & + (this,Z,H,V,km_in,km_4_in,km_16_in) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: km_in,km_4_in,km_16_in + real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: Z + real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + end subroutine + module subroutine downsending_loc_g4 & + (this,W,Z,H,V,km_in,km_4_in,km_16_in,km_64_in) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: km_in,km_4_in,km_16_in,km_64_in + real(r_kind),dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: W + real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: Z + real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + end subroutine + module subroutine weighting_helm & + (this,V,H) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + end subroutine + module subroutine weighting & + (this,V,H) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + end subroutine + module subroutine weighting_highest & + (this,H) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + end subroutine + module subroutine weighting_ens & + (this,V,H,kmx) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: kmx + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + end subroutine + module subroutine weighting_loc_g3 & + (this,V,H04,H16,km_in,km_4_in,km_16_in) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: km_in,km_4_in,km_16_in + real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H04 + real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H16 + end subroutine + module subroutine weighting_loc_g4 & + (this,V,H04,H16,H64,km_in,km_4_in,km_16_in,km_64_in) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: km_in,km_4_in,km_16_in,km_64_in + real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H04 + real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H16 + real(r_kind),dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H64 + end subroutine + module subroutine adjoint & + (this,F,W,km_in,g) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: g + integer(i_kind),intent(in):: km_in + real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(in):: F + real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(out):: W + end subroutine + module subroutine direct1 & + (this,W,F,km_in,g) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: g + integer(i_kind),intent(in):: km_in + real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(in):: W + real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(out):: F + end subroutine + module subroutine adjoint2 & + (this,F,W,km_in,g) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: g + integer(i_kind),intent(in):: km_in + real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(in):: F + real(r_kind), dimension(km_in,0:this%imL+1,0:this%jmL+1), intent(out):: W + end subroutine + module subroutine direct2 & + (this,W,F,km_in,g) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: g + integer(i_kind),intent(in):: km_in + real(r_kind), dimension(km_in,0:this%imL+1,0:this%jmL+1), intent(in):: W + real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(out):: F + end subroutine + module subroutine adjoint_nearest & + (this,F,W,km_in,g) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: g + integer(i_kind),intent(in):: km_in + real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(in):: F + real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(out):: W + end subroutine + module subroutine direct_nearest & + (this,W,F,km_in,g) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: g + integer(i_kind),intent(in):: km_in + real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(in):: W + real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(out):: F + end subroutine + module subroutine adjoint_highest & + (this,F,W,km_in,g) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: g + integer(i_kind),intent(in):: km_in + real(r_kind), dimension(km_in,1:this%im0(g),1:this%jm0(g)), intent(in):: F + real(r_kind), dimension(km_in,-1:this%im0(g+1)+2,-1:this%jm0(g+1)+2), intent(out):: W + end subroutine + module subroutine direct_highest & + (this,W,F,km_in,g) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: g + integer(i_kind),intent(in):: km_in + real(r_kind), dimension(km_in,-1:this%im0(g+1)+2,-1:this%jm0(g+1)+2), intent(in):: W + real(r_kind), dimension(km_in,1:this%im0(g),1:this%jm0(g)), intent(out):: F + end subroutine +!from mg_filtering + module subroutine filtering_procedure(this,mg_filt,mg_filt_flag) + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: mg_filt + integer(i_kind),intent(in):: mg_filt_flag + end subroutine + module subroutine filtering_rad3(this) + class(mg_intstate_type),target::this + end subroutine + module subroutine filtering_lin3(this) + class(mg_intstate_type),target::this + end subroutine + module subroutine filtering_rad2_bkg(this) + class(mg_intstate_type),target::this + end subroutine + module subroutine filtering_lin2_bkg(this) + class(mg_intstate_type),target::this + end subroutine + module subroutine filtering_fast_bkg(this) + class(mg_intstate_type),target::this + end subroutine + module subroutine filtering_rad2_ens(this,mg_filt_flag) + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: mg_filt_flag + end subroutine + module subroutine filtering_lin2_ens(this,mg_filt_flag) + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: mg_filt_flag + end subroutine + module subroutine filtering_fast_ens(this,mg_filt_flag) + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: mg_filt_flag + end subroutine + module subroutine filtering_rad_highest(this) + class(mg_intstate_type),target::this + end subroutine + module subroutine sup_vrbeta1 & + (this,kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) + implicit none + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm + real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V + real(r_kind),dimension(1,1,1:lm), intent(in):: pasp + real(r_kind),dimension(1:lm), intent(in):: ss + end subroutine + module subroutine sup_vrbeta1T & + (this,kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm + real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V + real(r_kind),dimension(1,1,1:lm), intent(in):: pasp + real(r_kind),dimension(1:lm), intent(in):: ss + end subroutine + module subroutine sup_vrbeta3 & + (this,kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm + real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V + real(r_kind),dimension(3,3,1:im,1:jm,1:lm), intent(in):: pasp + real(r_kind),dimension(1:im,1:jm,1:lm), intent(in):: ss + end subroutine + module subroutine sup_vrbeta3T & + (this,kmax,hx,hy,hz,im,jm,lm, pasp,ss,V) + implicit none + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm + real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V + real(r_kind),dimension(3,3,1:im,1:jm,1:lm), intent(in):: pasp + real(r_kind),dimension(1:im,1:jm,1:lm), intent(in):: ss + end subroutine + module subroutine sup_vrbeta1_ens & + (this,km_en,hx,hy,hz,im,jm,lm,pasp,ss,VALL) + implicit none + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: km_en,hx,hy,hz,im,jm,lm + real(r_kind),dimension(1:km_en*lm,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL + real(r_kind),dimension(1,1,1:lm), intent(in):: pasp + real(r_kind),dimension(1:lm), intent(in):: ss + end subroutine + module subroutine sup_vrbeta1T_ens & + (this,km_en,hx,hy,hz,im,jm,lm,pasp,ss,VALL) + implicit none + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: km_en,hx,hy,hz,im,jm,lm + real(r_kind),dimension(1:km_en*lm,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL + real(r_kind),dimension(1,1,1:lm), intent(in):: pasp + real(r_kind),dimension(1:lm), intent(in):: ss + end subroutine + module subroutine sup_vrbeta1_bkg & + (this,km,km3,hx,hy,hz,im,jm,lm,pasp,ss,VALL) + implicit none + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: km,km3,hx,hy,hz,im,jm,lm + real(r_kind),dimension(1:km,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL + real(r_kind),dimension(1,1,1:lm), intent(in):: pasp + real(r_kind),dimension(1:lm), intent(in):: ss + end subroutine + module subroutine sup_vrbeta1T_bkg & + (this,km,km3,hx,hy,hz,im,jm,lm,pasp,ss,VALL) + implicit none + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: km,km3,hx,hy,hz,im,jm,lm + real(r_kind),dimension(1:km,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL + real(r_kind),dimension(1,1,1:lm), intent(in):: pasp + real(r_kind),dimension(1:lm), intent(in):: ss + end subroutine +!from mg_transfer.f90 + module subroutine anal_to_filt_allmap(this,WORKA) + class(mg_intstate_type),target::this + real (r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm) + end subroutine + module subroutine filt_to_anal_allmap(this,WORKA) + class(mg_intstate_type),target::this + real (r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm) + end subroutine + module subroutine anal_to_filt_all(this,WORKA) + class(mg_intstate_type),target::this + real (r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm) + end subroutine + module subroutine filt_to_anal_all(this,WORKA) + class(mg_intstate_type),target::this + real (r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm) + end subroutine + module subroutine anal_to_filt_all2(this,WORKA) + class(mg_intstate_type),target::this + real (r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm) + end subroutine + module subroutine filt_to_anal_all2(this,WORKA) + class(mg_intstate_type),target::this + real (r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm) + end subroutine + module subroutine stack_to_composite(this,ARR_ALL,A2D,A3D) + class(mg_intstate_type),target::this + real(r_kind),dimension(this%km ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy), intent(in):: ARR_ALL + real(r_kind),dimension(this%km3,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,this%lm),intent(out):: A3D + real(r_kind),dimension(this%km2,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy) ,intent(out):: A2D + end subroutine + module subroutine composite_to_stack(this,A2D,A3D,ARR_ALL) + class(mg_intstate_type),target::this + real(r_kind),dimension(this%km2,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy), intent(in):: A2D + real(r_kind),dimension(this%km3,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,this%lm),intent(in):: A3D + real(r_kind),dimension(this%km ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy), intent(out):: ARR_ALL + end subroutine + module subroutine S2C_ens(this,ARR_ALL,A3D,imn,imx,jmn,jmx,lmx,kmx,kmx_all) + class(mg_intstate_type),target::this + integer, intent(in):: imn,imx,jmn,jmx,lmx,kmx,kmx_all + real(r_kind),dimension(kmx_all,imn:imx,jmn:jmx) ,intent(in):: ARR_ALL + real(r_kind),dimension(this%km3_all,imn:imx,jmn:jmx,lmx),intent(out):: A3D + end subroutine + module subroutine C2S_ens(this,A3D,ARR_ALL,imn,imx,jmn,jmx,lmx,kmx,kmx_all) + class(mg_intstate_type),target::this + integer, intent(in):: imn,imx,jmn,jmx,lmx,kmx,kmx_all + real(r_kind),dimension(this%km3_all,imn:imx,jmn:jmx,lmx),intent(in):: A3D + real(r_kind),dimension(kmx_all,imn:imx,jmn:jmx) ,intent(out):: ARR_ALL + end subroutine + module subroutine anal_to_filt(this,WORK) + class(mg_intstate_type),target::this + real (r_kind):: WORK(this%km_all,1:this%nm,1:this%mm) + end subroutine + module subroutine filt_to_anal(this,WORK) + class(mg_intstate_type),target::this + real (r_kind):: WORK(this%km_all,1:this%nm,1:this%mm) + end subroutine +!from mg_entrymod.f90 + module subroutine mg_initialize(this,inputfilename,obj_parameter) + class (mg_intstate_type):: this + character*(*),optional,intent(in) :: inputfilename + class(mg_parameter_type),optional,intent(in)::obj_parameter + end subroutine + module subroutine mg_finalize(this) + implicit none + class (mg_intstate_type)::this + end subroutine +end interface + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +contains +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +subroutine allocate_mg_intstate(this) +!*********************************************************************** +! ! +! Allocate internal state variables ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this + +if(this%l_loc) then + allocate(this%w1_loc(this%km_all ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%w1_loc=0. + allocate(this%w2_loc(this%km_all/4 ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%w2_loc=0. + allocate(this%w3_loc(this%km_all/16,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%w3_loc=0. + allocate(this%w4_loc(this%km_all/64,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%w4_loc=0. +endif + +allocate(this%V(1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,this%lm)) ; this%V=0. +allocate(this%VALL(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%VALL=0. +allocate(this%HALL(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%HALL=0. + +allocate(this%a_diff_f(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%a_diff_f=0. +allocate(this%a_diff_h(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%a_diff_h=0. +allocate(this%b_diff_f(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%b_diff_f=0. +allocate(this%b_diff_h(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%b_diff_h=0. + +allocate(this%p_eps(1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%p_eps=0. +allocate(this%p_del(1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%p_del=0. +allocate(this%p_sig(1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%p_sig=0. +allocate(this%p_rho(1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%p_rho=0. + +allocate(this%paspx(1,1,1:this%im)) ; this%paspx=0. +allocate(this%paspy(1,1,1:this%jm)) ; this%paspy=0. + +allocate(this%pasp1(1,1,1:this%lm)) ; this%pasp1=0. +allocate(this%pasp2(2,2,1:this%im,1:this%jm)) ; this%pasp2=0. +allocate(this%pasp3(3,3,1:this%im,1:this%jm,1:this%lm)) ; this%pasp3=0. + +allocate(this%vpasp2(0:2,1:this%im,1:this%jm)) ; this%vpasp2=0. +allocate(this%hss2(1:this%im,1:this%jm,1:3)) ; this%hss2=0. + +allocate(this%vpasp3(1:6,1:this%im,1:this%jm,1:this%lm)) ; this%vpasp3=0. +allocate(this%hss3(1:this%im,1:this%jm,1:this%lm,1:6)) ; this%hss3=0. + +allocate(this%ssx(1:this%im)) ; this%ssx=0. +allocate(this%ssy(1:this%jm)) ; this%ssy=0. +allocate(this%ss1(1:this%lm)) ; this%ss1=0. +allocate(this%ss2(1:this%im,1:this%jm)) ; this%ss2=0. +allocate(this%ss3(1:this%im,1:this%jm,1:this%lm)) ; this%ss3=0. + +allocate(this%dixs(1:this%im,1:this%jm,3)) ; this%dixs=0 +allocate(this%diys(1:this%im,1:this%jm,3)) ; this%diys=0 + +allocate(this%dixs3(1:this%im,1:this%jm,1:this%lm,6)) ; this%dixs3=0 +allocate(this%diys3(1:this%im,1:this%jm,1:this%lm,6)) ; this%diys3=0 +allocate(this%dizs3(1:this%im,1:this%jm,1:this%lm,6)) ; this%dizs3=0 + +allocate(this%qcols(0:7,1:this%im,1:this%jm,1:this%lm)) ; this%qcols=0 + +! +! for re-decomposition +! + +allocate(this%iref(1:this%nm)) ; this%iref=0 +allocate(this%jref(1:this%mm)) ; this%jref=0 + +allocate(this%irefq(1:this%nm)) ; this%irefq=0 +allocate(this%jrefq(1:this%mm)) ; this%jrefq=0 + +allocate(this%irefL(1:this%nm)) ; this%irefL=0 +allocate(this%jrefL(1:this%mm)) ; this%jrefL=0 + +allocate(this%cx0(1:this%nm)) ; this%cx0=0. +allocate(this%cx1(1:this%nm)) ; this%cx1=0. +allocate(this%cx2(1:this%nm)) ; this%cx2=0. +allocate(this%cx3(1:this%nm)) ; this%cx3=0. + +allocate(this%cy0(1:this%mm)) ; this%cy0=0. +allocate(this%cy1(1:this%mm)) ; this%cy1=0. +allocate(this%cy2(1:this%mm)) ; this%cy2=0. +allocate(this%cy3(1:this%mm)) ; this%cy3=0. + +allocate(this%qx0(1:this%nm)) ; this%qx0=0. +allocate(this%qx1(1:this%nm)) ; this%qx1=0. +allocate(this%qx2(1:this%nm)) ; this%qx2=0. + +allocate(this%qy0(1:this%mm)) ; this%qy0=0. +allocate(this%qy1(1:this%mm)) ; this%qy1=0. +allocate(this%qy2(1:this%mm)) ; this%qy2=0. + +allocate(this%Lx0(1:this%nm)) ; this%Lx0=0. +allocate(this%Lx1(1:this%nm)) ; this%Lx1=0. + +allocate(this%Ly0(1:this%mm)) ; this%Ly0=0. +allocate(this%Ly1(1:this%mm)) ; this%Ly1=0. + +allocate(this%p_coef(4)) ; this%p_coef=0. +allocate(this%q_coef(4)) ; this%q_coef=0. + +allocate(this%a_coef(3)) ; this%a_coef=0. +allocate(this%b_coef(3)) ; this%b_coef=0. + +allocate(this%cf00(1:this%nm,1:this%mm)) ; this%cf00=0. +allocate(this%cf01(1:this%nm,1:this%mm)) ; this%cf01=0. +allocate(this%cf02(1:this%nm,1:this%mm)) ; this%cf02=0. +allocate(this%cf03(1:this%nm,1:this%mm)) ; this%cf03=0. +allocate(this%cf10(1:this%nm,1:this%mm)) ; this%cf10=0. +allocate(this%cf11(1:this%nm,1:this%mm)) ; this%cf11=0. +allocate(this%cf12(1:this%nm,1:this%mm)) ; this%cf12=0. +allocate(this%cf13(1:this%nm,1:this%mm)) ; this%cf13=0. +allocate(this%cf20(1:this%nm,1:this%mm)) ; this%cf20=0. +allocate(this%cf21(1:this%nm,1:this%mm)) ; this%cf21=0. +allocate(this%cf22(1:this%nm,1:this%mm)) ; this%cf22=0. +allocate(this%cf23(1:this%nm,1:this%mm)) ; this%cf23=0. +allocate(this%cf30(1:this%nm,1:this%mm)) ; this%cf30=0. +allocate(this%cf31(1:this%nm,1:this%mm)) ; this%cf31=0. +allocate(this%cf32(1:this%nm,1:this%mm)) ; this%cf32=0. +allocate(this%cf33(1:this%nm,1:this%mm)) ; this%cf33=0. + +allocate(this%Lref(1:this%lm_a)) ; this%Lref=0 +allocate(this%Lref_h(1:this%lm)) ; this%Lref_h=0 + +allocate(this%cvf1(1:this%lm_a)) ; this%cvf1=0. +allocate(this%cvf2(1:this%lm_a)) ; this%cvf2=0. +allocate(this%cvf3(1:this%lm_a)) ; this%cvf3=0. +allocate(this%cvf4(1:this%lm_a)) ; this%cvf4=0. + +allocate(this%cvh1(1:this%lm)) ; this%cvh1=0. +allocate(this%cvh2(1:this%lm)) ; this%cvh2=0. +allocate(this%cvh3(1:this%lm)) ; this%cvh3=0. +allocate(this%cvh4(1:this%lm)) ; this%cvh4=0. + +!----------------------------------------------------------------------- +endsubroutine allocate_mg_intstate + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +subroutine def_mg_weights(this) +!*********************************************************************** +! ! +! Define weights and scales ! +! ! +implicit none +class (mg_intstate_type),target::this +!*********************************************************************** +integer(i_kind):: i,j,L +real(r_kind):: gen_fac +!----------------------------------------------------------------------- + +this%p_eps(:,:)=0.0 +this%p_del(:,:)=0.0 +this%p_sig(:,:)=0.0 +this%p_rho(:,:)=0.0 + +!-------------------------------------------------------- +! +! For localization (for now) +! +if(this%l_loc) then + this%w1_loc(:,:,:)=this%mg_weig1 + this%w2_loc(:,:,:)=this%mg_weig2 + this%w3_loc(:,:,:)=this%mg_weig3 + this%w4_loc(:,:,:)=this%mg_weig4 +endif +!-------------------------------------------------------- +gen_fac=1. +this%a_diff_f(:,:,:)=this%mg_weig1 +this%a_diff_h(:,:,:)=this%mg_weig1 + +this%b_diff_f(:,:,:)=0. +this%b_diff_h(:,:,:)=0. + +select case(this%my_hgen) +case(2) + this%a_diff_h(:,:,:)=this%mg_weig2 +case(3) + this%a_diff_h(:,:,:)=this%mg_weig3 +case default + this%a_diff_h(:,:,:)=this%mg_weig4 +end select + +do L=1,this%lm + this%pasp1(1,1,L)=this%pasp01 +enddo + +do i=1,this%im + this%paspx(1,1,i)=this%pasp02 +enddo +do j=1,this%jm + this%paspy(1,1,j)=this%pasp02 +enddo + +do j=1,this%jm +do i=1,this%im + this%pasp2(1,1,i,j)=this%pasp02*(1.+this%p_del(i,j)) + this%pasp2(2,2,i,j)=this%pasp02*(1.-this%p_del(i,j)) + this%pasp2(1,2,i,j)=this%pasp02*this%p_eps(i,j) + this%pasp2(2,1,i,j)=this%pasp02*this%p_eps(i,j) +end do +end do + +do L=1,this%lm + do j=1,this%jm + do i=1,this%im + this%pasp3(1,1,i,j,l)=this%pasp03*(1+this%p_del(i,j)) + this%pasp3(2,2,i,j,l)=this%pasp03 + this%pasp3(3,3,i,j,l)=this%pasp03*(1-this%p_del(i,j)) + this%pasp3(1,2,i,j,l)=this%pasp03*this%p_eps(i,j) + this%pasp3(2,1,i,j,l)=this%pasp03*this%p_eps(i,j) + this%pasp3(2,3,i,j,l)=this%pasp03*this%p_sig(i,j) + this%pasp3(3,2,i,j,l)=this%pasp03*this%p_sig(i,j) + this%pasp3(1,3,i,j,l)=this%pasp03*this%p_rho(i,j) + this%pasp3(3,1,i,j,l)=this%pasp03*this%p_rho(i,j) + end do + end do +end do + + +if(.not.this%mgbf_line) then + if(this%nxm*this%nym>1) then + if(this%l_loc) then + if(this%l_vertical_filter) then + call this%cholaspect(1,this%lm,this%pasp1) + call this%getlinesum(this%hz,1,this%lm,this%pasp1,this%ss1) + do L=1,this%lm + this%VALL(L,2,1)=1. + call this%sup_vrbeta1T_ens(1,0,0,this%hz,1,1,this%lm,this%pasp1,this%ss1,this%VALL(1:this%lm,2,1)) + call this%sup_vrbeta1_ens(1,0,0,this%hz,1,1,this%lm,this%pasp1,this%ss1,this%VALL(1:this%lm,2,1)) + this%VALL(L,1,1)=sqrt(this%VALL(L,2,1)) + this%VALL(1:this%lm,2,1)=0. + enddo + this%ss1(1:this%lm)=this%ss1(1:this%lm)/this%VALL(1:this%lm,1,1) + this%VALL(1:this%lm,1,1)=0. + endif + call this%cholaspect(1,this%im,1,this%jm,this%pasp2) + call this%getlinesum(this%hx,1,this%im,this%hy,1,this%jm,this%pasp2,this%ss2) + this%VALL(1,this%im/2,this%jm/2)=1. + call this%rbetaT(this%hx,1,this%im,this%hy,1,this%jm,this%pasp2,this%ss2,this%VALL(1,:,:)) + call this%rbeta(this%hx,1,this%im,this%hy,1,this%jm,this%pasp2,this%ss2,this%VALL(1,:,:)) + this%ss2=this%ss2/sqrt(this%VALL(1,this%im/2,this%jm/2)) + this%VALL(1,:,:)=0. + call this%cholaspect(1,this%im,this%paspx) + call this%getlinesum(this%hx,1,this%im,this%paspx,this%ssx) + this%VALL(1,this%im/2,1)=1. + call this%rbetaT(this%hx,1,this%im,this%paspx,this%ssx,this%VALL(1,:,1)) + call this%rbeta(this%hx,1,this%im,this%paspx(1,1,:),this%ssx,this%VALL(1,:,1)) + this%ssx=this%ssx/sqrt(this%VALL(1,this%im/2,1)) + this%VALL(1,:,1)=0. + call this%cholaspect(1,this%jm,this%paspy) + call this%getlinesum(this%hy,1,this%jm,this%paspy,this%ssy) + this%VALL(1,1,this%jm/2)=1. + call this%rbetaT(this%hy,1,this%jm,this%paspy,this%ssy,this%VALL(1,1,:)) + call this%rbeta(this%hy,1,this%jm,this%paspy(1,1,:),this%ssy,this%VALL(1,1,:)) + this%ssy=this%ssy/sqrt(this%VALL(1,1,this%jm/2)) + this%VALL(1,1,:)=0. + else + call this%cholaspect(1,this%lm,this%pasp1) + call this%cholaspect(1,this%im,1,this%jm,this%pasp2) + call this%cholaspect(1,this%im,1,this%jm,1,this%lm,this%pasp3) + call this%getlinesum(this%hx,1,this%im,this%paspx,this%ssx) + call this%getlinesum(this%hy,1,this%jm,this%paspy,this%ssy) + call this%getlinesum(this%hz,1,this%lm,this%pasp1,this%ss1) + call this%getlinesum(this%hx,1,this%im,this%hy,1,this%jm,this%pasp2,this%ss2) + call this%getlinesum(this%hx,1,this%im,this%hy,1,this%jm,this%hz,1,this%lm,this%pasp3,this%ss3) + end if + else + call this%cholaspect(1,this%imH,1,this%jmH,& + &this%pasp2(:,:,1:this%imH,1:this%jmH)) + call this%getlinesum(this%hx,1,this%imH,this%hy,1,this%jmH,& + &this%pasp2(:,:,1:this%imH,1:this%jmH),this%ss2(1:this%imH,1:this%jmH)) + this%VALL(1,this%imH/2,this%jmH/2)=1. + call this%rbetaT(this%hx,1,this%imH,this%hy,1,this%jmH,& + &this%pasp2(:,:,1:this%imH,1:this%jmH),this%ss2(1:this%imH,1:this%jmH),& + &this%VALL(1,1-this%hx:this%imH+this%hx,1-this%hy:this%jmH+this%hy)) + call this%rbeta(this%hx,1,this%imH,this%hy,1,this%jmH,& + &this%pasp2(:,:,1:this%imH,1:this%jmH),this%ss2(1:this%imH,1:this%jmH),& + &this%VALL(1,1-this%hx:this%imH+this%hx,1-this%hy:this%jmH+this%hy)) + this%ss2=this%ss2/sqrt(this%VALL(1,this%imH/2,this%jmH/2)) + this%VALL(1,1-this%hx:this%imH+this%hx,1-this%hy:this%jmH+this%hy)=0. + end if +end if +!----------------------------------------------------------------------- +endsubroutine def_mg_weights + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +subroutine init_mg_line(this) +implicit none +class(mg_intstate_type),target::this +integer(i_kind):: i,j,L,icol +logical:: ff +!*********************************************************************** +! ! +! Inititate line filters ! +! ! +!*********************************************************************** +!----------------------------------------------------------------------- + +do j=1,this%jm +do i=1,this%im + call t22_to_3(this%pasp2(:,:,i,j),this%vpasp2(:,i,j)) +enddo +enddo + +do l=1,this%lm +do j=1,this%jm +do i=1,this%im + call t33_to_6(this%pasp3(:,:,i,j,l),this%vpasp3(:,i,j,l)) +enddo +enddo +enddo + +call inimomtab(this%p,this%nh,ff) + +call tritform(1,this%im,1,this%jm,this%vpasp2, this%dixs,this%diys, ff) + +do icol=1,3 + this%hss2(:,:,icol)=this%vpasp2(icol-1,:,:) +enddo + +call hextform(1,this%im,1,this%jm,1,this%lm,this%vpasp3,this%qcols,this%dixs3,this%diys3,this%dizs3, ff) + +do icol=1,6 + this%hss3(:,:,:,icol)=this%vpasp3(icol,:,:,:) +enddo + +!----------------------------------------------------------------------- +endsubroutine init_mg_line + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +subroutine deallocate_mg_intstate(this) +implicit none +class (mg_intstate_type),target:: this +!*********************************************************************** +! ! +! Deallocate internal state variables ! +! ! +!*********************************************************************** + +deallocate(this%V) + +deallocate(this%HALL,this%VALL) + +deallocate(this%a_diff_f,this%b_diff_f) +deallocate(this%a_diff_h,this%b_diff_h) +deallocate(this%p_eps,this%p_del,this%p_sig,this%p_rho,this%pasp1,this%pasp2,this%pasp3,this%ss1,this%ss2,this%ss3) +deallocate(this%dixs,this%diys) +deallocate(this%dixs3,this%diys3,this%dizs3) +deallocate(this%qcols) + +! +! for re-decomposition +! +deallocate(this%iref,this%jref) +deallocate(this%irefq,this%jrefq) +deallocate(this%irefL,this%jrefL) + +deallocate(this%cf00,this%cf01,this%cf02,this%cf03,this%cf10,this%cf11,this%cf12,this%cf13) +deallocate(this%cf20,this%cf21,this%cf22,this%cf23,this%cf30,this%cf31,this%cf32,this%cf33) + +deallocate(this%Lref,this%Lref_h) + +deallocate(this%cvf1,this%cvf2,this%cvf3,this%cvf4) + +deallocate(this%cvh1,this%cvh2,this%cvh3,this%cvh4) + +deallocate(this%cx0,this%cx1,this%cx2,this%cx3) +deallocate(this%cy0,this%cy1,this%cy2,this%cy3) + +deallocate(this%qx0,this%qx1,this%qx2) +deallocate(this%qy0,this%qy1,this%qy2) + +deallocate(this%Lx0,this%Lx1) +deallocate(this%Ly0,this%Ly1) + +deallocate(this%p_coef,this%q_coef) +deallocate(this%a_coef,this%b_coef) + +if(this%l_loc) then + deallocate(this%w1_loc,this%w2_loc,this%w3_loc,this%w4_loc) +endif + +end subroutine deallocate_mg_intstate + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end module mg_intstate diff --git a/src/mgbf/mg_mppstuff.f90 b/src/mgbf/mg_mppstuff.f90 new file mode 100644 index 0000000000..e1d24b180c --- /dev/null +++ b/src/mgbf/mg_mppstuff.f90 @@ -0,0 +1,190 @@ +submodule(mg_parameter) mg_mppstuff +!$$$ submodule documentation block +! . . . . +! module: mg_mppstuff +! prgmmr: rancic org: NCEP/EMC date: 2020 +! +! abstract: Everything related to mpi communication +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! init_mg_MPI - +! barrierMPI - +! finishMPI - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use kinds, only: i_kind +implicit none + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +contains +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine init_mg_MPI(this) +!*********************************************************************** +! ! +! Initialize mpi ! +! Create group for filter grid ! +! ! +!*********************************************************************** +use mpi + +implicit none +class (mg_parameter_type),target:: this +integer(i_kind):: g,m +integer(i_kind), dimension(this%npes_filt):: out_ranks +integer(i_kind):: nf +integer(i_kind)::ierr +integer(i_kind):: color +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" +!----------------------------------------------------------------------- + +!*** +!*** Initial MPI calls +!*** + call MPI_COMM_RANK(MPI_COMM_WORLD,mype,ierr) + call MPI_COMM_SIZE(MPI_COMM_WORLD,npes,ierr) +! call MPI_Barrier(MPI_COMM_WORLD, ierr) + + ! Create a new communicator with MPI_Comm_split + color=1 ! just create an communicator now for the whole processes + call MPI_Comm_split(MPI_COMM_WORLD, color, mype, mpi_comm_comp, ierr) + call MPI_COMM_SIZE(mpi_comm_comp,npes,ierr) + + rTYPE = MPI_REAL + dTYPE = MPI_DOUBLE + iTYPE = MPI_INTEGER + +!*** +!*** Analysis grid +!*** + + nx = mod(mype,nxm)+1 + my = (mype/nxm)+1 + +!*** +!*** Define PEs that handle high generations +!*** + + mype_hgen=-1 + my_hgen=-1 + + if( mype < maxpe_filt-nxy(1)) then + mype_hgen=mype+nxy(1) + endif + do g=1,gm + if(maxpe_fgen(g-1)<= mype_hgen .and. mype_hgen< maxpe_fgen(g)) then + my_hgen=g + endif + enddo + l_hgen = mype_hgen >-1 + +!*** +!*** Chars +!*** + write(c_mype,1000) mype + 1000 format(i5.5) + +!----------------------------------------------------------------------- +! + call MPI_BARRIER(mpi_comm_comp,ierr) +! +!----------------------------------------------------------------------- +!*** +!*** Define group communicator for higher generations +!*** +! +! Associate a group with communicator this@mpi_comm_comp +! + call MPI_COMM_GROUP(mpi_comm_comp,group_world,ierr) +! +! Create a new group out of exising group +! + do nf = 1,npes_filt + out_ranks(nf)=nf-1 + enddo + + call MPI_GROUP_INCL(group_world,npes_filt,out_ranks,group_work,ierr) +! +! Now create a new communicator associated with new group +! + call MPI_COMM_CREATE(mpi_comm_comp, group_work, mpi_comm_work, ierr) + + if( mype < npes_filt) then + + call MPI_COMM_RANK(mpi_comm_work,mype_gr,ierr) + call MPI_COMM_SIZE(mpi_comm_work,npes_gr,ierr) + + else + + mype_gr= -1 + npes_gr= npes_filt + + endif + +!----------------------------------------------------------------------- +! + call MPI_BARRIER(mpi_comm_comp,ierr) +! +!----------------------------------------------------------------------- +endsubroutine init_mg_MPI + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine barrierMPI(this) +!*********************************************************************** +! ! +! Call barrier for all ! +! ! +!*********************************************************************** +use mpi + +implicit none +class(mg_parameter_type),target::this +integer(i_kind):: ierr +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" +!----------------------------------------------------------------------- + + call MPI_BARRIER(mpi_comm_comp,ierr) + +!----------------------------------------------------------------------- +endsubroutine barrierMPI + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine finishMPI(this) +!*********************************************************************** +! ! +! Finalize MPI ! +! ! +!*********************************************************************** +use mpi + +implicit none +class(mg_parameter_type),target::this +! +! don't need mpi_finalize if mgbf is a lib to be called from outside +! + call MPI_FINALIZE(this%ierr) + stop +! +!----------------------------------------------------------------------- +endsubroutine finishMPI + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end submodule mg_mppstuff + diff --git a/src/mgbf/mg_parameter.f90 b/src/mgbf/mg_parameter.f90 new file mode 100644 index 0000000000..f08b87aab3 --- /dev/null +++ b/src/mgbf/mg_parameter.f90 @@ -0,0 +1,936 @@ +module mg_parameter +!$$$ submodule documentation block +! . . . . +! module: mg_parameter +! prgmmr: rancic org: NCEP/EMC date: 2022 +! +! abstract: Set resolution, grid and decomposition (offset version) +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! init_mg_parameter - +! def_maxgen - +! def_ngens - +! +! Functions Included: +! +! remarks: +! ixm(1)=nxm, jym(1)=nym +! If mod(nxm,2)=0 then mod(im0,2)=0 +! If mod(nxm,2)>0 then mod(im0,8)=0 (for 4 generations) +! (This will keep the right boundary of all decompmisitions +! at same physical location) +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use kinds, only: i_kind,r_kind +use jp_pietc, only: u1 + +implicit none +type:: mg_parameter_type +!----------------------------------------------------------------------- +!*** +!*** Namelist parameters +!*** +real(r_kind):: mg_ampl01,mg_ampl02,mg_ampl03 +real(r_kind):: mg_weig1,mg_weig2,mg_weig3,mg_weig4 +integer(i_kind):: mgbf_proc !1-2: 3D filter (1: radial, 2: line) + !3-5: 2D filter for static B (3: radial, 4: line, 5: isotropic line) + !6-8: 2D filter for localization (6: radial, 7: line, 8: isotropic line) +logical:: mgbf_line +integer(i_kind):: nxPE,nyPE,im_filt,jm_filt +logical:: lquart,lhelm + +!*** +!*** Number of generations +!*** +integer(i_kind):: gm +integer(i_kind):: gm_max + +!*** +!*** Horizontal resolution +!*** + +! +! Original number of data on GSI analysis grid +! +integer(i_kind):: nA_max0 +integer(i_kind):: mA_max0 + +! +! Global number of data on Analysis grid +! +integer(i_kind):: nm0 +integer(i_kind):: mm0 + +! +! Number of PEs on Analysis grid +! +integer(i_kind):: nxm +integer(i_kind):: nym + +! +! Number of data on local Analysis grid +! +integer(i_kind):: nm +integer(i_kind):: mm + +! +! Number of data on global Filter grid +! +integer(i_kind):: im00 +integer(i_kind):: jm00 + +! +! Number of data on local Filter grid +! +integer(i_kind):: im +integer(i_kind):: jm + +! +! Initial index on local Filter grid +! +integer(i_kind):: i0 +integer(i_kind):: j0 +! +! Initial index on local analysis grid +! +integer(i_kind):: n0 +integer(i_kind):: m0 + +! +! Halo on local Filter grid +! +integer(i_kind):: ib +integer(i_kind):: jb + +! +! Halo on local Analysis grid +! +integer(i_kind):: nb +integer(i_kind):: mb + +integer(i_kind):: hx,hy,hz +integer(i_kind):: p +integer(i_kind):: nh,nfil +real(r_kind):: pasp01,pasp02,pasp03 +real(r_kind):: pee2,rmom2_1,rmom2_2,rmom2_3,rmom2_4 + +integer, allocatable, dimension(:):: maxpe_fgen +integer, allocatable, dimension(:):: ixm,jym,nxy +integer, allocatable, dimension(:):: im0,jm0 +integer, allocatable, dimension(:):: Fimax,Fjmax +integer, allocatable, dimension(:):: FimaxL,FjmaxL + +integer(i_kind):: npes_filt +integer(i_kind):: maxpe_filt + +integer(i_kind):: imL,jmL +integer(i_kind):: imH,jmH +integer(i_kind):: lm_a ! number of vertical layers in analysis fields +integer(i_kind):: lm ! number of vertical layers in filter grids +integer(i_kind):: km2 ! number of 2d variables for filtering +integer(i_kind):: km3 ! number of 3d variables for filtering +integer(i_kind):: n_ens ! number of ensemble members +integer(i_kind):: km_a ! total number of horizontal levels for analysis +integer(i_kind):: km_all ! total number of k levels of ensemble for filtering +integer(i_kind):: km_a_all ! total number of k levels of ensemble +integer(i_kind):: km2_all ! total number of k horizontal levels of ensemble for filtering +integer(i_kind):: km3_all ! total number of k vertical levels of ensemble +logical :: l_loc ! logical flag for localization +logical :: l_filt_g1 ! logical flag for filtering of generation one +logical :: l_lin_vertical ! logical flag for linear interpolation in vertcial +logical :: l_lin_horizontal ! logical flag for linear interpolation in horizontal +logical :: l_quad_horizontal ! logical flag for quadratic interpolation in horizontal +logical :: l_new_map ! logical flag for new mapping between analysis and filter grid +logical :: l_vertical_filter ! logical flag for vertical filtering +integer(i_kind):: km ! number of vertically stacked all variables (km=km2+lm*km3) +integer(i_kind):: km_4 +integer(i_kind):: km_16 +integer(i_kind):: km_64 + +real(r_kind):: lengthx,lengthy,xa0,ya0,xf0,yf0 +real(r_kind):: dxf,dyf,dxa,dya + +integer(i_kind):: npadx ! x padding on analysis grid +integer(i_kind):: mpady ! y padding on analysis grid + +integer(i_kind):: ipadx ! x padding on filter decomposition +integer(i_kind):: jpady ! y padding on filter deocmposition + +! +! Just for standalone test +! +logical:: ldelta + +!from mg_mppstuff.f90 +character(len=5):: c_mype +integer(i_kind):: mype +integer(i_kind):: npes,iTYPE,rTYPE,dTYPE,mpi_comm_comp,ierr,ierror +integer(i_kind):: mpi_comm_work,group_world,group_work +integer(i_kind):: mype_gr,npes_gr +integer(i_kind):: my_hgen +integer(i_kind):: mype_hgen +logical:: l_hgen +integer(i_kind):: nx,my +!from mg_domain.f90 +logical,dimension(2):: Flwest,Fleast,Flnorth,Flsouth +integer(i_kind),dimension(2):: Fitarg_n,Fitarg_e,Fitarg_s,Fitarg_w +integer(i_kind),dimension(2):: Fitarg_sw,Fitarg_se,Fitarg_ne,Fitarg_nw +logical,dimension(2):: Flsendup_sw,Flsendup_se,Flsendup_nw,Flsendup_ne +integer(i_kind),dimension(2):: Fitarg_up +integer(i_kind):: itargdn_sw,itargdn_se,itargdn_ne,itargdn_nw +integer(i_kind):: itarg_wA,itarg_eA,itarg_sA,itarg_nA +logical:: lwestA,leastA,lsouthA,lnorthA +integer(i_kind):: ix,jy +integer(i_kind),dimension(2):: mype_filt +!from mg_domain_loc.f90 +integer(i_kind):: nsq21,nsq32,nsq43 +logical,dimension(4):: Flsouth_loc,Flnorth_loc,Flwest_loc,Fleast_loc +integer(i_kind),dimension(4):: Fitarg_s_loc,Fitarg_n_loc,Fitarg_w_loc,Fitarg_e_loc +integer(i_kind),dimension(4):: Fitargup_loc12 +integer(i_kind),dimension(4):: Fitargup_loc23 +integer(i_kind),dimension(4):: Fitargup_loc34 +integer(i_kind):: itargdn_sw_loc21,itargdn_se_loc21,itargdn_nw_loc21,itargdn_ne_loc21 +integer(i_kind):: itargdn_sw_loc32,itargdn_se_loc32,itargdn_nw_loc32,itargdn_ne_loc32 +integer(i_kind):: itargdn_sw_loc43,itargdn_se_loc43,itargdn_nw_loc43,itargdn_ne_loc43 +logical:: lsendup_sw_loc,lsendup_se_loc,lsendup_nw_loc,lsendup_ne_loc + +contains + procedure :: init_mg_parameter +!from mg_mppstuff.f90 + procedure :: init_mg_MPI + procedure :: finishMPI + procedure :: barrierMPI +!from mg_domain.f90 + procedure :: init_mg_domain + procedure :: init_domain + procedure :: init_topology_2d + procedure :: real_itarg +!from mg_domain_loc.f90 + procedure :: init_domain_loc + procedure :: sidesend_loc + procedure :: targup_loc + procedure :: targdn21_loc + procedure :: targdn32_loc + procedure :: targdn43_loc +!from jp_pbfil.f90 + generic :: cholaspect => cholaspect1,cholaspect2,cholaspect3,cholaspect4 + procedure,nopass :: cholaspect1,cholaspect2,cholaspect3,cholaspect4 + generic :: getlinesum => getlinesum1,getlinesum2,getlinesum3 + procedure :: getlinesum1,getlinesum2,getlinesum3 + generic :: rbeta => rbeta1,rbeta2,rbeta3,rbeta4,vrbeta1,vrbeta2,vrbeta3,vrbeta4 + procedure:: rbeta1,rbeta2,rbeta3,rbeta4,vrbeta1,vrbeta2,vrbeta3,vrbeta4 + generic :: rbetaT => rbeta1t,rbeta2t,rbeta3t,rbeta4t,vrbeta1t,vrbeta2t,vrbeta3t,vrbeta4t + procedure:: rbeta1t,rbeta2t,rbeta3t,rbeta4t,vrbeta1t,vrbeta2t,vrbeta3t,vrbeta4t +end type mg_parameter_type + +interface +!from mg_mppstuff.f90 + module subroutine init_mg_MPI(this) + class(mg_parameter_type),target :: this + end subroutine + module subroutine finishMPI(this) + class(mg_parameter_type),target :: this + end subroutine + module subroutine barrierMPI(this) + class(mg_parameter_type),target :: this + end subroutine +!from mg_domain.f90 + module subroutine init_mg_domain(this) + class(mg_parameter_type)::this + end subroutine + module subroutine init_domain(this) + class(mg_parameter_type),target::this + end subroutine + module subroutine init_topology_2d(this) + class(mg_parameter_type),target::this + end subroutine + module subroutine real_itarg (this,itarg) + class(mg_parameter_type),target::this + integer(i_kind), intent(inout):: itarg + end subroutine +!from mg_domain_loc.f90 + module subroutine init_domain_loc(this) + class(mg_parameter_type)::this + end subroutine + module subroutine sidesend_loc(this) + class(mg_parameter_type),target::this + end subroutine + module subroutine targup_loc(this) + class(mg_parameter_type),target::this + end subroutine + module subroutine targdn21_loc(this) + class(mg_parameter_type),target::this + end subroutine + module subroutine targdn32_loc(this) + class(mg_parameter_type),target::this + end subroutine + module subroutine targdn43_loc(this) + class(mg_parameter_type),target::this + end subroutine +!from jp_pbfil.f90 + module subroutine cholaspect1(lx,mx, el) + use kinds, only: dp=>r_kind + integer, intent(in ):: lx,mx + real(dp),dimension(1,1,lx:mx),intent(inout):: el + end subroutine + module subroutine cholaspect2(lx,mx, ly,my, el) + use kinds, only: dp=>r_kind + integer, intent(in ):: lx,mx, ly,my + real(dp),dimension(2,2,lx:mx,ly:my),intent(inout):: el + real(dp),dimension(2,2):: tel + end subroutine + module subroutine cholaspect3(lx,mx, ly,my, lz,mz, el) + use kinds, only: dp=>r_kind + integer, intent(in ):: lx,mx, ly,my, lz,mz + real(dp),dimension(3,3,lx:mx,ly:my,lz:mz),intent(inout):: el + real(dp),dimension(3,3):: tel + end subroutine + module subroutine cholaspect4(lx,mx, ly,my, lz,mz, lw,mw,el) + use kinds, only: dp=>r_kind + integer, intent(in ):: lx,mx, ly,my, lz,mz, lw,mw + real(dp),dimension(4,4,lx:mx,ly:my,lz:mz,lw:mw),intent(inout):: el + real(dp),dimension(4,4):: tel + end subroutine + module subroutine getlinesum1(this,hx,lx,mx, el, ss) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx + real(dp),dimension(1,1,Lx:Mx),intent(in ):: el + real(dp),dimension( lx:mx),intent( out):: ss + end subroutine + module subroutine getlinesum2(this,hx,lx,mx, hy,ly,my, el, ss) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx, hy,ly,my + real(dp),dimension(2,2,Lx:Mx,Ly:My),intent(in ):: el + real(dp),dimension( lx:mx,ly:my),intent( out):: ss + end subroutine + module subroutine getlinesum3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el, ss) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx, hy,ly,my, hz,lz,mz + real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el + real(dp),dimension( lx:mx,ly:my,lz:mz),intent( out):: ss + end subroutine + module subroutine getlinesum4(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el, ss) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw + real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el + real(dp),dimension( lx:mx,ly:my,lz:mz,Lw:Mw),intent( out):: ss + end subroutine + module subroutine rbeta1(this,hx,lx,mx, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx + real(dp),dimension(Lx:Mx),intent(in ):: el + real(dp),dimension(Lx:Mx),intent(in ):: ss + real(dp),dimension(lx-hx:mx+hx),intent(inout):: a + end subroutine + module subroutine rbeta2(this,hx,lx,mx, hy,ly,my, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx, hy,ly,my + real(dp),dimension(2,2,Lx:Mx,Ly:My),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My),intent(in ):: ss + real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a + end subroutine + module subroutine rbeta3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx, hy,ly,my, hz,lz,mz + real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz),intent(in ):: ss + real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz),intent(inout):: a + end subroutine + module subroutine rbeta4(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss,a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw + real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss + real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz,lw-hw:mw+hw),intent(inout):: a + end subroutine + module subroutine rbeta1T(this,hx,lx,mx, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx + real(dp),dimension(1,1,Lx:Mx),intent(in ):: el + real(dp),dimension( Lx:Mx),intent(in ):: ss + real(dp),dimension(lx-hx:mx+hx),intent(inout):: a + end subroutine + module subroutine rbeta2T(this,hx,lx,mx, hy,ly,my, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx, hy,ly,my + real(dp),dimension(2,2,Lx:Mx,Ly:My),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My),intent(in ):: ss + real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a + end subroutine + module subroutine rbeta3T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx, hy,ly,my, hz,lz,mz + real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz),intent(in ):: ss + real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz),intent(inout):: a + end subroutine + module subroutine rbeta4T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw + real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss + real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz,lw-hw:mw+hw),intent(inout):: a + end subroutine + module subroutine vrbeta1(this,nv,hx,lx,mx, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: nv,hx,Lx,mx + real(dp),dimension(1,1,Lx:Mx),intent(in ):: el + real(dp),dimension( Lx:Mx),intent(in ):: ss + real(dp),dimension(nv,lx-hx:mx+hx),intent(inout):: a + end subroutine + module subroutine vrbeta2(this,nv,hx,lx,mx, hy,ly,my, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: nv, hx,Lx,mx, hy,ly,my + real(dp),dimension(2,2,Lx:Mx,Ly:My),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My),intent(in ):: ss + real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a + end subroutine + module subroutine vrbeta3(this,nv, hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: nv, hx,Lx,mx, hy,ly,my, hz,lz,mz + real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz),intent(in ):: ss + real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz),intent(inout):: a + end subroutine + module subroutine vrbeta4(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss,a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: nv, hx,Lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw + real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss + real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz,lw-hw:mw+hw),intent(inout):: a + end subroutine + module subroutine vrbeta1T(this,nv, hx,lx,mx, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: nv,hx,Lx,mx + real(dp),dimension(1,1,Lx:Mx),intent(in ):: el + real(dp),dimension( Lx:Mx),intent(in ):: ss + real(dp),dimension(nv,lx-hx:mx+hx),intent(inout):: a + end subroutine + module subroutine vrbeta2T(this,nv,hx,lx,mx, hy,ly,my, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: nv, hx,Lx,mx, hy,ly,my + real(dp),dimension(2,2,Lx:Mx,Ly:My),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My),intent(in ):: ss + real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a + end subroutine + module subroutine vrbeta3T(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: nv, hx,Lx,mx, hy,ly,my, hz,lz,mz + real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz),intent(in ):: ss + real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz),intent(inout):: a + end subroutine + module subroutine vrbeta4T(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: nv, hx,Lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw + real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss + real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz,lw-hw:mw+hw),intent(inout):: a + end subroutine +end interface + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +contains +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +subroutine init_mg_parameter(this,inputfilename) +!**********************************************************************! +! ! +! Initialize .... ! +! ! +!**********************************************************************! +implicit none +class (mg_parameter_type),target:: this +integer(i_kind):: g +character(*):: inputfilename + +! Namelist parameters as local variable +real(r_kind):: mg_ampl01,mg_ampl02,mg_ampl03 +real(r_kind):: mg_weig1,mg_weig2,mg_weig3,mg_weig4 +integer(i_kind):: mgbf_proc +logical:: mgbf_line +integer(i_kind):: nxPE,nyPE,im_filt,jm_filt +logical:: lquart,lhelm +logical:: ldelta + +integer(i_kind):: lm_a ! number of vertical layers in analysis fields +integer(i_kind):: lm ! number of vertical layers in filter grids +integer(i_kind):: km2 ! number of 2d variables for filtering +integer(i_kind):: km3 ! number of 3d variables for filtering +integer(i_kind):: n_ens ! number of ensemble members +logical :: l_loc ! logical flag for localization +logical :: l_filt_g1 ! logical flag for filtering of generation one +logical :: l_lin_vertical ! logical flag for linear interpolation in vertcial +logical :: l_lin_horizontal ! logical flag for linear interpolation in horizontal +logical :: l_quad_horizontal ! logical flag for quadratic interpolation in horizontal +logical :: l_new_map ! logical flag for new mapping between analysis and filter grid +logical :: l_vertical_filter ! logical flag for vertical filtering +integer(i_kind):: gm_max + +! Global number of data on Analysis grid +integer(i_kind):: nm0 +integer(i_kind):: mm0 + +integer(i_kind):: hx,hy,hz +integer(i_kind):: p + + namelist /parameters_mgbeta/ mg_ampl01,mg_ampl02,mg_ampl03 & + ,mg_weig1,mg_weig2,mg_weig3,mg_weig4 & + ,hx,hy,hz,p & + ,mgbf_line,mgbf_proc & + ,lm_a,lm & + ,km2,km3 & + ,n_ens & + ,l_loc & + ,l_filt_g1 & + ,l_lin_vertical & + ,l_lin_horizontal & + ,l_quad_horizontal & + ,l_new_map & + ,l_vertical_filter & + ,ldelta,lquart,lhelm & + ,gm_max & + ,nm0,mm0 & + ,nxPE,nyPE,im_filt,jm_filt +! + open(unit=10,file=inputfilename,status='old',action='read') + read(10,nml=parameters_mgbeta) + close(unit=10) +! +!----------------------------------------------------------------- +!for safety, copy all namelist loc vars to them of this object + this%mg_ampl01=mg_ampl01 + this%mg_ampl02=mg_ampl02 + this%mg_ampl03=mg_ampl03 + this%mg_weig1=mg_weig1 + this%mg_weig2=mg_weig2 + this%mg_weig3=mg_weig3 + this%mg_weig4=mg_weig4 + this%hx=hx + this%hy=hy + this%hz=hz + this%p =p + this%mgbf_line=mgbf_line + this%mgbf_proc=mgbf_proc + this%lm_a=lm_a + this%lm=lm + this%km2=km2 + this%km3=km3 + this%n_ens=n_ens + this%l_loc=l_loc + this%l_filt_g1=l_filt_g1 + this%l_lin_vertical=l_lin_vertical + this%l_lin_horizontal=l_lin_horizontal + this%l_quad_horizontal=l_quad_horizontal + this%l_new_map=l_new_map + this%l_vertical_filter=l_vertical_filter + this%ldelta=ldelta + this%lquart=lquart + this%lhelm=lhelm + this%nm0=nm0 + this%mm0=mm0 + this%nxPE=nxPE + this%nyPE=nyPE + this%im_filt=im_filt + this%jm_filt=jm_filt + + this%nxm = nxPE + this%nym = nyPE + + this%im = im_filt + this%jm = jm_filt + +!----------------------------------------------------------------- +! +! +! For 168 PES +! +! nxm = 14 +! nym = 12 +! +! For 256 PES +! +! nxm = 16 +! nym = 16 +! +! For 336 PES +! +! nxm = 28 +! nym = 12 +! +! For 448 PES +! +! nxm = 28 +! nym = 16 +! +! For 512 PES +! +! nxm = 32 +! nym = 16 +! +! For 704 PES +! +! nxm = 32 +! nym = 22 +! +! For 768 PES +! +! nxm = 32 +! nym = 24 +! +! For 924 PES +! +! nxm = 28 +! nym = 33 +! +! For 1056 PES +! +! nxm = 32 +! nym = 33 +! +! For 1408 PES +! +! nxm = 32 +! nym = 44 +! +! For 1848 PES +! +! nxm = 56 +! nym = 33 +! +! For 2464 PES +! +! nxm = 56 +! nym = 44 + +! +! Define total number of horizontal levels in the case of ensemble +! + + this%km_a = this%km2+this%lm_a*this%km3 + this%km = this%km2+this%lm *this%km3 + + this%km_a_all = this%km_a * this%n_ens + this%km_all = this%km * this%n_ens + + this%km2_all = this%km2 * this%n_ens + this%km3_all = this%km3 * this%n_ens + + this%km_4 = this%km/4 + this%km_16 = this%km/16 + this%km_64 = this%km/64 + +! +! Define maximum number of generations 'gm' +! + + call def_maxgen(this%nxm,this%nym,this%gm) + +! Restrict to gm_max + + if(this%gm>gm_max) then + this%gm=gm_max + endif + if(this%nxm*this%nym<=1) then + this%gm=gm_max + endif + +!*** +!*** Analysis grid +!*** + +! +! Number of grid intervals on GSI grid for the reduced RTMA domain +! before padding +! + this%nA_max0 = 1792 + this%mA_max0 = 1056 + +! +! Number of grid points on the analysis grid after padding +! + + this%nm = this%nm0/this%nxm + this%mm = this%mm0/this%nym + +!*** +!*** Filter grid +!*** + +! im = nm +! jm = mm + +! +! For 168 PES +! +! im = 120 +! jm = 80 +! +! For 256 PES +! +! im = 96 +! jm = 64 +! +! im = 88 +! jm = 56 +! +! For 336 PES +! +! im = 56 +! jm = 80 +! +! For 448 PES +! +! im = 56 +! jm = 64 +! +! For 512 PES +! +! im = 48 +! jm = 64 +! +! For 704 PES +! +! im = 48 +! jm = 40 +! +! For 768 PES +! +! im = 48 +! jm = 40 +! +! For 924 PES +! +! im = 56 +! jm = 24 +! +! For 1056 PES +! +! im = 48 +! jm = 24 +! +! For 1408 PES +! +! im = 48 +! jm = 20 +! +! For 1848 PES +! +! im = 28 +! jm = 24 +! +! For 2464 PES +! +! im = 28 +! jm = 20 + + this%im00 = this%nxm*this%im + this%jm00 = this%nym*this%jm + + this%n0 = 1 + this%m0 = 1 + + this%i0 = 1 + this%j0 = 1 + +! +! Make sure that nm0 and mm0 and divisibvle with nxm and nym +! + if(this%nm*this%nxm /= this%nm0 ) then + write(17,*) 'nm,nxm,nm0=',this%nm,this%nxm,this%nm0 + stop 'nm0 is not divisible by nxm' + endif + + if(this%mm*this%nym /= this%mm0 ) then + write(17,*) 'mm,nym,mm0=',this%mm,this%nym,this%mm0 + stop 'mm0 is not divisible by nym' + endif + +! +! Set number of processors at higher generations +! + + allocate(this%ixm(this%gm)) + allocate(this%jym(this%gm)) + allocate(this%nxy(this%gm)) + allocate(this%maxpe_fgen(0:this%gm)) + allocate(this%im0(this%gm)) + allocate(this%jm0(this%gm)) + allocate(this%Fimax(this%gm)) + allocate(this%Fjmax(this%gm)) + allocate(this%FimaxL(this%gm)) + allocate(this%FjmaxL(this%gm)) + + call def_ngens(this%ixm,this%gm,this%nxm) + call def_ngens(this%jym,this%gm,this%nym) + + do g=1,this%gm + this%nxy(g)=this%ixm(g)*this%jym(g) + enddo + + this%maxpe_fgen(0)= 0 + do g=1,this%gm + this%maxpe_fgen(g)=this%maxpe_fgen(g-1)+this%nxy(g) + enddo + + this%maxpe_filt=this%maxpe_fgen(this%gm) + this%npes_filt=this%maxpe_filt-this%nxy(1) + + this%im0(1)=this%im00 + do g=2,this%gm + this%im0(g)=this%im0(g-1)/2 + enddo + + this%jm0(1)=this%jm00 + do g=2,this%gm + this%jm0(g)=this%jm0(g-1)/2 + enddo + + do g=1,this%gm + this%Fimax(g)=this%im0(g)-this%im*(this%ixm(g)-1) + this%Fjmax(g)=this%jm0(g)-this%jm*(this%jym(g)-1) + enddo + + do g=1,this%gm + this%FimaxL(g)=this%Fimax(g)/2 + this%FjmaxL(g)=this%Fjmax(g)/2 + enddo + +!*** +!*** Filter related parameters +!** + this%lengthx = 1.*this%nm ! arbitrary chosen scale of the domain + this%lengthy = 1.*this%mm ! arbitrary chosen scale of the domain + + this%ib=6 + this%jb=6 + + this%dxa =this%lengthx/this%nm + this%dxf = this%lengthx/this%im + this%nb = 2*this%dxf/this%dxa + + this%dya = this%lengthy/this%mm + this%dyf = this%lengthy/this%jm + this%mb = 2*this%dyf/this%dya + + this%xa0 = this%dxa*0.5 + this%ya0 = this%dya*0.5 + + this%xf0 = this%dxf*0.5 + this%yf0 = this%dyf*0.5 + + this%imL=this%im/2 + this%jmL=this%jm/2 + + this%imH=this%im0(this%gm) + this%jmH=this%jm0(this%gm) + + this%pasp01 = mg_ampl01 + this%pasp02 = mg_ampl02 + this%pasp03 = mg_ampl03 + + this%nh= max(hx,hy,hz) + this%nfil = this%nh + 2 + + this%pee2=this%p*2 + this%rmom2_1=u1/sqrt(this%pee2+3) + this%rmom2_2=u1/sqrt(this%pee2+4) + this%rmom2_3=u1/sqrt(this%pee2+5) + this%rmom2_4=u1/sqrt(this%pee2+6) + +!---------------------------------------------------------------------- +end subroutine init_mg_parameter + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +subroutine def_maxgen & +!********************************************************************** +! ! +! Given number of PEs in x and y direction decides what is the ! +! maximum number of generations that a multigrid scheme can support ! +! ! +! M. Rancic 2020 ! +!********************************************************************** +(nxm,nym,gm) +!---------------------------------------------------------------------- +implicit none +integer, intent(in):: nxm,nym +integer, intent(out):: gm +integer:: npx,npy,gx,gy + + npx = nxm; gx=1 + Do + npx = (npx + 1)/2 + gx = gx + 1 + if(npx == 1) exit + end do + + npy = nym; gy=1 + Do + npy = (npy + 1)/2 + gy = gy + 1 + if(npy == 1) exit + end do + + gm = Min(gx,gy) + + +!---------------------------------------------------------------------- +endsubroutine def_maxgen + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +subroutine def_ngens & +!*********************************************************************! +! ! +! Given number of generations, find number of PEs is s direction ! +! ! +! M. Rancic 2020 ! +!*********************************************************************! +(nsm,gm,nsm0) +!---------------------------------------------------------------------- +implicit none +integer, intent(in):: gm,nsm0 +integer, dimension(gm), intent(out):: nsm +integer:: g +!---------------------------------------------------------------------- + + nsm(1)=nsm0 + Do g=2,gm + nsm(g) = (nsm(g-1) + 1)/2 + end do + +!---------------------------------------------------------------------- +endsubroutine def_ngens + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end module mg_parameter diff --git a/src/mgbf/mg_timers.f90 b/src/mgbf/mg_timers.f90 new file mode 100644 index 0000000000..0905d4d867 --- /dev/null +++ b/src/mgbf/mg_timers.f90 @@ -0,0 +1,218 @@ +module mg_timers +!$$$ submodule documentation block +! . . . . +! module: mg_timers +! prgmmr: jovic org: date: 2017 +! +! abstract: Measure cpu and wallclock timing +! +! module history log: +! 2020 rancic - adjusted +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! btim - +! etim - +! print_mg_timers - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use mpi + use kinds, only: r_kind,i_kind + implicit none + + private + + public :: btim, etim, print_mg_timers + + type timer + logical :: running = .false. + real(r_kind) :: start_clock = 0.0 + real(r_kind) :: start_cpu = 0.0 + real(r_kind) :: time_clock = 0.0 + real(r_kind) :: time_cpu = 0.0 + end type timer + + type(timer),save,public :: total_tim + type(timer),save,public :: init_tim + type(timer),save,public :: output_tim + type(timer),save,public :: dynamics_tim + type(timer),save,public :: upsend_tim + type(timer),save,public :: upsend1_tim + type(timer),save,public :: upsend2_tim + type(timer),save,public :: upsend3_tim + type(timer),save,public :: an2filt_tim + type(timer),save,public :: filt2an_tim + type(timer),save,public :: weight_tim + type(timer),save,public :: hfiltT_tim + type(timer),save,public :: vfiltT_tim + type(timer),save,public :: vadv1_tim + type(timer),save,public :: hfilt_tim + type(timer),save,public :: vfilt_tim + type(timer),save,public :: adv2_tim + type(timer),save,public :: vtoa_tim + type(timer),save,public :: dnsend_tim + type(timer),save,public :: dnsend1_tim + type(timer),save,public :: dnsend2_tim + type(timer),save,public :: dnsend3_tim + type(timer),save,public :: update_tim + type(timer),save,public :: physics_tim + type(timer),save,public :: radiation_tim + type(timer),save,public :: convection_tim + type(timer),save,public :: turbulence_tim + type(timer),save,public :: microphys_tim + type(timer),save,public :: pack_tim + type(timer),save,public :: arrn_tim + type(timer),save,public :: aintp_tim + type(timer),save,public :: intp_tim + type(timer),save,public :: bocoT_tim + type(timer),save,public :: boco_tim + + integer, parameter, public :: print_clock = 1, & + print_cpu = 2, & + print_clock_pct = 3, & + print_cpu_pct = 4 + +contains + +!----------------------------------------------------------------------- + subroutine btim(t) + implicit none + type(timer), intent(inout) :: t + + if (t%running) then + write(0,*)'btim: timer is already running' + STOP + end if + t%running = .true. + + t%start_clock = wtime() + t%start_cpu = ctime() + + endsubroutine btim +!----------------------------------------------------------------------- + subroutine etim(t) + implicit none + type(timer), intent(inout) :: t + real(r_kind) :: wt, ct + + wt = wtime() + ct = ctime() + + if (.not.t%running) then + write(0,*)'etim: timer is not running' + STOP + end if + t%running = .false. + + t%time_clock = t%time_clock + (wt - t%start_clock) + t%time_cpu = t%time_cpu + (ct - t%start_cpu) + t%start_clock = 0.0 + t%start_cpu = 0.0 + + endsubroutine etim +!----------------------------------------------------------------------- + subroutine print_mg_timers(filename, print_type,mype) + use mpi + implicit none + integer(i_kind),intent(in):: mype + + character(len=*), intent(in) :: filename + integer, intent(in) :: print_type + + integer :: fh + integer :: ierr + integer(kind=MPI_OFFSET_KIND) :: disp + integer, dimension(MPI_STATUS_SIZE) :: stat + character(len=1024) :: buffer, header + integer :: bufsize + + call MPI_File_open(MPI_COMM_WORLD, filename, & + MPI_MODE_WRONLY + MPI_MODE_CREATE, & + MPI_INFO_NULL, fh, ierr) + + buffer = ' ' + if ( print_type == print_clock ) then + write(buffer,"(I6,12(',',F10.4))") mype, & + init_tim%time_clock, & + upsend_tim%time_clock, & + dnsend_tim%time_clock, & + weight_tim%time_clock, & + hfiltT_tim%time_clock, & + hfilt_tim%time_clock, & + filt2an_tim%time_clock, & + aintp_tim%time_clock, & + intp_tim%time_clock, & + an2filt_tim%time_clock, & + output_tim%time_clock, & + total_tim%time_clock + else if ( print_type == print_cpu ) then + write(buffer,"(I6,14(',',F10.4))") mype, & + init_tim%time_cpu, & + an2filt_tim%time_cpu, & + vfiltT_tim%time_cpu, & + upsend_tim%time_cpu, & + hfiltT_tim%time_cpu, & + bocoT_tim%time_cpu, & + weight_tim%time_cpu, & + boco_tim%time_cpu, & + hfilt_tim%time_cpu, & + dnsend_tim%time_cpu, & + vfilt_tim%time_cpu, & + filt2an_tim%time_cpu, & + output_tim%time_cpu, & + total_tim%time_cpu + end if + + bufsize = LEN(TRIM(buffer)) + 1 + buffer(bufsize:bufsize) = NEW_LINE(' ') + + write(header,"(A6,14(',',A10))") "mype", & + "init", & + "an2filt", & + "vfiltT", & + "upsend", & + "hfiltT", & + "bocoT" , & + "weight", & + "boco", & + "hfilt", & + "dnsend", & + "vfilt", & + "filt2an", & + "output", & + "total" + + header(bufsize:bufsize) = NEW_LINE(' ') + disp = 0 + call MPI_File_write_at(fh, disp, header, bufsize, MPI_BYTE, stat, ierr) + + disp = (mype+1)*bufsize + call MPI_File_write_at(fh, disp, buffer, bufsize, MPI_BYTE, stat, ierr) + + call MPI_File_close(fh, ierr) + + endsubroutine print_mg_timers +!----------------------------------------------------------------------- + function wtime() + use mpi + real(r_kind) :: wtime + wtime = MPI_Wtime() + endfunction wtime +!----------------------------------------------------------------------- + function ctime() + real(r_kind) :: ctime + call CPU_TIME(ctime) + endfunction ctime +!----------------------------------------------------------------------- +end module mg_timers diff --git a/src/mgbf/mg_transfer.f90 b/src/mgbf/mg_transfer.f90 new file mode 100644 index 0000000000..5f929c0243 --- /dev/null +++ b/src/mgbf/mg_transfer.f90 @@ -0,0 +1,499 @@ +submodule(mg_intstate) mg_transfer +!$$$ submodule documentation block +! . . . . +! module: mg_transfer +! prgmmr: rancic org: NOAA/EMC date: 2021 +! +! abstract: Transfer data between analysis and filter grid +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! anal_to_filt_allmap - +! filt_to_anal_allmap - +! anal_to_filt_all - +! filt_to_anal_all - +! anal_to_filt_all2 - +! filt_to_anal_all2 - +! stack_to_composite - +! composite_to_stack - +! S2C_ens - +! C2S_ens - +! anal_to_filt - +! filt_to_anal - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +use mg_timers +use kinds, only: r_kind,i_kind + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +contains +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine anal_to_filt_allmap(this,WORKA) +!*********************************************************************** +! ! +! Transfer data from analysis to first generaton of filter grid ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this +real(r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm) +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- +if(km_a_all==km_all.and.nm==im.and.mm==jm) then + VALL=0. + VALL(1:km_all,1:im,1:jm)=WORKA +elseif(l_new_map) then + call this%anal_to_filt_all2(WORKA) +else + call this%anal_to_filt_all(WORKA) +endif +!---------------------------------------------------------------------- +endsubroutine anal_to_filt_allmap + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filt_to_anal_allmap(this,WORKA) +!*********************************************************************** +! ! +! Transfer data from filter to analysis grid ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this +real(r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm) +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- +if(km_a_all==km_all.and.nm==im.and.mm==jm) then + WORKA=VALL(1:km_all,1:im,1:jm) + VALL=0. +elseif(l_new_map) then + call this%filt_to_anal_all2(WORKA) +else + call this%filt_to_anal_all(WORKA) +endif +!---------------------------------------------------------------------- +endsubroutine filt_to_anal_allmap + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine anal_to_filt_all(this,WORKA) +!*********************************************************************** +! ! +! Transfer data from analysis to first generaton of filter grid ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this +real(r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm) +real(r_kind),allocatable,dimension(:,:,:,:):: A3D +real(r_kind),allocatable,dimension(:,:,:,:):: F3D +real(r_kind),allocatable,dimension(:,:,:):: WORK +integer(i_kind):: L +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- +allocate(WORK(km_all,1:nm,1:mm)) +allocate(A3D(km3_all,1:nm,1:mm,lm_a)) +allocate(F3D(km3_all,1:nm,1:mm,lm)) + + call btim(an2filt_tim) + call this%S2C_ens(WORKA,A3D,1,nm,1,mm,lm_a,km_a,km_a_all) + + if(lm_a>lm) then + if(l_lin_vertical) then + call this%l_vertical_adjoint_spec(km3_all,lm_a,lm,1,nm,1,mm,A3D,F3D) + else + call this%lwq_vertical_adjoint_spec(km3_all,lm_a,lm,1,nm,1,mm, & + cvf1,cvf2,cvf3,cvf4,lref,A3D,F3D) + endif + else + + do L=1,lm + F3D(:,:,:,L)=A3D(:,:,:,L) + enddo + + endif + + call this%C2S_ens(F3D,WORK,1,nm,1,mm,lm,km,km_all) + + call this%anal_to_filt(WORK) + call etim(an2filt_tim) + +deallocate(A3D,F3D,WORK) +!---------------------------------------------------------------------- +endsubroutine anal_to_filt_all + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filt_to_anal_all(this,WORKA) +!*********************************************************************** +! ! +! Transfer data from filter to analysis grid ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this +real(r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm) +real(r_kind),allocatable,dimension(:,:,:,:):: A3D +real(r_kind),allocatable,dimension(:,:,:,:):: F3D +real(r_kind),allocatable,dimension(:,:,:):: WORK +integer(i_kind):: L +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- +allocate(WORK(km_all,1:nm,1:mm)) +allocate(A3D(km3_all,1:nm,1:mm,lm_a)) +allocate(F3D(km3_all,1:nm,1:mm,lm)) + + call btim(filt2an_tim) + call this%filt_to_anal(WORK) + + call this%S2C_ens(WORK,F3D,1,nm,1,mm,lm,km,km_all) + + if(lm_a>lm) then + if(l_lin_vertical) then + call this%l_vertical_direct_spec(km3_all,lm,lm_a,1,nm,1,mm,F3D,A3D) + else + call this%lwq_vertical_direct_spec(km3_all,lm,lm_a,1,nm,1,mm, & + cvf1,cvf2,cvf3,cvf4,lref,F3D,A3D) + endif + else + + do L=1,lm + A3D(:,:,:,L)=F3D(:,:,:,L) + enddo + + endif + + call this%C2S_ens(A3D,WORKA,1,nm,1,mm,lm_a,km_a,km_a_all) + call etim(filt2an_tim) + +deallocate(A3D,F3D,WORK) +!---------------------------------------------------------------------- +endsubroutine filt_to_anal_all + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine anal_to_filt_all2(this,WORKA) +!*********************************************************************** +! ! +! Transfer data from analysis to first generaton of filter grid ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this +real(r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm) +real(r_kind),allocatable,dimension(:,:,:):: WORK +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- +allocate(WORK(km_all,1:nm,1:mm)) + + call btim(an2filt_tim) + if(lm_a>lm) then + call this%l_vertical_adjoint_spec2(km3*n_ens,lm_a,lm,1,nm,1,mm,WORKA,WORK) + else + WORK = WORKA + endif + + call this%anal_to_filt(WORK) + call etim(an2filt_tim) + +deallocate(WORK) +!---------------------------------------------------------------------- +endsubroutine anal_to_filt_all2 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filt_to_anal_all2(this,WORKA) +!*********************************************************************** +! ! +! Transfer data from filter to analysis grid ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this +real(r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm) +real(r_kind),allocatable,dimension(:,:,:):: WORK +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- +allocate(WORK(km_all,1:nm,1:mm)) + + call btim(filt2an_tim) + call this%filt_to_anal(WORK) + + if(lm_a>lm) then + call this%l_vertical_direct_spec2(km3*n_ens,lm,lm_a,1,nm,1,mm,WORK,WORKA) + else + WORKA = WORK + endif + call etim(filt2an_tim) + +deallocate(WORK) +!---------------------------------------------------------------------- +endsubroutine filt_to_anal_all2 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine stack_to_composite & +!*********************************************************************** +! ! +! Transfer data from stack to composite variables ! +! ! +!*********************************************************************** +(this,ARR_ALL,A2D,A3D) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +real(r_kind),dimension(this%km ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy), intent(in):: ARR_ALL +real(r_kind),dimension(this%km3,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,this%lm),intent(out):: A3D +real(r_kind),dimension(this%km2,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy) ,intent(out):: A2D +integer(i_kind):: i,j,k,L +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- + do L=1,lm + do j=1-hy,jm+hy + do i=1-hx,im+hx + do k=1,km3 + A3D(k,i,j,L)=ARR_ALL( (k-1)*lm+L,i,j ) + enddo + enddo + enddo + enddo + + do k=1,km2 + A2D(k,:,:)=ARR_ALL(km3*lm+k,:,:) + enddo + +!---------------------------------------------------------------------- +endsubroutine stack_to_composite + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine composite_to_stack & +!*********************************************************************** +! ! +! Transfer data from composite to stack variables ! +! ! +!*********************************************************************** +(this,A2D,A3D,ARR_ALL) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +real(r_kind),dimension(this%km2,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy), intent(in):: A2D +real(r_kind),dimension(this%km3,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,this%lm),intent(in):: A3D +real(r_kind),dimension(this%km ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy), intent(out):: ARR_ALL +integer(i_kind):: i,j,k,L +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- + do L=1,lm + do j=1-hy,jm+hy + do i=1-hx,im+hx + do k=1,km3 + ARR_ALL( (k-1)*lm+L,i,j )=A3D(k,i,j,L) + enddo + enddo + enddo + enddo + + do k=1,km2 + ARR_ALL(km3*lm+k,:,:)=A2D(k,:,:) + enddo + +!---------------------------------------------------------------------- +endsubroutine composite_to_stack + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine S2C_ens & +!*********************************************************************** +! ! +! General transfer data from stack to composite variables for ensemble ! +! ! +!*********************************************************************** +(this,ARR_ALL,A3D,imn,imx,jmn,jmx,lmx,kmx,kmx_all) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer, intent(in):: imn,imx,jmn,jmx,lmx,kmx,kmx_all +real(r_kind),dimension(kmx_all,imn:imx,jmn:jmx) ,intent(in):: ARR_ALL +real(r_kind),dimension(this%km3_all,imn:imx,jmn:jmx,lmx),intent(out):: A3D +integer(i_kind):: i,j,k,L +integer(i_kind):: n,n_inc +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- + do n=1,n_ens + n_inc = kmx*(n-1) + + do L=1,lmx + do j=jmn,jmx + do i=imn,imx + do k=1,km3 + A3D(km3*(n-1)+k,i,j,L)=ARR_ALL(n_inc+(k-1)*lmx+L,i,j) + enddo + enddo + enddo + enddo + + enddo +!---------------------------------------------------------------------- +endsubroutine S2C_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine C2S_ens & +!*********************************************************************** +! ! +! General transfer data from composite to stack variables for ensemble ! +! ! +!*********************************************************************** +(this,A3D,ARR_ALL,imn,imx,jmn,jmx,lmx,kmx,kmx_all) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer, intent(in):: imn,imx,jmn,jmx,lmx,kmx,kmx_all +real(r_kind),dimension(this%km3_all,imn:imx,jmn:jmx,lmx),intent(in):: A3D +real(r_kind),dimension(kmx_all,imn:imx,jmn:jmx) ,intent(out):: ARR_ALL +integer(i_kind):: i,j,k,L +integer(i_kind):: n,n_inc +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- + do n=1,n_ens + n_inc = kmx*(n-1) + + do L=1,lmx + do j=jmn,jmx + do i=imn,imx + do k=1,km3 + ARR_ALL(n_inc+(k-1)*lmx+L,i,j )= A3D(km3*(n-1)+k,i,j,L) + enddo + enddo + enddo + enddo + + enddo +!---------------------------------------------------------------------- +endsubroutine C2S_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine anal_to_filt(this,WORK) +!*********************************************************************** +! ! +! Transfer data from analysis to first generaton of filter grid ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this +real(r_kind):: WORK(this%km_all,1:this%nm,1:this%mm) +integer(i_kind):: ibm,jbm +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- + VALL=0. + + if(l_lin_horizontal) then + ibm=1 + jbm=1 + call this%lin_adjoint_offset(WORK,VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,ibm,jbm) + elseif(l_quad_horizontal) then + ibm=2 + jbm=2 + call this%quad_adjoint_offset(WORK,VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,ibm,jbm) + else + ibm=3 + jbm=3 + call this%lsqr_adjoint_offset(WORK,VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,ibm,jbm) + endif + +!*** +!*** Apply adjoint lateral bc on PKF and WKF +!*** + + call this%bocoT_2d(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,im,jm,ibm,jbm) + +!---------------------------------------------------------------------- +endsubroutine anal_to_filt + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filt_to_anal(this,WORK) +!*********************************************************************** +! ! +! Transfer data from filter to analysis grid ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this +real(r_kind):: WORK(this%km_all,1:this%nm,1:this%mm) +integer(i_kind):: ibm,jbm +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- + + if(l_lin_horizontal) then + ibm=1 + jbm=1 + elseif(l_quad_horizontal) then + ibm=2 + jbm=2 + else + ibm=3 + jbm=3 + endif + +!*** +!*** Supply boundary conditions for VALL +!*** + + call this%boco_2d(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,im,jm,ibm,jbm) + + if(l_lin_horizontal) then + call this%lin_direct_offset(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),WORK,km_all,ibm,jbm) + elseif(l_quad_horizontal) then + call this%quad_direct_offset(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),WORK,km_all,ibm,jbm) + else + call this%lsqr_direct_offset(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),WORK,km_all,ibm,jbm) + endif + +!---------------------------------------------------------------------- +endsubroutine filt_to_anal + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end submodule mg_transfer diff --git a/src/mgbf/type_intstat_locpointer.inc b/src/mgbf/type_intstat_locpointer.inc new file mode 100644 index 0000000000..52cdb687e8 --- /dev/null +++ b/src/mgbf/type_intstat_locpointer.inc @@ -0,0 +1,44 @@ +real(r_kind), dimension(:,:,:),pointer:: V +real(r_kind), dimension(:,:,:),pointer:: VALL +real(r_kind), dimension(:,:,:),pointer:: HALL +real(r_kind), dimension(:,:,:),pointer:: a_diff_f +real(r_kind), dimension(:,:,:),pointer:: a_diff_h +real(r_kind), dimension(:,:,:),pointer:: b_diff_f +real(r_kind), dimension(:,:,:),pointer:: b_diff_h +real(r_kind), dimension(:,:),pointer:: p_eps +real(r_kind), dimension(:,:),pointer:: p_del +real(r_kind), dimension(:,:),pointer:: p_sig +real(r_kind), dimension(:,:),pointer:: p_rho +real(r_kind), dimension(:,:,:),pointer:: paspx +real(r_kind), dimension(:,:,:),pointer:: paspy +real(r_kind), dimension(:,:,:),pointer:: pasp1 +real(r_kind), dimension(:,:,:,:),pointer:: pasp2 +real(r_kind), dimension(:,:,:,:,:),pointer:: pasp3 +real(r_kind), dimension(:,:,:),pointer:: vpasp2 +real(r_kind), dimension(:,:,:),pointer:: hss2 +real(r_kind), dimension(:,:,:,:),pointer:: vpasp3 +real(r_kind), dimension(:,:,:,:),pointer:: hss3 +real(r_kind), dimension(:),pointer:: ssx +real(r_kind), dimension(:),pointer:: ssy +real(r_kind), dimension(:),pointer:: ss1 +real(r_kind), dimension(:,:),pointer:: ss2 +real(r_kind), dimension(:,:,:),pointer:: ss3 +integer(fpi), dimension(:,:,:),pointer:: dixs +integer(fpi), dimension(:,:,:),pointer:: diys +integer(fpi), dimension(:,:,:),pointer:: dizs +integer(fpi), dimension(:,:,:,:),pointer:: dixs3 +integer(fpi), dimension(:,:,:,:),pointer:: diys3 +integer(fpi), dimension(:,:,:,:),pointer:: dizs3 +integer(fpi), dimension(:,:,:,:),pointer:: qcols +integer(i_kind),dimension(:),pointer:: iref,jref +integer(i_kind),dimension(:),pointer:: Lref,Lref_h +real(r_kind),dimension(:),pointer:: cvf1,cvf2,cvf3,cvf4 +real(r_kind),dimension(:),pointer:: cvh1,cvh2,cvh3,cvh4 +real(r_kind),dimension(:),pointer:: cx0,cx1,cx2,cx3 +real(r_kind),dimension(:),pointer:: cy0,cy1,cy2,cy3 +real(r_kind),dimension(:),pointer:: p_coef,q_coef +real(r_kind),dimension(:),pointer:: a_coef,b_coef +real(r_kind),dimension(:,:),pointer:: cf00,cf01,cf02,cf03 & + ,cf10,cf11,cf12,cf13 & + ,cf20,cf21,cf22,cf23 & + ,cf30,cf31,cf32,cf33 diff --git a/src/mgbf/type_intstat_point2this.inc b/src/mgbf/type_intstat_point2this.inc new file mode 100644 index 0000000000..ab8923f059 --- /dev/null +++ b/src/mgbf/type_intstat_point2this.inc @@ -0,0 +1,83 @@ +V=>this%V +VALL=>this%VALL +HALL=>this%HALL + +a_diff_f=>this%a_diff_f +a_diff_h=>this%a_diff_h +b_diff_f=>this%b_diff_f +b_diff_h=>this%b_diff_h + +p_eps=>this%p_eps +p_del=>this%p_del +p_sig=>this%p_sig +p_rho=>this%p_rho +paspx=>this%paspx +paspy=>this%paspy +pasp1=>this%pasp1 +pasp2=>this%pasp2 +pasp3=>this%pasp3 + +vpasp2=>this%vpasp2 +hss2=>this%hss2 +vpasp3=>this%vpasp3 +hss3=>this%hss3 + +ssx=>this%ssx +ssy=>this%ssy +ss1=>this%ss1 +ss2=>this%ss2 +ss3=>this%ss3 + +dixs=>this%dixs +diys=>this%diys +dizs=>this%dizs + +dixs3=>this%dixs3 +diys3=>this%diys3 +dizs3=>this%dizs3 + +qcols=>this%qcols + +iref=>this%iref +jref=>this%jref +Lref=>this%Lref +Lref_h=>this%Lref_h +cvf1=>this%cvf1 +cvf2=>this%cvf2 +cvf3=>this%cvf3 +cvf4=>this%cvf4 +cvh1=>this%cvh1 +cvh2=>this%cvh2 +cvh3=>this%cvh3 +cvh4=>this%cvh4 + +cx0=>this%cx0 +cx1=>this%cx1 +cx2=>this%cx2 +cx3=>this%cx3 +cy0=>this%cy0 +cy1=>this%cy1 +cy2=>this%cy2 +cy3=>this%cy3 + +p_coef=>this%p_coef +q_coef=>this%q_coef +a_coef=>this%a_coef +b_coef=>this%b_coef + +cf00=>this%cf00 +cf01=>this%cf01 +cf02=>this%cf02 +cf03=>this%cf03 +cf10=>this%cf10 +cf11=>this%cf11 +cf12=>this%cf12 +cf13=>this%cf13 +cf20=>this%cf20 +cf21=>this%cf21 +cf22=>this%cf22 +cf23=>this%cf23 +cf30=>this%cf30 +cf31=>this%cf31 +cf32=>this%cf32 +cf33=>this%cf33 diff --git a/src/mgbf/type_parameter_locpointer.inc b/src/mgbf/type_parameter_locpointer.inc new file mode 100644 index 0000000000..7a8f587dd2 --- /dev/null +++ b/src/mgbf/type_parameter_locpointer.inc @@ -0,0 +1,105 @@ +real(r_kind),pointer :: mg_ampl01,mg_ampl02,mg_ampl03 +real(r_kind),pointer:: mg_weig1,mg_weig2,mg_weig3,mg_weig4 +integer(i_kind),pointer:: mgbf_proc +logical,pointer:: mgbf_line +integer(i_kind),pointer:: nxPE,nyPE,im_filt,jm_filt +logical,pointer:: lquart,lhelm +integer(i_kind),pointer:: gm +integer(i_kind),pointer:: gm_max +integer(i_kind),pointer:: nA_max0 +integer(i_kind),pointer:: mA_max0 +integer(i_kind),pointer:: nm0 +integer(i_kind),pointer:: mm0 +integer(i_kind),pointer:: nxm +integer(i_kind),pointer:: nym +integer(i_kind),pointer:: nm +integer(i_kind),pointer:: mm +integer(i_kind),pointer:: im00 +integer(i_kind),pointer:: jm00 +integer(i_kind),pointer:: im +integer(i_kind),pointer:: jm +integer(i_kind),pointer:: i0 +integer(i_kind),pointer:: j0 +integer(i_kind),pointer:: n0 +integer(i_kind),pointer:: m0 +integer(i_kind),pointer:: ib +integer(i_kind),pointer:: jb +integer(i_kind),pointer:: nb +integer(i_kind),pointer:: mb +integer(i_kind),pointer:: hx,hy,hz +integer(i_kind),pointer:: p +integer(i_kind),pointer:: nh,nfil +real(r_kind),pointer:: pasp01,pasp02,pasp03 +real(r_kind),pointer:: pee2,rmom2_1,rmom2_2,rmom2_3,rmom2_4 +integer, pointer, dimension(:):: maxpe_fgen +integer, pointer, dimension(:):: ixm,jym,nxy +integer, pointer, dimension(:):: im0,jm0 +integer, pointer, dimension(:):: Fimax,Fjmax +integer, pointer, dimension(:):: FimaxL,FjmaxL +integer(i_kind),pointer:: npes_filt +integer(i_kind),pointer:: maxpe_filt +integer(i_kind),pointer:: imL,jmL +integer(i_kind),pointer:: imH,jmH +integer(i_kind),pointer:: lm_a ! number of vertical layers in analysis fields +integer(i_kind),pointer:: lm ! number of vertical layers in filter grids +integer(i_kind),pointer:: km2 ! number of 2d variables for filtering +integer(i_kind),pointer:: km3 ! number of 3d variables for filtering +integer(i_kind),pointer:: n_ens ! number of ensemble members +integer(i_kind),pointer:: km_a ! total number of horizontal levels for analysis +integer(i_kind),pointer:: km_all ! total number of k levels of ensemble for filtering +integer(i_kind),pointer:: km_a_all ! total number of k levels of ensemble +integer(i_kind),pointer:: km2_all ! total number of k horizontal levels of ensemble for filtering +integer(i_kind),pointer:: km3_all ! total number of k vertical levels of ensemble +logical,pointer :: l_loc ! logical flag for localization +logical,pointer :: l_filt_g1 ! logical flag for filtering of generation one +logical,pointer :: l_lin_vertical ! logical flag for linear interpolation in vertcial +logical,pointer :: l_lin_horizontal ! logical flag for linear interpolation in horizontal +logical,pointer :: l_quad_horizontal ! logical flag for quadratic interpolation in horizontal +logical,pointer :: l_new_map ! logical flag for new mapping between analysis and filter grid +logical,pointer :: l_vertical_filter ! logical flag for vertical filtering +integer(i_kind),pointer:: km ! number of vertically stacked all variables (km=km2+lm*km3) +integer(i_kind),pointer:: km_4 +integer(i_kind),pointer:: km_16 +integer(i_kind),pointer:: km_64 +real(r_kind),pointer:: lengthx,lengthy,xa0,ya0,xf0,yf0 +real(r_kind),pointer:: dxf,dyf,dxa,dya +integer(i_kind),pointer:: npadx ! x padding on analysis grid +integer(i_kind),pointer:: mpady ! y padding on analysis grid +integer(i_kind),pointer:: ipadx ! x padding on filter decomposition +integer(i_kind),pointer:: jpady ! y padding on filter deocmposition +logical,pointer:: ldelta + +!from mg_mppstuff.f90 +character(len=5),pointer:: c_mype +integer(i_kind),pointer:: mype +integer(i_kind),pointer:: npes,iTYPE,rTYPE,dTYPE,mpi_comm_comp,ierror +integer(i_kind),pointer:: mpi_comm_work,group_world,group_work +integer(i_kind),pointer:: mype_gr,npes_gr +integer(i_kind),pointer:: my_hgen +integer(i_kind),pointer:: mype_hgen +logical,pointer:: l_hgen +integer(i_kind),pointer:: nx,my + +!from mg_domain.f90 +logical,dimension(:),pointer:: Flwest,Fleast,Flnorth,Flsouth +integer(i_kind),dimension(:),pointer:: Fitarg_n,Fitarg_e,Fitarg_s,Fitarg_w +integer(i_kind),dimension(:),pointer:: Fitarg_sw,Fitarg_se,Fitarg_ne,Fitarg_nw +logical,dimension(:),pointer:: Flsendup_sw,Flsendup_se,Flsendup_nw,Flsendup_ne +integer(i_kind),dimension(:),pointer:: Fitarg_up +integer(i_kind),pointer:: itargdn_sw,itargdn_se,itargdn_ne,itargdn_nw +integer(i_kind),pointer:: itarg_wA,itarg_eA,itarg_sA,itarg_nA +logical,pointer:: lwestA,leastA,lsouthA,lnorthA +integer(i_kind),pointer:: ix,jy +integer(i_kind),dimension(:),pointer:: mype_filt + +!from mg_domain_loc.f90 +integer(i_kind),pointer:: nsq21,nsq32,nsq43 +logical,dimension(:),pointer:: Flsouth_loc,Flnorth_loc,Flwest_loc,Fleast_loc +integer(i_kind),dimension(:),pointer:: Fitarg_s_loc,Fitarg_n_loc,Fitarg_w_loc,Fitarg_e_loc +integer(i_kind),dimension(:),pointer:: Fitargup_loc12 +integer(i_kind),dimension(:),pointer:: Fitargup_loc23 +integer(i_kind),dimension(:),pointer:: Fitargup_loc34 +integer(i_kind),pointer:: itargdn_sw_loc21,itargdn_se_loc21,itargdn_nw_loc21,itargdn_ne_loc21 +integer(i_kind),pointer:: itargdn_sw_loc32,itargdn_se_loc32,itargdn_nw_loc32,itargdn_ne_loc32 +integer(i_kind),pointer:: itargdn_sw_loc43,itargdn_se_loc43,itargdn_nw_loc43,itargdn_ne_loc43 +logical,pointer:: lsendup_sw_loc,lsendup_se_loc,lsendup_nw_loc,lsendup_ne_loc diff --git a/src/mgbf/type_parameter_point2this.inc b/src/mgbf/type_parameter_point2this.inc new file mode 100644 index 0000000000..310f183311 --- /dev/null +++ b/src/mgbf/type_parameter_point2this.inc @@ -0,0 +1,189 @@ +mg_ampl01=>this%mg_ampl01 +mg_ampl02=>this%mg_ampl02 +mg_ampl03=>this%mg_ampl03 +mg_weig1=>this%mg_weig1 +mg_weig2=>this%mg_weig2 +mg_weig3=>this%mg_weig3 +mg_weig4=>this%mg_weig4 +mgbf_proc=>this%mgbf_proc +mgbf_line=>this%mgbf_line +nxPE=>this%nxPE +nyPE=>this%nyPE +im_filt=>this%im_filt +jm_filt=>this%jm_filt +lquart=>this%lquart +lhelm=>this%lhelm +gm=>this%gm +gm_max=>this%gm_max +nA_max0=>this%nA_max0 +mA_max0=>this%mA_max0 +nm0=>this%nm0 +mm0=>this%mm0 +nxm=>this%nxm +nym=>this%nym +nm=>this%nm +mm=>this%mm +im00=>this%im00 +jm00=>this%jm00 +im=>this%im +jm=>this%jm +i0=>this%i0 +j0=>this%j0 +n0=>this%n0 +m0=>this%m0 +ib=>this%ib +jb=>this%jb +nb=>this%nb +mb=>this%mb +hx=>this%hx +hy=>this%hy +hz=>this%hz +p=>this%p +nh=>this%nh +nfil=>this%nfil +pasp01=>this%pasp01 +pasp02=>this%pasp02 +pasp03=>this%pasp03 +pee2=>this%pee2 +rmom2_1=>this%rmom2_1 +rmom2_2=>this%rmom2_2 +rmom2_3=>this%rmom2_3 +rmom2_4=>this%rmom2_4 +maxpe_fgen=>this%maxpe_fgen +ixm=>this%ixm +jym=>this%jym +nxy=>this%nxy +im0=>this%im0 +jm0=>this%jm0 +Fimax=>this%Fimax +Fjmax=>this%Fjmax +FimaxL=>this%FimaxL +FjmaxL=>this%FjmaxL +npes_filt=>this%npes_filt +maxpe_filt=>this%maxpe_filt +imL=>this%imL +jmL=>this%jmL +imH=>this%imH +jmH=>this%jmH +lm_a=>this%lm_a ! number of vertical layers in analysis fields +lm=>this%lm ! number of vertical layers in filter grids +km2=>this%km2 ! number of 2d variables for filtering +km3=>this%km3 ! number of 3d variables for filtering +n_ens=>this%n_ens ! number of ensemble members +km_a=>this%km_a ! total number of horizontal levels for analysis +km_all=>this%km_all ! total number of k levels of ensemble for filtering +km_a_all=>this%km_a_all ! total number of k levels of ensemble +km2_all=>this%km2_all ! total number of k horizontal levels of ensemble for filtering +km3_all=>this%km3_all ! total number of k vertical levels of ensemble +l_loc=>this%l_loc ! logical flag for localization +l_filt_g1=>this%l_filt_g1 ! logical flag for filtering of generation one +l_lin_vertical=>this%l_lin_vertical ! logical flag for linear interpolation in vertcial +l_lin_horizontal=>this%l_lin_horizontal ! logical flag for linear interpolation in horizontal +l_quad_horizontal=>this%l_quad_horizontal ! logical flag for quadratic interpolation in horizontal +l_new_map=>this%l_new_map ! logical flag for new mapping between analysis and filter grid +l_vertical_filter=>this%l_vertical_filter ! logical flag for vertical filtering +km=>this%km ! number of vertically stacked all variables (km=km2+lm*km3) +km_4=>this%km_4 +km_16=>this%km_16 +km_64=>this%km_64 +lengthx=>this%lengthx +lengthy=>this%lengthy +xa0=>this%xa0 +ya0=>this%ya0 +xf0=>this%xf0 +yf0=>this%yf0 +dxf=>this%dxf +dyf=>this%dyf +dxa=>this%dxa +dya=>this%dya +npadx=>this%npadx ! x padding on analysis grid +mpady=>this%mpady ! y padding on analysis grid +ipadx=>this%ipadx ! x padding on filter decomposition +jpady=>this%jpady ! y padding on filter deocmposition +ldelta=>this%ldelta + +!from mg_mppstuff.f90 +c_mype=>this%c_mype +mype=>this%mype +npes=>this%npes +iTYPE=>this%iTYPE +rTYPE=>this%rTYPE +dTYPE=>this%dTYPE +mpi_comm_comp=>this%mpi_comm_comp +ierror=>this%ierror +mpi_comm_work=>this%mpi_comm_work +group_world=>this%group_world +group_work=>this%group_work +mype_gr=>this%mype_gr +npes_gr=>this%npes_gr +my_hgen=>this%my_hgen +mype_hgen=>this%mype_hgen +l_hgen=>this%l_hgen +nx=>this%nx +my=>this%my + +!from mg_domain.f90 +Flwest=>this%Flwest +Fleast=>this%Fleast +Flnorth=>this%Flnorth +Flsouth=>this%Flsouth +Fitarg_n=>this%Fitarg_n +Fitarg_e=>this%Fitarg_e +Fitarg_s=>this%Fitarg_s +Fitarg_w=>this%Fitarg_w +Fitarg_sw=>this%Fitarg_sw +Fitarg_se=>this%Fitarg_se +Fitarg_ne=>this%Fitarg_ne +Fitarg_nw=>this%Fitarg_nw +Flsendup_sw=>this%Flsendup_sw +Flsendup_se=>this%Flsendup_se +Flsendup_nw=>this%Flsendup_nw +Flsendup_ne=>this%Flsendup_ne +Fitarg_up=>this%Fitarg_up +itargdn_sw=>this%itargdn_sw +itargdn_se=>this%itargdn_se +itargdn_ne=>this%itargdn_ne +itargdn_nw=>this%itargdn_nw +itarg_wA=>this%itarg_wA +itarg_eA=>this%itarg_eA +itarg_sA=>this%itarg_sA +itarg_nA=>this%itarg_nA +lwestA=>this%lwestA +leastA=>this%leastA +lsouthA=>this%lsouthA +lnorthA=>this%lnorthA +ix=>this%ix +jy=>this%jy +mype_filt=>this%mype_filt + +!from mg_domain_loc.f90 +nsq21=>this%nsq21 +nsq32=>this%nsq32 +nsq43=>this%nsq43 +Flsouth_loc=>this%Flsouth_loc +Flnorth_loc=>this%Flnorth_loc +Flwest_loc=>this%Flwest_loc +Fleast_loc=>this%Fleast_loc +Fitarg_s_loc=>this%Fitarg_s_loc +Fitarg_n_loc=>this%Fitarg_n_loc +Fitarg_w_loc=>this%Fitarg_w_loc +Fitarg_e_loc=>this%Fitarg_e_loc +Fitargup_loc12=>this%Fitargup_loc12 +Fitargup_loc23=>this%Fitargup_loc23 +Fitargup_loc34=>this%Fitargup_loc34 +itargdn_sw_loc21=>this%itargdn_sw_loc21 +itargdn_se_loc21=>this%itargdn_se_loc21 +itargdn_nw_loc21=>this%itargdn_nw_loc21 +itargdn_ne_loc21=>this%itargdn_ne_loc21 +itargdn_sw_loc32=>this%itargdn_sw_loc32 +itargdn_se_loc32=>this%itargdn_se_loc32 +itargdn_nw_loc32=>this%itargdn_nw_loc32 +itargdn_ne_loc32=>this%itargdn_ne_loc32 +itargdn_sw_loc43=>this%itargdn_sw_loc43 +itargdn_se_loc43=>this%itargdn_se_loc43 +itargdn_nw_loc43=>this%itargdn_nw_loc43 +itargdn_ne_loc43=>this%itargdn_ne_loc43 +lsendup_sw_loc=>this%lsendup_sw_loc +lsendup_se_loc=>this%lsendup_se_loc +lsendup_nw_loc=>this%lsendup_nw_loc +lsendup_ne_loc=>this%lsendup_ne_loc From 6d9ebbb7896b92a93959ce63c7a1ad9e9a0aab4f Mon Sep 17 00:00:00 2001 From: Andrew Collard <40322596+ADCollard@users.noreply.github.com> Date: Tue, 26 Mar 2024 15:41:59 -0400 Subject: [PATCH 070/109] Dsfcalc fix (#727) Tiny fix to allow modelling of sub-fov variability for NOAA-21 ATMS. --- regression/regression_namelists.sh | 2 +- src/gsi/calc_fov_crosstrk.f90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh index 7ca183ef3e..552bc1ba59 100755 --- a/regression/regression_namelists.sh +++ b/regression/regression_namelists.sh @@ -181,7 +181,7 @@ OBS_INPUT:: sstviirs viirs-m j1 viirs-m_j1 0.0 4 0 abibufr abi g18 abi_g18 0.0 1 0 ahibufr ahi himawari9 ahi_himawari9 0.0 1 0 - atmsbufr atms n21 atms_n21 0.0 1 0 + atmsbufr atms n21 atms_n21 0.0 1 1 crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 1 0 sstviirs viirs-m j2 viirs-m_j2 0.0 4 0 ompsnpbufr ompsnp n21 ompsnp_n21 0.0 0 0 diff --git a/src/gsi/calc_fov_crosstrk.f90 b/src/gsi/calc_fov_crosstrk.f90 index dc9767e850..6cb817b56b 100644 --- a/src/gsi/calc_fov_crosstrk.f90 +++ b/src/gsi/calc_fov_crosstrk.f90 @@ -1287,7 +1287,7 @@ subroutine get_sat_height(satid, height, valid) height=866._r_kind case('npp') height=840._r_kind - case('n20') + case('n20', 'n21', 'n22', 'n23') height=840._r_kind case default write(6,*) 'GET_SAT_HEIGHT: ERROR, unrecognized satellite id: ', trim(satid) From b53740a7bd1cc416f634589075b8c8b89f0ef761 Mon Sep 17 00:00:00 2001 From: Xu Lu Date: Tue, 26 Mar 2024 21:46:08 -0400 Subject: [PATCH 071/109] Fix HAFS GSI debug build and run issues (#679) **DUE DATE for merger of this PR into `develop` is 2/19/2024 (six weeks after PR creation).** **DUE DATE for this PR is extended to 3/19/2024 because @XuLu-NOAA is on leave.** **Description** Xu Lu (xu.lu@noaa.gov) and Biju Thomas (biju.thomas@noaa.gov) fixed bugs regarding HAFS GSI debug build and run issues. This is in corresponding to issue #661 Fixes #661 1. In read_radar.f90, uninitialized toff is making all the ground-based radar observations be placed at -3h instead of 0h, which creates wrong increments for FGAT and 4DEnVar. 2. In read_radar.f90, uninitialized zsges will crash the debug mode. 3. In read_radar.f90, t4dvo should be used instead of t4dv in the read_radar_l2rw_novadqc subroutine. 4. In radinfo.90, maxscan should be increased to at least 252 to allow more scans, or it will crash the debug mode. 5. In read_fl_hdob.f90, dlnpsob is replaced with 1000. since the SFMR does not sample surface pressure, and the uninitialized dlnpsob creates issues later in setupspd.f90 in the debug mode. 6. In mod_fv3_lola.f90, (i,j+1) should be used instead of (i+1,j) in searching for V edges. 7. In stpcalc.f90, when tried to find the best stepsize from outpen around L838-864, the minimum outstp(i) is stored in stp(ii), but the istp_use is asigned with i instead of ii. Create inconsistency when assigning stp(istp_use) to stpinout at L872. Should use istp_use=ii instead. **Type of change** - [Yes] Bug fix (non-breaking change which fixes an issue) **How Has This Been Tested?** Regression test on Orion: ``` Test project /work/noaa/hwrf/save/xulu/mergeversions/GSI/build CMake Warning (dev) at CTestTestfile.cmake:9 (subdirs): Syntax Warning in cmake code at /work/noaa/hwrf/save/xulu/mergeversions/GSI/build/regression/CTestTestfile.cmake:7:10 1/7 Test #4: [=[netcdf_fv3_regional]=] ........ Passed 365.11 sec 2/7 Test #7: [=[global_enkf]=] ................ Passed 430.29 sec 3/7 Test #3: [=[rrfs_3denvar_glbens]=] ........ Passed 605.35 sec 4/7 Test #2: [=[rtma]=] ....................... Passed 969.78 sec 5/7 Test #6: [=[hafs_3denvar_hybens]=] ........***Failed 1455.47 sec 6/7 Test #1: [=[global_4denvar]=] ............. Passed 1682.40 sec 7/7 Test #5: [=[hafs_4denvar_glbens]=] ........***Failed 1758.90 sec ``` The failed hafs_3denvar and 4denvar are within expectation due to the fix for toff. As demonstrated in the single observation tests in the following figure, the uninitialized toff can result in increment degradations due to wrongly assigned observation times: ![image](https://github.com/NOAA-EMC/GSI/assets/26603014/0de870e1-f8c8-4b6d-8039-57f417b76367) --- src/gsi/mod_fv3_lola.f90 | 8 +++----- src/gsi/radinfo.f90 | 2 +- src/gsi/read_fl_hdob.f90 | 4 ++-- src/gsi/read_radar.f90 | 24 +++++++++++++----------- src/gsi/stpcalc.f90 | 4 ++-- 5 files changed, 21 insertions(+), 21 deletions(-) diff --git a/src/gsi/mod_fv3_lola.f90 b/src/gsi/mod_fv3_lola.f90 index e8df85068e..11bb3b6e37 100644 --- a/src/gsi/mod_fv3_lola.f90 +++ b/src/gsi/mod_fv3_lola.f90 @@ -951,7 +951,6 @@ subroutine definecoef_regular_grids(nxen,nyen,grid_lon,grid_lont,grid_lat,grid_l do i=1,nxen ! center lat/lon of the edge rlat=half*(grid_lat(i,j)+grid_lat(i+1,j)) -! rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)) diff=(grid_lon(i,j)-grid_lon(i+1,j))**2 if(diff < sq180)then rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)) @@ -979,12 +978,11 @@ subroutine definecoef_regular_grids(nxen,nyen,grid_lon,grid_lont,grid_lat,grid_l do j=1,nyen do i=1,nxen+1 rlat=half*(grid_lat(i,j)+grid_lat(i,j+1)) -! rlon=half*(grid_lon(i,j)+grid_lon(i,j+1)) - diff=(grid_lon(i,j)-grid_lon(i+1,j))**2 + diff=(grid_lon(i,j)-grid_lon(i,j+1))**2 if(diff < sq180)then - rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)) + rlon=half*(grid_lon(i,j)+grid_lon(i,j+1)) else - rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)-360._r_kind) + rlon=half*(grid_lon(i,j)+grid_lon(i,j+1)-360._r_kind) endif xr=cos(rlat*deg2rad)*cos(rlon*deg2rad) yr=cos(rlat*deg2rad)*sin(rlon*deg2rad) diff --git a/src/gsi/radinfo.f90 b/src/gsi/radinfo.f90 index ede58b9bca..4ad17626e6 100644 --- a/src/gsi/radinfo.f90 +++ b/src/gsi/radinfo.f90 @@ -897,7 +897,7 @@ subroutine radinfo_read ! Allocate arrays to receive angle dependent bias information. ! Open file to bias file (satang=satbias_angle). Read data. - maxscan=250 + maxscan=252 if (.not.adp_anglebc) maxscan = 90 ! default value for old files if (adp_anglebc) then diff --git a/src/gsi/read_fl_hdob.f90 b/src/gsi/read_fl_hdob.f90 index 1ef3d8617f..4041740d52 100644 --- a/src/gsi/read_fl_hdob.f90 +++ b/src/gsi/read_fl_hdob.f90 @@ -48,7 +48,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si use kinds, only: r_single,r_kind,r_double,i_kind use constants, only: zero,one_tenth,one,two,ten,deg2rad,t0c,half,& three,four,rad2deg,tiny_r_kind,huge_r_kind,r0_01,& - r60inv,r10,r100,r2000,hvap,eps,omeps,rv,grav + r60inv,r10,r100,r2000,hvap,eps,omeps,rv,grav,r_missing use gridmod, only: diagnostic_reg,regional,nlon,nlat,nsig,& tll2xy,txy2ll,rotate_wind_ll2xy,rotate_wind_xy2ll,& rlats,rlons,twodvar_regional,fv3_regional @@ -1133,7 +1133,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si cdata_all( 1,iout)=woe ! wind error cdata_all( 2,iout)=dlon ! grid relative longitude cdata_all( 3,iout)=dlat ! grid relative latitude - cdata_all( 4,iout)=dlnpsob ! ln(surface pressure in cb) + cdata_all( 4,iout)=r_missing ! ln(surface pressure in cb) !Since dlnpsob is not provided by SFMR, force it to be r_missing. Not used in setupspd.f90 cdata_all( 5,iout)=spdob*sqrt(two)*half ! u obs cdata_all( 6,iout)=spdob*sqrt(two)*half ! v obs cdata_all( 7,iout)=rstation_id ! station id diff --git a/src/gsi/read_radar.f90 b/src/gsi/read_radar.f90 index 5b1cffbf0c..a824bbbe4e 100644 --- a/src/gsi/read_radar.f90 +++ b/src/gsi/read_radar.f90 @@ -3282,7 +3282,7 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs) 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 + use obsmod, only: reduce_diag,time_offset implicit none @@ -3323,7 +3323,7 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs) integer(i_kind) iret,kx0 integer(i_kind) nreal,nchanl,ilat,ilon,ikx integer(i_kind) idomsfc - real(r_kind) usage,ff10,sfcr,skint,t4dv,t4dvo,toff + real(r_kind) usage,ff10,sfcr,skint,t4dvo 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 @@ -3467,7 +3467,7 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs) staheight=this_stahgt !station elevation tiltangle=corrected_tilt*deg2rad - t4dvo=toff+thistime + t4dvo=thistime+time_offset timemax=max(timemax,t4dvo) timemin=min(timemin,t4dvo) @@ -3586,7 +3586,8 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs) end if if(usage >= 100._r_kind)rusage(ndata)=.true. - call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr) + call deter_sfc2(dlat_earth,dlon_earth,t4dvo,idomsfc,skint,ff10,sfcr) + call deter_zsfc_model(dlat,dlon,zsges) cdata(1) = error ! wind obs error (m/s) cdata(2) = dlon ! grid relative longitude @@ -3594,7 +3595,7 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs) cdata(4) = height ! obs absolute height (m) cdata(5) = rwnd ! wind obs (m/s) cdata(6) = azm*deg2rad ! azimuth angle (radians) - cdata(7) = t4dv ! obs time (hour) + cdata(7) = t4dvo ! obs time (hour) cdata(8) = ikx ! type cdata(9) = tiltangle ! tilt angle (radians) cdata(10)= staheight ! station elevation (m) @@ -3699,6 +3700,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) 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,deter_zsfc_model use mpimod, only: npe 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 @@ -3744,7 +3746,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,t4dv,t4dvo,toff + real(r_kind) usage,ff10,sfcr,skint,t4dvo 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 @@ -4071,7 +4073,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) slat=sin(dlat_earth) staheight=this_stahgt !station elevation tiltangle=corrected_tilt*deg2rad - t4dvo=toff+thistime + t4dvo=time_offset+thistime timemax=max(timemax,t4dvo) timemin=min(timemin,t4dvo) ! Exclude data if it does not fall within time window @@ -4166,7 +4168,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) if (l4dvar) then timedif = zero else - timedif=abs(t4dvo-toff) + timedif=abs(t4dvo-time_offset) endif crit1 = timedif/r6+half call map3grids_m(1,save_all,zflag,zl_thin,nlevz, & @@ -4233,8 +4235,8 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) 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) + call deter_zsfc_model(dlat,dlon,zsges) + call deter_sfc2(dlat_earth,dlon_earth,t4dvo,idomsfc,skint,ff10,sfcr) nsuper2_kept=nsuper2_kept+1 cdata(1) = error ! wind obs error (m/s) @@ -4243,7 +4245,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) cdata(4) = height ! obs absolute height (m) cdata(5) = rwnd ! wind obs (m/s) cdata(6) = azm*deg2rad ! azimuth angle (radians) - cdata(7) = t4dvo+time_offset ! obs time (hour) + cdata(7) = t4dvo ! obs time (hour) cdata(8) = ikx ! type cdata(9) = tiltangle ! tilt angle (radians) cdata(10)= staheight ! station elevation (m) diff --git a/src/gsi/stpcalc.f90 b/src/gsi/stpcalc.f90 index c66bb58291..34030763db 100644 --- a/src/gsi/stpcalc.f90 +++ b/src/gsi/stpcalc.f90 @@ -844,10 +844,10 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & if(outpen(i) < outpensave)then stp(ii)=outstp(i) outpensave=outpen(i) - istp_use=i + istp_use=ii end if end do - if(istp_use /= istp_iter) then + if(istp_use /= nsteptot) then final_ii=ii exit stepsize end if From b2fc4fd92c49878af2381d985699c3f7987b8b4e Mon Sep 17 00:00:00 2001 From: Jeff Whitaker Date: Fri, 29 Mar 2024 07:57:50 -0600 Subject: [PATCH 072/109] add ability to taper analysis perts near top of model (#729) --- src/enkf/gridinfo_fv3reg.f90 | 34 +++++++++++++++++++++++++++------- src/enkf/gridinfo_gfs.f90 | 34 +++++++++++++++++++++++++++------- src/enkf/gridinfo_nmmb.f90 | 9 ++++++++- src/enkf/gridinfo_wrf.f90 | 9 +++++++-- src/enkf/inflation.f90 | 19 +++++++++++++------ src/enkf/params.f90 | 7 ++++++- 6 files changed, 88 insertions(+), 24 deletions(-) diff --git a/src/enkf/gridinfo_fv3reg.f90 b/src/enkf/gridinfo_fv3reg.f90 index 9a16f0ca03..337c9ba682 100644 --- a/src/enkf/gridinfo_fv3reg.f90 +++ b/src/enkf/gridinfo_fv3reg.f90 @@ -47,7 +47,8 @@ module gridinfo use mpimod, only: mpi_comm_world use params, only: datapath,nlevs,nlons,nlats,use_gfs_nemsio, fgfileprefixes, & fv3fixpath, nx_res,ny_res, ntiles,l_fv3reg_filecombined,paranc, & - fv3_io_layout_nx,fv3_io_layout_ny + fv3_io_layout_nx,fv3_io_layout_ny,taperanalperts,taperanalperts_akbot, & + taperanalperts_aktop use kinds, only: r_kind, i_kind, r_double, r_single use constants, only: one,zero,pi,cp,rd,grav,rearth,max_varname_length @@ -65,6 +66,7 @@ module gridinfo public :: ak,bk,eta1_ll,eta2_ll real(r_single),public :: ptop real(r_single),public, allocatable, dimension(:) :: lonsgrd, latsgrd +real(r_single),public, allocatable, dimension(:) :: taper_vert ! arrays passed to kdtree2 routines must be single real(r_single),public, allocatable, dimension(:,:) :: gridloc real(r_single),public, allocatable, dimension(:,:) :: logp @@ -133,7 +135,7 @@ subroutine getgridinfo(fileprefix, reducedgrid) !when paranc=.false, fv3_io_layout_nx=fv3_io_layout_ny=1 ! read data on root task -if (nproc .eq. 0) then +if (nproc == 0) then ! read ak,bk from ensmean fv_core.res.nc ! read nx,ny and nz from fv_core.res.nc @@ -164,19 +166,35 @@ subroutine getgridinfo(fileprefix, reducedgrid) eta2_ll(i)=bk(i) enddo - - - ptop = eta1_ll(nlevsp1) call nc_check( nf90_close(file_id),& myname_,'close '//trim(filename) ) + + ! vertical taper function for ens perts + allocate(taper_vert(nlevs)) + if (taperanalperts) then + do k=1,nlevs + if (k < nlevs/2 .and. (ak(k) <= taperanalperts_akbot .and. ak(k) >= taperanalperts_aktop)) then + taper_vert(nlevs-k+1)= log(ak(k) - taperanalperts_aktop)/log(taperanalperts_akbot - taperanalperts_aktop) + else if (bk(k) == zero .and. ak(k) < taperanalperts_aktop) then + taper_vert(nlevs-k+1) = zero + endif + enddo + print *,'vertical taper for anal perts:' + do k=1,nlevs + print *,k,ak(nlevs-k+1),bk(nlevs-k+1),taper_vert(k) + enddo + else + taper_vert = one + endif + deallocate(ak,bk) endif ! root task allocate(nxlocgroup(fv3_io_layout_nx,fv3_io_layout_ny)) allocate(nylocgroup(fv3_io_layout_nx,fv3_io_layout_ny)) -if(nproc.eq.0) then +if(nproc == 0) then ii=0 do j=1,fv3_io_layout_ny do i=1,fv3_io_layout_nx @@ -463,7 +481,7 @@ subroutine getgridinfo(fileprefix, reducedgrid) allocate(gridloc(3,npts)) if (nproc .ne. 0) then ! allocate arrays on other (non-root) tasks - allocate(latsgrd(npts),lonsgrd(npts)) + allocate(latsgrd(npts),lonsgrd(npts),taper_vert(nlevs)) allocate(logp(npts,nlevs_pres)) ! log(ens mean first guess press) on mid-layers allocate(eta1_ll(nlevsp1),eta2_ll(nlevsp1)) endif @@ -473,6 +491,7 @@ subroutine getgridinfo(fileprefix, reducedgrid) enddo call mpi_bcast(lonsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) call mpi_bcast(latsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) +call mpi_bcast(taper_vert,nlevs,mpi_real4,0,MPI_COMM_WORLD,ierr) call mpi_bcast(eta1_ll,nlevsp1,mpi_real4,0,MPI_COMM_WORLD,ierr) call mpi_bcast(eta2_ll,nlevsp1,mpi_real4,0,MPI_COMM_WORLD,ierr) call mpi_bcast(ptop,1,mpi_real4,0,MPI_COMM_WORLD,ierr) @@ -489,6 +508,7 @@ end subroutine getgridinfo subroutine gridinfo_cleanup() if (allocated(lonsgrd)) deallocate(lonsgrd) if (allocated(latsgrd)) deallocate(latsgrd) +if (allocated(taper_vert)) deallocate(taper_vert) if (allocated(logp)) deallocate(logp) if (allocated(gridloc)) deallocate(gridloc) end subroutine gridinfo_cleanup diff --git a/src/enkf/gridinfo_gfs.f90 b/src/enkf/gridinfo_gfs.f90 index de71153c69..efbd7a2959 100644 --- a/src/enkf/gridinfo_gfs.f90 +++ b/src/enkf/gridinfo_gfs.f90 @@ -45,7 +45,8 @@ module gridinfo use mpisetup, only: nproc, mpi_integer, mpi_real4 use mpimod, only: mpi_comm_world -use params, only: datapath,nlevs,nlons,nlats,use_gfs_nemsio,use_gfs_ncio,fgfileprefixes +use params, only: datapath,nlevs,nlons,nlats,use_gfs_nemsio,use_gfs_ncio,fgfileprefixes,& + taperanalperts,taperanalperts_aktop,taperanalperts_akbot use kinds, only: r_kind, i_kind, r_double, r_single use constants, only: one,zero,pi,cp,rd,grav,rearth,max_varname_length use specmod, only: sptezv_s, sptez_s, init_spec_vars, isinitialized, asin_gaulats, & @@ -57,7 +58,7 @@ module gridinfo public :: getgridinfo, gridinfo_cleanup integer(i_kind),public :: nlevs_pres, idvc real(r_single),public :: ptop -real(r_single),public, allocatable, dimension(:) :: lonsgrd, latsgrd +real(r_single),public, allocatable, dimension(:) :: lonsgrd, latsgrd, taper_vert ! arrays passed to kdtree2 routines must be single real(r_single),public, allocatable, dimension(:,:) :: gridloc real(r_single),public, allocatable, dimension(:,:) :: logp @@ -105,7 +106,7 @@ subroutine getgridinfo(fileprefix, reducedgrid) kapr = cp/rd kap1 = kap + one nlevs_pres=nlevs+1 -if (nproc .eq. 0) then +if (nproc == 0) then filename = trim(adjustl(datapath))//trim(adjustl(fileprefix))//"ensmean" if (use_gfs_nemsio) then call nemsio_init(iret=iret) @@ -168,11 +169,13 @@ subroutine getgridinfo(fileprefix, reducedgrid) ! initialize spectral module on all tasks. if (.not. isinitialized) call init_spec_vars(nlons,nlats,ntrunc,4) -if (nproc .eq. 0) then +if (nproc == 0) then ! get pressure, lat/lon information from ensemble mean file. allocate(presslmn(nlons*nlats,nlevs)) allocate(pressimn(nlons*nlats,nlevs+1)) allocate(spressmn(nlons*nlats)) + allocate(taper_vert(nlevs)) + taper_vert=one if (use_gfs_nemsio) then call nemsio_readrecv(gfile,'pres','sfc',1,nems_wrk,iret=iret) if (iret/=0) then @@ -221,7 +224,6 @@ subroutine getgridinfo(fileprefix, reducedgrid) enddo call nemsio_close(gfile, iret=iret) ptop = ak(nlevs+1) - deallocate(ak,bk) else if (use_gfs_ncio) then call read_vardata(dset, 'pressfc', values_2d,errcode=iret) if (iret /= 0) then @@ -238,7 +240,7 @@ subroutine getgridinfo(fileprefix, reducedgrid) pressimn(:,k) = 0.01_r_kind*ak(nlevs-k+2)+bk(nlevs-k+2)*spressmn(:) enddo ptop = 0.01_r_kind*ak(1) - deallocate(ak,bk,values_2d) + deallocate(values_2d) else ! get pressure from ensemble mean, ! distribute to all processors. @@ -278,7 +280,6 @@ subroutine getgridinfo(fileprefix, reducedgrid) enddo call sigio_axdata(sigdata,iret) ptop = ak(nlevs+1) - deallocate(ak,bk) endif if (reducedgrid) then call reducedgrid_init(nlons,nlats,asin_gaulats) @@ -334,11 +335,28 @@ subroutine getgridinfo(fileprefix, reducedgrid) logp(:,nlevs_pres) = -log(spressmn(:)) endif deallocate(spressmn,presslmn,pressimn) + ! vertical taper function for ens perts + if (taperanalperts) then + do k=1,nlevs + if (k < nlevs/2 .and. (ak(k) <= taperanalperts_akbot .and. ak(k) >= taperanalperts_aktop)) then + taper_vert(nlevs-k+1)= log(ak(k) - taperanalperts_aktop)/log(taperanalperts_akbot - taperanalperts_aktop) + else if (bk(k) == zero .and. ak(k) < taperanalperts_aktop) then + taper_vert(nlevs-k+1) = zero + endif + enddo + print *,'vertical taper for anal perts:' + do k=1,nlevs + print *,k,ak(nlevs-k+1),bk(nlevs-k+1),taper_vert(k) + enddo + endif + if (allocated(ak)) deallocate(ak) + if (allocated(bk)) deallocate(bk) end if call mpi_bcast(npts,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) if (nproc .ne. 0) then ! allocate arrays on other (non-root) tasks allocate(latsgrd(npts),lonsgrd(npts)) + allocate(taper_vert(nlevs)) allocate(logp(npts,nlevs_pres)) ! log(ens mean first guess press) on mid-layers allocate(gridloc(3,npts)) ! initialize reducedgrid_mod on other tasks. @@ -352,6 +370,7 @@ subroutine getgridinfo(fileprefix, reducedgrid) enddo call mpi_bcast(lonsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) call mpi_bcast(latsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) +call mpi_bcast(taper_vert,nlevs,mpi_real4,0,MPI_COMM_WORLD,ierr) call mpi_bcast(ptop,1,mpi_real4,0,MPI_COMM_WORLD,ierr) !==> precompute cartesian coords of analysis grid points. do nn=1,npts @@ -365,6 +384,7 @@ end subroutine getgridinfo subroutine gridinfo_cleanup() if (allocated(lonsgrd)) deallocate(lonsgrd) if (allocated(latsgrd)) deallocate(latsgrd) +if (allocated(taper_vert)) deallocate(taper_vert) if (allocated(logp)) deallocate(logp) if (allocated(gridloc)) deallocate(gridloc) end subroutine gridinfo_cleanup diff --git a/src/enkf/gridinfo_nmmb.f90 b/src/enkf/gridinfo_nmmb.f90 index df6c22ee1e..33b487354e 100644 --- a/src/enkf/gridinfo_nmmb.f90 +++ b/src/enkf/gridinfo_nmmb.f90 @@ -1,6 +1,7 @@ module gridinfo -use mpisetup +use mpisetup, only: nproc, mpi_integer, mpi_real4 +use mpimod, only: mpi_comm_world use params, only: datapath,nlevs,datestring,& nmmb,regional,nlons,nlats,nbackgrounds,fgfileprefixes use kinds, only: r_kind, i_kind, r_double, r_single @@ -16,6 +17,7 @@ module gridinfo integer(i_kind),public :: nlevs_pres real(r_single),public :: ptop real(r_single),public, allocatable, dimension(:) :: lonsgrd, latsgrd +real(r_single),public, allocatable, dimension(:) :: taper_vert ! arrays passed to kdtree2 routines must be single real(r_single),public, allocatable, dimension(:,:) :: gridloc real(r_single),public, allocatable, dimension(:,:) :: logp @@ -124,6 +126,8 @@ subroutine getgridinfo(fileprefix, reducedgrid) allocate(latsgrd(npts),lonsgrd(npts)) allocate(logp(npts,nlevs_pres)) ! log(ens mean first guess press) on mid-layers allocate(gridloc(3,npts)) + allocate(taper_vert(nlevs)) + taper_vert=one lonsgrd = lons; latsgrd = lats print *,'min/max lonsgrd',minval(lonsgrd),maxval(lonsgrd) print *,'min/max latsgrd',minval(latsgrd),maxval(latsgrd) @@ -165,6 +169,7 @@ subroutine getgridinfo(fileprefix, reducedgrid) if (nproc .ne. 0) then ! allocate arrays on other (non-root) tasks allocate(latsgrd(npts),lonsgrd(npts)) + allocate(taper_vert(nlevs)) allocate(logp(npts,nlevs_pres)) ! log(ens mean first guess press) on mid-layers allocate(gridloc(3,npts)) endif @@ -174,6 +179,7 @@ subroutine getgridinfo(fileprefix, reducedgrid) enddo call mpi_bcast(lonsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) call mpi_bcast(latsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) +call mpi_bcast(taper_vert,nlevs,mpi_real4,0,MPI_COMM_WORLD,ierr) call mpi_bcast(ptop,1,mpi_real4,0,MPI_COMM_WORLD,ierr) !==> precompute cartesian coords of analysis grid points. @@ -188,6 +194,7 @@ end subroutine getgridinfo subroutine gridinfo_cleanup() if (allocated(lonsgrd)) deallocate(lonsgrd) if (allocated(latsgrd)) deallocate(latsgrd) +if (allocated(taper_vert)) deallocate(taper_vert) if (allocated(logp)) deallocate(logp) if (allocated(gridloc)) deallocate(gridloc) end subroutine gridinfo_cleanup diff --git a/src/enkf/gridinfo_wrf.f90 b/src/enkf/gridinfo_wrf.f90 index e67b827b41..4ad80aaa60 100644 --- a/src/enkf/gridinfo_wrf.f90 +++ b/src/enkf/gridinfo_wrf.f90 @@ -32,12 +32,13 @@ module gridinfo ! Define associated modules - use constants, only: rearth_equator, omega, pi, deg2rad, zero, rad2deg, & + use constants, only: rearth_equator, omega, pi, deg2rad, zero, one, rad2deg, & rearth,max_varname_length use kinds, only: i_kind, r_kind, r_single, i_long, r_double use params, only: datapath, nlevs, nlons, nlats, & arw, nmm - use mpisetup + use mpisetup, only: nproc, mpi_integer, mpi_real4,mpi_status + use mpimod, only: mpi_comm_world use netcdf_io implicit none @@ -63,6 +64,7 @@ module gridinfo real(r_single), dimension(:,:), allocatable, public :: gridloc real(r_single), dimension(:), allocatable, public :: lonsgrd real(r_single), dimension(:), allocatable, public :: latsgrd + real(r_single), dimension(:), allocatable, public :: taper_vert real(r_single), public :: ptop integer(i_long), public :: npts integer(i_kind), public :: nlevs_pres @@ -211,7 +213,9 @@ subroutine getgridinfo_arw(fileprefix) ! Allocate memory for global arrays if(.not. allocated(lonsgrd)) allocate(lonsgrd(npts)) if(.not. allocated(latsgrd)) allocate(latsgrd(npts)) + if(.not. allocated(taper_vert)) allocate(taper_vert(nlevs)) if(.not. allocated(logp)) allocate(logp(npts,nlevs_pres)) + taper_vert = one !====================================================================== ! Begin: Ingest all grid variables required for EnKF routines and @@ -848,6 +852,7 @@ end subroutine dot2cross subroutine gridinfo_cleanup() if (allocated(lonsgrd)) deallocate(lonsgrd) if (allocated(latsgrd)) deallocate(latsgrd) + if (allocated(taper_vert)) deallocate(taper_vert) if (allocated(logp)) deallocate(logp) if (allocated(gridloc)) deallocate(gridloc) end subroutine gridinfo_cleanup diff --git a/src/enkf/inflation.f90 b/src/enkf/inflation.f90 index 51d1dd1106..c80cc99c10 100644 --- a/src/enkf/inflation.f90 +++ b/src/enkf/inflation.f90 @@ -71,14 +71,14 @@ module inflation analpertwtnh_rtpp,analpertwtsh_rtpp,analpertwttr_rtpp,& latbound, delat, datapath, covinflatemax, save_inflation, & covinflatemin, nlons, nlats, smoothparm, nbackgrounds,& - covinflatenh,covinflatesh,covinflatetr,lnsigcovinfcutoff + covinflatenh,covinflatesh,covinflatetr,lnsigcovinfcutoff,taperanalperts use kinds, only: r_single, i_kind use mpeu_util, only: getindex use constants, only: one, zero, rad2deg, deg2rad use covlocal, only: latval, taper -use controlvec, only: ncdim, cvars3d, cvars2d, nc3d, nc2d, clevels +use controlvec, only: ncdim, cvars3d, cvars2d, nc3d, nc2d, clevels, index_pres ! note: vars2d_landonly currently only defined for gridio_gfs, but smoothing only coded for gfs. -use gridinfo, only: latsgrd, logp, npts, nlevs_pres, vars2d_landonly +use gridinfo, only: latsgrd, logp, npts, nlevs_pres, vars2d_landonly, taper_vert use loadbal, only: indxproc, numptsperproc, npts_max, anal_chunk, anal_chunk_prior use smooth_mod, only: smooth @@ -102,7 +102,7 @@ subroutine inflate_ens() real(r_single),dimension(ndiag) :: sumcoslat,suma,suma2,sumi,sumf,sumitot,sumatot, & sumcoslattot,suma2tot,sumftot real(r_single) fnanalsml,coslat -integer(i_kind) i,nn,iunit,ierr,nb,nnlvl,ps_ind, this_ind, ind +integer(i_kind) i,k,nlev,nn,iunit,ierr,nb,nnlvl,ps_ind, this_ind, ind integer(i_kind), dimension(8) :: soil_index character(len=500) filename real(r_single), allocatable, dimension(:,:) :: tmp_chunk2,covinfglobal,store_presmooth @@ -113,7 +113,7 @@ subroutine inflate_ens() if (analpertwtnh_rtpp > 1.e-5_r_single .and. & analpertwtnh_rtpp > 1.e-5_r_single .and. & analpertwttr_rtpp > 1.e-5_r_single) then -if (nproc .eq. 0) print *,'performing RTPP inflation...' +if (nproc == 0) print *,'performing RTPP inflation...' nbloop: do nb=1,nbackgrounds ! loop over time levels in background ! First perform RTPP ensemble inflation, ! as first described in: @@ -139,7 +139,7 @@ subroutine inflate_ens() abs(analpertwttr) < 1.e-5_r_single .and. & abs(analpertwtsh) < 1.e-5_r_single) return -if (nproc .eq. 0) print *,'performing RTPS inflation...' +if (nproc == 0) print *,'performing RTPS inflation...' ! now perform RTPS inflation nbloop2: do nb=1,nbackgrounds ! loop over time levels in background @@ -302,11 +302,18 @@ subroutine inflate_ens() ! apply inflation. do nn=1,ncdim + nlev = index_pres(nn) ! vertical index for i'th control variable + if (nlev == nlevs+1) nlev=-1 ! 2d field do i=1,numptsperproc(nproc+1) ! inflate posterior perturbations. anal_chunk(:,i,nn,nb) = tmp_chunk2(i,nn)*anal_chunk(:,i,nn,nb) + ! optionally 'deflate' perturbations to reduce spread near top of model + if (taperanalperts .and. nlev > 0) then + anal_chunk(:,i,nn,nb) = taper_vert(nlev)*anal_chunk(:,i,nn,nb) + endif + ! area mean surface pressure posterior spread, inflation. ! (this diagnostic only makes sense for grids that are regular in longitude) if (ps_ind > 0 .and. nn == clevels(nc3d) + ps_ind) then diff --git a/src/enkf/params.f90 b/src/enkf/params.f90 index 36b0c9c207..f2a52d9a1a 100644 --- a/src/enkf/params.f90 +++ b/src/enkf/params.f90 @@ -254,6 +254,11 @@ module params ! write ensemble mean analysis (or analysis increment) logical,public :: write_ensmean = .false. +! taper analysis ens perturbations at top of model (gfs only) +logical, public :: taperanalperts = .false. +real(r_kind), public :: taperanalperts_akbot = 500.0_r_kind +real(r_kind), public :: taperanalperts_aktop = -1.0_r_kind + namelist /nam_enkf/datestring,datapath,iassim_order,nvars,& covinflatemax,covinflatemin,deterministic,sortinc,& mincorrlength_fact,corrlengthnh,corrlengthtr,corrlengthsh,& @@ -286,7 +291,7 @@ module params fv3_native, paranc, nccompress, write_fv3_incr,incvars_to_zero,write_ensmean, & corrlengthrdrnh,corrlengthrdrsh,corrlengthrdrtr,& lnsigcutoffrdrnh,lnsigcutoffrdrsh,lnsigcutoffrdrtr,& - l_use_enkf_directZDA + l_use_enkf_directZDA,taperanalperts,taperanalperts_akbot,taperanalperts_aktop namelist /nam_wrf/arw,nmm,nmm_restart namelist /nam_fv3/fv3fixpath,nx_res,ny_res,ntiles,l_pres_add_saved,l_fv3reg_filecombined, & fv3_io_layout_nx,fv3_io_layout_ny From db477e361f75f412c69ca6fdf9acfd411628f403 Mon Sep 17 00:00:00 2001 From: JingCheng-NOAA <135154465+JingCheng-NOAA@users.noreply.github.com> Date: Mon, 1 Apr 2024 14:15:10 -0400 Subject: [PATCH 073/109] Update the QC for the enhanced high-resolution GOES-R mesoscale floater AMVs (#724) **Description** This is an update of the QC process for the enhanced high-resolution GOES-R mesoscale floater AMVs to resolve the issue #713. As mentioned in the issue, enhanced AMV data are derived from IR band, which turns out to be not reliable in the mid-layer of atmosphere. Adding additional QC process to remove data in those layers are necessary and proved to enhance the Hurricane intensity forecast. **Type of change** Please delete options that are not relevant. - [ ] Bug fix (non-breaking change which fixes an issue) - [x] New feature (non-breaking change which adds functionality) - [ ] Breaking change (fix or feature that would cause existing functionality to not work as expected) - [ ] This change requires a documentation update **How Has This Been Tested?** This change has been tested with GSI regression test on Hera. **Checklist** - [x] My code follows the style guidelines of this project - [x] I have performed a self-review of my own code - [x] I have commented my code, particularly in hard-to-understand areas - [x] New and existing tests pass with my changes - [x] Any dependent changes have been merged and published --- src/gsi/setupw.f90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/gsi/setupw.f90 b/src/gsi/setupw.f90 index e350c7deba..e7dd08c5f5 100644 --- a/src/gsi/setupw.f90 +++ b/src/gsi/setupw.f90 @@ -945,7 +945,11 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav else if( presw >950.0_r_kind) error =zero ! screen data beloww 950mb endif - if(itype ==242 .or. itype ==243 ) then ! visible winds from JMA and EUMETSAT + if(itype == 241 ) then + if( presw >399.0_r_kind .and. presw <601.0_r_kind) then !CIMISS(enhanced AMV) winds + error=zero ! no data between400-600mb + endif + else 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 From 29d9d8fdea7e5139bca6bdd135711a33e7bf25a6 Mon Sep 17 00:00:00 2001 From: Gang Zhao <53267411+GangZhao-NOAA@users.noreply.github.com> Date: Fri, 5 Apr 2024 09:39:54 -0400 Subject: [PATCH 074/109] Adding I/O for direct analysis of near-surface wind gust for RRFS-based 3DRTMA (#730) **Description** To improve the analysis of the near-surface wind gust in 3DRTMA, the observations of near-surface wind gust would be analyzed directly in GSI (3DVar and Hybrid 3DEnVar), instead of being a derived product from the near-surface wind analysis. Since the core subroutines for direct variational assimilation of wind gust (e.g., setupgust.f90, intgust.f90, stpgust.f90, etc.) had already been implemented in GSI for 2DRTMA, so in the work the development in GSI mainly focus on adding I/O of 2-D wind gust firstguess and analysis fields for RRFS-based 3DRTMA, and some minor modifications in observation and background error for wind gust, options to control the analysis of wind gust, etc. This PR is to address the issue #726 : Adding I/O for direct analysis of near-surface wind gust for RRFS-based 3DRTMA Fixes #726 **Type of change** Please delete options that are not relevant. - [x] New feature (non-breaking change which adds functionality) **How Has This Been Tested?** **Checklist** - [x] My code follows the style guidelines of this project - [x] I have performed a self-review of my own code - [x] I have commented my code, particularly in hard-to-understand areas - [x] New and existing tests pass with my changes tested with a real case - 2024-02-20_12:00Z, 1. dry-run (using my updated GSI code with wind gust analysis, but actually no wind gust obs is analyzed, so-called dryrun) is compared to control-run (original GSI code running without wind gust obs): the results are identical. This indicates that if without analyzing wind-gust obs, then the updated code generates the analysis identical to the analysis of original/control code. Or say, the added code does not have influence on the other part of code. 2. real case run with updated GSI code to analyze the obs of wind gust: The following figure shows the used observations of near-surface wind gust: ![var_obs_2024022012_gust_used_maprll_datll_reg_ncf](https://github.com/NOAA-EMC/GSI/assets/53267411/ecbe479a-03c6-490f-a179-9e0027291468) the following figure shows the analysis increments: ![GUST_hyb_hwllp90_corptuned_inc_incrintrp_maprll_datrll_reg_grb2](https://github.com/NOAA-EMC/GSI/assets/53267411/a01fca0d-dc1f-438b-b8eb-e624de35a631) - [x] Any dependent changes have been merged and published - [x] Regression tests on WCOSS2 (Cactus) and Hera (Rocky-8) : my updated GSI commit [#f91f247d](https://github.com/GangZhao-NOAA/GSI/commit/f91f247dde65dea0b659c0b78d747433d9ca9559)) vs control/original GSI code (commit [#6d9ebbb7](https://github.com/NOAA-EMC/GSI/commit/6d9ebbb7896b92a93959ce63c7a1ad9e9a0aab4f)) Here is the reports of the regression tests on WCOSS2 (Cactus): ~~~ [gang.zhao@clogin02:build] (feature/windgust_in_3dvar_for_3drtma)$ ctest -j 7 Test project /lfs/h2/emc/da/save/gang.zhao/WorkDir/ProdGSI_Dev/gsi_dev/build Start 1: global_4denvar Start 2: rtma Start 3: rrfs_3denvar_glbens Start 4: netcdf_fv3_regional Start 5: hafs_4denvar_glbens Start 6: hafs_3denvar_hybens Start 7: global_enkf 1/7 Test #4: netcdf_fv3_regional .............. Passed 483.15 sec 2/7 Test #3: rrfs_3denvar_glbens .............. Passed 486.74 sec 3/7 Test #7: global_enkf ...................... Passed 850.98 sec 4/7 Test #2: rtma ............................. Passed 970.28 sec 5/7 Test #6: hafs_3denvar_hybens .............. Passed 1152.82 sec 6/7 Test #5: hafs_4denvar_glbens .............. Passed 1213.93 sec 7/7 Test #1: global_4denvar ................... Passed 1683.16 sec 100% tests passed, 0 tests failed out of 7 Total Test time (real) = 1683.19 sec ~~~ Here is the reports of the regression tests on Hera (Rocky8): ~~~ (base) [Gang.Zhao@hfe11:build] (feature/windgust_in_3dvar_for_3drtma)$ ctest -j 7 Test project /scratch1/NCEPDEV/da/Gang.Zhao/ProdGSI_dev/gsi_dev/build Start 1: global_4denvar Start 2: rtma Start 3: rrfs_3denvar_glbens Start 4: netcdf_fv3_regional Start 5: hafs_4denvar_glbens Start 6: hafs_3denvar_hybens Start 7: global_enkf 1/7 Test #4: netcdf_fv3_regional .............. Passed 491.53 sec 2/7 Test #3: rrfs_3denvar_glbens ..............***Failed 495.27 sec 3/7 Test #2: rtma ............................. Passed 982.45 sec 4/7 Test #6: hafs_3denvar_hybens .............. Passed 1168.99 sec 5/7 Test #7: global_enkf ...................... Passed 1239.77 sec 6/7 Test #5: hafs_4denvar_glbens ..............***Failed 1347.87 sec 7/7 Test #1: global_4denvar ................... Passed 1974.45 sec 71% tests passed, 2 tests failed out of 7 Total Test time (real) = 1974.91 sec The following tests FAILED: 3 - rrfs_3denvar_glbens (Failed) 5 - hafs_4denvar_glbens (Failed) Errors while running CTest Output from these tests are in: /scratch1/NCEPDEV/da/Gang.Zhao/ProdGSI_dev/gsi_dev/build/Testing/Temporary/LastTest.log Use "--rerun-failed --output-on-failure" to re-run the failed cases verbosely. (base) [Gang.Zhao@hfe11:build] (feature/windgust_in_3dvar_for_3drtma)$ ctest -R rrfs_3denvar_glbens Test project /scratch1/NCEPDEV/da/Gang.Zhao/ProdGSI_dev/gsi_dev/build Start 3: rrfs_3denvar_glbens 1/1 Test #3: rrfs_3denvar_glbens .............. Passed 430.52 sec 100% tests passed, 0 tests failed out of 1 Total Test time (real) = 430.55 sec (base) [Gang.Zhao@hfe11:build] (feature/windgust_in_3dvar_for_3drtma)$ ctest -R hafs_4denvar_glbens Test project /scratch1/NCEPDEV/da/Gang.Zhao/ProdGSI_dev/gsi_dev/build Start 5: hafs_4denvar_glbens 1/1 Test #5: hafs_4denvar_glbens .............. Passed 1225.37 sec 100% tests passed, 0 tests failed out of 1 Total Test time (real) = 1225.39 sec ~~~ **Note**: _When I was running the regression tests, GSI code was just updated to the latest commit [#b53740a7](https://github.com/GangZhao-NOAA/GSI/commit/f91f247dde65dea0b659c0b78d747433d9ca9559). Considering the frequent update in EMC GSI code recently and saving the time, after this PR has been reviewed and approved by peer-reviewers, I will update the code to latest EMC GSI commit, then re-run the regression tests for final approval. --- src/gsi/gsi_rfv3io_mod.f90 | 65 +++++++++++++++++++++++----- src/gsi/gsimod.F90 | 7 ++- src/gsi/m_berror_stats_reg.f90 | 29 ++++++++++++- src/gsi/rapidrefresh_cldsurf_mod.f90 | 50 +++++++++++++++++++++ src/gsi/read_prepbufr.f90 | 5 ++- 5 files changed, 140 insertions(+), 16 deletions(-) diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 652bad9a33..8e1c3ab98f 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -61,7 +61,7 @@ module gsi_rfv3io_mod use rapidrefresh_cldsurf_mod, only: i_use_2mq4b,i_use_2mt4b use chemmod, only: naero_cmaq_fv3,aeronames_cmaq_fv3,imodes_cmaq_fv3,laeroana_fv3cmaq use chemmod, only: naero_smoke_fv3,aeronames_smoke_fv3,laeroana_fv3smoke - use rapidrefresh_cldsurf_mod, only: i_howv_3dda + use rapidrefresh_cldsurf_mod, only: i_howv_3dda, i_gust_3dda implicit none public type_fv3regfilenameg @@ -147,7 +147,7 @@ module gsi_rfv3io_mod public :: mype_u,mype_v,mype_t,mype_q,mype_p,mype_oz,mype_ql public :: mype_qi,mype_qr,mype_qs,mype_qg,mype_qnr,mype_w public :: k_slmsk,k_tsea,k_vfrac,k_vtype,k_stype,k_zorl,k_smc,k_stc - public :: k_snwdph,k_f10m,mype_2d,n2d,k_orog,k_psfc,k_t2m,k_q2m,k_howv + public :: k_snwdph,k_f10m,mype_2d,n2d,k_orog,k_psfc,k_t2m,k_q2m,k_howv,k_gust public :: ijns,ijns2d,displss,displss2d,ijnz,displsz_g public :: fv3lam_io_dynmetvars3d_nouv,fv3lam_io_tracermetvars3d_nouv public :: fv3lam_io_tracerchemvars3d_nouv,fv3lam_io_tracersmokevars3d_nouv @@ -158,7 +158,7 @@ module gsi_rfv3io_mod integer(i_kind) mype_qi,mype_qr,mype_qs,mype_qg,mype_qnr,mype_w integer(i_kind) k_slmsk,k_tsea,k_vfrac,k_vtype,k_stype,k_zorl,k_smc,k_stc - integer(i_kind) k_snwdph,k_f10m,mype_2d,n2d,k_orog,k_psfc,k_t2m,k_q2m,k_howv + integer(i_kind) k_snwdph,k_f10m,mype_2d,n2d,k_orog,k_psfc,k_t2m,k_q2m,k_howv,k_gust parameter( & k_f10m =1, & !fact10 k_stype=2, & !soil_type @@ -174,7 +174,8 @@ module gsi_rfv3io_mod k_q2m =12, & ! 2 m Q k_orog =13, & !terrain k_howv =14, & ! significant wave height (aka howv in GSI) - n2d=14 ) + k_gust =15, & ! wind gust (aka gust in GSI) + n2d=15 ) logical :: grid_reverse_flag character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_io_dynmetvars3d_nouv ! copy of cvars3d excluding uv 3-d fields @@ -996,6 +997,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) real(r_kind),dimension(:,:),pointer::ges_t2m=>NULL() real(r_kind),dimension(:,:),pointer::ges_q2m=>NULL() real(r_kind),dimension(:,:),pointer::ges_howv=>NULL() + real(r_kind),dimension(:,:),pointer::ges_gust=>NULL() real(r_kind),dimension(:,:,:),pointer::ges_ql=>NULL() real(r_kind),dimension(:,:,:),pointer::ges_qi=>NULL() @@ -1274,6 +1276,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) else if(trim(vartem)=='t2m') then else if(trim(vartem)=='q2m') then else if(trim(vartem)=='howv') then + else if(trim(vartem)=='gust') then else write(6,*)'the metvarname2 ',trim(vartem),' has not been considered yet, stop' call stop2(333) @@ -1294,7 +1297,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) vartem=trim(name_metvars2d(i)) if(.not.( (trim(vartem)=='ps'.and.fv3sar_bg_opt==0).or.(trim(vartem)=="z") & .or.(trim(vartem)=="t2m").or.(trim(vartem)=="q2m") & - .or.(trim(vartem)=="howv"))) then ! z is treated separately + .or.(trim(vartem)=="howv").or.(trim(vartem)=="gust"))) then ! z is treated separately if (ifindstrloc(vardynvars,trim(vartem)) > 0) then jdynvar=jdynvar+1 fv3lam_io_dynmetvars2d_nouv(jdynvar)=trim(vartem) @@ -1557,6 +1560,12 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) if (ier/=0) call die(trim(myname),'cannot get pointers for howv, ier=',ier) endif +!--- wind gust (gust) + if ( i_gust_3dda == 1 ) then + call GSI_BundleGetPointer(GSI_MetGuess_Bundle(it),'gust',ges_gust,istatus ); ier=ier+istatus + if (ier/=0) call die(trim(myname),'cannot get pointers for gust, ier=',ier) + endif + if(mype == 0 ) then call check(nf90_open(fv3filenamegin(it)%dynvars,nf90_nowrite,loc_id)) call check(nf90_inquire(loc_id,formatNum=ncfmt)) @@ -1739,7 +1748,8 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) endif - call gsi_fv3ncdf2d_read(fv3filenamegin(it),it,ges_z,ges_t2m,ges_q2m,ges_howv) + call gsi_fv3ncdf2d_read(fv3filenamegin(it),it,ges_z,ges_t2m,ges_q2m, & + ges_howv,ges_gust) if(i_use_2mq4b > 0 .and. i_use_2mt4b > 0 ) then ! Convert 2m guess mixing ratio to specific humidity @@ -1975,7 +1985,8 @@ end subroutine gsi_bundlegetpointer_fv3lam_tracerchem_nouv end subroutine read_fv3_netcdf_guess -subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) +subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m, & + ges_howv,ges_gust) !$$$ subprogram documentation block ! . . . . ! subprogram: gsi_fv3ncdf2d_read @@ -2022,6 +2033,7 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) 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 + real(r_kind), intent(in),dimension(:,:),pointer::ges_gust type (type_fv3regfilenameg),intent(in) :: fv3filenamegin character(len=max_varname_length) :: name @@ -2036,8 +2048,8 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) integer(i_kind) kk,n,ns,j,ii,jj,mm1 character(len=:),allocatable :: sfcdata !='fv3_sfcdata' character(len=:),allocatable :: dynvars !='fv3_dynvars' -! for checking the existence of howv in firstguess file - integer(i_kind) id_howv +! for checking the existence of howv/gust in firstguess file + integer(i_kind) id_howv, id_gust integer(i_kind) iret_bcast ! for io_layout > 1 @@ -2057,8 +2069,9 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) allocate(work(itotsub*n2d)) allocate( sfcn2d(lat2,lon2,n2d)) -!-- initialisation of the array for howv +!-- initialisation of the array for howv/gust sfcn2d(:,:,k_howv) = zero + sfcn2d(:,:,k_gust) = zero !-- initialisation of the array for sfc_var_exist sfc_var_exist = .false. @@ -2107,6 +2120,21 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) trim(sfcdata), ', iret, varid = ',iret, id_howv,' (on pe: ', mype,').' end if end if +!--- check the existence of wind gust (gust) in 2D FV3-LAM firstguess file +! (similar as done above for howv) + if ( i_gust_3dda == 1 ) then + iret = nf90_inq_varid(gfile_loc,'gust',id_gust) + if ( iret /= nf90_noerr ) then + iret = nf90_inq_varid(gfile_loc,'GUST',id_gust) ! double check with name in uppercase + end if + if ( iret /= nf90_noerr ) then + i_gust_3dda = 0 ! gust does not exist in firstguess, then stop GSI run. + call die('gsi_fv3ncdf2d_read','Warning: CANNOT find gust in firstguess, aborting..., iret = ', iret) + else + write(6,'(1x,A,1x,A,1x,A,1x,I4,1x,I4,1x,A,1x,I4.4,A)') 'gsi_fv3ncdf2d_read:: Found gust in firstguess ', & + trim(sfcdata), ', iret, varid = ',iret, id_gust,' (on pe: ', mype,').' + end if + end if !!!!!!!!!!!! read in 2d variables !!!!!!!!!!!!!!!!!!!!!!!!!! do i=ndimensions+1,nvariables @@ -2150,6 +2178,9 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) else if( trim(name)=='HOWV'.or.trim(name)=='howv' ) then k=k_howv sfc_var_exist(k) = .true. + else if( trim(name)=='GUST'.or.trim(name)=='gust' ) then + k=k_gust + sfc_var_exist(k) = .true. else cycle endif @@ -2283,8 +2314,9 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) if(allocated(sfc_fulldomain)) deallocate (sfc_fulldomain) endif ! mype -!-- broadcast the updated i_howv_3dda to all tasks (!!!!) +!-- broadcast the updated i_howv_3dda, i_gust_3dda to all tasks (!!!!) call mpi_bcast(i_howv_3dda, 1, mpi_itype, mype_2d, mpi_comm_world, iret_bcast) + call mpi_bcast(i_gust_3dda, 1, mpi_itype, mype_2d, mpi_comm_world, iret_bcast) !-- broadcast the updated sfc_var_exist to all tasks (!!!!) call mpi_bcast(sfc_var_exist, n2d, mpi_itype, mype_2d, mpi_comm_world, iret_bcast) @@ -2313,6 +2345,9 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) if ( i_howv_3dda == 1 ) then if ( sfc_var_exist(k_howv) ) ges_howv(:,:)=sfcn2d(:,:,k_howv) endif + if ( i_gust_3dda == 1 ) then + if ( sfc_var_exist(k_gust) ) ges_gust(:,:)=sfcn2d(:,:,k_gust) + endif deallocate (sfcn2d,a) return end subroutine gsi_fv3ncdf2d_read @@ -3628,6 +3663,7 @@ subroutine wrfv3_netcdf(fv3filenamegin) real(r_kind),pointer,dimension(:,: ):: ges_t2m =>NULL() real(r_kind),pointer,dimension(:,: ):: ges_q2m =>NULL() real(r_kind),pointer,dimension(:,: ):: ges_howv =>NULL() + real(r_kind),pointer,dimension(:,: ):: ges_gust =>NULL() integer(i_kind) i,k @@ -3750,6 +3786,9 @@ subroutine wrfv3_netcdf(fv3filenamegin) if ( i_howv_3dda == 1 ) then call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'howv',ges_howv,istatus); ier=ier+istatus endif + if ( i_gust_3dda == 1 ) then + call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'gust',ges_gust,istatus); ier=ier+istatus + endif if (ier/=0) call die('wrfv3_netcdf','cannot get pointers for fv3 met-fields, ier =',ier) if (laeroana_fv3cmaq) then @@ -3964,6 +4003,10 @@ subroutine wrfv3_netcdf(fv3filenamegin) if ( i_howv_3dda == 1 ) then call gsi_fv3ncdf_write_sfc(fv3filenamegin,'howv',ges_howv,add_saved) endif +!-- output analysis of gust + if ( i_gust_3dda == 1 ) then + call gsi_fv3ncdf_write_sfc(fv3filenamegin,'gust',ges_gust,add_saved) + endif if(allocated(g_prsi)) deallocate(g_prsi) diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index 8a1ce896bb..d7f5667252 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -184,7 +184,7 @@ module gsimod cld_bld_coverage,cld_clr_coverage,& i_cloud_q_innovation,i_ens_mean,DTsTmax,& i_T_Q_adjust,l_saturate_bkCloud,l_rtma3d,i_precip_vertical_check, & - corp_howv, hwllp_howv + corp_howv, hwllp_howv, corp_gust, hwllp_gust, oerr_gust use gsi_metguess_mod, only: gsi_metguess_init,gsi_metguess_final use gsi_chemguess_mod, only: gsi_chemguess_init,gsi_chemguess_final use tcv_mod, only: init_tcps_errvals,tcp_refps,tcp_width,tcp_ermin,tcp_ermax @@ -1604,6 +1604,9 @@ module gsimod ! = 0.42 meters (default) ! hwllp_howv - real, background error de-correlation length scale of howv ! = 170,000.0 meters (default 170 km) +! corp_gust - real, static background error of gust (stddev error) +! hwllp_gust - real, background error de-correlation length scale of gust +! oerr_gust - real, observation error of gust ! namelist/rapidrefresh_cldsurf/dfi_radar_latent_heat_time_period, & metar_impact_radius,metar_impact_radius_lowcloud, & @@ -1625,7 +1628,7 @@ module gsimod cld_bld_coverage,cld_clr_coverage,& i_cloud_q_innovation,i_ens_mean,DTsTmax, & i_T_Q_adjust,l_saturate_bkCloud,l_rtma3d,i_precip_vertical_check, & - corp_howv, hwllp_howv + corp_howv, hwllp_howv, corp_gust, hwllp_gust, oerr_gust ! chem(options for gsi chem analysis) : ! berror_chem - .true. when background for chemical species that require diff --git a/src/gsi/m_berror_stats_reg.f90 b/src/gsi/m_berror_stats_reg.f90 index 8730e56c3b..d7a30808e6 100644 --- a/src/gsi/m_berror_stats_reg.f90 +++ b/src/gsi/m_berror_stats_reg.f90 @@ -313,6 +313,7 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt use mpeu_util,only: getindex use radiance_mod, only: icloud_cv,n_clouds_fwd,cloud_names_fwd use chemmod, only: berror_fv3_cmaq_regional,berror_fv3_sd_regional + use rapidrefresh_cldsurf_mod, only: corp_gust, hwllp_gust, l_rtma3d implicit none @@ -825,11 +826,35 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt ! end if else if (n==nrf2_gust) then do i=1,mlat - corp(i,n)=three + corp(i,n)=three ! background error stddev of wind gust = 3 m/s (default: legacy code from 2DRTMA) end do do i=0,mlat+1 - hwllp(i,n)=hwll(i,1,nrf3_q) + hwllp(i,n)=hwll(i,1,nrf3_q) ! de-correlation length of bkgd error of gust is + ! same as the value of q at bottom level (default: legacy code from 2DRTMA) + ! for other DA apps, it is recommended to change it + ! by setting hwllp_gust in GSI namelist. end do + if ( l_rtma3d ) then ! For 3drtma only: allowing to change the stddev and + ! de-correlation length of bkgd error of gust: + ! corp_gust : set in namelist(if <=0, using default value above (3.0) + ! hwllp_gust: set in namelist(if <=0, using default value above (value of q) + if ( corp_gust .gt. 0.0_r_kind ) then + corp(1:mlat, n) = corp_gust + if (mype==0) write(6,'(1x,A,A,I5.5,A,F8.3)') & + myname_,"@pe=",mype," (3drtma) set b_error stddev of gust = ",corp_gust + else + if (mype==0) write(6,'(1x,A,A,I5.5,A,F8.3)') & + myname_,"@pe=",mype," (3drtma) set b_error stddev of gust (default) = ",three + end if + if ( hwllp_gust .gt. 0.0_r_kind ) then + hwllp(0:mlat+1,n) = hwllp_gust + if (mype==0) write(6,'(1x,A,A,I5.5,A,F12.3)') & + myname_,"@pe=",mype," (3drtma) set b_error de-corr length of gust = ",hwllp_gust + else + if (mype==0) write(6,'(1x,A,A,I5.5,A)') & + myname_,"@pe=",mype," (3drtma) set b_error de-corr length of gust is same as length of q." + end if + end if else if (n==nrf2_vis) then do i=1,mlat corp(i,n)=3.0_r_kind diff --git a/src/gsi/rapidrefresh_cldsurf_mod.f90 b/src/gsi/rapidrefresh_cldsurf_mod.f90 index 122d2872d0..475f44a9d3 100644 --- a/src/gsi/rapidrefresh_cldsurf_mod.f90 +++ b/src/gsi/rapidrefresh_cldsurf_mod.f90 @@ -197,6 +197,30 @@ module rapidrefresh_cldsurf_mod ! just the reduced static BE of howv. If to make the analysis of howv ! in hyrbid run is as similar as the analysis of howv in pure 3dvar run, ! the static BE of howv used in hybrid run needs to be tuned (inflated actually). +! corp_gust - namelist real, static BE of gust (standard error deviation) +! note: 1. initialised to be an arbitary negative value, in order to skip this +! negative value, instead to use value (3.0 m/s) set in subroutine +! berror_read_wgt_reg as default. +! 2. (3drtma only) if a user-specified value (e.g., 2.0 m/s) is preferred +! for corp_gust, in GSI namelist session "rapidrefresh_cldsurf", +! set "corp_gust=2.0," +! hwllp_gust - namelist real, static BE de-correlation length scale of gust +! note: 1. initialised to be an arbitary negative value, in order to skip this +! negative value, instead to use value (same value for q) set in +! subroutine berror_read_wgt_reg as default +! 2. (3drtma only) if a user-specified value (e.g., 100 km) is preferred +! for hwllp_gust, in GSI namelist session "rapidrefresh_cldsurf", +! set "hwllp_gust=100000.0," +! oerr_gust - namelist real, observation error of gust +! note: 1. initialised to be an arbitary negative value, in order to skip this +! negative value, instead to use value (1.0 m/s) set in read_prepbufr.f90 +! 2. (3drtma only) if a user-specified value (e.g., 1.5 m/s ) is preferred +! for oerr_gust, in GSI namelist session "rapidrefresh_cldsurf", +! set "oerr_gust=1.5," +! i_gust_3dda - integer, control the analysis of gust in 3D analysis (either var or hybrid) +! = 0 (gust-off: default) : no analysis of gust in 3D analysis. +! = 1 (gust-on) : if variable name "gust" is found in anavinfo, +! set it to be 1 to turn on analysis of gust; ! ! attributes: ! language: f90 @@ -270,6 +294,8 @@ module rapidrefresh_cldsurf_mod public :: i_precip_vertical_check public :: corp_howv, hwllp_howv public :: i_howv_3dda + public :: corp_gust, hwllp_gust, oerr_gust + public :: i_gust_3dda logical l_hydrometeor_bkio real(r_kind) dfi_radar_latent_heat_time_period @@ -330,6 +356,8 @@ module rapidrefresh_cldsurf_mod integer(i_kind) i_precip_vertical_check real(r_kind) :: corp_howv, hwllp_howv integer(i_kind) :: i_howv_3dda + real(r_kind) :: corp_gust, hwllp_gust, oerr_gust + integer(i_kind) :: i_gust_3dda contains @@ -447,6 +475,22 @@ subroutine init_rapidrefresh_cldsurf corp_howv = 0.42_r_kind ! 0.42 meters (default) hwllp_howv = 170000.0_r_kind ! 170,000.0 meters (170km as default for 3DRTMA, 50km is used in 2DRTMA) i_howv_3dda = 0 ! no analysis of significant wave height (howv) in 3D analysis (default) + corp_gust = -1.50_r_kind ! initialised as negative & void to be skipped, in order to use + ! the value (3.0 m/s) set in sub berror_read_wgt_reg (as default). + ! If user-specified value is preferred, set it in session + ! "rapidrefresh_cldsurf" of GSI namelist file + + hwllp_gust = -90000.0_r_kind ! initialised as a value, in order to skip this negative value + ! and to use the value (used for q) set in sub berror_read_wgt_reg. + ! If user-specified value is preferred, set it in session + ! "rapidrefresh_cldsurf" of GSI namelist file + + oerr_gust = -2.5_r_kind ! initialised as a negative value, in order to skip this negative value + ! and to use the value (1.0 m/s) set in read_prepbufr.f90 + ! If user-specified value is preferred, set it in session + ! "rapidrefresh_cldsurf" of GSI namelist file + + i_gust_3dda = 0 ! no analysis of wind gust (gust) in 3D analysis (default) !-- searching for specific variable in state variable list (reading from anavinfo) do i2=1,ns2d @@ -456,6 +500,12 @@ subroutine init_rapidrefresh_cldsurf write(6,'(1x,A,1x,A8,1x,A,1x,I4)')"init_rapidrefresh_cldsurf: anavinfo svars2d (state variable): ",trim(adjustl(svars2d(i2))), " is found in anavinfo, set i_howv_3dda = ", i_howv_3dda end if end if + if ( trim(svars2d(i2))=='gust' .or. trim(svars2d(i2))=='GUST' ) then + i_gust_3dda = 1 + if ( mype == 0 ) then + write(6,'(1x,A,1x,A8,1x,A,1x,I4)')"init_rapidrefresh_cldsurf: anavinfo svars2d (state variable): ",trim(adjustl(svars2d(i2))), " is found in anavinfo, set i_gust_3dda = ", i_gust_3dda + end if + end if end do ! i2 : looping over 2-D anasv return diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index f281573a4e..bed3b31db2 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -227,7 +227,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& use adjust_cloudobs_mod, only: adjust_convcldobs,adjust_goescldobs use mpimod, only: npe use rapidrefresh_cldsurf_mod, only: i_gsdsfc_uselist,i_gsdqc,i_ens_mean - use rapidrefresh_cldsurf_mod, only: l_rtma3d + use rapidrefresh_cldsurf_mod, only: l_rtma3d, oerr_gust use gsi_io, only: verbose use phil2, only: denest ! hilbert curve @@ -1825,6 +1825,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& gustqm=0 if (kx==188 .or. kx==288 .or. kx==195 .or. kx==295 ) & call get_gustqm(kx,c_station_id,c_prvstg,c_sprvstg,gustqm) + if ( l_rtma3d ) gustqm = 0 ! skipping get_gustqm for 3drtma run (missing list file) qm=gustqm else if(visob) then visqm=0 ! need to fix this later @@ -2556,6 +2557,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! need to find out gustoe ! gustoe=1.8 gustoe=1.0 + if ( l_rtma3d .and. oerr_gust > 0.0_r_kind ) gustoe = oerr_gust selev=stnelev oelev=obsdat(4,k) if(selev == oelev)oelev=r10+selev @@ -2577,6 +2579,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if ((kx==188).or.(kx==288) .or.(kx==195) .or.(kx==295)) then ! gustoe=2.5 gustoe=1.0 + if ( l_rtma3d .and. oerr_gust > 0.0_r_kind ) gustoe = oerr_gust windcorr=abs(obsdat(5,k))<1.0 .and. abs(obsdat(6,k))<1.0 .and. obsdat(8,k)>10.0 if (windcorr) gustoe=gustoe*1.5_r_kind From b401c4776af7eb892d5087d7d1ebdfbf342ab6c6 Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Wed, 17 Apr 2024 17:06:13 +0000 Subject: [PATCH 075/109] Fix minor thinning annoyances. GSI #731 --- src/gsi/read_atms.f90 | 5 ----- src/gsi/satthin.F90 | 11 ++++++++--- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/gsi/read_atms.f90 b/src/gsi/read_atms.f90 index c6ed159068..424843a7c1 100644 --- a/src/gsi/read_atms.f90 +++ b/src/gsi/read_atms.f90 @@ -544,11 +544,6 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& dlat_earth = dlat_earth*deg2rad dlon_earth = dlon_earth*deg2rad -! Just use every fifth scan position and scanline (and make sure that we have -! position 48 as we need it for scan bias) - if (5*NINT(REAL(IScan(Iob))/5_r_kind) /= IScan(IOb) .OR. & - 5*NINT(REAL(IFov-3)/5_r_kind) /= IFOV -3 ) CYCLE ObsLoop - ! Regional case if(regional)then call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) diff --git a/src/gsi/satthin.F90 b/src/gsi/satthin.F90 index 93f193014f..c093c4b1d5 100644 --- a/src/gsi/satthin.F90 +++ b/src/gsi/satthin.F90 @@ -350,7 +350,7 @@ subroutine makegvals end subroutine makegvals - subroutine makegrids(rmesh,ithin,n_tbin) + subroutine makegrids(rmesh,ithin,n_tbin,itxmax_in) !$$$ subprogram documentation block ! . . . . ! subprogram: makegrids @@ -386,7 +386,8 @@ subroutine makegrids(rmesh,ithin,n_tbin) real(r_kind) ,intent(in ) :: rmesh integer(i_kind),intent(in ) :: ithin - integer(i_kind),intent(in ), optional :: n_tbin + integer(i_kind),intent(in ), optional :: n_tbin + integer(i_kind),intent(in ), optional :: itxmax_in real(r_kind),parameter:: r360 = 360.0_r_kind integer(i_kind) i,j integer(i_kind) mlonx,mlonj @@ -402,7 +403,11 @@ subroutine makegrids(rmesh,ithin,n_tbin) itx_all=0 if(abs(rmesh) <= one .or. ithin <= 0)then use_all=.true. - itxmax=1e9 + if (present(itxmax_in)) then + itxmax = itxmax_in + else + itxmax = 1e7 + endif allocate(icount(itxmax)) allocate(score_crit(itxmax)) do j=1,itxmax From d75f44a34419e719e78cc2fb21b33fcfa428ada7 Mon Sep 17 00:00:00 2001 From: Andrew Collard <40322596+ADCollard@users.noreply.github.com> Date: Thu, 18 Apr 2024 14:30:17 -0400 Subject: [PATCH 076/109] Two small tweaks to thinning (#734) This PR addresses GSI #731. It modifies the satthin.F90 routine to allow data to be processed unthinned in the GSI without requiring exorbitant resources and it removes an unnecessary thinning from the read_atms.f90 routine. The change to satthin reduces the value of `itxmax` from 1.e9 to 1.e7 which should be sufficient for most sensors. But if a larger number is required for a sensor, this may be passed in via optional argument. This change will change results for ATMS only as documented in the issue. --- src/gsi/read_atms.f90 | 5 ----- src/gsi/satthin.F90 | 11 ++++++++--- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/gsi/read_atms.f90 b/src/gsi/read_atms.f90 index c6ed159068..424843a7c1 100644 --- a/src/gsi/read_atms.f90 +++ b/src/gsi/read_atms.f90 @@ -544,11 +544,6 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& dlat_earth = dlat_earth*deg2rad dlon_earth = dlon_earth*deg2rad -! Just use every fifth scan position and scanline (and make sure that we have -! position 48 as we need it for scan bias) - if (5*NINT(REAL(IScan(Iob))/5_r_kind) /= IScan(IOb) .OR. & - 5*NINT(REAL(IFov-3)/5_r_kind) /= IFOV -3 ) CYCLE ObsLoop - ! Regional case if(regional)then call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) diff --git a/src/gsi/satthin.F90 b/src/gsi/satthin.F90 index 93f193014f..c093c4b1d5 100644 --- a/src/gsi/satthin.F90 +++ b/src/gsi/satthin.F90 @@ -350,7 +350,7 @@ subroutine makegvals end subroutine makegvals - subroutine makegrids(rmesh,ithin,n_tbin) + subroutine makegrids(rmesh,ithin,n_tbin,itxmax_in) !$$$ subprogram documentation block ! . . . . ! subprogram: makegrids @@ -386,7 +386,8 @@ subroutine makegrids(rmesh,ithin,n_tbin) real(r_kind) ,intent(in ) :: rmesh integer(i_kind),intent(in ) :: ithin - integer(i_kind),intent(in ), optional :: n_tbin + integer(i_kind),intent(in ), optional :: n_tbin + integer(i_kind),intent(in ), optional :: itxmax_in real(r_kind),parameter:: r360 = 360.0_r_kind integer(i_kind) i,j integer(i_kind) mlonx,mlonj @@ -402,7 +403,11 @@ subroutine makegrids(rmesh,ithin,n_tbin) itx_all=0 if(abs(rmesh) <= one .or. ithin <= 0)then use_all=.true. - itxmax=1e9 + if (present(itxmax_in)) then + itxmax = itxmax_in + else + itxmax = 1e7 + endif allocate(icount(itxmax)) allocate(score_crit(itxmax)) do j=1,itxmax From 457510c72e486b7b01db09e5b1a6f407778dc772 Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Mon, 22 Apr 2024 09:16:16 -0400 Subject: [PATCH 077/109] reorder correlated error setup checks (#736) --- src/gsi/correlated_obsmod.F90 | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/gsi/correlated_obsmod.F90 b/src/gsi/correlated_obsmod.F90 index 7a14cd3226..17cd94efe1 100644 --- a/src/gsi/correlated_obsmod.F90 +++ b/src/gsi/correlated_obsmod.F90 @@ -961,14 +961,18 @@ subroutine upd_varch_ enddo nchanl1=jc - if(nchanl1==0) call die(myname_,' improperly set GSI_BundleErrorCov') if(.not.amiset_(GSI_BundleErrorCov(itbl))) then - if (iamroot_) write(6,*) 'WARNING: Error Covariance not set for ',trim(idnames(itbl)) + if (iamroot_) write(6,*) trim(myname_), ' WARNING: Error Covariance not set for ',trim(idnames(itbl)) cycle read_tab endif nch_active=GSI_BundleErrorCov(itbl)%nch_active - if(nch_active<0) return + if(nch_active<0) then + if (iamroot_) write(6,*) trim(myname_), ' WARNING: No active channels for ',trim(idnames(itbl)) + return + endif + + if(nchanl1==0) call die(myname_,' improperly set GSI_BundleErrorCov') if(GMAO_ObsErrorCov)then do jj=1,nch_active From 8e279f9c734097f673b07e80f385b2623d13ba4a Mon Sep 17 00:00:00 2001 From: Innocent Souopgui <162634017+InnocentSouopgui-NOAA@users.noreply.github.com> Date: Thu, 25 Apr 2024 14:45:32 -0500 Subject: [PATCH 078/109] Update Jet modulefiles to Rocky8 (#733) - Update Jet module file to use Rocky8 installation of spack-stack; --- modulefiles/gsi_jet.intel.lua | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modulefiles/gsi_jet.intel.lua b/modulefiles/gsi_jet.intel.lua index cc43e98260..48189ba241 100644 --- a/modulefiles/gsi_jet.intel.lua +++ b/modulefiles/gsi_jet.intel.lua @@ -1,7 +1,7 @@ help([[ ]]) -prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/spack-stack/spack-stack-1.6.0/envs/gsi-addon-dev/install/modulefiles/Core") +prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/spack-stack/spack-stack-1.6.0/envs/gsi-addon-dev-rocky8/install/modulefiles/Core") local python_ver=os.getenv("python_ver") or "3.11.6" local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.5.0" From 8a85d7c9dcc4b63e1792fda75ca9a405f3ba9dc2 Mon Sep 17 00:00:00 2001 From: James Jung Date: Mon, 29 Apr 2024 14:35:25 -0400 Subject: [PATCH 079/109] Add _CLDDET.NL to fix and activate CADS in global_4denvar ctest (#740) --- fix | 2 +- regression/global_4denvar.sh | 4 ++++ regression/regression_namelists.sh | 2 +- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/fix b/fix index 92de100c4d..a801d5cf07 160000 --- a/fix +++ b/fix @@ -1 +1 @@ -Subproject commit 92de100c4d5893e9d6409afbdda6937b0de1cb3b +Subproject commit a801d5cf07c3955e71258a0c8e9b074bb0f03fe4 diff --git a/regression/global_4denvar.sh b/regression/global_4denvar.sh index 056815228b..177ce0f8a9 100755 --- a/regression/global_4denvar.sh +++ b/regression/global_4denvar.sh @@ -128,6 +128,8 @@ errtable=$fixgsi/prepobs_errtable.global aeroinfo=$fixgsi/global_aeroinfo.txt atmsbeaminfo=$fixgsi/atms_beamwidth.txt cloudyinfo=$fixgsi/cloudy_radiance_info.txt +cris_clddet=$fixgsi/CRIS_CLDDET.NL +iasi_clddet=$fixgsi/IASI_CLDDET.NL emiscoef_IRwater=$fixcrtm/Nalli.IRwater.EmisCoeff.bin emiscoef_IRice=$fixcrtm/NPOESS.IRice.EmisCoeff.bin @@ -169,6 +171,8 @@ $ncp $errtable ./errtable $ncp $aeroinfo ./aeroinfo $ncp $atmsbeaminfo ./atms_beamwidth.txt $ncp $cloudyinfo ./cloudy_radiance_info.txt +$ncp $cris_clddet ./CRIS_CLDDET.NL +$ncp $iasi_clddet ./IASI_CLDDET.NL $ncp $bufrtable ./prepobs_prep.bufrtable $ncp $bftab_sst ./bftab_sstphr diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh index 552bc1ba59..620f776526 100755 --- a/regression/regression_namelists.sh +++ b/regression/regression_namelists.sh @@ -68,7 +68,7 @@ export gsi_namelist=" dfact=0.75,dfact1=3.0,noiqc=.true.,oberrflg=.false.,c_varqc=0.04, use_poq7=.true.,qc_noirjaco3_pole=.true.,vqc=.false.,nvqc=.true.,hub_norm=.true., aircraft_t_bc=.true.,biaspredt=1.0e5,upd_aircraft=.true.,cleanup_tail=.true., - tcp_width=70.0,tcp_ermax=7.35, + tcp_width=70.0,tcp_ermax=7.35,cris_cads=.true.,iasi_cads=.true., $OBSQC / &OBS_INPUT From a3a26336dcf4de3bac4afe8fbe790947e51af4db Mon Sep 17 00:00:00 2001 From: ShunLiu-NOAA Date: Mon, 29 Apr 2024 22:45:49 -0400 Subject: [PATCH 080/109] nread bug in read_radar.f90 (#738) In read_radar.f90, the value of nread should be "nsuper2_kept" and shouldn't be reset to zero after processing TDR data. - [x] Bug fix (non-breaking change which fixes an issue) --- src/gsi/read_radar.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/gsi/read_radar.f90 b/src/gsi/read_radar.f90 index a824bbbe4e..84a4f4fbcf 100644 --- a/src/gsi/read_radar.f90 +++ b/src/gsi/read_radar.f90 @@ -907,6 +907,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu end do superobs close(lnbufr) ! A simple unformatted fortran file should not be mixed with a bufr I/O + nread=nsuper2_kept LEVEL_TWO_READ_2: if(loop==0 .and. sis=='l2rw') then write(6,*)'READ_RADAR: ',trim(outmessage),' reached eof on 2/2.5/3 superob radar file' @@ -2176,7 +2177,6 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu ibadstaheight=0 notgood=0 notgood0=0 - nread=0 ntdrvr_in=0 ntdrvr_kept=0 ntdrvr_thin1=0 @@ -2522,7 +2522,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu end do ! end of loop, reading TDR so data files close(lnbufr) - else + else if (trim(infile) == 'tldplrbufr' ) then nswptype=0 nmrecs=0 From 38bdb95640b72fb335092857680dd2f16e29940e Mon Sep 17 00:00:00 2001 From: Wei Huang Date: Tue, 7 May 2024 06:53:54 -0600 Subject: [PATCH 081/109] Add module file to compile on AWS (#742) --- modulefiles/gsi_noaacloud.intel.lua | 25 +++++++++++++++++++++++++ ush/module-setup.sh | 4 ++++ 2 files changed, 29 insertions(+) create mode 100644 modulefiles/gsi_noaacloud.intel.lua diff --git a/modulefiles/gsi_noaacloud.intel.lua b/modulefiles/gsi_noaacloud.intel.lua new file mode 100644 index 0000000000..e2e019628e --- /dev/null +++ b/modulefiles/gsi_noaacloud.intel.lua @@ -0,0 +1,25 @@ +help([[ +]]) + +prepend_path("MODULEPATH", "/contrib/spack-stack/spack-stack-1.6.0/envs/gsi-addon-env/install/modulefiles/Core") + +local python_ver=os.getenv("python_ver") or "3.10.13" +local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.3.0" +local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.3.0" +local cmake_ver=os.getenv("cmake_ver") or "3.23.1" +local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1" + +load(pathJoin("stack-intel", stack_intel_ver)) +load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) +load(pathJoin("python", python_ver)) +load(pathJoin("cmake", cmake_ver)) + +load("gsi_common") +load(pathJoin("prod_util", prod_util_ver)) + +pushenv("CFLAGS", "-xHOST") +pushenv("FFLAGS", "-xHOST") + +pushenv("GSI_BINARY_SOURCE_DIR", "/contrib/Wei.Huang/data/hack-orion/fix/gsi/20240208") + +whatis("Description: GSI environment on NOAA Cloud with Intel Compilers") diff --git a/ush/module-setup.sh b/ush/module-setup.sh index c1893ab4ee..f587842f0f 100755 --- a/ush/module-setup.sh +++ b/ush/module-setup.sh @@ -75,6 +75,10 @@ elif [[ $MACHINE_ID = discover* ]]; then export PATH=$PATH:$SPACK_ROOT/bin . $SPACK_ROOT/share/spack/setup-env.sh +elif [[ $MACHINE_ID = noaacloud* ]]; then + # We are on NOAA Cloud + module purge + else echo WARNING: UNKNOWN PLATFORM 1>&2 fi From 042e1d75cb539f04056ded1fef9fb84237e123b9 Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Tue, 7 May 2024 16:16:58 -0500 Subject: [PATCH 082/109] Add additional geoval and obs outputs --- src/gsi/genstats_gps.f90 | 92 ++++++++++---- src/gsi/read_atms.f90 | 8 +- src/gsi/read_bufrtovs.f90 | 5 + src/gsi/read_gps.f90 | 80 +++++++++--- src/gsi/read_obs.F90 | 13 +- src/gsi/read_ozone.f90 | 7 +- src/gsi/read_prepbufr.f90 | 47 +++++-- src/gsi/read_satwnd.f90 | 14 ++- src/gsi/setupbend.f90 | 94 +++++++++++++- src/gsi/setupoz.f90 | 62 +++++++-- src/gsi/setuppm2_5.f90 | 113 +---------------- src/gsi/setupps.f90 | 190 ++++++++++++++++++++++++---- src/gsi/setupq.f90 | 130 ++++++++++++++++++- src/gsi/setuprad.f90 | 257 ++++++++++++++++++++++++++++++++------ src/gsi/setupt.f90 | 169 ++++++++++++++++++++++++- src/gsi/setupw.f90 | 138 +++++++++++++++++++- 16 files changed, 1169 insertions(+), 250 deletions(-) diff --git a/src/gsi/genstats_gps.f90 b/src/gsi/genstats_gps.f90 index ce90d06f50..e235cca06f 100644 --- a/src/gsi/genstats_gps.f90 +++ b/src/gsi/genstats_gps.f90 @@ -64,6 +64,15 @@ module m_gpsStats integer(i_kind) :: idv,iob ! device id and obs index for sorting real (r_kind) :: elat, elon ! earth lat-lon for redistribution !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution + !> xuanli + real(r_kind),dimension(:),pointer :: tsenges => NULL() + real(r_kind),dimension(:),pointer :: tvirges => NULL() + real(r_kind),dimension(:),pointer :: sphmges => NULL() + real(r_kind),dimension(:),pointer :: hgtlges => NULL() + real(r_kind),dimension(:),pointer :: hgtiges => NULL() + real(r_kind),dimension(:),pointer :: prslges => NULL() + real(r_kind),dimension(:),pointer :: prsiges => NULL() + !< xuanli end type gps_all_ob_type type gps_all_ob_head @@ -427,7 +436,10 @@ subroutine genstats_gps(bwork,awork,toss_gps_sub,conv_diagsave,mype) end do END DO if(icnt > 0)then - nreal =22 +!> xuanli +! nreal =22 + nreal =35 +!< xuanli ioff =nreal if (lobsdiagsave) nreal=nreal+4*miter+1 if (save_jacobian) then @@ -760,40 +772,66 @@ subroutine contents_netcdf_diag_ ! Observation class character(7),parameter :: obsclass = ' gps' - call nc_diag_metadata("Station_ID", gps_allptr%cdiag ) - call nc_diag_metadata("Observation_Class", obsclass ) + call nc_diag_metadata("Station_ID", gps_allptr%cdiag ) + call nc_diag_metadata("Observation_Class", obsclass ) obstype = gps_allptr%rdiag(1) obssubtype = gps_allptr%rdiag(2) - call nc_diag_metadata("Observation_Type", obstype ) - call nc_diag_metadata("Observation_Subtype", obssubtype ) - call nc_diag_metadata("Latitude", sngl(gps_allptr%rdiag(3)) ) - call nc_diag_metadata("Longitude", sngl(gps_allptr%rdiag(4)) ) - call nc_diag_metadata("Incremental_Bending_Angle", sngl(gps_allptr%rdiag(5)) ) - call nc_diag_metadata("Pressure", sngl(gps_allptr%rdiag(6)) ) - call nc_diag_metadata("Height", sngl(gps_allptr%rdiag(7)) ) - call nc_diag_metadata("Time", sngl(gps_allptr%rdiag(8)) ) - call nc_diag_metadata("Model_Elevation", sngl(gps_allptr%rdiag(9)) ) - call nc_diag_metadata("Setup_QC_Mark", sngl(gps_allptr%rdiag(10)) ) - call nc_diag_metadata("Prep_Use_Flag", sngl(gps_allptr%rdiag(11)) ) - call nc_diag_metadata("Analysis_Use_Flag", sngl(gps_allptr%rdiag(12)) ) - - call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(gps_allptr%rdiag(13)) ) - call nc_diag_metadata("Errinv_Input", sngl(gps_allptr%rdiag(14)) ) - call nc_diag_metadata("Errinv_Adjust", sngl(gps_allptr%rdiag(15)) ) - call nc_diag_metadata("Errinv_Final", sngl(gps_allptr%rdiag(16)) ) - call nc_diag_metadata("Observation", sngl(gps_allptr%rdiag(17)) ) - call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(gps_allptr%rdiag(17))*sngl(gps_allptr%rdiag(5)) ) - call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(gps_allptr%rdiag(17))*sngl(gps_allptr%rdiag(5)) ) - call nc_diag_metadata("GPS_Type", sngl(gps_allptr%rdiag(20)) ) - call nc_diag_metadata("Temperature_at_Obs_Location", sngl(gps_allptr%rdiag(18)) ) - call nc_diag_metadata("Specific_Humidity_at_Obs_Location", sngl(gps_allptr%rdiag(21)) ) - + call nc_diag_metadata("Observation_Type", obstype ) + call nc_diag_metadata("Observation_Subtype", obssubtype ) + call nc_diag_metadata("Latitude", sngl(gps_allptr%rdiag(3)) ) + call nc_diag_metadata("Longitude", sngl(gps_allptr%rdiag(4)) ) + call nc_diag_metadata("Incremental_Bending_Angle", sngl(gps_allptr%rdiag(5)) ) + call nc_diag_metadata("Pressure", sngl(gps_allptr%rdiag(6)*100.0) ) +! xuanli rename the variable as impact_height +! call nc_diag_metadata("Height", sngl(gps_allptr%rdiag(7)) ) + call nc_diag_metadata("Impact_Height", sngl(gps_allptr%rdiag(7)) ) + call nc_diag_metadata("Time", sngl(gps_allptr%rdiag(8)) ) + call nc_diag_metadata("Model_Elevation", sngl(gps_allptr%rdiag(9)) ) + call nc_diag_metadata("Setup_QC_Mark", sngl(gps_allptr%rdiag(10)) ) + call nc_diag_metadata("Prep_Use_Flag", sngl(gps_allptr%rdiag(11)) ) + call nc_diag_metadata("Analysis_Use_Flag", sngl(gps_allptr%rdiag(12)) ) + + call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(gps_allptr%rdiag(13)) ) + call nc_diag_metadata("Errinv_Input", sngl(gps_allptr%rdiag(14)) ) + call nc_diag_metadata("Errinv_Adjust", sngl(gps_allptr%rdiag(15)) ) + call nc_diag_metadata("Errinv_Final", sngl(gps_allptr%rdiag(16)) ) + call nc_diag_metadata("Observation", sngl(gps_allptr%rdiag(17)) ) + call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(gps_allptr%rdiag(17))*sngl(gps_allptr%rdiag(5)) ) + call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(gps_allptr%rdiag(17))*sngl(gps_allptr%rdiag(5)) ) + call nc_diag_metadata("GPS_Type", sngl(gps_allptr%rdiag(20)) ) + call nc_diag_metadata("Temperature_at_Obs_Location", sngl(gps_allptr%rdiag(18)) ) + call nc_diag_metadata("Specific_Humidity_at_Obs_Location", sngl(gps_allptr%rdiag(21)) ) +!> xuanli + call nc_diag_metadata("impact_parameter", sngl(gps_allptr%rdiag(23)) ) + call nc_diag_metadata("pccf", sngl(gps_allptr%rdiag(24)) ) + call nc_diag_metadata("reference_sat_id", int(gps_allptr%rdiag(25)) ) + call nc_diag_metadata("earth_radius_of_curvature", sngl(gps_allptr%rdiag(26)) ) + call nc_diag_metadata("geoid_height_above_reference_ellipsoid", sngl(gps_allptr%rdiag(27)) ) + call nc_diag_metadata("qfro", int(gps_allptr%rdiag(28)) ) + call nc_diag_metadata("ascending_flag", int(gps_allptr%rdiag(29)) ) + call nc_diag_metadata("sensor_azimuth_angle", sngl(gps_allptr%rdiag(30)) ) + call nc_diag_metadata("sat_constellation", int(gps_allptr%rdiag(31)) ) + call nc_diag_metadata("occulting_sat", int(gps_allptr%rdiag(32)) ) + call nc_diag_metadata("process_center", int(gps_allptr%rdiag(33)) ) + call nc_diag_metadata("atmospheric_refractivity", sngl(gps_allptr%rdiag(34)) ) +! xuanli output the altitude as height + call nc_diag_metadata("Height", sngl(gps_allptr%rdiag(35)) ) +!< xuanli if (save_jacobian) then call readarray(dhx_dx, gps_allptr%rdiag(ioff+1:nreal)) call nc_diag_data2d("Observation_Operator_Jacobian_stind", dhx_dx%st_ind(1:dhx_dx%nind)) call nc_diag_data2d("Observation_Operator_Jacobian_endind", dhx_dx%end_ind(1:dhx_dx%nind)) call nc_diag_data2d("Observation_Operator_Jacobian_val", real(dhx_dx%val(1:dhx_dx%nnz),r_single)) endif +!> xuanli + call nc_diag_data2d("atmosphere_pressure_coordinate", sngl(gps_allptr%prslges)) + call nc_diag_data2d("atmosphere_pressure_coordinate_interface", sngl(gps_allptr%prsiges)) + call nc_diag_data2d("air_temperature", sngl(gps_allptr%tsenges)) + call nc_diag_data2d("virtual_temperature", sngl(gps_allptr%tvirges)) + call nc_diag_data2d("specific_humidity", sngl(gps_allptr%sphmges)) + call nc_diag_data2d("geopotential_height", sngl(gps_allptr%hgtlges)) + call nc_diag_data2d("geopotential_height_levels", sngl(gps_allptr%hgtiges)) +!< xuanli diff --git a/src/gsi/read_atms.f90 b/src/gsi/read_atms.f90 index 9f5efb5301..1864b78e29 100644 --- a/src/gsi/read_atms.f90 +++ b/src/gsi/read_atms.f90 @@ -177,6 +177,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& real(r_kind), ALLOCATABLE, TARGET :: dlat_earth_save(:) real(r_kind), ALLOCATABLE, TARGET :: crit1_save(:) real(r_kind), ALLOCATABLE, TARGET :: lza_save(:) + real(r_kind), ALLOCATABLE, TARGET :: satheight_save(:) real(r_kind), ALLOCATABLE, TARGET :: satazi_save(:) real(r_kind), ALLOCATABLE, TARGET :: solzen_save(:) real(r_kind), ALLOCATABLE, TARGET :: solazi_save(:) @@ -352,6 +353,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& ALLOCATE(crit1_save(maxobs)) ALLOCATE(it_mesh_save(maxobs)) ALLOCATE(lza_save(maxobs)) + ALLOCATE(satheight_save(maxobs)) ALLOCATE(satazi_save(maxobs)) ALLOCATE(solzen_save(maxobs)) ALLOCATE(solazi_save(maxobs)) @@ -457,7 +459,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& panglr=(start+float(ifov-1)*step)*deg2rad satellite_height=bfr1bhdr(13) -! Ensure orbit height is reasonable + satheight_save(iob)=satellite_height if (satellite_height < 780000.0_r_kind .OR. & satellite_height > 900000.0_r_kind) satellite_height = 824000.0_r_kind rato = one + satellite_height/rearth_equator @@ -534,6 +536,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& it_mesh => it_mesh_save(iob) ifov => ifov_save(iob) lza => lza_save(iob) + satellite_height = satheight_save(iob) satazi => satazi_save(iob) solzen => solzen_save(iob) solazi => solazi_save(iob) @@ -736,7 +739,8 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& data_all(3 ,itx)= dlon ! grid relative longitude data_all(4 ,itx)= dlat ! grid relative latitude data_all(5 ,itx)= lza ! local zenith angle - data_all(6 ,itx)= satazi ! local azimuth angle + !data_all(6 ,itx)= satazi ! local azimuth angle + data_all(6 ,itx)= satellite_height ! temporary output data_all(7 ,itx)= panglr ! look angle data_all(8 ,itx)= ifovmod ! scan position data_all(9 ,itx)= solzen ! solar zenith angle diff --git a/src/gsi/read_bufrtovs.f90 b/src/gsi/read_bufrtovs.f90 index 0aed801ee5..268cdbab9d 100644 --- a/src/gsi/read_bufrtovs.f90 +++ b/src/gsi/read_bufrtovs.f90 @@ -1080,6 +1080,11 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& call count_obs(ndata,nele,ilat,ilon,data_all,nobs) write(lunout) obstype,sis,nreal,nchanl,ilat,ilon write(lunout) ((data_all(k,n),k=1,nele),n=1,ndata) +! write(6,*)'emily checking jsatid = ', jsatid +! write(6,*)'emily checking nread = ', nread +! write(6,*)'emily checking ndata = ', ndata +! write(6,*)'emily checking ndata*nchanl = ', ndata*nchanl +! write(6,*)'emily checking nodata = ', nodata end if ! Deallocate local arrays diff --git a/src/gsi/read_gps.f90 b/src/gsi/read_gps.f90 index 3d8379ee3b..916f94e652 100644 --- a/src/gsi/read_gps.f90 +++ b/src/gsi/read_gps.f90 @@ -137,21 +137,32 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & bend_error,ref_error,bend_pccf,ref_pccf real(r_kind),allocatable,dimension(:,:):: cdata_all - - integer(i_kind),parameter:: n1ahdr=10 + +!> xuanli +! integer(i_kind),parameter:: n1ahdr=10 + integer(i_kind),parameter:: n1ahdr=13 +!< xuanli real(r_double),dimension(n1ahdr):: bfr1ahdr real(r_double),dimension(50,maxlevs):: data1b real(r_double),dimension(50,maxlevs):: data2a real(r_double),dimension(maxlevs):: nreps_this_ROSEQ2 + +!> xuanli + real(r_kind):: azm_ang, sat_ascd, sat_constid, siid, ogce +!< xuanli data lnbufr/10/ - data hdr1a / 'YEAR MNTH DAYS HOUR MINU PCCF ELRC SAID PTID GEODU' / +! data hdr1a / 'YEAR MNTH DAYS HOUR MINU PCCF ELRC SAID PTID GEODU' / + data hdr1a / 'YEAR MNTH DAYS HOUR MINU PCCF ELRC SAID PTID GEODU SCLF SIID OGCE' / data nemo /'QFRO'/ !*********************************************************************************** maxobs=2e6 - nreal=maxinfo +!> xuanli +! nreal=maxinfo + nreal=24 +!< xuanli nchanl=0 ilon=2 ilat=3 @@ -170,7 +181,6 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & write(6,*)'READ GPS: CONVINFO DOES NOT INCLUDE ANY ',trim(sis),' DATA' return end if - ! Open file for input, then read bufr data open(lnbufr,file=trim(infile),form='unformatted') call openbf(lnbufr,'IN',lnbufr) @@ -214,28 +224,41 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & call ufbint(lnbufr,qfro,1,1,iret,nemo) ! observation time in minutes - idate5(1) = bfr1ahdr(1) ! year - idate5(2) = bfr1ahdr(2) ! month - idate5(3) = bfr1ahdr(3) ! day - idate5(4) = bfr1ahdr(4) ! hour - idate5(5) = bfr1ahdr(5) ! minute - pcc=bfr1ahdr(6) ! profile per cent confidence - roc=bfr1ahdr(7) ! Earth local radius of curvature - said=bfr1ahdr(8) ! Satellite identifier - ptid=bfr1ahdr(9) ! Platform transmitter ID number - geoid=bfr1ahdr(10) ! Geoid undulation + idate5(1) = bfr1ahdr(1) ! year + idate5(2) = bfr1ahdr(2) ! month + idate5(3) = bfr1ahdr(3) ! day + idate5(4) = bfr1ahdr(4) ! hour + idate5(5) = bfr1ahdr(5) ! minute + pcc=bfr1ahdr(6) ! profile per cent confidence + roc=bfr1ahdr(7) ! Earth local radius of curvature + said=bfr1ahdr(8) ! Satellite identifier + print *,' NICKE SAID2: ', said + ptid=bfr1ahdr(9) ! Platform transmitter ID number + geoid=bfr1ahdr(10) ! Geoid undulation + sat_constid=bfr1ahdr(11) ! Satellite classification + siid=bfr1ahdr(12) ! Satellite instrument + ogce = bfr1ahdr(13) ! Identification of originating/generating centre call w3fs21(idate5,minobs) ! Locate satellite id in convinfo file ikx = 0 find_loop: do i=1,ngpsro_type + print *, 'NICKE find_loop A, ', said if ( (trim(sis)==trim(gpsro_ctype(i))) .and. (said == gpsro_itype(i)) ) then ikx=gpsro_ikx(i) igpsro_type = i + print *, 'NICKE SAID,ikx,c/itype', said, ikx, gpsro_ctype(i), & + gpsro_itype exit find_loop endif end do find_loop - if (ikx==0) then + if (ikx==0) then + if(said == 803) then + print *,'NICKE 803 cycle read_loop' + endif + if(said /= 803) then + print *,'NICKE NOT 803 cycle read_loop' + endif cycle read_loop endif @@ -258,6 +281,9 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & endif ! Check profile quality flags + if (said == 803) then + print *, "NICKE SAID 803" + endif if ( ((said > 739).and.(said < 746)).or.(said == 820).or.(said == 786).or. & ((said > 749).and.(said < 756)).or.(said == 825).or.(said == 44) .or. & (said == 265).or.(said == 266).or.(said == 267).or.(said == 268).or. & @@ -296,6 +322,16 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & endif endif +!> xuanli ascending flag: when qfro bit3 is set, occultation is ascending +! bit3 is clear, occultation is descending + sat_ascd = 0.0 + call upftbv(lnbufr,nemo,qfro,mxib,ibit,nib) + if(nib > 0) then + do i=1,nib + if(ibit(i) .eq. 3) sat_ascd=1.0 + enddo + endif +!< xuanli ! Read bending angle information ! Get the number of occurences of sequence ROSEQ2 in this subset @@ -345,6 +381,7 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & nread=nread+1 ! count observations rlat=data1b(1,k) ! earth relative latitude (degrees) rlon=data1b(2,k) ! earth relative longitude (degrees) + azm_ang=data1b(3,k) ! azimuth angle !xuanli height=data2a(1,k) ref=data2a(2,k) ref_error=data2a(4,k) @@ -440,7 +477,16 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & cdata_all(14,ndata)= dlon_earth_deg ! earth relative longitude (degrees) cdata_all(15,ndata)= dlat_earth_deg ! earth relative latitude (degrees) cdata_all(16,ndata)= geoid ! geoid undulation (m) - +!> xuanli + cdata_all(17,ndata)= qfro ! qfro + cdata_all(18,ndata)= sat_ascd ! ascending flag + cdata_all(19,ndata)= azm_ang ! azimuth angle + cdata_all(20,ndata)= sat_constid ! satellite classification + cdata_all(21,ndata)= siid ! occulting satellite + cdata_all(22,ndata)= ogce ! Identification of originating/generating centre + cdata_all(23,ndata)= ref ! refractivity obs (units of N) + cdata_all(24,ndata)= height ! geometric height above geoid (m) +!< xuanli else notgood = notgood + 1 end if diff --git a/src/gsi/read_obs.F90 b/src/gsi/read_obs.F90 index 53b0723953..c031b91a1f 100644 --- a/src/gsi/read_obs.F90 +++ b/src/gsi/read_obs.F90 @@ -202,7 +202,7 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) call datelen(10) call readmg(lnbufr,subset,idate,iret) if(iret == 0)then - + print *, "NICKE IRET ", trim(filename), trim(dtype) ! Extract date and check for consistency with analysis date if (idateiadateend) then if(offtime_data) then @@ -220,6 +220,7 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) write(6,*)'***read_obs_check*** iret/=0 for reading date for ',trim(filename),dtype,jsatid,iret lexist=.false. end if + print *, 'NICKE JSATID', jsatid if(lexist)then if(jsatid == '')then kidsat=0 @@ -336,12 +337,16 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) else if ( jsatid == 'meghat' ) then kidsat = 440 else + print *, 'NICKE jsatid not avail so kidsat =0' kidsat = 0 end if + print *, 'NICKE kidsat: ', kidsat + call closbf(lnbufr) close(lnbufr) open(lnbufr,file=trim(filename),form='unformatted',status ='unknown') + print *,' NICKE FILENAMEEE ', filename call openbf(lnbufr,'IN',lnbufr) call datelen(10) @@ -402,7 +407,11 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) (said == 44) .or. (said == 5) .or. (said == 41) .or. & (said == 42) .or. (said == 43) .or. (said == 722) .or. & (said == 723).or. (said == 265).or. (said == 266) .or. & - (said == 267).or. (said == 268).or. (said == 269)) then + (said == 267).or. (said == 268).or. (said == 269) .or. & + (said == 803)) then + if(said == 803) then + print *, 'NICKE 803' + end if lexist=.true. exit gpsloop end if diff --git a/src/gsi/read_ozone.f90 b/src/gsi/read_ozone.f90 index 43dd16d5c8..c7062abbcf 100644 --- a/src/gsi/read_ozone.f90 +++ b/src/gsi/read_ozone.f90 @@ -624,7 +624,8 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & call makegrids(rmesh,ithin,n_tbin=n_tbin) ! Set dependent variables and allocate arrays - nreal=14 +! nreal=14 !orig + nreal=15 !emily (add AFBO) nloz=0 nchanl=1 nozdat=nreal+nchanl @@ -753,7 +754,9 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & ozout(12,itx)=hdrozo2(2) ! aerosol index ozout(13,itx)=hdrozo2(3) ! ascending/descending ozout(14,itx)=hdrozo2(7) ! scan position - ozout(15,itx)=totoz + ozout(15,itx)=hdrozo2(8) ! AFBO !emily + ozout(16,itx)=totoz !emily +!orig ozout(15,itx)=totoz ! End of loop over observations end do read_loop2 diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index d2cb503926..0a89034158 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -200,7 +200,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& 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 qcmod, only: errormod,errormod_aircraft,noiqc,newvad,njqc + use qcmod, only: errormod,errormod_aircraft,noiqc,newvad,njqc,errormod_test use qcmod, only: pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres use qcmod, only: nrand use nltransf, only: nltransf_forward @@ -349,6 +349,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& real(r_kind) :: tempvis,visout real(r_kind) :: tempcldch,cldchout real(r_kind) :: windsensht + real(r_kind) :: vmag, pdiffu, pdiffd real(r_double) rstation_id,qcmark_huge real(r_double) vtcd,glcd !virtual temp program code and GLERL program code @@ -475,7 +476,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if(tob)then nreal=25 else if(uvob) then - nreal=27 + nreal=34 else if(spdob) then nreal=24 else if(psob) then @@ -521,11 +522,13 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! Set qc limits based on noiqc flag if (noiqc) then + print *, "NickE noiqc" lim_qm=8 if (psob) lim_zqm=7 if (qob.or.tdob) lim_tqm=7 if (tob) lim_qqm=8 else + print *, "NickE not noiqc" lim_qm=4 if (psob) lim_zqm=4 if (qob.or.tdob) lim_tqm=4 @@ -648,6 +651,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! Extract type information call ufbint(lunin,hdr,4,1,iret,hdstr2) kx=hdr(1) + print *, "NickE kx is ", kx if (aircraft_t_bc .and. acft_profl_file) then kx0=kx if (.not. uvob) then @@ -690,6 +694,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! identify drifting buoys - TYP=180/280 T29=562 and last three digits of SID between 500 and 999 ! (see https://www.wmo.int/pages/prog/amp/mmop/wmo-number-rules.html) Set kx to 199/299 if (id_drifter .and. (kx==180 .or. kx==280) .and. nint(hdr(3))==562) then + print *, "NickE id_drifter, kx ==180or280, hdr3==562" rstation_id=hdr(4) read(c_station_id,*,iostat=ios) iwmo if (ios == 0 .and. iwmo > 0) then @@ -700,27 +705,35 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& end if if (id_ship .and. (kx==180) .and. (nint(hdr(3))==522 .or. nint(hdr(3))==523)) then + print *, "NickE id_ship, kx==180, hdr3 ==522or523" rstation_id=hdr(4) kx = kx + 18 end if if(twodvar_regional)then + print *, "NickE twodvar_regional" ! If running in 2d-var (surface analysis) mode, check to see if observation ! is surface type or GOES cloud product(kx=151). If not, read next observation report from bufr file sfctype=(kx>179.and.kx<190).or.(kx>=280.and.kx<=290).or. & (kx>=192.and.kx<=199).or.(kx>=292.and.kx<=299) .or. & (kx==151) + print *, "NickE twodvar_regional sfctype = ", sfctype if (.not.sfctype ) cycle loop_report end if ! temporary specify iobsub until put in bufr file iobsub = 0 - if(kx == 280 .or. kx == 180 ) iobsub=hdr(3) + if(kx == 280 .or. kx == 180 ) then + iobsub=hdr(3) + print *, "NickE kx==180or280 iobsub=hdr3= ", iobsub + endif if(kx == 280 .or. kx ==180) then if ( hdr(3) >555.0_r_kind .and. hdr(3) <565.0_r_kind ) then + print *, "NickE 180or280 555 0) then if(mod(iwmo,1000) >=500) then kx = kx + 19 + print *, "NickE id_drifter kx is now 19 more" end if end if end if if (id_ship .and. (kx==180) .and. (nint(hdr(8))==522 .or. nint(hdr(8))==523) ) then + print *, "NickE id_ship 2 kx is 18 more" rstation_id=hdr(1) kx = kx + 18 end if @@ -1109,7 +1125,9 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& sfctype=(kx>179.and.kx<190).or.(kx>=280.and.kx<=290).or. & (kx>=192.and.kx<=199).or.(kx>=292.and.kx<=299) - + if (sfctype) then + print *, "NickE sfctype because kx is ", kx + endif if (sfctype) then call ufbint(lunin,r_prvstg,1,1,iret,prvstr) call ufbint(lunin,r_sprvstg,1,1,iret,sprvstr) @@ -1260,8 +1278,11 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if (qob) then itypex=itypey ierr_q=0 + print *, "NickE qob itypex,y,maxsub_q",itypex,itypey,maxsub_q do i =1,maxsub_q if( icsubtype(nc) == isuble_q(itypex,i) ) then + print *,"NickE icsubtype,isuble_q", icsubtype(nc), & + isuble_q(itypex,i) ierr_q=i+1 exit else if( i == maxsub_q .and. icsubtype(nc) /= isuble_q(itypex,i)) then @@ -1279,6 +1300,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& endif endif enddo + print *, "NickE qob levs", levs do k=1,levs ppb=obsdat(1,k) if(kx==153)ppb=obsdat(11,k)*0.01_r_kind @@ -2119,7 +2141,10 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if (aircraftobs .and. aircraft_t_bc .and. acft_profl_file) then call errormod_aircraft(pqm,wqm,levs,plevs,errout,k,presl,dpres,nsig,lim_qm,hdr3) else - call errormod(pqm,wqm,levs,plevs,errout,k,presl,dpres,nsig,lim_qm) + if (trim(c_station_id) == '50774') then + call errormod_test(pqm,wqm,levs,plevs,errout,k,presl,dpres,nsig,lim_qm,vmag,pdiffu,pdiffd) + write(*,*) "Number of obs in record",c_station_id,levs + endif end if woe=obserr(5,k)*errout if (inflate_error) woe=woe*r1_2 @@ -2234,10 +2259,14 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& cdata_all(20,iout)=dlat_earth_deg ! earth relative latitude (degrees) 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 - cdata_all(24,iout)=obsdat(10,k) ! cat - cdata_all(25,iout)=var_jb(5,k) ! non linear qc parameter - cdata_all(26,iout)=one ! hilbert curve weight, modified later + !cdata_all(23,iout)=r_sprvstg(1,1) ! subprovider name + !cdata_all(24,iout)=obsdat(10,k) ! cat + !cdata_all(25,iout)=var_jb(5,k) ! non linear qc parameter + !cdata_all(26,iout)=one ! hilbert curve weight, modified later + cdata_all(23,iout)=errout ! + cdata_all(24,iout)=vmag ! Intermediate + cdata_all(25,iout)=pdiffd ! errormod + cdata_all(26,iout)=pdiffu ! variables if(perturb_obs)then cdata_all(28,iout)=ran01dom()*perturb_fact ! u perturbation cdata_all(29,iout)=ran01dom()*perturb_fact ! v perturbation diff --git a/src/gsi/read_satwnd.f90 b/src/gsi/read_satwnd.f90 index 874483c86e..af9357814f 100644 --- a/src/gsi/read_satwnd.f90 +++ b/src/gsi/read_satwnd.f90 @@ -271,7 +271,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis ! Set lower limits for observation errors werrmin=one nsattype=0 - nreal=27 + nreal=34 if(perturb_obs ) nreal=nreal+2 ntread=1 ntmatch=0 @@ -1587,10 +1587,18 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis cdata_all(25,iout)=var_jb ! non linear qc parameter cdata_all(26,iout)=one ! hilbert curve weight cdata_all(27,iout)=obsdat(5) ! AMVQ for GOES-17 mitig.AMVs + ! extra variables for satwind qc for brett + cdata_all(28,iout)=hdrdat(9) ! wind computation method + cdata_all(29,iout)=hdrdat(10) ! satellite zenith angle + cdata_all(30,iout)=hdrdat(1) ! satellite identifier + cdata_all(31,iout)=qifn ! QI without forecast + cdata_all(32,iout)=qify ! QI with forecast + cdata_all(33,iout)=ee ! expected error + cdata_all(34,iout)=pct1 if(perturb_obs)then - cdata_all(28,iout)=ran01dom()*perturb_fact ! u perturbation - cdata_all(29,iout)=ran01dom()*perturb_fact ! v perturbation + cdata_all(35,iout)=ran01dom()*perturb_fact ! u perturbation + cdata_all(36,iout)=ran01dom()*perturb_fact ! v perturbation endif enddo loop_readsb diff --git a/src/gsi/setupbend.f90 b/src/gsi/setupbend.f90 index 9bc856d67a..9238117031 100644 --- a/src/gsi/setupbend.f90 +++ b/src/gsi/setupbend.f90 @@ -147,13 +147,17 @@ subroutine setupbend(obsLL,odiagLL, & use gsi_4dvar, only: nobs_bins,hr_obsbin use guess_grids, only: ges_lnprsi,hrdifsig,geop_hgti,nfldsig + use guess_grids, only: ges_lnprsl,ges_prsi,geop_hgtl use guess_grids, only: nsig_ext,gpstop,commgpstop,commgpserrinf +!> xuanli + use guess_grids, only: ges_tsen +!< xuanli use gridmod, only: nsig use gridmod, only: get_ij,latlon11 use constants, only: fv,n_a,n_b,n_c,deg2rad,tiny_r_kind,r0_01,r18,r61,r63,r10000 use constants, only: zero,half,one,two,eccentricity,semi_major_axis,& grav_equator,somigliana,flattening,grav_ratio,grav,rd,eps,three,four,five,& - r100,r400 + r100,r400,r1000 use lagmod, only: setq, setq_TL use lagmod, only: slagdw, slagdw_TL use jfunc, only: jiter,miter,jiterstart @@ -225,10 +229,14 @@ subroutine setupbend(obsLL,odiagLL, & real(r_kind),dimension(nele,nobs):: data real(r_kind),dimension(nsig):: dbenddn,dbenddxi real(r_kind) pressure,hob_s,d_ref_rad,d_ref_rad_TL,hob_s_top + real(r_kind) hobb real(r_kind),dimension(4) :: w4,dw4,dw4_TL - + +!> xuanli integer(i_kind) ier,ilon,ilat,ihgt,igps,itime,ikx,iuse, & - iprof,ipctc,iroc,isatid,iptid,ilate,ilone,ioff,igeoid + iprof,ipctc,iroc,isatid,iptid,ilate,ilone,ioff,igeoid,iqfro + integer(i_kind) iascd, iazm, iconstid, isiid, iogce, iref, ihggt +!< xuanli integer(i_kind) i,j,k,kk,mreal,nreal,jj,ikxx,ibin integer(i_kind) mm1,nsig_up,ihob,istatus,nsigstart integer(i_kind) kprof,istat,k1,k2,nobs_out,top_layer_SR,bot_layer_SR,count_SR @@ -264,6 +272,11 @@ subroutine setupbend(obsLL,odiagLL, & real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q +!> xuanli + real(r_kind),dimension(nsig, nobs) :: Tsen,Tvir,sphm,hgtl,prslnl + real(r_kind),dimension(nsig+1,nobs) :: hgti,prslni +!< xuanli + type(obsLList),pointer,dimension(:):: gpshead logical:: commdat gpshead => obsLL(:) @@ -301,7 +314,7 @@ subroutine setupbend(obsLL,odiagLL, & !268 => PlanetiQ GNOMES-B !269 => Spire Lemur 3U CubeSat !66 => Sentinel-6 - + print *, "NICKE setupbend" ! Check to see if required guess fields are available call check_vars_(proceed) if(.not.proceed) return ! not all vars available, simply return @@ -328,6 +341,16 @@ subroutine setupbend(obsLL,odiagLL, & ilone=14 ! index of earth relative longitude (degrees) ilate=15 ! index of earth relative latitude (degrees) igeoid=16 ! index of geoid undulation (a value per profile, m) +!> xuanli + iqfro=17 ! index of qfro (integer) + iascd=18 ! index of ascending flag (integer) + iazm=19 ! index of azimuth angle + iconstid=20 ! index of classification ID (integer) + isiid=21 ! index of occulting sat (integer) + iogce=22 ! index of identification of originating (integer) + iref=23 ! index of refractivity + ihggt=24 ! index of height +!< xuanli ! Intialize variables nsig_up=nsig+nsig_ext ! extend nsig_ext levels above interface level nsig @@ -345,7 +368,8 @@ subroutine setupbend(obsLL,odiagLL, & allocate(ddnj(grids_dim),grid_s(grids_dim),ref_rad_s(grids_dim)) ! Allocate arrays for output to diagnostic file - mreal=22 +! mreal=22 ! xuanli + mreal=35 ! xuanli nreal=mreal if (lobsdiagsave) nreal=nreal+4*miter+1 if (save_jacobian) then @@ -453,6 +477,19 @@ subroutine setupbend(obsLL,odiagLL, & prsltmp_o(1:nsig,i)=prsltmp(1:nsig) ! needed in minimization + call tintrp2a1(ges_tsen, Tsen(1:nsig,i), dlat,dlon,dtime,hrdifsig, & + nsig, mype,nfldsig) + call tintrp2a1(geop_hgtl, hgtl(1:nsig,i), dlat,dlon,dtime,hrdifsig, & + nsig, mype,nfldsig) + call tintrp2a1(ges_lnprsl,prslnl(1:nsig,i),dlat,dlon,dtime,hrdifsig, & + nsig, mype,nfldsig) + + Tvir(1:nsig,i) = tges(1:nsig) ! virtual temperature + sphm(1:nsig,i) = qges(1:nsig) ! specific humidity + hgtl(1:nsig,i) = hgtl(1:nsig,i) + zsges ! mid level geopotential height + hgti(1:nsig+1,i) = hges(1:nsig+1) + zsges ! interface level geopotential height + prslni(1:nsig+1,i) = prsltmp(1:nsig+1) ! interface level log(pressure) + ! Compute refractivity index-radius product at interface ! ! Convert geopotential height at layer midpoints to geometric height using @@ -563,6 +600,8 @@ subroutine setupbend(obsLL,odiagLL, & ! Save some diagnostic information ! occultation identification satellite_id = data(isatid,i) ! receiver occ id + print *, "NICKE ALL SATELLITE IDs: " + print *, satellite_id transmitter_id = data(iptid,i) ! transmitter occ id write(cdiagbuf(i),'(2(i4.4))') satellite_id,transmitter_id @@ -573,7 +612,11 @@ subroutine setupbend(obsLL,odiagLL, & rdiagbuf(2,i) = data(iprof,i) ! profile identifier rdiagbuf(3,i) = data(ilate,i) ! lat in degrees rdiagbuf(4,i) = data(ilone,i) ! lon in degrees - rdiagbuf(7,i) = tpdpres(i)-rocprof ! impact height in meters +!> xuanli: modified imph in the diag file. In jedi: imph=impp-roc-geoid +! rdiagbuf(7,i) = tpdpres(i)-rocprof ! impact height in meters + rdiagbuf(7,i) = tpdpres(i)-rocprof-unprof ! impact height in meters +!< xuanli + ! rdiagbuf(7,i) = tpdpres(i) ! impact parameter in meters rdiagbuf(8,i) = dtime-time_offset ! obs time (hours relative to analysis time) ! rdiagbuf(9,i) = data(ipctc,i) ! input bufr qc - index of per cent confidence @@ -582,6 +625,21 @@ subroutine setupbend(obsLL,odiagLL, & rdiagbuf(17,i) = data(igps,i) ! bending angle observation (radians) rdiagbuf(19,i) = hob ! model vertical grid (interface) if monotone grid rdiagbuf(22,i) = 1.e+10_r_kind ! spread (filled in by EnKF) +!> xuanli + rdiagbuf(23,i) = tpdpres(i) ! impact parameter in meters + rdiagbuf(24,i) = data(ipctc,i) ! input bufr qc - index of per cent confidence + rdiagbuf(25,i) = data(iptid,i) ! transmitter occ id + rdiagbuf(26,i) = rocprof ! local radius of curvature (m) + rdiagbuf(27,i) = unprof ! geoid undulation (m) + rdiagbuf(28,i) = data(iqfro,i) ! qfro + rdiagbuf(29,i) = data(iascd,i) ! ascending flag + rdiagbuf(30,i) = data(iazm,i) ! azimuth angle + rdiagbuf(31,i) = data(iconstid,i) ! satellite classification + rdiagbuf(32,i) = data(isiid,i) ! occulting satellite + rdiagbuf(33,i) = data(iogce,i) ! Identification of processing center + rdiagbuf(34,i) = data(iref,i) ! refractivity + rdiagbuf(35,i) = data(ihggt,i) ! geometric height +!< xuanli - if(ratio_errors(i) > tiny_r_kind) then ! obs inside model grid @@ -624,8 +682,10 @@ subroutine setupbend(obsLL,odiagLL, & qrefges=qges_o(k1)*(one-delz)+qges_o(k2)*delz !Lidia rdiagbuf( 6,i) = ten*exp(dpressure) ! pressure at obs location (hPa) if monotone grid + ! atmosphere_pressure_coordinate rdiagbuf(18,i) = trefges ! temperature at obs location (Kelvin) if monotone grid rdiagbuf(21,i) = qrefges ! specific humidity at obs location (kg/kg) if monotone grid + commdat=.false. if (data(isatid,i)>=265 .and. data(isatid,i)<=269) commdat=.true. if (.not. qcfail(i)) then ! not SR @@ -1027,6 +1087,28 @@ subroutine setupbend(obsLL,odiagLL, & gps_alltail(ibin)%head%elat= data(ilate,i) gps_alltail(ibin)%head%elon= data(ilone,i) +! 2 dimensional geovals for JEDI + allocate(gps_alltail(ibin)%head%tvirges(nsig),stat=istatus) + allocate(gps_alltail(ibin)%head%tsenges(nsig),stat=istatus) + allocate(gps_alltail(ibin)%head%sphmges(nsig),stat=istatus) + allocate(gps_alltail(ibin)%head%hgtlges(nsig),stat=istatus) + allocate(gps_alltail(ibin)%head%hgtiges(nsig+1),stat=istatus) + allocate(gps_alltail(ibin)%head%prsiges(nsig+1),stat=istatus) + allocate(gps_alltail(ibin)%head%prslges(nsig),stat=istatus) + + do j= 1, nsig + gps_alltail(ibin)%head%tvirges(j) = Tvir(j,i) + gps_alltail(ibin)%head%tsenges(j) = Tsen(j,i) + gps_alltail(ibin)%head%sphmges(j) = sphm(j,i) + gps_alltail(ibin)%head%hgtlges(j) = hgtl(j,i) + gps_alltail(ibin)%head%prslges(j) = 1000.0*exp(prslnl(j,i)) + end do + + do j= 1, nsig + 1 + gps_alltail(ibin)%head%hgtiges(j) = hgti(j,i) + gps_alltail(ibin)%head%prsiges(j) = 1000.0*exp(prslni(j,i)) + end do + allocate(gps_alltail(ibin)%head%rdiag(nreal),stat=istatus) if (istatus/=0) write(6,*)'SETUPBEND: allocate error for gps_alldiag, istatus=',istatus diff --git a/src/gsi/setupoz.f90 b/src/gsi/setupoz.f90 index 24381df447..cce8970ee0 100644 --- a/src/gsi/setupoz.f90 +++ b/src/gsi/setupoz.f90 @@ -113,7 +113,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& use state_vectors, only: svars3d, levels use constants, only : zero,half,one,two,tiny_r_kind - use constants, only : rozcon,cg_term,wgtlim,h300,r10 + use constants, only : rozcon,cg_term,wgtlim,h300,r10,r100,r1000,constoz use m_obsdiagNode, only : obs_diag use m_obsdiagNode, only : obs_diags @@ -201,6 +201,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& real(r_kind),dimension(nlevs):: pobs,gross,tnoise real(r_kind),dimension(nreal+nlevs,nobs):: data real(r_kind),dimension(nsig+1)::prsitmp + real(r_kind),dimension(nsig)::ozgestmp ! GeoVaLs for JEDI/UFO real(r_single),dimension(nlevs):: pob4,grs4,err4 real(r_single),dimension(ireal,nobs):: diagbuf real(r_single),allocatable,dimension(:,:,:)::rdiagbuf @@ -214,10 +215,10 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& type(sparr2) :: dhx_dx integer(i_kind) i,nlev,ii,jj,iextra,ibin, kk, nperobs - integer(i_kind) k,j,nz,jc,idia,irdim1,istatus,ioff0 + integer(i_kind) k1,k2,k,j,nz,jc,idia,irdim1,istatus,ioff0 integer(i_kind) ioff,itoss,ikeep,ierror_toq,ierror_poq integer(i_kind) isolz,ifovn,itoqf - integer(i_kind) mm1,itime,ilat,ilon,ilate,ilone,itoq,ipoq + integer(i_kind) mm1,itime,ilat,ilon,ilate,ilone,itoq,ipoq,iafbo !emily integer(i_kind),dimension(iint,nobs):: idiagbuf integer(i_kind),dimension(nlevs):: ipos,iouse,ikeepk @@ -252,6 +253,9 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& call init_vars_ mm1=mype+1 + + write(6,*)'emily checking: you are here ...', myname, obstype + ! !********************************************************************************* ! Initialize arrays @@ -345,7 +349,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& isolz=8 ! index of solar zenith angle (gome and omi only) itoqf=9 ! index of row anomaly (omi only) ifovn=14 ! index of scan position (gome and omi only) - + iafbo=15 ! index of algorithm flag for best ozone (for omi, ompsnm, and ompstc8) !emily ! If requested, save data for diagnostic ouput if(ozone_diagsave)ii=0 @@ -409,7 +413,13 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& ozp_omi(nloz_omi) = prsitmp(1) call grdcrd1(ozp_omi(nloz_omi),prsitmp,nsig+1,-1) end if - + + ! GeoVaLs for JEDI/UFO + call tintrp2a1(ges_oz,ozgestmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + call tintrp2a1(ges_prsi, prsitmp,dlat,dlon,dtime,hrdifsig,& + nsig+1,mype,nfldsig) + if (obstype /= 'omieff' .and. obstype /= 'tomseff') then call intrp3oz1(ges_oz,ozges,dlat,dlon,ozp,dtime,& nlevs,mype,doz_dz) @@ -574,14 +584,33 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& endif if (netcdf_diag) then + k1 = k + k2 = k - 1 + if(k2 == 0)k2 = 1 + if(k == nlevs)then + k1=nlevs-1 + k2=1 + endif + if (obstype == 'sbuv2' .or. obstype == 'ompsnp' ) then + call nc_diag_metadata("TopLevelPressure",sngl(pobs(k2)*r100)) + call nc_diag_metadata("BottomLevelPressure", & sngl(pobs(k1)*r100)) + else + call nc_diag_metadata("TopLevelPressure",sngl(prsitmp(nsig+1)*r1000) ) + call nc_diag_metadata("BottomLevelPressure", sngl(prsitmp(1)*r1000) ) + endif + call nc_diag_data2d("mole_fraction_of_ozone_in_air", sngl(ozgestmp*constoz)) + call nc_diag_data2d("air_pressure_levels",sngl(prsitmp*r1000)) call nc_diag_metadata("MPI_Task_Number", mype ) call nc_diag_metadata("Latitude", sngl(data(ilate,i)) ) call nc_diag_metadata("Longitude", sngl(data(ilone,i)) ) call nc_diag_metadata("Time", sngl(data(itime,i)-time_offset) ) - call nc_diag_metadata("Reference_Pressure", sngl(pobs(k)) ) + call nc_diag_metadata("Total_Ozone_Error_Flag", sngl(ierror_toq )) + call nc_diag_metadata("Profile_Ozone_Error_Flag", sngl(ierror_poq )) + call nc_diag_metadata("Reference_Pressure", sngl(pobs(k)*r100) ) call nc_diag_metadata("Analysis_Use_Flag", iouse(k) ) call nc_diag_metadata("Observation", sngl(ozobs(k))) call nc_diag_metadata("Inverse_Observation_Error", sngl(errorinv)) + call nc_diag_metadata("Input_Observation_Error", sngl(error(k))) call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ozone_inv(k))) call nc_diag_metadata("Obs_Minus_Forecast_unadjusted",sngl(ozone_inv(k))) if (obstype == 'gome' .or. obstype == 'omieff' .or. & @@ -597,6 +626,11 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& else call nc_diag_metadata("Row_Anomaly_Index", sngl(rmiss) ) endif +!>>emily + if (obstype == 'omi' .or. obstype == 'ompstc8' .or. obstype == 'ompsnm') then + call nc_diag_metadata("Algorithm_Flag_For_Best_Ozone", sngl(data(iafbo,i))) + endif +!< 0 .or. ipm2_5 <= 0) then - write(6,*) 'setuppm2_5: ',trim(aeroname),' missing in anavinfo' - call stop2(452) - endif - enddo - - if (size(gsi_chemguess_bundle)==nfldsig) then - aeroname='smoke' - call gsi_bundlegetpointer(gsi_chemguess_bundle(1),trim(aeroname),& - rank3,ier) - if (ier==0) then - allocate(ges_pm2_5(size(rank3,1),size(rank3,2),size(rank3,3),& - nfldsig)) - ges_pm2_5(:,:,:,1)=rank3 - allocate(pm25wc(size(rank3,1),size(rank3,2),size(rank3,3),naero_smoke_fv3,nfldsig)) - pm25wc(:,:,:,1,1)=rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_chemguess_bundle(ifld),trim(aeroname),rank3,ier) - ges_pm2_5(:,:,:,ifld)=rank3 - pm25wc(:,:,:,1,ifld)=rank3 - enddo - else - write(6,*) 'setuppm2_5: ',trim(aeroname),' not found in chembundle,ier= ',ier - call stop2(453) - endif - - do i=2,naero_smoke_fv3 - aeroname=trim(aeronames_smoke_fv3(i)) - call gsi_bundlegetpointer(gsi_chemguess_bundle(1),trim(aeroname),& - rank3,ier) - pm25wc(:,:,:,i,1)=rank3 - if (ier==0) then - ges_pm2_5(:,:,:,1)=ges_pm2_5(:,:,:,1)+rank3 - do ifld=2,nfldsig - call gsi_bundlegetpointer(gsi_chemguess_bundle(ifld),trim(aeroname),rank3,ier) - ges_pm2_5(:,:,:,ifld)=ges_pm2_5(:,:,:,ifld)+rank3 - pm25wc(:,:,:,i,ifld)=rank3 - enddo - else - write(6,*) 'setuppm2_5: ',trim(aeroname),' not found in chembundle,ier= ',ier - call stop2(453) - end if - end do - else - write(6,*) 'setuppm2_5: size(gsi_chemguess_bundle)/=nfldsig ges_pm2_5 not setup !!!' - call stop2(454) - end if ! eq. nfldsig - - endif - if (fv3_cmaq_regional .and. laeroana_fv3cmaq) then !check if pm25at, pm25ac and pm25co are in ges call gsi_chemguess_get ('var::pm25at', ipm2_5, ier ) @@ -702,7 +632,7 @@ subroutine setuppm2_5(obsLL,odiagLL,lunin,mype,nreal,nobs,isis,is,conv_diagsave) !convert for cmaq as well - if (wrf_mass_regional .or. fv3_cmaq_regional .or. laeroana_fv3smoke) then + if (wrf_mass_regional .or. fv3_cmaq_regional) then call tintrp2a11(ges_ps,ps_ges,dlat,dlon,dtime,hrdifsig,& mype,nfldsig) @@ -739,48 +669,17 @@ subroutine setuppm2_5(obsLL,odiagLL,lunin,mype,nreal,nobs,isis,is,conv_diagsave) call tintrp2a11(ges_pm2_5,pm2_5ges,dlat,dlon,dtime,hrdifsig,& mype,nfldsig) innov = conc - pm2_5ges - if (laeroana_fv3smoke) then - if ( -1.0*innov >= pm2_5_innov_threshold .or. & - (innov > pm2_5_innov_threshold .and. pm2_5ges >=1.0_r_kind).or. & - (conc >= 40.0_r_kind .and. pm2_5ges >=1.0_r_kind).or. & - conc >= 100.0_r_kind ) then - innov = innov - else - innov = 0.0_r_kind - muse(i)=.false. - end if - if (tv_ges-273.15_r_kind < 5.0_r_kind) then - innov = 0.0_r_kind - muse(i)=.false. - end if - - end if end if if ( fv3_cmaq_regional .and. laeroana_fv3cmaq) then - ! interpoloate pm25ac +! interpoloate pm25ac call tintrp2a11(pm25wc(:,:,:,1,nfldsig),pm25wc_ges(1),dlat,dlon,dtime,hrdifsig,& mype,nfldsig) call tintrp2a11(pm25wc(:,:,:,2,nfldsig),pm25wc_ges(2),dlat,dlon,dtime,hrdifsig,& mype,nfldsig) call tintrp2a11(pm25wc(:,:,:,3,nfldsig),pm25wc_ges(3),dlat,dlon,dtime,hrdifsig,& mype,nfldsig) - elseif (laeroana_fv3smoke) then - call tintrp2a11(pm25wc(:,:,:,1,nfldsig),pm25wc_ges(1),dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - call tintrp2a11(pm25wc(:,:,:,2,nfldsig),pm25wc_ges(2),dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - if (pm25wc_ges(1) >= 1.0_r_kind) then - pm25wc_ges(1)=1.0_r_kind - else - pm25wc_ges(2)=0.0_r_kind - end if - if (pm25wc_ges(2) >= 1.0_r_kind) then - pm25wc_ges(2)=1.0_r_kind - else - pm25wc_ges(2)=0.0_r_kind - end if else pm25wc_ges = 0.0_r_kind end if diff --git a/src/gsi/setupps.f90 b/src/gsi/setupps.f90 index 6a0fdd4fb2..581ada95e5 100644 --- a/src/gsi/setupps.f90 +++ b/src/gsi/setupps.f90 @@ -130,10 +130,11 @@ subroutine setupps(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa use gridmod, only: nsig,get_ij,twodvar_regional use constants, only: zero,one_tenth,one,half,pi,g_over_rd, & huge_r_kind,tiny_r_kind,two,huge_single, & - r1000,wgtlim,tiny_single,r10,three + r1000,r100,wgtlim,tiny_single,r10,three use jfunc, only: jiter,last,jiterstart,miter use qcmod, only: dfact,dfact1,npres_print,vqc,nvqc use guess_grids, only: hrdifsig,ges_lnprsl,nfldsig,ntguessig + use guess_grids, only: geop_hgtl, ges_prsi, ges_tsen use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype,icsubtype use convinfo, only: ibeta,ikapa @@ -181,15 +182,26 @@ subroutine setupps(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa real(r_kind) cg_t,cvar,wgt,rat_err2,qcgross real(r_kind),dimension(nobs):: dup real(r_kind),dimension(nsig):: prsltmp + real(r_kind),dimension(nsig):: zges, prsltmp2, tvgestmp, tsentmp, qtmp, utmp, vtmp + real(r_kind) :: tgges,roges + real(r_kind),dimension(nsig+1):: prsitmp real(r_kind),dimension(nele,nobs):: data real(r_single),allocatable,dimension(:,:)::rdiagbuf + ! GSI profiles are stored with bottom up index; output the profiles + ! with top down index + real(r_kind),dimension(nsig):: ttmp_reverse,tvtmp_reverse,qtmp_reverse,utmp_reverse,vtmp_reverse + real(r_kind),dimension(nsig):: zges_reverse,prsltmp2_reverse + real(r_kind),dimension(nsig):: zges_read_reverse, zges_geometric_reverse + real(r_kind),dimension(nsig+1):: prsitmp_reverse + !<< JEDI integer(i_kind) ier,ilon,ilat,ipres,ihgt,itemp,id,itime,ikx,iqc,iptrb,ijb integer(i_kind) ier2,iuse,ilate,ilone,istnelv,idomsfc,izz,iprvd,isprvd integer(i_kind) ikxx,nn,ibin,ioff,ioff0 - integer(i_kind) i,j,nchar,nreal,ii,jj,k,l,mm1 + integer(i_kind) i,j,nchar,nreal,ii,jj,k,kk,l,mm1 integer(i_kind) itype,isubtype integer(i_kind) ibb,ikk,idddd + integer(i_kind) msges logical,dimension(nobs):: luse,muse integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID @@ -214,6 +226,8 @@ subroutine setupps(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps real(r_kind),allocatable,dimension(:,:,: ) :: ges_z real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q + real(r_kind),allocatable,dimension(:,:,:,:) :: ges_u, ges_v type(sparr2) :: dhx_dx integer(i_kind) :: ps_ind, nnz, nind @@ -298,26 +312,26 @@ subroutine setupps(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa hr_offset=min_offset/60.0_r_kind ! Check for duplicate observations at same location dup=one - do k=1,nobs - do l=k+1,nobs - if(data(ilat,k) == data(ilat,l) .and. & - data(ilon,k) == data(ilon,l) .and. & - data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. & - muse(k) .and. muse(l))then - if(l_closeobs) then - if(abs(data(itime,k)-hr_offset)>emily + do k = 1, nsig + kk = nsig-k+1 + utmp_reverse(kk) = utmp(k) + vtmp_reverse(kk) = vtmp(k) + ttmp_reverse(kk) = tsentmp(k) + tvtmp_reverse(kk) = tvgestmp(k) !emily + qtmp_reverse(kk) = qtmp(k) + !hsges_reverse(kk) = hsges(k) + !zges_read_reverse(kk)= zges_read(k) + !zges_geometric_reverse(kk)= zges_geometric(k) + zges_read_reverse(kk)= zsges+zges(k) + !zges_geometric_reverse(kk)= zges_geometric(k) + zges_reverse(kk) = zges(k) + prsltmp2_reverse(kk) = prsltmp2(k) + enddo + do k = 1, nsig+1 + kk = (nsig+1)-k+1 + prsitmp_reverse(kk) = prsitmp(k) + enddo + call nc_diag_data2d("atmosphere_pressure_coordinate", sngl(prsltmp2_reverse*r1000)) + call nc_diag_data2d("atmosphere_pressure_coordinate_interface", sngl(prsitmp_reverse*r1000)) + call nc_diag_data2d("air_temperature", sngl(ttmp_reverse)) + call nc_diag_data2d("virtual_temperature", sngl(tvtmp_reverse)) !emily + call nc_diag_data2d("specific_humidity", sngl(qtmp_reverse)) + call nc_diag_data2d("eastward_wind", sngl(utmp_reverse)) + call nc_diag_data2d("northward_wind", sngl(vtmp_reverse)) +! call nc_diag_data2d("geopotential_height", sngl(hsges_reverse) ) !orig + call nc_diag_data2d("geopotential_height", sngl(zges_read_reverse) ) !emily + !call nc_diag_data2d("geometric_height", sngl(zges_geometric_reverse) ) !emily + !<>emily + do k = 1, nsig + kk = nsig-k+1 + utmp_reverse(kk) = utmp(k) + vtmp_reverse(kk) = vtmp(k) + ttmp_reverse(kk) = ttmp(k) + !tvtmp_reverse(kk) = tges(k) !emily + qtmp_reverse(kk) = qtmp(k) + hsges_reverse(kk) = hsges(k) +! zges_read_reverse(kk)= zges_read(k) +! zges_geometric_reverse(kk)= zges_geometric(k) + !zges_reverse(kk) = zges(k) + prsltmp2_reverse(kk) = prsltmp2(k) + enddo + do k = 1, nsig+1 + kk = (nsig+1)-k+1 + prsitmp_reverse(kk) = prsitmp(k) + enddo + call nc_diag_data2d("atmosphere_pressure_coordinate", sngl(prsltmp2_reverse*r1000)) + call nc_diag_data2d("atmosphere_pressure_coordinate_interface", sngl(prsitmp_reverse*r1000)) + call nc_diag_data2d("air_temperature", sngl(ttmp_reverse)) + call nc_diag_data2d("virtual_temperature", sngl(tvtmp_reverse)) !emily + call nc_diag_data2d("specific_humidity", sngl(qtmp_reverse)) + call nc_diag_data2d("eastward_wind", sngl(utmp_reverse)) + call nc_diag_data2d("northward_wind", sngl(vtmp_reverse)) + call nc_diag_data2d("geopotential_height", sngl(hsges_reverse) ) !orig +! call nc_diag_data2d("geopotential_height", sngl(zges_read_reverse) ) !emily +! call nc_diag_data2d("geometric_height", sngl(zges_geometric_reverse) ) !emily + !<>emily + real(r_kind),dimension(nchanl):: varinv_grosschk, varinv_sdoei + real(r_kind),dimension(nchanl):: varinv_after_jsfcchk,varinv_after_sdoei + real(r_kind),dimension(nchanl):: varinv_after_grosschk + real(r_kind),dimension(nchanl):: varinv_after_wavenum,varinv_after_rangechk,varinv_after_topo,varinv_after_transmittop + real(r_kind),dimension(nchanl):: varinv_after_clddet,varinv_after_jsfcchk_land,varinv_after_nsstret + real(r_kind),dimension(nchanl):: varinv_after_grossroutinechk_over_ocean + real(r_kind),dimension(nchanl):: varinv_after_grossroutinechk + real(r_kind),dimension(nchanl):: varinv_after_sfcchk + real(r_kind),dimension(nchanl):: varinv_after_ch2chk + real(r_kind),dimension(nchanl):: varinv_after_scatteringchk + real(r_kind),dimension(nchanl):: varinv_after_sfcterrianchk + real(r_kind),dimension(nchanl):: varinv_after_clrfracchk + real(r_kind),dimension(nchanl):: varinv_after_stdchk + real(r_kind),dimension(nchanl):: varinv_after_stdadj + real(r_kind) :: pred9,pred10,pred11 !emily +!<>emily + do k = 1, nsig + kk = nsig-k+1 + utmp_reverse(kk) = utmp(k) + vtmp_reverse(kk) = vtmp(k) + ttmp_reverse(kk) = ttmp(k) + !tvtmp_reverse(kk) = tges(k) !emily + tvtmp_reverse(kk) = tvtmp(k) !ADC + qtmp_reverse(kk) = qtmp(k) + hsges_reverse(kk) = hsges(k) + !zges_read_reverse(kk)= zges_read(k) + !zges_geometric_reverse(kk)= zges_geometric(k) + !zges_reverse(kk) = zges(k) + prsltmp2_reverse(kk) = prsltmp2(k) + enddo + do k = 1, nsig+1 + kk = (nsig+1)-k+1 + prsitmp_reverse(kk) = prsitmp(k) + enddo + call nc_diag_data2d("atmosphere_pressure_coordinate", sngl(prsltmp2_reverse*r1000)) + call nc_diag_data2d("atmosphere_pressure_coordinate_interface", sngl(prsitmp_reverse*r1000)) + call nc_diag_data2d("air_temperature", sngl(ttmp_reverse)) + call nc_diag_data2d("virtual_temperature", sngl(tvtmp_reverse)) !emily + call nc_diag_data2d("specific_humidity", sngl(qtmp_reverse)) + call nc_diag_data2d("eastward_wind", sngl(utmp_reverse)) + call nc_diag_data2d("northward_wind", sngl(vtmp_reverse)) + call nc_diag_data2d("geopotential_height", sngl(hsges_reverse) ) !orig +! call nc_diag_data2d("geopotential_height", sngl(zges_read_reverse) ) !emily +! call nc_diag_data2d("geometric_height", sngl(zges_geometric_reverse) ) !emily + !<>emily + do k = 1, nsig + kk = nsig-k+1 + utmp_reverse(kk) = utmp(k) + vtmp_reverse(kk) = vtmp(k) + ttmp_reverse(kk) = ttmp(k) + !tvtmp_reverse(kk) = tges(k) !emily + tvtmp_reverse(kk) = tvtmp(k) !ADC + qtmp_reverse(kk) = qtmp(k) + hsges_reverse(kk) = hsges(k) + !zges_read_reverse(kk)= zges_read(k) + !zges_geometric_reverse(kk)= zges_geometric(k) + !zges_reverse(kk) = zges(k) + prsltmp2_reverse(kk) = prsltmp2(k) + enddo + do k = 1, nsig+1 + kk = (nsig+1)-k+1 + prsitmp_reverse(kk) = prsitmp(k) + enddo + call nc_diag_data2d("atmosphere_pressure_coordinate", sngl(prsltmp2_reverse*r1000)) + call nc_diag_data2d("atmosphere_pressure_coordinate_interface", sngl(prsitmp_reverse*r1000)) + call nc_diag_data2d("air_temperature", sngl(ttmp_reverse)) + call nc_diag_data2d("virtual_temperature", sngl(tvtmp_reverse)) !emily + call nc_diag_data2d("specific_humidity", sngl(qtmp_reverse)) + call nc_diag_data2d("eastward_wind", sngl(utmp_reverse)) + call nc_diag_data2d("northward_wind", sngl(vtmp_reverse)) + call nc_diag_data2d("geopotential_height", sngl(hsges_reverse) ) !orig +! call nc_diag_data2d("geopotential_height", sngl(zges_read_reverse) ) !emily +! call nc_diag_data2d("geometric_height", sngl(zges_geometric_reverse) ) !emily + !<>emily + do k = 1, nsig + kk = nsig-k+1 + utmp_reverse(kk) = utmp(k) + vtmp_reverse(kk) = vtmp(k) + ttmp_reverse(kk) = ttmp(k) + tvtmp_reverse(kk) = tges(k) !emily + qtmp_reverse(kk) = qtmp(k) + hsges_reverse(kk) = hsges(k) + zges_read_reverse(kk)= zges_read(k) + zges_geometric_reverse(kk)= zges_geometric(k) + zges_reverse(kk) = zges(k) + prsltmp2_reverse(kk) = prsltmp2(k) + enddo + do k = 1, nsig+1 + kk = (nsig+1)-k+1 + prsitmp_reverse(kk) = prsitmp(k) + enddo + call nc_diag_data2d("atmosphere_pressure_coordinate", sngl(prsltmp2_reverse*r1000)) + call nc_diag_data2d("atmosphere_pressure_coordinate_interface", sngl(prsitmp_reverse*r1000)) + call nc_diag_data2d("air_temperature", sngl(ttmp_reverse)) + call nc_diag_data2d("virtual_temperature", sngl(tvtmp_reverse)) !emily + call nc_diag_data2d("specific_humidity", sngl(qtmp_reverse)) + call nc_diag_data2d("eastward_wind", sngl(utmp_reverse)) + call nc_diag_data2d("northward_wind", sngl(vtmp_reverse)) +! call nc_diag_data2d("geopotential_height", sngl(hsges_reverse) ) !orig + call nc_diag_data2d("geopotential_height", sngl(zges_read_reverse) ) !emily + call nc_diag_data2d("geometric_height", sngl(zges_geometric_reverse) ) !emily + !< Date: Tue, 7 May 2024 21:31:58 -0400 Subject: [PATCH 083/109] add license (#745) --- LICENSE.md | 157 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 157 insertions(+) create mode 100644 LICENSE.md diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 index 0000000000..0927556b54 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,157 @@ +### GNU LESSER GENERAL PUBLIC LICENSE + +Version 3, 29 June 2007 + +Copyright (C) 2007 Free Software Foundation, Inc. + + +Everyone is permitted to copy and distribute verbatim copies of this +license document, but changing it is not allowed. + +This version of the GNU Lesser General Public License incorporates the +terms and conditions of version 3 of the GNU General Public License, +supplemented by the additional permissions listed below. + +#### 0. Additional Definitions. + +As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the +GNU General Public License. + +"The Library" refers to a covered work governed by this License, other +than an Application or a Combined Work as defined below. + +An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + +A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + +The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + +The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + +#### 1. Exception to Section 3 of the GNU GPL. + +You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + +#### 2. Conveying Modified Versions. + +If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + +- a) under this License, provided that you make a good faith effort + to ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or +- b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + +#### 3. Object Code Incorporating Material from Library Header Files. + +The object code form of an Application may incorporate material from a +header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + +- a) Give prominent notice with each copy of the object code that + the Library is used in it and that the Library and its use are + covered by this License. +- b) Accompany the object code with a copy of the GNU GPL and this + license document. + +#### 4. Combined Works. + +You may convey a Combined Work under terms of your choice that, taken +together, effectively do not restrict modification of the portions of +the Library contained in the Combined Work and reverse engineering for +debugging such modifications, if you also do each of the following: + +- a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. +- b) Accompany the Combined Work with a copy of the GNU GPL and this + license document. +- c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. +- d) Do one of the following: + - 0) Convey the Minimal Corresponding Source under the terms of + this License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + - 1) Use a suitable shared library mechanism for linking with + the Library. A suitable mechanism is one that (a) uses at run + time a copy of the Library already present on the user's + computer system, and (b) will operate properly with a modified + version of the Library that is interface-compatible with the + Linked Version. +- e) Provide Installation Information, but only if you would + otherwise be required to provide such information under section 6 + of the GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the Application + with a modified version of the Linked Version. (If you use option + 4d0, the Installation Information must accompany the Minimal + Corresponding Source and Corresponding Application Code. If you + use option 4d1, you must provide the Installation Information in + the manner specified by section 6 of the GNU GPL for conveying + Corresponding Source.) + +#### 5. Combined Libraries. + +You may place library facilities that are a work based on the Library +side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + +- a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities, conveyed under the terms of this License. +- b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + +#### 6. Revised Versions of the GNU Lesser General Public License. + +The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +as you received it specifies that a certain numbered version of the +GNU Lesser General Public License "or any later version" applies to +it, you have the option of following the terms and conditions either +of that published version or of any later version published by the +Free Software Foundation. If the Library as you received it does not +specify a version number of the GNU Lesser General Public License, you +may choose any version of the GNU Lesser General Public License ever +published by the Free Software Foundation. + +If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. From 5be3fa98fd3494e467775eedfd557420d3618b83 Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Thu, 9 May 2024 13:16:02 -0500 Subject: [PATCH 084/109] Add virtual temperature information --- src/gsi/setupt.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/gsi/setupt.f90 b/src/gsi/setupt.f90 index 707af25110..96e5cb5925 100644 --- a/src/gsi/setupt.f90 +++ b/src/gsi/setupt.f90 @@ -1856,6 +1856,7 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata_to_single("Prep_QC_Mark",data(iqc,i)) call nc_diag_metadata_to_single("Setup_QC_Mark",data(iqt,i)) call nc_diag_metadata_to_single("Prep_Use_Flag",data(iuse,i)) + call nc_diag_metadata_to_single("Virtual_Temperature",nint(data(iqt,i))) if(muse(i)) then call nc_diag_metadata_to_single("Analysis_Use_Flag", one) else From 67cddc0ee93c06122f8a024774ec07813c31fe20 Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Thu, 9 May 2024 13:43:17 -0500 Subject: [PATCH 085/109] Bug fixes --- src/gsi/setupps.f90 | 2 +- src/gsi/setupt.f90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/gsi/setupps.f90 b/src/gsi/setupps.f90 index c0d24ca8a4..bed168122c 100644 --- a/src/gsi/setupps.f90 +++ b/src/gsi/setupps.f90 @@ -1084,7 +1084,7 @@ subroutine contents_netcdf_diag_(odiag) !call nc_diag_metadata("skin_temperature", sngl(tgges)) !call nc_diag_metadata("2m_temperature", sngl(tgges)) !call nc_diag_metadata("2m_specific_humidity", sngl()) - call nc_diag_metadata("landmask", sngl(msges)) + call nc_diag_metadata("landmask", msges) ! call nc_diag_data2d("geopotential_height", sngl(zsges+zges)) ! call nc_diag_data2d("atmosphere_pressure_coordinate", ! sngl(prsltmp2*r1000)) diff --git a/src/gsi/setupt.f90 b/src/gsi/setupt.f90 index 96e5cb5925..1085311303 100644 --- a/src/gsi/setupt.f90 +++ b/src/gsi/setupt.f90 @@ -1856,7 +1856,7 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata_to_single("Prep_QC_Mark",data(iqc,i)) call nc_diag_metadata_to_single("Setup_QC_Mark",data(iqt,i)) call nc_diag_metadata_to_single("Prep_Use_Flag",data(iuse,i)) - call nc_diag_metadata_to_single("Virtual_Temperature",nint(data(iqt,i))) + call nc_diag_metadata("Virtual_Temperature_Flag",nint(data(iqt,i))) if(muse(i)) then call nc_diag_metadata_to_single("Analysis_Use_Flag", one) else From 59d7578b31454140cb38bf65b27e3cffb02c7e3e Mon Sep 17 00:00:00 2001 From: DavidBurrows-NCO <82525974+DavidBurrows-NCO@users.noreply.github.com> Date: Mon, 20 May 2024 11:51:45 -0400 Subject: [PATCH 086/109] Update module files to build gsi on Gaea-C5 (#746) --- modulefiles/gsi_gaea.intel.lua | 26 ++++++++------------------ regression/regression_param.sh | 34 +++++++++++++++++----------------- regression/regression_var.sh | 16 ++++++---------- ush/module-setup.sh | 4 +--- ush/sub_gaea | 12 ++++++------ 5 files changed, 38 insertions(+), 54 deletions(-) diff --git a/modulefiles/gsi_gaea.intel.lua b/modulefiles/gsi_gaea.intel.lua index 96643202a7..799822caa8 100644 --- a/modulefiles/gsi_gaea.intel.lua +++ b/modulefiles/gsi_gaea.intel.lua @@ -1,18 +1,13 @@ help([[ ]]) -unload("intel") -unload("cray-mpich") -unload("cray-python") -unload("darshan") +prepend_path("MODULEPATH", "/ncrc/proj/epic/spack-stack/spack-stack-1.6.0/envs/gsi-addon-dev/install/modulefiles/Core") -prepend_path("MODULEPATH", "/lustre/f2/dev/wpo/role.epic/contrib/spack-stack/spack-stack-1.4.1-c4/envs/unified-env/install/modulefiles/Core") -prepend_path("MODULEPATH", "/lustre/f2/pdata/esrl/gsd/spack-stack/modulefiles") - -local stack_python_ver=os.getenv("stack_python_ver") or "3.9.12" -local stack_intel_ver=os.getenv("stack_intel_ver") or "2022.0.2" -local stack_cray_mpich_ver=os.getenv("stack_cray_mpich_ver") or "7.7.20" +local stack_python_ver=os.getenv("stack_python_ver") or "3.11.6" +local stack_intel_ver=os.getenv("stack_intel_ver") or "2023.1.0" +local stack_cray_mpich_ver=os.getenv("stack_cray_mpich_ver") or "8.1.25" local cmake_ver=os.getenv("cmake_ver") or "3.23.1" +local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1" load(pathJoin("stack-intel", stack_intel_ver)) load(pathJoin("stack-cray-mpich", stack_cray_mpich_ver)) @@ -20,23 +15,18 @@ load(pathJoin("stack-python", stack_python_ver)) load(pathJoin("cmake", cmake_ver)) load("gsi_common") - -local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" -load(pathJoin("prod-util", prod_util_ver)) - --- Needed at runtime: -load("alps") +load(pathJoin("prod_util", prod_util_ver)) local MKLROOT="/opt/intel/oneapi/mkl/2022.0.2/" prepend_path("LD_LIBRARY_PATH",pathJoin(MKLROOT,"lib/intel64")) pushenv("MKLROOT", MKLROOT) -pushenv("GSI_BINARY_SOURCE_DIR", "/lustre/f2/dev/role.epic/contrib/GSI_data/fix/20240208") +pushenv("GSI_BINARY_SOURCE_DIR", "/gpfs/f5/ufs-ard/world-shared/GSI_data/fix/gsi/20240208") setenv("CC","cc") setenv("FC","ftn") setenv("CXX","CC") pushenv("CRAYPE_LINK_TYPE","dynamic") +unload("cray-libsci") whatis("Description: GSI environment on Gaea with Intel Compilers") - diff --git a/regression/regression_param.sh b/regression/regression_param.sh index a4f5d7035c..6ee72f14da 100755 --- a/regression/regression_param.sh +++ b/regression/regression_param.sh @@ -26,8 +26,8 @@ case $machine in ;; Gaea) sub_cmd="sub_gaea" - memnode=64 - numcore=36 + memnode=251 + numcore=128 ;; wcoss2) sub_cmd="sub_wcoss2" @@ -69,8 +69,8 @@ case $regtest in topts[1]="0:30:00" ; popts[1]="48/2" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="60/3" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:10:00" ; popts[1]="18/8/" ; ropts[1]="/1" - topts[2]="0:10:00" ; popts[2]="18/10/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2" @@ -99,8 +99,8 @@ case $regtest in topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" @@ -129,8 +129,8 @@ case $regtest in topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" @@ -158,8 +158,8 @@ case $regtest in topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" @@ -188,8 +188,8 @@ case $regtest in topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="28/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="28/2/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="28/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="28/2/" ; ropts[2]="/1" @@ -218,8 +218,8 @@ case $regtest in topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:30:00" ; popts[1]="8/6/" ; ropts[1]="/1" - topts[2]="0:30:00" ; popts[2]="8/8/" ; ropts[2]="/1" + topts[1]="0:30:00" ; popts[1]="14/8/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="14/14/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:30:00" ; popts[1]="14/8/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="14/14/" ; ropts[2]="/2" @@ -248,8 +248,8 @@ case $regtest in topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="16/2/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="16/4/" ; ropts[2]="/2" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:10:00" ; popts[1]="16/2/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="16/4/" ; ropts[2]="/2" @@ -315,7 +315,7 @@ elif [[ "$machine" = "Gaea" ]]; then export MPI_BUFS_PER_PROC=256 export MPI_BUFS_PER_HOST=256 export MPI_GROUP_MAX=256 - export APRUN="srun --export=ALL --mpi=pmi2 -n \$ntasks" + export APRUN="srun --export=ALL -n \$ntasks" elif [[ "$machine" = "wcoss2" ]]; then export OMP_PLACES=cores export OMP_STACKSIZE=2G diff --git a/regression/regression_var.sh b/regression/regression_var.sh index 315028675c..aebbccab8b 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -36,7 +36,7 @@ elif [[ -d /mnt/lfs4 || -d /jetmon || -d /mnt/lfs1 ]]; then # Jet export machine="Jet" elif [[ -d /discover ]]; then # NCCS Discover export machine="Discover" -elif [[ -d /sw/gaea ]]; then # Gaea +elif [[ -d /ncrc ]]; then # Gaea export machine="Gaea" elif [[ -d /data/prod ]]; then # S4 export machine="S4" @@ -52,17 +52,13 @@ echo "Running Regression Tests on '$machine'"; case $machine in Gaea) export queue="normal" - export noscrub="/lustre/f2/scratch/$LOGNAME/gsi_tmp/noscrub" - export ptmp="/lustre/f2/scratch/$LOGNAME/gsi_tmp/ptmp" - export casesdir="/lustre/f2/dev/role.epic/contrib/GSI_data/CASES/regtest" - - export group="global" - if [[ "$cmaketest" = "false" ]]; then - export basedir="/lustre/f2/dev/$LOGNAME/sandbox/GSI" - fi + export group="ufs-ard" + export noscrub="/gpfs/f5/${group}/scratch/${USER}/$LOGNAME/gsi_tmp/noscrub" + export ptmp="/gpfs/f5/${group}/scratch/${USER}/$LOGNAME/gsi_tmp/ptmp" + export casesdir="/gpfs/f5/ufs-ard/world-shared/GSI_data/CASES/regtest" export check_resource="no" - export accnt="nggps_emc" + export accnt="ufs-ard" ;; wcoss2) export local_or_default="${local_or_default:-/lfs/h2/emc/da/noscrub/$LOGNAME}" diff --git a/ush/module-setup.sh b/ush/module-setup.sh index f587842f0f..299e13aa4e 100755 --- a/ush/module-setup.sh +++ b/ush/module-setup.sh @@ -56,10 +56,8 @@ elif [[ $MACHINE_ID = gaea* ]] ; then # the module command fails. Hence we actually have to source # /etc/profile here. source /etc/profile - __ms_source_etc_profile=yes fi - - source /lustre/f2/dev/role.epic/contrib/Lmod_init.sh + module reset elif [[ $MACHINE_ID = expanse* ]]; then # We are on SDSC Expanse diff --git a/ush/sub_gaea b/ush/sub_gaea index afad6aa7ab..9c4e253c93 100755 --- a/ush/sub_gaea +++ b/ush/sub_gaea @@ -88,8 +88,8 @@ output=${output:-$jobname.out} myuser=$LOGNAME myhost=$(hostname) -if [ -d /lustre/f2/scratch/$LOGNAME ]; then - DATA=/lustre/f2/scratch/$LOGNAME/tmp +if [ -d /gpfs/f5/epic/scratch/${USER}/$LOGNAME ]; then + DATA=/gpfs/f5/epic/scratch/${USER}/$LOGNAME/tmp fi DATA=${DATA:-$ptmp/tmp} @@ -110,7 +110,7 @@ echo "" echo "#SBATCH --output=$output" >> $cfile echo "#SBATCH --job-name=$jobname" >> $cfile echo "#SBATCH --qos=$queue" >> $cfile -echo "#SBATCH --clusters=c4" >> $cfile +echo "#SBATCH --clusters=c5" >> $cfile echo "#SBATCH --time=$timew" >> $cfile echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile echo "#SBATCH --account=$accnt" >> $cfile @@ -121,13 +121,13 @@ echo "export ntasks=$(( $nodes * $procs ))" >> $cfile echo "export ppn=$procs" >> $cfile echo "export threads=$threads" >> $cfile echo "export OMP_NUM_THREADS=$threads" >> $cfile -echo "ulimit -s unlimited" >> $cfile +echo "ulimit -s unlimited" >> $cfile echo "" >>$cfile echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile echo "" >>$cfile -echo "source /lustre/f2/dev/role.epic/contrib/Lmod_init.sh" >> $cfile +echo "module reset" >> $cfile echo "module use $modulefiles" >> $cfile echo "module load gsi_gaea.intel" >> $cfile echo "module list" >> $cfile @@ -158,7 +158,7 @@ sbatch=${sbatch:-sbatch} ofile=$DATA/subout$$ >$ofile chmod 777 $ofile -$sbatch --export=ALL $cfile >$ofile +$sbatch $cfile >$ofile rc=$? cat $ofile if [[ -w $SUBLOG ]];then From 6cd87ae6356ed3729de69c606a73e6b11b9ce5dd Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Thu, 30 May 2024 09:56:23 -0500 Subject: [PATCH 087/109] Bug fixes --- src/gsi/setupq.f90 | 45 ++++++++++++++++++++++++++++++++++++--------- src/gsi/setupw.f90 | 5 +++-- 2 files changed, 39 insertions(+), 11 deletions(-) diff --git a/src/gsi/setupq.f90 b/src/gsi/setupq.f90 index 57cd039aa0..5854a8dd77 100644 --- a/src/gsi/setupq.f90 +++ b/src/gsi/setupq.f90 @@ -1176,6 +1176,42 @@ subroutine init_vars_ call stop2(999) endif endif ! hofx_2m_sfcfile +! get u ... + varname='u' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_u))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_u(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_u(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_u(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! get v ... + varname='v' + call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) + if (istatus==0) then + if(allocated(ges_v))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + allocate(ges_v(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig)) + ges_v(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_v(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif ! get q ... varname='q' call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) @@ -1441,16 +1477,7 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata_to_single("Observation_Tdry", data(itemp,i) ) call nc_diag_metadata_to_single("Setup_QC_Mark", data(iqt, i) ) endif - call nc_diag_metadata_to_single("Errinv_Input", errinv_input) - call nc_diag_metadata_to_single("Errinv_Adjust", errinv_adjst) - call nc_diag_metadata_to_single("Errinv_Final", errinv_final) - call nc_diag_metadata_to_single("Observation", data(iqob,i)) - call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted", ddiff) - call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted", qob-qges) - call nc_diag_metadata_to_single("Forecast_adjusted", data(iqob,i)-ddiff) - call nc_diag_metadata_to_single("Forecast_unadjusted", qges) - call nc_diag_metadata_to_single("Forecast_Saturation_Spec_Hum", qsges) if (lobsdiagsave) then do jj=1,miter if (odiag%muse(jj)) then diff --git a/src/gsi/setupw.f90 b/src/gsi/setupw.f90 index 784905a918..4fc1537e7e 100644 --- a/src/gsi/setupw.f90 +++ b/src/gsi/setupw.f90 @@ -402,8 +402,9 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav icat=24 ! index of data level category ijb=25 ! index of non linear qc parameter ihil=26 ! index of hilbert curve weight - iptrbu=27 ! index of u perturbation - iptrbv=28 ! index of v perturbation + iamvq=27 ! index of AMVQ + iptrbu=35 ! index of u perturbation + iptrbv=36 ! index of v perturbation mm1=mype+1 scale=one From 8d20eb28e2bf7dec4203775fec6c63d8702e8f56 Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Thu, 30 May 2024 17:36:03 +0000 Subject: [PATCH 088/109] Fix type --- src/gsi/setupw.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/gsi/setupw.f90 b/src/gsi/setupw.f90 index 4fc1537e7e..34c62e85dc 100644 --- a/src/gsi/setupw.f90 +++ b/src/gsi/setupw.f90 @@ -1977,7 +1977,7 @@ subroutine contents_netcdf_diag_(udiag,vdiag) call nc_diag_metadata("surface_geopotential_height", sngl(zsges) ) !emily call nc_diag_metadata("tropopause_pressure", sngl(trop5*r100) ) call nc_diag_metadata("surface_air_pressure", sngl(psges2*r1000) ) - call nc_diag_metadata("Land_Type_Index", sngl(isli)) + call nc_diag_metadata("Land_Type_Index", isli) ! END GEOVALS ! extra fields for AMV QC call nc_diag_metadata("wind_computation_method", sngl(data(28,i))) From f82dc3405704d0022c20b200f053272e9bbb3383 Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Fri, 21 Jun 2024 10:01:21 -0400 Subject: [PATCH 089/109] add two band sdl to global_4denvar namelist (#758) --- regression/regression_namelists.sh | 6 ++++-- regression/regression_namelists_db.sh | 9 ++++++--- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh index 620f776526..d360dfd870 100755 --- a/regression/regression_namelists.sh +++ b/regression/regression_namelists.sh @@ -195,10 +195,12 @@ OBS_INPUT:: / &HYBRID_ENSEMBLE - l_hyb_ens=.true.,n_ens=$NMEM_ENKF,beta_s0=0.125,readin_beta=.false.,s_ens_h=800,s_ens_v=-0.8, + l_hyb_ens=.true.,n_ens=$NMEM_ENKF,beta_s0=0.125,readin_beta=.false., generate_ens=.false.,uv_hyb_ens=.true.,jcap_ens=48,nlat_ens=98,nlon_ens=192, - ANISO_A_EN=.false.,jcap_ens_test=48,oz_univ_static=.false.,readin_localization=.true., + ANISO_A_EN=.false.,jcap_ens_test=48,oz_univ_static=.false., ensemble_path='./ensemble_data/',ens_fast_read=.true.,write_ens_sprd=.false., + s_ens_h=1000.0,450.0,685.0,s_ens_v=-0.5,-0.5,0.0,readin_localization=.false., + global_spectral_filter_sd=.false.,r_ensloccov4scl=1,nsclgrp=2,naensloc=3, $HYBRID_ENSEMBLE / &RAPIDREFRESH_CLDSURF diff --git a/regression/regression_namelists_db.sh b/regression/regression_namelists_db.sh index e03917e888..83718b50d5 100755 --- a/regression/regression_namelists_db.sh +++ b/regression/regression_namelists_db.sh @@ -174,9 +174,12 @@ OBS_INPUT:: $LAGDATA / &HYBRID_ENSEMBLE - l_hyb_ens=.true.,n_ens=10,beta_s0=0.125,readin_beta=.false.,s_ens_h=800,s_ens_v=-0.8,generate_ens=.false.,uv_hyb_ens=.true.,jcap_ens=190, - nlat_ens=194,nlon_ens=384,aniso_a_en=.false.,jcap_ens_test=62,oz_univ_static=.false.,readin_localization=.true.,ensemble_path='./ensemble_data/', - ens_fast_read=.true.,write_ens_sprd=.false., + l_hyb_ens=.true.,n_ens=$NMEM_ENKF,beta_s0=0.125,readin_beta=.false., + generate_ens=.false.,uv_hyb_ens=.true.,jcap_ens=48,nlat_ens=98,nlon_ens=192, + ANISO_A_EN=.false.,jcap_ens_test=48,oz_univ_static=.false., + ensemble_path='./ensemble_data/',ens_fast_read=.true.,write_ens_sprd=.false., + s_ens_h=1000.0,450.0,685.0,s_ens_v=-0.5,-0.5,0.0,readin_localization=.false., + global_spectral_filter_sd=.false.,r_ensloccov4scl=1,nsclgrp=2,naensloc=3, $HYBRID_ENSEMBLE / &RAPIDREFRESH_CLDSURF From 6a87460bd9d116d3e4b0ceadc565f66496443636 Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Tue, 25 Jun 2024 08:12:01 -0400 Subject: [PATCH 090/109] update path to global ctest model data (#762) --- regression/global_4denvar.sh | 6 +++--- regression/global_enkf.sh | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/regression/global_4denvar.sh b/regression/global_4denvar.sh index 177ce0f8a9..945200eb66 100755 --- a/regression/global_4denvar.sh +++ b/regression/global_4denvar.sh @@ -61,7 +61,7 @@ suffix=tm00.bufr_d dumpges=gdas COMROOTgfs=$casesdir/gfs/prod datobs=$COMROOTgfs/$dumpobs.$PDYa/${cyca}/obs -dathis=$COMROOTgfs/$dumpges.$PDYg/${cycg}/model_data/atmos/history +dathis=$COMROOTgfs/$dumpges.$PDYg/${cycg}/model/atmos/history datanl=$COMROOTgfs/gdas.$PDYg/${cycg}/analysis/atmos datens=$COMROOTgfs/enkfgdas.$PDYg/${cycg} @@ -291,7 +291,7 @@ $nln $dathis/${prefix_ges}.atmf007.nc ./sigf07 $nln $dathis/${prefix_ges}.atmf008.nc ./sigf08 $nln $dathis/${prefix_ges}.atmf009.nc ./sigf09 -$nln $datens/ensstat/model_data/atmos/history/${prefix_ens}.sfcf006.ensmean.nc ./sfcf06_anlgrid +$nln $datens/ensstat/model/atmos/history/${prefix_ens}.sfcf006.ensmean.nc ./sfcf06_anlgrid export ENS_PATH='./ensemble_data/' mkdir -p ${ENS_PATH} @@ -301,7 +301,7 @@ for fh in $flist; do imem=1 while [[ $imem -le $NMEM_ENKF ]]; do member="mem"`printf %03i $imem` - $nln $datens/$member/model_data/atmos/history/$sigens ${ENS_PATH}sigf${fh}_ens_${member} + $nln $datens/$member/model/atmos/history/$sigens ${ENS_PATH}sigf${fh}_ens_${member} (( imem = $imem + 1 )) done done diff --git a/regression/global_enkf.sh b/regression/global_enkf.sh index ca40abda52..a35f8d109f 100755 --- a/regression/global_enkf.sh +++ b/regression/global_enkf.sh @@ -163,13 +163,13 @@ nfhrs=`echo $IAUFHRS_ENKF | sed 's/,/ /g'` for fhr in $nfhrs; do for imem in $(seq 1 $NMEM_ENKF); do memchar="mem"$(printf %03i $imem) - $nln $datens/$memchar/model_data/atmos/history/${prefix_ens}.atmf00${fhr}.nc sfg_${global_adate}_fhr0${fhr}_${memchar} + $nln $datens/$memchar/model/atmos/history/${prefix_ens}.atmf00${fhr}.nc sfg_${global_adate}_fhr0${fhr}_${memchar} if [ $cnvw_option = ".true." ]; then - $nln $datens/$memchar/model_data/atmos/history/${prefix_ens}sfcf00${fhr}.nc sfgsfc_${global_adate}_fhr0${fhr}_${memchar} + $nln $datens/$memchar/model/atmos/history/${prefix_ens}sfcf00${fhr}.nc sfgsfc_${global_adate}_fhr0${fhr}_${memchar} fi (( imem = $imem + 1 )) done - $nln $datens/ensstat/model_data/atmos/history/${prefix_ens}.atmf00${fhr}.ensmean.nc sfg_${global_adate}_fhr0${fhr}_ensmean + $nln $datens/ensstat/model/atmos/history/${prefix_ens}.atmf00${fhr}.ensmean.nc sfg_${global_adate}_fhr0${fhr}_ensmean if [ $cnvw_option = ".true." ]; then $nln $datens/${prefix_ens}.sfcf00${fhr}.ensmean.nc sfgsfc_${global_adate}_fhr0${fhr}_ensmean fi From 24b731a6c6574bd93586bedd694bac7ac60cd7b8 Mon Sep 17 00:00:00 2001 From: Ming Hu Date: Thu, 27 Jun 2024 08:11:01 -0400 Subject: [PATCH 091/109] Update RRFS regression test cases (#750) 1) Change RRFS case from rrfs_3denvar_glbens to rrfs_3denvar_rdasens. The new RRFS case has the same configuration as RRFS_A warm cycles. 2) delete case netcdf_fv3_regional 3) add RRFS EnKF case for conventional observations: rrfs_enkf_conv --- fix | 2 +- regression/CMakeLists.txt | 14 +- regression/multi_regression.sh | 8 +- regression/netcdf_fv3_regional.sh | 207 ------------ regression/regression_driver.sh | 2 +- regression/regression_namelists.sh | 302 ++++++++++-------- regression/regression_namelists_db.sh | 190 +++-------- regression/regression_param.sh | 24 +- regression/regression_test_enkf.sh | 99 ++++-- regression/regression_var.sh | 14 +- ...nvar_glbens.sh => rrfs_3denvar_rdasens.sh} | 181 +++++++++-- regression/rrfs_enkf_conv.sh | 223 +++++++++++++ 12 files changed, 708 insertions(+), 558 deletions(-) delete mode 100755 regression/netcdf_fv3_regional.sh rename regression/{rrfs_3denvar_glbens.sh => rrfs_3denvar_rdasens.sh} (55%) create mode 100755 regression/rrfs_enkf_conv.sh diff --git a/fix b/fix index a801d5cf07..15ffa60307 160000 --- a/fix +++ b/fix @@ -1 +1 @@ -Subproject commit a801d5cf07c3955e71258a0c8e9b074bb0f03fe4 +Subproject commit 15ffa60307bbc19746d8caeb41782de0b7604be6 diff --git a/regression/CMakeLists.txt b/regression/CMakeLists.txt index 99d92162e6..e36cca605b 100644 --- a/regression/CMakeLists.txt +++ b/regression/CMakeLists.txt @@ -40,14 +40,20 @@ endif() list(APPEND GSI_REG_TEST_NAMES global_4denvar rtma - rrfs_3denvar_glbens netcdf_fv3_regional + rrfs_3denvar_rdasens hafs_4denvar_glbens hafs_3denvar_hybens ) # EnKF regression test names -list(APPEND ENKF_REG_TEST_NAMES - global_enkf -) +if(ENKF_MODE MATCHES "^(FV3REG)$") + list(APPEND ENKF_REG_TEST_NAMES + rrfs_enkf_conv + ) +else() + list(APPEND ENKF_REG_TEST_NAMES + global_enkf + ) +endif() # Add GSI regression tests to list of tests if(GSICONTROLEXEC) diff --git a/regression/multi_regression.sh b/regression/multi_regression.sh index 4df5581097..d01492aa44 100755 --- a/regression/multi_regression.sh +++ b/regression/multi_regression.sh @@ -1,16 +1,16 @@ #!/bin/sh --login regtests_all="global_4denvar - netcdf_fv3_regional - rrfs_3denvar_glbens + rrfs_3denvar_rdasens hafs_4denvar_glbens hafs_3denvar_hybens rtma global_enkf" +# rrfs_enkf_conv : comment out RRFS enkf case for now +# need to update EnKF code regtests_debug="global_4denvar - netcdf_fv3_regional - rrfs_3denvar_glbens + rrfs_3denvar_rdasens hafs_4denvar_glbens hafs_3denvar_hybens rtma diff --git a/regression/netcdf_fv3_regional.sh b/regression/netcdf_fv3_regional.sh deleted file mode 100755 index e6188f51c6..0000000000 --- a/regression/netcdf_fv3_regional.sh +++ /dev/null @@ -1,207 +0,0 @@ - -set -x - -# Set analysis date -#adate=2015061000 - -# Set experiment name -exp=$jobname - -# Set runtime and save directories -tmpdir=$tmpdir/tmpreg_netcdf_fv3_regional/${exp} -savdir=$savdir/outreg_netcdf_fv3_regional/${exp} - -# Set variables used in script -# CLEAN up $tmpdir when finished (YES=remove, NO=leave alone) -# ncp is cp replacement, currently keep as /bin/cp - -UNCOMPRESS=gunzip -CLEAN=NO -ncp=/bin/cp - - -# Set up $tmpdir -rm -rf $tmpdir -mkdir -p $tmpdir -chgrp rstprod $tmpdir -chmod 750 $tmpdir -cd $tmpdir - -#FIXnam=/da/save/Michael.Lueken/trunk/fix -fixcrtm=${fixcrtm:-$CRTM_FIX} - -berror=$fixgsi/nam_nmm_berror.f77.gcv -anavinfo=$fixgsi/anavinfo_fv3 - - -# Make gsi namelist - -. $scripts/regression_nl_update.sh - -SETUP="$SETUP_update" -GRIDOPTS="$GRIDOPTS_update" -BKGVERR="$BKGVERR_update" -ANBKGERR="$ANBKERR_update" -JCOPTS="$JCOPTS_update" -STRONGOPTS="$STRONGOPTS_update" -OBSQC="$OBSQC_update" -OBSINPUT="$OBSINPUT_update" -SUPERRAD="$SUPERRAD_update" -HYBRID_ENSEMBLE='ensemble_path="",' -SINGLEOB="$SINGLEOB_update" - -if [ "$debug" = ".false." ]; then - . $scripts/regression_namelists.sh netcdf_fv3_regional -else - . $scripts/regression_namelists_db.sh netcdf_fv3_regional -fi - -# dmesh(1)=120.0,time_window_max=1.5,ext_sonde=.true., - -cat << EOF > gsiparm.anl - -$gsi_namelist - -EOF - -emiscoef_IRwater=$fixcrtm/Nalli.IRwater.EmisCoeff.bin -emiscoef_IRice=$fixcrtm/NPOESS.IRice.EmisCoeff.bin -emiscoef_IRland=$fixcrtm/NPOESS.IRland.EmisCoeff.bin -emiscoef_IRsnow=$fixcrtm/NPOESS.IRsnow.EmisCoeff.bin -emiscoef_VISice=$fixcrtm/NPOESS.VISice.EmisCoeff.bin -emiscoef_VISland=$fixcrtm/NPOESS.VISland.EmisCoeff.bin -emiscoef_VISsnow=$fixcrtm/NPOESS.VISsnow.EmisCoeff.bin -emiscoef_VISwater=$fixcrtm/NPOESS.VISwater.EmisCoeff.bin -emiscoef_MWwater=$fixcrtm/FASTEM6.MWwater.EmisCoeff.bin -aercoef=$fixcrtm/AerosolCoeff.bin -cldcoef=$fixcrtm/CloudCoeff.bin -satinfo=$fixgsi/nam_regional_satinfo.txt -cloudyinfo=$fixgsi/cloudy_radiance_info.txt -scaninfo=$fixgsi/global_scaninfo.txt -pcpinfo=$fixgsi/nam_global_pcpinfo.txt -ozinfo=$fixgsi/nam_global_ozinfo.txt -errtable=$fixgsi/nam_errtable.r3dv -convinfo=$fixgsi/nam_regional_convinfo.txt -mesonetuselist=$fixgsi/nam_mesonet_uselist.txt -stnuselist=$fixgsi/nam_mesonet_stnuselist.txt -qdaylist=$fixgsi/rtma_q_day_rejectlist -qnightlist=$fixgsi/rtma_q_night_rejectlist -tdaylist=$fixgsi/rtma_t_day_rejectlist -tnightlist=$fixgsi/rtma_t_night_rejectlist -wbinuselist=$fixgsi/rtma_wbinuselist -locinfo=$fixgsi/nam_hybens_d01_locinfo -### add 9 tables -errtable_pw=$fixgsi/prepobs_errtable_pw.global -errtable_ps=$fixgsi/prepobs_errtable_ps.global_nqcf -errtable_t=$fixgsi/prepobs_errtable_t.global_nqcf -errtable_q=$fixgsi/prepobs_errtable_q.global_nqcf -errtable_uv=$fixgsi/prepobs_errtable_uv.global_nqcf -btable_ps=$fixgsi/nqc_b_ps.global_nqcf -btable_t=$fixgsi/nqc_b_t.global_nqcf -btable_q=$fixgsi/nqc_b_q.global_nqcf -btable_uv=$fixgsi/nqc_b_uv.global_nqcf - -# add vertical profile of localization and beta_s,beta_e weights for hybrid ensemble runs -hybens_info=$fixgsi/nam_hybens_d01_info - - -# Copy executable and fixed files to $tmpdir -if [[ $exp == *"updat"* ]]; then - $ncp $gsiexec_updat ./gsi.x -elif [[ $exp == *"contrl"* ]]; then - $ncp $gsiexec_contrl ./gsi.x -fi - -cp $anavinfo ./anavinfo -cp $berror ./berror_stats -cp $errtable ./errtable -cp $emiscoef_IRwater ./Nalli.IRwater.EmisCoeff.bin -cp $emiscoef_IRice ./NPOESS.IRice.EmisCoeff.bin -cp $emiscoef_IRsnow ./NPOESS.IRsnow.EmisCoeff.bin -cp $emiscoef_IRland ./NPOESS.IRland.EmisCoeff.bin -cp $emiscoef_VISice ./NPOESS.VISice.EmisCoeff.bin -cp $emiscoef_VISland ./NPOESS.VISland.EmisCoeff.bin -cp $emiscoef_VISsnow ./NPOESS.VISsnow.EmisCoeff.bin -cp $emiscoef_VISwater ./NPOESS.VISwater.EmisCoeff.bin -cp $emiscoef_MWwater ./FASTEM6.MWwater.EmisCoeff.bin -cp $aercoef ./AerosolCoeff.bin -cp $cldcoef ./CloudCoeff.bin -cp $satinfo ./satinfo -cp $cloudyinfo ./cloudy_radiance_info.txt -cp $scaninfo ./scaninfo -cp $pcpinfo ./pcpinfo -cp $ozinfo ./ozinfo -cp $convinfo ./convinfo -cp $mesonetuselist ./mesonetuselist -cp $stnuselist ./mesonet_stnuselist -cp $qdaylist ./q_day_rejectlist -cp $qnightlist ./q_night_rejectlist -cp $tdaylist ./t_day_rejectlist -cp $tnightlist ./t_night_rejectlist -cp $wbinuselist ./wbinuselist -#cp $locinfo ./hybens_info -#add 9 tables for new varqc -$ncp $errtable_pw ./errtable_pw -$ncp $errtable_ps ./errtable_ps -$ncp $errtable_t ./errtable_t -$ncp $errtable_q ./errtable_q -$ncp $errtable_uv ./errtable_uv -$ncp $btable_ps ./btable_ps -$ncp $btable_t ./btable_t -$ncp $btable_q ./btable_q -$ncp $btable_uv ./btable_uv - -$ncp $hybens_info ./hybens_info - - -###### crtm coeff's ####################### -set +x -for file in `awk '{if($1!~"!"){print $1}}' satinfo | sort | uniq` ;do - cp $fixcrtm/${file}.SpcCoeff.bin ./ - cp $fixcrtm/${file}.TauCoeff.bin ./ -done -set -x - -PDY=`echo $adate | cut -c1-8` -CYC=`echo $adate | cut -c9-10` - -#datdir=/meso/noscrub/Wanshu.Wu/CASE/$adate - -cp $fv3_netcdf_obs/ndas.t06z.radwnd.tm06.bufr_d ./radarbufr -cp $fv3_netcdf_obs/ndas.t06z.prepbufr.tm06 ./prepbufr -cp $fv3_netcdf_obs/ndas.t06z.1bamua.tm06.bufr_d ./amsuabufr -cp $fv3_netcdf_obs/ndas.t06z.1bmhs.tm06.bufr_d ./mhsbufr -cp $fv3_netcdf_obs/ndas.t06z.goesfv.tm06.bufr_d ./gsnd1bufr -cp $fv3_netcdf_obs/ndas.t06z.airsev.tm06.bufr_d ./airsbufr -cp $fv3_netcdf_obs/ndas.t06z.satwnd.tm06.bufr_d ./satwndbufr - -cp $fv3_netcdf_ges/coupler.res coupler.res -cp $fv3_netcdf_ges/fv_core.res.nest02.nc fv3_akbk -cp $fv3_netcdf_ges/grid_spec.nest02.nc fv3_grid_spec -#the current GSI parallel IO for fv3-lam require the netcdf 4 format for nc files containing 3d fields -nccopy -4 $fv3_netcdf_ges/fv_core.res.nest02.tile7.nc fv3_dynvars -nccopy -4 $fv3_netcdf_ges/fv_tracer.res.nest02.tile7.nc fv3_tracer -cp $fv3_netcdf_ges/sfc_data.nest02.tile7.nc fv3_sfcdata - - -cp $fv3_netcdf_ges/nam.t06z.satbias_pc.tm04 ./satbias_pc -cp $fv3_netcdf_ges/nam.t06z.satbias.tm04 ./satbias_in -cp $fv3_netcdf_ges/nam.t06z.radstat.tm04 ./radstat.gdas - -listdiag=`tar xvf radstat.gdas | cut -d' ' -f2 | grep _ges` -for type in $listdiag; do - diag_file=`echo $type | cut -d',' -f1` - fname=`echo $diag_file | cut -d'.' -f1` - date=`echo $diag_file | cut -d'.' -f2` - $UNCOMPRESS $diag_file - fnameanl=$(echo $fname|sed 's/_ges//g') - mv $fname.$date $fnameanl -done - - -# Run GSI -cd $tmpdir -echo "run gsi now" -eval "$APRUN $tmpdir/gsi.x > stdout 2>&1" -rc=$? -exit $rc diff --git a/regression/regression_driver.sh b/regression/regression_driver.sh index 38329778a4..805a9dd1fb 100755 --- a/regression/regression_driver.sh +++ b/regression/regression_driver.sh @@ -59,7 +59,7 @@ if [ "$debug" == ".false." ]; then export scripts=${scripts_updat:-$scripts} - if [ $regtest = 'global_enkf' ]; then + if [ $regtest = 'global_enkf' ] || [ $regtest = 'rrfs_enkf_conv' ]; then /bin/sh $scripts/regression_test_enkf.sh ${job[1]} ${job[2]} ${job[3]} ${job[4]} ${tmpregdir} ${result} ${scaling[1]} ${scaling[2]} ${scaling[3]} else /bin/sh $scripts/regression_test.sh ${job[1]} ${job[2]} ${job[3]} ${job[4]} ${tmpregdir} ${result} ${scaling[1]} ${scaling[2]} ${scaling[3]} diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh index d360dfd870..a4f283f92b 100755 --- a/regression/regression_namelists.sh +++ b/regression/regression_namelists.sh @@ -319,7 +319,7 @@ OBS_INPUT:: / " ;; - rrfs_3denvar_glbens) + rrfs_3denvar_rdasens) # Define namelist for rrfs 3d hybrid envar run with global ensembles @@ -328,13 +328,14 @@ export gsi_namelist=" &SETUP miter=2,niter(1)=5,niter(2)=5, write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - qoption=2,print_obs_para=.true.,diag_radardbz=.false., - if_model_dbz=.false., static_gsi_nopcp_dbz=0.0, + qoption=2,print_obs_para=.true.,diag_fed=.true.,diag_radardbz=.false., + if_model_dbz=.true.,if_model_fed=.true.,static_gsi_nopcp_dbz=0.0,if_use_w_vr=.false., rmesh_dbz=4.0,rmesh_vr=4.0,zmesh_dbz=1000.0,zmesh_vr=1000.0, - missing_to_nopcp=.false.,radar_no_thinning=.true., + inflate_dbz_obserr=.true.,missing_to_nopcp=.false.,radar_no_thinning=.true., gencode=78,factqmin=0.0,factqmax=0.0, - iguess=-1, + iguess=-1,crtm_coeffs_path='./', lread_obs_save=.false.,lread_obs_skip=.false., + ens_nstarthr=01, oneobtest=.false.,retrieval=.false., nhr_assimilation=3,l_foto=.false., use_pbl=.false.,use_prepb_satwnd=.false., @@ -343,8 +344,10 @@ export gsi_namelist=" diag_precon=.true.,step_start=1.e-3, l4densvar=.false.,nhr_obsbin=3, use_gfs_nemsio=.false.,use_gfs_ncio=.true.,reset_bad_radbc=.true., - netcdf_diag=.false.,binary_diag=.true., + netcdf_diag=.true.,binary_diag=.false., l_obsprvdiag=.false., + lwrite_peakwt=.true., + innov_use_model_fed=.true., / &GRIDOPTS fv3_regional=.true.,grid_ratio_fv3_regional=2.0,nvege_type=20, @@ -372,7 +375,9 @@ export gsi_namelist=" / OBS_INPUT:: ! dfile dtype dplat dsis dval dthin dsfcalc + pm25bufr pm2_5 null TEOM 1.0 0 0 dbzobs.nc dbz null dbz 1.0 0 0 + fedobs.nc fed null fed 1.0 0 0 prepbufr ps null ps 1.0 0 0 prepbufr t null t 1.0 0 0 prepbufr q null q 1.0 0 0 @@ -389,6 +394,12 @@ OBS_INPUT:: sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 + hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 + hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 + hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 2 0 + hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0 + hirs4bufr hirs4 n19 hirs4_n19 0.0 2 0 + hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 2 0 gimgrbufr goes_img g11 imgr_g11 0.0 1 0 gimgrbufr goes_img g12 imgr_g12 0.0 1 0 airsbufr airs aqua airs_aqua 0.0 2 0 @@ -397,12 +408,14 @@ OBS_INPUT:: amsuabufr amsua n19 amsua_n19 0.0 2 0 amsuabufr amsua metop-a amsua_metop-a 0.0 2 0 amsuabufr amsua metop-b amsua_metop-b 0.0 2 0 + amsuabufr amsua metop-c amsua_metop-c 0.0 2 0 airsbufr amsua aqua amsua_aqua 0.0 2 0 amsubbufr amsub n17 amsub_n17 0.0 1 0 mhsbufr mhs n18 mhs_n18 0.0 2 0 mhsbufr mhs n19 mhs_n19 0.0 2 0 mhsbufr mhs metop-a mhs_metop-a 0.0 2 0 mhsbufr mhs metop-b mhs_metop-b 0.0 2 0 + mhsbufr mhs metop-c mhs_metop-c 0.0 2 0 ssmitbufr ssmi f13 ssmi_f13 0.0 2 0 ssmitbufr ssmi f14 ssmi_f14 0.0 2 0 ssmitbufr ssmi f15 ssmi_f15 0.0 2 0 @@ -431,11 +444,23 @@ OBS_INPUT:: gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 2 0 iasibufr iasi metop-a iasi_metop-a 0.0 2 0 gomebufr gome metop-a gome_metop-a 0.0 2 0 + omibufr omi aura omi_aura 0.0 2 0 + sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 + tcvitl tcp null tcp 0.0 0 0 + seviribufr seviri m08 seviri_m08 0.0 2 0 + seviribufr seviri m09 seviri_m09 0.0 2 0 + seviribufr seviri m10 seviri_m10 0.0 2 0 + seviribufr seviri m11 seviri_m11 0.0 2 0 + iasibufr iasi metop-b iasi_metop-b 0.0 2 0 + iasibufr iasi metop-c iasi_metop-c 0.0 2 0 + gomebufr gome metop-b gome_metop-b 0.0 2 0 atmsbufr atms npp atms_npp 0.0 2 0 atmsbufr atms n20 atms_n20 0.0 2 0 + atmsbufr atms n21 atms_n21 0.0 2 0 crisbufr cris npp cris_npp 0.0 2 0 crisfsbufr cris-fsr npp cris-fsr_npp 0.0 2 0 crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 2 0 + crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 2 0 abibufr abi g16 abi_g16 0.0 2 0 mlsbufr mls30 aura mls30_aura 0.0 0 0 oscatbufr uv null uv 0.0 0 0 @@ -444,6 +469,7 @@ OBS_INPUT:: refInGSI rad_ref null rad_ref 1.0 0 0 lghtInGSI lghtn null lghtn 1.0 0 0 larcInGSI larccld null larccld 1.0 0 0 + abibufr abi g18 abi_g18 0.0 2 0 :: &SUPEROB_RADAR del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., l2superob_only=.false., @@ -456,17 +482,30 @@ OBS_INPUT:: q_hyb_ens=.false., aniso_a_en=.false.,generate_ens=.false., n_ens=${nummem}, - beta_s0=0.15,s_ens_h=110,s_ens_v=3, - regional_ensemble_option=1, + l_both_fv3sar_gfs_ens=.false.,n_ens_gfs=0,n_ens_fv3sar=30, + weight_ens_gfs=1.0,weight_ens_fv3sar=1.0, + beta_s0=0.15,s_ens_h=328.632,82.1580,4.10790,4.10790,82.1580,s_ens_v=3,3,-0.30125,-0.30125,0.0, + regional_ensemble_option=5, pseudo_hybens = .false., - grid_ratio_ens = 3, + grid_ratio_ens = 1, l_ens_in_diff_time=.true., ensemble_path='', i_en_perts_io=1, jcap_ens=574, fv3sar_bg_opt=0, - readin_localization=.true., - ens_fast_read=.false., + readin_localization=.false., + parallelization_over_ensmembers=.false., + nsclgrp=2,l_timloc_opt=.false.,ngvarloc=2,naensloc=5, + r_ensloccov4tim=1.0,r_ensloccov4var=0.05,r_ensloccov4scl=1.0, + global_spectral_filter_sd=.false.,assign_vdl_nml=.false.,vdl_scale=0, + vloc_varlist(1,1)='sf ',vloc_varlist(2,1)='w ',vloc_varlist(3,1)='sf ',vloc_varlist(4,1)='w ', + vloc_varlist(1,2)='vp ',vloc_varlist(2,2)='qr ',vloc_varlist(3,2)='vp ',vloc_varlist(4,2)='qr ', + vloc_varlist(1,3)='ps ',vloc_varlist(2,3)='qs ',vloc_varlist(3,3)='ps ',vloc_varlist(4,3)='qs ', + vloc_varlist(1,4)='t ',vloc_varlist(2,4)='qi ',vloc_varlist(3,4)='t ',vloc_varlist(4,4)='qi ', + vloc_varlist(1,5)='q ',vloc_varlist(2,5)='qg ',vloc_varlist(3,5)='q ',vloc_varlist(4,5)='qg ', + vloc_varlist(1,6)='sst',vloc_varlist(2,6)='ql ',vloc_varlist(3,6)='sst',vloc_varlist(4,6)='ql ', + vloc_varlist(1,7)='stl',vloc_varlist(2,7)='dbz',vloc_varlist(3,7)='stl',vloc_varlist(4,7)='dbz', + vloc_varlist(1,8)='sti',vloc_varlist(2,8)='aaa',vloc_varlist(3,8)='sti',vloc_varlist(4,8)='aaa', / &RAPIDREFRESH_CLDSURF dfi_radar_latent_heat_time_period=20.0, @@ -506,6 +545,8 @@ OBS_INPUT:: i_gsdqc=2, / &CHEM + laeroana_fv3smoke=.false., + berror_fv3_cmaq_regional=.false., / &NST / @@ -516,6 +557,7 @@ OBS_INPUT:: / " ;; + hafs_envar) # Define namelist for hafs 3denvar run with global ensembles export gsi_namelist=" @@ -777,130 +819,128 @@ SUPEROB_RADAR:: / " ;; - netcdf_fv3_regional) + rrfs_enkf_conv) -# Define namelist for netcdf fv3 run +# Define namelist for rrfs EnKF run export gsi_namelist=" - &SETUP - miter=2,niter(1)=5,niter(2)=5,niter_no_qc(1)=2, - write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - qoption=2, - factqmin=0.0,factqmax=0.0,deltim=$DELTIM, - iguess=-1, - newpc4pred=.true., adp_anglebc=.true., angord=4, - diag_precon=.true., step_start=1.e-3, - nhr_assimilation=3,l_foto=.false., - use_pbl=.false.,use_compress=.false.,gpstop=30., - lrun_subdirs=.true., - $SETUP - / - &GRIDOPTS - fv3_regional=.true.,grid_ratio_fv3_regional=3.0, - / - &BKGERR - hzscl=0.373,0.746,1.50, - vs=0.6,bw=0.,fstat=.false., - / - &ANBKGERR - anisotropic=.false., - / - &JCOPTS - / - &STRONGOPTS - / - &OBSQC - dfact=0.75,dfact1=3.0,noiqc=.true.,c_varqc=0.02, - vadfile='prepbufr',oberrflg=.false.,njqc=.false.,vqc=.true., - / - &OBS_INPUT - dmesh(1)=120.0,dmesh(2)=60.0,dmesh(3)=60.0,dmesh(4)=60.0,dmesh(5)=120,time_window_max=1.5,ext_sonde=.true., - / -OBS_INPUT:: -! dfile dtype dplat dsis dval dthin dsfcalc - prepbufr ps null ps 0.0 0 0 - prepbufr t null t 0.0 0 0 - prepbufr q null q 0.0 0 0 - prepbufr pw null pw 0.0 0 0 - prepbufr uv null uv 0.0 0 0 - prepbufr spd null spd 0.0 0 0 - prepbufr dw null dw 0.0 0 0 - radarbufr rw null rw 0.0 0 0 - prepbufr sst null sst 0.0 0 0 - gpsrobufr gps_bnd null gps_bnd 0.0 0 0 - ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0 - tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0 - sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 - sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 - sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - gsndrbufr sndr g11 sndr_g11 0.0 1 0 - gsndrbufr sndr g12 sndr_g12 0.0 1 0 - gimgrbufr goes_img g11 imgr_g11 0.0 1 0 - gimgrbufr goes_img g12 imgr_g12 0.0 1 0 - airsbufr airs aqua airs281_aqua 0.0 1 0 - msubufr msu n14 msu_n14 0.0 1 0 - amsuabufr amsua n15 amsua_n15 0.0 1 0 - amsuabufr amsua n16 amsua_n16 0.0 1 0 - amsuabufr amsua n17 amsua_n17 0.0 1 0 - amsuabufr amsua n18 amsua_n18 0.0 1 0 - amsuabufr amsua metop-a amsua_metop-a 0.0 1 0 - amsuabufr amsua metop-b amsua_metop-b 0.0 1 0 - airsbufr amsua aqua amsua_aqua 0.0 1 0 - amsubbufr amsub n15 amsub_n15 0.0 1 0 - amsubbufr amsub n16 amsub_n16 0.0 1 0 - amsubbufr amsub n17 amsub_n17 0.0 1 0 - mhsbufr mhs n18 mhs_n18 0.0 1 0 - mhsbufr mhs metop-a mhs_metop-a 0.0 1 0 - mhsbufr mhs metop-b mhs_metop-b 0.0 1 0 - ssmitbufr ssmi f13 ssmi_f13 0.0 1 0 - ssmitbufr ssmi f14 ssmi_f14 0.0 1 0 - ssmitbufr ssmi f15 ssmi_f15 0.0 1 0 - amsrebufr amsre_low aqua amsre_aqua 0.0 1 0 - amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0 - amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0 - ssmisbufr ssmis f16 ssmis_f16 0.0 1 0 - iasibufr iasi metop-a iasi_metop-a 0.0 1 0 - gomebufr gome metop-a gome_metop-a 0.0 1 0 - iasibufr iasi metop-b iasi_metop-b 0.0 1 0 - omibufr omi aura omi_aura 0.0 1 0 - sbuvbufr sbuv2 n19 sbuv8_n19 0.0 1 0 - amsuabufr amsua n19 amsua_n19 0.0 1 0 - mhsbufr mhs n19 mhs_n19 0.0 1 0 - tcvitl tcp null tcp 0.0 0 0 - satwndbufr uv null uv 0.0 0 0 - atmsbufr atms npp atms_npp 0.0 1 0 - crisbufr cris npp cris_npp 0.0 1 0 - crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 - seviribufr seviri m08 seviri_m08 0.0 1 0 - seviribufr seviri m09 seviri_m09 0.0 1 0 - seviribufr seviri m10 seviri_m10 0.0 1 0 - seviribufr seviri m11 seviri_m11 0.0 1 0 - gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 1 0 - gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0 - gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0 - gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0 - prepbufr mta_cld null mta_cld 1.0 0 0 - prepbufr gos_ctp null gos_ctp 1.0 0 0 - lgycldbufr larccld null larccld 1.0 0 0 -:: - &SUPEROB_RADAR - del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., - l2superob_only=.false., - / - &LAG_DATA - / - &HYBRID_ENSEMBLE - / - &RAPIDREFRESH_CLDSURF - dfi_radar_latent_heat_time_period=30.0, - / - &CHEM - / - &SINGLEOB_TEST - / - &NST - / + &nam_enkf + datestring=${rrfs_enkf_adate},datapath='${tmpdir}/', + analpertwtnh=1.10,analpertwtsh=1.10,analpertwttr=1.10, + covinflatemax=1.e2,covinflatemin=1,pseudo_rh=.true.,iassim_order=0, + corrlengthnh=300,corrlengthsh=300,corrlengthtr=300, + lnsigcutoffnh=0.5,lnsigcutoffsh=0.5,lnsigcutofftr=0.5, + lnsigcutoffpsnh=0.5,lnsigcutoffpssh=0.5,lnsigcutoffpstr=0.5, + lnsigcutoffsatnh=0.5,lnsigcutoffsatsh=0.5,lnsigcutoffsattr=0.5, + obtimelnh=1.e30,obtimelsh=1.e30,obtimeltr=1.e30, + saterrfact=1.0,numiter=1, + sprd_tol=1.e30,paoverpb_thresh=0.98, + nlons=420,nlats= 252, nlevs= 65,nanals=5, + deterministic=.true.,sortinc=.true.,lupd_satbiasc=.false., + reducedgrid=.true.,readin_localization=.false., + use_gfs_nemsio=.true.,imp_physics=99,lupp=.false., + univaroz=.false.,adp_anglebc=.true.,angord=4,use_edges=.false.,emiss_bc=.true., + lobsdiag_forenkf=.false., + write_spread_diag=.false., + netcdf_diag=.true., + fv3_native=.true., + / + &satobs_enkf + sattypes_rad(1) = 'amsua_n15', dsis(1) = 'amsua_n15', + sattypes_rad(2) = 'amsua_n18', dsis(2) = 'amsua_n18', + sattypes_rad(3) = 'amsua_n19', dsis(3) = 'amsua_n19', + sattypes_rad(4) = 'amsub_n16', dsis(4) = 'amsub_n16', + sattypes_rad(5) = 'amsub_n17', dsis(5) = 'amsub_n17', + sattypes_rad(6) = 'amsua_aqua', dsis(6) = 'amsua_aqua', + sattypes_rad(7) = 'amsua_metop-a', dsis(7) = 'amsua_metop-a', + sattypes_rad(8) = 'airs_aqua', dsis(8) = 'airs_aqua', + sattypes_rad(9) = 'hirs3_n17', dsis(9) = 'hirs3_n17', + sattypes_rad(10)= 'hirs4_n19', dsis(10)= 'hirs4_n19', + sattypes_rad(11)= 'hirs4_metop-a', dsis(11)= 'hirs4_metop-a', + sattypes_rad(12)= 'mhs_n18', dsis(12)= 'mhs_n18', + sattypes_rad(13)= 'mhs_n19', dsis(13)= 'mhs_n19', + sattypes_rad(14)= 'mhs_metop-a', dsis(14)= 'mhs_metop-a', + sattypes_rad(15)= 'goes_img_g11', dsis(15)= 'imgr_g11', + sattypes_rad(16)= 'goes_img_g12', dsis(16)= 'imgr_g12', + sattypes_rad(17)= 'goes_img_g13', dsis(17)= 'imgr_g13', + sattypes_rad(18)= 'goes_img_g14', dsis(18)= 'imgr_g14', + sattypes_rad(19)= 'goes_img_g15', dsis(19)= 'imgr_g15', + sattypes_rad(20)= 'avhrr_n18', dsis(20)= 'avhrr3_n18', + sattypes_rad(21)= 'avhrr_metop-a', dsis(21)= 'avhrr3_metop-a', + sattypes_rad(22)= 'avhrr_n19', dsis(22)= 'avhrr3_n19', + sattypes_rad(23)= 'amsre_aqua', dsis(23)= 'amsre_aqua', + sattypes_rad(24)= 'ssmis_f16', dsis(24)= 'ssmis_f16', + sattypes_rad(25)= 'ssmis_f17', dsis(25)= 'ssmis_f17', + sattypes_rad(26)= 'ssmis_f18', dsis(26)= 'ssmis_f18', + sattypes_rad(27)= 'ssmis_f19', dsis(27)= 'ssmis_f19', + sattypes_rad(28)= 'ssmis_f20', dsis(28)= 'ssmis_f20', + sattypes_rad(29)= 'sndrd1_g11', dsis(29)= 'sndrD1_g11', + sattypes_rad(30)= 'sndrd2_g11', dsis(30)= 'sndrD2_g11', + sattypes_rad(31)= 'sndrd3_g11', dsis(31)= 'sndrD3_g11', + sattypes_rad(32)= 'sndrd4_g11', dsis(32)= 'sndrD4_g11', + sattypes_rad(33)= 'sndrd1_g12', dsis(33)= 'sndrD1_g12', + sattypes_rad(34)= 'sndrd2_g12', dsis(34)= 'sndrD2_g12', + sattypes_rad(35)= 'sndrd3_g12', dsis(35)= 'sndrD3_g12', + sattypes_rad(36)= 'sndrd4_g12', dsis(36)= 'sndrD4_g12', + sattypes_rad(37)= 'sndrd1_g13', dsis(37)= 'sndrD1_g13', + sattypes_rad(38)= 'sndrd2_g13', dsis(38)= 'sndrD2_g13', + sattypes_rad(39)= 'sndrd3_g13', dsis(39)= 'sndrD3_g13', + sattypes_rad(40)= 'sndrd4_g13', dsis(40)= 'sndrD4_g13', + sattypes_rad(41)= 'sndrd1_g14', dsis(41)= 'sndrD1_g14', + sattypes_rad(42)= 'sndrd2_g14', dsis(42)= 'sndrD2_g14', + sattypes_rad(43)= 'sndrd3_g14', dsis(43)= 'sndrD3_g14', + sattypes_rad(44)= 'sndrd4_g14', dsis(44)= 'sndrD4_g14', + sattypes_rad(45)= 'sndrd1_g15', dsis(45)= 'sndrD1_g15', + sattypes_rad(46)= 'sndrd2_g15', dsis(46)= 'sndrD2_g15', + sattypes_rad(47)= 'sndrd3_g15', dsis(47)= 'sndrD3_g15', + sattypes_rad(48)= 'sndrd4_g15', dsis(48)= 'sndrD4_g15', + sattypes_rad(49)= 'iasi_metop-a', dsis(49)= 'iasi_metop-a', + sattypes_rad(50)= 'seviri_m08', dsis(50)= 'seviri_m08', + sattypes_rad(51)= 'seviri_m09', dsis(51)= 'seviri_m09', + sattypes_rad(52)= 'seviri_m10', dsis(52)= 'seviri_m10', + sattypes_rad(53)= 'seviri_m11', dsis(53)= 'seviri_m11', + sattypes_rad(54)= 'amsua_metop-b', dsis(54)= 'amsua_metop-b', + sattypes_rad(55)= 'hirs4_metop-b', dsis(55)= 'hirs4_metop-b', + sattypes_rad(56)= 'mhs_metop-b', dsis(56)= 'mhs_metop-b', + sattypes_rad(57)= 'iasi_metop-b', dsis(57)= 'iasi_metop-b', + sattypes_rad(58)= 'avhrr_metop-b', dsis(58)= 'avhrr3_metop-b', + sattypes_rad(59)= 'atms_npp', dsis(59)= 'atms_npp', + sattypes_rad(60)= 'atms_n20', dsis(60)= 'atms_n20', + sattypes_rad(61)= 'cris_npp', dsis(61)= 'cris_npp', + sattypes_rad(62)= 'cris-fsr_npp', dsis(62)= 'cris-fsr_npp', + sattypes_rad(63)= 'cris-fsr_n20', dsis(63)= 'cris-fsr_n20', + sattypes_rad(64)= 'gmi_gpm', dsis(64)= 'gmi_gpm', + sattypes_rad(65)= 'saphir_meghat', dsis(65)= 'saphir_meghat', + sattypes_rad(66)= 'amsua_metop-c', dsis(66)= 'amsua_metop-c', + sattypes_rad(67)= 'mhs_metop-c', dsis(67)= 'mhs_metop-c', + sattypes_rad(68)= 'ahi_himawari8', dsis(68)= 'ahi_himawari8', + sattypes_rad(69)= 'abi_g16', dsis(69)= 'abi_g16', + sattypes_rad(70)= 'abi_g17', dsis(70)= 'abi_g17', + sattypes_rad(71)= 'iasi_metop-c', dsis(71)= 'iasi_metop-c', + sattypes_rad(72)= 'viirs-m_npp', dsis(72)= 'viirs-m_npp', + sattypes_rad(73)= 'viirs-m_j1', dsis(73)= 'viirs-m_j1', + sattypes_rad(74)= 'avhrr_metop-c', dsis(74)= 'avhrr3_metop-c', + sattypes_rad(75)= 'abi_g18', dsis(75)= 'abi_g18', + sattypes_rad(76)= 'ahi_himawari9', dsis(76)= 'ahi_himawari9', + sattypes_rad(77)= 'viirs-m_j2', dsis(77)= 'viirs-m_j2', + sattypes_rad(78)= 'atms_n21', dsis(78)= 'atms_n21', + sattypes_rad(79)= 'cris-fsr_n21', dsis(79)= 'cris-fsr_n21', + / + &ozobs_enkf + sattypes_oz(1) = 'sbuv2_n16', + sattypes_oz(2) = 'sbuv2_n17', + sattypes_oz(3) = 'sbuv2_n18', + sattypes_oz(4) = 'sbuv2_n19', + sattypes_oz(5) = 'omi_aura', + sattypes_oz(6) = 'gome_metop-a', + sattypes_oz(7) = 'gome_metop-b', + sattypes_oz(8) = 'mls30_aura', + / + &nam_fv3 + fv3fixpath="XXX",nx_res=${NX_RES:-420},ny_res=${NY_RES-252},ntiles=1, + l_fv3reg_filecombined=.false., + / " ;; global_enkf) diff --git a/regression/regression_namelists_db.sh b/regression/regression_namelists_db.sh index 83718b50d5..b96c208070 100755 --- a/regression/regression_namelists_db.sh +++ b/regression/regression_namelists_db.sh @@ -301,7 +301,7 @@ OBS_INPUT:: " ;; - rrfs_3denvar_glbens) + rrfs_3denvar_rdasens) # Define namelist for rrfs 3d hybrid envar run with global ensembles @@ -310,13 +310,14 @@ export gsi_namelist=" &SETUP miter=1,niter(1)=2,niter(2)=2, write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - qoption=2,print_obs_para=.true.,diag_radardbz=.false., - if_model_dbz=.false., static_gsi_nopcp_dbz=0.0, + qoption=2,print_obs_para=.true.,diag_fed=.true.,diag_radardbz=.false., + if_model_dbz=.true.,if_model_fed=.true.,static_gsi_nopcp_dbz=0.0,if_use_w_vr=.false., rmesh_dbz=4.0,rmesh_vr=4.0,zmesh_dbz=1000.0,zmesh_vr=1000.0, - missing_to_nopcp=.false.,radar_no_thinning=.true., + inflate_dbz_obserr=.true.,missing_to_nopcp=.false.,radar_no_thinning=.true., gencode=78,factqmin=0.0,factqmax=0.0, - iguess=-1, + iguess=-1,crtm_coeffs_path='./', lread_obs_save=.false.,lread_obs_skip=.false., + ens_nstarthr=01, oneobtest=.false.,retrieval=.false., nhr_assimilation=3,l_foto=.false., use_pbl=.false.,use_prepb_satwnd=.false., @@ -325,8 +326,10 @@ export gsi_namelist=" diag_precon=.true.,step_start=1.e-3, l4densvar=.false.,nhr_obsbin=3, use_gfs_nemsio=.false.,use_gfs_ncio=.true.,reset_bad_radbc=.true., - netcdf_diag=.false.,binary_diag=.true., + netcdf_diag=.true.,binary_diag=.false., l_obsprvdiag=.false., + lwrite_peakwt=.true., + innov_use_model_fed=.true., / &GRIDOPTS fv3_regional=.true.,grid_ratio_fv3_regional=2.0,nvege_type=20, @@ -354,7 +357,9 @@ export gsi_namelist=" / OBS_INPUT:: ! dfile dtype dplat dsis dval dthin dsfcalc + pm25bufr pm2_5 null TEOM 1.0 0 0 dbzobs.nc dbz null dbz 1.0 0 0 + fedobs.nc fed null fed 1.0 0 0 prepbufr ps null ps 1.0 0 0 prepbufr t null t 1.0 0 0 prepbufr q null q 1.0 0 0 @@ -371,6 +376,12 @@ OBS_INPUT:: sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 + hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 + hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 + hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 2 0 + hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0 + hirs4bufr hirs4 n19 hirs4_n19 0.0 2 0 + hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 2 0 gimgrbufr goes_img g11 imgr_g11 0.0 1 0 gimgrbufr goes_img g12 imgr_g12 0.0 1 0 airsbufr airs aqua airs_aqua 0.0 2 0 @@ -379,12 +390,14 @@ OBS_INPUT:: amsuabufr amsua n19 amsua_n19 0.0 2 0 amsuabufr amsua metop-a amsua_metop-a 0.0 2 0 amsuabufr amsua metop-b amsua_metop-b 0.0 2 0 + amsuabufr amsua metop-c amsua_metop-c 0.0 2 0 airsbufr amsua aqua amsua_aqua 0.0 2 0 amsubbufr amsub n17 amsub_n17 0.0 1 0 mhsbufr mhs n18 mhs_n18 0.0 2 0 mhsbufr mhs n19 mhs_n19 0.0 2 0 mhsbufr mhs metop-a mhs_metop-a 0.0 2 0 mhsbufr mhs metop-b mhs_metop-b 0.0 2 0 + mhsbufr mhs metop-c mhs_metop-c 0.0 2 0 ssmitbufr ssmi f13 ssmi_f13 0.0 2 0 ssmitbufr ssmi f14 ssmi_f14 0.0 2 0 ssmitbufr ssmi f15 ssmi_f15 0.0 2 0 @@ -413,11 +426,23 @@ OBS_INPUT:: gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 2 0 iasibufr iasi metop-a iasi_metop-a 0.0 2 0 gomebufr gome metop-a gome_metop-a 0.0 2 0 + omibufr omi aura omi_aura 0.0 2 0 + sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 + tcvitl tcp null tcp 0.0 0 0 + seviribufr seviri m08 seviri_m08 0.0 2 0 + seviribufr seviri m09 seviri_m09 0.0 2 0 + seviribufr seviri m10 seviri_m10 0.0 2 0 + seviribufr seviri m11 seviri_m11 0.0 2 0 + iasibufr iasi metop-b iasi_metop-b 0.0 2 0 + iasibufr iasi metop-c iasi_metop-c 0.0 2 0 + gomebufr gome metop-b gome_metop-b 0.0 2 0 atmsbufr atms npp atms_npp 0.0 2 0 atmsbufr atms n20 atms_n20 0.0 2 0 + atmsbufr atms n21 atms_n21 0.0 2 0 crisbufr cris npp cris_npp 0.0 2 0 crisfsbufr cris-fsr npp cris-fsr_npp 0.0 2 0 crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 2 0 + crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 2 0 abibufr abi g16 abi_g16 0.0 2 0 mlsbufr mls30 aura mls30_aura 0.0 0 0 oscatbufr uv null uv 0.0 0 0 @@ -426,6 +451,7 @@ OBS_INPUT:: refInGSI rad_ref null rad_ref 1.0 0 0 lghtInGSI lghtn null lghtn 1.0 0 0 larcInGSI larccld null larccld 1.0 0 0 + abibufr abi g18 abi_g18 0.0 2 0 :: &SUPEROB_RADAR del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., l2superob_only=.false., @@ -438,17 +464,30 @@ OBS_INPUT:: q_hyb_ens=.false., aniso_a_en=.false.,generate_ens=.false., n_ens=${nummem}, - beta_s0=0.15,s_ens_h=110,s_ens_v=3, - regional_ensemble_option=1, + l_both_fv3sar_gfs_ens=.false.,n_ens_gfs=0,n_ens_fv3sar=30, + weight_ens_gfs=1.0,weight_ens_fv3sar=1.0, + beta_s0=0.15,s_ens_h=328.632,82.1580,4.10790,4.10790,82.1580,s_ens_v=3,3,-0.30125,-0.30125,0.0, + regional_ensemble_option=5, pseudo_hybens = .false., - grid_ratio_ens = 3, + grid_ratio_ens = 1, l_ens_in_diff_time=.true., ensemble_path='', i_en_perts_io=1, jcap_ens=574, fv3sar_bg_opt=0, - readin_localization=.true., - ens_fast_read=.false., + readin_localization=.false., + parallelization_over_ensmembers=.false., + nsclgrp=2,l_timloc_opt=.false.,ngvarloc=2,naensloc=5, + r_ensloccov4tim=1.0,r_ensloccov4var=0.05,r_ensloccov4scl=1.0, + global_spectral_filter_sd=.false.,assign_vdl_nml=.false.,vdl_scale=0, + vloc_varlist(1,1)='sf ',vloc_varlist(2,1)='w ',vloc_varlist(3,1)='sf ',vloc_varlist(4,1)='w ', + vloc_varlist(1,2)='vp ',vloc_varlist(2,2)='qr ',vloc_varlist(3,2)='vp ',vloc_varlist(4,2)='qr ', + vloc_varlist(1,3)='ps ',vloc_varlist(2,3)='qs ',vloc_varlist(3,3)='ps ',vloc_varlist(4,3)='qs ', + vloc_varlist(1,4)='t ',vloc_varlist(2,4)='qi ',vloc_varlist(3,4)='t ',vloc_varlist(4,4)='qi ', + vloc_varlist(1,5)='q ',vloc_varlist(2,5)='qg ',vloc_varlist(3,5)='q ',vloc_varlist(4,5)='qg ', + vloc_varlist(1,6)='sst',vloc_varlist(2,6)='ql ',vloc_varlist(3,6)='sst',vloc_varlist(4,6)='ql ', + vloc_varlist(1,7)='stl',vloc_varlist(2,7)='dbz',vloc_varlist(3,7)='stl',vloc_varlist(4,7)='dbz', + vloc_varlist(1,8)='sti',vloc_varlist(2,8)='aaa',vloc_varlist(3,8)='sti',vloc_varlist(4,8)='aaa', / &RAPIDREFRESH_CLDSURF dfi_radar_latent_heat_time_period=20.0, @@ -488,6 +527,8 @@ OBS_INPUT:: i_gsdqc=2, / &CHEM + laeroana_fv3smoke=.false., + berror_fv3_cmaq_regional=.false., / &NST / @@ -761,133 +802,6 @@ SUPEROB_RADAR:: obhourset=0., / " -;; - - netcdf_fv3_regional) - -# Define namelist for netcdf fv3 run - -export gsi_namelist=" - - &SETUP - miter=2,niter(1)=2,niter(2)=1,niter_no_qc(1)=1, - write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - qoption=2, - factqmin=0.0,factqmax=0.0,deltim=$DELTIM, - iguess=-1, - newpc4pred=.true., adp_anglebc=.true., angord=4, - diag_precon=.true., step_start=1.e-3, - nhr_assimilation=3,l_foto=.false., - use_pbl=.false.,use_compress=.false.,gpstop=30., - lrun_subdirs=.true., - $SETUP - / - &GRIDOPTS - fv3_regional=.true.,grid_ratio_fv3_regional=3.0, - / - &BKGERR - hzscl=0.373,0.746,1.50, - vs=0.6,bw=0.,fstat=.false., - / - &ANBKGERR - anisotropic=.false., - / - &JCOPTS - / - &STRONGOPTS - / - &OBSQC - dfact=0.75,dfact1=3.0,noiqc=.true.,c_varqc=0.02, - vadfile='prepbufr',oberrflg=.false.,njqc=.false.,vqc=.true., - / - &OBS_INPUT - dmesh(1)=120.0,dmesh(2)=60.0,dmesh(3)=60.0,dmesh(4)=60.0,dmesh(5)=120,time_window_max=1.5,ext_sonde=.true., - / -OBS_INPUT:: -! dfile dtype dplat dsis dval dthin dsfcalc - prepbufr ps null ps 0.0 0 0 - prepbufr t null t 0.0 0 0 - prepbufr q null q 0.0 0 0 - prepbufr pw null pw 0.0 0 0 - prepbufr uv null uv 0.0 0 0 - prepbufr spd null spd 0.0 0 0 - prepbufr dw null dw 0.0 0 0 - radarbufr rw null rw 0.0 0 0 - prepbufr sst null sst 0.0 0 0 - gpsrobufr gps_bnd null gps_bnd 0.0 0 0 - ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0 - tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0 - sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 - sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 - sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - gsndrbufr sndr g11 sndr_g11 0.0 1 0 - gsndrbufr sndr g12 sndr_g12 0.0 1 0 - gimgrbufr goes_img g11 imgr_g11 0.0 1 0 - gimgrbufr goes_img g12 imgr_g12 0.0 1 0 - airsbufr airs aqua airs281_aqua 0.0 1 0 - msubufr msu n14 msu_n14 0.0 1 0 - amsuabufr amsua n15 amsua_n15 0.0 1 0 - amsuabufr amsua n16 amsua_n16 0.0 1 0 - amsuabufr amsua n17 amsua_n17 0.0 1 0 - amsuabufr amsua n18 amsua_n18 0.0 1 0 - amsuabufr amsua metop-a amsua_metop-a 0.0 1 0 - amsuabufr amsua metop-b amsua_metop-b 0.0 1 0 - airsbufr amsua aqua amsua_aqua 0.0 1 0 - amsubbufr amsub n15 amsub_n15 0.0 1 0 - amsubbufr amsub n16 amsub_n16 0.0 1 0 - amsubbufr amsub n17 amsub_n17 0.0 1 0 - mhsbufr mhs n18 mhs_n18 0.0 1 0 - mhsbufr mhs metop-a mhs_metop-a 0.0 1 0 - mhsbufr mhs metop-b mhs_metop-b 0.0 1 0 - ssmitbufr ssmi f13 ssmi_f13 0.0 1 0 - ssmitbufr ssmi f14 ssmi_f14 0.0 1 0 - ssmitbufr ssmi f15 ssmi_f15 0.0 1 0 - amsrebufr amsre_low aqua amsre_aqua 0.0 1 0 - amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0 - amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0 - ssmisbufr ssmis f16 ssmis_f16 0.0 1 0 - iasibufr iasi metop-a iasi_metop-a 0.0 1 0 - gomebufr gome metop-a gome_metop-a 0.0 1 0 - iasibufr iasi metop-b iasi_metop-b 0.0 1 0 - omibufr omi aura omi_aura 0.0 1 0 - sbuvbufr sbuv2 n19 sbuv8_n19 0.0 1 0 - amsuabufr amsua n19 amsua_n19 0.0 1 0 - mhsbufr mhs n19 mhs_n19 0.0 1 0 - tcvitl tcp null tcp 0.0 0 0 - satwndbufr uv null uv 0.0 0 0 - atmsbufr atms npp atms_npp 0.0 1 0 - crisbufr cris npp cris_npp 0.0 1 0 - crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 - seviribufr seviri m08 seviri_m08 0.0 1 0 - seviribufr seviri m09 seviri_m09 0.0 1 0 - seviribufr seviri m10 seviri_m10 0.0 1 0 - seviribufr seviri m11 seviri_m11 0.0 1 0 - gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 1 0 - gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0 - gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0 - gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0 - prepbufr mta_cld null mta_cld 1.0 0 0 - prepbufr gos_ctp null gos_ctp 1.0 0 0 - lgycldbufr larccld null larccld 1.0 0 0 -:: - &SUPEROB_RADAR - del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., - l2superob_only=.false., - / - &LAG_DATA - / - &HYBRID_ENSEMBLE - / - &RAPIDREFRESH_CLDSURF - dfi_radar_latent_heat_time_period=30.0, - / - &CHEM - / - &SINGLEOB_TEST - / - &NST - / -" ;; *) diff --git a/regression/regression_param.sh b/regression/regression_param.sh index 6ee72f14da..bfc6f042fc 100755 --- a/regression/regression_param.sh +++ b/regression/regression_param.sh @@ -84,17 +84,17 @@ case $regtest in ;; - rrfs_3denvar_glbens) + rrfs_3denvar_rdasens) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" + topts[1]="0:05:00" ; popts[1]="40/3/" ; ropts[1]="/1" + topts[2]="0:05:00" ; popts[2]="40/5/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/2" elif [[ "$machine" = "Hercules" ]]; then - topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/2" + topts[1]="0:05:00" ; popts[1]="40/3/" ; ropts[1]="/1" + topts[2]="0:05:00" ; popts[2]="40/5/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" @@ -173,17 +173,17 @@ case $regtest in ;; - netcdf_fv3_regional) + rrfs_enkf_conv) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" + topts[1]="0:05:00" ; popts[1]="40/2/" ; ropts[1]="/1" + topts[2]="0:05:00" ; popts[2]="40/4/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" elif [[ "$machine" = "Hercules" ]]; then - topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" + topts[1]="0:05:00" ; popts[1]="40/2/" ; ropts[1]="/1" + topts[2]="0:05:00" ; popts[2]="40/4/" ; ropts[2]="/1" elif [[ "$machine" = "Jet" ]]; then topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" @@ -191,8 +191,8 @@ case $regtest in topts[1]="0:15:00" ; popts[1]="28/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="28/2/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then - topts[1]="0:15:00" ; popts[1]="28/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="28/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="64/2/" ; ropts[2]="/1" fi if [ "$debug" = ".true." ] ; then diff --git a/regression/regression_test_enkf.sh b/regression/regression_test_enkf.sh index 38ee20ce99..ac839631c2 100755 --- a/regression/regression_test_enkf.sh +++ b/regression/regression_test_enkf.sh @@ -35,16 +35,30 @@ maxtime=1200 # Copy stdout and incr files # from $savdir to $tmpdir list="$exp1 $exp2 $exp3" -for exp in $list; do - $ncp $savdir/$exp/stdout ./stdout.$exp - nmem=10 - imem=1 - while [[ $imem -le $nmem ]]; do - member="_mem"`printf %03i $imem` - $ncp $savdir/$exp/incr_${global_adate}_fhr06$member $tmpdir/incr$member.$exp - (( imem = $imem + 1 )) +if [[ $(expr substr $exp1 1 4) = "rrfs" ]]; then + for exp in $list; do + $ncp $savdir/$exp/stdout ./stdout.$exp + nmem=5 + imem=1 + while [[ $imem -le $nmem ]]; do + member="_mem"`printf %03i $imem` + $ncp $savdir/$exp/fv3sar_tile1_mem${member}_dynvars $tmpdir/dynvars$member.$exp + $ncp $savdir/$exp/fv3sar_tile1_mem${member}_tracer $tmpdir/tracer$member.$exp + (( imem = $imem + 1 )) + done done -done +else + for exp in $list; do + $ncp $savdir/$exp/stdout ./stdout.$exp + nmem=10 + imem=1 + while [[ $imem -le $nmem ]]; do + member="_mem"`printf %03i $imem` + $ncp $savdir/$exp/incr_${global_adate}_fhr06$member $tmpdir/incr$member.$exp + (( imem = $imem + 1 )) + done + done +fi # Grep out ensemble mean increment information, run time, and maximum resident memory from stdout file list="$exp1 $exp2 $exp3" @@ -223,16 +237,36 @@ fi # Next, check reproducibility of results between exp1 and exp2 -if [[ `expr substr $exp1 1 4` = "rtma" ]]; then +if [[ $(expr substr $exp1 1 4) = "rrfs" ]]; then { -if cmp -s siganl.${exp1} siganl.${exp2} -then - echo 'The results between the two runs ('${exp1}' and '${exp2}') are reproducible' - echo 'since the corresponding results are identical.' - echo -fi +nmem=5 +imem=1 +while [[ $imem -le $nmem ]]; do + member="_mem"`printf %03i $imem` + ncdump dynvars$member.${exp1} > dynvars$member.${exp1}.out + ncdump dynvars$member.${exp2} > dynvars$member.${exp2}.out + if [ ! diff dynvars$member.${exp1}.out dynvars$member.${exp2}.out ]; then + echo 'dynvars'$member'.'${exp1}' dynvars'$member'.'${exp2}' are NOT identical' + failed_test=1 + else + rm -f dynvars$member.${exp1}.out dynvars$member.${exp2}.out + echo 'dynvars'$member'.'${exp1}' dynvars'$member'.'${exp2}' are identical' + fi + ncdump tracer$member.${exp1} > tracers$member.${exp1}.out + ncdump tracer$member.${exp2} > tracers$member.${exp2}.out + if [ ! diff tracers$member.${exp1}.out tracers$member.${exp2}.out ]; then + echo 'tracer'$member'.'${exp1}' tracer'$member'.'${exp2}' are NOT identical' + failed_test=1 + else + rm -f tracers$member.${exp1}.out tracers$member.${exp2}.out + echo 'tracer'$member'.'${exp1}' tracer'$member'.'${exp2}' are identical' + q + fi + (( imem = $imem + 1 )) +done +echo } >> $output @@ -321,16 +355,35 @@ else # Next, check reproducibility of results between exp1 and exp3 - if [[ `expr substr $exp1 1 4` = "rtma" ]]; then + if [[ $(expr substr $exp1 1 4) = "rrfs" ]]; then { - if cmp -s wrf_inout.${exp1} wrf_inout.${exp3} - then - echo 'The results between the two runs ('${exp1}' and '${exp3}') are reproducible' - echo 'since the corresponding results are identical.' - echo - fi + nmem=5 + imem=1 + while [[ $imem -le $nmem ]]; do + member="_mem"`printf %03i $imem` + ncdump dynvars$member.${exp1} > dynvars$member.${exp1}.out + ncdump dynvars$member.${exp3} > dynvars$member.${exp3}.out + if [ ! diff dynvars$member.${exp1}.out dynvars$member.${exp3}.out ]; then + echo 'dynvars'$member'.'${exp1}' dynvars'$member'.'${exp3}' are NOT identical' + failed_test=1 + else + rm -f dynvars$member.${exp1}.out dynvars$member.${exp3}.out + echo 'dynvars'$member'.'${exp1}' dynvars'$member'.'${exp3}' are identical' + fi + ncdump tracer$member.${exp1} > tracers$member.${exp1}.out + ncdump tracer$member.${exp3} > tracers$member.${exp3}.out + if [ ! diff tracers$member.${exp1}.out tracers$member.${exp3}.out ]; then + echo 'tracer'$member'.'${exp1}' tracer'$member'.'${exp3}' are NOT identical' + failed_test=1 + else + rm -f tracers$member.${exp1}.out tracers$member.${exp3}.out + echo 'tracer'$member'.'${exp1}' tracer'$member'.'${exp3}' are identical' + fi + (( imem = $imem + 1 )) + done + echo } >> $output diff --git a/regression/regression_var.sh b/regression/regression_var.sh index aebbccab8b..3e5487009d 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -188,19 +188,19 @@ export JCAP="62" # Case Study analysis dates export global_adate="2024022300" export rtma_adate="2020022420" -export fv3_netcdf_adate="2017030100" -export rrfs_3denvar_glbens_adate="2021072518" +export rrfs_enkf_adate="2023061012" +export rrfs_3denvar_rdasens_adate="2023061012" export hafs_envar_adate="2020082512" # Paths for canned case data. export global_data="$casesdir/gfs/prod" export rtma_obs="$casesdir/regional/rtma_binary/$rtma_adate" export rtma_ges="$casesdir/regional/rtma_binary/$rtma_adate" -export fv3_netcdf_obs="$casesdir/regional/fv3_netcdf/$fv3_netcdf_adate" -export fv3_netcdf_ges="$casesdir/regional/fv3_netcdf/$fv3_netcdf_adate" -export rrfs_3denvar_glbens_obs="$casesdir/regional/rrfs/$rrfs_3denvar_glbens_adate/obs" -export rrfs_3denvar_glbens_ges="$casesdir/regional/rrfs/$rrfs_3denvar_glbens_adate/ges" -export rrfs_3denvar_glbens_ens="$casesdir/regional/rrfs/$rrfs_3denvar_glbens_adate/ens" +export rrfs_enkf_diag="$casesdir/regional/rrfs/$rrfs_enkf_adate/diag" +export rrfs_enkf_ges="$casesdir/regional/rrfs/$rrfs_enkf_adate/ens" +export rrfs_3denvar_rdasens_obs="$casesdir/regional/rrfs/$rrfs_3denvar_rdasens_adate/obs" +export rrfs_3denvar_rdasens_ges="$casesdir/regional/rrfs/$rrfs_3denvar_rdasens_adate/ges" +export rrfs_3denvar_rdasens_ens="$casesdir/regional/rrfs/$rrfs_3denvar_rdasens_adate/ens" export hafs_envar_obs="$casesdir/regional/hafs_RTdata/$hafs_envar_adate/obs" export hafs_envar_ges="$casesdir/regional/hafs_RTdata/$hafs_envar_adate/ges" export hafs_envar_ens="$casesdir/regional/hafs_RTdata/$hafs_envar_adate/ens" diff --git a/regression/rrfs_3denvar_glbens.sh b/regression/rrfs_3denvar_rdasens.sh similarity index 55% rename from regression/rrfs_3denvar_glbens.sh rename to regression/rrfs_3denvar_rdasens.sh index af5da51172..b00047ec65 100755 --- a/regression/rrfs_3denvar_glbens.sh +++ b/regression/rrfs_3denvar_rdasens.sh @@ -21,7 +21,7 @@ exp=$jobname # #----------------------------------------------------------------------- # -adate=${rrfs_3denvar_glbens_adate} +adate=${rrfs_3denvar_rdasens_adate} YYYYMMDDHH=$(date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2}") JJJ=$(date +%j -d "${adate:0:8} ${adate:8:2}") @@ -31,9 +31,6 @@ DD=${YYYYMMDDHH:6:2} HH=${YYYYMMDDHH:8:2} YYYYMMDD=${YYYYMMDDHH:0:8} # -#MESO_USELIST_FN=$(date +%Y-%m-%d -d "${START_DATE} -1 day")_meso_uselist.txt -#AIR_REJECT_FN=$(date +%Y%m%d -d "${START_DATE} -1 day")_rejects.txt - # #----------------------------------------------------------------------- # @@ -42,17 +39,16 @@ YYYYMMDD=${YYYYMMDDHH:0:8} # #----------------------------------------------------------------------- # Set runtime and save directories -tmpdir=$tmpdir/tmpreg_rrfs_3denvar_glbens/${exp} -savdir=$savdir/outreg_rrfs_3denvar_glbens/${exp} +tmpdir=$tmpdir/tmpreg_rrfs_3denvar_rdasens/${exp} +savdir=$savdir/outreg_rrfs_3denvar_rdasens/${exp} # Set up $tmpdir rm -rf $tmpdir mkdir -p $tmpdir -chgrp rstprod $tmpdir chmod 750 $tmpdir cd $tmpdir -bkpath=${rrfs_3denvar_glbens_ges} +bkpath=${rrfs_3denvar_rdasens_ges} # decide background type if [ -r "${bkpath}/fv3_coupler.res" ]; then BKTYPE=0 # warm start @@ -68,19 +64,59 @@ fixcrtm=${fixcrtm:-$CRTM_FIX} # #--------------------------------------------------------------------- # -echo "regional_ensemble_option is ",${regional_ensemble_option:-1} - +regional_ensemble_option=${regional_ensemble_option:-5} +NUM_ENS_MEMBERS=5 +echo "regional_ensemble_option is ",${regional_ensemble_option} +echo "regional_ensemble number is ",${NUM_ENS_MEMBERS} echo "$VERBOSE" "fixgsi is $fixgsi" -echo "$VERBOSE" "fixgriddir is $fixgriddir" echo "$VERBOSE" "default bkpath is $bkpath" echo "$VERBOSE" "background type is is $BKTYPE" ifhyb=.false. -if [[ ${regional_ensemble_option:-1} -eq 1 ]]; then #using GDAS +# +# Check if we have enough FV3-LAM ensembles when regional_ensemble_option=5 +# +if [[ ${regional_ensemble_option} -eq 5 ]]; then + + imem=1 + ifound=0 + while [[ $imem -le ${NUM_ENS_MEMBERS} ]];do + memcharv0=$( printf "%03d" $imem ) + memchar=mem$( printf "%04d" $imem ) + + restart_prefix="${YYYYMMDD}.${HH}0000." + slash_ensmem_subdir=$memchar + bkpathmem=${rrfs_3denvar_rdasens_ens}/${slash_ensmem_subdir}/fcst_fv3lam/RESTART + + dynvarfile=${bkpathmem}/${restart_prefix}fv_core.res.tile1.nc + tracerfile=${bkpathmem}/${restart_prefix}fv_tracer.res.tile1.nc + phyvarfile=${bkpathmem}/${restart_prefix}phy_data.nc + if [ -r "${dynvarfile}" ] && [ -r "${tracerfile}" ] && [ -r "${phyvarfile}" ] ; then + ln -snf ${bkpathmem}/${restart_prefix}fv_core.res.tile1.nc fv3SAR01_ens_mem${memcharv0}-fv3_dynvars + ln -snf ${bkpathmem}/${restart_prefix}fv_tracer.res.tile1.nc fv3SAR01_ens_mem${memcharv0}-fv3_tracer + ln -snf ${bkpathmem}/${restart_prefix}phy_data.nc fv3SAR01_ens_mem${memcharv0}-fv3_phyvars + (( ifound += 1 )) + else + print_info_msg "WARNING: Cannot find ensemble files: ${dynvarfile} ${tracerfile} ${phyvarfile} " + fi + (( imem += 1 )) + done + + ifhyb=.true. + nummem=${NUM_ENS_MEMBERS} + if [[ $ifound -ne ${NUM_ENS_MEMBERS} ]] || [[ ${BKTYPE} -eq 1 ]]; then + print_info_msg "Not enough FV3_LAM ensembles, will fall to GDAS" + regional_ensemble_option=1 + l_both_fv3sar_gfs_ens=.false. + ifhyb=.false. + fi +fi +# +if [[ ${regional_ensemble_option} -eq 1 ]]; then #using GDAS #----------------------------------------------------------------------- # Make a list of the latest GFS EnKF ensemble #----------------------------------------------------------------------- - ls ${rrfs_3denvar_glbens_ens}/*gdas.t??z.atmf009.mem0??.nc >> filelist03 + ls ${rrfs_3denvar_rdasens_ens}/*gdas.t??z.atmf009.mem0??.nc >> filelist03 nummem=$(more filelist03 | wc -l) nummem=$((nummem - 3 )) @@ -109,12 +145,13 @@ ln -snf ${bkpath}/fv3_akbk fv3_akbk ln -snf ${bkpath}/fv3_grid_spec fv3_grid_spec if [ ${BKTYPE} -eq 1 ]; then # cold start uses background from INPUT - ln -snf ${bkpath}/phis.nc phis.nc - ncks -A -v phis phis.nc ${bkpath}/gfs_data.tile7.halo0.nc - ln_vrfy -snf ${bkpath}/sfc_data.tile7.halo0.nc fv3_sfcdata - ln_vrfy -snf ${bkpath}/gfs_data.tile7.halo0.nc fv3_dynvars - ln_vrfy -s fv3_dynvars fv3_tracer + cp ${bkpath}/sfc_data.tile7.halo0.nc fv3_sfcdata + cp ${bkpath}/gfs_data.tile7.halo0.nc fv3_dynvars + ln_vrfy -s fv3_dynvars fv3_tracer + + ln -snf ${bkpath}/phis.nc phis.nc + ncks -A -v phis phis.nc fv3_dynvars fv3lam_bg_type=1 else # cycle uses background from restart @@ -133,7 +170,6 @@ sed -i "s/mm/${MM}/" coupler.res sed -i "s/dd/${DD}/" coupler.res sed -i "s/hh/${HH}/" coupler.res - # #----------------------------------------------------------------------- # @@ -143,7 +179,7 @@ sed -i "s/hh/${HH}/" coupler.res #----------------------------------------------------------------------- obs_source=rap obsfileprefix=${YYYYMMDDHH}.${obs_source} - obspath_tmp=${rrfs_3denvar_glbens_obs} + obspath_tmp=${rrfs_3denvar_rdasens_obs} obs_files_source[0]=${obspath_tmp}/${obsfileprefix}.t${HH}${SUBH}z.prepbufr.tm00 obs_files_target[0]=prepbufr @@ -156,6 +192,73 @@ sed -i "s/hh/${HH}/" coupler.res obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}${SUBH}z.nexrad.tm00.bufr_d obs_files_target[${obs_number}]=l2rwbufr + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${YYYYMMDDHH}.Gridded_ref.nc + obs_files_target[${obs_number}]=dbzobs.nc + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${YYYYMMDDHH}.fedobs.nc + obs_files_target[${obs_number}]=fedobs.nc + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.1bamua.tm00.bufr_d + obs_files_target[${obs_number}]=amsuabufr + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.esamua.tm00.bufr_d + obs_files_target[${obs_number}]=amsuabufrears + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.1bmhs.tm00.bufr_d + obs_files_target[${obs_number}]=mhsbufr + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.esmhs.tm00.bufr_d + obs_files_target[${obs_number}]=mhsbufrears + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.atms.tm00.bufr_d + obs_files_target[${obs_number}]=atmsbufr + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.esatms.tm00.bufr_d + obs_files_target[${obs_number}]=atmsbufrears + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.atmsdb.tm00.bufr_d + obs_files_target[${obs_number}]=atmsbufr_db + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.crisf4.tm00.bufr_d + obs_files_target[${obs_number}]=crisfsbufr + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.crsfdb.tm00.bufr_d + obs_files_target[${obs_number}]=crisfsbufr_db + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.mtiasi.tm00.bufr_d + obs_files_target[${obs_number}]=iasibufr + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.esiasi.tm00.bufr_d + obs_files_target[${obs_number}]=iasibufrears + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.iasidb.tm00.bufr_d + obs_files_target[${obs_number}]=iasibufr_db + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.gsrcsr.tm00.bufr_d + obs_files_target[${obs_number}]=abibufr + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.ssmisu.tm00.bufr_d + obs_files_target[${obs_number}]=ssmisbufr + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.sevcsr.tm00.bufr_d + obs_files_target[${obs_number}]=sevcsr obs_number=${#obs_files_source[@]} for (( i=0; i<${obs_number}; i++ )); @@ -176,7 +279,7 @@ done # #----------------------------------------------------------------------- -ANAVINFO=${fixgsi}/anavinfo.rrfs +ANAVINFO=${fixgsi}/anavinfo.rrfs_conv_dbz CONVINFO=${fixgsi}/convinfo.rrfs HYBENSINFO=${fixgsi}/hybens_info.rrfs OBERROR=${fixgsi}/errtable.rrfs @@ -198,9 +301,31 @@ cp $OBERROR errtable cp $ATMS_BEAMWIDTH atms_beamwidth.txt cp ${HYBENSINFO} hybens_info -cp ${bkpath}/gsd_sfcobs_provider.txt gsd_sfcobs_provider.txt -cp ${bkpath}/current_bad_aircraft current_bad_aircraft -cp ${bpath}/gsd_sfcobs_uselist.txt gsd_sfcobs_uselist.txt +cp ${obspath_tmp}/gsd_sfcobs_provider.txt gsd_sfcobs_provider.txt +cp ${obspath_tmp}/current_bad_aircraft current_bad_aircraft +cp ${obspath_tmp}/gsd_sfcobs_uselist.txt gsd_sfcobs_uselist.txt + +#----------------------------------------------------------------------- +# +# cycling radiance bias corretion files +# +#----------------------------------------------------------------------- + +cp $obspath_tmp/rrfs.prod.${YYYYMMDDHH}_satbias_pc ./satbias_pc +cp $obspath_tmp/rrfs.prod.${YYYYMMDDHH}_satbias ./satbias_in +cp $obspath_tmp/rrfs.prod.${YYYYMMDDHH}_radstat ./radstat.rrfs + +if [ -r radstat.rrfs ]; then + listdiag=$(tar xvf radstat.rrfs | cut -d' ' -f2 | grep _ges) + for type in $listdiag; do + diag_file=$(echo $type | cut -d',' -f1) + fname=$(echo $diag_file | cut -d'.' -f1) + date=$(echo $diag_file | cut -d'.' -f2) + gunzip $diag_file + fnameanl=$(echo $fname|sed 's/_ges//g') + mv $fname.$date* $fnameanl + done +fi #----------------------------------------------------------------------- # @@ -261,9 +386,9 @@ HYBRID_ENSEMBLE='ensemble_path="",' SINGLEOB="$SINGLEOB_update" if [ "$debug" = ".false." ]; then - . $scripts/regression_namelists.sh rrfs_3denvar_glbens + . $scripts/regression_namelists.sh rrfs_3denvar_rdasens else - . $scripts/regression_namelists_db.sh rrfs_3denvar_glbens + . $scripts/regression_namelists_db.sh rrfs_3denvar_rdasens fi cat << EOF > gsiparm.anl @@ -279,10 +404,6 @@ elif [[ $exp == *"contrl"* ]]; then $ncp $gsiexec_contrl ./gsi.x fi -#cp $fv3_netcdf_ges/nam.t06z.satbias_pc.tm04 ./satbias_pc -#cp $fv3_netcdf_ges/nam.t06z.satbias.tm04 ./satbias_in -#cp $fv3_netcdf_ges/nam.t06z.radstat.tm04 ./radstat.gdas - # Run GSI cd $tmpdir echo "run gsi now" diff --git a/regression/rrfs_enkf_conv.sh b/regression/rrfs_enkf_conv.sh new file mode 100755 index 0000000000..21f7aacee2 --- /dev/null +++ b/regression/rrfs_enkf_conv.sh @@ -0,0 +1,223 @@ + +set -x + +# Set variables used in script +# CLEAN up $tmpdir when finished (YES=remove, NO=leave alone) +# ncp is cp replacement, currently keep as /bin/cp + +UNCOMPRESS=gunzip +CLEAN=NO +ncp=/bin/cp +# +# Set experiment name +# +exp=$jobname + +#----------------------------------------------------------------------- +# +# Extract from ADATE the starting year, month, day, and hour of the +# forecast. These are needed below for various operations. +# +#----------------------------------------------------------------------- +# + +adate=${rrfs_enkf_adate} +YYYYMMDDHH=$(date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2}") +JJJ=$(date +%j -d "${adate:0:8} ${adate:8:2}") + +YYYY=${YYYYMMDDHH:0:4} +MM=${YYYYMMDDHH:4:2} +DD=${YYYYMMDDHH:6:2} +HH=${YYYYMMDDHH:8:2} +YYYYMMDD=${YYYYMMDDHH:0:8} + +# +#----------------------------------------------------------------------- +# +# go to working directory and save directory. +# define fix and background path +# +#----------------------------------------------------------------------- +# Set runtime and save directories +tmpdir=$tmpdir/tmpreg_rrfs_enkf_conv/${exp} +savdir=$savdir/outreg_rrfs_enkf_conv/${exp} + +# Set up $tmpdir +rm -rf $tmpdir +mkdir -p $tmpdir +chmod 750 $tmpdir +cd $tmpdir + +fixcrtm=${fixcrtm:-$CRTM_FIX} + +cp ${rrfs_3denvar_rdasens_ges}/fv3_coupler.res coupler.res +cp ${rrfs_3denvar_rdasens_ges}/fv3_akbk fv3sar_tile1_akbk.nc +cp ${rrfs_3denvar_rdasens_ges}/fv3_grid_spec fv3sar_tile1_grid_spec.nc + +# +#----------------------------------------------------------------------- +# +# Loop through the members, link the background and copy over +# observer output (diag*ges*) files to the running directory +# +#----------------------------------------------------------------------- +# +ob_type="conv" +DO_ENS_RADDA="false" +nens=${nens:-5} +netcdf_diag=".true." +for imem in $(seq 1 $nens) ensmean; do + + if [ "${imem}" = "ensmean" ]; then + memchar="ensmean" + memcharv0="ensmean" + restart_prefix="" + else + memchar="mem"$(printf %04i $imem) + memcharv0="mem"$(printf %03i $imem) + restart_prefix="${YYYYMMDD}.${HH}0000." + fi + slash_ensmem_subdir=$memchar + bkpath=${rrfs_enkf_ges}/${slash_ensmem_subdir}/fcst_fv3lam/RESTART + observer_nwges_dir="${rrfs_enkf_diag}/${slash_ensmem_subdir}/observer_gsi" + + cp ${bkpath}/${restart_prefix}fv_core.res.tile1.nc fv3sar_tile1_${memcharv0}_dynvars + cp ${bkpath}/${restart_prefix}fv_tracer.res.tile1.nc fv3sar_tile1_${memcharv0}_tracer + cp ${bkpath}/${restart_prefix}sfc_data.nc fv3sar_tile1_${memcharv0}_sfcdata + cp ${bkpath}/${restart_prefix}phy_data.nc fv3sar_tile1_${memcharv0}_phyvar + + # +#----------------------------------------------------------------------- +# +# Copy observer outputs (diag*ges*) to the working directory +# +#----------------------------------------------------------------------- +# + if [ "${netcdf_diag}" = ".true." ] ; then + # Note, listall_rad is copied from exrrfs_run_analysis.sh + listall_rad="hirs2_n14 msu_n14 sndr_g08 sndr_g11 sndr_g11 sndr_g12 sndr_g13 sndr_g08_prep sndr_g11_prep sndr_g12_prep sndr_g13_prep sndrd1_g11 sndrd2_g11 sndrd3_g11 sndrd4_g11 sndrd1_g15 sndrd2_g15 sndrd3_g15 sndrd4_g15 sndrd1_g13 sndrd2_g13 sndrd3_g13 sndrd4_g13 hirs3_n15 hirs3_n16 hirs3_n17 amsua_n15 amsua_n16 amsua_n17 amsua_n18 amsua_n19 amsua_metop-a amsua_metop-b amsua_metop-c amsub_n15 amsub_n16 amsub_n17 hsb_aqua airs_aqua amsua_aqua imgr_g08 imgr_g11 imgr_g12 pcp_ssmi_dmsp pcp_tmi_trmm conv sbuv2_n16 sbuv2_n17 sbuv2_n18 omi_aura ssmi_f13 ssmi_f14 ssmi_f15 hirs4_n18 hirs4_metop-a mhs_n18 mhs_n19 mhs_metop-a mhs_metop-b mhs_metop-c amsre_low_aqua amsre_mid_aqua amsre_hig_aqua ssmis_las_f16 ssmis_uas_f16 ssmis_img_f16 ssmis_env_f16 iasi_metop-a iasi_metop-b iasi_metop-c seviri_m08 seviri_m09 seviri_m10 seviri_m11 cris_npp atms_npp ssmis_f17 cris-fsr_npp cris-fsr_n20 atms_n20 abi_g16" + + + if [ "${ob_type}" = "conv" ]; then + list_ob_type="conv_ps conv_q conv_t conv_uv conv_pw conv_rw conv_sst" + + if [ "${DO_ENS_RADDA}" = "TRUE" ]; then + list_ob_type="$list_ob_type $listall_rad" + fi + fi + + if [ "${ob_type}" = "radardbz" ]; then + if [ ${DO_GLM_FED_DA} == "TRUE" ]; then + list_ob_type="conv_dbz conv_fed" + else + list_ob_type="conv_dbz" + fi + fi + for sub_ob_type in ${list_ob_type} ; do + diagfile0=${observer_nwges_dir}/diag_${sub_ob_type}_ges.${YYYYMMDDHH}.nc4.gz + if [ -s $diagfile0 ]; then + diagfile=$(basename $diagfile0) + cp $diagfile0 $diagfile + gzip -d $diagfile && rm -f $diagfile + ncfile0=$(basename -s .gz $diagfile) + ncfile=$(basename -s .nc4 $ncfile0) + mv $ncfile0 ${ncfile}_${memcharv0}.nc4 + fi + done + else + for diagfile0 in $(ls ${observer_nwges_dir}/diag*${ob_type}*ges* ) ; do + if [ -s $diagfile0 ]; then + diagfile=$(basename $diagfile0) + cp $diagfile0 diag_conv_ges.$memcharv0 + fi + done + fi +done + +# +#----------------------------------------------------------------------- +# +# Set GSI fix files +# +#---------------------------------------------------------------------- +# +found_ob_type=0 + +CONVINFO=${fixgsi}/convinfo.rrfs + +if [ "${ob_type}" = "conv" ]; then + ANAVINFO=${fixgsi}/anavinfo.rrfs + found_ob_type=1 +fi +if [ "${ob_type}" = "radardbz" ]; then + ANAVINFO=${fixgsi}/anavinfo.enkf.rrfs_dbz + CORRLENGTH="18" + LNSIGCUTOFF="0.5" + found_ob_type=1 +fi +if [ ${found_ob_type} == 0 ]; then + err_exit "Unknown observation type: ${ob_type}" +fi +stdout_name=stdout.${ob_type} +stderr_name=stderr.${ob_type} + +SATINFO=${fixgsi}/global_satinfo.txt +OZINFO=${fixgsi}/global_ozinfo.txt + +cp ${ANAVINFO} anavinfo +cp $SATINFO satinfo +cp $CONVINFO convinfo +cp $OZINFO ozinfo + +# +#----------------------------------------------------------------------- +# +# Get nlons (NX_RES), nlats (NY_RES) and nlevs +# +#----------------------------------------------------------------------- +# +NX_RES=$(ncdump -h fv3sar_tile1_grid_spec.nc | grep "grid_xt =" | cut -f3 -d" " ) +NY_RES=$(ncdump -h fv3sar_tile1_grid_spec.nc | grep "grid_yt =" | cut -f3 -d" " ) +nlevs=$(ncdump -h fv3sar_tile1_mem001_tracer | grep "zaxis_1 =" | cut -f3 -d" " ) +# +#---------------------------------------------------------------------- +# +# Set namelist parameters for EnKF +# +#---------------------------------------------------------------------- +# +EnKFTracerVars=${EnKFTracerVar:-"sphum,o3mr"} +ldo_enscalc_option=${ldo_enscalc_option:-0} + +# Make gsi namelist + +. $scripts/regression_namelists.sh rrfs_enkf_conv + +# + +cat << EOF > enkf.nml + +$gsi_namelist + +EOF + +# +#----------------------------------------------------------------------- +# +# Run the EnKF +# +#----------------------------------------------------------------------- +# +# Copy executable and fixed files to $tmpdir +if [[ $exp == *"updat"* ]]; then + $ncp $enkfexec_updat ./enkf.x +elif [[ $exp == *"contrl"* ]]; then + $ncp $enkfexec_contrl ./enkf.x +fi + +# Run enkf +cd $tmpdir +echo "run rrfs enkf now" +eval "$APRUN $tmpdir/enkf.x < enkf.nml > stdout 2>&1" +rc=$? +exit $rc From b37b7d73270bed86a1c80fd2013982948ece4955 Mon Sep 17 00:00:00 2001 From: David Huber <69919478+DavidHuber-NOAA@users.noreply.github.com> Date: Thu, 27 Jun 2024 08:59:16 -0400 Subject: [PATCH 092/109] Update Jet directories (#763) --- regression/regression_var.sh | 10 +++++----- ush/detect_machine.sh | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/regression/regression_var.sh b/regression/regression_var.sh index 3e5487009d..401c7e0022 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -32,7 +32,7 @@ fi # Determine the machine if [[ -d /scratch1 ]]; then # Hera export machine="Hera" -elif [[ -d /mnt/lfs4 || -d /jetmon || -d /mnt/lfs1 ]]; then # Jet +elif [[ -d /mnt/lfs4 || -d /jetmon || -d /mnt/lfs5 ]]; then # Jet export machine="Jet" elif [[ -d /discover ]]; then # NCCS Discover export machine="Discover" @@ -137,16 +137,16 @@ case $machine in ;; Jet) - export noscrub=/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/noscrub - export ptmp=/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/ptmp - export casesdir="/lfs1/NESDIS/nesdis-rdo2/David.Huber/save/CASES/regtest" + export noscrub=/lfs5/NESDIS/nesdis-rdo2/$LOGNAME/noscrub + export ptmp=/lfs5/NESDIS/nesdis-rdo2/$LOGNAME/ptmp + export casesdir="/lfs5/NESDIS/nesdis-rdo2/David.Huber/save/CASES/regtest" export check_resource="no" export accnt="nesdis-rdo2" export group="global" export queue="batch" if [[ "$cmaketest" = "false" ]]; then - export basedir="/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/save/git/gsi" + export basedir="/lfs5/NESDIS/nesdis-rdo2/$LOGNAME/save/git/gsi" fi # On Jet, there are no scrubbers to remove old contents from stmp* directories. diff --git a/ush/detect_machine.sh b/ush/detect_machine.sh index 683ee0db7f..6562b183b6 100755 --- a/ush/detect_machine.sh +++ b/ush/detect_machine.sh @@ -67,7 +67,7 @@ if [[ -d /lfs/h3 ]]; then elif [[ -d /lfs/h1 && ! -d /lfs/h3 ]]; then # We are on NOAA TDS Acorn MACHINE_ID=acorn -elif [[ -d /mnt/lfs1 ]]; then +elif [[ -d /mnt/lfs5 ]]; then # We are on NOAA Jet MACHINE_ID=jet elif [[ -d /scratch1 ]]; then From 529bb796bea0e490f186729cd168a91c034bb12d Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Fri, 28 Jun 2024 16:10:41 -0400 Subject: [PATCH 093/109] Updates to build and run on Orion Rocky 9 (#764) note; while this commit enables gsi.x and enkf.x to be built on Orion Rocky 9, both executables run 2x slower on Orion Rocky 9 than Orion Centos 7 --- modulefiles/gsi_orion.intel.lua | 9 +++++---- regression/regression_var.sh | 11 +++++++---- ush/detect_machine.sh | 4 ++-- ush/sub_orion | 8 +++++--- 4 files changed, 19 insertions(+), 13 deletions(-) diff --git a/modulefiles/gsi_orion.intel.lua b/modulefiles/gsi_orion.intel.lua index 03ea22018d..d05bda5b2e 100644 --- a/modulefiles/gsi_orion.intel.lua +++ b/modulefiles/gsi_orion.intel.lua @@ -1,11 +1,11 @@ help([[ ]]) -prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/spack-stack/orion/spack-stack-1.6.0/envs/gsi-addon-env/install/modulefiles/Core") +prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/spack-stack/orion/spack-stack-1.6.0/envs/gsi-addon-env-rocky9/install/modulefiles/Core") -local stack_python_ver=os.getenv("python_ver") or "3.11.6" -local stack_intel_ver=os.getenv("stack_intel_ver") or "2022.0.2" -local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.1" +local stack_python_ver=os.getenv("stack_python_ver") or "3.11.6" +local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.9.0" +local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.9.0" local cmake_ver=os.getenv("cmake_ver") or "3.23.1" local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1" @@ -16,6 +16,7 @@ load(pathJoin("cmake", cmake_ver)) load("gsi_common") load(pathJoin("prod_util", prod_util_ver)) +load("intel-oneapi-mkl/2022.2.1") pushenv("CFLAGS", "-xHOST") pushenv("FFLAGS", "-xHOST") diff --git a/regression/regression_var.sh b/regression/regression_var.sh index 401c7e0022..4a2bc85874 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -40,10 +40,13 @@ elif [[ -d /ncrc ]]; then # Gaea export machine="Gaea" elif [[ -d /data/prod ]]; then # S4 export machine="S4" -elif [[ -d /work && $(hostname) =~ "Orion" ]]; then # Orion - export machine="Orion" -elif [[ -d /work && $(hostname) =~ "hercules" ]]; then # Hercules - export machine="Hercules" +elif [[ -d /work ]]; then # Orion or Hercules + mount=$(findmnt -n -o SOURCE /home) + if [[ ${mount} =~ "hercules" ]]; then + export machine="Hercules" + else + export machine="Orion" + fi elif [[ -d /lfs/h2 ]]; then # wcoss2 export machine="wcoss2" fi diff --git a/ush/detect_machine.sh b/ush/detect_machine.sh index 6562b183b6..0beb937f7e 100755 --- a/ush/detect_machine.sh +++ b/ush/detect_machine.sh @@ -75,8 +75,8 @@ elif [[ -d /scratch1 ]]; then MACHINE_ID=hera elif [[ -d /work ]]; then # We are on MSU Orion or Hercules - if [[ -d /apps/other ]]; then - # We are on Hercules + mount=$(findmnt -n -o SOURCE /home) + if [[ ${mount} =~ "hercules" ]]; then MACHINE_ID=hercules else MACHINE_ID=orion diff --git a/ush/sub_orion b/ush/sub_orion index b810576379..371c30e321 100755 --- a/ush/sub_orion +++ b/ush/sub_orion @@ -115,23 +115,25 @@ echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --exclusive" >> $cfile echo "#SBATCH --account=$accnt" >> $cfile echo "" >>$cfile +echo "set -x" >> $cfile echo "export ntasks=$(( $nodes * $procs ))" >> $cfile echo "export ppn=$procs" >> $cfile echo "export threads=$threads" >> $cfile echo "export OMP_NUM_THREADS=$threads" >> $cfile -##echo "export OMP_STACKSIZE=2048M" >> $cfile echo "ulimit -s unlimited" >> $cfile echo "" >>$cfile echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile echo "" >>$cfile -echo ". /apps/lmod/lmod/init/sh" >> $cfile +echo ". /apps/other/lmod/lmod/init/sh" >> $cfile echo "module purge" >> $cfile echo "module use $modulefiles" >> $cfile echo "module load gsi_orion.intel" >> $cfile echo "module list" >> $cfile -echo "" >> $cfile +#TODO reenable I_MPI_EXTRA_FILESYSTEM once regional ctests can properly handle parallel I/O on Orion +echo "unset I_MPI_EXTRA_FILESYSTEM" >> $cfile + cat $exec >> $cfile if [[ $nosub = YES ]];then From 2745c6533b34db9ca72800d061a8c86fc898fb6d Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Wed, 31 Jul 2024 16:28:02 -0500 Subject: [PATCH 094/109] Add observer script --- src/gsi/read_gps.f90 | 13 - src/gsi/read_obs.F90 | 9 - src/gsi/setupbend.f90 | 3 - ush/run_observer/gsi_observer.sh | 523 ++++++++++++++++++++++++ ush/run_observer/iodaconv.sh | 68 +++ ush/run_observer/submit_gsi_observer.sh | 54 +++ 6 files changed, 645 insertions(+), 25 deletions(-) create mode 100755 ush/run_observer/gsi_observer.sh create mode 100755 ush/run_observer/iodaconv.sh create mode 100755 ush/run_observer/submit_gsi_observer.sh diff --git a/src/gsi/read_gps.f90 b/src/gsi/read_gps.f90 index 62eeef38eb..02012cb5f6 100644 --- a/src/gsi/read_gps.f90 +++ b/src/gsi/read_gps.f90 @@ -232,7 +232,6 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & pcc=bfr1ahdr(6) ! profile per cent confidence roc=bfr1ahdr(7) ! Earth local radius of curvature said=bfr1ahdr(8) ! Satellite identifier - print *,' NICKE SAID2: ', said ptid=bfr1ahdr(9) ! Platform transmitter ID number geoid=bfr1ahdr(10) ! Geoid undulation sat_constid=bfr1ahdr(11) ! Satellite classification @@ -243,22 +242,13 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & ! Locate satellite id in convinfo file ikx = 0 find_loop: do i=1,ngpsro_type - print *, 'NICKE find_loop A, ', said if ( (trim(sis)==trim(gpsro_ctype(i))) .and. (said == gpsro_itype(i)) ) then ikx=gpsro_ikx(i) igpsro_type = i - print *, 'NICKE SAID,ikx,c/itype', said, ikx, gpsro_ctype(i), & - gpsro_itype exit find_loop endif end do find_loop if (ikx==0) then - if(said == 803) then - print *,'NICKE 803 cycle read_loop' - endif - if(said /= 803) then - print *,'NICKE NOT 803 cycle read_loop' - endif cycle read_loop endif @@ -281,9 +271,6 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & endif ! Check profile quality flags - if (said == 803) then - print *, "NICKE SAID 803" - endif if ( ((said > 739).and.(said < 746)).or.(said == 820).or.(said == 786).or. & ((said > 749).and.(said < 756)).or.(said == 825).or.(said == 44) .or. & (said == 265).or.(said == 266).or.(said == 267).or.(said == 268).or. & diff --git a/src/gsi/read_obs.F90 b/src/gsi/read_obs.F90 index 8d696cc18d..f89b42e155 100644 --- a/src/gsi/read_obs.F90 +++ b/src/gsi/read_obs.F90 @@ -203,7 +203,6 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) call datelen(10) call readmg(lnbufr,subset,idate,iret) if(iret == 0)then - print *, "NICKE IRET ", trim(filename), trim(dtype) ! Extract date and check for consistency with analysis date if (idateiadateend) then if(offtime_data) then @@ -221,7 +220,6 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) write(6,*)'***read_obs_check*** iret/=0 for reading date for ',trim(filename),dtype,jsatid,iret lexist=.false. end if - print *, 'NICKE JSATID', jsatid if(lexist)then kidsat=0 if(jsatid == 'metop-a')then @@ -337,16 +335,12 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) else if ( jsatid == 'meghat' ) then kidsat = 440 else - print *, 'NICKE jsatid not avail so kidsat =0' kidsat = 0 end if - print *, 'NICKE kidsat: ', kidsat - call closbf(lnbufr) close(lnbufr) open(lnbufr,file=trim(filename),form='unformatted',status ='unknown') - print *,' NICKE FILENAMEEE ', filename call openbf(lnbufr,'IN',lnbufr) call datelen(10) @@ -409,9 +403,6 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) (said == 723).or. (said == 265).or. (said == 266) .or. & (said == 267).or. (said == 268).or. (said == 269) .or. & (said == 803)) then - if(said == 803) then - print *, 'NICKE 803' - end if lexist=.true. exit gpsloop end if diff --git a/src/gsi/setupbend.f90 b/src/gsi/setupbend.f90 index de8b105e6d..074bc7e002 100644 --- a/src/gsi/setupbend.f90 +++ b/src/gsi/setupbend.f90 @@ -314,7 +314,6 @@ subroutine setupbend(obsLL,odiagLL, & !268 => PlanetiQ GNOMES-B !269 => Spire Lemur 3U CubeSat !66 => Sentinel-6 - print *, "NICKE setupbend" ! Check to see if required guess fields are available call check_vars_(proceed) if(.not.proceed) return ! not all vars available, simply return @@ -600,8 +599,6 @@ subroutine setupbend(obsLL,odiagLL, & ! Save some diagnostic information ! occultation identification satellite_id = data(isatid,i) ! receiver occ id - print *, "NICKE ALL SATELLITE IDs: " - print *, satellite_id transmitter_id = data(iptid,i) ! transmitter occ id write(cdiagbuf(i),'(2(i4.4))') satellite_id,transmitter_id diff --git a/ush/run_observer/gsi_observer.sh b/ush/run_observer/gsi_observer.sh new file mode 100755 index 0000000000..ed338c1be9 --- /dev/null +++ b/ush/run_observer/gsi_observer.sh @@ -0,0 +1,523 @@ +#!/bin/bash +#SBATCH -J GSIobserver +#SBATCH -o GSIobserver.o%j +#SBATCH -A da-cpu +#SBATCH -q batch +#SBATCH -p orion +#SBATCH --nodes=25 +#SBATCH --ntasks-per-node=8 +#SBATCH --exclusive +#SBATCH -t 30:00 +# run_gsi_observer.sh +# run GSI observer for a specified +# analysis cycle and subset of observations +# cory.r.martin@noaa.gov +set -x +ulimit -s unlimited + +# source user configuration +source $1 +# adate, GSIDIR, GSIFIX + +## resolution things for GSI +export JCAP=1534 +export JCAP_B=1534 +export LEVS=127 +export LONA=3072 +export LATA=1536 +export DELTIM=120 +export NLON=3072 +export NLAT=1538 + +## load modules for GSI +#set +x +MACHINE_ID=orion +source $GSIDIR/ush/module-setup.sh +module use $GSIDIR/modulefiles +module load gsi_$MACHINE_ID.intel +module list +#set -x +set +eu + +## load env vars as needed +export APRUN_GSI='srun --export=ALL' + +## variables for executables +CRMroot=/work2/noaa/da/cmartin/UFO_eval/geovals/ +gsiexec=$GSIDIR/install/bin/gsi.x +nccat=$CRMroot/GSI-ncdiag/build/ncdiag/ncdiag_cat_serial.x +NDATE=${NDATE:-`which ndate`} +ncpc=/bin/cp +ncpl="ln -fs" + +## get analysis/guess date +PDYa=`echo $adate | cut -c1-8` +cyca=`echo $adate | cut -c9-10` +gdate=`$NDATE -06 $adate` +PDYg=`echo $gdate | cut -c1-8` +cycg=`echo $gdate | cut -c9-10` + +## variables for other useful paths +fixgsi=$GSIFIX +ushgsi=$GSIDIR/ush +crtm_coeffs=./crtm_coeffs/ +datobs=$dumpdir/${dump}.$PDYa/$cyca/atmos +datobsnr=$dumpdir/${dump}nr.$PDYa/$cyca/atmos +datobsur=$dumpdir/${dump}ur.$PDYa/$cyca/atmos +datges=$gesroot/${dump}.$PDYg/$cycg/model_data/atmos/history/ +datbias=$gesroot/${dump}.$PDYg/$cycg/analysis/atmos/ +prefix_obs=${dump}.t${cyca}z +prefix_ges=${dump}.t${cycg}z +suffix=tm00.bufr_d +# gps DO-1 obs +gpsobs=/work/noaa/da/Cory.R.Martin/noscrub/UFO_eval/GNSSRO_DO1/$PDYa$cyca/${dump}/gpsrobufr + +# forcing it to be gfsv16 +SUFFIX=".nc" +use_gfs_nemsio=".false." +use_gfs_ncio=".true." + +## paths of fix files +anavinfo=$fixgsi/global_anavinfo.l${LEVS}.txt +berror=$fixgsi/Big_Endian/global_berror.l${LEVS}y${NLAT}.f77 +locinfo=$fixgsi/global_hybens_info.l${LEVS}.txt +satinfo=$fixgsi/global_satinfo.txt +scaninfo=$fixgsi/global_scaninfo.txt +satangl=$fixgsi/global_satangbias.txt +pcpinfo=$fixgsi/global_pcpinfo.txt +ozinfo=$fixgsi/global_ozinfo.txt +convinfo=/work2/noaa/da/nesposito/GSI_fixdir/global_convinfo.txt +vqcdat=$fixgsi/vqctp001.dat +insituinfo=$fixgsi/global_insituinfo.txt +errtable=$fixgsi/prepobs_errtable.global +aeroinfo=$fixgsi/global_aeroinfo.txt +atmsbeaminfo=$fixgsi/atms_beamwidth.txt +cloudyinfo=$fixgsi/cloudy_radiance_info.txt + +CRTM_FIX=/apps/contrib/NCEP/libs/hpc-stack-gfsv16/intel-2018.4/crtm/2.3.0/fix/ + +emiscoef_IRwater=$CRTM_FIX/Nalli.IRwater.EmisCoeff.bin +emiscoef_IRice=$CRTM_FIX/NPOESS.IRice.EmisCoeff.bin +emiscoef_IRland=$CRTM_FIX/NPOESS.IRland.EmisCoeff.bin +emiscoef_IRsnow=$CRTM_FIX/NPOESS.IRsnow.EmisCoeff.bin +emiscoef_VISice=$CRTM_FIX/NPOESS.VISice.EmisCoeff.bin +emiscoef_VISland=$CRTM_FIX/NPOESS.VISland.EmisCoeff.bin +emiscoef_VISsnow=$CRTM_FIX/NPOESS.VISsnow.EmisCoeff.bin +emiscoef_VISwater=$CRTM_FIX/NPOESS.VISwater.EmisCoeff.bin +emiscoef_MWwater=$CRTM_FIX/FASTEM6.MWwater.EmisCoeff.bin +aercoef=$CRTM_FIX/AerosolCoeff.bin +cldcoef=$CRTM_FIX/CloudCoeff.bin + +## rm, make, and cd to working directory +cd $workdir +rm -rf $workdir/gsi +mkdir -p $workdir/gsi +cd $workdir/gsi + +## copy executable and fix files +$ncpc $gsiexec ./gsi.x + +$ncpc $anavinfo ./anavinfo +$ncpc $berror ./berror_stats +$ncpc $locinfo ./hybens_info +$ncpc $satinfo ./satinfo +$ncpc $scaninfo ./scaninfo +$ncpc $pcpinfo ./pcpinfo +$ncpc $ozinfo ./ozinfo +$ncpc $convinfo ./convinfo +$ncpc $vqcdat ./vqctp001.dat +$ncpc $insituinfo ./insituinfo +$ncpc $errtable ./errtable +$ncpc $aeroinfo ./aeroinfo +$ncpc $atmsbeaminfo ./atms_beamwidth.txt +$ncpc $cloudyinfo ./cloudy_radiance_info.txt + +## copy CRTM coefficient files based on entries in satinfo file +mkdir -p ${crtm_coeffs} +for file in `awk '{if($1!~"!"){print $1}}' satinfo | sort | uniq` ;do + $ncpc $CRTM_FIX/${file}.SpcCoeff.bin ${crtm_coeffs} + $ncpc $CRTM_FIX/${file}.TauCoeff.bin ${crtm_coeffs} +done +$ncpc $emiscoef_IRwater ${crtm_coeffs}Nalli.IRwater.EmisCoeff.bin +$ncpc $emiscoef_IRice ${crtm_coeffs}NPOESS.IRice.EmisCoeff.bin +$ncpc $emiscoef_IRsnow ${crtm_coeffs}NPOESS.IRsnow.EmisCoeff.bin +$ncpc $emiscoef_IRland ${crtm_coeffs}NPOESS.IRland.EmisCoeff.bin +$ncpc $emiscoef_VISice ${crtm_coeffs}NPOESS.VISice.EmisCoeff.bin +$ncpc $emiscoef_VISland ${crtm_coeffs}NPOESS.VISland.EmisCoeff.bin +$ncpc $emiscoef_VISsnow ${crtm_coeffs}NPOESS.VISsnow.EmisCoeff.bin +$ncpc $emiscoef_VISwater ${crtm_coeffs}NPOESS.VISwater.EmisCoeff.bin +$ncpc $emiscoef_MWwater ${crtm_coeffs}FASTEM6.MWwater.EmisCoeff.bin +$ncpc $aercoef ${crtm_coeffs}AerosolCoeff.bin +$ncpc $cldcoef ${crtm_coeffs}CloudCoeff.bin + +## copy observations +if [[ "$rstprod" = "true" ]]; then + $ncpl $datobs/${prefix_obs}.prepbufr ./prepbufr + $ncpl $datobs/${prefix_obs}.saphir.${suffix} ./saphirbufr + $ncpl $datobs/${prefix_obs}.prepbufr.acft_profiles ./prepbufr_profl + $ncpl $datobs/${prefix_obs}.nsstbufr ./nsstbufr +else + $ncpl $datobsur/${prefix_obs}.prepbufr ./prepbufr + $ncpl $datobsur/${prefix_obs}.saphir.${suffix} ./saphirbufr +fi +# use GNSSRO obs with DO-1 included from Kristen if available +if [[ -f "$gpsobs" ]]; then + $ncpl $gpsobs ./gpsrobufr +else + $ncpl $datobs/${prefix_obs}.gpsro.${suffix} ./gpsrobufr +fi +$ncpl $datobs/${prefix_obs}.satwnd.${suffix} ./satwndbufr +$ncpl $datobs/${prefix_obs}.spssmi.${suffix} ./ssmirrbufr +$ncpl $datobs/${prefix_obs}.sptrmm.${suffix} ./tmirrbufr +$ncpl $datobs/${prefix_obs}.osbuv8.${suffix} ./sbuvbufr +$ncpl $datobs/${prefix_obs}.goesfv.${suffix} ./gsnd1bufr +$ncpl $datobs/${prefix_obs}.1bamua.${suffix} ./amsuabufr +$ncpl $datobs/${prefix_obs}.1bamub.${suffix} ./amsubbufr +$ncpl $datobs/${prefix_obs}.1bhrs2.${suffix} ./hirs2bufr +$ncpl $datobs/${prefix_obs}.1bhrs3.${suffix} ./hirs3bufr +$ncpl $datobs/${prefix_obs}.1bhrs4.${suffix} ./hirs4bufr +$ncpl $datobs/${prefix_obs}.1bmhs.${suffix} ./mhsbufr +$ncpl $datobs/${prefix_obs}.1bmsu.${suffix} ./msubufr +$ncpl $datobs/${prefix_obs}.airsev.${suffix} ./airsbufr +$ncpl $datobs/${prefix_obs}.sevcsr.${suffix} ./seviribufr +$ncpl $datobs/${prefix_obs}.mtiasi.${suffix} ./iasibufr +$ncpl $datobs/${prefix_obs}.ssmit.${suffix} ./ssmitbufr +$ncpl $datobs/${prefix_obs}.ssmisu.${suffix} ./ssmisbufr +$ncpl $datobs/${prefix_obs}.gome.${suffix} ./gomebufr +$ncpl $datobs/${prefix_obs}.omi.${suffix} ./omibufr +$ncpl $datobs/${prefix_obs}.mls.${suffix} ./mlsbufr +$ncpl $datobs/${prefix_obs}.ompsn8.${suffix} ./ompsnpbufr +$ncpl $datobs/${prefix_obs}.ompst8.${suffix} ./ompstcbufr +$ncpl $datobs/${prefix_obs}.eshrs3.${suffix} ./hirs3bufrears +$ncpl $datobs/${prefix_obs}.esamua.${suffix} ./amsuabufrears +$ncpl $datobs/${prefix_obs}.esamub.${suffix} ./amsubbufrears +$ncpl $datobs/${prefix_obs}.atms.${suffix} ./atmsbufr +$ncpl $datobs/${prefix_obs}.cris.${suffix} ./crisbufr +$ncpl $datobs/${prefix_obs}.crisf4.${suffix} ./crisfsbufr +$ncpl $datobs/${prefix_obs}.syndata.tcvitals.tm00 ./tcvitl +$ncpl $datobs/${prefix_obs}.avcsam.${suffix} ./avhambufr +$ncpl $datobs/${prefix_obs}.avcspm.${suffix} ./avhpmbufr +$ncpl $datobs/${prefix_obs}.gmi1cr.${suffix} ./gmibufr +$ncpl $datobs/${prefix_obs}.esiasi.${suffix} ./iasibufrears +$ncpl $datobs/${prefix_obs}.hrs3db.${suffix} ./hirs3bufr_db +$ncpl $datobs/${prefix_obs}.amuadb.${suffix} ./amsuabufr_db +$ncpl $datobs/${prefix_obs}.amubdb.${suffix} ./amsubbufr_db +$ncpl $datobs/${prefix_obs}.iasidb.${suffix} ./iasibufr_db +$ncpl $datobs/${prefix_obs}.crisdb.${suffix} ./crisbufr_db +$ncpl $datobs/${prefix_obs}.atmsdb.${suffix} ./atmsbufr_db +$ncpl $datobs/${prefix_obs}.escris.${suffix} ./crisbufrears +$ncpl $datobs/${prefix_obs}.esatms.${suffix} ./atmsbufrears + +## copy gsistats +$ncpl $datges/${prefix_obs}.gsistat ./gsistat + +## copy bias correction, atmospheric and surface files +$ncpl $datbias/${prefix_ges}.abias ./satbias_in +$ncpl $datbias/${prefix_ges}.abias_pc ./satbias_pc +$ncpl $datbias/${prefix_ges}.abias_air ./aircftbias_in + +nhr_obsbin=$GSI_background_nhr +if [[ "$GSI_background_nhr" = "1" ]]; then + $ncpl $datges/${prefix_ges}.sfcf003$SUFFIX ./sfcf03 + $ncpl $datges/${prefix_ges}.sfcf004$SUFFIX ./sfcf04 + $ncpl $datges/${prefix_ges}.sfcf005$SUFFIX ./sfcf05 + $ncpl $datges/${prefix_ges}.sfcf006$SUFFIX ./sfcf06 + $ncpl $datges/${prefix_ges}.sfcf007$SUFFIX ./sfcf07 + $ncpl $datges/${prefix_ges}.sfcf008$SUFFIX ./sfcf08 + $ncpl $datges/${prefix_ges}.sfcf009$SUFFIX ./sfcf09 + $ncpl $datges/${prefix_ges}.atmf003$SUFFIX ./sigf03 + $ncpl $datges/${prefix_ges}.atmf004$SUFFIX ./sigf04 + $ncpl $datges/${prefix_ges}.atmf005$SUFFIX ./sigf05 + $ncpl $datges/${prefix_ges}.atmf006$SUFFIX ./sigf06 + $ncpl $datges/${prefix_ges}.atmf007$SUFFIX ./sigf07 + $ncpl $datges/${prefix_ges}.atmf008$SUFFIX ./sigf08 + $ncpl $datges/${prefix_ges}.atmf009$SUFFIX ./sigf09 +elif [[ "$GSI_background_nhr" = "3" ]]; then + $ncpl $datges/${prefix_ges}.sfcf003$SUFFIX ./sfcf03 + $ncpl $datges/${prefix_ges}.atmf003$SUFFIX ./sigf03 + $ncpl $datges/${prefix_ges}.sfcf006$SUFFIX ./sfcf06 + $ncpl $datges/${prefix_ges}.atmf006$SUFFIX ./sigf06 + $ncpl $datges/${prefix_ges}.sfcf009$SUFFIX ./sfcf09 + $ncpl $datges/${prefix_ges}.atmf009$SUFFIX ./sigf09 +else + $ncpl $datges/${prefix_ges}.sfcf006$SUFFIX ./sfcf06 + $ncpl $datges/${prefix_ges}.atmf006$SUFFIX ./sigf06 + nhr_obsbin=6 +fi + +## create GSI namelist +cat > gsiparm.anl << EOF +&SETUP + miter=0, + niter(1)=1,niter(2)=1, + niter_no_qc(1)=50,niter_no_qc(2)=0, + write_diag(1)=.true.,write_diag(2)=.false., + qoption=2, + gencode=0,deltim=94., + factqmin=0.5,factqmax=0.0002, + iguess=-1, + tzr_qc=1, + oneobtest=.false.,retrieval=.false.,l_foto=.false., + use_pbl=.false.,use_compress=.true.,nsig_ext=56,gpstop=55.,commgpstop=45., + thin4d=.true., + use_gfs_nemsio=${use_gfs_nemsio},use_gfs_ncio=${use_gfs_ncio},sfcnst_comb=.true., + use_readin_anl_sfcmask=.false., + lrun_subdirs=.true., + crtm_coeffs_path='./crtm_coeffs/', + newpc4pred=.true.,adp_anglebc=.true.,angord=4,passive_bc=.true.,use_edges=.false., + diag_precon=.true.,step_start=1.e-3,emiss_bc=.true.,nhr_obsbin=${nhr_obsbin:-3}, + cwoption=3,imp_physics=11,lupp=.true.,cnvw_option=.false., ta2tb=.false., + netcdf_diag=.true.,binary_diag=.false., + lobsdiag_forenkf=.false., + write_fv3_incr=.true., + $SETUP +/ +&GRIDOPTS + JCAP_B=$JCAP_B,JCAP=$JCAP,NLAT=$NLAT,NLON=$NLON,nsig=$LEVS, + regional=.false.,nlayers(63)=1,nlayers(64)=1, + $GRIDOPTS +/ +&BKGERR + vs=0.7, + hzscl=1.7,0.8,0.5, + hswgt=0.45,0.3,0.25, + bw=0.0,norsp=4, + bkgv_flowdep=.true.,bkgv_rewgtfct=1.5, + bkgv_write=.false., + cwcoveqqcov=.false., + $BKGVERR +/ +&ANBKGERR + anisotropic=.false., + $ANBKGERR +/ +&JCOPTS + ljcdfi=.false.,alphajc=0.0,ljcpdry=.true.,bamp_jcpdry=5.0e7, + $JCOPTS +/ +&STRONGOPTS + tlnmc_option=2,nstrong=1,nvmodes_keep=8,period_max=6.,period_width=1.5, + $STRONGOPTS +/ +&OBSQC + dfact=0.75,dfact1=3.0,noiqc=.true.,oberrflg=.false.,c_varqc=0.04, + use_poq7=.true.,qc_noirjaco3_pole=.true.,vqc=.false.,nvqc=.true., + aircraft_t_bc=.true.,biaspredt=1.0e5,upd_aircraft=.true.,cleanup_tail=.true., + tcp_width=70.0,tcp_ermax=7.35, + $OBSQC +/ +&OBS_INPUT + dmesh(1)=145.0,dmesh(2)=150.0,dmesh(3)=100.0,time_window_max=3.0, + $OBSINPUT +/ +OBS_INPUT:: +! dfile dtype dplat dsis dval dthin dsfcalc + prepbufr ps null ps 0.0 0 0 + prepbufr t null t 0.0 0 0 + prepbufr_profl t null t 0.0 0 0 + prepbufr q null q 0.0 0 0 + prepbufr_profl q null q 0.0 0 0 + prepbufr pw null pw 0.0 0 0 + prepbufr uv null uv 0.0 0 0 + prepbufr_profl uv null uv 0.0 0 0 + satwndbufr uv null uv 0.0 0 0 +# prepbufr spd null spd 0.0 0 0 +# prepbufr dw null dw 0.0 0 0 +# radarbufr rw null rw 0.0 0 0 +# nsstbufr sst nsst sst 0.0 0 0 + gpsrobufr gps_bnd null gps 0.0 0 0 +# ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0 +# tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0 +# sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 +# sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 +# sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 +# hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 +# hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 0 +# gimgrbufr goes_img g11 imgr_g11 0.0 1 0 +# gimgrbufr goes_img g12 imgr_g12 0.0 1 0 +# airsbufr airs aqua airs_aqua 0.0 1 0 + amsuabufr amsua n15 amsua_n15 0.0 1 0 + amsuabufr amsua n18 amsua_n18 0.0 1 0 + amsuabufr amsua metop-a amsua_metop-a 0.0 1 0 + airsbufr amsua aqua amsua_aqua 0.0 1 0 + amsubbufr amsub n17 amsub_n17 0.0 1 0 + mhsbufr mhs n18 mhs_n18 0.0 1 0 + mhsbufr mhs metop-a mhs_metop-a 0.0 1 0 + ssmitbufr ssmi f15 ssmi_f15 0.0 1 0 +# amsrebufr amsre_low aqua amsre_aqua 0.0 1 0 +# amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0 +# amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0 + ssmisbufr ssmis f16 ssmis_f16 0.0 1 0 + ssmisbufr ssmis f17 ssmis_f17 0.0 1 0 + ssmisbufr ssmis f18 ssmis_f18 0.0 1 0 +# gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 1 0 +# gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 1 0 +# gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 1 0 +# gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 1 0 +# gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 1 0 +# gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 1 0 +# gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 1 0 +# gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 1 0 +# gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 1 0 +# gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 1 0 +# gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 1 0 +# gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 1 0 +# iasibufr iasi metop-a iasi_metop-a 0.0 1 0 +# gomebufr gome metop-a gome_metop-a 0.0 2 0 +# omibufr omi aura omi_aura 0.0 2 0 +# sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 +# hirs4bufr hirs4 n19 hirs4_n19 0.0 1 0 +# amsuabufr amsua n19 amsua_n19 0.0 1 0 +# mhsbufr mhs n19 mhs_n19 0.0 1 0 +# tcvitl tcp null tcp 0.0 0 0 +# seviribufr seviri m08 seviri_m08 0.0 1 0 +# seviribufr seviri m09 seviri_m09 0.0 1 0 +# seviribufr seviri m10 seviri_m10 0.0 1 0 +# seviribufr seviri m11 seviri_m11 0.0 1 0 +# hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 + amsuabufr amsua metop-b amsua_metop-b 0.0 1 0 + mhsbufr mhs metop-b mhs_metop-b 0.0 1 0 + iasibufr iasi metop-b iasi_metop-b 0.0 1 0 +# gomebufr gome metop-b gome_metop-b 0.0 2 0 + atmsbufr atms npp atms_npp 0.0 1 0 + atmsbufr atms n20 atms_n20 0.0 1 0 +# atmsbufr atms n21 atms_n21 0.0 1 0 +# crisbufr cris npp cris_npp 0.0 1 0 +# crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 + crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0 +# crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 1 0 +# gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 1 0 +# gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 1 0 +# gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 1 0 +# gsnd1bufr sndrd4 g14 sndrD4_g14 0.0 1 0 +# gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 1 0 +# gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0 +# gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0 +# gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0 +# oscatbufr uv null uv 0.0 0 0 +# mlsbufr mls30 aura mls30_aura 0.0 0 0 + avhambufr avhrr metop-a avhrr3_metop-a 0.0 1 0 + avhpmbufr avhrr n18 avhrr3_n18 0.0 1 0 + avhambufr avhrr metop-b avhrr3_metop-b 0.0 1 0 + avhpmbufr avhrr n19 avhrr3_n19 0.0 1 0 + amsr2bufr amsr2 gcom-w1 amsr2_gcom-w1 0.0 3 0 + gmibufr gmi gpm gmi_gpm 0.0 3 0 + saphirbufr saphir meghat saphir_meghat 0.0 3 0 + ahibufr ahi himawari8 ahi_himawari8 0.0 1 0 + abibufr abi g16 abi_g16 0.0 1 0 + abibufr abi g17 abi_g17 0.0 1 0 +# rapidscatbufr uv null uv 0.0 0 0 + ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 + ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 + amsuabufr amsua metop-c amsua_metop-c 0.0 1 0 + mhsbufr mhs metop-c mhs_metop-c 0.0 1 0 + iasibufr iasi metop-c iasi_metop-c 0.0 1 0 +:: +&SUPEROB_RADAR + $SUPERRAD +/ +&LAG_DATA + $LAGDATA +/ +&HYBRID_ENSEMBLE + l_hyb_ens=.false., + generate_ens=.false., + beta_s0=0.125,readin_beta=.false., + s_ens_h=800.,s_ens_v=-0.8,readin_localization=.true., + aniso_a_en=.false.,oz_univ_static=.false.,uv_hyb_ens=.true., + ensemble_path='./ensemble_data/', + ens_fast_read=.true., + $HYBRID_ENSEMBLE +/ +&RAPIDREFRESH_CLDSURF + dfi_radar_latent_heat_time_period=30.0, + $RAPIDREFRESH_CLDSURF +/ +&CHEM + $CHEM +/ +&SINGLEOB_TEST + maginnov=0.1,magoberr=0.1,oneob_type='t', + oblat=45.,oblon=180.,obpres=1000.,obdattim=${adate}, + obhourset=0., + $SINGLEOB +/ +&NST + nst_gsi=0, + nstinfo=4,fac_dtl=1,fac_tsl=1,zsea1=0,zsea2=0, + $NSST +/ +EOF +cat gsiparm.anl + +## run GSI observer +export OMP_NUM_THREADS=1 +$APRUN_GSI ./gsi.x > gsi.stdout || exit 1 + +## cat diags +ntype=3 +numfile[0]=0 +numfile[1]=0 +numfile[2]=0 +numfile[3]=0 +diagtype[0]="conv conv_gps conv_ps conv_q conv_sst conv_t conv_uv" +diagtype[1]="pcp_ssmi_dmsp pcp_tmi_trmm" +diagtype[2]="sbuv2_n16 sbuv2_n17 sbuv2_n18 sbuv2_n19 gome_metop-a gome_metop-b omi_aura mls30_aura ompsnp_npp +ompstc8_npp" +diagtype[3]="hirs2_n14 msu_n14 sndr_g08 sndr_g11 sndr_g12 sndr_g13 sndr_g08_prep sndr_g11_prep sndr_g12_prep +sndr_g13_prep sndrd1_g11 sndrd2_g11 sndrd3_g11 sndrd4_g11 sndrd1_g12 sndrd2_g12 sndrd3_g12 sndrd4_g12 sndrd1_g13 +sndrd2_g13 sndrd3_g13 sndrd4_g13 sndrd1_g14 sndrd2_g14 sndrd3_g14 sndrd4_g14 sndrd1_g15 sndrd2_g15 sndrd3_g15 sndrd4_g15 +hirs3_n15 hirs3_n16 hirs3_n17 amsua_n15 amsua_n16 amsua_n17 amsub_n15 amsub_n16 amsub_n17 hsb_aqua airs_aqua amsua_aqua +imgr_g08 imgr_g11 imgr_g12 imgr_g14 imgr_g15 ssmi_f13 ssmi_f15 hirs4_n18 hirs4_metop-a amsua_n18 amsua_metop-a mhs_n18 +mhs_metop-a amsre_low_aqua amsre_mid_aqua amsre_hig_aqua ssmis_f16 ssmis_f17 ssmis_f18 ssmis_f19 ssmis_f20 iasi_metop-a +hirs4_n19 amsua_n19 mhs_n19 seviri_m08 seviri_m09 seviri_m10 seviri_m11 cris_npp cris-fsr_npp cris-fsr_n20 atms_npp +atms_n20 hirs4_metop-b amsua_metop-b mhs_metop-b iasi_metop-b amsua_metop-c mhs_metop-c avhrr_n18 avhrr_n19 avhrr_metop-a avhrr_metop-b avhrr_metop-c amsr2_gcom-w1 gmi_gpm +saphir_meghat ahi_himawari8" + +prefix=" dir.*/" +loops="01" +for loop in $loops; do + case $loop in + 01) string=ges;; + 03) string=anl;; + *) string=$loop;; + esac + echo $(date) START loop $string >&2 + n=-1 + while [ $((n+=1)) -le $ntype ] ;do + for type in $(echo ${diagtype[n]}); do + count=$(ls ${prefix}${type}_${loop}* | wc -l) + if [ $count -gt 0 ]; then + file=diag_${type}_${string}.${adate}.nc4 + # note if the GSI utility is not working correctly, use the python version + # same syntax is used to call it, just change what $nccat is + $nccat -o $file ${prefix}${type}_${loop}.nc4 & + sleep 5 + echo "diag_${type}_${string}.${adate}*" >> ${diaglist[n]} + numfile[n]=$(expr ${numfile[n]} + 1) + fi + done + done + echo $(date) END loop $string >&2 +done +wait + +cat `echo fort.*` > gsistat.out + +mkdir -p $workdir/diags +mv diag_* $workdir/diags + +## cannot let rstprod data become readable by all +if [[ "$rstprod" = "true" ]]; then + chgrp rstprod $workdir/diags/diag_* + chmod 640 $workdir/diags/diag_* +fi + +date +set +x +module purge +set -x +echo "GSI observer script completed" +cd $workdir +echo "Submitting IODA converters script" +sbatch /work2/noaa/da/acollard/GSI_jedi/scripts/iodaconv.sh $GDASApp $workdir $adate diff --git a/ush/run_observer/iodaconv.sh b/ush/run_observer/iodaconv.sh new file mode 100755 index 0000000000..8af57b7326 --- /dev/null +++ b/ush/run_observer/iodaconv.sh @@ -0,0 +1,68 @@ +#!/bin/bash +#SBATCH -J iodaconv +#SBATCH -o iodaconv.o%j +#SBATCH -A da-cpu +#SBATCH -q batch +#SBATCH -p orion +#SBATCH --nodes=1 +#SBATCH --exclusive +#SBATCH -t 1:30:00 +# run python ioda-iodaconverters +# on GSI netCDF diag files to generate +# IODA formatted observations for UFO H(x) +# cory.r.martin@noaa.gov +set -x + +GDASApp=$1 +workdir=$2 +adate=$3 + +# source modulefile to get proper python on environment +module purge +module use $GDASApp/modulefiles +module load GDAS/orion +module list + +# executable paths +IODA_iodaconv_iodaconvbin=$GDASApp/build/bin/proc_gsi_ncdiag.py +IODA_iodaconv_iodacombinebin=$GDASApp/build/bin/combine_obsspace.py +#IODA_iodaconv_iodaconvgnssrobin=$GDASApp/build/bin/gnssro_gsidiag2ioda + +# make working directory +IODA_data_iodaworkdir=$workdir/iodawork +rm -rf $IODA_data_iodaworkdir +mkdir -p $IODA_data_iodaworkdir +cd $IODA_data_iodaworkdir + +# make output directory +IODA_data_iodaoutdir=$workdir/ioda +rm -rf $IODA_data_iodaoutdir/obs +mkdir -p $IODA_data_iodaoutdir/obs +rm -rf $IODA_data_iodaoutdir/geovals +mkdir -p $IODA_data_iodaoutdir/geovals + +#export PYTHONPATH=$GDASApp/build/lib/python3.7/pyioda:$PYTHONPATH +#export PYTHONPATH=$GDASApp/build/lib/pyiodaconv:$PYTHONPATH +export PYTHONPATH=$GDASApp/build/lib/python3.7:$PYTHONPATH +export PYTHONPATH=$GDASApp/build/lib/python3.7/pyiodaconv:$PYTHONPATH +#export PYTHONPATH=$GDASApp/iodaconv/src:$PYTHONPATH +#export PYTHONPATH=$PYTHONPATH:$GDASApp/iodaconv/src + +# +# run script to generate IODA obs files +$IODA_iodaconv_iodaconvbin -o $IODA_data_iodaoutdir/obs -g $IODA_data_iodaoutdir/geovals $workdir/diags +#$IODA_iodaconv_iodaconvbin -o $IODA_data_iodaoutdir/obs -g $IODA_data_iodaoutdir/geovals $workdir/diags -q True -r True +# +# concatenate these files together +python $IODA_iodaconv_iodacombinebin -i $IODA_data_iodaoutdir/obs/sfc_*.nc4 -o $IODA_data_iodaoutdir/obs/sfc_obs_"$adate".nc4 -g $IODA_data_iodaoutdir/geovals +python $IODA_iodaconv_iodacombinebin -i $IODA_data_iodaoutdir/obs/sfcship_*.nc4 -o $IODA_data_iodaoutdir/obs/sfcship_obs_"$adate".nc4 -g $IODA_data_iodaoutdir/geovals +python $IODA_iodaconv_iodacombinebin -i $IODA_data_iodaoutdir/obs/aircraft_*.nc4 -o $IODA_data_iodaoutdir/obs/aircraft_obs_"$adate".nc4 -g $IODA_data_iodaoutdir/geovals +python $IODA_iodaconv_iodacombinebin -i $IODA_data_iodaoutdir/obs/sondes_ps*.nc4 $IODA_data_iodaoutdir/obs/sondes_q*.nc4 $IODA_data_iodaoutdir/obs/sondes_tsen*.nc4 $IODA_data_iodaoutdir/obs/sondes_tv*.nc4 $IODA_data_iodaoutdir/obs/sondes_uv*.nc4 -o $IODA_data_iodaoutdir/obs/sondes_obs_"$adate".nc4 -g $IODA_data_iodaoutdir/geovals +python $IODA_iodaconv_iodacombinebin -i $IODA_data_iodaoutdir/obs/sondes_ps*.nc4 $IODA_data_iodaoutdir/obs/sondes_q*.nc4 $IODA_data_iodaoutdir/obs/sondes_tv*.nc4 $IODA_data_iodaoutdir/obs/sondes_uv*.nc4 -o $IODA_data_iodaoutdir/obs/sondes_tvirt_obs_"$adate".nc4 -g $IODA_data_iodaoutdir/geovals + +# gnssro converter +#ln -sf $IODA_data_iodaoutdir/obs/gnssro_obs_${adate}.nc4 ./gnssro_obs_${adate}.nc4 +#$IODA_iodaconv_iodaconvgnssrobin $adate $IODA_data_gsiindir/diag_conv_gps_* 1 + +date +echo "GSI ncdiag ioda converter script completed" diff --git a/ush/run_observer/submit_gsi_observer.sh b/ush/run_observer/submit_gsi_observer.sh new file mode 100755 index 0000000000..cd6202dc21 --- /dev/null +++ b/ush/run_observer/submit_gsi_observer.sh @@ -0,0 +1,54 @@ +#!/bin/bash +# submit_gsi_observer.sh +# script to define configuration, +# prepare, and submit GSI observer job +# cory.r.martin@noaa.gov + +set -x + +#---- user modified variables +# valid time +cycle=2024021900 +# path to your GSI clone +THISDIR=`pwd` +GSIDIR=$THISDIR/../.. +# top level working directory +workdir=/work2/noaa/da/$LOGNAME/ufoeval/GSIobserver/orion/$cycle/ +# GDASApp clone +GDASApp=/work2/noaa/da/$LOGNAME/git/GDASApp +#GDASApp=/work2/noaa/da/$LOGNAME/git/orion/GDASApp + +# gfs or gdas +dump=gdas +# restricted data inclusion +rstprod="true" +# 6 for 3d, 1 or 3 for 4d +nhr_bkg=6 + +# should NOT touch below this line +CRTM_FIX=/apps/contrib/NCEP/libs/hpc-stack-gfsv16/intel-2018.4/crtm/2.3.0/fix/ +# many people cannot clone this without gerrit permissions +# plus, I have the C768 berror file here +# so that GSI observer can run at full background res +GSIFIX=/work2/noaa/da/cmartin/UFO_eval/geovals/GSI/fix +dumpdir=/work/noaa/rstprod/dump +gesroot=/work2/noaa/da/acollard/UFO_eval/data/para/output_ufo_eval_feb2024/ + +mkdir -p $workdir +cd $workdir +cat > $workdir/config.sh << EOF +export adate=$cycle +export GSIDIR=$GSIDIR +export workdir=$workdir +export GSIFIX=$GSIFIX +export dump=$dump +export dumpdir=$dumpdir +export gesroot=$gesroot +export CRTM_FIX=$CRTM_FIX +export rstprod=$rstprod +export GSI_background_nhr=$nhr_bkg +export GDASApp=$GDASApp +EOF + +#sbatch $GDASApp/ush/ufoeval/gsi/gsi_observer.sh $workdir/config.sh +sbatch $GSIDIR/ush/run_observer/gsi_observer.sh $workdir/config.sh From 2e62d4868f7b98732694a55ad8977b7cd657af07 Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Wed, 31 Jul 2024 16:57:09 -0500 Subject: [PATCH 095/109] Fix iodaconv.sh path --- ush/run_observer/gsi_observer.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ush/run_observer/gsi_observer.sh b/ush/run_observer/gsi_observer.sh index ed338c1be9..aca7a17928 100755 --- a/ush/run_observer/gsi_observer.sh +++ b/ush/run_observer/gsi_observer.sh @@ -520,4 +520,4 @@ set -x echo "GSI observer script completed" cd $workdir echo "Submitting IODA converters script" -sbatch /work2/noaa/da/acollard/GSI_jedi/scripts/iodaconv.sh $GDASApp $workdir $adate +sbatch $GSIDIR/ush/run_observer/iodaconv.sh $GDASApp $workdir $adate From 96aacb67b0629cd1aa94523980498655553a2003 Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Wed, 31 Jul 2024 17:19:38 -0500 Subject: [PATCH 096/109] Small fixes --- ush/run_observer/README | 5 +++++ ush/run_observer/gsi_observer.sh | 2 +- ush/run_observer/iodaconv.sh | 5 ++--- ush/run_observer/submit_gsi_observer.sh | 3 ++- 4 files changed, 10 insertions(+), 5 deletions(-) create mode 100644 ush/run_observer/README diff --git a/ush/run_observer/README b/ush/run_observer/README new file mode 100644 index 0000000000..5e68d63929 --- /dev/null +++ b/ush/run_observer/README @@ -0,0 +1,5 @@ +Main driver script is submit_gsi_observer.sh + +This calls gsi_observer.sh where the GSI observer is run producing GSI diag files in $workdir/diags ($workdir is defined in submit_gsi_observer.sh) + +This calls iodaconv.sh which runs the iodacoverters in $GDASApp and outputs to $workdir/ioda diff --git a/ush/run_observer/gsi_observer.sh b/ush/run_observer/gsi_observer.sh index aca7a17928..a68015a09f 100755 --- a/ush/run_observer/gsi_observer.sh +++ b/ush/run_observer/gsi_observer.sh @@ -31,7 +31,7 @@ export NLAT=1538 ## load modules for GSI #set +x -MACHINE_ID=orion +MACHINE_ID=$MACHINE source $GSIDIR/ush/module-setup.sh module use $GSIDIR/modulefiles module load gsi_$MACHINE_ID.intel diff --git a/ush/run_observer/iodaconv.sh b/ush/run_observer/iodaconv.sh index 8af57b7326..94a6db9e07 100755 --- a/ush/run_observer/iodaconv.sh +++ b/ush/run_observer/iodaconv.sh @@ -3,7 +3,7 @@ #SBATCH -o iodaconv.o%j #SBATCH -A da-cpu #SBATCH -q batch -#SBATCH -p orion +#SBATCH -p orion #SBATCH --nodes=1 #SBATCH --exclusive #SBATCH -t 1:30:00 @@ -20,7 +20,7 @@ adate=$3 # source modulefile to get proper python on environment module purge module use $GDASApp/modulefiles -module load GDAS/orion +module load GDAS/$MACHINE module list # executable paths @@ -51,7 +51,6 @@ export PYTHONPATH=$GDASApp/build/lib/python3.7/pyiodaconv:$PYTHONPATH # # run script to generate IODA obs files $IODA_iodaconv_iodaconvbin -o $IODA_data_iodaoutdir/obs -g $IODA_data_iodaoutdir/geovals $workdir/diags -#$IODA_iodaconv_iodaconvbin -o $IODA_data_iodaoutdir/obs -g $IODA_data_iodaoutdir/geovals $workdir/diags -q True -r True # # concatenate these files together python $IODA_iodaconv_iodacombinebin -i $IODA_data_iodaoutdir/obs/sfc_*.nc4 -o $IODA_data_iodaoutdir/obs/sfc_obs_"$adate".nc4 -g $IODA_data_iodaoutdir/geovals diff --git a/ush/run_observer/submit_gsi_observer.sh b/ush/run_observer/submit_gsi_observer.sh index cd6202dc21..49b02a0d2f 100755 --- a/ush/run_observer/submit_gsi_observer.sh +++ b/ush/run_observer/submit_gsi_observer.sh @@ -17,6 +17,7 @@ workdir=/work2/noaa/da/$LOGNAME/ufoeval/GSIobserver/orion/$cycle/ # GDASApp clone GDASApp=/work2/noaa/da/$LOGNAME/git/GDASApp #GDASApp=/work2/noaa/da/$LOGNAME/git/orion/GDASApp +MACHINE=orion # gfs or gdas dump=gdas @@ -48,7 +49,7 @@ export CRTM_FIX=$CRTM_FIX export rstprod=$rstprod export GSI_background_nhr=$nhr_bkg export GDASApp=$GDASApp +export MACHINE=$MACHINE EOF -#sbatch $GDASApp/ush/ufoeval/gsi/gsi_observer.sh $workdir/config.sh sbatch $GSIDIR/ush/run_observer/gsi_observer.sh $workdir/config.sh From c069aecb73e3dc553015635efbf2f5d7c963a247 Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Thu, 1 Aug 2024 08:58:08 -0500 Subject: [PATCH 097/109] update path --- ush/run_observer/submit_gsi_observer.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ush/run_observer/submit_gsi_observer.sh b/ush/run_observer/submit_gsi_observer.sh index 49b02a0d2f..d732d0b950 100755 --- a/ush/run_observer/submit_gsi_observer.sh +++ b/ush/run_observer/submit_gsi_observer.sh @@ -15,8 +15,8 @@ GSIDIR=$THISDIR/../.. # top level working directory workdir=/work2/noaa/da/$LOGNAME/ufoeval/GSIobserver/orion/$cycle/ # GDASApp clone -GDASApp=/work2/noaa/da/$LOGNAME/git/GDASApp -#GDASApp=/work2/noaa/da/$LOGNAME/git/orion/GDASApp +#GDASApp=/work2/noaa/da/$LOGNAME/git/GDASApp +GDASApp=/work2/noaa/da/$LOGNAME/git/orion/GDASApp MACHINE=orion # gfs or gdas From 235018e69ef5f36834f0beb19810a98c2a2b9b52 Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Tue, 6 Aug 2024 08:40:05 -0500 Subject: [PATCH 098/109] Remove duplicate output --- src/gsi/setupps.f90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/gsi/setupps.f90 b/src/gsi/setupps.f90 index bed168122c..fde1f540ba 100644 --- a/src/gsi/setupps.f90 +++ b/src/gsi/setupps.f90 @@ -1005,10 +1005,6 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata_to_single("Observation", pob ) call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",pob,pges,'-') call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",pob,pgesorig,'-') - - call nc_diag_metadata_to_single("Observation", pob) - call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted", pob-pges) - call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted", pob-pgesorig) call nc_diag_metadata_to_single("Forecast_adjusted", pges) call nc_diag_metadata_to_single("Forecast_unadjusted", pgesorig) From 47a6db49f9839f69d712bc52e101a541828d5af2 Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Tue, 6 Aug 2024 11:20:42 -0500 Subject: [PATCH 099/109] Fix variable types in setupoz.f90 --- src/gsi/setupoz.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/gsi/setupoz.f90 b/src/gsi/setupoz.f90 index bcedee5c68..7328efc140 100644 --- a/src/gsi/setupoz.f90 +++ b/src/gsi/setupoz.f90 @@ -625,10 +625,10 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& call nc_diag_metadata_to_single("Latitude", data(ilate,i)) call nc_diag_metadata_to_single("Longitude", data(ilone,i)) call nc_diag_metadata_to_single("Time", data(itime,i)-time_offset) - call nc_diag_metadata("Total_Ozone_Error_Flag", ierror_toq ) - call nc_diag_metadata("Profile_Ozone_Error_Flag", ierror_poq ) + call nc_diag_metadata("Total_Ozone_Error_Flag", sngl(ierror_toq) ) + call nc_diag_metadata("Profile_Ozone_Error_Flag", sngl(ierror_poq) ) call nc_diag_metadata_to_single("Reference_Pressure",(pobs(k)*r100)) - call nc_diag_metadata("Analysis_Use_Flag", iouse(k) ) + call nc_diag_metadata("Analysis_Use_Flag", sngl(iouse(k)) ) call nc_diag_metadata_to_single("Observation",(ozobs(k))) call nc_diag_metadata_to_single("Inverse_Observation_Error",(errorinv)) call nc_diag_metadata_to_single("Input_Observation_Error", (error(k))) From 0dcda32f61d9fab4127b6908f940cc178aa02a53 Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Tue, 6 Aug 2024 13:02:48 -0500 Subject: [PATCH 100/109] Fix variable types in setupoz.f90 --- src/gsi/setupoz.f90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/gsi/setupoz.f90 b/src/gsi/setupoz.f90 index 7328efc140..9e52bf4bf2 100644 --- a/src/gsi/setupoz.f90 +++ b/src/gsi/setupoz.f90 @@ -625,10 +625,10 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,& call nc_diag_metadata_to_single("Latitude", data(ilate,i)) call nc_diag_metadata_to_single("Longitude", data(ilone,i)) call nc_diag_metadata_to_single("Time", data(itime,i)-time_offset) - call nc_diag_metadata("Total_Ozone_Error_Flag", sngl(ierror_toq) ) - call nc_diag_metadata("Profile_Ozone_Error_Flag", sngl(ierror_poq) ) + call nc_diag_metadata("Total_Ozone_Error_Flag", float(ierror_toq) ) + call nc_diag_metadata("Profile_Ozone_Error_Flag", float(ierror_poq) ) call nc_diag_metadata_to_single("Reference_Pressure",(pobs(k)*r100)) - call nc_diag_metadata("Analysis_Use_Flag", sngl(iouse(k)) ) + call nc_diag_metadata("Analysis_Use_Flag", float(iouse(k)) ) call nc_diag_metadata_to_single("Observation",(ozobs(k))) call nc_diag_metadata_to_single("Inverse_Observation_Error",(errorinv)) call nc_diag_metadata_to_single("Input_Observation_Error", (error(k))) @@ -1786,10 +1786,10 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_data2d("Observation_Operator_Jacobian_stind", dhx_dx%st_ind) call nc_diag_data2d("Observation_Operator_Jacobian_endind", dhx_dx%end_ind) call nc_diag_data2d("Observation_Operator_Jacobian_val", real(dhx_dx%val,r_single)) - endif - ! GeoVaLs for JEDI/UFO - call nc_diag_data2d("mole_fraction_of_ozone_in_air", sngl(ozgestmp*constoz)) - call nc_diag_data2d("air_pressure_levels",sngl(prsitmp*r1000)) + endif + ! GeoVaLs for JEDI/UFO + call nc_diag_data2d("mole_fraction_of_ozone_in_air", sngl(ozgestmp*constoz)) + call nc_diag_data2d("air_pressure_levels",sngl(prsitmp*r1000)) if (lobsdiagsave) then do jj=1,miter if (odiag%muse(jj)) then From 73062e78b31937fd759284728f29962704975c7d Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Thu, 8 Aug 2024 10:12:27 -0500 Subject: [PATCH 101/109] Make sure aveage surface temperature is included --- src/gsi/setuprad.f90 | 28 ++++++++++++------------- ush/run_observer/gsi_observer.sh | 21 ++++++------------- ush/run_observer/submit_gsi_observer.sh | 2 +- 3 files changed, 21 insertions(+), 30 deletions(-) diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 index 29d6d265be..17d0b14f8c 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -2671,7 +2671,7 @@ subroutine contents_netcdf_diag_(odiags,idv,iob) call nc_diag_metadata_to_single("Soil_Temperature",surface(1)%soil_temperature ) ! soil temperature (K) call nc_diag_metadata_to_single("Soil_Moisture",surface(1)%soil_moisture_content ) ! soil moisture call nc_diag_metadata("Land_Type_Index", surface(1)%land_type ) ! surface land type - call nc_diag_metadata("tsavg5", missing ) ! SST first guess used for SST retrieval + call nc_diag_metadata("tsavg5", tsavg5 ) ! SST first guess used for SST retrieval call nc_diag_metadata("sstcu", missing ) ! NCEP SST analysis at t call nc_diag_metadata("sstph", missing ) ! Physical SST retrieval call nc_diag_metadata("sstnv", missing ) ! Navy SST retrieval @@ -2922,22 +2922,22 @@ subroutine contents_netcdf_diag_(odiags,idv,iob) call nc_diag_metadata_to_single("tropopause_pressure", trop5*r1000) ! trop5 is in kPa - convert to Pa for JEDI ! Get GeoVaLs for atmosphere - !call nc_diag_data2d("air_temperature", atmosphere(1)%temperature) ! K - !call nc_diag_data2d("air_pressure", atmosphere(1)%pressure*r100) - !call nc_diag_data2d("air_pressure_levels", atmosphere(1)%level_pressure*r100) + call nc_diag_data2d("air_temperature", atmosphere(1)%temperature) ! K + call nc_diag_data2d("air_pressure", atmosphere(1)%pressure*r100) + call nc_diag_data2d("air_pressure_levels", atmosphere(1)%level_pressure*r100) ! Get GeoVaLs for atmospheric absorbers - !do iabsorb = 1, n_absorbers - ! write (fieldname, "(A,I0.2)") "atmosphere_absorber_", atmosphere(1)%absorber_id(iabsorb) - ! call nc_diag_data2d(trim(fieldname), atmosphere(1)%absorber(:,iabsorb)) ! check %absorber_units - !enddo + do iabsorb = 1, n_absorbers + write (fieldname, "(A,I0.2)") "atmosphere_absorber_", atmosphere(1)%absorber_id(iabsorb) + call nc_diag_data2d(trim(fieldname), atmosphere(1)%absorber(:,iabsorb)) ! check %absorber_units + enddo ! Get GeoVaLs for hydrometeors - !do icloud = 1, n_clouds_fwd_wk - ! write (fieldname, "(A,I0.2)") "atmosphere_mass_content_of_cloud_", atmosphere(1)%Cloud(icloud)%Type - ! call nc_diag_data2d(trim(fieldname), atmosphere(1)%Cloud(icloud)%Water_Content) - ! write (fieldname, "(A,I0.2)") "effective_radius_of_cloud_particle_", atmosphere(1)%Cloud(icloud)%Type - ! call nc_diag_data2d(trim(fieldname), atmosphere(1)%Cloud(icloud)%Effective_Radius) - !enddo + do icloud = 1, n_clouds_fwd_wk + write (fieldname, "(A,I0.2)") "atmosphere_mass_content_of_cloud_", atmosphere(1)%Cloud(icloud)%Type + call nc_diag_data2d(trim(fieldname), atmosphere(1)%Cloud(icloud)%Water_Content) + write (fieldname, "(A,I0.2)") "effective_radius_of_cloud_particle_", atmosphere(1)%Cloud(icloud)%Type + call nc_diag_data2d(trim(fieldname), atmosphere(1)%Cloud(icloud)%Effective_Radius) + enddo enddo ! if (adp_anglebc) then if (.true.) then diff --git a/ush/run_observer/gsi_observer.sh b/ush/run_observer/gsi_observer.sh index a68015a09f..72ce6af080 100755 --- a/ush/run_observer/gsi_observer.sh +++ b/ush/run_observer/gsi_observer.sh @@ -94,8 +94,6 @@ aeroinfo=$fixgsi/global_aeroinfo.txt atmsbeaminfo=$fixgsi/atms_beamwidth.txt cloudyinfo=$fixgsi/cloudy_radiance_info.txt -CRTM_FIX=/apps/contrib/NCEP/libs/hpc-stack-gfsv16/intel-2018.4/crtm/2.3.0/fix/ - emiscoef_IRwater=$CRTM_FIX/Nalli.IRwater.EmisCoeff.bin emiscoef_IRice=$CRTM_FIX/NPOESS.IRice.EmisCoeff.bin emiscoef_IRland=$CRTM_FIX/NPOESS.IRland.EmisCoeff.bin @@ -372,8 +370,8 @@ OBS_INPUT:: # tcvitl tcp null tcp 0.0 0 0 # seviribufr seviri m08 seviri_m08 0.0 1 0 # seviribufr seviri m09 seviri_m09 0.0 1 0 -# seviribufr seviri m10 seviri_m10 0.0 1 0 -# seviribufr seviri m11 seviri_m11 0.0 1 0 + seviribufr seviri m10 seviri_m10 0.0 1 0 + seviribufr seviri m11 seviri_m11 0.0 1 0 # hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 amsuabufr amsua metop-b amsua_metop-b 0.0 1 0 mhsbufr mhs metop-b mhs_metop-b 0.0 1 0 @@ -381,11 +379,11 @@ OBS_INPUT:: # gomebufr gome metop-b gome_metop-b 0.0 2 0 atmsbufr atms npp atms_npp 0.0 1 0 atmsbufr atms n20 atms_n20 0.0 1 0 -# atmsbufr atms n21 atms_n21 0.0 1 0 + atmsbufr atms n21 atms_n21 0.0 1 0 # crisbufr cris npp cris_npp 0.0 1 0 # crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0 -# crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 1 0 + crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 1 0 # gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 1 0 # gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 1 0 # gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 1 0 @@ -406,6 +404,7 @@ OBS_INPUT:: ahibufr ahi himawari8 ahi_himawari8 0.0 1 0 abibufr abi g16 abi_g16 0.0 1 0 abibufr abi g17 abi_g17 0.0 1 0 + abibufr abi g18 abi_g18 0.0 1 0 # rapidscatbufr uv null uv 0.0 0 0 ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 @@ -464,15 +463,7 @@ diagtype[0]="conv conv_gps conv_ps conv_q conv_sst conv_t conv_uv" diagtype[1]="pcp_ssmi_dmsp pcp_tmi_trmm" diagtype[2]="sbuv2_n16 sbuv2_n17 sbuv2_n18 sbuv2_n19 gome_metop-a gome_metop-b omi_aura mls30_aura ompsnp_npp ompstc8_npp" -diagtype[3]="hirs2_n14 msu_n14 sndr_g08 sndr_g11 sndr_g12 sndr_g13 sndr_g08_prep sndr_g11_prep sndr_g12_prep -sndr_g13_prep sndrd1_g11 sndrd2_g11 sndrd3_g11 sndrd4_g11 sndrd1_g12 sndrd2_g12 sndrd3_g12 sndrd4_g12 sndrd1_g13 -sndrd2_g13 sndrd3_g13 sndrd4_g13 sndrd1_g14 sndrd2_g14 sndrd3_g14 sndrd4_g14 sndrd1_g15 sndrd2_g15 sndrd3_g15 sndrd4_g15 -hirs3_n15 hirs3_n16 hirs3_n17 amsua_n15 amsua_n16 amsua_n17 amsub_n15 amsub_n16 amsub_n17 hsb_aqua airs_aqua amsua_aqua -imgr_g08 imgr_g11 imgr_g12 imgr_g14 imgr_g15 ssmi_f13 ssmi_f15 hirs4_n18 hirs4_metop-a amsua_n18 amsua_metop-a mhs_n18 -mhs_metop-a amsre_low_aqua amsre_mid_aqua amsre_hig_aqua ssmis_f16 ssmis_f17 ssmis_f18 ssmis_f19 ssmis_f20 iasi_metop-a -hirs4_n19 amsua_n19 mhs_n19 seviri_m08 seviri_m09 seviri_m10 seviri_m11 cris_npp cris-fsr_npp cris-fsr_n20 atms_npp -atms_n20 hirs4_metop-b amsua_metop-b mhs_metop-b iasi_metop-b amsua_metop-c mhs_metop-c avhrr_n18 avhrr_n19 avhrr_metop-a avhrr_metop-b avhrr_metop-c amsr2_gcom-w1 gmi_gpm -saphir_meghat ahi_himawari8" +diagtype[3]="msu_n14 sndr_g08 sndr_g11 sndr_g12 sndr_g13 sndr_g08_prep sndr_g11_prep sndr_g12_prep sndr_g13_prep sndrd1_g11 sndrd2_g11 sndrd3_g11 sndrd4_g11 sndrd1_g12 sndrd2_g12 sndrd3_g12 sndrd4_g12 sndrd1_g13 sndrd2_g13 sndrd3_g13 sndrd4_g13 sndrd1_g14 sndrd2_g14 sndrd3_g14 sndrd4_g14 sndrd1_g15 sndrd2_g15 sndrd3_g15 sndrd4_g15 amsua_n15 amsua_n16 amsua_n17 amsub_n15 amsub_n16 amsub_n17 hsb_aqua airs_aqua amsua_aqua imgr_g08 imgr_g11 imgr_g12 imgr_g14 imgr_g15 ssmi_f13 ssmi_f15 amsua_n18 amsua_metop-a mhs_n18 mhs_metop-a amsre_low_aqua amsre_mid_aqua amsre_hig_aqua ssmis_f16 ssmis_f17 ssmis_f18 ssmis_f19 ssmis_f20 iasi_metop-a amsua_n19 mhs_n19 seviri_m08 seviri_m09 seviri_m10 seviri_m11 cris_npp cris-fsr_npp cris-fsr_n20 atms_npp atms_n20 amsua_metop-b mhs_metop-b iasi_metop-b avhrr_metop-b avhrr_n18 avhrr_n19 avhrr_metop-a amsr2_gcom-w1 gmi_gpm saphir_meghat ahi_himawari8 abi_g16 abi_g17 amsua_metop-c mhs_metop-c iasi_metop-c avhrr_metop-c viirs-m_npp viirs-m_j1 abi_g18 ahi_himawari9 viirs-m_j2 cris-fsr_n21 atms_n21" prefix=" dir.*/" loops="01" diff --git a/ush/run_observer/submit_gsi_observer.sh b/ush/run_observer/submit_gsi_observer.sh index d732d0b950..74a448d0a0 100755 --- a/ush/run_observer/submit_gsi_observer.sh +++ b/ush/run_observer/submit_gsi_observer.sh @@ -27,7 +27,7 @@ rstprod="true" nhr_bkg=6 # should NOT touch below this line -CRTM_FIX=/apps/contrib/NCEP/libs/hpc-stack-gfsv16/intel-2018.4/crtm/2.3.0/fix/ +CRTM_FIX=/work/noaa/epic/role-epic/spack-stack/hercules/spack-stack-1.6.0/envs/unified-env/install/intel/2021.9.0/crtm-fix-2.4.0.1_emc-2os2hw2/fix # many people cannot clone this without gerrit permissions # plus, I have the C768 berror file here # so that GSI observer can run at full background res From ba90137d3cdd80ea8fb7451509703b67fcd29804 Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Mon, 12 Aug 2024 15:03:13 -0500 Subject: [PATCH 102/109] Add instruments --- ush/run_observer/gsi_observer.sh | 44 +++++++++++++++++--------------- 1 file changed, 23 insertions(+), 21 deletions(-) diff --git a/ush/run_observer/gsi_observer.sh b/ush/run_observer/gsi_observer.sh index 72ce6af080..b783f3eb62 100755 --- a/ush/run_observer/gsi_observer.sh +++ b/ush/run_observer/gsi_observer.sh @@ -205,6 +205,8 @@ $ncpl $datobs/${prefix_obs}.crisdb.${suffix} ./crisbufr_db $ncpl $datobs/${prefix_obs}.atmsdb.${suffix} ./atmsbufr_db $ncpl $datobs/${prefix_obs}.escris.${suffix} ./crisbufrears $ncpl $datobs/${prefix_obs}.esatms.${suffix} ./atmsbufrears +$ncpl $datobs/${prefix_obs}.gsrcsr.${suffix} ./abibufr +$ncpl $datobs/${prefix_obs}.ahicsr.${suffix} ./ahibufr ## copy gsistats $ncpl $datges/${prefix_obs}.gsistat ./gsistat @@ -348,28 +350,28 @@ OBS_INPUT:: ssmisbufr ssmis f16 ssmis_f16 0.0 1 0 ssmisbufr ssmis f17 ssmis_f17 0.0 1 0 ssmisbufr ssmis f18 ssmis_f18 0.0 1 0 -# gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 1 0 -# gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 1 0 -# gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 1 0 -# gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 1 0 -# gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 1 0 -# gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 1 0 -# gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 1 0 -# gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 1 0 -# gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 1 0 -# gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 1 0 -# gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 1 0 -# gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 1 0 -# iasibufr iasi metop-a iasi_metop-a 0.0 1 0 -# gomebufr gome metop-a gome_metop-a 0.0 2 0 -# omibufr omi aura omi_aura 0.0 2 0 -# sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 + gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 1 0 + gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 1 0 + gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 1 0 + gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 1 0 + gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 1 0 + gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 1 0 + gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 1 0 + gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 1 0 + gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 1 0 + gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 1 0 + gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 1 0 + gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 1 0 + iasibufr iasi metop-a iasi_metop-a 0.0 1 0 + gomebufr gome metop-a gome_metop-a 0.0 2 0 + omibufr omi aura omi_aura 0.0 2 0 + sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 # hirs4bufr hirs4 n19 hirs4_n19 0.0 1 0 -# amsuabufr amsua n19 amsua_n19 0.0 1 0 -# mhsbufr mhs n19 mhs_n19 0.0 1 0 -# tcvitl tcp null tcp 0.0 0 0 -# seviribufr seviri m08 seviri_m08 0.0 1 0 -# seviribufr seviri m09 seviri_m09 0.0 1 0 + amsuabufr amsua n19 amsua_n19 0.0 1 0 + mhsbufr mhs n19 mhs_n19 0.0 1 0 + tcvitl tcp null tcp 0.0 0 0 + seviribufr seviri m08 seviri_m08 0.0 1 0 + seviribufr seviri m09 seviri_m09 0.0 1 0 seviribufr seviri m10 seviri_m10 0.0 1 0 seviribufr seviri m11 seviri_m11 0.0 1 0 # hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 From fd6be62b44419c562298c4d10ea72844b2e757ab Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Wed, 14 Aug 2024 10:06:29 -0500 Subject: [PATCH 103/109] Use CRTM 2.4.0.1 --- modulefiles/gsi_hercules.intel.lua | 10 ++++++++++ modulefiles/gsi_orion.intel.lua | 10 ++++++++++ src/gsi/CMakeLists.txt | 1 + ush/run_observer/gsi_observer.sh | 16 ++++++++-------- ush/run_observer/submit_gsi_observer.sh | 3 ++- 5 files changed, 31 insertions(+), 9 deletions(-) diff --git a/modulefiles/gsi_hercules.intel.lua b/modulefiles/gsi_hercules.intel.lua index 66ec9b03e1..597cc87291 100644 --- a/modulefiles/gsi_hercules.intel.lua +++ b/modulefiles/gsi_hercules.intel.lua @@ -15,6 +15,16 @@ load(pathJoin("python", stack_python_ver)) load(pathJoin("cmake", cmake_ver)) load("gsi_common") +setenv("crtm_ROOT","/work/noaa/da/eliu/HERCULES/CRTM/crtm_v2.4.1-jedi.1/build") +setenv("crtm_VERSION","2.4.1-jedi.1") +setenv("CRTM_INC","/work/noaa/da/eliu/HERCULES/CRTM/crtm_v2.4.1-jedi.1/build/module") +setenv("CRTM_LIB","/work/noaa/da/eliu/HERCULES/CRTM/crtm_v2.4.1-jedi.1/build/lib/libcrtm_static.a") +setenv("CRTM_FIX","/work/noaa/da/eliu/HERCULES/CRTM-fix/crtm_v2.4.1-jedi.1-fix_gdasapp") +whatis("Name: crtm") +whatis("Version: 2.4.1-jedi.1") +whatis("Category: library") +whatis("Description: crtm library") + load(pathJoin("prod_util", prod_util_ver)) load("intel-oneapi-mkl/2022.2.1") diff --git a/modulefiles/gsi_orion.intel.lua b/modulefiles/gsi_orion.intel.lua index d05bda5b2e..ede89f5b77 100644 --- a/modulefiles/gsi_orion.intel.lua +++ b/modulefiles/gsi_orion.intel.lua @@ -15,6 +15,16 @@ load(pathJoin("python", stack_python_ver)) load(pathJoin("cmake", cmake_ver)) load("gsi_common") +setenv("crtm_ROOT","/work/noaa/da/eliu/ORION/CRTM/crtm_v2.4.1-jedi.1/build") +setenv("crtm_VERSION","2.4.1-jedi.1") +setenv("CRTM_INC","/work/noaa/da/eliu/ORION/CRTM/crtm_v2.4.1-jedi.1/build/module") +setenv("CRTM_LIB","/work/noaa/da/eliu/ORION/CRTM/crtm_v2.4.1-jedi.1/build/lib/libcrtm_static.a") +setenv("CRTM_FIX","/work/noaa/da/eliu/ORION/CRTM-fix/crtm_v2.4.1-jedi.1-fix_gdasapp") +whatis("Name: crtm") +whatis("Version: 2.4.1-jedi.1") +whatis("Category: library") +whatis("Description: crtm library") + load(pathJoin("prod_util", prod_util_ver)) load("intel-oneapi-mkl/2022.2.1") diff --git a/src/gsi/CMakeLists.txt b/src/gsi/CMakeLists.txt index f894b0a8a8..1afb0774ca 100644 --- a/src/gsi/CMakeLists.txt +++ b/src/gsi/CMakeLists.txt @@ -155,6 +155,7 @@ target_link_libraries(gsi_fortran_obj PUBLIC nemsio::nemsio) target_link_libraries(gsi_fortran_obj PUBLIC ncio::ncio) target_link_libraries(gsi_fortran_obj PUBLIC w3emc::w3emc_d) target_link_libraries(gsi_fortran_obj PUBLIC sp::sp_d) +add_library(crtm::crtm ALIAS crtm) target_link_libraries(gsi_fortran_obj PUBLIC bufr::bufr_d) target_link_libraries(gsi_fortran_obj PUBLIC crtm::crtm) if(GSI_MODE MATCHES "Regional") diff --git a/ush/run_observer/gsi_observer.sh b/ush/run_observer/gsi_observer.sh index b783f3eb62..7ba80320cf 100755 --- a/ush/run_observer/gsi_observer.sh +++ b/ush/run_observer/gsi_observer.sh @@ -307,7 +307,7 @@ cat > gsiparm.anl << EOF $OBSQC / &OBS_INPUT - dmesh(1)=145.0,dmesh(2)=150.0,dmesh(3)=100.0,time_window_max=3.0, + dmesh(1)=145.0,dmesh(2)=150.0,dmesh(3)=100.0,dmesh(4)=580,time_window_max=3.0, $OBSINPUT / OBS_INPUT:: @@ -362,7 +362,7 @@ OBS_INPUT:: gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 1 0 gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 1 0 gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 1 0 - iasibufr iasi metop-a iasi_metop-a 0.0 1 0 + iasibufr iasi metop-a iasi_metop-a 0.0 4 0 gomebufr gome metop-a gome_metop-a 0.0 2 0 omibufr omi aura omi_aura 0.0 2 0 sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 @@ -377,15 +377,15 @@ OBS_INPUT:: # hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 amsuabufr amsua metop-b amsua_metop-b 0.0 1 0 mhsbufr mhs metop-b mhs_metop-b 0.0 1 0 - iasibufr iasi metop-b iasi_metop-b 0.0 1 0 + iasibufr iasi metop-b iasi_metop-b 0.0 4 0 # gomebufr gome metop-b gome_metop-b 0.0 2 0 atmsbufr atms npp atms_npp 0.0 1 0 atmsbufr atms n20 atms_n20 0.0 1 0 atmsbufr atms n21 atms_n21 0.0 1 0 -# crisbufr cris npp cris_npp 0.0 1 0 -# crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 - crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0 - crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 1 0 +# crisbufr cris npp cris_npp 0.0 4 0 +# crisfsbufr cris-fsr npp cris-fsr_npp 0.0 4 0 + crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 4 0 + crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 4 0 # gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 1 0 # gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 1 0 # gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 1 0 @@ -412,7 +412,7 @@ OBS_INPUT:: ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0 amsuabufr amsua metop-c amsua_metop-c 0.0 1 0 mhsbufr mhs metop-c mhs_metop-c 0.0 1 0 - iasibufr iasi metop-c iasi_metop-c 0.0 1 0 + iasibufr iasi metop-c iasi_metop-c 0.0 4 0 :: &SUPEROB_RADAR $SUPERRAD diff --git a/ush/run_observer/submit_gsi_observer.sh b/ush/run_observer/submit_gsi_observer.sh index 74a448d0a0..ce80060aa3 100755 --- a/ush/run_observer/submit_gsi_observer.sh +++ b/ush/run_observer/submit_gsi_observer.sh @@ -33,7 +33,7 @@ CRTM_FIX=/work/noaa/epic/role-epic/spack-stack/hercules/spack-stack-1.6.0/envs/u # so that GSI observer can run at full background res GSIFIX=/work2/noaa/da/cmartin/UFO_eval/geovals/GSI/fix dumpdir=/work/noaa/rstprod/dump -gesroot=/work2/noaa/da/acollard/UFO_eval/data/para/output_ufo_eval_feb2024/ +gesroot=/work2/noaa/da/acollard/UFO_eval/data/para/output_ufo_eval_feb2024_9Aug mkdir -p $workdir cd $workdir @@ -52,4 +52,5 @@ export GDASApp=$GDASApp export MACHINE=$MACHINE EOF +#sbatch $GSIDIR/ush/run_observer/gsi_observer.sh $workdir/config.sh sbatch $GSIDIR/ush/run_observer/gsi_observer.sh $workdir/config.sh From d9e7c54546cb412a79058f2020d4fe94e074d531 Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Thu, 15 Aug 2024 10:18:12 -0500 Subject: [PATCH 104/109] Additional changes for CRTM --- ush/run_observer/submit_gsi_observer.sh | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ush/run_observer/submit_gsi_observer.sh b/ush/run_observer/submit_gsi_observer.sh index ce80060aa3..2d9dfcecbd 100755 --- a/ush/run_observer/submit_gsi_observer.sh +++ b/ush/run_observer/submit_gsi_observer.sh @@ -27,7 +27,7 @@ rstprod="true" nhr_bkg=6 # should NOT touch below this line -CRTM_FIX=/work/noaa/epic/role-epic/spack-stack/hercules/spack-stack-1.6.0/envs/unified-env/install/intel/2021.9.0/crtm-fix-2.4.0.1_emc-2os2hw2/fix +CRTM_FIX=/work/noaa/da/eliu/ORION/CRTM-fix/crtm_v2.4.1-jedi.1-fix_gdasapp # many people cannot clone this without gerrit permissions # plus, I have the C768 berror file here # so that GSI observer can run at full background res @@ -50,6 +50,7 @@ export rstprod=$rstprod export GSI_background_nhr=$nhr_bkg export GDASApp=$GDASApp export MACHINE=$MACHINE +export LD_LIBRARY_PATH=/work/noaa/da/eliu/${MACHINE^^}/CRTM/crtm_v2.4.1-jedi.1/build/lib:${LD_LIBRARY_PATH} EOF #sbatch $GSIDIR/ush/run_observer/gsi_observer.sh $workdir/config.sh From 6f7da623cb356772744a8424b5514c23cbb3b084 Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Thu, 10 Oct 2024 15:51:28 -0500 Subject: [PATCH 105/109] Fix virtual temperature --- src/gsi/setupt.f90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/gsi/setupt.f90 b/src/gsi/setupt.f90 index 1085311303..0fd4691386 100644 --- a/src/gsi/setupt.f90 +++ b/src/gsi/setupt.f90 @@ -610,6 +610,8 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav prsltmp2 = exp(prsltmp) call tintrp2a1(ges_prsi,prsitmp,dlat,dlon,dtime,hrdifsig,& nsig+1,mype,nfldsig) + call tintrp2a1(ges_tv,tvtmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) call tintrp2a1(ges_tsen,ttmp,dlat,dlon,dtime,hrdifsig,& nsig,mype,nfldsig) call tintrp2a1(ges_q,qtmp,dlat,dlon,dtime,hrdifsig,& @@ -741,6 +743,8 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav nsig+1,mype,nfldsig) call tintrp2a1(ges_tsen,ttmp,dlat,dlon,dtime,hrdifsig,& nsig,mype,nfldsig) + call tintrp2a1(ges_tv,tvtmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) call tintrp2a1(ges_q,qtmp,dlat,dlon,dtime,hrdifsig,& nsig,mype,nfldsig) call tintrp2a1(ges_u,utmp,dlat,dlon,dtime,hrdifsig,& From 0fe60bb97cbeca8da20d84b89a85272ea795bf4d Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Thu, 10 Oct 2024 15:55:04 -0500 Subject: [PATCH 106/109] Fix virtual temperature --- src/gsi/setupt.f90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/gsi/setupt.f90 b/src/gsi/setupt.f90 index 1085311303..0fd4691386 100644 --- a/src/gsi/setupt.f90 +++ b/src/gsi/setupt.f90 @@ -610,6 +610,8 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav prsltmp2 = exp(prsltmp) call tintrp2a1(ges_prsi,prsitmp,dlat,dlon,dtime,hrdifsig,& nsig+1,mype,nfldsig) + call tintrp2a1(ges_tv,tvtmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) call tintrp2a1(ges_tsen,ttmp,dlat,dlon,dtime,hrdifsig,& nsig,mype,nfldsig) call tintrp2a1(ges_q,qtmp,dlat,dlon,dtime,hrdifsig,& @@ -741,6 +743,8 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav nsig+1,mype,nfldsig) call tintrp2a1(ges_tsen,ttmp,dlat,dlon,dtime,hrdifsig,& nsig,mype,nfldsig) + call tintrp2a1(ges_tv,tvtmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) call tintrp2a1(ges_q,qtmp,dlat,dlon,dtime,hrdifsig,& nsig,mype,nfldsig) call tintrp2a1(ges_u,utmp,dlat,dlon,dtime,hrdifsig,& From bfbca87ec0866ec592272ae348caf37a7bb13237 Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Thu, 17 Oct 2024 15:08:52 -0500 Subject: [PATCH 107/109] Fix time window --- src/gsi/read_prepbufr.f90 | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index bed3b31db2..d838db9472 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -1156,8 +1156,11 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if (l4dvar.or.l4densvar) then if ((t4dvwinlen) .and. .not.driftl) cycle loop_readsb ! outside time window else - if((real(abs(time)) > real(ctwind(nc)) .or. real(abs(time)) > real(twindin)) & - .and. .not. driftl)cycle loop_readsb ! outside time window + ! Fix to ensure end of time window is NOT included + if ((real(abs(time)) > real(ctwind(nc)) .or. real(time)==real(three) .or. & + real(abs(time)) > real(twindin)) .and. .not. driftl)cycle loop_readsb ! outside time window +! if((real(abs(time)) > real(ctwind(nc)) .or. real(abs(time)) > real(twindin)) & +! .and. .not. driftl)cycle loop_readsb ! outside time window endif timex=time @@ -1918,7 +1921,10 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if (l4dvar.or.l4densvar) then if (t4dvwinlen) cycle LOOP_K_LEVS else - if (real(abs(time))>real(ctwind(nc)) .or. real(abs(time))>real(twindin)) cycle LOOP_K_LEVS + ! Fix to ensure end of time window is NOT included + if ((real(abs(time)) > real(ctwind(nc)) .or. real(time)==real(three) .or. & + real(abs(time)) > real(twindin)) cycle LOOP_K_LEVS ! outside time window +! if (real(abs(time))>real(ctwind(nc)) .or. real(abs(time))>real(twindin)) cycle LOOP_K_LEVS endif end if From 28bf87db767040497aa9bfc4c46004c83609f4a2 Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Thu, 17 Oct 2024 15:11:27 -0500 Subject: [PATCH 108/109] Add AVHRR cloud fraction --- src/gsi/read_iasi.f90 | 8 ++++++-- src/gsi/setuprad.f90 | 7 +++++++ 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/src/gsi/read_iasi.f90 b/src/gsi/read_iasi.f90 index edd7a9b50e..362d7257a4 100644 --- a/src/gsi/read_iasi.f90 +++ b/src/gsi/read_iasi.f90 @@ -118,7 +118,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& use crtm_spccoeff, only: sc,crtm_spccoeff_load,crtm_spccoeff_destroy use gridmod, only: diagnostic_reg,regional,nlat,nlon,& tll2xy,txy2ll,rlats,rlons - use constants, only: zero,deg2rad,rad2deg,r60inv,one,ten,r100 + use constants, only: zero,deg2rad,rad2deg,r60inv,one,ten,r100,r_missing use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen use calc_fov_crosstrk, only: instrument_init, fov_check, fov_cleanup use deter_sfc_mod, only: deter_sfc,deter_sfc_fov @@ -690,6 +690,9 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& if (iret == 7 .and. cloud_frac(1) <= r100 .and. cloud_frac(1) >= zero) then pred = r100 - cloud_frac(1) cloud_info = .true. + cloud_frac = cloud_frac/r100 + else + cloud_frac = r_missing endif crit1 = crit1 + pred @@ -913,7 +916,8 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& data_all(18,itx)= ts(3) ! snow skin temperature data_all(19,itx)= tsavg ! average skin temperature data_all(20,itx)= vty ! vegetation type - data_all(21,itx)= vfr ! vegetation fraction + !data_all(21,itx)= vfr ! vegetation fraction + data_all(21,itx)= cloud_frac(1) ! temporary place for cloud fraction data_all(22,itx)= sty ! soil type data_all(23,itx)= stp ! soil temperature data_all(24,itx)= sm ! soil moisture diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 index 17d0b14f8c..6ad39ce6ad 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -366,6 +366,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& real(r_kind) si_obs,si_fg ! real(r_kind) si_mean real(r_kind) total_cloud_cover + real(r_kind) cloud_frac logical cao_flag logical hirs2,msu,goessndr,hirs3,hirs4,hirs,amsua,amsub,airs,hsb,goes_img,ahi,mhs,abi @@ -840,6 +841,11 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& zsges=data_s(izz,n) nadir = nint(data_s(iscan_pos,n)) pangs = data_s(iszen_ang,n) + if (iasi) then + cloud_frac = data_s(21,n) + else + cloud_frac = r_missing + end if ! Extract warm load temperatures ! wltm1 = data_s(isty,n) ! wltm2 = data_s(istp,n) @@ -2662,6 +2668,7 @@ subroutine contents_netcdf_diag_(odiags,idv,iob) call nc_diag_metadata_to_single("Land_Fraction",surface(1)%land_coverage ) ! fractional coverage by land call nc_diag_metadata_to_single("Ice_Fraction",surface(1)%ice_coverage ) ! fractional coverage by ice call nc_diag_metadata_to_single("Snow_Fraction",surface(1)%snow_coverage ) ! fractional coverage by snow + call nc_diag_metadata_to_single("fractionOfClearPixelsInFOV",cloud_frac ) ! fractional coverage by snow if(.not. retrieval)then call nc_diag_metadata_to_single("Water_Temperature",surface(1)%water_temperature ) ! surface temperature over water (K) From fe5f1d2c1d5477b78397c3ff43690d8cacc5d00f Mon Sep 17 00:00:00 2001 From: Andrew Collard Date: Thu, 17 Oct 2024 15:16:43 -0500 Subject: [PATCH 109/109] fic paren --- src/gsi/read_prepbufr.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index d838db9472..7dc1c463bf 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -1922,7 +1922,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if (t4dvwinlen) cycle LOOP_K_LEVS else ! Fix to ensure end of time window is NOT included - if ((real(abs(time)) > real(ctwind(nc)) .or. real(time)==real(three) .or. & + if (real(abs(time)) > real(ctwind(nc)) .or. real(time)==real(three) .or. & real(abs(time)) > real(twindin)) cycle LOOP_K_LEVS ! outside time window ! if (real(abs(time))>real(ctwind(nc)) .or. real(abs(time))>real(twindin)) cycle LOOP_K_LEVS endif