!WRF:MODEL_LAYER:PHYSICS

!

MODULE module_fddaobs_rtfdda

! This obs-nudging FDDA module (RTFDDA) is developed by the

! NCAR/RAL/NSAP (National Security Application Programs), under the

! sponsorship of ATEC (Army Test and Evaluation Commands). ATEC is

! acknowledged for releasing this capability for WRF community

! research applications.

!

! The NCAR/RAL RTFDDA module was adapted, and significantly modified

! from the obs-nudging module in the standard MM5V3.1 which was originally

! developed by PSU (Stauffer and Seaman, 1994).

!

! Yubao Liu (NCAR/RAL): lead developer of the RTFDDA module

! Al Bourgeois (NCAR/RAL): lead engineer implementing RTFDDA into WRF-ARW

! Nov. 2006

!

! References:

!

! Liu, Y., A. Bourgeois, T. Warner, S. Swerdlin and J. Hacker, 2005: An

! implementation of obs-nudging-based FDDA into WRF for supporting

! ATEC test operations. 2005 WRF user workshop. Paper 10.7.

!

! Liu, Y., A. Bourgeois, T. Warner, S. Swerdlin and W. Yu, 2006: An update

! on "obs-nudging"-based FDDA for WRF-ARW: Verification using OSSE

! and performance of real-time forecasts. 2006 WRF user workshop. Paper 4.7.

!

! Stauffer, D.R., and N.L. Seaman, 1994: Multi-scale four-dimensional data

! assimilation. J. Appl. Meteor., 33, 416-434.

!

! http://www.rap.ucar.edu/projects/armyrange/references.html

!

! Modification History:

! 03212007 Modified fddaobs_init to compute Lambert cone factor. -Al Bourgeois

CONTAINS

!------------------------------------------------------------------------------

SUBROUTINE fddaobs_init(nudge_opt, maxdom, inest, parid, &

idynin, dtramp, fdaend, restart, &

twindo_cg, twindo, itimestep, &

no_pbl_nudge_uv, &

no_pbl_nudge_t, &

no_pbl_nudge_q, &

sfc_scheme_horiz, sfc_scheme_vert, &

maxsnd_gap, &

sfcfact, sfcfacr, dpsmx, &

nudge_wind, nudge_temp, nudge_mois, &

nudgezfullr1_uv, nudgezrampr1_uv, &

nudgezfullr2_uv, nudgezrampr2_uv, &

nudgezfullr4_uv, nudgezrampr4_uv, &

nudgezfullr1_t, nudgezrampr1_t, &

nudgezfullr2_t, nudgezrampr2_t, &

nudgezfullr4_t, nudgezrampr4_t, &

nudgezfullr1_q, nudgezrampr1_q, &

nudgezfullr2_q, nudgezrampr2_q, &

nudgezfullr4_q, nudgezrampr4_q, &

nudgezfullmin, nudgezrampmin, nudgezmax, &

xlat, xlong, &

start_year, start_month, start_day, &

start_hour, start_minute, start_second, &

p00, t00, tlp, &

znu, p_top, &

#if ( EM_CORE == 1 )

fdob, &

#endif

iprt, &

ids,ide, jds,jde, kds,kde, &

ims,ime, jms,jme, kms,kme, &

its,ite, jts,jte, kts,kte)

!-----------------------------------------------------------------------

! This routine does initialization for real time fdda obs-nudging.

!

!-----------------------------------------------------------------------

USE module_model_constants, ONLY : g, r_d

USE module_domain

USE module_dm, ONLY : wrf_dm_min_real

!-----------------------------------------------------------------------

IMPLICIT NONE

!-----------------------------------------------------------------------

!=======================================================================

! Definitions

!-----------

INTEGER, intent(in) :: maxdom

INTEGER, intent(in) :: nudge_opt(maxdom)

INTEGER, intent(in) :: ids,ide, jds,jde, kds,kde, &

ims,ime, jms,jme, kms,kme, &

its,ite, jts,jte, kts,kte

INTEGER, intent(in) :: inest

INTEGER, intent(in) :: parid(maxdom)

INTEGER, intent(in) :: idynin ! flag for dynamic initialization

REAL, intent(in) :: dtramp ! time period for idynin ramping (min)

REAL, intent(in) :: fdaend(maxdom) ! nudging end time for domain (min)

LOGICAL, intent(in) :: restart

REAL, intent(in) :: twindo_cg ! time window on coarse grid

REAL, intent(in) :: twindo

INTEGER, intent(in) :: itimestep

INTEGER , INTENT(IN) :: no_pbl_nudge_uv(maxdom) ! flags for no wind nudging in pbl

INTEGER , INTENT(IN) :: no_pbl_nudge_t(maxdom) ! flags for no temperature nudging in pbl

INTEGER , INTENT(IN) :: no_pbl_nudge_q(maxdom) ! flags for no moisture nudging in pbl

INTEGER , INTENT(IN) :: sfc_scheme_horiz ! horizontal spreading scheme for surf obs (wrf or orig mm5)

INTEGER , INTENT(IN) :: sfc_scheme_vert ! vertical spreading scheme for surf obs (orig or regime vif)

REAL , INTENT(IN) :: maxsnd_gap ! max allowed pressure gap in soundings, for interp (centibars)

REAL, intent(in) :: sfcfact ! scale factor applied to time window for surface obs

REAL, intent(in) :: sfcfacr ! scale fac applied to horiz rad of infl for sfc obs

REAL, intent(in) :: dpsmx ! max press change allowed within hor rad of infl

INTEGER , INTENT(IN) :: nudge_wind(maxdom) ! wind-nudging flag

INTEGER , INTENT(IN) :: nudge_temp(maxdom) ! temperature-nudging flag

INTEGER , INTENT(IN) :: nudge_mois(maxdom) ! moisture-nudging flag

REAL, INTENT(IN) :: nudgezfullr1_uv ! vert infl fcn, regime=1 full-wt hght, winds

REAL, INTENT(IN) :: nudgezrampr1_uv ! vert infl fcn, regime=1 ramp down hght, winds

REAL, INTENT(IN) :: nudgezfullr2_uv ! vert infl fcn, regime=2 full-wt hght, winds

REAL, INTENT(IN) :: nudgezrampr2_uv ! vert infl fcn, regime=2 ramp down hght, winds

REAL, INTENT(IN) :: nudgezfullr4_uv ! vert infl fcn, regime=4 full-wt hght, winds

REAL, INTENT(IN) :: nudgezrampr4_uv ! vert infl fcn, regime=4 ramp down hght, winds

REAL, INTENT(IN) :: nudgezfullr1_t ! vert infl fcn, regime=1 full-wt hght, temp

REAL, INTENT(IN) :: nudgezrampr1_t ! vert infl fcn, regime=1 ramp down hght, temp

REAL, INTENT(IN) :: nudgezfullr2_t ! vert infl fcn, regime=2 full-wt hght, temp

REAL, INTENT(IN) :: nudgezrampr2_t ! vert infl fcn, regime=2 ramp down hght, temp

REAL, INTENT(IN) :: nudgezfullr4_t ! vert infl fcn, regime=4 full-wt hght, temp

REAL, INTENT(IN) :: nudgezrampr4_t ! vert infl fcn, regime=4 ramp down hght, temp

REAL, INTENT(IN) :: nudgezfullr1_q ! vert infl fcn, regime=1 full-wt hght, mois

REAL, INTENT(IN) :: nudgezrampr1_q ! vert infl fcn, regime=1 ramp down hght, mois

REAL, INTENT(IN) :: nudgezfullr2_q ! vert infl fcn, regime=2 full-wt hght, mois

REAL, INTENT(IN) :: nudgezrampr2_q ! vert infl fcn, regime=2 ramp down hght, mois

REAL, INTENT(IN) :: nudgezfullr4_q ! vert infl fcn, regime=4 full-wt hght, mois

REAL, INTENT(IN) :: nudgezrampr4_q ! vert infl fcn, regime=4 ramp down hght, mois

REAL, INTENT(IN) :: nudgezfullmin ! min dpth thru which vert infl fcn remains 1.0 (m)

REAL, INTENT(IN) :: nudgezrampmin ! min dpth thru which vif decreases 1.0 to 0.0 (m)

REAL, INTENT(IN) :: nudgezmax ! max dpth in which vif is nonzero (m)

REAL, INTENT(IN) :: xlat ( ims:ime, jms:jme ) ! latitudes on mass-point grid

REAL, INTENT(IN) :: xlong( ims:ime, jms:jme ) ! longitudes on mass-point grid

INTEGER, intent(in) :: start_year ! Model start year

INTEGER, intent(in) :: start_month ! Model start month

INTEGER, intent(in) :: start_day ! Model start day

INTEGER, intent(in) :: start_hour ! Model start hour

INTEGER, intent(in) :: start_minute ! Model start minute

INTEGER, intent(in) :: start_second ! Model start second

REAL, INTENT(IN) :: p00 ! base state pressure

REAL, INTENT(IN) :: t00 ! base state temperature

REAL, INTENT(IN) :: tlp ! base state lapse rate

REAL, INTENT(IN) :: p_top ! pressure at top of model

REAL, INTENT(IN) :: znu( kms:kme ) ! eta values on half (mass) levels

#if ( EM_CORE == 1 )

TYPE(fdob_type), intent(inout) :: fdob

#endif

LOGICAL, intent(in) :: iprt ! Flag enabling printing warning messages

! Local variables

logical :: nudge_flag ! nudging flag for this nest

integer :: ktau ! current timestep

integer :: nest ! loop counter

integer :: idom ! domain id

integer :: parent ! parent domain

real :: conv ! 180/pi

real :: tl1 ! Lambert standard parallel 1

real :: tl2 ! Lambert standard parallel 2

real :: xn1

real :: known_lat ! Latitude of domain point (i,j)=(1,1)

real :: known_lon ! Longitude of domain point (i,j)=(1,1)

character(len=200) :: msg ! Argument to wrf_message

real :: z_at_p( kms:kme ) ! height at p levels

integer :: i,j,k ! loop counters

#if ( EM_CORE == 1 )

! Check to see if the nudging flag has been set. If not,

! simply RETURN.

nudge_flag = (nudge_opt(inest) .eq. 1)

if (.not. nudge_flag) return

call wrf_message("")

write(msg,fmt='(a,i2)') ' OBSERVATION NUDGING IS ACTIVATED FOR MESH ',inest

call wrf_message(msg)

ktau = itimestep

if(restart) then

fdob%ktaur = ktau

else

fdob%ktaur = 0

endif

! Create character string containing model starting-date

CALL date_string(start_year, start_month, start_day, start_hour, &

start_minute, start_second, fdob%sdate)

! Set flag for nudging on pressure (not sigma) surfaces.

fdob%iwtsig = 0

!**************************************************************************

! *** Initialize datend for dynamic initialization (ajb added 08132008) ***

!**************************************************************************

! Set ending nudging date (used with dynamic ramp-down) to zero.

fdob%datend = 0.

fdob%ieodi = 0

! Check for dynamic initialization flag

if(idynin.eq.1)then

! Set datend to time in minutes after which data are assumed to have ended.

if(dtramp.gt.0.)then

fdob%datend = fdaend(inest) - dtramp

else

fdob%datend = fdaend(inest)

endif

if(iprt) then

call wrf_message("")

write(msg,fmt='(a,i3,a)') &

' *** DYNAMIC-INITIALIZATION OPTION FOR INEST = ', inest, ' ***'

call wrf_message(msg)

write(msg,*) ' FDAEND,DATEND,DTRAMP: ',fdaend(inest),fdob%datend,dtramp

call wrf_message(msg)

call wrf_message("")

endif

endif

! *** end dynamic initialization section ***

!**************************************************************************

! Store flags for surface obs spreading schemes

if(sfc_scheme_horiz.eq.1) then

call wrf_message('MM5 scheme selected for horizontal spreading of surface obs')

elseif (sfc_scheme_horiz.eq.0) then

call wrf_message('WRF scheme selected for horizontal spreading of surface obs')

else

write(msg,fmt='(a,i3)') 'Unknown h-spreading scheme for surface obs: ',sfc_scheme_horiz

call wrf_message(msg)

call wrf_message("Valid selections: 0=WRF scheme, 1=Original MM5 scheme")

call wrf_error_fatal ( 'fddaobs_init: module_fddaobs_rtfdda STOP' )

endif

if(sfc_scheme_vert.eq.1) then

call wrf_message('Original simple scheme selected for vertical spreading of surface obs')

elseif (sfc_scheme_vert.eq.0) then

call wrf_message("Regime-based VIF scheme selected for vertical spreading of surface obs")

else

write(msg,fmt='(a,i3)') 'Unknown v-spreading scheme for surface obs: ',sfc_scheme_vert

call wrf_message(msg)

call wrf_message("Valid selections: 0=Regime-based VIF scheme, 1=Original simple scheme")

call wrf_error_fatal ( 'fddaobs_init: module_fddaobs_rtfdda STOP' )

endif

fdob%sfc_scheme_horiz = sfc_scheme_horiz

fdob%sfc_scheme_vert = sfc_scheme_vert

! Store temporal and spatial scales

fdob%sfcfact = sfcfact

fdob%sfcfacr = sfcfacr

! Set time window.

fdob%window = twindo

call wrf_message("")

write(msg,fmt='(a,i3)') '*** TIME WINDOW SETTINGS FOR NEST ',inest

call wrf_message(msg)

write(msg,fmt='(a,f6.3,2(a,f5.3))') ' TWINDO (hrs) = ',twindo, &

' SFCFACT = ',sfcfact,' SFCFACR = ',sfcfacr

call wrf_message(msg)

call wrf_message("")

if(inest.eq.1) then

if(twindo .eq. 0.) then

if(iprt) then

call wrf_message("")

write(msg,*) '*** WARNING: TWINDO=0 on the coarse domain.'

call wrf_message(msg)

write(msg,*) '*** Did you forget to set twindo in the fdda namelist?'

call wrf_message(msg)

call wrf_message("")

endif

endif

else ! nest

if(twindo .eq. 0.) then

fdob%window = twindo_cg

if(iprt) then

call wrf_message("")

write(msg,fmt='(a,i2)') 'WARNING: TWINDO=0. for nest ',inest

call wrf_message(msg)

write(msg,fmt='(a,f12.5,a)') 'Default to coarse-grid value of ', twindo_cg,' hrs'

call wrf_message(msg)

call wrf_message("")

endif

endif

endif

! Initialize flags.

fdob%domain_tot=0

do nest=1,maxdom

fdob%domain_tot = fdob%domain_tot + nudge_opt(nest)

end do

! Calculate and store dcon from dpsmx

if(dpsmx.gt.0.) then

fdob%dpsmx = dpsmx

fdob%dcon = 1.0/fdob%dpsmx

else

call wrf_error_fatal('fddaobs_init: Namelist variable dpsmx must be greater than zero!')

endif

! Calculate and store base-state heights at half (mass) levels.

CALL get_base_state_height_column( p_top, p00, t00, tlp, g, r_d, znu, &

fdob%base_state, kts, kte, kds,kde, kms,kme )

! Initialize flags for nudging within PBL.

fdob%nudge_uv_pbl = .true.

fdob%nudge_t_pbl = .true.

fdob%nudge_q_pbl = .true.

if(no_pbl_nudge_uv(inest) .eq. 1) fdob%nudge_uv_pbl = .false.

if(no_pbl_nudge_t(inest) .eq. 1) fdob%nudge_t_pbl = .false.

if(no_pbl_nudge_q(inest) .eq. 1) fdob%nudge_q_pbl = .false.

if(no_pbl_nudge_uv(inest) .eq. 1) then

fdob%nudge_uv_pbl = .false.

write(msg,*) ' --> Obs nudging for U/V is turned off in PBL'

call wrf_message(msg)

endif

if(no_pbl_nudge_t(inest) .eq. 1) then

fdob%nudge_t_pbl = .false.

write(msg,*) ' --> Obs nudging for T is turned off in PBL'

call wrf_message(msg)

endif

if(no_pbl_nudge_q(inest) .eq. 1) then

fdob%nudge_q_pbl = .false.

write(msg,*) ' --> Obs nudging for Q is turned off in PBL'

call wrf_message(msg)

endif

! Store max allowed pressure gap for interpolating between soundings

fdob%max_sndng_gap = maxsnd_gap

write(msg,fmt='(a,f6.1)') &

'*** MAX PRESSURE GAP (cb) for interpolation between soundings = ',maxsnd_gap

call wrf_message(msg)

call wrf_message("")

! Initialize vertical influence fcn for LML obs

if(sfc_scheme_vert.eq.0) then

fdob%vif_uv(1) = nudgezfullr1_uv

fdob%vif_uv(2) = nudgezrampr1_uv

fdob%vif_uv(3) = nudgezfullr2_uv

fdob%vif_uv(4) = nudgezrampr2_uv

fdob%vif_uv(5) = nudgezfullr4_uv

fdob%vif_uv(6) = nudgezrampr4_uv

fdob%vif_t (1) = nudgezfullr1_t

fdob%vif_t (2) = nudgezrampr1_t

fdob%vif_t (3) = nudgezfullr2_t

fdob%vif_t (4) = nudgezrampr2_t

fdob%vif_t (5) = nudgezfullr4_t

fdob%vif_t (6) = nudgezrampr4_t

fdob%vif_q (1) = nudgezfullr1_q

fdob%vif_q (2) = nudgezrampr1_q

fdob%vif_q (3) = nudgezfullr2_q

fdob%vif_q (4) = nudgezrampr2_q

fdob%vif_q (5) = nudgezfullr4_q

fdob%vif_q (6) = nudgezrampr4_q

! Sanity checks

if(nudgezmax.le.0.) then

write(msg,*) 'STOP! OBS NAMELIST INPUT obs_nudgezmax MUST BE GREATER THAN ZERO.'

call wrf_message(msg)

write(msg,*) 'THE NAMELIST VALUE IS',nudgezmax

call wrf_message(msg)

call wrf_error_fatal ( 'fddaobs_init: STOP on bad obs_nudgemax value' )

endif

if(nudgezfullmin.lt.0.) then

write(msg,*) 'STOP! OBS NAMELIST INPUT obs_nudgezfullmin MUST BE NONNEGATIVE.'

call wrf_message(msg)

write(msg,*) 'THE NAMELIST VALUE IS',nudgezfullmin

call wrf_message(msg)

call wrf_error_fatal ( 'fddaobs_init: STOP on bad obs_nudgefullmin value' )

endif

if(nudgezrampmin.lt.0.) then

write(msg,*) 'STOP! OBS NAMELIST INPUT obs_nudgezrampmin MUST BE NONNEGATIVE.'

call wrf_message(msg)

write(msg,*) 'THE NAMELIST VALUE IS',nudgezrampmin

call wrf_message(msg)

call wrf_error_fatal ( 'fddaobs_init: STOP on bad obs_nudgerampmin value' )

endif

if(nudgezmax.lt.nudgezfullmin+nudgezrampmin) then

write(msg,*) 'STOP! INCONSISTENT OBS NAMELIST INPUTS.'

call wrf_message(msg)

write(msg,fmt='(3(a,f12.3))') 'obs_nudgezmax = ',nudgezmax, &

' obs_nudgezfullmin = ',nudgezfullmin, &

' obs_nudgezrampmin = ',nudgezrampmin

call wrf_message(msg)

write(msg,*) 'REQUIRE NUDGEZMAX >= NUDGEZFULLMIN + NUDGEZRAMPMIN'

call wrf_message(msg)

call wrf_error_fatal ( 'fddaobs_init: STOP on inconsistent namelist values' )

endif

fdob%vif_fullmin = nudgezfullmin

fdob%vif_rampmin = nudgezrampmin

fdob%vif_max = nudgezmax

! Check to make sure that if nudgzfullmin > 0, then it must be at least as large as the

! first model half-level will be anywhere in the domain at any time within the simulation.

! We use 1.1 times the base-state value fdob%base_state(1) for this purpose.

if(nudgezfullmin.gt.0.0) then

if(nudgezfullmin .lt. 1.1*fdob%base_state(1)) then

fdob%vif_fullmin = 1.1*fdob%base_state(1)

endif

endif

! Print vertical weight info only if wind, temperature, or moisture nudging is requested.

if( (nudge_wind(inest).eq.1) .or. (nudge_temp(inest).eq.1) &

.or. (nudge_mois(inest).eq.1) ) then

call wrf_message("")

write(msg,fmt='(a,i2,a)') ' *** SETUP DESCRIPTION FOR SURFACE OBS NUDGING ON MESH ',inest,' :'

call wrf_message(msg)

call wrf_message("")

write(msg,fmt='(a,i5,a)') ' NUDGEZMAX: The maximum height at which nudging will be'// &

' applied from surface obs is ', nint(nudgezmax),' m AGL.'

call wrf_message(msg)

call wrf_message("")

write(msg,fmt='(a,i3,a)') ' NUDGEZFULLMIN: The minimum height of full nudging weight'// &

' for surface obs is ', nint(fdob%vif_fullmin),' m.'

call wrf_message(msg)

if(nudgezfullmin.lt.fdob%vif_fullmin) then

write(msg,fmt='(a,i3,a)') ' ***WARNING***: NUDGEZFULLMIN has been increased from'// &

' the user-input value of ',nint(nudgezfullmin),' m.'

call wrf_message(msg)

write(msg,fmt='(a,i3,a)') ' to ensure that at least the bottom model level is'// &

' included in full nudging.'

call wrf_message(msg)

endif

call wrf_message("")

write(msg,fmt='(a,i3,a)') ' NUDGEZRAMPMIN: The minimum height to ramp from full to no'// &

' nudging for surface obs is ', nint(nudgezrampmin),' m.'

call wrf_message(msg)

call wrf_message("")

endif !endif either wind, temperature, or moisture nudging is requested

! Print vif settings

if(nudge_wind(inest) .eq. 1) then

call print_vif_var('wind', fdob%vif_uv, nudgezfullmin, nudgezrampmin)

call wrf_message("")

endif

if(nudge_temp(inest) .eq. 1) then

call print_vif_var('temp', fdob%vif_t, nudgezfullmin, nudgezrampmin)

call wrf_message("")

endif

if(nudge_mois(inest) .eq. 1) then

call print_vif_var('mois', fdob%vif_q, nudgezfullmin, nudgezrampmin)

call wrf_message("")

endif

if( (nudge_wind(inest).eq.1) .or. (nudge_temp(inest).eq.1) &

.or. (nudge_mois(inest).eq.1) ) then

write(msg,fmt='(a,i2)') ' *** END SETUP DESCRIPTION FOR SURFACE OBS NUDGING ON MESH ',inest

call wrf_message(msg)

call wrf_message("")

endif

endif !endif(sfc_scheme_vert.EQ.0)

! Set parameters.

fdob%pfree = 50.0

fdob%rinfmn = 1.0

fdob%rinfmx = 2.0

! Get known lat and lon and store these on all processors in fdob structure, for

! later use in projection x-formation to map (lat,lon) to (x,y) for each obs.

IF (its .eq. 1 .AND. jts .eq. 1) then

known_lat = xlat(1,1)

known_lon = xlong(1,1)

ELSE

known_lat = 9999.

known_lon = 9999.

END IF

fdob%known_lat = wrf_dm_min_real(known_lat)

fdob%known_lon = wrf_dm_min_real(known_lon)

! Calculate the nest levels, levidn. Note that each nest

! must know the nest levels levidn(maxdom) of each domain.

do nest=1,maxdom

! Initialize nest level for each domain.

if (nest .eq. 1) then

fdob%levidn(nest) = 0 ! Mother domain has nest level 0

else

fdob%levidn(nest) = 1 ! All other domains start with 1

endif

idom = nest

100 parent = parid(idom) ! Go up the parent tree

if (parent .gt. 1) then ! If not up to mother domain

fdob%levidn(nest) = fdob%levidn(nest) + 1

idom = parent

goto 100

endif

enddo

! fdob%LML_OBS_HT1_LEV = kte

! HT1: do k = kte, kts, -1

! if( LML_HT1 .gt. z_at_p(k) ) then

! fdob%LML_OBS_HT1_LEV = k

! EXIT HT1

! endif

! enddo HT1

! fdob%LML_OBS_HT2_LEV = kte

! HT2: do k = kte, kts, -1

! if( LML_HT2 .gt. z_at_p(k) ) then

! fdob%LML_OBS_HT2_LEV = k

! EXIT HT2

! endif

! enddo HT2

RETURN

#endif

END SUBROUTINE fddaobs_init

#if ( EM_CORE == 1 )

!-----------------------------------------------------------------------

SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, &

z, &

uratx, vratx, tratx, kpbl, &

nndgv, nerrf, niobf, maxdom, &

levidn, parid, nstat, nstaw, &

iswind, istemp, ismois, ispstr, &

timeob, rio, rjo, rko, &

varobs, errf, ktau, xtime, &

iratio, npfi, &

prt_max, prt_freq, iprt, &

obs_prt, stnid_prt, lat_prt, lon_prt, &

mlat_prt, mlon_prt, &

ids,ide, jds,jde, kds,kde, &

ims,ime, jms,jme, kms,kme, &

its,ite, jts,jte, kts,kte )

!-----------------------------------------------------------------------

#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )

USE module_dm, ONLY : get_full_obs_vector, wrf_dm_sum_real

#else

USE module_dm, ONLY : wrf_dm_sum_real

#endif

USE module_model_constants, ONLY : rcp

!-----------------------------------------------------------------------

IMPLICIT NONE

!-----------------------------------------------------------------------

!

! PURPOSE: THIS SUBROUTINE CALCULATES THE DIFFERENCE BETWEEN THE

! OBSERVED VALUES AND THE FORECAST VALUES AT THE OBSERVATION

! POINTS. THE OBSERVED VALUES CLOSEST TO THE CURRENT

! FORECAST TIME (XTIME) WERE DETERMINED IN SUBROUTINE

! IN4DOB AND STORED IN ARRAY VAROBS. THE DIFFERENCES

! CALCULATED BY SUBROUTINE ERROB WILL BE STORED IN ARRAY

! ERRF FOR THE NSTA OBSERVATION LOCATIONS. MISSING

! OBSERVATIONS ARE DENOTED BY THE DUMMY VALUE 99999.

!

! HISTORY: Original author: MM5 version???

! 02/04/2004 - Creation of WRF version. Al Bourgeois

! 08/28/2006 - Conversion from F77 to F90 Al Bourgeois

!------------------------------------------------------------------------------

! THE STORAGE ORDER IN ERRF IS AS FOLLOWS:

! IVAR VARIABLE TYPE(TAU-1)

! ---- --------------------

! 1 U error at obs loc

! 2 V error at obs loc

! 3 T error at obs loc

! 4 Q error at obs loc

! 5 Vertical layer index for PBL top at IOB, JOB

! 6 Model surface press at obs loc (T-points)

! 7 Model surface press at obs loc (U-points)

! 8 Model surface press at obs loc (V-points)

! 9 RKO at U-points

! 10 Model Q at obs loc (T-points)

!-----------------------------------------------------------------------

!

! Description of input arguments.

!

!-----------------------------------------------------------------------

INTEGER, INTENT(IN) :: inest ! Domain index.

INTEGER, INTENT(IN) :: nndgv ! Number of nudge variables.

INTEGER, INTENT(IN) :: nerrf ! Number of error fields.

INTEGER, INTENT(IN) :: niobf ! Number of observations.

INTEGER, INTENT(IN) :: maxdom ! Maximum number of domains.

INTEGER, INTENT(IN) :: levidn(maxdom) ! Level of nest.

INTEGER, INTENT(IN) :: parid(maxdom) ! Id of parent grid.

INTEGER, INTENT(IN) :: ktau ! Model time step index

REAL, INTENT(IN) :: xtime ! Forecast time in minutes

INTEGER, INTENT(IN) :: iratio ! Nest to parent gridsize ratio.

INTEGER, INTENT(IN) :: npfi ! Coarse-grid diagnostics freq.

INTEGER, INTENT(IN) :: prt_max ! Max number of obs to print.

INTEGER, INTENT(IN) :: prt_freq ! Frequency of obs to print.

LOGICAL, INTENT(IN) :: iprt ! Print flag

INTEGER, INTENT(IN) :: obs_prt(prt_max) ! Print obs indices

INTEGER, INTENT(IN) :: stnid_prt(40,prt_max) ! Print obs station ids

REAL, INTENT(IN) :: lat_prt(prt_max) ! Print obs latitude

REAL, INTENT(IN) :: lon_prt(prt_max) ! Print obs longitude

REAL, INTENT(IN) :: mlat_prt(prt_max) ! Print model lat at obs loc

REAL, INTENT(IN) :: mlon_prt(prt_max) ! Print model lon at obs loc

INTEGER, INTENT(IN) :: nstat ! # stations held for use

INTEGER, INTENT(IN) :: nstaw ! # stations in current window

INTEGER, intent(in) :: iswind

INTEGER, intent(in) :: istemp

INTEGER, intent(in) :: ismois

INTEGER, intent(in) :: ispstr

INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde ! domain dims.

INTEGER, INTENT(IN) :: ims,ime, jms,jme, kms,kme ! memory dims.

INTEGER, INTENT(IN) :: its,ite, jts,jte, kts,kte ! tile dims.

REAL, INTENT(IN) :: ub( ims:ime, kms:kme, jms:jme )

REAL, INTENT(IN) :: vb( ims:ime, kms:kme, jms:jme )

REAL, INTENT(IN) :: tb( ims:ime, kms:kme, jms:jme )

REAL, INTENT(IN) :: t0

REAL, INTENT(IN) :: qvb( ims:ime, kms:kme, jms:jme )

REAL, INTENT(IN) :: pbase( ims:ime, kms:kme, jms:jme )

REAL, INTENT(IN) :: pp( ims:ime, kms:kme, jms:jme ) ! Press. perturbation (Pa)

REAL, INTENT(IN) :: rovcp

REAL, INTENT(IN) :: z( ims:ime, kms:kme, jms:jme ) ! Ht above sl on half-levels

REAL, INTENT(IN) :: uratx( ims:ime, jms:jme ) ! U to U10 ratio on mass points.

REAL, INTENT(IN) :: vratx( ims:ime, jms:jme ) ! V to V10 ratio on mass points.

REAL, INTENT(IN) :: tratx( ims:ime, jms:jme ) ! T to TH2 ratio on mass points.

INTEGER,INTENT(IN) :: kpbl( ims:ime, jms:jme ) ! Vertical layer index for PBL top

REAL, INTENT(IN) :: timeob(niobf) ! Obs time (hrs)

REAL, INTENT(IN) :: rio(niobf) ! Obs west-east coordinate (non-stag grid).

REAL, INTENT(IN) :: rjo(niobf) ! Obs south-north coordinate (non-stag grid).

REAL, INTENT(INOUT) :: rko(niobf) ! Obs bottom-top coordinate

REAL, INTENT(INOUT) :: varobs(nndgv, niobf)

REAL, INTENT(INOUT) :: errf(nerrf, niobf)

! Local variables

INTEGER :: iobmg(niobf) ! Obs i-coord on mass grid

INTEGER :: jobmg(niobf) ! Obs j-coord on mass grid

INTEGER :: ia(niobf)

INTEGER :: ib(niobf)

INTEGER :: ic(niobf)

REAL :: pbbo(kds:kde) ! column base pressure (cb) at obs loc.

REAL :: ppbo(kds:kde) ! column pressure perturbation (cb) at obs loc.

REAL :: ra(niobf)

REAL :: rb(niobf)

REAL :: rc(niobf)

REAL :: dxobmg(niobf) ! Interp. fraction (x dir) referenced to mass-grid

REAL :: dyobmg(niobf) ! Interp. fraction (y dir) referenced to mass-grid

INTEGER MM(MAXDOM)

INTEGER NNL

real :: uratio( ims:ime, jms:jme ) ! U to U10 ratio on momentum points.

real :: vratio( ims:ime, jms:jme ) ! V to V10 ratio on momentum points.

real :: pug1,pug2,pvg1,pvg2

character(len=200) :: msg ! Argument to wrf_message

! Define staggers for U, V, and T grids, referenced from non-staggered grid.

real, parameter :: gridx_t = 0.5 ! Mass-point x stagger

real, parameter :: gridy_t = 0.5 ! Mass-point y stagger

real, parameter :: gridx_u = 0.0 ! U-point x stagger

real, parameter :: gridy_u = 0.5 ! U-point y stagger

real, parameter :: gridx_v = 0.5 ! V-point x stagger

real, parameter :: gridy_v = 0.0 ! V-point y stagger

real :: dummy = 99999.

real :: pbhi, pphi

real :: obs_pottemp ! Potential temperature at observation

!*** DECLARATIONS FOR IMPLICIT NONE

integer nsta,ivar,n,ityp

integer iob,job,kob,iob_ms,job_ms

integer k,kbot,nml,nlb,nle

integer iobm,jobm,iobp,jobp,kobp,inpf,i,j

integer i_start,i_end,j_start,j_end ! loop ranges for uratio,vratio calc.

integer k_start,k_end

integer ips ! For printing obs information

integer pnx ! obs index for printout

real gridx,gridy,dxob,dyob,dzob,dxob_ms,dyob_ms

real pob

real hob

real uratiob,vratiob,tratiob,tratxob,fnpf

#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )

LOGICAL MP_LOCAL_DUMMASK(NIOBF) ! Mask for work to be done on this processor

LOGICAL MP_LOCAL_UOBMASK(NIOBF) ! Dot-point mask

LOGICAL MP_LOCAL_VOBMASK(NIOBF) ! Dot-point mask

LOGICAL MP_LOCAL_COBMASK(NIOBF) ! Cross-point mask

#endif

! LOGICAL, EXTERNAL :: TILE_MASK

NSTA=NSTAT

! FIRST, DETERMINE THE GRID TYPE CORRECTION FOR U-momentum, V-momentum,

! AND MASS POINTS, AND WHEN INEST=2, CONVERT THE STORED COARSE MESH INDICES

! TO THE FINE MESH INDEX EQUIVALENTS

! ITYP=1 FOR U-POINTS, ITYP=2 for V-POINTS, and ITYP=3 FOR MASS POINTS

if (iprt) then

write(msg,fmt='(a,i5,a,i2,a,i5,a)') '++++++CALL ERROB AT KTAU = ', &

KTAU,' AND INEST = ',INEST,': NSTA = ',NSTAW,' ++++++'

call wrf_message(msg)

endif

ERRF = 0.0 ! Zero out errf array

! Set up loop bounds for this grid's boundary conditions

i_start = max( its-1,ids )

i_end = min( ite+1,ide-1 )

j_start = max( jts-1,jds )

j_end = min( jte+1,jde-1 )

k_start = kts

k_end = min( kte, kde-1 )

DO ITYP=1,3 ! Big loop: ityp=1 for U, ityp=2 for V, ityp=3 for T,Q,SP

! Set grid stagger

IF(ITYP.EQ.1) THEN ! U-POINT CASE

GRIDX = gridx_u

GRIDY = gridy_u

ELSE IF(ITYP.EQ.2) THEN ! V-POINT CASE

GRIDX = gridx_v

GRIDY = gridy_v

ELSE ! MASS-POINT CASE

GRIDX = gridx_t

GRIDY = gridy_t

ENDIF

! Compute URATIO and VRATIO fields on momentum (u,v) points.

IF(ityp.eq.1)THEN

call upoint(i_start,i_end, j_start,j_end, ids,ide, ims,ime, jms,jme, uratx, uratio)

ELSE IF (ityp.eq.2) THEN

call vpoint(i_start,i_end, j_start,j_end, jds,jde, ims,ime, jms,jme, vratx, vratio)

ENDIF

IF(INEST.EQ.1) THEN ! COARSE MESH CASE...

DO N=1,NSTA

RA(N)=RIO(N)-GRIDX

RB(N)=RJO(N)-GRIDY

IA(N)=RA(N)

IB(N)=RB(N)

IOB=MAX0(1,IA(N))

IOB=MIN0(IOB,ide-1)

JOB=MAX0(1,IB(N))

JOB=MIN0(JOB,jde-1)

DXOB=RA(N)-FLOAT(IA(N))

DYOB=RB(N)-FLOAT(IB(N))

! Save mass-point arrays for computing rko for all var types

if(ityp.eq.1) then

iobmg(n) = MIN0(MAX0(1,int(RIO(n)-gridx_t)),ide-1)

jobmg(n) = MIN0(MAX0(1,int(RJO(n)-gridy_t)),jde-1)

dxobmg(n) = RIO(N)-gridx_t-FLOAT(int(RIO(N)-gridx_t))

dyobmg(n) = RJO(N)-gridy_t-FLOAT(int(RJO(N)-gridy_t))

endif

iob_ms = iobmg(n)

job_ms = jobmg(n)

dxob_ms = dxobmg(n)

dyob_ms = dyobmg(n)

! ajb 20090423: BUGFIX TO OBS_IN_HEIGHT OPTION

! This is tricky: Initialize pob to zero in all procs. Only one proc actually

! calculates pob. If this is an obs to be converted from height-to-pressure, then

! by definition, varobs(5,n) will initially have the missing value -888888. After

! the pob calculation, pob will be zero in all procs except the one that calculated

! it, and so pob is dm_summed over all procs and stored into varobs(5,n). So on

! subsequent passes, the dm_sum will not occur because varobs(5,n) will not have a

! missing value. If this is not an obs-in-height,

pob = 0.0

#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )

! Set mask for obs to be handled by this processor

MP_LOCAL_DUMMASK(N) = TILE_MASK(IOB, JOB, its, ite, jts, jte)

IF ( MP_LOCAL_DUMMASK(N) ) THEN

#endif

! Interpolate pressure to obs location column and convert from Pa to cb.

do k = kds, kde

pbbo(k) = .001*( &

(1.-DYOB_MS)*( (1.-DXOB_MS)*pbase(IOB_MS,K,JOB_MS) + &

DXOB_MS *pbase(IOB_MS+1,K,JOB_MS) ) + &

DYOB_MS* ( (1.-DXOB_MS)*pbase(IOB_MS,K,JOB_MS+1) + &

DXOB_MS *pbase(IOB_MS+1,K,JOB_MS+1) ) )

ppbo(k) = .001*( &

(1.-DYOB_MS)*( (1.-DXOB_MS)*pp(IOB_MS,K,JOB_MS) + &

DXOB_MS *pp(IOB_MS+1,K,JOB_MS) ) + &

DYOB_MS* ( (1.-DXOB_MS)*pp(IOB_MS,K,JOB_MS+1) + &

DXOB_MS *pp(IOB_MS+1,K,JOB_MS+1) ) )

enddo

!ajb 20040119: Note based on bugfix for dot/cross points split across processors,

!ajb which was actually a serial code fix: The ityp=2 (v-points) and

!ajb ityp=3 (mass-points) cases should not use the ityp=1 (u-points)

!ajb case rko! This is necessary for bit-for-bit reproducability

!ajb with the parallel run. (coarse mesh)

if(abs(rko(n)+99).lt.1.)then

pob = varobs(5,n)

if(pob .eq.-888888.) then

hob = varobs(6,n)

if(hob .gt. -800000. ) then

pob = ht_to_p( hob, ppbo, pbbo, z, iob_ms, job_ms, &

dxob_ms, dyob_ms, k_start, k_end, kds,kde, &

ims,ime, jms,jme, kms,kme )

endif

endif

if(pob .gt.-800000.)then

do k=k_end-1,1,-1

kbot = k

if(pob .le. pbbo(k)+ppbo(k)) then

goto 199

endif

enddo

199 continue

pphi = ppbo(kbot+1)

pbhi = pbbo(kbot+1)

rko(n) = real(kbot+1)- &

( (pob-pbhi-pphi) / (pbbo(kbot)+ppbo(kbot)-pbhi-pphi) )

rko(n)=max(rko(n),1.0)

endif

endif

#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )

ENDIF !end IF( MP_LOCAL_DUMMASK(N) ) !ajb

#endif

! ajb 20090423: If obs-in-height, varobs(5,n) is sum of pob (see note above).

if(varobs(5,n) .eq. -888888. .and. varobs(6,n) .gt. -800000.) then

varobs(5,n) = wrf_dm_sum_real ( pob )

endif

RC(N)=RKO(N)

ENDDO ! END COARSE MESH LOOP OVER NSTA

ELSE ! FINE MESH CASE

!**********************************************************************

!ajb_07012008: Conversion of obs coordinates to the fine mesh here

!ajb is no longer necessary, since implementation of the WRF map pro-

!ajb jections (to each nest directly) is implemented in sub in4dob.

!**********************************************************************

!ajb

!ajb GET (I,J,K) OF OBSERVATIONS ON FINE MESH VALUES.

DO N=1,NSTA

RA(N)=RIO(N)-GRIDX ! ajb added 07012008

RB(N)=RJO(N)-GRIDY ! ajb added 07012008

IA(N)=RA(N)

IB(N)=RB(N)

IOB=MAX0(1,IA(N))

IOB=MIN0(IOB,ide-1)

JOB=MAX0(1,IB(N))

JOB=MIN0(JOB,jde-1)

DXOB=RA(N)-FLOAT(IA(N))

DYOB=RB(N)-FLOAT(IB(N))

! Save mass-point arrays for computing rko for all var types

if(ityp.eq.1) then

iobmg(n) = MIN0(MAX0(1,int(RIO(n)-gridx_t)),ide-1)

jobmg(n) = MIN0(MAX0(1,int(RJO(n)-gridy_t)),jde-1)

dxobmg(n) = RIO(N)-gridx_t-FLOAT(int(RIO(N)-gridx_t))

dyobmg(n) = RJO(N)-gridy_t-FLOAT(int(RJO(N)-gridy_t))

endif

iob_ms = iobmg(n)

job_ms = jobmg(n)

dxob_ms = dxobmg(n)

dyob_ms = dyobmg(n)

! ajb 20090423: BUGFIX TO OBS_IN_HEIGHT OPTION (see COARSE MESH comments)

pob = 0.0

#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )

! Set mask for obs to be handled by this processor

MP_LOCAL_DUMMASK(N) = TILE_MASK(IOB, JOB, its, ite, jts, jte)

IF ( MP_LOCAL_DUMMASK(N) ) THEN

#endif

! Interpolate pressure to obs location column and convert from Pa to cb.

do k = kds, kde

pbbo(k) = .001*( &

(1.-DYOB_MS)*( (1.-DXOB_MS)*pbase(IOB_MS,K,JOB_MS) + &

DXOB_MS *pbase(IOB_MS+1,K,JOB_MS) ) + &

DYOB_MS* ( (1.-DXOB_MS)*pbase(IOB_MS,K,JOB_MS+1) + &

DXOB_MS *pbase(IOB_MS+1,K,JOB_MS+1) ) )

ppbo(k) = .001*( &

(1.-DYOB_MS)*( (1.-DXOB_MS)*pp(IOB_MS,K,JOB_MS) + &

DXOB_MS *pp(IOB_MS+1,K,JOB_MS) ) + &

DYOB_MS* ( (1.-DXOB_MS)*pp(IOB_MS,K,JOB_MS+1) + &

DXOB_MS *pp(IOB_MS+1,K,JOB_MS+1) ) )

enddo

!ajb 20040119: Note based on bugfix for dot/cross points split across processors,

!ajb which was actually a serial code fix: The ityp=2 (v-points) and

!ajb itype=3 (mass-points) cases should not use the ityp=1 (u-points)

!ajb case) rko! This is necessary for bit-for-bit reproducability

!ajb with parallel run. (fine mesh)

if(abs(rko(n)+99).lt.1.)then

pob = varobs(5,n)

if(pob .eq.-888888.) then

hob = varobs(6,n)

if(hob .gt. -800000. ) then

pob = ht_to_p( hob, ppbo, pbbo, z, iob_ms, job_ms, &

dxob_ms, dyob_ms, k_start, k_end, kds,kde, &

ims,ime, jms,jme, kms,kme )

endif

endif

if(pob .gt.-800000.)then

do k=k_end-1,1,-1

kbot = k

if(pob .le. pbbo(k)+ppbo(k)) then

goto 198

endif

enddo

198 continue

pphi = ppbo(kbot+1)

pbhi = pbbo(kbot+1)

rko(n) = real(kbot+1)- &

( (pob-pbhi-pphi) / (pbbo(kbot)+ppbo(kbot)-pbhi-pphi) )

rko(n)=max(rko(n),1.0)

endif

endif

#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )

ENDIF !end IF( MP_LOCAL_DUMMASK(N) ) !ajb

#endif

! ajb 20090423: If obs-in-height, varobs(5,n) is sum of pob (see note above).

if(varobs(5,n) .eq. -888888. .and. varobs(6,n) .gt. -800000.) then

varobs(5,n) = wrf_dm_sum_real ( pob )

endif

RC(N)=RKO(N)

ENDDO ! END FINE MESH LOOP OVER NSTA

ENDIF ! end if(inest.eq.1)

! INITIALIZE THE ARRAY OF DIFFERENCES BETWEEN THE OBSERVATIONS

! AND THE LOCAL FORECAST VALUES TO ZERO. FOR THE FINE MESH

! ONLY, SET THE DIFFERENCE TO A LARGE DUMMY VALUE IF THE

! OBSERVATION IS OUTSIDE THE FINE MESH DOMAIN.

! SET DIFFERENCE VALUE TO A DUMMY VALUE FOR OBS POINTS OUTSIDE

! CURRENT DOMAIN

IF(ITYP.EQ.1) THEN

NLB=1

NLE=1

ELSE IF(ITYP.EQ.2) THEN

NLB=2

NLE=2

ELSE

NLB=3

NLE=5

ENDIF

DO IVAR=NLB,NLE

DO N=1,NSTA

IF((RA(N)-1.).LT.0)THEN

ERRF(IVAR,N)=ERRF(IVAR,N)+DUMMY

ENDIF

IF((RB(N)-1.).LT.0)THEN

ERRF(IVAR,N)=ERRF(IVAR,N)+DUMMY

ENDIF

IF((FLOAT(ide)-2.0*GRIDX-RA(N)-1.E-10).LT.0)THEN

ERRF(IVAR,N)=ERRF(IVAR,N)+DUMMY

ENDIF

IF((FLOAT(jde)-2.0*GRIDY-RB(N)-1.E-10).LT.0)THEN

ERRF(IVAR,N)=ERRF(IVAR,N)+DUMMY

ENDIF

if(rc(n).lt.1.)errf(ivar,n)=errf(ivar,n)+dummy

ENDDO

ENDDO

! NOW FIND THE EXACT OFFSET OF EACH OBSERVATION FROM THE

! GRID POINT TOWARD THE LOWER LEFT

DO N=1,NSTA

IA(N)=RA(N)

IB(N)=RB(N)

IC(N)=RC(N)

ENDDO

DO N=1,NSTA

RA(N)=RA(N)-FLOAT(IA(N))

RB(N)=RB(N)-FLOAT(IB(N))

RC(N)=RC(N)-FLOAT(IC(N))

ENDDO

! PERFORM A TRILINEAR EIGHT-POINT (3-D) INTERPOLATION

! TO FIND THE FORECAST VALUE AT THE EXACT OBSERVATION

! POINTS FOR U, V, T, AND Q.