1 SUBROUTINE qc_reduction (nobs_max, obs, number_of_obs)
3 !-------------------------------------------------------------------------------
10 INTEGER, INTENT (in) :: nobs_max
11 TYPE (report), INTENT (inout), DIMENSION (nobs_max) :: obs
12 INTEGER, INTENT (in) :: number_of_obs
14 TYPE (measurement ) , POINTER :: current
15 INTEGER :: loop_index, nlevel
20 !------------------------------------------------------------------------------!
22 WRITE (UNIT = 0, FMT = '(A)') &
23 '------------------------------------------------------------------------------'
24 WRITE (UNIT = 0, FMT = '(A,/)') 'REDUCE QC FROM 7 TO 2 DIGITS:'
27 ! 1. LOOP OVER STATIONS
28 ! ====================
31 DO loop_index = 1, number_of_obs
34 ! 1.1 Check if record is valid
35 ! ------------------------
38 IF (obs(loop_index)%info%discard ) THEN
44 ! 1.2 Ground info qc reduction
45 ! ------------------------
47 CALL reduce_qc (obs (loop_index) % ground % slp % qc)
48 CALL reduce_qc (obs (loop_index) % ground % pw % qc)
49 CALL reduce_qc (obs (loop_index) % ground % tb19v % qc)
50 CALL reduce_qc (obs (loop_index) % ground % tb19h % qc)
51 CALL reduce_qc (obs (loop_index) % ground % tb22v % qc)
52 CALL reduce_qc (obs (loop_index) % ground % tb37v % qc)
53 CALL reduce_qc (obs (loop_index) % ground % tb37h % qc)
54 CALL reduce_qc (obs (loop_index) % ground % tb85v % qc)
55 CALL reduce_qc (obs (loop_index) % ground % tb85h % qc)
58 ! 1.3 Initialise upper level pointer to surface level
59 ! -----------------------------------------------
61 current => obs (loop_index) % surface
64 ! 2. LOOP ON UPPER-AIR LEVELS (FIRST LEVEL IS SURFACE)
65 ! ====================================================
67 upper_level: DO WHILE (ASSOCIATED (current))
69 CALL reduce_qc (current % meas % speed % qc)
70 CALL reduce_qc (current % meas % direction % qc)
71 CALL reduce_qc (current % meas % u % qc)
72 CALL reduce_qc (current % meas % v % qc)
73 CALL reduce_qc (current % meas % height % qc)
74 CALL reduce_qc (current % meas % pressure % qc)
75 CALL reduce_qc (current % meas % temperature % qc)
76 CALL reduce_qc (current % meas % dew_point % qc)
77 CALL reduce_qc (current % meas % rh % qc)
78 CALL reduce_qc (current % meas % qv % qc)
80 ! 3. GO TOP NEXT LEVEL
81 ! =====================
83 current => current%next
88 ! 6. GO TO NEXT STATION
89 ! ======================
92 ! 6.1 Go to next valid station
93 ! ------------------------
97 ! 6.1 Go to next station
106 END SUBROUTINE qc_reduction
107 ! ----------------------------------------------------------------
108 SUBROUTINE reduce_qc (QC)
110 !------------------------------------------------------------------------------!
111 INTEGER, INTENT (inout) :: qc
113 include 'missing.inc'
115 !------------------------------------------------------------------------------!
119 qc = -88 ! Missing data
121 ELSE IF (qc .EQ. 0) THEN
125 ELSE IF (qc .GE. outside_of_domain) THEN
127 qc = -77 ! Outside of horizontal domain
129 ELSE IF ((qc .LT. outside_of_domain) .AND. (qc .GE. wrong_direction))&
132 qc = -15 ! Wind direction <0 or > 360 degrees
134 ELSE IF ((qc .LT. wrong_direction) .AND. (qc .GE. negative_spd))&
137 qc = -14 ! Negative wind speed vector norm
139 ELSE IF ((qc .LT. negative_spd) .AND. (qc .GE. zero_spd))&
142 qc = -13 ! Null wind speed vector norm
144 ELSE IF ((qc .LT. zero_spd) .AND. (qc .GE. wrong_wind_data))&
147 qc = -12 ! Spike in the wind profile
149 ELSE IF ((qc .LT. wrong_wind_data) .AND. (qc .GE. zero_t_td))&
152 qc = -11 ! Null temperature or dew point
154 ELSE IF ((qc .LT. zero_t_td) .AND. (qc .GE. t_fail_supa_inver))&
157 qc = -10 ! Superadiabatic temperature
159 ELSE IF ((qc .LT. t_fail_supa_inver) .AND. (qc .GE. wrong_t_sign))&
162 qc = -9 ! Spike in Temperature profile
164 ELSE IF ((qc .LT. t_fail_supa_inver) .AND. (qc .GE. above_model_lid))&
167 qc = -8 ! Height higher than model lid's height
169 ELSE IF ((qc .LT. above_model_lid).AND.(qc .GE. reference_atmosphere))&
171 qc = -5 ! h,p or T from standard atmosphere
173 ELSE IF ((qc .LT. reference_atmosphere) .AND. (qc .GE. from_background)) &
176 qc = -4 ! h,p or T from background
178 ELSE IF ((qc .LT. from_background) .AND. (qc .GE. convective_adjustment))&
181 qc = 1 ! convective adjustement correction
183 ELSE IF ((qc .LT. convective_adjustment).AND.(qc .GE. Hydrostatic_recover)) THEN
185 qc = 3 ! Height recovery from hydrostaic + OBS
187 ELSE IF ((qc .LT. Hydrostatic_recover).AND.(qc .GE. surface_correction)) THEN
189 qc = 2 ! surface_correction
191 ELSE IF ((qc .LT. surface_correction).AND.(qc .GE. Reference_OBS_scaled)) THEN
193 qc = 4 ! Height recovery from reference + OBS
197 qc = 88 ! Any other check
201 END SUBROUTINE reduce_qc