Update version info for release v4.6.1 (#2122)
[WRF.git] / var / obsproc / src / qc_reduction.F90
blob36133bda780bce7b68c256ed6053196bcd18e99e
1 SUBROUTINE qc_reduction (nobs_max, obs, number_of_obs)
3 !-------------------------------------------------------------------------------
5   USE module_type
6   USE module_func
8   IMPLICIT NONE
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
16   
17    INTEGER             :: fm
19   include 'missing.inc'
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 ! ====================
30 stations: &
31       DO loop_index = 1, number_of_obs
34 ! 1.1 Check if record is valid
35 !     ------------------------
37 stations_valid: &
38       IF (obs(loop_index)%info%discard ) THEN
40       CYCLE  stations
42       ELSE stations_valid
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
85       ENDDO upper_level
88 ! 6.  GO TO NEXT STATION
89 ! ======================
92 ! 6.1 Go to next valid station
93 !     ------------------------
95       ENDIF  stations_valid
97 ! 6.1 Go to next station
98 !     ------------------
100       ENDDO  stations
102 ! 7.  END
103 ! =======
104       RETURN
106       END SUBROUTINE qc_reduction
107 ! ----------------------------------------------------------------
108 SUBROUTINE reduce_qc (QC)
110 !------------------------------------------------------------------------------!
111       INTEGER, INTENT (inout) :: qc
113       include 'missing.inc'
115 !------------------------------------------------------------------------------!
117      IF        (qc .LT. 0) THEN
119                 qc = -88               ! Missing data
121       ELSE IF  (qc .EQ. 0) THEN
123                 qc =   0               ! Good data
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))&
130       THEN
132                 qc = -15               ! Wind direction <0 or > 360 degrees
134       ELSE IF ((qc .LT. wrong_direction) .AND. (qc .GE. negative_spd))&
135       THEN
137                 qc = -14               ! Negative wind speed vector norm
139       ELSE IF ((qc .LT. negative_spd) .AND. (qc .GE. zero_spd))&
140       THEN
142                 qc = -13               ! Null wind speed vector norm
144       ELSE IF ((qc .LT. zero_spd) .AND. (qc .GE. wrong_wind_data))&
145       THEN
147                 qc = -12               ! Spike in the wind profile
149       ELSE IF ((qc .LT. wrong_wind_data) .AND. (qc .GE. zero_t_td))&
150       THEN
152                 qc = -11               ! Null temperature or dew point
154       ELSE IF ((qc .LT. zero_t_td) .AND. (qc .GE. t_fail_supa_inver))&
155       THEN
157                 qc = -10               ! Superadiabatic temperature
159       ELSE IF ((qc .LT. t_fail_supa_inver) .AND. (qc .GE. wrong_t_sign))&
160       THEN
162                 qc =  -9               ! Spike in Temperature profile
164       ELSE IF ((qc .LT. t_fail_supa_inver) .AND. (qc .GE. above_model_lid))&
165       THEN
167                 qc =  -8               ! Height higher than model lid's height
169       ELSE IF ((qc .LT. above_model_lid).AND.(qc .GE. reference_atmosphere))&
170       THEN
171                 qc =  -5               ! h,p or T from  standard atmosphere
173       ELSE IF ((qc .LT. reference_atmosphere) .AND. (qc .GE. from_background)) &
174       THEN
176                 qc =  -4               ! h,p or T from background
178       ELSE IF ((qc .LT. from_background) .AND. (qc .GE. convective_adjustment))&
179       THEN
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
188              
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
194      
195       ELSE
197                 qc =  88               ! Any other check
199       ENDIF
201 END SUBROUTINE reduce_qc