1module thinning_mod
2 ! MODULE thinning_mod (prefix='thn' category='1. High-level functionality')
3 !
4 !:Purpose: Using observation-type-specific algorithms, set bit 11 of 'flag'
5 ! on data that are not to be assimilated.
6 !
7 !:Note: This module is intended to group all of the thinning methods in a
8 ! single fortran module.
9 !
10 use midasMpi_mod
11 use bufr_mod
12 use mathPhysConstants_mod
13 use earthConstants_mod
14 use obsSpaceData_mod
15 use horizontalCoord_mod
16 use verticalCoord_mod
17 use timeCoord_mod
18 use gridStateVector_mod
19 use gridStateVectorFileIO_mod
20 use codtyp_mod
21 use physicsFunctions_mod
22 use utilities_mod
23 use kdTree2_mod
24 implicit none
25 private
26
27 public :: thn_thinHyper, thn_thinTovs, thn_thinCSR
28 public :: thn_thinRaobs, thn_thinAircraft, thn_thinScat, thn_thinSatWinds
29 public :: thn_thinSurface, thn_thinGbGps, thn_thinGpsRo, thn_thinAladin
30 public :: thn_thinSatSST
31 integer, external :: get_max_rss
32
33contains
34
35 !--------------------------------------------------------------------------
36 ! thn_thinSurface
37 !--------------------------------------------------------------------------
38 subroutine thn_thinSurface(obsdat, obsFamily)
39 !
40 !:Purpose: Main subroutine for thinning of surface obs.
41 !
42 implicit none
43
44 ! Arguments:
45 type(struct_obs), intent(inout) :: obsdat
46 character(len=2), intent(in) :: obsFamily
47
48 ! Locals:
49 integer :: nulnam
50 integer :: fnom, fclos, ierr
51
52 ! Namelist variables:
53 logical :: doThinning ! if false, we return immediately
54 real(8) :: step ! time resolution (in hours)
55 integer :: deltmax ! maximum time difference (in minutes)
56 logical :: useBlackList ! signal if blacklist file should be read and used
57 logical :: considerSHIPstnID ! signal if SHIP stn ID should be considered in thinning
58
59 namelist /thin_surface/doThinning, step, deltmax, useBlackList, considerSHIPstnID
60
61 ! set default values for namelist variables
62 doThinning = .false.
63 step = 6.0d0
64 deltmax = 90
65 useBlackList = .false.
66 considerSHIPstnID = .true.
67
68 ! return if no surface obs
69 if (.not. obs_famExist(obsdat, obsFamily)) return
70
71 ! Read the namelist for Surface observations (if it exists)
72 if (utl_isNamelistPresent('thin_surface', './flnml')) then
73 nulnam = 0
74 ierr = fnom(nulnam, './flnml','FTN+SEQ+R/O', 0)
75 if (ierr /= 0) call utl_abort('thn_thinSurface: Error opening file flnml')
76 read(nulnam,nml = thin_surface, iostat = ierr)
77 if (ierr /= 0) call utl_abort('thn_thinSurface: Error reading namelist')
78 if (mmpi_myid == 0) write(*, nml = thin_surface)
79 ierr = fclos(nulnam)
80 else
81 write(*,*)
82 write(*,*) 'thn_thinSurface: Namelist block thin_surface is missing in the namelist.'
83 write(*,*) ' The default value will be taken.'
84 if (mmpi_myid == 0) write(*, nml = thin_surface)
85 end if
86
87 if (.not. doThinning) return
88
89 call utl_tmg_start(114,'--ObsThinning')
90 call thn_surfaceInTime(obsdat, obsFamily, step, deltmax, useBlackList, considerSHIPstnID)
91 call utl_tmg_stop(114)
92
93 end subroutine thn_thinSurface
94
95 !--------------------------------------------------------------------------
96 ! thn_thinRaobs
97 !--------------------------------------------------------------------------
98 subroutine thn_thinRaobs(obsdat)
99 !
100 !:Purpose: Main thinning subroutine Radiosonde obs.
101 !
102 implicit none
103
104 ! Arguments:
105 type(struct_obs), intent(inout) :: obsdat
106
107 ! Locals:
108 integer :: nulnam
109 integer :: fnom, fclos, ierr
110
111 ! Namelist variables:
112 logical :: verticalThinningES ! choose to do vertical thinning of humidity obs
113 logical :: ecmwfRejetsES ! choose to do filtering of T-Td obs with approach similar to ECMWF
114 real(4) :: toleranceFactor ! Tolerance factor for TAC vs BUFR selection
115
116 namelist /thin_raobs/ verticalThinningES, ecmwfRejetsES, toleranceFactor
117
118 ! return if no aircraft obs
119 if (.not. obs_famExist(obsdat,'UA')) return
120
121 ! Default values for namelist variables
122 verticalThinningES = .true.
123 ecmwfRejetsES = .true.
124 toleranceFactor = 1.4
125
126 ! Read the namelist for Radiosonde observations (if it exists)
127 if (utl_isNamelistPresent('thin_raobs','./flnml')) then
128 nulnam = 0
129 ierr = fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
130 if (ierr /= 0) call utl_abort('thn_thinRaobs: Error opening file flnml')
131 read(nulnam,nml=thin_raobs,iostat=ierr)
132 if (ierr /= 0) call utl_abort('thn_thinRaobs: Error reading thin_raobs namelist')
133 if (mmpi_myid == 0) write(*,nml=thin_raobs)
134 ierr = fclos(nulnam)
135 else
136 write(*,*)
137 write(*,*) 'thn_thinRaobs: Namelist block thin_raobs is missing in the namelist.'
138 write(*,*) ' The default value will be taken.'
139 if (mmpi_myid == 0) write(*,nml=thin_raobs)
140 end if
141
142 call utl_tmg_start(114,'--ObsThinning')
143 call thn_radiosonde(obsdat, verticalThinningES, ecmwfRejetsES, toleranceFactor)
144 call utl_tmg_stop(114)
145
146 end subroutine thn_thinRaobs
147
148 !--------------------------------------------------------------------------
149 ! thn_thinAircraft
150 !--------------------------------------------------------------------------
151 subroutine thn_thinAircraft(obsdat)
152 !
153 !:Purpose: Main thinning subroutine for aircraft obs.
154 !
155 implicit none
156
157 ! Arguments:
158 type(struct_obs), intent(inout) :: obsdat
159
160 ! Locals:
161 integer :: nulnam
162 integer :: fnom, fclos, ierr
163
164 ! Namelist variables:
165 integer :: deltmax ! maximum time difference (in minutes)
166
167 namelist /thin_aircraft/deltmax
168
169 ! return if no aircraft obs
170 if (.not. obs_famExist(obsdat,'AI')) return
171
172 ! Default values for namelist variables
173 deltmax = 90
174
175 ! Read the namelist for Aircraft observations (if it exists)
176 if (utl_isNamelistPresent('thin_aircraft','./flnml')) then
177 nulnam = 0
178 ierr = fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
179 if (ierr /= 0) call utl_abort('thn_thinAircraft: Error opening file flnml')
180 read(nulnam,nml=thin_aircraft,iostat=ierr)
181 if (ierr /= 0) call utl_abort('thn_thinAircraft: Error reading thin_aircraft namelist')
182 if (mmpi_myid == 0) write(*,nml=thin_aircraft)
183 ierr = fclos(nulnam)
184 else
185 write(*,*)
186 write(*,*) 'thn_thinAircraft: Namelist block thin_aircraft is missing in the namelist.'
187 write(*,*) ' The default value will be taken.'
188 if (mmpi_myid == 0) write(*,nml=thin_aircraft)
189 end if
190
191 call utl_tmg_start(114,'--ObsThinning')
192 call thn_aircraftByBoxes(obsdat, 'AI', deltmax)
193 call utl_tmg_stop(114)
194
195 end subroutine thn_thinAircraft
196
197 !--------------------------------------------------------------------------
198 ! thn_thinSatWinds
199 !--------------------------------------------------------------------------
200 subroutine thn_thinSatWinds(obsdat)
201 !
202 !:Purpose: Main thinning subroutine for satellite winds (AMVs).
203 !
204 implicit none
205
206 ! Arguments:
207 type(struct_obs), intent(inout) :: obsdat
208
209 ! Locals:
210 integer :: nulnam
211 integer :: fnom, fclos, ierr
212
213 ! Namelist variables:
214 integer :: deltemps ! number of time bins between adjacent observations
215 integer :: deldist ! minimal distance in km between adjacent observations
216
217 namelist /thin_satwind/deltemps, deldist
218
219 ! return if no satwind obs
220 if (.not. obs_famExist(obsdat,'SW')) return
221
222 ! Default values for namelist variables
223 deltemps = 6
224 deldist = 200
225
226 ! Read the namelist for SatWinds observations (if it exists)
227 if (utl_isNamelistPresent('thin_satwind','./flnml')) then
228 nulnam = 0
229 ierr = fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
230 if (ierr /= 0) call utl_abort('thn_thinSatWinds: Error opening file flnml')
231 read(nulnam,nml=thin_satwind,iostat=ierr)
232 if (ierr /= 0) call utl_abort('thn_thinSatWinds: Error reading thin_satwind namelist')
233 if (mmpi_myid == 0) write(*,nml=thin_satwind)
234 ierr = fclos(nulnam)
235 else
236 write(*,*)
237 write(*,*) 'thn_thinSatWinds: Namelist block thin_satwind is missing in the namelist.'
238 write(*,*) ' The default value will be taken.'
239 if (mmpi_myid == 0) write(*,nml=thin_satwind)
240 end if
241
242 call utl_tmg_start(114,'--ObsThinning')
243 call thn_satWindsByDistance(obsdat, 'SW', deltemps, deldist)
244 call utl_tmg_stop(114)
245
246 end subroutine thn_thinSatWinds
247
248 !--------------------------------------------------------------------------
249 ! thn_thinGpsRo
250 !--------------------------------------------------------------------------
251 subroutine thn_thinGpsRo(obsdat)
252 !
253 !:Purpose: Main thinning subroutine GPS radio-occultation obs.
254 !
255 implicit none
256
257 ! Arguments:
258 type(struct_obs), intent(inout) :: obsdat
259
260 ! Locals:
261 integer :: nulnam
262 integer :: fnom, fclos, ierr
263
264 ! Namelist variables:
265 real(8) :: heightMin ! niveau a partir du quel on accepte les donnees
266 real(8) :: heightMax ! niveau a partir du quel on rejette les donnees
267 real(8) :: heightSpacing ! epaisseur minimale entre deux niveaux
268 integer :: gpsroVarNo ! bufr element id to be used
269
270 namelist /thin_gpsro/heightMin, heightMax, heightSpacing, gpsroVarNo
271
272 ! return if no gb-gps obs
273 if (.not. obs_famExist(obsdat,'RO')) return
274
275 ! Default values for namelist variables
276 heightMin = 1000.0d0
277 heightMax = 40000.0d0
278 heightSpacing = 750.0d0
279 gpsroVarNo = BUFR_NERF ! default is refractivity
280
281 ! Read the namelist for GpsRo observations (if it exists)
282 if (utl_isNamelistPresent('thin_gpsro','./flnml')) then
283 nulnam = 0
284 ierr = fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
285 if (ierr /= 0) call utl_abort('thn_thinGpsRo: Error opening file flnml')
286 read(nulnam,nml=thin_gpsro,iostat=ierr)
287 if (ierr /= 0) call utl_abort('thn_thinGpsRo: Error reading thin_gpsro namelist')
288 if (mmpi_myid == 0) write(*,nml=thin_gpsro)
289 ierr = fclos(nulnam)
290 else
291 write(*,*)
292 write(*,*) 'thn_thinGpsRo: Namelist block thin_gpsro is missing in the namelist.'
293 write(*,*) ' The default value will be taken.'
294 if (mmpi_myid == 0) write(*,nml=thin_gpsro)
295 end if
296
297 call utl_tmg_start(114,'--ObsThinning')
298 call thn_gpsroVertical(obsdat, heightMin, heightMax, heightSpacing, gpsroVarNo)
299 call utl_tmg_stop(114)
300
301 end subroutine thn_thinGpsRo
302
303 !--------------------------------------------------------------------------
304 ! thn_thinGbGps
305 !--------------------------------------------------------------------------
306 subroutine thn_thinGbGps(obsdat)
307 !
308 !:Purpose: Main thinning subroutine ground-based GPS obs.
309 !
310 implicit none
311
312 ! Arguments:
313 type(struct_obs), intent(inout) :: obsdat
314
315 ! Locals:
316 integer :: nulnam
317 integer :: fnom, fclos, ierr
318
319 ! Namelist variables:
320 integer :: deltemps ! number of time bins between adjacent observations
321 integer :: deldist ! minimal distance in km between adjacent observations
322 logical :: removeUncorrected ! remove obs that are not bias corrected (bit 6)
323 logical :: rejectNoZTDScore ! reject GB-GPS obs if no ZTD quality score available
324
325 namelist /thin_gbgps/deltemps, deldist, rejectNoZTDScore, removeUncorrected
326
327 ! return if no gb-gps obs
328 if (.not. obs_famExist(obsdat,'GP')) return
329
330 ! Default values for namelist variables
331 deltemps = 8
332 deldist = 50
333 removeUncorrected = .false.
334 rejectNoZTDScore = .false.
335
336 ! Read the namelist for GbGps observations (if it exists)
337 if (utl_isNamelistPresent('thin_gbgps','./flnml')) then
338 nulnam = 0
339 ierr = fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
340 if (ierr /= 0) call utl_abort('thn_thinGbGps: Error opening file flnml')
341 read(nulnam,nml=thin_gbgps,iostat=ierr)
342 if (ierr /= 0) call utl_abort('thn_thinGbGps: Error reading thin_gbgps namelist')
343 if (mmpi_myid == 0) write(*,nml=thin_gbgps)
344 ierr = fclos(nulnam)
345 else
346 write(*,*)
347 write(*,*) 'thn_thinGbGps: Namelist block thin_gbgps is missing in the namelist.'
348 write(*,*) ' The default value will be taken.'
349 if (mmpi_myid == 0) write(*,nml=thin_gbgps)
350 end if
351
352 call utl_tmg_start(114,'--ObsThinning')
353 call thn_gbgpsByDistance(obsdat, deltemps, deldist, removeUncorrected, rejectNoZTDScore)
354 call utl_tmg_stop(114)
355
356 end subroutine thn_thinGbGps
357
358 !--------------------------------------------------------------------------
359 ! thn_thinAladin
360 !--------------------------------------------------------------------------
361 subroutine thn_thinAladin(obsdat)
362 !
363 !:Purpose: Main thinning subroutine for Aladin winds obs.
364 !
365 implicit none
366
367 ! Arguments:
368 type(struct_obs), intent(inout) :: obsdat
369
370 ! Locals:
371 integer :: nulnam
372 integer :: fnom, fclos, ierr
373
374 ! Namelist variables:
375 integer :: keepNthVertical ! keep every nth vertical datum
376
377 namelist /thin_aladin/keepNthVertical
378
379 ! return if no Aladin obs
380 if (.not. obs_famExist(obsdat,'AL')) return
381
382 ! Default values for namelist variables
383 keepNthVertical=-1
384
385 ! Read the namelist for Aladin observations (if it exists)
386 if (utl_isNamelistPresent('thin_aladin','./flnml')) then
387 nulnam = 0
388 ierr = fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
389 if (ierr /= 0) call utl_abort('thn_thinAladin: Error opening file flnml')
390 read(nulnam,nml=thin_aladin,iostat=ierr)
391 if (ierr /= 0) call utl_abort('thn_thinAladin: Error reading thin_aladin namelist')
392 if (mmpi_myid == 0) write(*,nml=thin_aladin)
393 ierr = fclos(nulnam)
394 else
395 write(*,*)
396 write(*,*) 'thn_thinAladin: Namelist block thin_aladin is missing in the namelist.'
397 write(*,*) ' The default value will be taken.'
398 if (mmpi_myid == 0) write(*,nml=thin_aladin)
399 end if
400
401 if (keepNthVertical > 0) then
402 call utl_tmg_start(114,'--ObsThinning')
403 call thn_keepNthObs(obsdat, 'AL', keepNthVertical)
404 call utl_tmg_stop(114)
405 end if
406
407 end subroutine thn_thinAladin
408
409 !--------------------------------------------------------------------------
410 ! thn_thinCSR
411 !--------------------------------------------------------------------------
412 subroutine thn_thinCSR(obsdat)
413 !
414 !:Purpose: Main thinning subroutine for geostationary radiances (CSR).
415 !
416 implicit none
417
418 ! Arguments:
419 type(struct_obs), intent(inout) :: obsdat
420
421 ! Locals:
422 integer :: nulnam
423 integer :: fnom, fclos, ierr
424
425 ! Namelist variables:
426 integer :: deltax ! thinning (dimension of box sides) (in km)
427 integer :: deltrad ! radius around box center for chosen obs (in km)
428
429 namelist /thin_csr/deltax, deltrad
430
431 ! return if no TOVS obs
432 if (.not. obs_famExist(obsdat,'TO')) return
433
434 ! Default namelist values
435 deltax = 150
436 deltrad = 45
437
438 ! Read the namelist for CSR observations (if it exists)
439 if (utl_isNamelistPresent('thin_csr','./flnml')) then
440 nulnam = 0
441 ierr = fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
442 if (ierr /= 0) call utl_abort('thn_thinCSR: Error opening file flnml')
443 read(nulnam,nml=thin_csr,iostat=ierr)
444 if (ierr /= 0) call utl_abort('thn_thinCSR: Error reading thin_csr namelist')
445 if (mmpi_myid == 0) write(*,nml=thin_csr)
446 ierr = fclos(nulnam)
447 else
448 write(*,*)
449 write(*,*) 'thn_thinCSR: Namelist block thin_csr is missing in the namelist.'
450 write(*,*) ' The default value will be taken.'
451 if (mmpi_myid == 0) write(*,nml=thin_csr)
452 end if
453
454 write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
455 call utl_tmg_start(114,'--ObsThinning')
456 call thn_csrByLatLonBoxes(obsdat, deltax, deltrad)
457 call utl_tmg_stop(114)
458 write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
459
460 end subroutine thn_thinCSR
461
462 !--------------------------------------------------------------------------
463 ! thn_thinScat
464 !--------------------------------------------------------------------------
465 subroutine thn_thinScat(obsdat)
466 !
467 !:Purpose: Main thinning subroutine for scatterometer winds.
468 !
469 implicit none
470
471 ! Arguments:
472 type(struct_obs), intent(inout) :: obsdat
473
474 ! Locals:
475 integer :: nulnam
476 integer :: fnom, fclos, ierr
477
478 ! Namelist variables:
479 integer :: deltax ! thinning (dimension of box sides) (in km)
480 integer :: deltmax ! temporal thinning resolution (in minutes)
481
482 namelist /thin_scat/deltax, deltmax
483
484 ! return if no scat obs
485 if (.not. obs_famExist(obsdat,'SC')) return
486
487 ! Default namelist values
488 deltax = 100
489 deltmax = 90
490
491 ! Read the namelist for Scat observations (if it exists)
492 if (utl_isNamelistPresent('thin_scat','./flnml')) then
493 nulnam = 0
494 ierr = fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
495 if (ierr /= 0) call utl_abort('thn_thinScat: Error opening file flnml')
496 read(nulnam,nml=thin_scat,iostat=ierr)
497 if (ierr /= 0) call utl_abort('thn_thinScat: Error reading thin_scat namelist')
498 if (mmpi_myid == 0) write(*,nml=thin_scat)
499 ierr = fclos(nulnam)
500 else
501 write(*,*)
502 write(*,*) 'thn_thinScat: Namelist block thin_scat is missing in the namelist.'
503 write(*,*) ' The default value will be taken.'
504 if (mmpi_myid == 0) write(*,nml=thin_scat)
505 end if
506
507 write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
508 call utl_tmg_start(114,'--ObsThinning')
509 call thn_scatByLatLonBoxes(obsdat, deltax, deltmax)
510 call utl_tmg_stop(114)
511 write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
512
513 end subroutine thn_thinScat
514
515 !--------------------------------------------------------------------------
516 ! thn_thinTovs
517 !--------------------------------------------------------------------------
518 subroutine thn_thinTovs(obsdat)
519 !
520 !:Purpose: Main thinning subroutine for AMSU and ATMS obs.
521 !
522 implicit none
523
524 ! Arguments:
525 type(struct_obs), intent(inout) :: obsdat
526
527 ! Locals:
528 integer :: nulnam
529 integer :: fnom, fclos, ierr
530
531 ! Namelist variables:
532 integer :: delta ! thinning (dimension of box sides) (in km)
533 integer :: deltrad ! radius around box center for chosen obs (in km)
534
535 namelist /thin_tovs/delta, deltrad
536
537 ! return if no TOVS obs
538 if (.not. obs_famExist(obsdat,'TO')) return
539
540 ! Default namelist values
541 delta = 100
542 deltrad = 75
543
544 ! Read the namelist for TOVS observations (if it exists)
545 if (utl_isNamelistPresent('thin_tovs','./flnml')) then
546 nulnam = 0
547 ierr = fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
548 if (ierr /= 0) call utl_abort('thn_thinTovs: Error opening file flnml')
549 read(nulnam,nml=thin_tovs,iostat=ierr)
550 if (ierr /= 0) call utl_abort('thn_thinTovs: Error reading thin_tovs namelist')
551 if (mmpi_myid == 0) write(*,nml=thin_tovs)
552 ierr = fclos(nulnam)
553 else
554 write(*,*)
555 write(*,*) 'thn_thinTovs: Namelist block thin_tovs is missing in the namelist.'
556 write(*,*) ' The default value will be taken.'
557 if (mmpi_myid == 0) write(*,nml=thin_tovs)
558 end if
559
560 call utl_tmg_start(114,'--ObsThinning')
561 write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
562 call thn_tovsFilt(obsdat, delta, deltrad, codtyp_get_codtyp('amsua'))
563 write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
564 call thn_tovsFilt(obsdat, delta, deltrad, codtyp_get_codtyp('amsub'), &
565 codtyp2_opt=codtyp_get_codtyp('mhs'))
566 write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
567 call thn_tovsFilt(obsdat, delta, deltrad, codtyp_get_codtyp('atms'))
568 write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
569 call thn_tovsFilt(obsdat, delta, deltrad, codtyp_get_codtyp('mwhs2'))
570 write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
571 call thn_tovsFilt(obsdat, delta, deltrad, codtyp_get_codtyp('ssmis'))
572 write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
573 call utl_tmg_stop(114)
574
575 end subroutine thn_thinTovs
576
577 !--------------------------------------------------------------------------
578 ! thn_thinHyper
579 !--------------------------------------------------------------------------
580 subroutine thn_thinHyper(obsdat)
581 !
582 !:Purpose: Main thinning subroutine for hyperspectral infrared radiances.
583 !
584 implicit none
585
586 ! Arguments:
587 type(struct_obs), intent(inout) :: obsdat
588
589 ! Locals:
590 integer :: nulnam
591 integer :: fnom, fclos, ierr
592
593 ! Namelist variables:
594 logical :: removeUnCorrected ! indicate if obs without bias correction should be removed
595 integer :: deltmax ! time window by bin (from bin center to bin edge) (in minutes)
596 integer :: deltax ! thinning (dimension of box sides) (in km)
597 integer :: deltrad ! radius around box center for chosen obs (in km)
598 namelist /thin_hyper/removeUnCorrected, deltmax, deltax, deltrad
599
600 ! return if no TOVS obs
601 if (.not. obs_famExist(obsdat,'TO')) return
602
603 ! Default namelist values
604 removeUnCorrected = .true.
605 deltmax = 22
606 deltax = 150
607 deltrad = 45
608
609 ! Read the namelist for Aladin observations (if it exists)
610 if (utl_isNamelistPresent('thin_hyper','./flnml')) then
611 nulnam = 0
612 ierr = fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
613 if (ierr /= 0) call utl_abort('thn_thinHyper: Error opening file flnml')
614 read(nulnam,nml=thin_hyper,iostat=ierr)
615 if (ierr /= 0) call utl_abort('thn_thinHyper: Error reading thin_hyper namelist')
616 if (mmpi_myid == 0) write(*,nml=thin_hyper)
617 ierr = fclos(nulnam)
618 else
619 write(*,*)
620 write(*,*) 'thn_thinHyper: Namelist block thin_hyper is missing in the namelist.'
621 write(*,*) ' The default value will be taken.'
622 if (mmpi_myid == 0) write(*,nml=thin_hyper)
623 end if
624
625 call utl_tmg_start(114,'--ObsThinning')
626 write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
627 call thn_hyperByLatLonBoxes(obsdat, removeUnCorrected, deltmax, deltax, deltrad, &
628 'TO', codtyp_get_codtyp('airs'))
629 write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
630 call thn_hyperByLatLonBoxes(obsdat, removeUnCorrected, deltmax, deltax, deltrad, &
631 'TO', codtyp_get_codtyp('iasi'))
632 write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
633 call thn_hyperByLatLonBoxes(obsdat, removeUnCorrected, deltmax, deltax, deltrad, &
634 'TO', codtyp_get_codtyp('cris'))
635 write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
636 call thn_hyperByLatLonBoxes(obsdat, removeUnCorrected, deltmax, deltax, deltrad, &
637 'TO', codtyp_get_codtyp('crisfsr'))
638 write(*,*) 'Memory Used: ',get_max_rss()/1024,'Mb'
639 call utl_tmg_stop(114)
640
641 end subroutine thn_thinHyper
642
643!_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
644!_/
645!_/ The following methods are intended to be general algorithms that may be
646!_/ called by any of the observation-type-specific thinning methods.
647!_/
648!_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
649
650 !--------------------------------------------------------------------------
651 ! thn_surfaceInTime
652 !--------------------------------------------------------------------------
653 subroutine thn_surfaceInTime(obsdat, obsFamily, step, deltmax, &
654 useBlackList, considerSHIPstnID)
655 !
656 !:Purpose: Original method for thinning surface data in time.
657 ! Set bit 11 of OBS_FLG on observations that are to be rejected.
658 !
659 implicit none
660
661 ! Arguments:
662 type(struct_obs), intent(inout) :: obsdat
663 character(len=*), intent(in) :: obsFamily
664 real(8), intent(in) :: step
665 integer, intent(in) :: deltmax
666 logical, intent(in) :: useBlackList
667 logical, intent(in) :: considerSHIPstnID
668
669 ! Local paramters:
670
671 ! Drifter removal parameters:
672 ! Remove incomplete DRIFTER reports (using listEleBadDrifter)?
673 logical, parameter :: removeBadDrifters = .true.
674 ! Minimum required number elements (1 is consistent with bextrep in ops)
675 integer, parameter :: numEleMinBadDrifter = 1
676 ! List of required elements for codtyp 'drifter' (see ops derivate program)
677 integer, parameter :: listEleBadDrifter(5) = (/bufr_nepn, bufr_neds, bufr_nefs, bufr_nets, bufr_sst/)
678
679 ! Selection parameters:
680 integer, parameter :: numListCodtyp = 9 ! number of elements in listCodtyp
681 ! List of codtyps to keep (what about SYNOP mobil? SA+SYNOP?)
682 character(len=13), parameter :: listCodtypName(numListCodtyp) = &
683 (/'synopnonauto', 'asynopauto', 'shipnonauto', 'ashipauto', &
684 'drifter', 'saswobnonauto', 'saswobauto', 'metar', 'satob'/)
685 ! Codtyps to which list_ele_select will be applied
686 integer, parameter :: numListCodtypSelect = 3
687 character(len=13), parameter :: listCodtypNameSelect(numListCodtypSelect) = &
688 (/'metar', 'saswobnonauto', 'saswobauto'/)
689 ! Elements to select (flags for all other elements will have bit 11 set)
690 integer, parameter :: listEleSelect(14) = (/bufr_suWindSpeed, bufr_neps, bufr_nepn, bufr_neds, &
691 bufr_nefs, bufr_neus, bufr_nevs, bufr_nets, &
692 bufr_dewPoint2m, bufr_ness, bufr_vis, &
693 bufr_logVis, bufr_gust, bufr_sst/)
694 ! BlackList parameters:
695 character(len=*), parameter :: blackListFileName = 'blacklist_sf'
696 character(len=6), parameter :: blacklistMode = 'normal'
697 integer, parameter :: numColBlacklist = 5 ! number of columns in blacklist file
698 integer, parameter :: numEleBlacklist = 11 ! number of elements in listEleBlacklist
699 integer, parameter :: listEleBlacklist(numEleBlacklist) = (/bufr_neps, bufr_neps, bufr_nepn, &
700 bufr_nepn, bufr_neds, bufr_nefs, &
701 bufr_neus, bufr_nevs, bufr_nets, &
702 bufr_dewPoint2m, bufr_ness/)
703 integer, parameter :: listColBlackList(numEleBlacklist) = &
704 (/ 1, 2, 1, 2, 5, 5, 5, 5, 3, 4, 4 /)
705
706 ! Locals:
707 integer :: countObsIn, countObsInMpi, countObsOut
708 integer :: countObsInAllMpi(mmpi_nprocs), countObsInMyOffset
709 integer :: numElements, codtyp, obsDateStamp, numStep
710 integer :: listIndex, obsIndex, obsIndex2, headerIndex, bodyIndex, procIndex
711 integer :: ierr, istat, nulfile, numRowBlacklist
712 integer :: elemIndex, rowIndex, colIndex, obsFlag, obsVarNo
713 integer :: rowBlackList(numColBlacklist) ! blacklist work array
714 integer :: countObsInPerCodtyp(numListCodtyp), countObsOutPerCodtyp(numListCodtyp)
715 integer :: numEleInPerCodtyp(numListCodtyp), numEleOutPerCodtyp(numListCodtyp)
716 integer :: numBit8InPerCodtyp(numListCodtyp), numBit8OutPerCodtyp(numListCodtyp)
717 integer :: numBit11InPerCodtyp(numListCodtyp), numBit11OutPerCodtyp(numListCodtyp)
718 integer :: numBit8In, numBit8Out, numBit11In, numBit11Out
719 integer :: numRemovedCodtyp, numRemovedCodTypPriority
720 integer :: numRemovedTime, numRemovedDelt
721 integer :: numEleIn, numEleOut, numRepeat1, numRepeat2, numRemovedDrifter
722 integer, allocatable :: dataBlacklist(:,:) ! blacklist data matrix
723 integer, allocatable :: obsLon(:), obsLat(:), obsDate(:)
724 integer, allocatable :: obsLonMpi(:), obsLatMpi(:)
725 integer, allocatable :: obsTime(:), obsStepIndex(:), obsStepIndexMpi(:)
726 integer, allocatable :: obsCodtypIndex(:), obsDelT(:)
727 integer, allocatable :: obsCodtypIndexMpi(:), obsDelTMpi(:)
728 real(8) :: obsStepIndex_r8, deltaHours
729 logical, allocatable :: valid(:), validMpi(:)
730 character(len=9), allocatable :: obsStnid(:), obsStnidMpi(:), stnidBlacklist(:)
731 integer :: listCodtypSelect(numListCodtypSelect)
732 integer, external :: newdate
733
734 ! Check if any observations to be treated
735 countObsIn = 0
736 call obs_set_current_header_list(obsdat, obsFamily)
737 HEADER0: do
738 headerIndex = obs_getHeaderIndex(obsdat)
739 if (headerIndex < 0) exit HEADER0
740 codtyp = obs_headElem_i(obsdat, OBS_ITY, headerIndex)
741 if (codtyp /= codtyp_get_codtyp('satob')) countObsIn = countObsIn + 1
742 end do HEADER0
743
744 call rpn_comm_allReduce(countObsIn, countObsInMpi, 1, 'mpi_integer', 'mpi_sum', 'grid', ierr)
745 write(*,*)
746 if (countObsInMpi == 0) then
747 write(*,*) 'thn_surfaceInTime: no surface observations present'
748 return
749 else
750 write(*,*) 'thn_surfaceInTime: countObs initial = ', countObsIn, countObsInMpi
751 end if
752 write(*,*)
753
754 ! Compute number of time steps in the window for thinning
755 numStep = 2 * nint(((tim_windowsize - step) / 2.d0) / step) + 1
756 write(*,*) 'thn_surfaceInTime: step, numStep = ', real(step), numStep
757 write(*,*)
758
759 ! Print some values to the listing
760 write(*,*) 'Codtyps to which selection will be applied:'
761 do listIndex = 1, numListCodtypSelect
762 listCodtypSelect(listIndex) = codtyp_get_codtyp(listCodtypNameSelect(listIndex))
763 write(*,*) listCodtypNameSelect(listIndex),': ', listCodtypSelect(listIndex)
764 end do
765 write(*,*) 'Elements to select from above codtyps:'
766 do listIndex = 1, size(listEleSelect)
767 write(*,*) listEleSelect(listIndex)
768 end do
769 write(*,*) 'Remove incomplete DRIFTER reports: ', removeBadDrifters
770 write(*,*)
771
772 ! Allocate arrays
773 allocate(valid(countObsIn))
774 allocate(obsCodtypIndex(countObsIn))
775 allocate(obsLon(countObsIn))
776 allocate(obsLat(countObsIn))
777 allocate(obsDate(countObsIn))
778 allocate(obsTime(countObsIn))
779 allocate(obsDelT(countObsIn))
780 allocate(obsStepIndex(countObsIn))
781 allocate(obsStnid(countObsIn))
782
783 ! Initialize dynamic arrays
784 valid(:) = .true. ! array which keeps track of which reports to keep
785 obsCodtypIndex(:) = MPC_missingValue_INT ! codtyp index array (MPC_missingValue_INT means non-existent)
786 obsLon(:) = 0 ! longitude corresponding to each report
787 obsLat(:) = 0 ! latitude corresponding to each report
788 obsDate(:) = 0 ! DATE yyyymmdd corresponding to each report
789 obsTime(:) = 0 ! time hhmm corresponding to each report
790 obsDelT(:) = MPC_missingValue_INT ! delta t array (departure from nearest bin time)
791 obsStepIndex(:) = 0 ! temporal bin corresponding to each report
792 obsStnid(:) = '' ! stnid corresponding to each report
793
794 ! Initialize counters and counter arrays
795 numEleIn = 0 ! number of elements in input file
796 numBit8In = 0 ! number of input elements flagged (blacklist)
797 numBit11In = 0 ! number of input elements flagged (selection)
798 numEleOut = 0 ! number of elements in output file
799 numBit8Out = 0 ! number of output elements flagged (blacklist)
800 numBit11Out = 0 ! number of output elements flagged (selection)
801 numRemovedCodtyp = 0 ! number of obs removed due to network
802 numRemovedTime = 0 ! number of obs removed (desired time window)
803 numRemovedCodTypPriority = 0 ! number of obs removed due to codtyp
804 numRemovedDelt = 0 ! number of obs removed due to delta t
805 numRemovedDrifter = 0 ! number of incomplete drifter reports removed
806 numRepeat1 = 0 ! number of obs same lon/lat/date/time
807 numRepeat2 = 0 ! number of obs same lon/lat/date/time/codtyp
808
809 countObsInPerCodtyp(:) = 0 ! number of input reports for each codtyp
810 numEleInPerCodtyp(:) = 0 ! number of input elements for each codtyp
811 numBit8InPerCodtyp(:) = 0 ! number of input flags bit 8 for each codtyp
812 numBit11InPerCodtyp(:) = 0 ! number of input flags bit 11 for each codtyp
813 countObsOutPerCodtyp(:) = 0 ! number of output reports for each codtyp
814 numEleOutPerCodtyp(:) = 0 ! number of output elements for each codtyp
815 numBit8OutPerCodtyp(:) = 0 ! number of output flags bit 8 for each codtyp
816 numBit11OutPerCodtyp(:) = 0 ! number of output flags bit 11 for each codtyp
817
818 ! Extract needed information from obsSpaceData
819 obsIndex = 0
820 call obs_set_current_header_list(obsdat, obsFamily)
821 HEADER1: do
822 headerIndex = obs_getHeaderIndex(obsdat)
823 if (headerIndex < 0) exit HEADER1
824 codtyp = obs_headElem_i(obsdat, OBS_ITY, headerIndex)
825 if (codtyp /= codtyp_get_codtyp('satob')) then
826 obsIndex = obsIndex + 1
827 else
828 cycle HEADER1
829 end if
830
831 ! Get index in codtyp list
832 do listIndex = 1, numListCodtyp
833 if (codtyp == codtyp_get_codtyp(listCodtypName(listIndex))) then
834 obsCodtypIndex(obsIndex) = listIndex
835 end if
836 end do
837
838 ! Remove observation if not in codtyp list
839 if (obsCodtypIndex(obsIndex) == MPC_missingValue_INT) then
840 valid(obsIndex) = .false.
841 numRemovedCodtyp = numRemovedCodtyp + 1
842 cycle HEADER1
843 end if
844
845 ! Check if DRIFTER reports contain required element(s), otherwise cycle
846 if ((codtyp == codtyp_get_codtyp('drifter')) .and. removeBadDrifters) then
847 numElements = 0
848 call obs_set_current_body_list(obsdat, headerIndex)
849 BODY1: do
850 bodyIndex = obs_getBodyIndex(obsdat)
851 if (bodyIndex < 0) exit BODY1
852 obsVarNo = obs_bodyElem_i(obsdat, obs_vnm, bodyIndex)
853 if (any(listEleBadDrifter(:) == obsVarNo)) numElements = numElements + 1
854 enddo BODY1
855 if (numElements < numEleMinBadDrifter) then
856 valid(obsIndex) = .false.
857 numRemovedDrifter = numRemovedDrifter + 1
858 cycle HEADER1
859 end if
860 end if
861
862 ! Count the number of elements
863 numElements = 0
864 call obs_set_current_body_list(obsdat, headerIndex)
865 BODY2: do
866 bodyIndex = obs_getBodyIndex(obsdat)
867 if (bodyIndex < 0) exit BODY2
868
869 obsVarNo = obs_bodyElem_i(obsdat, obs_vnm, bodyIndex)
870 if (obsVarNo == -1) cycle BODY2
871
872 numElements = numElements + 1
873
874 obsFlag = obs_bodyElem_i(obsdat, obs_flg, bodyIndex)
875
876 ! Count input flags with bit 8 set
877 if (btest(obsFlag, 8)) then
878 numBit8InPerCodtyp(obsCodtypIndex(obsIndex)) = &
879 numBit8InPerCodtyp(obsCodtypIndex(obsIndex)) + 1
880 numBit8In = numBit8In + 1
881 end if
882
883 ! Count input flags with bit 11 set
884 if (btest(obsFlag, 11)) then
885 numBit11InPerCodtyp(obsCodtypIndex(obsIndex)) = &
886 numBit11InPerCodtyp(obsCodtypIndex(obsIndex)) + 1
887 numBit11In = numBit11In + 1
888 end if
889
890 end do BODY2
891
892 numEleIn = numEleIn + numElements
893
894 ! Counts per codtyp
895 listIndex = obsCodtypIndex(obsIndex)
896 countObsInPerCodtyp(listIndex) = countObsInPerCodtyp(listIndex) + 1
897 numEleInPerCodtyp(listIndex) = numEleInPerCodtyp(listIndex) + numElements
898
899 obsStnid(obsIndex) = obs_elem_c(obsdat, 'STID', headerIndex)
900
901 obsLon(obsIndex) = nint(100.0 * MPC_DEGREES_PER_RADIAN_R8 * &
902 obs_headElem_r(obsdat, obs_lon, headerIndex))
903 obsLat(obsIndex) = nint(100.0 * MPC_DEGREES_PER_RADIAN_R8 * &
904 obs_headElem_r(obsdat, obs_lat, headerIndex)) + 9000
905
906 obsDate(obsIndex) = obs_headElem_i(obsdat, obs_dat, headerIndex)
907 obsTime(obsIndex) = obs_headElem_i(obsdat, obs_etm, headerIndex)
908
909 call tim_getStepObsIndex(obsStepIndex_r8, tim_getDatestamp(), &
910 obsDate(obsIndex), obsTime(obsIndex), numStep)
911 obsStepIndex(obsIndex) = nint(obsStepIndex_r8)
912 if (numStep > 1) then
913 obsDelT(obsIndex) = nint(60.0 * step * (obsStepIndex_r8 - real(obsStepIndex(obsIndex))))
914 else
915 ierr = newdate(obsDateStamp, obsDate(obsIndex), obsTime(obsIndex) * 10000, 3)
916 ! Difference (in hours) between obs time
917 call difdatr(obsDateStamp, tim_getDateStamp(), deltaHours)
918 obsDelT(obsIndex) = nint(60.0 * deltaHours)
919 end if
920
921 ! Reject if time difference larger than deltmax
922 if (abs(obsDelT(obsIndex)) > deltmax) then
923 valid(obsIndex) = .false.
924 numRemovedTime = numRemovedTime + 1
925 endif
926
927 end do HEADER1
928
929 call utl_allReduce(numRemovedDrifter)
930 call utl_allReduce(numRemovedTime)
931 call utl_allReduce(numRemovedCodtyp)
932
933 ! Read blacklist file
934 if (useBlackList) then
935 write(*,*) 'Opening blacklist file'
936 numRowBlacklist = 0
937 nulfile = 0
938 open (unit = nulfile, file = blackListFileName, status = 'OLD', iostat = ierr)
939 if (ierr /= 0) then
940 write(*,*) 'Cannot open blacklist file ', trim(blackListFileName)
941 call utl_abort('thn_surfaceInTime')
942 end if
943 read(nulfile, iostat = istat, fmt = '(i6)') numRowBlacklist
944 write(*,*) 'thn_surfaceInTime: Number of stations in blacklist: ', numRowBlacklist
945
946 allocate(stnidBlacklist(numRowBlacklist))
947 allocate(dataBlacklist(numRowBlacklist, numEleBlacklist))
948 stnidBlacklist(:) = '' ! array of stnid values in blacklist file
949 dataBlacklist(:,:) = 0 ! blacklist matrix for stnids and elements
950
951 do rowIndex = 1, numRowBlacklist
952 read(nulfile, iostat = istat, fmt = '(x,a8,x,5(x,i1))') &
953 stnidBlacklist(rowIndex), &
954 (rowBlackList(colIndex), colIndex = 1, numColBlacklist)
955 do elemIndex = 1, numEleBlacklist
956 if ((blacklistMode == 'severe') .or. &
957 (rowBlackList(listColBlackList(elemIndex))==1)) then
958 dataBlacklist(rowIndex, elemIndex) = 1
959 end if
960 end do
961 end do
962 write(*,*) 'thn_surfaceInTime: Closing blacklist file'
963 write(*,*)
964 close (unit = nulfile)
965 end if
966
967 ! Gather array information over all mpi tasks
968 allocate(validMpi(countObsInMpi))
969 allocate(obsCodtypIndexMpi(countObsInMpi))
970 allocate(obsLonMpi(countObsInMpi))
971 allocate(obsLatMpi(countObsInMpi))
972 allocate(obsDelTMpi(countObsInMpi))
973 allocate(obsStepIndexMpi(countObsInMpi))
974 allocate(obsStnidMpi(countObsInMpi))
975
976 call intArrayToMpi(obsLon, obsLonMpi)
977 call intArrayToMpi(obsLat, obsLatMpi)
978 call intArrayToMpi(obsCodtypIndex, obsCodtypIndexMpi)
979 call intArrayToMpi(obsStepIndex, obsStepIndexMpi)
980 call intArrayToMpi(obsDelT, obsDelTMpi)
981 call logicalArrayToMpi(valid, validMpi)
982 call stringArrayToMpi(obsStnid, obsStnidMpi)
983
984 ! Apply the thinning algorithm
985 do obsIndex = 1, countObsInMpi
986
987 ! If current report OK so far
988 if (validMpi(obsIndex)) then
989 ! Loop over previously-read reports
990 do obsIndex2 = 1, obsIndex - 1
991 ! If other report OK so far and both reports in same bin
992 if ( validMpi(obsIndex2) .and. &
993 (obsStepIndexMpi(obsIndex) == obsStepIndexMpi(obsIndex2))) then
994 ! If reports are spatially colocated or have same stnid
995 if ( ( (obsLonMpi(obsIndex) == obsLonMpi(obsIndex2)) .and. &
996 (obsLatMpi(obsIndex) == obsLatMpi(obsIndex2)) ) .or. &
997 ( considerSHIPstnID .and. &
998 (obsStnidMpi(obsIndex) == obsStnidMpi(obsIndex2)))) then
999 ! If both reports have same codtyp
1000 if (obsCodtypIndexMpi(obsIndex) == obsCodtypIndexMpi(obsIndex2)) then
1001 ! If current report closer to bin time
1002 if (abs(obsDelTMpi(obsIndex)) < abs(obsDelTMpi(obsIndex2))) then
1003 ! Reject other report
1004 validMpi(obsIndex2) = .false.
1005 numRemovedDelt = numRemovedDelt + 1
1006 else if (abs(obsDelTMpi(obsIndex)) > abs(obsDelTMpi(obsIndex2))) then
1007 ! other report closer to bin time, so reject current report
1008 validMpi(obsIndex) = .false.
1009 numRemovedDelt = numRemovedDelt + 1
1010 else if (obsDelTMpi(obsIndex) >= obsDelTMpi(obsIndex2)) then
1011 ! both reports equally far from bin time
1012 ! If other report not more recent then reject it
1013 validMpi(obsIndex2) = .false.
1014 if (obsDelTMpi(obsIndex) == obsDelTMpi(obsIndex2)) then
1015 numRepeat2 = numRepeat2 + 1
1016 else
1017 numRemovedDelt = numRemovedDelt + 1
1018 end if
1019 else
1020 ! current report less recent, reject it
1021 validMpi(obsIndex) = .false.
1022 numRemovedDelt = numRemovedDelt + 1
1023 end if ! delta t
1024 else
1025 ! Reports do not have same codtyp
1026 ! If current report has higher codtyp precedence
1027 if (obsCodtypIndexMpi(obsIndex) < obsCodtypIndexMpi(obsIndex2)) then
1028 ! Reject other report
1029 validMpi(obsIndex2) = .false.
1030 else
1031 ! Other report has higher codtyp precedence, so reject current report
1032 validMpi(obsIndex) = .false.
1033 end if
1034 numRemovedCodTypPriority = numRemovedCodTypPriority + 1
1035 if (obsDelTMpi(obsIndex) == obsDelTMpi(obsIndex2)) then
1036 numRepeat1 = numRepeat1 + 1
1037 end if
1038 end if ! codtyp
1039 end if ! lon, lat, ibin
1040 end if ! other report OK
1041 end do ! obsIndex2
1042 end if ! current report OK
1043
1044 end do ! obsIndex
1045
1046 ! Transfer mpi global array 'valid' to local array
1047 call rpn_comm_allGather(countObsIn, 1, 'mpi_integer', countObsInAllMpi, 1, 'mpi_integer', 'GRID', ierr)
1048
1049 countObsInMyOffset = 0
1050 do procIndex = 1, mmpi_myid
1051 countObsInMyOffset = countObsInMyOffset + countObsInAllMpi(procIndex)
1052 end do
1053 do obsIndex = 1, countObsIn
1054 valid(obsIndex) = validMpi(obsIndex + countObsInMyOffset)
1055 end do
1056
1057 ! Do counts of kepts observations
1058 obsIndex = 0
1059 countObsOut = 0
1060 call obs_set_current_header_list(obsdat, obsFamily)
1061 HEADER2: do
1062 headerIndex = obs_getHeaderIndex(obsdat)
1063 if (headerIndex < 0) exit HEADER2
1064 codtyp = obs_headElem_i(obsdat, OBS_ITY, headerIndex)
1065 if (codtyp /= codtyp_get_codtyp('satob')) then
1066 obsIndex = obsIndex + 1
1067 else
1068 cycle HEADER2
1069 end if
1070
1071 ! If rejected, set bit 11 for all data flags
1072 if (.not. valid(obsIndex)) then
1073 call obs_set_current_body_list(obsdat, headerIndex)
1074 BODY3: do
1075 bodyIndex = obs_getBodyIndex(obsdat)
1076 if (bodyIndex < 0) exit BODY3
1077 obsFlag = obs_bodyElem_i(obsdat, obs_flg, bodyIndex)
1078 call obs_bodySet_i(obsdat, obs_flg, bodyIndex, ibset(obsFlag,11))
1079 end do BODY3
1080 cycle HEADER2
1081 end if
1082
1083 ! Count the number of elements
1084 numElements = 0
1085 call obs_set_current_body_list(obsdat, headerIndex)
1086 BODY4: do
1087 bodyIndex = obs_getBodyIndex(obsdat)
1088 if (bodyIndex < 0) exit BODY4
1089
1090 obsVarNo = obs_bodyElem_i(obsdat, obs_vnm, bodyIndex)
1091 if (obsVarNo == -1) cycle BODY4
1092
1093 numElements = numElements + 1
1094
1095 ! Set bit 8 according to blacklist, if blacklist present
1096 if (useBlackList) then
1097 ! Traverse rows of blacklist matrix
1098 do rowIndex = 1, numRowBlacklist
1099 ! If stnid found in blacklist, flag elements as appropriate
1100 if (obsStnid(obsIndex) == stnidBlacklist(rowIndex)) then
1101 ! Traverse columns of blacklist matrix
1102 do elemIndex = 1, numEleBlacklist
1103 ! If element is to be blacklisted, set bit 8
1104 if (obsVarNo == listEleBlacklist(elemIndex) .and. &
1105 dataBlacklist(rowIndex,elemIndex) == 1) then
1106 obsFlag = obs_bodyElem_i(obsdat, obs_flg, bodyIndex)
1107 call obs_bodySet_i(obsdat, obs_flg, bodyIndex, ibset(obsFlag,8))
1108 end if
1109 end do ! elemIndex
1110 end if ! stnid
1111 end do ! rowIndex
1112 end if ! useBlackList
1113
1114 ! Set bit 11 according to requested codtyps and elements
1115 if (any(listCodtypSelect(:) == codtyp)) then
1116 ! If current element not in select list, set bit 11
1117 if (.not. any(listEleSelect(:) == obsVarNo)) then
1118 obsFlag = obs_bodyElem_i(obsdat, obs_flg, bodyIndex)
1119 write(*,*) 'Setting bit 11 for codtyp, elem = ', codtyp, obsVarNo
1120 call obs_bodySet_i(obsdat, obs_flg, bodyIndex, ibset(obsFlag,11))
1121 end if
1122 end if
1123
1124 obsFlag = obs_bodyElem_i(obsdat, obs_flg, bodyIndex)
1125
1126 ! Count output flags with bit 8 set
1127 if (btest(obsFlag, 8)) then
1128 numBit8OutPerCodtyp(obsCodtypIndex(obsIndex)) = numBit8OutPerCodtyp(obsCodtypIndex(obsIndex)) + 1
1129 numBit8Out = numBit8Out + 1
1130 end if
1131
1132 ! Count output flags with bit 11 set
1133 if (btest(obsFlag, 11)) then
1134 numBit11OutPerCodtyp(obsCodtypIndex(obsIndex)) = numBit11OutPerCodtyp(obsCodtypIndex(obsIndex)) + 1
1135 numBit11Out = numBit11Out + 1
1136 end if
1137
1138 end do BODY4
1139
1140 numEleOut = numEleOut + numElements
1141 countObsOut = countObsOut + 1
1142
1143 ! Counts per codtyp
1144 listIndex = obsCodtypIndex(obsIndex)
1145 countObsOutPerCodtyp(listIndex) = countObsOutPerCodtyp(listIndex) + 1
1146 numEleOutPerCodtyp(listIndex) = numEleOutPerCodtyp(listIndex) + numElements
1147
1148 end do HEADER2
1149
1150 ! Output statistics to screen
1151
1152 ! numRepeat1 should include the case where codtyps are the same
1153 numRepeat1 = numRepeat1 + numRepeat2
1154
1155 write(*,'(a)') ' Number of reports in input file'
1156 do listIndex = 1, numListCodtyp
1157 call utl_allReduce(countObsInPerCodtyp(listIndex))
1158 write(*,'(i4,3a,i7)') codtyp_get_codtyp(listCodtypName(listIndex)), ' (', &
1159 listCodtypName(listIndex), '): ', countObsInPerCodtyp(listIndex)
1160 end do
1161
1162 write(*,*)
1163 write(*,'(a)') ' Number of elements in input file'
1164 do listIndex = 1, numListCodtyp
1165 call utl_allReduce(numEleInPerCodtyp(listIndex))
1166 call utl_allReduce(numBit8InPerCodtyp(listIndex))
1167 call utl_allReduce(numBit11InPerCodtyp(listIndex))
1168 write(*,'(i4,3a,i7,a,i7,a,i7,a)') codtyp_get_codtyp(listCodtypName(listIndex)), ' (', &
1169 listCodtypName(listIndex), '): ', numEleInPerCodtyp(listIndex), ' (', &
1170 numBit8InPerCodtyp(listIndex), ' bit 8, ', &
1171 numBit11InPerCodtyp(listIndex), ' bit 11)'
1172 end do
1173
1174 write(*,*)
1175 write(*,'(a)') ' Number of reports in output file'
1176 do listIndex = 1, numListCodtyp
1177 call utl_allReduce(countObsOutPerCodtyp(listIndex))
1178 write(*,'(i4,3a,i7)') codtyp_get_codtyp(listCodtypName(listIndex)), ' (', &
1179 listCodtypName(listIndex), '): ', countObsOutPerCodtyp(listIndex)
1180 end do
1181
1182 write(*,*)
1183 write(*,'(a)') ' Number of elements in output file'
1184 do listIndex = 1, numListCodtyp
1185 call utl_allReduce(numEleOutPerCodtyp(listIndex))
1186 call utl_allReduce(numBit8OutPerCodtyp(listIndex))
1187 call utl_allReduce(numBit11OutPerCodtyp(listIndex))
1188 write(*,'(i4,3a,i7,a,i7,a,i7,a)') codtyp_get_codtyp(listCodtypName(listIndex)), ' (', &
1189 listCodtypName(listIndex), '): ', numEleOutPerCodtyp(listIndex), ' (', &
1190 numBit8OutPerCodtyp(listIndex), ' bit 8, ', &
1191 numBit11OutPerCodtyp(listIndex), ' bit 11)'
1192 end do
1193
1194 write(*,*)
1195 call utl_allReduce(countObsIn)
1196 call utl_allReduce(countObsOut)
1197 write(*,'(a,i12)') 'Total number of reports in input file: ', countObsIn
1198 write(*,'(a,i12)') 'Total number of reports in output file: ', countObsOut
1199 call utl_allReduce(numEleIn)
1200 call utl_allReduce(numBit8In)
1201 call utl_allReduce(numBit11In)
1202 call utl_allReduce(numEleOut)
1203 call utl_allReduce(numBit8Out)
1204 call utl_allReduce(numBit11Out)
1205 write(*,'(a,i7,a,i7,a,i7,a)') 'Total number of elements in input file: ', numEleIn, &
1206 ' (', numBit8In, ' bit 8, ', numBit11In, ' bit 11)'
1207 write(*,'(a,i7,a,i7,a,i7,a)') 'Total number of elements in output file: ', numEleOut, &
1208 ' (', numBit8Out, ' bit 8, ', numBit11Out, ' bit 11)'
1209 write(*,*)
1210 write(*,'(a,i7)') 'Number of repeated reports (lon/lat/date/time): ', numRepeat1
1211 write(*,'(a,f6.2)') 'Above count as a percentage of total reports in: ', 100.0 * numRepeat1 / countObsIn
1212 write(*,'(a,i7)') 'Number of repeated reports (lon/lat/date/time/codtyp): ', numRepeat2
1213 write(*,'(a,f6.2)') 'Above count as a percentage of total reports in: ', 100.00 * numRepeat2 / countObsIn
1214 write(*,*)
1215 write(*,'(a,i7)') 'Number of reports removed due to codtyp: ', numRemovedCodtyp
1216 write(*,'(a,i7)') 'Number of reports removed due to time: ', numRemovedTime
1217 write(*,'(a,i7)') 'Number of reports removed using codtyp precedence: ', numRemovedCodTypPriority
1218 write(*,'(a,i7)') 'Number of reports removed using delta t: ', numRemovedDelt
1219 write(*,'(a,i7)') 'Number of incomplete drifter reports removed: ', numRemovedDrifter
1220 write(*,*)
1221
1222 end subroutine thn_surfaceInTime
1223
1224 !--------------------------------------------------------------------------
1225 ! thn_gpsroVertical
1226 !--------------------------------------------------------------------------
1227 subroutine thn_gpsroVertical(obsdat, heightMin, heightMax, heightSpacing, &
1228 gpsroVarNo)
1229 !
1230 !:Purpose: Original method for thinning GPSRO data by vertical distance.
1231 ! Set bit 11 of OBS_FLG on observations that are to be rejected.
1232 !
1233 implicit none
1234
1235 ! Arguments:
1236 type(struct_obs), intent(inout) :: obsdat
1237 real(8), intent(in) :: heightMin
1238 real(8), intent(in) :: heightMax
1239 real(8), intent(in) :: heightSpacing
1240 integer, intent(in) :: gpsroVarNo
1241
1242 ! Locals:
1243 integer :: countObs, countObsMpi
1244 integer :: countObsReject, countObsRejectMpi, countObsTotal, countObsTotalMpi
1245 integer :: headerIndex, bodyIndex, ierr
1246 integer :: numLev
1247 integer :: levIndex, obsVarNo, obsFlag
1248 real(8) :: nextHeightMin
1249 logical :: rejectObs
1250 integer, allocatable :: bodyIndexList(:)
1251 real(8), allocatable :: obsHeights(:)
1252
1253 write(*,*)
1254 write(*,*) 'thn_gpsroVertical: Starting'
1255 write(*,*)
1256
1257 ! Check if any observations to be treated
1258 countObs = 0
1259 call obs_set_current_header_list(obsdat,'RO')
1260 HEADER0: do
1261 headerIndex = obs_getHeaderIndex(obsdat)
1262 if (headerIndex < 0) exit HEADER0
1263 countObs = countObs + 1
1264 end do HEADER0
1265
1266 call rpn_comm_allReduce(countObs, countObsMpi, 1, 'mpi_integer', &
1267 'mpi_sum','grid',ierr)
1268 if (countObsMpi == 0) then
1269 write(*,*) 'thn_gpsroVertical: no gpsro observations present'
1270 return
1271 end if
1272
1273 countObsTotal = 0
1274 countObsReject = 0
1275 call obs_set_current_header_list(obsdat,'RO')
1276 HEADER1: do
1277 headerIndex = obs_getHeaderIndex(obsdat)
1278 if (headerIndex < 0) exit HEADER1
1279
1280 ! count number of levels for this profile
1281 numLev = 0
1282 call obs_set_current_body_list(obsdat, headerIndex)
1283 BODY1: do
1284 bodyIndex = obs_getBodyIndex(obsdat)
1285 if (bodyIndex < 0) exit BODY1
1286
1287 obsVarNo = obs_bodyElem_i(obsdat, OBS_VNM, bodyIndex)
1288 if (obsVarNo /= gpsroVarNo) cycle BODY1
1289
1290 numLev = numLev + 1
1291 countObsTotal = countObsTotal + 1
1292
1293 end do BODY1
1294
1295 allocate(obsHeights(numLev))
1296 allocate(bodyIndexList(numLev))
1297
1298 ! extract altitudes for this profile
1299 levIndex = 0
1300 call obs_set_current_body_list(obsdat, headerIndex)
1301 BODY2: do
1302 bodyIndex = obs_getBodyIndex(obsdat)
1303 if (bodyIndex < 0) exit BODY2
1304
1305 obsVarNo = obs_bodyElem_i(obsdat, OBS_VNM, bodyIndex)
1306 if (obsVarNo /= gpsroVarNo) cycle BODY2
1307
1308 levIndex = levIndex + 1
1309 obsHeights(levIndex) = obs_bodyElem_r(obsdat, OBS_PPP, bodyIndex)
1310 bodyIndexList(levIndex) = bodyIndex
1311
1312 end do BODY2
1313
1314 ! ensure altitudes are in ascending order
1315 call thn_QsortReal8(obsHeights,bodyIndexList)
1316
1317 ! apply vertical thinning
1318 nextHeightMin = heightMin
1319 LEVELS: do levIndex = 1, numLev
1320
1321 if ( obsHeights(levIndex) >= nextHeightMin .and. &
1322 obsHeights(levIndex) < heightMax ) then
1323 nextHeightMin = obsHeights(levIndex) + heightSpacing
1324 rejectObs = .false.
1325 else
1326 rejectObs = .true.
1327 end if
1328
1329 if (rejectObs) then
1330 bodyIndex = bodyIndexList(levIndex)
1331 obsFlag = obs_bodyElem_i(obsdat, OBS_FLG, bodyIndex)
1332 call obs_bodySet_i(obsdat, OBS_FLG, bodyIndex, ibset(obsFlag,11))
1333 countObsReject = countObsReject + 1
1334 end if
1335
1336 end do LEVELS
1337
1338 deallocate(obsHeights)
1339 deallocate(bodyIndexList)
1340
1341 end do HEADER1
1342
1343 call rpn_comm_allReduce(countObsTotal, countObsTotalMpi, 1, 'mpi_integer', &
1344 'mpi_sum','grid',ierr)
1345 call rpn_comm_allReduce(countObsReject, countObsRejectMpi, 1, 'mpi_integer', &
1346 'mpi_sum','grid',ierr)
1347 write(*,*)' Number of GPS-RO elements, total --->', countObsTotalMpi
1348 write(*,*)' Number of GPS-RO elements, rejected --->', countObsRejectMpi
1349 write(*,*)' Number of GPS-RO elements, kept --->', countObsTotalMpi - &
1350 countObsRejectMpi
1351
1352 write(*,*)
1353 write(*,*) 'thn_gpsroVertical: Finished'
1354 write(*,*)
1355
1356 end subroutine thn_gpsroVertical
1357
1358 !--------------------------------------------------------------------------
1359 ! thn_radiosonde
1360 !--------------------------------------------------------------------------
1361 subroutine thn_radiosonde(obsdat, verticalThinningES, ecmwfRejetsES, toleranceFactor)
1362 !
1363 !:Purpose: Original method for thinning radiosonde data vertically.
1364 ! We assume that each vertical level is stored in obsSpaceData
1365 ! with a separate headerIndex. That is, the 4D representation.
1366 ! Set bit 11 of OBS_FLG on observations that are to be rejected.
1367 !
1368 implicit none
1369
1370 ! Arguments:
1371 type(struct_obs), intent(inout) :: obsdat
1372 logical, intent(in) :: verticalThinningES
1373 logical, intent(in) :: ecmwfRejetsES
1374 real(4), intent(in) :: toleranceFactor
1375
1376 ! Locals:
1377 type(struct_hco), pointer :: hco_sfc
1378 type(struct_vco), pointer :: vco_sfc
1379 type(struct_gsv) :: stateVectorPsfc
1380 integer :: fnom, fclos, ezgdef, ezsint, ezdefset, ezsetopt
1381 integer :: ierr, nulnam, numLevStn, numLevStnMpi, countLevel, numLevStnMax
1382 integer :: numStation, numStationMpi, stationIndex, stationIndexMpi, lastProfileIndex
1383 integer :: profileIndex, headerIndex, bodyIndex, levIndex, stepIndex, varIndex
1384 integer :: levStnIndex, levStnIndexMpi, obsFlag
1385 integer :: ig1obs, ig2obs, ig3obs, ig4obs, obsGridID
1386 real(4) :: obsValue, obsOmp, obsStepIndex
1387 real(4) :: zig1, zig2, zig3, zig4, zpresa, zpresb
1388 real(8) :: obsStepIndex_r8
1389 integer, allocatable :: obsLevOffset(:), obsType(:), obsHeadDate(:), obsHeadTime(:)
1390 integer, allocatable :: obsDate(:), obsTime(:), obsLaunchTime(:), stationFlags(:)
1391 integer, allocatable :: trajFlags(:,:), obsFlags(:,:)
1392 integer, allocatable :: obsLevOffsetMpi(:), obsHeadDateMpi(:)
1393 integer, allocatable :: obsLaunchTimeMpi(:), stationFlagsMpi(:)
1394 integer, allocatable :: trajFlagsMpi(:,:), obsFlagsMpi(:,:)
1395 integer, allocatable :: procIndexes(:), procIndexesMpi(:)
1396 real(4), allocatable :: obsLat(:), obsLon(:), surfPresInterp(:,:)
1397 real(4), allocatable :: obsValues(:,:), oMinusB(:,:), presInterp(:,:)
1398 real(4), allocatable :: obsLatMpi(:), obsLonMpi(:)
1399 real(4), allocatable :: obsValuesMpi(:,:), oMinusBMpi(:,:)
1400 real(4), pointer :: surfPressure(:,:,:,:)
1401 character(len=4), allocatable :: varNamesPsfc(:)
1402 character(len=9), allocatable :: stnId(:), stnIdMpi(:)
1403 character(len=20) :: trlmFileName
1404 character(len=2) :: fileNumber
1405 logical :: upperAirObs
1406 integer :: countAcc_dd, countRej_dd, countAccMpi_dd, countRejMpi_dd
1407 integer :: countAcc_ff, countRej_ff, countAccMpi_ff, countRejMpi_ff
1408 integer :: countAcc_tt, countRej_tt, countAccMpi_tt, countRejMpi_tt
1409 integer :: countAcc_es, countRej_es, countAccMpi_es, countRejMpi_es
1410 integer, parameter :: numVars=5, numTraj=2, maxNumLev=300
1411
1412 ! Namelist variables:
1413 real(8) :: rprefinc ! parameter for defining fixed set of model levels for vertical thinning
1414 real(8) :: rptopinc ! parameter for defining fixed set of model levels for vertical thinning
1415 real(8) :: rcoefinc ! parameter for defining fixed set of model levels for vertical thinning
1416 real(4) :: vlev(maxNumLev) ! parameter for defining fixed set of model levels for vertical thinning
1417 integer :: numlev ! MUST NOT BE INCLUDED IN NAMELIST!
1418 namelist /namgem/rprefinc, rptopinc, rcoefinc, numlev, vlev
1419
1420 ! Check if any observations to be treated and count number of "profiles"
1421 numLevStn = 0
1422 numStation = 0
1423 lastProfileIndex = -1
1424 call obs_set_current_header_list(obsdat,'UA')
1425 HEADER0: do
1426 headerIndex = obs_getHeaderIndex(obsdat)
1427 if (headerIndex < 0) exit HEADER0
1428
1429 ! skip if this headerIndex doesn't contain upper air obs
1430 upperAirObs = .false.
1431 call obs_set_current_body_list(obsdat, headerIndex)
1432 BODY0: do
1433 bodyIndex = obs_getBodyIndex(obsdat)
1434 if (bodyIndex < 0) exit BODY0
1435
1436 select case (obs_bodyElem_i(obsdat,OBS_VNM,bodyIndex))
1437 case (bufr_neuu, bufr_nevv, bufr_nett, bufr_nees)
1438 upperAirObs = .true.
1439 end select
1440 end do BODY0
1441 profileIndex = obs_headElem_i(obsdat, obs_prfl, headerIndex)
1442 if (.not. upperAirObs) cycle HEADER0
1443
1444 numLevStn = numLevStn + 1
1445
1446 profileIndex = obs_headElem_i(obsdat, obs_prfl, headerIndex)
1447 if (profileIndex /= lastProfileIndex) then
1448 lastProfileIndex = profileIndex
1449 numStation = numStation + 1
1450 end if
1451
1452 end do HEADER0
1453
1454 call rpn_comm_allReduce(numLevStn, numLevStnMpi, 1, 'mpi_integer', &
1455 'mpi_sum','grid',ierr)
1456 if (numLevStnMpi == 0) then
1457 write(*,*) 'thn_radiosonde: no UA obs observations present'
1458 return
1459 end if
1460
1461 call rpn_comm_allReduce(numStation, numStationMpi, 1, 'mpi_integer', &
1462 'mpi_sum','grid',ierr)
1463
1464 write(*,*) 'thn_radiosonde: number of obs initial = ', &
1465 numLevStn, numLevStnMpi
1466 write(*,*) 'thn_radiosonde: number of profiles = ', &
1467 numStation, numStationMpi
1468
1469 ! Allocate some quanitities needed for each profile
1470 allocate(obsLevOffset(numStation+1))
1471 allocate(obsType(numStation))
1472 allocate(obsHeadDate(numStation))
1473 allocate(obsHeadTime(numStation))
1474 allocate(obsDate(numStation))
1475 allocate(obsTime(numStation))
1476 allocate(obsLaunchTime(numStation))
1477 allocate(stationFlags(numStation))
1478 allocate(obsLat(numStation))
1479 allocate(obsLon(numStation))
1480 allocate(stnId(numStation))
1481 allocate(presInterp(numStation,maxNumLev))
1482 allocate(trajFlags(numTraj,numLevStn))
1483 allocate(obsFlags(numVars,numLevStn))
1484 allocate(obsValues(numVars,numLevStn))
1485 allocate(oMinusB(numVars,numLevStn))
1486 obsLevOffset(:) = 0
1487 obsDate(:) = -1
1488 trajFlags(:,:) = -1
1489 obsFlags(:,:) = 0
1490 obsValues(:,:) = -999.0
1491 oMinusB(:,:) = -999.0
1492
1493 ! Fill in the arrays for each profile
1494 levStnIndex = 0
1495 stationIndex = 0
1496 lastProfileIndex = -1
1497 numLevStnMax = -1
1498 call obs_set_current_header_list(obsdat,'UA')
1499 HEADER1: do
1500 headerIndex = obs_getHeaderIndex(obsdat)
1501 if (headerIndex < 0) exit HEADER1
1502
1503 ! skip if this headerIndex doesn't contain upper air obs
1504 upperAirObs = .false.
1505 call obs_set_current_body_list(obsdat, headerIndex)
1506 BODY1: do
1507 bodyIndex = obs_getBodyIndex(obsdat)
1508 if (bodyIndex < 0) exit BODY1
1509
1510 select case (obs_bodyElem_i(obsdat,OBS_VNM,bodyIndex))
1511 case (bufr_neuu, bufr_nevv, bufr_nett, bufr_nees)
1512 upperAirObs = .true.
1513 end select
1514 end do BODY1
1515 if (.not. upperAirObs) cycle HEADER1
1516
1517 levStnIndex = levStnIndex + 1
1518
1519 profileIndex = obs_headElem_i(obsdat, obs_prfl, headerIndex)
1520 if (profileIndex /= lastProfileIndex) then
1521 lastProfileIndex = profileIndex
1522 stationIndex = stationIndex + 1
1523 countLevel = 0
1524 end if
1525
1526 countLevel = countLevel + 1
1527 obsLevOffset(stationIndex+1) = obsLevOffset(stationIndex) + countLevel
1528
1529 if (countLevel > numLevStnMax) numLevStnMax = countLevel
1530
1531 ! Get some information from the first header in this profile
1532 if (countLevel == 1) then
1533 obsDate(stationIndex) = obs_headElem_i(obsdat,obs_dat,headerIndex)
1534 obsTime(stationIndex) = obs_headElem_i(obsdat,obs_etm,headerIndex)
1535 obsLat(stationIndex) = obs_headElem_r(obsdat,obs_lat,headerIndex) * &
1536 MPC_DEGREES_PER_RADIAN_R8
1537 obsLon(stationIndex) = obs_headElem_r(obsdat,obs_lon,headerIndex) * &
1538 MPC_DEGREES_PER_RADIAN_R8
1539 obsLat(stationIndex) = 0.01*nint(100.0*obsLat(stationIndex))
1540 obsLon(stationIndex) = 0.01*nint(100.0*obsLon(stationIndex))
1541 end if
1542 obsHeadDate(stationIndex) = obs_headElem_i(obsdat,obs_hdd,headerIndex)
1543 obsHeadTime(stationIndex) = obs_headElem_i(obsdat,obs_hdt,headerIndex)
1544 obsLaunchTime(stationIndex) = obs_headElem_i(obsdat,obs_lch,headerIndex)
1545 if (obsLaunchTime(stationIndex) == mpc_missingValue_int) then
1546 obsLaunchTime(stationIndex) = obsHeadTime(stationIndex)
1547 end if
1548 obsType(stationIndex) = obs_headElem_i(obsdat,obs_rtp,headerIndex)
1549 stationFlags(stationIndex) = obs_headElem_i(obsdat,obs_st1,headerIndex)
1550 stnId(stationIndex) = obs_elem_c(obsdat,'STID',headerIndex)
1551
1552 trajFlags(1,levStnIndex) = obs_headElem_i(obsdat,obs_tflg,headerIndex)
1553 trajFlags(2,levStnIndex) = obs_headElem_i(obsdat,obs_lflg,headerIndex)
1554
1555 call obs_set_current_body_list(obsdat, headerIndex)
1556 BODY2: do
1557 bodyIndex = obs_getBodyIndex(obsdat)
1558 if (bodyIndex < 0) exit BODY2
1559
1560 obsFlag = obs_bodyElem_i(obsdat,obs_flg,bodyIndex)
1561 obsValue = obs_bodyElem_r(obsdat,obs_var,bodyIndex)
1562 obsOmp = obs_bodyElem_r(obsdat,obs_omp,bodyIndex)
1563 select case (obs_bodyElem_i(obsdat,OBS_VNM,bodyIndex))
1564 case (bufr_nedd)
1565 obsFlags(1,levStnIndex) = obsFlag
1566 obsValues(1,levStnIndex) = obsValue
1567 case (bufr_neuu)
1568 oMinusB(1,levStnIndex) = obsOmp
1569 case (bufr_neff)
1570 obsFlags(2,levStnIndex) = obsFlag
1571 obsValues(2,levStnIndex) = obsValue
1572 case (bufr_nevv)
1573 oMinusB(2,levStnIndex) = obsOmp
1574 case (bufr_nett)
1575 obsFlags(3,levStnIndex) = obsFlag
1576 obsValues(3,levStnIndex) = obsValue
1577 oMinusB(3,levStnIndex) = obsOmp
1578 case (bufr_nees)
1579 obsFlags(4,levStnIndex) = obsFlag
1580 obsValues(4,levStnIndex) = obsValue
1581 oMinusB(4,levStnIndex) = obsOmp
1582 end select
1583 obsValues(5,levStnIndex) = 0.01 * obs_bodyElem_r(obsdat,obs_ppp,bodyIndex)
1584 end do BODY2
1585
1586 end do HEADER1
1587
1588 ! Default namelist values
1589 numlev = MPC_missingValue_INT
1590 vlev(:) = MPC_missingValue_R4
1591 rprefinc = 0.0d0
1592 rptopinc = 0.0d0
1593 rcoefinc = 0.0d0
1594 ! Read the namelist defining the vertical levels
1595 if (utl_isNamelistPresent('namgem','./flnml')) then
1596 nulnam = 0
1597 ierr = fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
1598 if (ierr /= 0) call utl_abort('thn_radiosonde: Error opening file flnml')
1599 read(nulnam,nml=namgem,iostat=ierr)
1600 if (ierr /= 0) call utl_abort('thn_radiosonde: Error reading namgem namelist')
1601 if (numlev /= MPC_missingValue_INT) then
1602 call utl_abort('thn_radiosonde: check NAMGEM namelist section: numlev should be removed')
1603 end if
1604 numlev = 0
1605 do levIndex = 1, maxNumLev
1606 if (vlev(levIndex) == MPC_missingValue_R4) exit
1607 numlev = numlev + 1
1608 end do
1609 if (mmpi_myid == 0) write(*,nml=namgem)
1610 ierr = fclos(nulnam)
1611 else
1612 call utl_abort('thn_radiosonde: Namelist block namgem is missing in the namelist.')
1613 end if
1614
1615 ! Read the trial surface pressure
1616 nullify(vco_sfc)
1617 nullify(hco_sfc)
1618 trlmFileName = './trlm_01'
1619 call vco_setupFromFile(vco_sfc, trlmFileName)
1620 call hco_setupFromFile(hco_sfc, trlmFileName, ' ')
1621 if (vco_sfc%Vcode == 5100) then
1622 allocate(varNamesPsfc(2))
1623 varNamesPsfc = (/'P0','P0LS'/)
1624 else
1625 allocate(varNamesPsfc(1))
1626 varNamesPsfc = (/'P0'/)
1627 end if
1628 call gsv_allocate( stateVectorPsfc, tim_nstepobs, hco_sfc, vco_sfc, &
1629 datestamp_opt=tim_getDatestamp(), mpi_local_opt=.false., &
1630 dataKind_opt=4, varNames_opt=varNamesPsfc, &
1631 hInterpolateDegree_opt='LINEAR' )
1632 deallocate(varNamesPsfc)
1633 do stepIndex = 1, tim_nstepobs
1634 write(fileNumber,'(I2.2)') stepIndex
1635 trlmFileName = './trlm_' // trim(fileNumber)
1636 call gio_readFromFile( stateVectorPsfc, trlmFileName, ' ', ' ', &
1637 stepIndex_opt=stepIndex, containsFullField_opt=.true. )
1638 end do
1639 call gsv_getField(stateVectorPsfc,surfPressure)
1640
1641 ! Setup the interpolation to obs locations of surface pressure
1642 zig1 = 0.0
1643 zig2 = 0.0
1644 zig3 = 1.0
1645 zig4 = 1.0
1646 ierr = ezsetopt('INTERP_DEGREE', 'LINEAR')
1647 call cxgaig('L',ig1obs,ig2obs,ig3obs,ig4obs,zig1,zig2,zig3,zig4)
1648 obsGridID = ezgdef(numStation,1,'Y','L',ig1obs,ig2obs,ig3obs,ig4obs,obsLon,obsLat)
1649 ierr = ezdefset(obsGridID,hco_sfc%ezScintId)
1650
1651 ! Do the interpolation of surface pressure to obs locations
1652 allocate(surfPresInterp(numStation,tim_nstepobs))
1653 do stepIndex = 1, tim_nstepobs
1654 ierr = ezsint(surfPresInterp(:,stepIndex),surfPressure(:,:,1,stepIndex))
1655 end do
1656 call gsv_deallocate(stateVectorPsfc)
1657
1658 ! Compute pressure profile at each obs location
1659 do stationIndex = 1, numStation
1660
1661 ! Calculate the stepIndex corresponding to the launch time
1662 call tim_getStepObsIndex(obsStepIndex_r8, tim_getDatestamp(), &
1663 obsDate(stationIndex), obsTime(stationIndex), tim_nstepobs)
1664 obsStepIndex = nint(obsStepIndex_r8)
1665 if (obsStepIndex < 0) then
1666 obsStepIndex = (tim_nstepobs+1)/2
1667 write(*,*) 'thn_radiosonde: Obs outside the assimilation window, set to middle of window'
1668 end if
1669
1670 ! Calculate pressure levels for each station based on GEM3 vertical coordinate
1671 do levIndex = 1, numLev
1672 zpresb = ((vlev(levIndex) - rptopinc/rprefinc) / &
1673 (1.0-rptopinc/rprefinc))**rcoefinc
1674 zpresa = rprefinc * (vlev(levIndex)-zpresb)
1675 presInterp(stationIndex,levIndex) = &
1676 0.01 * (zpresa + zpresb*surfPresInterp(stationIndex,obsStepIndex))
1677 end do
1678
1679 end do
1680
1681 ! communicate several arrays to all MPI tasks for raobs_check_duplicated_stations
1682 allocate(obsLevOffsetMpi(numStationMpi+1))
1683 allocate(obsHeadDateMpi(numStationMpi))
1684 allocate(obsLaunchTimeMpi(numStationMpi))
1685 allocate(stationFlagsMpi(numStationMpi))
1686 allocate(obsLatMpi(numStationMpi))
1687 allocate(obsLonMpi(numStationMpi))
1688 allocate(trajFlagsMpi(numTraj,numLevStnMpi))
1689 allocate(obsFlagsMpi(numVars,numLevStnMpi))
1690 allocate(obsValuesMpi(numVars,numLevStnMpi))
1691 allocate(oMinusBMpi(numVars,numLevStnMpi))
1692 allocate(stnIdMpi(numStationMpi))
1693
1694 call intArrayToMpi(obsLevOffset, obsLevOffsetMpi, is_obsLevOffset_opt=.true.)
1695 call intArrayToMpi(obsHeadDate, obsHeadDateMpi)
1696 call intArrayToMpi(obsLaunchTime, obsLaunchTimeMpi)
1697 call intArrayToMpi(stationFlags, stationFlagsMpi)
1698 call realArrayToMpi(obsLat, obsLatMpi)
1699 call realArrayToMpi(obsLon, obsLonMpi)
1700 do varIndex = 1, numTraj
1701 call intArrayToMpi(trajFlags(varIndex,:), trajFlagsMpi(varIndex,:))
1702 end do
1703 do varIndex = 1, numVars
1704 call intArrayToMpi(obsFlags(varIndex,:), obsFlagsMpi(varIndex,:))
1705 call realArrayToMpi(obsValues(varIndex,:), obsValuesMpi(varIndex,:))
1706 call realArrayToMpi(oMinusB(varIndex,:), oMinusBMpi(varIndex,:))
1707 end do
1708 call stringArrayToMpi(stnId,stnIdMpi)
1709
1710 ! set stnIdMpi to 'NOT_VALID' for rejected duplicate stations
1711 call raobs_check_duplicated_stations( stnIdMpi, obsLevOffsetMpi, obsLatMpi, obsLonMpi, &
1712 obsHeadDateMpi, trajFlagsMpi, &
1713 obsFlagsMpi, obsValuesMpi, oMinusBMpi, &
1714 obsLaunchTimeMpi, stationFlagsMpi, &
1715 numVars, numStationMpi, toleranceFactor )
1716
1717 ! modify obs flags based on stnIdMpi
1718 do stationIndexMpi = 1, numStationMpi
1719 if (stnIdMpi(stationIndexMpi) == 'NOT_VALID') then
1720 do levStnIndex = obsLevOffsetMpi(stationIndexMpi)+1, &
1721 obsLevOffsetMpi(stationIndexMpi+1)
1722 do varIndex = 1, numVars
1723 obsFlagsMpi(varIndex,levStnIndex) = &
1724 ibset(obsFlagsMpi(varIndex,levStnIndex),11)
1725 end do
1726 end do
1727 end if
1728 end do
1729
1730 ! copy global mpi flags to local copy
1731 allocate(procIndexes(numStation))
1732 allocate(procIndexesMpi(numStationMpi))
1733 procIndexes(:) = mmpi_myid
1734 call intArrayToMpi(procIndexes, procIndexesMpi)
1735 levStnIndex = 0
1736 do stationIndexMpi = 1, numStationMpi
1737 if (procIndexesMpi(stationIndexMpi) == mmpi_myid) then
1738 do levStnIndexMpi = obsLevOffsetMpi(stationIndexMpi)+1, &
1739 obsLevOffsetMpi(stationIndexMpi+1)
1740 levStnIndex = levStnIndex + 1
1741 obsFlags(:,levStnIndex) = obsFlagsMpi(:,levStnIndexMpi)
1742 end do
1743 end if
1744 end do
1745 deallocate(procIndexes)
1746 deallocate(procIndexesMpi)
1747
1748 call raobs_thinning_model( obsFlags, obsValues, presInterp, numVars, numlev, &
1749 numStation, numLevStnMax, obsLevOffset )
1750
1751 if ( verticalThinningES ) then
1752 call raobs_thinning_es( obsFlags, obsValues, numStation, numLevStnMax, obsLevOffset )
1753 end if
1754
1755 if ( ecmwfRejetsES ) then
1756 call raobs_blacklisting_ecmwf( obsFlags, obsValues, obsType, numStation, obsLevOffset )
1757 end if
1758
1759 countAcc_dd=0; countRej_dd=0
1760 countAcc_ff=0; countRej_ff=0
1761 countAcc_tt=0; countRej_tt=0
1762 countAcc_es=0; countRej_es=0
1763 do stationIndex = 1, numStation
1764 do levStnIndex = obsLevOffset(stationIndex)+1, obsLevOffset(stationIndex+1)
1765 if (btest(obsFlags(1,levStnIndex),11)) then
1766 countRej_dd = countRej_dd + 1
1767 else
1768 countAcc_dd = countAcc_dd + 1
1769 end if
1770 if (btest(obsFlags(2,levStnIndex),11)) then
1771 countRej_ff = countRej_ff + 1
1772 else
1773 countAcc_ff = countAcc_ff + 1
1774 end if
1775 if (btest(obsFlags(3,levStnIndex),11)) then
1776 countRej_tt = countRej_tt + 1
1777 else
1778 countAcc_tt = countAcc_tt + 1
1779 end if
1780 if (btest(obsFlags(4,levStnIndex),11) .or. btest(obsFlags(4,levStnIndex),8)) then
1781 countRej_es = countRej_es + 1
1782 else
1783 countAcc_es = countAcc_es + 1
1784 end if
1785 end do
1786 end do
1787
1788 call rpn_comm_allReduce(countRej_dd, countRejMpi_dd, 1, 'mpi_integer', &
1789 'mpi_sum','grid',ierr)
1790 call rpn_comm_allReduce(countRej_ff, countRejMpi_ff, 1, 'mpi_integer', &
1791 'mpi_sum','grid',ierr)
1792 call rpn_comm_allReduce(countRej_tt, countRejMpi_tt, 1, 'mpi_integer', &
1793 'mpi_sum','grid',ierr)
1794 call rpn_comm_allReduce(countRej_es, countRejMpi_es, 1, 'mpi_integer', &
1795 'mpi_sum','grid',ierr)
1796 call rpn_comm_allReduce(countAcc_dd, countAccMpi_dd, 1, 'mpi_integer', &
1797 'mpi_sum','grid',ierr)
1798 call rpn_comm_allReduce(countAcc_ff, countAccMpi_ff, 1, 'mpi_integer', &
1799 'mpi_sum','grid',ierr)
1800 call rpn_comm_allReduce(countAcc_tt, countAccMpi_tt, 1, 'mpi_integer', &
1801 'mpi_sum','grid',ierr)
1802 call rpn_comm_allReduce(countAcc_es, countAccMpi_es, 1, 'mpi_integer', &
1803 'mpi_sum','grid',ierr)
1804
1805 write(*,*)
1806 write(*,*) 'DD Rej/Acc = ',countRejMpi_dd, countAccMpi_dd
1807 write(*,*) 'FF Rej/Acc = ',countRejMpi_ff, countAccMpi_ff
1808 write(*,*) 'TT Rej/Acc = ',countRejMpi_tt, countAccMpi_tt
1809 write(*,*) 'ES Rej/Acc = ',countRejMpi_es, countAccMpi_es
1810 write(*,*)
1811
1812 ! Replace obs flags in obsSpaceData with obsFlags
1813 levStnIndex = 0
1814 call obs_set_current_header_list(obsdat,'UA')
1815 HEADER2: do
1816 headerIndex = obs_getHeaderIndex(obsdat)
1817 if (headerIndex < 0) exit HEADER2
1818
1819 ! skip if this headerIndex doesn't contain upper air obs
1820 upperAirObs = .false.
1821 call obs_set_current_body_list(obsdat, headerIndex)
1822 BODY3: do
1823 bodyIndex = obs_getBodyIndex(obsdat)
1824 if (bodyIndex < 0) exit BODY3
1825
1826 select case (obs_bodyElem_i(obsdat,OBS_VNM,bodyIndex))
1827 case (bufr_neuu, bufr_nevv, bufr_nett, bufr_nees)
1828 upperAirObs = .true.
1829 end select
1830 end do BODY3
1831 if (.not. upperAirObs) cycle HEADER2
1832
1833 levStnIndex = levStnIndex + 1
1834
1835 call obs_set_current_body_list(obsdat, headerIndex)
1836 BODY4: do
1837 bodyIndex = obs_getBodyIndex(obsdat)
1838 if (bodyIndex < 0) exit BODY4
1839
1840 select case (obs_bodyElem_i(obsdat,OBS_VNM,bodyIndex))
1841 case (bufr_neuu)
1842 call obs_bodySet_i(obsdat, OBS_FLG, bodyIndex, obsFlags(1,levStnIndex))
1843 case (bufr_nevv)
1844 call obs_bodySet_i(obsdat, OBS_FLG, bodyIndex, obsFlags(2,levStnIndex))
1845 case (bufr_nett)
1846 call obs_bodySet_i(obsdat, OBS_FLG, bodyIndex, obsFlags(3,levStnIndex))
1847 case (bufr_nees)
1848 call obs_bodySet_i(obsdat, OBS_FLG, bodyIndex, obsFlags(4,levStnIndex))
1849 end select
1850 end do BODY4
1851
1852 end do HEADER2
1853
1854 ! Deallocate arrays
1855 deallocate(surfPresInterp)
1856 deallocate(obsLevOffset)
1857 deallocate(obsType)
1858 deallocate(obsHeadDate)
1859 deallocate(obsHeadTime)
1860 deallocate(obsDate)
1861 deallocate(obsTime)
1862 deallocate(obsLaunchTime)
1863 deallocate(stationFlags)
1864 deallocate(obsLat)
1865 deallocate(obsLon)
1866 deallocate(stnId)
1867 deallocate(presInterp)
1868 deallocate(trajFlags)
1869 deallocate(obsFlags)
1870 deallocate(obsValues)
1871 deallocate(oMinusB)
1872 deallocate(obsLevOffsetMpi)
1873 deallocate(obsHeadDateMpi)
1874 deallocate(obsLaunchTimeMpi)
1875 deallocate(stationFlagsMpi)
1876 deallocate(obsLatMpi)
1877 deallocate(obsLonMpi)
1878 deallocate(trajFlagsMpi)
1879 deallocate(obsFlagsMpi)
1880 deallocate(obsValuesMpi)
1881 deallocate(oMinusBMpi)
1882 deallocate(stnIdMpi)
1883
1884 end subroutine thn_radiosonde
1885
1886 !---------------------------------------------------------------------
1887 ! Following are several subroutines needed by thn_radiosonde
1888 !---------------------------------------------------------------------
1889
1890 !--------------------------------------------------------------------------
1891 ! stringArrayToMpi
1892 !--------------------------------------------------------------------------
1893 subroutine stringArrayToMpi(array, arrayMpi)
1894 !
1895 !:Purpose: Do the equivalent of mpi_allgatherv for a string array
1896 !
1897 implicit none
1898
1899 ! Arguments:
1900 character(len=*), intent(in) :: array(:)
1901 character(len=*), intent(out) :: arrayMpi(:)
1902
1903 ! Locals:
1904 integer :: ierr, arrayIndex, charIndex, lenString
1905 integer :: nsize, nsizeMpi, allnsize(mmpi_nprocs)
1906 integer, allocatable :: stringInt(:), stringIntMpi(:)
1907
1908 nsize = size(array)
1909 call rpn_comm_allgather( nsize, 1, 'mpi_integer', &
1910 allnsize, 1, 'mpi_integer', &
1911 'GRID', ierr )
1912 nsizeMpi = sum(allnsize(:))
1913
1914 allocate(stringInt(nsize))
1915 allocate(stringIntMpi(nsizeMpi))
1916
1917 lenString = len(array(1))
1918 do charIndex = 1, lenString
1919 do arrayIndex = 1, nsize
1920 stringInt(arrayIndex) = iachar(array(arrayIndex)(charIndex:charIndex))
1921 end do
1922
1923 call intArrayToMpi(stringInt, stringIntMpi)
1924
1925 do arrayIndex = 1, nsizeMpi
1926 arrayMpi(arrayIndex)(charIndex:charIndex) = achar(stringIntMpi(arrayIndex))
1927 end do
1928 end do
1929
1930 deallocate(stringInt)
1931 deallocate(stringIntMpi)
1932
1933 end subroutine stringArrayToMpi
1934
1935 !--------------------------------------------------------------------------
1936 ! intArrayToMpi
1937 !--------------------------------------------------------------------------
1938 subroutine intArrayToMpi(array, arrayMpi, is_obsLevOffset_opt)
1939 !
1940 !:Purpose: Do the equivalent of mpi_allgatherv for an integer array,
1941 ! but with special treatment if array of obsLevOffset.
1942 !
1943 implicit none
1944
1945 ! Arguments:
1946 integer, intent(in) :: array(:)
1947 integer, intent(out) :: arrayMpi(:)
1948 logical, optional, intent(in) :: is_obsLevOffset_opt
1949
1950 ! Locals:
1951 integer :: ierr, procIndex, arrayIndex
1952 integer :: nsize, nsizeMpi, allnsize(mmpi_nprocs), displs(mmpi_nprocs)
1953 logical :: is_obsLevOffset
1954 integer, allocatable :: numLevels(:), numLevelsMpi(:)
1955
1956 if (present(is_obsLevOffset_opt)) then
1957 is_obsLevOffset = is_obsLevOffset_opt
1958 else
1959 is_obsLevOffset = .false.
1960 end if
1961
1962 if (is_obsLevOffset) then
1963
1964 ! special treatment is requirement for the variable "obsLevOffset"
1965
1966 nsize = size(array) - 1
1967 call rpn_comm_allgather( nsize, 1, 'mpi_integer', &
1968 allnsize, 1, 'mpi_integer', &
1969 'GRID', ierr )
1970 nsizeMpi = sum(allnsize(:))
1971
1972 if ( mmpi_myid == 0 ) then
1973 displs(1) = 0
1974 do procIndex = 2, mmpi_nprocs
1975 displs(procIndex) = displs(procIndex-1) + allnsize(procIndex-1)
1976 end do
1977 else
1978 displs(:) = 0
1979 end if
1980
1981 allocate(numLevels(nsize))
1982 allocate(numLevelsMpi(nsizeMpi))
1983 do arrayIndex = 1, nsize
1984 numLevels(arrayIndex) = array(arrayIndex+1) - array(arrayIndex)
1985 end do
1986 call rpn_comm_gatherv( numLevels , nsize, 'mpi_integer', &
1987 numLevelsMpi, allnsize, displs, 'mpi_integer', &
1988 0, 'GRID', ierr )
1989
1990 call rpn_comm_bcast(numLevelsMpi, nsizeMpi, 'mpi_integer', &
1991 0, 'GRID', ierr)
1992 arrayMpi(1) = 0
1993 do arrayIndex = 1, nsizeMpi
1994 arrayMpi(arrayIndex+1) = arrayMpi(arrayIndex) + numLevelsMpi(arrayIndex)
1995 end do
1996 deallocate(numLevels)
1997 deallocate(numLevelsMpi)
1998
1999 else
2000
2001 nsize = size(array)
2002 call rpn_comm_allgather( nsize, 1, 'mpi_integer', &
2003 allnsize, 1, 'mpi_integer', &
2004 'GRID', ierr )
2005 nsizeMpi = sum(allnsize(:))
2006
2007 if ( mmpi_myid == 0 ) then
2008 displs(1) = 0
2009 do procIndex = 2, mmpi_nprocs
2010 displs(procIndex) = displs(procIndex-1) + allnsize(procIndex-1)
2011 end do
2012 else
2013 displs(:) = 0
2014 end if
2015
2016 call rpn_comm_gatherv( array , nsize, 'mpi_integer', &
2017 arrayMpi, allnsize, displs, 'mpi_integer', &
2018 0, 'GRID', ierr )
2019
2020 call rpn_comm_bcast(arrayMpi, nsizeMpi, 'mpi_integer', &
2021 0, 'GRID', ierr)
2022 end if
2023
2024 end subroutine intArrayToMpi
2025
2026 !--------------------------------------------------------------------------
2027 ! realArrayToMpi
2028 !--------------------------------------------------------------------------
2029 subroutine realArrayToMpi(array, arrayMpi)
2030 !
2031 !:Purpose: Do the equivalent of mpi_allgatherv for a real array,
2032 !
2033 implicit none
2034
2035 ! Arguments:
2036 real(4), intent(in) :: array(:)
2037 real(4), intent(out) :: arrayMpi(:)
2038
2039 ! Locals:
2040 integer :: ierr, procIndex
2041 integer :: nsize, nsizeMpi, allnsize(mmpi_nprocs), displs(mmpi_nprocs)
2042
2043 nsize = size(array)
2044 call rpn_comm_allgather( nsize, 1, 'mpi_integer', &
2045 allnsize, 1, 'mpi_integer', &
2046 'GRID', ierr )
2047 nsizeMpi = sum(allnsize(:))
2048
2049 if ( mmpi_myid == 0 ) then
2050 displs(1) = 0
2051 do procIndex = 2, mmpi_nprocs
2052 displs(procIndex) = displs(procIndex-1) + allnsize(procIndex-1)
2053 end do
2054 else
2055 displs(:) = 0
2056 end if
2057
2058 call rpn_comm_gatherv( array , nsize, 'mpi_real4', &
2059 arrayMpi, allnsize, displs, 'mpi_real4', &
2060 0, 'GRID', ierr )
2061
2062 call rpn_comm_bcast(arrayMpi, nsizeMpi, 'mpi_real4', &
2063 0, 'GRID', ierr)
2064
2065 end subroutine realArrayToMpi
2066
2067 !--------------------------------------------------------------------------
2068 ! logicalArrayToMpi
2069 !--------------------------------------------------------------------------
2070 subroutine logicalArrayToMpi(array, arrayMpi)
2071 !
2072 !:Purpose: Do the equivalent of mpi_allgatherv for a logical array,
2073 !
2074 implicit none
2075
2076 ! Arguments:
2077 logical, intent(in) :: array(:)
2078 logical, intent(out) :: arrayMpi(:)
2079
2080 ! Locals:
2081 integer :: ierr, procIndex
2082 integer :: nsize, nsizeMpi, allnsize(mmpi_nprocs), displs(mmpi_nprocs)
2083
2084 nsize = size(array)
2085 call rpn_comm_allgather( nsize, 1, 'mpi_integer', &
2086 allnsize, 1, 'mpi_integer', &
2087 'GRID', ierr )
2088 nsizeMpi = sum(allnsize(:))
2089
2090 if ( mmpi_myid == 0 ) then
2091 displs(1) = 0
2092 do procIndex = 2, mmpi_nprocs
2093 displs(procIndex) = displs(procIndex-1) + allnsize(procIndex-1)
2094 end do
2095 else
2096 displs(:) = 0
2097 end if
2098
2099 call rpn_comm_gatherv( array , nsize, 'mpi_logical', &
2100 arrayMpi, allnsize, displs, 'mpi_logical', &
2101 0, 'GRID', ierr )
2102
2103 call rpn_comm_bcast(arrayMpi, nsizeMpi, 'mpi_logical', &
2104 0, 'GRID', ierr)
2105
2106 end subroutine logicalArrayToMpi
2107
2108 !--------------------------------------------------------------------------
2109 ! raobs_check_duplicated_stations
2110 !--------------------------------------------------------------------------
2111 subroutine raobs_check_duplicated_stations ( stnId, obsLevOffset, obsLat, obsLon, &
2112 obsHeadDate, trajFlags, obsFlags, obsValues, &
2113 oMinusB, obsLaunchTime, stationFlags, &
2114 numVars, numStation, toleranceFactor )
2115 !
2116 !:Purpose: Check duplicated stations and select the best TAC/BUFR profiles
2117 !
2118 implicit none
2119
2120 ! Arguments:
2121 integer, intent(in) :: numVars, numStation
2122 integer, intent(in) :: obsHeadDate(:), obsLaunchTime(:), stationFlags(:)
2123 real(4), intent(in) :: obsLat(:), obsLon(:)
2124 real(4), intent(in) :: obsValues(:,:), oMinusB(:,:), toleranceFactor
2125 integer, intent(in) :: trajFlags(:,:)
2126 integer, intent(in) :: obsFlags(:,:)
2127 integer, intent(in) :: obsLevOffset(:)
2128 character(len=9), intent(inout) :: stnId(:)
2129
2130 ! Locals:
2131 integer, parameter :: maxNumStnid = 5000
2132 logical :: condition, sameProfile, stnidNotFound
2133 integer :: stationIndex, stationIndex2, stationIndex3, catIndex
2134 integer :: greaterNumVal, numDuplicate, numDuplicateTotal, selectStationIndex
2135 integer :: bufrStationIndex, tacStationIndex, numChecked, numStnid, numSame
2136 character (len=9) :: stnidList(maxNumStnid)
2137 integer :: stationIndexList(maxNumStnid)
2138 integer :: numCriteria(5), cloche(30), selectCriteria
2139
2140 numCriteria(:) = 0
2141 cloche(:) = 0
2142
2143 ! Check for duplication of TAC or BUFR profiles
2144
2145 numDuplicateTotal = 0
2146 do stationIndex = 1, numStation
2147
2148 if ( stnId(stationIndex) /= 'NOT_VALID' ) then
2149
2150 greaterNumVal = obsLevOffset(stationIndex+1) - obsLevOffset(stationIndex) + 1
2151 selectStationIndex = stationIndex
2152 numDuplicate = 0
2153
2154 ! Verify if there exists two records with the same stnid, date, time, flgs.
2155 ! Keep the one with the greatest number of vertical levels
2156 do stationIndex2 = stationIndex+1, numStation
2157
2158 if ( stnId(stationIndex2) /= 'NOT_VALID' ) then
2159 condition = stnId(stationIndex2) == stnId(stationIndex) .and. &
2160 obsHeadDate(stationIndex2) == obsHeadDate(stationIndex) .and. &
2161 obsLaunchTime(stationIndex2) == obsLaunchTime(stationIndex) .and. &
2162 obsLat(stationIndex2) == obsLat(stationIndex) .and. &
2163 obsLon(stationIndex2) == obsLon(stationIndex) .and. &
2164 stationFlags(stationIndex2) == stationFlags(stationIndex)
2165
2166 if ( condition ) then
2167 numDuplicate = numDuplicate + 1
2168 if ( (obsLevOffset(stationIndex2+1) - obsLevOffset(stationIndex2) + 1) > &
2169 greaterNumVal ) then
2170 greaterNumVal = obsLevOffset(stationIndex2+1) - &
2171 obsLevOffset(stationIndex2) + 1
2172 selectStationIndex = stationIndex2
2173 end if
2174 end if
2175 end if
2176
2177 end do ! stationIndex2
2178
2179 ! Invalid all duplicated station except one with greatest number of levels
2180 if (numDuplicate > 0) then
2181 do stationIndex2 = stationIndex, numStation
2182 if ( stnId(stationIndex2) /= 'NOT_VALID' .and. &
2183 stnId(stationIndex2) == stnId(stationIndex) .and. &
2184 selectStationIndex /= stationIndex2 ) then
2185 write(*,'(2A20,I10,2F9.2,I10)') 'Station duplique ', stnId(stationIndex2), &
2186 obsLevOffset(stationIndex2+1)-obsLevOffset(stationIndex2), &
2187 obsLat(stationIndex2), obsLon(stationIndex2), &
2188 obsLaunchTime(stationIndex2)
2189 stnId(stationIndex2) = 'NOT_VALID'
2190 end if
2191 end do
2192 numDuplicateTotal = numDuplicateTotal + numDuplicate
2193 end if
2194
2195 end if
2196
2197 end do ! stationIndex
2198
2199 ! Select best profile for collocated TAC or BUFR reports
2200 if (mmpi_myid == 0) then
2201 open(unit=11, file='./selected_stations_tac_bufr.txt', status='UNKNOWN')
2202 end if
2203
2204 numChecked = 0
2205 do stationIndex = 1, numStation
2206
2207 if ( stnId(stationIndex) /= 'NOT_VALID' ) then
2208
2209 do stationIndex2 = stationIndex+1, numStation
2210
2211 if ( stnId(stationIndex2) /= 'NOT_VALID' ) then
2212 condition = (stnId(stationIndex2) == stnId(stationIndex)) .and. &
2213 ( btest(stationFlags(stationIndex),23) .neqv. &
2214 btest(stationFlags(stationIndex2),23) )
2215
2216 if ( condition ) then
2217
2218 if (obsLaunchTime(stationIndex2) == obsLaunchTime(stationIndex)) then
2219 sameProfile = .true.
2220 else
2221 call raobs_check_if_same_profile(stationIndex,stationIndex2, &
2222 obsValues,obsLevOffset,sameProfile)
2223 end if
2224
2225 if ( sameProfile ) then
2226
2227 numChecked = numChecked + 1
2228
2229 call raobs_compare_profiles(stationIndex, stationIndex2, &
2230 stationFlags, trajFlags, obsFlags, obsValues, &
2231 oMinusB, obsLevOffset, &
2232 numVars, cloche, selectCriteria, &
2233 selectStationIndex, toleranceFactor)
2234
2235 numCriteria(selectCriteria) = numCriteria(selectCriteria) + 1
2236
2237 bufrStationIndex = stationIndex2
2238 if ( btest(stationFlags(stationIndex),23) ) bufrStationIndex = stationIndex
2239 tacStationIndex = stationIndex2
2240 if ( .not.btest(stationFlags(stationIndex),23) ) tacStationIndex = stationIndex
2241
2242 if (mmpi_myid == 0) write(11,'(A9,2F10.3,3I10)') stnId(stationIndex), &
2243 obsLat(stationIndex), obsLon(stationIndex), &
2244 obsLevOffset(bufrStationIndex+1)-obsLevOffset(bufrStationIndex)+1, &
2245 obsLevOffset(tacStationIndex+1)-obsLevOffset(tacStationIndex)+1, selectCriteria
2246
2247 if ( selectStationIndex == stationIndex) stnId(stationIndex2) = 'NOT_VALID'
2248 if ( selectStationIndex == stationIndex2) stnId(stationIndex) = 'NOT_VALID'
2249
2250 end if ! sameProfile
2251
2252 end if ! condition
2253
2254 end if ! stnId(stationIndex2) /= 'NOT_VALID'
2255
2256 end do ! stationIndex2
2257
2258 end if ! stnId(stationIndex) /= 'NOT_VALID'
2259
2260 end do ! stationIndex
2261
2262 write(*,*)
2263 write(*,*)
2264 write(*,'(a30,I10)') 'nb of total duplicates ' ,numDuplicateTotal
2265 write(*,'(a30,I10)') 'nb TAC vs BUFR checked' ,numChecked
2266 write(*,'(a30,I10)') 'nb not selected' ,numCriteria(1)
2267 write(*,'(a30,I10)') 'nb suspicious traj BUFR' ,numCriteria(2)
2268 write(*,'(a30,I10)') 'nb Energy higher BUFR' ,numCriteria(3)
2269 write(*,'(a30,I10)') 'nb variables lower BUFR' ,numCriteria(4)
2270 write(*,'(a30,I10)') 'nb TAC selected' ,numCriteria(2) + &
2271 numCriteria(3) + numCriteria(4)
2272 write(*,'(a30,I10)') 'nb BUFR selected' ,numCriteria(5)
2273 write(*,*)
2274 write(*,*)
2275
2276 do catIndex = 1, 29
2277 write(*,'(a15,f4.2,a3,f4.2,I5)') 'nb e ratio ',(catIndex/10.)-.05,' - ', &
2278 (catIndex/10.)+.05,cloche(catIndex)
2279 end do
2280 write(*,*)
2281 write(*,'(a30,I5)') 'nb of energyTot(2)) very small ',cloche(30)
2282 write(*,*)
2283
2284 if (mmpi_myid == 0) close(unit=11)
2285
2286 ! Check whether there is still duplications
2287 numStnid = 0
2288 do stationIndex = 1, numStation
2289
2290 if ( stnId(stationIndex) /= 'NOT_VALID' ) then
2291
2292 if (numStnid < maxNumStnid ) then
2293 stnidNotFound=.true.
2294 if ( numStnid == 0) then
2295 numStnid = numStnid + 1
2296 stnidList(numStnid) = stnId(stationIndex)
2297 stationIndexList(numStnid) = stationIndex
2298 else
2299 numSame = 0
2300 do stationIndex2 = 1, numStnid
2301 if ( stnidList(stationIndex2) == stnId(stationIndex) ) then
2302 stnidNotFound=.false.
2303 numSame = numSame + 1
2304 stationIndex3 = stationIndexList(stationIndex2)
2305 end if
2306 end do
2307 if ( stnidNotFound ) then
2308 numStnid = numStnid + 1
2309 stnidList(numStnid) = stnId(stationIndex)
2310 stationIndexList(numStnid) = stationIndex
2311 else
2312 write(*,*) 'Multi profiles found : ',stnId(stationIndex), &
2313 stnId(stationIndex3),numSame,stationIndex,stationIndex3, &
2314 btest(stationFlags(stationIndex),23),btest(stationFlags(stationIndex3),23)
2315 write(*,'(a30,2i10,2f10.2,i10)') 'date, lch, lat lon ', &
2316 obsHeadDate(stationIndex),obsLaunchTime(stationIndex), &
2317 obsLat(stationIndex), obsLon(stationIndex), &
2318 obsLevOffset(stationIndex+1)-obsLevOffset(stationIndex)+1
2319 write(*,'(a30,2i10,2f10.2,i10)') 'date, lch, lat lon ', &
2320 obsHeadDate(stationIndex3),obsLaunchTime(stationIndex3), &
2321 obsLat(stationIndex3), obsLon(stationIndex3), &
2322 obsLevOffset(stationIndex3+1)-obsLevOffset(stationIndex3)+1
2323 write(*,*)
2324
2325 end if
2326 end if
2327 else
2328 write(*,*) 'numStnid >= ',maxNumStnid
2329 call utl_abort('raobs_check_duplicated_stations')
2330 end if
2331
2332 end if
2333
2334 end do
2335
2336 end subroutine raobs_check_duplicated_stations
2337
2338 !--------------------------------------------------------------------------
2339 ! raobs_check_if_same_profile
2340 !--------------------------------------------------------------------------
2341 subroutine raobs_check_if_same_profile( stationIndex, stationIndex2, &
2342 obsValues, obsLevOffset, sameProfile )
2343 !
2344 !:Purpose: Check if two raobs profiles are the same.
2345 !
2346 implicit none
2347
2348 ! Arguments:
2349 integer, intent(in) :: stationIndex, stationIndex2
2350 real(4), intent(in) :: obsValues(:,:)
2351 integer, intent(in) :: obsLevOffset(:)
2352 logical, intent(out) :: sameProfile
2353
2354 ! Locals:
2355 integer :: varIndex, levIndex, levStnIndex, levStnIndex1, levStnIndex2, numSum
2356 real(4) :: valSum, minDeltaP1, minDeltaP2
2357 integer, parameter :: numStdLevels = 16
2358 real(4) :: standardLevels(numStdLevels)
2359 standardLevels = (/ 1000.,925.,850.,700.,500.,400.,300.,250.,200.,150., &
2360 100.,70.,50.,30.,20.,10./)
2361
2362 valSum = 0.0
2363 numSum = 0
2364
2365 sameProfile = .false.
2366
2367 do levIndex = 1, numStdLevels
2368
2369 minDeltaP1 = 1000.
2370 do levStnIndex = obsLevOffset(stationIndex)+1, obsLevOffset(stationIndex+1)
2371 if ( abs(standardLevels(levIndex) - obsValues(5,levStnIndex)) < minDeltaP1 ) then
2372 levStnIndex1 = levStnIndex
2373 minDeltaP1 = abs(standardLevels(levIndex) - obsValues(5,levStnIndex))
2374 end if
2375 end do
2376 minDeltaP2 = 1000.
2377 do levStnIndex = obsLevOffset(stationIndex2)+1, obsLevOffset(stationIndex2+1)
2378 if ( abs(standardLevels(levIndex) - obsValues(5,levStnIndex)) < minDeltaP2 ) then
2379 levStnIndex2 = levStnIndex
2380 minDeltaP2 = abs(standardLevels(levIndex) - obsValues(5,levStnIndex))
2381 end if
2382 end do
2383
2384 if ( minDeltaP1 < 1.0 .and. minDeltaP2 < 1.0 ) then
2385 do varIndex = 2, 4, 2
2386
2387 if ( obsValues(varIndex,levStnIndex1) /= -999.0 .and. &
2388 obsValues(varIndex,levStnIndex2) /= -999.0 ) then
2389 valSum = valSum + abs(obsValues(varIndex,levStnIndex1) - &
2390 obsValues(varIndex,levStnIndex2))
2391 numSum = numSum + 1
2392 end if
2393
2394 end do
2395
2396 end if
2397
2398 end do !levIndex
2399
2400 if (numSum > 0) then
2401 if (valSum/numSum < 0.5) sameProfile = .true.
2402 end if
2403
2404 end subroutine raobs_check_if_same_profile
2405
2406 !--------------------------------------------------------------------------
2407 ! raobs_compare_profiles
2408 !--------------------------------------------------------------------------
2409 subroutine raobs_compare_profiles( stationIndex, stationIndex2, stationFlags, trajFlags, &
2410 obsFlags, obsValues, oMinusB, obsLevOffset, numVars, &
2411 cloche, selectCriteria, selectStationIndex, toleranceFactor )
2412 !
2413 !:Purpose: Perform a comparison between two raobs profiles.
2414 !
2415 implicit none
2416
2417 ! Arguments:
2418 integer, intent(in) :: stationIndex, stationIndex2, numVars
2419 integer, intent(in) :: trajFlags(:,:)
2420 integer, intent(in) :: obsFlags(:,:)
2421 real(4), intent(in) :: obsValues(:,:), oMinusB(:,:), toleranceFactor
2422 integer, intent(in) :: obsLevOffset(:), stationFlags(:)
2423 integer, intent(inout) :: cloche(:)
2424 integer, intent(out) :: selectCriteria, selectStationIndex
2425
2426 ! Locals:
2427 logical :: condition, tacAndBufr, trajInfoOk
2428 integer :: raobFormatIndex, varIndex, levStnIndex, levStnIndex2, catIndex
2429 integer :: bufrStationIndex, tacStationIndex, countTimeFlag, countLatFlag, countTraj
2430 integer :: countValues(2), thisStationIndex
2431 real(4) :: presBottom, ombBottom, deltaPres, sumDeltaPres, oMinusBavg
2432 real(4) :: sumEnergy, presLower, presUpper
2433 real(4) :: percentTrajBad
2434 real(4) :: sumEnergyVar(numVars,2), energyTot(2)
2435 real(4) :: presLowerTacBufr(numVars,2), presUpperTacBufr(numVars,2)
2436
2437 percentTrajBad = 10.0
2438 catIndex = 1
2439 selectCriteria = 1
2440
2441 tacAndBufr = .true.
2442 trajInfoOk = .true.
2443
2444 if ( btest(stationFlags(stationIndex),23) .and. &
2445 btest(stationFlags(stationIndex2),23) ) tacAndBufr = .false.
2446 if ( .not.btest(stationFlags(stationIndex),23) .and. &
2447 .not.btest(stationFlags(stationIndex2),23) ) tacAndBufr = .false.
2448
2449 if ( tacAndBufr ) then
2450
2451 bufrStationIndex = stationIndex2
2452 if ( btest(stationFlags(stationIndex),23) ) bufrStationIndex = stationIndex
2453 tacStationIndex = stationIndex2
2454 if ( .not.btest(stationFlags(stationIndex),23) ) tacStationIndex = stationIndex
2455 selectStationIndex = tacStationIndex
2456
2457 ! 1. Evalue si la trajectoire native est correct
2458
2459 if ( btest(stationFlags(bufrStationIndex),14) ) then
2460
2461 countTimeFlag = 0
2462 countLatFlag = 0
2463 countTraj = obsLevOffset(bufrStationIndex+1) - obsLevOffset(bufrStationIndex) + 1
2464
2465 do levStnIndex = obsLevOffset(bufrStationIndex)+1, obsLevOffset(bufrStationIndex+1)
2466 if ( btest(trajFlags(1,levStnIndex),4) ) countTimeFlag = countTimeFlag + 1
2467 if ( btest(trajFlags(2,levStnIndex),4) ) countLatFlag = countLatFlag + 1
2468 end do
2469
2470 if (100.*countTimeFlag/countTraj > percentTrajBad .or. &
2471 100.*countLatFlag/countTraj > percentTrajBad) then
2472 trajInfoOk = .false.
2473 selectStationIndex = tacStationIndex
2474 selectCriteria = 2
2475 end if
2476
2477 end if
2478
2479 if (trajInfoOk) then
2480
2481 ! Cherche les pressions (bas et haut) des extremites des profils (TAC et BUFR)
2482
2483 do raobFormatIndex = 1, 2
2484
2485 if (raobFormatIndex == 1) thisStationIndex = bufrStationIndex
2486 if (raobFormatIndex == 2) thisStationIndex = tacStationIndex
2487
2488 do varIndex = 1, 3
2489
2490 presLowerTacBufr(varIndex,raobFormatIndex) = 1000.0
2491 do levStnIndex = obsLevOffset(thisStationIndex)+1, &
2492 obsLevOffset(thisStationIndex+1)
2493 condition = oMinusB(varIndex,levStnIndex) /= -999.0 .and. &
2494 .not.btest(obsFlags(varIndex,levStnIndex),18) .and. &
2495 .not.btest(obsFlags(varIndex,levStnIndex),16) .and. &
2496 .not.btest(obsFlags(varIndex,levStnIndex),9) .and. &
2497 .not.btest(obsFlags(varIndex,levStnIndex),8) .and. &
2498 .not.btest(obsFlags(varIndex,levStnIndex),2) .and. &
2499 .not.btest(obsFlags(varIndex,levStnIndex),11)
2500 if ( condition ) then
2501 presLowerTacBufr(varIndex,raobFormatIndex) = obsValues(5,levStnIndex)
2502 exit
2503 end if
2504
2505 end do
2506 presUpperTacBufr(varIndex,raobFormatIndex) = &
2507 presLowerTacBufr(varIndex,raobFormatIndex)
2508
2509 if (levStnIndex < obsLevOffset(thisStationIndex+1) ) then
2510
2511 do levStnIndex2 = levStnIndex+1, obsLevOffset(thisStationIndex+1)
2512
2513 condition = oMinusB(varIndex,levStnIndex2) /= -999.0 .and. &
2514 .not.btest(obsFlags(varIndex,levStnIndex2),18) .and. &
2515 .not.btest(obsFlags(varIndex,levStnIndex2),16) .and. &
2516 .not.btest(obsFlags(varIndex,levStnIndex2),9) .and. &
2517 .not.btest(obsFlags(varIndex,levStnIndex2),8) .and. &
2518 .not.btest(obsFlags(varIndex,levStnIndex2),2) .and. &
2519 .not.btest(obsFlags(varIndex,levStnIndex2),11)
2520 if ( condition ) then
2521 presUpperTacBufr(varIndex,raobFormatIndex) = obsValues(5,levStnIndex2)
2522 end if
2523
2524 end do
2525
2526 end if
2527
2528 end do !varIndex
2529
2530 end do !raobFormatIndex
2531
2532 ! Calcul de la norme energie equivalente (NE)
2533
2534 do raobFormatIndex = 1, 2
2535
2536 if (raobFormatIndex == 1) thisStationIndex = bufrStationIndex
2537 if (raobFormatIndex == 2) thisStationIndex = tacStationIndex
2538
2539 countValues(raobFormatIndex) = 0
2540
2541 do varIndex = 1, 3
2542
2543 presLower = presLowerTacBufr(varIndex,1)
2544 if ( presLower > presLowerTacBufr(varIndex,2) ) then
2545 presLower = presLowerTacBufr(varIndex,2)
2546 end if
2547 presUpper = presUpperTacBufr(varIndex,1)
2548 if ( presUpper < presUpperTacBufr(varIndex,2) ) then
2549 presUpper = presUpperTacBufr(varIndex,2)
2550 end if
2551
2552 sumDeltaPres = 0.0
2553 sumEnergy = 0.0
2554 sumEnergyVar(varIndex,raobFormatIndex) = 0.0
2555
2556 do levStnIndex = obsLevOffset(thisStationIndex)+1, &
2557 obsLevOffset(thisStationIndex+1)
2558
2559 condition = oMinusB(varIndex,levStnIndex) /= -999.0 .and. &
2560 .not.btest(obsFlags(varIndex,levStnIndex),18) .and. &
2561 .not.btest(obsFlags(varIndex,levStnIndex),16) .and. &
2562 .not.btest(obsFlags(varIndex,levStnIndex),9) .and. &
2563 .not.btest(obsFlags(varIndex,levStnIndex),8) .and. &
2564 .not.btest(obsFlags(varIndex,levStnIndex),2) .and. &
2565 .not.btest(obsFlags(varIndex,levStnIndex),11)
2566
2567 if ( condition ) then
2568 countValues(raobFormatIndex) = countValues(raobFormatIndex) + 1
2569 if ( obsValues(5,levStnIndex) <= presLower ) then
2570 presBottom = obsValues( 5,levStnIndex)
2571 ombBottom = oMinusB(varIndex,levStnIndex)
2572 exit
2573 end if
2574 end if
2575
2576 end do
2577
2578 if (levStnIndex < obsLevOffset(thisStationIndex+1) ) then
2579
2580 do levStnIndex2 = levStnIndex+1, obsLevOffset(thisStationIndex+1)
2581
2582 condition = oMinusB(varIndex,levStnIndex2) /= -999.0 .and. &
2583 .not.btest(obsFlags(varIndex,levStnIndex2),18) .and. &
2584 .not.btest(obsFlags(varIndex,levStnIndex2),16) .and. &
2585 .not.btest(obsFlags(varIndex,levStnIndex2),9) .and. &
2586 .not.btest(obsFlags(varIndex,levStnIndex2),8) .and. &
2587 .not.btest(obsFlags(varIndex,levStnIndex2),2) .and. &
2588 .not.btest(obsFlags(varIndex,levStnIndex2),11)
2589 if ( condition ) then
2590 countValues(raobFormatIndex) = countValues(raobFormatIndex) + 1
2591 if ( obsValues(5,levStnIndex2) >= presUpper ) then
2592 deltaPres = log(presBottom) - log(obsValues(5,levStnIndex2))
2593 oMinusBavg = ( ombBottom + oMinusB(varIndex,levStnIndex2) ) / 2
2594 sumEnergy = sumEnergy + deltaPres * oMinusBavg**2
2595 sumDeltaPres = sumDeltaPres + deltaPres
2596 presBottom = obsValues( 5,levStnIndex2)
2597 ombBottom = oMinusB(varIndex,levStnIndex2)
2598 end if
2599 end if
2600
2601 end do
2602
2603 end if
2604 if (sumDeltaPres > 0.) then
2605 sumEnergyVar(varIndex,raobFormatIndex) = sumEnergy/sumDeltaPres
2606 end if
2607
2608 end do ! varIndex
2609
2610 energyTot(raobFormatIndex) = sumEnergyVar(1,raobFormatIndex) + &
2611 sumEnergyVar(2,raobFormatIndex) + &
2612 (1005./300.)*sumEnergyVar(3,raobFormatIndex)
2613
2614 end do ! raobFormatIndex
2615
2616 ! 2. Choisi le profil TAC (raobFormatIndex==2) si le nombre de niveaux ou
2617 ! il y a des donnees est plus grand ou egal au nombre dans le profil
2618 ! BUFR (raobFormatIndex==1)
2619
2620 if ( countValues(2) >= countValues(1) ) then
2621
2622 selectStationIndex = tacStationIndex
2623 selectCriteria = 4
2624
2625 else
2626
2627 ! 3. Choisi le profil BUFR si la norme energie equivalente du profil
2628 ! ne depasse pas 'toleranceFactor'
2629
2630 if (abs(energyTot(2)) > 1.e-6) catIndex = nint(10.*energyTot(1)/energyTot(2)) + 1
2631 if (catIndex > 30) catIndex = 30
2632
2633 cloche(catIndex) = cloche(catIndex) + 1
2634
2635 if ( energyTot(1) <= toleranceFactor*energyTot(2) ) then
2636
2637 selectStationIndex = bufrStationIndex
2638 selectCriteria = 5
2639
2640 else
2641
2642 selectStationIndex = tacStationIndex
2643 selectCriteria = 3
2644
2645 end if
2646
2647 end if
2648
2649 end if ! trajInfoOk
2650
2651 else
2652
2653 write(*,*) 'MEME TYPE DE FICHIER'
2654
2655 end if !tacAndBufr
2656
2657 end subroutine raobs_compare_profiles
2658
2659 !--------------------------------------------------------------------------
2660 ! raobs_thinning_model
2661 !--------------------------------------------------------------------------
2662 subroutine raobs_thinning_model( obsFlags, obsValues, presInterp, numVars, numLev, &
2663 numStation, numLevStnMax, obsLevOffset )
2664 !
2665 !:Purpose: Perform raobs thinning by comparing with a set of model levels.
2666 !
2667 implicit none
2668
2669 ! Arguments:
2670 integer, intent(in) :: numVars, numLev, numStation, numLevStnMax
2671 integer, intent(in) :: obsLevOffset(:)
2672 integer, intent(inout) :: obsFlags(:,:)
2673 real(4), intent(in) :: obsValues(:,:)
2674 real(4), intent(in) :: presInterp(:,:)
2675
2676 ! Locals:
2677 logical :: condition, debug
2678 integer :: stationIndex, levIndex, levStnIndex, stdLevelIndex, varIndex
2679 integer :: varIndexDD, varIndexFF, varIndexPres
2680 integer :: levSelectIndex, levSelectIndex2, numLevSelect, levStnIndexValid
2681 integer :: numLevSelectBest, tempInt
2682 real(4) :: presTop, presBottom, deltaPres, deltaPresMin
2683 integer, allocatable :: levStnIndexList(:), numValidObs(:), listIndex(:)
2684 ! Standard levels including 925 hPa
2685 integer, parameter :: numStdLevels = 16
2686 real(4) :: standardLevels(numStdLevels)
2687 standardLevels(1:numStdLevels) = (/ 1000.,925.,850.,700.,500.,400.,300.,250.,200.,150., &
2688 100.,70.,50.,30.,20.,10./)
2689
2690 varIndexDD = 1
2691 varIndexFF = 2
2692 varIndexPres = 5
2693 debug = .false.
2694
2695 allocate(levStnIndexList(numLevStnMax))
2696 allocate(numValidObs(numLevStnMax))
2697 allocate(listIndex(numLevStnMax))
2698
2699 do stationIndex = 1, numStation
2700
2701 ! If one obsFlags is set to 0 but not the other then make the obsFlagss consistent
2702 ! and obsFlags wind direction and module if one of these wind variables is missing
2703
2704 do levStnIndex = obsLevOffset(stationIndex)+1, obsLevOffset(stationIndex+1)
2705
2706 if ( obsFlags(varIndexDD,levStnIndex) == 0 .and. &
2707 obsFlags(varIndexFF,levStnIndex) /= 0 ) then
2708 obsFlags(varIndexDD,levStnIndex) = obsFlags(varIndexFF,levStnIndex)
2709 end if
2710 if ( obsFlags(varIndexDD,levStnIndex) /= 0 .and. &
2711 obsFlags(varIndexFF,levStnIndex) == 0 ) then
2712 obsFlags(varIndexFF,levStnIndex) = obsFlags(varIndexDD,levStnIndex)
2713 end if
2714
2715 if ( (obsValues(varIndexDD,levStnIndex) < 0. .and. &
2716 obsValues(varIndexFF,levStnIndex) >= 0.) .or. &
2717 (obsValues(varIndexDD,levStnIndex) >= 0. .and. &
2718 obsValues(varIndexFF,levStnIndex) < 0.) ) then
2719 obsFlags(varIndexDD,levStnIndex) = ibset(obsFlags(varIndexDD,levStnIndex),11)
2720 obsFlags(varIndexFF,levStnIndex) = ibset(obsFlags(varIndexFF,levStnIndex),11)
2721 end if
2722
2723 end do
2724
2725 do levIndex = 1, numLev
2726
2727 ! Pressures at the bottom and top of the model layer
2728
2729 if (levIndex == 1) then
2730 presTop = presInterp(stationIndex,levIndex)
2731 presBottom = exp( 0.5*alog(presInterp(stationIndex,levIndex+1) * &
2732 presInterp(stationIndex,levIndex)) )
2733 else if (levIndex == numLev) then
2734 presTop = exp( 0.5*alog(presInterp(stationIndex,levIndex-1) * &
2735 presInterp(stationIndex,levIndex)) )
2736 presBottom = presInterp(stationIndex,levIndex)
2737 else
2738 presTop = exp( 0.5*alog(presInterp(stationIndex,levIndex-1) * &
2739 presInterp(stationIndex,levIndex)) )
2740 presBottom = exp( 0.5*alog(presInterp(stationIndex,levIndex+1) * &
2741 presInterp(stationIndex,levIndex)) )
2742 end if
2743
2744 ! Select the observation levels between presTop and presBottom
2745
2746 numLevSelect = 0
2747 do levStnIndex = obsLevOffset(stationIndex)+1, obsLevOffset(stationIndex+1)
2748
2749 if (obsValues(varIndexPres,levStnIndex) > presTop .and. &
2750 obsValues(varIndexPres,levStnIndex) <= presBottom) then
2751
2752 numLevSelect = numLevSelect + 1
2753 levStnIndexList(numLevSelect) = levStnIndex
2754 numValidObs(numLevSelect) = 0
2755
2756 ! numValidObs(numLevSelect) contains number of valid obs at each level selected
2757
2758 do varIndex = 1, numVars
2759 condition = obsValues(varIndex,levStnIndex) >= 0. .and. &
2760 .not.btest(obsFlags(varIndex,levStnIndex),18) .and. &
2761 .not.btest(obsFlags(varIndex,levStnIndex),16) .and. &
2762 .not.btest(obsFlags(varIndex,levStnIndex),9) .and. &
2763 .not.btest(obsFlags(varIndex,levStnIndex),8) .and. &
2764 .not.btest(obsFlags(varIndex,levStnIndex),2) .and. &
2765 .not.btest(obsFlags(varIndex,levStnIndex),11)
2766 if ( condition ) numValidObs(numLevSelect) = numValidObs(numLevSelect) + 1
2767 end do
2768
2769 end if
2770
2771 end do ! levStnIndex
2772
2773 if ( numLevSelect > 0 ) then
2774
2775 ! Sort the observation levels by greatest numbers of valid observations
2776
2777 do levSelectIndex = 1, numLevSelect
2778 listIndex(levSelectIndex) = levSelectIndex
2779 end do
2780 do levSelectIndex = 1, numLevSelect
2781 do levSelectIndex2 = levSelectIndex, numLevSelect
2782 if ( numValidObs(levSelectIndex2) > numValidObs(levSelectIndex) ) then
2783 tempInt = numValidObs(levSelectIndex)
2784 numValidObs(levSelectIndex) = numValidObs(levSelectIndex2)
2785 numValidObs(levSelectIndex2) = tempInt
2786 tempInt = listIndex(levSelectIndex)
2787 listIndex(levSelectIndex) = listIndex(levSelectIndex2)
2788 listIndex(levSelectIndex2) = tempInt
2789 end if
2790 end do
2791 end do
2792 numLevSelectBest = 1
2793 if ( numLevSelect > 1 ) then
2794 do levSelectIndex = 2, numLevSelect
2795 if (numValidObs(levSelectIndex) == numValidObs(1)) then
2796 numLevSelectBest = numLevSelectBest + 1
2797 end if
2798 end do
2799 end if
2800
2801 do varIndex = 1, numVars
2802
2803 levStnIndexValid = 0
2804
2805 ! Rule #1 : get valid the observation at the standard level if one
2806 ! is found in the layer
2807
2808 do levSelectIndex = 1, numLevSelect
2809
2810 levStnIndex = levStnIndexList(levSelectIndex)
2811
2812 condition = obsValues(varIndex,levStnIndex) >= 0. .and. &
2813 .not.btest(obsFlags(varIndex,levStnIndex),18) .and. &
2814 .not.btest(obsFlags(varIndex,levStnIndex),16) .and. &
2815 .not.btest(obsFlags(varIndex,levStnIndex),9) .and. &
2816 .not.btest(obsFlags(varIndex,levStnIndex),8) .and. &
2817 .not.btest(obsFlags(varIndex,levStnIndex),2) .and. &
2818 .not.btest(obsFlags(varIndex,levStnIndex),11)
2819
2820 do stdLevelIndex = 1, numStdLevels
2821 if ( (obsValues(varIndexPres,levStnIndex) == &
2822 standardLevels(stdLevelIndex)) .and. &
2823 condition ) then
2824 levStnIndexValid = levStnIndex
2825 end if
2826 end do
2827
2828 end do ! levSelectIndex
2829
2830 if ( levStnIndexValid == 0 ) then
2831
2832 ! Rule #2 : get the closest valid observation to the model level
2833 ! and most complete
2834
2835 deltaPresMin = presBottom - presTop
2836 do levSelectIndex = 1, numLevSelectBest
2837
2838 levStnIndex = levStnIndexList(listIndex(levSelectIndex))
2839
2840 deltaPres = abs(obsValues(varIndexPres,levStnIndex) - &
2841 presInterp(stationIndex,levIndex))
2842 condition = obsValues(varIndex,levStnIndex) >= 0. .and. &
2843 .not.btest(obsFlags(varIndex,levStnIndex),18) .and. &
2844 .not.btest(obsFlags(varIndex,levStnIndex),16) .and. &
2845 .not.btest(obsFlags(varIndex,levStnIndex),9) .and. &
2846 .not.btest(obsFlags(varIndex,levStnIndex),8) .and. &
2847 .not.btest(obsFlags(varIndex,levStnIndex),2) .and. &
2848 .not.btest(obsFlags(varIndex,levStnIndex),11)
2849
2850 if ( deltaPres < deltaPresMin .and. condition) then
2851 deltaPresMin = deltaPres
2852 levStnIndexValid = levStnIndex
2853 end if
2854
2855 end do ! levSelectIndex
2856
2857 end if ! levStnIndexValid == 0
2858
2859 if ( levStnIndexValid == 0 ) then
2860
2861 ! Rule #3 : get the closest valid observation if not previously selected
2862
2863 deltaPresMin = presBottom - presTop
2864 do levSelectIndex = 1, numLevSelect
2865
2866 levStnIndex = levStnIndexList(levSelectIndex)
2867
2868 deltaPres = abs(obsValues(varIndexPres,levStnIndex) - &
2869 presInterp(stationIndex,levIndex))
2870 condition = obsValues(varIndex,levStnIndex) >= 0. .and. &
2871 .not.btest(obsFlags(varIndex,levStnIndex),18) .and. &
2872 .not.btest(obsFlags(varIndex,levStnIndex),16) .and. &
2873 .not.btest(obsFlags(varIndex,levStnIndex),9) .and. &
2874 .not.btest(obsFlags(varIndex,levStnIndex),8) .and. &
2875 .not.btest(obsFlags(varIndex,levStnIndex),2) .and. &
2876 .not.btest(obsFlags(varIndex,levStnIndex),11)
2877
2878 if ( deltaPres < deltaPresMin .and. condition) then
2879 deltaPresMin = deltaPres
2880 levStnIndexValid = levStnIndex
2881 end if
2882
2883 end do ! levSelectIndex
2884
2885 end if ! levStnIndexValid == 0
2886
2887 ! Apply thinning obsFlags to all obs except the one on level levStnIndexValid
2888
2889 do levSelectIndex = 1, numLevSelect
2890
2891 levStnIndex = levStnIndexList(levSelectIndex)
2892
2893 if ( levStnIndex /= levStnIndexValid .and. &
2894 obsValues(varIndex,levStnIndex) >= 0. ) then
2895 obsFlags(varIndex,levStnIndex) = ibset(obsFlags(varIndex,levStnIndex),11)
2896 end if
2897
2898 end do
2899
2900 end do !varIndex
2901
2902 end if !numLevSelect > 0
2903
2904 end do !levIndex
2905
2906 ! Following lines for debugging purposes
2907
2908 if ( debug ) then
2909
2910 levIndex = numLev
2911 presBottom = presInterp(stationIndex,levIndex)
2912 write (*,*) ' '
2913 write (*,'(a40,I8,a40)') ' ==================== Station no. ', &
2914 stationIndex,' =============================='
2915 write (*,*) ' '
2916 write (*,'(a80,f10.2,i10)') 'lowest model layer-------------> ',presBottom,levIndex
2917 do while(obsValues(varIndexPres,obsLevOffset(stationIndex)+1) < presBottom)
2918 levIndex = levIndex - 1
2919 presBottom = exp(0.5 * alog(presInterp(stationIndex,levIndex+1) * &
2920 presInterp(stationIndex,levIndex)))
2921 end do
2922 if (levIndex == numLev) levIndex = numLev - 1
2923
2924 do levStnIndex = obsLevOffset(stationIndex)+1, obsLevOffset(stationIndex+1)
2925
2926 presBottom = exp( 0.5*alog(presInterp(stationIndex,levIndex+1) * &
2927 presInterp(stationIndex,levIndex)) )
2928 do while(obsValues(varIndexPres,levStnIndex) < presBottom)
2929 write (*,'(a80,f10.2,i10)') 'model layer---------------> ',presBottom,levIndex
2930 levIndex = levIndex - 1
2931 presBottom = exp( 0.5*alog(presInterp(stationIndex,levIndex+1) * &
2932 presInterp(stationIndex,levIndex)) )
2933 end do
2934 write (*,'(5f8.2,4i8)') obsValues(varIndexPres,levStnIndex), &
2935 obsValues(1,levStnIndex), obsValues(2,levStnIndex), &
2936 obsValues(3,levStnIndex), obsValues(4,levStnIndex), &
2937 obsFlags(1,levStnIndex), obsFlags(2,levStnIndex), &
2938 obsFlags(3,levStnIndex), obsFlags(4,levStnIndex)
2939
2940 end do
2941
2942 end if
2943
2944 end do !stationIndex
2945
2946 deallocate(levStnIndexList, numValidObs, listIndex)
2947
2948 end subroutine raobs_thinning_model
2949
2950 !--------------------------------------------------------------------------
2951 ! raobs_thinning_es
2952 !--------------------------------------------------------------------------
2953 subroutine raobs_thinning_es( obsFlags, obsValues, numStation, &
2954 numLevStnMax, obsLevOffset )
2955 !
2956 !:Purpose: Perform thinning of T-Td raobs observations.
2957 !
2958 implicit none
2959
2960 ! Arguments:
2961 integer, intent(in) :: numStation, numLevStnMax
2962 integer, intent(in) :: obsLevOffset(:)
2963 integer, intent(inout) :: obsFlags(:,:)
2964 real(4), intent(in) :: obsValues(:,:)
2965
2966 ! Locals:
2967 integer, parameter :: numLevES = 42
2968 logical :: condition
2969 integer :: stationIndex, levIndex, levStnIndex, levSelectIndex, varIndexES, varIndexPres
2970 integer :: numLevSelect, levStnIndexValid
2971 real(4) :: levelsES(numLevES), deltaPres, deltaPresMin, presBottom, presTop
2972 integer, allocatable :: levStnIndexList(:)
2973
2974 ! Selected pressure levels for additional thinning to humitidy observations
2975
2976 levelsES(1:numLevES) = (/ 1025.,1000.,975.,950.,925.,900.,875.,850.,825., &
2977 800.,775.,750.,725.,700.,675.,650.,625.,600.,575., &
2978 550.,525.,500.,475.,450.,425.,400.,375.,350.,325., &
2979 300.,275.,250.,225.,200.,175.,150.,100., 70., 50., &
2980 30., 20., 10./)
2981
2982 varIndexES = 4
2983 varIndexPres = 5
2984
2985 allocate(levStnIndexList(numLevStnMax))
2986
2987 do stationIndex = 1, numStation
2988
2989 ! Retain nearest observations to selected pressure levels in levelsES
2990
2991 do levIndex = 1, numLevES
2992
2993 ! Pressures at the bottom and top of the ES layer
2994
2995 if (levIndex == 1) then
2996 presBottom = levelsES(levIndex)
2997 presTop = exp(0.5*alog(levelsES(levIndex+1)*levelsES(levIndex)))
2998 else if (levIndex == numLevES) then
2999 presBottom = exp(0.5*alog(levelsES(levIndex-1)*levelsES(levIndex)))
3000 presTop = levelsES(levIndex)
3001 else
3002 presBottom = exp(0.5*alog(levelsES(levIndex-1)*levelsES(levIndex)))
3003 presTop = exp(0.5*alog(levelsES(levIndex+1)*levelsES(levIndex)))
3004 end if
3005
3006 ! Select the levels between presTop and presBottom
3007
3008 numLevSelect = 0
3009
3010 do levStnIndex = obsLevOffset(stationIndex)+1, obsLevOffset(stationIndex+1)
3011
3012 if ( obsValues(varIndexPres,levStnIndex) > presTop .and. &
3013 obsValues(varIndexPres,levStnIndex) <= presBottom ) then
3014 numLevSelect = numLevSelect + 1
3015 levStnIndexList(numLevSelect) = levStnIndex
3016 end if
3017
3018 end do ! levStnIndex
3019
3020 ! Get the closest valid observation to the selected pressure level
3021
3022 levStnIndexValid = 0
3023 deltaPresMin = presBottom - presTop
3024
3025 do levSelectIndex = 1, numLevSelect
3026
3027 levStnIndex = levStnIndexList(levSelectIndex)
3028
3029 deltaPres = abs(obsValues(varIndexPres,levStnIndex) - levelsES(levIndex))
3030 condition = .not.btest(obsFlags(varIndexES,levStnIndex),18) .and. &
3031 .not.btest(obsFlags(varIndexES,levStnIndex),16) .and. &
3032 .not.btest(obsFlags(varIndexES,levStnIndex),9) .and. &
3033 .not.btest(obsFlags(varIndexES,levStnIndex),8) .and. &
3034 .not.btest(obsFlags(varIndexES,levStnIndex),2) .and. &
3035 .not.btest(obsFlags(varIndexES,levStnIndex),11) .and. &
3036 obsValues(varIndexES,levStnIndex) >= 0. .and. &
3037 deltaPres < deltaPresMin
3038
3039 if ( condition ) then
3040 deltaPresMin = deltaPres
3041 levStnIndexValid = levStnIndex
3042 end if
3043
3044 end do !levSelectIndex
3045
3046 ! Apply thinning obsFlags to all obs except the one selected with levStnIndexValid
3047
3048 do levSelectIndex = 1, numLevSelect
3049
3050 levStnIndex = levStnIndexList(levSelectIndex)
3051
3052 if ( (levStnIndex /= levStnIndexValid) .and. &
3053 (obsValues(varIndexES,levStnIndex) >= 0.) ) then
3054 obsFlags(varIndexES,levStnIndex) = ibset(obsFlags(varIndexES,levStnIndex),11)
3055 end if
3056
3057 end do
3058
3059 end do !levIndex
3060
3061 end do !stationIndex
3062
3063 deallocate(levStnIndexList)
3064
3065 end subroutine raobs_thinning_es
3066
3067 !--------------------------------------------------------------------------
3068 ! raobs_blacklisting_ecmwf
3069 !--------------------------------------------------------------------------
3070 subroutine raobs_blacklisting_ecmwf( obsFlags, obsValues, obsType, numStation, obsLevOffset )
3071 !
3072 !:Purpose: Perform filtering of T-Td raobs observations based on
3073 ! approach inspired by ECMWF approach
3074 !
3075 implicit none
3076
3077 ! Arguments:
3078 integer, intent(in) :: numStation
3079 integer, intent(in) :: obsLevOffset(:), obsType(:)
3080 integer, intent(inout) :: obsFlags(:,:)
3081 real(4), intent(in) :: obsValues(:,:)
3082
3083 ! Locals:
3084 logical :: conditionTT, conditionES, rejectES
3085 integer :: ierr, stationIndex, levStnIndex, varIndexES, varIndexTT, varIndexPres
3086 integer :: type, countReject0p, countReject0t, countReject1p, countReject1t
3087 integer :: countReject0pMpi, countReject0tMpi, countReject1pMpi, countReject1tMpi
3088 integer :: countTotalES, countTotalESMpi
3089
3090 countReject0p = 0
3091 countReject0t = 0
3092 countReject1p = 0
3093 countReject1t = 0
3094 countTotalES = 0
3095
3096 varIndexTT = 3
3097 varIndexES = 4
3098 varIndexPres = 5
3099
3100 do stationIndex = 1, numStation
3101 type = 0
3102
3103 if ( obsType(stationIndex) /= -1 ) then
3104
3105 if ( obsType(stationIndex) == 14 .or. &
3106 obsType(stationIndex) == 24 .or. &
3107 obsType(stationIndex) == 41 .or. &
3108 obsType(stationIndex) == 42 .or. &
3109 obsType(stationIndex) == 52 .or. &
3110 obsType(stationIndex) == 79 .or. &
3111 obsType(stationIndex) == 80 .or. &
3112 obsType(stationIndex) == 81 .or. &
3113 obsType(stationIndex) == 83 .or. &
3114 obsType(stationIndex) == 141 .or. &
3115 obsType(stationIndex) == 142 ) then
3116
3117 type = 1
3118
3119 end if
3120
3121 end if
3122
3123 do levStnIndex = obsLevOffset(stationIndex)+1, obsLevOffset(stationIndex+1)
3124
3125 conditionTT = &
3126 .not.btest(obsFlags(varIndexTT,levStnIndex),18) .and. &
3127 .not.btest(obsFlags(varIndexTT,levStnIndex),16) .and. &
3128 .not.btest(obsFlags(varIndexTT,levStnIndex),9) .and. &
3129 .not.btest(obsFlags(varIndexTT,levStnIndex),8) .and. &
3130 .not.btest(obsFlags(varIndexTT,levStnIndex),2) .and. &
3131 .not.btest(obsFlags(varIndexTT,levStnIndex),11) .and. &
3132 obsValues(varIndexTT,levStnIndex) >= 0.0
3133 conditionES = &
3134 .not.btest(obsFlags(varIndexES,levStnIndex),18) .and. &
3135 .not.btest(obsFlags(varIndexES,levStnIndex),16) .and. &
3136 .not.btest(obsFlags(varIndexES,levStnIndex),9) .and. &
3137 .not.btest(obsFlags(varIndexES,levStnIndex),8) .and. &
3138 .not.btest(obsFlags(varIndexES,levStnIndex),2) .and. &
3139 .not.btest(obsFlags(varIndexES,levStnIndex),11) .and. &
3140 obsValues(varIndexES,levStnIndex) >= 0.0
3141
3142 if ( conditionTT ) then
3143
3144 rejectES = .false.
3145 if (conditionES) countTotalES = countTotalES + 1
3146
3147 if ( type == 0 ) then
3148
3149 if ( .not.rejectES .and. obsValues(varIndexPres,levStnIndex) < 300.0 ) then
3150 if (conditionES) countReject0p = countReject0p + 1
3151 rejectES = .true.
3152 end if
3153 if ( .not.rejectES .and. obsValues(varIndexTT,levStnIndex) < 233.15 ) then
3154 if (conditionES) countReject0t = countReject0t + 1
3155 rejectES = .true.
3156 end if
3157
3158 else if ( type == 1 ) then
3159
3160 if ( .not.rejectES .and. obsValues(varIndexPres,levStnIndex) < 100.0 ) then
3161 if (conditionES) countReject1p = countReject1p + 1
3162 rejectES = .true.
3163 end if
3164 if ( .not.rejectES .and. obsValues(varIndexTT,levStnIndex) < 213.15 ) then
3165 if (conditionES) countReject1t = countReject1t + 1
3166 rejectES = .true.
3167 end if
3168
3169 end if
3170
3171 if ( rejectES ) then
3172 obsFlags(varIndexES,levStnIndex) = ibset(obsFlags(varIndexES,levStnIndex),11)
3173 end if
3174
3175 else
3176
3177 obsFlags(varIndexES,levStnIndex) = obsFlags(varIndexTT,levStnIndex)
3178
3179 end if
3180
3181 end do !levStnIndex
3182
3183 end do !stationIndex
3184
3185
3186 call rpn_comm_allReduce(countTotalES, countTotalESMpi, 1, 'mpi_integer', &
3187 'mpi_sum','grid',ierr)
3188 call rpn_comm_allReduce(countReject0p, countReject0pMpi, 1, 'mpi_integer', &
3189 'mpi_sum','grid',ierr)
3190 call rpn_comm_allReduce(countReject0t, countReject0tMpi, 1, 'mpi_integer', &
3191 'mpi_sum','grid',ierr)
3192 call rpn_comm_allReduce(countReject1p, countReject1pMpi, 1, 'mpi_integer', &
3193 'mpi_sum','grid',ierr)
3194 call rpn_comm_allReduce(countReject1t, countReject1tMpi, 1, 'mpi_integer', &
3195 'mpi_sum','grid',ierr)
3196 write(*,*)
3197 write(*,*) ' Rejet des donnees ES inspire de ECMWF'
3198 write(*,*)
3199 write(*,'(a30,I10)') 'nb total donnees es ',countTotalESMpi
3200 write(*,'(a30,I10)') 'nb rejet type 0 pression ',countReject0pMpi
3201 write(*,'(a30,I10)') 'nb rejet type 0 temperature',countReject0tMpi
3202 write(*,'(a30,I10)') 'nb rejet type 1 pression ',countReject1pMpi
3203 write(*,'(a30,I10)') 'nb rejet type 1 temperature',countReject1tMpi
3204 write(*,*)
3205 if (countTotalESMpi > 0) then
3206 write(*,'(a30,I10,f10.2)') 'nb rejet total et %', &
3207 countReject0pMpi + countReject0tMpi + countReject1pMpi + countReject1tMpi, &
3208 100.0 * (countReject0pMpi + countReject0tMpi + countReject1pMpi + &
3209 countReject1tMpi) / countTotalESMpi
3210 end if
3211 write(*,*)
3212
3213 end subroutine raobs_blacklisting_ecmwf
3214
3215 !--------------------------------------------------------------------------
3216 ! thn_gbGpsByDistance
3217 !--------------------------------------------------------------------------
3218 subroutine thn_gbGpsByDistance(obsdat, deltemps, deldist, removeUncorrected, rejectNoZTDScore)
3219 !
3220 !:Purpose: Original method for thinning GB-GPS data by the distance method.
3221 ! Set bit 11 of OBS_FLG on observations that are to be rejected.
3222 !
3223 implicit none
3224
3225 ! Arguments:
3226 type(struct_obs), intent(inout) :: obsdat
3227 integer, intent(in) :: deltemps
3228 integer, intent(in) :: deldist
3229 logical, intent(in) :: removeUncorrected
3230 logical, intent(in) :: rejectNoZTDScore
3231
3232 ! Locals:
3233 real(4), parameter :: normZtdScore = 50.0 ! normalization factor for zdscores
3234 integer, parameter :: nullValue = 9999 ! Value representing a non-value or null Value
3235 character(len=3), parameter :: winpos='mid' ! Preference to obs close to middle of window
3236 integer :: ierr, numHeader, numHeaderMpi, numHeaderMaxMpi, bodyIndex, headerIndex
3237 integer :: countObs, countObsOutMpi, countObsInMpi
3238 integer :: obsDate, obsTime, obsVarno, ztdObsFlag, obsFlag, nsize
3239 integer :: bgckCount, bgckCountMpi, blackListCount, blackListCountMpi
3240 integer :: unCorrectCount, unCorrectCountMpi, badTimeCount, badTimeCountMpi
3241 integer :: ztdScoreCount, ztdScoreCountMpi
3242 integer :: numSelected, middleStep
3243 integer :: obsIndex1, obsIndex2, headerIndex1, headerIndex2
3244 integer :: headerIndexBeg, headerIndexEnd
3245 real(4) :: thinDistance, deltaLat, deltaLon, obsLat1, obsLat2
3246 real(4) :: normFormalErr, missingFormalErr, formalError, finalZtdScore, ztdScore
3247 real(8) :: obsLonInDegrees, obsLatInDegrees, obsStepIndex_r8
3248 character(len=12) :: stnId
3249 logical :: skipThisObs, thisStnIdNoaa
3250 integer, allocatable :: quality(:), qualityMpi(:)
3251 integer, allocatable :: obsLonBurpFile(:), obsLatBurpFile(:)
3252 integer, allocatable :: obsLonBurpFileMpi(:), obsLatBurpFileMpi(:)
3253 integer, allocatable :: obsStepIndex(:), obsStepIndexMpi(:)
3254 integer, allocatable :: headerIndexSelected(:), headerIndexSorted(:)
3255 logical, allocatable :: valid(:), validMpi(:)
3256
3257 write(*,*)
3258 write(*,*) 'thn_gbGpsByDistance: Starting'
3259 write(*,*)
3260
3261 numHeader = obs_numHeader(obsdat)
3262 call rpn_comm_allReduce(numHeader, numHeaderMaxMpi, 1, 'mpi_integer', &
3263 'mpi_max', 'grid', ierr)
3264 numHeaderMpi = numHeaderMaxMpi * mmpi_nprocs
3265
3266 ! Check if any observations to be treated
3267 countObs = 0
3268 call obs_set_current_header_list(obsdat,'GP')
3269 HEADER0: do
3270 headerIndex = obs_getHeaderIndex(obsdat)
3271 if (headerIndex < 0) exit HEADER0
3272 countObs = countObs + 1
3273 end do HEADER0
3274
3275 call rpn_comm_allReduce(countObs, countObsInMpi, 1, 'mpi_integer', &
3276 'mpi_sum','grid',ierr)
3277 if (countObsInMpi == 0) then
3278 write(*,*) 'thn_gbGpsByDistance: no gb-gps observations present'
3279 return
3280 end if
3281
3282 write(*,*) 'thn_gbGpsByDistance: number of obs initial = ', &
3283 countObs, countObsInMpi
3284
3285 thinDistance = real(deldist)
3286 write(*,*)
3287 write(*,*) 'Minimum thinning distance ', thinDistance
3288
3289 middleStep = nint( ((tim_windowSize/2.0d0) - tim_dstepobs/2.d0) / &
3290 tim_dstepobs) + 1
3291
3292 write(*,*)
3293 write(*,*) 'Number of time bins = ', tim_nstepobs
3294 write(*,*) 'Minimum number of time bins between obs = ', deltemps
3295 write(*,*) 'Central time bin = ', middleStep
3296 write(*,*)
3297
3298 ! Allocations:
3299 allocate(obsLatBurpFile(numHeaderMaxMpi))
3300 allocate(obsLonBurpFile(numHeaderMaxMpi))
3301 allocate(obsStepIndex(numHeaderMaxMpi))
3302 allocate(quality(numHeaderMaxMpi))
3303 allocate(valid(numHeaderMaxMpi))
3304
3305 allocate(obsLatBurpFileMpi(numHeaderMpi))
3306 allocate(obsLonBurpFileMpi(numHeaderMpi))
3307 allocate(obsStepIndexMpi(numHeaderMpi))
3308 allocate(qualityMpi(numHeaderMpi))
3309
3310 allocate(headerIndexSorted(numHeaderMpi))
3311 allocate(headerIndexSelected(numHeaderMpi))
3312 allocate(validMpi(numHeaderMpi))
3313
3314 validMpi(:) = .false.
3315
3316 quality(:) = nullValue
3317 obsLatBurpFile(:) = 0
3318 obsLonBurpFile(:) = 0
3319 obsStepIndex(:) = 0
3320
3321 qualityMpi(:) = nullValue
3322 obsLatBurpFileMpi(:) = 0
3323 obsLonBurpFileMpi(:) = 0
3324 obsStepIndexMpi(:) = 0
3325
3326 badTimeCount = 0
3327 bgckCount = 0
3328 blackListCount = 0
3329 unCorrectCount = 0
3330 ztdScoreCount = 0
3331
3332 ! First pass through observations
3333 call obs_set_current_header_list(obsdat,'GP')
3334 HEADER1: do
3335 headerIndex = obs_getHeaderIndex(obsdat)
3336 if (headerIndex < 0) exit HEADER1
3337
3338 ! convert and store stnId as integer array
3339 stnId = obs_elem_c(obsdat,'STID',headerIndex)
3340
3341 ! get latitude and longitude
3342 obsLonInDegrees = MPC_DEGREES_PER_RADIAN_R8 * obs_headElem_r(obsdat, OBS_LON, headerIndex)
3343 obsLatInDegrees = MPC_DEGREES_PER_RADIAN_R8 * obs_headElem_r(obsdat, OBS_LAT, headerIndex)
3344 obsLonBurpFile(headerIndex) = nint(100.0*obsLonInDegrees)
3345 obsLatBurpFile(headerIndex) = 9000 + nint(100.0*obsLatInDegrees)
3346 if (obsLonBurpFile(headerIndex) >= 18000) then
3347 obsLonBurpFile(headerIndex) = obsLonBurpFile(headerIndex) - 18000
3348 else
3349 obsLonBurpFile(headerIndex) = obsLonBurpFile(headerIndex) + 18000
3350 end if
3351
3352 ! get step bin
3353 obsDate = obs_headElem_i(obsdat, OBS_DAT, headerIndex)
3354 obsTime = obs_headElem_i(obsdat, OBS_ETM, headerIndex)
3355 call tim_getStepObsIndex(obsStepIndex_r8, tim_getDatestamp(), &
3356 obsDate, obsTime, tim_nstepobs)
3357 obsStepIndex(headerIndex) = nint(obsStepIndex_r8)
3358
3359 ! thisStnIdNoaa==TRUE means obs has collocated GPS met (Psfc) observations
3360 thisStnIdNoaa = ((index(stnId,'FSL_') + index(stnId,'-NOAA') + index(stnId,'-UCAR')) > 0)
3361 ! normalization factor (Units = mm) for ZTD formal error (formalError)
3362 if (thisStnIdNoaa) then
3363 normFormalErr = 15.0
3364 missingFormalErr = 7.0
3365 else
3366 normFormalErr = 5.0
3367 missingFormalErr = 3.0
3368 end if
3369
3370 ! get ztd flag and formal error value, element 15032
3371 formalError = -1.0
3372 ztdScore = -1.0
3373 ztdObsFlag = -1
3374 call obs_set_current_body_list(obsdat, headerIndex)
3375 BODY1: do
3376 bodyIndex = obs_getBodyIndex(obsdat)
3377 if (bodyIndex < 0) exit BODY1
3378 obsVarno = obs_bodyElem_i(obsdat, OBS_VNM, bodyIndex)
3379 if (obsVarno == bufr_nezd) then
3380 ! convert units from m to mm
3381 formalError = 1000.0*obs_bodyElem_r(obsdat, OBS_OER, bodyIndex)
3382 end if
3383 if (obsVarno == bufr_ztdScore) then
3384 ztdScore = obs_bodyElem_r(obsdat, OBS_VAR, bodyIndex)
3385 end if
3386 if (obsVarno == bufr_nezd) then
3387 ztdObsFlag = obs_bodyElem_i(obsdat, OBS_FLG, bodyIndex)
3388 end if
3389 end do BODY1
3390 if (formalError == -1.0 .or. formalError == 1000.0*MPC_missingValue_R4) then
3391 formalError = missingFormalErr
3392 end if
3393 if (ztdScore == -1.0) then
3394 ztdScore = 999.0
3395 end if
3396 if (ztdObsFlag == -1) then
3397 call utl_abort('thn_gbGpsByDistance: ztd not found')
3398 end if
3399
3400 ! ZTD quality estimate using monitoring zdscore and the formal error
3401 finalZtdScore = 80*(ztdScore/normZtdScore) + 20*(formalError/normFormalErr)
3402
3403 ! Give preference to FSL/UCAR ZTD observations (usually include collocated GPS met Psfc)
3404 if (.not. thisStnIdNoaa) finalZtdScore = finalZtdScore + 5.0
3405
3406 ! Give preference to obs near middle or end of the assimilation window
3407 if (winpos == 'mid') then
3408 finalZtdScore = finalZtdScore + 25.0*float(abs(middleStep-obsStepIndex(headerIndex))) / &
3409 float(middleStep-1)
3410 else if (winpos == 'end') then
3411 finalZtdScore = finalZtdScore + 25.0*float(tim_nstepobs-obsStepIndex(headerIndex)) / &
3412 float(tim_nstepobs-1)
3413 end if
3414
3415 ! Quality (lower is better), typical values 20->100, if no zdscore then > 1600
3416 quality(headerIndex) = nint(finalZtdScore)
3417
3418 ! obs is outside time window
3419 if(obsStepIndex(headerIndex) == -1.0d0) then
3420 badTimeCount = badTimeCount + 1
3421 quality(headerIndex) = nullValue
3422 end if
3423
3424 ! ZTD O-P failed background/topography checks, ZTD is blacklisted, ZTD is not bias corrected
3425 if ( btest(ztdObsFlag,16) ) bgckCount = bgckCount + 1
3426 if ( btest(ztdObsFlag,8) ) blackListCount = blackListCount + 1
3427 if ( btest(ztdObsFlag,16) .or. btest(ztdObsFlag,18) .or. &
3428 btest(ztdObsFlag,8) ) then
3429 quality(headerIndex) = nullValue
3430 end if
3431 if (removeUncorrected) then
3432 if ( .not. btest(ztdObsflag,6) ) then
3433 unCorrectCount = unCorrectCount + 1
3434 quality(headerIndex) = nullValue
3435 end if
3436 end if
3437
3438 ! ZTD quality is unknown (missing ztd score)
3439 if (ztdScore == 999.0) then
3440 ztdScoreCount = ztdScoreCount + 1
3441 if ( rejectNoZTDScore ) then
3442 quality(headerIndex) = 9999
3443 end if
3444 end if
3445
3446 end do HEADER1
3447
3448 ! Gather needed information from all MPI tasks
3449 nsize = numHeaderMaxMpi
3450 call rpn_comm_allgather(quality, nsize, 'mpi_integer', &
3451 qualityMpi, nsize, 'mpi_integer', 'grid', ierr)
3452 call rpn_comm_allgather(obsLatBurpFile, nsize, 'mpi_integer', &
3453 obsLatBurpFileMpi, nsize, 'mpi_integer', 'grid', ierr)
3454 call rpn_comm_allgather(obsLonBurpFile, nsize, 'mpi_integer', &
3455 obsLonBurpFileMpi, nsize, 'mpi_integer', 'grid', ierr)
3456 call rpn_comm_allgather(obsStepIndex, nsize, 'mpi_integer', &
3457 obsStepIndexMpi, nsize, 'mpi_integer', 'grid', ierr)
3458
3459 do obsIndex1 = 1, numHeaderMpi
3460 headerIndexSorted(obsIndex1) = obsIndex1
3461 end do
3462
3463 call thn_QsortIntIgnoringNullValues(qualityMpi,headerIndexSorted,nullValue)
3464
3465 numSelected = 0 ! number of obs selected so far
3466 OBS_LOOP: do obsIndex1 = 1, numHeaderMpi
3467
3468 if ( qualityMpi(obsIndex1) /= nullValue ) then
3469
3470 headerIndex1 = headerIndexSorted(obsIndex1)
3471
3472 ! Check if any of the obs already selected are close in space/time to this obs
3473 ! If no, then keep (select) this obs
3474 if( numSelected >= 1 ) then
3475 skipThisObs = .false.
3476 LOOP2: do obsIndex2 = 1, numSelected
3477 headerIndex2 = headerIndexSelected(obsIndex2)
3478 if ( abs(obsStepIndexMpi(headerIndex1) - &
3479 obsStepIndexMpi(headerIndex2)) < deltemps ) then
3480 deltaLat = abs(obsLatBurpFileMpi(headerIndex1) - &
3481 obsLatBurpFileMpi(headerIndex2))/100.
3482 deltaLon = abs(obsLonBurpFileMpi(headerIndex1) - &
3483 obsLonBurpFileMpi(headerIndex2))/100.
3484 if (deltaLon > 180.) deltaLon = 360. - deltaLon
3485 obsLat1 = ((obsLatBurpFileMpi(headerIndex1) - 9000)/100.)
3486 obsLat2 = ((obsLatBurpFileMpi(headerIndex2) - 9000)/100.)
3487 if ( thn_distanceArc(deltaLat,deltaLon,obsLat1,obsLat2) < thinDistance ) then
3488 skipThisObs = .true.
3489 exit LOOP2
3490 end if
3491 end if
3492 end do LOOP2
3493 else
3494 skipThisObs = .false.
3495 end if
3496
3497 if (.not. skipThisObs) then
3498 numSelected = numSelected + 1
3499 headerIndexSelected(numSelected) = headerIndex1
3500 end if
3501
3502 end if
3503
3504 end do OBS_LOOP
3505
3506 do obsIndex1 = 1, numSelected
3507 obsIndex2 = headerIndexSelected(obsIndex1)
3508 validMpi(obsIndex2) = .true.
3509 end do
3510
3511 ! Update local copy of valid from global mpi version
3512 headerIndexBeg = 1 + mmpi_myid * numHeaderMaxMpi
3513 headerIndexEnd = headerIndexBeg + numHeaderMaxMpi - 1
3514 valid(:) = validMpi(headerIndexBeg:headerIndexEnd)
3515
3516 countObs = count(valid)
3517 call rpn_comm_allReduce(countObs, countObsOutMpi, 1, 'mpi_integer', &
3518 'mpi_sum','grid',ierr)
3519 write(*,*) 'thn_gbGpsByDistance: number of obs after thinning = ', &
3520 countObs, countObsOutMpi
3521
3522 ! modify the obs flags and count number of obs kept for each stnId
3523 call obs_set_current_header_list(obsdat,'GP')
3524 HEADER3: do
3525 headerIndex = obs_getHeaderIndex(obsdat)
3526 if (headerIndex < 0) exit HEADER3
3527
3528 ! do not keep this obs: set bit 11 and jump to the next obs
3529 if (.not. valid(headerIndex)) then
3530 call obs_set_current_body_list(obsdat, headerIndex)
3531 BODY3: do
3532 bodyIndex = obs_getBodyIndex(obsdat)
3533 if (bodyIndex < 0) exit BODY3
3534 obsFlag = obs_bodyElem_i(obsdat, OBS_FLG, bodyIndex)
3535 call obs_bodySet_i(obsdat, OBS_FLG, bodyIndex, ibset(obsFlag,11))
3536 end do BODY3
3537 cycle HEADER3
3538 end if
3539
3540 end do HEADER3
3541
3542 call rpn_comm_allReduce(badTimeCount, badTimeCountMpi, 1, 'mpi_integer', &
3543 'mpi_sum','grid',ierr)
3544 call rpn_comm_allReduce(unCorrectCount, unCorrectCountMpi, 1, 'mpi_integer', &
3545 'mpi_sum','grid',ierr)
3546 call rpn_comm_allReduce(blackListCount, blackListCountMpi, 1, 'mpi_integer', &
3547 'mpi_sum','grid',ierr)
3548 call rpn_comm_allReduce(bgckCount, bgckCountMpi, 1, 'mpi_integer', &
3549 'mpi_sum','grid',ierr)
3550 call rpn_comm_allReduce(ztdScoreCount, ztdScoreCountMpi, 1, 'mpi_integer', &
3551 'mpi_sum','grid',ierr)
3552
3553 write(*,*)
3554 write(*,'(a50,i10)') 'Number of input obs = ', countObsInMpi
3555 write(*,'(a50,i10)') 'Total number of rejected/thinned obs = ', countObsInMpi - countObsOutMpi
3556 write(*,'(a50,i10)') 'Number of output obs = ', countObsOutMpi
3557 write(*,*)
3558 write(*,*)
3559 write(*,'(a50,i10)') 'Number of blacklisted obs = ', blackListCountMpi
3560 write(*,'(a50,i10)') 'Number of obs without bias correction= ', unCorrectCountMpi
3561 write(*,'(a50,i10)') 'Number of obs with no ztdScore = ', ztdScoreCountMpi
3562 write(*,'(a60,4i10)') 'Number of rejects outside time window, BGCK, thinning ', &
3563 badTimeCountMpi, bgckCountMpi, &
3564 countObsInMpi - countObsOutMpi - &
3565 bgckCountMpi - badTimeCountMpi - blackListCountMpi - unCorrectCountMpi - ztdScoreCountMpi
3566
3567 write(*,*)
3568 write(*,*) 'thn_gbGpsByDistance: Finished'
3569 write(*,*)
3570
3571 end subroutine thn_gbGpsByDistance
3572
3573 !--------------------------------------------------------------------------
3574 ! thn_satWindsByDistance
3575 !--------------------------------------------------------------------------
3576 subroutine thn_satWindsByDistance(obsdat, familyType, deltemps, deldist)
3577 !
3578 !:Purpose: Original method for thinning SatWinds data by the distance method.
3579 ! Set bit 11 of OBS_FLG on observations that are to be rejected.
3580 !
3581 implicit none
3582
3583 ! Arguments:
3584 type(struct_obs), intent(inout) :: obsdat
3585 character(len=*), intent(in) :: familyType
3586 integer, intent(in) :: deltemps
3587 integer, intent(in) :: deldist
3588
3589 ! Locals:
3590 integer, parameter :: numStnIdMax = 100
3591 integer, parameter :: numLayers = 11
3592 integer, parameter :: nullValue = -1
3593 real(4), parameter :: layer(numLayers) = (/ 100000., 92500., 85000., 70000., &
3594 50000., 40000., 30000., 25000., &
3595 20000., 15000., 10000. /)
3596 integer :: ierr, numHeader, numHeaderMaxMpi, bodyIndex, headerIndex, stnIdIndex
3597 integer :: numStnId, stnIdIndexFound, lenStnId, charIndex
3598 integer :: obsDate, obsTime, layerIndex, obsVarno, obsFlag, uObsFlag, vObsFlag
3599 integer :: bgckCount, bgckCountMpi, missingCount, missingCountMpi, nsize
3600 integer :: countObs, countObsOutMpi, countObsInMpi, numSelected, numHeaderMpi
3601 integer :: obsIndex1, obsIndex2, headerIndex1, headerIndex2
3602 integer :: headerIndexBeg, headerIndexEnd, mpiTaskId
3603 real(4) :: thinDistance, deltaLat, deltaLon, obsLat1, obsLat2
3604 real(4) :: obsPressure
3605 real(8) :: obsLonInDegrees, obsLatInDegrees
3606 real(8) :: obsStepIndex_r8, deltaPress, deltaPressMin
3607 character(len=12) :: stnId, stnidList(numStnIdMax)
3608 logical :: obsAlreadySameStep, skipThisObs
3609 integer :: numObsStnIdOut(numStnIdMax)
3610 integer :: numObsStnIdInMpi(numStnIdMax), numObsStnIdOutMpi(numStnIdMax)
3611 integer, allocatable :: stnIdInt(:,:), stnIdIntMpi(:,:), obsMethod(:), obsMethodMpi(:)
3612 integer, allocatable :: quality(:), qualityMpi(:)
3613 integer, allocatable :: obsLonBurpFile(:), obsLatBurpFile(:)
3614 integer, allocatable :: obsLonBurpFileMpi(:), obsLatBurpFileMpi(:)
3615 integer, allocatable :: obsStepIndex(:), obsStepIndexMpi(:)
3616 integer, allocatable :: obsLayerIndex(:), obsLayerIndexMpi(:)
3617 integer, allocatable :: headerIndexSorted(:), headerIndexSelected(:)
3618 logical, allocatable :: valid(:), validMpi(:), validMpi2(:)
3619
3620 write(*,*)
3621 write(*,*) 'thn_satWindsByDistance: Starting'
3622 write(*,*)
3623
3624 numHeader = obs_numHeader(obsdat)
3625 call rpn_comm_allReduce(numHeader, numHeaderMaxMpi, 1, 'mpi_integer', &
3626 'mpi_max', 'grid', ierr)
3627
3628 ! Check if any observations to be treated
3629 countObs = 0
3630 call obs_set_current_header_list(obsdat,trim(familyType))
3631 HEADER0: do
3632 headerIndex = obs_getHeaderIndex(obsdat)
3633 if (headerIndex < 0) exit HEADER0
3634 countObs = countObs + 1
3635 end do HEADER0
3636
3637 call rpn_comm_allReduce(countObs, countObsInMpi, 1, 'mpi_integer', &
3638 'mpi_sum','grid',ierr)
3639 if (countObsInMpi == 0) then
3640 write(*,*) 'thn_satWindsByDistance: no satwind observations present'
3641 return
3642 end if
3643
3644 write(*,*) 'thn_satWindsByDistance: number of obs initial = ', &
3645 countObs, countObsInMpi
3646
3647 thinDistance = real(deldist)
3648 write(*,*) 'Minimun thinning distance ',thinDistance
3649
3650 ! Allocations:
3651 allocate(valid(numHeaderMaxMpi))
3652 allocate(quality(numHeaderMaxMpi))
3653 allocate(obsLatBurpFile(numHeaderMaxMpi))
3654 allocate(obsLonBurpFile(numHeaderMaxMpi))
3655 allocate(obsStepIndex(numHeaderMaxMpi))
3656 allocate(obsLayerIndex(numHeaderMaxMpi))
3657 allocate(obsMethod(numHeaderMaxMpi))
3658 lenStnId = len(stnId)
3659 allocate(stnIdInt(lenStnId,numHeaderMaxMpi))
3660
3661 ! Initializations:
3662 valid(:) = .false.
3663 quality(:) = nullValue
3664 obsLatBurpFile(:) = 0
3665 obsLonBurpFile(:) = 0
3666 obsLayerIndex(:) = 0
3667 obsStepIndex(:) = 0
3668 obsMethod(:) = 0
3669 stnIdInt(:,:) = 0
3670 numObsStnIdInMpi(:) = 0
3671 numObsStnIdOut(:) = 0
3672 numObsStnIdOutMpi(:) = 0
3673 bgckCount = 0
3674 missingCount = 0
3675
3676 ! First pass through observations
3677 numStnId = 0
3678 call obs_set_current_header_list(obsdat,trim(familyType))
3679 HEADER1: do
3680 headerIndex = obs_getHeaderIndex(obsdat)
3681 if (headerIndex < 0) exit HEADER1
3682
3683 ! convert and store stnId as integer array
3684 stnId = obs_elem_c(obsdat,'STID',headerIndex)
3685 do charIndex = 1, lenStnId
3686 stnIdInt(charIndex,headerIndex) = iachar(stnId(charIndex:charIndex))
3687 end do
3688
3689 ! get latitude and longitude
3690 obsLonInDegrees = MPC_DEGREES_PER_RADIAN_R8 * obs_headElem_r(obsdat, OBS_LON, headerIndex)
3691 obsLatInDegrees = MPC_DEGREES_PER_RADIAN_R8 * obs_headElem_r(obsdat, OBS_LAT, headerIndex)
3692 obsLonBurpFile(headerIndex) = nint(100.0*obsLonInDegrees)
3693 obsLatBurpFile(headerIndex) = 9000 + nint(100.0*obsLatInDegrees)
3694
3695 ! get step bin
3696 obsDate = obs_headElem_i(obsdat, OBS_DAT, headerIndex)
3697 obsTime = obs_headElem_i(obsdat, OBS_ETM, headerIndex)
3698 call tim_getStepObsIndex(obsStepIndex_r8, tim_getDatestamp(), &
3699 obsDate, obsTime, tim_nstepobs)
3700 obsStepIndex(headerIndex) = nint(obsStepIndex_r8)
3701
3702 ! find layer (assumes 1 level only per headerIndex)
3703 obsPressure = -1.0
3704 call obs_set_current_body_list(obsdat, headerIndex)
3705 BODY1: do
3706 bodyIndex = obs_getBodyIndex(obsdat)
3707 if (bodyIndex < 0) exit BODY1
3708
3709 if (obsPressure <= 0.0) then
3710 obsPressure = obs_bodyElem_r(obsdat, OBS_PPP, bodyIndex)
3711 exit BODY1
3712 end if
3713 end do BODY1
3714 ! modify obsPressure to be consistent with operational pgm
3715 obsPressure = 100.0*nint(obsPressure/100.0)
3716 deltaPressMin = abs( log(obsPressure) - log(layer(1)) )
3717 obsLayerIndex(headerIndex) = 1
3718 do layerIndex = 2, numLayers
3719 deltaPress = abs( log(obsPressure) - log(layer(layerIndex)) )
3720 if ( deltaPress < deltaPressMin ) then
3721 deltaPressMin = deltaPress
3722 obsLayerIndex(headerIndex) = layerIndex
3723 end if
3724 end do
3725
3726 ! extract additional information
3727 obsMethod(headerIndex) = obs_headElem_i(obsdat, OBS_SWMT, headerIndex)
3728
3729 ! set the observation quality based on QI1
3730 quality(headerIndex) = obs_headElem_i(obsdat, OBS_SWQ1, headerIndex)
3731
3732 ! find observation flags (assumes 1 level only per headerIndex)
3733 uObsFlag = nullValue
3734 vObsFlag = nullValue
3735 call obs_set_current_body_list(obsdat, headerIndex)
3736 BODY2: do
3737 bodyIndex = obs_getBodyIndex(obsdat)
3738 if (bodyIndex < 0) exit BODY2
3739 obsVarno = obs_bodyElem_i(obsdat, OBS_VNM, bodyIndex)
3740 if (obsVarno == bufr_neuu) then
3741 uObsFlag = obs_bodyElem_i(obsdat, OBS_FLG, bodyIndex)
3742 else if (obsVarno == bufr_nevv) then
3743 vObsFlag = obs_bodyElem_i(obsdat, OBS_FLG, bodyIndex)
3744 end if
3745 end do BODY2
3746
3747 ! modify quality based on flags
3748 if (uObsFlag /= nullValue .and. vObsFlag /= nullValue ) then
3749 if ( btest(uObsFlag,16) .or. btest(vObsFlag,16) ) bgckCount = bgckCount + 1
3750 if ( btest(uObsFlag,16) .or. btest(vObsFlag,16) .or. &
3751 btest(uObsFlag,18) .or. btest(vObsFlag,18) ) then
3752 quality(headerIndex) = 0
3753 end if
3754 else
3755 quality(headerIndex) = 0
3756 MissingCount = MissingCount + 1
3757 end if
3758
3759 end do HEADER1
3760
3761 ! Gather needed information from all MPI tasks
3762 allocate(validMpi(numHeaderMaxMpi*mmpi_nprocs))
3763 allocate(validMpi2(numHeaderMaxMpi*mmpi_nprocs))
3764 allocate(qualityMpi(numHeaderMaxMpi*mmpi_nprocs))
3765 allocate(obsLatBurpFileMpi(numHeaderMaxMpi*mmpi_nprocs))
3766 allocate(obsLonBurpFileMpi(numHeaderMaxMpi*mmpi_nprocs))
3767 allocate(obsStepIndexMpi(numHeaderMaxMpi*mmpi_nprocs))
3768 allocate(obsLayerIndexMpi(numHeaderMaxMpi*mmpi_nprocs))
3769 allocate(obsMethodMpi(numHeaderMaxMpi*mmpi_nprocs))
3770 allocate(stnIdIntMpi(lenStnId,numHeaderMaxMpi*mmpi_nprocs))
3771
3772 nsize = numHeaderMaxMpi
3773 call rpn_comm_allgather(quality, nsize, 'mpi_integer', &
3774 qualityMpi, nsize, 'mpi_integer', 'grid', ierr)
3775 call rpn_comm_allgather(obsLatBurpFile, nsize, 'mpi_integer', &
3776 obsLatBurpFileMpi, nsize, 'mpi_integer', 'grid', ierr)
3777 call rpn_comm_allgather(obsLonBurpFile, nsize, 'mpi_integer', &
3778 obsLonBurpFileMpi, nsize, 'mpi_integer', 'grid', ierr)
3779 call rpn_comm_allgather(obsStepIndex, nsize, 'mpi_integer', &
3780 obsStepIndexMpi, nsize, 'mpi_integer', 'grid', ierr)
3781 call rpn_comm_allgather(obsLayerIndex, nsize, 'mpi_integer', &
3782 obsLayerIndexMpi, nsize, 'mpi_integer', 'grid', ierr)
3783 call rpn_comm_allgather(obsMethod, nsize, 'mpi_integer', &
3784 obsMethodMpi, nsize, 'mpi_integer', 'grid', ierr)
3785 nsize = lenStnId * numHeaderMaxMpi
3786 call rpn_comm_allgather(stnIdInt, nsize, 'mpi_integer', &
3787 stnIdIntMpi, nsize, 'mpi_integer', 'grid', ierr)
3788
3789 ! build a global list of stnId over all mpi tasks
3790 numHeaderMpi = numHeaderMaxMpi * mmpi_nprocs
3791 HEADER: do headerIndex = 1, numHeaderMpi
3792 if (all(stnIdIntMpi(:,headerIndex) == 0)) cycle HEADER
3793
3794 ! Station ID converted back to character string
3795 do charIndex = 1, lenStnId
3796 stnId(charIndex:charIndex) = achar(stnIdIntMpi(charIndex,headerIndex))
3797 end do
3798
3799 if (numStnId < numStnIdMax ) then
3800 stnIdIndexFound = nullValue
3801 do stnIdIndex = 1, numStnId
3802 if ( stnidList(stnIdIndex) == stnid ) stnIdIndexFound = stnIdIndex
3803 end do
3804 if ( stnIdIndexFound == nullValue ) then
3805 numStnId = numStnId + 1
3806 stnidList(numStnId) = stnid
3807 stnIdIndexFound = numStnId
3808 end if
3809 numObsStnIdInMpi(stnIdIndexFound) = numObsStnIdInMpi(stnIdIndexFound) + 1
3810 else
3811 call utl_abort('thn_satWindsByDistance: numStnId too large')
3812 end if
3813 end do HEADER
3814
3815 allocate(headerIndexSorted(numHeaderMaxMpi*mmpi_nprocs))
3816 do headerIndex = 1, numHeaderMaxMpi*mmpi_nprocs
3817 headerIndexSorted(headerIndex) = headerIndex
3818 end do
3819 allocate(headerIndexSelected(numHeaderMaxMpi*mmpi_nprocs))
3820 headerIndexSelected(:) = 0
3821
3822 ! Thinning procedure
3823 call thn_QsortIntIgnoringNullValues(qualityMpi,headerIndexSorted,nullValue)
3824
3825 validMpi(:) = .false.
3826 STNIDLOOP: do stnIdIndex = 1, numStnId
3827 write(*,*) 'thn_satWindsByDistance: applying thinning for: ', &
3828 trim(stnidList(stnIdIndex))
3829
3830 LAYERLOOP: do layerIndex = 1, numLayers
3831
3832 ! do selection of obs for 1 satellite and layer at a time, on separate mpi tasks
3833 mpiTaskId = mod((stnIdIndex-1)*numLayers + layerIndex - 1, mmpi_nprocs)
3834 if (mmpi_myid /= mpiTaskId) cycle LAYERLOOP
3835
3836 numSelected = 0
3837 OBSLOOP1: do obsIndex1 = 1, numHeaderMpi
3838 headerIndex1 = headerIndexSorted(numHeaderMpi-obsIndex1+1)
3839
3840 ! only consider obs with current layer being considered
3841 if (obsLayerIndexMpi(headerIndex1) /= layerIndex) cycle OBSLOOP1
3842
3843 ! only consider obs with high quality
3844 if (qualityMpi(numHeaderMpi-obsIndex1+1) <= 10) cycle OBSLOOP1
3845
3846 ! only consider obs from current satellite
3847 do charIndex = 1, lenStnId
3848 stnId(charIndex:charIndex) = achar(stnIdIntMpi(charIndex,headerIndex1))
3849 end do
3850 if (stnidList(stnIdIndex) /= stnId) cycle OBSLOOP1
3851
3852 ! On compte le nombre d'observations qui sont deja
3853 ! selectionnees avec les memes parametres 'obsStepIndex' et 'obsLayerIndex'
3854 ! que l'observation consideree ici.
3855 obsAlreadySameStep = .false.
3856 OBSLOOP2: do obsIndex2 = 1, numSelected
3857 headerIndex2 = headerIndexSelected(obsIndex2)
3858 if ( obsStepIndexMpi(headerIndex1) == obsStepIndexMpi(headerIndex2) ) then
3859 if ( (obsLatBurpFileMpi(headerIndex1) == obsLatBurpFileMpi(headerIndex2)) .and. &
3860 (obsLonBurpFileMpi(headerIndex1) == obsLonBurpFileMpi(headerIndex2)) ) then
3861 ! Si une observation selectionnee porte deja le meme lat, lon, layer et step.
3862 cycle OBSLOOP1
3863 end if
3864 obsAlreadySameStep = .true.
3865 exit OBSLOOP2
3866 end if
3867 end do OBSLOOP2
3868
3869 if ( obsAlreadySameStep ) then
3870 ! Calcule les distances entre la donnee courante et toutes celles choisies
3871 ! precedemment.
3872 skipThisObs = .false.
3873 OBSLOOP3: do obsIndex2 = 1, numSelected
3874 headerIndex2 = headerIndexSelected(obsIndex2)
3875 if ( abs( obsStepIndexMpi(headerIndex1) - &
3876 obsStepIndexMpi(headerIndex2) ) < deltemps ) then
3877 deltaLat = abs( obsLatBurpFileMpi(headerIndex1) - &
3878 obsLatBurpFileMpi(headerIndex2) ) / 100.
3879 deltaLon = abs( obsLonBurpFileMpi(headerIndex1) - &
3880 obsLonBurpFileMpi(headerIndex2) ) / 100.
3881 if(deltaLon > 180.) deltaLon = 360. - deltaLon
3882 obsLat1 = ((obsLatBurpFileMpi(headerIndex1) - 9000)/100.)
3883 obsLat2 = ((obsLatBurpFileMpi(headerIndex2) - 9000)/100.)
3884 if ( thn_distanceArc(deltaLat,deltaLon,obsLat1,obsLat2) < thinDistance ) then
3885 skipThisObs = .true.
3886 exit OBSLOOP3
3887 end if
3888 end if
3889 end do OBSLOOP3
3890
3891 if ( .not. skipThisObs ) then
3892
3893 ! On selectionne la donnee si toutes celles choisies sont au-dela
3894 ! de thinDistance. Cet evaluation est faite dan la boucle
3895 ! 'check_list' precedante.
3896 numSelected = numSelected + 1
3897 headerIndexSelected(numSelected) = headerIndex1
3898
3899 end if
3900
3901 else
3902
3903 ! On selectionne la donnee s'il y en a aucune choisie dans les intervalles
3904 ! layer et step.
3905 numSelected = numSelected + 1
3906 headerIndexSelected(numSelected) = headerIndex1
3907
3908 end if
3909
3910 end do OBSLOOP1
3911
3912 do obsIndex1 = 1, numSelected
3913 validMpi(headerIndexSelected(obsIndex1)) = .true.
3914 end do
3915
3916 end do LAYERLOOP
3917 end do STNIDLOOP
3918
3919 ! communicate values of validMpi computed on each mpi task
3920 nsize = numHeaderMaxMpi * mmpi_nprocs
3921 call rpn_comm_allReduce(validMpi, validMpi2, nsize, 'mpi_logical', &
3922 'mpi_lor','grid',ierr)
3923
3924 ! Update local copy of valid from global mpi version
3925 headerIndexBeg = 1 + mmpi_myid * numHeaderMaxMpi
3926 headerIndexEnd = headerIndexBeg + numHeaderMaxMpi - 1
3927 valid(:) = validMpi2(headerIndexBeg:headerIndexEnd)
3928
3929 countObs = count(valid)
3930 call rpn_comm_allReduce(countObs, countObsOutMpi, 1, 'mpi_integer', &
3931 'mpi_sum','grid',ierr)
3932 write(*,*) 'thn_satWindsByDistance: number of obs after thinning = ', &
3933 countObs, countObsOutMpi
3934
3935 ! modify the obs flags and count number of obs kept for each stnId
3936 call obs_set_current_header_list(obsdat,trim(familyType))
3937 HEADER3: do
3938 headerIndex = obs_getHeaderIndex(obsdat)
3939 if (headerIndex < 0) exit HEADER3
3940
3941 ! do not keep this obs: set bit 11 and jump to the next obs
3942 if (.not. valid(headerIndex)) then
3943 call obs_set_current_body_list(obsdat, headerIndex)
3944 BODY3: do
3945 bodyIndex = obs_getBodyIndex(obsdat)
3946 if (bodyIndex < 0) exit BODY3
3947 obsFlag = obs_bodyElem_i(obsdat, OBS_FLG, bodyIndex)
3948 call obs_bodySet_i(obsdat, OBS_FLG, bodyIndex, ibset(obsFlag,11))
3949 end do BODY3
3950 cycle HEADER3
3951 end if
3952
3953 stnId = obs_elem_c(obsdat,'STID',headerIndex)
3954 stnIdIndexFound = nullValue
3955 do stnIdIndex = 1, numStnId
3956 if (stnidList(stnIdIndex) == stnId) stnIdIndexFound = stnIdIndex
3957 end do
3958 if (stnIdIndexFound == nullValue) call utl_abort('stnid not found in list')
3959 numObsStnIdOut(stnIdIndexFound) = numObsStnIdOut(stnIdIndexFound) + 1
3960 end do HEADER3
3961
3962 call rpn_comm_allReduce(numObsStnIdOut, numObsStnIdOutMpi, &
3963 numStnIdMax, 'mpi_integer', 'mpi_sum', 'grid', ierr)
3964 call rpn_comm_allReduce(bgckCount, bgckCountMpi, 1, &
3965 'mpi_integer', 'mpi_sum', 'grid', ierr)
3966 call rpn_comm_allReduce(missingCount, missingCountMpi, 1, &
3967 'mpi_integer', 'mpi_sum', 'grid', ierr)
3968
3969 ! Print counts
3970 write(*,*)
3971 write(*,'(a30, i10)') ' Number of obs in = ', countObsInMpi
3972 write(*,'(a30, i10)') ' Total number of reject = ', countObsInMpi - countObsOutMpi
3973 write(*,'(a30, i10)') ' Number of obs out = ', countObsOutMpi
3974 write(*,*)
3975 write(*,'(a30,4i10)') ' Number of rejects from bgck, thinned, missing obs ', &
3976 bgckCountMpi, &
3977 countObsInMpi - countObsOutMpi - bgckCountMpi - missingCountMpi, &
3978 missingCountMpi
3979 write(*,*)
3980 write(*,'(a30,i10)') 'Number of satellites found = ',numStnId
3981 write(*,*)
3982
3983 write(*,'(a30,2a15)') 'Satellite', 'nb AMVs in'
3984 write(*,*)
3985 do stnIdIndex = 1, numStnId
3986 write(*,'(a30,2i15)') stnidList(stnIdIndex), numObsStnIdInMpi(stnIdIndex)
3987 end do
3988 write(*,*)
3989 write(*,'(a30,2i10,f10.4)') 'Total number of obs in : ',sum(numObsStnIdInMpi)
3990
3991 write(*,*)
3992 write(*,'(a30,2a15)') 'Satellite', 'nb AMVs out'
3993 write(*,*)
3994 do stnIdIndex = 1, numStnId
3995 write(*,'(a30,2i15)') stnidList(stnIdIndex), numObsStnIdOutMpi(stnIdIndex)
3996 end do
3997 write(*,*)
3998 write(*,'(a30,2i10,f10.4)') 'Total number of obs out : ',sum(numObsStnIdOutMpi)
3999
4000 ! Deallocations:
4001 deallocate(valid)
4002 deallocate(quality)
4003 deallocate(obsLatBurpFile)
4004 deallocate(obsLonBurpFile)
4005 deallocate(obsStepIndex)
4006 deallocate(obsLayerIndex)
4007 deallocate(obsMethod)
4008 deallocate(stnIdInt)
4009 deallocate(validMpi)
4010 deallocate(validMpi2)
4011 deallocate(qualityMpi)
4012 deallocate(obsLatBurpFileMpi)
4013 deallocate(obsLonBurpFileMpi)
4014 deallocate(obsStepIndexMpi)
4015 deallocate(obsLayerIndexMpi)
4016 deallocate(obsMethodMpi)
4017 deallocate(stnIdIntMpi)
4018 deallocate(headerIndexSorted)
4019 deallocate(headerIndexSelected)
4020
4021 write(*,*)
4022 write(*,*) 'thn_satWindsByDistance: Finished'
4023 write(*,*)
4024
4025 end subroutine thn_satWindsByDistance
4026
4027 !--------------------------------------------------------------------------
4028 ! thn_QsortIntIgnoringNullValues
4029 !--------------------------------------------------------------------------
4030 subroutine thn_QsortIntIgnoringNullValues(A,B,nullValue)
4031 !
4032 !:Purpose: Quick sort algorithm for integer data
4033 ! Calling 'thn_QsortInt' on array without missing values (-1)
4034 ! The 'QuickSort' algorithm gives different results
4035 ! depending on the size of the input array. The same
4036 ! values won't be put in the same order if null values
4037 ! are inserted in the array. So this routine filters
4038 ! the input array and asks for 'thn_QsortInt' to sort
4039 ! the filtered array and then insert back the values to
4040 ! respect the order of the original input array.
4041 !
4042 implicit none
4043
4044 ! Arguments:
4045 integer, intent(inout) :: A(:)
4046 integer, intent(inout) :: B(:)
4047 integer, intent(in) :: nullValue
4048
4049 ! Locals:
4050 integer :: numSelected, indexSelected, index
4051 integer, allocatable :: buffer(:), indices(:)
4052
4053 ! Compute the number of non-null values in array 'A'
4054 indexSelected = 0
4055 do index = 1, size(A)
4056 if ( A(index) /= nullValue ) then
4057 indexSelected = indexSelected + 1
4058 end if
4059 end do
4060 numSelected = indexSelected
4061
4062 ! Allocate temporary arrays
4063 allocate(buffer(numSelected))
4064 allocate(indices(numSelected))
4065
4066 ! Initialize the temporary arrays
4067 indexSelected = 0
4068 do index = 1, size(A)
4069 if ( A(index) /= nullValue ) then
4070 indexSelected = indexSelected + 1
4071 buffer(indexSelected) = A(index)
4072 ! keep the index of the value in the original array
4073 indices(indexSelected) = index
4074 end if
4075 end do
4076
4077 call thn_QsortInt(buffer,indices)
4078
4079 ! Populate again the array 'A' with the data from 'buffer'
4080 ! Populate again the array 'B' with the data from 'indices'
4081 indexSelected = 0
4082 do index = 1, size(A)
4083 if ( A(index) /= nullValue ) then
4084 indexSelected = indexSelected + 1
4085 A(index) = buffer(indexSelected)
4086 B(index) = indices(indexSelected)
4087 else
4088 B(index) = index
4089 end if
4090 end do
4091
4092 deallocate(buffer)
4093 deallocate(indices)
4094
4095 end subroutine thn_QsortIntIgnoringNullValues
4096
4097 !--------------------------------------------------------------------------
4098 ! thn_QsortInt
4099 !--------------------------------------------------------------------------
4100 recursive subroutine thn_QsortInt(A,B)
4101 !
4102 !:Purpose: Quick sort algorithm for integer data.
4103 !
4104 implicit none
4105
4106 ! Arguments:
4107 integer, intent(inout) :: A(:)
4108 integer, intent(inout) :: B(:)
4109
4110 ! Locals:
4111 integer :: iq
4112
4113 if (size(A) > 1) then
4114 call thn_QsortIntpartition(A,B,iq)
4115 call thn_QsortInt(A(:iq-1),B(:iq-1))
4116 call thn_QsortInt(A(iq:),B(iq:))
4117 end if
4118
4119 end subroutine thn_QsortInt
4120
4121 !--------------------------------------------------------------------------
4122 ! thn_QsortIntpartition
4123 !--------------------------------------------------------------------------
4124 subroutine thn_QsortIntpartition(A,B,marker)
4125 !
4126 !:Purpose: Subroutine called in quick sort for integers.
4127 !
4128 implicit none
4129
4130 ! Arguments:
4131 integer, intent(inout) :: A(:)
4132 integer, intent(inout) :: B(:)
4133 integer, intent(out) :: marker
4134
4135 ! Locals:
4136 integer :: i, j, tmpi
4137 integer :: temp
4138 integer :: x ! pivot point
4139
4140 x = A(1)
4141 i= 0
4142 j= size(A) + 1
4143
4144 do
4145 j = j-1
4146 do
4147 if (A(j) <= x) exit
4148 j = j-1
4149 end do
4150 i = i+1
4151 do
4152 if (A(i) >= x) exit
4153 i = i+1
4154 end do
4155 if (i < j) then
4156 ! exchange A(i) and A(j)
4157 temp = A(i)
4158 A(i) = A(j)
4159 A(j) = temp
4160 tmpi = B(i)
4161 B(i) = B(j)
4162 B(j) = tmpi
4163 else if (i == j) then
4164 marker = i+1
4165 return
4166 else
4167 marker = i
4168 return
4169 end if
4170 end do
4171
4172 end subroutine thn_QsortIntpartition
4173
4174 !--------------------------------------------------------------------------
4175 ! thn_QsortReal8
4176 !--------------------------------------------------------------------------
4177 recursive subroutine thn_QsortReal8(A,B)
4178 !
4179 !:Purpose: Quick sort algorithm for real8 data.
4180 !
4181 implicit none
4182
4183 ! Arguments:
4184 real(8), intent(inout) :: A(:)
4185 integer, intent(inout) :: B(:)
4186
4187 ! Locals:
4188 integer :: iq
4189
4190 if (size(A) > 1) then
4191 call thn_QsortReal8partition(A,B,iq)
4192 call thn_QsortReal8(A(:iq-1),B(:iq-1))
4193 call thn_QsortReal8(A(iq:),B(iq:))
4194 end if
4195
4196 end subroutine thn_QsortReal8
4197
4198 !--------------------------------------------------------------------------
4199 ! thn_QsortReal8partition
4200 !--------------------------------------------------------------------------
4201 subroutine thn_QsortReal8partition(A,B,marker)
4202 !
4203 !:Purpose: Subroutine called for quick sort of real8 data.
4204 !
4205 implicit none
4206
4207 ! Arguments:
4208 real(8), intent(inout) :: A(:)
4209 integer, intent(inout) :: B(:)
4210 integer, intent(out) :: marker
4211
4212 ! Locals:
4213 integer :: i, j, tmpi
4214 real(8) :: temp
4215 real(8) :: x ! pivot point
4216
4217 x = A(1)
4218 i= 0
4219 j= size(A) + 1
4220
4221 do
4222 j = j-1
4223 do
4224 if (A(j) <= x) exit
4225 j = j-1
4226 end do
4227 i = i+1
4228 do
4229 if (A(i) >= x) exit
4230 i = i+1
4231 end do
4232 if (i < j) then
4233 ! exchange A(i) and A(j)
4234 temp = A(i)
4235 A(i) = A(j)
4236 A(j) = temp
4237 tmpi = B(i)
4238 B(i) = B(j)
4239 B(j) = tmpi
4240 else if (i == j) then
4241 marker = i+1
4242 return
4243 else
4244 marker = i
4245 return
4246 end if
4247 end do
4248
4249 end subroutine thn_QsortReal8partition
4250
4251 !--------------------------------------------------------------------------
4252 ! thn_distanceArc
4253 !--------------------------------------------------------------------------
4254 real(4) function thn_distanceArc( deltaLat, deltaLon, lat1, lat2 )
4255 !
4256 !:Purpose: Compute arc distance.
4257 !
4258 implicit none
4259
4260 ! Arguments:
4261 real(4), intent(in) :: deltaLat
4262 real(4), intent(in) :: deltaLon
4263 real(4), intent(in) :: lat1
4264 real(4), intent(in) :: lat2
4265
4266 ! Locals:
4267 real(4), parameter :: PI = 3.141592654
4268 real(4), parameter :: RT = 6374.893
4269 real(4) :: lat1_r, lat2_r, deltaLat_r, deltaLon_r, term_a
4270
4271 lat1_r = lat1*PI/180.
4272 lat2_r = lat2*PI/180.
4273 deltaLat_r = deltaLat*PI/180.
4274 deltaLon_r = deltaLon*PI/180.
4275
4276 term_a = sin(deltaLat_r/2)*sin(deltaLat_r/2) + &
4277 cos(lat1_r)*cos(lat2_r)*sin(deltaLon_r/2)*sin(deltaLon_r/2)
4278 if(term_a < 0.0) term_a = 0.0
4279 if(term_a > 1.0) term_a = 1.0
4280
4281 thn_distanceArc = 2*RT*asin(sqrt(term_a))
4282
4283 end function thn_distanceArc
4284
4285 !--------------------------------------------------------------------------
4286 ! thn_aircraftByBoxes
4287 !--------------------------------------------------------------------------
4288 subroutine thn_aircraftByBoxes(obsdat, familyType, deltmax)
4289 !
4290 !:Purpose: Original method for thinning aircraft data by lat-lon boxes.
4291 ! Set bit 11 of OBS_FLG on observations that are to be rejected.
4292 !
4293 implicit none
4294
4295 ! Arguments:
4296 type(struct_obs), intent(inout) :: obsdat
4297 character(len=*), intent(in) :: familyType
4298 integer, intent(in) :: deltmax
4299
4300 ! Locals:
4301 character(len=4), allocatable :: varNamesPsfc(:)
4302 character(len=20) :: trlmFileName
4303 character(len=2) :: fileNumber
4304 type(struct_hco), pointer :: hco_thinning
4305 type(struct_vco), pointer :: vco_sfc
4306 type(struct_gsv) :: stateVectorPsfc
4307 integer :: numLon, numLat, nsize, headerIndexBeg, headerIndexEnd
4308 integer :: nulnam, ierr, lonIndex, latIndex, levIndex, stepIndex, codtyp
4309 integer :: obsLonIndex, obsLatIndex, obsLevIndex, obsStepIndex
4310 integer :: numHeader, numHeaderMaxMpi, headerIndex, bodyIndex
4311 integer :: aiTypeCount(4), aiTypeCountMpi(4)
4312 integer :: obsFlag, obsVarno, obsDate, obsTime, countObs, countObsMpi
4313 logical :: ttMissing, huMissing, uuMissing, vvMissing, ddMissing, ffMissing
4314 real(8) :: zpresa, zpresb, obsPressure, delMinutes, obsStepIndex_r8
4315 real(8) :: obsLonInRad, obsLatInRad, obsLonInDegrees, obsLatInDegrees
4316 real(8) :: deltaLon, deltaLat, deltaPress, midDistance, score
4317 real(4), allocatable :: gridLat(:), gridLon(:)
4318 integer, allocatable :: rejectCount(:), rejectCountMpi(:)
4319 real(8), allocatable :: gridPressure(:,:,:,:)
4320 real(8), pointer :: surfPressure(:,:,:,:)
4321 logical, allocatable :: valid(:), validMpi(:), isAircraft(:)
4322 integer, allocatable :: obsLatIndexVec(:), obsLonIndexVec(:)
4323 integer, allocatable :: obsTimeIndexVec(:), obsLevIndexVec(:)
4324 integer, allocatable :: obsLatIndexMpi(:), obsLonIndexMpi(:)
4325 integer, allocatable :: obsTimeIndexMpi(:), obsLevIndexMpi(:)
4326 logical, allocatable :: obsUVPresent(:), obsTTPresent(:)
4327 logical, allocatable :: obsUVPresentMpi(:), obsTTPresentMpi(:)
4328 real(4), allocatable :: obsDistance(:), obsUU(:), obsVV(:), obsTT(:)
4329 real(4), allocatable :: obsDistanceMpi(:), obsUUMpi(:), obsVVMpi(:), obsTTMpi(:)
4330 integer, allocatable :: handlesGrid(:,:,:), numObsGrid(:,:,:)
4331 real(4), allocatable :: minScoreGrid(:,:,:), minDistGrid(:,:,:), maxDistGrid(:,:,:)
4332 real(4), allocatable :: uuSumGrid(:,:,:), vvSumGrid(:,:,:), ttSumGrid(:,:,:)
4333 integer, external :: fnom, fclos
4334 integer, parameter :: maxLev = 500
4335
4336 ! Namelist variables:
4337 real(8) :: rprefinc ! parameter for defining fixed set of model levels for vertical thinning
4338 real(8) :: rptopinc ! parameter for defining fixed set of model levels for vertical thinning
4339 real(8) :: rcoefinc ! parameter for defining fixed set of model levels for vertical thinning
4340 real(4) :: vlev(maxLev) ! parameter for defining fixed set of model levels for vertical thinning
4341 integer :: numlev ! MUST NOT BE INCLUDED IN NAMELIST!
4342 namelist /namgem/rprefinc, rptopinc, rcoefinc, numlev, vlev
4343
4344 write(*,*)
4345 write(*,*) 'thn_aircraftByBoxes: Starting'
4346 write(*,*)
4347
4348 numHeader = obs_numHeader(obsdat)
4349 call rpn_comm_allReduce(numHeader, numHeaderMaxMpi, 1, 'mpi_integer', &
4350 'mpi_max','grid',ierr)
4351
4352 allocate(valid(numHeaderMaxMpi))
4353 allocate(isAircraft(numHeaderMaxMpi))
4354 valid(:) = .false.
4355 aiTypeCount(:) = 0
4356
4357 call obs_set_current_header_list(obsdat,trim(familyType))
4358 HEADER0: do
4359 headerIndex = obs_getHeaderIndex(obsdat)
4360 if (headerIndex < 0) exit HEADER0
4361
4362 ! check observation type
4363 codtyp = obs_headElem_i(obsdat, OBS_ITY, headerIndex)
4364 if ( codtyp == codtyp_get_codtyp('airep') ) then
4365 aiTypeCount(1) = aiTypeCount(1) + 1
4366 valid(headerIndex) = .true.
4367 else if ( codtyp == codtyp_get_codtyp('amdar') ) then
4368 aiTypeCount(2) = aiTypeCount(2) + 1
4369 valid(headerIndex) = .true.
4370 else if ( codtyp == codtyp_get_codtyp('acars') ) then
4371 aiTypeCount(3) = aiTypeCount(3) + 1
4372 valid(headerIndex) = .true.
4373 else if ( codtyp == codtyp_get_codtyp('ads') ) then
4374 aiTypeCount(4) = aiTypeCount(4) + 1
4375 valid(headerIndex) = .true.
4376 end if
4377 end do HEADER0
4378 isAircraft(:) = valid(:)
4379
4380 ! Return if no aircraft obs to thin
4381 allocate(validMpi(numHeaderMaxMpi*mmpi_nprocs))
4382 nsize = numHeaderMaxMpi
4383 call rpn_comm_allgather(valid, nsize, 'mpi_logical', &
4384 validMpi, nsize, 'mpi_logical', 'grid', ierr)
4385 if (count(validMpi(:)) == 0) then
4386 write(*,*) 'thn_aircraftByBoxes: no aircraft observations present'
4387 return
4388 end if
4389
4390 write(*,*) 'thn_aircraftByBoxes: numHeader, numHeaderMaxMpi = ', &
4391 numHeader, numHeaderMaxMpi
4392
4393 countObs = count(valid(:))
4394 call rpn_comm_allReduce(countObs, countObsMpi, 1, 'mpi_integer', &
4395 'mpi_sum','grid',ierr)
4396 write(*,*) 'thn_aircraftByBoxes: number of obs initial = ', countObs, countObsMpi
4397
4398 ! Setup horizontal thinning grid
4399 nullify(hco_thinning)
4400 call hco_SetupFromFile(hco_thinning, './analysisgrid_thinning_ai', &
4401 'ANALYSIS', 'Analysis')
4402
4403 ! Default namelist values
4404 numlev = MPC_missingValue_INT
4405 vlev(:) = -1
4406 rprefinc = 0.0d0
4407 rptopinc = 0.0d0
4408 rcoefinc = 0.0d0
4409 ! Read the namelist defining the vertical levels
4410 if (utl_isNamelistPresent('namgem','./flnml')) then
4411 nulnam = 0
4412 ierr = fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
4413 if (ierr /= 0) call utl_abort('thn_aircraftByBoxes: Error opening file flnml')
4414 read(nulnam,nml=namgem,iostat=ierr)
4415 if (ierr /= 0) call utl_abort('thn_aircraftByBoxes: Error reading namgem namelist')
4416 if (mmpi_myid == 0) write(*,nml=namgem)
4417 ierr = fclos(nulnam)
4418 if (numlev /= MPC_missingValue_INT) then
4419 call utl_abort('thn_aircraftByBoxes: check NAMGEM namelist section: numlev should be removed')
4420 end if
4421 numlev = 0
4422 do levIndex = 1, maxLev
4423 if (vlev(levIndex) == -1) exit
4424 numlev = numlev + 1
4425 end do
4426 else
4427 call utl_abort('thn_aircraftByBoxes: Namelist block namgem is missing in the namelist.')
4428 end if
4429
4430 ! Setup thinning grid parameters
4431 numLon = hco_thinning%ni
4432 numLat = hco_thinning%nj
4433 allocate(gridLat(numLat))
4434 allocate(gridLon(numLon))
4435 gridLon(:) = hco_thinning%lon(:) * MPC_DEGREES_PER_RADIAN_R8
4436 gridLat(:) = hco_thinning%lat(:) * MPC_DEGREES_PER_RADIAN_R8
4437 write(*,*) 'thinning grid vlev = '
4438 write(*,*) vlev(1:numLev)
4439
4440 ! Allocate vectors
4441 allocate(rejectCount(tim_nstepObs))
4442 allocate(obsLatIndexVec(numHeaderMaxMpi))
4443 allocate(obsLonIndexVec(numHeaderMaxMpi))
4444 allocate(obsLevIndexVec(numHeaderMaxMpi))
4445 allocate(obsTimeIndexVec(numHeaderMaxMpi))
4446 allocate(obsDistance(numHeaderMaxMpi))
4447 allocate(obsUU(numHeaderMaxMpi))
4448 allocate(obsVV(numHeaderMaxMpi))
4449 allocate(obsTT(numHeaderMaxMpi))
4450 allocate(obsUVPresent(numHeaderMaxMpi))
4451 allocate(obsTTPresent(numHeaderMaxMpi))
4452
4453 ! Allocate mpi global vectors
4454 allocate(rejectCountMpi(tim_nstepObs))
4455 allocate(obsLatIndexMpi(numHeaderMaxMpi*mmpi_nprocs))
4456 allocate(obsLonIndexMpi(numHeaderMaxMpi*mmpi_nprocs))
4457 allocate(obsLevIndexMpi(numHeaderMaxMpi*mmpi_nprocs))
4458 allocate(obsTimeIndexMpi(numHeaderMaxMpi*mmpi_nprocs))
4459 allocate(obsDistanceMpi(numHeaderMaxMpi*mmpi_nprocs))
4460 allocate(obsUUMpi(numHeaderMaxMpi*mmpi_nprocs))
4461 allocate(obsVVMpi(numHeaderMaxMpi*mmpi_nprocs))
4462 allocate(obsTTMpi(numHeaderMaxMpi*mmpi_nprocs))
4463 allocate(obsUVPresentMpi(numHeaderMaxMpi*mmpi_nprocs))
4464 allocate(obsTTPresentMpi(numHeaderMaxMpi*mmpi_nprocs))
4465
4466 ! Initialize vectors
4467 rejectCount(:) = 0
4468 obsLatIndexVec(:) = 0
4469 obsLonIndexVec(:) = 0
4470 obsLevIndexVec(:) = 0
4471 obsTimeIndexVec(:) = 0
4472 obsDistance(:) = 0.
4473 obsUU(:) = 0.
4474 obsVV(:) = 0.
4475 obsTT(:) = 0.
4476 obsUVPresent(:) = .true.
4477 obsTTPresent(:) = .true.
4478
4479 ! Read and interpolate the trial surface pressure
4480 nullify(vco_sfc)
4481 trlmFileName = './trlm_01'
4482 call vco_setupFromFile(vco_sfc, trlmFileName)
4483 if (vco_sfc%Vcode == 5100) then
4484 allocate(varNamesPsfc(2))
4485 varNamesPsfc = (/'P0','P0LS'/)
4486 else
4487 allocate(varNamesPsfc(1))
4488 varNamesPsfc = (/'P0'/)
4489 end if
4490 call gsv_allocate( stateVectorPsfc, tim_nstepobs, hco_thinning, vco_sfc, &
4491 datestamp_opt=tim_getDatestamp(), mpi_local_opt=.false., &
4492 varNames_opt=varNamesPsfc, hInterpolateDegree_opt='LINEAR' )
4493 deallocate(varNamesPsfc)
4494 do stepIndex = 1, tim_nstepobs
4495 write(fileNumber,'(I2.2)') stepIndex
4496 trlmFileName = './trlm_' // trim(fileNumber)
4497 call gio_readFromFile( stateVectorPsfc, trlmFileName, ' ', ' ', &
4498 stepIndex_opt=stepIndex, containsFullField_opt=.true. )
4499 end do
4500
4501 ! compute pressure of each model level using p0
4502 allocate(gridPressure(numLon,numLat,numLev,tim_nstepobs))
4503 gridPressure(:,:,:,:) = -1.0
4504 call gsv_getField(stateVectorPsfc,surfPressure)
4505 do stepIndex = 1, tim_nstepobs
4506 do levIndex = 1, numLev
4507 zpresb = ( (vlev(levIndex) - rptopinc/rprefinc) / &
4508 (1.0D0-rptopinc/rprefinc) )**rcoefinc
4509 zpresa = rprefinc * (vlev(levIndex)-zpresb)
4510 do latIndex = 1, numLat
4511 do lonIndex = 1, numLon
4512 gridPressure(lonIndex,latIndex,levIndex,stepIndex) = &
4513 zpresa + zpresb*surfPressure(lonIndex,latIndex,1,stepIndex)
4514 end do
4515 end do
4516 end do
4517 end do
4518 call gsv_deallocate(stateVectorPsfc)
4519
4520 call obs_set_current_header_list(obsdat,trim(familyType))
4521 HEADER1: do
4522 headerIndex = obs_getHeaderIndex(obsdat)
4523 if (headerIndex < 0) exit HEADER1
4524
4525 ! find time difference
4526 obsDate = obs_headElem_i(obsdat, OBS_DAT, headerIndex)
4527 obsTime = obs_headElem_i(obsdat, OBS_ETM, headerIndex)
4528 call tim_getStepObsIndex(obsStepIndex_r8, tim_getDatestamp(), &
4529 obsDate, obsTime, tim_nstepobs)
4530 obsStepIndex = nint(obsStepIndex_r8)
4531 delMinutes = abs(nint(60.0 * tim_dstepobs * abs(real(obsStepIndex) - obsStepIndex_r8)))
4532
4533 ! check time window
4534 if ( delMinutes > deltmax ) then
4535 valid(headerIndex) = .false.
4536 rejectCount(obsStepIndex) = rejectCount(obsStepIndex) + 1
4537 end if
4538
4539 ! Only accept obs below 175hPa
4540 obsPressure = -1.0d0
4541 call obs_set_current_body_list(obsdat, headerIndex)
4542 BODY: do
4543 bodyIndex = obs_getBodyIndex(obsdat)
4544 if (bodyIndex < 0) exit BODY
4545
4546 if (obsPressure < 0.0d0) then
4547 obsPressure = obs_bodyElem_r(obsdat, OBS_PPP, bodyIndex)
4548 if ( obsPressure < 17500.0 .or. obsPressure > 110000.0 ) valid(headerIndex) = .false.
4549 end if
4550 end do BODY
4551
4552 ttMissing = .true.
4553 huMissing = .true.
4554 uuMissing = .true.
4555 vvMissing = .true.
4556 ddMissing = .true.
4557 ffMissing = .true.
4558 call obs_set_current_body_list(obsdat, headerIndex)
4559 BODY2: do
4560 bodyIndex = obs_getBodyIndex(obsdat)
4561 if (bodyIndex < 0) exit BODY2
4562
4563 obsFlag = obs_bodyElem_i(obsdat, OBS_FLG, bodyIndex)
4564 obsVarno = obs_bodyElem_i(obsdat, OBS_VNM, bodyIndex)
4565
4566 ! find number of elements availables
4567 if (obsVarno == BUFR_NETT) then
4568 if ( .not. (btest(obsFlag,18) .or. btest(obsFlag,16) .or. &
4569 btest(obsFlag,9) .or. btest(obsFlag,8) .or. &
4570 btest(obsFlag,2)) ) then
4571 ttMissing = .false.
4572 obsTT(headerIndex) = obs_bodyElem_r(obsdat, OBS_VAR, bodyIndex)
4573 end if
4574 else if (obsVarno == BUFR_NEES) then
4575 if ( .not. (btest(obsFlag,18) .or. btest(obsFlag,16) .or. &
4576 btest(obsFlag,9) .or. btest(obsFlag,8) .or. &
4577 btest(obsFlag,2)) ) huMissing = .false.
4578 else if (obsVarno == BUFR_NEUU) then
4579 if ( .not. (btest(obsFlag,18) .or. btest(obsFlag,16) .or. &
4580 btest(obsFlag,9) .or. btest(obsFlag,8) .or. &
4581 btest(obsFlag,2)) ) then
4582 uuMissing = .false.
4583 obsUU(headerIndex) = obs_bodyElem_r(obsdat, OBS_VAR, bodyIndex)
4584 end if
4585 else if (obsVarno == BUFR_NEVV) then
4586 if ( .not. (btest(obsFlag,18) .or. btest(obsFlag,16) .or. &
4587 btest(obsFlag,9) .or. btest(obsFlag,8) .or. &
4588 btest(obsFlag,2)) ) then
4589 vvMissing = .false.
4590 obsVV(headerIndex) = obs_bodyElem_r(obsdat, OBS_VAR, bodyIndex)
4591 end if
4592 else if (obsVarno == BUFR_NEDD) then
4593 if ( .not. (btest(obsFlag,18) .or. btest(obsFlag,16) .or. &
4594 btest(obsFlag,9) .or. btest(obsFlag,8) .or. &
4595 btest(obsFlag,2)) ) ddMissing = .false.
4596 else if (obsVarno == BUFR_NEFF) then
4597 if ( .not. (btest(obsFlag,18) .or. btest(obsFlag,16) .or. &
4598 btest(obsFlag,9) .or. btest(obsFlag,8) .or. &
4599 btest(obsFlag,2)) ) ffMissing = .false.
4600 end if
4601
4602 end do BODY2
4603
4604 ! wind components are rejected if speed or direction
4605 if (ddMissing .or. ffMissing) then
4606 uuMissing = .true.
4607 vvMissing = .true.
4608 end if
4609
4610 ! eliminate records with nothing to assimilate
4611 if (ttMissing .and. huMissing .and. uuMissing .and. vvMissing) then
4612 rejectCount(obsStepIndex) = rejectCount(obsStepIndex) + 1
4613 valid(headerIndex) = .false.
4614 end if
4615
4616 if( uuMissing .or. vvMissing ) obsUVPresent(headerIndex) = .false.
4617 if( ttMissing ) obsTTPresent(headerIndex) = .false.
4618
4619 ! Lat and Lon for each observation
4620 obsLonInRad = obs_headElem_r(obsdat, OBS_LON, headerIndex)
4621 obsLatInRad = obs_headElem_r(obsdat, OBS_LAT, headerIndex)
4622 obsLonInDegrees = MPC_DEGREES_PER_RADIAN_R8 * obsLonInRad
4623 obsLatInDegrees = MPC_DEGREES_PER_RADIAN_R8 * obsLatInRad
4624
4625 ! latitude index
4626 deltaLat = abs(gridLat(1) - obsLatInDegrees)
4627 obsLatIndex = 1
4628 do latIndex = 2, numLat
4629 if (abs(gridLat(latIndex) - obsLatInDegrees) < deltaLat) then
4630 deltaLat = abs(gridLat(latIndex) - obsLatInDegrees)
4631 obsLatIndex = latIndex
4632 end if
4633 end do
4634
4635 ! longitude index
4636 deltaLon = abs(gridLon(1) - obsLonInDegrees)
4637 obsLonIndex = 1
4638 do lonIndex = 2, numLon
4639 if ( abs(gridLon(lonIndex) - obsLonInDegrees) < deltaLon ) then
4640 deltaLon = abs(gridLon(lonIndex) - obsLonInDegrees)
4641 obsLonIndex = lonIndex
4642 end if
4643 end do
4644
4645 ! layer index
4646 deltaPress = abs(gridPressure(obsLonIndex,obsLatIndex,1,obsStepIndex) - obsPressure)
4647 obsLevIndex = 1
4648 do levIndex = 2, numLev
4649 if ( abs(gridPressure(obsLonIndex,obsLatIndex,levIndex,obsStepIndex) - obsPressure) < &
4650 deltaPress ) then
4651 deltaPress = abs( gridPressure(obsLonIndex,obsLatIndex,levIndex,obsStepIndex) - &
4652 obsPressure )
4653 obsLevIndex = levIndex
4654 end if
4655 end do
4656
4657 obsLatIndexVec(headerIndex) = obsLatIndex
4658 obsLonIndexVec(headerIndex) = obsLonIndex
4659 obsLevIndexVec(headerIndex) = obsLevIndex
4660 obsTimeIndexVec(headerIndex) = obsStepIndex
4661 obsDistance(headerIndex) = sqrt((deltaLon*3)**2 + (deltaLat*3)**2 + (deltaPress/100.0)**2)
4662
4663 end do HEADER1
4664
4665 call rpn_comm_allReduce(aiTypeCount, aiTypeCountMpi, 4, 'mpi_integer', &
4666 'mpi_sum','grid',ierr)
4667 call rpn_comm_allReduce(rejectCount, rejectCountMpi, tim_nstepObs, 'mpi_integer', &
4668 'mpi_sum','grid',ierr)
4669
4670 write(*,*)
4671 write(*,'(a50,i10)') ' Total number of obs = ', sum(aiTypeCountMpi(:))
4672 write(*,*)
4673 do stepIndex = 1, tim_nstepobs
4674 write(*,'(a50,2i10)')' Number of rejects for bin = ', stepIndex, rejectCountMpi(stepIndex)
4675 end do
4676 write(*,'(a50,i10)')' Total number of rejects = ', sum(rejectCountMpi)
4677 write(*,*)
4678 write(*,'(a50,i10)') '====nb AIREP = ', aiTypeCountMpi(1)
4679 write(*,'(a50,i10)') '====nb AMDAR = ', aiTypeCountMpi(2)
4680 write(*,'(a50,i10)') '====nb ACARS = ', aiTypeCountMpi(3)
4681 write(*,'(a50,i10)') '====nb ADS = ', aiTypeCountMpi(4)
4682 write(*,*)
4683
4684 allocate(handlesGrid(numLat,numLon,numLev))
4685 allocate(minScoreGrid(numLat,numLon,numLev))
4686 allocate(minDistGrid(numLat,numLon,numLev))
4687 allocate(maxDistGrid(numLat,numLon,numLev))
4688 allocate(numObsGrid(numLat,numLon,numLev))
4689 allocate(uuSumGrid(numLat,numLon,numLev))
4690 allocate(vvSumGrid(numLat,numLon,numLev))
4691 allocate(ttSumGrid(numLat,numLon,numLev))
4692
4693 ! Make all inputs to the following tests mpiglobal
4694 nsize = numHeaderMaxMpi
4695 call rpn_comm_allgather(valid, nsize, 'mpi_logical', &
4696 validMpi, nsize, 'mpi_logical', 'grid', ierr)
4697 call rpn_comm_allgather(obsLatIndexVec, nsize, 'mpi_integer', &
4698 obsLatIndexMpi, nsize, 'mpi_integer', 'grid', ierr)
4699 call rpn_comm_allgather(obsLonIndexVec, nsize, 'mpi_integer', &
4700 obsLonIndexMpi, nsize, 'mpi_integer', 'grid', ierr)
4701 call rpn_comm_allgather(obsLevIndexVec, nsize, 'mpi_integer', &
4702 obsLevIndexMpi, nsize, 'mpi_integer', 'grid', ierr)
4703 call rpn_comm_allgather(obsTimeIndexVec,nsize, 'mpi_integer', &
4704 obsTimeIndexMpi,nsize, 'mpi_integer', 'grid', ierr)
4705 call rpn_comm_allgather(obsDistance, nsize, 'mpi_real4', &
4706 obsDistanceMpi, nsize, 'mpi_real4', 'grid', ierr)
4707 call rpn_comm_allgather(obsUU, nsize, 'mpi_real4', &
4708 obsUUMpi, nsize, 'mpi_real4', 'grid', ierr)
4709 call rpn_comm_allgather(obsVV, nsize, 'mpi_real4', &
4710 obsVVMpi, nsize, 'mpi_real4', 'grid', ierr)
4711 call rpn_comm_allgather(obsTT, nsize, 'mpi_real4', &
4712 obsTTMpi, nsize, 'mpi_real4', 'grid', ierr)
4713 call rpn_comm_allgather(obsUVPresent, nsize, 'mpi_logical', &
4714 obsUVPresentMpi, nsize, 'mpi_logical', 'grid', ierr)
4715 call rpn_comm_allgather(obsTTPresent, nsize, 'mpi_logical', &
4716 obsTTPresentMpi, nsize, 'mpi_logical', 'grid', ierr)
4717
4718 STEP: do stepIndex = 1, tim_nstepobs
4719 handlesGrid(:,:,:) = -1
4720 minScoreGrid(:,:,:) = 1000000.
4721 minDistGrid(:,:,:) = 1000000.
4722 maxDistGrid(:,:,:) = 0.
4723 numObsGrid(:,:,:) = 0
4724 uuSumGrid(:,:,:) = 0.
4725 vvSumGrid(:,:,:) = 0.
4726 ttSumGrid(:,:,:) = 0.
4727
4728 ! Calcul des distances min et max du centre la boite des rapports
4729 ! contenus dans les boites
4730 do headerIndex = 1, numHeaderMaxMpi*mmpi_nprocs
4731 if( .not. validMpi(headerIndex) ) cycle
4732 if( obsTimeIndexMpi(headerIndex) /= stepIndex ) cycle
4733 latIndex = obsLatIndexMpi(headerIndex)
4734 lonIndex = obsLonIndexMpi(headerIndex)
4735 levIndex = obsLevIndexMpi(headerIndex)
4736 if ( obsDistanceMpi(headerIndex) < minDistGrid(latIndex,lonIndex,levIndex) ) then
4737 minDistGrid(latIndex,lonIndex,levIndex) = obsDistanceMpi(headerIndex)
4738 end if
4739 if ( obsDistanceMpi(headerIndex) > maxDistGrid(latIndex,lonIndex,levIndex) ) then
4740 maxDistGrid(latIndex,lonIndex,levIndex) = obsDistanceMpi(headerIndex)
4741 end if
4742 end do
4743
4744 ! Calcul des sommes de u, v et t des observations situees a une distance midDistance
4745 ! du centre de la boite
4746 do headerIndex = 1, numHeaderMaxMpi*mmpi_nprocs
4747 if( .not. validMpi(headerIndex) ) cycle
4748 if( obsTimeIndexMpi(headerIndex) /= stepIndex ) cycle
4749 latIndex = obsLatIndexMpi(headerIndex)
4750 lonIndex = obsLonIndexMpi(headerIndex)
4751 levIndex = obsLevIndexMpi(headerIndex)
4752 midDistance = ( minDistGrid(latIndex,lonIndex,levIndex) + &
4753 maxDistGrid(latIndex,lonIndex,levIndex) )/2.
4754 if ( (obsDistanceMpi(headerIndex) < midDistance) .and. &
4755 obsTTPresentMpi(headerIndex) .and. &
4756 obsUVPresentMpi(headerIndex) ) then
4757 numObsGrid(latIndex,lonIndex,levIndex) = &
4758 numObsGrid(latIndex,lonIndex,levIndex) + 1
4759 uuSumGrid(latIndex,lonIndex,levIndex) = &
4760 uuSumGrid(latIndex,lonIndex,levIndex) + obsUUMpi(headerIndex)
4761 vvSumGrid(latIndex,lonIndex,levIndex) = &
4762 vvSumGrid(latIndex,lonIndex,levIndex) + obsVVMpi(headerIndex)
4763 ttSumGrid(latIndex,lonIndex,levIndex) = &
4764 ttSumGrid(latIndex,lonIndex,levIndex) + obsTTMpi(headerIndex)
4765 end if
4766 end do
4767
4768 ! Calcul la moyenne de u, v et t s'il y a plus de 3 rapports dans la boite
4769 do latIndex = 1, numLat
4770 do lonIndex = 1, numLon
4771 do levIndex = 1, numLev
4772 if(numObsGrid(latIndex,lonIndex,levIndex) >= 3) then
4773 uuSumGrid(latIndex,lonIndex,levIndex) = &
4774 uuSumGrid(latIndex,lonIndex,levIndex)/numObsGrid(latIndex,lonIndex,levIndex)
4775 vvSumGrid(latIndex,lonIndex,levIndex) = &
4776 vvSumGrid(latIndex,lonIndex,levIndex)/numObsGrid(latIndex,lonIndex,levIndex)
4777 ttSumGrid(latIndex,lonIndex,levIndex) = &
4778 ttSumGrid(latIndex,lonIndex,levIndex)/numObsGrid(latIndex,lonIndex,levIndex)
4779 end if
4780 end do
4781 end do
4782 end do
4783
4784 ! S'il y a plus de 3 rapports dans la boite, le rapport dont le score est le plus
4785 ! petit est retenu. S'il y a 2 rapports ou moins, le rapport le plus pres du centre
4786 ! de la boite est retenu.
4787 do headerIndex = 1, numHeaderMaxMpi*mmpi_nprocs
4788 if( .not. validMpi(headerIndex) ) cycle
4789 if( obsTimeIndexMpi(headerIndex) /= stepIndex ) cycle
4790 latIndex = obsLatIndexMpi(headerIndex)
4791 lonIndex = obsLonIndexMpi(headerIndex)
4792 levIndex = obsLevIndexMpi(headerIndex)
4793
4794 if(numObsGrid(latIndex,lonIndex,levIndex) >= 3) then
4795
4796 midDistance = ( minDistGrid(latIndex,lonIndex,levIndex) + &
4797 maxDistGrid(latIndex,lonIndex,levIndex) )/2.
4798 if ((obsDistanceMpi(headerIndex) < midDistance) .and. &
4799 obsTTPresentMpi(headerIndex) .and. &
4800 obsUVPresentMpi(headerIndex) ) then
4801 score = sqrt( (uuSumGrid(latIndex,lonIndex,levIndex) - &
4802 obsUUMpi(headerIndex))**2/(1.4**2) + &
4803 (vvSumGrid(latIndex,lonIndex,levIndex) - &
4804 obsVVMpi(headerIndex))**2/(1.4**2) ) + &
4805 (ttSumGrid(latIndex,lonIndex,levIndex) - &
4806 obsTTMpi(headerIndex))**2/(0.9**2)
4807
4808 if ( handlesGrid(latIndex,lonIndex,levIndex) /= -1 ) then
4809 if ( score >= minScoreGrid(latIndex,lonIndex,levIndex) ) then
4810 validMpi(headerIndex) = .false.
4811 end if
4812 end if
4813
4814 if ( validMpi(headerIndex) ) then
4815 if ( handlesGrid(latIndex,lonIndex,levIndex) /= -1 ) then
4816 validMpi(handlesGrid(latIndex,lonIndex,levIndex)) = .false.
4817 end if
4818 minScoreGrid(latIndex,lonIndex,levIndex) = score
4819 validMpi(headerIndex) = .true.
4820 handlesGrid(latIndex,lonIndex,levIndex) = headerIndex
4821 end if
4822
4823 else
4824 validMpi(headerIndex) = .false.
4825 end if
4826
4827 else ! if(numObsGrid(latIndex,lonIndex,levIndex) < 3)
4828
4829 if ( handlesGrid(latIndex,lonIndex,levIndex) /= -1 ) then
4830 if ( obsDistanceMpi(headerIndex) > minDistGrid(latIndex,lonIndex,levIndex) ) then
4831 validMpi(headerIndex) = .false.
4832 end if
4833 end if
4834
4835 if ( validMpi(headerIndex) ) then
4836 if ( handlesGrid(latIndex,lonIndex,levIndex) /= -1 ) then
4837 validMpi(handlesGrid(latIndex,lonIndex,levIndex)) = .false.
4838 end if
4839 validMpi(headerIndex) = .true.
4840 handlesGrid(latIndex,lonIndex,levIndex) = headerIndex
4841 end if
4842
4843 end if
4844
4845 end do ! headerIndex
4846
4847 end do STEP
4848
4849 ! Update local copy of valid from global mpi version
4850 headerIndexBeg = 1 + mmpi_myid * numHeaderMaxMpi
4851 headerIndexEnd = headerIndexBeg + numHeaderMaxMpi - 1
4852 valid(:) = validMpi(headerIndexBeg:headerIndexEnd)
4853
4854 deallocate(handlesGrid)
4855 deallocate(minScoreGrid)
4856 deallocate(minDistGrid)
4857 deallocate(maxDistGrid)
4858 deallocate(numObsGrid)
4859 deallocate(uuSumGrid)
4860 deallocate(vvSumGrid)
4861 deallocate(ttSumGrid)
4862
4863 write(*,*)
4864 write(*,'(a50,i10)') ' Number of obs in = ', sum(aiTypeCountMpi(:))
4865 write(*,'(a50,i10)') ' Number of obs out = ', count(validMpi(:))
4866 write(*,'(a50,i10)') ' Number of obs not out = ', &
4867 sum(aiTypeCountMpi(:)) - count(validMpi(:))
4868 write(*,*)
4869
4870 ! Modify the flags for rejected observations
4871 do headerIndex = 1, numHeader
4872 ! skip observation if we're not supposed to consider it
4873 if (.not. isAirCraft(headerIndex)) cycle
4874
4875 if (.not. valid(headerIndex)) then
4876 call obs_set_current_body_list(obsdat, headerIndex)
4877 BODY3: do
4878 bodyIndex = obs_getBodyIndex(obsdat)
4879 if (bodyIndex < 0) exit BODY3
4880
4881 obsFlag = obs_bodyElem_i(obsdat, OBS_FLG, bodyIndex)
4882 call obs_bodySet_i(obsdat, OBS_FLG, bodyIndex, ibset(obsFlag,11))
4883
4884 end do BODY3
4885 end if
4886 end do
4887
4888 ! Deallocation
4889 deallocate(valid)
4890 deallocate(isAircraft)
4891 deallocate(validMpi)
4892 deallocate(gridLat)
4893 deallocate(gridLon)
4894 deallocate(rejectCount)
4895 deallocate(obsLatIndexVec)
4896 deallocate(obsLonIndexVec)
4897 deallocate(obsLevIndexVec)
4898 deallocate(obsTimeIndexVec)
4899 deallocate(obsDistance)
4900 deallocate(obsUU)
4901 deallocate(obsVV)
4902 deallocate(obsTT)
4903 deallocate(obsUVPresent)
4904 deallocate(obsTTPresent)
4905 deallocate(rejectCountMpi)
4906 deallocate(obsLatIndexMpi)
4907 deallocate(obsLonIndexMpi)
4908 deallocate(obsLevIndexMpi)
4909 deallocate(obsTimeIndexMpi)
4910 deallocate(obsDistanceMpi)
4911 deallocate(obsUUMpi)
4912 deallocate(obsVVMpi)
4913 deallocate(obsTTMpi)
4914 deallocate(obsUVPresentMpi)
4915 deallocate(obsTTPresentMpi)
4916 deallocate(gridPressure)
4917
4918 write(*,*)
4919 write(*,*) 'thn_aircraftByBoxes: Finished'
4920 write(*,*)
4921
4922 end subroutine thn_aircraftByBoxes
4923
4924 !--------------------------------------------------------------------------
4925 ! thn_keepNthObs
4926 !--------------------------------------------------------------------------
4927 subroutine thn_keepNthObs(obsdat, familyType, keepNthVertical)
4928 !
4929 !:Purpose: Of the observations in a column that have not already been
4930 ! rejected, keep every nth observation and throw out the rest.
4931 ! Set bit 11 of OBS_FLG on observations that are to be rejected.
4932 !
4933 implicit none
4934
4935 ! Arguments:
4936 type(struct_obs), intent(inout) :: obsdat
4937 character(len=*), intent(in) :: familyType
4938 integer, intent(in) :: keepNthVertical
4939
4940 ! Locals:
4941 integer, parameter :: PROFILE_NOT_FOUND=-1
4942 integer :: headerIndex, bodyIndex
4943 integer :: flag
4944 integer :: countKeepN ! count to keep every Nth observation in the column
4945 integer :: newProfileId
4946
4947 write(*,*)
4948 write(*,*) 'thn_keepNthObs: Starting'
4949 write(*,*)
4950
4951 countKeepN=0
4952
4953 ! Loop over all body indices (columns) of the family of interest and
4954 ! thin each column independently of the others
4955 call obs_set_current_body_list(obsdat, familyType)
4956 BODY: do
4957 bodyIndex = obs_getBodyIndex(obsdat)
4958 if (bodyIndex < 0) exit BODY
4959
4960 ! If datum already rejected, ignore it
4961 flag = obs_bodyElem_i(obsdat, OBS_FLG, bodyIndex)
4962 if ( btest(flag,9) .or. &
4963 btest(flag,11) ) cycle BODY
4964
4965 headerIndex = obs_bodyElem_i(obsdat, OBS_HIND, bodyIndex )
4966 newProfileId = obs_headElem_i(obsdat, OBS_PRFL, headerIndex)
4967
4968 countKeepN=countKeepN + 1
4969 if ( countKeepN == keepNthVertical .or. &
4970 new_column() ) then
4971 ! Reset the counter and keep this observation
4972 countKeepN=0
4973 else
4974 ! Reject this observation
4975 call obs_bodySet_i(obsdat, OBS_FLG, bodyIndex, ibset(flag,11))
4976 end if
4977
4978 end do BODY
4979
4980 write(*,*)
4981 write(*,*) 'thn_keepNthObs: Finished'
4982 write(*,*)
4983
4984 contains
4985 function new_column()
4986 !
4987 !:Purpose: Determine whether the current observation begins a new vertical column
4988 ! (Assume that observations are in chronological order)
4989 !
4990 !:Note: This method has been written with aladin observations in mind.
4991 ! It might be necessary to generalize the method.
4992 !
4993 implicit none
4994
4995 ! Result:
4996 logical :: new_column
4997
4998 ! Locals:
4999 integer, save :: previousProfileId=huge(previousProfileId)
5000
5001 if (newProfileId == PROFILE_NOT_FOUND) then
5002 ! The profile ID for this element is missing.
5003 ! Assume that it is the same as the previous element
5004 newProfileId = previousProfileId
5005 end if
5006
5007 if (newProfileId /= previousProfileId) then
5008 previousProfileId = newProfileId
5009 new_column=.true.
5010 else
5011 new_column=.false.
5012 end if
5013 end function new_column
5014
5015 end subroutine thn_keepNthObs
5016
5017 !--------------------------------------------------------------------------
5018 ! thn_tovsFilt
5019 !--------------------------------------------------------------------------
5020 subroutine thn_tovsFilt(obsdat, delta, deltrad, codtyp, codtyp2_opt)
5021 !
5022 !:Purpose: Thinning algorithm used for AMSU and ATMS radiance obs.
5023 ! Set bit 11 of OBS_FLG on observations that are to be rejected.
5024 !
5025 implicit none
5026
5027 ! Arguments:
5028 type(struct_obs), intent(inout) :: obsdat
5029 integer, intent(in) :: delta
5030 integer, intent(in) :: deltrad
5031 integer, intent(in) :: codtyp
5032 integer, optional, intent(in) :: codtyp2_opt
5033
5034 ! Locals:
5035 integer :: numLat, numLon, headerIndex, headerIndexKeep, latIndex, lonIndex, latIndex2
5036 integer :: gridIndex, numGridLonsTotal, obsTime, obsDate, numHeader, numHeaderMaxMpi, ierr
5037 integer :: bodyIndex, stepIndex, obsIndex, obsFov
5038 integer :: loscan, hiscan, obsFlag, numObs, minLonBurpFileMpi(mmpi_nprocs)
5039 integer :: procIndex, procIndexKeep, minLonBurpFile, countObs, countObsMpi
5040 integer :: countQc, countKept, countOther, countKeptMpi, countQcMpi, countGridPoints
5041 real(4) :: obsLatInRad, obsLonInRad, obsLat, obsLon, distance
5042 real(4) :: obsLatInDegrees, obsLonInDegrees, minDistance, minDistanceMpi(mmpi_nprocs)
5043 real(4) :: rejectRate, gridLat, gridLon
5044 real(4) :: percentTotal, percentQc, percentOther, percentKept
5045 real(8), allocatable :: stepObsIndex(:)
5046 real(4), allocatable :: gridLats(:), gridLatsAll(:), gridLonsAll(:), obsDistance(:)
5047 logical, allocatable :: valid(:)
5048 integer, allocatable :: numGridLons(:), numObsGrid(:), obsGridIndex(:)
5049 integer, allocatable :: obsLonBurpFile(:), obsLatBurpFile(:), numObsAssim(:)
5050 integer, allocatable :: headerIndexList(:), headerIndexList2(:)
5051 integer, allocatable :: obsIndexGrid(:), obsIndexLink(:)
5052 character(len=codtyp_name_length) :: instrumName
5053 integer, parameter :: latLength=10000
5054 integer, parameter :: lonLength=40000
5055 integer, parameter :: mxscanamsua=30
5056 integer, parameter :: mxscanamsub=90
5057 integer, parameter :: mxscanatms =96
5058 integer, parameter :: mxscanmwhs2=98
5059 integer, parameter :: mxscanssmis=90
5060
5061 instrumName = codtyp_get_name(codtyp)
5062 write(*,*)
5063 write(*,*) 'thn_tovsFilt: Starting, ', trim(instrumName)
5064 write(*,*)
5065
5066 numHeader = obs_numHeader(obsdat)
5067 call rpn_comm_allReduce(numHeader, numHeaderMaxMpi, 1, 'mpi_integer', &
5068 'mpi_max','grid',ierr)
5069
5070 ! Check if we have any observations to process
5071 allocate(valid(numHeaderMaxMpi))
5072 valid(:) = .false.
5073 do headerIndex = 1, numHeader
5074 if (obs_headElem_i(obsdat, OBS_ITY, headerIndex) == codtyp) then
5075 valid(headerIndex) = .true.
5076 else if (present(codtyp2_opt)) then
5077 if (obs_headElem_i(obsdat, OBS_ITY, headerIndex) == codtyp2_opt) then
5078 valid(headerIndex) = .true.
5079 end if
5080 end if
5081 end do
5082
5083 countObs = count(valid(:))
5084 call rpn_comm_allReduce(countObs, countObsMpi, 1, 'mpi_integer', &
5085 'mpi_sum','grid',ierr)
5086 if (countObsMpi == 0) then
5087 write(*,*) 'thn_tovsFilt: no observations for this instrument'
5088 deallocate(valid)
5089 return
5090 end if
5091
5092 write(*,*) 'thn_tovsFilt: countObs initial = ', &
5093 countObs, countObsMpi
5094
5095 ! Remove RARS obs that are also present from a global originating centre
5096 call thn_removeRarsDuplicates(obsdat, valid)
5097
5098 countObs = count(valid(:))
5099 call rpn_comm_allReduce(countObs, countObsMpi, 1, 'mpi_integer', &
5100 'mpi_sum','grid',ierr)
5101 write(*,*) 'thn_tovsFilt: countObs after thn_removeRarsDuplicates = ', &
5102 countObs, countObsMpi
5103
5104 numLat = 2*latLength/delta
5105 numLon = lonLength/delta
5106
5107 ! Allocations
5108 allocate(gridLats(numLat))
5109 allocate(gridLatsAll(numLat*numLon))
5110 allocate(gridLonsAll(numLat*numLon))
5111 allocate(numObsGrid(numLat*numLon))
5112 allocate(obsIndexGrid(numLat*numLon))
5113 allocate(obsIndexLink(numHeader))
5114 allocate(headerIndexList(numHeader))
5115 allocate(headerIndexList2(numHeader))
5116 allocate(numGridLons(numLat))
5117 allocate(obsGridIndex(numHeader))
5118 allocate(obsLonBurpFile(numHeader))
5119 allocate(obsLatBurpFile(numHeader))
5120 allocate(numObsAssim(numHeader))
5121 allocate(obsDistance(numHeader))
5122 allocate(stepObsIndex(numHeader))
5123
5124 ! Initialize arrays
5125 gridLats(:) = 0.0
5126 gridLatsAll(:) = 0.0
5127 gridLonsAll(:) = 0.0
5128 obsDistance(:) = 0.0
5129 numObsGrid(:) = 0
5130 obsIndexGrid(:) = 0
5131 obsIndexLink(:) = 0
5132 headerIndexList(:) = 0
5133 headerIndexList2(:) = 0
5134 numGridLons(:) = 0
5135 obsGridIndex(:) = 0
5136 obsLonBurpFile(:) = 0
5137 obsLatBurpFile(:) = 0
5138 numObsAssim(:) = 0
5139 stepObsIndex(:) = 0.0d0
5140
5141 ! Set up the grid used for thinning
5142 numGridLonsTotal = 0
5143 do latIndex = 1, numLat
5144 gridLats(latIndex) = (latIndex*180./numLat) - 90.
5145 distance = lonLength * cos(gridLats(latIndex) * mpc_pi_r4 / 180.)
5146 numGridLons(latIndex) = nint(distance/delta)
5147 numGridLons(latIndex) = max(numGridLons(latIndex),1)
5148 numGridLonsTotal = numGridLonsTotal + numGridLons(latIndex)
5149 end do
5150
5151 gridIndex = 0
5152 do latIndex = 1, numLat
5153 do lonIndex = 1, numGridLons(latIndex)
5154 gridLatsAll(gridIndex+lonIndex) = gridLats(latIndex)
5155 gridLonsAll(gridIndex+lonIndex) = (lonIndex-1) * 360. / numGridLons(latIndex)
5156 end do
5157 gridIndex = gridIndex + numGridLons(latIndex)
5158 end do
5159
5160 ! Loop over all observation locations
5161 do headerIndex = 1, numHeader
5162 if ( .not. valid(headerIndex) ) cycle
5163
5164 ! Lat and Lon for each observation
5165 obsLonInRad = obs_headElem_r(obsdat, OBS_LON, headerIndex)
5166 obsLatInRad = obs_headElem_r(obsdat, OBS_LAT, headerIndex)
5167
5168 obsLonInDegrees = MPC_DEGREES_PER_RADIAN_R8 * obsLonInRad
5169 obsLatInDegrees = MPC_DEGREES_PER_RADIAN_R8 * obsLatInRad
5170 obsLonBurpFile(headerIndex) = nint(100.0*(obsLonInDegrees - 180.0))
5171 if(obsLonBurpFile(headerIndex) < 0) then
5172 obsLonBurpFile(headerIndex) = obsLonBurpFile(headerIndex) + 36000
5173 end if
5174 obsLatBurpFile(headerIndex) = 9000+nint(100.0*obsLatInDegrees)
5175
5176 obsDate = obs_headElem_i(obsdat, OBS_DAT, headerIndex)
5177 obsTime = obs_headElem_i(obsdat, OBS_ETM, headerIndex)
5178 call tim_getStepObsIndex(stepObsIndex(headerIndex), tim_getDatestamp(), &
5179 obsDate, obsTime, tim_nstepobs)
5180
5181 ! Associate each observation to a grid point
5182 obsLat = (obsLatBurpFile(headerIndex) - 9000.) / 100.
5183 obsLon = obsLonBurpFile(headerIndex) / 100.
5184 do latIndex = 1, numLat-1
5185 if (obsLat < gridLats(1)) obsLat = gridLats(1)
5186 if (obsLat >= gridLats(numLat)) obsLat = gridLats(numLat) - 0.5
5187 if (obsLat >= gridLats(latIndex) .and. obsLat < gridLats(latIndex+1)) then
5188 gridIndex = 1
5189 do latIndex2 = 1, latIndex-1
5190 gridIndex = gridIndex + numGridLons(latIndex2)
5191 end do
5192 gridIndex = gridIndex + ifix(obsLon/(360./numGridLons(latIndex)))
5193 exit
5194 end if
5195 end do
5196 obsGridIndex(headerIndex) = gridIndex
5197 numObsGrid(gridIndex) = numObsGrid(gridIndex) + 1
5198
5199 end do ! headerIndex
5200
5201 if ( codtyp == codtyp_get_codtyp('amsua') ) then
5202 loscan = 1
5203 hiscan = mxscanamsua
5204 else if ( codtyp == codtyp_get_codtyp('amsub') ) then
5205 loscan = 1
5206 hiscan = mxscanamsub
5207 else if ( codtyp == codtyp_get_codtyp('atms') ) then
5208 loscan = 2
5209 hiscan = mxscanatms - 1
5210 else if ( codtyp == codtyp_get_codtyp('mwhs2') ) then
5211 loscan = 1
5212 hiscan = mxscanmwhs2
5213 else if ( codtyp == codtyp_get_codtyp('ssmis') ) then
5214 loscan = 1
5215 hiscan = mxscanssmis
5216 else
5217 write(*,*) 'codtyp = ', codtyp
5218 call utl_abort('thn_tovsFilt: Invalid codtyp')
5219 end if
5220
5221 countQc = 0
5222 numObsAssim(:) = 0
5223 do headerIndex = 1, numHeader
5224
5225 if ( .not. valid(headerIndex) ) cycle
5226
5227 ! Look at the obs flags
5228 rejectRate = 0.
5229
5230 call obs_set_current_body_list(obsdat, headerIndex)
5231 BODY: do
5232 bodyIndex = obs_getBodyIndex(obsdat)
5233 if (bodyIndex < 0) exit BODY
5234
5235 ! If not a blacklisted channel (note that bit 11 is set in
5236 ! satqc_amsu*.f for blacklisted channels)
5237 obsFlag = obs_bodyElem_i(obsdat, OBS_FLG, bodyIndex)
5238 if ( .not. btest(obsFlag,11) ) then
5239 numObsAssim(headerIndex) = numObsAssim(headerIndex) + 1
5240 if ( btest(obsFlag,9) ) then
5241 rejectRate = rejectRate + 1.0
5242 end if
5243 end if
5244 end do BODY
5245
5246 ! fixer le % de rejets a 100% si aucun canal n'est assimilable
5247 if ( rejectRate == 0. .and. numObsAssim(headerIndex) == 0 ) then
5248 rejectRate = 1.
5249 else
5250 rejectRate = rejectRate / max(numObsAssim(headerIndex),1)
5251 end if
5252
5253 obsFov = obs_headElem_i(obsdat, OBS_FOV, headerIndex)
5254 if ( rejectRate >= 0.80 ) then
5255 countQc = countQc + 1
5256 valid(headerIndex) = .false.
5257 else if (obsFov < loscan .or. &
5258 obsFov > hiscan ) then
5259 countQc = countQc + 1
5260 valid(headerIndex) = .false.
5261 end if
5262
5263 end do
5264
5265 countObs = count(valid(:))
5266 call rpn_comm_allReduce(countObs, countObsMpi, 1, 'mpi_integer', &
5267 'mpi_sum','grid',ierr)
5268 write(*,*) 'thn_tovsFilt: countObs after QC = ', &
5269 countObs, countObsMpi
5270
5271 ! Calculate distance of obs. from center of its grid box center
5272 do headerIndex = 1, numHeader
5273 if ( .not. valid(headerIndex) ) cycle
5274
5275 gridIndex = obsGridIndex(headerIndex)
5276 if (numObsGrid(gridIndex) /= 0) then
5277 latIndex = (gridLatsAll(gridIndex)+90.)/(180./numLat)
5278 gridLat = gridLatsAll(gridIndex) + 0.5*(180./numLat)
5279 gridLon = gridLonsAll(gridIndex) + 0.5*360./numGridLons(latIndex)
5280 obsLat = (obsLatBurpFile(headerIndex) - 9000.) / 100.
5281 obsLon = obsLonBurpFile(headerIndex) / 100.
5282 obsDistance(headerIndex) = thn_separation(obsLon,obsLat,gridLon,gridLat) * &
5283 float(latLength) / 90.
5284 end if
5285 end do
5286
5287 ! Create a linked list of observations (link to grid point)
5288 obsIndexGrid(:) = 0
5289 obsIndexLink(:) = 0
5290 countObs = 0
5291 do headerIndex = 1, numHeader
5292 if ( .not. valid(headerIndex) ) cycle
5293
5294 gridIndex = obsGridIndex(headerIndex)
5295 if (numObsGrid(gridIndex) /= 0) then
5296 countObs = countObs + 1
5297 headerIndexList(countObs) = headerIndex
5298 obsIndexLink(countObs) = obsIndexGrid(gridIndex)
5299 obsIndexGrid(gridIndex) = countObs
5300 end if
5301 end do
5302
5303 ! Loop over stepObs
5304 do stepIndex = 1, tim_nstepobs
5305
5306 ! Loop over all grid points
5307 countGridPoints = 0
5308 do gridIndex = 1, numGridLonsTotal
5309 if (numObsGrid(gridIndex) /= 0) then
5310 countGridPoints = countGridPoints + 1
5311 end if
5312 numObs = 0
5313 obsIndex = obsIndexGrid(gridIndex)
5314 do
5315 if (obsIndex == 0) exit
5316 headerIndex = headerIndexList(obsIndex)
5317 if ( obsGridIndex(headerIndex) == gridIndex .and. &
5318 valid(headerIndex) .and. &
5319 nint(stepObsIndex(headerIndex)) == stepIndex ) then
5320 numObs = numObs + 1
5321 headerIndexList2(numObs) = headerIndex
5322 end if
5323
5324 obsIndex = obsIndexLink(obsIndex)
5325 end do
5326
5327 minDistance = 1000000.
5328
5329 ! Choose the obs closest to the grid point
5330 do obsIndex = 1, numObs
5331 if (obsDistance(headerIndexList2(obsIndex)) < minDistance) then
5332 minDistance = obsDistance(headerIndexList2(obsIndex))
5333 minLonBurpFile = obsLonBurpFile(headerIndexList2(obsIndex))
5334 headerIndexKeep = headerIndexList2(obsIndex)
5335 end if
5336 end do
5337
5338 ! Check for multiple obs with same distance to grid point
5339 if (numObs > 0) then
5340 if ( count(obsDistance(headerIndexList2(1:numObs)) == minDistance) > 1 ) then
5341 ! resolve ambiguity by choosing obs with min value of lon
5342 minLonBurpFile = 10000000
5343 do obsIndex = 1, numObs
5344 if (obsDistance(headerIndexList2(obsIndex)) == minDistance) then
5345 if (obsLonBurpFile(headerIndexList2(obsIndex)) < minLonBurpFile) then
5346 minLonBurpFile = obsLonBurpFile(headerIndexList2(obsIndex))
5347 headerIndexKeep = headerIndexList2(obsIndex)
5348 end if
5349 end if
5350 end do
5351 end if
5352 end if
5353
5354 do obsIndex = 1, numObs
5355 valid(headerIndexList2(obsIndex)) = .false.
5356 end do
5357 if (numObs > 0 .and. minDistance <= real(deltRad) ) then
5358 valid(headerIndexKeep) = .true.
5359 end if
5360
5361 ! Communicate the distance of chosen observation among all mpi tasks
5362 call rpn_comm_allgather(minDistance, 1, 'mpi_real4', &
5363 minDistanceMpi, 1, 'mpi_real4', 'grid', ierr)
5364
5365 ! Choose the closest to the center of the box among all mpi tasks
5366 minDistance = 1000000.
5367 do procIndex = 1, mmpi_nprocs
5368 if (minDistanceMpi(procIndex) < minDistance) then
5369 minDistance = minDistanceMpi(procIndex)
5370 procIndexKeep = procIndex
5371 end if
5372 end do
5373
5374 ! Adjust flags to only keep 1 observation among all mpi tasks
5375 if (minDistance < 1000000.) then
5376 if ( count(minDistanceMpi(:) == minDistance) > 1 ) then
5377 ! resolve ambiguity by choosing obs with min value of lon
5378 call rpn_comm_allgather(minLonBurpFile, 1, 'mpi_integer', &
5379 minLonBurpFileMpi, 1, 'mpi_integer', 'grid', ierr)
5380 minLonBurpFile = 10000000
5381 do procIndex = 1, mmpi_nprocs
5382 if (minDistanceMpi(procIndex) == minDistance) then
5383 if (minLonBurpFileMpi(procIndex) < minLonBurpFile) then
5384 minLonBurpFile = minLonBurpFileMpi(procIndex)
5385 procIndexKeep = procIndex
5386 end if
5387 end if
5388 end do
5389 end if
5390 if (numObs > 0) then
5391 if (mmpi_myid /= (procIndexKeep-1)) then
5392 valid(headerIndexKeep) = .false.
5393 end if
5394 end if
5395 end if
5396
5397 end do ! gridIndex
5398 end do ! stepIndex
5399
5400 countObs = count(valid(:))
5401 call rpn_comm_allReduce(countObs, countObsMpi, 1, 'mpi_integer', &
5402 'mpi_sum','grid',ierr)
5403 write(*,*) 'thn_tovsFilt: countObs after thinning = ', &
5404 countObs, countObsMpi
5405
5406 ! modify the observation flags in obsSpaceData
5407 countObs = 0
5408 do headerIndex = 1, numHeader
5409 ! skip observation if we're not supposed to consider it
5410 if (obs_headElem_i(obsdat, OBS_ITY, headerIndex) /= codtyp) then
5411 if (present(codtyp2_opt)) then
5412 if (obs_headElem_i(obsdat, OBS_ITY, headerIndex) /= codtyp2_opt) then
5413 cycle
5414 end if
5415 else
5416 cycle
5417 end if
5418 end if
5419
5420 countObs = countObs + 1
5421
5422 if (.not. valid(headerIndex)) then
5423 call obs_set_current_body_list(obsdat, headerIndex)
5424 BODY2: do
5425 bodyIndex = obs_getBodyIndex(obsdat)
5426 if (bodyIndex < 0) exit BODY2
5427
5428 obsFlag = obs_bodyElem_i(obsdat, OBS_FLG, bodyIndex)
5429 call obs_bodySet_i(obsdat, OBS_FLG, bodyIndex, ibset(obsFlag,11))
5430
5431 end do BODY2
5432 end if
5433 end do
5434
5435 ! print a summary to the listing
5436 countKept = count(valid)
5437 call rpn_comm_allReduce(countKept, countKeptMpi, 1, 'mpi_integer', &
5438 'mpi_sum','grid',ierr)
5439 call rpn_comm_allReduce(countQc, countQcMpi, 1, 'mpi_integer', &
5440 'mpi_sum','grid',ierr)
5441 call rpn_comm_allReduce(countObs, countObsMpi, 1, 'mpi_integer', &
5442 'mpi_sum','grid',ierr)
5443
5444 countOther = countObsMpi - countKeptMpi - countQcMpi
5445
5446 percentTotal = 100.0
5447 percentQc = (float(countQcMpi) / float(countObsMpi)) * 100.0
5448 percentOther = (float(countOther) / float(countObsMpi)) * 100.0
5449 percentKept = (float(countKeptMpi) / float(countObsMpi)) * 100.0
5450
5451 write(*,100)
5452100 format(/,' SOMMAIRE DES RESULTATS',/)
5453 write(*,200) countObsMpi, percentTotal, countQcMpi, percentQc, &
5454 countOther, percentOther, countKeptMpi, percentKept, &
5455 delta, numGridLonsTotal, countGridPoints
5456200 format(' NB.STNS TOTAL AU DEBUT EN ENTREE = ',I7, &
5457 ' = ',F6.1,'%',/, &
5458 ' NB.STNS REJETEES AU CONTROLE QUALITATIF = - ',I7, &
5459 ' = ',F6.1,'%',/, &
5460 ' NB.STNS REJETEES POUR LES AUTRES RAISONS= - ',I7, &
5461 ' = ',F6.1,'%',/, &
5462 ' ', &
5463 '-------- = -------',/, &
5464 ' NB.STNS GARDEES A LA FIN = ',I7, &
5465 ' = ',F6.1,'%',/////, &
5466 ' NB.PTS GRILLE AVEC LA RESOLUTION ',I5,' KM = ', &
5467 I7,/, &
5468 ' NB.PTS GRILLE TRAITES = ',I7)
5469
5470 ! end of sommair
5471
5472 deallocate(valid)
5473 deallocate(gridLats)
5474 deallocate(gridLatsAll)
5475 deallocate(gridLonsAll)
5476 deallocate(numObsGrid)
5477 deallocate(obsIndexGrid)
5478 deallocate(obsIndexLink)
5479 deallocate(headerIndexList)
5480 deallocate(headerIndexList2)
5481 deallocate(numGridLons)
5482 deallocate(obsGridIndex)
5483 deallocate(obsLonBurpFile)
5484 deallocate(obsLatBurpFile)
5485 deallocate(numObsAssim)
5486 deallocate(obsDistance)
5487 deallocate(stepObsIndex)
5488
5489 write(*,*)
5490 write(*,*) 'thn_tovsFilt: Finished'
5491 write(*,*)
5492
5493 end subroutine thn_tovsFilt
5494
5495 !--------------------------------------------------------------------------
5496 ! thn_removeRarsDuplicates
5497 !--------------------------------------------------------------------------
5498 subroutine thn_removeRarsDuplicates(obsdat, valid)
5499 !
5500 !:Purpose: Remove duplicate TOVS observations due to RARS.
5501 !
5502 implicit none
5503
5504 ! Arguments:
5505 type(struct_obs), intent(inout) :: obsdat
5506 logical, intent(inout) :: valid(:)
5507
5508 ! Locals:
5509 integer :: nsize, ierr, lenStnId, headerIndex, headerIndex1, headerIndex2
5510 integer :: numHeader, numHeaderMaxMpi, charIndex, headerIndexBeg, headerIndexEnd
5511 integer :: obsDate, obsTime
5512 real(4) :: obsLatInRad, obsLonInRad
5513 real(8) :: dlhours
5514 logical :: global1, global2
5515 integer, allocatable :: centreOrig(:), centreOrigMpi(:)
5516 integer, allocatable :: obsFov(:), obsFovMpi(:)
5517 integer, allocatable :: obsDateStamp(:), obsDateStampMpi(:)
5518 integer, allocatable :: stnIdInt(:,:), stnIdIntMpi(:,:)
5519 logical, allocatable :: validMpi(:)
5520 character(len=12) :: stnId
5521 type(kdtree2), pointer :: tree
5522 integer, parameter :: maxNumSearch = 100
5523 integer :: numFoundSearch, resultIndex
5524 type(kdtree2_result) :: searchResults(maxNumSearch)
5525 real(kdkind) :: maxRadius = 100.d6
5526 real(kdkind) :: refPosition(3)
5527 real(kdkind), allocatable :: obsPosition3d(:,:)
5528 real(kdkind), allocatable :: obsPosition3dMpi(:,:)
5529 integer, parameter :: centreOrigGlobal(3)=(/53, 74, 160/)
5530 integer, external :: newdate
5531
5532 numHeader = obs_numHeader(obsdat)
5533 call rpn_comm_allReduce(numHeader, numHeaderMaxMpi, 1, 'mpi_integer', &
5534 'mpi_max','grid',ierr)
5535
5536 ! Allocations
5537 allocate(obsPosition3d(3,numHeaderMaxMpi))
5538 allocate(obsPosition3dMpi(3,numHeaderMaxMpi*mmpi_nprocs))
5539 allocate(centreOrig(numHeaderMaxMpi))
5540 allocate(centreOrigMpi(numHeaderMaxMpi*mmpi_nprocs))
5541 allocate(obsFov(numHeaderMaxMpi))
5542 allocate(obsFovMpi(numHeaderMaxMpi*mmpi_nprocs))
5543 allocate(obsDateStamp(numHeaderMaxMpi))
5544 allocate(obsDateStampMpi(numHeaderMaxMpi*mmpi_nprocs))
5545 allocate(validMpi(numHeaderMaxMpi*mmpi_nprocs))
5546 lenStnId = len(stnId)
5547 allocate(stnIdInt(lenStnId,numHeaderMaxMpi))
5548 allocate(stnIdIntMpi(lenStnId,numHeaderMaxMpi*mmpi_nprocs))
5549
5550 ! Some initializations
5551 centreOrig(:) = 0
5552 obsPosition3d(:,:) = 0.0
5553
5554 ! Loop over all observation locations
5555 do headerIndex = 1, numHeader
5556 if ( .not. valid(headerIndex) ) cycle
5557
5558 ! Originating centre of data
5559 centreOrig(headerIndex) = obs_headElem_i(obsdat, OBS_ORI, headerIndex)
5560
5561 ! Station ID converted to integer array
5562 stnId = obs_elem_c(obsdat,'STID',headerIndex)
5563 do charIndex = 1, lenStnId
5564 stnIdInt(charIndex,headerIndex) = iachar(stnId(charIndex:charIndex))
5565 end do
5566
5567 ! Date stamp for each observation
5568 obsDate = obs_headElem_i(obsdat, OBS_DAT, headerIndex)
5569 obsTime = obs_headElem_i(obsdat, OBS_ETM, headerIndex)
5570 ierr = newdate(obsDateStamp(headerIndex), obsDate, obsTime*10000+2900, 3)
5571
5572 ! Field of View for each observation
5573 obsFov(headerIndex) = obs_headElem_i(obsdat, OBS_FOV, headerIndex)
5574
5575 ! Lat and Lon for each observation
5576 obsLonInRad = obs_headElem_r(obsdat, OBS_LON, headerIndex)
5577 obsLatInRad = obs_headElem_r(obsdat, OBS_LAT, headerIndex)
5578
5579 ! 3D location array for kdtree
5580 obsPosition3d(1,headerIndex) = ec_ra * sin(obsLonInRad) * cos(obsLatInRad)
5581 obsPosition3d(2,headerIndex) = ec_ra * cos(obsLonInRad) * cos(obsLatInRad)
5582 obsPosition3d(3,headerIndex) = ec_ra * sin(obsLatInRad)
5583 end do
5584
5585 nsize = 3 * numHeaderMaxMpi
5586 call rpn_comm_allgather(obsPosition3d, nsize, 'mpi_real8', &
5587 obsPosition3dMpi, nsize, 'mpi_real8', 'grid', ierr)
5588 nsize = numHeaderMaxMpi
5589 call rpn_comm_allgather(valid, nsize, 'mpi_logical', &
5590 validMpi, nsize, 'mpi_logical', 'grid', ierr)
5591 call rpn_comm_allgather(centreOrig, nsize, 'mpi_integer', &
5592 centreOrigMpi, nsize, 'mpi_integer', 'grid', ierr)
5593 call rpn_comm_allgather(obsFov, nsize, 'mpi_integer', &
5594 obsFovMpi, nsize, 'mpi_integer', 'grid', ierr)
5595 call rpn_comm_allgather(obsDateStamp, nsize, 'mpi_integer', &
5596 obsDateStampMpi, nsize, 'mpi_integer', 'grid', ierr)
5597 nsize = lenStnId * numHeaderMaxMpi
5598 call rpn_comm_allgather(stnIdInt, nsize, 'mpi_integer', &
5599 stnIdIntMpi, nsize, 'mpi_integer', 'grid', ierr)
5600 nullify(tree)
5601
5602 tree => kdtree2_create(obsPosition3dMpi, sort=.true., rearrange=.true.)
5603 HEADER1: do headerIndex1 = 1, mmpi_nprocs*numHeaderMaxMpi
5604
5605 if ( .not. validMpi(headerIndex1) ) cycle HEADER1
5606
5607 ! Find all obs within 10km
5608 refPosition(:) = obsPosition3dMpi(:,headerIndex1)
5609 call kdtree2_r_nearest(tp=tree, qv=refPosition, r2=maxRadius, nfound=numFoundSearch, &
5610 nalloc=maxNumSearch, results=searchResults)
5611 if (numFoundSearch >= maxNumSearch) then
5612 call utl_abort('thn_tovsFilt: the parameter maxNumSearch must be increased')
5613 end if
5614 if (numFoundSearch == 0) then
5615 call utl_abort('thn_tovsFilt: no match found. This should not happen!!!')
5616 end if
5617
5618 ! Loop over all of these nearby locations
5619 HEADER2: do resultIndex = 1, numFoundSearch
5620 headerIndex2 = searchResults(resultIndex)%idx
5621
5622 if ( .not. validMpi(headerIndex2) ) cycle HEADER2
5623
5624 ! Certaines stations locales nous envoient
5625 ! le mauvais numero d'orbite. On ne peut donc
5626 ! pas s'y fier.
5627 ! Il faut comparer le temps de la reception des
5628 ! donnees
5629 if ( centreOrigMpi(headerIndex1) /= centreOrigMpi(headerIndex2) ) then
5630 if ( obsFovMpi(headerIndex1) == obsFovMpi(headerIndex2) ) then
5631 if ( all(stnIdIntMpi(:,headerIndex1) == stnIdIntMpi(:,headerIndex2)) ) then
5632
5633 ! Difference (in hours) between obs time
5634 call difdatr(obsDateStampMpi(headerIndex1),obsDateStampMpi(headerIndex2),dlhours)
5635
5636 ! Si la difference est moins de 6 minutes,
5637 ! on peut avoir affaire a un rars
5638
5639 if ( abs(dlhours) <= 0.1 ) then
5640
5641 ! si l'element_i est global, on doit le garder et rejeter l'element_j
5642 global1 = any(centreOrigGlobal(:) == centreOrigMpi(headerIndex1))
5643 if (global1) then
5644 validMpi(headerIndex2) = .false.
5645 else
5646 ! toutefois, ca ne signifie pas que l'element_j est un rars
5647 ! VERIFIER SI LA STATION 2 EST RARS
5648 global2 = any(centreOrigGlobal(:) == centreOrigMpi(headerIndex2))
5649
5650 ! Si l'element_j est global, rejeter l'element_i
5651 ! Si les 2 elements sont rars, garder le 1er
5652 if (global2) then
5653 validMpi(headerIndex1) = .false.
5654 cycle HEADER1
5655 else
5656 validMpi(headerIndex2) = .false.
5657 end if
5658 end if
5659
5660 end if ! abs(dlhours) <= 0.1
5661
5662 end if ! STID1 == STID2
5663 end if ! FOV1 == FOV2
5664 end if ! centreOrig1 /= centreOrig2
5665
5666 end do HEADER2
5667 end do HEADER1
5668 call kdtree2_destroy(tree)
5669
5670 ! update local copy of 'valid' array
5671 headerIndexBeg = 1 + mmpi_myid * numHeaderMaxMpi
5672 headerIndexEnd = headerIndexBeg + numHeaderMaxMpi - 1
5673 valid(:) = validMpi(headerIndexBeg:headerIndexEnd)
5674
5675 deallocate(obsPosition3d)
5676 deallocate(obsPosition3dMpi)
5677 deallocate(centreOrig)
5678 deallocate(centreOrigMpi)
5679 deallocate(obsFov)
5680 deallocate(obsFovMpi)
5681 deallocate(obsDateStamp)
5682 deallocate(obsDateStampMpi)
5683 deallocate(validMpi)
5684 deallocate(stnIdInt)
5685 deallocate(stnIdIntMpi)
5686
5687 end subroutine thn_removeRarsDuplicates
5688
5689 !--------------------------------------------------------------------------
5690 ! thn_scatByLatLonBoxes
5691 !--------------------------------------------------------------------------
5692 subroutine thn_scatByLatLonBoxes(obsdat, deltax, deltmax)
5693 !
5694 !:Purpose: Only keep the observation closest to the center of each
5695 ! lat-lon (and time) box for SCAT observations.
5696 ! Set bit 11 of OBS_FLG on observations that are to be rejected.
5697 !
5698 implicit none
5699
5700 ! Arguments:
5701 type(struct_obs), intent(inout) :: obsdat
5702 integer, intent(in) :: deltax
5703 integer, intent(in) :: deltmax
5704
5705 ! Locals:
5706 integer, parameter :: latLength = 10000 ! Earth dimension parameters
5707 integer, parameter :: lonLength = 40000 ! Earth dimension parameters
5708 integer, parameter :: numStnIdMax = 100
5709 integer :: bodyIndex, charIndex, nsize, lenStnId
5710 integer :: timeRejectCount, flagRejectCount, timeRejectCountMpi, flagRejectCountMpi
5711 integer :: uObsFlag, vObsFlag, obsVarno, stnIdIndex, numStnId, stnIdIndexFound
5712 integer :: numLat, numLon, latIndex, lonIndex, stepIndex, obsFlag
5713 integer :: ierr, headerIndex, numHeader, numHeaderMaxMpi
5714 integer :: headerIndexBeg, headerIndexEnd
5715 integer :: countObs, countObsInMpi, countObsOutMpi
5716 integer :: obsLonBurpFile, obsLatBurpFile, obsDate, obsTime
5717 integer :: numObsStnIdOut(numStnIdMax)
5718 integer :: numObsStnIdInMpi(numStnIdMax), numObsStnIdOutMpi(numStnIdMax)
5719 real(4) :: latInRadians, distance, obsLat, obsLon
5720 real(8) :: obsLatInDegrees, obsLonInDegrees, obsStepIndex_r8
5721 logical :: change
5722 real(4), allocatable :: gridLats(:), gridLatsMid(:), gridLonsMid(:,:)
5723 integer, allocatable :: headerIndexGrid(:,:,:), delMinutesGrid(:,:,:)
5724 real(4), allocatable :: distanceGrid(:,:,:)
5725 integer, allocatable :: obsLatIndex(:), obsLonIndex(:), obsStepIndex(:), numGridLons(:)
5726 real(4), allocatable :: obsDistance(:)
5727 integer, allocatable :: obsLatIndexMpi(:), obsLonIndexMpi(:), obsStepIndexMpi(:)
5728 integer, allocatable :: obsDelMinutes(:), obsDelMinutesMpi(:)
5729 integer, allocatable :: stnIdInt(:,:), stnIdIntMpi(:,:)
5730 real(4), allocatable :: obsDistanceMpi(:)
5731 logical, allocatable :: valid(:), validMpi(:)
5732 character(len=5) :: stnIdTrim
5733 character(len=12) :: stnId, stnidList(numStnIdMax)
5734 character(len=12), allocatable :: stnIdGrid(:,:,:)
5735
5736 write(*,*)
5737 write(*,*) 'thn_scatByLatLonBoxes: Starting'
5738 write(*,*)
5739
5740 numHeader = obs_numHeader(obsdat)
5741 call rpn_comm_allReduce(numHeader, numHeaderMaxMpi, 1, 'mpi_integer', &
5742 'mpi_max','grid',ierr)
5743 write(*,*) 'thn_scatByLatLonBoxes: numHeader, numHeaderMaxMpi = ', &
5744 numHeader, numHeaderMaxMpi
5745
5746 ! Check if we have any observations to process
5747 allocate(valid(numHeaderMaxMpi))
5748 valid(:) = .false.
5749 call obs_set_current_header_list(obsdat,'SC')
5750 HEADER0: do
5751 headerIndex = obs_getHeaderIndex(obsdat)
5752 if (headerIndex < 0) exit HEADER0
5753 valid(headerIndex) = .true.
5754 end do HEADER0
5755 countObs = count(valid(:))
5756 call rpn_comm_allReduce(countObs, countObsInMpi, 1, 'mpi_integer', &
5757 'mpi_sum','grid',ierr)
5758 if (countObsInMpi == 0) then
5759 write(*,*) 'thn_scatByLatLonBoxes: no observations for this instrument'
5760 deallocate(valid)
5761 return
5762 end if
5763
5764 numLat = nint(2.*real(latLength)/real(deltax))
5765 numLon = nint(real(lonLength)/real(deltax))
5766
5767 write(*,*)
5768 write(*,*) 'Number of horizontal boxes : ', numLon
5769 write(*,*) 'Number of vertical boxes : ', numLat
5770 write(*,*) 'Number of temporal bins : ', tim_nstepobs
5771 write(*,*)
5772
5773 write(*,*) 'thn_scatByLatLonBoxes: countObs initial = ', &
5774 countObs, countObsInMpi
5775
5776 ! Allocate arrays
5777 allocate(gridLats(numLat))
5778 allocate(gridLatsMid(numLat))
5779 allocate(gridLonsMid(numLat,numLon))
5780 allocate(numGridLons(numLat))
5781 allocate(stnIdGrid(numLat,numLon,tim_nstepobs))
5782 allocate(distanceGrid(numLat,numLon,tim_nstepobs))
5783 allocate(headerIndexGrid(numLat,numLon,tim_nstepobs))
5784 allocate(delMinutesGrid(numLat,numLon,tim_nstepobs))
5785
5786 allocate(obsLatIndex(numHeaderMaxMpi))
5787 allocate(obsLonIndex(numHeaderMaxMpi))
5788 allocate(obsStepIndex(numHeaderMaxMpi))
5789 allocate(obsDistance(numHeaderMaxMpi))
5790 allocate(obsDelMinutes(numHeaderMaxMpi))
5791 lenStnId = len(stnId)
5792 allocate(stnIdInt(lenStnId,numHeaderMaxMpi))
5793
5794 ! Allocation for MPI gather
5795 allocate(validMpi(numHeaderMaxMpi*mmpi_nprocs))
5796 allocate(obsLatIndexMpi(numHeaderMaxMpi*mmpi_nprocs))
5797 allocate(obsLonIndexMpi(numHeaderMaxMpi*mmpi_nprocs))
5798 allocate(obsStepIndexMpi(numHeaderMaxMpi*mmpi_nprocs))
5799 allocate(obsDistanceMpi(numHeaderMaxMpi*mmpi_nprocs))
5800 allocate(obsDelMinutesMpi(numHeaderMaxMpi*mmpi_nprocs))
5801 allocate(stnIdIntMpi(lenStnId,numHeaderMaxMpi*mmpi_nprocs))
5802
5803 gridLats(:) = 0.
5804 gridLatsMid(:) = 0.
5805 gridLonsMid(:,:) = 0.
5806 numGridLons(:) = 0
5807 stnIdGrid(:,:,:) = ''
5808 distanceGrid(:,:,:) = -1.0
5809 headerIndexGrid(:,:,:) = -1
5810
5811 timeRejectCount = 0
5812 flagRejectCount = 0
5813
5814 ! set spatial boxes properties
5815 do latIndex = 1, numLat
5816 gridLats(latIndex) = (latIndex*180./numLat) - 90.
5817 gridLatsMid(latIndex) = gridLats(latIndex) - (90./numLat)
5818 if (gridLats(latIndex) <= 0.0) then
5819 latInRadians = gridLats(latIndex) * MPC_PI_R8 / 180.
5820 else
5821 latInRadians = gridLats(latIndex-1) * MPC_PI_R8 / 180.
5822 end if
5823 distance = lonLength * cos(latInRadians)
5824 numGridLons(latIndex) = nint(distance/deltax)
5825 do lonIndex = 1, numGridLons(latIndex)
5826 gridLonsMid(latIndex,lonIndex) = &
5827 (lonIndex * 36000 / numGridLons(latIndex)) - &
5828 (18000 / numGridLons(latIndex))
5829 gridLonsMid(latIndex,lonIndex) = 0.01 * gridLonsMid(latIndex,lonIndex)
5830 end do
5831 end do
5832
5833 ! Station ID converted to integer array
5834 stnIdInt(:,:) = 0
5835 HEADER1: do headerIndex = 1, numHeader
5836 if (.not. valid(headerIndex)) cycle HEADER1
5837
5838 stnId = obs_elem_c(obsdat,'STID',headerIndex)
5839 do charIndex = 1, lenStnId
5840 stnIdInt(charIndex,headerIndex) = iachar(stnId(charIndex:charIndex))
5841 end do
5842 end do HEADER1
5843
5844 nsize = numHeaderMaxMpi
5845 call rpn_comm_allgather(valid, nsize, 'mpi_logical', &
5846 validMpi, nsize, 'mpi_logical', 'grid', ierr)
5847 nsize = lenStnId * numHeaderMaxMpi
5848 call rpn_comm_allgather(stnIdInt, nsize, 'mpi_integer', &
5849 stnIdIntMpi, nsize, 'mpi_integer', 'grid', ierr)
5850
5851 ! build a global list of stnId over all mpi tasks
5852 numStnId = 0
5853 numObsStnIdInMpi(:) = 0
5854 HEADER2: do headerIndex = 1, numHeaderMaxMpi * mmpi_nprocs
5855 if (all(stnIdIntMpi(:,headerIndex) == 0)) cycle HEADER2
5856 if (.not.validMpi(headerIndex)) cycle HEADER2
5857
5858 ! Station ID converted back to character string
5859 do charIndex = 1, lenStnId
5860 stnId(charIndex:charIndex) = achar(stnIdIntMpi(charIndex,headerIndex))
5861 end do
5862
5863 if (numStnId < numStnIdMax ) then
5864 stnIdIndexFound = -1
5865 do stnIdIndex = 1, numStnId
5866 if ( stnidList(stnIdIndex) == stnid ) stnIdIndexFound = stnIdIndex
5867 end do
5868 if ( stnIdIndexFound == -1 ) then
5869 numStnId = numStnId + 1
5870 stnidList(numStnId) = stnid
5871 stnIdIndexFound = numStnId
5872 end if
5873 numObsStnIdInMpi(stnIdIndexFound) = numObsStnIdInMpi(stnIdIndexFound) + 1
5874 else
5875 call utl_abort('thn_scatByLatLonBoxes: numStnId too large')
5876 end if
5877 end do HEADER2
5878
5879 ! Initial pass through all observations
5880 HEADER3: do headerIndex = 1, numHeader
5881 if (.not. valid(headerIndex)) cycle HEADER3
5882
5883 ! Station ID converted to integer array
5884 stnId = obs_elem_c(obsdat,'STID',headerIndex)
5885 do charIndex = 1, lenStnId
5886 stnIdInt(charIndex,headerIndex) = iachar(stnId(charIndex:charIndex))
5887 end do
5888
5889 ! Obs lat-lon
5890 obsLonInDegrees = MPC_DEGREES_PER_RADIAN_R8 * obs_headElem_r(obsdat, OBS_LON, headerIndex)
5891 obsLatInDegrees = MPC_DEGREES_PER_RADIAN_R8 * obs_headElem_r(obsdat, OBS_LAT, headerIndex)
5892 obsLonBurpFile = nint(100.0*(obsLonInDegrees - 180.0))
5893 if(obsLonBurpFile < 0) obsLonBurpFile = obsLonBurpFile + 36000
5894 obsLatBurpFile = 9000+nint(100.0*obsLatInDegrees)
5895
5896 ! compute box indices
5897 obsLat = (obsLatBurpFile - 9000.)/100.
5898 do latIndex = 1, numLat
5899 if ( obsLat <= (gridLats(latIndex) + 0.000001) ) then
5900 obsLatIndex(headerIndex) = latIndex
5901 exit
5902 end if
5903 end do
5904
5905 if (obsLonBurpFile >= 18000) then
5906 obsLonBurpFile = obsLonBurpFile - 18000
5907 else
5908 obsLonBurpFile = obsLonBurpFile + 18000
5909 end if
5910 obsLonIndex(headerIndex) = &
5911 int( obsLonBurpFile / &
5912 (36000. / real(numGridLons(obsLatIndex(headerIndex)))) ) + 1
5913 if ( obsLonIndex(headerIndex) > numGridLons(obsLatIndex(headerIndex)) ) then
5914 obsLonIndex(headerIndex) = numGridLons(obsLatIndex(headerIndex))
5915 end if
5916
5917 ! compute spatial distances
5918 obsLat = (obsLatBurpFile - 9000.)/100.
5919 obsLon = obsLonBurpFile/100.
5920 obsDistance(headerIndex) = 100.0 * &
5921 ( ((gridLatsMid(obsLatIndex(headerIndex))-obsLat))**2 + &
5922 ((gridLonsMid(obsLatIndex(headerIndex),obsLonIndex(headerIndex))-obsLon))**2)**0.5
5923
5924 ! calcul de la bin temporelle dans laquelle se trouve l'observation
5925 obsDate = obs_headElem_i(obsdat, OBS_DAT, headerIndex)
5926 obsTime = obs_headElem_i(obsdat, OBS_ETM, headerIndex)
5927 call tim_getStepObsIndex(obsStepIndex_r8, tim_getDatestamp(), &
5928 obsDate, obsTime, tim_nstepobs)
5929 obsStepIndex(headerIndex) = nint(obsStepIndex_r8)
5930 obsDelMinutes(headerIndex) = nint( 60.0 * tim_dstepobs * &
5931 abs(real(obsStepIndex(headerIndex)) - obsStepIndex_r8) )
5932
5933 ! check time window
5934 if ( obsDelMinutes(headerIndex) > deltmax ) then
5935 timeRejectCount = timeRejectCount + 1
5936 valid(headerIndex) = .false.
5937 end if
5938
5939 ! find observation flags (assumes 1 level only per headerIndex)
5940 uObsFlag = -1
5941 vObsFlag = -1
5942 call obs_set_current_body_list(obsdat, headerIndex)
5943 BODY3: do
5944 bodyIndex = obs_getBodyIndex(obsdat)
5945 if (bodyIndex < 0) exit BODY3
5946 obsVarno = obs_bodyElem_i(obsdat, OBS_VNM, bodyIndex)
5947 if (obsVarno == bufr_neus) then
5948 uObsFlag = obs_bodyElem_i(obsdat, OBS_FLG, bodyIndex)
5949 else if (obsVarno == bufr_nevs) then
5950 vObsFlag = obs_bodyElem_i(obsdat, OBS_FLG, bodyIndex)
5951 end if
5952 end do BODY3
5953
5954 ! modify valid based on flags
5955 if (uObsFlag /= -1 .and. vObsFlag /= -1) then
5956 if ( btest(uObsFlag,16) .or. btest(vObsFlag,16) .or. &
5957 btest(uObsFlag,18) .or. btest(vObsFlag,18) ) then
5958 flagRejectCount = flagRejectCount + 1
5959 valid(headerIndex) = .false.
5960 end if
5961 else
5962 valid(headerIndex) = .false.
5963 end if
5964
5965 end do HEADER3
5966
5967 countObs = count(valid(:))
5968 call rpn_comm_allReduce(countObs, countObsOutMpi, 1, 'mpi_integer', &
5969 'mpi_sum','grid',ierr)
5970 write(*,*) 'thn_scatByLatLonBoxes: countObs after QC and time tests = ', &
5971 countObs, countObsOutMpi
5972
5973 ! Gather data from all MPI tasks
5974 nsize = numHeaderMaxMpi
5975 call rpn_comm_allgather(valid, nsize, 'mpi_logical', &
5976 validMpi, nsize, 'mpi_logical', 'grid', ierr)
5977 call rpn_comm_allgather(obsLatIndex, nsize, 'mpi_integer', &
5978 obsLatIndexMpi, nsize, 'mpi_integer', 'grid', ierr)
5979 call rpn_comm_allgather(obsLonIndex, nsize, 'mpi_integer', &
5980 obsLonIndexMpi, nsize, 'mpi_integer', 'grid', ierr)
5981 call rpn_comm_allgather(obsStepIndex, nsize, 'mpi_integer', &
5982 obsStepIndexMpi, nsize, 'mpi_integer', 'grid', ierr)
5983 call rpn_comm_allgather(obsDelMinutes, nsize, 'mpi_integer', &
5984 obsDelMinutesMpi, nsize, 'mpi_integer', 'grid', ierr)
5985 call rpn_comm_allgather(obsDistance, nsize, 'mpi_real4', &
5986 obsDistanceMpi, nsize, 'mpi_real4', 'grid', ierr)
5987
5988 ! Apply thinning algorithm
5989 HEADER4: do headerIndex = 1, numHeaderMaxMpi*mmpi_nprocs
5990 if (.not. validMpi(headerIndex)) cycle HEADER4
5991
5992 change = .true.
5993
5994 latIndex = obsLatIndexMpi(headerIndex)
5995 lonIndex = obsLonIndexMpi(headerIndex)
5996 stepIndex = obsStepIndexMpi(headerIndex)
5997
5998 ! Station ID converted back to character string
5999 do charIndex = 1, lenStnId
6000 stnId(charIndex:charIndex) = achar(stnIdIntMpi(charIndex,headerIndex))
6001 end do
6002 stnIdTrim = stnId(2:6)
6003
6004 if ( stnIdGrid(latIndex,lonIndex,stepIndex) /= '' ) then
6005
6006 ! This is an ASCAT observation
6007 if (stnIdTrim == 'METOP') then
6008
6009 ! si l'obs retenue precedemment etait un ASCAT, on poursuit l'investigation
6010 if ( stnIdTrim == stnIdGrid(latIndex,lonIndex,stepIndex) ) then
6011
6012 ! si la difference temporelle est plus grande que celle deja retenue
6013 if ( obsDelMinutesMpi(headerIndex) > &
6014 delMinutesGrid(latIndex,lonIndex,stepIndex) ) then
6015 change = .false.
6016 else
6017 ! si la distance au centre de la boite est plus grande que celle retenue
6018 if ( (obsDelMinutesMpi(headerIndex) == &
6019 delMinutesGrid(latIndex,lonIndex,stepIndex)) .and. &
6020 (obsDistanceMpi(headerIndex) >= &
6021 distanceGrid(latIndex,lonIndex,stepIndex)) ) then
6022 change = .false.
6023 end if
6024 end if
6025
6026 else
6027
6028 ! si l'obs retenue precedemment etait autre que METOP
6029 change = .true.
6030
6031 end if
6032
6033 else ! satellites autre que METOP
6034
6035 ! si l'obs retenue precedemment etait autre qu'un METOP, on poursuit l'investigation
6036 if ( stnIdTrim == stnIdGrid(latIndex,lonIndex,stepIndex) ) then
6037
6038 ! si la difference temporelle est plus grande que celle deja retenue, skip it
6039 if ( obsDelMinutesMpi(headerIndex) > &
6040 delMinutesGrid(latIndex,lonIndex,stepIndex) ) then
6041 change = .false.
6042 else
6043 ! si la distance au centre de la boite est plus grande que celle retenue, skip it
6044 if ( (obsDelMinutesMpi(headerIndex) == &
6045 delMinutesGrid(latIndex,lonIndex,stepIndex)) .and. &
6046 (obsDistanceMpi(headerIndex) >= &
6047 distanceGrid(latIndex,lonIndex,stepIndex)) ) then
6048 change = .false.
6049 end if
6050 end if
6051
6052 else
6053
6054 ! si l'obs retenue precedemment etait un METOP
6055 change = .false.
6056
6057 end if
6058
6059 end if ! METOP
6060
6061 end if
6062
6063 ! update list of data to save
6064 if ( .not. change ) then
6065 ! keep previously accepted obs, so reject current obs
6066 validMpi(headerIndex) = .false.
6067 else
6068 ! reject previously accepted obs
6069 if ( headerIndexGrid(latIndex,lonIndex,stepIndex) /= -1 ) then
6070 validMpi(headerIndexGrid(latIndex,lonIndex,stepIndex)) = .false.
6071 end if
6072
6073 ! keep current obs
6074 validMpi(headerIndex) = .true.
6075 headerIndexGrid(latIndex,lonIndex,stepIndex) = headerIndex
6076 stnIdGrid(latIndex,lonIndex,stepIndex) = stnIdTrim
6077 delMinutesGrid(latIndex,lonIndex,stepIndex) = obsDelMinutesMpi(headerIndex)
6078 distanceGrid(latIndex,lonIndex,stepIndex) = obsDistanceMpi(headerIndex)
6079 end if
6080
6081 end do HEADER4
6082
6083 ! update local copy of 'valid' array
6084 headerIndexBeg = 1 + mmpi_myid * numHeaderMaxMpi
6085 headerIndexEnd = headerIndexBeg + numHeaderMaxMpi - 1
6086 valid(:) = validMpi(headerIndexBeg:headerIndexEnd)
6087
6088 countObs = count(valid(:))
6089 call rpn_comm_allReduce(countObs, countObsOutMpi, 1, 'mpi_integer', &
6090 'mpi_sum','grid',ierr)
6091 write(*,*) 'thn_scatByLatLonBoxes: countObs after choosing 1 per box = ', &
6092 countObs, countObsOutMpi
6093
6094 ! modify the observation flags in obsSpaceData and count obs for each stnId
6095 numObsStnIdOut(:) = 0
6096 call obs_set_current_header_list(obsdat,'SC')
6097 HEADER5: do
6098 headerIndex = obs_getHeaderIndex(obsdat)
6099 if (headerIndex < 0) exit HEADER5
6100
6101 if (.not. valid(headerIndex)) then
6102 call obs_set_current_body_list(obsdat, headerIndex)
6103 BODY5: do
6104 bodyIndex = obs_getBodyIndex(obsdat)
6105 if (bodyIndex < 0) exit BODY5
6106
6107 obsFlag = obs_bodyElem_i(obsdat, OBS_FLG, bodyIndex)
6108 call obs_bodySet_i(obsdat, OBS_FLG, bodyIndex, ibset(obsFlag,11))
6109
6110 end do BODY5
6111 cycle HEADER5
6112 end if
6113
6114 ! count number of obs kept for each stnId
6115 stnId = obs_elem_c(obsdat,'STID',headerIndex)
6116 stnIdIndexFound = -1
6117 do stnIdIndex = 1, numStnId
6118 if (stnidList(stnIdIndex) == stnId) stnIdIndexFound = stnIdIndex
6119 end do
6120 if (stnIdIndexFound == -1) call utl_abort('stnid not found in list')
6121 numObsStnIdOut(stnIdIndexFound) = numObsStnIdOut(stnIdIndexFound) + 1
6122 end do HEADER5
6123
6124 call rpn_comm_allReduce(numObsStnIdOut, numObsStnIdOutMpi, &
6125 numStnIdMax, 'mpi_integer', 'mpi_sum', 'grid', ierr)
6126 call rpn_comm_allReduce(timeRejectCount, timeRejectCountMpi, 1, &
6127 'mpi_integer', 'mpi_sum', 'grid', ierr)
6128 call rpn_comm_allReduce(flagRejectCount, flagRejectCountMpi, 1, &
6129 'mpi_integer', 'mpi_sum', 'grid', ierr)
6130
6131 write(*,*)
6132 write(*,'(a,i6)') 'scatByLatLonBoxes: Number of obs in input = ', countObsInMpi
6133 write(*,'(a,i6)') 'scatByLatLonBoxes: Number of obs in output = ', countObsOutMpi
6134 write(*,'(a,i6)') 'scatByLatLonBoxes: Number of obs not selected due to time = ', &
6135 timeRejectCountMpi
6136 write(*,'(a,i6)') 'scatByLatLonBoxes: Number of obs not selected due to topo = ', &
6137 flagRejectCountMpi
6138 write(*,*)
6139
6140 write(*,'(a40,i10)' ) 'Number of satellites found = ', numStnId
6141 write(*,*)
6142
6143 write(*,'(a40,a15)' ) 'Satellite', 'nb SCAT in'
6144 write(*,*)
6145 do stnIdIndex = 1, numStnId
6146 write(*,'(a40,i15)') stnidList(stnIdIndex), numObsStnIdInMpi(stnIdIndex)
6147 end do
6148 write(*,*)
6149 write(*,'(a40,i15)' ) 'Total number of obs in : ', sum(numObsStnIdInMpi(:))
6150
6151 write(*,*)
6152 write(*,'(a40,a15)' ) 'Satellite', 'nb SCAT out'
6153 write(*,*)
6154 do stnIdIndex = 1, numStnId
6155 write(*,'(a40,i15)') stnidList(stnIdIndex), numObsStnIdOutMpi(stnIdIndex)
6156 end do
6157 write(*,*)
6158 write(*,'(a40,i15)' ) 'Total number of obs out : ', sum(numObsStnIdOutMpi(:))
6159
6160 ! Deallocations:
6161 deallocate(valid)
6162 deallocate(gridLats)
6163 deallocate(gridLatsMid)
6164 deallocate(gridLonsMid)
6165 deallocate(numGridLons)
6166 deallocate(stnIdGrid)
6167 deallocate(distanceGrid)
6168 deallocate(headerIndexGrid)
6169 deallocate(delMinutesGrid)
6170
6171 deallocate(obsLatIndex)
6172 deallocate(obsLonIndex)
6173 deallocate(obsStepIndex)
6174 deallocate(obsDistance)
6175 deallocate(obsDelMinutes)
6176 deallocate(stnIdInt)
6177
6178 deallocate(validMpi)
6179 deallocate(obsLatIndexMpi)
6180 deallocate(obsLonIndexMpi)
6181 deallocate(obsStepIndexMpi)
6182 deallocate(obsDistanceMpi)
6183 deallocate(obsDelMinutesMpi)
6184 deallocate(stnIdIntMpi)
6185
6186 write(*,*)
6187 write(*,*) 'thn_scatByLatLonBoxes: Finished'
6188 write(*,*)
6189
6190 end subroutine thn_scatByLatLonBoxes
6191
6192 !--------------------------------------------------------------------------
6193 ! thn_csrByLatLonBoxes
6194 !--------------------------------------------------------------------------
6195 subroutine thn_csrByLatLonBoxes(obsdat, deltax, deltrad)
6196 !
6197 !:Purpose: Only keep the observation closest to the center of each
6198 ! lat-lon (and time) box for CSR observations.
6199 ! Set bit 11 of OBS_FLG on observations that are to be rejected.
6200 !
6201 implicit none
6202
6203 ! Arguments:
6204 type(struct_obs), intent(inout) :: obsdat
6205 integer, intent(in) :: deltax
6206 integer, intent(in) :: deltrad
6207
6208 ! Locals:
6209 integer, parameter :: latLength = 10000 ! Earth dimension parameters
6210 integer, parameter :: lonLength = 40000 ! Earth dimension parameters
6211 integer, parameter :: maxNumChan = 15 ! nb max de canaux
6212 integer :: bodyIndex, channelIndex, charIndex, nsize, lenStnId
6213 integer :: numLat, numLon, latIndex, lonIndex, stepIndex, obsFlag
6214 integer :: ierr, headerIndex, numHeader, numHeaderMaxMpi, channelList(maxNumChan)
6215 integer :: headerIndexBeg, headerIndexEnd, countObs, countObsMpi
6216 integer :: obsLonBurpFile, obsLatBurpFile, obsDate, obsTime
6217 real(4) :: latInRadians, distance, obsLat, obsLon, gridLat, gridLon
6218 real(8) :: obsLatInDegrees, obsLonInDegrees, obsStepIndex_r8
6219 logical :: change
6220 real(4), allocatable :: gridLats(:)
6221 integer, allocatable :: numChanAssimGrid(:,:,:), headerIndexGrid(:,:,:)
6222 real(4), allocatable :: angleGrid(:,:,:), distanceGrid(:,:,:), cloudGrid(:,:,:,:)
6223 integer, allocatable :: obsLatIndex(:), obsLonIndex(:), obsStepIndex(:), numGridLons(:)
6224 real(4), allocatable :: obsCloud(:,:), obsAngle(:), obsDistance(:)
6225 integer, allocatable :: obsLatIndexMpi(:), obsLonIndexMpi(:), obsStepIndexMpi(:)
6226 integer, allocatable :: stnIdInt(:,:), stnIdIntMpi(:,:), numChannel(:), numChannelMpi(:)
6227 real(4), allocatable :: obsCloudMpi(:,:), obsAngleMpi(:), obsDistanceMpi(:)
6228 logical, allocatable :: valid(:), validMpi(:), channelAssim(:,:), channelAssimMpi(:,:)
6229 character(len=12) :: stnId
6230 character(len=12), allocatable :: stnIdGrid(:,:,:)
6231
6232 write(*,*)
6233 write(*,*) 'thn_csrByLatLonBoxes: Starting'
6234 write(*,*)
6235
6236 numHeader = obs_numHeader(obsdat)
6237 call rpn_comm_allReduce(numHeader, numHeaderMaxMpi, 1, 'mpi_integer', &
6238 'mpi_max','grid',ierr)
6239 write(*,*) 'thn_csrByLatLonBoxes: numHeader, numHeaderMaxMpi = ', &
6240 numHeader, numHeaderMaxMpi
6241
6242 ! Check if we have any observations to process
6243 allocate(valid(numHeaderMaxMpi))
6244 valid(:) = .false.
6245 do headerIndex = 1, numHeader
6246 if ( obs_headElem_i(obsdat, OBS_ITY, headerIndex) == &
6247 codtyp_get_codtyp('radianceclear') ) then
6248 valid(headerIndex) = .true.
6249 end if
6250 end do
6251 countObs = count(valid(:))
6252 call rpn_comm_allReduce(countObs, countObsMpi, 1, 'mpi_integer', &
6253 'mpi_sum','grid',ierr)
6254 if (countObsMpi == 0) then
6255 write(*,*) 'thn_csrByLatLonBoxes: no observations for this instrument'
6256 deallocate(valid)
6257 return
6258 end if
6259
6260 numLat = nint(2.*real(latLength)/real(deltax))
6261 numLon = nint(real(lonLength)/real(deltax))
6262
6263 write(*,*)
6264 write(*,*) 'Number of horizontal boxes : ', numLon
6265 write(*,*) 'Number of vertical boxes : ', numLat
6266 write(*,*) 'Number of temporal bins : ', tim_nstepobs
6267 write(*,*)
6268
6269 write(*,*) 'thn_csrByLatLonBoxes: countObs initial = ', &
6270 countObs, countObsMpi
6271
6272 ! Allocate arrays
6273 allocate(gridLats(numLat))
6274 allocate(numGridLons(numLat))
6275 allocate(stnIdGrid(numLat,numLon,tim_nstepobs))
6276 allocate(numChanAssimGrid(numLat,numLon,tim_nstepobs))
6277 allocate(angleGrid(numLat,numLon,tim_nstepobs))
6278 allocate(distanceGrid(numLat,numLon,tim_nstepobs))
6279 allocate(headerIndexGrid(numLat,numLon,tim_nstepobs))
6280 allocate(cloudGrid(maxNumChan,numLat,numLon,tim_nstepobs))
6281 allocate(obsLatIndex(numHeaderMaxMpi))
6282 allocate(obsLonIndex(numHeaderMaxMpi))
6283 allocate(obsStepIndex(numHeaderMaxMpi))
6284 allocate(numChannel(numHeaderMaxMpi))
6285 allocate(channelAssim(maxNumChan,numHeaderMaxMpi))
6286 allocate(obsAngle(numHeaderMaxMpi))
6287 allocate(obsCloud(maxNumChan,numHeaderMaxMpi))
6288 allocate(obsDistance(numHeaderMaxMpi))
6289
6290 gridLats(:) = 0.
6291 numGridLons(:) = 0
6292 stnIdGrid(:,:,:) = ''
6293 numChanAssimGrid(:,:,:) = -1
6294 angleGrid(:,:,:) = -1.0
6295 distanceGrid(:,:,:) = -1.0
6296 headerIndexGrid(:,:,:) = -1
6297 cloudGrid(:,:,:,:) = -1.0
6298 channelAssim(:,:) = .false.
6299 numChannel(:) = 0
6300 obsAngle(:) = 0.0
6301 obsCloud(:,:) = 0.0
6302 obsDistance(:) = 0.0
6303
6304 ! set spatial boxes properties
6305
6306 do latIndex = 1, numLat
6307 gridLats(latIndex) = (latIndex*180./numLat) - 90.
6308 if (gridLats(latIndex) <= 0.0) then
6309 latInRadians = gridLats(latIndex) * MPC_PI_R8 / 180.
6310 else
6311 latInRadians = gridLats(latIndex-1) * MPC_PI_R8 / 180.
6312 end if
6313 distance = lonLength * cos(latInRadians)
6314 numGridLons(latIndex) = nint(distance/deltax)
6315 end do
6316
6317 ! Initial pass through all observations
6318 HEADER1: do headerIndex = 1, numHeader
6319 if (.not. valid(headerIndex)) cycle HEADER1
6320
6321 obsLonInDegrees = MPC_DEGREES_PER_RADIAN_R8 * obs_headElem_r(obsdat, OBS_LON, headerIndex)
6322 obsLatInDegrees = MPC_DEGREES_PER_RADIAN_R8 * obs_headElem_r(obsdat, OBS_LAT, headerIndex)
6323 obsLonBurpFile = nint(100.0*(obsLonInDegrees - 180.0))
6324 if(obsLonBurpFile < 0) obsLonBurpFile = obsLonBurpFile + 36000
6325 obsLatBurpFile = 9000+nint(100.0*obsLatInDegrees)
6326
6327 ! compute box indices
6328 do latIndex = 1, numLat
6329 if ( (obsLatBurpFile - 9000.)/100. <= (gridLats(latIndex) + 0.000001) ) then
6330 obsLatIndex(headerIndex) = latIndex
6331 exit
6332 end if
6333 end do
6334
6335 obsLonIndex(headerIndex) = int(obsLonBurpFile / &
6336 (36000. / numGridLons(obsLatIndex(headerIndex)))) + 1
6337 if ( obsLonIndex(headerIndex) > numGridLons(obsLatIndex(headerIndex)) ) then
6338 obsLonIndex(headerIndex) = numGridLons(obsLatIndex(headerIndex))
6339 end if
6340
6341 ! compute spatial distances
6342 ! position of the observation
6343 obsLat = (obsLatBurpFile - 9000.) / 100.
6344 obsLon = obsLonBurpFile / 100.
6345
6346 ! position of the box center
6347 gridLat = gridLats(obsLatIndex(headerIndex)) - 0.5 * (180./numLat)
6348 gridLon = (360. / numGridLons(obsLatIndex(headerIndex))) * &
6349 (obsLonIndex(headerIndex) - 0.5)
6350
6351 ! spatial separation
6352 obsDistance(headerIndex) = thn_separation(obsLon,obsLat,gridLon,gridLat) * &
6353 latLength / 90.
6354
6355 ! calcul de la bin temporelle dans laquelle se trouve l'observation
6356 obsDate = obs_headElem_i(obsdat, OBS_DAT, headerIndex)
6357 obsTime = obs_headElem_i(obsdat, OBS_ETM, headerIndex)
6358 call tim_getStepObsIndex(obsStepIndex_r8, tim_getDatestamp(), &
6359 obsDate, obsTime, tim_nstepobs)
6360 obsStepIndex(headerIndex) = nint(obsStepIndex_r8)
6361
6362 ! check if distance too far from box center
6363 if (obsDistance(headerIndex) > real(deltrad)) then
6364 valid(headerIndex) = .false.
6365 cycle HEADER1
6366 end if
6367
6368 end do HEADER1
6369
6370 countObs = count(valid(:))
6371 call rpn_comm_allReduce(countObs, countObsMpi, 1, 'mpi_integer', &
6372 'mpi_sum','grid',ierr)
6373 write(*,*) 'thn_csrByLatLonBoxes: countObs after deltrad test = ', &
6374 countObs, countObsMpi
6375
6376 ! Second pass through all observations
6377 HEADER2: do headerIndex = 1, numHeader
6378 if (.not. valid(headerIndex)) cycle HEADER2
6379
6380 ! get the zenith angle
6381 obsAngle(headerIndex) = obs_headElem_r(obsdat, OBS_SZA, headerIndex)
6382
6383 ! Keep obs only if at least one channel not rejected based on tests in suprep
6384 valid(headerIndex) = .false.
6385 channelIndex = 0
6386 call obs_set_current_body_list(obsdat, headerIndex)
6387 BODY1: do
6388 bodyIndex = obs_getBodyIndex(obsdat)
6389 if (bodyIndex < 0) exit BODY1
6390
6391 if (obs_bodyElem_i(obsdat, OBS_VNM, bodyIndex) /= bufr_nbt3) then
6392 cycle BODY1
6393 end if
6394
6395 numChannel(headerIndex) = numChannel(headerIndex) + 1
6396 channelIndex = channelIndex + 1
6397 channelList(channelIndex) = nint(obs_bodyElem_r(obsdat, OBS_PPP, bodyIndex))
6398
6399 obsFlag = obs_bodyElem_i(obsdat, OBS_FLG, bodyIndex)
6400 if ( .not.btest(obsFlag,8) .and. &
6401 .not.btest(obsFlag,9) .and. &
6402 .not.btest(obsFlag,11) ) then
6403 valid(headerIndex) = .true.
6404 channelAssim(channelIndex,headerIndex) = .true.
6405 end if
6406 end do BODY1
6407
6408 ! read the new element 20081 in obsspacedata OBS_CLA
6409 CHANNELS: do channelIndex = 1, numChannel(headerIndex)
6410 obsCloud(channelIndex, headerIndex) = -1.0
6411
6412 ! search for the cloud information for this channel
6413 call obs_set_current_body_list(obsdat, headerIndex)
6414 BODY2: do
6415 bodyIndex = obs_getBodyIndex(obsdat)
6416 if (bodyIndex < 0) exit BODY2
6417
6418 ! check if channel number matches
6419 if (nint(obs_bodyElem_r(obsdat, OBS_PPP, bodyIndex)) == channelList(channelIndex)) then
6420 obsCloud(channelIndex, headerIndex) = real(obs_bodyElem_i(obsdat, OBS_CLA, bodyIndex))
6421 cycle CHANNELS
6422 end if
6423 end do BODY2
6424 if (obsCloud(channelIndex, headerIndex) == -1.0) then
6425 call utl_abort('thn_csrByLatLonBoxes: could not find cloud fraction in obsSpaceData')
6426 end if
6427 end do CHANNELS
6428
6429 end do HEADER2
6430
6431 countObs = count(valid(:))
6432 call rpn_comm_allReduce(countObs, countObsMpi, 1, 'mpi_integer', &
6433 'mpi_sum','grid',ierr)
6434 write(*,*) 'thn_csrByLatLonBoxes: countObs after rejection flag test = ', &
6435 countObs, countObsMpi
6436
6437 ! Allocation for MPI gather
6438 allocate(validMpi(numHeaderMaxMpi*mmpi_nprocs))
6439 allocate(obsLatIndexMpi(numHeaderMaxMpi*mmpi_nprocs))
6440 allocate(obsLonIndexMpi(numHeaderMaxMpi*mmpi_nprocs))
6441 allocate(obsStepIndexMpi(numHeaderMaxMpi*mmpi_nprocs))
6442 allocate(numChannelMpi(numHeaderMaxMpi*mmpi_nprocs))
6443 allocate(obsAngleMpi(numHeaderMaxMpi*mmpi_nprocs))
6444 allocate(obsDistanceMpi(numHeaderMaxMpi*mmpi_nprocs))
6445 allocate(channelAssimMpi(maxNumChan,numHeaderMaxMpi*mmpi_nprocs))
6446 allocate(obsCloudMpi(maxNumChan,numHeaderMaxMpi*mmpi_nprocs))
6447 lenStnId = len(stnId)
6448 allocate(stnIdInt(lenStnId,numHeaderMaxMpi))
6449 allocate(stnIdIntMpi(lenStnId,numHeaderMaxMpi*mmpi_nprocs))
6450
6451 ! Initialize arrays
6452 obsLatIndexMpi(:) = 0
6453 obsLonIndexMpi(:) = 0
6454 obsStepIndexMpi(:) = 0
6455 numChannelMpi(:) = 0
6456 obsAngleMpi(:) = 0.0
6457 obsDistanceMpi(:) = 0.0
6458 channelAssimMpi(:,:) = 0
6459 obsCloudMpi(:,:) = 0.0
6460 stnIdInt(:,:) = 0
6461 stnIdIntMpi(:,:) = 0
6462
6463 ! Station ID converted to integer array
6464 HEADER3: do headerIndex = 1, numHeader
6465 if (.not. valid(headerIndex)) cycle HEADER3
6466
6467 stnId = obs_elem_c(obsdat,'STID',headerIndex)
6468 do charIndex = 1, lenStnId
6469 stnIdInt(charIndex,headerIndex) = iachar(stnId(charIndex:charIndex))
6470 end do
6471 end do HEADER3
6472
6473 ! Gather data from all MPI tasks
6474 nsize = numHeaderMaxMpi
6475 call rpn_comm_allgather(valid, nsize, 'mpi_logical', &
6476 validMpi, nsize, 'mpi_logical', 'grid', ierr)
6477 call rpn_comm_allgather(obsLatIndex, nsize, 'mpi_integer', &
6478 obsLatIndexMpi, nsize, 'mpi_integer', 'grid', ierr)
6479 call rpn_comm_allgather(obsLonIndex, nsize, 'mpi_integer', &
6480 obsLonIndexMpi, nsize, 'mpi_integer', 'grid', ierr)
6481 call rpn_comm_allgather(obsStepIndex, nsize, 'mpi_integer', &
6482 obsStepIndexMpi, nsize, 'mpi_integer', 'grid', ierr)
6483 call rpn_comm_allgather(numChannel, nsize, 'mpi_integer', &
6484 numChannelMpi, nsize, 'mpi_integer', 'grid', ierr)
6485 call rpn_comm_allgather(obsAngle, nsize, 'mpi_real4', &
6486 obsAngleMpi, nsize, 'mpi_real4', 'grid', ierr)
6487 call rpn_comm_allgather(obsDistance, nsize, 'mpi_real4', &
6488 obsDistanceMpi, nsize, 'mpi_real4', 'grid', ierr)
6489
6490 nsize = maxNumChan * numHeaderMaxMpi
6491 call rpn_comm_allgather(channelAssim, nsize, 'mpi_integer', &
6492 channelAssimMpi, nsize, 'mpi_integer', 'grid', ierr)
6493 call rpn_comm_allgather(obsCloud, nsize, 'mpi_real4', &
6494 obsCloudMpi, nsize, 'mpi_real4', 'grid', ierr)
6495
6496 nsize = lenStnId * numHeaderMaxMpi
6497 call rpn_comm_allgather(stnIdInt, nsize, 'mpi_integer', &
6498 stnIdIntMpi, nsize, 'mpi_integer', 'grid', ierr)
6499
6500 ! Apply thinning algorithm
6501 HEADER4: do headerIndex = 1, numHeaderMaxMpi*mmpi_nprocs
6502 if (.not. validMpi(headerIndex)) cycle HEADER4
6503
6504 change = .true.
6505
6506 latIndex = obsLatIndexMpi(headerIndex)
6507 lonIndex = obsLonIndexMpi(headerIndex)
6508 stepIndex = obsStepIndexMpi(headerIndex)
6509
6510 ! Station ID converted back to character string
6511 do charIndex = 1, lenStnId
6512 stnId(charIndex:charIndex) = achar(stnIdIntMpi(charIndex,headerIndex))
6513 end do
6514
6515 if ( stnIdGrid(latIndex,lonIndex,stepIndex) /= '' ) then
6516
6517 ! on veut previlegier les profils avec le plus de canaux assimiles
6518 if ( count(channelAssimMpi(:,headerIndex)) < &
6519 numChanAssimGrid(latIndex,lonIndex,stepIndex) ) change = .false.
6520
6521 ! en cas d'egalite, on doit regarder d'autres conditions pour faire un choix
6522 if ( count(channelAssimMpi(:,headerIndex)) == &
6523 numChanAssimGrid(latIndex,lonIndex,stepIndex) ) then
6524
6525 ! si le profil actuel est d'un autre instrument que celui deja considere
6526 ! choisir celui qui a le plus petit angle satellite
6527 if ( stnid /= stnIdGrid(latIndex,lonIndex,stepIndex) ) then
6528 if ( obsAngleMpi(headerIndex) > &
6529 angleGrid(latIndex,lonIndex,stepIndex) ) change = .false.
6530
6531 ! en cas d'egalite de l'angle,
6532 ! choisir le profil le plus pres du centre de la boite
6533 if ( ( obsAngleMpi(headerIndex) == &
6534 angleGrid(latIndex,lonIndex,stepIndex) ) .and. &
6535 ( obsDistanceMpi(headerIndex) > &
6536 distanceGrid(latIndex,lonIndex,stepIndex) ) ) change = .false.
6537
6538 ! si le profil actuel est du meme instrument que celui deja considere
6539 ! choisir celui dont tous les canaux assimiles ont respectivement
6540 ! moins de fraction nuageuse que celui deja considere
6541 else
6542 do channelIndex = 1, numChannelMpi(headerIndex)
6543 if ( channelAssimMpi(channelIndex,headerIndex) .and. &
6544 ( obsCloudMpi(channelIndex,headerIndex) > &
6545 cloudGrid(channelIndex,latIndex,lonIndex,stepIndex) ) ) change = .false.
6546 end do
6547
6548 ! en cas d'egalite de la fraction nuageuse pour chaque canal present,
6549 ! choisir le profil le plus pres du centre de la boite
6550 do channelIndex = 1, numChannelMpi(headerIndex)
6551 if ( channelAssimMpi(channelIndex,headerIndex) .and. &
6552 ( obsCloudMpi(channelIndex,headerIndex) < &
6553 cloudGrid(channelIndex,latIndex,lonIndex,stepIndex) ) ) exit
6554 if ( ( channelIndex == numChannelMpi(headerIndex) ) .and. &
6555 ( obsDistanceMpi(headerIndex) > &
6556 distanceGrid(latIndex,lonIndex,stepIndex) ) ) change = .false.
6557 end do
6558 end if
6559 end if
6560 end if
6561
6562 ! update list of data to save
6563 if ( .not. change ) then
6564 ! keep previously accepted obs, so reject current obs
6565 validMpi(headerIndex) = .false.
6566 else
6567 ! reject previously accepted obs
6568 if ( headerIndexGrid(latIndex,lonIndex,stepIndex) /= -1 ) then
6569 validMpi(headerIndexGrid(latIndex,lonIndex,stepIndex)) = .false.
6570 end if
6571
6572 ! keep current obs
6573 validMpi(headerIndex) = .true.
6574 headerIndexGrid(latIndex,lonIndex,stepIndex) = headerIndex
6575 numChanAssimGrid(latIndex,lonIndex,stepIndex) = &
6576 count(channelAssimMpi(:,headerIndex))
6577 stnIdGrid(latIndex,lonIndex,stepIndex) = stnid
6578 angleGrid(latIndex,lonIndex,stepIndex) = obsAngleMpi(headerIndex)
6579 cloudGrid(:,latIndex,lonIndex,stepIndex) = obsCloudMpi(:,headerIndex)
6580 distanceGrid(latIndex,lonIndex,stepIndex) = obsDistanceMpi(headerIndex)
6581 end if
6582
6583 end do HEADER4
6584
6585 ! update local copy of 'valid' array
6586 headerIndexBeg = 1 + mmpi_myid * numHeaderMaxMpi
6587 headerIndexEnd = headerIndexBeg + numHeaderMaxMpi - 1
6588 valid(:) = validMpi(headerIndexBeg:headerIndexEnd)
6589
6590 countObs = count(valid(:))
6591 call rpn_comm_allReduce(countObs, countObsMpi, 1, 'mpi_integer', &
6592 'mpi_sum','grid',ierr)
6593 write(*,*) 'thn_csrByLatLonBoxes: countObs after choosing 1 per box = ', &
6594 countObs, countObsMpi
6595
6596 ! modify the observation flags in obsSpaceData
6597 HEADER5: do headerIndex = 1, numHeader
6598 ! skip observation if we're not supposed to consider it
6599 if ( obs_headElem_i(obsdat, OBS_ITY, headerIndex) /= &
6600 codtyp_get_codtyp('radianceclear') ) then
6601 cycle HEADER5
6602 end if
6603
6604 if (.not. valid(headerIndex)) then
6605 call obs_set_current_body_list(obsdat, headerIndex)
6606 BODY3: do
6607 bodyIndex = obs_getBodyIndex(obsdat)
6608 if (bodyIndex < 0) exit BODY3
6609
6610 obsFlag = obs_bodyElem_i(obsdat, OBS_FLG, bodyIndex)
6611 call obs_bodySet_i(obsdat, OBS_FLG, bodyIndex, ibset(obsFlag,11))
6612
6613 end do BODY3
6614 end if
6615 end do HEADER5
6616
6617 deallocate(valid)
6618 deallocate(gridLats)
6619 deallocate(numGridLons)
6620 deallocate(stnIdGrid)
6621 deallocate(numChanAssimGrid)
6622 deallocate(angleGrid)
6623 deallocate(distanceGrid)
6624 deallocate(headerIndexGrid)
6625 deallocate(cloudGrid)
6626 deallocate(obsLatIndex)
6627 deallocate(obsLonIndex)
6628 deallocate(obsStepIndex)
6629 deallocate(numChannel)
6630 deallocate(channelAssim)
6631 deallocate(obsAngle)
6632 deallocate(obsCloud)
6633 deallocate(obsDistance)
6634 deallocate(validMpi)
6635 deallocate(obsLatIndexMpi)
6636 deallocate(obsLonIndexMpi)
6637 deallocate(obsStepIndexMpi)
6638 deallocate(numChannelMpi)
6639 deallocate(obsAngleMpi)
6640 deallocate(obsDistanceMpi)
6641 deallocate(channelAssimMpi)
6642 deallocate(obsCloudMpi)
6643 deallocate(stnIdInt)
6644 deallocate(stnIdIntMpi)
6645
6646 write(*,*)
6647 write(*,*) 'thn_csrByLatLonBoxes: Finished'
6648 write(*,*)
6649
6650 end subroutine thn_csrByLatLonBoxes
6651
6652 !--------------------------------------------------------------------------
6653 ! thn_hyperByLatLonBoxes
6654 !--------------------------------------------------------------------------
6655 subroutine thn_hyperByLatLonBoxes(obsdat, removeUnCorrected, &
6656 deltmax, deltax, deltrad, &
6657 familyType, codtyp)
6658 !
6659 !:Purpose: Only keep the observation closest to the center of each
6660 ! lat-lon (and time) box.
6661 ! Set bit 11 of OBS_FLG on observations that are to be rejected.
6662 !
6663 implicit none
6664
6665 ! Arguments:
6666 type(struct_obs), intent(inout) :: obsdat
6667 logical, intent(in) :: removeUnCorrected
6668 integer, intent(in) :: deltmax
6669 integer, intent(in) :: deltax
6670 integer, intent(in) :: deltrad
6671 character(len=*), intent(in) :: familyType
6672 integer, intent(in) :: codtyp
6673
6674 ! Locals:
6675 integer :: headerIndex, bodyIndex, obsDate, obsTime, obsFlag
6676 integer :: numHeader, numHeaderMpi, numHeaderMaxMpi, lenStnId
6677 integer :: numLat, numLon, latIndex, numChannels, delMinutes
6678 integer :: lonBinIndex, latBinIndex, timeBinIndex, charIndex
6679 integer :: ierr, nsize, procIndex, countHeader, countHeaderMpi
6680 real(4) :: latInRadians, length, distance
6681 real(8) :: lonBoxCenterInDegrees, latBoxCenterInDegrees
6682 real(8) :: obsLatInRad, obsLonInRad, obsLat, obsLon
6683 real(8) :: obsLatInDegrees, obsLonInDegrees, obsStepIndex_r8
6684 integer, parameter :: latLength = 10000
6685 integer, parameter :: lonLength = 40000
6686 real(4), allocatable :: gridLats(:)
6687 integer, allocatable :: numGridLons(:)
6688 integer, allocatable :: stnIdInt(:,:), stnIdIntMpi(:,:)
6689 integer, allocatable :: headerIndexKeep(:,:,:), numChannelsKeep(:,:,:)
6690 integer, allocatable :: headerIndexKeepMpi(:,:,:,:), numChannelsKeepMpi(:,:,:,:)
6691 integer, allocatable :: delMinutesKeep(:,:,:), delMinutesKeepMpi(:,:,:,:)
6692 integer, allocatable :: procIndexKeep(:,:,:)
6693 real(4), allocatable :: distanceKeep(:,:,:), distanceKeepMpi(:,:,:,:)
6694 logical, allocatable :: rejectThisHeader(:)
6695 logical :: keepThisObs, stnIdFoundInList
6696 integer :: obsLonBurpFile, obsLatBurpFile
6697 integer, parameter :: numStnIdMax = 10
6698 integer :: numStnId, stnIdIndexFound, stnIdIndex, countMpi, numObsStnId(numStnIdMax)
6699 character(len=12) :: stnid, stnidList(numStnIdMax)
6700 character(len=codtyp_name_length) :: instrumName
6701
6702 instrumName = codtyp_get_name(codtyp)
6703 write(*,*)
6704 write(*,*) 'thn_hyperByLatLonBoxes: Starting, ', trim(instrumName)
6705 write(*,*)
6706
6707 numHeader = obs_numHeader(obsdat)
6708 call rpn_comm_allReduce(numHeader, numHeaderMaxMpi, 1, 'mpi_integer', &
6709 'mpi_max', 'grid', ierr)
6710
6711 lenStnId = len(stnId)
6712 allocate(stnIdInt(lenStnId,numHeaderMaxMpi))
6713 allocate(stnIdIntMpi(lenStnId,numHeaderMaxMpi*mmpi_nprocs))
6714 stnIdInt(:,:) = 0
6715 stnIdIntMpi(:,:) = 0
6716
6717 ! loop over all header indices of the specified family and get integer stnId
6718 countHeader = 0
6719 call obs_set_current_header_list(obsdat,trim(familyType))
6720 HEADER: do
6721 headerIndex = obs_getHeaderIndex(obsdat)
6722 if (headerIndex < 0) exit HEADER
6723 if (obs_headElem_i(obsdat, OBS_ITY, headerIndex) /= codtyp) cycle HEADER
6724
6725 countHeader = countHeader + 1
6726
6727 ! convert and store stnId as integer array
6728 stnId = obs_elem_c(obsdat,'STID',headerIndex)
6729 do charIndex = 1, lenStnId
6730 stnIdInt(charIndex,headerIndex) = iachar(stnId(charIndex:charIndex))
6731 end do
6732 end do HEADER
6733
6734 ! return if no observations for this instrument
6735 call rpn_comm_allReduce(countHeader, countHeaderMpi, 1, 'mpi_integer', &
6736 'mpi_sum', 'grid', ierr)
6737 if (countHeaderMpi == 0) then
6738 write(*,*) 'thn_hyperByLatLonBoxes: no observations for this instrument'
6739 return
6740 end if
6741
6742 ! Gather stnIdInt from all MPI tasks
6743 nsize = lenStnId * numHeaderMaxMpi
6744 call rpn_comm_allgather(stnIdInt, nsize, 'mpi_integer', &
6745 stnIdIntMpi, nsize, 'mpi_integer', 'grid', ierr)
6746
6747 ! build a global stnIdList
6748 numStnId = 0
6749 numHeaderMpi = numHeaderMaxMpi * mmpi_nprocs
6750 HEADER4: do headerIndex = 1, numHeaderMpi
6751 if (all(stnIdIntMpi(:,headerIndex) == 0)) cycle HEADER4
6752
6753 ! Station ID converted back to character string
6754 do charIndex = 1, lenStnId
6755 stnId(charIndex:charIndex) = achar(stnIdIntMpi(charIndex,headerIndex))
6756 end do
6757
6758 stnIdFoundInList = .false.
6759 if ( numStnId == 0 ) then
6760 stnIdFoundInList = .true.
6761 numStnId = numStnId + 1
6762 stnidList(numStnId) = stnId
6763 else
6764 do stnIdIndex = 1, numStnId
6765 if ( stnidList(stnIdIndex) == stnId ) cycle HEADER4
6766 end do
6767 end if
6768
6769 if ( .not. stnIdFoundInList ) then
6770 numStnId = numStnId + 1
6771 stnidList(numStnId) = stnId
6772 end if
6773
6774 if ( numStnId >= numStnIdMax ) then
6775 call utl_abort('thn_hyperByLatLonBoxes: numStnId too large')
6776 end if
6777
6778 end do HEADER4
6779
6780 ! loop over local headers to find numObs for each stnId
6781 call obs_set_current_header_list(obsdat,trim(familyType))
6782 HEADER0: do
6783 headerIndex = obs_getHeaderIndex(obsdat)
6784 if (headerIndex < 0) exit HEADER0
6785 if (obs_headElem_i(obsdat, OBS_ITY, headerIndex) /= codtyp) cycle HEADER0
6786
6787 stnId = obs_elem_c(obsdat,'STID',headerIndex)
6788
6789 do stnIdIndex = 1, numStnId
6790 if ( stnidList(stnIdIndex) == stnId ) then
6791 numObsStnId(stnIdIndex) = numObsStnId(stnIdIndex) + 1
6792 end if
6793 end do
6794
6795 end do HEADER0
6796
6797 ! Initial setup
6798 numLat = nint( 2. * real(latLength) / real(deltax) )
6799 numLon = nint( real(lonLength) / real(deltax) )
6800 allocate(headerIndexKeep(numLat,numLon,tim_nstepobs))
6801 allocate(numChannelsKeep(numLat,numLon,tim_nstepobs))
6802 allocate(distanceKeep(numLat,numLon,tim_nstepobs))
6803 allocate(delMinutesKeep(numLat,numLon,tim_nstepobs))
6804 allocate(gridLats(numLat))
6805 allocate(numGridLons(numLat))
6806 headerIndexKeep(:,:,:) = -1
6807 numChannelsKeep(:,:,:) = 0
6808 distanceKeep(:,:,:) = 0.0
6809 delMinutesKeep(:,:,:) = deltmax
6810 gridLats(:) = 0.0
6811 numGridLons(:) = 0
6812
6813 write(*,'(a)') ' '
6814 write(*,'(a)') ' == Gridbox properties == '
6815 write(*,'(a)') ' '
6816 write(*,'(a,i8)') ' Number of horizontal boxes : ', numLon
6817 write(*,'(a,i8)') ' Number of vertical boxes : ', numLat
6818 write(*,'(a,i8)') ' Number of temporal bins : ', tim_nstepobs
6819
6820 ! print some statistics before thinning
6821
6822 instrumName = codtyp_get_name(codtyp)
6823 write(*,*)
6824 write(*,'(a)') ' == Input file == '
6825 write(*,*)
6826 write(*,'(a,a4)') ' Instrument = ', trim(instrumName)
6827 write(*,'(a,i4)') ' Codtyp = ', codtyp
6828
6829 write(*,*)
6830 write(*,'(a,2i8)') ' Number of valid satellite profiles = ', countHeader, countHeaderMpi
6831 write(*,*)
6832
6833 do stnIdIndex = 1, numStnId
6834 call rpn_comm_allReduce(numObsStnId(stnIdIndex), countMpi, 1, 'mpi_integer', &
6835 'mpi_sum', 'grid', ierr)
6836 write(*,'(a9,a,2i8)') stnidList(stnIdIndex), ' : ', numObsStnId(stnIdIndex), countMpi
6837 end do
6838
6839 allocate(headerIndexKeepMpi(numLat,numLon,tim_nstepobs,mmpi_nprocs))
6840 allocate(numChannelsKeepMpi(numLat,numLon,tim_nstepobs,mmpi_nprocs))
6841 allocate(distanceKeepMpi(numLat,numLon,tim_nstepobs,mmpi_nprocs))
6842 allocate(delMinutesKeepMpi(numLat,numLon,tim_nstepobs,mmpi_nprocs))
6843 allocate(procIndexKeep(numLat,numLon,tim_nstepobs))
6844 procIndexKeep(:,:,:) = -1
6845
6846 ! set spatial boxes properties
6847 ! gridLats(:) : latitude (deg) of northern side of the box
6848 ! numGridLons(:) : number of longitudinal boxes at this latitude
6849 do latIndex = 1, numLat
6850 gridLats(latIndex) = (latIndex*180./numLat) - 90.
6851 if ( gridLats(latIndex) <= 0.0 ) then
6852 latInRadians = gridLats(latIndex) * MPC_PI_R8 / 180.
6853 else
6854 latInRadians = gridLats(latIndex-1) * MPC_PI_R8 / 180.
6855 end if
6856 length = lonLength * cos(latInRadians)
6857 numGridLons(latIndex) = nint(length/deltax)
6858 end do
6859
6860 ! loop over all header indices of the specified family
6861 call obs_set_current_header_list(obsdat,trim(familyType))
6862 HEADER1: do
6863 headerIndex = obs_getHeaderIndex(obsdat)
6864 if (headerIndex < 0) exit HEADER1
6865
6866 if (obs_headElem_i(obsdat, OBS_ITY, headerIndex) /= codtyp) cycle HEADER1
6867
6868 obsLonInRad = obs_headElem_r(obsdat, OBS_LON, headerIndex)
6869 obsLatInRad = obs_headElem_r(obsdat, OBS_LAT, headerIndex)
6870 obsDate = obs_headElem_i(obsdat, OBS_DAT, headerIndex)
6871 obsTime = obs_headElem_i(obsdat, OBS_ETM, headerIndex)
6872
6873 obsLonInDegrees = MPC_DEGREES_PER_RADIAN_R8 * obsLonInRad
6874 obsLatInDegrees = MPC_DEGREES_PER_RADIAN_R8 * obsLatInRad
6875 obsLonBurpFile = nint(100.0*(obsLonInDegrees - 180.0))
6876 if(obsLonBurpFile < 0) obsLonBurpFile = obsLonBurpFile + 36000
6877 obsLatBurpFile = 9000+nint(100.0*obsLatInDegrees)
6878
6879 numChannels = 0
6880
6881 ! loop over all body indices for this headerIndex
6882 call obs_set_current_body_list(obsdat, headerIndex)
6883 BODY: do
6884 bodyIndex = obs_getBodyIndex(obsdat)
6885 if (bodyIndex < 0) exit BODY
6886
6887 ! mark for rejection if not bias corrected (bit 6 not set)
6888 if (removeUnCorrected) then
6889 obsFlag = obs_bodyElem_i(obsdat, OBS_FLG, bodyIndex)
6890 if (.not. btest(obsFlag,6)) then
6891 call obs_bodySet_i(obsdat, OBS_FLG, bodyIndex, ibset(obsFlag,11))
6892 end if
6893 end if
6894
6895 ! count the number of accepted channels
6896 obsFlag = obs_bodyElem_i(obsdat, OBS_FLG, bodyIndex)
6897 if ( .not. btest(obsFlag,8) .and. &
6898 .not. btest(obsFlag,9) .and. &
6899 .not. btest(obsFlag,11) ) then
6900 numChannels = numChannels + 1
6901 end if
6902
6903 end do BODY
6904
6905 ! Determine the lat and lon bin indexes
6906 do latIndex = 1, numLat
6907 if ( obsLatInDegrees <= (gridLats(latIndex)+0.000001) ) then
6908 latBinIndex = latIndex
6909 exit
6910 end if
6911 end do
6912 lonBinIndex = int( obsLonBurpFile/(36000.0/numGridLons(latBinIndex)) ) + 1
6913 if ( lonBinIndex > numGridLons(latBinIndex) ) lonBinIndex = numGridLons(latBinIndex)
6914
6915 ! Determine the time bin index
6916 call tim_getStepObsIndex(obsStepIndex_r8, tim_getDatestamp(), &
6917 obsDate, obsTime, tim_nstepobs)
6918 timeBinIndex = nint(obsStepIndex_r8)
6919 delMinutes = nint(60.0 * tim_dstepobs * abs(real(timeBinIndex) - obsStepIndex_r8))
6920
6921 ! Determine distance from box center
6922 latBoxCenterInDegrees = gridLats(latBinIndex) - 0.5 * (180./numLat)
6923 lonBoxCenterInDegrees = (360. / numGridLons(latBinIndex)) * (lonBinIndex - 0.5)
6924 obsLat = (obsLatBurpFile - 9000.) / 100.
6925 obsLon = obsLonBurpFile / 100.
6926 distance = 1.0d-3 * phf_calcDistance(MPC_RADIANS_PER_DEGREE_R8 * latBoxCenterInDegrees, &
6927 MPC_RADIANS_PER_DEGREE_R8 * lonBoxCenterInDegrees, &
6928 MPC_RADIANS_PER_DEGREE_R8 * obsLat, &
6929 MPC_RADIANS_PER_DEGREE_R8 * obsLon )
6930
6931 ! Apply thinning criteria
6932 keepThisObs = .false.
6933
6934 ! keep if distance to box center smaller than limit and
6935 ! time under limit fixed at input and maximise number of channels
6936 if ( (distance < deltrad) .and. &
6937 (numChannels >= numChannelsKeep(latBinIndex,lonBinIndex,timeBinIndex)) .and. &
6938 (delMinutes <= deltmax) ) keepThisObs = .true.
6939
6940 ! keep the closest to bin central time
6941 if ( numChannels == numChannelsKeep(latBinIndex,lonBinIndex,timeBinIndex) ) then
6942 if ( headerIndexKeep(latBinIndex,lonBinIndex,timeBinIndex) == -1 ) then
6943 keepThisObs = .false.
6944 else
6945 if ( delMinutes > delMinutesKeep(latBinIndex,lonBinIndex,timeBinIndex) ) then
6946 keepThisObs = .false.
6947 end if
6948
6949 if ( delMinutes == delMinutesKeep(latBinIndex,lonBinIndex,timeBinIndex) ) then
6950 if ( distance > distanceKeep(latBinIndex,lonBinIndex,timeBinIndex) ) then
6951 keepThisObs = .false.
6952 end if
6953 end if
6954
6955 end if
6956 end if
6957
6958 ! save the observation if thinning criteria is satisfied
6959 if ( keepThisObs ) then
6960 headerIndexKeep(latBinIndex,lonBinIndex,timeBinIndex) = headerIndex
6961 distanceKeep(latBinIndex,lonBinIndex,timeBinIndex) = distance
6962 delMinutesKeep(latBinIndex,lonBinIndex,timeBinIndex) = delMinutes
6963 numChannelsKeep(latBinIndex,lonBinIndex,timeBinIndex) = numChannels
6964 end if
6965
6966 end do HEADER1
6967
6968 ! communicate results to all other mpi tasks
6969 nsize = numLat * numLon * tim_nstepobs
6970 call rpn_comm_allgather(distanceKeep, nsize, 'mpi_real4', &
6971 distanceKeepMpi, nsize, 'mpi_real4', 'grid', ierr)
6972 call rpn_comm_allgather(delMinutesKeep, nsize, 'mpi_integer', &
6973 delMinutesKeepMpi, nsize, 'mpi_integer', 'grid', ierr)
6974 call rpn_comm_allgather(numChannelsKeep, nsize, 'mpi_integer', &
6975 numChannelsKeepMpi, nsize, 'mpi_integer', 'grid', ierr)
6976 call rpn_comm_allgather(headerIndexKeep, nsize, 'mpi_integer', &
6977 headerIndexKeepMpi, nsize, 'mpi_integer', 'grid', ierr)
6978
6979 ! reset arrays that store info about kept obs
6980 headerIndexKeep(:,:,:) = -1
6981 numChannelsKeep(:,:,:) = 0
6982 distanceKeep(:,:,:) = 0.0
6983 delMinutesKeep(:,:,:) = deltmax
6984
6985 do timeBinIndex = 1, tim_nstepobs
6986 do lonBinIndex = 1, numLon
6987 do latBinIndex = 1, numLat
6988
6989 ! Apply thinning criteria to results from all mpi tasks
6990 do procIndex = 1, mmpi_nprocs
6991
6992 headerIndex = headerIndexKeepMpi(latBinIndex,lonBinIndex,timeBinIndex,procIndex)
6993 distance = distanceKeepMpi(latBinIndex,lonBinIndex,timeBinIndex,procIndex)
6994 delMinutes = delMinutesKeepMpi(latBinIndex,lonBinIndex,timeBinIndex,procIndex)
6995 numChannels = numChannelsKeepMpi(latBinIndex,lonBinIndex,timeBinIndex,procIndex)
6996
6997 keepThisObs = .false.
6998
6999 ! keep if distance to box center smaller than limit and
7000 ! time under limit fixed at input and maximise number of channels
7001 if ( (distance < deltrad) .and. &
7002 (numChannels >= numChannelsKeep(latBinIndex,lonBinIndex,timeBinIndex)) .and. &
7003 (delMinutes <= deltmax) ) keepThisObs = .true.
7004
7005 ! keep the closest to bin central time
7006 if ( numChannels == numChannelsKeep(latBinIndex,lonBinIndex,timeBinIndex) ) then
7007 if ( headerIndexKeep(latBinIndex,lonBinIndex,timeBinIndex) == -1 ) then
7008 keepThisObs = .false.
7009 else
7010 if ( delMinutes > delMinutesKeep(latBinIndex,lonBinIndex,timeBinIndex) ) then
7011 keepThisObs = .false.
7012 end if
7013
7014 if ( delMinutes == delMinutesKeep(latBinIndex,lonBinIndex,timeBinIndex) ) then
7015 if ( distance > distanceKeep(latBinIndex,lonBinIndex,timeBinIndex) ) then
7016 keepThisObs = .false.
7017 end if
7018 end if
7019
7020 end if
7021 end if
7022
7023 ! save the observation if thinning criteria is satisfied
7024 if ( keepThisObs ) then
7025 procIndexKeep(latBinIndex,lonBinIndex,timeBinIndex) = procIndex
7026 headerIndexKeep(latBinIndex,lonBinIndex,timeBinIndex) = headerIndex
7027 distanceKeep(latBinIndex,lonBinIndex,timeBinIndex) = distance
7028 delMinutesKeep(latBinIndex,lonBinIndex,timeBinIndex) = delMinutes
7029 numChannelsKeep(latBinIndex,lonBinIndex,timeBinIndex) = numChannels
7030 end if
7031
7032 end do ! procIndex
7033
7034 end do
7035 end do
7036 end do
7037
7038 ! determine which headerIndex values are rejected
7039 allocate(rejectThisHeader(obs_numheader(obsdat)))
7040 rejectThisHeader(:) = .true.
7041 do timeBinIndex = 1, tim_nstepobs
7042 do lonBinIndex = 1, numLon
7043 do latBinIndex = 1, numLat
7044 if (procIndexKeep(latBinIndex,lonBinIndex,timeBinIndex) == mmpi_myid+1) then
7045 headerIndex = headerIndexKeep(latBinIndex,lonBinIndex,timeBinIndex)
7046 rejectThisHeader(headerIndex) = .false.
7047 end if
7048 end do
7049 end do
7050 end do
7051
7052 ! modify flags, by setting bit 11 for those rejected, and count obs
7053 countHeader = 0
7054 numObsStnId(:) = 0
7055 call obs_set_current_header_list(obsdat,trim(familyType))
7056 HEADER2: do
7057 headerIndex = obs_getHeaderIndex(obsdat)
7058 if (headerIndex < 0) exit HEADER2
7059
7060 if (obs_headElem_i(obsdat, OBS_ITY, headerIndex) /= codtyp) cycle HEADER2
7061
7062 if (.not. rejectThisHeader(headerIndex)) then
7063
7064 stnid = obs_elem_c(obsdat,'STID',headerIndex)
7065 stnIdIndexFound = -1
7066 do stnIdIndex = 1, numStnId
7067 if ( stnidList(stnIdIndex) == stnid ) stnIdIndexFound = stnIdIndex
7068 end do
7069 if ( stnIdIndexFound == -1 ) then
7070 call utl_abort('thn_hyperByLatLonBoxes: Problem with stnId')
7071 end if
7072 numObsStnId(stnIdIndexFound) = numObsStnId(stnIdIndexFound) + 1
7073 countHeader = countHeader + 1
7074
7075 cycle HEADER2
7076 end if
7077
7078 ! loop over all body indices for this headerIndex
7079 call obs_set_current_body_list(obsdat, headerIndex)
7080 BODY2: do
7081 bodyIndex = obs_getBodyIndex(obsdat)
7082 if (bodyIndex < 0) exit BODY2
7083
7084 obsFlag = obs_bodyElem_i(obsdat, OBS_FLG, bodyIndex)
7085 call obs_bodySet_i(obsdat, OBS_FLG, bodyIndex, ibset(obsFlag,11))
7086 end do BODY2
7087
7088 end do HEADER2
7089
7090 call rpn_comm_allReduce(countHeader, countHeaderMpi, 1, 'mpi_integer', &
7091 'mpi_sum', 'grid', ierr)
7092
7093 write(*,*)
7094 write(*,'(a)') ' == Output file == '
7095
7096 write(*,*)
7097 write(*,'(a,2i8)') ' Number of valid satellite profiles = ', countHeader, countHeaderMpi
7098 write(*,*)
7099
7100 do stnIdIndex = 1, numStnId
7101 call rpn_comm_allReduce(numObsStnId(stnIdIndex), countMpi, 1, 'mpi_integer', &
7102 'mpi_sum', 'grid', ierr)
7103 write(*,'(a9,a,2i8)') stnidList(stnIdIndex), ' : ', numObsStnId(stnIdIndex), countMpi
7104 end do
7105
7106 deallocate(rejectThisHeader)
7107 deallocate(headerIndexKeep)
7108 deallocate(numChannelsKeep)
7109 deallocate(distanceKeep)
7110 deallocate(delMinutesKeep)
7111 deallocate(gridLats)
7112 deallocate(numGridLons)
7113 deallocate(headerIndexKeepMpi)
7114 deallocate(numChannelsKeepMpi)
7115 deallocate(distanceKeepMpi)
7116 deallocate(delMinutesKeepMpi)
7117 deallocate(procIndexKeep)
7118 deallocate(stnIdIntMpi)
7119 deallocate(stnIdInt)
7120
7121 write(*,*)
7122 write(*,*) 'thn_hyperByLatLonBoxes: Finished'
7123 write(*,*)
7124
7125 end subroutine thn_hyperByLatLonBoxes
7126
7127 !--------------------------------------------------------------------------
7128 ! thn_separation
7129 !--------------------------------------------------------------------------
7130 function thn_separation(xlon1, xlat1, xlon2, xlat2)
7131 !
7132 !:Purpose: Compute the separation distance for some thinning algorithms.
7133 !
7134 implicit none
7135
7136 ! Arguments:
7137 real(4), intent(in) :: xlat1
7138 real(4), intent(in) :: xlat2
7139 real(4), intent(in) :: xlon1
7140 real(4), intent(in) :: xlon2
7141 ! Result:
7142 real(4) :: thn_separation
7143
7144 ! Locals:
7145 real(4) :: cosval, degrad, raddeg
7146
7147 raddeg = 180.0 / 3.14159265358979
7148 degrad = 1.0 / raddeg
7149 cosval = sin(xlat1 * degrad) * sin(xlat2 * degrad) + &
7150 cos(xlat1 * degrad) * cos(xlat2 * degrad) * &
7151 cos((xlon1 - xlon2) * degrad)
7152
7153 if (cosval < -1.0d0) then
7154 cosval = -1.0d0
7155 else if (cosval > 1.0d0) then
7156 cosval = 1.0d0
7157 end if
7158 thn_separation = acos(cosval) * raddeg
7159
7160 end function thn_separation
7161
7162 !--------------------------------------------------------------------------
7163 ! thn_thinSatSST
7164 !--------------------------------------------------------------------------
7165 subroutine thn_thinSatSST(obsData)
7166 !
7167 !:Purpose: Main subroutine for thinning of satellite SST obs.
7168 !
7169 implicit none
7170
7171 ! Arguments:
7172 type(struct_obs), intent(inout) :: obsData
7173
7174 ! Locals:
7175 integer :: nulnam
7176 integer :: fnom, fclos, ierr
7177 integer, parameter :: maxNumDataSetSST = 10 ! maximum number of SST datasets considered in surface thinning
7178 integer :: dataSetSSTIndex, numberDataSetSST
7179
7180 ! Namelist variables:
7181 logical :: doThinning ! if false, we return immediately
7182 integer :: numTimesteps ! thinning number of timesteps
7183 integer :: deltmax ! maximum time difference (in minutes)
7184 real(4) :: fractionGridCell ! keep data only inside a fraction of the grid cell size
7185 character(len=10) :: dataSetSST(maxNumDataSetSST) ! array of SST dataset names considered in thinning
7186
7187 namelist /thin_satSST/doThinning, numTimesteps, deltmax, fractionGridCell, dataSetSST
7188
7189 ! set default values for namelist variables
7190 doThinning = .false.
7191 numTimesteps = 5
7192 deltmax = 90
7193 fractionGridCell = 1.0
7194 dataSetSST(:) = ''
7195
7196 ! return if no SST obs
7197 if (.not. obs_famExist(obsData, 'TM')) return
7198
7199 ! Read the namelist for Surface observations (if it exists)
7200 if (utl_isNamelistPresent('thin_satSST', './flnml')) then
7201 nulnam = 0
7202 ierr = fnom(nulnam, './flnml','FTN+SEQ+R/O', 0)
7203 if (ierr /= 0) call utl_abort('thn_thinSatSST: Error opening file flnml')
7204 read(nulnam,nml = thin_satSST, iostat = ierr)
7205 if (ierr /= 0) call utl_abort('thn_thinSatSST: Error reading namelist')
7206 if (mmpi_myid == 0) write(*, nml = thin_satSST)
7207 ierr = fclos(nulnam)
7208 else
7209 write(*,*)
7210 write(*,*) 'thn_thinSatSST: Namelist block thin_satSST is missing in the namelist.'
7211 write(*,*) ' The default value will be taken.'
7212 if (mmpi_myid == 0) write(*, nml = thin_satSST)
7213 end if
7214
7215 if (.not. doThinning) return
7216
7217 numberDataSetSST = 0
7218 do dataSetSSTIndex = 1, maxNumDataSetSST
7219 if (trim(dataSetSST(dataSetSSTIndex)) == '') exit
7220 numberDataSetSST = numberDataSetSST + 1
7221 end do
7222
7223 write(*,*)''
7224 if (numberDataSetSST > 0) then
7225 write(*,*) 'thn_thinSurface: satellite SST datasets considered in thinning: '
7226 do dataSetSSTIndex = 1, numberDataSetSST
7227 write(*,'(i5,a)') dataSetSSTIndex, trim(dataSetSST(dataSetSSTIndex))
7228 end do
7229 end if
7230
7231 call utl_tmg_start(114,'--ObsThinning')
7232 do dataSetSSTIndex = 1, numberDataSetSST
7233 call thn_satelliteSSTByGridCell(obsData, dataSetSST(dataSetSSTIndex), &
7234 numTimesteps, deltmax, fractionGridCell)
7235 end do
7236 call utl_tmg_stop(114)
7237
7238 end subroutine thn_thinSatSST
7239
7240 !--------------------------------------------------------------------------
7241 ! thn_satelliteSSTByGridCell
7242 !--------------------------------------------------------------------------
7243 subroutine thn_satelliteSSTByGridCell(obsData, dataSet, numTimesteps, deltmax, fractionGridCell)
7244 !
7245 !:Purpose: thinning satellite SST data by grid cells.
7246 ! Set bit 11 of obs_flg on observations that are to be rejected.
7247 ! The algorithm consists in keeping median satellite SST data
7248 ! within one grid cell.
7249 ! The grid is provided in the input file analysisgrid_thinning_satSST.
7250 !
7251 implicit none
7252
7253 ! Arguments:
7254 type(struct_obs), intent(inout) :: obsData ! obsSpace data object
7255 character(len=*), intent(in) :: dataSet ! station ID (id_stn variable in SQLite obs.files)
7256 integer , intent(in) :: numTimesteps ! thinning number of timesteps
7257 integer , intent(in) :: deltmax ! maximum time difference (in minutes)
7258 real(4) , intent(in) :: fractionGridCell ! between 0. and 1., keep data only inside a fraction of the grid cell size
7259
7260 ! Locals:
7261 type(struct_hco), pointer :: hco_thinning
7262 integer :: headerIndexBeg, headerIndexEnd
7263 integer :: ierr, lonIndex, latIndex, stepIndex, codeType
7264 integer :: obsLonIndex, obsLatIndex, obsStepIndex
7265 integer :: numHeader, numHeaderMaxMpi, headerIndex, bodyIndex
7266 integer :: satSSTCount, satSSTCountMpi
7267 integer :: obsFlag, obsVarno, obsDate, obsTime
7268 real(8) :: delMinutes, obsStepIndex_r8
7269 real(8) :: obsLon, obsLat
7270 real(8) :: deltaLon, deltaLat, deltaLatCell, deltaLonCell
7271 real(4) :: obsDistance, sizeGridCell
7272 integer :: medianIndex
7273 logical :: llok
7274 real(4), allocatable :: lonGrid(:), latGrid(:)
7275 logical, allocatable :: valid(:), validMpi(:)
7276 integer, allocatable :: obsLonIndexVec(:), obsLonIndexMpi(:)
7277 integer, allocatable :: obsLatIndexVec(:), obsLatIndexMpi(:)
7278 integer, allocatable :: obsTimeIndexVec(:), obsTimeIndexMpi(:)
7279 real(4), allocatable :: obsSST(:), obsSSTMpi(:)
7280 type countSatSSTdataType
7281 integer :: numObs ! number of data inside each grid cell
7282 real(4), allocatable :: dataVec(:) ! vector of data inside each grid cell
7283 integer, allocatable :: headerIndex(:) ! header indexes inside each grid cell
7284 end type countSatSSTdataType
7285 type(countSatSSTdataType), allocatable :: dataGrid(:,:) ! for each lon/lat of the grid
7286
7287 write(*,*)
7288 write(*,*) 'thn_satelliteSSTByGridCell: Starting satellite SST data thinning for sensor: ', trim(dataSet)
7289 write(*,*)
7290
7291 numHeader = obs_numHeader(obsData)
7292 call rpn_comm_allReduce(numHeader, numHeaderMaxMpi, 1, 'mpi_integer', 'mpi_max','grid',ierr)
7293
7294 allocate(valid(numHeaderMaxMpi))
7295 valid(:) = .false.
7296
7297 ! count satellite SST data of the current sensor (id_stn)
7298 satSSTCount = 0
7299 do headerIndex = 1, numHeader
7300 bodyIndex = obs_headElem_i(obsData, obs_rln, headerIndex)
7301 llok = (obs_bodyElem_i(obsData, obs_ass, bodyIndex) == obs_assimilated)
7302 if (.not. llok) cycle
7303 obsVarno = obs_bodyElem_i(obsData, obs_vnm, bodyIndex)
7304 if (obsVarno /= bufr_sst) cycle
7305 codeType = obs_headElem_i(obsData, obs_ity, headerIndex)
7306 if (codeType /= codtyp_get_codtyp('satob')) cycle
7307
7308 if (trim(obs_elem_c(obsData, 'STID' , headerIndex)) == trim(dataSet)) then
7309 satSSTCount = satSSTCount + 1
7310 valid(headerIndex) = .true.
7311 end if
7312 end do
7313
7314 ! Return if no satellite SST obs to thin
7315 allocate(validMpi(numHeaderMaxMpi * mmpi_nprocs))
7316 validMpi(:) = .false.
7317 call rpn_comm_allgather(valid, numHeaderMaxMpi, 'mpi_logical', &
7318 validMpi, numHeaderMaxMpi, 'mpi_logical', 'grid', ierr)
7319 if (count(validMpi(:)) == 0) then
7320 write(*,*) 'thn_satelliteSSTByGridCell: no ', trim(dataSet), ' SST data present'
7321 return
7322 end if
7323
7324 write(*,*) 'thn_satelliteSSTByGridCell: ', trim(dataSet), ': numHeader, numHeaderMaxMpi: ', &
7325 numHeader, numHeaderMaxMpi
7326
7327 call rpn_comm_allReduce(satSSTCount, satSSTCountMpi, 1, 'mpi_integer', 'mpi_sum','grid', ierr)
7328 write(*,*) 'thn_satelliteSSTByGridCell: ', trim(dataSet),' data: total number of initial data: ', satSSTCountMpi
7329 write(*,*) 'thn_satelliteSSTByGridCell: ', trim(dataSet),' data: number of thinning timesteps: ', numTimesteps
7330
7331 ! Setup horizontal thinning grid
7332 nullify(hco_thinning)
7333 call hco_SetupFromFile(hco_thinning, './analysisgrid_thinning_satSST', 'ANALYSIS', 'Analysis')
7334
7335 ! Setup thinning grid parameters
7336 allocate(lonGrid(hco_thinning%ni))
7337 allocate(latGrid(hco_thinning%nj))
7338 lonGrid(:) = hco_thinning%lon(:) * MPC_DEGREES_PER_RADIAN_R8
7339 latGrid(:) = hco_thinning%lat(:) * MPC_DEGREES_PER_RADIAN_R8
7340 allocate(dataGrid(hco_thinning%nj, hco_thinning%ni))
7341
7342 ! Allocate vectors
7343 allocate(obsLatIndexVec(numHeaderMaxMpi))
7344 allocate(obsLonIndexVec(numHeaderMaxMpi))
7345 allocate(obsTimeIndexVec(numHeaderMaxMpi))
7346 allocate(obsSST(numHeaderMaxMpi))
7347
7348 ! Allocate mpi global vectors
7349 allocate(obsLatIndexMpi(numHeaderMaxMpi * mmpi_nprocs))
7350 allocate(obsLonIndexMpi(numHeaderMaxMpi * mmpi_nprocs))
7351 allocate(obsTimeIndexMpi(numHeaderMaxMpi * mmpi_nprocs))
7352 allocate(obsSSTMpi(numHeaderMaxMpi * mmpi_nprocs))
7353
7354 ! Initialize vectors
7355 obsLatIndexVec(:) = 0
7356 obsLonIndexVec(:) = 0
7357 obsTimeIndexVec(:) = 0
7358 obsSST(:) = 0.
7359
7360 HEADER: do headerIndex = 1, numHeader
7361 bodyIndex = obs_headElem_i(obsData, obs_rln, headerIndex)
7362 llok = (obs_bodyElem_i(obsData, obs_ass, bodyIndex) == obs_assimilated)
7363 if (.not. llok) cycle HEADER
7364 obsVarno = obs_bodyElem_i(obsData, obs_vnm, bodyIndex)
7365 if (obsVarno /= bufr_sst) cycle HEADER
7366 codeType = obs_headElem_i(obsData, obs_ity, headerIndex)
7367 if (codeType /= codtyp_get_codtyp('satob')) cycle HEADER
7368 if (trim(obs_elem_c(obsData, 'STID' , headerIndex)) /= trim(dataSet)) cycle HEADER
7369
7370 ! find time difference
7371 obsDate = obs_headElem_i(obsData, obs_dat, headerIndex)
7372 obsTime = obs_headElem_i(obsData, obs_etm, headerIndex)
7373 call tim_getStepObsIndex(obsStepIndex_r8, tim_getDatestamp(), obsDate, obsTime, numTimesteps)
7374 obsStepIndex = nint(obsStepIndex_r8)
7375
7376 ! reject observations that are outside the assimilation window
7377 if (obsStepIndex < 1 .or. obsStepIndex > numTimesteps) then
7378 valid(headerIndex) = .false.
7379 cycle HEADER
7380 end if
7381
7382 if (numTimesteps == 1) then
7383 delMinutes = abs(nint(60.0 * tim_windowsize * abs(real(obsStepIndex) - obsStepIndex_r8)))
7384 else
7385 delMinutes = abs(nint(60.0 * tim_windowsize / (numTimesteps - 1) * &
7386 abs(real(obsStepIndex) - obsStepIndex_r8)))
7387 end if
7388
7389 ! check time window
7390 if (delMinutes > deltmax) then
7391 valid(headerIndex) = .false.
7392 cycle HEADER
7393 end if
7394
7395 obsFlag = obs_bodyElem_i(obsData, obs_flg, bodyIndex)
7396 obsVarno = obs_bodyElem_i(obsData, obs_vnm, bodyIndex)
7397
7398 if (btest(obsFlag, 9)) cycle HEADER
7399
7400 obsSST(headerIndex) = obs_bodyElem_r(obsData, obs_var, bodyIndex)
7401
7402 ! obs lat and lon in degrees
7403 obsLon = obs_headElem_r(obsData, obs_lon, headerIndex) * MPC_DEGREES_PER_RADIAN_R8
7404 obsLat = obs_headElem_r(obsData, obs_lat, headerIndex) * MPC_DEGREES_PER_RADIAN_R8
7405 ! latitude index
7406 deltaLat = abs(latGrid(1) - obsLat)
7407 obsLatIndex = 1
7408 do latIndex = 2, hco_thinning%nj
7409 if (abs(latGrid(latIndex) - obsLat) < deltaLat) then
7410 deltaLat = abs(latGrid(latIndex) - obsLat)
7411 deltaLatCell = abs(latGrid(latIndex) - latGrid(latIndex - 1))
7412 obsLatIndex = latIndex
7413 end if
7414 end do
7415
7416 ! longitude index
7417 deltaLon = abs(lonGrid(1) - obsLon)
7418 obsLonIndex = 1
7419 do lonIndex = 2, hco_thinning%ni
7420 if (abs(lonGrid(lonIndex) - obsLon) < deltaLon) then
7421 deltaLon = abs(lonGrid(lonIndex) - obsLon)
7422 deltaLonCell = abs(lonGrid(lonIndex) - lonGrid(lonIndex - 1))
7423 obsLonIndex = lonIndex
7424 end if
7425 end do
7426
7427 obsLatIndexVec(headerIndex) = obsLatIndex
7428 obsLonIndexVec(headerIndex) = obsLonIndex
7429 obsTimeIndexVec(headerIndex) = obsStepIndex
7430 obsDistance = sqrt(deltaLon**2 + deltaLat**2)
7431 sizeGridCell = sqrt(deltaLonCell**2 + deltaLatCell**2)
7432
7433 ! reject data that are farther than the given fraction of the size of grid cell
7434 if (obsDistance > sizeGridCell * fractionGridCell) valid(headerIndex) = .false.
7435
7436 end do HEADER
7437
7438 ! Make all inputs to the following tests mpiglobal
7439 call rpn_comm_allgather(valid , numHeaderMaxMpi, 'mpi_logical', &
7440 validMpi , numHeaderMaxMpi, 'mpi_logical', 'grid', ierr)
7441 call rpn_comm_allgather(obsLatIndexVec , numHeaderMaxMpi, 'mpi_integer', &
7442 obsLatIndexMpi , numHeaderMaxMpi, 'mpi_integer', 'grid', ierr)
7443 call rpn_comm_allgather(obsLonIndexVec , numHeaderMaxMpi, 'mpi_integer', &
7444 obsLonIndexMpi , numHeaderMaxMpi, 'mpi_integer', 'grid', ierr)
7445 call rpn_comm_allgather(obsTimeIndexVec, numHeaderMaxMpi, 'mpi_integer', &
7446 obsTimeIndexMpi, numHeaderMaxMpi, 'mpi_integer', 'grid', ierr)
7447 call rpn_comm_allgather(obsSST , numHeaderMaxMpi, 'mpi_real4' , &
7448 obsSSTMpi , numHeaderMaxMpi, 'mpi_real4' , 'grid', ierr)
7449
7450 TIMESTEP: do stepIndex = 1, numTimesteps
7451
7452 dataGrid(:,:)%numObs = 0
7453 ! Computation of number of data inside each grid cell
7454 do headerIndex = 1, numHeaderMaxMpi * mmpi_nprocs
7455 if (.not. validMpi(headerIndex)) cycle
7456 if (obsTimeIndexMpi(headerIndex) /= stepIndex) cycle
7457 latIndex = obsLatIndexMpi(headerIndex)
7458 lonIndex = obsLonIndexMpi(headerIndex)
7459 dataGrid(latIndex, lonIndex)%numObs = dataGrid(latIndex, lonIndex)%numObs + 1
7460 end do
7461
7462 ! Allocation of vector data inside each grid cell
7463 do lonIndex = 1, hco_thinning%ni
7464 do latIndex = 1, hco_thinning%nj
7465 allocate(dataGrid(latIndex, lonIndex)%dataVec(dataGrid(latIndex, lonIndex)%numObs))
7466 allocate(dataGrid(latIndex, lonIndex)%headerIndex(dataGrid(latIndex, lonIndex)%numObs))
7467 end do
7468 end do
7469
7470 ! Fill out vectors of data and header indexes inside each grid cell
7471 dataGrid(:,:)%numObs = 0 ! to reuse it as a counter that should be differentiated for each lat-lon cell
7472 do headerIndex = 1, numHeaderMaxMpi * mmpi_nprocs
7473 if (.not. validMpi(headerIndex)) cycle
7474 if (obsTimeIndexMpi(headerIndex) /= stepIndex) cycle
7475 latIndex = obsLatIndexMpi(headerIndex)
7476 lonIndex = obsLonIndexMpi(headerIndex)
7477 dataGrid(latIndex, lonIndex)%numObs = dataGrid(latIndex, lonIndex)%numObs + 1
7478 dataGrid(latIndex, lonIndex)%dataVec(dataGrid(latIndex, lonIndex)%numObs) = obsSSTMpi(headerIndex)
7479 dataGrid(latIndex, lonIndex)%headerIndex(dataGrid(latIndex, lonIndex)%numObs) = headerIndex
7480 end do
7481
7482 ! Compute median inside each grid cell and keep only this observation, rejecting all the others
7483 do lonIndex = 1, hco_thinning%ni
7484 do latIndex = 1, hco_thinning%nj
7485 if(dataGrid(latIndex, lonIndex)%numObs <= 1) cycle
7486 medianIndex = utl_medianIndex(dataGrid(latIndex, lonIndex)%dataVec(:))
7487 validMpi(dataGrid(latIndex, lonIndex)%headerIndex(:)) = .false.
7488 validMpi(dataGrid(latIndex, lonIndex)%headerIndex(medianIndex)) = .true.
7489 end do
7490 end do
7491
7492 ! Deallocation of vector data inside each grid cell
7493 do lonIndex = 1, hco_thinning%ni
7494 do latIndex = 1, hco_thinning%nj
7495 deallocate(dataGrid(latIndex, lonIndex)%dataVec)
7496 deallocate(dataGrid(latIndex, lonIndex)%headerIndex)
7497 end do
7498 end do
7499
7500 end do TIMESTEP
7501
7502 ! Update local copy of valid from global mpi version
7503 headerIndexBeg = 1 + mmpi_myid * numHeaderMaxMpi
7504 headerIndexEnd = headerIndexBeg + numHeaderMaxMpi - 1
7505 valid(:) = validMpi(headerIndexBeg:headerIndexEnd)
7506
7507 deallocate(dataGrid)
7508
7509 write(*,*)
7510 write(*,*) 'thn_satelliteSSTByGridCell: results for ', trim(dataSet), ' data ****************'
7511 write(*,'(a30,i10)') ' Number of obs initially: ', satSSTCountMpi
7512 write(*,'(a30,i10)') ' Number of obs kept : ', count(validMpi(:))
7513 write(*,'(a30,i10)') ' Number of obs rejected : ', satSSTCountMpi - count(validMpi(:))
7514 write(*,*)
7515
7516 ! Modify the flags for rejected observations
7517 do headerIndex = 1, numHeader
7518 ! skip observation if we're not supposed to consider it
7519 bodyIndex = obs_headElem_i(obsData, obs_rln, headerIndex)
7520 llok = (obs_bodyElem_i(obsData, obs_ass, bodyIndex) == obs_assimilated)
7521 if (.not. llok) cycle
7522 obsVarno = obs_bodyElem_i(obsData, obs_vnm, bodyIndex)
7523 if (obsVarno /= bufr_sst) cycle
7524 codeType = obs_headElem_i(obsData, obs_ity, headerIndex)
7525 if (codeType /= codtyp_get_codtyp('satob')) cycle
7526 if (trim(obs_elem_c(obsData, 'STID' , headerIndex)) /= trim(dataSet)) cycle
7527
7528 if (.not. valid(headerIndex)) then
7529 obsFlag = obs_bodyElem_i(obsData, obs_flg, bodyIndex)
7530 call obs_bodySet_i(obsData, obs_flg, bodyIndex, ibset(obsFlag, 11))
7531 end if
7532 end do
7533
7534 ! Deallocation
7535 deallocate(valid)
7536 deallocate(validMpi)
7537 deallocate(latGrid)
7538 deallocate(lonGrid)
7539 deallocate(obsTimeIndexVec)
7540 deallocate(obsTimeIndexMpi)
7541 deallocate(obsLatIndexVec)
7542 deallocate(obsLatIndexMpi)
7543 deallocate(obsLonIndexVec)
7544 deallocate(obsLonIndexMpi)
7545 deallocate(obsSST)
7546 deallocate(obsSSTMpi)
7547
7548 write(*,*)
7549 write(*,*) 'thn_satelliteSSTByGridCell: thinning for ', trim(dataSet) ,' data completed.'
7550 write(*,*)
7551
7552 end subroutine thn_satelliteSSTByGridCell
7553
7554end module thinning_mod
