1module bgckMicrowave_mod
2 ! MODULE bgckMicrowave_mod (prefix='mwbg' category='1. High-level functionality')
3 !
4 !:Purpose: Perform background check and quality control for all microwave
5 ! satellite radiance observations: AMSU-A, AMSU-B/MHS, ATMS, MWHS2.
6 !
7 use midasMpi_mod
8 use MathPhysConstants_mod
9 use utilities_mod
10 use obsSpaceData_mod
11 use tovsNL_mod
12 use obsErrors_mod
13 use codtyp_mod
14
15 implicit none
16 save
17 private
18
19 ! Public functions/subroutines
20 public :: mwbg_bgCheckMW
21 public :: mwbg_computeMwhs2SurfaceType
22
23 real(8) :: mwbg_clwQcThreshold
24 real(8) :: mwbg_cloudyClwThresholdBcorr
25 real(8) :: mwbg_minSiOverWaterThreshold ! for AMSUB/MHS
26 real(8) :: mwbg_maxSiOverWaterThreshold ! for AMSUB/MHS
27 real(8) :: mwbg_cloudySiThresholdBcorr ! for AMSUB/MHS
28 logical :: mwbg_debug
29 logical :: mwbg_useUnbiasedObsForClw
30
31 integer, parameter :: mwbg_maxScanAngle = 98
32 real(8), parameter :: mwbg_realMissing = -99.0d0
33 integer, parameter :: mwbg_intMissing = -1
34
35 ! Module variable
36
37 integer, parameter :: mwbg_atmsNumSfcSensitiveChannel = 6
38 character(len=128), parameter :: fileMgLg='fstglmg' ! glace de mer file
39 ! Upper limit for CLW (kg/m**2) for Tb rejection over water
40 real(8), parameter :: clw_atms_nrl_LTrej = 0.175d0 ! lower trop chans 1-6, 16-20
41 real(8), parameter :: clw_atms_nrl_UTrej = 0.2d0 ! upper trop chans 7-9, 21-22
42 real(8), parameter :: clw_mwhs2_nrl_LTrej = 0.175d0
43 real(8), parameter :: clw_mwhs2_nrl_UTrej = 0.2d0
44 ! Other NRL thresholds
45 real(8), parameter :: scatec_atms_nrl_LTrej = 9.0d0 ! lower trop chans 1-6, 16-22
46 real(8), parameter :: scatec_atms_nrl_UTrej = 18.0d0 ! upper trop chans 7-9
47 real(8), parameter :: scatbg_atms_nrl_LTrej = 10.0d0 ! lower trop chans 1-6
48 real(8), parameter :: scatbg_atms_nrl_UTrej = 15.0d0 ! upper trop chans 7-9
49 real(8), parameter :: scatec_mwhs2_nrl_LTrej = 9.0d0 ! all MWHS-2 channels (over water)
50 real(8), parameter :: scatbg_mwhs2_cmc_LANDrej = 0.0d0 ! all MWHS-2 channels (all surfaces)
51 real(8), parameter :: scatbg_mwhs2_cmc_ICErej = 40.0d0
52 real(8), parameter :: scatbg_mwhs2_cmc_SEA = 15.0d0
53 real(8), parameter :: mean_Tb_183Ghz_min = 240.0d0 ! min. value for Mean(Tb) chans. 18-22
54
55 integer, parameter :: mwbg_maxNumChan = 100
56 integer, parameter :: mwbg_maxNumTest = 16
57
58 integer, allocatable :: rejectionCodArray(:,:,:) ! number of rejection per sat. per channl per test
59 integer, allocatable :: rejectionCodArray2(:,:,:) ! number of rejection per channl per test for ATMS 2nd category of tests
60
61 ! namelist variables
62 character(len=9) :: instName ! instrument name
63 real(4) :: clwQcThreshold !
64 real(4) :: cloudyClwThresholdBcorr !
65 real(4) :: minSiOverWaterThreshold ! min scattering index over water for AMSUB/MHS
66 real(4) :: maxSiOverWaterThreshold ! max scattering index over water for AMSUB/MHS
67 real(4) :: cloudySiThresholdBcorr !
68 logical :: useUnbiasedObsForClw !
69 logical :: RESETQC ! reset Qc flags option
70 logical :: modLSQ !
71 logical :: debug ! debug mode
72 logical :: skipTestArr(mwbg_maxNumTest) ! array to set to skip the test
73
74
75 namelist /nambgck/instName, clwQcThreshold, &
76 useUnbiasedObsForClw, debug, RESETQC, &
77 cloudyClwThresholdBcorr, modLSQ, &
78 minSiOverWaterThreshold, maxSiOverWaterThreshold, &
79 cloudySiThresholdBcorr, skipTestArr
80
81
82contains
83
84 subroutine mwbg_init()
85 !
86 !:Purpose: This subroutine reads the namelist section NAMBGCK for the module.
87 !
88 implicit none
89
90 ! Locals:
91 integer :: nulnam, ierr
92 integer, external :: fnom, fclos
93
94 ! Default values for namelist variables
95 debug = .false.
96 clwQcThreshold = 0.3
97 useUnbiasedObsForClw = .false.
98 cloudyClwThresholdBcorr = 0.05
99 minSiOverWaterThreshold = -10.0
100 maxSiOverWaterThreshold = 30.0
101 cloudySiThresholdBcorr = 5.0
102 RESETQC = .false.
103 modLSQ = .false.
104 skipTestArr(:) = .false.
105
106 nulnam = 0
107 ierr = fnom(nulnam, './flnml','FTN+SEQ+R/O', 0)
108 read(nulnam, nml=nambgck, iostat=ierr)
109 if (ierr /= 0) call utl_abort('mwbg_init: Error reading namelist')
110 if (mmpi_myid == 0) write(*, nml=nambgck)
111 ierr = fclos(nulnam)
112
113 mwbg_debug = debug
114 mwbg_clwQcThreshold = real(clwQcThreshold,8)
115 mwbg_useUnbiasedObsForClw = useUnbiasedObsForClw
116 mwbg_cloudyClwThresholdBcorr = real(cloudyClwThresholdBcorr,8)
117 mwbg_minSiOverWaterThreshold = real(minSiOverWaterThreshold,8)
118 mwbg_maxSiOverWaterThreshold = real(maxSiOverWaterThreshold,8)
119 mwbg_cloudySiThresholdBcorr = real(cloudySiThresholdBcorr,8)
120
121 ! Allocation
122 call utl_reAllocate(rejectionCodArray, mwbg_maxNumTest, mwbg_maxNumChan, tvs_nsensors)
123 call utl_reAllocate(rejectionCodArray2, mwbg_maxNumTest, mwbg_maxNumChan, tvs_nsensors)
124
125 end subroutine mwbg_init
126
127 !--------------------------------------------------------------------------
128 ! extractParamForGrodyRun
129 !--------------------------------------------------------------------------
130 subroutine extractParamForGrodyRun(tb23, tb31, tb50, tb53, tb89, &
131 tb23FG, tb31FG, tb50FG, tb53FG, tb89FG, &
132 headerIndex, sensorIndex, obsSpaceData)
133 !
134 !:Purpose: Compute Grody parameters by extracting tb for required channels:
135 ! - 23 Ghz = AMSU-A 1 = channel #28
136 ! - 31 Ghz = AMSU-A 2 = channel #29
137 ! - 50 Ghz = AMSU-A 3 = channel #30
138 ! - 53 Ghz = AMSU-A 5 = channel #32
139 ! - 89 Ghz = AMSU-A15 = channel #42
140 !
141 implicit none
142
143 ! Arguments:
144 real(8), intent(out) :: tb23 ! radiance frequence 23 Ghz
145 real(8), intent(out) :: tb31 ! radiance frequence 31 Ghz
146 real(8), intent(out) :: tb50 ! radiance frequence 50 Ghz
147 real(8), intent(out) :: tb53 ! radiance frequence 53 Ghz
148 real(8), intent(out) :: tb89 ! radiance frequence 89 Ghz
149 real(8), intent(out) :: tb23FG ! radiance frequence 23 Ghz
150 real(8), intent(out) :: tb31FG ! radiance frequence 31 Ghz
151 real(8), intent(out) :: tb50FG ! radiance frequence 50 Ghz
152 real(8), intent(out) :: tb53FG ! radiance frequence 53 Ghz
153 real(8), intent(out) :: tb89FG ! radiance frequence 89 Ghz
154 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
155 integer, intent(in) :: headerIndex ! current header Index
156 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
157
158 ! Locals:
159 integer :: bodyIndex, bodyIndexBeg, bodyIndexEnd, obsChanNum, obsChanNumWithOffset
160 real(8) :: obsTb, ompTb, obsTbBiasCorr
161
162 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
163 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
164
165 tb23 = mwbg_realMissing
166 tb31 = mwbg_realMissing
167 tb50 = mwbg_realMissing
168 tb53 = mwbg_realMissing
169 tb89 = mwbg_realMissing
170 tb23FG = mwbg_realMissing
171 tb31FG = mwbg_realMissing
172 tb50FG = mwbg_realMissing
173 tb53FG = mwbg_realMissing
174 tb89FG = mwbg_realMissing
175
176 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
177 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
178 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
179 ompTb = obs_bodyElem_r(obsSpaceData, OBS_OMP, bodyIndex)
180 obsTb = obs_bodyElem_r(obsSpaceData, OBS_VAR, bodyIndex)
181 obsTbBiasCorr = obs_bodyElem_r(obsSpaceData, OBS_BCOR, bodyIndex)
182
183 if ( obsTb /= mwbg_realMissing ) then
184 if ( obsTbBiasCorr /= mwbg_realMissing ) then
185 if ( obsChanNumWithOffset == 28 ) tb23 = obsTb - obsTbBiasCorr
186 if ( obsChanNumWithOffset == 29 ) tb31 = obsTb - obsTbBiasCorr
187 if ( obsChanNumWithOffset == 30 ) tb50 = obsTb - obsTbBiasCorr
188 if ( obsChanNumWithOffset == 32 ) tb53 = obsTb - obsTbBiasCorr
189 if ( obsChanNumWithOffset == 42 ) tb89 = obsTb - obsTbBiasCorr
190 else
191 if ( obsChanNumWithOffset == 28 ) tb23 = obsTb
192 if ( obsChanNumWithOffset == 29 ) tb31 = obsTb
193 if ( obsChanNumWithOffset == 30 ) tb50 = obsTb
194 if ( obsChanNumWithOffset == 32 ) tb53 = obsTb
195 if ( obsChanNumWithOffset == 42 ) tb89 = obsTb
196 end if
197
198 if ( obsChanNumWithOffset == 28 ) tb23FG = obsTb - ompTb
199 if ( obsChanNumWithOffset == 29 ) tb31FG = obsTb - ompTb
200 if ( obsChanNumWithOffset == 30 ) tb50FG = obsTb - ompTb
201 if ( obsChanNumWithOffset == 32 ) tb53FG = obsTb - ompTb
202 if ( obsChanNumWithOffset == 42 ) tb89FG = obsTb - ompTb
203 else
204 if ( obsChanNumWithOffset == 28 ) tb23 = 0.0d0
205 if ( obsChanNumWithOffset == 29 ) tb31 = 0.0d0
206 if ( obsChanNumWithOffset == 30 ) tb50 = 0.0d0
207 if ( obsChanNumWithOffset == 32 ) tb53 = 0.0d0
208 if ( obsChanNumWithOffset == 42 ) tb89 = 0.0d0
209
210 if ( obsChanNumWithOffset == 28 ) tb23FG = 0.0d0
211 if ( obsChanNumWithOffset == 29 ) tb31FG = 0.0d0
212 if ( obsChanNumWithOffset == 30 ) tb50FG = 0.0d0
213 if ( obsChanNumWithOffset == 32 ) tb53FG = 0.0d0
214 if ( obsChanNumWithOffset == 42 ) tb89FG = 0.0d0
215 end if
216 end do BODY
217
218 end subroutine extractParamForGrodyRun
219
220 !--------------------------------------------------------------------------
221 ! extractParamForBennartzRun
222 !--------------------------------------------------------------------------
223 subroutine extractParamForBennartzRun(tb89, tb150, tb1831, tb1832, tb1833, &
224 tb89FG, tb150FG, tb89FgClear, tb150FgClear, &
225 headerIndex, sensorIndex, obsSpaceData)
226 !
227 !:Purpose: Extract Parameters required to run bennaertz for required channels:
228 ! - 89 Ghz = AMSU-B 1 = channel #43
229 ! - 150 Ghz = AMSU-B 2 = channel #44
230 !
231 implicit none
232
233 ! Arguments:
234 real(8), intent(out) :: tb89 ! 89GHz radiance from observation
235 real(8), intent(out) :: tb150 ! 150GHz radiance from observation
236 real(8), intent(out) :: tb1831 ! 183GHz radiance from observation
237 real(8), intent(out) :: tb1832 ! 183GHz radiance from observation
238 real(8), intent(out) :: tb1833 ! 183GHz radiance from observation
239 real(8), intent(out) :: tb89FG ! 89GHz radiance from background
240 real(8), intent(out) :: tb150FG ! 150GHz radiance from background
241 real(8), intent(out) :: tb89FgClear ! 89GHz clear-sky radiance from background
242 real(8), intent(out) :: tb150FgClear ! 150GHz clear-sky radiance from background
243 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
244 integer, intent(in) :: headerIndex ! current header Index
245 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
246
247 ! Locals:
248 integer :: bodyIndex, bodyIndexBeg, bodyIndexEnd, obsChanNum, obsChanNumWithOffset, codtyp
249 real(8) :: obsTb, btClear, ompTb, obsTbBiasCorr
250
251 codtyp = obs_headElem_i(obsSpaceData, OBS_ITY, headerIndex)
252 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
253 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
254
255 tb89 = mwbg_realMissing
256 tb150 = mwbg_realMissing
257 tb1831 = mwbg_realMissing
258 tb1832 = mwbg_realMissing
259 tb1833 = mwbg_realMissing
260 tb89FG = mwbg_realMissing
261 tb150FG = mwbg_realMissing
262 tb89FgClear = mwbg_realMissing
263 tb150FgClear = mwbg_realMissing
264
265 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
266 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
267 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
268 ompTb = obs_bodyElem_r(obsSpaceData, OBS_OMP, bodyIndex)
269 obsTb = obs_bodyElem_r(obsSpaceData, OBS_VAR, bodyIndex)
270 obsTbBiasCorr = obs_bodyElem_r(obsSpaceData, OBS_BCOR, bodyIndex)
271 if (tvs_isInstrumAllskyHuAssim(tvs_getInstrumentId(codtyp_get_name(codtyp)))) then
272 btClear = obs_bodyElem_r(obsSpaceData, OBS_BTCL, bodyIndex)
273 else
274 btClear = mwbg_realMissing
275 end if
276
277 if ( obsTb /= mwbg_realMissing ) then
278 if ( obsTbBiasCorr /= mwbg_realMissing ) then
279 if ( obsChanNumWithOffset == 43 ) tb89 = obsTb - obsTbBiasCorr
280 if ( obsChanNumWithOffset == 44 ) tb150 = obsTb - obsTbBiasCorr
281 if ( obsChanNumWithOffset == 45 ) tb1831 = obsTb - obsTbBiasCorr
282 if ( obsChanNumWithOffset == 46 ) tb1832 = obsTb - obsTbBiasCorr
283 if ( obsChanNumWithOffset == 47 ) tb1833 = obsTb - obsTbBiasCorr
284 else
285 if ( obsChanNumWithOffset == 43 ) tb89 = obsTb
286 if ( obsChanNumWithOffset == 44 ) tb150 = obsTb
287 if ( obsChanNumWithOffset == 45 ) tb1831 = obsTb
288 if ( obsChanNumWithOffset == 46 ) tb1832 = obsTb
289 if ( obsChanNumWithOffset == 47 ) tb1833 = obsTb
290 end if
291
292 if ( obsChanNumWithOffset == 43 ) tb89FG = obsTb - ompTb
293 if ( obsChanNumWithOffset == 44 ) tb150FG = obsTb - ompTb
294
295 else
296 if ( obsChanNumWithOffset == 43 ) tb89 = 0.0d0
297 if ( obsChanNumWithOffset == 44 ) tb150 = 0.0d0
298 if ( obsChanNumWithOffset == 45 ) tb1831 = 0.0d0
299 if ( obsChanNumWithOffset == 46 ) tb1832 = 0.0d0
300 if ( obsChanNumWithOffset == 47 ) tb1833 = 0.0d0
301
302 if ( obsChanNumWithOffset == 43 ) tb89FG = 0.0d0
303 if ( obsChanNumWithOffset == 44 ) tb150FG = 0.0d0
304 end if
305
306 if (btClear /= mwbg_realMissing) then
307 if (obsChanNumWithOffset == 43) tb89FgClear = btClear
308 if (obsChanNumWithOffset == 44) tb150FgClear = btClear
309 else
310 if (obsChanNumWithOffset == 43) tb89FgClear = 0.0d0
311 if (obsChanNumWithOffset == 44) tb150FgClear = 0.0d0
312 end if
313 end do BODY
314
315 end subroutine extractParamForBennartzRun
316
317 !--------------------------------------------------------------------------
318 ! amsuABTest10RttovRejectCheck
319 !--------------------------------------------------------------------------
320 subroutine amsuABTest10RttovRejectCheck(sensorIndex, RESETQC, qcIndicator, headerIndex, obsSpaceData)
321 !
322 !:Purpose: test 10: RTTOV reject check (single).
323 ! Rejected datum flag has bit #9 on.
324 !
325 implicit none
326
327 ! Arguments:
328 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
329 logical, intent(in) :: RESETQC ! yes or not reset QC flag
330 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
331 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
332 integer, intent(in) :: headerIndex ! current header Index
333
334 ! Locals:
335 integer :: testIndex, IBIT, bodyIndex, bodyIndexBeg, bodyIndexEnd
336 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
337 character(len=9) :: stnId
338
339 if (RESETQC) return
340 testIndex = 10
341
342 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
343
344 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
345 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
346
347 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
348 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
349 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
350 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
351 if (obsChanNumWithOffset /= 20) then
352 IBIT = AND(obsFlags, 2**9)
353 if (IBIT /= 0) then
354 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
355 obsFlags = OR(obsFlags,2**7)
356 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
357 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex)+ 1
358
359 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
360
361 if ( mwbg_DEBUG ) then
362 write(*,*)stnId(2:9),' RTTOV REJECT.', &
363 'CHANNEL=', obsChanNumWithOffset, &
364 ' obsFlags= ',obsFlags
365 end if
366 end if
367
368 end if
369 end do BODY
370
371 end subroutine amsuABTest10RttovRejectCheck
372
373 !--------------------------------------------------------------------------
374 ! amsuABTest1TopographyCheck
375 !--------------------------------------------------------------------------
376 subroutine amsuABTest1TopographyCheck(sensorIndex, modelInterpTerrain, channelForTopoFilter, altitudeForTopoFilter, &
377 qcIndicator, headerIndex, obsSpaceData)
378 !
379 !:Purpose: test 1: Topography check (partial)
380 ! Channel 6 is rejected for topography > 250m.
381 ! Channel 7 is rejected for topography > 2000m.
382 !
383 implicit none
384
385 ! Arguments:
386 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
387 integer, intent(in) :: channelForTopoFilter(:) ! channel list for filter
388 real(8), intent(in) :: altitudeForTopoFilter(:)! altitude threshold
389 real(8), intent(in) :: modelInterpTerrain ! topo aux point d'obs
390 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
391 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
392 integer, intent(in) :: headerIndex ! current header Index
393
394 ! Locals:
395 integer :: numFilteringTest, indexFilteringTest, testIndex
396 integer :: bodyIndex, bodyIndexBeg, bodyIndexEnd
397 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
398 character(len=9) :: stnId
399
400 testIndex = 1
401
402 !check consistency between channelForTopoFilter and altitudeForTopoFilter
403 if ( size(altitudeForTopoFilter) /= size(channelForTopoFilter) ) then
404 call utl_abort('ABORT: amsuABTest1TopographyCheck, no consistency between channel List and altitude list ')
405 end if
406
407 numFilteringTest = size(altitudeForTopoFilter)
408 indexFilteringTest = 1
409
410 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
411
412 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
413 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
414
415 do while ( indexFilteringTest <= numFilteringTest )
416 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
417 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
418 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
419 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
420
421 if (obsChanNumWithOffset == channelForTopoFilter(indexFilteringTest)) then
422 if (modelInterpTerrain >= altitudeForTopoFilter(indexFilteringTest)) then
423 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
424 obsFlags = OR(obsFlags,2**9)
425 obsFlags = OR(obsFlags,2**18)
426 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
427 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
428 if ( mwbg_DEBUG ) then
429 write(*,*) stnId(2:9),' TOPOGRAPHY REJECT.', &
430 'CHANNEL=', obsChanNumWithOffset, &
431 ' TOPO= ',modelInterpTerrain
432 end if
433
434 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
435
436 end if
437 end if
438 end do BODY
439 indexFilteringTest = indexFilteringTest + 1
440 end do ! while ( indexFilteringTest <= numFilteringTest )
441
442 end subroutine amsuABTest1TopographyCheck
443
444 !--------------------------------------------------------------------------
445 ! amsuABTest2LandSeaQualifierCheck
446 !--------------------------------------------------------------------------
447 subroutine amsuABTest2LandSeaQualifierCheck(sensorIndex, qcIndicator, headerIndex, obsSpaceData)
448 !
449 !:Purpose: test 2: "Land/sea qualifier" code check (full)
450 ! allowed values are: 0 land, 1 sea, 2 coast.
451 !
452 implicit none
453
454 ! Arguments:
455 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
456 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
457 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
458 integer, intent(in) :: headerIndex ! current header Index
459
460 ! Locals:
461 integer :: testIndex, landQualifierIndice, bodyIndex, bodyIndexBeg, bodyIndexEnd
462 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
463 character(len=9) :: stnId
464
465 testIndex = 2
466
467 landQualifierIndice = obs_headElem_i(obsSpaceData, OBS_STYP, headerIndex)
468 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
469
470 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
471 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
472
473 if (landQualifierIndice < 0 .or. landQualifierIndice > 2) then
474 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
475 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
476 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
477 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
478
479 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
480 obsFlags = OR(obsFlags,2**9)
481 obsFlags = OR(obsFlags,2**7)
482 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
483 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
484
485 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
486 end do BODY
487
488 if ( mwbg_DEBUG ) then
489 write(*,*) stnId(2:9), 'LAND/SEA QUALifIER CODE', &
490 ' REJECT. landQualifierIndice=', landQualifierIndice
491 end if
492 end if
493
494 end subroutine amsuABTest2LandSeaQualifierCheck
495
496 !--------------------------------------------------------------------------
497 ! amsuABTest3TerrainTypeCheck
498 !--------------------------------------------------------------------------
499 subroutine amsuABTest3TerrainTypeCheck(sensorIndex, qcIndicator, headerIndex, obsSpaceData)
500 !
501 !:Purpose: test 3: "Terrain type" code check (full)
502 ! allowed values are: -1 missing, 0 sea-ice, 1 snow on land.
503 !
504 implicit none
505
506 ! Arguments:
507 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
508 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
509 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
510 integer, intent(in) :: headerIndex ! current header Index
511
512 ! Locals:
513 integer :: testIndex, terrainTypeIndice, bodyIndex, bodyIndexBeg, bodyIndexEnd
514 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
515 character(len=9) :: stnId
516
517 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
518 terrainTypeIndice = obs_headElem_i(obsSpaceData, OBS_TTYP, headerIndex)
519
520 ! If terrain type is missing, set it to -1 for the QC programs
521 if (terrainTypeIndice == 99) terrainTypeIndice = mwbg_intMissing
522
523 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
524 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
525
526 testIndex = 3
527 if ( terrainTypeIndice /= mwbg_intMissing ) then
528 if (terrainTypeIndice < 0 .or. terrainTypeIndice > 1) then
529 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
530 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
531 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
532 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
533
534 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
535 obsFlags = OR(obsFlags,2**9)
536 obsFlags = OR(obsFlags,2**7)
537 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
538 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
539
540 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
541 end do BODY
542 if ( mwbg_debug ) then
543 write(*,*)stnId(2:9),'TERRAIN type CODE', &
544 ' REJECT. TERRAIN=', terrainTypeIndice
545 end if
546 end if
547 end if
548
549 end subroutine amsuABTest3TerrainTypeCheck
550
551 !--------------------------------------------------------------------------
552 ! amsuABTest4FieldOfViewCheck
553 !--------------------------------------------------------------------------
554 subroutine amsuABTest4FieldOfViewCheck(sensorIndex, maxScanAngleAMSU, qcIndicator, &
555 headerIndex, obsSpaceData)
556 !
557 !:Purpose: test 4: Field of view number check (full)
558 ! Field of view acceptable range is [1,maxScanAngleAMSU] for AMSU footprints.
559 !
560 implicit none
561
562 ! Arguments:
563 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
564 integer, intent(in) :: maxScanAngleAMSU ! max scan angle
565 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
566 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
567 integer, intent(in) :: headerIndex ! current header Index
568
569 ! Locals:
570 integer :: testIndex, satScanPosition, bodyIndex, bodyIndexBeg, bodyIndexEnd
571 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
572 character(len=9) :: stnId
573
574 satScanPosition = obs_headElem_i(obsSpaceData, OBS_FOV , headerIndex)
575 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
576
577 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
578 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
579
580 testIndex = 4
581 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
582 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
583 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
584 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
585
586 if (satScanPosition < 1 .or. satScanPosition > maxScanAngleAMSU) then
587 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
588 obsFlags = OR(obsFlags,2**9)
589 obsFlags = OR(obsFlags,2**7)
590 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
591 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
592
593 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
594
595 if ( mwbg_debug ) then
596 write(*,*)stnId(2:9),'FIELD OF VIEW NUMBER', &
597 ' REJECT. FIELD OF VIEW= ', satScanPosition
598 end if
599 end if
600 end do BODY
601
602 end subroutine amsuABTest4FieldOfViewCheck
603
604 !--------------------------------------------------------------------------
605 ! amsuABTest5ZenithAngleCheck
606 !--------------------------------------------------------------------------
607 subroutine amsuABTest5ZenithAngleCheck(sensorIndex, qcIndicator, headerIndex, obsSpaceData)
608 !
609 !:Purpose: test 5: Satellite zenith angle check (full)
610 ! Satellite zenith angle acceptable range is [0.,60.].
611 !
612 implicit none
613
614 ! Arguments:
615 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
616 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
617 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
618 integer, intent(in) :: headerIndex ! current header Index
619
620 ! Locals:
621 integer :: testIndex, bodyIndex, bodyIndexBeg, bodyIndexEnd
622 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
623 real(8) :: satZenithAngle
624 character(len=9) :: stnId
625
626 testIndex = 5
627
628 satZenithAngle = obs_headElem_r(obsSpaceData, OBS_SZA, headerIndex)
629 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
630
631 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
632 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
633
634 if ( satZenithAngle /= mwbg_realMissing ) then
635 if (satZenithAngle < 0.0d0 .or. satZenithAngle > 60.0d0) then
636 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
637 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
638 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
639 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
640
641 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
642 obsFlags = OR(obsFlags,2**9)
643 obsFlags = OR(obsFlags,2**7)
644 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
645 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
646
647 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
648 end do BODY
649
650 if ( mwbg_debug ) then
651 write(*,*) stnId(2:9),' SATELLITE ZENITH ANGLE', &
652 ' REJECT. satZenithAngle= ', &
653 satZenithAngle
654 end if
655 end if
656 end if
657
658 end subroutine amsuABTest5ZenithAngleCheck
659
660 !--------------------------------------------------------------------------
661 ! amsuABTest6ZenAngleAndFovConsistencyCheck
662 !--------------------------------------------------------------------------
663 subroutine amsuABTest6ZenAngleAndFovConsistencyCheck(sensorIndex, ZANGL, maxScanAngleAMSU, qcIndicator, &
664 headerIndex, obsSpaceData)
665 !
666 !:Purpose: test 6: "Sat. zenith angle"/"field of view" consistency check. (full)
667 ! Acceptable difference between "Satellite zenith angle" and
668 ! "approximate angle computed from field of view number" is 1.8 degrees.
669 !
670 implicit none
671
672 ! Arguments:
673 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
674 real(8), intent(in) :: ZANGL ! satellite constant param
675 integer, intent(in) :: maxScanAngleAMSU ! max scan angle
676 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
677 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
678 integer, intent(in) :: headerIndex ! current header Index
679
680 ! Locals:
681 integer :: testIndex, satScanPosition, bodyIndex, bodyIndexBeg, bodyIndexEnd
682 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
683 real(8) :: APPROXIM, ANGDif, satZenithAngle
684 character(len=9) :: stnId
685
686 testIndex = 6
687
688 satZenithAngle = obs_headElem_r(obsSpaceData, OBS_SZA, headerIndex)
689 satScanPosition = obs_headElem_i(obsSpaceData, OBS_FOV , headerIndex)
690 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
691
692 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
693 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
694
695 if (satZenithAngle /= mwbg_realMissing .and. satScanPosition /= mwbg_intMissing) then
696 APPROXIM = ABS((satScanPosition - maxScanAngleAMSU / 2.0d0 - 0.5d0) * ZANGL)
697 ANGDif = ABS(satZenithAngle - APPROXIM)
698 if ( ANGDif > 1.8d0 ) then
699 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
700 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
701 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
702 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
703
704 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
705 obsFlags = OR(obsFlags,2**9)
706 obsFlags = OR(obsFlags,2**7)
707 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
708 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
709
710 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
711 end do BODY
712
713 if ( mwbg_debug ) then
714 write(*,*) stnId(2:9),' ANGLE/FIELD OF VIEW', &
715 ' INCONSISTENCY REJECT. satZenithAngle= ', &
716 satZenithAngle, ' FIELD OF VIEW= ',satScanPosition, &
717 ' ANGDif= ',ANGDif
718 end if
719 end if
720 end if
721
722 end subroutine amsuABTest6ZenAngleAndFovConsistencyCheck
723
724 !--------------------------------------------------------------------------
725 ! amsuABTest7landSeaQualifyerAndModelLandSeaConsistencyCheck
726 !--------------------------------------------------------------------------
727 subroutine amsuABTest7landSeaQualifyerAndModelLandSeaConsistencyCheck(sensorIndex, modelInterpLandFrac, &
728 qcIndicator, headerIndex, obsSpaceData)
729 !
730 !:Purpose: test 7: "Land/sea qual."/"model land/sea" consistency check (full).
731 ! Acceptable conditions are:
732 ! - both over ocean (landQualifierIndice=1; mg<0.01), new threshold 0.20, jh dec 2000,
733 ! - both over land (landQualifierIndice=0; mg>0.80), new threshold 0.50, jh dec 2000.
734 ! All other conditions are unacceptable.
735 !
736 implicit none
737
738 ! Arguments:
739 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
740 real(8), intent(in) :: modelInterpLandFrac ! model interpolated land fraction
741 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
742 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
743 integer, intent(in) :: headerIndex ! current header Index
744
745 ! Locals:
746 integer :: testIndex, landQualifierIndice, bodyIndex, bodyIndexBeg, bodyIndexEnd
747 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
748 character(len=9) :: stnId
749
750 testIndex = 7
751
752 landQualifierIndice = obs_headElem_i(obsSpaceData, OBS_STYP, headerIndex)
753 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
754
755 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
756 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
757
758 if (landQualifierIndice /= mwbg_intMissing .and. &
759 .not. (landQualifierIndice == 1 .and. modelInterpLandFrac < 0.20d0) .and. &
760 .not. (landQualifierIndice == 0 .and. modelInterpLandFrac > 0.50d0)) then
761 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
762 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
763 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
764 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
765
766 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
767 obsFlags = OR(obsFlags,2**9)
768 obsFlags = OR(obsFlags,2**7)
769 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
770 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
771
772 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
773 end do BODY
774
775 if ( mwbg_debug ) then
776 write(*,*) stnId(2:9),' LAND/SEA QUALifIER', &
777 ' INCONSISTENCY REJECT. landQualifierIndice= ', &
778 landQualifierIndice, ' MODEL MASK= ', modelInterpLandFrac
779 end if
780 end if
781
782 end subroutine amsuABTest7landSeaQualifyerAndModelLandSeaConsistencyCheck
783
784 !--------------------------------------------------------------------------
785 ! amsuABTest9UncorrectedTbCheck
786 !--------------------------------------------------------------------------
787 subroutine amsuABTest9UncorrectedTbCheck(sensorIndex, RESETQC, qcIndicator, headerIndex, obsSpaceData)
788 !
789 !:Purpose: test 9: Uncorrected Tb check (single).
790 ! Uncorrected datum (flag bit #6 off). In this case switch bit 11 ON.
791 !
792 implicit none
793
794 ! Arguments:
795 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
796 logical, intent(in) :: RESETQC ! yes or not reset QC flag
797 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
798 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
799 integer, intent(in) :: headerIndex ! current header Index
800
801 ! Locals:
802 integer :: testIndex, IBIT, bodyIndex, bodyIndexBeg, bodyIndexEnd
803 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
804 character(len=9) :: stnId
805
806 if (RESETQC) return
807 testIndex = 9
808
809 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
810
811 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
812 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
813
814 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
815 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
816 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
817 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
818
819 if (obsChanNumWithOffset /= 20) then
820 IBIT = AND(obsFlags, 2**6)
821 if (IBIT == 0) then
822 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
823 obsFlags = OR(obsFlags,2**11)
824 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
825 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex)+ 1
826
827 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
828
829 if ( mwbg_debug ) then
830 write(*,*) stnId(2:9),' UNCORRECTED TB REJECT.', &
831 'CHANNEL=', obsChanNumWithOffset, ' obsFlags= ',obsFlags
832 end if
833 end if
834 end if
835 end do BODY
836
837 end subroutine amsuABTest9UncorrectedTbCheck
838
839 !--------------------------------------------------------------------------
840 ! amsuABTest11RadianceGrossValueCheck
841 !--------------------------------------------------------------------------
842 subroutine amsuABTest11RadianceGrossValueCheck(sensorIndex, GROSSMIN, GROSSMAX, qcIndicator, &
843 headerIndex, obsSpaceData)
844 !
845 !:Purpose: test 11: Radiance observation "Gross" check (single).
846 ! Change this test from full to single. jh nov 2000.
847 !
848 implicit none
849
850 ! Arguments:
851 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
852 real(8), intent(in) :: GROSSMIN(:) ! Gross val min
853 real(8), intent(in) :: GROSSMAX(:) ! Gross val max
854 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
855 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
856 integer, intent(in) :: headerIndex ! current header Index
857
858 ! Locals:
859 integer :: testIndex, GROSSERROR, actualNumChannel, bodyIndex, bodyIndexBeg, bodyIndexEnd
860 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
861 real(8) :: obsTb
862 character(len=9) :: stnId
863
864 testIndex = 11
865 GROSSERROR = .FALSE.
866
867 actualNumChannel = tvs_coefs(sensorIndex)%coef%fmv_ori_nchn
868 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
869
870 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
871 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
872
873 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
874 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
875 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
876 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
877 obsTb = obs_bodyElem_r(obsSpaceData, OBS_VAR, bodyIndex)
878
879 if (obsChanNumWithOffset /= 20 .and. obsChanNumWithOffset >= 1 .and. &
880 obsChanNumWithOffset <= actualNumChannel) then
881
882 if (obsTb /= mwbg_realMissing .and. &
883 (obsTb < GROSSMIN(obsChanNumWithOffset) .or. &
884 obsTb > GROSSMAX(obsChanNumWithOffset))) then
885 GROSSERROR = .TRUE.
886 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
887 obsFlags = OR(obsFlags,2**9)
888 obsFlags = OR(obsFlags,2**7)
889 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
890 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex)+ 1
891
892 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
893
894 if ( mwbg_debug ) then
895 write(*,*) stnId(2:9),' GROSS CHECK REJECT.', &
896 'CHANNEL=', obsChanNumWithOffset, ' TB= ',obsTb
897 end if
898 end if
899 end if
900 end do BODY
901
902 end subroutine amsuABTest11RadianceGrossValueCheck
903
904 !--------------------------------------------------------------------------
905 ! amsuaTest12GrodyClwCheck
906 !--------------------------------------------------------------------------
907 subroutine amsuaTest12GrodyClwCheck(sensorIndex, ICLWREJ, qcIndicator, headerIndex, obsSpaceData)
908 !
909 !:Purpose: test 12: Grody cloud liquid water check (partial).
910 !
911 ! For Cloud Liquid Water > clwQcThreshold, reject AMSUA-A channels 1-5 and 15.
912 !
913 implicit none
914
915 ! Arguments:
916 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
917 integer, intent(in) :: ICLWREJ(:) ! rejection channel list
918 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
919 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
920 integer, intent(in) :: headerIndex ! current header Index
921
922 ! Locals:
923 integer :: testIndex, INDXCAN, landQualifierIndice, bodyIndex, bodyIndexBeg, bodyIndexEnd
924 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
925 real(8) :: clwUsedForQC, clwObsFGaveraged
926 real(8) :: cloudLiquidWaterPathObs, cloudLiquidWaterPathFG
927 logical :: surfTypeIsWater, cldPredMissing
928 character(len=9) :: stnId
929
930 testIndex = 12
931
932 cloudLiquidWaterPathObs = obs_headElem_r(obsSpaceData, OBS_CLWO, headerIndex)
933 cloudLiquidWaterPathFG = obs_headElem_r(obsSpaceData, OBS_CLWB, headerIndex)
934 landQualifierIndice = obs_headElem_i(obsSpaceData, OBS_STYP, headerIndex)
935 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
936
937 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
938 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
939
940 if ( tvs_mwAllskyAssim ) then
941 clwObsFGaveraged = 0.5d0 * (cloudLiquidWaterPathObs + cloudLiquidWaterPathFG)
942 clwUsedForQC = clwObsFGaveraged
943 cldPredMissing = (cloudLiquidWaterPathObs == mwbg_realMissing .or. cloudLiquidWaterPathFG == mwbg_realMissing)
944 else
945 clwUsedForQC = cloudLiquidWaterPathObs
946 cldPredMissing = (cloudLiquidWaterPathObs == mwbg_realMissing)
947 end if
948
949 surfTypeIsWater = (landQualifierIndice == 1)
950
951 if (.not. cldPredMissing) then
952 if (clwUsedForQC > mwbg_clwQcThreshold) then
953 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
954 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
955 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
956 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
957
958 INDXCAN = utl_findloc(ICLWREJ(:),obsChanNumWithOffset)
959 if ( INDXCAN /= 0 ) then
960 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
961 obsFlags = OR(obsFlags,2**9)
962 obsFlags = OR(obsFlags,2**7)
963 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
964 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
965 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
966 end if
967 end do BODY
968
969 if ( mwbg_debug ) then
970 write(*,*) stnId(2:9), 'Grody cloud liquid water check', &
971 ' REJECT. CLW= ',clwUsedForQC, ' SEUIL= ',mwbg_clwQcThreshold
972 end if
973 end if
974
975 ! In all-sky mode, turn on bit=23 for channels in ICLWREJ(:) as
976 ! cloud-affected radiances over sea when there is mismatch between
977 ! cloudLiquidWaterPathObs and cloudLiquidWaterPathFG (to be used in gen_bias_corr)
978 clwObsFGaveraged = 0.5d0 * (cloudLiquidWaterPathObs + cloudLiquidWaterPathFG)
979 IF (tvs_mwAllskyAssim .and. clwObsFGaveraged > mwbg_cloudyClwThresholdBcorr) then
980 BODY2: do bodyIndex = bodyIndexBeg, bodyIndexEnd
981 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
982 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
983 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
984 INDXCAN = utl_findloc(ICLWREJ(:),obsChanNumWithOffset)
985
986 if ( INDXCAN /= 0 ) then
987 obsFlags = OR(obsFlags,2**23)
988 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
989 end if
990 end do BODY2
991
992 if ( mwbg_debug ) then
993 write(*,*) stnId(2:9), ' Grody cloud liquid water check', &
994 ' cloud-affected obs. CLW= ',clwUsedForQC, ', threshold= ', &
995 mwbg_cloudyClwThresholdBcorr
996 end if
997 end if
998
999 ! Reject surface sensitive observations over water, in all-sky mode,
1000 ! if CLW is not retrieved, and is needed to define obs error.
1001 else if (tvs_mwAllskyAssim .and. surfTypeIsWater .and. cldPredMissing) then
1002 loopChannel: do bodyIndex = bodyIndexBeg, bodyIndexEnd
1003 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
1004 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
1005 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
1006
1007 INDXCAN = utl_findloc(ICLWREJ(:),obsChanNumWithOffset)
1008 if ( INDXCAN /= 0 .and. oer_useStateDepSigmaObs(obsChanNumWithOffset,sensorIndex) ) then
1009 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
1010 obsFlags = OR(obsFlags,2**9)
1011 obsFlags = OR(obsFlags,2**7)
1012 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
1013 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
1014
1015 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
1016 end if
1017 end do loopChannel
1018
1019 end if
1020
1021 end subroutine amsuaTest12GrodyClwCheck
1022
1023 !-------------------------------------------------------------------------
1024 ! amsubTest12DrynessIndexCheck
1025 !-------------------------------------------------------------------------
1026 subroutine amsubTest12DrynessIndexCheck(sensorIndex, tb1831, tb1833, modelInterpSeaIce, qcIndicator, &
1027 headerIndex, obsSpaceData, skipTestArr_opt)
1028 !
1029 !:Purpose: test 12: Dryness index check.
1030 ! The difference between channels AMSUB-3 and AMSUB-5 is used as an indicator
1031 ! of "dryness" of the atmosphere. In extreme dry conditions, channels AMSUB-3 4 and 5
1032 ! are sensitive to the surface.
1033 ! Therefore, various thresholds are used to reject channels AMSUB-3 4 and 5 over land and ice
1034 !
1035 implicit none
1036
1037 ! Arguments:
1038 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
1039 real(8), intent(in) :: tb1831 ! tb for channel
1040 real(8), intent(in) :: tb1833 ! tb for channel
1041 real(8), intent(in) :: modelInterpSeaIce ! topo interpolated to obs point
1042 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
1043 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
1044 integer, intent(in) :: headerIndex ! current header Index
1045 logical, optional, intent(in) :: skipTestArr_opt(:) ! array to set to skip the test
1046
1047 ! Locals:
1048 integer :: testIndex, landQualifierIndice, bodyIndex, bodyIndexBeg, bodyIndexEnd
1049 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
1050 real(8) :: drynessIndex
1051 character(len=9) :: stnId
1052 logical, save :: firstCall = .true.
1053
1054 testIndex = 12
1055 if (present(skipTestArr_opt)) then
1056 if (skipTestArr_opt(testIndex)) then
1057 if (firstCall) then
1058 firstCall = .false.
1059 write(*,*) 'amsubTest12DrynessIndexCheck: skipping this test'
1060 end if
1061 return
1062 end if
1063 end if
1064
1065 landQualifierIndice = obs_headElem_i(obsSpaceData, OBS_STYP, headerIndex)
1066 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
1067
1068 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
1069 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
1070
1071 drynessIndex = tb1831 - tb1833
1072 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
1073 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
1074 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
1075 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
1076
1077 if ( .not. ((landQualifierIndice == 1) .and. &
1078 (modelInterpSeaIce < 0.01d0)) ) then
1079 if (obsChanNumWithOffset == 45 .and. drynessIndex > 0.0d0) then
1080 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
1081 obsFlags = OR(obsFlags,2**9)
1082 obsFlags = OR(obsFlags,2**7)
1083 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
1084 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
1085
1086 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
1087
1088 if (mwbg_debug) then
1089 write(*,*) stnId(2:9),' DRYNESS INDEX REJECT.', &
1090 'CHANNEL=', obsChanNumWithOffset, &
1091 'INDEX= ',drynessIndex
1092 end if
1093
1094 else if (obsChanNumWithOffset == 46 .and. drynessIndex > -10.0d0) then
1095 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
1096 obsFlags = OR(obsFlags,2**9)
1097 obsFlags = OR(obsFlags,2**7)
1098 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
1099 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
1100
1101 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
1102
1103 if (mwbg_debug) then
1104 write(*,*) stnId(2:9),' DRYNESS INDEX REJECT.', &
1105 'CHANNEL=', obsChanNumWithOffset,&
1106 'INDEX= ',drynessIndex
1107 end if
1108
1109 else if (obsChanNumWithOffset == 47 .and. drynessIndex > -20.0d0) then
1110 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
1111 obsFlags = OR(obsFlags,2**9)
1112 obsFlags = OR(obsFlags,2**7)
1113 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
1114 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
1115
1116 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
1117
1118 if (mwbg_debug) then
1119 write(*,*) stnId(2:9),' DRYNESS INDEX REJECT.', &
1120 'CHANNEL=', obsChanNumWithOffset,&
1121 'INDEX= ',drynessIndex
1122 end if
1123
1124 end if
1125 end if
1126 end do BODY
1127
1128 end subroutine amsubTest12DrynessIndexCheck
1129
1130 !--------------------------------------------------------------------------
1131 ! amsuaTest13GrodyScatteringIndexCheck
1132 !--------------------------------------------------------------------------
1133 subroutine amsuaTest13GrodyScatteringIndexCheck(sensorIndex, ISCATREJ, qcIndicator, headerIndex, obsSpaceData)
1134 !
1135 !:Purpose: test 13: Grody scattering index check (partial).
1136 !
1137 ! For Scattering Index > 9, reject AMSUA-A channels 1-6 and 15.
1138 !
1139 implicit none
1140
1141 ! Arguments:
1142 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
1143 integer, intent(in) :: ISCATREJ(:) ! rejection channel list
1144 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
1145 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
1146 integer, intent(in) :: headerIndex ! current header Index
1147
1148 ! Locals:
1149 integer :: testIndex, INDXCAN, landQualifierIndice, terrainTypeIndice, bodyIndex, bodyIndexBeg, bodyIndexEnd
1150 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
1151 real(8) :: ZSEUILSCAT, scatIndexOverWaterObs
1152 character(len=9) :: stnId
1153
1154 testIndex = 13
1155 ZSEUILSCAT = 9.0
1156
1157 scatIndexOverWaterObs = obs_headElem_r(obsSpaceData, OBS_SIO, headerIndex)
1158 landQualifierIndice = obs_headElem_i(obsSpaceData, OBS_STYP, headerIndex)
1159 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
1160 terrainTypeIndice = obs_headElem_i(obsSpaceData, OBS_TTYP, headerIndex)
1161
1162 ! If terrain type is missing, set it to -1 for the QC programs
1163 if (terrainTypeIndice == 99) terrainTypeIndice = mwbg_intMissing
1164
1165 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
1166 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
1167
1168 if ( scatIndexOverWaterObs /= MPC_missingValue_R8 ) then
1169 if (landQualifierIndice == 1 .and. terrainTypeIndice /= 0 .and. &
1170 scatIndexOverWaterObs > ZSEUILSCAT) then
1171 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
1172 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
1173 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
1174 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
1175
1176 INDXCAN = utl_findloc(ISCATREJ(:),obsChanNumWithOffset)
1177 if ( INDXCAN /= 0 ) then
1178 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
1179 obsFlags = OR(obsFlags,2**9)
1180 obsFlags = OR(obsFlags,2**7)
1181 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
1182 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
1183
1184 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
1185 end if
1186 end do BODY
1187
1188 if ( mwbg_debug ) then
1189 write(*,*) stnId(2:9), 'Grody scattering index check', &
1190 ' REJECT. scatIndexOverWaterObs= ', scatIndexOverWaterObs, ' SEUIL= ',ZSEUILSCAT
1191 end if
1192 end if
1193 end if
1194
1195 end subroutine amsuaTest13GrodyScatteringIndexCheck
1196
1197 !--------------------------------------------------------------------------
1198 ! amsubTest13BennartzScatteringIndexCheck
1199 !--------------------------------------------------------------------------
1200 subroutine amsubTest13BennartzScatteringIndexCheck(sensorIndex, scatIndexOverLandObs, modelInterpSeaIce, &
1201 qcIndicator, chanIgnoreInAllskyGenCoeff, &
1202 headerIndex, obsSpaceData, skipTestArr_opt)
1203 !
1204 !:Purpose: test 13: Bennartz scattering index check (full).
1205 ! For Scattering Index:
1206 ! - > 40 sea ice,
1207 ! - > 15 sea,
1208 ! - > 0 land reject all AMSUB Channels
1209 !
1210 implicit none
1211
1212 ! Arguments:
1213 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
1214 real(8), intent(in) :: scatIndexOverLandObs ! scattering index over land
1215 real(8), intent(in) :: modelInterpSeaIce ! glace de mer
1216 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
1217 integer, intent(in) :: chanIgnoreInAllskyGenCoeff(:) ! channels to exclude from genCoeff
1218 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
1219 integer, intent(in) :: headerIndex ! current header Index
1220 logical, optional, intent(in) :: skipTestArr_opt(:) ! array to set to skip the test
1221
1222 ! Locals:
1223 integer :: testIndex, chanIndex, landQualifierIndice, bodyIndex, bodyIndexBeg, bodyIndexEnd
1224 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
1225 real(8) :: ZSEUILSCATICE, ZSEUILSCATL, ZSEUILSCATW
1226 real(8) :: scatwUsedForQcThresh, scatwObsFGaveraged, scatwUsedForQC
1227 real(8) :: scatIndexOverWaterObs, scatIndexOverWaterFG
1228 character(len=9) :: stnId
1229 logical :: FULLREJCT, surfTypeIsSea, cldPredMissing
1230 logical, save :: firstCall = .true.
1231
1232 testIndex = 13
1233 if (present(skipTestArr_opt)) then
1234 if (skipTestArr_opt(testIndex)) then
1235 if (firstCall) then
1236 firstCall = .false.
1237 write(*,*) 'amsubTest13BennartzScatteringIndexCheck: skipping this test'
1238 end if
1239 return
1240 end if
1241 end if
1242
1243 ZSEUILSCATICE = 40.0d0
1244 ZSEUILSCATW = 15.0d0
1245 ZSEUILSCATL = 0.0d0
1246 FULLREJCT = .false.
1247 surfTypeIsSea = .false.
1248
1249 scatIndexOverWaterObs = obs_headElem_r(obsSpaceData, OBS_SIO, headerIndex)
1250 scatIndexOverWaterFG = obs_headElem_r(obsSpaceData, OBS_SIB, headerIndex)
1251 landQualifierIndice = obs_headElem_i(obsSpaceData, OBS_STYP, headerIndex)
1252 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
1253
1254 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
1255 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
1256
1257 if (landQualifierIndice == 1) then
1258 if ( modelInterpSeaIce > 0.01d0 ) then ! sea ice
1259 if (scatIndexOverWaterObs /= MPC_missingValue_R8 .and. scatIndexOverWaterObs > ZSEUILSCATICE) then
1260 FULLREJCT = .TRUE.
1261 end if
1262 else ! sea
1263 surfTypeIsSea = .true.
1264
1265 if (tvs_mwAllskyAssim) then
1266 scatwObsFGaveraged = 0.5d0 * (scatIndexOverWaterObs + scatIndexOverWaterFG)
1267 scatwUsedForQC = scatwObsFGaveraged
1268 scatwUsedForQcThresh = mwbg_maxSiOverWaterThreshold
1269 cldPredMissing = (scatIndexOverWaterObs == MPC_missingValue_R8 .or. &
1270 scatIndexOverWaterFG == MPC_missingValue_R8)
1271 else
1272 scatwUsedForQC = scatIndexOverWaterObs
1273 scatwUsedForQcThresh = ZSEUILSCATW
1274 cldPredMissing = (scatIndexOverWaterObs == MPC_missingValue_R8)
1275 end if
1276
1277 if (.not. cldPredMissing .and. scatwUsedForQC > scatwUsedForQcThresh) then
1278 FULLREJCT = .TRUE.
1279 end if
1280 end if
1281
1282 else ! land
1283 if ( scatIndexOverLandObs /= mwbg_realMissing .and. scatIndexOverLandObs > ZSEUILSCATL ) then
1284 FULLREJCT = .TRUE.
1285 end if
1286 end if
1287 if ( FULLREJCT ) then
1288 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
1289 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
1290 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
1291 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
1292
1293 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
1294 obsFlags = OR(obsFlags,2**9)
1295 obsFlags = OR(obsFlags,2**7)
1296 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
1297 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
1298
1299 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
1300 end do BODY
1301
1302 if (mwbg_debug) then
1303 write(*,*) stnId(2:9), ' BENNARTZ scattering index check REJECT, scatIndexOverWaterObs=', &
1304 scatIndexOverWaterObs, ', scatIndexOverWaterFG=', scatIndexOverWaterFG, &
1305 ', scatIndexOverLandObs= ',scatIndexOverLandObs
1306 end if
1307 end if ! if ( FULLREJCT )
1308
1309 if (tvs_mwAllskyAssim .and. surfTypeIsSea) then
1310 scatwObsFGaveraged = 0.5d0 * (scatIndexOverWaterObs + scatIndexOverWaterFG)
1311
1312 ! In all-sky mode, turn on bit=23 for channels in chanIgnoreInAllskyGenCoeff(:)
1313 ! as cloud-affected radiances over sea when there is mismatch between
1314 ! scatIndexOverWaterObs and scatIndexOverWaterFG (to be used in gen_bias_corr)
1315 if (scatwObsFGaveraged > mwbg_cloudySiThresholdBcorr .or. cldPredMissing) then
1316 BODY2: do bodyIndex = bodyIndexBeg, bodyIndexEnd
1317 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
1318 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
1319 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
1320
1321 chanIndex = utl_findloc(chanIgnoreInAllskyGenCoeff(:),obsChanNumWithOffset)
1322 if (chanIndex == 0) cycle BODY2
1323 obsFlags = OR(obsFlags,2**23)
1324
1325 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
1326 end do BODY2
1327
1328 if ( mwbg_debug ) then
1329 write(*,*) stnId(2:9),' BENNARTZ scattering index check', &
1330 ' cloud-affected obs. scatwObsFGaveraged= ', scatwObsFGaveraged, ', threshold= ', &
1331 mwbg_cloudySiThresholdBcorr
1332 end if
1333 end if
1334 end if
1335
1336 if (tvs_mwAllskyAssim .and. landQualifierIndice == 1) then
1337 scatwObsFGaveraged = 0.5d0 * (scatIndexOverWaterObs + scatIndexOverWaterFG)
1338 cldPredMissing = (scatIndexOverWaterObs == MPC_missingValue_R8 .or. &
1339 scatIndexOverWaterFG == MPC_missingValue_R8)
1340
1341 ! In all-sky mode, reject observations over sea if:
1342 ! - scatwObsFGaveraged can not be computed.
1343 ! - scatwObsFGaveraged smaller than the minimum value
1344 ! - scatwObsFGaveraged greater than the maximum value
1345 ! scatwObsFGaveraged is needed to define obs error.
1346 if (cldPredMissing .or. scatwObsFGaveraged < mwbg_minSiOverWaterThreshold .or. &
1347 scatwObsFGaveraged > mwbg_maxSiOverWaterThreshold) then
1348
1349 loopChannel3: do bodyIndex = bodyIndexBeg, bodyIndexEnd
1350 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
1351 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
1352 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
1353
1354 if (oer_useStateDepSigmaObs(obsChanNumWithOffset,sensorIndex)) then
1355 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
1356 obsFlags = OR(obsFlags,2**9)
1357 obsFlags = OR(obsFlags,2**7)
1358 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
1359 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
1360 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
1361 end if
1362 end do loopChannel3
1363 end if
1364
1365 end if ! if (tvs_mwAllskyAssim .and. surfTypeIsSea)
1366
1367 end subroutine amsubTest13BennartzScatteringIndexCheck
1368
1369 !--------------------------------------------------------------------------
1370 ! amsuaTest14RogueCheck
1371 !--------------------------------------------------------------------------
1372 subroutine amsuaTest14RogueCheck(sensorIndex, ROGUEFAC, ISFCREJ, qcIndicator, headerIndex, obsSpaceData)
1373 !
1374 !:Purpose: test 14: "Rogue check" for (O-P) Tb residuals out of range.
1375 ! (single/full). Les observations, dont le residu (O-P)
1376 ! depasse par un facteur (roguefac) l'erreur totale des TOVS.
1377 !
1378 ! N.B.: a reject by any of the 3 surface channels produces the
1379 ! rejection of AMSUA-A channels 1-5 and 15.
1380 !
1381 implicit none
1382
1383 ! Arguments:
1384 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
1385 real(8), intent(in) :: ROGUEFAC(:) ! rogue factor
1386 integer, intent(in) :: ISFCREJ(:) ! rejection channel list
1387 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
1388 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
1389 integer, intent(in) :: headerIndex ! current header Index
1390
1391 ! Locals:
1392 integer :: testIndex, INDXCAN, landQualifierIndice, bodyIndex, bodyIndexBeg, bodyIndexEnd
1393 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
1394 real(8) :: XCHECKVAL, clwThresh1, clwThresh2, errThresh1, errThresh2
1395 real(8) :: sigmaObsErrUsed, clwObsFGaveraged
1396 real(8) :: cloudLiquidWaterPathObs, cloudLiquidWaterPathFG
1397 real(8) :: ompTb
1398 logical :: SFCREJCT, surfTypeIsWater
1399 character(len=9) :: stnId
1400
1401 testIndex = 14
1402
1403 cloudLiquidWaterPathObs = obs_headElem_r(obsSpaceData, OBS_CLWO, headerIndex)
1404 cloudLiquidWaterPathFG = obs_headElem_r(obsSpaceData, OBS_CLWB, headerIndex)
1405 landQualifierIndice = obs_headElem_i(obsSpaceData, OBS_STYP, headerIndex)
1406 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
1407 surfTypeIsWater = (landQualifierIndice == 1)
1408
1409 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
1410 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
1411
1412 SFCREJCT = .FALSE.
1413 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
1414 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
1415 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
1416 if (obsChanNumWithOffset /= 20) then
1417 ! using state-dependent obs error only over water.
1418 ! obs over sea-ice will be rejected in test 15.
1419 if ( tvs_mwAllskyAssim .and. oer_useStateDepSigmaObs(obsChanNumWithOffset,sensorIndex) &
1420 .and. surfTypeIsWater ) then
1421 clwThresh1 = oer_cldPredThresh(obsChanNumWithOffset,sensorIndex,1)
1422 clwThresh2 = oer_cldPredThresh(obsChanNumWithOffset,sensorIndex,2)
1423 errThresh1 = oer_errThreshAllsky(obsChanNumWithOffset,sensorIndex,1)
1424 errThresh2 = oer_errThreshAllsky(obsChanNumWithOffset,sensorIndex,2)
1425 clwObsFGaveraged = 0.5d0 * (cloudLiquidWaterPathObs + cloudLiquidWaterPathFG)
1426 if (cloudLiquidWaterPathObs == mwbg_realMissing .or. cloudLiquidWaterPathFG == mwbg_realMissing) then
1427 sigmaObsErrUsed = MPC_missingValue_R8
1428 else
1429 sigmaObsErrUsed = calcStateDepObsErr(clwThresh1,clwThresh2,errThresh1, &
1430 errThresh2,clwObsFGaveraged)
1431 end if
1432 else
1433 sigmaObsErrUsed = oer_toverrst(obsChanNumWithOffset,sensorIndex)
1434 end if
1435 ! For sigmaObsErrUsed=MPC_missingValue_R8 (cloudLiquidWaterPathObs[FG]=mwbg_realMissing
1436 ! in all-sky mode), the observation is already rejected in test 12.
1437 XCHECKVAL = ROGUEFAC(obsChanNumWithOffset) * sigmaObsErrUsed
1438 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
1439 ompTb = obs_bodyElem_r(obsSpaceData, OBS_OMP, bodyIndex)
1440
1441 if (ompTb /= mwbg_realMissing .and. &
1442 ABS(ompTb) >= XCHECKVAL .and. &
1443 sigmaObsErrUsed /= MPC_missingValue_R8) then
1444 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
1445 obsFlags = OR(obsFlags,2**9)
1446 obsFlags = OR(obsFlags,2**16)
1447 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
1448 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
1449
1450 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
1451
1452 if ( mwbg_debug ) then
1453 write(*,*) stnId(2:9),'ROGUE CHECK REJECT.NO.', &
1454 ' CHANNEL= ',obsChanNumWithOffset, &
1455 ' CHECK VALUE= ',XCHECKVAL, &
1456 ' TBOMP= ',ompTb
1457 end if
1458 if (obsChanNumWithOffset == 28 .or. obsChanNumWithOffset == 29 .or. obsChanNumWithOffset == 30) SFCREJCT = .TRUE.
1459 end if ! if (ompTb /= mwbg_realMissing
1460
1461 end if ! if (obsChanNumWithOffset /= 20)
1462 end do BODY
1463
1464 if ( SFCREJCT ) then
1465 BODY2: do bodyIndex = bodyIndexBeg, bodyIndexEnd
1466 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
1467 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
1468 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
1469
1470 INDXCAN = utl_findloc(ISFCREJ(:),obsChanNumWithOffset)
1471 if ( INDXCAN /= 0 ) then
1472 if ( qcIndicator(obsChanNum) /= testIndex ) then
1473 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
1474 obsFlags = OR(obsFlags,2**9)
1475 obsFlags = OR(obsFlags,2**16)
1476 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
1477 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
1478
1479 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
1480 end if
1481 end if
1482 end do BODY2
1483 end if ! SFCREJCT
1484
1485 end subroutine amsuaTest14RogueCheck
1486
1487 !--------------------------------------------------------------------------
1488 ! amsubTest14RogueCheck
1489 !--------------------------------------------------------------------------
1490 subroutine amsubTest14RogueCheck(sensorIndex, ROGUEFAC, ICH2OMPREJ, qcIndicator, &
1491 headerIndex, obsSpaceData, skipTestArr_opt)
1492 !
1493 !:Purpose: test 14: "Rogue check" for (O-P) Tb residuals out of range. (single)
1494 ! Also, remove CH2,3,4,5 if CH2 |O-P|>5K (partial)
1495 !
1496 implicit none
1497
1498 ! Arguments:
1499 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
1500 real(8), intent(in) :: ROGUEFAC(:) ! rogue factor
1501 integer, intent(in) :: ICH2OMPREJ(:) ! rejection channel list
1502 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
1503 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
1504 integer, intent(in) :: headerIndex ! current header Index
1505 logical, optional, intent(in) :: skipTestArr_opt(:) ! array to set to skip the test
1506
1507 ! Locals:
1508 integer :: testIndex, INDXCAN, landQualifierIndice, terrainTypeIndice, bodyIndex, bodyIndexBeg, bodyIndexEnd
1509 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
1510 real(8) :: XCHECKVAL, siThresh1, siThresh2, errThresh1, errThresh2
1511 real(8) :: sigmaObsErrUsed, scatwObsFGaveraged
1512 real(8) :: scatIndexOverWaterObs, scatIndexOverWaterFG
1513 real(8) :: ompTb
1514 character(len=9) :: stnId
1515 logical :: CH2OMPREJCT, ch2OmpRejectInAllsky, channelIsAllsky, surfTypeIsWater
1516 logical, save :: firstCall = .true.
1517
1518 testIndex = 14
1519 if (present(skipTestArr_opt)) then
1520 if (skipTestArr_opt(testIndex)) then
1521 if (firstCall) then
1522 firstCall = .false.
1523 write(*,*) 'amsubTest14RogueCheck: skipping this test'
1524 end if
1525 return
1526 end if
1527 end if
1528
1529 landQualifierIndice = obs_headElem_i(obsSpaceData, OBS_STYP, headerIndex)
1530 terrainTypeIndice = obs_headElem_i(obsSpaceData, OBS_TTYP, headerIndex)
1531
1532 ! If terrain type is missing, set it to -1 for the QC programs
1533 if (terrainTypeIndice == 99) terrainTypeIndice = mwbg_intMissing
1534
1535 surfTypeIsWater = (landQualifierIndice == 1 .and. terrainTypeIndice /= 0)
1536 ch2OmpRejectInAllsky = .false.
1537 CH2OMPREJCT = .FALSE.
1538
1539 scatIndexOverWaterObs = obs_headElem_r(obsSpaceData, OBS_SIO, headerIndex)
1540 scatIndexOverWaterFG = obs_headElem_r(obsSpaceData, OBS_SIB, headerIndex)
1541 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
1542
1543 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
1544 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
1545
1546 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
1547 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
1548 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
1549 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
1550 ompTb = obs_bodyElem_r(obsSpaceData, OBS_OMP, bodyIndex)
1551
1552 if ( obsChanNumWithOffset /= 20 ) then
1553 channelIsAllsky = (tvs_mwAllskyAssim .and. &
1554 oer_useStateDepSigmaObs(obsChanNumWithOffset,sensorIndex) .and. &
1555 surfTypeIsWater)
1556 ! using state-dependent obs error only over water.
1557 if (channelIsAllsky) then
1558 siThresh1 = oer_cldPredThresh(obsChanNumWithOffset,sensorIndex,1)
1559 siThresh2 = oer_cldPredThresh(obsChanNumWithOffset,sensorIndex,2)
1560 errThresh1 = oer_errThreshAllsky(obsChanNumWithOffset,sensorIndex,1)
1561 errThresh2 = oer_errThreshAllsky(obsChanNumWithOffset,sensorIndex,2)
1562 scatwObsFGaveraged = 0.5 * (scatIndexOverWaterObs + scatIndexOverWaterFG)
1563 if (scatIndexOverWaterObs == MPC_missingValue_R8 .or. &
1564 scatIndexOverWaterFG == MPC_missingValue_R8) then
1565 sigmaObsErrUsed = MPC_missingValue_R8
1566 else
1567 sigmaObsErrUsed = calcStateDepObsErr(siThresh1,siThresh2,errThresh1, &
1568 errThresh2,scatwObsFGaveraged)
1569 end if
1570 else
1571 sigmaObsErrUsed = oer_toverrst(obsChanNumWithOffset,sensorIndex)
1572 end if
1573 ! For sigmaObsErrUsed=MPC_missingValue_R8 (scatIndexOverWaterObs[FG]=mwbg_realMissing
1574 ! in all-sky mode), the observation is already rejected in test 13.
1575 XCHECKVAL = ROGUEFAC(obsChanNumWithOffset) * sigmaObsErrUsed
1576 if (ompTb /= mwbg_realMissing .and. &
1577 abs(ompTb) >= XCHECKVAL .and. &
1578 sigmaObsErrUsed /= MPC_missingValue_R8) then
1579 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
1580 obsFlags = OR(obsFlags,2**9)
1581 obsFlags = OR(obsFlags,2**16)
1582 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
1583 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
1584
1585 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
1586
1587 ch2OmpRejectInAllSky = (channelIsAllsky .and. obsChanNumWithOffset == 44)
1588
1589 if (mwbg_debug) then
1590 write(*,*) stnId(2:9),'ROGUE CHECK REJECT.NO.', &
1591 ' CHANNEL= ',obsChanNumWithOffset, &
1592 ' CHECK VALUE= ',XCHECKVAL, &
1593 ' TBOMP= ',ompTb
1594 end if
1595 end if ! if (ompTb /= mwbg_realMissing
1596
1597 if (obsChanNumWithOffset == 44 .and. ompTb /= mwbg_realMissing) then
1598 if (channelIsAllsky) then
1599 if (ch2OmpRejectInAllSky) CH2OMPREJCT = .true.
1600 else
1601 if (abs(ompTb) >= 5.0) CH2OMPREJCT = .true.
1602 end if
1603 end if ! if (obsChanNumWithOffset == 44
1604 end if ! if ( obsChanNumWithOffset /= 20 )
1605 end do BODY
1606
1607 if (CH2OMPREJCT .and. landQualifierIndice == 1 .and. terrainTypeIndice /= 0) then
1608 BODY2: do bodyIndex = bodyIndexBeg, bodyIndexEnd
1609 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
1610 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
1611 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
1612
1613 INDXCAN = utl_findloc(ICH2OMPREJ(:),obsChanNumWithOffset)
1614 if ( INDXCAN /= 0 ) then
1615 if ( qcIndicator(obsChanNum) /= testIndex ) then
1616 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
1617 obsFlags = OR(obsFlags,2**9)
1618 obsFlags = OR(obsFlags,2**16)
1619 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
1620 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
1621
1622 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
1623 end if
1624 end if
1625 end do BODY2
1626 end if ! if (CH2OMPREJCT
1627
1628 end subroutine amsubTest14RogueCheck
1629
1630 !--------------------------------------------------------------------------
1631 ! amsuABTest15ChannelSelectionWithTovutil
1632 !--------------------------------------------------------------------------
1633 subroutine amsuABTest15ChannelSelectionWithTovutil(sensorIndex, modelInterpSeaIce, ISFCREJ2, qcIndicator, &
1634 headerIndex, obsSpaceData)
1635 !
1636 !:Purpose: test 15: Channel Selection using array oer_tovutil(chan,sat):
1637 ! - = 0 blacklisted,
1638 ! - = 1 assmilate,
1639 ! - = 2 assimilate over open water only
1640 ! We set QC flag bits 7 and 9 ON for channels with oer_tovutil=2
1641 ! over land or sea-ice.
1642 !
1643 ! We set QC flag bits 7 and 9 ON for channels
1644 ! 1-3, 15 over land or sea-ice REGARDLESS of oer_tovutil value
1645 ! (but oer_tovutil=0 always for these unassimilated channels).
1646 !
1647 implicit none
1648
1649 ! Arguments:
1650 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
1651 real(8), intent(in) :: modelInterpSeaIce ! gl
1652 integer, intent(in) :: ISFCREJ2(:) ! rejection channel list
1653 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
1654 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
1655 integer, intent(in) :: headerIndex ! current header Index
1656
1657 ! Locals:
1658 integer :: testIndex, ITRN, INDXCAN, landQualifierIndice, bodyIndex, bodyIndexBeg, bodyIndexEnd
1659 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
1660 integer :: terrainTypeIndice
1661 logical :: SFCREJCT
1662 character(len=9) :: stnId
1663
1664 testIndex = 15
1665
1666 landQualifierIndice = obs_headElem_i(obsSpaceData, OBS_STYP, headerIndex)
1667 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
1668 terrainTypeIndice = obs_headElem_i(obsSpaceData, OBS_TTYP, headerIndex)
1669
1670 ! If terrain type is missing, set it to -1 for the QC programs
1671 if (terrainTypeIndice == 99) terrainTypeIndice = mwbg_intMissing
1672
1673 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
1674 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
1675
1676 ITRN = terrainTypeIndice
1677 if (landQualifierIndice == 1 .and. terrainTypeIndice == mwbg_intMissing .and. &
1678 modelInterpSeaIce >= 0.01d0) then
1679 ITRN = 0
1680 end if
1681 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
1682 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
1683 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
1684 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
1685
1686 INDXCAN = utl_findloc(ISFCREJ2(:),obsChanNumWithOffset)
1687 if ( INDXCAN /= 0 ) then
1688 if (landQualifierIndice == 0 .or. ITRN == 0) then
1689 obsFlags = OR(obsFlags,2**9)
1690 obsFlags = OR(obsFlags,2**7)
1691
1692 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
1693 end if
1694 end if
1695 if ( oer_tovutil(obsChanNumWithOffset,sensorIndex) /= 1 ) then
1696 SFCREJCT = .FALSE.
1697 if ( oer_tovutil(obsChanNumWithOffset,sensorIndex) == 0 ) then
1698 SFCREJCT = .TRUE.
1699 obsFlags = OR(obsFlags,2**11)
1700 else
1701 if (landQualifierIndice == 0 .or. ITRN == 0) then
1702 SFCREJCT = .TRUE.
1703 obsFlags = OR(obsFlags,2**9)
1704 obsFlags = OR(obsFlags,2**7)
1705 end if
1706 end if
1707 if ( SFCREJCT ) then
1708 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
1709 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
1710 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
1711
1712 if ( mwbg_debug ) then
1713 write(*,*)stnId(2:9),'CHANNEL REJECT: ', &
1714 ' CHANNEL= ',obsChanNumWithOffset
1715 end if
1716 end if
1717 end if
1718
1719 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
1720
1721 if ( mwbg_debug ) write(*,*) 'qcIndicator = ', qcIndicator(obsChanNum)
1722 end do BODY
1723
1724 end subroutine amsuABTest15ChannelSelectionWithTovutil
1725
1726 !--------------------------------------------------------------------------
1727 ! amsuaTest16ExcludeExtremeScattering
1728 !--------------------------------------------------------------------------
1729 subroutine amsuaTest16ExcludeExtremeScattering(sensorIndex, qcIndicator, headerIndex, obsSpaceData)
1730 !
1731 !:Purpose: Exclude radiances affected extreme scattering in deep convective region.
1732 ! For channel 5, if BT_cld-BT_clr < -0.5 OR O-BT_clr < -0.5, reject channels 4-5.
1733 !
1734 implicit none
1735
1736 ! Arguments:
1737 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
1738 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
1739 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
1740 integer, intent(in) :: headerIndex ! current header Index
1741
1742 ! Locals:
1743 integer :: testIndex, INDXCAN, landQualifierIndice, bodyIndex, bodyIndexBeg, bodyIndexEnd
1744 integer :: obsChanNum, obsChanNumWithOffset, obsFlags, codtyp
1745 real(8) :: BTcloudy, simulatedCloudEffect, observedCloudEffect
1746 real(8) :: obsTb, btClear, ompTb
1747 logical :: surfTypeIsWater, rejectLowPeakingChannels
1748 character(len=9) :: stnId
1749
1750 integer, dimension(2), parameter :: lowPeakingChannelsList = (/ 31, 32 /)
1751
1752 testIndex = 16
1753
1754 landQualifierIndice = obs_headElem_i(obsSpaceData, OBS_STYP, headerIndex)
1755 surfTypeIsWater = (landQualifierIndice == 1)
1756 if (.not. (tvs_mwAllskyAssim .and. surfTypeIsWater)) return
1757
1758 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
1759
1760 codtyp = obs_headElem_i(obsSpaceData, OBS_ITY, headerIndex)
1761 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
1762 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
1763
1764 rejectLowPeakingChannels = .false.
1765 loopChannel2: do bodyIndex = bodyIndexBeg, bodyIndexEnd
1766 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
1767 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
1768 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
1769 ompTb = obs_bodyElem_r(obsSpaceData, OBS_OMP, bodyIndex)
1770 obsTb = obs_bodyElem_r(obsSpaceData, OBS_VAR, bodyIndex)
1771 if (tvs_isInstrumAllskyTtAssim(tvs_getInstrumentId(codtyp_get_name(codtyp)))) then
1772 btClear = obs_bodyElem_r(obsSpaceData, OBS_BTCL, bodyIndex)
1773 else
1774 btClear = mwbg_realMissing
1775 end if
1776
1777 if ( obsChanNumWithOffset /= 32 ) cycle loopChannel2
1778
1779 BTcloudy = obsTb - ompTb
1780 simulatedCloudEffect = BTcloudy - btClear
1781 observedCloudEffect = obsTb - btClear
1782 if ( simulatedCloudEffect < -0.5d0 .or. observedCloudEffect < -0.5d0 ) then
1783 rejectLowPeakingChannels = .true.
1784 end if
1785
1786 exit loopChannel2
1787 end do loopChannel2
1788
1789 ! reject channel 4-5
1790 if ( rejectLowPeakingChannels ) then
1791 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
1792 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
1793 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
1794 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
1795
1796 INDXCAN = utl_findloc(lowPeakingChannelsList(:),obsChanNumWithOffset)
1797 if ( INDXCAN /= 0 ) then
1798 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
1799 obsFlags = OR(obsFlags,2**9)
1800 obsFlags = OR(obsFlags,2**16)
1801 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
1802 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
1803
1804 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
1805 end if
1806
1807 if ( mwbg_debug ) then
1808 write(*,*) stnId(2:9),' extreme scattering check reject: ', &
1809 ' obs location index = ', obsChanNum, &
1810 ' channel = 1-5'
1811 end if
1812 end do BODY
1813 end if ! rejectLowPeakingChannels
1814
1815 end subroutine amsuaTest16ExcludeExtremeScattering
1816
1817 !--------------------------------------------------------------------------
1818 ! mwbg_tovCheckAmsua
1819 !--------------------------------------------------------------------------
1820 subroutine mwbg_tovCheckAmsua(qcIndicator, sensorIndex, modelInterpLandFrac, modelInterpTerrain, &
1821 modelInterpSeaIce, RESETQC, headerIndex, obsSpaceData)
1822 !
1823 !:Purpose: Effectuer le controle de qualite des radiances tovs.
1824 !
1825 ! Quinze tests sont effectues menant aux erreurs suivantes:
1826 ! - 1) topography reject,
1827 ! - 2) invalid land/sea qualifier,
1828 ! - 3) invalid terrain type,
1829 ! - 4) invalid field of view number,
1830 ! - 5) satellite zenith angle out of range,
1831 ! - 6) inconsistent field of view and sat. zenith angle,
1832 ! - 7) inconsistent land/sea qualifier and model mask,
1833 ! - 8) inconsistent terrain type and model ice, (NOT USED)
1834 ! - 9) uncorrected radiance,
1835 ! - 10) rejected by RTTOV,
1836 ! - 11) radiance gross check failure,
1837 ! - 12) cloud liquid water reject,
1838 ! - 13) scattering index reject,
1839 ! - 14) radiance residual rogue check failure,
1840 ! - 15) channel reject (channel selection).
1841 ! - **) set terrain type to sea ice given certain conditions
1842 !
1843 implicit none
1844
1845 ! Arguments:
1846 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
1847 integer, intent(in) :: headerIndex ! current header Index
1848 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
1849 real(8), intent(in) :: modelInterpLandFrac ! masque terre/mer du modele
1850 real(8), intent(in) :: modelInterpTerrain ! topographie du modele
1851 real(8), intent(in) :: modelInterpSeaIce ! etendue de glace du modele
1852 logical, intent(in) :: RESETQC ! reset du controle de qualite?
1853 integer, allocatable, intent(out) :: qcIndicator(:) ! indicateur controle de qualite tovs par canal (=0 ok, >0 rejet)
1854
1855 ! Locals:
1856 integer, parameter :: maxScanAngleAMSU = 30
1857 real(8), parameter :: cloudyClwThreshold = 0.3d0
1858 real(8), parameter :: ZANGL = 117.6/maxScanAngleAMSU
1859 integer :: KCHKPRF, JI, rain, snow, newInformationFlag, actualNumChannel
1860 integer :: ICLWREJ(6), ISFCREJ(6), ISFCREJ2(4), ISCATREJ(7), channelForTopoFilter(2)
1861 integer :: bodyIndex, bodyIndexBeg, bodyIndexEnd, obsFlags
1862 real(8), allocatable :: GROSSMIN(:), GROSSMAX(:), ROGUEFAC(:)
1863 real(8) :: EPSILON, tb23, tb31, tb50, tb53, tb89
1864 real(8) :: tb23FG, tb31FG, tb50FG, tb53FG, tb89FG
1865 real(8) :: ice, tpw, scatIndexOverLandObs, altitudeForTopoFilter(2)
1866 logical, save :: LLFIRST = .true.
1867
1868 EPSILON = 0.01
1869
1870 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
1871 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
1872
1873 actualNumChannel = tvs_coefs(sensorIndex)%coef%fmv_ori_nchn
1874 allocate(ROGUEFAC(actualNumChannel+tvs_channelOffset(sensorIndex)))
1875 ROGUEFAC(:) =(/ 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, &
1876 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, &
1877 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 2.0d0, 2.0d0, 2.0d0, &
1878 3.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, &
1879 4.0d0, 2.0d0/)
1880 ICLWREJ(:) = (/ 28, 29, 30, 31, 32, 42 /)
1881 ISFCREJ(:) = (/ 28, 29, 30, 31, 32, 42 /)
1882 ISCATREJ(:) = (/ 28, 29, 30, 31, 32, 33, 42 /)
1883 ISFCREJ2(:) = (/ 28, 29, 30, 42 /)
1884
1885 allocate(GROSSMIN(actualNumChannel+tvs_channelOffset(sensorIndex)))
1886 GROSSMIN(:) = (/ 200.0d0, 190.0d0, 190.0d0, 180.0d0, 180.0d0, 180.0d0, 170.0d0, &
1887 170.0d0, 180.0d0, 170.0d0, 170.0d0, 170.0d0, 180.0d0, 180.0d0, &
1888 180.0d0, 180.0d0, 170.0d0, 180.0d0, 180.0d0, 000.0d0, 120.0d0, &
1889 190.0d0, 180.0d0, 180.0d0, 180.0d0, 190.0d0, 200.0d0, 120.0d0, &
1890 120.0d0, 160.0d0, 190.0d0, 190.0d0, 200.0d0, 190.0d0, 180.0d0, &
1891 180.0d0, 180.0d0, 180.0d0, 190.0d0, 190.0d0, 200.0d0, 130.0d0 /)
1892
1893 allocate(GROSSMAX(actualNumChannel+tvs_channelOffset(sensorIndex)))
1894 GROSSMAX(:) = (/ 270.0d0, 250.0d0, 250.0d0, 250.0d0, 260.0d0, 280.0d0, 290.0d0, &
1895 320.0d0, 300.0d0, 320.0d0, 300.0d0, 280.0d0, 320.0d0, 300.0d0, &
1896 290.0d0, 280.0d0, 330.0d0, 350.0d0, 350.0d0, 000.0d0, 310.0d0, &
1897 300.0d0, 250.0d0, 250.0d0, 270.0d0, 280.0d0, 290.0d0, 310.0d0, &
1898 310.0d0, 310.0d0, 300.0d0, 300.0d0, 260.0d0, 250.0d0, 250.0d0, &
1899 250.0d0, 260.0d0, 260.0d0, 270.0d0, 280.0d0, 290.0d0, 330.0d0 /)
1900 channelForTopoFilter(:) = (/ 33, 34 /)
1901 altitudeForTopoFilter(:) = (/ 250.0d0, 2000.0d0/)
1902
1903 ! Allocation
1904 allocate(qcIndicator(actualNumChannel))
1905 qcIndicator(:) = 0
1906
1907 ! Initialisation, la premiere fois seulement!
1908 if (LLFIRST) then
1909 rejectionCodArray(:,:,:) = 0
1910 LLFIRST = .FALSE.
1911 end if
1912 ! fill newInformationFlag with zeros ONLY for consistency with ATMS
1913 newInformationFlag = 0
1914 if ( RESETQC ) then
1915 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
1916 obsFlags = 0
1917 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
1918 end do BODY
1919 end if
1920
1921 ! Grody parameters are extract required channels:
1922 call extractParamForGrodyRun (tb23, tb31, tb50, tb53, tb89, &
1923 tb23FG, tb31FG, tb50FG, tb53FG, tb89FG, &
1924 headerIndex, sensorIndex, obsSpaceData)
1925
1926 ! Run Grody AMSU-A algorithms.
1927 call grody (tb23, tb31, tb50, tb53, tb89, tb23FG, tb31FG, &
1928 ice, tpw, &
1929 rain, snow, scatIndexOverLandObs, &
1930 headerIndex, obsSpaceData)
1931
1932 ! 10) test 10: RTTOV reject check (single)
1933 ! Rejected datum flag has bit #9 on.
1934 call amsuABTest10RttovRejectCheck (sensorIndex, RESETQC, qcIndicator, headerIndex, obsSpaceData)
1935
1936 ! 1) test 1: Topography check (partial)
1937 ! Channel 6 is rejected for topography > 250m.
1938 ! Channel 7 is rejected for topography > 2000m.
1939 call amsuABTest1TopographyCheck (sensorIndex, modelInterpTerrain, channelForTopoFilter, altitudeForTopoFilter, &
1940 qcIndicator, headerIndex, obsSpaceData)
1941
1942 ! 2) test 2: "Land/sea qualifier" code check (full)
1943 ! allowed values are: 0 land, 1 sea, 2 coast.
1944 call amsuABTest2LandSeaQualifierCheck (sensorIndex, qcIndicator, headerIndex, obsSpaceData)
1945
1946 ! 3) test 3: "Terrain type" code check (full)
1947 ! allowed values are: -1 missing, 0 sea-ice, 1 snow on land.
1948 call amsuABTest3TerrainTypeCheck (sensorIndex, qcIndicator, headerIndex, obsSpaceData)
1949
1950 ! 4) test 4: Field of view number check (full)
1951 ! Field of view acceptable range is [1,maxScanAngleAMSU] for AMSU footprints.
1952 call amsuABTest4FieldOfViewCheck (sensorIndex, maxScanAngleAMSU, qcIndicator, &
1953 headerIndex, obsSpaceData)
1954
1955 ! 5) test 5: Satellite zenith angle check (full)
1956 ! Satellite zenith angle acceptable range is [0.,60.].
1957 call amsuABTest5ZenithAngleCheck (sensorIndex, qcIndicator, headerIndex, obsSpaceData)
1958
1959 ! 6) test 6: "Sat. zenith angle"/"field of view" consistency check. (full)
1960 ! Acceptable difference between "Satellite zenith angle" and
1961 ! "approximate angle computed from field of view number" is 1.8 degrees.
1962 call amsuABTest6ZenAngleAndFovConsistencyCheck (sensorIndex, ZANGL, maxScanAngleAMSU, qcIndicator, &
1963 headerIndex, obsSpaceData)
1964
1965 ! 7) test 7: "Land/sea qual."/"model land/sea" consistency check. (full)
1966 ! Acceptable conditions are:
1967 ! a) both over ocean (landQualifierIndice=1; mg<0.01), new threshold 0.20, jh dec 2000,
1968 ! b) both over land (landQualifierIndice=0; mg>0.80), new threshold 0.50, jh dec 2000.
1969 ! Other conditions are unacceptable.
1970 call amsuABTest7landSeaQualifyerAndModelLandSeaConsistencyCheck (sensorIndex, modelInterpLandFrac, &
1971 qcIndicator, headerIndex, obsSpaceData)
1972
1973 ! 8) test 8: "Terrain type"/"Land/sea qual."/"model ice" consistency check. (full)
1974 ! Unacceptable conditions are:
1975 ! a) terrain is sea-ice and model has no ice(terrainTypeIndice=0; gl<0.01).
1976 ! b) terrain is sea-ice and land/sea qualifier is land (terrainTypeIndice=0; landQualifierIndice=0).
1977 ! c) terrain is snow on land and land/sea qualifier is sea (terrainTypeIndice=1; landQualifierIndice=1).
1978 ! d) terrain is missing, land/sea qualifier is sea and model has ice(terrainTypeIndice=-1; landQualifierIndice=1; gl>0.01). (enleve jh, jan 2001)
1979 ! NOT doNE ANYMORE
1980
1981 ! 9) test 9: Uncorrected Tb check (single)
1982 ! Uncorrected datum (flag bit #6 off). In this case switch bit 11 ON.
1983 call amsuABTest9UncorrectedTbCheck (sensorIndex, RESETQC, qcIndicator, headerIndex, obsSpaceData)
1984
1985 ! 11) test 11: Radiance observation "Gross" check (single)
1986 ! Change this test from full to single. jh nov 2000.
1987 call amsuABTest11RadianceGrossValueCheck (sensorIndex, GROSSMIN, GROSSMAX, qcIndicator, &
1988 headerIndex, obsSpaceData)
1989
1990 ! 12) test 12: Grody cloud liquid water check (partial)
1991 ! For Cloud Liquid Water > clwQcThreshold, reject AMSUA-A channels 1-5 and 15.
1992 call amsuaTest12GrodyClwCheck (sensorIndex, ICLWREJ, qcIndicator, headerIndex, obsSpaceData)
1993
1994 ! 13) test 13: Grody scattering index check (partial)
1995 ! For Scattering Index > 9, reject AMSUA-A channels 1-6 and 15.
1996 call amsuaTest13GrodyScatteringIndexCheck (sensorIndex, ISCATREJ, qcIndicator, headerIndex, obsSpaceData)
1997
1998 ! 14) test 14: "Rogue check" for (O-P) Tb residuals out of range. (single/full)
1999 ! Les observations, dont le residu (O-P) depasse par un facteur (roguefac) l'erreur totale des TOVS.
2000 ! N.B.: a reject by any of the 3 surface channels produces the rejection of AMSUA-A channels 1-5 and 15.
2001 call amsuaTest14RogueCheck (sensorIndex, ROGUEFAC, ISFCREJ, qcIndicator, headerIndex, obsSpaceData)
2002
2003 ! 15) test 15: Channel Selection using array oer_tovutil(chan,sat)
2004 ! oer_tovutil = 0 (blacklisted)
2005 ! 1 (assmilate)
2006 ! 2 (assimilate over open water only)
2007 !
2008 ! We also set QC flag bits 7 and 9 ON for channels with oer_tovutil=2
2009 ! over land or sea-ice
2010 ! and
2011 ! we set QC flag bits 7 and 9 ON for channels 1-3,15 over land
2012 ! or sea-ice REGARDLESS of oer_tovutil value (but oer_tovutil=0 always for
2013 ! these unassimilated channels).
2014 call amsuABTest15ChannelSelectionWithTovutil (sensorIndex, modelInterpSeaIce, ISFCREJ2, qcIndicator, &
2015 headerIndex, obsSpaceData)
2016
2017 ! 16) test 16: exclude radiances affected by extreme scattering in deep convective region in all-sky mode.
2018 call amsuaTest16ExcludeExtremeScattering(sensorIndex, qcIndicator, headerIndex, obsSpaceData)
2019
2020 ! Synthese de la controle de qualite au niveau de chaque point
2021 ! d'observation. Code:
2022 ! =0, aucun rejet,
2023 ! >0, au moins un canal rejete.
2024
2025 KCHKPRF = 0
2026 do JI = 1, actualNumChannel
2027 KCHKPRF = MAX(KCHKPRF,qcIndicator(JI))
2028 end do
2029
2030 if ( mwbg_debug ) write(*,*) 'KCHKPRF = ', KCHKPRF
2031
2032 ! reset global marker flag (55200) and mark it if observtions are rejected
2033 call resetQcCases(RESETQC, KCHKPRF, headerIndex, obsSpaceData)
2034
2035 call obs_headSet_i(obsSpaceData, OBS_INFG, headerIndex, newInformationFlag)
2036
2037 !###############################################################################
2038 ! FINAL STEP: set terrain type to sea ice given certain conditions
2039 !###############################################################################
2040 call setTerrainTypeToSeaIce(modelInterpSeaIce, headerIndex, obsSpaceData)
2041
2042 end subroutine mwbg_tovCheckAmsua
2043
2044 !--------------------------------------------------------------------------
2045 ! mwbg_tovCheckAmsub
2046 !--------------------------------------------------------------------------
2047 subroutine mwbg_tovCheckAmsub(qcIndicator, sensorIndex, modelInterpLandFrac, modelInterpTerrain, &
2048 modelInterpSeaIce, RESETQC, headerIndex, obsSpaceData)
2049 !
2050 !:Purpose: Effectuer le controle de qualite des radiances tovs.
2051 !
2052 ! Quinze tests sont effectues menant aux erreurs suivantes:
2053 ! - 1) topography reject,
2054 ! - 2) invalid land/sea qualifier,
2055 ! - 3) invalid terrain type,
2056 ! - 4) invalid field of view number,
2057 ! - 5) satellite zenith angle out of range,
2058 ! - 6) inconsistent field of view and sat. zenith angle,
2059 ! - 7) inconsistent land/sea qualifier and model mask,
2060 ! - 8) inconsistent terrain type and model ice
2061 ! - 9) uncorrected radiance,
2062 ! - 10) rejected by RTTOV,
2063 ! - 11) radiance gross check failure,
2064 ! - 12) drynes index reject
2065 ! - 13) scattering index reject,
2066 ! - 14) radiance residual rogue check failure,
2067 ! - 15) channel reject (channel selection).
2068 ! - **) set terrain type to sea ice given certain conditions
2069 !
2070 implicit none
2071
2072 ! Arguments:
2073 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
2074 integer, intent(in) :: headerIndex ! current header Index
2075 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
2076 real(8), intent(in) :: modelInterpLandFrac ! masque terre/mer du modele
2077 real(8), intent(in) :: modelInterpTerrain ! topographie du modele
2078 real(8), intent(in) :: modelInterpSeaIce ! etendue de glace du modele
2079 logical, intent(in) :: RESETQC ! reset du controle de qualite?
2080 integer, allocatable, intent(out) :: qcIndicator(:) ! indicateur controle de qualite tovs par canal (=0 ok, >0 rejet)
2081
2082 ! Locals:
2083 integer, parameter :: maxScanAngleAMSU = 90
2084 real(8), parameter :: ZANGL = 117.6d0 / maxScanAngleAMSU
2085
2086 integer :: KCHKPRF, JI, newInformationFlag, actualNumChannel
2087 integer :: ISFCREJ(2), ICH2OMPREJ(4), ISFCREJ2(1), chanIgnoreInAllskyGenCoeff(5), channelForTopoFilter(3)
2088 integer :: bodyIndex, bodyIndexBeg, bodyIndexEnd, obsFlags
2089 real(8), allocatable :: GROSSMIN(:), GROSSMAX(:), ROGUEFAC(:)
2090 real(8) :: tb89, tb150, tb1831, tb1832, tb1833
2091 real(8) :: tb89FG, tb150FG, tb89FgClear, tb150FgClear, scatIndexOverLandObs
2092 real(8) :: altitudeForTopoFilter(3)
2093 logical, save :: LLFIRST = .true.
2094
2095 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
2096 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
2097
2098 actualNumChannel = tvs_coefs(sensorIndex)%coef%fmv_ori_nchn
2099 allocate(ROGUEFAC(actualNumChannel+tvs_channelOffset(sensorIndex)))
2100 ROGUEFAC(:) =(/ 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, &
2101 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, &
2102 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 2.0d0, 2.0d0, 2.0d0, &
2103 3.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, &
2104 4.0d0, 2.0d0, 2.0d0, 2.0d0, 4.0d0, 4.0d0, 4.0d0 /)
2105
2106 ISFCREJ(:) = (/ 43, 44 /)
2107 ISFCREJ2(:) = (/ 43 /)
2108 ICH2OMPREJ(:) = (/ 44, 45, 46, 47 /)
2109 allocate(GROSSMIN(actualNumChannel+tvs_channelOffset(sensorIndex)))
2110 GROSSMIN(:) = (/ 200.0d0, 190.0d0, 190.0d0, 180.0d0, 180.0d0, 180.0d0, 170.0d0, &
2111 170.0d0, 180.0d0, 170.0d0, 170.0d0, 170.0d0, 180.0d0, 180.0d0, &
2112 180.0d0, 180.0d0, 170.0d0, 180.0d0, 180.0d0, 000.0d0, 120.0d0, &
2113 190.0d0, 180.0d0, 180.0d0, 180.0d0, 190.0d0, 200.0d0, 120.0d0, &
2114 120.0d0, 160.0d0, 190.0d0, 190.0d0, 200.0d0, 190.0d0, 180.0d0, &
2115 180.0d0, 180.0d0, 180.0d0, 190.0d0, 190.0d0, 200.0d0, 130.0d0, &
2116 130.0d0, 130.0d0, 130.0d0, 130.0d0, 130.0d0 /)
2117 allocate(GROSSMAX(actualNumChannel+tvs_channelOffset(sensorIndex)))
2118 GROSSMAX(:) = (/ 270.0d0, 250.0d0, 250.0d0, 250.0d0, 260.0d0, 280.0d0, 290.0d0, &
2119 320.0d0, 300.0d0, 320.0d0, 300.0d0, 280.0d0, 320.0d0, 300.0d0, &
2120 290.0d0, 280.0d0, 330.0d0, 350.0d0, 350.0d0, 000.0d0, 310.0d0, &
2121 300.0d0, 250.0d0, 250.0d0, 270.0d0, 280.0d0, 290.0d0, 310.0d0, &
2122 310.0d0, 310.0d0, 300.0d0, 300.0d0, 260.0d0, 250.0d0, 250.0d0, &
2123 250.0d0, 260.0d0, 260.0d0, 270.0d0, 280.0d0, 290.0d0, 330.0d0, &
2124 330.0d0, 330.0d0, 330.0d0, 330.0d0, 330.0d0 /)
2125
2126 channelForTopoFilter(:) = (/ 45, 46, 47 /)
2127 altitudeForTopoFilter(:) = (/ 2500.0d0, 2000.0d0, 1000.0d0 /)
2128
2129 ! Channels excluded from genCoeff in all-sky mode
2130 chanIgnoreInAllskyGenCoeff(:) = (/43, 44, 45, 46, 47/)
2131
2132 ! Allocation
2133 allocate(qcIndicator(actualNumChannel))
2134 qcIndicator(:) = 0
2135
2136 ! Initialisation, la premiere fois seulement!
2137 if (LLFIRST) then
2138 rejectionCodArray(:,:,:) = 0
2139 LLFIRST = .FALSE.
2140 end if
2141 ! fill newInformationFlag with zeros ONLY for consistency with ATMS
2142 newInformationFlag = 0
2143 if ( RESETQC ) then
2144 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
2145 obsFlags = 0
2146 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
2147 end do BODY
2148 end if
2149
2150 ! Bennartz parameters are extract required channels:
2151 call extractParamForBennartzRun (tb89, tb150, tb1831, tb1832, tb1833, &
2152 tb89FG, tb150FG, tb89FgClear, tb150FgClear, &
2153 headerIndex, sensorIndex, obsSpaceData)
2154
2155 ! Run Bennartz AMSU-B algorithms.
2156 call bennartz (tb89, tb150, tb89FG, tb150FG, tb89FgClear, tb150FgClear, &
2157 scatIndexOverLandObs, &
2158 headerIndex, obsSpaceData)
2159
2160 ! 10) test 10: RTTOV reject check (single)
2161 ! Rejected datum flag has bit #9 on.
2162 call amsuABTest10RttovRejectCheck (sensorIndex, RESETQC, qcIndicator, headerIndex, obsSpaceData)
2163
2164 ! 1) test 1: Topography check (partial)
2165 ! Channel 3- 45 is rejected for topography > 2500m.
2166 ! Channel 4 - 46 is rejected for topography > 2000m.
2167 ! Channel 5 - 47 is rejected for topography > 1000m.
2168 call amsuABTest1TopographyCheck (sensorIndex, modelInterpTerrain, channelForTopoFilter, altitudeForTopoFilter, &
2169 qcIndicator, headerIndex, obsSpaceData)
2170
2171 ! 2) test 2: "Land/sea qualifier" code check (full)
2172 ! allowed values are: 0, land,
2173 ! 1, sea,
2174 ! 2, coast.
2175 call amsuABTest2LandSeaQualifierCheck (sensorIndex, qcIndicator, headerIndex, obsSpaceData)
2176
2177 ! 3) test 3: "Terrain type" code check (full)
2178 ! allowed values are: -1 missing, 0 sea-ice, 1 snow on land.
2179 call amsuABTest3TerrainTypeCheck (sensorIndex, qcIndicator, headerIndex, obsSpaceData)
2180
2181 ! 4) test 4: Field of view number check (full)
2182 ! Field of view acceptable range is [1,maxScanAngleAMSU] for AMSU footprints.
2183 call amsuABTest4FieldOfViewCheck (sensorIndex, maxScanAngleAMSU, qcIndicator, &
2184 headerIndex, obsSpaceData)
2185
2186 ! 5) test 5: Satellite zenith angle check (full)
2187 ! Satellite zenith angle acceptable range is [0.,60.].
2188 call amsuABTest5ZenithAngleCheck (sensorIndex, qcIndicator, headerIndex, obsSpaceData)
2189
2190 ! 6) test 6: "Sat. zenith angle"/"field of view" consistency check. (full)
2191 ! Acceptable difference between "Satellite zenith angle" and
2192 ! "approximate angle computed from field of view number" is 1.8 degrees.
2193 call amsuABTest6ZenAngleAndFovConsistencyCheck (sensorIndex, ZANGL, maxScanAngleAMSU, qcIndicator, &
2194 headerIndex, obsSpaceData)
2195
2196 ! 7) test 7: "Land/sea qual."/"model land/sea" consistency check. (full)
2197 ! Acceptable conditions are:
2198 ! a) both over ocean (landQualifierIndice=1; mg<0.01), new threshold 0.20, jh dec 2000,
2199 ! b) both over land (landQualifierIndice=0; mg>0.80), new threshold 0.50, jh dec 2000.
2200 ! Other conditions are unacceptable.
2201 call amsuABTest7landSeaQualifyerAndModelLandSeaConsistencyCheck (sensorIndex, modelInterpLandFrac, &
2202 qcIndicator, headerIndex, obsSpaceData)
2203
2204 ! 8) test 8: "Terrain type"/"Land/sea qual."/"model ice" consistency check. (full)
2205 ! Unacceptable conditions are:
2206 ! a) terrain is sea-ice and model has no ice(terrainTypeIndice=0; gl<0.01).
2207 ! b) terrain is sea-ice and land/sea qualifier is land (terrainTypeIndice=0; landQualifierIndice=0).
2208 ! c) terrain is snow on land and land/sea qualifier is sea (terrainTypeIndice=1; landQualifierIndice=1).
2209 ! d) terrain is missing, land/sea qualifier is sea and model has ice(terrainTypeIndice=-1; landQualifierIndice=1; gl>0.01). (enleve jh, jan 2001)
2210 ! NOT doNE ANYMORE
2211
2212 ! 9) test 9: Uncorrected Tb check (single) SKIP FOR NOW
2213 ! Uncorrected datum (flag bit #6 off). In this case switch bit 11 ON.
2214 ! call amsuABTest9UncorrectedTbCheck (sensorIndex, RESETQC, qcIndicator, &
2215 ! headerIndex, obsSpaceData)
2216
2217 ! 11) test 11: Radiance observation "Gross" check (single)
2218 ! Change this test from full to single. jh nov 2000.
2219 call amsuABTest11RadianceGrossValueCheck (sensorIndex, GROSSMIN, GROSSMAX, qcIndicator, &
2220 headerIndex, obsSpaceData)
2221
2222 ! 12) test 12: Dryness index check
2223 !The difference between channels AMSUB-3 and AMSUB-5 is used as an indicator
2224 !of "dryness" of the atmosphere. In extreme dry conditions, channels AMSUB-3 4 and 5
2225 ! are sensitive to the surface.
2226 ! Therefore, various thresholds are used to reject channels AMSUB-3 4 and 5
2227 ! over land and ice
2228 call amsubTest12DrynessIndexCheck (sensorIndex, tb1831, tb1833, modelInterpSeaIce, qcIndicator, &
2229 headerIndex, obsSpaceData, skipTestArr_opt=skipTestArr(:))
2230
2231 ! 13) test 13: Bennartz scattering index check (full)
2232 call amsubTest13BennartzScatteringIndexCheck(sensorIndex, scatIndexOverLandObs, modelInterpSeaIce, &
2233 qcIndicator, chanIgnoreInAllskyGenCoeff, &
2234 headerIndex, obsSpaceData, skipTestArr_opt=skipTestArr(:))
2235
2236 ! 14) test 14: "Rogue check" for (O-P) Tb residuals out of range. (single/full)
2237 ! Les observations, dont le residu (O-P) depasse par un facteur (roguefac) l'erreur totale des TOVS.
2238 ! N.B.: a reject by any of the 3 surface channels produces the rejection of AMSUA-A channels 1-5 and 15.
2239 call amsubTest14RogueCheck(sensorIndex, ROGUEFAC, ICH2OMPREJ, qcIndicator, &
2240 headerIndex, obsSpaceData, skipTestArr_opt=skipTestArr(:))
2241
2242 ! 15) test 15: Channel Selection using array oer_tovutil(chan,sat)
2243 ! oer_tovutil = 0 (blacklisted)
2244 ! 1 (assmilate)
2245 ! 2 (assimilate over open water only)
2246 !
2247 ! We also set QC flag bits 7 and 9 ON for channels with oer_tovutil=2
2248 ! over land or sea-ice
2249 ! and
2250 ! we set QC flag bits 7 and 9 ON for channels 1-3,15 over land
2251 ! or sea-ice REGARDLESS of oer_tovutil value (but oer_tovutil=0 always for
2252 ! these unassimilated channels).
2253 call amsuABTest15ChannelSelectionWithTovutil (sensorIndex, modelInterpSeaIce, ISFCREJ2, qcIndicator, &
2254 headerIndex, obsSpaceData)
2255
2256 ! Synthese de la controle de qualite au niveau de chaque point
2257 ! d'observation. Code:
2258 ! =0, aucun rejet,
2259 ! >0, au moins un canal rejete.
2260
2261 KCHKPRF = 0
2262 do JI = 1, actualNumChannel
2263 KCHKPRF = MAX(KCHKPRF,qcIndicator(JI))
2264 end do
2265
2266 if ( mwbg_debug ) write(*,*)'KCHKPRF = ', KCHKPRF
2267
2268 ! reset global marker flag (55200) and mark it if observtions are rejected
2269 call resetQcCases(RESETQC, KCHKPRF, headerIndex, obsSpaceData)
2270
2271 call obs_headSet_i(obsSpaceData, OBS_INFG, headerIndex, newInformationFlag)
2272
2273 !###############################################################################
2274 ! FINAL STEP: set terrain type to sea ice given certain conditions
2275 !###############################################################################
2276 call setTerrainTypeToSeaIce(modelInterpSeaIce, headerIndex, obsSpaceData)
2277
2278 end subroutine mwbg_tovCheckAmsub
2279
2280 !--------------------------------------------------------------------------
2281 ! mwbg_qcStats
2282 !--------------------------------------------------------------------------
2283 subroutine mwbg_qcStats(instName, qcIndicator, sensorIndex, satelliteId, LDprint)
2284 !
2285 !:Purpose: Cumuler ou imprimer des statistiques decriptives des rejets tovs.
2286 !
2287 implicit none
2288
2289 ! Arguments:
2290 character(*), intent(in) :: instName ! Instrument Name
2291 integer, intent(in) :: qcIndicator(:) ! indicateur controle de qualite tovs par canal (=0 ok, >0 rejet)
2292 integer, intent(in) :: sensorIndex ! numero d'identificateur du satellite
2293 character(len=15), intent(in) :: satelliteId(:) ! identificateur du satellite
2294 logical, intent(in) :: LDprint ! mode: imprimer ou cumuler?
2295
2296 ! Locals:
2297 integer :: numSats, JI, JJ, JK, INTOTOBS, INTOTACC, actualNumChannel, channelIndex
2298 integer, allocatable, save :: INTOT(:) ! INTOT(tvs_nsensors)
2299 integer, allocatable, save :: INTOTRJF(:) ! INTOTRJF(tvs_nsensors)
2300 integer, allocatable, save :: INTOTRJP(:) ! INTOTRJP(tvs_nsensors)
2301 integer, allocatable :: obsChannels(:)
2302 logical :: FULLREJCT, FULLACCPT
2303 logical, save :: LLFIRST = .true.
2304
2305 ! Initialize
2306 if ( LLFIRST ) then
2307 allocate(INTOT(tvs_nsensors))
2308 allocate(INTOTRJF(tvs_nsensors))
2309 allocate(INTOTRJP(tvs_nsensors))
2310 INTOTRJF(:) = 0
2311 INTOTRJP(:) = 0
2312 INTOT(:) = 0
2313 LLFIRST = .false.
2314 end if
2315
2316 actualNumChannel = tvs_coefs(sensorIndex)%coef%fmv_ori_nchn
2317 allocate(obsChannels(actualNumChannel))
2318 do channelIndex = 1, actualNumChannel
2319 obsChannels(channelIndex) = channelIndex + tvs_channelOffset(sensorIndex)
2320 end do
2321
2322 if (.not. LDprint ) then
2323 ! Accumulate statistics on rejects
2324 INTOT(sensorIndex) = INTOT(sensorIndex) + 1
2325 ! Fully accepted, fully rejected or partially rejected?
2326 FULLREJCT = .true.
2327 FULLACCPT = .true.
2328 if (instName == "AMSUA") then
2329 do JI = 1, actualNumChannel
2330 if ( obsChannels(JI) /= 20 ) then
2331 if ( qcIndicator(JI) /= 0 ) then
2332 FULLACCPT = .false.
2333 else
2334 FULLREJCT = .false.
2335 end if
2336 end if
2337 end do
2338 if ( FULLREJCT ) then
2339 INTOTRJF(sensorIndex) = INTOTRJF(sensorIndex) + 1
2340 end if
2341 if ( .not. FULLREJCT .and. .not.FULLACCPT ) then
2342 INTOTRJP(sensorIndex) = INTOTRJP(sensorIndex) + 1
2343 end if
2344 else if (instName == "ATMS") then
2345 do JI = 1, actualNumChannel
2346 if ( qcIndicator(JI) /= 0 ) then
2347 FULLACCPT = .false.
2348 else
2349 FULLREJCT = .false.
2350 end if
2351 end do
2352 if ( FULLREJCT ) then
2353 INTOTRJF(sensorIndex) = INTOTRJF(sensorIndex) + 1
2354 end if
2355 if ( .not. FULLREJCT .and. .not.FULLACCPT ) then
2356 INTOTRJP(sensorIndex) = INTOTRJP(sensorIndex) + 1
2357 end if
2358 end if
2359
2360 else
2361
2362 numSats = size(satelliteId)
2363 ! Print statistics
2364 do JK = 1, numSats
2365
2366 INTOTOBS = INTOT(JK)
2367 INTOTACC = INTOTOBS - INTOTRJF(JK) - INTOTRJP(JK)
2368 write(*,'(/////50("*"))')
2369 write(*,'( 50("*")/)')
2370 write(*,'(T5,"SUMMARY OF QUALITY CONTROL FOR ", &
2371 A8)') satelliteId(JK)
2372 write(*,'(T5,"------------------------------------- ",/)')
2373 write(*,'( &
2374 " - TOTAL NUMBER OF OBS. = ",I10,/ &
2375 " - TOTAL FULL REJECTS = ",I10,/ &
2376 " - TOTAL PARTIAL REJECTS = ",I10,/ &
2377 " ------------------------------------",/ &
2378 " TOTAL FULLY ACCEPTED = ",I10,/)') &
2379 INTOTOBS, INTOTRJF(JK), INTOTRJP(JK), INTOTACC
2380
2381 if (instName == "AMSUA" .or. instName == "AMSUB") then
2382 write(*,'(//,1x,114("-"))')
2383 write(*,'(t10,"|",t47,"REJECTION CATEGORIES")')
2384 write(*,'(" CHANNEL",t10,"|",105("-"))')
2385 write(*,'(t10,"|",16i7)') (JI,JI=1,mwbg_maxNumTest)
2386 write(*,'(1x,"--------|",105("-"))')
2387 do JJ = 1, actualNumChannel
2388 write(*,'(3X,I2,t10,"|",16I7)') JJ,(rejectionCodArray(JI,JJ,JK), &
2389 JI=1,mwbg_maxNumTest)
2390 end do
2391 write(*,'(1x,114("-"))')
2392 print *, ' '
2393 print *, ' '
2394 print *, ' -----------------------------------------------------'
2395 print *, ' Definition of rejection categories:'
2396 print *, ' -----------------------------------------------------'
2397 print *, ' 1 - topography reject'
2398 print *, ' 2 - invalid land/sea qualifier'
2399 print *, ' 3 - invalid terrain type'
2400 print *, ' 4 - invalid field of view number'
2401 print *, ' 5 - satellite zenith angle out of range '
2402 print *, ' 6 - inconsistent field of view and sat. zenith angle'
2403 print *, ' 7 - inconsistent land/sea qualifier and model mask'
2404 print *, ' 8 - inconsistent terrain type and land/sea', &
2405 ' qualifier/model ice (NOT doNE)'
2406 print *, ' 9 - uncorrected radiance'
2407 print *, ' 10 - rejected by RTTOV'
2408 print *, ' 11 - radiance gross check failure'
2409 print *, ' 12 - cloud liquid water reject'
2410 print *, ' 13 - scattering index reject'
2411 print *, ' 14 - radiance residual rogue check failure'
2412 print *, ' 15 - rejection by channel selection'
2413 print *, ' -----------------------------------------------------'
2414 print *, ' '
2415
2416 else if (instName == "ATMS" .or. instName == "MWHS2") then
2417 write(*,'(//,1x,59("-"))')
2418 write(*,'(t10,"|",t19,"1. REJECTION CATEGORIES")')
2419 write(*,'(" CHANNEL",t10,"|",50("-"))')
2420 write(*,'(t10,"|",5i7)') (JI,JI=1,mwbg_maxNumTest)
2421 write(*,'(1x,"--------|",50("-"))')
2422 do JJ = 1, actualNumChannel
2423 write(*,'(3X,I2,t10,"|",5I7)') JJ,(rejectionCodArray(JI,JJ,JK), &
2424 JI=1,mwbg_maxNumTest)
2425 end do
2426 write(*,'(1x,59("-"))')
2427 write(*,'(//,1x,59("-"))')
2428 write(*,'(t10,"|",t19,"2. QC2 REJECT CATEGORIES")')
2429 write(*,'(" CHANNEL",t10,"|",50("-"))')
2430 write(*,'(t10,"|",5i7)') (JI,JI=1,mwbg_maxNumTest)
2431 write(*,'(1x,"--------|",50("-"))')
2432 do JJ = 1, actualNumChannel
2433 write(*,'(3X,I2,t10,"|",5I7)') JJ,(rejectionCodArray2(JI,JJ,JK), &
2434 JI=1,mwbg_maxNumTest)
2435 end do
2436 print *, ' '
2437 print *, ' '
2438 print *, ' -----------------------------------------------------'
2439 print *, ' Definition of rejection categories: '
2440 print *, ' -----------------------------------------------------'
2441 print *, ' 1 - first bgckAtms/bgckMwhs2 program reject [bit 7]'
2442 print *, ' 2 - topography reject'
2443 print *, ' 3 - uncorrected radiance'
2444 print *, ' 4 - innovation (O-P) based reject'
2445 print *, ' 5 - rejection by channel selection'
2446 print *, ' -----------------------------------------------------'
2447 print *, ' '
2448 print *, ' QC2 REJECT numbers in Table 2 are for data that '
2449 print *, ' passed test 1 (data with QC flag bit 7 OFF)'
2450 print *, ' '
2451 end if
2452 end do
2453 end if
2454
2455 end subroutine mwbg_qcStats
2456
2457 !--------------------------------------------------------------------------
2458 ! resetQcC
2459 !--------------------------------------------------------------------------
2460 subroutine resetQcCases(RESETQC, KCHKPRF, headerIndex, obsSpaceData)
2461 !
2462 !:Purpose: allumer la bit (6) indiquant que l'observation a un element
2463 ! rejete par le controle de qualite de l'AO.
2464 !
2465 ! N.B.: si on est en mode resetqc, on remet le marqueur global a
2466 ! sa valeur de defaut, soit 1024, avant de faire la mise a jour.
2467 !
2468 implicit none
2469
2470 ! Arguments:
2471 logical, intent(in) :: RESETQC ! reset the quality control flags before adding the new ones ?
2472 integer, intent(in) :: KCHKPRF ! indicateur global controle de qualite tovs. Code:
2473 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
2474 integer, intent(in) :: headerIndex ! current header index
2475
2476 ! Locals:
2477 integer :: obsGlobalMarker
2478
2479 obsGlobalMarker = obs_headElem_i(obsSpaceData, OBS_ST1, headerIndex)
2480
2481 if (RESETQC) obsGlobalMarker = 1024
2482 if (KCHKPRF /= 0) obsGlobalMarker = OR (obsGlobalMarker,2**6)
2483 if (mwbg_debug) write(*,*) ' KCHKPRF = ', KCHKPRF, ', NEW FLAGS = ', obsGlobalMarker
2484
2485 call obs_headSet_i(obsSpaceData, OBS_ST1, headerIndex, obsGlobalMarker)
2486
2487 end subroutine resetQcCases
2488
2489 !--------------------------------------------------------------------------
2490 ! setTerrainTypeToSeaIce
2491 !--------------------------------------------------------------------------
2492 subroutine setTerrainTypeToSeaIce(modelInterpSeaIce, headerIndex, obsSpaceData)
2493 !
2494 !:Purpose: Dans les conditions suivantes:
2495 ! 1) l'indicateur terre/mer indique l'ocean (landQualifierIndice=1),
2496 ! 2) le "terrain type" est manquant (terrainTypeIndice=-1),
2497 ! 3) le modele indique de la glace (gl >= 0.01),
2498 ! on specifie "sea ice" pour le "terrain type" (terrainTypeIndice=0).
2499 !
2500 implicit none
2501
2502 ! Arguments:
2503 real(8), intent(in) :: modelInterpSeaIce ! sea ice
2504 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
2505 integer, intent(in) :: headerIndex ! current header Index
2506
2507 ! Locals:
2508 integer :: landQualifierIndice, terrainTypeIndice
2509
2510 landQualifierIndice = obs_headElem_i(obsSpaceData, OBS_STYP, headerIndex)
2511 terrainTypeIndice = obs_headElem_i(obsSpaceData, OBS_TTYP, headerIndex)
2512
2513 ! If terrain type is missing, set it to -1 for the QC programs
2514 if (terrainTypeIndice == 99) terrainTypeIndice = mwbg_intMissing
2515
2516 if ( mwbg_debug ) then
2517 write(*,*) ' OLD TERRAIN type = ', terrainTypeIndice, &
2518 ', landQualifierIndice = ', landQualifierIndice, &
2519 ', modelInterpSeaIce = ', modelInterpSeaIce
2520 end if
2521
2522 if (landQualifierIndice == 1 .and. terrainTypeIndice == mwbg_intMissing .and. &
2523 modelInterpSeaIce >= 0.01d0) then
2524 terrainTypeIndice = 0
2525 call obs_headSet_i(obsSpaceData, OBS_TTYP, headerIndex, terrainTypeIndice)
2526 end if
2527
2528 if ( mwbg_debug ) write(*,*) 'NEW TERRAIN type = ', terrainTypeIndice
2529
2530 end subroutine setTerrainTypeToSeaIce
2531
2532 !--------------------------------------------------------------------------
2533 ! GRODY
2534 !--------------------------------------------------------------------------
2535 subroutine GRODY (tb23, tb31, tb50, tb53, tb89, tb23FG, tb31FG, &
2536 ice, tpw, &
2537 rain, snow, scatIndexOverLandObs, &
2538 headerIndex, obsSpaceData)
2539 !
2540 !:Purpose: Compute the following parameters using 5 AMSU-A channels:
2541 ! - sea ice,
2542 ! - total precipitable water,
2543 ! - cloud liquid water,
2544 ! - ocean/land rain,
2545 ! - <snow> cover/glacial ice,
2546 ! - scattering index (sur la terre et sur l'eau).
2547 ! The four channels used are: 23Ghz, 31Ghz, 50Ghz and 89Ghz.
2548 ! REGERENCES N. Grody, NOAA/NESDIS, ....
2549 !
2550
2551 implicit none
2552
2553 ! Arguments:
2554 real(8), intent(in) :: tb23 ! 23Ghz brightness temperature (K)
2555 real(8), intent(in) :: tb31 ! 31Ghz brightness temperature (K)
2556 real(8), intent(in) :: tb50 ! 50Ghz brightness temperature (K)
2557 real(8), intent(in) :: tb53 ! 53Ghz brightness temperature (K)
2558 real(8), intent(in) :: tb89 ! 89Ghz brightness temperature (K)
2559 real(8), intent(in) :: tb23FG ! 23Ghz brightness temperature from background (K)
2560 real(8), intent(in) :: tb31FG ! 31Ghz brightness temperature from background (K)
2561 real(8), intent(out) :: ice ! sea ice concentration (0-100%)
2562 real(8), intent(out) :: tpw ! total precipitable water (0-70mm)
2563 integer, intent(out) :: rain ! rain identification (0=no rain; 1=rain)
2564 integer, intent(out) :: snow ! snow cover and glacial ice id: 0=no snow; 1=snow; 2=glacial ice
2565 real(8), intent(out) :: scatIndexOverLandObs ! scattering index over land
2566 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
2567 integer, intent(in) :: headerIndex ! current header Index
2568
2569 ! Locals:
2570 real(8) :: df1, df2, df3, a, b, c, d, e23
2571 real(8) :: ei, cosz, tt, scat, sc31, t23, t31, t50, t89
2572 real(8) :: sc50, par, t53
2573 real(8) :: dif285t23, dif285t31, epsilon
2574 real(8) :: dif285t23FG, dif285t31FG
2575 real(8) :: cloudLiquidWaterPathObs, cloudLiquidWaterPathFG
2576 real(8) :: scatIndexOverWaterObs, landQualifierIndice
2577 real(8) :: obsLat, obsLon, satZenithAngle
2578 integer :: codtyp, ier
2579
2580 data epsilon / 1.E-30 /
2581
2582 logical chan15Missing
2583 !
2584 ! Notes: In the case where an output parameter cannot be calculated, the
2585 ! value of this parameter is to mwbg_realMissing
2586
2587 satZenithAngle = obs_headElem_r(obsSpaceData, OBS_SZA, headerIndex)
2588 landQualifierIndice = obs_headElem_i(obsSpaceData, OBS_STYP, headerIndex)
2589 obsLat = obs_headElem_r(obsSpaceData, OBS_LAT, headerIndex)
2590 obsLon = obs_headElem_r(obsSpaceData, OBS_LON, headerIndex)
2591
2592 ! Convert lat/lon to degrees
2593 obsLon = obsLon * MPC_DEGREES_PER_RADIAN_R8
2594 if (obsLon > 180.0d0) obsLon = obsLon - 360.0d0
2595 obsLat = obsLat * MPC_DEGREES_PER_RADIAN_R8
2596
2597 ! 1) Initialise output parameters:
2598 ice = mwbg_realMissing
2599 tpw = mwbg_realMissing
2600 cloudLiquidWaterPathObs = mwbg_realMissing
2601 cloudLiquidWaterPathFG = mwbg_realMissing
2602 scatIndexOverLandObs = mwbg_realMissing
2603 scatIndexOverWaterObs = mwbg_realMissing
2604 rain = nint(mwbg_realMissing)
2605 snow = nint(mwbg_realMissing)
2606
2607 ! 2) Validate input parameters:
2608 if ( tb23 < 120.0d0 .or. tb23 > 350.0d0 .or. &
2609 tb31 < 120.0d0 .or. tb31 > 350.0d0 .or. &
2610 tb50 < 120.0d0 .or. tb50 > 350.0d0 .or. &
2611 tb53 < 120.0d0 .or. tb53 > 350.0d0 .or. &
2612 satZenithAngle < -90.0d0 .or. satZenithAngle > 90.0d0 .or. &
2613 obsLat < -90.0d0 .or. obsLat > 90.0d0 .or. &
2614 landQualifierIndice < 0 .or. landQualifierIndice > 1 ) then
2615 ier = 1
2616 else
2617 ier = 0
2618 end if
2619
2620 !3) Compute parameters:
2621 if ( ier == 0 ) then
2622 cosz = cosd(satZenithAngle)
2623 t23 = tb23
2624 t31 = tb31
2625 t50 = tb50
2626 t53 = tb53
2627 dif285t23 =max(285.0d0-t23,epsilon)
2628 dif285t23FG=max(285.0d0-tb23FG,epsilon)
2629 dif285t31 =max(285.0d0-t31,epsilon)
2630 dif285t31FG=max(285.0d0-tb31FG,epsilon)
2631
2632 chan15Missing = .false.
2633 if (tb89 < 120.0d0 .or. tb89 > 350.0d0) then
2634 chan15Missing = .true.
2635 end if
2636
2637 if (.not. chan15Missing) then
2638 t89 = tb89
2639 ! scattering indices:
2640 scatIndexOverWaterObs = -113.2d0 + (2.41d0 - 0.0049d0 * t23) * t23 + 0.454d0 * t31 - t89
2641 scatIndexOverLandObs = t23 - t89
2642 end if
2643
2644 ! discriminate functions:
2645 df1 = 2.85d0 + 0.020d0 * t23 - 0.028d0 * t50 ! used to identify (also remove) sea ice
2646 df2 = 5.10d0 + 0.078d0 * t23 - 0.096d0 * t50 ! used to identify (also remove) warm deserts
2647 df3 = 10.20d0 + 0.036d0 * t23 - 0.074d0 * t50 ! used to identify (also remove) cold deserts
2648
2649 if (landQualifierIndice == 1) then
2650
2651 ! Ocean Parameters
2652
2653 !3.1) Sea ice:
2654 if (abs(obsLat) < 50.0d0) then
2655 ice = 0.0
2656 else
2657 if ( df1 < 0.45 ) then
2658 ice = 0.0
2659 else
2660 a = 1.7340d0 - 0.6236d0 * cosz
2661 b = 0.0070d0 + 0.0025d0 * cosz
2662 c = -0.00106d0
2663 d = -0.00909d0
2664 e23 = a + b * t31 + c * t23 + d * t50 ! theoretical 23Ghz sfc emissivity (0.3-1.)
2665 if ( (t23-t31) >= 5. ) then ! fov contains multiyear or new ice/water
2666 ei = 0.88d0
2667 else
2668 ei = 0.95d0
2669 end if
2670 ice = 100 * (e23 - 0.45d0) / (ei - 0.45d0) ! sea-ice concentration within fov (0-100%)
2671 ice = min(100.0d0,max(0.0d0,ice)) / 100.0d0 !jh (0.-1.)
2672 end if
2673 end if
2674
2675 ! 3.2) Total precipitable water:
2676 ! identify and remove sea ice
2677 if (abs(obsLat) > 50.0d0 .and. df1 > 0.2d0) then
2678 tpw = mwbg_realMissing
2679 else
2680 a = 247.92d0 - (69.235d0 - 44.177d0 * cosz) * cosz
2681 b = -116.27d0
2682 c = 73.409d0
2683 tpw = a + b * log(dif285t23) + c * log(dif285t31)
2684 tpw = tpw * cosz ! theoretical total precipitable water (0-70mm)
2685 tpw = 0.942d0 * tpw - 2.17d0 ! corrected total precipitable water
2686 tpw = min(70.0d0,max(0.0d0,tpw)) ! jh
2687 end if
2688
2689 !3.3) Cloud liquid water from obs (cloudLiquidWaterPathObs) and background state (cloudLiquidWaterPathFG):
2690 ! identify and remove sea ice
2691 if (abs(obsLat) > 50.0d0 .and. df1 > 0.0d0) then
2692 cloudLiquidWaterPathObs = mwbg_realMissing
2693 cloudLiquidWaterPathFG = mwbg_realMissing
2694 else
2695 a = 8.240d0 - (2.622d0 - 1.846d0 * cosz) * cosz
2696 b = 0.754d0
2697 c = -2.265d0
2698 cloudLiquidWaterPathObs = a + b * log(dif285t23) + c * log(dif285t31)
2699 cloudLiquidWaterPathObs = cloudLiquidWaterPathObs * cosz ! theoretical cloud liquid water (0-3mm)
2700 cloudLiquidWaterPathObs = cloudLiquidWaterPathObs - 0.03d0 ! corrected cloud liquid water
2701 cloudLiquidWaterPathObs = min(3.0d0,max(0.0d0,cloudLiquidWaterPathObs))
2702
2703 cloudLiquidWaterPathFG = a + b * log(dif285t23FG) + c * log(dif285t31FG)
2704 cloudLiquidWaterPathFG = cloudLiquidWaterPathFG * cosz ! theoretical cloud liquid water (0-3mm)
2705 cloudLiquidWaterPathFG = cloudLiquidWaterPathFG - 0.03d0 ! corrected cloud liquid water
2706 cloudLiquidWaterPathFG = min(3.,max(0.,cloudLiquidWaterPathFG))
2707 end if
2708
2709 if (.not. chan15Missing) then
2710 !3.4) Ocean rain: 0=no rain; 1=rain.
2711 ! identify and remove sea ice
2712 if (abs(obsLat) > 50.0d0 .and. df1 > 0.0d0) then
2713 rain = nint(mwbg_realMissing)
2714 else ! remove non-precipitating clouds
2715 if (cloudLiquidWaterPathObs > 0.3d0 .or. scatIndexOverLandObs> 9.0d0) then
2716 rain = 1
2717 else
2718 rain = 0
2719 end if
2720 end if
2721 end if
2722
2723 else
2724
2725 if (.not. chan15Missing) then
2726 ! Land Parameters
2727
2728 ! 3.5) Rain over land: 0=no rain; 1=rain.
2729 tt = 168.0d0 + 0.49d0 * t89
2730 if (scatIndexOverLandObs >= 3.0d0) then
2731 rain = 1
2732 else
2733 rain = 0
2734 end if
2735
2736 ! remove snow cover
2737 if (t23 <= 261.0d0 .and. t23 < tt) rain = 0
2738
2739 ! remove warm deserts
2740 if (t89 > 273.0d0 .or. df2 < 0.6d0) rain = 0
2741
2742 ! 3.6) Snow cover and glacial ice: 0=no snow; 1=snow; 2=glacial ice.
2743 tt = 168.0d0 + 0.49d0 * t89
2744 scat = t23 - t89
2745 sc31 = t23 - t31
2746 sc50 = t31 - t50
2747 par = t50 - t53
2748
2749 ! re-frozen snow
2750 if (t89 < 255.0d0 .and. scat < sc31) scat = sc31
2751
2752 ! identify glacial ice
2753 if (scat < 3.0d0 .and. t23 < 215.0d0) snow = 2
2754 if (scat >= 3.0d0) then
2755 snow = 1
2756 else
2757 snow = 0
2758 end if
2759
2760 ! remove precipitation
2761 if (t23 >= 262.0d0 .or. t23 >= tt) snow = 0
2762 ! remove deserts
2763 if (df3 <= 0.35d0) snow = 0
2764
2765 ! high elevation deserts
2766 if (scat < 15.0d0 .and. sc31 < 3.0d0 .and. par > 2.0d0) snow = 0
2767
2768 ! remove frozen ground
2769 if (scat < 9.0d0 .and. sc31 < 3.0d0 .and. sc50 < 0.0d0) snow = 0
2770 end if
2771
2772 end if
2773
2774 end if
2775
2776 codtyp = obs_headElem_i(obsSpaceData, OBS_ITY, headerIndex)
2777 call obs_headSet_r(obsSpaceData, OBS_CLWO, headerIndex, cloudLiquidWaterPathObs)
2778 if (tvs_isInstrumAllskyTtAssim(tvs_getInstrumentId(codtyp_get_name(codtyp)))) then
2779 call obs_headSet_r(obsSpaceData, OBS_CLWB, headerIndex, cloudLiquidWaterPathFG)
2780 end if
2781
2782 if (scatIndexOverWaterObs /= mwbg_realMissing) then
2783 call obs_headSet_r(obsSpaceData, OBS_SIO, headerIndex, scatIndexOverWaterObs)
2784 else
2785 call obs_headSet_r(obsSpaceData, OBS_SIO, headerIndex, MPC_missingValue_R8)
2786 end if
2787
2788 if (mwbg_DEBUG) then
2789 write(*,*) 'GRODY: tb23, tb31, tb50, tb89, satZenithAngle, obsLat, landQualifierIndice = ', &
2790 tb23, tb31, tb50, tb89, satZenithAngle, obsLat, landQualifierIndice
2791 write(*,*) 'GRODY: ier, ice, tpw, cloudLiquidWaterPathObs, cloudLiquidWaterPathFG, rain, snow=', &
2792 ier, ice, tpw, cloudLiquidWaterPathObs, cloudLiquidWaterPathFG, rain, snow
2793 end if
2794
2795 end subroutine GRODY
2796
2797 !------------------------------------------------------------------------------------
2798 ! bennartz
2799 !------------------------------------------------------------------------------------
2800 subroutine bennartz (tb89, tb150, tb89FG, tb150FG, tb89FgClear, tb150FgClear, &
2801 scatIndexOverLandObs, &
2802 headerIndex, obsSpaceData)
2803 !
2804 !:Purpose: Compute the following parameters using 2 AMSU-B channels:
2805 ! - scattering index (over land and ocean).
2806 ! The two channels used are: 89Ghz, 150Ghz.
2807 !
2808 ! REGERENCES: Bennartz, R., A. Thoss, A. Dybbroe and D. B. Michelson,
2809 ! 1999: Precipitation Analysis from AMSU, Nowcasting SAF,
2810 ! Swedish Meteorologicali and Hydrological Institute,
2811 ! Visiting Scientist Report, November 1999.
2812 !
2813 implicit none
2814
2815 ! Arguments:
2816 real(8), intent(in) :: tb89 ! 89Ghz AMSU-B brightness temperature (K)
2817 real(8), intent(in) :: tb150 ! 150Ghz AMSU-B brightness temperature (K)
2818 real(8), intent(in) :: tb89FG ! 89Ghz AMSU-B brightness temperature from background (K)
2819 real(8), intent(in) :: tb150FG ! 150Ghz AMSU-B brightness temperature from background (K)
2820 real(8), intent(in) :: tb89FgClear ! 89Ghz clear-sky brightness temperature from background (K)
2821 real(8), intent(in) :: tb150FgClear ! 150Ghz clear-sky brightness temperature from background (K)
2822 real(8), intent(out) :: scatIndexOverLandObs ! scattering index over land
2823 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
2824 integer, intent(in) :: headerIndex ! current header Index
2825
2826 ! Locals:
2827 integer :: landQualifierIndice, ier
2828 real(8) :: cloudLiquidWaterPathObs, cloudLiquidWaterPathFG
2829 real(8) :: scatIndexOverWaterObs, scatIndexOverWaterFG
2830 real(8) :: satZenithAngle
2831 integer :: codtyp
2832
2833 landQualifierIndice = obs_headElem_i(obsSpaceData, OBS_STYP, headerIndex)
2834 satZenithAngle = obs_headElem_r(obsSpaceData, OBS_SZA, headerIndex)
2835
2836 ! Notes: In the case where an output parameter cannot be calculated, the
2837 ! value of this parameter is to mwbg_realMissing
2838
2839 ! 1) Initialise output parameters
2840 scatIndexOverLandObs = mwbg_realMissing
2841 scatIndexOverWaterObs = mwbg_realMissing
2842 scatIndexOverWaterFG = mwbg_realMissing
2843 cloudLiquidWaterPathObs = mwbg_realMissing
2844 cloudLiquidWaterPathFG = mwbg_realMissing
2845
2846 ! 2) Validate input parameters
2847 if (tb89 < 120.0d0 .or. tb89 > 350.0d0 .or. &
2848 tb150 < 120.0d0 .or. tb150 > 350.0d0 .or. &
2849 satZenithAngle < -90.0d0 .or. satZenithAngle > 90.0d0 .or. &
2850 landQualifierIndice < 0 .or. landQualifierIndice > 1) then
2851 ier = 1
2852 else
2853 ier = 0
2854 end if
2855
2856 ! 3) Compute parameters
2857 if (ier == 0) then
2858 if (landQualifierIndice == 1) then
2859 if (tvs_mwAllskyAssim) then
2860 scatIndexOverWaterObs = (tb89 - tb150) - (tb89FgClear - tb150FgClear)
2861 scatIndexOverWaterFG = (tb89FG - tb150FG) - (tb89FgClear - tb150FgClear)
2862 else
2863 scatIndexOverWaterObs = (tb89 - tb150) - (-39.2010d0 + 0.1104d0 * satZenithAngle)
2864 end if
2865 else
2866 scatIndexOverLandObs = (tb89 - tb150) - (0.158d0 + 0.0163d0 * satZenithAngle)
2867 end if ! if (landQualifierIndice == 1)
2868 else if (ier /= 0) then
2869 write(*,*) 'bennartz: input Parameters are not all valid: '
2870 write(*,*) 'bennartz: tb89, tb150, satZenithAngle, landQualifierIndice = ', &
2871 tb89, tb150, satZenithAngle, landQualifierIndice
2872 write(*,*) 'bennartz: ier, scatIndexOverLandObs, scatIndexOverWaterObs, scatIndexOverWaterFG=', &
2873 ier, scatIndexOverLandObs, scatIndexOverWaterObs, scatIndexOverWaterFG
2874 end if ! if (ier == 0)
2875
2876 codtyp = obs_headElem_i(obsSpaceData, OBS_ITY, headerIndex)
2877 call obs_headSet_r(obsSpaceData, OBS_CLWO, headerIndex, cloudLiquidWaterPathObs)
2878 if (tvs_isInstrumAllskyTtAssim(tvs_getInstrumentId(codtyp_get_name(codtyp)))) then
2879 call obs_headSet_r(obsSpaceData, OBS_CLWB, headerIndex, cloudLiquidWaterPathFG)
2880 end if
2881
2882 if (scatIndexOverWaterObs /= mwbg_realMissing) then
2883 call obs_headSet_r(obsSpaceData, OBS_SIO, headerIndex, scatIndexOverWaterObs)
2884 else
2885 call obs_headSet_r(obsSpaceData, OBS_SIO, headerIndex, MPC_missingValue_R8)
2886 end if
2887
2888 if (tvs_isInstrumAllskyHuAssim(tvs_getInstrumentId(codtyp_get_name(codtyp)))) then
2889 if (scatIndexOverWaterFG /= mwbg_realMissing) then
2890 call obs_headSet_r(obsSpaceData, OBS_SIB, headerIndex, scatIndexOverWaterFG)
2891 else
2892 call obs_headSet_r(obsSpaceData, OBS_SIB, headerIndex, MPC_missingValue_R8)
2893 end if
2894 end if
2895
2896 end subroutine bennartz
2897
2898 !--------------------------------------------------------------------------
2899 ! atmsMwhs2Test1Flagbit7Check
2900 !--------------------------------------------------------------------------
2901 subroutine atmsMwhs2Test1Flagbit7Check (itest, sensorIndex, qcIndicator, &
2902 B7CHCK, headerIndex, obsSpaceData)
2903 !
2904 !:Purpose: test 1: Check flag bit 7 on from the first bgckAtms/bgckMwhs2 program
2905 ! Includes observations flagged for cloud liquid water, scattering index,
2906 ! dryness index plus failure of several QC checks.
2907 !
2908 implicit none
2909
2910 ! Arguments:
2911 integer, intent(in) :: itest(:) ! test number
2912 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
2913 integer, intent(inout) :: B7CHCK(:) ! bit=7 of channel is on (=1) or off(=0)
2914 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
2915 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
2916 integer, intent(in) :: headerIndex ! current header Index
2917
2918 ! Locals:
2919 integer :: testIndex, IBIT, bodyIndex, bodyIndexBeg, bodyIndexEnd
2920 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
2921 character(len=9) :: stnId
2922
2923 testIndex = 1
2924 if ( itest(testIndex) /= 1 ) return
2925
2926 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
2927
2928 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
2929 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
2930
2931 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
2932 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
2933 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
2934 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
2935
2936 IBIT = AND(obsFlags, 2**7)
2937 if (IBIT /= 0) then
2938 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
2939 B7CHCK(obsChanNum) = 1
2940 obsFlags = OR(obsFlags,2**9)
2941 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
2942 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
2943
2944 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
2945
2946 if ( mwbg_debug ) then
2947 write(*,*)stnId(2:9),' first bgckAtms/bgckMwhs2 program REJECT.', &
2948 'CHANNEL=', obsChanNumWithOffset, &
2949 ' obsFlags= ',obsFlags
2950 end if
2951 end if
2952 end do BODY
2953
2954 end subroutine atmsMwhs2Test1Flagbit7Check
2955
2956 !--------------------------------------------------------------------------
2957 ! atmsMwhs2Test2TopographyCheck
2958 !--------------------------------------------------------------------------
2959 subroutine atmsMwhs2Test2TopographyCheck(itest, sensorIndex, &
2960 modelInterpTerrain, ICHTOPO, ZCRIT, B7CHCK, qcIndicator, &
2961 headerIndex, obsSpaceData)
2962 !
2963 !:Purpose: test 2: Topography check (partial)
2964 !
2965 implicit none
2966
2967 ! Arguments:
2968 integer, intent(in) :: itest(:) ! test number
2969 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
2970 real(8), intent(in) :: modelInterpTerrain ! topo aux point d'obs
2971 integer, intent(in) :: ICHTOPO(:) ! rejection channel list
2972 real(8), intent(in) :: ZCRIT(:) ! criteria for topo check
2973 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
2974 integer, intent(inout) :: B7CHCK(:) ! bit=7 of channel is on (=1) or off(=0)
2975 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
2976 integer, intent(in) :: headerIndex ! current header Index
2977
2978 ! Locals:
2979 integer :: testIndex, INDXTOPO, bodyIndex, bodyIndexBeg, bodyIndexEnd
2980 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
2981 character(len=9) :: stnId
2982
2983 testIndex = 2
2984
2985 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
2986
2987 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
2988 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
2989
2990 if ( itest(testIndex) /= 1 ) return
2991
2992 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
2993 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
2994 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
2995 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
2996
2997 INDXTOPO = utl_findloc(ICHTOPO(:),obsChanNumWithOffset)
2998 if ( INDXTOPO > 0 ) then
2999 if (modelInterpTerrain >= ZCRIT(INDXTOPO)) then
3000 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
3001 obsFlags = OR(obsFlags,2**9)
3002 obsFlags = OR(obsFlags,2**18)
3003 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
3004 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
3005 if ( B7CHCK(obsChanNum) == 0 ) then
3006 rejectionCodArray2(testIndex,obsChanNumWithOffset,sensorIndex) = &
3007 rejectionCodArray2(testIndex,obsChanNumWithOffset,sensorIndex) + 1
3008 end if
3009
3010 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
3011
3012 if ( mwbg_debug ) then
3013 write(*,*) stnId(2:9),' TOPOGRAPHY REJECT.', &
3014 'CHANNEL=', obsChanNumWithOffset, &
3015 ' TOPO= ',modelInterpTerrain
3016 end if
3017 end if
3018 end if
3019 end do BODY
3020
3021 end subroutine atmsMwhs2Test2TopographyCheck
3022
3023 !--------------------------------------------------------------------------
3024 ! atmsMwhs2Test3UncorrectedTbCheck
3025 !--------------------------------------------------------------------------
3026 subroutine atmsMwhs2Test3UncorrectedTbCheck(itest, sensorIndex, RESETQC, B7CHCK, qcIndicator, &
3027 headerIndex, obsSpaceData)
3028 !
3029 !:Purpose: Test 3: Uncorrected Tb check (single)
3030 ! Uncorrected datum (flag bit #6 off).
3031 ! In this case switch bit 11 ON.
3032 !
3033 implicit none
3034
3035 ! Arguments:
3036 integer, intent(in) :: itest(:) ! test number
3037 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
3038 logical, intent(in) :: RESETQC ! resetqc logical
3039 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
3040 integer, intent(inout) :: B7CHCK(:) ! bit=7 of channel is on (=1) or off(=0)
3041 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
3042 integer, intent(in) :: headerIndex ! current header Index
3043
3044 ! Locals:
3045 integer :: testIndex, IBIT, bodyIndex, bodyIndexBeg, bodyIndexEnd
3046 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
3047 character(len=9) :: stnId
3048
3049 if (RESETQC) return
3050 testIndex = 3
3051 if ( itest(testIndex) /= 1 ) return
3052
3053 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
3054
3055 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
3056 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
3057
3058 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
3059 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
3060 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
3061 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
3062
3063 IBIT = AND(obsFlags, 2**6)
3064 if (IBIT == 0) then
3065 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
3066 obsFlags = OR(obsFlags,2**11)
3067 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
3068 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
3069 if ( B7CHCK(obsChanNum) == 0 ) then
3070 rejectionCodArray2(testIndex,obsChanNumWithOffset,sensorIndex) = &
3071 rejectionCodArray2(testIndex,obsChanNumWithOffset,sensorIndex) + 1
3072 end if
3073
3074 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
3075
3076 if ( mwbg_debug ) then
3077 write(*,*) stnId(2:9),' UNCORRECTED TB REJECT.', &
3078 'CHANNEL=', obsChanNumWithOffset, &
3079 ' obsFlags= ',obsFlags
3080 end if
3081 end if
3082 end do BODY
3083
3084 end subroutine atmsMwhs2Test3UncorrectedTbCheck
3085
3086 !--------------------------------------------------------------------------
3087 ! atmsTest4RogueCheck
3088 !--------------------------------------------------------------------------
3089 subroutine atmsTest4RogueCheck(itest, sensorIndex, ROGUEFAC, waterobs, ISFCREJ, ICH2OMPREJ, &
3090 B7CHCK, qcIndicator, headerIndex, obsSpaceData)
3091 !
3092 !:Purpose: test 4: "Rogue check" for (O-P) Tb residuals out of range (single/full).
3093 ! Also, over WATER remove CH.17-22 if CH.17 |O-P|>5K (partial)
3094 ! Les observations, dont le residu (O-P)
3095 ! depasse par un facteur (roguefac) l'erreur totale des TOVS.
3096 !
3097 ! N.B.: a reject by any of the 3 amsua surface channels 1-3 produces the
3098 ! rejection of ATMS sfc/tropospheric channels 1-6 and 16-17.
3099 !
3100 ! OVER OPEN WATER ch. 17 Abs(O-P) > 5K produces rejection of all ATMS amsub channels 17-22.
3101 !
3102 implicit none
3103
3104 ! Arguments:
3105 integer, intent(in) :: itest(:) ! test number
3106 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
3107 real(8), intent(in) :: ROGUEFAC(:) ! rogue factor
3108 logical, intent(in) :: waterobs ! open water obs
3109 integer, intent(in) :: ISFCREJ(:) ! rejection surface channel list
3110 integer, intent(in) :: ICH2OMPREJ(:) ! rejection channel list
3111 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
3112 integer, intent(inout) :: B7CHCK(:) ! bit=7 of channel is on (=1) or off(=0)
3113 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
3114 integer, intent(in) :: headerIndex ! current header Index
3115
3116 ! Locals:
3117 integer :: testIndex, INDXCAN, newInformationFlag, bodyIndex, bodyIndexBeg, bodyIndexEnd
3118 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
3119 real(8) :: XCHECKVAL, clwThresh1, clwThresh2, errThresh1, errThresh2
3120 real(8) :: sigmaObsErrUsed, clwObsFGaveraged
3121 real(8) :: cloudLiquidWaterPathObs, cloudLiquidWaterPathFG, ompTb
3122 logical :: SFCREJCT, CH2OMPREJCT, IBIT
3123 character(len=9) :: stnId
3124
3125 testIndex = 4
3126 if ( itest(testIndex) /= 1 ) return
3127
3128 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
3129 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
3130
3131 cloudLiquidWaterPathObs = obs_headElem_r(obsSpaceData, OBS_CLWO, headerIndex)
3132 cloudLiquidWaterPathFG = obs_headElem_r(obsSpaceData, OBS_CLWB, headerIndex)
3133 newInformationFlag = obs_headElem_i(obsSpaceData, OBS_INFG, headerIndex)
3134 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
3135
3136 SFCREJCT = .FALSE.
3137 CH2OMPREJCT = .FALSE.
3138 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
3139 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
3140 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
3141
3142 ! using state-dependent obs error only over water.
3143 ! obs over sea-ice will be rejected in test 15.
3144 if ( tvs_mwAllskyAssim .and. oer_useStateDepSigmaObs(obsChanNumWithOffset,sensorIndex) .and. waterobs ) then
3145 clwThresh1 = oer_cldPredThresh(obsChanNumWithOffset,sensorIndex,1)
3146 clwThresh2 = oer_cldPredThresh(obsChanNumWithOffset,sensorIndex,2)
3147 errThresh1 = oer_errThreshAllsky(obsChanNumWithOffset,sensorIndex,1)
3148 errThresh2 = oer_errThreshAllsky(obsChanNumWithOffset,sensorIndex,2)
3149 clwObsFGaveraged = 0.5d0 * (cloudLiquidWaterPathObs + cloudLiquidWaterPathFG)
3150 if (cloudLiquidWaterPathObs == mwbg_realMissing .or. &
3151 cloudLiquidWaterPathFG == mwbg_realMissing) then
3152 sigmaObsErrUsed = MPC_missingValue_R8
3153 else
3154 sigmaObsErrUsed = calcStateDepObsErr(clwThresh1,clwThresh2,errThresh1, &
3155 errThresh2,clwObsFGaveraged)
3156 end if
3157 else
3158 sigmaObsErrUsed = oer_toverrst(obsChanNumWithOffset,sensorIndex)
3159 end if
3160 ! For sigmaObsErrUsed=MPC_missingValue_R8 (cloudLiquidWaterPathObs[FG]=mwbg_realMissing
3161 ! in all-sky mode), the observation is flagged for rejection in
3162 ! mwbg_reviewAllCritforFinalFlagsAtms.
3163 XCHECKVAL = ROGUEFAC(obsChanNumWithOffset) * sigmaObsErrUsed
3164 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
3165 ompTb = obs_bodyElem_r(obsSpaceData, OBS_OMP, bodyIndex)
3166
3167 if (ompTb /= mwbg_realMissing .and. ABS(ompTb) >= XCHECKVAL .and. &
3168 sigmaObsErrUsed /= MPC_missingValue_R8) then
3169 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
3170 obsFlags = OR(obsFlags,2**9)
3171 obsFlags = OR(obsFlags,2**16)
3172 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
3173 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
3174 if ( B7CHCK(obsChanNum) == 0 ) then
3175 rejectionCodArray2(testIndex,obsChanNumWithOffset,sensorIndex) = &
3176 rejectionCodArray2(testIndex,obsChanNumWithOffset,sensorIndex) + 1
3177 end if
3178
3179 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
3180
3181 if ( mwbg_debug ) then
3182 write(*,*) stnId(2:9),'ROGUE CHECK REJECT.NO.', &
3183 ' CHANNEL= ',obsChanNumWithOffset, &
3184 ' CHECK VALUE= ',XCHECKVAL, &
3185 ' TBOMP= ',ompTb, &
3186 ' TOVERRST= ',oer_toverrst(obsChanNumWithOffset,sensorIndex)
3187 end if
3188
3189 if (obsChanNumWithOffset == 1 .or. obsChanNumWithOffset == 2 .or. &
3190 obsChanNumWithOffset == 3) then
3191 SFCREJCT = .TRUE.
3192 end if
3193 end if ! if (ompTb /= mwbg_realMissing
3194
3195 if (obsChanNumWithOffset == 17 .and. ompTb /= mwbg_realMissing .and. &
3196 ABS(ompTb) > 5.0d0) then
3197 CH2OMPREJCT = .TRUE.
3198 end if
3199 end do BODY
3200
3201 if ( SFCREJCT ) then
3202 BODY2: do bodyIndex = bodyIndexBeg, bodyIndexEnd
3203 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
3204 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
3205 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
3206
3207 INDXCAN = utl_findloc(ISFCREJ(:),obsChanNumWithOffset)
3208 if ( INDXCAN /= 0 ) then
3209 if ( qcIndicator(obsChanNum) /= testIndex ) then
3210 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
3211 obsFlags = OR(obsFlags,2**9)
3212 obsFlags = OR(obsFlags,2**16)
3213 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
3214 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
3215 if ( B7CHCK(obsChanNum) == 0 ) then
3216 rejectionCodArray2(testIndex,obsChanNumWithOffset,sensorIndex) = &
3217 rejectionCodArray2(testIndex,obsChanNumWithOffset,sensorIndex) + 1
3218 end if
3219
3220 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
3221 end if ! if ( qcIndicator(obsChanNum)
3222 end if ! if ( INDXCAN /= 0 )
3223 end do BODY2
3224 end if ! SFCREJCT
3225
3226 ! amsub channels 17-22 obs are rejected if, for ch17 ABS(O-P) > 5K
3227 ! Apply over open water only (bit 0 ON in QC integer newInformationFlag).
3228 ! Only apply if obs not rejected in this test already.
3229 IBIT = AND(newInformationFlag, 2**0)
3230 if ( CH2OMPREJCT .and. (IBIT /= 0) ) then
3231 BODY3: do bodyIndex = bodyIndexBeg, bodyIndexEnd
3232 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
3233 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
3234 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
3235
3236 INDXCAN = utl_findloc(ICH2OMPREJ(:),obsChanNumWithOffset)
3237 if ( INDXCAN /= 0 ) then
3238 if ( qcIndicator(obsChanNum) /= testIndex ) then
3239 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
3240 obsFlags = OR(obsFlags,2**9)
3241 obsFlags = OR(obsFlags,2**16)
3242
3243 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
3244 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
3245 if ( B7CHCK(obsChanNum) == 0 ) then
3246 rejectionCodArray2(testIndex,obsChanNumWithOffset,sensorIndex) = &
3247 rejectionCodArray2(testIndex,obsChanNumWithOffset,sensorIndex) + 1
3248 end if
3249
3250 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
3251 end if ! if ( qcIndicator(obsChanNum)
3252 end if ! if ( INDXCAN /= 0 )
3253 end do BODY3
3254 end if ! if ( CH2OMPREJCT
3255
3256 end subroutine atmsTest4RogueCheck
3257
3258 !--------------------------------------------------------------------------
3259 ! Mwhs2Test4RogueCheck
3260 !--------------------------------------------------------------------------
3261 subroutine Mwhs2Test4RogueCheck(itest, sensorIndex, ROGUEFAC, waterobs, ICH2OMPREJ, &
3262 B7CHCK, qcIndicator, headerIndex, obsSpaceData)
3263 !
3264 !:Purpose: test 4: "Rogue check" for (O-P) Tb residuals out of range (single/full).
3265 ! Also, over WATER remove CH.10-15 if CH.10 |O-P|>5K (full)
3266 ! Les observations, dont le residu (O-P)
3267 ! depasse par un facteur (roguefac) l'erreur totale des TOVS.
3268 !
3269 ! OVER OPEN WATER ch. 10 Abs(O-P) > 5K produces rejection of all ATMS amsub channels 10-15.
3270 !
3271 implicit none
3272
3273 ! Arguments:
3274 integer, intent(in) :: itest(:) ! test number
3275 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
3276 real(8), intent(in) :: ROGUEFAC(:) ! rogue factor
3277 logical, intent(in) :: waterobs ! open water obs
3278 integer, intent(in) :: ICH2OMPREJ(:) ! rejection channel list
3279 integer, intent(inout) :: qcIndicator(:) ! indicateur du QC par canal
3280 integer, intent(inout) :: B7CHCK(:) ! bit=7 of channel is on (=1) or off(=0)
3281 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
3282 integer, intent(in) :: headerIndex ! current header Index
3283
3284 ! Locals:
3285 integer :: testIndex, INDXCAN, newInformationFlag, bodyIndex, bodyIndexBeg, bodyIndexEnd
3286 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
3287 real(8) :: XCHECKVAL, clwThresh1, clwThresh2, sigmaThresh1, sigmaThresh2
3288 real(8) :: sigmaObsErrUsed, clwObsFGaveraged
3289 real(8) :: cloudLiquidWaterPathObs, cloudLiquidWaterPathFG, ompTb
3290 logical :: CH2OMPREJCT, IBIT
3291 character(len=9) :: stnId
3292
3293 testIndex = 4
3294 if ( itest(testIndex) /= 1 ) return
3295
3296 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
3297 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
3298
3299 cloudLiquidWaterPathObs = obs_headElem_r(obsSpaceData, OBS_CLWO, headerIndex)
3300 cloudLiquidWaterPathFG = obs_headElem_r(obsSpaceData, OBS_CLWB, headerIndex)
3301 newInformationFlag = obs_headElem_i(obsSpaceData, OBS_INFG, headerIndex)
3302 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
3303
3304 CH2OMPREJCT = .FALSE.
3305 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
3306 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
3307 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
3308
3309 ! using state-dependent obs error only over water.
3310 ! obs over sea-ice will be rejected in test 15.
3311 if ( tvs_mwAllskyAssim .and. oer_useStateDepSigmaObs(obsChanNumWithOffset,sensorIndex) .and. waterobs ) then
3312 clwThresh1 = oer_cldPredThresh(obsChanNumWithOffset,sensorIndex,1)
3313 clwThresh2 = oer_cldPredThresh(obsChanNumWithOffset,sensorIndex,2)
3314 sigmaThresh1 = oer_errThreshAllsky(obsChanNumWithOffset,sensorIndex,1)
3315 sigmaThresh2 = oer_errThreshAllsky(obsChanNumWithOffset,sensorIndex,2)
3316 clwObsFGaveraged = 0.5d0 * (cloudLiquidWaterPathObs + cloudLiquidWaterPathFG)
3317 if ( cloudLiquidWaterPathObs == mwbg_realMissing ) then
3318 sigmaObsErrUsed = MPC_missingValue_R8
3319 else
3320 sigmaObsErrUsed = calcStateDepObsErr(clwThresh1,clwThresh2,sigmaThresh1, &
3321 sigmaThresh2,clwObsFGaveraged)
3322 end if
3323 else
3324 sigmaObsErrUsed = oer_toverrst(obsChanNumWithOffset,sensorIndex)
3325 end if
3326 ! For sigmaObsErrUsed=MPC_missingValue_R8 (cloudLiquidWaterPathObs=mwbg_realMissing
3327 ! in all-sky mode), the observation is flagged for rejection in
3328 ! mwbg_reviewAllCritforFinalFlagsMwhs2.
3329 XCHECKVAL = ROGUEFAC(obsChanNumWithOffset) * sigmaObsErrUsed
3330 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
3331 ompTb = obs_bodyElem_r(obsSpaceData, OBS_OMP, bodyIndex)
3332
3333 if (ompTb /= mwbg_realMissing .and. ABS(ompTb) >= XCHECKVAL .and. &
3334 sigmaObsErrUsed /= MPC_missingValue_R8) then
3335 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
3336 obsFlags = OR(obsFlags,2**9)
3337 obsFlags = OR(obsFlags,2**16)
3338
3339 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
3340 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
3341 if ( B7CHCK(obsChanNum) == 0 ) then
3342 rejectionCodArray2(testIndex,obsChanNumWithOffset,sensorIndex) = &
3343 rejectionCodArray2(testIndex,obsChanNumWithOffset,sensorIndex) + 1
3344 end if
3345
3346 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
3347
3348 if ( mwbg_debug ) then
3349 write(*,*) stnId(2:9),'ROGUE CHECK REJECT.NO.', &
3350 ' CHANNEL= ',obsChanNumWithOffset, &
3351 ' CHECK VALUE= ',XCHECKVAL, &
3352 ' TBOMP= ',ompTb, &
3353 ' TOVERRST= ',oer_toverrst(obsChanNumWithOffset,sensorIndex)
3354 end if
3355 end if ! if (ompTb /= mwbg_realMissing
3356
3357 if (obsChanNumWithOffset == 10 .and. ompTb /= mwbg_realMissing .and. ABS(ompTb) > 5.0d0) then
3358 CH2OMPREJCT = .TRUE.
3359 end if
3360 end do BODY
3361
3362 ! Channels 10-15 are rejected if, for ch10 ABS(O-P) > 5K
3363 ! Apply over open water only (bit 0 ON in QC integer newInformationFlag).
3364 ! Only apply if obs not rejected in this test already.
3365 IBIT = AND(newInformationFlag, 2**0)
3366 if ( CH2OMPREJCT .and. (IBIT /= 0) ) then
3367 BODY2: do bodyIndex = bodyIndexBeg, bodyIndexEnd
3368 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
3369 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
3370 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
3371
3372 INDXCAN = utl_findloc(ICH2OMPREJ(:),obsChanNumWithOffset)
3373 if ( INDXCAN /= 0 ) then
3374 if ( qcIndicator(obsChanNum) /= testIndex ) then
3375 qcIndicator(obsChanNum) = MAX(qcIndicator(obsChanNum),testIndex)
3376 obsFlags = OR(obsFlags,2**9)
3377 obsFlags = OR(obsFlags,2**16)
3378 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
3379 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
3380 if ( B7CHCK(obsChanNum) == 0 ) then
3381 rejectionCodArray2(testIndex,obsChanNumWithOffset,sensorIndex) = &
3382 rejectionCodArray2(testIndex,obsChanNumWithOffset,sensorIndex) + 1
3383 end if
3384
3385 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
3386 end if
3387 end if ! if ( INDXCAN /= 0 )
3388 end do BODY2
3389 end if ! if ( CH2OMPREJCT
3390
3391 end subroutine Mwhs2Test4RogueCheck
3392
3393 !--------------------------------------------------------------------------
3394 ! atmsMwhs2Test5ChannelSelectionUsingTovutil
3395 !--------------------------------------------------------------------------
3396 subroutine atmsMwhs2Test5ChannelSelectionUsingTovutil(itest, sensorIndex, &
3397 headerIndex, obsSpaceData)
3398 !
3399 !:Purpose: test 5: Channel selection using array oer_tovutil(chan,sat):
3400 ! - = 0 blacklisted,
3401 ! - = 1 assmilate
3402 !
3403 implicit none
3404
3405 ! Arguments:
3406 integer, intent(in) :: itest(:) ! test number
3407 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
3408 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
3409 integer, intent(in) :: headerIndex ! current header Index
3410
3411 ! Locals:
3412 integer :: testIndex, bodyIndex, bodyIndexBeg, bodyIndexEnd
3413 integer :: obsChanNum, obsChanNumWithOffset, obsFlags
3414 character(len=9) :: stnId
3415
3416 testIndex = 5
3417 if ( itest(testIndex) /= 1 ) return
3418
3419 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
3420 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
3421
3422 stnId = obs_elem_c(obsSpaceData, 'STID', headerIndex)
3423
3424 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
3425 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
3426 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
3427 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
3428
3429 if ( oer_tovutil(obsChanNumWithOffset,sensorIndex) == 0 ) then
3430 obsFlags = OR(obsFlags,2**8)
3431 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) = &
3432 rejectionCodArray(testIndex,obsChanNumWithOffset,sensorIndex) + 1
3433
3434 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
3435
3436 if ( mwbg_debug ) then
3437 write(*,*) stnId(2:9),'CHANNEL REJECT: ', &
3438 ' CHANNEL= ',obsChanNumWithOffset
3439 end if
3440 end if ! if ( oer_tovutil
3441 end do BODY
3442
3443 end subroutine atmsMwhs2Test5ChannelSelectionUsingTovutil
3444
3445 !--------------------------------------------------------------------------
3446 ! mwbg_tovCheckAtms
3447 !--------------------------------------------------------------------------
3448 subroutine mwbg_tovCheckAtms(qcIndicator, sensorIndex, modelInterpTerrain, &
3449 RESETQC, headerIndex, obsSpaceData)
3450 !
3451 !:Purpose: Effectuer le controle de qualite des radiances tovs.
3452 !
3453 implicit none
3454
3455 ! Arguments:
3456 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
3457 integer, intent(in) :: headerIndex ! current header Index
3458 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
3459 real(8), intent(in) :: modelInterpTerrain ! topographie du modele
3460 logical, intent(in) :: RESETQC ! reset du controle de qualite?
3461 integer, allocatable, intent(out) :: qcIndicator(:) ! indicateur controle de qualite tovs par canal (=0 ok, >0 rejet)
3462
3463 ! Locals:
3464 integer, parameter :: maxScanAngleAMSU = 96
3465 integer, parameter :: ilsmOpt = 1 ! OPTION for values of MG (land/sea mask) and LG (ice)
3466 ! at each observation point using values on 5x5 mesh
3467 ! centered at each point.
3468 ! ilsmOpt = 1 --> use MAX value from all 25 mesh points
3469 ! ilsmOpt = 2 --> use value at central mesh point (obs location)
3470 ! ilsmOpt = 3 --> use AVG value from all 25 mesh points
3471 integer :: calcLandQualifierIndice, calcTerrainTypeIndice, KCHKPRF
3472 integer :: iRej, iNumSeaIce, JI, actualNumChannel
3473 integer :: bodyIndex, bodyIndexBeg, bodyIndexEnd, obsFlags
3474 integer :: ISFCREJ(8), ICH2OMPREJ(6)
3475 integer, allocatable :: B7CHCK(:)
3476 integer :: ITEST(mwbg_maxNumTest), chanIgnoreInAllskyGenCoeff(6), ICHTOPO(5)
3477 logical :: waterobs, grossrej, reportHasMissingTb
3478 logical :: cloudobs, iwvreject, precipobs
3479 real(8) :: zdi, scatec, scatbg, SeaIce, riwv, ZCRIT(5)
3480 real(8), allocatable :: ROGUEFAC(:)
3481 logical, allocatable :: qcRejectLogic(:)
3482 logical, save :: LLFIRST = .true.
3483 integer, save :: numReportWithMissingTb
3484 integer, save :: drycnt ! Number of pts flagged for AMSU-B Dryness Index
3485 integer, save :: landcnt ! Number of obs pts found over land/ice
3486 integer, save :: rejcnt ! Number of problem obs pts (Tb err, QCfail)
3487 integer, save :: iwvcnt ! Number of pts with Mean 183 Ghz Tb < 240K
3488 integer, save :: pcpcnt ! Number of scatter/precip obs
3489 integer, save :: cldcnt ! Number of water point covered by cloud
3490 integer, save :: flgcnt ! Total number of filtered obs pts
3491 integer, save :: seaIcePointNum ! Number of waterobs points converted to sea ice points
3492 integer, save :: clwMissingPointNum ! Number of points where cloudLiquidWaterPath/SI missing
3493 ! over water due bad data
3494
3495 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
3496 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
3497
3498 actualNumChannel = tvs_coefs(sensorIndex)%coef%fmv_ori_nchn
3499 allocate(ROGUEFAC(actualNumChannel+tvs_channelOffset(sensorIndex)))
3500 ROGUEFAC(:) = (/2.0d0, 2.0d0, 2.0d0, 3.0d0, 3.0d0, 4.0d0, 4.0d0, 4.0d0, &
3501 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 2.0d0, &
3502 2.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0/)
3503 if ( tvs_mwAllskyAssim ) ROGUEFAC(1:3) = 3.0
3504
3505 ! Channel sets for rejection in test 9
3506 ! These LT channels are rejected if O-P fails rogue check for window ch. 1, 2, or 3
3507 ISFCREJ(:) = (/1, 2, 3, 4, 5, 6, 16, 17/)
3508 ! These AMSU-B channels are rejected if ch. 17 O-P fails rogue check over OPEN WATER only
3509 ICH2OMPREJ(:) = (/17, 18, 19, 20, 21, 22/)
3510
3511 ! Data for TOPOGRAPHY CHECK
3512 ! Channel AMSUA-6 (atms ch 7) is rejected for topography > 250m.
3513 ! Channel AMSUA-7 (atms ch 8) is rejected for topography > 2000m.
3514 ! Channel AMSUB-3 (atms ch 22) is rejected for topography > 2500m.
3515 ! atms ch 21 is rejected for topography > 2250m.
3516 ! Channel AMSUB-4 (atms ch 20) is rejected for topography > 2000m.
3517 ICHTOPO(:) = (/7, 8, 20, 21, 22/)
3518 ZCRIT(:) = (/250.0d0, 2000.0d0, 2000.0d0, 2250.0d0, 2500.0d0/)
3519
3520 ! Test selection (0=skip test, 1=do test)
3521 ! 1 2 3 4 5
3522 ITEST(:) = 0
3523 ITEST(1:5) = (/1, 1, 1, 1, 1/)
3524
3525 ! Channels excluded from gen_bias_corr in all-sky mode
3526 chanIgnoreInAllskyGenCoeff(:) = (/ 1, 2, 3, 4, 5, 6/)
3527
3528 ! Initialisation, la premiere fois seulement!
3529 if (LLFIRST) then
3530 numReportWithMissingTb = 0
3531 flgcnt = 0
3532 landcnt = 0
3533 rejcnt = 0
3534 cldcnt = 0
3535 iwvcnt = 0
3536 pcpcnt = 0
3537 drycnt = 0
3538 seaIcePointNum = 0
3539 clwMissingPointNum = 0
3540 rejectionCodArray(:,:,:) = 0
3541 rejectionCodArray2(:,:,:) = 0
3542 LLFIRST = .FALSE.
3543 end if
3544
3545 ! PART 1 TESTS:
3546
3547 !###############################################################################
3548 ! STEP 1 ) Determine which obs pts are over open water (i.e NOT near coasts or
3549 ! over/near land/ice) using model MG and LG fields from glbhyb2 ANAL
3550 !###############################################################################
3551 call atmsMwhs2landIceMask(calcLandQualifierIndice, calcTerrainTypeIndice, waterobs, ilsmOpt, &
3552 headerIndex, obsSpaceData)
3553
3554 !###############################################################################
3555 ! STEP 2 ) Check for values of TB that are missing or outside physical limits.
3556 !###############################################################################
3557 call mwbg_grossValueCheck(50.0d0, 380.0d0, grossrej, headerIndex, sensorIndex, obsSpaceData)
3558
3559 !###############################################################################
3560 ! STEP 3 ) Preliminary QC checks --> set qcRejectLogic(actualNumChannel)=.true.
3561 ! for data that fail QC
3562 !###############################################################################
3563 call mwbg_firstQcCheckAtms(qcRejectLogic, grossrej, calcLandQualifierIndice, calcTerrainTypeIndice, &
3564 reportHasMissingTb, headerIndex, sensorIndex, obsSpaceData)
3565
3566 if ( reportHasMissingTb ) numReportWithMissingTb = numReportWithMissingTb + 1
3567 ! Exclude problem points from further calculations
3568 if ( COUNT(qcRejectLogic(:)) == actualNumChannel ) grossrej = .true.
3569
3570 !###############################################################################
3571 ! STEP 4 ) mwbg_nrlFilterAtms returns cloudLiquidWaterPathObs, cloudLiquidWaterPathFG, scatec, scatbg and also does sea-ice
3572 ! detection missing value for cloudLiquidWaterPathObs, scatec, scatbg is mwbg_realMissing (e.g. over
3573 ! land or sea-ice).Sets calcTerrainTypeIndice=0 (sea ice) for points where retrieved SeaIce
3574 ! >=0.55. Does nothing if calcTerrainTypeIndice=0 (sea ice) and retrieved SeaIce<0.55.
3575 !###############################################################################
3576 call mwbg_nrlFilterAtms(calcLandQualifierIndice, calcTerrainTypeIndice, waterobs, grossrej, &
3577 scatec, scatbg, iNumSeaIce, iRej, SeaIce, &
3578 headerIndex, sensorIndex, obsSpaceData)
3579
3580 seaIcePointNum = seaIcePointNum + iNumSeaIce
3581 clwMissingPointNum = clwMissingPointNum + iRej
3582
3583 !###############################################################################
3584 ! STEP 5 ) Apply NRL cloud filter, scattering index and sea-ice detection algorithms
3585 ! to OPEN WATER (waterobs=true) points.
3586 ! Points with SeaIce>0.55 are set to sea-ice points (waterobs --> false)
3587 !###############################################################################
3588 call mwbg_flagDataUsingNrlCritAtms(scatec, scatbg, SeaIce, grossrej, waterobs, mwbg_useUnbiasedObsForClw, &
3589 iwvreject, cloudobs, precipobs, cldcnt , riwv, zdi, &
3590 headerIndex, sensorIndex, obsSpaceData)
3591
3592 !###############################################################################
3593 ! STEP 6 ) ! Review all the checks previously made to determine which obs are to be
3594 ! accepted for assimilation and which are to be flagged for exclusion
3595 ! (obsFlags).
3596 ! grossrej() = .true. if any channel had a gross error at the point
3597 ! cloudobs() = .true. if CLW > clw_atms_nrl_LTrej (0.175) or precipobs
3598 ! precipobs() = .true. if precip. detected through NRL scattering indices
3599 ! waterobs() = .true. if open water point
3600 ! iwvreject() = .true. if Mean 183 Ghz [ch. 18-22] Tb < 240K (too dry
3601 ! for ch.20-22 over land)
3602 !###############################################################################
3603 call mwbg_reviewAllCritforFinalFlagsAtms(qcRejectLogic, grossrej, waterobs, &
3604 precipobs, scatec, scatbg, &
3605 iwvreject, riwv, &
3606 zdi, drycnt, landcnt, &
3607 rejcnt, iwvcnt, pcpcnt, flgcnt, &
3608 chanIgnoreInAllskyGenCoeff, &
3609 headerIndex, sensorIndex, obsSpaceData)
3610
3611 !###############################################################################
3612 ! PART 2 TESTS:
3613 !###############################################################################
3614
3615 ! allocations
3616 allocate(qcIndicator(actualNumChannel))
3617 allocate(B7CHCK(actualNumChannel))
3618 ! Initialisations
3619 qcIndicator(:) = 0
3620 B7CHCK(:) = 0
3621
3622 if ( RESETQC ) then
3623 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
3624 obsFlags = 0
3625 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
3626 end do BODY
3627 end if
3628
3629 ! 1) test 1: Check flag bit 7 on from the first bgckAtms program
3630 ! Includes observations flagged for cloud liquid water, scattering index,
3631 ! dryness index plus failure of several QC checks.
3632 call atmsMwhs2Test1Flagbit7Check (itest, sensorIndex, qcIndicator, &
3633 B7CHCK, headerIndex, obsSpaceData)
3634
3635 ! 2) test 2: Topography check (partial)
3636 call atmsMwhs2Test2TopographyCheck (itest, sensorIndex, &
3637 modelInterpTerrain, ICHTOPO, ZCRIT, B7CHCK, qcIndicator, &
3638 headerIndex, obsSpaceData)
3639
3640 ! 3) test 3: Uncorrected Tb check (single)
3641 ! Uncorrected datum (flag bit #6 off). In this case switch bit 11 ON.
3642 call atmsMwhs2Test3UncorrectedTbCheck (itest, sensorIndex, RESETQC, B7CHCK, qcIndicator, &
3643 headerIndex, obsSpaceData)
3644
3645 ! 4) test 4: "Rogue check" for (O-P) Tb residuals out of range. (single/full)
3646 ! Also, over WATER remove CH.17-22 if CH.17 |O-P|>5K (partial)
3647 ! Les observations, dont le residu (O-P) depasse par un facteur (roguefac)
3648 ! l'erreur totale des TOVS.
3649 ! N.B.: a reject by any of the 3 amsua surface channels 1-3 produces the
3650 ! rejection of ATMS sfc/tropospheric channels 1-6 and 16-17.
3651 ! OVER OPEN WATER
3652 ! ch. 17 Abs(O-P) > 5K produces rejection of all ATMS amsub channels 17-22.
3653 call atmsTest4RogueCheck (itest, sensorIndex, ROGUEFAC, waterobs, ISFCREJ, ICH2OMPREJ, &
3654 B7CHCK, qcIndicator, headerIndex, obsSpaceData)
3655
3656 ! 5) test 5: Channel selection using array oer_tovutil(chan,sat)
3657 ! oer_tovutil = 0 (blacklisted)
3658 ! 1 (assmilate)
3659 call atmsMwhs2Test5ChannelSelectionUsingTovutil(itest, sensorIndex, &
3660 headerIndex, obsSpaceData)
3661
3662 ! Synthese de la controle de qualite au niveau de chaque point
3663 ! d'observation. Code:
3664 ! =0 aucun rejet, >0 au moins un canal rejete.
3665 KCHKPRF = 0
3666 do JI = 1, actualNumChannel
3667 KCHKPRF = MAX(KCHKPRF,qcIndicator(JI))
3668 end do
3669
3670 if ( mwbg_debug ) write(*,*)'KCHKPRF = ', KCHKPRF
3671
3672 ! reset global marker flag (55200) and mark it if observtions are rejected
3673 call resetQcCases(RESETQC, KCHKPRF, headerIndex, obsSpaceData)
3674
3675 if(mwbg_debug) then
3676 write(*,*) ' --------------------------------------------------------------- '
3677 write(*,*) ' Number of BURP file reports where Tb set to mwbg_realMissing = ', numReportWithMissingTb
3678 write(*,*) ' --------------------------------------------------------------- '
3679 write(*,*) ' 1. Number of obs pts found over land/ice = ', landcnt
3680 write(*,*) ' 2. Number of problem obs pts (Tb err, QCfail) = ', rejcnt
3681 write(*,*) ' 3. Number of cloudy obs (CLW > clw_min) = ', cldcnt
3682 write(*,*) ' 4. Number of scatter/precip obs = ', pcpcnt
3683 write(*,*) ' 5. Number of pts with Mean 183 Ghz Tb < 240K = ', iwvcnt
3684 write(*,*) ' 6. Number of pts flagged for AMSU-B Dryness Index = ', drycnt
3685 write(*,*) ' --------------------------------------------------------------- '
3686 write(*,*) ' Total number of filtered obs pts = ', flgcnt
3687 write(*,*) ' ----------------------------------------------------------------'
3688 write(*,*) ' '
3689 write(*,*) ' Number of waterobs points converted to sea ice points = ', seaIcePointNum
3690 write(*,*) ' Number of points where CLW/SI missing over water due bad data = ', clwMissingPointNum
3691 write(*,*) ' --------------------------------------------------------------- '
3692
3693 write(*,*) ' Meaning of newInformationFlag flag bits: '
3694 write(*,*) ' '
3695 write(*,*) ' BIT Meaning'
3696 write(*,*) ' 0 off=land or sea-ice, on=open water away from coast'
3697 write(*,*) ' 1 Mean 183 Ghz [ch. 18-22] is missing'
3698 write(*,*) ' 2 NRL CLW is missing (over water)'
3699 write(*,*) ' 3 NRL > clw_atms_nrl_LTrej (0.175 kg/m2) (cloudobs)'
3700 write(*,*) ' 4 scatec/scatbg > Lower Troposphere limit 9/10 (precipobs)'
3701 write(*,*) ' 5 Mean 183 Ghz [ch. 18-22] Tb < 240K'
3702 write(*,*) ' 6 CLW > clw_atms_nrl_UTrej (0.200 kg/m2)'
3703 write(*,*) ' 7 Dryness Index rejection (for ch. 22)'
3704 write(*,*) ' 8 scatec/scatbg > Upper Troposphere limit 18/15'
3705 write(*,*) ' 9 Dryness Index rejection (for ch. 21)'
3706 write(*,*) ' 10 Sea ice > 0.55 detected'
3707 write(*,*) ' 11 Gross error in Tb (any chan.) or other QC problem (all channels rejected)'
3708 write(*,*) ' '
3709 write(*,*) ' New Element 13209 in BURP file = CLW (kg/m2)'
3710 write(*,*) ' New Element 13208 in BURP file = ECMWF Scattering Index'
3711 write(*,*) ' New Element 25174 in BURP file = newInformationFlag flag'
3712 write(*,*) ' '
3713 end if
3714
3715 end subroutine mwbg_tovCheckAtms
3716
3717 !--------------------------------------------------------------------------
3718 ! mwbg_tovCheckMwhs2
3719 !--------------------------------------------------------------------------
3720 subroutine mwbg_tovCheckMwhs2(qcIndicator, sensorIndex, modelInterpTerrain, &
3721 RESETQC, modLSQ, lastHeader, headerIndex, obsSpaceData)
3722 !
3723 !:Purpose: Effectuer le controle de qualite des radiances tovs.
3724 !
3725 implicit none
3726
3727 ! Arguments:
3728 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
3729 integer, intent(in) :: headerIndex ! current header Index
3730 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
3731 real(8), intent(in) :: modelInterpTerrain ! topographie du modele as being over land/ice, cloudy, bad IWV
3732 logical, intent(in) :: RESETQC ! reset du controle de qualite?
3733 logical, intent(in) :: modLSQ ! If active, recalculate land/sea qualifier and terrain type based on LG/MG
3734 logical, intent(in) :: lastHeader ! active if last header
3735 integer, allocatable, intent(out) :: qcIndicator(:) ! indicateur controle de qualite tovs par canal (=0 ok, >0 rejet)
3736
3737 ! Locals:
3738 integer, parameter :: maxScanAngleAMSU = 98
3739 integer, parameter :: ilsmOpt = 2 ! OPTION for values of MG (land/sea mask) and LG (ice)
3740 ! at each observation point using values on 5x5 mesh
3741 ! centered at each point.
3742 ! ilsmOpt = 1 --> use MAX value from all 25 mesh points
3743 ! ilsmOpt = 2 --> use value at central mesh point (obs location)
3744 ! ilsmOpt = 3 --> use AVG value from all 25 mesh points
3745 integer :: calcLandQualifierIndice, calcTerrainTypeIndice, KCHKPRF
3746 integer :: iRej, iNumSeaIce, JI, actualNumChannel
3747 integer :: bodyIndex, bodyIndexBeg, bodyIndexEnd, obsFlags
3748 integer :: ICH2OMPREJ(6), chanIgnoreInAllskyGenCoeff(6), ICHTOPO(3)
3749 integer :: ITEST(mwbg_maxNumTest)
3750 integer, allocatable :: B7CHCK(:)
3751 logical :: waterobs, grossrej, reportHasMissingTb
3752 logical :: cloudobs, iwvreject, precipobs
3753 logical, allocatable :: qcRejectLogic(:)
3754 real(8) :: zdi, scatec, scatbg, SeaIce, riwv, ZCRIT(3)
3755 real(8), allocatable :: ROGUEFAC(:)
3756 logical, save :: LLFIRST = .true.
3757 integer, save :: numReportWithMissingTb
3758 integer, save :: allcnt ! Number of Tovs obs
3759 integer, save :: drycnt ! Number of pts flagged for AMSU-B Dryness Index
3760 integer, save :: landcnt ! Number of obs pts found over land/ice
3761 integer, save :: rejcnt ! Number of problem obs pts (Tb err, QCfail)
3762 integer, save :: iwvcnt ! Number of pts with Mean 183 Ghz Tb < 240K
3763 integer, save :: pcpcnt ! Number of scatter/precip obs
3764 integer, save :: cldcnt ! Number of water point covered by cloud
3765 integer, save :: flgcnt ! Total number of filtered obs pts
3766 integer, save :: seaIcePointNum ! Number of waterobs points converted to sea ice points
3767 integer, save :: clwMissingPointNum ! Number of points where cloudLiquidWaterPath/SI missing
3768 ! over water due bad data
3769
3770 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
3771 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
3772
3773 actualNumChannel = tvs_coefs(sensorIndex)%coef%fmv_ori_nchn
3774 allocate(ROGUEFAC(actualNumChannel+tvs_channelOffset(sensorIndex)))
3775 ROGUEFAC(:) = (/2.0d0, 9.9d0, 9.9d0, 9.9d0, 9.9d0, 9.9d0, 9.9d0, 9.9d0, &
3776 9.9d0, 2.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0/)
3777 if ( tvs_mwAllskyAssim ) ROGUEFAC(1:3) = 9.9d0
3778
3779 ! Channel sets for rejection in test 9
3780 ! These AMSU-B channels are rejected if ch. 10 O-P fails rogue check over OPEN WATER only
3781 ICH2OMPREJ(:) = (/10, 11, 12, 13, 14, 15/)
3782
3783 ! Data for TOPOGRAPHY CHECK
3784 ! Channel AMSUB-3 (mwhs2 ch 11) is rejected for topography > 2500m.
3785 ! (mwhs2 ch 12) is rejected for topography > 2250m.
3786 ! Channel AMSUB-4 (mwhs2 ch 13) is rejected for topography > 2000m.
3787 ICHTOPO(:) = (/11, 12, 13/)
3788 ZCRIT(:) = (/2500.0d0, 2250.0d0, 2000.0d0/)
3789
3790 ! Test selection (0=skip test, 1=do test)
3791 ! 1 2 3 4 5
3792 ITEST(:) = 0
3793 ITEST(1:5) = (/1, 1, 1, 1, 1/)
3794
3795 ! Channels excluded from gen_bias_corr in all-sky mode
3796 chanIgnoreInAllskyGenCoeff(:) = (/ 10, 11, 12, 13, 14, 15/)
3797
3798 ! Initialisation, la premiere fois seulement!
3799 if (LLFIRST) then
3800 numReportWithMissingTb = 0
3801 allcnt = 0
3802 flgcnt = 0
3803 landcnt = 0
3804 rejcnt = 0
3805 cldcnt = 0
3806 iwvcnt = 0
3807 pcpcnt = 0
3808 drycnt = 0
3809 seaIcePointNum = 0
3810 clwMissingPointNum = 0
3811 rejectionCodArray(:,:,:) = 0
3812 rejectionCodArray2(:,:,:) = 0
3813 LLFIRST = .FALSE.
3814 end if
3815
3816 ! PART 1 TESTS:
3817
3818 !###############################################################################
3819 ! STEP 1 ) Determine which obs pts are over open water (i.e NOT near coasts or
3820 ! over/near land/ice) using model MG and LG fields from glbhyb2 ANAL
3821 !###############################################################################
3822 call atmsMwhs2landIceMask(calcLandQualifierIndice, calcTerrainTypeIndice, waterobs, ilsmOpt, &
3823 headerIndex, obsSpaceData)
3824
3825 !###############################################################################
3826 ! STEP 2 ) Check for values of TB that are missing or outside physical limits.
3827 !###############################################################################
3828 call mwbg_grossValueCheck(50.0d0, 380.0d0, grossrej, headerIndex, sensorIndex, obsSpaceData)
3829
3830 !###############################################################################
3831 ! STEP 3 ) Preliminary QC checks --> set qcRejectLogic(actualNumChannel)=.true.
3832 ! for data that fail QC
3833 !###############################################################################
3834 call mwbg_firstQcCheckMwhs2(qcRejectLogic, calcLandQualifierIndice, calcTerrainTypeIndice, &
3835 reportHasMissingTb, modLSQ, headerIndex, sensorIndex, obsSpaceData)
3836
3837 if ( reportHasMissingTb ) numReportWithMissingTb = numReportWithMissingTb + 1
3838 ! Exclude problem points from further calculations
3839 if ( COUNT(qcRejectLogic(:)) == actualNumChannel ) grossrej = .true.
3840
3841 !###############################################################################
3842 ! STEP 4 ) mwbg_nrlFilterMwhs2 returns cloudLiquidWaterPathObs, cloudLiquidWaterPathFG, scatec, scatbg and also does sea-ice
3843 ! detection missing value for cloudLiquidWaterPathObs, scatec, scatbg is mwbg_realMissing (e.g. over
3844 ! land or sea-ice).Sets calcTerrainTypeIndice=0 (sea ice) for points where retrieved SeaIce
3845 ! >=0.55. Does nothing if calcTerrainTypeIndice=0 (sea ice) and retrieved SeaIce<0.55.
3846 !###############################################################################
3847 call mwbg_nrlFilterMwhs2(calcLandQualifierIndice, calcTerrainTypeIndice, waterobs, grossrej, &
3848 scatec, scatbg, iNumSeaIce, iRej, SeaIce, &
3849 headerIndex, sensorIndex, obsSpaceData)
3850
3851 seaIcePointNum = seaIcePointNum + iNumSeaIce
3852 clwMissingPointNum = clwMissingPointNum + iRej
3853
3854 !###############################################################################
3855 ! STEP 5 ) Apply NRL cloud filter, scattering index and sea-ice detection algorithms
3856 ! to OPEN WATER (waterobs=true) points.
3857 ! Points with SeaIce>0.55 are set to sea-ice points (waterobs --> false)
3858 !###############################################################################
3859 call mwbg_flagDataUsingNrlCritMwhs2(scatec, SeaIce, grossrej, waterobs, mwbg_useUnbiasedObsForClw, &
3860 iwvreject, cloudobs, precipobs, cldcnt , riwv, zdi, &
3861 headerIndex, sensorIndex, obsSpaceData)
3862
3863 !###############################################################################
3864 ! STEP 6 ) ! Review all the checks previously made to determine which obs are to be
3865 ! accepted for assimilation and which are to be flagged for exclusion
3866 ! (obsFlags).
3867 ! grossrej() = .true. if any channel had a gross error at the point
3868 ! cloudobs() = .true. if CLW > clw_mwhs2_nrl_LTrej (0.175) or precipobs
3869 ! precipobs() = .true. if precip. detected through NRL scattering indices
3870 ! waterobs() = .true. if open water point
3871 ! iwvreject() = .true. if Mean 183 Ghz [ch. 11-15] Tb < 240K (too dry
3872 ! for ch.11-13 over land)
3873 !###############################################################################
3874 call mwbg_reviewAllCritforFinalFlagsMwhs2(qcRejectLogic, grossrej, calcTerrainTypeIndice, waterobs, &
3875 precipobs, scatec, scatbg, &
3876 iwvreject, riwv, &
3877 zdi, allcnt, drycnt, landcnt, &
3878 rejcnt, iwvcnt, pcpcnt, flgcnt, &
3879 chanIgnoreInAllskyGenCoeff, &
3880 headerIndex, sensorIndex, obsSpaceData)
3881
3882 !###############################################################################
3883 ! PART 2 TESTS:
3884 !###############################################################################
3885
3886 ! allocations
3887 allocate(qcIndicator(actualNumChannel))
3888 allocate(B7CHCK(actualNumChannel))
3889 ! Initialisations
3890 qcIndicator(:) = 0
3891 B7CHCK(:) = 0
3892
3893 if ( RESETQC ) then
3894 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
3895 obsFlags = 0
3896 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
3897 end do BODY
3898 end if
3899
3900 ! 1) test 1: Check flag bit 7 on from the first bgckMwhs2 program
3901 ! Includes observations flagged for cloud liquid water, scattering index,
3902 ! dryness index plus failure of several QC checks.
3903 call atmsMwhs2Test1Flagbit7Check (itest, sensorIndex, qcIndicator, &
3904 B7CHCK, headerIndex, obsSpaceData)
3905
3906 ! 2) test 2: Topography check (partial)
3907 call atmsMwhs2Test2TopographyCheck (itest, sensorIndex, &
3908 modelInterpTerrain, ICHTOPO, ZCRIT, B7CHCK, qcIndicator, &
3909 headerIndex, obsSpaceData)
3910
3911 ! 3) test 3: Uncorrected Tb check (single)
3912 ! Uncorrected datum (flag bit #6 off). In this case switch bit 11 ON.
3913 call atmsMwhs2Test3UncorrectedTbCheck (itest, sensorIndex, RESETQC, B7CHCK, qcIndicator, &
3914 headerIndex, obsSpaceData)
3915
3916 ! 4) test 4: "Rogue check" for (O-P) Tb residuals out of range. (single/full)
3917 ! Also, over WATER remove CH.10-15 if CH.10 |O-P|>5K (full)
3918 ! Les observations, dont le residu (O-P) depasse par un facteur (roguefac)
3919 ! l'erreur totale des TOVS.
3920 ! OVER OPEN WATER
3921 ! ch. 10 Abs(O-P) > 5K produces rejection of all ATMS amsub channels 10-15.
3922 call Mwhs2Test4RogueCheck (itest, sensorIndex, ROGUEFAC, waterobs, ICH2OMPREJ, &
3923 B7CHCK, qcIndicator, headerIndex, obsSpaceData)
3924
3925 ! 5) test 5: Channel selection using array oer_tovutil(chan,sat)
3926 ! oer_tovutil = 0 (blacklisted)
3927 ! 1 (assmilate)
3928 call atmsMwhs2Test5ChannelSelectionUsingTovutil(itest, sensorIndex, &
3929 headerIndex, obsSpaceData)
3930
3931 ! Synthese de la controle de qualite au niveau de chaque point
3932 ! d'observation. Code:
3933 ! =0 aucun rejet, >0 au moins un canal rejete.
3934 KCHKPRF = 0
3935 do JI = 1, actualNumChannel
3936 KCHKPRF = MAX(KCHKPRF,qcIndicator(JI))
3937 end do
3938
3939 if ( mwbg_debug ) write(*,*)'KCHKPRF = ', KCHKPRF
3940
3941 ! reset global marker flag (55200) and mark it if observtions are rejected
3942 call resetQcCases(RESETQC, KCHKPRF, headerIndex, obsSpaceData)
3943
3944 if (lastHeader) then
3945 write(*,*) ' --------------------------------------------------------------- '
3946 write(*,*) ' Number of obs pts read from BURP file = ', allcnt
3947 write(*,*) ' Number of BURP file reports where Tb set to mwbg_realMissing = ', numReportWithMissingTb
3948 write(*,*) ' --------------------------------------------------------------- '
3949 write(*,*) ' 1. Number of obs pts found over land/ice = ', landcnt
3950 write(*,*) ' 2. Number of problem obs pts (Tb err, QCfail) = ', rejcnt
3951 write(*,*) ' 3. Number of cloudy obs (CLW > clw_min) = ', cldcnt
3952 write(*,*) ' 4. Number of scatter/precip obs = ', pcpcnt
3953 write(*,*) ' 5. Number of pts with Mean 183 Ghz Tb < 240K = ', iwvcnt
3954 write(*,*) ' 6. Number of pts flagged for AMSU-B Dryness Index = ', drycnt
3955 write(*,*) ' --------------------------------------------------------------- '
3956 write(*,*) ' Total number of filtered obs pts = ', flgcnt
3957 write(*,*) ' ----------------------------------------------------------------'
3958 write(*,*) ' '
3959 write(*,*) ' Number of waterobs points converted to sea ice points = ', seaIcePointNum
3960 write(*,*) ' Number of points where CLW/SI missing over water due bad data = ', clwMissingPointNum
3961 write(*,*) ' --------------------------------------------------------------- '
3962
3963 write(*,*) ' Meaning of newInformationFlag flag bits: '
3964 write(*,*) ' '
3965 write(*,*) ' BIT Meaning'
3966 write(*,*) ' 0 off=land or sea-ice, on=open water away from coast'
3967 write(*,*) ' 1 Mean 183 Ghz [ch. 11-15] is missing'
3968 write(*,*) ' 2 NRL CLW is missing (over water)'
3969 write(*,*) ' 3 NRL > clw_mwhs2_nrl_LTrej (0.175 kg/m2) (cloudobs)'
3970 write(*,*) ' 4 scatec > Lower Troposphere limit=9 (precipobs)'
3971 write(*,*) ' 5 Mean 183 Ghz [ch. 11-15] Tb < 240K'
3972 write(*,*) ' 6 CLW > clw_mwhs2_nrl_UTrej (0.200 kg/m2)'
3973 write(*,*) ' 7 Dryness Index rejection (for ch. 11)'
3974 write(*,*) ' 8 scatbg > CMC amsu-b limit (land=0,sea=15,ice=40)'
3975 write(*,*) ' 9 Dryness Index rejection (for ch. 12)'
3976 write(*,*) ' 10 Sea ice > 0.55 detected'
3977 write(*,*) ' 11 Gross error in Tb (any chan.) or other QC problem (all channels rejected)'
3978 write(*,*) ' '
3979 write(*,*) ' New Element 13209 in BURP file = CLW (kg/m2)'
3980 write(*,*) ' New Element 13208 in BURP file = Bennartz-Grody Scattering Index'
3981 write(*,*) ' New Element 25174 in BURP file = newInformationFlag flag'
3982 write(*,*) ' '
3983 end if
3984
3985 end subroutine mwbg_tovCheckMwhs2
3986
3987 !--------------------------------------------------------------------------
3988 ! mwbg_readGeophysicFieldsAndInterpolate
3989 !--------------------------------------------------------------------------
3990 subroutine mwbg_readGeophysicFieldsAndInterpolate(instName, modelInterpTerrain, &
3991 modelInterpLandFrac, modelInterpSeaIce, &
3992 headerIndex, obsSpaceData)
3993 !
3994 !:Purpose: Reads Modele Geophysical variables and save for the first time
3995 ! TOPOGRAPHIE (MF ou MX):
3996 ! - MF est la topographie filtree avec unites en metres (filtered ME).
3997 ! - MX est la topographie filtree avec unites en m2/s2 (geopotential topography).
3998 ! - Glace de Mer (GL)
3999 ! - Masque Terre-Mer (MG)
4000 ! Then Interpolate Those variables to observation location
4001 !
4002 implicit none
4003
4004 ! Arguments:
4005 character(len=*), intent(in) :: instName ! Instrument Name
4006 real(8), intent(out) :: modelInterpLandFrac ! model interpolated land fraction.
4007 real(8), intent(out) :: modelInterpTerrain ! topographie filtree (en metres) et interpolees
4008 real(8), intent(out) :: modelInterpSeaIce ! Glace de mer interpolees au pt d'obs.
4009 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
4010 integer, intent(in) :: headerIndex ! current header Index
4011
4012 ! Locals:
4013 integer, parameter :: MXLON = 5, MXLAT = 5, MXELM = 40
4014 real(4), parameter :: DLAT = 0.4, DLON = 0.6
4015 real(4), allocatable, save :: GL(:) ! Modele Glace de Mer (GL)
4016 real(4), allocatable, save :: MG(:) ! Modele Masque Terre-Mer (MG)
4017 real(4), allocatable, save :: MT(:) ! Modele Topographie (MT)
4018 integer, save :: gdmt ! topo interpolation param
4019 integer, save :: gdmg ! mask terre-mer interpolation param
4020 integer, save :: gdgl ! glace interpolation param
4021 real(4), save :: TOPOFACT ! Facteur x topo pour avoir des unites en metre
4022 logical, save :: ifFirstCall = .True. ! If .True. we read GL, MT and MG
4023 integer :: gdllsval, IUNGEO
4024 integer :: ier, irec, ezqkdef, ezsetopt, FSTINF,FSTPRM,FCLOS, FSTLIR,FSTFRM, FNOM, FSTOUV
4025 integer :: NI, NJ, NK, IG1, IG2, IG3, IG4, IDUM1, IDUM2, IDUM3, IDUM4, IDUM5, IDUM6, IDUM7, IDUM8
4026 integer :: IDUM9, IDUM10, IDUM11, IDUM12, IDUM13, IDUM14, IDUM15, IDUM16, IDUM17, IDUM18
4027 integer :: NLAT, NLON, boxPointIndex, latIndex, lonIndex, boxPointNum
4028 character(len=12) :: ETIKXX
4029 character(len=4) :: CLNOMVAR
4030 character(len=4) :: NOMVXX
4031 character(len=2) :: TYPXX
4032 character(len=1) :: GRTYP
4033 real(4) :: XLAT, XLON, obsLat, obsLon
4034 real(4), allocatable :: ZLATBOX(:), ZLONBOX(:), MGINTBOX(:), MTINTBOX(:), GLINTBOX(:)
4035 logical :: readGlaceMask
4036
4037 ! lat/lon
4038 obsLat = obs_headElem_r(obsSpaceData, OBS_LAT, headerIndex)
4039 obsLon = obs_headElem_r(obsSpaceData, OBS_LON, headerIndex)
4040
4041 ! Convert lat/lon to degrees
4042 obsLon = obsLon * MPC_DEGREES_PER_RADIAN_R8
4043 if (obsLon > 180.) obsLon = obsLon - 360.
4044 obsLat = obsLat * MPC_DEGREES_PER_RADIAN_R8
4045
4046 ! STEP 1: READ MT, GL and MG from the FST FILE
4047 readGlaceMask = .True.
4048 if (instName == 'ATMS') readGlaceMask = .False.
4049 if (ifFirstCall) then
4050 IUNGEO = 0
4051 IER = FNOM(IUNGEO,fileMgLg,'STD+RND+R/O',0)
4052
4053 ! 3) Lecture des champs geophysiques (MF/MX) du modele
4054 IER = FSTOUV(IUNGEO,'RND')
4055
4056 ! TOPOGRAPHIE (MF ou MX).
4057 ! MX est la topographie filtree avec unites en m2/s2 (geopotential topography).
4058
4059 IREC = FSTINF(IUNGEO,NI,NJ,NK,-1,' ',-1,-1,-1,' ','MX')
4060 if (IREC .GE. 0) then
4061 TOPOFACT = 9.80616
4062 CLNOMVAR = 'MX'
4063 if(allocated(MT)) deallocate(MT)
4064 allocate ( MT(NI*NJ), STAT=ier)
4065 IER = FSTLIR(MT,IUNGEO,NI,NJ,NK,-1,' ',-1,-1,-1, &
4066 ' ',CLNOMVAR)
4067 else
4068 call utl_abort ('bgckMicrowave_mod: ERREUR: LA TOPOGRAPHIE (MF or MX) EST INEXISTANTE')
4069 end if
4070
4071 IER = FSTPRM(IREC, IDUM1, IDUM2, IDUM3, IDUM4, &
4072 IDUM5, IDUM6, IDUM7, IDUM8, IDUM9, IDUM10, &
4073 IDUM11, TYPXX, NOMVXX, ETIKXX, GRTYP, IG1, &
4074 IG2, IG3, IG4, IDUM12, IDUM13, IDUM14, &
4075 IDUM15, IDUM16, IDUM17, IDUM18)
4076 write (*,*) 'GRILLE MT : ',grtyp,ni,nj, ig1,ig2,ig3,ig4
4077 ier = ezsetopt('INTERP_DEGREE','LINEAR')
4078 ier = ezsetopt('EXTRAP_DEGREE','ABORT')
4079 gdmt = ezqkdef(ni,nj,grtyp,ig1,ig2,ig3,ig4,iungeo)
4080
4081 if (readGlaceMask) then
4082 ! MG
4083 IREC = FSTINF(IUNGEO,NI,NJ,NK,-1,' ',-1,-1,-1,' ','MG')
4084 if (IREC < 0) then
4085 call utl_abort ('bgckMicrowave_mod: ERREUR: LE MASQUE TERRE-MER EST INEXISTANT')
4086 end if
4087
4088 if(allocated(MG)) deallocate(MG)
4089 allocate ( MG(NI*NJ), STAT=ier)
4090 IER = FSTLIR(MG,IUNGEO,NI,NJ,NK,-1,' ',-1,-1,-1,' ','MG')
4091
4092 IER = FSTPRM(IREC, IDUM1, IDUM2, IDUM3, IDUM4, &
4093 IDUM5, IDUM6, IDUM7, IDUM8, IDUM9, IDUM10, &
4094 IDUM11, TYPXX, NOMVXX, ETIKXX, GRTYP, IG1,&
4095 IG2, IG3, IG4, IDUM12, IDUM13, IDUM14, &
4096 IDUM15, IDUM16, IDUM17, IDUM18)
4097 write (*,*) ' GRILLE MG : ',grtyp,ni,nj, ig1,ig2,ig3,ig4
4098 ier = ezsetopt('INTERP_DEGREE','LINEAR')
4099 ier = ezsetopt('EXTRAP_DEGREE','ABORT')
4100 gdmg = ezqkdef(ni,nj,grtyp,ig1,ig2,ig3,ig4,iungeo)
4101 ! GL
4102 IREC = FSTINF(IUNGEO,NI,NJ,NK,-1,' ',-1,-1,-1,' ','GL')
4103 if (IREC < 0) then
4104 call utl_abort ('bgckMicrowave_mod: ERREUR: LE CHAMP GLACE DE MER EST INEXISTANT')
4105 end if
4106
4107 if(allocated(GL)) deallocate(GL)
4108 allocate ( GL(NI*NJ), STAT=ier)
4109 IER = FSTLIR(GL,IUNGEO,NI,NJ,NK,-1,' ',-1,-1,-1, ' ','GL')
4110
4111 IER = FSTPRM(IREC, IDUM1, IDUM2, IDUM3, IDUM4, &
4112 IDUM5, IDUM6, IDUM7, IDUM8, IDUM9, IDUM10, &
4113 IDUM11, TYPXX, NOMVXX, ETIKXX, GRTYP, IG1, &
4114 IG2, IG3, IG4, IDUM12, IDUM13, IDUM14, &
4115 IDUM15, IDUM16, IDUM17, IDUM18)
4116 write (*,*) ' GRILLE GL : ',grtyp,ni,nj, ig1,ig2,ig3,ig4
4117 ier = ezsetopt('INTERP_DEGREE','LINEAR')
4118 ier = ezsetopt('EXTRAP_DEGREE','ABORT')
4119 gdgl = ezqkdef(ni,nj,grtyp,ig1,ig2,ig3,ig4,iungeo)
4120 else
4121 gdgl = -1
4122 gdmg = -1
4123 end if
4124 IER = FSTFRM(IUNGEO)
4125 IER = FCLOS(IUNGEO)
4126 ifFirstCall = .False.
4127 end if ! if (ifFirstCall)
4128
4129 ! STEP 3: Interpolation de la glace et le champ terre/mer du modele aux pts TOVS.
4130 ! N.B.: on examine ces champs sur une boite centree sur chaque obs.
4131 boxPointNum = MXLAT*MXLON
4132 if(allocated(ZLATBOX)) deallocate(ZLATBOX)
4133 allocate (ZLATBOX(boxPointNum) , STAT=ier)
4134 if(allocated(ZLONBOX)) deallocate(ZLONBOX)
4135 allocate (ZLONBOX(boxPointNum) , STAT=ier)
4136 if(allocated(MTINTBOX)) deallocate(MTINTBOX)
4137 allocate (MTINTBOX(boxPointNum) , STAT=ier)
4138 if(allocated(GLINTBOX)) deallocate(GLINTBOX)
4139 allocate (GLINTBOX(boxPointNum) , STAT=ier)
4140 if(allocated(MGINTBOX)) deallocate(MGINTBOX)
4141 allocate (MGINTBOX(boxPointNum) , STAT=ier)
4142 NLAT = (MXLAT-1) / 2
4143 NLON = (MXLON-1) / 2
4144 boxPointIndex = 0
4145 do latIndex = -NLAT, NLAT
4146 XLAT = obsLat + latIndex*DLAT
4147 XLAT = MAX(-90.0,MIN(90.0,XLAT))
4148 do lonIndex = -NLON, NLON
4149 boxPointIndex = boxPointIndex + 1
4150 XLON = obsLon + lonIndex*DLON
4151 if ( XLON < -180. ) XLON = XLON + 360.
4152 if ( XLON > 180. ) XLON = XLON - 360.
4153 if ( XLON < 0. ) XLON = XLON + 360.
4154 ZLATBOX(boxPointIndex) = XLAT
4155 ZLONBOX(boxPointIndex) = XLON
4156 end do
4157 end do
4158 ier = ezsetopt('INTERP_DEGREE','LINEAR')
4159 ier = gdllsval(gdmt,mtintbox,mt,ZLATBOX,ZLONBOX,boxPointNum)
4160 if (ier < 0) then
4161 call utl_abort ('bgckMicrowave_mod: ERROR in the interpolation of MT')
4162 end if
4163 if(readGlaceMask) then
4164 ier = gdllsval(gdmg,mgintbox,mg,ZLATBOX,ZLONBOX,boxPointNum)
4165 if (ier < 0) then
4166 call utl_abort ('bgckMicrowave_mod: ERROR in the interpolation of MG')
4167 end if
4168 ier = gdllsval(gdgl,glintbox,gl,ZLATBOX,ZLONBOX,boxPointNum)
4169 if (ier < 0) then
4170 call utl_abort ('bgckMicrowave_mod: ERROR in the interpolation of GL')
4171 end if
4172 end if
4173
4174 if (mwbg_debug) then
4175 print *, ' ------------------ '
4176 print *, ' obsLat,obsLon = ', obsLat, obsLon
4177 print *, ' '
4178 print *, ' ZLATBOX = '
4179 print *, (ZLATBOX(boxPointIndex),boxPointIndex=1,boxPointNum)
4180 print *, ' ZLONBOX = '
4181 print *, (ZLONBOX(boxPointIndex),boxPointIndex=1,boxPointNum)
4182 print *, ' MGINTBOX = '
4183 print *, (MGINTBOX(boxPointIndex),boxPointIndex=1,boxPointNum)
4184 print *, ' MTINTBOX = '
4185 print *, (MTINTBOX(boxPointIndex),boxPointIndex=1,boxPointNum)
4186 print *, ' GLINTBOX = '
4187 print *, (GLINTBOX(boxPointIndex),boxPointIndex=1,boxPointNum)
4188 end if
4189 modelInterpLandFrac = 0.0d0
4190 modelInterpTerrain = 0.0d0
4191 modelInterpSeaIce = 0.0d0
4192 do boxPointIndex = 1, MXLAT*MXLON
4193 modelInterpTerrain = MAX(modelInterpTerrain, &
4194 real(MTINTBOX(boxPointIndex)/TOPOFACT,8))
4195 if (readGlaceMask) then
4196 modelInterpLandFrac = MAX(modelInterpLandFrac,real(MGINTBOX(boxPointIndex),8))
4197 modelInterpSeaIce = MAX(modelInterpSeaIce,real(GLINTBOX(boxPointIndex),8))
4198 end if
4199 end do
4200 if (mwbg_debug) then
4201 print *, ' modelInterpLandFrac = ', modelInterpLandFrac
4202 print *, ' modelInterpTerrain = ', modelInterpTerrain
4203 print *, ' modelInterpSeaIce = ', modelInterpSeaIce
4204 end if
4205 end subroutine mwbg_readGeophysicFieldsAndInterpolate
4206
4207 !--------------------------------------------------------------------------
4208 ! atmsMwhs2landIceMask
4209 !--------------------------------------------------------------------------
4210 subroutine atmsMwhs2landIceMask(calcLandQualifierIndice, calcTerrainTypeIndice, waterobs, ilsmOpt, &
4211 headerIndex, obsSpaceData)
4212 !
4213 !:Purpose: This routine sets waterobs array by performing a land/ice proximity check using
4214 ! using analysis MG and LG (or GL) fields used by the model which produces the trial field.
4215 ! The purpose of this check is to remove obs that reside close to coasts or ice,
4216 ! and so whose TBs may be contaminated.
4217 ! The GEM Global (glbhyb2) analysis contains MG and LG fields (on different grids).
4218 ! Adapted from: land_ice_mask_ssmis.ftn90 of mwbg_ssmis (D. Anselmo, S. Macpherson)
4219 !
4220 ! NOTE: The 0.1 deg binary ice field check from land_ice_mask_ssmis.ftn90
4221 ! was removed. The land/sea qualifier (calcLandQualifierIndice) and terrain type (calcTerrainTypeIndice)
4222 ! are modified to indicate proximity to land and sea-ice but are NOT changed in output BURP file.
4223 !
4224 ! In the application of this check, a 5x5 mesh, with spacing defined by rlat_km and
4225 ! rlon_km, is positioned with its center over an obs pt (2 grid pts on either side
4226 ! of the obs pt; size of mesh is equal to 4*rlat_km x 4*rlon_km). The values of MG
4227 ! and LG are evaluated at the grid points of this mesh. For ilsmOpt=1 (or 3), the maximum
4228 ! (or average) determines whether the obs pt is too close to ice or land to be retained.
4229 ! For ilsmOpt=2, the value at the central mesh point is used.
4230 ! **NOTE: the threshold value for MG has a very strong effect on the distance
4231 ! from land that is permitted for an obs to be retained
4232 !
4233 !
4234 ! Maximum FOV x---x---x---x---x ^
4235 ! = 75km x 75km | | | | | |
4236 ! for Meso-sphere CHs x---x---x---x---x |
4237 ! = 74km x 47km | | | | | |
4238 ! for 19 GHz x---x---o---x---x | = 4*rlat_km
4239 ! | | | | | | = 4*40 km
4240 ! ^ x---x---x---x---x | = 160 km = 80 km north & south
4241 ! rlat_km | | | | | | |
4242 ! v x---x---x---x---x v
4243 ! <--->
4244 ! rlon_km
4245 !
4246 ! <--------------->
4247 ! = 4*rlon_km
4248 ! = 4*40 km
4249 ! = 160 km = 80 km east & west
4250 !
4251 !
4252 ! MG value = 1.0 ==> LAND MG value = 0.0 ==> OCEAN
4253 ! LG value = 1.0 ==> ICE LG value = 0.0 ==> NO ICE
4254 !
4255 ! Variable Definitions
4256 ! --------------------
4257 ! - mxlat : internal- number of grid pts in lat. direction for mesh
4258 ! - mxlon : internal- number of grid pts in lon. direction for mesh
4259 ! - rlat_km : internal- spacing desired between mesh grid points in km
4260 ! along lat. direction
4261 ! - rlon_km : internal- spacing desired between mesh grid points in km
4262 ! along lon. direction
4263 ! - dlat : internal- spacing between mesh grid points along lon. direction
4264 ! in degrees computed from rlat_km
4265 ! - dlon : internal- spacing between mesh grid points along lon. direction
4266 ! in degrees computed from rlon_km
4267 ! - rkm_per_deg : internal- distance in km per degree
4268 ! = Earth radius * PI/180.0
4269 ! = 6371.01 km * PI/180.0
4270 ! = 111.195 km
4271 ! - nlat,nlon : internal- used to define the lat/lon of the grid pts of mesh
4272 ! - zlatbox : internal- lat values at all grid pts of mesh for all obs pts
4273 ! - zlonbox : internal- lon values at all grid pts of mesh for all obs pts
4274 ! - latmesh : internal- lat values at all grid pts of mesh for 1 obs pt
4275 ! - lonmesh : internal- lon values at all grid pts of mesh for 1 obs pt
4276 ! - mgintob : internal- interpolated MG values at all grid pts of mesh for 1 obs pt
4277 ! - lgintob : internal- interpolated LG values at all grid pts of mesh for 1 obs pt
4278 ! - mgintrp : internal- max. interpolated MG value on mesh for all obs pts
4279 ! - lgintrp : internal- max. interpolated LG value on mesh for all obs pts
4280 ! - MGthresh : internal- maximum allowable land fraction for obs to be kept
4281 ! - LGthresh : internal- maximum allowable ice fraction for obs to be kept
4282 !
4283 implicit none
4284
4285 ! Arguments::
4286 integer, intent(in) :: ilsmOpt ! option for "interpolated" value of MG, LG at each location, 1 = use MAX value taken from all mesh grid points, 2 = use CENTRAL mesh point value (value at obs location), 3 = use AVG value of all mesh grid points
4287 integer, intent(out) :: calcLandQualifierIndice! land/sea qualifier (0 = land, 1 = sea)
4288 integer, intent(out) :: calcTerrainTypeIndice ! terrain-type (-1 land/open water, 0 = ice)
4289 logical, intent(out) :: waterobs ! if obs over open water, far from coast/ice
4290 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
4291 integer, intent(in) :: headerIndex ! current header Index
4292
4293 ! Locals:
4294 logical, save :: firstCall = .true.
4295 integer, parameter :: mxlat = 5, mxlon = 5
4296 integer :: iungeo, ier, key
4297 integer, save :: ni, nj, nk, nilg, njlg
4298 integer, save :: ig1, ig2, ig3, ig4, ig1lg, ig2lg, ig3lg, ig4lg
4299 integer :: idum4, idum5, idum6, idum7, idum8, idum9, idum10, idum11
4300 integer :: idum12, idum13, idum14, idum15, idum16, idum17, idum18
4301 integer :: indx, ii, jj, nlat, nlon
4302 integer, parameter :: ii_obsloc = ((mxlat * mxlon) / 2) + 1 ! 1D-index of central mesh-point (obs location)
4303 real(4), parameter :: pi = 3.141592654
4304 real(4), parameter :: MGthresh = 0.01, LGthresh = 0.01
4305 real(4), parameter :: rlat_km = 40.0, rlon_km = 40.0
4306 real(4), parameter :: rkm_per_deg = 111.195
4307 real(4) :: xlat, xlatrad, xlon, rii, rjj
4308 real(4) :: dlat, dlon, obsLat, obsLon
4309 character(len=12) :: etikxx
4310 character(len=4) :: nomvxx
4311 character(len=2) :: typxx
4312 character(len=1), save :: grtyp, grtyplg
4313 logical :: llg
4314 real(4), allocatable, save :: mg(:),lg(:)
4315 real(4), allocatable :: latmesh(:), lonmesh(:)
4316 real(4), allocatable :: mgintob(:), lgintob(:)
4317 real(4), allocatable :: zlatbox(:), zlonbox(:)
4318 real(4) :: mgintrp, lgintrp
4319 ! RMNLIB interpolating functions:
4320 integer :: ezsetopt, ezqkdef
4321 integer :: gdllsval, gdid, gdidlg
4322 ! Define FORTRAN FST functions:
4323 integer, external :: fstinf, fstprm, fstlir, fnom, fclos
4324 integer, external :: fstouv, fstfrm
4325 integer :: idum1, idum2, idum3
4326
4327 obsLat = obs_headElem_r(obsSpaceData, OBS_LAT, headerIndex)
4328 obsLon = obs_headElem_r(obsSpaceData, OBS_LON, headerIndex)
4329
4330 ! Convert lat/lon to degrees
4331 obsLon = obsLon * MPC_DEGREES_PER_RADIAN_R8
4332 if (obsLon > 180.) obsLon = obsLon - 360.
4333 obsLat = obsLat * MPC_DEGREES_PER_RADIAN_R8
4334
4335 ! Allocate space for arrays holding values on mesh grid pts.
4336 allocate(latmesh(mxlat*mxlon))
4337 allocate(lonmesh(mxlat*mxlon))
4338 allocate(mgintob(mxlat*mxlon))
4339 allocate(lgintob(mxlat*mxlon))
4340 allocate(zlatbox(mxlat*mxlon))
4341 allocate(zlonbox(mxlat*mxlon))
4342 latmesh(:) = 0.0
4343 lonmesh(:) = 0.0
4344 mgintob(:) = 0.0
4345 lgintob(:) = 0.0
4346 zlatbox(:) = 0.0
4347 zlonbox(:) = 0.0
4348
4349 ! Open FST file.
4350 iungeo = 0
4351 ier = fnom( iungeo,fileMgLg,'STD+RND+R/O',0 )
4352 ier = fstouv( iungeo,'RND' )
4353
4354 if (firstCall) then
4355 firstCall = .false.
4356
4357 ! Read MG field.
4358 key = fstinf(iungeo,ni,nj,nk,-1,' ',-1,-1,-1,' ' ,'MG')
4359 if ( key < 0 ) then
4360 call utl_abort('atmsMwhs2landIceMask: The MG field is MISSING')
4361 end if
4362
4363 call utl_reAllocate(mg, ni*nj)
4364
4365 ier = fstlir(mg,iungeo,ni,nj,nk,-1,' ',-1,-1,-1,' ','MG')
4366
4367 ier = fstprm(key,idum1,idum2,idum3,idum4,idum5,idum6,idum7,idum8, &
4368 idum9,idum10,idum11,typxx,nomvxx,etikxx,grtyp,ig1,ig2, &
4369 ig3,ig4,idum12,idum13,idum14,idum15,idum16,idum17, &
4370 idum18)
4371
4372 ! Read LG field. Use GL field as backup.
4373 ! **CAUTION**: Discontinuities in GL field may cause interpolation problems! LG field is preferable.
4374 llg = .false.
4375 key = fstinf(iungeo,nilg,njlg,nk,-1,' ',-1,-1,-1,' ' ,'LG')
4376 if ( key < 0 ) then
4377 key = fstinf(iungeo,nilg,njlg,nk,-1,' ',-1,-1,-1,' ' ,'GL')
4378 if ( key < 0 ) then
4379 call utl_abort('atmsMwhs2landIceMask: The LG or GL field is MISSING')
4380 end if
4381 else
4382 llg = .true.
4383 end if
4384
4385 call utl_reAllocate(lg, nilg*njlg)
4386
4387 if ( llg ) then
4388 ier = fstlir(lg,iungeo,nilg,njlg,nk,-1,' ',-1,-1,-1,' ','LG')
4389 else
4390 ier = fstlir(lg,iungeo,nilg,njlg,nk,-1,' ',-1,-1,-1,' ','GL')
4391 end if
4392
4393 ier = fstprm(key,idum1,idum2,idum3,idum4,idum5,idum6,idum7,idum8, &
4394 idum9,idum10,idum11,typxx,nomvxx,etikxx,grtyplg,ig1lg,ig2lg, &
4395 ig3lg,ig4lg,idum12,idum13,idum14,idum15,idum16,idum17, &
4396 idum18)
4397
4398 end if ! firstCall
4399
4400 ! For each obs pt, define a grid of artificial pts surrounding it.
4401 nlat = ( mxlat - 1 ) / 2
4402 nlon = ( mxlon - 1 ) / 2
4403
4404 dlat = rlat_km / rkm_per_deg
4405 indx = 0
4406
4407 do ii = -nlat, nlat
4408 rii = float(ii)
4409 xlat = obsLat + rii*dlat
4410 xlat = max( -90.0, min(90.0,xlat) )
4411 xlatrad = xlat * pi / 180.0
4412
4413 do jj = -nlon, nlon
4414 dlon = rlon_km / ( rkm_per_deg*cos(xlatrad) )
4415 rjj = float(jj)
4416 indx = indx + 1
4417 xlon = obsLon + rjj*dlon
4418 if ( xlon < -180. ) xlon = xlon + 360.
4419 if ( xlon > 180. ) xlon = xlon - 360.
4420 if ( xlon < 0. ) xlon = xlon + 360.
4421 zlatbox(indx) = xlat
4422 zlonbox(indx) = xlon
4423 end do
4424
4425 end do
4426
4427 ! Interpolate values from MG and LG field to grid pts of mesh centred over each obs pt.
4428 ! Determine for each obs pt, the max interpolated MG and LG value within the box
4429 ! surrounding it.
4430 ier = ezsetopt('INTERP_DEGREE','LINEAR')
4431 gdid = ezqkdef(ni,nj,grtyp,ig1,ig2,ig3,ig4,iungeo)
4432 gdidlg = ezqkdef(nilg,njlg,grtyplg,ig1lg,ig2lg,ig3lg,ig4lg,iungeo)
4433
4434 mgintrp = 0.0
4435 lgintrp = 0.0
4436
4437 latmesh = zlatbox(:)
4438 lonmesh = zlonbox(:)
4439
4440 ier = gdllsval(gdid,mgintob,mg,latmesh,lonmesh,mxlat*mxlon)
4441 ier = gdllsval(gdidlg,lgintob,lg,latmesh,lonmesh,mxlat*mxlon)
4442
4443 if ( ilsmOpt == 1 ) then
4444 mgintrp = maxval(mgintob(:))
4445 lgintrp = maxval(lgintob(:))
4446 elseif ( ilsmOpt == 2) then
4447 mgintrp = mgintob(ii_obsloc)
4448 lgintrp = lgintob(ii_obsloc)
4449 else
4450 mgintrp = sum(mgintob(:))/real((mxlat*mxlon))
4451 lgintrp = sum(lgintob(:))/real((mxlat*mxlon))
4452 end if
4453
4454 ! Initialize all obs as being over land and free of ice or snow.
4455 ! Determine which obs are over open water.
4456 waterobs = .false. ! not over open water
4457 calcTerrainTypeIndice = -1 ! no ice (reset terain type)
4458 calcLandQualifierIndice = 0 ! land (reset land/sea qualifier)
4459
4460 if ( mgintrp < MGthresh ) calcLandQualifierIndice = 1 ! ocean point away from coast
4461 if ( lgintrp >= LGthresh .and. calcLandQualifierIndice == 1 ) calcTerrainTypeIndice = 0 ! sea-ice affected point
4462 if ( lgintrp < LGthresh .and. calcLandQualifierIndice == 1 ) then
4463 waterobs = .true. ! water point not in close proximity to land or sea-ice
4464 end if
4465
4466 ier = fstfrm(iungeo)
4467 ier = fclos(iungeo)
4468
4469 end subroutine atmsMwhs2landIceMask
4470
4471 !--------------------------------------------------------------------------
4472 ! mwbg_computeMwhs2SurfaceType
4473 !--------------------------------------------------------------------------
4474 subroutine mwbg_computeMwhs2SurfaceType(obsSpaceData)
4475 !
4476 !:Purpose: Compute surface type element and update obsSpaceData.
4477 !
4478 implicit none
4479
4480 ! Arguments:
4481 type(struct_obs), intent(inout) :: obsSpaceData ! ObsSpaceData object
4482
4483 ! Locals:
4484 integer, parameter :: ilsmOpt = 2 ! OPTION for values of MG (land/sea mask) and LG (ice)
4485 ! at each observation point using values on 5x5 mesh
4486 ! centered at each point.
4487 ! ilsmOpt = 1 --> use MAX value from all 25 mesh points
4488 ! ilsmOpt = 2 --> use value at central mesh point (obs location)
4489 ! ilsmOpt = 3 --> use AVG value from all 25 mesh points
4490 integer :: calcLandQualifierIndice, calcTerrainTypeIndice, codtyp, headerIndex
4491 logical :: waterobs, mwhs2DataPresent
4492
4493 write(*,*) 'ssbg_computeMwhs2SurfaceType: Starting'
4494
4495 mwhs2DataPresent = .false.
4496 call obs_set_current_header_list(obsSpaceData,'TO')
4497
4498 HEADER0: do
4499 headerIndex = obs_getHeaderIndex(obsSpaceData)
4500 if (headerIndex < 0) exit HEADER0
4501 codtyp = obs_headElem_i(obsSpaceData, OBS_ITY, headerIndex)
4502 if ( tvs_isIdBurpInst(codtyp,'mwhs2') ) then
4503 mwhs2DataPresent = .true.
4504 exit HEADER0
4505 end if
4506 end do HEADER0
4507
4508 if ( .not. mwhs2DataPresent ) then
4509 write(*,*) 'WARNING: WILL NOT RUN ssbg_computeMwhs2SurfaceType since no MWHS2 DATA is found'
4510 return
4511 end if
4512
4513 call mwbg_init()
4514
4515 if ( .not. modLSQ ) then
4516 write(*,*) 'WARNING: WILL NOT RUN ssbg_computeMwhs2SurfaceType since MODLSQ is not activated'
4517 return
4518 end if
4519
4520 write(*,*) 'MWHS2 data found and modLSQ option activated!'
4521 write(*,*) '--> Output file will contain recomputed values for land/sea qualifier and terrain type based on LG/MG.'
4522
4523 call obs_set_current_header_list(obsSpaceData,'TO')
4524 HEADER1: do
4525 headerIndex = obs_getHeaderIndex(obsSpaceData)
4526 if (headerIndex < 0) exit HEADER1
4527
4528 call atmsMwhs2landIceMask(calcLandQualifierIndice, calcTerrainTypeIndice, waterobs, ilsmOpt, &
4529 headerIndex, obsSpaceData)
4530
4531 call obs_headSet_i(obsSpaceData, OBS_STYP, headerIndex, calcLandQualifierIndice)
4532 call obs_headSet_i(obsSpaceData, OBS_TTYP, headerIndex, calcTerrainTypeIndice)
4533
4534 end do HEADER1
4535
4536 write(*,*) 'ssbg_computeMwhs2SurfaceType: Finished'
4537
4538 end subroutine mwbg_computeMwhs2SurfaceType
4539
4540 !--------------------------------------------------------------------------
4541 ! mwbg_grossValueCheck
4542 !--------------------------------------------------------------------------
4543
4544 subroutine mwbg_grossValueCheck(ztbThresholdMin, ztbThresholdMax, grossrej, headerIndex, sensorIndex, obsSpaceData)
4545 !
4546 !:Purpose: Check Tbs for values that are missing or outside physical limits.
4547 ! REJECT ALL CHANNELS OF ONE IS FOUND TO BE BAD.
4548 !
4549 implicit none
4550
4551 ! Arguments:
4552 real(8), intent(in) :: ztbThresholdMin ! ztb threshold for rejection
4553 real(8), intent(in) :: ztbThresholdMax ! ztb threshold for rejection
4554 logical, intent(out) :: grossrej ! logical array defining which obs are to be rejected
4555 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
4556 integer, intent(in) :: headerIndex ! current header Index
4557 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
4558
4559 ! Locals:
4560 integer :: actualNumChannel, bodyIndex, bodyIndexBeg, bodyIndexEnd
4561 integer :: obsChanNum, obsChanNumWithOffset
4562 real(8) :: obsTb, obsTbBiasCorr
4563 real(8), allocatable :: ztb(:) ! biased or unbiased radiances
4564
4565 actualNumChannel = tvs_coefs(sensorIndex)%coef%fmv_ori_nchn
4566 allocate(ztb(actualNumChannel))
4567 ztb(:) = mwbg_realMissing
4568
4569 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
4570 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
4571
4572 grossrej = .true.
4573 if ( mwbg_useUnbiasedObsForClw ) then
4574 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
4575 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
4576 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
4577 obsTb = obs_bodyElem_r(obsSpaceData, OBS_VAR, bodyIndex)
4578
4579 ztb(obsChanNum) = obsTb
4580 end do BODY
4581 else
4582 BODY2: do bodyIndex = bodyIndexBeg, bodyIndexEnd
4583 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
4584 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
4585 obsTb = obs_bodyElem_r(obsSpaceData, OBS_VAR, bodyIndex)
4586 obsTbBiasCorr = obs_bodyElem_r(obsSpaceData, OBS_BCOR, bodyIndex)
4587
4588 if (obsTbBiasCorr /= mwbg_realMissing) then
4589 ztb(obsChanNum) = obsTb - obsTbBiasCorr
4590 else
4591 ztb(obsChanNum) = obsTb
4592 end if
4593 end do BODY2
4594 end if
4595
4596 if (all(ztb(:) > ztbThresholdMin) .and. all(ztb(:) < ztbThresholdMax)) grossrej = .false.
4597
4598 end subroutine mwbg_grossValueCheck
4599
4600 !--------------------------------------------------------------------------
4601 ! mwbg_firstQcCheckAtms
4602 !--------------------------------------------------------------------------
4603 subroutine mwbg_firstQcCheckAtms(qcRejectLogic, grossrej, calcLandQualifierIndice, calcTerrainTypeIndice, &
4604 reportHasMissingTb, headerIndex, sensorIndex, obsSpaceData)
4605 !
4606 !:Purpose: This routine performs basic quality control checks on the data. It sets array
4607 ! qcRejectLogic(actualNumChannel) elements to .true. to flag data with failed checks.
4608 !
4609 ! The 6 QC checks are:
4610 ! - 1) Invalid land/sea qualifier or terrain type,
4611 ! - 2) Invalid field of view number,
4612 ! - 3) Satellite zenith angle missing or out of range, (> 75 deg),
4613 ! - 4) lat,lon check (lat,lon = O(-90.), 0(-180.))
4614 ! - 5) Change in (computed) calcLandQualifierIndice,calcTerrainTypeIndice from (input)
4615 ! - 6) ATMS quality flag check (qual. flag elements 33078,33079,33080,33081)
4616 !
4617 ! landQualifierIndice,terrainTypeIndice (from MG,LG fields).
4618 !
4619 ! landQualifierIndice= 0,1 (from hi-res land/sea mask interpolated to obs point [CMDA])
4620 !
4621 ! terrainTypeIndice=-1,0 (from hi-res ice analysis interpolated to obs point [CMDA])
4622 !
4623 ! calcLandQualifierIndice= 0,1 (from max interp MG (0.0 to 1.0) in box surrounding obs point)
4624 !
4625 ! calcTerrainTypeIndice=-1,0 (from max interp LG (0.0 to 1.0) in box surrounding obs point)
4626 !
4627 ! In most cases, qcRejectLogic(actualNumChannel) is set to .true. for all channels at point ii
4628 ! if the check detects a problem. In addition, Tb (obsTb) is set to missing_value
4629 ! for checks 3 and 4 fails.
4630 !
4631 implicit none
4632
4633 ! Arguments:
4634 integer, intent(in) :: calcLandQualifierIndice ! land/sea qualifier (0 = land, 1 = sea)
4635 integer, intent(in) :: calcTerrainTypeIndice ! terrain-type (-1 land/open water, 0 = ice)
4636 logical, intent(in) :: grossrej ! .true. if 1 or more Tb fail gross error check
4637 logical, intent(out) :: reportHasMissingTb ! .true. if Tb(obsTb) are set to missing_value
4638 logical, allocatable, intent(out) :: qcRejectLogic(:) ! qcRejectLogic = .false. on input
4639 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
4640 integer, intent(in) :: headerIndex ! current header Index
4641 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
4642
4643 ! Locals:
4644 integer :: indx1, icount, landQualifierIndice, terrainTypeIndice, satScanPosition, actualNumChannel
4645 integer :: bodyIndex, bodyIndexBeg, bodyIndexEnd, obsChanNum, obsChanNumWithOffset, channelIndex
4646 integer :: obsQcFlag1(3), obsQcFlag2
4647 integer, allocatable :: obsChannels(:)
4648 real(8) :: obsLat, obsLon, satZenithAngle, obsTb
4649 logical :: fail, fail1, fail2
4650
4651 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
4652 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
4653
4654 reportHasMissingTb = .false.
4655 actualNumChannel = tvs_coefs(sensorIndex)%coef%fmv_ori_nchn
4656 allocate(qcRejectLogic(actualNumChannel))
4657 qcRejectLogic(:) = .false. ! Flag for preliminary QC checks
4658
4659 landQualifierIndice = obs_headElem_i(obsSpaceData, OBS_STYP, headerIndex)
4660 satZenithAngle = obs_headElem_r(obsSpaceData, OBS_SZA, headerIndex)
4661 satScanPosition = obs_headElem_i(obsSpaceData, OBS_FOV , headerIndex)
4662
4663 ! lat/lon
4664 obsLat = obs_headElem_r(obsSpaceData, OBS_LAT, headerIndex)
4665 obsLon = obs_headElem_r(obsSpaceData, OBS_LON, headerIndex)
4666
4667 ! Convert lat/lon to degrees
4668 obsLon = obsLon * MPC_DEGREES_PER_RADIAN_R8
4669 if (obsLon > 180.0d0) obsLon = obsLon - 360.0d0
4670 obsLat = obsLat * MPC_DEGREES_PER_RADIAN_R8
4671
4672 ! terrain type
4673 terrainTypeIndice = obs_headElem_i(obsSpaceData, OBS_TTYP, headerIndex)
4674
4675 ! If terrain type is missing, set it to -1 for the QC programs
4676 if (terrainTypeIndice == 99) terrainTypeIndice = mwbg_intMissing
4677
4678 obsQcFlag1(:) = 0
4679 if (instName == 'ATMS') then
4680 obsQcFlag1(1) = obs_headElem_i(obsSpaceData, OBS_AQF1, headerIndex)
4681 obsQcFlag1(2) = obs_headElem_i(obsSpaceData, OBS_AQF2, headerIndex)
4682 obsQcFlag1(3) = obs_headElem_i(obsSpaceData, OBS_AQF3, headerIndex)
4683 end if
4684
4685 allocate(obsChannels(actualNumChannel))
4686 do channelIndex = 1, actualNumChannel
4687 obsChannels(channelIndex) = channelIndex + tvs_channelOffset(sensorIndex)
4688 end do
4689
4690 ! Global rejection checks
4691
4692 ! Check if number of channels is correct
4693 !if ( actualNumChannel /= mwbg_maxNumChan ) then
4694 ! write(*,*) 'WARNING: Number of channels (',actualNumChannel, ') is not equal to mwbg_maxNumChan (', mwbg_maxNumChan,')'
4695 ! write(*,*) ' All data flagged as bad and returning to calling routine!'
4696 ! qcRejectLogic(:) = .true. ! flag all data in report as bad
4697 ! return
4698 !end if
4699
4700 ! Check for errors in channel numbers (should be 1-22 for each location ii)
4701 ! For this, tvs_channelOffset(sensorIndex)=0 and total number of channels
4702 ! in obsSpaceData should be equal to 22
4703 fail = .false.
4704 if (tvs_channelOffset(sensorIndex) /= 0 .or. &
4705 obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) /= actualNumChannel) then
4706 fail = .true.
4707 end if
4708 if ( fail ) then
4709 write(*,*) 'WARNING: Bad channel number(s) detected!'
4710 write(*,*) ' All data flagged as bad and returning to calling routine!'
4711 write(*,*) ' obsChannels(actualNumChannel) array = ', obsChannels(:)
4712 qcRejectLogic(:) = .true. ! flag all data in report as bad
4713 return
4714 end if
4715
4716 ! 1) invalid land/sea qualifier or terrain type
4717 ! landQualifierIndice = 0 (land), 1 (sea)
4718 ! terrainTypeIndice = 0 (sea-ice), -1 otherwise
4719 ! calcLandQualifierIndice = 1 (sea, away from land/coast [MG]), 0 otherwise
4720 ! calcTerrainTypeIndice = 0 (over or near analyzed sea-ice [LG]), -1 otherwise
4721 fail = .false.
4722 if ( landQualifierIndice < 0 .or. landQualifierIndice > 2 ) fail = .true.
4723 if ( terrainTypeIndice < -1 .or. terrainTypeIndice > 1 ) fail = .true.
4724 if ( fail ) then
4725 write(*,*) 'WARNING: Invalid land/sea qualifier or terrain type!'
4726 write(*,*) ' landQualifierIndice, terrainTypeIndice, (lat, lon) = ', landQualifierIndice, terrainTypeIndice, '(',obsLat, obsLon,')'
4727 end if
4728
4729 if ( landQualifierIndice == 0 .and. terrainTypeIndice == 0 ) then
4730 fail = .true.
4731 write(*,*) 'WARNING: Sea ice point (terrainTypeIndice=0) at land point (landQualifierIndice=0)!'
4732 write(*,*) ' lat, lon = ', obsLat, obsLon
4733 end if
4734 if ( fail ) qcRejectLogic(:) = .true.
4735
4736 fail = .false.
4737 if ( calcLandQualifierIndice < 0 .or. calcLandQualifierIndice > 2 ) fail = .true.
4738 if ( calcTerrainTypeIndice < -1 .or. calcTerrainTypeIndice > 1 ) fail = .true.
4739 if ( fail ) then
4740 write(*,*) 'WARNING: Invalid model-based (MG/LG) land/sea qualifier or terrain type!'
4741 write(*,*) ' calcLandQualifierIndice, calcTerrainTypeIndice, (lat, lon) = ', &
4742 calcLandQualifierIndice, calcTerrainTypeIndice, '(',obsLat, obsLon,')'
4743 end if
4744 if ( fail ) qcRejectLogic(:) = .true.
4745
4746 ! 2) invalid field of view number
4747 fail = .false.
4748 if ( satScanPosition < 1 .or. satScanPosition > mwbg_maxScanAngle ) then
4749 fail = .true.
4750 write(*,*) 'WARNING: Invalid field of view! satScanPosition, lat, lon = ', satScanPosition, obsLat, obsLon
4751 end if
4752 if ( fail ) qcRejectLogic(:) = .true.
4753
4754 ! 3) satellite zenith angle missing or out of range (> 75 deg)
4755 ! If bad zenith, then set Tb (and zenith) = missing value
4756 indx1 = 1
4757 fail = .false.
4758 if ( satZenithAngle > 75.0d0 .or. satZenithAngle < 0.0d0 ) then
4759 fail = .true.
4760 write(*,*) 'WARNING: Bad or missing zenith angle! zenith, lat, lon = ', satZenithAngle, obsLat, obsLon
4761 satZenithAngle = mwbg_realMissing
4762 reportHasMissingTb = .true.
4763 end if
4764 if ( fail ) then
4765 qcRejectLogic(:) = .true.
4766 do bodyIndex = bodyIndexBeg, bodyIndexEnd
4767 obsTb = mwbg_realMissing
4768 call obs_bodySet_r(obsSpaceData, OBS_VAR, bodyIndex, obsTb)
4769 end do
4770 end if
4771
4772 ! 4) Lat,lon check
4773 ! Check for undecoded BURP file integer values of lat,lon = 0,0
4774 ! (usually associated with missing zenith angle and erroneous Tb=330K)
4775
4776 icount = 0
4777 fail = .false.
4778 if ( obsLat == -90.0d0 .and. obsLon == -180.0d0 ) then
4779 fail = .true.
4780 icount = icount + 1
4781 reportHasMissingTb = .true.
4782 end if
4783 if ( fail ) then
4784 qcRejectLogic(:) = .true.
4785 do bodyIndex = bodyIndexBeg, bodyIndexEnd
4786 obsTb = mwbg_realMissing
4787 call obs_bodySet_r(obsSpaceData, OBS_VAR, bodyIndex, obsTb)
4788 end do
4789 end if
4790 if ( icount > 0 ) write(*,*) 'WARNING: Bad lat,lon pair(s) detected. Number of locations = ', icount
4791
4792 icount = 0
4793 fail = .false.
4794 if ( abs(obsLat) > 90.0d0 .or. abs(obsLon) > 180.0d0 ) then
4795 fail = .true.
4796 icount = icount + 1
4797 reportHasMissingTb = .true.
4798 end if
4799 if ( fail ) then
4800 qcRejectLogic(:) = .true.
4801 do bodyIndex = bodyIndexBeg, bodyIndexEnd
4802 obsTb = mwbg_realMissing
4803 call obs_bodySet_r(obsSpaceData, OBS_VAR, bodyIndex, obsTb)
4804 end do
4805 end if
4806 if ( icount > 0 ) write(*,*) 'WARNING: Lat or lon out of range! Number of locations = ', icount
4807
4808 ! 5) Change in land/sea qualifier or terrain-type based on MG,LG fields
4809 icount = 0
4810 fail = .false.
4811 if ( (landQualifierIndice /= calcLandQualifierIndice) .or. &
4812 (terrainTypeIndice /= calcTerrainTypeIndice) ) then
4813 fail = .true.
4814 end if
4815 if ( fail ) icount = icount + 1
4816
4817 ! 6) ATMS quality flag check (qual. flag elements 33078,33079,33080,33081)
4818
4819 ! 33078 Geolocation quality code obsQcFlag1(1) code value = 0-15 (0= OK, 15=misg)
4820 ! 33079 Granule level quality flags obsQcFlag1(2) 16 bit flag (start bit 6(2^5)=32) (misg=2^16-1 = 65535)
4821 ! 33080 Scan level quality flags obsQcFlag1(3) 20 bit flag (start bit 7(2^6)=64) (misg=2^20-1)
4822 ! 33081 Channel data quality flags obsQcFlag2 12 bit flag (start bit 3(2^2)=4) (misg=2^12-1)
4823 !
4824 ! See http://www.wmo.int/pages/prog/www/WMOCodes/WMO306_vI2/2010edition/BUFRver16/BUFR_16_0_0_TableD.pdf
4825
4826 fail1 = .false.
4827 fail = .false.
4828 if ( (obsQcFlag1(1) > 0) .or. (obsQcFlag1(2) >= 32) .or. (obsQcFlag1(3) >= 64) ) then
4829 write(*,*) 'WARNING: INFO BLOCK QC flag(s) indicate problem with data'
4830 write(*,*) ' ele33078 = ',obsQcFlag1(1),' ele33079 = ',obsQcFlag1(2),' ele33080 = ', obsQcFlag1(3)
4831 write(*,*) ' lat, lon = ', obsLat, obsLon
4832 fail1 = .true.
4833 if ( grossrej ) write(*,*) ' NOTE: grossrej is also true for this point!'
4834 end if
4835
4836 do bodyIndex = bodyIndexBeg, bodyIndexEnd
4837 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
4838 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
4839 obsQcFlag2 = obs_bodyElem_i(obsSpaceData, OBS_QCF2, bodyIndex)
4840
4841 fail2 = .false.
4842 if ( obsQcFlag2 >= 4 ) then
4843 !write(*,*) 'WARNING: DATA BLOCK QC flag ele33081 = ', obsQcFlag2
4844 !write(*,*) ' Lat, lon, channel = ', obsLat, obsLon, obsChanNum
4845 fail2 = .true.
4846 fail = .true.
4847 !if ( (.not. fail1) .and. grossrej ) write(*,*) ' NOTE: grossrej is also true for this point!'
4848 end if
4849 if ( fail2 .or. fail1 ) qcRejectLogic(obsChanNum) = .true.
4850 end do
4851 if ( fail ) write(*,*) 'WARNING: DATA BLOCK QC flag ele33081 >= 4 for one or more channels! lat, lon = ', obsLat, obsLon
4852
4853 !write(*,*) 'mwbg_firstQcCheckAtms: Number of data processed and flagged = ', &
4854 ! actualNumChannel, count(qcRejectLogic)
4855
4856 call obs_headSet_r(obsSpaceData, OBS_SZA, headerIndex, satZenithAngle)
4857
4858 end subroutine mwbg_firstQcCheckAtms
4859
4860 !--------------------------------------------------------------------------
4861 ! mwbg_firstQcCheckMwhs2
4862 !--------------------------------------------------------------------------
4863 subroutine mwbg_firstQcCheckMwhs2(qcRejectLogic, calcLandQualifierIndice, calcTerrainTypeIndice, &
4864 reportHasMissingTb, modLSQ, headerIndex, sensorIndex, obsSpaceData)
4865 !
4866 !:Purpose: This routine performs basic quality control checks on the data. It sets array
4867 ! qcRejectLogic(actualNumChannel) elements to .true. to flag data with failed checks. Check 1
4868 ! (for landQualifierIndice,terrainTypeIndice) and check 5 are skipped if modlsqtt=.true.,
4869 ! as the original values will be replaced in output file by calcLandQualifierIndice,calcTerrainTypeIndice.
4870 !
4871 ! The 5 QC checks are:
4872 ! - 1) Invalid land/sea qualifier or terrain type,
4873 ! - 2) Invalid field of view number,
4874 ! - 3) Satellite zenith angle missing or out of range, (> 75 deg),
4875 ! - 4) lat,lon check (lat,lon = O(-90.), 0(-180.))
4876 ! - 5) Change in (computed) calcLandQualifierIndice,calcTerrainTypeIndice
4877 ! from (input) landQualifierIndice,terrainTypeIndice (from MG,LG fields).
4878 !
4879 ! landQualifierIndice= 0,1 (from hi-res land/sea mask interpolated to obs point [CMDA])
4880 !
4881 ! terrainTypeIndice=-1,0 (from hi-res ice analysis interpolated to obs point [CMDA])
4882 !
4883 ! calcLandQualifierIndice= 0,1 (from max interp MG (0.0 to 1.0) in box surrounding obs point)
4884 !
4885 ! calcTerrainTypeIndice=-1,0 (from max interp LG (0.0 to 1.0) in box surrounding obs point)
4886 !
4887 ! In most cases, qcRejectLogic(ii,actualNumChannel) is set to .true. for all channels at point ii
4888 ! if the check detects a problem. In addition, Tb (obsTb) is set to missing_value
4889 ! for checks 3 and 4 fails.
4890 !
4891 implicit none
4892
4893 ! Arguments:
4894 integer, intent(in) :: calcLandQualifierIndice! land/sea qualifier (0 = land, 1 = sea)
4895 integer, intent(in) :: calcTerrainTypeIndice ! terrain-type (-1 land/open water, 0 = ice)
4896 logical, intent(out) :: reportHasMissingTb ! true if Tb(obsTb) are set to missing_value
4897 logical, intent(in) :: modLSQ ! If active, recalculate land/sea qualifier and terrain type based on LG/MG
4898 logical, allocatable, intent(inout) :: qcRejectLogic(:) ! qcRejectLogic = .false. on input
4899 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
4900 integer, intent(in) :: headerIndex ! current header Index
4901 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
4902
4903 ! Locals:
4904 integer :: icount, landQualifierIndice, terrainTypeIndice, satScanPosition, actualNumChannel
4905 integer :: bodyIndex, bodyIndexBeg, bodyIndexEnd, channelIndex
4906 integer, allocatable :: obsChannels(:)
4907 real(8) :: obsLat, obsLon, satZenithAngle
4908 real(8) :: obsTb
4909 logical :: fail
4910
4911 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
4912 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
4913
4914 reportHasMissingTb = .false.
4915 actualNumChannel = tvs_coefs(sensorIndex)%coef%fmv_ori_nchn
4916 allocate(qcRejectLogic(actualNumChannel))
4917 qcRejectLogic(:) = .false. ! Flag for preliminary QC checks
4918
4919 landQualifierIndice = obs_headElem_i(obsSpaceData, OBS_STYP, headerIndex)
4920 satZenithAngle = obs_headElem_r(obsSpaceData, OBS_SZA, headerIndex)
4921 satScanPosition = obs_headElem_i(obsSpaceData, OBS_FOV , headerIndex)
4922
4923 ! lat/lon
4924 obsLat = obs_headElem_r(obsSpaceData, OBS_LAT, headerIndex)
4925 obsLon = obs_headElem_r(obsSpaceData, OBS_LON, headerIndex)
4926
4927 ! Convert lat/lon to degrees
4928 obsLon = obsLon * MPC_DEGREES_PER_RADIAN_R8
4929 if (obsLon > 180.0d0) obsLon = obsLon - 360.0d0
4930 obsLat = obsLat * MPC_DEGREES_PER_RADIAN_R8
4931
4932 ! terrain type
4933 terrainTypeIndice = obs_headElem_i(obsSpaceData, OBS_TTYP, headerIndex)
4934
4935 ! If terrain type is missing, set it to -1 for the QC programs
4936 if (terrainTypeIndice == 99) terrainTypeIndice = mwbg_intMissing
4937
4938 allocate(obsChannels(actualNumChannel))
4939 do channelIndex = 1, actualNumChannel
4940 obsChannels(channelIndex) = channelIndex + tvs_channelOffset(sensorIndex)
4941 end do
4942
4943 ! Global rejection checks
4944
4945 ! Check if number of channels is correct
4946 !if ( actualNumChannel /= mwbg_maxNumChan ) then
4947 ! write(*,*) 'WARNING: Number of channels (',actualNumChannel, ') is not equal to mwbg_maxNumChan (', mwbg_maxNumChan,')'
4948 ! write(*,*) ' All data flagged as bad and returning to calling routine!'
4949 ! qcRejectLogic(:) = .true. ! flag all data in report as bad
4950 ! return
4951 !end if
4952
4953 ! Check for errors in channel numbers (should be 1-15 for each location ii)
4954 ! For this, tvs_channelOffset(sensorIndex)=0 and total number of channels
4955 ! in obsSpaceData should be equal to 15
4956 fail = .false.
4957 if (tvs_channelOffset(sensorIndex) /= 0 .or. &
4958 obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) /= actualNumChannel) then
4959 fail = .true.
4960 end if
4961 if ( fail ) then
4962 write(*,*) 'WARNING: Bad channel number(s) detected!'
4963 write(*,*) ' All data flagged as bad and returning to calling routine!'
4964 write(*,*) ' obsChannels(actualNumChannel) array = ', obsChannels(:)
4965 qcRejectLogic(:) = .true. ! flag all data in report as bad
4966 return
4967 end if
4968
4969 ! 1) invalid land/sea qualifier or terrain type
4970 ! landQualifierIndice = 0 (land), 1 (sea)
4971 ! terrainTypeIndice = 0 (sea-ice), -1 otherwise
4972 ! calcLandQualifierIndice = 1 (sea, away from land/coast [MG]), 0 otherwise
4973 ! calcTerrainTypeIndice = 0 (over or near analyzed sea-ice [LG]), -1 otherwise
4974
4975 ! Checks on landQualifierIndice,terrainTypeIndice are not done if values are to be replaced in output file.
4976
4977 if ( .not. modLSQ ) then
4978 fail = .false.
4979 if ( landQualifierIndice < 0 .or. landQualifierIndice > 2 ) fail = .true.
4980 if ( terrainTypeIndice < -1 .or. terrainTypeIndice > 1 ) fail = .true.
4981 if ( fail ) then
4982 write(*,*) 'WARNING: Invalid land/sea qualifier or terrain type!'
4983 write(*,*) ' landQualifierIndice, terrainTypeIndice, (lat, lon) = ', &
4984 landQualifierIndice, terrainTypeIndice, '(',obsLat, obsLon,')'
4985 end if
4986
4987 if ( landQualifierIndice == 0 .and. terrainTypeIndice == 0 ) then
4988 fail = .true.
4989 write(*,*) 'WARNING: Sea ice point (terrainTypeIndice=0) at land point (landQualifierIndice=0)!'
4990 write(*,*) ' lat, lon = ', obsLat, obsLon
4991 end if
4992 if ( fail ) qcRejectLogic(:) = .true.
4993 end if
4994
4995 fail = .false.
4996 if ( calcLandQualifierIndice < 0 .or. calcLandQualifierIndice > 2 ) fail = .true.
4997 if ( calcTerrainTypeIndice < -1 .or. calcTerrainTypeIndice > 1 ) fail = .true.
4998 if ( fail ) then
4999 write(*,*) 'WARNING: Invalid model-based (MG/LG) land/sea qualifier or terrain type!'
5000 write(*,*) ' calcLandQualifierIndice, calcTerrainTypeIndice, (lat, lon) = ', &
5001 calcLandQualifierIndice, calcTerrainTypeIndice, '(',obsLat, obsLon,')'
5002 end if
5003 if ( fail ) qcRejectLogic(:) = .true.
5004
5005 ! 2) invalid field of view number
5006 fail = .false.
5007 if ( satScanPosition < 1 .or. satScanPosition > mwbg_maxScanAngle ) then
5008 fail = .true.
5009 write(*,*) 'WARNING: Invalid field of view! satScanPosition, lat, lon = ', &
5010 satScanPosition, obsLat, obsLon
5011 end if
5012 if ( fail ) qcRejectLogic(:) = .true.
5013
5014 ! 3) satellite zenith angle missing or out of range (> 75 deg)
5015 ! If bad zenith, then set Tb (and zenith) = missing value
5016 fail = .false.
5017 if ( satZenithAngle > 75.0d0 .or. satZenithAngle < 0.0d0 ) then
5018 fail = .true.
5019 write(*,*) 'WARNING: Bad or missing zenith angle! zenith, lat, lon = ', &
5020 satZenithAngle, obsLat, obsLon
5021 satZenithAngle = mwbg_realMissing
5022 reportHasMissingTb = .true.
5023 end if
5024 if ( fail ) then
5025 qcRejectLogic(:) = .true.
5026 do bodyIndex = bodyIndexBeg, bodyIndexEnd
5027 obsTb = mwbg_realMissing
5028 call obs_bodySet_r(obsSpaceData, OBS_VAR, bodyIndex, obsTb)
5029 end do
5030 end if
5031
5032 ! 4) Lat,lon check
5033 ! Check for undecoded BURP file integer values of lat,lon = 0,0
5034 ! (usually associated with missing zenith angle and erroneous Tb=330K)
5035
5036 icount = 0
5037 fail = .false.
5038 if ( obsLat == -90.0d0 .and. obsLon == -180.0d0 ) then
5039 fail = .true.
5040 icount = icount + 1
5041 reportHasMissingTb = .true.
5042 end if
5043 if ( fail ) then
5044 qcRejectLogic(:) = .true.
5045 do bodyIndex = bodyIndexBeg, bodyIndexEnd
5046 obsTb = mwbg_realMissing
5047 call obs_bodySet_r(obsSpaceData, OBS_VAR, bodyIndex, obsTb)
5048 end do
5049 end if
5050 if ( icount > 0 ) write(*,*) 'WARNING: Bad lat,lon pair(s) detected. Number of locations = ', icount
5051
5052 icount = 0
5053 fail = .false.
5054 if ( abs(obsLat) > 90.0d0 .or. abs(obsLon) > 180.0d0 ) then
5055 fail = .true.
5056 icount = icount + 1
5057 reportHasMissingTb = .true.
5058 end if
5059 if ( fail ) then
5060 qcRejectLogic(:) = .true.
5061 do bodyIndex = bodyIndexBeg, bodyIndexEnd
5062 obsTb = mwbg_realMissing
5063 call obs_bodySet_r(obsSpaceData, OBS_VAR, bodyIndex, obsTb)
5064 end do
5065 end if
5066 if ( icount > 0 ) write(*,*) 'WARNING: Lat or lon out of range! Number of locations = ', icount
5067
5068 ! 5) Change in land/sea qualifier or terrain-type based on MG,LG fields
5069 if ( .not. modLSQ ) then
5070 icount = 0
5071 fail = .false.
5072 if (landQualifierIndice /= calcLandQualifierIndice .or. terrainTypeIndice /= calcTerrainTypeIndice) then
5073 fail = .true.
5074 end if
5075 if ( fail ) then
5076 icount = icount + 1
5077 end if
5078 end if
5079
5080 call obs_headSet_r(obsSpaceData, OBS_SZA, headerIndex, satZenithAngle)
5081
5082 end subroutine mwbg_firstQcCheckMwhs2
5083
5084 !--------------------------------------------------------------------------
5085 ! mwbg_nrlFilterAtms
5086 !--------------------------------------------------------------------------
5087 subroutine mwbg_nrlFilterAtms(calcLandQualifierIndice, calcTerrainTypeIndice, waterobs, grossrej, &
5088 si_ecmwf, si_bg, iNumSeaIce, iRej, SeaIce, &
5089 headerIndex, sensorIndex, obsSpaceData)
5090 !
5091 !:Purpose: Compute the following parameters using 5 ATMS channels:
5092 ! - sea ice,
5093 ! - cloud liquid water from observation (cloudLiquidWaterPathObs),
5094 ! - cloud liquid water from first guess (cloudLiquidWaterPathFG),
5095 ! - 2 scattering indices (si) (ECMWF, Bennartz-Grody)
5096 ! The five channels used are: 23Ghz, 31Ghz, 50Ghz, 89Ghz, and 165Ghz.
5097 !
5098 ! NOTES:
5099 ! - open water points are converted to sea-ice points if sea ice concentration >= 0.55
5100 ! and <calcTerrainTypeIndice> (terrainTypeIndice or terrain type) is changed accordingly
5101 ! - <cloudLiquidWaterPathObs> are missing when out-of-range parameters/Tb detected or grossrej = .true.
5102 ! - <cloudLiquidWaterPathObs> and si only computed over open water away from coasts and sea-ice
5103 ! - <cloudLiquidWaterPathObs> and si = mwbg_realMissing where value cannot be computed.
5104 ! REFERENCES: Ben Ruston, NRL Monterey
5105 ! JCSDA Seminar 12/12/12: Impact of NPP Satellite Assimilation in the U.S. Navy Global Modeling System
5106 !
5107 ! Notes: In the case where an output parameter cannot be calculated, the
5108 ! value of this parameter is set to mwbg_realMissing
5109 !
5110 implicit none
5111
5112 ! Arguments:
5113 integer, intent(out) :: iNumSeaIce ! counter for number open water points with sea-ice detected (from algorithm)
5114 integer, intent(in) :: calcLandQualifierIndice ! land/sea indicator (0=land, 1=ocean)
5115 integer, intent(inout) :: calcTerrainTypeIndice ! terrain type (0=ice, -1 otherwise)
5116 integer, intent(out) :: iRej ! counter for number locations with bad satZenithAngle, obsLat, calcLandQualifierIndice, or with grossrej=true
5117 logical, intent(in) :: grossrej ! .true. if any channel had a gross error from mwbg_grossValueCheck
5118 logical, intent(inout) :: waterobs ! .true. if open water point (away from coasts and sea-ice)
5119 real(8), intent(out) :: si_ecmwf ! ECMWF scattering index from tb89 & tb165
5120 real(8), intent(out) :: si_bg ! Bennartz-Grody scattering index from tb89 & tb165
5121 real(8), intent(out) :: SeaIce ! computed sea-ice fraction from tb23 & tb50
5122 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
5123 integer, intent(in) :: headerIndex ! current header Index
5124 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
5125
5126 ! Locals:
5127 integer :: bodyIndex, bodyIndexBeg, bodyIndexEnd, obsChanNum, obsChanNumWithOffset
5128 integer :: ier, actualNumChannel
5129 real(8) :: ice, tb23, tb23FG, tb31, tb31FG, tb50, tb89, tb165
5130 real(8) :: bcor23, bcor31, bcor50, bcor89, bcor165
5131 real(8) :: aa, deltb, cosz, t23, t23FG, t31, t31FG, t50, t89, t165
5132 real(8) :: cloudLiquidWaterPathObs, cloudLiquidWaterPathFG
5133 real(8) :: obsLat, obsLon, satZenithAngle
5134 real(8), allocatable :: obsTb(:), ompTb(:), obsTbBiasCorr(:)
5135
5136 iNumSeaIce = 0
5137 iRej = 0
5138
5139 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
5140 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
5141 actualNumChannel = obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex)
5142 satZenithAngle = obs_headElem_r(obsSpaceData, OBS_SZA, headerIndex)
5143 if (tvs_coefs(sensorIndex)%coef%fmv_ori_nchn /= actualNumChannel) then
5144 write(*,*) 'mwbg_nrlFilterAtms: tvs_coefs(sensorIndex)%coef%fmv_ori_nchn /= actualNumChannel'
5145 end if
5146
5147 ! lat/lon
5148 obsLat = obs_headElem_r(obsSpaceData, OBS_LAT, headerIndex)
5149 obsLon = obs_headElem_r(obsSpaceData, OBS_LON, headerIndex)
5150
5151 ! Convert lat/lon to degrees
5152 obsLon = obsLon * MPC_DEGREES_PER_RADIAN_R8
5153 if (obsLon > 180.0d0) obsLon = obsLon - 360.0d0
5154 obsLat = obsLat * MPC_DEGREES_PER_RADIAN_R8
5155
5156 if (.not. grossrej) then
5157 allocate(ompTb(actualNumChannel))
5158 allocate(obsTb(actualNumChannel))
5159 allocate(obsTbBiasCorr(actualNumChannel))
5160 ompTb(:) = mwbg_realMissing
5161 obsTb(:) = mwbg_realMissing
5162 obsTbBiasCorr(:) = mwbg_realMissing
5163 do bodyIndex = bodyIndexBeg, bodyIndexEnd
5164 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
5165 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
5166
5167 ompTb(obsChanNum) = obs_bodyElem_r(obsSpaceData, OBS_OMP, bodyIndex)
5168 obsTb(obsChanNum) = obs_bodyElem_r(obsSpaceData, OBS_VAR, bodyIndex)
5169 obsTbBiasCorr(obsChanNum) = obs_bodyElem_r(obsSpaceData, OBS_BCOR, bodyIndex)
5170 end do
5171 end if
5172
5173 ! 1) Initialise parameters:
5174 ice = mwbg_realMissing
5175 cloudLiquidWaterPathObs = mwbg_realMissing
5176 cloudLiquidWaterPathFG = mwbg_realMissing
5177 si_ecmwf = mwbg_realMissing
5178 si_bg = mwbg_realMissing
5179 SeaIce = 0.0d0
5180
5181 tb23 = mwbg_realMissing
5182 tb23FG = mwbg_realMissing
5183 bcor23 = mwbg_realMissing
5184 tb31 = mwbg_realMissing
5185 tb31FG = mwbg_realMissing
5186 bcor31 = mwbg_realMissing
5187 tb50 = mwbg_realMissing
5188 bcor50 = mwbg_realMissing
5189 tb89 = mwbg_realMissing
5190 bcor89 = mwbg_realMissing
5191 tb165 = mwbg_realMissing
5192 bcor165 = mwbg_realMissing
5193
5194 ! 2) Validate input parameters:
5195 if (satZenithAngle < 0.0d0 .or. satZenithAngle > 70.0d0 .or. &
5196 obsLat < -90.0d0 .or. obsLat > 90.0d0 .or. &
5197 calcLandQualifierIndice < 0 .or. calcLandQualifierIndice > 1) then
5198 ier = 1
5199 end if
5200
5201 ! Skip computations for points where all data are rejected (bad Tb ANY channel)
5202 if ( grossrej ) then
5203 ier = 1
5204 else
5205 ier = 0
5206
5207 ! extract required channels:
5208 ! 23 Ghz = AMSU-A 1 = ATMS channel 1
5209 ! 31 Ghz = AMSU-A 2 = ATMS channel 2
5210 ! 50 Ghz = AMSU-A 3 = ATMS channel 3
5211 ! 53 Ghz = AMSU-A 5 = ATMS channel 6
5212 ! 89 Ghz = AMSU-A15 = ATMS channel 16
5213 ! 150 Ghz = AMSU-B 2 = ATMS channel 17
5214 tb23 = obsTb(1)
5215 tb23FG = obsTb(1) - ompTb(1)
5216 bcor23 = obsTbBiasCorr(1)
5217 tb31 = obsTb(2)
5218 tb31FG = obsTb(2) - ompTb(2)
5219 bcor31 = obsTbBiasCorr(2)
5220 tb50 = obsTb(3)
5221 bcor50 = obsTbBiasCorr(3)
5222 tb89 = obsTb(16)
5223 bcor89 = obsTbBiasCorr(16)
5224 tb165 = obsTb(17)
5225 bcor165 = obsTbBiasCorr(17)
5226 end if
5227
5228 ! 3) Compute parameters:
5229 if ( ier == 0 ) then
5230 cosz = cosd(satZenithAngle)
5231
5232 if (bcor23 == mwbg_realMissing .or. mwbg_useUnbiasedObsForClw) then
5233 t23 = tb23
5234 else
5235 t23 = tb23 - bcor23
5236 end if
5237 if (bcor31 == mwbg_realMissing .or. mwbg_useUnbiasedObsForClw) then
5238 t31 = tb31
5239 else
5240 t31 = tb31 - bcor31
5241 end if
5242 if (bcor50 == mwbg_realMissing .or. mwbg_useUnbiasedObsForClw) then
5243 t50 = tb50
5244 else
5245 t50 = tb50 - bcor50
5246 end if
5247 if (bcor89 == mwbg_realMissing .or. mwbg_useUnbiasedObsForClw) then
5248 t89 = tb89
5249 else
5250 t89 = tb89 - bcor89
5251 end if
5252 if (bcor165 == mwbg_realMissing .or. mwbg_useUnbiasedObsForClw) then
5253 t165 = tb165
5254 else
5255 t165 = tb165 - bcor165
5256 end if
5257
5258 deltb = t89 - t165
5259 t23FG = tb23FG
5260 t31FG = tb31FG
5261
5262 ! Check for sea-ice over water points. Set terrain type to 0 if ice>=0.55 detected.
5263 if ( calcLandQualifierIndice == 1 ) then ! water point
5264
5265 if ( abs(obsLat) < 50.0d0 ) then
5266 ice = 0.0d0
5267 else
5268 ice = 2.85d0 + 0.020d0 * t23 - 0.028d0 * t50
5269 end if
5270
5271 SeaIce = ice
5272
5273 if ( ice >= 0.55d0 .and. waterobs ) then
5274 iNumSeaIce = iNumSeaIce + 1
5275 waterobs = .false.
5276 calcTerrainTypeIndice = 0
5277 end if
5278
5279 end if
5280
5281 ! Compute cloudLiquidWaterPathObs, cloudLiquidWaterPathFG, and Scattering Indices (over open water only)
5282 if ( waterobs ) then
5283 if ( t23 < 284.0d0 .and. t31 < 284.0d0 ) then
5284 aa = 8.24d0 - (2.622d0 - 1.846d0 * cosz) * cosz
5285 cloudLiquidWaterPathObs = aa + 0.754d0 * dlog(285.0d0 - t23) - 2.265d0 * dlog(285.0d0 - t31)
5286 cloudLiquidWaterPathObs = cloudLiquidWaterPathObs * cosz
5287 if ( cloudLiquidWaterPathObs < 0.0d0 ) cloudLiquidWaterPathObs = 0.0d0
5288
5289 cloudLiquidWaterPathFG = aa + 0.754d0 * dlog(285.0d0 - t23FG) - 2.265d0 * dlog(285.0d0 - t31FG)
5290 cloudLiquidWaterPathFG = cloudLiquidWaterPathFG * cosz
5291 if ( cloudLiquidWaterPathFG < 0.0d0 ) cloudLiquidWaterPathFG = 0.0d0
5292 end if
5293 si_ecmwf = deltb - (-46.94d0 + 0.248d0 * satZenithAngle)
5294 si_bg = deltb - (-39.201d0 + 0.1104d0 * satZenithAngle)
5295 end if
5296
5297 else ! ier == 1 case
5298 iRej = iRej + 1
5299
5300 end if ! if ( ier == 0 )
5301
5302 call obs_headSet_r(obsSpaceData, OBS_CLWO, headerIndex, cloudLiquidWaterPathObs)
5303 call obs_headSet_r(obsSpaceData, OBS_CLWB, headerIndex, cloudLiquidWaterPathFG)
5304
5305 if ( mwbg_debug ) then
5306 write(*,*) ' '
5307 write(*,*) ' tb23,tb23FG,tb31,tb31FG,tb50,tb89,tb165,satZenithAngle,obsLat, calcLandQualifierIndice = ', &
5308 tb23,tb23FG,tb31,tb31FG,tb50,tb89,tb165,satZenithAngle,obsLat, calcLandQualifierIndice
5309 write(*,*) ' ier,ice,cloudLiquidWaterPathObs,cloudLiquidWaterPathFG,si_ecmwf,si_bg,calcTerrainTypeIndice,waterobs =', &
5310 ier,ice,cloudLiquidWaterPathObs,cloudLiquidWaterPathFG,si_ecmwf,si_bg,calcTerrainTypeIndice,waterobs
5311 end if
5312
5313 end subroutine mwbg_nrlFilterAtms
5314
5315 !--------------------------------------------------------------------------
5316 ! mwbg_nrlFilterMwhs2
5317 !--------------------------------------------------------------------------
5318 subroutine mwbg_nrlFilterMwhs2(calcLandQualifierIndice, calcTerrainTypeIndice, waterobs, grossrej, &
5319 si_ecmwf, si_bg, iNumSeaIce, iRej, SeaIce, &
5320 headerIndex, sensorIndex, obsSpaceData)
5321 !
5322 !:Purpose: Compute the following parameters using 2 MWHS2 channels:
5323 ! - sea ice,
5324 ! - cloud liquid water from observation (cloudLiquidWaterPathObs),
5325 ! - cloud liquid water from first guess (cloudLiquidWaterPathFG),
5326 ! - 2 scattering indices (si) (ECMWF, Bennartz-Grody)
5327 ! The two channels used are: 89Ghz, and 165Ghz.
5328 !
5329 ! NOTES:
5330 ! - open water points are converted to sea-ice points if sea ice concentration >= 0.55
5331 ! and calcTerrainTypeIndice (terrainTypeIndice or terrain type) is changed accordingly
5332 ! - <cloudLiquidWaterPathObs> are missing when out-of-range parameters/Tb detected or grossrej = .true.
5333 ! - <cloudLiquidWaterPathObs> and <si_ecmwf> only computed over open water away from coasts and sea-ice
5334 ! - <si_bg> is computed for all points
5335 ! - <cloudLiquidWaterPathObs> and si = mwbg_realMissing where value cannot be computed.
5336 ! REFERENCES: Ben Ruston, NRL Monterey
5337 ! JCSDA Seminar 12/12/12: Impact of NPP Satellite Assimilation in the U.S. Navy Global Modeling System
5338 !
5339 ! Notes: In the case where an output parameter cannot be calculated, the
5340 ! value of this parameter is set to mwbg_realMissing
5341 !
5342 implicit none
5343
5344 ! Arguments:
5345 integer, intent(out) :: iNumSeaIce ! running counter for number of open water points with sea-ice detected (from algorithm)
5346 integer, intent(in) :: calcLandQualifierIndice ! land/sea indicator (0=land, 1=ocean)
5347 integer, intent(inout) :: calcTerrainTypeIndice ! terrain type (0=ice, -1 otherwise)
5348 integer, intent(out) :: iRej ! running counter for number of locations with bad satZenithAngle, obsLat, calcLandQualifierIndice, or with grossrej=true
5349 logical, intent(in) :: grossrej ! .true. if any channel had a gross error from mwbg_grossValueCheck
5350 logical, intent(inout) :: waterobs ! .true. if open water point (away from coasts and sea-ice)
5351 real(8), intent(out) :: si_ecmwf ! ECMWF scattering index from tb89 & tb165
5352 real(8), intent(out) :: si_bg ! Bennartz-Grody scattering index from tb89 & tb165
5353 real(8), intent(out) :: SeaIce ! computed sea-ice fraction from tb23 & tb50
5354 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
5355 integer, intent(in) :: headerIndex ! current header Index
5356 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
5357
5358 ! Locals:
5359 integer :: bodyIndex, bodyIndexBeg, bodyIndexEnd, obsChanNum, obsChanNumWithOffset
5360 integer :: ier, actualNumChannel
5361 real(8) :: ice, tb23, tb23FG, tb31, tb31FG, tb50, tb89, tb165
5362 real(8) :: bcor23, bcor31, bcor50, bcor89, bcor165
5363 real(8) :: aa, deltb, cosz, t23, t23FG, t31, t31FG, t50, t89, t165
5364 real(8) :: cloudLiquidWaterPathObs, cloudLiquidWaterPathFG
5365 real(8) :: obsLat, obsLon, satZenithAngle
5366 real(8), allocatable :: obsTb(:), obsTbBiasCorr(:)
5367
5368 iNumSeaIce = 0
5369 iRej = 0
5370
5371 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
5372 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
5373 actualNumChannel = obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex)
5374 satZenithAngle = obs_headElem_r(obsSpaceData, OBS_SZA, headerIndex)
5375
5376 ! lat/lon
5377 obsLat = obs_headElem_r(obsSpaceData, OBS_LAT, headerIndex)
5378 obsLon = obs_headElem_r(obsSpaceData, OBS_LON, headerIndex)
5379
5380 ! Convert lat/lon to degrees
5381 obsLon = obsLon * MPC_DEGREES_PER_RADIAN_R8
5382 if (obsLon > 180.0d0) obsLon = obsLon - 360.0d0
5383 obsLat = obsLat * MPC_DEGREES_PER_RADIAN_R8
5384
5385 if (.not. grossrej) then
5386 allocate(obsTb(actualNumChannel))
5387 allocate(obsTbBiasCorr(actualNumChannel))
5388 obsTb(:) = mwbg_realMissing
5389 obsTbBiasCorr(:) = mwbg_realMissing
5390 do bodyIndex = bodyIndexBeg, bodyIndexEnd
5391 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
5392 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
5393
5394 obsTb(obsChanNum) = obs_bodyElem_r(obsSpaceData, OBS_VAR, bodyIndex)
5395 obsTbBiasCorr(obsChanNum) = obs_bodyElem_r(obsSpaceData, OBS_BCOR, bodyIndex)
5396 end do
5397 end if
5398
5399 !! extract required channels: ATMS ch. MWHS-2 ch.
5400 !! 23 Ghz = AMSU-A 1 = 1 n/a
5401 !! 31 Ghz = AMSU-A 2 = 2 n/a
5402 !! 50 Ghz = AMSU-A 3 = 3 n/a
5403 !! 53 Ghz = AMSU-A 5 = 6 n/a
5404 !! 89 Ghz = AMSU-A 15/ B 1 = 16 1
5405 !! 150 Ghz = AMSU-B 2 = 17 10
5406 !! 183 Ghz = AMSU-B 3 = 22 11
5407 !! 183 Ghz = AMSU-B 5 = 18 15
5408 !
5409 ! Extract Tb for channels 1 (AMSU-B 1) and 10 (AMSU-B 2) for Bennartz SI
5410 ! Extract Tb for channels 22 (AMSU-B 3) and 18 (AMSU-B 5) for Dryness Index (DI)
5411
5412 tb23 = mwbg_realMissing
5413 tb23FG = mwbg_realMissing
5414 bcor23 = mwbg_realMissing
5415 tb31 = mwbg_realMissing
5416 tb31FG = mwbg_realMissing
5417 bcor31 = mwbg_realMissing
5418 tb50 = mwbg_realMissing
5419 bcor50 = mwbg_realMissing
5420 tb89 = mwbg_realMissing
5421 bcor89 = mwbg_realMissing
5422 tb165 = mwbg_realMissing
5423 bcor165 = mwbg_realMissing
5424
5425 ! 1) Initialise parameters:
5426 ice = mwbg_realMissing
5427 cloudLiquidWaterPathObs = mwbg_realMissing
5428 cloudLiquidWaterPathFG = mwbg_realMissing
5429 si_ecmwf = mwbg_realMissing
5430 si_bg = mwbg_realMissing
5431 SeaIce = 0.0d0
5432
5433 ! 2) Validate input parameters:
5434 if (satZenithAngle < 0.0d0 .or. satZenithAngle > 70.0d0 .or. &
5435 obsLat < -90.0d0 .or. obsLat > 90.0d0 .or. &
5436 calcLandQualifierIndice < 0 .or. calcLandQualifierIndice > 1) then
5437 ier = 1
5438 end if
5439
5440 ! Skip computations for points where all data are rejected (bad Tb ANY channel)
5441 if ( grossrej ) then
5442 ier = 1
5443 else
5444 ier = 0
5445
5446 tb89 = obsTb(1)
5447 bcor89 = obsTbBiasCorr(1)
5448 tb165 = obsTb(10)
5449 bcor165 = obsTbBiasCorr(10)
5450 end if
5451
5452 ! 3) Compute parameters:
5453 if ( ier == 0 ) then
5454 cosz = cosd(satZenithAngle)
5455
5456 if (bcor23 == mwbg_realMissing .or. mwbg_useUnbiasedObsForClw) then
5457 t23 = tb23
5458 else
5459 t23 = tb23 - bcor23
5460 end if
5461 if (bcor31 == mwbg_realMissing .or. mwbg_useUnbiasedObsForClw) then
5462 t31 = tb31
5463 else
5464 t31 = tb31 - bcor31
5465 end if
5466 if (bcor50 == mwbg_realMissing .or. mwbg_useUnbiasedObsForClw) then
5467 t50 = tb50
5468 else
5469 t50 = tb50 - bcor50
5470 end if
5471 if (bcor89 == mwbg_realMissing .or. mwbg_useUnbiasedObsForClw) then
5472 t89 = tb89
5473 else
5474 t89 = tb89 - bcor89
5475 end if
5476 if (bcor165 == mwbg_realMissing .or. mwbg_useUnbiasedObsForClw) then
5477 t165 = tb165
5478 else
5479 t165 = tb165 - bcor165
5480 end if
5481
5482 deltb = t89 - t165
5483 t23FG = tb23FG
5484 t31FG = tb31FG
5485
5486 ! Check for sea-ice over water points. Set terrain type to 0 if ice>=0.55 detected.
5487 if ( calcLandQualifierIndice == 1 .and. t23 /= mwbg_realMissing ) then ! water point
5488
5489 if ( abs(obsLat) < 50.0d0 ) then
5490 ice = 0.0d0
5491 else
5492 ice = 2.85d0 + 0.020d0 * t23 - 0.028d0 * t50
5493 end if
5494
5495 SeaIce = ice
5496 if ( ice >= 0.55d0 .and. waterobs ) then
5497 iNumSeaIce = iNumSeaIce + 1
5498 waterobs = .false.
5499 calcTerrainTypeIndice = 0
5500 end if
5501
5502 end if
5503
5504 ! Compute cloudLiquidWaterPathObs, cloudLiquidWaterPathFG, and Scattering Indices (over open water only)
5505 if ( waterobs ) then
5506 if ( t23 /= mwbg_realMissing ) then
5507 if ( t23 < 284.0d0 .and. t31 < 284.0d0 ) then
5508 aa = 8.24d0 - (2.622d0 - 1.846d0 * cosz) * cosz
5509 cloudLiquidWaterPathObs = aa + 0.754d0 * dlog(285.0d0 - t23) - 2.265d0 * dlog(285.0d0 - t31)
5510 cloudLiquidWaterPathObs = cloudLiquidWaterPathObs * cosz
5511 if ( cloudLiquidWaterPathObs < 0.0d0 ) cloudLiquidWaterPathObs = 0.0d0
5512
5513 cloudLiquidWaterPathFG = aa + 0.754d0 * dlog(285.0d0 - t23FG) - 2.265d0 * dlog(285.0d0 - t31FG)
5514 cloudLiquidWaterPathFG = cloudLiquidWaterPathFG * cosz
5515 if ( cloudLiquidWaterPathFG < 0.0d0 ) cloudLiquidWaterPathFG = 0.0d0
5516 end if
5517 end if
5518 si_ecmwf = deltb - (-46.94d0 + 0.248d0 * satZenithAngle)
5519 si_bg = deltb - (-39.201d0 + 0.1104d0 * satZenithAngle)
5520 else
5521 si_bg = deltb - (0.158d0 + 0.0163d0 * satZenithAngle)
5522 end if
5523
5524 else ! ier == 1 case
5525 iRej = iRej + 1
5526
5527 end if ! if ( ier == 0 )
5528
5529 call obs_headSet_r(obsSpaceData, OBS_CLWO, headerIndex, cloudLiquidWaterPathObs)
5530 call obs_headSet_r(obsSpaceData, OBS_CLWB, headerIndex, cloudLiquidWaterPathFG)
5531
5532 if ( mwbg_debug ) then
5533 write(*,*) ' '
5534 write(*,*) ' tb23,tb23FG,tb31,tb31FG,tb50,tb89,tb165,satZenithAngle,obsLat, calcLandQualifierIndice = ', &
5535 tb23,tb23FG,tb31,tb31FG,tb50,tb89,tb165,satZenithAngle,obsLat, calcLandQualifierIndice
5536 write(*,*) ' ier,ice,cloudLiquidWaterPathObs,cloudLiquidWaterPathFG,si_ecmwf,si_bg,calcTerrainTypeIndice,waterobs =', &
5537 ier,ice,cloudLiquidWaterPathObs,cloudLiquidWaterPathFG,si_ecmwf,si_bg,calcTerrainTypeIndice,waterobs
5538 end if
5539
5540 end subroutine mwbg_nrlFilterMwhs2
5541
5542 !--------------------------------------------------------------------------
5543 ! mwbg_flagDataUsingNrlCritAtms
5544 !--------------------------------------------------------------------------
5545 subroutine mwbg_flagDataUsingNrlCritAtms(scatec, scatbg, SeaIce, grossrej, waterobs, useUnbiasedObsForClw, &
5546 iwvreject, cloudobs, precipobs, cldcnt, riwv, zdi, &
5547 headerIndex, sensorIndex, obsSpaceData)
5548 !
5549 !:Purpose: Set the Information flag (newInformationFlag) values (new BURP element 025174 in header).
5550 ! BIT Meaning:
5551 ! - 0 off=land or sea-ice, on=open water away from coast
5552 ! - 1 Mean 183 Ghz [ch. 18-22] is missing
5553 ! - 2 CLW is missing (over water)
5554 ! - 3 CLW > clw_atms_nrl_LTrej (0.175 kg/m2) (cloudobs)
5555 ! - 4 scatec/scatbg > Lower Troposphere limit 9/10 (precipobs)
5556 ! - 5 Mean 183 Ghz [ch. 18-22] Tb < 240K
5557 ! - 6 CLW > clw_atms_nrl_UTrej (0.200 kg/m2)
5558 ! - 7 Dryness Index rejection (for ch. 22)
5559 ! - 8 scatec/scatbg > Upper Troposphere limit 18/15
5560 ! - 9 Dryness Index rejection (for ch. 21)
5561 ! - 10 Sea ice > 0.55 detected
5562 ! - 11 Gross error in Tb (any chan.) (all channels rejected)
5563 !
5564 implicit none
5565
5566 ! Arguments:
5567 real(8), intent(in) :: scatec ! ECMWF scattering index from tb89 & tb165
5568 real(8), intent(in) :: scatbg ! Bennartz-Grody scattering index from tb89 & tb165
5569 real(8), intent(in) :: SeaIce ! computed sea-ice fraction from tb23 & tb50
5570 logical, intent(in) :: useUnbiasedObsForClw ! use unbiased Tb for CLW calculation
5571 logical, intent(in) :: grossrej ! .true. if any channel had a gross error from mwbg_grossValueCheck
5572 logical, intent(in) :: waterobs ! if obs over open-water
5573 integer, intent(inout) :: cldcnt ! Number of water point covered by cloud
5574 logical, intent(out) :: cloudobs ! .true. if CLW > clw_atms_nrl_LTrej (0.175) or precipobs
5575 logical, intent(out) :: iwvreject ! .true. if Mean 183 Ghz [ch. 18-22] Tb < 240K (too dry for ch.20-22 over land)
5576 logical, intent(out) :: precipobs ! .true. if precip. detected through NRL scattering indices
5577 real(8), intent(out) :: zdi ! simple AMSU-B Dryness Index Tb(ch.3)-Tb(ch.5)
5578 real(8), intent(out) :: riwv ! Mean 183 Ghz [ch. 18-22] Tb
5579 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
5580 integer, intent(in) :: headerIndex ! current header Index
5581 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
5582
5583 ! Locals:
5584 integer :: indx, n_cld, newInformationFlag, actualNumChannel
5585 integer :: bodyIndex, bodyIndexBeg, bodyIndexEnd, obsChanNum, obsChanNumWithOffset
5586 real(8) :: ztb_amsub3, bcor_amsub3, ztb_amsub5, bcor_amsub5, ztb183(5)
5587 real(8) :: cloudLiquidWaterPathObs
5588 real(8), allocatable :: obsTb(:), obsTbBiasCorr(:)
5589
5590 ! To begin, assume that all obs are good.
5591 newInformationFlag = 0
5592 n_cld = 0
5593 cloudobs = .false.
5594 iwvreject = .false.
5595 precipobs = .false.
5596
5597 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
5598 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
5599 actualNumChannel = obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex)
5600 if (tvs_coefs(sensorIndex)%coef%fmv_ori_nchn /= actualNumChannel) then
5601 write(*,*) 'mwbg_flagDataUsingNrlCritAtms: tvs_coefs(sensorIndex)%coef%fmv_ori_nchn /= actualNumChannel'
5602 end if
5603
5604 cloudLiquidWaterPathObs = obs_headElem_r(obsSpaceData, OBS_CLWO, headerIndex)
5605
5606 if (.not. grossrej) then
5607 allocate(obsTb(actualNumChannel))
5608 allocate(obsTbBiasCorr(actualNumChannel))
5609 obsTb(:) = mwbg_realMissing
5610 obsTbBiasCorr(:) = mwbg_realMissing
5611 do bodyIndex = bodyIndexBeg, bodyIndexEnd
5612 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
5613 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
5614
5615 obsTb(obsChanNum) = obs_bodyElem_r(obsSpaceData, OBS_VAR, bodyIndex)
5616 obsTbBiasCorr(obsChanNum) = obs_bodyElem_r(obsSpaceData, OBS_BCOR, bodyIndex)
5617 end do
5618
5619 ! Extract Tb for channels 16 (AMSU-B 1) and 17 (AMSU-B 2) for Bennartz SI
5620 ! Extract Tb for channels 22 (AMSU-B 3) and 18 (AMSU-B 5) for Dryness Index (DI)
5621 ztb_amsub3 = obsTb(22)
5622 bcor_amsub3 = obsTbBiasCorr(22)
5623 ztb_amsub5 = obsTb(18)
5624 bcor_amsub5 = obsTbBiasCorr(18)
5625 end if
5626
5627 ! Flag data using NRL criteria
5628
5629 ! Compute Mean 183 Ghz [ch. 18-22] Tb (riwv)
5630 riwv = mwbg_realMissing
5631 if (.not. grossrej) then
5632 do indx = 1, 5
5633 if (obsTbBiasCorr(indx+10) == mwbg_realMissing .or. useUnbiasedObsForClw) then
5634 ztb183(indx) = obsTb(indx+17)
5635 else
5636 ztb183(indx) = obsTb(indx+17) - obsTbBiasCorr(indx+17)
5637 end if
5638 end do
5639 riwv = sum(ztb183) / 5.0d0
5640 if ( riwv < mean_Tb_183Ghz_min ) iwvreject = .true.
5641 else
5642 iwvreject = .true.
5643 end if
5644
5645 ! Set bits in newInformationFlag flag to identify where various data selection criteria are met
5646 ! precipobs = .true where ECMWF or BG scattering index > min_threshold (LT)
5647 ! cloudobs = .true. where CLW > min_threshold (LT) or if precipobs = .true
5648
5649 if ( grossrej ) newInformationFlag = IBSET(newInformationFlag,11)
5650 if ( scatec > scatec_atms_nrl_LTrej .or. scatbg > scatbg_atms_nrl_LTrej ) precipobs = .true.
5651 if (cloudLiquidWaterPathObs > clw_atms_nrl_LTrej) n_cld = 1
5652 cldcnt = cldcnt + n_cld
5653 if ( (cloudLiquidWaterPathObs > clw_atms_nrl_LTrej) .or. precipobs ) cloudobs = .true.
5654 if ( waterobs ) newInformationFlag = IBSET(newInformationFlag,0)
5655 if ( iwvreject ) newInformationFlag = IBSET(newInformationFlag,5)
5656 if ( precipobs ) newInformationFlag = IBSET(newInformationFlag,4)
5657 if ( cloudLiquidWaterPathObs > clw_atms_nrl_LTrej) newInformationFlag = IBSET(newInformationFlag,3)
5658 if ( cloudLiquidWaterPathObs > clw_atms_nrl_UTrej) newInformationFlag = IBSET(newInformationFlag,6)
5659 if ( scatec > scatec_atms_nrl_UTrej .or. scatbg > scatbg_atms_nrl_UTrej ) newInformationFlag = IBSET(newInformationFlag,8)
5660 if ( SeaIce >= 0.55d0 ) newInformationFlag = IBSET(newInformationFlag,10)
5661
5662 if (waterobs .and. cloudLiquidWaterPathObs == mwbg_realMissing) then
5663 newInformationFlag = IBSET(newInformationFlag,2)
5664 end if
5665 if (riwv == mwbg_realMissing) newInformationFlag = IBSET(newInformationFlag,1)
5666
5667 ! Compute the simple AMSU-B Dryness Index zdi for all points = Tb(ch.3)-Tb(ch.5)
5668 if ( useUnbiasedObsForClw ) then
5669 if (.not. grossrej) then
5670 zdi = ztb_amsub3 - ztb_amsub5
5671 else
5672 zdi = mwbg_realMissing
5673 end if
5674 else
5675 if (.not. grossrej) then
5676 zdi = (ztb_amsub3 - bcor_amsub3) - (ztb_amsub5 - bcor_amsub5)
5677 else
5678 zdi = mwbg_realMissing
5679 end if
5680 end if
5681
5682 call obs_headSet_i(obsSpaceData, OBS_INFG, headerIndex, newInformationFlag)
5683
5684 end subroutine mwbg_flagDataUsingNrlCritAtms
5685
5686 !--------------------------------------------------------------------------
5687 ! mwbg_flagDataUsingNrlCritMwhs2
5688 !--------------------------------------------------------------------------
5689 subroutine mwbg_flagDataUsingNrlCritMwhs2(scatec, SeaIce, grossrej, waterobs, useUnbiasedObsForClw, &
5690 iwvreject, cloudobs, precipobs, cldcnt, riwv, zdi, &
5691 headerIndex, sensorIndex, obsSpaceData)
5692 !
5693 !:Purpose: Set the Information flag (newInformationFlag) values (new BURP element 025174 in header).
5694 ! BIT Meaning:
5695 ! - 0 off=land or sea-ice, on=open water away from coast
5696 ! - 1 Mean 183 Ghz [ch. 18-22] is missing
5697 ! - 2 CLW is missing (over water)
5698 ! - 3 CLW > clw_mwhs2_nrl_LTrej (0.175 kg/m2) (cloudobs)
5699 ! - 4 scatec > Lower Troposphere limit 9/10 (precipobs)
5700 ! - 5 Mean 183 Ghz [ch. 18-22] Tb < 240K
5701 ! - 6 CLW > clw_mwhs2_nrl_UTrej (0.200 kg/m2)
5702 ! - 10 Sea ice > 0.55 detected
5703 ! - 11 Gross error in Tb (any chan.) (all channels rejected)
5704 !
5705 implicit none
5706
5707 ! Arguments:
5708 real(8), intent(in) :: scatec ! ECMWF scattering index from tb89 & tb165
5709 real(8), intent(in) :: SeaIce ! computed sea-ice fraction from tb23 & tb50
5710 logical, intent(in) :: useUnbiasedObsForClw ! use unbiased Tb for CLW calculation
5711 logical, intent(in) :: grossrej ! .true. if any channel had a gross error from mwbg_grossValueCheck
5712 logical, intent(in) :: waterobs ! if obs over open-water
5713 integer, intent(inout) :: cldcnt ! Number of water point covered by cloud
5714 logical, intent(out) :: cloudobs ! .true. if CLW > clw_atms_nrl_LTrej (0.175) or precipobs
5715 logical, intent(out) :: iwvreject ! .true. if Mean 183 Ghz [ch. 18-22] Tb < 240K (too dry for ch.20-22 over land)
5716 logical, intent(out) :: precipobs ! .true. if precip. detected through NRL scattering indices
5717 real(8), intent(out) :: zdi ! simple AMSU-B Dryness Index Tb(ch.3)-Tb(ch.5)
5718 real(8), intent(out) :: riwv ! Mean 183 Ghz [ch. 18-22] Tb
5719 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
5720 integer, intent(in) :: headerIndex ! current header Index
5721 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
5722
5723 ! Locals:
5724 integer :: indx, n_cld, newInformationFlag, actualNumChannel
5725 integer :: bodyIndex, bodyIndexBeg, bodyIndexEnd, obsChanNum, obsChanNumWithOffset
5726 real(8) :: ztb_amsub3, bcor_amsub3, ztb_amsub5, bcor_amsub5, ztb183(5)
5727 real(8) :: cloudLiquidWaterPathObs
5728 real(8), allocatable :: obsTb(:), obsTbBiasCorr(:)
5729
5730 ! To begin, assume that all obs are good.
5731 newInformationFlag = 0
5732 n_cld = 0
5733 cloudobs = .false.
5734 iwvreject = .false.
5735 precipobs = .false.
5736
5737 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
5738 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
5739 actualNumChannel = obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex)
5740
5741 cloudLiquidWaterPathObs = obs_headElem_r(obsSpaceData, OBS_CLWO, headerIndex)
5742
5743 if (.not. grossrej) then
5744 allocate(obsTb(actualNumChannel))
5745 allocate(obsTbBiasCorr(actualNumChannel))
5746 obsTb(:) = mwbg_realMissing
5747 obsTbBiasCorr(:) = mwbg_realMissing
5748 do bodyIndex = bodyIndexBeg, bodyIndexEnd
5749 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
5750 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
5751
5752 obsTb(obsChanNum) = obs_bodyElem_r(obsSpaceData, OBS_VAR, bodyIndex)
5753 obsTbBiasCorr(obsChanNum) = obs_bodyElem_r(obsSpaceData, OBS_BCOR, bodyIndex)
5754 end do
5755
5756 ! Extract Tb for channels 1 (AMSU-B 1) and 10 (AMSU-B 2) for Bennartz SI
5757 ! Extract Tb for channels 11 (AMSU-B 3) and 15 (AMSU-B 5) for Dryness Index (DI)
5758 ztb_amsub3 = obsTb(11)
5759 bcor_amsub3 = obsTbBiasCorr(11)
5760 ztb_amsub5 = obsTb(15)
5761 bcor_amsub5 = obsTbBiasCorr(15)
5762 end if
5763
5764 ! Flag data using NRL criteria
5765
5766 ! Compute Mean 183 Ghz [ch. 11-15] Tb (riwv)
5767 riwv = mwbg_realMissing
5768 if (.not. grossrej) then
5769 do indx = 1, 5
5770 if (obsTbBiasCorr(indx+10) == mwbg_realMissing .or. useUnbiasedObsForClw) then
5771 ztb183(indx) = obsTb(indx+10)
5772 else
5773 ztb183(indx) = obsTb(indx+10) - obsTbBiasCorr(indx+10)
5774 end if
5775 end do
5776 riwv = sum(ztb183) / 5.0d0
5777 if ( riwv < mean_Tb_183Ghz_min ) iwvreject = .true.
5778 else
5779 iwvreject = .true.
5780 end if
5781
5782 ! Set bits in newInformationFlag flag to identify where various data selection criteria are met
5783 ! precipobs = .true where ECMWF or BG scattering index > min_threshold (LT)
5784 ! cloudobs = .true. where CLW > min_threshold (LT) or if precipobs = .true
5785
5786 if ( grossrej ) newInformationFlag = IBSET(newInformationFlag,11)
5787 if ( scatec > scatec_mwhs2_nrl_LTrej ) precipobs = .true.
5788 if (cloudLiquidWaterPathObs > clw_mwhs2_nrl_LTrej) n_cld = 1
5789 cldcnt = cldcnt + n_cld
5790 if ( (cloudLiquidWaterPathObs > clw_mwhs2_nrl_LTrej) .or. precipobs ) cloudobs = .true.
5791 if ( waterobs ) newInformationFlag = IBSET(newInformationFlag,0)
5792 if ( iwvreject ) newInformationFlag = IBSET(newInformationFlag,5)
5793 if ( precipobs ) newInformationFlag = IBSET(newInformationFlag,4)
5794 if ( cloudLiquidWaterPathObs > clw_mwhs2_nrl_LTrej) newInformationFlag = IBSET(newInformationFlag,3)
5795 if ( cloudLiquidWaterPathObs > clw_mwhs2_nrl_UTrej) newInformationFlag = IBSET(newInformationFlag,6)
5796 if ( SeaIce >= 0.55d0 ) newInformationFlag = IBSET(newInformationFlag,10)
5797
5798 if (waterobs .and. cloudLiquidWaterPathObs == mwbg_realMissing) then
5799 newInformationFlag = IBSET(newInformationFlag,2)
5800 end if
5801 if (riwv == mwbg_realMissing) newInformationFlag = IBSET(newInformationFlag,1)
5802
5803 ! Compute the simple AMSU-B Dryness Index zdi for all points = Tb(ch.3)-Tb(ch.5)
5804 if ( useUnbiasedObsForClw ) then
5805 if ( .not. grossrej ) then
5806 zdi = ztb_amsub3 - ztb_amsub5
5807 else
5808 zdi = mwbg_realMissing
5809 end if
5810 else
5811 if ( .not. grossrej ) then
5812 zdi = (ztb_amsub3 - bcor_amsub3) - (ztb_amsub5 - bcor_amsub5)
5813 else
5814 zdi = mwbg_realMissing
5815 end if
5816 end if
5817
5818 call obs_headSet_i(obsSpaceData, OBS_INFG, headerIndex, newInformationFlag)
5819
5820 end subroutine mwbg_flagDataUsingNrlCritMwhs2
5821
5822 !--------------------------------------------------------------------------
5823 ! mwbg_reviewAllCritforFinalFlagsAtms
5824 !--------------------------------------------------------------------------
5825 subroutine mwbg_reviewAllCritforFinalFlagsAtms(qcRejectLogic, grossrej, waterobs, &
5826 precipobs, scatec, scatbg, &
5827 iwvreject, riwv, &
5828 zdi, drycnt, landcnt, &
5829 rejcnt, iwvcnt, pcpcnt, flgcnt, &
5830 chanIgnoreInAllskyGenCoeff, &
5831 headerIndex, sensorIndex, obsSpaceData)
5832 !
5833 !:Purpose: Review all the checks previously made to determine which obs are to be accepted
5834 ! for assimilation and which are to be flagged for exclusion (lflagchn).
5835 ! - <grossrej> = .true. if any channel had a gross error at the point
5836 ! - <cloudobs> = .true. if CLW > clw_atms_nrl_LTrej (0.175) or precipobs
5837 ! - <precipobs> = .true. if precip. detected through NRL scattering indices
5838 ! - <waterobs> = .true. if open water point
5839 ! - <iwvreject> = .true. if Mean 183 Ghz [ch. 18-22] Tb < 240K (too dry for ch.20-22 over land)
5840 !
5841 implicit none
5842
5843 ! Arguments:
5844 logical, intent(in) :: qcRejectLogic(:) ! .true. if channel is rejected
5845 real(8), intent(in) :: scatbg ! Bennartz-Grody scattering index from tb89 & tb165
5846 real(8), intent(in) :: scatec ! ECMWF scattering index from tb89 & tb165
5847 logical, intent(in) :: grossrej ! .true. if any channel had a gross error from mwbg_grossValueCheck
5848 logical, intent(in) :: waterobs ! if obs over open-water
5849 logical, intent(in) :: iwvreject ! .true. if Mean 183 Ghz [ch. 18-22] Tb < 240K (too dry for ch.20-22 over land)
5850 logical, intent(in) :: precipobs ! .true. if precip. detected through NRL scattering indices
5851 real(8), intent(in) :: zdi ! simple AMSU-B Dryness Index Tb(ch.3)-Tb(ch.5)
5852 real(8), intent(in) :: riwv ! Mean 183 Ghz [ch. 18-22] Tb
5853 integer, intent(inout) :: landcnt ! Number of obs pts found over land/ice
5854 integer, intent(inout) :: drycnt ! Number of pts flagged for AMSU-B Dryness Index
5855 integer, intent(inout) :: rejcnt ! Number of rejected obs (Tb err, QCfail)
5856 integer, intent(inout) :: iwvcnt ! Number of pts with Mean 183 Ghz Tb < 240K
5857 integer, intent(inout) :: pcpcnt ! Number of scatter/precip obs
5858 integer, intent(inout) :: flgcnt ! Total number of filtered obs
5859 integer, intent(in) :: chanIgnoreInAllskyGenCoeff(:) ! Channels excluded from gen_bias_corr in all-sky mode
5860 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
5861 integer, intent(in) :: headerIndex ! current header Index
5862 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
5863
5864 ! Locals:
5865 integer :: INDXCAN, codtyp, obsGlobalMarker, newInformationFlag, actualNumChannel
5866 integer :: bodyIndex, bodyIndexBeg, bodyIndexEnd, obsChanNum, obsChanNumWithOffset
5867 integer :: obsFlags
5868 real(8) :: clwObsFGaveraged, cloudLiquidWaterPathObs, cloudLiquidWaterPathFG
5869 real(8) :: scatIndexOverWaterObs, scatIndexOverWaterFG
5870 logical, allocatable :: lflagchn(:)
5871
5872 cloudLiquidWaterPathObs = obs_headElem_r(obsSpaceData, OBS_CLWO, headerIndex)
5873 cloudLiquidWaterPathFG = obs_headElem_r(obsSpaceData, OBS_CLWB, headerIndex)
5874 newInformationFlag = obs_headElem_i(obsSpaceData, OBS_INFG, headerIndex)
5875 actualNumChannel = tvs_coefs(sensorIndex)%coef%fmv_ori_nchn
5876
5877 ! Allocation
5878 allocate(lflagchn(actualNumChannel))
5879
5880 lflagchn(:) = qcRejectLogic(:) ! initialize with flags set in mwbg_firstQcCheckAtms
5881 ! Reject all channels if gross Tb error detected in any channel or other problems
5882 if ( grossrej ) then
5883 lflagchn(:) = .true.
5884 else
5885
5886 ! OVER LAND OR SEA-ICE,
5887 ! -- CLW/SI not determined over land
5888 ! -- surface emissivity effects lower tropospheric and window channels
5889 ! -- reject window & lower tropospheric channels 1-6, 16-19
5890 ! -- reject ch. 20-22 if iwvreject = .true. [ Mean 183 Ghz [ch. 18-22] Tb < 240K ]
5891 ! -- check DI for AMSU-B like channels
5892
5893 if ( .not. waterobs ) then
5894 lflagchn(1:mwbg_atmsNumSfcSensitiveChannel) = .true. ! AMSU-A 1-6
5895 lflagchn(16:19) = .true. ! AMSU-B (like 1,2,5)
5896 if ( iwvreject ) lflagchn(20:22) = .true. ! AMSU-B (like 4,3)
5897
5898 ! Dryness index (for AMSU-B channels 19-22 assimilated over land/sea-ice)
5899 ! Channel AMSUB-3 (ATMS channel 22) is rejected for a dryness index > 0.
5900 ! (ATMS channel 21) is rejected for a dryness index > -5.
5901 ! Channel AMSUB-4 (ATMS channel 20) is rejected for a dryness index > -8.
5902 if ( zdi > 0.0d0 ) then
5903 lflagchn(22) = .true.
5904 newInformationFlag = IBSET(newInformationFlag,7)
5905 end if
5906 if ( zdi > -5.0d0 ) then
5907 lflagchn(21) = .true.
5908 newInformationFlag = IBSET(newInformationFlag,9)
5909 drycnt = drycnt + 1
5910 end if
5911 if ( zdi > -8.0d0 ) then
5912 lflagchn(20) = .true.
5913 end if
5914
5915 else ! if waterobs
5916
5917 ! OVER WATER,
5918 ! in clear-sky mode:
5919 ! -- reject ch. 5-6, if CLW > clw_atms_nrl_LTrej or CLW = mwbg_realMissing
5920 ! in all-sky mode:
5921 ! -- reject ch. 5-6, if CLW > mwbg_clwQcThreshold or CLW = mwbg_realMissing
5922 !
5923 ! -- reject ch. 1-4, if CLW > clw_atms_nrl_LTrej or CLW = mwbg_realMissing
5924 ! -- reject ch. 16-20 if CLW > clw_atms_nrl_LTrej or CLW = mwbg_realMissing
5925 ! -- reject ch. 7-9, 21-22 if CLW > clw_atms_nrl_UTrej or CLW = mwbg_realMissing
5926 ! -- reject ch. 1-6, 16-22 if scatec > 9 or scatec = mwbg_realMissing
5927 ! -- reject ch. 7-9 if scatec > 18 or scatec = mwbg_realMissing
5928 ! -- reject ch. 1-6 if scatbg > 10 or scatbg = mwbg_realMissing
5929 ! -- reject ch. 7-9 if scatbg > 15 or scatbg = mwbg_realMissing
5930 ! -- reject ch. 16-22 if iwvreject = .true. [ Mean 183 Ghz [ch. 18-22] Tb < 240K ]
5931
5932 if ( cloudLiquidWaterPathObs > clw_atms_nrl_LTrej ) then
5933 if ( tvs_mwAllskyAssim ) then
5934 lflagchn(1:4) = .true.
5935 clwObsFGaveraged = 0.5d0 * (cloudLiquidWaterPathObs + cloudLiquidWaterPathFG)
5936 if ( clwObsFGaveraged > mwbg_clwQcThreshold ) lflagchn(5:6) = .true.
5937 else
5938 lflagchn(1:mwbg_atmsNumSfcSensitiveChannel) = .true.
5939 end if
5940 lflagchn(16:20) = .true.
5941 end if
5942 if ( cloudLiquidWaterPathObs > clw_atms_nrl_UTrej ) then
5943 lflagchn(7:9) = .true.
5944 lflagchn(21:22) = .true.
5945 end if
5946 if ( scatec > scatec_atms_nrl_LTrej ) then
5947 lflagchn(1:mwbg_atmsNumSfcSensitiveChannel) = .true.
5948 lflagchn(16:22) = .true.
5949 end if
5950 if ( scatec > scatec_atms_nrl_UTrej ) lflagchn(7:9) = .true.
5951 if ( scatbg > scatbg_atms_nrl_LTrej ) lflagchn(1:mwbg_atmsNumSfcSensitiveChannel) = .true.
5952 if ( scatbg > scatbg_atms_nrl_UTrej ) lflagchn(7:9) = .true.
5953 if ( iwvreject ) lflagchn(16:22) = .true.
5954 if ( cloudLiquidWaterPathObs == mwbg_realMissing ) then
5955 newInformationFlag = IBSET(newInformationFlag,2)
5956 lflagchn(1:9) = .true.
5957 lflagchn(16:22) = .true.
5958 end if
5959 if ( riwv == mwbg_realMissing ) then ! riwv = mean_Tb_183Ghz
5960 newInformationFlag = IBSET(newInformationFlag,1)
5961 lflagchn(16:22) = .true.
5962 end if
5963 end if ! if waterobs
5964
5965 end if ! if .not. grossrej
5966
5967 if ( .not. waterobs ) landcnt = landcnt + 1
5968 if ( grossrej ) rejcnt = rejcnt + 1
5969 if ( iwvreject) iwvcnt = iwvcnt + 1
5970 if ( precipobs .and. waterobs ) then
5971 pcpcnt = pcpcnt + 1
5972 end if
5973
5974 if ( ANY(lflagchn(:)) ) flgcnt = flgcnt + 1
5975
5976 ! RESET scatIndexOverWaterObs array to ECMWF scattering index for output to BURP file
5977 scatIndexOverWaterObs = scatec
5978 ! Set missing cloudLiquidWaterPathFG and scatIndexOverWaterFG to BURP missing value (mwbg_realMissing)
5979 if (cloudLiquidWaterPathObs == mwbg_realMissing) cloudLiquidWaterPathFG = mwbg_realMissing
5980 scatIndexOverWaterFG = mwbg_realMissing
5981
5982 ! Modify data flag values (set bit 7) for rejected data
5983 ! In all-sky mode, turn on bit=23 for channels in chanIgnoreInAllskyGenCoeff(:)
5984 ! as cloud-affected radiances over sea when there is mismatch between
5985 ! cloudLiquidWaterPathObs and cloudLiquidWaterPathFG (to be used in gen_bias_corr)
5986 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
5987 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
5988 clwObsFGaveraged = 0.5d0 * (cloudLiquidWaterPathObs + cloudLiquidWaterPathFG)
5989 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
5990 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
5991 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
5992 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
5993
5994 if (lflagchn(obsChanNum)) obsFlags = IBSET(obsFlags,7)
5995
5996 INDXCAN = utl_findloc(chanIgnoreInAllskyGenCoeff(:),obsChanNumWithOffset)
5997 if (tvs_mwAllskyAssim .and. waterobs .and. INDXCAN /= 0 .and. &
5998 (clwObsFGaveraged > mwbg_cloudyClwThresholdBcorr .or. &
5999 cloudLiquidWaterPathObs == mwbg_realMissing .or. &
6000 cloudLiquidWaterPathFG == mwbg_realMissing)) then
6001 obsFlags = IBSET(obsFlags,23)
6002 end if
6003
6004 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
6005 end do BODY
6006
6007 ! Set bit 6 in 24-bit global flags if any data rejected
6008 if ( ANY(lflagchn(:)) ) then
6009 obsGlobalMarker = obs_headElem_i(obsSpaceData, OBS_ST1, headerIndex)
6010 obsGlobalMarker = IBSET(obsGlobalMarker,6)
6011 call obs_headSet_i(obsSpaceData, OBS_ST1, headerIndex, obsGlobalMarker)
6012 end if
6013
6014 codtyp = obs_headElem_i(obsSpaceData, OBS_ITY, headerIndex)
6015 call obs_headSet_r(obsSpaceData, OBS_CLWO, headerIndex, cloudLiquidWaterPathObs)
6016 call obs_headSet_r(obsSpaceData, OBS_CLWB, headerIndex, cloudLiquidWaterPathFG)
6017 call obs_headSet_i(obsSpaceData, OBS_INFG, headerIndex, newInformationFlag)
6018
6019 if (scatIndexOverWaterObs /= mwbg_realMissing) then
6020 call obs_headSet_r(obsSpaceData, OBS_SIO, headerIndex, scatIndexOverWaterObs)
6021 else
6022 call obs_headSet_r(obsSpaceData, OBS_SIO, headerIndex, MPC_missingValue_R8)
6023 end if
6024
6025 if (tvs_isInstrumAllskyHuAssim(tvs_getInstrumentId(codtyp_get_name(codtyp)))) then
6026 if (scatIndexOverWaterFG /= mwbg_realMissing) then
6027 call obs_headSet_r(obsSpaceData, OBS_SIB, headerIndex, scatIndexOverWaterFG)
6028 else
6029 call obs_headSet_r(obsSpaceData, OBS_SIB, headerIndex, MPC_missingValue_R8)
6030 end if
6031 end if
6032
6033 end subroutine mwbg_reviewAllCritforFinalFlagsAtms
6034
6035 !--------------------------------------------------------------------------
6036 ! mwbg_reviewAllCritforFinalFlagsMwhs2
6037 !--------------------------------------------------------------------------
6038 subroutine mwbg_reviewAllCritforFinalFlagsMwhs2(qcRejectLogic, grossrej, calcTerrainTypeIndice, waterobs, &
6039 precipobs, scatec, scatbg, &
6040 iwvreject, riwv, &
6041 zdi, allcnt, drycnt, landcnt, &
6042 rejcnt, iwvcnt, pcpcnt, flgcnt, &
6043 chanIgnoreInAllskyGenCoeff, &
6044 headerIndex, sensorIndex, obsSpaceData)
6045 !
6046 !:Purpose: Review all the checks previously made to determine which obs are to be accepted
6047 ! for assimilation and which are to be flagged for exclusion (lflagchn).
6048 ! - <grossrej> = .true. if any channel had a gross error at the point
6049 ! - <cloudobs> = .true. if CLW > clw_mwhs2_nrl_LTrej (0.175) or precipobs
6050 ! - <precipobs> = .true. if precip. detected through NRL scattering indices
6051 ! - <waterobs> = .true. if open water point
6052 ! - <iwvreject> = .true. if Mean 183 Ghz [ch. 18-22] Tb < 240K (too dry for ch.20-22 over land)
6053 !
6054 implicit none
6055
6056 ! Arguments:
6057 logical, intent(in) :: qcRejectLogic(:) ! .true. if channel is rejected
6058 real(8), intent(in) :: scatec ! ECMWF scattering index from tb89 & tb165
6059 real(8), intent(in) :: scatbg ! Bennartz-Grody scattering index from tb89 & tb165
6060 logical, intent(in) :: grossrej ! .true. if any channel had a gross error from mwbg_grossValueCheck
6061 logical, intent(in) :: waterobs ! if obs over open-water
6062 logical, intent(in) :: iwvreject ! .true. if Mean 183 Ghz [ch. 18-22] Tb < 240K (too dry for ch.20-22 over land)
6063 logical, intent(in) :: precipobs ! .true. if precip. detected through NRL scattering indices
6064 real(8), intent(in) :: zdi ! simple AMSU-B Dryness Index Tb(ch.3)-Tb(ch.5)
6065 real(8), intent(in) :: riwv ! Mean 183 Ghz [ch. 18-22] Tb
6066 integer, intent(inout) :: allcnt ! total number of obs
6067 integer, intent(inout) :: drycnt ! Number of pts flagged for AMSU-B Dryness Index
6068 integer, intent(inout) :: landcnt ! Number of obs pts found over land/ice
6069 integer, intent(inout) :: rejcnt ! Number of rejected obs (Tb err, QCfail)
6070 integer, intent(inout) :: iwvcnt ! Number of pts with Mean 183 Ghz Tb < 240K
6071 integer, intent(inout) :: pcpcnt ! Number of scatter/precip obs
6072 integer, intent(inout) :: flgcnt ! Total number of filtered obs
6073 integer, intent(inout) :: calcTerrainTypeIndice ! terrain type (0=ice, -1 otherwise)
6074 integer, intent(in) :: chanIgnoreInAllskyGenCoeff(:) ! Channels excluded from gen_bias_corr in all-sky mode
6075 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
6076 integer, intent(in) :: headerIndex ! current header Index
6077 integer, intent(in) :: sensorIndex ! numero de satellite (i.e. indice)
6078
6079 ! Locals:
6080 integer :: INDXCAN, codtyp, obsGlobalMarker, newInformationFlag, actualNumChannel
6081 integer :: bodyIndex, bodyIndexBeg, bodyIndexEnd, obsChanNum, obsChanNumWithOffset
6082 integer :: obsFlags
6083 real(8) :: clwObsFGaveraged, cloudLiquidWaterPathObs, cloudLiquidWaterPathFG
6084 real(8) :: scatbg_rej, scatIndexOverWaterObs, scatIndexOverWaterFG
6085 logical, allocatable :: lflagchn(:)
6086
6087 cloudLiquidWaterPathObs = obs_headElem_r(obsSpaceData, OBS_CLWO, headerIndex)
6088 cloudLiquidWaterPathFG = obs_headElem_r(obsSpaceData, OBS_CLWB, headerIndex)
6089 newInformationFlag = obs_headElem_i(obsSpaceData, OBS_INFG, headerIndex)
6090 actualNumChannel = tvs_coefs(sensorIndex)%coef%fmv_ori_nchn
6091
6092 ! Allocation
6093 allocate(lflagchn(actualNumChannel))
6094
6095 lflagchn(:) = qcRejectLogic(:) ! initialize with flags set in mwbg_firstQcCheckMwhs2
6096 allcnt = allcnt + 1 ! Counting total number of observations
6097 ! Reject all channels if gross Tb error detected in any channel or other problems
6098 if ( grossrej ) then
6099 lflagchn(:) = .true.
6100 else
6101
6102 ! OVER LAND OR SEA-ICE,
6103 ! -- CLW/SI not determined over land
6104 ! -- surface emissivity effects lower tropospheric and window channels
6105 ! -- reject window & lower tropospheric channels 1,10,14,15
6106 ! -- reject ch. 11-13 if iwvreject = .true. [ Mean 183 Ghz [ch. 18-22] Tb < 240K ]
6107 ! -- check DI for AMSU-B like channels
6108 ! -- reject all channels if scatbg exceeds CMC thresholds for AMSU-B
6109
6110 if ( .not. waterobs ) then
6111 lflagchn((/ 1,10,14,15 /)) = .true. ! AMSU-B (like 1,2,5)
6112 if ( iwvreject ) lflagchn(11:13) = .true. ! AMSU-B (like 4,3)
6113
6114 ! Dryness index (for AMSU-B channels 11-14 assimilated over land/sea-ice)
6115 ! Channel AMSUB-3 (MWHS-2 channel 11) is rejected for a dryness index > 0.
6116 ! (MWHS-2 channel 12) is rejected for a dryness index > -5.
6117 ! Channel AMSUB-4 (MWHS-2 channel 13) is rejected for a dryness index > -8.
6118 if ( zdi > 0.0d0 ) then
6119 lflagchn(11) = .true.
6120 newInformationFlag = IBSET(newInformationFlag,7)
6121 end if
6122 if ( zdi > -5.0d0 ) then
6123 lflagchn(12) = .true.
6124 newInformationFlag = IBSET(newInformationFlag,9)
6125 drycnt = drycnt + 1
6126 end if
6127 if ( zdi > -8.0d0 ) then
6128 lflagchn(13) = .true.
6129 end if
6130
6131 ! Bennartz -Grody SI check thresholds (same as for QC of AMSU-B/MHS)
6132 if ( calcTerrainTypeIndice == 0 ) then ! sea-ice
6133 scatbg_rej = scatbg_mwhs2_cmc_ICErej
6134 else ! land
6135 scatbg_rej = scatbg_mwhs2_cmc_LANDrej
6136 end if
6137 if ( scatbg > scatbg_rej ) then
6138 lflagchn(:) = .true.
6139 newInformationFlag = IBSET(newInformationFlag,8)
6140 end if
6141
6142 else ! if waterobs
6143
6144 ! OVER WATER,
6145 !-----------------------------------------------------------------
6146 ! PLACEHOLDER VALUES FOR ALLSKY ASSIM, SINCE NOT IMPLEMENTED YET
6147 ! in clear-sky mode:
6148 ! -- reject ch. 1, if CLW > clw_mwhs2_nrl_LTrej or CLW = mwbg_realMissing
6149 ! in all-sky mode:
6150 ! -- reject ch. 1, if CLW > mwbg_clwQcThreshold or CLW = mwbg_realMissing
6151 !-----------------------------------------------------------------
6152 ! -- reject ch. 1, 10, 13-15 if CLW > clw_mwhs2_nrl_LTrej
6153 ! -- reject ch. 11-12 if CLW > clw_mwhs2_nrl_UTrej
6154 ! -- reject ch. 1, 10-15 if scatec > 9 or scatec = mwbg_realMissing
6155 ! -- reject ch. 1, 10-15 if iwvreject = .true. [ Mean 183 Ghz [ch. 11-15] Tb < 240K ]
6156 ! -- reject all channels if scatbg exceeds CMC SEA threshold for AMSU-B
6157
6158 if ( cloudLiquidWaterPathObs > clw_mwhs2_nrl_LTrej ) then
6159 if ( tvs_mwAllskyAssim ) then ! NEVER TRUE SINCE NOT IMPLEMENTED YET
6160 clwObsFGaveraged = 0.5d0 * (cloudLiquidWaterPathObs + cloudLiquidWaterPathFG)
6161 if ( clwObsFGaveraged > mwbg_clwQcThreshold ) lflagchn(1) = .true.
6162 else
6163 lflagchn(1) = .true.
6164 end if
6165 lflagchn((/ 10,13,14,15 /)) = .true.
6166 end if
6167 if ( cloudLiquidWaterPathObs > clw_mwhs2_nrl_UTrej ) then
6168 lflagchn(11:12) = .true.
6169 end if
6170 if ( scatec > scatec_mwhs2_nrl_LTrej ) then
6171 lflagchn(1) = .true.
6172 lflagchn(10:15) = .true.
6173 end if
6174 if ( iwvreject ) then
6175 lflagchn(1) = .true.
6176 lflagchn(10:15) = .true.
6177 end if
6178 if ( riwv == mwbg_realMissing ) then ! riwv = mean_Tb_183Ghz
6179 newInformationFlag = IBSET(newInformationFlag,1)
6180 lflagchn(1) = .true.
6181 lflagchn(10:15) = .true.
6182 end if
6183 ! Bennartz-Grody SI check thresholds (same as for QC of AMSU-B/MHS)
6184 if ( scatbg > scatbg_mwhs2_cmc_SEA ) then
6185 lflagchn(:) = .true.
6186 newInformationFlag = IBSET(newInformationFlag,8)
6187 end if
6188 end if ! if waterobs
6189
6190 end if ! if .not. grossrej
6191
6192 if ( .not. waterobs ) landcnt = landcnt + 1
6193 if ( grossrej ) rejcnt = rejcnt + 1
6194 if ( iwvreject) iwvcnt = iwvcnt + 1
6195 if ( precipobs .and. waterobs ) then
6196 pcpcnt = pcpcnt + 1
6197 end if
6198
6199 if ( ANY(lflagchn(:)) ) flgcnt = flgcnt + 1
6200
6201 ! RESET scatIndexOverWaterObs array to Bennartz-Grody scattering index for output to BURP file
6202 scatIndexOverWaterObs = scatbg
6203 ! Set missing cloudLiquidWaterPathFG and scatIndexOverWaterFG to BURP missing value (mwbg_realMissing)
6204 if (cloudLiquidWaterPathObs == mwbg_realMissing) cloudLiquidWaterPathFG = mwbg_realMissing
6205 scatIndexOverWaterFG = mwbg_realMissing
6206
6207 ! Modify data flag values (set bit 7) for rejected data
6208 ! In all-sky mode, turn on bit=23 for channels in chanIgnoreInAllskyGenCoeff(:)
6209 ! as cloud-affected radiances over sea when there is mismatch between
6210 ! cloudLiquidWaterPathObs and cloudLiquidWaterPathFG (to be used in gen_bias_corr)
6211 bodyIndexBeg = obs_headElem_i(obsSpaceData, OBS_RLN, headerIndex)
6212 bodyIndexEnd = bodyIndexBeg + obs_headElem_i(obsSpaceData, OBS_NLV, headerIndex) - 1
6213 clwObsFGaveraged = 0.5d0 * (cloudLiquidWaterPathObs + cloudLiquidWaterPathFG)
6214 BODY: do bodyIndex = bodyIndexBeg, bodyIndexEnd
6215 obsChanNumWithOffset = nint(obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex))
6216 obsChanNum = obsChanNumWithOffset - tvs_channelOffset(sensorIndex)
6217 obsFlags = obs_bodyElem_i(obsSpaceData, OBS_FLG, bodyIndex)
6218
6219 if (lflagchn(obsChanNum)) obsFlags = IBSET(obsFlags,7)
6220
6221 INDXCAN = utl_findloc(chanIgnoreInAllskyGenCoeff(:),obsChanNumWithOffset)
6222 if (tvs_mwAllskyAssim .and. waterobs .and. INDXCAN /= 0 .and. &
6223 (clwObsFGaveraged > mwbg_cloudyClwThresholdBcorr .or. &
6224 cloudLiquidWaterPathObs == mwbg_realMissing .or. &
6225 cloudLiquidWaterPathFG == mwbg_realMissing)) then
6226 obsFlags = IBSET(obsFlags,23)
6227 end if
6228
6229 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex, obsFlags)
6230 end do BODY
6231
6232 ! Set bit 6 in 24-bit global flags if any data rejected
6233 if ( ANY(lflagchn(:)) ) then
6234 obsGlobalMarker = obs_headElem_i(obsSpaceData, OBS_ST1, headerIndex)
6235 obsGlobalMarker = IBSET(obsGlobalMarker,6)
6236 call obs_headSet_i(obsSpaceData, OBS_ST1, headerIndex, obsGlobalMarker)
6237 end if
6238
6239 codtyp = obs_headElem_i(obsSpaceData, OBS_ITY, headerIndex)
6240 call obs_headSet_r(obsSpaceData, OBS_CLWO, headerIndex, cloudLiquidWaterPathObs)
6241 call obs_headSet_r(obsSpaceData, OBS_CLWB, headerIndex, cloudLiquidWaterPathFG)
6242 call obs_headSet_i(obsSpaceData, OBS_INFG, headerIndex, newInformationFlag)
6243
6244 if (scatIndexOverWaterObs /= mwbg_realMissing) then
6245 call obs_headSet_r(obsSpaceData, OBS_SIO, headerIndex, scatIndexOverWaterObs)
6246 else
6247 call obs_headSet_r(obsSpaceData, OBS_SIO, headerIndex, MPC_missingValue_R8)
6248 end if
6249
6250 if (tvs_isInstrumAllskyHuAssim(tvs_getInstrumentId(codtyp_get_name(codtyp)))) then
6251 if (scatIndexOverWaterFG /= mwbg_realMissing) then
6252 call obs_headSet_r(obsSpaceData, OBS_SIB, headerIndex, scatIndexOverWaterFG)
6253 else
6254 call obs_headSet_r(obsSpaceData, OBS_SIB, headerIndex, MPC_missingValue_R8)
6255 end if
6256 end if
6257
6258 end subroutine mwbg_reviewAllCritforFinalFlagsMwhs2
6259
6260 !--------------------------------------------------------------------------
6261 ! calcStateDepObsErr
6262 !--------------------------------------------------------------------------
6263 function calcStateDepObsErr(cldPredThresh1, cldPredThresh2, &
6264 errThresh1, errThresh2, cldPredUsed) result(sigmaObsErrUsed)
6265 !
6266 !:Purpose: Calculate single-precision state-dependent observation error.
6267 !
6268 implicit none
6269
6270 ! Arguments:
6271 real(8), intent(in) :: cldPredThresh1 ! first cloud predictor threshold
6272 real(8), intent(in) :: cldPredThresh2 ! second cloud predictor threshold
6273 real(8), intent(in) :: errThresh1 ! sigmaO corresponding to first cloud predictor threshold
6274 real(8), intent(in) :: errThresh2 ! sigmaO corresponding to second cloud predictor threshold
6275 real(8), intent(in) :: cldPredUsed ! cloud predictor for the obs
6276 ! Result:
6277 real(8) :: sigmaObsErrUsed ! estimated sigmaO for the obs
6278
6279 if (cldPredUsed <= cldPredThresh1) then
6280 sigmaObsErrUsed = errThresh1
6281 else if (cldPredUsed > cldPredThresh1 .and. &
6282 cldPredUsed <= cldPredThresh2) then
6283 sigmaObsErrUsed = errThresh1 + &
6284 (errThresh2 - errThresh1) / &
6285 (cldPredThresh2 - cldPredThresh1) * &
6286 (cldPredUsed - cldPredThresh1)
6287 else
6288 sigmaObsErrUsed = errThresh2
6289 end if
6290
6291 end function calcStateDepObsErr
6292
6293 !--------------------------------------------------------------------------
6294 ! ifTovsExist
6295 !--------------------------------------------------------------------------
6296 function ifTovsExist(headerIndex, sensorIndex, obsSpaceData) result(sensorIndexFound)
6297 !
6298 !:Purpose: Check obs is among the sensors.
6299 !
6300 implicit None
6301
6302 ! Arguments:
6303 integer, intent(in) :: headerIndex ! current header Index
6304 integer, intent(out) :: sensorIndex ! find tvs_sensor index corresponding to current obs
6305 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
6306 ! Result:
6307 logical :: sensorIndexFound
6308
6309 ! Locals:
6310 integer :: iplatform, instrum, isat, iplatf, instr
6311
6312 ! find tvs_sensor index corresponding to current obs
6313 iplatf = obs_headElem_i( obsSpaceData, OBS_SAT, headerIndex )
6314 instr = obs_headElem_i( obsSpaceData, OBS_INS, headerIndex )
6315
6316 call tvs_mapSat( iplatf, iplatform, isat )
6317 call tvs_mapInstrum( instr, instrum )
6318
6319 sensorIndexFound = .false.
6320 do sensorIndex =1, tvs_nsensors
6321 if ( iplatform == tvs_platforms(sensorIndex) .and. &
6322 isat == tvs_satellites(sensorIndex) .and. &
6323 instrum == tvs_instruments(sensorIndex) ) then
6324 sensorIndexFound = .true.
6325 exit
6326 end if
6327 end do
6328
6329 end function ifTovsExist
6330
6331 !--------------------------------------------------------------------------
6332 ! mwbg_mwbg_bgCheckMW
6333 !--------------------------------------------------------------------------
6334 subroutine mwbg_bgCheckMW( obsSpaceData )
6335 !
6336 !:Purpose: Do the quality control for ATMS, AMSUA, AMSUB and MWHS2
6337 !
6338 implicit None
6339
6340 ! Arguments:
6341 type(struct_obs), intent(inout) :: obsSpaceData ! obspaceData Object
6342
6343 ! Locals:
6344 integer :: headerIndex ! header Index
6345 integer :: sensorIndex ! satellite index in obserror file
6346 integer :: codtyp ! codetype
6347 real(8) :: modelInterpTerrain ! topo in standard file interpolated to obs point
6348 real(8) :: modelInterpSeaIce ! Glace de mer " "
6349 real(8) :: modelInterpLandFrac ! model interpolated land fraction
6350 integer, allocatable :: qcIndicator(:) ! indicateur controle de qualite tovs par canal
6351 ! =0 ok, >0 rejet,
6352 integer, external :: exdb, exfin, fnom, fclos
6353 logical :: mwDataPresent, sensorIndexFound
6354 logical :: lastHeader ! active while reading last report
6355
6356 call utl_tmg_start(118,'--BgckMicrowave')
6357 mwDataPresent = .false.
6358 call obs_set_current_header_list(obsSpaceData,'TO')
6359 HEADER0: do
6360 headerIndex = obs_getHeaderIndex(obsSpaceData)
6361 if (headerIndex < 0) exit HEADER0
6362 codtyp = obs_headElem_i(obsSpaceData, OBS_ITY, headerIndex)
6363 if ( tvs_isIdBurpInst(codtyp,'atms' ) .or. &
6364 tvs_isIdBurpInst(codtyp,'amsua') .or. &
6365 tvs_isIdBurpInst(codtyp,'amsub') .or. &
6366 tvs_isIdBurpInst(codtyp,'mwhs2') .or. &
6367 tvs_isIdBurpInst(codtyp,'mhs' ) ) then
6368 mwDataPresent = .true.
6369 end if
6370 end do HEADER0
6371
6372 if ( .not. mwDataPresent ) then
6373 write(*,*) 'WARNING: WILL NOT RUN mwbg_bgCheckMW since no ATMS or AMSUA or MWHS2'
6374 return
6375 end if
6376
6377 write(*,*) ' MWBG QC PROGRAM STARTS ....'
6378 ! read nambgck
6379 call mwbg_init()
6380
6381 !Quality Control loop over all observations
6382 !
6383 ! loop over all header indices of the specified family with surface obs
6384 lastHeader = .false.
6385
6386 call obs_set_current_header_list(obsSpaceData,'TO')
6387 HEADER: do
6388 headerIndex = obs_getHeaderIndex(obsSpaceData)
6389 if (headerIndex < 0) exit HEADER
6390 if (headerIndex == obs_numHeader(obsSpaceData)) lastHeader = .true.
6391 codtyp = obs_headElem_i(obsSpaceData, OBS_ITY, headerIndex)
6392 if (instName== 'AMSUB') then
6393 if ( .not. tvs_isIdBurpInst(codtyp,'amsub') .and. &
6394 .not. tvs_isIdBurpInst(codtyp,'mhs' ) .and. &
6395 .not. tvs_isIdBurpInst(codtyp,'mwhs2') ) then
6396 write(*,*) 'WARNING: Observation with codtyp = ', codtyp, ' is not ', instName
6397 cycle HEADER
6398 end if
6399 else
6400 if ( .not. (tvs_isIdBurpInst(codtyp,instName)) ) then
6401 write(*,*) 'WARNING: Observation with codtyp = ', codtyp, ' is not ', instName
6402 cycle HEADER
6403 end if
6404 end if
6405
6406 sensorIndexFound = ifTovsExist(headerIndex, sensorIndex, obsSpaceData)
6407 if ( .not. sensorIndexFound ) call utl_abort('midas-bgckMW: sensor Index not found')
6408
6409 ! STEP 1: Interpolation de le champ MX(topogrpahy), MG et GL aux pts TOVS.
6410 call mwbg_readGeophysicFieldsAndInterpolate(instName, modelInterpTerrain, &
6411 modelInterpLandFrac, modelInterpSeaIce, &
6412 headerIndex, obsSpaceData)
6413
6414 ! STEP 2: Controle de qualite des TOVS. Data QC flags (obsFlags) are modified here!
6415 if (instName == 'AMSUA') then
6416 call mwbg_tovCheckAmsua(qcIndicator, sensorIndex, modelInterpLandFrac, modelInterpTerrain, &
6417 modelInterpSeaIce, RESETQC, headerIndex, obsSpaceData)
6418
6419 else if (instName == 'AMSUB') then
6420 call mwbg_tovCheckAmsub(qcIndicator, sensorIndex, modelInterpLandFrac, modelInterpTerrain, &
6421 modelInterpSeaIce, RESETQC, headerIndex, obsSpaceData)
6422
6423 else if (instName == 'ATMS') then
6424 call mwbg_tovCheckAtms(qcIndicator, sensorIndex, modelInterpTerrain, &
6425 RESETQC, headerIndex, obsSpaceData)
6426
6427 else if (instName == 'MWHS2') then
6428 call mwbg_tovCheckMwhs2(qcIndicator, sensorIndex, modelInterpTerrain, &
6429 RESETQC, modLSQ, lastHeader, headerIndex, obsSpaceData)
6430
6431 else
6432 write(*,*) 'midas-bgckMW: instName = ', instName
6433 call utl_abort('midas-bgckMW: unknown instName')
6434 end if
6435
6436 ! STEP 3: Accumuler Les statistiques sur les rejets
6437 call mwbg_qcStats(instName, qcIndicator, sensorIndex, &
6438 tvs_satelliteName(1:tvs_nsensors), .FALSE.)
6439 end do HEADER
6440
6441 ! STEP 4: Print the statistics in listing file
6442 call mwbg_qcStats(instName, qcIndicator, sensorIndex, &
6443 tvs_satelliteName(1:tvs_nsensors), .TRUE.)
6444
6445 call utl_tmg_stop(118)
6446
6447 end subroutine mwbg_bgCheckMW
6448
6449end module bgckMicrowave_mod
