From a95d8ec27d7b8f249d9269d93bc9935cf2a3caa2 Mon Sep 17 00:00:00 2001 From: David Dowell Date: Mon, 10 Jul 2023 15:44:12 +0000 Subject: [PATCH 01/23] Trying to add new FED observation operator. --- src/gsi/setupfed.f90 | 1152 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1152 insertions(+) create mode 100644 src/gsi/setupfed.f90 diff --git a/src/gsi/setupfed.f90 b/src/gsi/setupfed.f90 new file mode 100644 index 0000000000..6432791443 --- /dev/null +++ b/src/gsi/setupfed.f90 @@ -0,0 +1,1152 @@ +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, ges_prsl, ges_tsen, geop_hgtl + use gridmod, only: lat2, lon2 + use gridmod, only: nsig, get_ij,get_ijk,regional,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: rad2deg,deg2rad,r60,tiny_r_kind,cg_term,huge_single + use constants, only: r10,r100,r1000 + use constants, only: rd,grav,tpwcon + use qcmod, only: npres_print,ptop,pbot,ptopq,pbotq,dfact,dfact1 + use jfunc, only: jiter,last,jiterstart,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' + + real(r_kind) :: Cs_tmp, Cg_tmp ! temporary coefficients for check-up + +! 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,denom + real(r_kind) jqg_num,jqg + real(r_kind) wgt_dry, wgt_wet + real(r_kind) jqg_num_dry, jqg_num_wet + 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) qgges,rhoges + real(r_kind) Ze,rdBZ,presw,fednoise,fednoise_runits + real(r_kind) Ze_orig, Zer, Zes, Zeg + real(r_kind) Zeg_dry, Zeg_wet + real(r_kind) errinv_input,errinv_adjst,errinv_final + real(r_kind) err_input,err_adjst,err_final + real(r_kind) qgexp + 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) :: P1D,T1D,Q1D,RHO + real(r_kind) :: qges,tsenges ! used to calculate tv - virtual temperature + real(r_kind) :: lnprslges ! use log(p) for vertical interpolation + real(r_kind) :: qg_min + 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,nii,jj,im,jm,km + integer(i_kind) mm1,k2,isli + integer(i_kind) jsig,ikxx,nn,ibin,ioff,ioff0 + integer(i_kind) ier,ilat,ilon,ihgt,ifedob,ikx,itime,iuse + integer(i_kind) ielev,id,itilt,iazm,ilone,ilate,irange + integer(i_kind) ier2,ifednoise,it,istatus + integer(i_kind) ier_b + integer(i_kind) ijk + + integer(i_kind) i4,j4,k4,n4 + 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 + integer(i_kind) nguess + + 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) + real(r_kind) wrange + integer(i_kind) numequal,numnotequal,kminmin,kmaxmax,istat + + logical:: in_curbin, in_anybin + + 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) :: ibgn, iend, jbgn, jend, ips,ipe,jps,jpe,itmp,jtmp,ktmp + character(256) :: binfilename + + integer(i_kind), parameter :: ntimesfed=1 + character(256) ::fedfilename + integer(i_kind),parameter :: nxfed=99, nyfed=99, nzfed=1, nfldfed=3 + real(4) :: a(ntimesfed,nfldfed,nzfed,nyfed,nxfed) + real(4) :: gga(ntimesfed,nfldfed,nzfed,nyfed,nxfed) + integer(i_kind) irec1, irec2, irec3, irec4, itot + integer(i_kind) :: la, iobs, lt, nnnnn + real(r_kind),dimension(nobs) :: FEDMdiag,FEDMdiagTL + real(r_kind),dimension(nobs) :: FEDMdiag2D + integer(i_kind) :: npt + integer(i_kind) :: nobsfed + real(r_kind) :: dlat_earth,dlon_earth + logical :: outside + +! YPW added the next lines + logical :: l_set_oerr_ratio_fed=.False. + logical :: l_gpht2gmht = .True. + integer(i_kind) :: ncid,status,x_dimid,y_dimid,z_dimid,varid,x_varid,y_varid + integer(i_kind),dimension(3):: dimids + integer(i_kind),dimension(2):: dimids_2d + character(256) :: outfile + real(r_kind),dimension(nobs) :: dlatobs,dlonobs + real(r_kind),dimension(4):: wgrd + integer(i_kind),dimension(4):: jgrd + 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*,'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 + enddo !igx + enddo !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 +! write(6,*) 'maxval(geop_hgtl)=',maxval(geop_hgtl(:,:,:,it)) + write(6,*) 'maxval(ges_tsen)=',maxval(ges_tsen(:,:,:,it)) + write(6,*) 'maxval(FED)=',maxval(rp) + write(6,*) 'ges_prsi',ges_prsi(100,100,1,1),ges_prsi(100,100,nsig,1) + + + !============================================================================================ + + 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) +! print*,'i,mype,dlat,dlon,dlon8km,dlat8km',i,mype,dlat,dlon,dlon8km,dlat8km,& +! dlon_earth,dlat_earth,dpres,data(ifedob,i) + + if (nobs_bins>1) then + ibin = NINT( dtime/hr_obsbin ) + 1 + else + ibin = 1 + endif + + 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) + endif + +! 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 + endif + 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) + + if (istat/=0) write(6,*)'MAKECOBS: allocate error for fedtail_dzg,istat=',istat + + 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%jqg = jqg ! for TL and ADJ + 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 + endif + enddo k_loop + endif + endif +!------------------------------------------------- + + 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 + endif + + my_head => null() + endif + +! 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 + endif + 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') + endif + endif + if(init_pass .and. mype == 0) then + write(66) ianldate + write(6,*)'SETUPFED: write time record to file ',& + trim(diag_file), ' ',ianldate + endif + +! 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 + print*,'For ps, proceed=',proceed + call gsi_metguess_get ('var::z' , ivar, istatus ) + proceed=proceed.and.ivar>0 + print*,'For z, proceed=',proceed + call gsi_metguess_get ('var::q' , ivar, istatus ) + proceed=proceed.and.ivar>0 + print*,'For q, proceed=',proceed +! 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 + print*,'For qs, proceed=',proceed + call gsi_metguess_get ('var::qg', ivar, istatus ) + proceed=proceed.and.ivar>0 + print*,'For qg, proceed=',proceed + call gsi_metguess_get ('var::qr', ivar, istatus ) + proceed=proceed.and.ivar>0 + print*,'For qr, proceed=',proceed +! if ( mphyopt == 108 ) then ! comment out by YPW +! proceed=proceed.and.ivar>0 ! comment out by YPW +! print*,'For qnr, proceed=',proceed ! comment out by YPW +! end if ! comment out by YPW + 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) + endif + 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 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! 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) + endif + 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 + 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) + if (istatus==0) then + if(allocated(ges_q))then + write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' + call stop2(999) + endif + 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 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif +! 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) +! endif +! 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 +! enddo +! else +! write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus +! call stop2(999) +! endif +! 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) + endif + 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)) + endif + + ges_qg(:,:,:,1)=rank3 + do ifld=2,nfldsig + call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus) + ges_qg(:,:,:,ifld)=rank3 + enddo + else + write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus + call stop2(999) + endif + else + write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& + nfldsig,size(gsi_metguess_bundle) + call stop2(999) + endif + 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 + endif + 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 ) + endif + 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 + endif + + 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 + endif + enddo + do jj=1,miter+1 + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%nldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%tldepart(jj) + enddo + do jj=1,miter + ioff=ioff+1 + rdiagbuf(ioff,ii) = odiag%obssen(jj) + enddo + endif + + 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) ) + 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(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 + 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 ) + endif + + 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 From 0c2780e25a0423e4e6fb38285020162c4e15575d Mon Sep 17 00:00:00 2001 From: David Dowell Date: Tue, 11 Jul 2023 01:33:12 +0000 Subject: [PATCH 02/23] updates for adding FED observations and observation operator to GSI observer --- src/gsi/gsi_fedOper.F90 | 185 ++++++++++++++ src/gsi/m_fedNode.F90 | 265 ++++++++++++++++++++ src/gsi/read_fed.f90 | 527 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 977 insertions(+) create mode 100644 src/gsi/gsi_fedOper.F90 create mode 100644 src/gsi/m_fedNode.F90 create mode 100644 src/gsi/read_fed.f90 diff --git a/src/gsi/gsi_fedOper.F90 b/src/gsi/gsi_fedOper.F90 new file mode 100644 index 0000000000..a306868f77 --- /dev/null +++ b/src/gsi/gsi_fedOper.F90 @@ -0,0 +1,185 @@ +module gsi_fedOper +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_fedOper +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-08-10 +! +! abstract: an obOper extension for fedNode type +! +! program history log: +! 2023-04-10 D. Dowell - moved diag_fed and its description here from +! obsmod. +! +! 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 intfedmod, only: intjo => intfed + 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 + +! 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 + 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 + +! 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/m_fedNode.F90 b/src/gsi/m_fedNode.F90 new file mode 100644 index 0000000000..f42503df19 --- /dev/null +++ b/src/gsi/m_fedNode.F90 @@ -0,0 +1,265 @@ +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(td_ob_type),pointer :: llpoint => NULL() + 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) :: time ! observation time in sec + 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 +! logical :: luse ! flag indicating if ob is used in pen. + integer(i_kind) :: k1 ! level of errtable 1-33 + integer(i_kind) :: kx ! ob type + integer(i_kind) :: ij(8) ! horizontal locations + +! integer(i_kind) :: idv,iob ! device id and obs index for sorting + real (r_kind) :: dlev ! reference to the vertical grid + !real (r_kind) :: elat, elon ! earth lat-lon for redistribution + !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution + contains + procedure,nopass:: mytype + procedure:: setHop => obsNode_setHop_ + procedure:: xread => obsNode_xread_ + procedure:: xwrite => obsNode_xwrite_ + procedure:: isvalid => obsNode_isvalid_ + procedure:: gettlddp => gettlddp_ + + ! procedure, nopass:: headerRead => obsHeader_read_ + ! procedure, nopass:: headerWrite => obsHeader_write_ + ! procedure:: init => obsNode_init_ + ! procedure:: clean => obsNode_clean_ + 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" + +!#define CHECKSUM_VERBOSE +!#define DEBUG_TRACE +#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 +! character(len=*),parameter:: myname_=MYNAME//"::typecast_" + ptr_ => null() + if(.not.associated(aNode)) return + select type(aNode) + type is(fedNode) + ptr_ => aNode +! class default +! call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) + 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%fedpertb , & + 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%fedpertb , & + 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/read_fed.f90 b/src/gsi/read_fed.f90 new file mode 100644 index 0000000000..79c6e2a726 --- /dev/null +++ b/src/gsi/read_fed.f90 @@ -0,0 +1,527 @@ +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,rad2deg,deg2rad + use convinfo, only: nconvtype,ctwind,cgross,cermax,cermin,cvar_b,cvar_pg, & + ncmiter,ncgroup,ncnumgrp,icuse,ictype,icsubtype,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,time_window + + 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 + + real(r_kind) :: maxfed + 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,numobsa,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) :: idate5(5), sec70,mins_an,mins_ob + integer(i_kind) :: varID, ncdfID, status + character(4) :: idate5s(5) + 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. 90 ) 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 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 +! +! From a54b475030431523a443a5028c523d3784615cf5 Mon Sep 17 00:00:00 2001 From: David Dowell Date: Tue, 11 Jul 2023 01:36:05 +0000 Subject: [PATCH 03/23] updates to add FED observations and observation operator to GSI observer --- 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_obsNodeTypeManager.F90 | 7 +++ src/gsi/m_rhs.F90 | 2 + src/gsi/obsmod.F90 | 15 +++++-- src/gsi/read_obs.F90 | 14 +++++- src/gsi/setuprhsall.f90 | 3 +- src/gsi/statsconv.f90 | 72 +++++++++++++++++++++++++++++-- 10 files changed, 122 insertions(+), 13 deletions(-) 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 ea306953c4..f7aef2a026 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 @@ -388,6 +392,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 @@ -485,6 +490,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() @@ -600,6 +606,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_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_obs.F90 b/src/gsi/read_obs.F90 index 9017c498c2..ee0209639b 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 @@ -910,7 +911,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' @@ -1295,6 +1297,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 @@ -1632,6 +1638,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/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..c72adf34e7 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 f9433d8bc69fa35e09a26b6325b05205fff73754 Mon Sep 17 00:00:00 2001 From: David Dowell Date: Tue, 22 Aug 2023 14:26:08 +0000 Subject: [PATCH 04/23] Updated code, with changes suggested by reviewers. --- src/gsi/gsi_fedOper.F90 | 17 ++----- src/gsi/m_fedNode.F90 | 21 +------- src/gsi/read_fed.f90 | 10 ++-- src/gsi/setupfed.f90 | 110 ++++++++++++++++++++-------------------- src/gsi/statsconv.f90 | 2 +- 5 files changed, 66 insertions(+), 94 deletions(-) diff --git a/src/gsi/gsi_fedOper.F90 b/src/gsi/gsi_fedOper.F90 index a306868f77..b2b2400ff0 100644 --- a/src/gsi/gsi_fedOper.F90 +++ b/src/gsi/gsi_fedOper.F90 @@ -2,15 +2,13 @@ module gsi_fedOper !$$$ subprogram documentation block ! . . . . ! subprogram: module gsi_fedOper -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2018-08-10 ! ! abstract: an obOper extension for fedNode type ! ! program history log: -! 2023-04-10 D. Dowell - moved diag_fed and its description here from -! obsmod. +! 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 ! @@ -130,7 +128,6 @@ 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 @@ -148,14 +145,9 @@ 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 @@ -177,9 +169,6 @@ 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/m_fedNode.F90 b/src/gsi/m_fedNode.F90 index f42503df19..84a319cd12 100644 --- a/src/gsi/m_fedNode.F90 +++ b/src/gsi/m_fedNode.F90 @@ -36,27 +36,21 @@ module m_fedNode public:: fedNode type,extends(obsNode):: fedNode - !type(td_ob_type),pointer :: llpoint => NULL() 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) :: time ! observation time in sec 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 -! logical :: luse ! flag indicating if ob is used in pen. integer(i_kind) :: k1 ! level of errtable 1-33 integer(i_kind) :: kx ! ob type integer(i_kind) :: ij(8) ! horizontal locations -! integer(i_kind) :: idv,iob ! device id and obs index for sorting real (r_kind) :: dlev ! reference to the vertical grid - !real (r_kind) :: elat, elon ! earth lat-lon for redistribution - !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution contains procedure,nopass:: mytype procedure:: setHop => obsNode_setHop_ @@ -65,10 +59,6 @@ module m_fedNode procedure:: isvalid => obsNode_isvalid_ procedure:: gettlddp => gettlddp_ - ! procedure, nopass:: headerRead => obsHeader_read_ - ! procedure, nopass:: headerWrite => obsHeader_write_ - ! procedure:: init => obsNode_init_ - ! procedure:: clean => obsNode_clean_ end type fedNode public:: fedNode_typecast @@ -81,8 +71,6 @@ module m_fedNode character(len=*),parameter:: MYNAME="m_fedNode" -!#define CHECKSUM_VERBOSE -!#define DEBUG_TRACE #include "myassert.H" #include "mytrace.H" contains @@ -92,14 +80,11 @@ function typecast_(aNode) result(ptr_) implicit none type(fedNode),pointer:: ptr_ class(obsNode),pointer,intent(in):: aNode -! character(len=*),parameter:: myname_=MYNAME//"::typecast_" ptr_ => null() if(.not.associated(aNode)) return select type(aNode) - type is(fedNode) - ptr_ => aNode -! class default -! call die(myname_,'unexpected type, aNode%mytype() =',aNode%mytype()) + type is(fedNode) + ptr_ => aNode end select return end function typecast_ @@ -171,7 +156,6 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) aNode%b , & aNode%pg , & aNode%jb , & - ! aNode%fedpertb , & aNode%k1 , & aNode%kx , & aNode%dlev , & @@ -210,7 +194,6 @@ subroutine obsNode_xwrite_(aNode,junit,jstat) aNode%b , & aNode%pg , & aNode%jb , & - ! aNode%fedpertb , & aNode%k1 , & aNode%kx , & aNode%dlev , & diff --git a/src/gsi/read_fed.f90 b/src/gsi/read_fed.f90 index 79c6e2a726..849f1b603d 100644 --- a/src/gsi/read_fed.f90 +++ b/src/gsi/read_fed.f90 @@ -370,8 +370,8 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) allocate(cdata_out(nreal,ndata)) ! ! - DO i=1,numfed - DO k=1,maxlvl + 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 @@ -381,7 +381,7 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) write(6,*) ' ------- check max and min value of OBS: bufr fed -------' write(6,*) ' level maxval(fed) minval(fed)' - DO k=1,maxlvl + do k=1,maxlvl write(6,*) k,maxval(fed3d_column(k+2,:)),minval(fed3d_column(k+2,:)) end do @@ -392,8 +392,8 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) kint_maxloc=-1 fed_max=-999.99 ndata2=0 - DO i=1,numfed - DO k=1,maxlvl + 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) diff --git a/src/gsi/setupfed.f90 b/src/gsi/setupfed.f90 index 6432791443..350a2a68ec 100644 --- a/src/gsi/setupfed.f90 +++ b/src/gsi/setupfed.f90 @@ -193,26 +193,26 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa !------------------------------------------------! - integer(i_kind) :: ibgn, iend, jbgn, jend, ips,ipe,jps,jpe,itmp,jtmp,ktmp + integer(i_kind) :: ibgn, iend, jbgn, jend, ips,ipe,jps,jpe,itmp,jtmp,ktmp character(256) :: binfilename integer(i_kind), parameter :: ntimesfed=1 - character(256) ::fedfilename - integer(i_kind),parameter :: nxfed=99, nyfed=99, nzfed=1, nfldfed=3 + character(256) :: fedfilename + integer(i_kind),parameter :: nxfed=99, nyfed=99, nzfed=1, nfldfed=3 real(4) :: a(ntimesfed,nfldfed,nzfed,nyfed,nxfed) real(4) :: gga(ntimesfed,nfldfed,nzfed,nyfed,nxfed) integer(i_kind) irec1, irec2, irec3, irec4, itot - integer(i_kind) :: la, iobs, lt, nnnnn + integer(i_kind) :: la, iobs, lt, nnnnn real(r_kind),dimension(nobs) :: FEDMdiag,FEDMdiagTL real(r_kind),dimension(nobs) :: FEDMdiag2D - integer(i_kind) :: npt - integer(i_kind) :: nobsfed - real(r_kind) :: dlat_earth,dlon_earth - logical :: outside + integer(i_kind) :: npt + integer(i_kind) :: nobsfed + real(r_kind) :: dlat_earth,dlon_earth + logical :: outside ! YPW added the next lines - logical :: l_set_oerr_ratio_fed=.False. - logical :: l_gpht2gmht = .True. + logical :: l_set_oerr_ratio_fed=.False. + logical :: l_gpht2gmht = .True. integer(i_kind) :: ncid,status,x_dimid,y_dimid,z_dimid,varid,x_varid,y_varid integer(i_kind),dimension(3):: dimids integer(i_kind),dimension(2):: dimids_2d @@ -341,8 +341,8 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa 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 - enddo !igx - enddo !jgy + end do !igx + end do !jgy end do !j end do !i end do !k @@ -419,7 +419,7 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa ibin = NINT( dtime/hr_obsbin ) + 1 else ibin = 1 - endif + end if IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin @@ -438,7 +438,7 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa miter = miter ) if(.not.associated(my_diag)) call die(myname, & 'obsdiagLList_nextNode(), create =',.not.lobsdiag_allocated) - endif + end if ! Interpolate terrain height(model elevation) to obs location. call tintrp2a11(ges_z,zsges,dlat,dlon,dtime,hrdifsig,& @@ -641,7 +641,7 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa term = exp_arg wgt = wgtlim rwgt = wgt/wgtlim - endif + end if valqc = -two*rat_err2*term ! print*,'Compute penalty terms' @@ -718,19 +718,19 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa if(presq > ptabl(k+1) .and. presq <= ptabl(k)) then my_head%k1=k exit k_loop - endif - enddo k_loop - endif - endif + 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 - endif + end if my_head => null() - endif + end if ! Save select output for diagnostic file if(.not.luse(i))write(6,*)' luse, mype',luse(i),mype @@ -743,7 +743,7 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa err_final = one/(ratio_errors*error) else err_final = huge_single - endif + end if errinv_input = huge_single errinv_adjst = huge_single errinv_final = huge_single @@ -775,13 +775,13 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa 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') - endif - endif + 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 - endif + end if ! call dtime_show(myname,'diagsave:fed',i_fed_ob_type) write(66)'fed',nchar,nreal,ii,mype,ioff0 @@ -849,17 +849,17 @@ subroutine init_vars_ if(allocated(ges_ps))then write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' call stop2(999) - endif + 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 - enddo + end do else write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus call stop2(999) - endif + end if ! get z ... varname='z' call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus) @@ -867,17 +867,17 @@ subroutine init_vars_ if(allocated(ges_z))then write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' call stop2(999) - endif + 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 - enddo + end do else write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus call stop2(999) - endif + end if ! get q ... varname='q' call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) @@ -885,17 +885,17 @@ subroutine init_vars_ if(allocated(ges_q))then write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' call stop2(999) - endif + 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 - enddo + end do else write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus call stop2(999) - endif + end if ! get tv ... ! varname='tv' ! call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) @@ -903,18 +903,18 @@ subroutine init_vars_ ! if(allocated(ges_tv))then ! write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' ! call stop2(999) -! endif +! 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 -! enddo +! end do ! else ! write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus ! call stop2(999) -! endif +! end if ! get qr ... ! get qg ... varname='qg' @@ -923,26 +923,26 @@ subroutine init_vars_ if(allocated(ges_qg))then write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' call stop2(999) - endif + 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)) - endif + 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 - enddo + end do else write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus call stop2(999) - endif + end if else write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',& nfldsig,size(gsi_metguess_bundle) call stop2(999) - endif + end if end subroutine init_vars_ subroutine init_netcdf_diag_ @@ -967,7 +967,7 @@ subroutine init_netcdf_diag_ 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 - endif + end if end if call nc_diag_init(diag_conv_file, append=append_diag) @@ -975,7 +975,7 @@ subroutine init_netcdf_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 ) - endif + end if end subroutine init_netcdf_diag_ subroutine contents_binary_diag_(odiag) type(obs_diag),pointer,intent(in):: odiag @@ -999,7 +999,7 @@ subroutine contents_binary_diag_(odiag) rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used) else rdiagbuf(12,ii) = -one - endif + end if rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (dBZ)**-1 @@ -1028,21 +1028,21 @@ subroutine contents_binary_diag_(odiag) rdiagbuf(ioff,ii) = one else rdiagbuf(ioff,ii) = -one - endif - enddo + end if + end do do jj=1,miter+1 ioff=ioff+1 rdiagbuf(ioff,ii) = odiag%nldepart(jj) - enddo + end do do jj=1,miter ioff=ioff+1 rdiagbuf(ioff,ii) = odiag%tldepart(jj) - enddo + end do do jj=1,miter ioff=ioff+1 rdiagbuf(ioff,ii) = odiag%obssen(jj) - enddo - endif + end do + end if end subroutine contents_binary_diag_ subroutine contents_netcdf_diag_(odiag) @@ -1068,7 +1068,7 @@ subroutine contents_netcdf_diag_(odiag) call nc_diag_metadata("Analysis_Use_Flag", sngl(one) ) else call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) ) - endif + end if call nc_diag_metadata("Errinv_Input", sngl(errinv_input) ) call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) ) @@ -1083,14 +1083,14 @@ subroutine contents_netcdf_diag_(odiag) obsdiag_iuse(jj) = one else obsdiag_iuse(jj) = -one - endif - enddo + 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 ) - endif + end if end subroutine contents_netcdf_diag_ diff --git a/src/gsi/statsconv.f90 b/src/gsi/statsconv.f90 index c72adf34e7..0da8606f24 100644 --- a/src/gsi/statsconv.f90 +++ b/src/gsi/statsconv.f90 @@ -1340,7 +1340,7 @@ subroutine statsconv(mype,& if(nread > 0)then if(first)then open(iout_fed) - else + else open(iout_fed,position='append') end if From d3e64d34e17733acaf22f4ba5d2e79558358e5f7 Mon Sep 17 00:00:00 2001 From: David Dowell Date: Wed, 23 Aug 2023 18:00:16 +0000 Subject: [PATCH 05/23] Bug fix requested by Guoqing Ge and Chunhua Zhou. --- src/gsi/constants.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/gsi/constants.f90 b/src/gsi/constants.f90 index b4cf775068..2d0d53a8ad 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=20 + integer(i_kind), parameter :: max_varname_length=60 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 From 9a997c05507bc822f5a5864f5057a89b10fa9977 Mon Sep 17 00:00:00 2001 From: Hongli Wang Date: Tue, 5 Sep 2023 16:58:21 +0000 Subject: [PATCH 06/23] Update subs read and setup FED and DBZ --- src/gsi/read_dbz_nc.f90 | 9 ++-- src/gsi/read_dbz_netcdf.f90 | 3 +- src/gsi/read_fed.f90 | 1 + src/gsi/setupdbz.f90 | 15 ++++--- src/gsi/setupfed.f90 | 88 ++++++++----------------------------- 5 files changed, 35 insertions(+), 81 deletions(-) diff --git a/src/gsi/read_dbz_nc.f90 b/src/gsi/read_dbz_nc.f90 index cddbd14de4..6c31caae75 100644 --- a/src/gsi/read_dbz_nc.f90 +++ b/src/gsi/read_dbz_nc.f90 @@ -74,6 +74,7 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no 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 @@ -452,7 +454,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,& @@ -490,7 +492,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) @@ -520,7 +522,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/read_dbz_netcdf.f90 b/src/gsi/read_dbz_netcdf.f90 index 6ea03afaff..d843c05b58 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 849f1b603d..129b1a57bd 100644 --- a/src/gsi/read_fed.f90 +++ b/src/gsi/read_fed.f90 @@ -402,6 +402,7 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) !-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 diff --git a/src/gsi/setupdbz.f90 b/src/gsi/setupdbz.f90 index 96f0378c52..043adc112a 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? diff --git a/src/gsi/setupfed.f90 b/src/gsi/setupfed.f90 index 350a2a68ec..cf6334e567 100644 --- a/src/gsi/setupfed.f90 +++ b/src/gsi/setupfed.f90 @@ -41,16 +41,16 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa 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, ges_prsl, ges_tsen, geop_hgtl + use guess_grids, only: ges_lnprsl, geop_hgtl use gridmod, only: lat2, lon2 - use gridmod, only: nsig, get_ij,get_ijk,regional,tll2xy + 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: rad2deg,deg2rad,r60,tiny_r_kind,cg_term,huge_single + use constants, only: deg2rad,r60,tiny_r_kind,cg_term,huge_single use constants, only: r10,r100,r1000 - use constants, only: rd,grav,tpwcon - use qcmod, only: npres_print,ptop,pbot,ptopq,pbotq,dfact,dfact1 - use jfunc, only: jiter,last,jiterstart,miter + 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 @@ -100,8 +100,6 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa real(r_kind),parameter:: D608=0.608_r_kind character(len=*),parameter:: myname='setupfed' - real(r_kind) :: Cs_tmp, Cg_tmp ! temporary coefficients for check-up - ! Declare external calls for code analysis external:: tintrp2a1 external:: tintrp2a11 @@ -112,10 +110,8 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa ! Declare local variables real(r_kind) rlow,rhgh,rsig - real(r_kind) dz,denom + real(r_kind) dz real(r_kind) jqg_num,jqg - real(r_kind) wgt_dry, wgt_wet - real(r_kind) jqg_num_dry, jqg_num_wet real(r_kind) dlnp,pobl,zob real(r_kind) sin2,termg,termr,termrg real(r_kind) psges,zsges @@ -129,13 +125,9 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa 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) qgges,rhoges - real(r_kind) Ze,rdBZ,presw,fednoise,fednoise_runits - real(r_kind) Ze_orig, Zer, Zes, Zeg - real(r_kind) Zeg_dry, Zeg_wet + 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) qgexp real(r_kind),dimension(nele,nobs):: data real(r_kind),dimension(lat2,lon2,nfldsig)::rp real(r_single),allocatable,dimension(:,:)::rdiagbuf @@ -145,29 +137,22 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa real(r_kind),allocatable,dimension(:,:,:,:) :: ges_qg,ges_qg_mask real(r_kind) :: presq - real(r_kind) :: P1D,T1D,Q1D,RHO - real(r_kind) :: qges,tsenges ! used to calculate tv - virtual temperature - real(r_kind) :: lnprslges ! use log(p) for vertical interpolation - real(r_kind) :: qg_min + 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,nii,jj,im,jm,km - integer(i_kind) mm1,k2,isli + 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,ihgt,ifedob,ikx,itime,iuse - integer(i_kind) ielev,id,itilt,iazm,ilone,ilate,irange - integer(i_kind) ier2,ifednoise,it,istatus - integer(i_kind) ier_b - integer(i_kind) ijk + integer(i_kind) ier,ilat,ilon,ifedob,ikx,itime,iuse + integer(i_kind) id,ilone,ilate + integer(i_kind) ier2 - integer(i_kind) i4,j4,k4,n4 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 - integer(i_kind) nguess character(8) station_id character(8),allocatable,dimension(:):: cdiagbuf @@ -179,11 +164,8 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa logical proceed equivalence(rstation_id,station_id) - real(r_kind) wrange - integer(i_kind) numequal,numnotequal,kminmin,kmaxmax,istat + integer(i_kind) numequal,numnotequal - logical:: in_curbin, in_anybin - type(fedNode),pointer:: my_head type(obs_diag),pointer:: my_diag type(obs_diags),pointer:: my_diagLL @@ -193,33 +175,18 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa !------------------------------------------------! - integer(i_kind) :: ibgn, iend, jbgn, jend, ips,ipe,jps,jpe,itmp,jtmp,ktmp - character(256) :: binfilename + integer(i_kind) :: itmp,jtmp integer(i_kind), parameter :: ntimesfed=1 - character(256) :: fedfilename integer(i_kind),parameter :: nxfed=99, nyfed=99, nzfed=1, nfldfed=3 - real(4) :: a(ntimesfed,nfldfed,nzfed,nyfed,nxfed) - real(4) :: gga(ntimesfed,nfldfed,nzfed,nyfed,nxfed) - integer(i_kind) irec1, irec2, irec3, irec4, itot - integer(i_kind) :: la, iobs, lt, nnnnn real(r_kind),dimension(nobs) :: FEDMdiag,FEDMdiagTL - real(r_kind),dimension(nobs) :: FEDMdiag2D integer(i_kind) :: npt - integer(i_kind) :: nobsfed real(r_kind) :: dlat_earth,dlon_earth - logical :: outside ! YPW added the next lines logical :: l_set_oerr_ratio_fed=.False. logical :: l_gpht2gmht = .True. - integer(i_kind) :: ncid,status,x_dimid,y_dimid,z_dimid,varid,x_varid,y_varid - integer(i_kind),dimension(3):: dimids - integer(i_kind),dimension(2):: dimids_2d - character(256) :: outfile real(r_kind),dimension(nobs) :: dlatobs,dlonobs - real(r_kind),dimension(4):: wgrd - integer(i_kind),dimension(4):: jgrd integer(i_kind):: ngx,ngy,igx,jgy real(r_kind):: dx_m, dy_m @@ -318,7 +285,7 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa ngy = 2 dx_m = 3000. dy_m = 3000. - print*,'Operator start here!,ngx=',ngx,'ngy=',ngy + print*,'FED Operator start here!,ngx=',ngx,'ngy=',ngy rp=zero print*, 'mype = ', mype @@ -377,10 +344,6 @@ 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 -! write(6,*) 'maxval(geop_hgtl)=',maxval(geop_hgtl(:,:,:,it)) - write(6,*) 'maxval(ges_tsen)=',maxval(ges_tsen(:,:,:,it)) - write(6,*) 'maxval(FED)=',maxval(rp) - write(6,*) 'ges_prsi',ges_prsi(100,100,1,1),ges_prsi(100,100,nsig,1) !============================================================================================ @@ -412,8 +375,6 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa dlon_earth = data(ilone,i) !the lontitude and latitude on the obs pts. dlat_earth = data(ilate,i) ! geometric hgh (hges --> zges below) -! print*,'i,mype,dlat,dlon,dlon8km,dlat8km',i,mype,dlat,dlon,dlon8km,dlat8km,& -! dlon_earth,dlat_earth,dpres,data(ifedob,i) if (nobs_bins>1) then ibin = NINT( dtime/hr_obsbin ) + 1 @@ -693,14 +654,11 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa my_head%elat= data(ilate,i) my_head%elon= data(ilone,i) - if (istat/=0) write(6,*)'MAKECOBS: allocate error for fedtail_dzg,istat=',istat - my_head%dlev= dpres - call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij) + 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%jqg = jqg ! for TL and ADJ my_head%time = dtime my_head%b = cvar_b(ikx) my_head%pg = cvar_pg(ikx) @@ -806,28 +764,18 @@ subroutine check_vars_ (proceed) ! Check to see if required guess fields are available call gsi_metguess_get ('var::ps', ivar, istatus ) proceed=ivar>0 - print*,'For ps, proceed=',proceed call gsi_metguess_get ('var::z' , ivar, istatus ) proceed=proceed.and.ivar>0 - print*,'For z, proceed=',proceed call gsi_metguess_get ('var::q' , ivar, istatus ) proceed=proceed.and.ivar>0 - print*,'For q, proceed=',proceed ! 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 - print*,'For qs, proceed=',proceed call gsi_metguess_get ('var::qg', ivar, istatus ) proceed=proceed.and.ivar>0 - print*,'For qg, proceed=',proceed call gsi_metguess_get ('var::qr', ivar, istatus ) proceed=proceed.and.ivar>0 - print*,'For qr, proceed=',proceed -! if ( mphyopt == 108 ) then ! comment out by YPW -! proceed=proceed.and.ivar>0 ! comment out by YPW -! print*,'For qnr, proceed=',proceed ! comment out by YPW -! end if ! comment out by YPW end subroutine check_vars_ From 02fcd482c001a56c74544e18f5e017f3ab09c78e Mon Sep 17 00:00:00 2001 From: Hongli Wang Date: Thu, 7 Sep 2023 18:16:52 +0000 Subject: [PATCH 07/23] Add Fed into Jo callucation that works --- src/gsi/gsi_fedOper.F90 | 15 ++- src/gsi/gsi_files.cmake | 2 + src/gsi/gsimod.F90 | 4 +- src/gsi/intfed.f90 | 194 +++++++++++++++++++++++++++++++++++++++ src/gsi/obsmod.F90 | 5 +- src/gsi/stpfed.f90 | 180 ++++++++++++++++++++++++++++++++++++ src/gsi/wrf_vars_mod.f90 | 5 +- 7 files changed, 397 insertions(+), 8 deletions(-) create mode 100644 src/gsi/intfed.f90 create mode 100644 src/gsi/stpfed.f90 diff --git a/src/gsi/gsi_fedOper.F90 b/src/gsi/gsi_fedOper.F90 index b2b2400ff0..970d8ba9f0 100644 --- a/src/gsi/gsi_fedOper.F90 +++ b/src/gsi/gsi_fedOper.F90 @@ -6,9 +6,9 @@ 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 +! 2023-04-10 D. Dowell - moved diag_fed and its description here from +! obsmod. +! 2023-08-24 H. Wang - Turned on intfed and stpfed ! ! input argument list: see Fortran 90 style document below ! @@ -128,6 +128,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 +146,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 +175,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/gsimod.F90 b/src/gsi/gsimod.F90 index de19c85fab..da679a9a2d 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -25,7 +25,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,if_use_w_vr,& + rmesh_vr,zmesh_dbz,zmesh_vr,if_vterminal, if_model_dbz,if_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 @@ -768,7 +768,7 @@ module gsimod 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,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,& diff --git a/src/gsi/intfed.f90 b/src/gsi/intfed.f90 new file mode 100644 index 0000000000..b12598efe2 --- /dev/null +++ b/src/gsi/intfed.f90 @@ -0,0 +1,194 @@ +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 +! prgmmr: derber org: np23 date: 1991-02-26 +! +! abstract: apply observation operator for radar winds +! with nonlinear qc operator +! +! program history log: +! 2023-08-24 H.Wang - modified based on intdbz.f90 +! - intfedmod is based on intqmod, and intrwmod +! - 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 gridmod, only: wrf_mass_regional, fv3_regional + use jfunc, only: jiter + use gsi_bundlemod, only: gsi_bundle + use gsi_bundlemod, only: gsi_bundlegetpointer + use gsi_4dvar, only: ladtest_obs +! use directDA_radaruse_mod, only: l_use_fed_directDA + use radarz_cst, only: mphyopt + 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,valqr,valqs,valqg,valfed,valqnr + real(r_kind) cg_fed,p0,grad,wnotgross,wgross,pg_fed + real(r_kind) qrtl,qstl, qgtl, qnrtl + real(r_kind),pointer,dimension(:) :: sqr,sqs,sqg,sfed,sqnr + real(r_kind),pointer,dimension(:) :: rqr,rqs,rqg,rfed,rqnr + 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 + print*,"FED_ADJ= ",grad,w1,w2,w3,w4 + end if + + endif + + !fedptr => fedptr%llpoint + fedptr => fedNode_nextcast(fedptr) + end do + return +end subroutine intfed_ + +end module intfedmod diff --git a/src/gsi/obsmod.F90 b/src/gsi/obsmod.F90 index a059586e67..5f7548ffe3 100644 --- a/src/gsi/obsmod.F90 +++ b/src/gsi/obsmod.F90 @@ -473,7 +473,7 @@ 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_model_fed, inflate_obserr, if_vrobs_raw, if_use_w_vr, l2rwthin public :: doradaroneob,oneoblat,oneoblon public :: oneobddiff,oneobvalue,oneobheight,oneobradid @@ -622,7 +622,7 @@ module obsmod logical :: ta2tb logical :: doradaroneob - logical :: vr_dealisingopt, if_vterminal, if_model_dbz, inflate_obserr, if_vrobs_raw, if_use_w_vr, l2rwthin + logical :: vr_dealisingopt, if_vterminal, if_model_dbz,if_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,6 +755,7 @@ subroutine init_obsmod_dflts if_vrobs_raw=.false. if_use_w_vr=.true. if_model_dbz=.false. + if_model_fed=.false. inflate_obserr=.false. whichradar="KKKK" diff --git a/src/gsi/stpfed.f90 b/src/gsi/stpfed.f90 new file mode 100644 index 0000000000..70670b1914 --- /dev/null +++ b/src/gsi/stpfed.f90 @@ -0,0 +1,180 @@ +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 +! +! abstract: calculate penalty and contribution to stepsize from radar reflectivity +! +! program history log: +! 1991-02-26 derber +! 1999-11-22 yang +! 2004-07-29 treadon - add only to module use, add intent in/out +! 2004-10-07 parrish - add nonlinear qc option +! 2016-09-xx G.Zhao - fed +! 2019-07-11 todling - introduced wrf_vars_mod +! +! 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) valqr, valqs, valqg, valqnr, valfed + real(r_kind) qrcur, qscur, qgcur, qnrcur, 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(:) :: sqr,sqs,sqg,sqnr,sfed + real(r_kind),pointer,dimension(:) :: rqr,rqs,rqg,rqnr,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 + print*,"FED_stp: ",kk,out(kk) + do kk=2,nstep + out(kk) = out(kk)+(pen(kk)-pen(1))*fedptr%raterr2 + print*,"FED_stp: ",kk,out(kk) + 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..70a14cf7be 100644 --- a/src/gsi/wrf_vars_mod.f90 +++ b/src/gsi/wrf_vars_mod.f90 @@ -46,8 +46,9 @@ 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 @@ -55,10 +56,12 @@ subroutine init_wrf_vars w_exist=.false. dbz_exist=.false. +fed_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 end subroutine init_wrf_vars From 77996067ce1fb74f918315cc9f0f3165d67143c5 Mon Sep 17 00:00:00 2001 From: Hongli Wang Date: Thu, 14 Sep 2023 18:18:52 +0000 Subject: [PATCH 08/23] 1. read in fed from background and ens files 2. TL/AD related codes test and debug 3. refine codes --- src/gsi/control2model.f90 | 3 + src/gsi/control2model_ad.f90 | 3 + src/gsi/control2state.f90 | 7 ++ src/gsi/cplr_get_fv3_regional_ensperts.f90 | 140 ++++++++++++++++----- src/gsi/ensctl2model.f90 | 4 + src/gsi/ensctl2model_ad.f90 | 5 +- src/gsi/ensctl2state.f90 | 4 + src/gsi/ensctl2state_ad.f90 | 11 ++ src/gsi/gsi_rfv3io_mod.f90 | 81 ++++++++---- src/gsi/intfed.f90 | 2 +- src/gsi/read_fed.f90 | 2 +- src/gsi/setupdbz.f90 | 2 +- src/gsi/stpfed.f90 | 4 +- src/gsi/stpjo.f90 | 3 +- 14 files changed, 208 insertions(+), 63 deletions(-) diff --git a/src/gsi/control2model.f90 b/src/gsi/control2model.f90 index ec628afe4f..4455eebd67 100644 --- a/src/gsi/control2model.f90 +++ b/src/gsi/control2model.f90 @@ -241,6 +241,9 @@ subroutine control2model(xhat,sval,bval) enddo end if end if +! Add fed + call gsi_bundlegetpointer (sval(jj),'fed',sv_rank3,istatus) + call gsi_bundlegetvar (wbundle, 'fed',sv_rank3,istatus) ! destroy temporary bundle call gsi_bundledestroy(wbundle,istatus) diff --git a/src/gsi/control2model_ad.f90 b/src/gsi/control2model_ad.f90 index 639bf87ffb..fd9573a9df 100644 --- a/src/gsi/control2model_ad.f90 +++ b/src/gsi/control2model_ad.f90 @@ -220,6 +220,9 @@ subroutine control2model_ad(rval,bval,grad) enddo end if end if +! Add fed + call gsi_bundlegetpointer (rval(jj),'fed',rv_rank3,istatus) + call gsi_bundleputvar (wbundle, 'fed',rv_rank3,istatus) ! Same one-to-one map for chemistry-vars; take care of them together do ic=1,ngases diff --git a/src/gsi/control2state.f90 b/src/gsi/control2state.f90 index f2d8849ce0..d9bcc9858c 100644 --- a/src/gsi/control2state.f90 +++ b/src/gsi/control2state.f90 @@ -282,6 +282,10 @@ subroutine control2state(xhat,sval,bval) endif enddo end if +! Add fed + call gsi_bundlegetpointer (sval(jj),'fed',sv_rank3,istatus) + call gsi_bundlegetvar (wbundle, 'fed',sv_rank3,istatus) + call gsi_bundlegetpointer (sval(jj),'ps' ,sv_ps, istatus) call gsi_bundlegetvar ( wbundle, 'ps' , sv_ps, istatus ) @@ -730,6 +734,9 @@ subroutine control2state_ad(rval,bval,grad) endif enddo end if +! Add fed + call gsi_bundlegetpointer (rval(jj),'fed',rv_rank3,istatus) + call gsi_bundleputvar (wbundle, 'fed',rv_rank3,istatus) ! Calculate sensible temperature if(do_tv_to_tsen) call tv_to_tsen_ad(cv_t,rv_q,rv_tsen) diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 index 5a3e72970d..e031db77fc 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() @@ -325,18 +325,30 @@ 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 + if ( .not. if_model_dbz .and. .not.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) 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_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, & + if ( if_model_dbz .and. if_model_fed) then + allocate(gg_dbz(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) + allocate(gg_fed(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,g_fed=gg_fed) + elseif ( if_model_dbz ) then + allocate(gg_dbz(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) + elseif ( if_model_fed ) then + allocate(gg_fed(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_fed=gg_fed) + end if end if end if end do @@ -393,16 +405,34 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) 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 (.not. if_model_fed) then !not FED_DA + 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 + else !fed_da NOW assign g_fed to dbz values. NEED to be changed !!!!! 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 .and. if_model_fed)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,g_fed=fed) 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 + else if( if_model_fed )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_fed=fed) + end if + + end if end if @@ -410,23 +440,45 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) 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 + if( if_model_dbz .and. if_model_fed)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,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) + elseif( 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) + elseif( if_model_fed )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_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) 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 + if( if_model_dbz .and. if_model_fed)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,g_fed=fed) + elseif( 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) + elseif( if_model_fed )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_fed=fed) 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) @@ -601,6 +653,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 @@ -710,7 +772,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 @@ -761,7 +823,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 @@ -770,7 +832,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 @@ -858,7 +920,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 @@ -872,7 +934,7 @@ 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 .or. if_model_dbz) then + 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 @@ -883,6 +945,9 @@ 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 @@ -991,7 +1056,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 @@ -1040,7 +1105,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 @@ -1052,7 +1117,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 @@ -1103,11 +1168,16 @@ 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) then + call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%phyvars,fv3_filenameginput,dbz=g_dbz,iope=iope) + end if + if(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) @@ -1170,8 +1240,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 @@ -1211,7 +1281,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 @@ -1220,7 +1290,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 @@ -1251,13 +1321,13 @@ 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_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) @@ -1273,6 +1343,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/ensctl2model.f90 b/src/gsi/ensctl2model.f90 index 12e1fe374e..9a32f12ab7 100644 --- a/src/gsi/ensctl2model.f90 +++ b/src/gsi/ensctl2model.f90 @@ -212,6 +212,10 @@ subroutine ensctl2model(xhat,mval,eval) call gsi_bundlegetvar (wbundle_c, clouds(ic),sv_rank3,istatus) endif enddo +! add fed + print*,"FED_ensctl2model.f90" + call gsi_bundlegetpointer (eval(jj),'fed',sv_rank3,istatus) + call gsi_bundlegetvar (wbundle_c, 'fed',sv_rank3,istatus) ! Add contribution from static B, if necessary call self_add(eval(jj),mval) diff --git a/src/gsi/ensctl2model_ad.f90 b/src/gsi/ensctl2model_ad.f90 index 706dafc59c..1f85a9bce5 100644 --- a/src/gsi/ensctl2model_ad.f90 +++ b/src/gsi/ensctl2model_ad.f90 @@ -190,7 +190,10 @@ subroutine ensctl2model_ad(eval,mval,grad) call gsi_bundleputvar (wbundle_c, clouds(ic),rv_rank3,istatus) endif enddo - +! add fed + print*,"FED_ensctl2model_ad.f90" + call gsi_bundlegetpointer (eval(jj), 'fed',rv_rank3,istatus) + call gsi_bundleputvar (wbundle_c,'fed',rv_rank3,istatus) ! Convert RHS calculations for u,v to st/vp if (do_getuv) then if(uv_hyb_ens) then diff --git a/src/gsi/ensctl2state.f90 b/src/gsi/ensctl2state.f90 index 0d6d3042c5..8e7f979c50 100644 --- a/src/gsi/ensctl2state.f90 +++ b/src/gsi/ensctl2state.f90 @@ -236,6 +236,10 @@ subroutine ensctl2state(xhat,mval,eval) enddo endif +! add fed + print*,"FED_ensctl2state.f90" + call gsi_bundlegetpointer (eval(jj),'fed',sv_rank3,istatus) + call gsi_bundlegetvar (wbundle_c, 'fed',sv_rank3,istatus) !$omp section diff --git a/src/gsi/ensctl2state_ad.f90 b/src/gsi/ensctl2state_ad.f90 index 4c038c8c6e..e7837fb3f3 100644 --- a/src/gsi/ensctl2state_ad.f90 +++ b/src/gsi/ensctl2state_ad.f90 @@ -46,6 +46,8 @@ subroutine ensctl2state_ad(eval,mval,grad) use cwhydromod, only: cw2hydro_ad_hwrf use timermod, only: timer_ini,timer_fnl use gridmod, only: nems_nmmb_regional + use state_vectors, only : & + prt_state_norms implicit none ! Declare passed variables @@ -240,6 +242,15 @@ subroutine ensctl2state_ad(eval,mval,grad) enddo endif +! add fed + print*,"FED_ensctl2state_ad.f90" + call gsi_bundlegetpointer (eval(jj), 'fed',rv_rank3,istatus) + if(istatus/=0) then + write(6,*) trim(myname), ': trouble_get_pointer: fed ' + endif + call gsi_bundleputvar (wbundle_c,'fed',rv_rank3,istatus) +! call prt_state_norms(wbundle_c,'weval_ensc2s_ad') + ! Calculate sensible temperature if(do_q_copy) then call gsi_bundleputvar (wbundle_c, 'q', rv_q, istatus ) diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 4fcb2aba1d..463fc75296 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -94,7 +94,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) :: & @@ -103,13 +103,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 @@ -795,7 +795,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 @@ -826,6 +826,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() @@ -1009,9 +1010,19 @@ 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 ( if_model_dbz .and. if_model_fed ) then + if( nphyvario3d<=1 ) then + write(6,*)"the set up for met variable (dbz and fed in phyvar) is not as expected,abort" + !call stop2(223) + end if + elseif ( if_model_dbz ) then + if( nphyvario3d<=0 ) then + write(6,*)"the set up for met variable (dbz in phyvar) is not as expected, abort" + call stop2(223) + end if + elseif ( if_model_fed ) then if( nphyvario3d<=0 ) then - write(6,*)"the set up for met variable (phyvar) is not as expected, abort" + write(6,*)"the set up for met variable (fed in phyvar) is not as expected, abort" call stop2(223) end if endif @@ -1208,10 +1219,11 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) ntracerio2d=0 endif - if( if_model_dbz )then + if( if_model_dbz .or. if_model_fed)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 @@ -1302,7 +1314,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) @@ -1343,7 +1355,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. 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 @@ -1356,6 +1368,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) @@ -1411,7 +1425,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( if_model_dbz .or. if_model_fed )then call gsi_fv3ncdf_read(grd_fv3lam_phyvar_ionouv,gsibundle_fv3lam_phyvar_nouv & & ,fv3filenamegin(it)%phyvars,fv3filenamegin(it)) end if @@ -1511,7 +1525,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)) + if(if_model_dbz .or. if_model_fed) 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 @@ -2273,7 +2287,8 @@ 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 + print*,"FED_check_phy_dimensions:",trim(adjustl(varname)) iret=nf90_inquire_dimension(gfile_loc,1,name,len) if(trim(name)=='xaxis_1') nx_phy=len if( nx_phy == nxcase )then @@ -2299,7 +2314,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) @@ -2733,7 +2748,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 @@ -2775,7 +2790,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_varname_length), allocatable,dimension(:) :: varname_files @@ -2824,6 +2839,11 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & allocate(varname_files(1)) varname_files = (/'ref_f3d'/) end if + if( 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)) @@ -2855,7 +2875,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 @@ -2881,7 +2901,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) @@ -2932,6 +2952,9 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & if( present(dbz) )then ! phyvars: dbz dbz = hwork end if + if( present(fed) )then ! phyvars: fed + fed = hwork + end if end do @@ -3157,7 +3180,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 @@ -3184,6 +3207,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 @@ -3273,7 +3297,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 @@ -3284,6 +3308,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 @@ -3414,7 +3440,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 @@ -3467,6 +3493,11 @@ subroutine wrfv3_netcdf(fv3filenamegin) call gsi_fv3ncdf_write(grd_fv3lam_phyvar_ionouv,gsibundle_fv3lam_phyvar_nouv,& add_saved,fv3filenamegin%phyvars,fv3filenamegin) end if + if( 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, & @@ -4165,7 +4196,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(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 @@ -4208,7 +4239,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) @@ -4241,7 +4272,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/intfed.f90 b/src/gsi/intfed.f90 index b12598efe2..f3aa968973 100644 --- a/src/gsi/intfed.f90 +++ b/src/gsi/intfed.f90 @@ -180,7 +180,7 @@ subroutine intfed_(fedhead,rval,sval) rfed(j6)=rfed(j6)+w6*valfed rfed(j7)=rfed(j7)+w7*valfed rfed(j8)=rfed(j8)+w8*valfed - print*,"FED_ADJ= ",grad,w1,w2,w3,w4 + !print*,"FED_ADJ= ",grad,w1,w2,w3,w4 end if endif diff --git a/src/gsi/read_fed.f90 b/src/gsi/read_fed.f90 index 129b1a57bd..f2851b57cf 100644 --- a/src/gsi/read_fed.f90 +++ b/src/gsi/read_fed.f90 @@ -402,7 +402,7 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) !-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 + if(dlon_earth>=r360 .or. dlat_earth >90.0_r_kind) cycle !-Convert back to radians rlon00 = dlon_earth*deg2rad diff --git a/src/gsi/setupdbz.f90 b/src/gsi/setupdbz.f90 index 043adc112a..c4d39601d9 100644 --- a/src/gsi/setupdbz.f90 +++ b/src/gsi/setupdbz.f90 @@ -1933,7 +1933,7 @@ 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)) ) - call nc_diag_metadata("Station_Elevation", sngl(data(ielev,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)) diff --git a/src/gsi/stpfed.f90 b/src/gsi/stpfed.f90 index 70670b1914..39898a3584 100644 --- a/src/gsi/stpfed.f90 +++ b/src/gsi/stpfed.f90 @@ -164,10 +164,10 @@ subroutine stpfed(fedhead,rval,sval,out,sges,nstep) out(1) = out(1)+pen(1)*fedptr%raterr2 kk=1 - print*,"FED_stp: ",kk,out(kk) + !print*,"FED_stp: ",kk,out(kk) do kk=2,nstep out(kk) = out(kk)+(pen(kk)-pen(1))*fedptr%raterr2 - print*,"FED_stp: ",kk,out(kk) + !print*,"FED_stp: ",kk,out(kk) end do end if diff --git a/src/gsi/stpjo.f90 b/src/gsi/stpjo.f90 index 0f80d9b4a2..5d6ebe2733 100644 --- a/src/gsi/stpjo.f90 +++ b/src/gsi/stpjo.f90 @@ -315,7 +315,6 @@ subroutine stpjo(dval,dbias,xval,xbias,sges,pbcjo,nstep) call perr(myname_,' stpcnt =',stpcnt) call die(myname_) endif - call it_obOper%stpjo(ib,dval(ib),xval(ib),pbcjo(:,ll,ib),sges,nstep,dbias,xbias) call obOper_destroy(it_obOper) enddo @@ -395,6 +394,7 @@ subroutine stpjo_setup(nobs_bins) call perr(myname_,' obOper_count =',obOper_count) call die(myname_) endif + ! call perr(myname_,' setup_obOper_typeInfo(ioper)=',obOper_typeInfo(ll)) do ib = 1,size(it_obOper%obsLL) ! for all bins headNode => obsLList_headNode(it_obOper%obsLL(ib)) @@ -403,7 +403,6 @@ subroutine stpjo_setup(nobs_bins) stpcnt = stpcnt +1 ll_jo(stpcnt) = ll ib_jo(stpcnt) = ib - enddo ! ib headNode => null() call obOper_destroy(it_obOper) From d1fc420a04f4e58cb870159417086c10adbe455f Mon Sep 17 00:00:00 2001 From: Hongli Wang Date: Thu, 14 Sep 2023 18:41:18 +0000 Subject: [PATCH 09/23] add B for fed --- src/gsi/m_berror_stats_reg.f90 | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/gsi/m_berror_stats_reg.f90 b/src/gsi/m_berror_stats_reg.f90 index 2ff8a6aa94..bd9fecfadc 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 From 3962e07917bd7af68b7ee9594cde661f508fa2f4 Mon Sep 17 00:00:00 2001 From: Hongli Wang Date: Thu, 14 Sep 2023 23:04:38 +0000 Subject: [PATCH 10/23] Keep record of printing sentences et al for debug --- src/gsi/control2model.f90 | 4 ++-- src/gsi/control2model_ad.f90 | 4 ++-- src/gsi/control2state.f90 | 8 ++++---- src/gsi/pcgsoi.f90 | 40 ++++++++++++++++++++++++++++++------ 4 files changed, 42 insertions(+), 14 deletions(-) diff --git a/src/gsi/control2model.f90 b/src/gsi/control2model.f90 index 4455eebd67..8243b96e8d 100644 --- a/src/gsi/control2model.f90 +++ b/src/gsi/control2model.f90 @@ -242,8 +242,8 @@ subroutine control2model(xhat,sval,bval) end if end if ! Add fed - call gsi_bundlegetpointer (sval(jj),'fed',sv_rank3,istatus) - call gsi_bundlegetvar (wbundle, 'fed',sv_rank3,istatus) +! call gsi_bundlegetpointer (sval(jj),'fed',sv_rank3,istatus) +! call gsi_bundlegetvar (wbundle, 'fed',sv_rank3,istatus) ! destroy temporary bundle call gsi_bundledestroy(wbundle,istatus) diff --git a/src/gsi/control2model_ad.f90 b/src/gsi/control2model_ad.f90 index fd9573a9df..e3b9e581db 100644 --- a/src/gsi/control2model_ad.f90 +++ b/src/gsi/control2model_ad.f90 @@ -221,8 +221,8 @@ subroutine control2model_ad(rval,bval,grad) end if end if ! Add fed - call gsi_bundlegetpointer (rval(jj),'fed',rv_rank3,istatus) - call gsi_bundleputvar (wbundle, 'fed',rv_rank3,istatus) +! call gsi_bundlegetpointer (rval(jj),'fed',rv_rank3,istatus) +! call gsi_bundleputvar (wbundle, 'fed',rv_rank3,istatus) ! Same one-to-one map for chemistry-vars; take care of them together do ic=1,ngases diff --git a/src/gsi/control2state.f90 b/src/gsi/control2state.f90 index d9bcc9858c..3c80b3c2fc 100644 --- a/src/gsi/control2state.f90 +++ b/src/gsi/control2state.f90 @@ -283,8 +283,8 @@ subroutine control2state(xhat,sval,bval) enddo end if ! Add fed - call gsi_bundlegetpointer (sval(jj),'fed',sv_rank3,istatus) - call gsi_bundlegetvar (wbundle, 'fed',sv_rank3,istatus) +! call gsi_bundlegetpointer (sval(jj),'fed',sv_rank3,istatus) +! call gsi_bundlegetvar (wbundle, 'fed',sv_rank3,istatus) call gsi_bundlegetpointer (sval(jj),'ps' ,sv_ps, istatus) call gsi_bundlegetvar ( wbundle, 'ps' , sv_ps, istatus ) @@ -735,8 +735,8 @@ subroutine control2state_ad(rval,bval,grad) enddo end if ! Add fed - call gsi_bundlegetpointer (rval(jj),'fed',rv_rank3,istatus) - call gsi_bundleputvar (wbundle, 'fed',rv_rank3,istatus) +! call gsi_bundlegetpointer (rval(jj),'fed',rv_rank3,istatus) +! call gsi_bundleputvar (wbundle, 'fed',rv_rank3,istatus) ! Calculate sensible temperature if(do_tv_to_tsen) call tv_to_tsen_ad(cv_t,rv_q,rv_tsen) diff --git a/src/gsi/pcgsoi.f90 b/src/gsi/pcgsoi.f90 index fac01c9315..870bbab526 100644 --- a/src/gsi/pcgsoi.f90 +++ b/src/gsi/pcgsoi.f90 @@ -204,7 +204,10 @@ subroutine pcgsoi() print_verbose=.false. if(verbose)print_verbose=.true. if (ladtest) call adtest() - +!Wang + print_verbose=.true. + print_diag_pcg=.true. + !luse_obsdiag =.true. ! Set constants. Initialize variables. restart=.false. if (jiter==jiterstart .and. (iguess==1 .or. iguess==2)) restart=.true. @@ -294,12 +297,19 @@ subroutine pcgsoi() if (diag_print) then do ii=1,nobs_bins - call prt_state_norms(rval(ii),'rval') + call prt_state_norms(sval(ii),'sval_1') + call prt_state_norms(rval(ii),'rval_1') enddo endif ! Adjoint of control to state call c2s_ad(gradx,rval,rbias,llprt) + if(print_diag_pcg) call prt_control_norms(gradx,'gradx_1') + if (diag_print) then + do ii=1,nobs_bins + call prt_state_norms(rval(ii),'rval_2') + enddo + endif ! Print initial Jo table if (iter==0) then @@ -330,8 +340,11 @@ subroutine pcgsoi() end if ! 2. Multiply by background error + print*,"FED_before_multb" + if(print_diag_pcg) call prt_control_norms(gradx,'gradx_2') call multb(gradx,grady) - + print*,"FED_after_multb" + if(print_diag_pcg) call prt_control_norms(grady,'grady_1') if(ortho) then ! save gradients if (iter <= iortho) then @@ -345,6 +358,7 @@ subroutine pcgsoi() ! 3. Calculate new norm of gradients and factors going into b calculation + if(print_diag_pcg) call prt_control_norms(gradx,'gradx_3') dprod(1) = qdot_prod_sub(gradx,grady) if(iter > 0 .and. .not. lanlerr)then dprod(3) = qdot_prod_sub(xdiff,grady) @@ -371,7 +385,7 @@ subroutine pcgsoi() end do dprod(2) = qdot_prod_sub(xdiff,grady) call mpl_allreduce(2,qpvals=dprod) - if(print_diag_pcg) call prt_control_norms(grady,'grady') + if(print_diag_pcg) call prt_control_norms(grady,'grady_2') gnorm(2)=dprod(2) gnorm(3)=dprod(2) @@ -437,7 +451,7 @@ subroutine pcgsoi() penorig=penalty end if endif - + print*,"FED_NORM= ",iter,jiter,jiterstart,gnormorig,gnorm(1) gnormx=gnorm(1)/gnormorig penx=penalty/penorig @@ -849,7 +863,7 @@ subroutine multb(vec1,vec2) use hybrid_ensemble_parameters,only : l_hyb_ens,aniso_a_en use hybrid_ensemble_isotropic, only: bkerror_a_en - use control_vectors, only: control_vector + use control_vectors, only: control_vector,prt_control_norms implicit none type(control_vector),intent(inout) :: vec1 @@ -858,13 +872,17 @@ subroutine multb(vec1,vec2) if(periodic)call periodic_(vec1) ! start by setting vec2=vec1 and then operate on vec2 (unless gram_schmidt) vec2=vec1 + call prt_control_norms(vec2,'vec2a') ! Multiply by background error if(anisotropic) then call anbkerror(vec2) else + print*,"call_bkerror(vec2)" call bkerror(vec2) end if + call prt_control_norms(vec2,'vec2b') +!Wang vec2=vec1 ! If hybrid ensemble run, then multiply ensemble control variable a_en ! by its localization correlation if(l_hyb_ens) then @@ -877,6 +895,7 @@ subroutine multb(vec1,vec2) end if end if + call prt_control_norms(vec2,'vec2c') return end subroutine multb subroutine c2s(hat,val,bias,llprt,ltest) @@ -977,13 +996,21 @@ 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 state_vectors, only : & + prt_state_norms + use gsi_4dvar, only: nobs_bins + implicit none type(control_vector) ,intent(inout) :: hat type(gsi_bundle) ,dimension(nobs_bins),intent(inout) :: val type(predictors) ,intent(inout) :: bias logical ,intent(in ) :: llprt + integer :: ii + do ii=1,nobs_bins + call prt_state_norms(val(ii),'val_c2s_ad') + enddo ! Adjoint of convert control var to physical space if (l4dvar) then @@ -1000,6 +1027,7 @@ subroutine c2s_ad(hat,val,bias,llprt) if (l_hyb_ens) then do ii=1,nobs_bins eval(ii)=val(ii) + call prt_state_norms(eval(ii),'eval_c2s_ad') end do call ensctl2state_ad(eval,mval(1),hat) else From a4cac6667b641aa6c378897d2f2ee0338b5ef0c2 Mon Sep 17 00:00:00 2001 From: Hongli Wang Date: Fri, 15 Sep 2023 00:19:09 +0000 Subject: [PATCH 11/23] Commented out lines for debug --- src/gsi/cplr_get_fv3_regional_ensperts.f90 | 16 +++------ src/gsi/ensctl2model.f90 | 6 ++-- src/gsi/ensctl2model_ad.f90 | 6 ++-- src/gsi/ensctl2state.f90 | 6 ++-- src/gsi/ensctl2state_ad.f90 | 12 +++---- src/gsi/gsi_rfv3io_mod.f90 | 2 +- src/gsi/pcgsoi.f90 | 40 ++++------------------ 7 files changed, 27 insertions(+), 61 deletions(-) diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 index e031db77fc..ff5d57c7ac 100644 --- a/src/gsi/cplr_get_fv3_regional_ensperts.f90 +++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90 @@ -417,7 +417,7 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) 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 - else !fed_da NOW assign g_fed to dbz values. NEED to be changed !!!!! + else !fed_da 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) @@ -430,9 +430,7 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) else if( if_model_fed )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_fed=fed) - end if - - + end if end if end if @@ -932,8 +930,8 @@ 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 + 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 @@ -946,8 +944,7 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g 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 - + call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_phyvar_nouv, 'fed' , g_fed, istatus );ier=ier+istatus end if @@ -1325,9 +1322,6 @@ subroutine parallel_read_fv3_step2(this,mype,iope, & 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) diff --git a/src/gsi/ensctl2model.f90 b/src/gsi/ensctl2model.f90 index 9a32f12ab7..542f4c8831 100644 --- a/src/gsi/ensctl2model.f90 +++ b/src/gsi/ensctl2model.f90 @@ -213,9 +213,9 @@ subroutine ensctl2model(xhat,mval,eval) endif enddo ! add fed - print*,"FED_ensctl2model.f90" - call gsi_bundlegetpointer (eval(jj),'fed',sv_rank3,istatus) - call gsi_bundlegetvar (wbundle_c, 'fed',sv_rank3,istatus) +! print*,"FED_ensctl2model.f90" +! call gsi_bundlegetpointer (eval(jj),'fed',sv_rank3,istatus) +! call gsi_bundlegetvar (wbundle_c, 'fed',sv_rank3,istatus) ! Add contribution from static B, if necessary call self_add(eval(jj),mval) diff --git a/src/gsi/ensctl2model_ad.f90 b/src/gsi/ensctl2model_ad.f90 index 1f85a9bce5..509808d106 100644 --- a/src/gsi/ensctl2model_ad.f90 +++ b/src/gsi/ensctl2model_ad.f90 @@ -191,9 +191,9 @@ subroutine ensctl2model_ad(eval,mval,grad) endif enddo ! add fed - print*,"FED_ensctl2model_ad.f90" - call gsi_bundlegetpointer (eval(jj), 'fed',rv_rank3,istatus) - call gsi_bundleputvar (wbundle_c,'fed',rv_rank3,istatus) +! print*,"FED_ensctl2model_ad.f90" +! call gsi_bundlegetpointer (eval(jj), 'fed',rv_rank3,istatus) +! call gsi_bundleputvar (wbundle_c,'fed',rv_rank3,istatus) ! Convert RHS calculations for u,v to st/vp if (do_getuv) then if(uv_hyb_ens) then diff --git a/src/gsi/ensctl2state.f90 b/src/gsi/ensctl2state.f90 index 8e7f979c50..31a1c6e34d 100644 --- a/src/gsi/ensctl2state.f90 +++ b/src/gsi/ensctl2state.f90 @@ -237,9 +237,9 @@ subroutine ensctl2state(xhat,mval,eval) endif ! add fed - print*,"FED_ensctl2state.f90" - call gsi_bundlegetpointer (eval(jj),'fed',sv_rank3,istatus) - call gsi_bundlegetvar (wbundle_c, 'fed',sv_rank3,istatus) +! print*,"FED_ensctl2state.f90" +! call gsi_bundlegetpointer (eval(jj),'fed',sv_rank3,istatus) +! call gsi_bundlegetvar (wbundle_c, 'fed',sv_rank3,istatus) !$omp section diff --git a/src/gsi/ensctl2state_ad.f90 b/src/gsi/ensctl2state_ad.f90 index e7837fb3f3..00e834c54b 100644 --- a/src/gsi/ensctl2state_ad.f90 +++ b/src/gsi/ensctl2state_ad.f90 @@ -243,12 +243,12 @@ subroutine ensctl2state_ad(eval,mval,grad) endif ! add fed - print*,"FED_ensctl2state_ad.f90" - call gsi_bundlegetpointer (eval(jj), 'fed',rv_rank3,istatus) - if(istatus/=0) then - write(6,*) trim(myname), ': trouble_get_pointer: fed ' - endif - call gsi_bundleputvar (wbundle_c,'fed',rv_rank3,istatus) +! print*,"FED_ensctl2state_ad.f90" +! call gsi_bundlegetpointer (eval(jj), 'fed',rv_rank3,istatus) +! if(istatus/=0) then +! write(6,*) trim(myname), ': trouble_get_pointer: fed ' +! endif +! call gsi_bundleputvar (wbundle_c,'fed',rv_rank3,istatus) ! call prt_state_norms(wbundle_c,'weval_ensc2s_ad') ! Calculate sensible temperature diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 463fc75296..bf3b8e44a0 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -2288,7 +2288,7 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) ! 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 - print*,"FED_check_phy_dimensions:",trim(adjustl(varname)) + !print*,"FED_check_phy_dimensions:",trim(adjustl(varname)) iret=nf90_inquire_dimension(gfile_loc,1,name,len) if(trim(name)=='xaxis_1') nx_phy=len if( nx_phy == nxcase )then diff --git a/src/gsi/pcgsoi.f90 b/src/gsi/pcgsoi.f90 index 870bbab526..fac01c9315 100644 --- a/src/gsi/pcgsoi.f90 +++ b/src/gsi/pcgsoi.f90 @@ -204,10 +204,7 @@ subroutine pcgsoi() print_verbose=.false. if(verbose)print_verbose=.true. if (ladtest) call adtest() -!Wang - print_verbose=.true. - print_diag_pcg=.true. - !luse_obsdiag =.true. + ! Set constants. Initialize variables. restart=.false. if (jiter==jiterstart .and. (iguess==1 .or. iguess==2)) restart=.true. @@ -297,19 +294,12 @@ subroutine pcgsoi() if (diag_print) then do ii=1,nobs_bins - call prt_state_norms(sval(ii),'sval_1') - call prt_state_norms(rval(ii),'rval_1') + call prt_state_norms(rval(ii),'rval') enddo endif ! Adjoint of control to state call c2s_ad(gradx,rval,rbias,llprt) - if(print_diag_pcg) call prt_control_norms(gradx,'gradx_1') - if (diag_print) then - do ii=1,nobs_bins - call prt_state_norms(rval(ii),'rval_2') - enddo - endif ! Print initial Jo table if (iter==0) then @@ -340,11 +330,8 @@ subroutine pcgsoi() end if ! 2. Multiply by background error - print*,"FED_before_multb" - if(print_diag_pcg) call prt_control_norms(gradx,'gradx_2') call multb(gradx,grady) - print*,"FED_after_multb" - if(print_diag_pcg) call prt_control_norms(grady,'grady_1') + if(ortho) then ! save gradients if (iter <= iortho) then @@ -358,7 +345,6 @@ subroutine pcgsoi() ! 3. Calculate new norm of gradients and factors going into b calculation - if(print_diag_pcg) call prt_control_norms(gradx,'gradx_3') dprod(1) = qdot_prod_sub(gradx,grady) if(iter > 0 .and. .not. lanlerr)then dprod(3) = qdot_prod_sub(xdiff,grady) @@ -385,7 +371,7 @@ subroutine pcgsoi() end do dprod(2) = qdot_prod_sub(xdiff,grady) call mpl_allreduce(2,qpvals=dprod) - if(print_diag_pcg) call prt_control_norms(grady,'grady_2') + if(print_diag_pcg) call prt_control_norms(grady,'grady') gnorm(2)=dprod(2) gnorm(3)=dprod(2) @@ -451,7 +437,7 @@ subroutine pcgsoi() penorig=penalty end if endif - print*,"FED_NORM= ",iter,jiter,jiterstart,gnormorig,gnorm(1) + gnormx=gnorm(1)/gnormorig penx=penalty/penorig @@ -863,7 +849,7 @@ subroutine multb(vec1,vec2) use hybrid_ensemble_parameters,only : l_hyb_ens,aniso_a_en use hybrid_ensemble_isotropic, only: bkerror_a_en - use control_vectors, only: control_vector,prt_control_norms + use control_vectors, only: control_vector implicit none type(control_vector),intent(inout) :: vec1 @@ -872,17 +858,13 @@ subroutine multb(vec1,vec2) if(periodic)call periodic_(vec1) ! start by setting vec2=vec1 and then operate on vec2 (unless gram_schmidt) vec2=vec1 - call prt_control_norms(vec2,'vec2a') ! Multiply by background error if(anisotropic) then call anbkerror(vec2) else - print*,"call_bkerror(vec2)" call bkerror(vec2) end if - call prt_control_norms(vec2,'vec2b') -!Wang vec2=vec1 ! If hybrid ensemble run, then multiply ensemble control variable a_en ! by its localization correlation if(l_hyb_ens) then @@ -895,7 +877,6 @@ subroutine multb(vec1,vec2) end if end if - call prt_control_norms(vec2,'vec2c') return end subroutine multb subroutine c2s(hat,val,bias,llprt,ltest) @@ -996,21 +977,13 @@ 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 state_vectors, only : & - prt_state_norms - use gsi_4dvar, only: nobs_bins - implicit none type(control_vector) ,intent(inout) :: hat type(gsi_bundle) ,dimension(nobs_bins),intent(inout) :: val type(predictors) ,intent(inout) :: bias logical ,intent(in ) :: llprt - integer :: ii - do ii=1,nobs_bins - call prt_state_norms(val(ii),'val_c2s_ad') - enddo ! Adjoint of convert control var to physical space if (l4dvar) then @@ -1027,7 +1000,6 @@ subroutine c2s_ad(hat,val,bias,llprt) if (l_hyb_ens) then do ii=1,nobs_bins eval(ii)=val(ii) - call prt_state_norms(eval(ii),'eval_c2s_ad') end do call ensctl2state_ad(eval,mval(1),hat) else From 0b63f57b2dbf77622b331a9d64e11ebeafb68c60 Mon Sep 17 00:00:00 2001 From: Hongli Wang Date: Fri, 15 Sep 2023 00:42:39 +0000 Subject: [PATCH 12/23] Delete lines for debugs --- src/gsi/ensctl2model.f90 | 4 ---- src/gsi/ensctl2model_ad.f90 | 4 ---- src/gsi/ensctl2state.f90 | 5 ----- src/gsi/ensctl2state_ad.f90 | 9 --------- src/gsi/gsi_rfv3io_mod.f90 | 1 - src/gsi/intfed.f90 | 1 - src/gsi/stpfed.f90 | 2 -- 7 files changed, 26 deletions(-) diff --git a/src/gsi/ensctl2model.f90 b/src/gsi/ensctl2model.f90 index 542f4c8831..12e1fe374e 100644 --- a/src/gsi/ensctl2model.f90 +++ b/src/gsi/ensctl2model.f90 @@ -212,10 +212,6 @@ subroutine ensctl2model(xhat,mval,eval) call gsi_bundlegetvar (wbundle_c, clouds(ic),sv_rank3,istatus) endif enddo -! add fed -! print*,"FED_ensctl2model.f90" -! call gsi_bundlegetpointer (eval(jj),'fed',sv_rank3,istatus) -! call gsi_bundlegetvar (wbundle_c, 'fed',sv_rank3,istatus) ! Add contribution from static B, if necessary call self_add(eval(jj),mval) diff --git a/src/gsi/ensctl2model_ad.f90 b/src/gsi/ensctl2model_ad.f90 index 509808d106..769ea611fe 100644 --- a/src/gsi/ensctl2model_ad.f90 +++ b/src/gsi/ensctl2model_ad.f90 @@ -190,10 +190,6 @@ subroutine ensctl2model_ad(eval,mval,grad) call gsi_bundleputvar (wbundle_c, clouds(ic),rv_rank3,istatus) endif enddo -! add fed -! print*,"FED_ensctl2model_ad.f90" -! call gsi_bundlegetpointer (eval(jj), 'fed',rv_rank3,istatus) -! call gsi_bundleputvar (wbundle_c,'fed',rv_rank3,istatus) ! Convert RHS calculations for u,v to st/vp if (do_getuv) then if(uv_hyb_ens) then diff --git a/src/gsi/ensctl2state.f90 b/src/gsi/ensctl2state.f90 index 31a1c6e34d..b333c4227f 100644 --- a/src/gsi/ensctl2state.f90 +++ b/src/gsi/ensctl2state.f90 @@ -236,11 +236,6 @@ subroutine ensctl2state(xhat,mval,eval) enddo endif -! add fed -! print*,"FED_ensctl2state.f90" -! call gsi_bundlegetpointer (eval(jj),'fed',sv_rank3,istatus) -! call gsi_bundlegetvar (wbundle_c, 'fed',sv_rank3,istatus) - !$omp section ! Get pointers to required state variables diff --git a/src/gsi/ensctl2state_ad.f90 b/src/gsi/ensctl2state_ad.f90 index 00e834c54b..e850f4ad50 100644 --- a/src/gsi/ensctl2state_ad.f90 +++ b/src/gsi/ensctl2state_ad.f90 @@ -242,15 +242,6 @@ subroutine ensctl2state_ad(eval,mval,grad) enddo endif -! add fed -! print*,"FED_ensctl2state_ad.f90" -! call gsi_bundlegetpointer (eval(jj), 'fed',rv_rank3,istatus) -! if(istatus/=0) then -! write(6,*) trim(myname), ': trouble_get_pointer: fed ' -! endif -! call gsi_bundleputvar (wbundle_c,'fed',rv_rank3,istatus) -! call prt_state_norms(wbundle_c,'weval_ensc2s_ad') - ! Calculate sensible temperature if(do_q_copy) then call gsi_bundleputvar (wbundle_c, 'q', rv_q, istatus ) diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index bf3b8e44a0..1fce253891 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -2288,7 +2288,6 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin) ! 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 - !print*,"FED_check_phy_dimensions:",trim(adjustl(varname)) iret=nf90_inquire_dimension(gfile_loc,1,name,len) if(trim(name)=='xaxis_1') nx_phy=len if( nx_phy == nxcase )then diff --git a/src/gsi/intfed.f90 b/src/gsi/intfed.f90 index f3aa968973..c2e58d9274 100644 --- a/src/gsi/intfed.f90 +++ b/src/gsi/intfed.f90 @@ -180,7 +180,6 @@ subroutine intfed_(fedhead,rval,sval) rfed(j6)=rfed(j6)+w6*valfed rfed(j7)=rfed(j7)+w7*valfed rfed(j8)=rfed(j8)+w8*valfed - !print*,"FED_ADJ= ",grad,w1,w2,w3,w4 end if endif diff --git a/src/gsi/stpfed.f90 b/src/gsi/stpfed.f90 index 39898a3584..2d02049c9e 100644 --- a/src/gsi/stpfed.f90 +++ b/src/gsi/stpfed.f90 @@ -164,10 +164,8 @@ subroutine stpfed(fedhead,rval,sval,out,sges,nstep) out(1) = out(1)+pen(1)*fedptr%raterr2 kk=1 - !print*,"FED_stp: ",kk,out(kk) do kk=2,nstep out(kk) = out(kk)+(pen(kk)-pen(1))*fedptr%raterr2 - !print*,"FED_stp: ",kk,out(kk) end do end if From 9bd61945cecaf29e2e27146148bf766e620f30ad Mon Sep 17 00:00:00 2001 From: Hongli Wang Date: Fri, 15 Sep 2023 04:29:56 +0000 Subject: [PATCH 13/23] update read_fed to David's PR, dbz to S' Pr. --- src/gsi/read_dbz_nc.f90 | 7 +++++-- src/gsi/read_fed.f90 | 15 ++++++--------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/gsi/read_dbz_nc.f90 b/src/gsi/read_dbz_nc.f90 index 6c31caae75..79054d3d76 100644 --- a/src/gsi/read_dbz_nc.f90 +++ b/src/gsi/read_dbz_nc.f90 @@ -69,7 +69,7 @@ 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,& @@ -482,7 +482,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 diff --git a/src/gsi/read_fed.f90 b/src/gsi/read_fed.f90 index f2851b57cf..c478b3d93f 100644 --- a/src/gsi/read_fed.f90 +++ b/src/gsi/read_fed.f90 @@ -29,14 +29,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,rad2deg,deg2rad - use convinfo, only: nconvtype,ctwind,cgross,cermax,cermin,cvar_b,cvar_pg, & - ncmiter,ncgroup,ncnumgrp,icuse,ictype,icsubtype,ioctype + 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,time_window + use obsmod, only: perturb_obs,iadatemn use netcdf implicit none @@ -67,7 +66,6 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) integer(i_kind) ifn,i - real(r_kind) :: maxfed integer(i_kind) :: ilon,ilat logical :: fedobs, fedob @@ -97,7 +95,7 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) integer(i_kind) :: ireadmg,ireadsb integer(i_kind) :: maxlvl - integer(i_kind) :: numlvl,numfed,numobsa,nmsgmax,maxobs + integer(i_kind) :: numlvl,numfed,nmsgmax,maxobs integer(i_kind) :: k,iret integer(i_kind) :: nmsg,ntb @@ -119,9 +117,8 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) integer :: unit_table ! for read netcdf - integer(i_kind) :: idate5(5), sec70,mins_an,mins_ob + integer(i_kind) :: sec70,mins_an integer(i_kind) :: varID, ncdfID, status - character(4) :: idate5s(5) real(r_kind) :: timeb,twindm,rmins_an,rmins_ob @@ -207,7 +204,7 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) ! Extract type, date, and location information from BUFR file call ufbint(lunin,hdr,5,1,iret,hdrstr) - if(hdr(3) .gt. 90 ) write(6,*) "Inside read_fed.f90, hdr(2)=",hdr(2),"hdr(3)=",hdr(3) + 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 From 4b3cc969cec5f58919c916abb7fcf8b2a996b077 Mon Sep 17 00:00:00 2001 From: Hongli Wang Date: Fri, 15 Sep 2023 14:11:20 +0000 Subject: [PATCH 14/23] Add option to use FED from background file to cal innov --- src/gsi/gsimod.F90 | 4 +- src/gsi/obsmod.F90 | 5 ++- src/gsi/setupfed.f90 | 101 ++++++++++++++++++++++++++++--------------- 3 files changed, 72 insertions(+), 38 deletions(-) diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index da679a9a2d..70ceac28eb 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -25,7 +25,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_model_fed,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 @@ -768,7 +768,7 @@ module gsimod 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,if_model_fed,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,& diff --git a/src/gsi/obsmod.F90 b/src/gsi/obsmod.F90 index 5f7548ffe3..a232eb9e6c 100644 --- a/src/gsi/obsmod.F90 +++ b/src/gsi/obsmod.F90 @@ -473,7 +473,7 @@ module obsmod ! ==== DBZ DA === public :: ntilt_radarfiles public :: whichradar - public :: vr_dealisingopt, if_vterminal, if_model_dbz,if_model_fed, inflate_obserr, if_vrobs_raw, if_use_w_vr, l2rwthin + public :: vr_dealisingopt, if_vterminal, if_model_dbz,if_model_fed, innov_use_model_fed, inflate_obserr, if_vrobs_raw, if_use_w_vr, l2rwthin public :: doradaroneob,oneoblat,oneoblon public :: oneobddiff,oneobvalue,oneobheight,oneobradid @@ -622,7 +622,7 @@ module obsmod logical :: ta2tb logical :: doradaroneob - logical :: vr_dealisingopt, if_vterminal, if_model_dbz,if_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,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 @@ -756,6 +756,7 @@ subroutine init_obsmod_dflts if_use_w_vr=.true. if_model_dbz=.false. if_model_fed=.false. + innov_use_model_fed=.true. inflate_obserr=.false. whichradar="KKKK" diff --git a/src/gsi/setupfed.f90 b/src/gsi/setupfed.f90 index cf6334e567..80a8a28a6e 100644 --- a/src/gsi/setupfed.f90 +++ b/src/gsi/setupfed.f90 @@ -17,6 +17,10 @@ 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 cal fed innov +! - fed in BG exist (if_model_fed=.true.), and is used +! to cal innov (innov_use_model_fed=.true.) ! ! use mpeu_util, only: die,perr @@ -30,6 +34,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 use m_obsNode, only: obsNode use m_fedNode, only: fedNode use m_fedNode, only: fedNode_appendto @@ -135,7 +140,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) @@ -293,10 +298,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 +317,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 +336,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 +348,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 !============================================================================================ @@ -415,15 +419,15 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa ! obs locations/times ! Note: geop_hgtl is relative to model terrain, i.e. height - ges_z (ref. to ! subroutine guess_grids) - call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& - mype,nfldsig) - call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - call tintrp2a1(geop_hgtl,hges,dlat,dlon,dtime,hrdifsig,& - nsig,mype,nfldsig) - - call tintrp2a1(ges_prsi,prsitmp,dlat,dlon,dtime, & - hrdifsig,nsig+1,mype,nfldsig) + call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,& + mype,nfldsig) + call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + call tintrp2a1(geop_hgtl,hges,dlat,dlon,dtime,hrdifsig,& + nsig,mype,nfldsig) + + call tintrp2a1(ges_prsi,prsitmp,dlat,dlon,dtime, & + hrdifsig,nsig+1,mype,nfldsig) ! ! 2. Convert geopotential height at layer midpoints to geometric height ! using @@ -521,17 +525,22 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa ! 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 + npt = 0 + FEDMdiag(i) = 0. + if ( if_model_fed .and. innov_use_model_fed) then + !use fed from background file + call tintrp2a11(ges_fed(:,:,1,:),FEDMdiag(i),dlat,dlon,dtime,hrdifsig,mype,nfldsig) + else + call tintrp2a11(rp,FEDMdiag(i),dlat,dlon,dtime,hrdifsig,mype,nfldsig) + end if + 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 @@ -782,7 +791,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 +831,29 @@ 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) + print*,"FED_setupfed: ",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 +970,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) = 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 @@ -1048,6 +1080,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) From a3a013dbbb8fdc3295d0c8ad37a7a377e745bddd Mon Sep 17 00:00:00 2001 From: Hongli Wang Date: Tue, 19 Sep 2023 21:50:36 +0000 Subject: [PATCH 15/23] Clean code --- src/gsi/control2model.f90 | 3 --- src/gsi/control2model_ad.f90 | 3 --- src/gsi/control2state.f90 | 7 +------ src/gsi/ensctl2state_ad.f90 | 2 -- src/gsi/gsi_rfv3io_mod.f90 | 2 +- src/gsi/intfed.f90 | 4 ---- src/gsi/stpfed.f90 | 9 +-------- src/gsi/stpjo.f90 | 3 ++- 8 files changed, 5 insertions(+), 28 deletions(-) diff --git a/src/gsi/control2model.f90 b/src/gsi/control2model.f90 index 8243b96e8d..ec628afe4f 100644 --- a/src/gsi/control2model.f90 +++ b/src/gsi/control2model.f90 @@ -241,9 +241,6 @@ subroutine control2model(xhat,sval,bval) enddo end if end if -! Add fed -! call gsi_bundlegetpointer (sval(jj),'fed',sv_rank3,istatus) -! call gsi_bundlegetvar (wbundle, 'fed',sv_rank3,istatus) ! destroy temporary bundle call gsi_bundledestroy(wbundle,istatus) diff --git a/src/gsi/control2model_ad.f90 b/src/gsi/control2model_ad.f90 index e3b9e581db..639bf87ffb 100644 --- a/src/gsi/control2model_ad.f90 +++ b/src/gsi/control2model_ad.f90 @@ -220,9 +220,6 @@ subroutine control2model_ad(rval,bval,grad) enddo end if end if -! Add fed -! call gsi_bundlegetpointer (rval(jj),'fed',rv_rank3,istatus) -! call gsi_bundleputvar (wbundle, 'fed',rv_rank3,istatus) ! Same one-to-one map for chemistry-vars; take care of them together do ic=1,ngases diff --git a/src/gsi/control2state.f90 b/src/gsi/control2state.f90 index 3c80b3c2fc..5836e082b2 100644 --- a/src/gsi/control2state.f90 +++ b/src/gsi/control2state.f90 @@ -282,9 +282,6 @@ subroutine control2state(xhat,sval,bval) endif enddo end if -! Add fed -! call gsi_bundlegetpointer (sval(jj),'fed',sv_rank3,istatus) -! call gsi_bundlegetvar (wbundle, 'fed',sv_rank3,istatus) call gsi_bundlegetpointer (sval(jj),'ps' ,sv_ps, istatus) call gsi_bundlegetvar ( wbundle, 'ps' , sv_ps, istatus ) @@ -734,9 +731,7 @@ subroutine control2state_ad(rval,bval,grad) endif enddo end if -! Add fed -! call gsi_bundlegetpointer (rval(jj),'fed',rv_rank3,istatus) -! call gsi_bundleputvar (wbundle, 'fed',rv_rank3,istatus) + ! Calculate sensible temperature if(do_tv_to_tsen) call tv_to_tsen_ad(cv_t,rv_q,rv_tsen) diff --git a/src/gsi/ensctl2state_ad.f90 b/src/gsi/ensctl2state_ad.f90 index 9d1c073321..d350743998 100644 --- a/src/gsi/ensctl2state_ad.f90 +++ b/src/gsi/ensctl2state_ad.f90 @@ -46,8 +46,6 @@ subroutine ensctl2state_ad(eval,mval,grad) use cwhydromod, only: cw2hydro_ad_hwrf use timermod, only: timer_ini,timer_fnl use gridmod, only: nems_nmmb_regional - use state_vectors, only : & - prt_state_norms implicit none ! Declare passed variables diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 5129056253..c44b8a3020 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -1013,7 +1013,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) if ( if_model_dbz .and. if_model_fed ) then if( nphyvario3d<=1 ) then write(6,*)"the set up for met variable (dbz and fed in phyvar) is not as expected,abort" - !call stop2(223) + call stop2(223) end if elseif ( if_model_dbz ) then if( nphyvario3d<=0 ) then diff --git a/src/gsi/intfed.f90 b/src/gsi/intfed.f90 index c2e58d9274..279efa0f9b 100644 --- a/src/gsi/intfed.f90 +++ b/src/gsi/intfed.f90 @@ -40,14 +40,12 @@ subroutine intfed_(fedhead,rval,sval) !$$$ subprogram documentation block ! . . . . ! subprogram: intfed apply nonlin qc operator for GLM FED -! prgmmr: derber org: np23 date: 1991-02-26 ! ! abstract: apply observation operator for radar winds ! with nonlinear qc operator ! ! program history log: ! 2023-08-24 H.Wang - modified based on intdbz.f90 -! - intfedmod is based on intqmod, and intrwmod ! - using tangent linear fed operator ! @@ -72,8 +70,6 @@ subroutine intfed_(fedhead,rval,sval) use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer use gsi_4dvar, only: ladtest_obs -! use directDA_radaruse_mod, only: l_use_fed_directDA - use radarz_cst, only: mphyopt use wrf_vars_mod, only : fed_exist implicit none diff --git a/src/gsi/stpfed.f90 b/src/gsi/stpfed.f90 index 2d02049c9e..3153eaf73c 100644 --- a/src/gsi/stpfed.f90 +++ b/src/gsi/stpfed.f90 @@ -34,16 +34,9 @@ subroutine stpfed(fedhead,rval,sval,out,sges,nstep) ! stepsize with nonlinear qc added. ! prgmmr: derber org: np23 date: 1991-02-26 ! -! abstract: calculate penalty and contribution to stepsize from radar reflectivity ! ! program history log: -! 1991-02-26 derber -! 1999-11-22 yang -! 2004-07-29 treadon - add only to module use, add intent in/out -! 2004-10-07 parrish - add nonlinear qc option -! 2016-09-xx G.Zhao - fed -! 2019-07-11 todling - introduced wrf_vars_mod -! +! 2019-08-23 H.Wang - added for FED DA ! input argument list: ! fedhead ! sges - step size estimates (nstep) diff --git a/src/gsi/stpjo.f90 b/src/gsi/stpjo.f90 index 5d6ebe2733..0f80d9b4a2 100644 --- a/src/gsi/stpjo.f90 +++ b/src/gsi/stpjo.f90 @@ -315,6 +315,7 @@ subroutine stpjo(dval,dbias,xval,xbias,sges,pbcjo,nstep) call perr(myname_,' stpcnt =',stpcnt) call die(myname_) endif + call it_obOper%stpjo(ib,dval(ib),xval(ib),pbcjo(:,ll,ib),sges,nstep,dbias,xbias) call obOper_destroy(it_obOper) enddo @@ -394,7 +395,6 @@ subroutine stpjo_setup(nobs_bins) call perr(myname_,' obOper_count =',obOper_count) call die(myname_) endif - ! call perr(myname_,' setup_obOper_typeInfo(ioper)=',obOper_typeInfo(ll)) do ib = 1,size(it_obOper%obsLL) ! for all bins headNode => obsLList_headNode(it_obOper%obsLL(ib)) @@ -403,6 +403,7 @@ subroutine stpjo_setup(nobs_bins) stpcnt = stpcnt +1 ll_jo(stpcnt) = ll ib_jo(stpcnt) = ib + enddo ! ib headNode => null() call obOper_destroy(it_obOper) From 4d20a0265d083aab96c6995f97f2e26ba4238abf Mon Sep 17 00:00:00 2001 From: Hongli Wang Date: Fri, 29 Sep 2023 06:26:55 +0000 Subject: [PATCH 16/23] 1. Add oneob capablity for FED DA 2. Use 3D interplotion when FED from BG is used 3. Clean code modified: src/gsi/gsimod.F90 modified: src/gsi/obsmod.F90 modified: src/gsi/read_fed.f90 modified: src/gsi/setupfed.f90 --- src/gsi/gsimod.F90 | 4 ++-- src/gsi/obsmod.F90 | 6 ++++-- src/gsi/read_fed.f90 | 26 ++++++++++++++++++++---- src/gsi/setupfed.f90 | 47 ++++++++++++++++++++++++++------------------ 4 files changed, 56 insertions(+), 27 deletions(-) diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index 69c0d0465d..a863df0b81 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -23,7 +23,7 @@ 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_model_fed,innov_use_model_fed,if_vrobs_raw,if_use_w_vr,& minobrangedbz,maxobrangedbz,maxobrangevr,maxtiltvr,missing_to_nopcp,& @@ -763,7 +763,7 @@ 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,& diff --git a/src/gsi/obsmod.F90 b/src/gsi/obsmod.F90 index a5970db6ee..c6ac57bbc4 100644 --- a/src/gsi/obsmod.F90 +++ b/src/gsi/obsmod.F90 @@ -488,6 +488,7 @@ module obsmod ! --- DBZ DA --- public :: iout_fed, mype_fed + public :: dofedoneob public :: obsmod_init_instr_table public :: obsmod_final_instr_table @@ -621,7 +622,7 @@ module obsmod integer(i_kind) ntilt_radarfiles,tcp_posmatch,tcp_box logical :: ta2tb - logical :: doradaroneob + 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 @@ -756,12 +757,13 @@ subroutine init_obsmod_dflts if_use_w_vr=.true. if_model_dbz=.false. if_model_fed=.false. - innov_use_model_fed=.true. + innov_use_model_fed=.false. inflate_obserr=.false. whichradar="KKKK" oneobradid="KKKK" doradaroneob=.false. + dofedoneob=.false. oneoblat=-999_r_kind oneoblon=-999_r_kind oneobddiff=-999_r_kind diff --git a/src/gsi/read_fed.f90 b/src/gsi/read_fed.f90 index c478b3d93f..d502cdd172 100644 --- a/src/gsi/read_fed.f90 +++ b/src/gsi/read_fed.f90 @@ -35,7 +35,7 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) 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 use netcdf implicit none @@ -389,6 +389,8 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) kint_maxloc=-1 fed_max=-999.99 ndata2=0 + + ILOOP : & 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 @@ -396,6 +398,12 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) ! ilone=18 ! index of longitude (degrees) dlat_earth = fed3d_column(2,i) ! latitude (degrees) of observation ! ilate=19 ! index of latitude (degrees) + + 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 0_r_kind) then + data(ifedob,i) = oneobvalue + ddiff = data(ifedob,i) - FEDMdiag(i) + else + ddiff = oneobddiff + data(ifedob,i) = FEDMdiag(i)+ddiff + endif + write(6,*)"FED_ONEOB: O_Val,B_Val= ",data(ifedob,i),FEDMdiag(i) + write(6,*)"FED_ONEOB: Innov,Error= ",ddiff,magoberr + else + 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) @@ -836,7 +846,6 @@ subroutine init_vars_ ! get fed .... varname='fed' call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus) - print*,"FED_setupfed: ",istatus if (istatus==0) then if(allocated(ges_fed))then write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc ' From dd2bb239d740eb3267c51d476df409c44b6663fe Mon Sep 17 00:00:00 2001 From: Hongli Wang Date: Fri, 29 Sep 2023 08:19:54 +0000 Subject: [PATCH 17/23] Refine oneob test modified: ../src/gsi/setupfed.f90 --- src/gsi/setupfed.f90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/gsi/setupfed.f90 b/src/gsi/setupfed.f90 index 29b2515622..c60a6dd5de 100644 --- a/src/gsi/setupfed.f90 +++ b/src/gsi/setupfed.f90 @@ -574,12 +574,14 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa 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 - ddiff = data(ifedob,i) - FEDMdiag(i) - end if + data(ifedob,i) = oneobvalue + ddiff = oneobvalue - FEDMdiag(i) + end if end if !oneob ! Gross error checks From 9836c30822f61415874db7334c23beaabf5e70d8 Mon Sep 17 00:00:00 2001 From: Hongli Wang Date: Fri, 29 Sep 2023 16:07:32 +0000 Subject: [PATCH 18/23] Oneline minor change modified: src/gsi/setupfed.f90 --- src/gsi/setupfed.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/gsi/setupfed.f90 b/src/gsi/setupfed.f90 index c60a6dd5de..d25af45fad 100644 --- a/src/gsi/setupfed.f90 +++ b/src/gsi/setupfed.f90 @@ -580,7 +580,7 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa write(6,*)"FED_ONEOB: Innov,Error= ",ddiff,magoberr else data(ifedob,i) = oneobvalue - ddiff = oneobvalue - FEDMdiag(i) + ddiff = data(ifedob,i) - FEDMdiag(i) end if end if !oneob From 085ea33b3f1277d5f9fa1d379cf60a6d440fec6d Mon Sep 17 00:00:00 2001 From: Hongli Wang Date: Fri, 6 Oct 2023 06:41:13 +0000 Subject: [PATCH 19/23] Cleanup code modified: src/gsi/control2state.f90 modified: src/gsi/cplr_get_fv3_regional_ensperts.f90 modified: src/gsi/ensctl2model_ad.f90 modified: src/gsi/ensctl2state.f90 modified: src/gsi/intfed.f90 modified: src/gsi/stpfed.f90 --- src/gsi/control2state.f90 | 2 - src/gsi/cplr_get_fv3_regional_ensperts.f90 | 76 ++++++++++------------ src/gsi/ensctl2model_ad.f90 | 1 + src/gsi/ensctl2state.f90 | 1 + src/gsi/intfed.f90 | 8 +-- src/gsi/stpfed.f90 | 8 +-- 6 files changed, 43 insertions(+), 53 deletions(-) diff --git a/src/gsi/control2state.f90 b/src/gsi/control2state.f90 index 5836e082b2..f2d8849ce0 100644 --- a/src/gsi/control2state.f90 +++ b/src/gsi/control2state.f90 @@ -282,7 +282,6 @@ subroutine control2state(xhat,sval,bval) endif enddo end if - call gsi_bundlegetpointer (sval(jj),'ps' ,sv_ps, istatus) call gsi_bundlegetvar ( wbundle, 'ps' , sv_ps, istatus ) @@ -731,7 +730,6 @@ subroutine control2state_ad(rval,bval,grad) endif enddo end if - ! Calculate sensible temperature if(do_tv_to_tsen) call tv_to_tsen_ad(cv_t,rv_q,rv_tsen) diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 index ff5d57c7ac..9b6c8dfc6c 100644 --- a/src/gsi/cplr_get_fv3_regional_ensperts.f90 +++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90 @@ -317,7 +317,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,32 +324,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 .and. .not.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) - 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)) - if ( if_model_dbz .and. if_model_fed) then - allocate(gg_dbz(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig)) - allocate(gg_fed(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,g_fed=gg_fed) - elseif ( if_model_dbz ) then - allocate(gg_dbz(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) - elseif ( if_model_fed ) then - allocate(gg_fed(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_fed=gg_fed) - end if 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.)' @@ -405,35 +407,25 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) 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. if_model_fed) then !not FED_DA - 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 - else !fed_da + if (if_model_fed) then + write(6,*)"This is not implemented for FED Ensemble" + write(6,*)"Please turn on parallelization_over_ensmembers when if_model_fed is .true. STOP(333)!" + call stop2(333) + end if + + 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 .and. if_model_fed)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,g_fed=fed) + 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) - else if( if_model_fed )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_fed=fed) + 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 diff --git a/src/gsi/ensctl2model_ad.f90 b/src/gsi/ensctl2model_ad.f90 index 769ea611fe..706dafc59c 100644 --- a/src/gsi/ensctl2model_ad.f90 +++ b/src/gsi/ensctl2model_ad.f90 @@ -190,6 +190,7 @@ subroutine ensctl2model_ad(eval,mval,grad) call gsi_bundleputvar (wbundle_c, clouds(ic),rv_rank3,istatus) endif enddo + ! Convert RHS calculations for u,v to st/vp if (do_getuv) then if(uv_hyb_ens) then diff --git a/src/gsi/ensctl2state.f90 b/src/gsi/ensctl2state.f90 index 3752f8bdee..bd72e12b76 100644 --- a/src/gsi/ensctl2state.f90 +++ b/src/gsi/ensctl2state.f90 @@ -236,6 +236,7 @@ subroutine ensctl2state(xhat,mval,eval) enddo endif + !$omp section ! Get pointers to required state variables diff --git a/src/gsi/intfed.f90 b/src/gsi/intfed.f90 index 279efa0f9b..8cb16eba10 100644 --- a/src/gsi/intfed.f90 +++ b/src/gsi/intfed.f90 @@ -65,7 +65,6 @@ subroutine intfed_(fedhead,rval,sval) 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 gridmod, only: wrf_mass_regional, fv3_regional use jfunc, only: jiter use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer @@ -81,11 +80,10 @@ subroutine intfed_(fedhead,rval,sval) ! 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,valqr,valqs,valqg,valfed,valqnr + 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) qrtl,qstl, qgtl, qnrtl - real(r_kind),pointer,dimension(:) :: sqr,sqs,sqg,sfed,sqnr - real(r_kind),pointer,dimension(:) :: rqr,rqs,rqg,rfed,rqnr + real(r_kind),pointer,dimension(:) :: sfed + real(r_kind),pointer,dimension(:) :: rfed type(fedNode), pointer :: fedptr ! If no fed obs type data return diff --git a/src/gsi/stpfed.f90 b/src/gsi/stpfed.f90 index 3153eaf73c..2a69dd08ec 100644 --- a/src/gsi/stpfed.f90 +++ b/src/gsi/stpfed.f90 @@ -77,13 +77,13 @@ subroutine stpfed(fedhead,rval,sval,out,sges,nstep) 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) valqr, valqs, valqg, valqnr, valfed - real(r_kind) qrcur, qscur, qgcur, qnrcur, fedcur + 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(:) :: sqr,sqs,sqg,sqnr,sfed - real(r_kind),pointer,dimension(:) :: rqr,rqs,rqg,rqnr,rfed + real(r_kind),pointer,dimension(:) :: sfed + real(r_kind),pointer,dimension(:) :: rfed type(fedNode), pointer :: fedptr out=zero_quad From afa85add2a7a38fa2d525e0b137c777d7cfce19a Mon Sep 17 00:00:00 2001 From: Hongli Wang Date: Thu, 19 Oct 2023 14:25:56 +0000 Subject: [PATCH 20/23] Reorganize and optimize some code accordint to reviewers' feedback Changes to be committed: modified: src/gsi/cplr_get_fv3_regional_ensperts.f90 modified: src/gsi/gsi_rfv3io_mod.f90 modified: src/gsi/gsimod.F90 modified: src/gsi/obsmod.F90 modified: src/gsi/setupfed.f90 --- src/gsi/cplr_get_fv3_regional_ensperts.f90 | 38 ++++++++------ src/gsi/gsi_rfv3io_mod.f90 | 59 +++++++++------------- src/gsi/gsimod.F90 | 14 +++++ src/gsi/obsmod.F90 | 11 +++- src/gsi/setupfed.f90 | 4 -- 5 files changed, 72 insertions(+), 54 deletions(-) diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 index cb13ba2e38..02dd1ac4fb 100644 --- a/src/gsi/cplr_get_fv3_regional_ensperts.f90 +++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90 @@ -407,22 +407,29 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) 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 (if_model_fed) then - write(6,*)"This is not implemented for FED Ensemble" - write(6,*)"Please turn on parallelization_over_ensmembers when if_model_fed is .true. STOP(333)!" - call stop2(333) - end if - - if (.not. (l_use_dbz_directDA .or. if_model_dbz) ) then ! Read additional hydrometers and w for dirZDA + if (.not. (l_use_dbz_directDA .or. if_model_dbz .or. if_model_fed) ) 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, & + if( .not. if_model_fed)then + 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, & + 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 + 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,g_fed=fed) + 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,g_fed=fed) + 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_w=w,g_fed=fed) + end if + end if ! if_model_fed end if end if @@ -1160,10 +1167,11 @@ subroutine general_read_fv3_regional_parallel_over_ens(this,iope,fv3_filenamegin 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) - if(if_model_dbz) then + 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) - end if - if(if_model_fed) then + 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 diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 71950010e5..23169d0ea4 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -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() @@ -1017,22 +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 .and. if_model_fed ) then - if( nphyvario3d<=1 ) then - write(6,*)"the set up for met variable (dbz and fed in phyvar) is not as expected,abort" - call stop2(223) - end if - elseif ( if_model_dbz ) then - if( nphyvario3d<=0 ) then - write(6,*)"the set up for met variable (dbz in phyvar) is not as expected, abort" - call stop2(223) - end if - elseif ( if_model_fed ) then - if( nphyvario3d<=0 ) then - write(6,*)"the set up for met variable (fed in 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 @@ -1228,11 +1219,10 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) ntracerio2d=0 endif - if( if_model_dbz .or. if_model_fed)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 - if (laeroana_fv3cmaq) then if (allocated(fv3lam_io_tracerchemvars3d_nouv) ) then @@ -1364,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 .or. if_model_fed) 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 @@ -1441,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 .or. if_model_fed )then + if( nphyvario3d > 0 )then call gsi_fv3ncdf_read(grd_fv3lam_phyvar_ionouv,gsibundle_fv3lam_phyvar_nouv & & ,fv3filenamegin(it)%phyvars,fv3filenamegin(it)) end if @@ -1540,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 .or. if_model_fed) 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 @@ -2949,11 +2940,13 @@ 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'/) - end if - if( present(fed) )then ! phyvars: fed + elseif( present(fed) )then ! phyvars: fed allocate(varname_files(1)) varname_files = (/'flash_extent_density'/) end if @@ -3063,10 +3056,12 @@ 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 - end if - if( present(fed) )then ! phyvars: fed + elseif( present(fed) )then ! phyvars: fed fed = hwork end if @@ -3609,11 +3604,7 @@ 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 - if( if_model_fed ) 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 diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index 22ad0eb1b6..d6426301a9 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -510,6 +510,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 variable list. 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 !------------------------------------------------------------------------- @@ -1978,6 +1987,11 @@ 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 if_model_fed, check namelist settings',335) + end if + ! Ensure valid number of horizontal scales if (nhscrf<0 .or. nhscrf>3) then diff --git a/src/gsi/obsmod.F90 b/src/gsi/obsmod.F90 index 6995da3472..efcda78881 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,11 @@ 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 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 @@ -473,7 +479,7 @@ module obsmod ! ==== DBZ DA === public :: ntilt_radarfiles public :: whichradar - public :: vr_dealisingopt, if_vterminal, if_model_dbz,if_model_fed, innov_use_model_fed, inflate_obserr, if_vrobs_raw, if_use_w_vr, 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 @@ -487,8 +493,11 @@ module obsmod public :: iout_dbz, mype_dbz ! --- DBZ DA --- + ! ==== FED DA === + public :: if_model_fed, innov_use_model_fed public :: iout_fed, mype_fed public :: dofedoneob + ! --- FED DA --- public :: obsmod_init_instr_table public :: obsmod_final_instr_table diff --git a/src/gsi/setupfed.f90 b/src/gsi/setupfed.f90 index d25af45fad..925f194ea7 100644 --- a/src/gsi/setupfed.f90 +++ b/src/gsi/setupfed.f90 @@ -19,10 +19,6 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa ! - capped maximum model FED ! Hongli Wang NOAA GSL 2023-09-14 ! - Add option to use fed from background file to calculate fed innov -! - The bellow two namelist parameters need to be true -! - if_model_fed=.true. fed in BG exist -! - innov_use_model_fed=.true. turn on flag to use FED from BG to cal innov -! ! use mpeu_util, only: die,perr use kinds, only: r_kind,r_single,r_double,i_kind From 79386129c196aa33f2dc25998ab229c516ffc81e Mon Sep 17 00:00:00 2001 From: Hongli Wang Date: Fri, 20 Oct 2023 05:04:10 +0000 Subject: [PATCH 21/23] 1. Cleanup and improve read_fed and setup_fed codes for examples, remove fed bufr obs reader, and hardcoded fed height(6500m) 2. Add namelist parameter checks modified: gsi_rfv3io_mod.f90 modified: gsimod.F90 modified: obsmod.F90 modified: read_fed.f90 modified: setupfed.f90 --- src/gsi/gsi_rfv3io_mod.f90 | 2 +- src/gsi/gsimod.F90 | 14 +- src/gsi/obsmod.F90 | 5 +- src/gsi/read_fed.f90 | 444 +++++++++++++------------------------ src/gsi/setupfed.f90 | 119 +++++----- 5 files changed, 223 insertions(+), 361 deletions(-) diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 14d3f072d8..e62cc06f2b 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -2939,7 +2939,7 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & end if if( present(dbz) .and. present(fed) )then ! phyvars: dbz, fed allocate(varname_files(2)) - varname_files = (/'ref_f3d','flash_extent_density'/) + varname_files = (/'ref_f3d ','flash_extent_density'/) elseif( present(dbz) )then ! phyvars: dbz allocate(varname_files(1)) varname_files = (/'ref_f3d'/) diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index d6426301a9..1cc4a19d81 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -28,7 +28,8 @@ module gsimod 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 use gsi_rfv3io_mod,only : fv3sar_bg_opt use radarz_cst, only: mphyopt, MFflg use radarz_iface, only: init_mphyopt @@ -788,7 +789,8 @@ module gsimod 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 @@ -1989,9 +1991,13 @@ subroutine gsimain_initialize 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 if_model_fed, check namelist settings',335) + call die(myname_,'invalid innov_use_model_fed,if_model_fed, check namelist settings',332) end if + if (miter > 0 .and. if_model_fed .and. .not. fed_exist) then + if(mype==0) write(6,*)' GSIMOD: invalid miter > 0 and if_model_fed=.true. but fed is not in anavinfo file' + call die(myname_,'Please add fed in anavinfo 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/obsmod.F90 b/src/gsi/obsmod.F90 index efcda78881..c43a23c1e6 100644 --- a/src/gsi/obsmod.F90 +++ b/src/gsi/obsmod.F90 @@ -194,6 +194,7 @@ module obsmod ! 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 @@ -495,6 +496,7 @@ module obsmod ! ==== FED DA === public :: if_model_fed, innov_use_model_fed + public :: r_hgt_fed public :: iout_fed, mype_fed public :: dofedoneob ! --- FED DA --- @@ -587,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 @@ -772,6 +774,7 @@ subroutine init_obsmod_dflts oneobradid="KKKK" doradaroneob=.false. + r_hgt_fed=6500_r_kind dofedoneob=.false. oneoblat=-999_r_kind oneoblon=-999_r_kind diff --git a/src/gsi/read_fed.f90 b/src/gsi/read_fed.f90 index d502cdd172..044aad73c3 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 @@ -31,11 +37,11 @@ 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 convinfo, only: nconvtype,ctwind,icuse,ioctype - use gsi_4dvar, only: l4dvar,l4densvar,winlen + use gsi_4dvar, only: l4dvar,l4densvar use gridmod, only: tll2xy use mod_wrfmass_to_a, only: wrfmass_obs_to_a8 use mpimod, only: npe - use obsmod, only: perturb_obs,iadatemn,dofedoneob,oneoblat,oneoblon + 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,60 @@ 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 + if (l4dvar.or.l4densvar) then + write(6,*) 'FED obs type is not set up for l4dvar.or.l4densvar. STOP92' + call stop2(92) + end if + + 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 +151,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 +176,73 @@ 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 + 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 - - + ! if ndata=0, should we continue? + if (ndata == 0) return 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,7 +252,6 @@ 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 @@ -392,42 +261,47 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) 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) - if (dofedoneob) then - dlat_earth=oneoblat - dlon_earth=oneoblon - endif + 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 + !-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 + !-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 (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 @@ -487,7 +361,8 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) ! 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) @@ -496,31 +371,26 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) fed_max =fed3d_column(k+2,i) end if - if( dofedoneob ) exit ILOOP - endif 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) @@ -529,15 +399,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 925f194ea7..dbb2f56111 100644 --- a/src/gsi/setupfed.f90 +++ b/src/gsi/setupfed.f90 @@ -19,6 +19,7 @@ subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsa ! - 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 @@ -95,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 @@ -357,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 @@ -387,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) @@ -407,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 Date: Fri, 20 Oct 2023 19:13:00 +0000 Subject: [PATCH 22/23] 1. Reorganize defaut get ens using case select 2. Check fed_exist and dbz_exist in metguess modified: cplr_get_fv3_regional_ensperts.f90 modified: read_fed.f90 modified: wrf_vars_mod.f90 --- src/gsi/cplr_get_fv3_regional_ensperts.f90 | 70 ++++++++++++++-------- src/gsi/gsimod.F90 | 2 +- src/gsi/read_fed.f90 | 2 - src/gsi/wrf_vars_mod.f90 | 34 ++++++++++- 4 files changed, 80 insertions(+), 28 deletions(-) diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 index c55c6949b8..758c413058 100644 --- a/src/gsi/cplr_get_fv3_regional_ensperts.f90 +++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90 @@ -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 @@ -407,30 +409,50 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) 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 .or. if_model_fed) ) then ! Read additional hydrometers and w for dirZDA - call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz) - else - if( .not. if_model_fed)then - 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 - 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,g_fed=fed) - 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,g_fed=fed) - 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_w=w,g_fed=fed) - end if - end if ! if_model_fed - end if + + ! 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. + ! Here the 6 cases that are considered in + ! the current applications are listed as of Oct 20 2023. + + ! 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 )) + i_caseflag=0 ! read in ps,u,v,tv,rh,oz + + ! 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 + + 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 diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index 1cc4a19d81..5e19bffe90 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -1996,7 +1996,7 @@ subroutine gsimain_initialize if (miter > 0 .and. if_model_fed .and. .not. fed_exist) then if(mype==0) write(6,*)' GSIMOD: invalid miter > 0 and if_model_fed=.true. but fed is not in anavinfo file' - call die(myname_,'Please add fed in anavinfo when miter > 0 and if_model_fed=.true.',334) + call die(myname_,'Please add fed 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 diff --git a/src/gsi/read_fed.f90 b/src/gsi/read_fed.f90 index 044aad73c3..78d0b5cff2 100644 --- a/src/gsi/read_fed.f90 +++ b/src/gsi/read_fed.f90 @@ -236,8 +236,6 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) nodata=ndata !!! - Finished reading fed observations from NETCDF format data file - ! if ndata=0, should we continue? - if (ndata == 0) return allocate(cdata_out(nreal,ndata)) ! do i=1,numfed diff --git a/src/gsi/wrf_vars_mod.f90 b/src/gsi/wrf_vars_mod.f90 index 70a14cf7be..1a5a9cfa6c 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 @@ -52,11 +54,17 @@ module wrf_vars_mod 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. @@ -64,6 +72,30 @@ subroutine init_wrf_vars 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.fed_cloud_exist )then +! dbz_exist=.false. +!endif + +if(ncloud>0) deallocate(cloud) + end subroutine init_wrf_vars end module wrf_vars_mod From 87db1fc1e41f4720545f2829fce6c9332c82064e Mon Sep 17 00:00:00 2001 From: Hongli Wang Date: Tue, 24 Oct 2023 19:45:13 +0000 Subject: [PATCH 23/23] 1. Reorganize the section for parallelization_over_ensmembers 2. Add namlelist consistency check for fed and dbz DA modified: cplr_get_fv3_regional_ensperts.f90 modified: gsimod.F90 modified: read_fed.f90 modified: wrf_vars_mod.f90 --- src/gsi/cplr_get_fv3_regional_ensperts.f90 | 125 +++++++++++++-------- src/gsi/gsimod.F90 | 17 ++- src/gsi/read_fed.f90 | 15 ++- src/gsi/wrf_vars_mod.f90 | 6 +- 4 files changed, 97 insertions(+), 66 deletions(-) diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 index 758c413058..2382ff1286 100644 --- a/src/gsi/cplr_get_fv3_regional_ensperts.f90 +++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90 @@ -406,34 +406,52 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) endif ! ! READ ENEMBLE MEMBERS DATA - 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) - - ! 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. - ! Here the 6 cases that are considered in - ! the current applications are listed as of Oct 20 2023. + ! + ! 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 - ! 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 )) - i_caseflag=0 ! read in ps,u,v,tv,rh,oz + ! 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 - ! 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 + ! 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 - ! only if_model_dbz is true - if(.not.l_use_dbz_directDA .and. if_model_dbz .and. .not.if_model_fed) i_caseflag=2 + ! 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 - ! 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 + + !-------------------------------------------------- + ! 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. - ! 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 + !-------------------------------------------- + ! When parallelization_over_ensmembers=.True. + ! Only i_flagcase=0,2,3,5 are vaild choices. - ! 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 + 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) + select case (i_caseflag) case (0) call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz) @@ -459,49 +477,58 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) 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 .and. if_model_fed)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,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) - elseif( 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) - elseif( if_model_fed )then - call this%parallel_read_fv3_step2(mype,iope,& + 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) - 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 .and. if_model_fed)then - call this%parallel_read_fv3_step2(mype,iope,& + 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) - elseif( if_model_dbz )then - call this%parallel_read_fv3_step2(mype,iope,& + 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 + 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) - elseif( if_model_fed )then - call this%parallel_read_fv3_step2(mype,iope,& + 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) - 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 (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) diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index 5e19bffe90..5a06eff27a 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -203,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,fed_exist + 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 @@ -515,7 +515,7 @@ module gsimod ! 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 variable list. If only run GSI observer, +! 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. @@ -1991,12 +1991,17 @@ subroutine gsimain_initialize 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',332) + call die(myname_,'invalid innov_use_model_fed,if_model_fed, check namelist settings',330) end if - if (miter > 0 .and. if_model_fed .and. .not. fed_exist) then - if(mype==0) write(6,*)' GSIMOD: invalid miter > 0 and if_model_fed=.true. but fed is not in anavinfo file' - call die(myname_,'Please add fed in anavinfo (contro/state_vector and met_guess) when miter > 0 and if_model_fed=.true.',334) + 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 diff --git a/src/gsi/read_fed.f90 b/src/gsi/read_fed.f90 index 78d0b5cff2..3d3d098b08 100644 --- a/src/gsi/read_fed.f90 +++ b/src/gsi/read_fed.f90 @@ -35,9 +35,9 @@ 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 + use gsi_4dvar, only: iwinbgn use gridmod, only: tll2xy use mod_wrfmass_to_a, only: wrfmass_obs_to_a8 use mpimod, only: npe @@ -115,11 +115,6 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) real(r_kind) :: timeb,twindm,rmins_an,rmins_ob - if (l4dvar.or.l4densvar) then - write(6,*) 'FED obs type is not set up for l4dvar.or.l4densvar. STOP92' - call stop2(92) - end if - hgt_fed = r_hgt_fed write(6,*) "r_kind=",r_kind @@ -224,6 +219,10 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) if(abs(timeb) > abs(twindm)) then print*, 'WARNING: ALL FED OBSERVATIONS OUTSIDE ASSIMILATION TIME WINDOW: ', timeb, twindm 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 @@ -315,7 +314,7 @@ subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs) 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 diff --git a/src/gsi/wrf_vars_mod.f90 b/src/gsi/wrf_vars_mod.f90 index 1a5a9cfa6c..f7a5e6c83d 100644 --- a/src/gsi/wrf_vars_mod.f90 +++ b/src/gsi/wrf_vars_mod.f90 @@ -90,9 +90,9 @@ subroutine init_wrf_vars fed_exist=.false. endif -!if(.not.dbz_exist .or. .not.fed_cloud_exist )then -! dbz_exist=.false. -!endif +if(.not.dbz_exist .or. .not.dbz_cloud_exist )then + dbz_exist=.false. +endif if(ncloud>0) deallocate(cloud)