1module burpRead_mod
2 ! MODULE burpRead_mod (prefix='brpr' category='3. Observation input/output')
3 !
4 !:Purpose: To read and update BURP observation files. Data is stored in
5 ! obsSpaceData object.
6 !
7
8 use codePrecision_mod
9 use bufr_mod
10 use burp_module
11 use ObsSpaceData_mod
12 use MathPhysConstants_mod
13 use earthConstants_mod
14 use utilities_mod
15 use obsUtil_mod
16 use obsVariableTransforms_mod
17 use obsFilter_mod
18 use tovsNL_mod
19 use kdTree2_mod
20 use codtyp_mod
21
22 implicit none
23 save
24
25 private
26
27 ! public procedures
28 public :: brpr_readBurp, brpr_updateBurp, brpr_getTypeResume, brpr_addCloudParametersandEmissivity
29 public :: brpr_addElementsToBurp, brpr_updateMissingObsFlags, brpr_burpClean
30
31 integer, parameter :: maxItems = 20
32 integer, parameter :: maxElements = 20
33 ! Namelist variables
34 INTEGER :: NELEMS ! MUST NOT BE INCLUDED IN NAMELIST!
35 INTEGER :: NELEMS_SFC ! MUST NOT BE INCLUDED IN NAMELIST!
36 INTEGER :: NELEMS_GPS ! MUST NOT BE INCLUDED IN NAMELIST!
37 INTEGER :: LISTE_ELE_GPS(maxElements) ! list of bufr element ids to read
38 INTEGER :: BLISTELEMENTS(maxElements) ! list of bufr element ids to read
39 INTEGER :: BLISTELEMENTS_SFC(maxElements) ! list of bufr element ids to read
40 INTEGER :: BN_ITEMS ! MUST NOT BE INCLUDED IN NAMELIST!
41 CHARACTER(len=3) :: BITEMLIST(maxItems) ! list of blocks to include in updated file (e.g. 'OMP','OMA')
42 CHARACTER(len=7) :: TYPE_RESUME = 'UNKNOWN' ! can be 'BGCKALT', 'POSTALT' or 'DERIALT'
43 LOGICAL :: ENFORCE_CLASSIC_SONDES ! choose to ignore high-res raobs lat/lon/time information
44 LOGICAL :: UA_HIGH_PRECISION_TT_ES ! choose to use higher precision elements for raobs
45 LOGICAL :: UA_FLAG_HIGH_PRECISION_TT_ES ! choose to read flag of higher precision elements for raobs
46 LOGICAL :: READ_QI_GA_MT_SW ! read additional QC-related elements for AMV obs
47 logical :: addBtClearToBurp ! choose to write clear-sky radiance to file in all-sky mode
48 integer :: clwFgElementId ! bufr element id of cloud liquid water from background in all-sky mode
49 integer :: siFgElementId ! bufr element id of scattering index in all-sky mode
50 integer :: btClearElementId ! bufr element id of clear-sky radiance in all-sky mode
51
52contains
53
54 character(len=7) function brpr_getTypeResume
55 brpr_getTypeResume=TYPE_RESUME
56 end function brpr_getTypeResume
57
58
59 subroutine brpr_updateBurp(obsdat,familytype,brp_file,filenumb)
60 !
61 !:Purpose: To update variables relative to assimilation in burp files
62
63 !***************************************************************************
64 !
65 ! WHEN SEARCHING FOR A SPECIFIC BLOCK BY ITS BTYP, VALUES OF
66 ! BIT 0 TO 3 ARE IRRELEVANT WHILE BIT 4 IS 0 FOR GLOBAL AND 1
67 ! FOR REGIONAL MODEL. HERE, WE SEARCH BLOCK BY THEIR FIRST
68 ! 10 BITS (BIT 5 TO 14).
69 !
70 !***************************************************************************
71
72 implicit none
73
74 ! Arguments:
75 type (struct_obs), intent(inout) :: obsdat ! obsSpaceData object
76 character(len=*), intent(in) :: FAMILYTYPE ! type of family('UA','SF','AI','SW','TO', ...)
77 character(len=*), intent(in) :: BRP_FILE ! name of burp file
78 integer, intent(in) :: FILENUMB
79
80 ! Locals:
81 type(kdtree2), pointer :: tree
82 integer, parameter :: maxNumSearch = 100
83 integer :: numFoundSearch, bodyCount, resultIndex
84 type(kdtree2_result) :: searchResults(maxNumSearch)
85 real(kdkind) :: maxRadius = 0.000001d0
86 real(kdkind) :: refPosition(2)
87 real(kdkind), allocatable :: PPPandVNM(:,:)
88 integer, allocatable :: bodyIndexList(:)
89
90 INTEGER, PARAMETER :: NBLOC_LIST = 9
91 INTEGER :: LNMX
92
93 TYPE(BURP_FILE) :: FILE_IN
94 TYPE(BURP_RPT) :: RPT_IN,CP_RPT
95 TYPE(BURP_BLOCK) :: BLOCK_IN,BLOCK_OMA,BLOCK_OMP,BLOCK_OER,BLOCK_FGE,BLOCK_FLG,BLOCK_FSO
96 TYPE(BURP_BLOCK) :: BLOCK_OMA_SFC,BLOCK_OMP_SFC,BLOCK_OER_SFC,BLOCK_FGE_SFC,BLOCK_FLG_SFC,BLOCK_FSO_SFC
97 TYPE(BURP_BLOCK) :: Block_FLG_CP,BLOCK_OBS_MUL_CP,BLOCK_MAR_MUL_CP,BLOCK_OBS_SFC_CP,BLOCK_MAR_SFC_CP
98 TYPE(BURP_BLOCK) :: BLOCK_GEN, BLOCK_OBS_BND,BLOCK_MAR_BND,BLOCK_ORB
99
100 CHARACTER(LEN=5) :: FAMILYTYPE2
101 CHARACTER(LEN=9) :: OPT_MISSING
102 integer :: BTYP,BFAM,BTYP10,BTYP10FLG_uni,BTYP10obs_uni
103 integer :: BTYP10DES,BTYP10INF,BTYP10OBS,BTYP10FLG
104
105 integer :: NB_RPTS,REF_RPT,REF_BLK,COUNT
106 INTEGER, ALLOCATABLE :: ADDRESS(:)
107 real :: VCOORD
108
109 integer :: NBELE,NVALE,NTE, numHeader
110 integer :: J,JJ,K,KK,KI,IL,Jo,ERROR,OBSN,KOBSN,ITEM
111 integer :: IND_ELE,IND_VCOORD
112 integer :: IND_ELE_MAR,IND_ELEU,IND_ELEF,IND_ELE_stat,IND_ELE_tth,IND_ELE_esh
113 integer :: IND_LAT,IND_LON,IND_TIME,IND_obsClear
114
115 integer :: vcord_type(10),SUM
116 real :: ELEVFACT
117 integer :: status ,idtyp,lati,long,dx,dy,elev, &
118 drnd,date_h,hhmm_h,oars,runn
119 integer :: IND055200
120
121 integer :: iele,NELE,NELE_SFC,NVAL,NT,NELE_INFO
122 integer :: bit_alt,btyp_offset,btyp_offset_uni
123 integer :: BKNAT,BKTYP,BKSTP
124 character(len = 5) :: BURP_TYP
125 CHARACTER(LEN=9) :: STNID,STN_RESUME,STID
126 LOGICAL :: HIRES,HIPCS
127 integer :: NDATA_SF
128 integer :: IFLAG
129
130 integer :: OBS_START,SAVE_OBS
131 integer :: IL_INDEX,IRLN,INLV,LK,VNM
132 real :: OBS,OMA,OMP,OER,FSO,FGE,OBSVA,CONVFACT, BCOR, obsClear
133 integer :: FLG,TIME,ILEMU,ILEMV,ILEMD,VCOORD_POS,ILEMZBCOR,ILEMTBCOR,ILEMHBCOR
134
135 integer :: BLOCK_LIST(NBLOC_LIST),bl
136
137 integer :: new_bktyp,post_bit,STATUS_HIRES,BIT_STATUS,FILEN
138 LOGICAL :: REGRUP,WINDS,OMA_SFC_EXIST,OMA_ALT_EXIST
139
140 integer :: LISTE_ELE(maxElements),LISTE_ELE_SFC(maxElements),is_in_list
141
142 LOGICAL :: LBLOCK_OER_CP, LBLOCK_FGE_CP
143 TYPE(BURP_BLOCK) :: BLOCK_OER_CP, BLOCK_FGE_CP
144 logical :: FSOFound, convertOnRead
145 logical :: btClearElementFound
146
147 ! ensure kdtrees object is null
148 nullify(tree)
149
150 STATUS_HIRES = 0
151 FAMILYTYPE2= 'SCRAP'
152 vcord_type(:)=-1
153 vcord_type(1)=0
154 NELE_INFO=1
155 NELE_SFC=0
156 NELE=0
157 NELEMS=0
158 NELEMS_SFC=0
159 NELEMS_GPS=0
160 ILEMU=11003
161 ILEMV=11004
162 ILEMD=11001
163 ILEMZBCOR=15234 ! bcor element for GP ZTD observations
164 ILEMTBCOR=12204 ! bcor element for altitude TT observations
165 ILEMHBCOR=12243 ! bcor element for altitude ES observations
166 ELEVFACT=0.
167 ENFORCE_CLASSIC_SONDES=.false.
168 UA_HIGH_PRECISION_TT_ES=.false.
169 UA_FLAG_HIGH_PRECISION_TT_ES=.false.
170 LNMX=100000
171 LISTE_ELE_SFC(:)=-1
172 LISTE_ELE(:)=-1
173 SELECT CASE(trim(FAMILYTYPE))
174 CASE('UA')
175 BURP_TYP='multi'
176 vcord_type(1)=7004
177
178 call BRPACMA_NML('namburp_filter_sfc')
179
180 FAMILYTYPE2= 'UA'
181 ENFORCE_CLASSIC_SONDES=.false.
182 call BRPACMA_NML('namburp_filter_conv')
183 WINDS=.TRUE.
184 CASE('AI')
185 BURP_TYP='uni'
186 vcord_type(1)=7004
187
188 call BRPACMA_NML('namburp_filter_conv')
189 WINDS=.TRUE.
190 CASE('AL')
191 BURP_TYP='uni'
192 vcord_type(1)=7071
193
194 call BRPACMA_NML('namburp_filter_conv')
195 WINDS=.TRUE.
196 CASE('SW')
197 BURP_TYP='uni'
198 vcord_type(1)=7004
199
200 call BRPACMA_NML('namburp_filter_conv')
201 WINDS=.TRUE.
202 vcord_type(2)=-1
203 CASE('SF')
204 BURP_TYP='uni'
205 vcord_type(1)=0
206
207 call BRPACMA_NML('namburp_filter_sfc')
208
209 FAMILYTYPE2= 'SFC'
210 WINDS=.TRUE.
211 IF (trim(FAMILYTYPE) == 'GP') WINDS=.FALSE.
212 ILEMU=11215
213 ILEMV=11216
214 CASE('GP')
215 BURP_TYP='uni'
216 vcord_type(1)=0
217
218 call BRPACMA_NML('namburp_filter_gp')
219
220 FAMILYTYPE2= 'SFC'
221 WINDS=.FALSE.
222 CASE('SC')
223 BURP_TYP='uni'
224 call BRPACMA_NML('namburp_filter_sfc')
225
226 FAMILYTYPE2='SCAT'
227 WINDS=.TRUE.
228 ILEMU=11215
229 ILEMV=11216
230 CASE('PR')
231 BURP_TYP='multi'
232 vcord_type(1)=7006
233 ELEVFACT=1.
234
235 call BRPACMA_NML('namburp_filter_conv')
236 WINDS=.TRUE.
237 CASE('RO')
238 BURP_TYP='multi'
239 vcord_type(1)=7007
240 vcord_type(2)=7040
241
242 call BRPACMA_NML('namburp_filter_conv')
243 WINDS=.FALSE.
244 NELE_INFO=16
245 CASE('TO')
246 BURP_TYP='multi'
247 vcord_type(1)=5042
248 vcord_type(2)=2150
249
250 CALL BRPACMA_NML('namburp_filter_tovs')
251
252 if ( addBtClearToBurp ) then
253 btClearElementFound = .false.
254
255 elementLoop: do iele = 1, NELEMS
256 if ( BLISTELEMENTS(iele) == btClearElementId ) then
257 btClearElementFound = .true.
258 exit elementLoop
259 end if
260 end do elementLoop
261
262 if ( .not. btClearElementFound ) &
263 call utl_abort('brpr_updateBurp: btClearElement element should be in namelist.')
264 end if
265
266 NELE_INFO=24
267 WINDS=.FALSE.
268 CASE('CH')
269 BURP_TYP='multi' ! Both 'multi' and 'uni' are possible for this family.
270 ! 'uni' level data are assumed not to have any accompanynig vertical
271 ! coordinate element in addition to having only one level.
272 vcord_type(1:8) = (/7004,7204,7006,7007,5042,2150,2071,0/) ! 0 must be at end.
273
274 call BRPACMA_NML('namburp_filter_chm_sfc')
275 WINDS=.FALSE.
276
277 FAMILYTYPE2='CH'
278 call BRPACMA_NML('namburp_filter_chm')
279 CASE default
280 call utl_abort('brpr_updateBurp: unknown familyType : ' // trim(familyType))
281 END SELECT
282
283 NELE=NELEMS
284 LISTE_ELE(1:NELE)=BLISTELEMENTS(1:NELE)
285 if (trim(FAMILYTYPE) == 'GP') then
286 ! for GP ignore BLISTELEMENTS_SFC, and use instead LISTE_ELE_GPS
287 NELE_SFC = NELEMS_GPS
288 LISTE_ELE_SFC(1:NELE_SFC)=LISTE_ELE_GPS(1:NELE_SFC)
289 else
290 NELE_SFC = NELEMS_SFC
291 LISTE_ELE_SFC(1:NELE_SFC)=BLISTELEMENTS_SFC(1:NELE_SFC)
292 end if
293 if(NELE > 0)write(*,*) ' LISTE_ELE =',LISTE_ELE
294 if(NELE_SFC > 0)write(*,*) ' LISTE_ELE_SFC =',LISTE_ELE_SFC
295
296 TYPE_RESUME='POSTALT'
297 call BRPACMA_NML('namburp_update')
298 write(*,*) ' BN_ITEMS =',BN_ITEMS
299 write(*,*) ' ITEMS TO ADD IN BURP FILE REPORTS =', BITEMLIST(1:BN_ITEMS)
300 write(*,*) ' BTYP OF UPDATED BURP FILE=', TYPE_RESUME
301
302 ! check if there is FSO calculation
303 FSOFound = .false.
304 do item = 1, BN_ITEMS
305 if ( BITEMLIST(item) == 'FSO' ) FSOFound = .true.
306 end do
307
308 SELECT CASE( trim(TYPE_RESUME))
309 CASE("BGCKALT", "POSTALT")
310 BIT_STATUS = 12
311 CASE("DERIALT")
312 BIT_STATUS = 11
313 END SELECT
314
315 if (trim(BURP_TYP) == 'uni') then
316 btyp_offset=256
317 else
318 btyp_offset=0
319 end if
320
321 if (trim(familytype) == 'AL') then
322 btyp_offset=255
323 end if
324
325 if ( TRIM(FAMILYTYPE2) == 'SCAT') then
326 btyp_offset= 0
327 btyp_offset_uni= 256 +0
328 elseif ( TRIM(FAMILYTYPE2) == 'SFC') then
329 btyp_offset= 0
330 btyp_offset_uni= 256 +32
331 elseif ( TRIM(FAMILYTYPE2) == 'UA') then
332 btyp_offset_uni= 256 +32
333 elseif ( TRIM(FAMILYTYPE2) == 'CH') then
334 btyp_offset_uni= 256
335 else
336 btyp_offset_uni= -999 !set to -999 when not used
337 end if
338
339
340 write(*,*) '----------------------------------------------------'
341 write(*,*) '----------- BEGIN brpr_updateBurp ------------'
342 write(*,*) 'FAMILYTYPE =',FAMILYTYPE
343 write(*,*) 'BURP_TYP btyp_offset =',BURP_TYP, btyp_offset
344 write(*,*) 'BURP_TYP btyp_offset_uni=',BURP_TYP, btyp_offset_uni
345 write(*,*) '----------------------------------------------------'
346
347
348 ! initialisation
349
350 SUM=0
351 opt_missing = 'MISSING'
352
353
354 call BURP_Set_Options( &
355 & REAL_OPTNAME = opt_missing, &
356 & REAL_OPTNAME_VALUE = MPC_missingValue_R4, &
357 & CHAR_OPTNAME = 'MSGLVL', &
358 & CHAR_OPTNAME_VALUE = 'FATAL', &
359 & IOSTAT = error )
360 call handle_error(error, "brpr_updateBurp: BURP_Set_Options")
361
362 call BURP_Init(File_in ,IOSTAT=error)
363 call handle_error(error, "brpr_updateBurp: BURP_Init FILE_in")
364
365 call BURP_Init(Rpt_in,CP_RPT)
366 call BURP_Init(Block_in)
367 call BURP_Init(BLOCK_OMA)
368 call BURP_Init(BLOCK_OMP)
369 call BURP_Init(BLOCK_OER)
370 call BURP_Init(BLOCK_FGE)
371 call BURP_Init(BLOCK_FSO)
372 call BURP_Init(BLOCK_OMA_SFC)
373 call BURP_Init(BLOCK_OMP_SFC)
374 call BURP_Init(BLOCK_OER_SFC)
375 call BURP_Init(BLOCK_FGE_SFC)
376 call BURP_Init(BLOCK_FSO_SFC)
377 call BURP_Init(BLOCK_FLG_SFC)
378
379 call BURP_Init(BLOCK_FLG)
380 call BURP_Init(Block_FLG_CP)
381
382 call BURP_Init(BLOCK_OBS_MUL_CP)
383 call BURP_Init(BLOCK_MAR_MUL_CP)
384
385 call BURP_Init(BLOCK_OBS_SFC_CP)
386 call BURP_Init(BLOCK_MAR_SFC_CP)
387
388 Call BURP_Init(BLOCK_GEN)
389 Call BURP_Init(BLOCK_OBS_BND)
390 Call BURP_Init(BLOCK_MAR_BND)
391 Call BURP_Init(BLOCK_ORB)
392
393 ! opening file
394 ! ------------
395 write(*,*) 'OPENING BURP FILE FOR UPDATE = ', trim(brp_file)
396
397 call BURP_New(File_in, FILENAME = brp_file, &
398 & MODE = FILE_ACC_APPEND, &
399 & IOSTAT = error )
400 call handle_error(error, "brpr_updateBurp: BURP_new error while opening burp file " // trim(brp_file))
401
402 ! obtain input burp file number of reports
403 ! ----------------------------------------
404 call BURP_Get_Property(File_in, NRPTS=nb_rpts)
405 call BURP_Init(Rpt_in)
406
407 write(*,*) '-----------------------------------------'
408 write(*,*) 'IOSTAT =',error
409 write(*,*) 'NUMBER OF REPORTS IN FILE = ',nb_rpts
410 write(*,*) '-----------------------------------------'
411
412 ! scan input burp file to get all reports address
413 ! -----------------------------------------------
414
415 Allocate(address(nb_rpts))
416 address(:) = 0
417 count = 0
418 ref_rpt = 0
419 bit_alt = 0
420 stn_resume='NOT_FOUND'
421
422 do
423 ref_rpt = BURP_Find_Report(File_in, &
424 & REPORT = Rpt_in, &
425 & SEARCH_FROM = ref_rpt, &
426 & IOSTAT = error)
427 call handle_error(error, "brpr_updateBurp: BURP_Find_Report #1")
428 call burp_get_property(Rpt_in, STNID = stnid )
429 IF ( stnid(1:2) == ">>" ) then
430 STN_RESUME=stnid
431 SELECT CASE(stnid)
432 CASE(">>BGCKALT", ">>POSTALT")
433 bit_alt=1
434 CASE(">>DERIALT")
435 bit_alt=2
436 END SELECT
437 END IF
438
439 if (ref_rpt < 0) Exit
440 if (count == nb_rpts) then
441 write(*,*) 'brpr_updateBurp: ERROR: count = nb_rpts:',count,nb_rpts
442 exit
443 end if
444 count = count + 1
445 address(count) = ref_rpt
446 end do
447
448 if (stn_resume == 'NOT_FOUND') then
449 write(*,*) 'brpr_updateBurp: WARNING: No RESUME record found in this file, ' // &
450 'check if found during reading of all files'
451 ! try to get value from previously read file
452 if ( type_resume /= 'UNKNOWN' ) then
453 stn_resume = '>>' // type_resume
454 SELECT CASE(stn_resume)
455 CASE(">>BGCKALT", ">>POSTALT")
456 bit_alt=1
457 CASE(">>DERIALT")
458 bit_alt=2
459 CASE DEFAULT
460 write(*,*) 'brpr_updateBurp: WARNING: Unknown RESUME record found, assume BGCKALT'
461 stn_resume = '>>BGCKALT'
462 bit_alt=1
463 END SELECT
464 else
465 write(*,*) 'brpr_updateBurp: WARNING: No file read has RESUME record, assume BGCKALT'
466 stn_resume = '>>BGCKALT'
467 bit_alt=1
468 end if
469 end if
470
471 write(*,'(a9,1x,a16,1x,i2)' )STN_RESUME,' bit_alt==== > ',bit_alt
472
473 BTYP10obs = 291 -btyp_offset
474 BTYP10obs_uni = 291 -btyp_offset_uni
475 if (bit_alt == 2) btyp10obs = BTYP10obs - 2
476 if (bit_alt == 2) btyp10obs_uni = BTYP10obs_uni - 2
477
478 BTYP10flg = 483 -btyp_offset
479 BTYP10flg_uni = 483 -btyp_offset_uni
480 if (bit_alt == 2) BTYP10flg = BTYP10flg - 2
481 if (bit_alt == 2) BTYP10flg_uni = BTYP10flg_uni - 2
482 BTYP10des = 160
483
484 BTYP10inf = 96
485
486 write(*, *) ' NUMBER OF VALID REPORTS IN FILE = ',count
487 write(*, *) ' BTYP10obs BTYP10obs_uni = ',BTYP10obs,BTYP10obs_uni
488
489 if ( count > 0 ) then
490
491 OBS_START=1
492 SAVE_OBS=1
493 DO Jo=1,obs_numHeader(obsdat)
494 filen= obs_headElem_i(obsdat,OBS_IDF,Jo)
495 if ( filen == filenumb) then
496 OBS_START=Jo
497 SAVE_OBS=Jo
498 exit
499 end if
500 END DO
501 write(*, *) ' FILE = ',trim(brp_file),' OBS_START= ',OBS_START
502
503 ! Create a new report.
504 ! The factor 12 before 'LNMX' is arbitrary.
505 ! We increase it from time to time as we encounter some
506 ! problems.
507 call BURP_New(Cp_rpt, ALLOC_SPACE=12*LNMX, IOSTAT=error)
508 call handle_error(error, "brpr_updateBurp: error while allocating Cp_rpt")
509
510 ! LOOP ON REPORTS
511 REPORTS: do kk = 1, count
512
513 call BURP_Get_Report(File_in, &
514 & REPORT = Rpt_in, &
515 & REF = address(kk), &
516 & IOSTAT = error)
517 call handle_error(error, "brpr_updateBurp: BURP_Get_Report #1")
518 call burp_get_property(Rpt_in, &
519 STNID = stnid ,TEMPS =hhmm_h,FLGS = status ,IDTYP =idtyp,LATI = lati &
520 ,LONG = long ,DX = dx ,DY = dy,ELEV=elev,DRND =drnd,DATE =date_h &
521 ,OARS =oars,RUNN=runn ,IOSTAT=error)
522 call handle_error(error, "brpr_updateBurp: burp_get_property #1")
523
524 IF ( stnid(1:2) == ">>" ) THEN
525 write(*,*) ' RESUME RECORD POSITION IN BURP FILE =',stnid,kk
526 call BURP_Copy_Header(TO=Cp_rpt,FROM=Rpt_in)
527 call BURP_Init_Report_Write(File_in,Cp_Rpt, IOSTAT=error)
528 call handle_error(error, "brpr_updateBurp: Burp_Init_Report_Write #1")
529 call BURP_Set_Property(Cp_Rpt,STNID =">>"//TYPE_RESUME)
530 call BURP_Delete_Report(File_in,Rpt_in, IOSTAT=error)
531 call handle_error(error, "brpr_updateBurp: BURP_Delete_Report #1")
532 call BURP_Write_Report(File_in,Cp_rpt, IOSTAT=error)
533 call handle_error(error, "brpr_updateBurp: BURP_Write_report #1")
534 cycle REPORTS
535 ELSE
536 !write(*,*) ' UPDATING STN IN BURP FILE =', TRIM(FAMILYTYPE),KK,stnid,lati,LONG,dx,DY,elev,idtyp
537 END IF
538 call BURP_Copy_Header(TO=Cp_rpt,FROM=Rpt_in)
539 call BURP_Init_Report_Write(File_in,Cp_Rpt, IOSTAT=error)
540 call handle_error(error, "brpr_updateBurp: Burp_Init_Report_Write #2")
541
542 ! FIRST LOOP ON BLOCKS
543
544 ref_blk = 0
545
546 LBLOCK_OER_CP=.false.
547 LBLOCK_FGE_CP=.false.
548 HIRES=.FALSE.
549 HIPCS=.FALSE.
550 REGRUP=.false.
551 NDATA_SF=-1
552 !WRITE(*,*)' record number =',kk,' obs_start =',obs_start
553 BLOCK_LIST(:)=-1
554 BLOCKS0: do
555 ref_blk = BURP_Find_Block(Rpt_in, &
556 & BLOCK = Block_in, &
557 & SEARCH_FROM = ref_blk, &
558 & IOSTAT = error)
559 call handle_error(error, "brpr_updateBurp: BURP_Find_Block #1")
560
561 if (ref_blk < 0) EXIT BLOCKS0
562
563 call BURP_Get_Property(Block_in, &
564 & NELE = nbele, &
565 & NVAL = nvale, &
566 & NT = nte, &
567 & BFAM = bfam, &
568 & BTYP = btyp, &
569 & BKTYP = bktyp, &
570 & BKNAT = BKNAT, &
571 & BKSTP = BKSTP, &
572 & IOSTAT = error)
573 call handle_error(error, "brpr_updateBurp: BURP_Get_Property #2")
574 if(trim(familytype) == 'AL')then
575
576 ! Fudge the block type, because the data are simulated
577 if(btyp == 1024) then
578 btyp=1152
579 else if(btyp == 7168)then
580 btyp=7296
581 end if
582 end if
583
584 btyp10 = ishft(btyp,-5)
585 if ( btyp10 == BTYP10des ) then
586 Block_FLG_CP=BLOCK_IN
587 BLOCK_LIST(1)=BTYP
588 REGRUP=.TRUE.
589 elseif ( btyp10 == btyp10obs_uni .and. bkstp <= 4 ) then
590 BLOCK_OBS_SFC_CP=BLOCK_IN
591 BLOCK_LIST(2)=BTYP
592 NDATA_SF=0
593 elseif ( btyp10 == btyp10flg_uni .and. bkstp <= 4) then
594 BLOCK_MAR_SFC_CP=BLOCK_IN
595 BLOCK_LIST(3)=BTYP
596 elseif ( btyp10 == btyp10obs .and. bfam == 0 ) then
597 BLOCK_LIST(4)=BTYP
598 BLOCK_OBS_MUL_CP=BLOCK_IN
599 elseif ( btyp10 == btyp10flg ) then
600 BLOCK_LIST(5)=BTYP
601 BLOCK_MAR_MUL_CP=BLOCK_IN
602 elseif ( (btyp10 == btyp10inf) .or. (btyp10 - btyp10inf == 1) ) then
603 BLOCK_LIST(6) = BTYP
604 else if (trim(familytype) == 'RO' .and. bfam == 0 .and. btyp == 9217) then
605 BLOCK_LIST(7) = BTYP
606 BLOCK_OBS_BND = BLOCK_IN
607 else if (trim(familytype) == 'RO' .and. bfam == 0 .and. btyp == 15361) then
608 BLOCK_LIST(8) = BTYP
609 BLOCK_MAR_BND = BLOCK_IN
610 else if (trim(familytype) == 'RO' .and. bfam == 0 .and. btyp == 9220) then
611 BLOCK_LIST(9) = BTYP
612 BLOCK_ORB = BLOCK_IN
613 else
614 !WRITE(*, *)' POUR STATION bloc NON CONNU: ',STNID,ref_blk,bfam,familytype
615 end if
616 if (bfam == 10.and.bkstp == 14) then
617 LBLOCK_OER_CP=.true.
618 BLOCK_OER_CP=BLOCK_IN
619 else if (bfam == 10.and.bkstp == 15) then
620 LBLOCK_FGE_CP=.true.
621 BLOCK_FGE_CP=BLOCK_IN
622 end if
623 end do BLOCKS0
624 if ( TYPE_RESUME == 'POSTALT' .or. TYPE_RESUME == 'BGCKALT') THEN
625 post_bit=2
626 else
627 post_bit=0
628 end if
629
630 BLOCKS1: do bl=1,NBLOC_LIST
631
632 if( BLOCK_LIST(bl) < 0 ) cycle
633 if ( bl == 6 ) then
634 convertOnRead = .false.
635 else
636 convertOnRead = .true.
637 end if
638 ref_blk = BURP_Find_Block(Rpt_in, &
639 & BLOCK = Block_in, &
640 & BTYP = BLOCK_LIST(bl), &
641 & convert = convertOnRead, &
642 & IOSTAT = error)
643 call handle_error(error, "brpr_updateBurp: BURP_Find_Block #2")
644
645 if (ref_blk < 0) cycle BLOCKS1
646
647 if (bl == 6) then
648 BLOCK_GEN = BLOCK_IN
649 end if
650
651 call BURP_Get_Property(Block_in, &
652 & NELE = nbele, &
653 & NVAL = nvale, &
654 & NT = nte, &
655 & BFAM = bfam, &
656 & BTYP = btyp, &
657 & BKTYP = bktyp, &
658 & BKNAT = BKNAT, &
659 & IOSTAT = error)
660 call handle_error(error, "brpr_updateBurp: BURP_Get_Property #3")
661 if(trim(familytype) == 'AL')then
662
663 ! Fudge the block type, because the data are simulated
664 if(btyp == 1024) then
665 btyp=1152
666 else if(btyp == 7168)then
667 btyp=7296
668 end if
669 end if
670
671 ! observation block (btyp = 0100 100011X XXXX)
672 !======================================================
673 btyp10 = ishft(btyp,-5)
674 !======================================================
675
676 OBS_START=SAVE_OBS
677 !if ( btyp10 - btyp10obs_uni == 0 .and. bfam == 0 ) then
678 if ( bl == 2 ) then
679 OBSN=OBS_START
680
681 NDATA_SF=0
682 new_bktyp=bktyp
683 if ( post_bit > 0 ) then
684 new_bktyp=IBSET(bktyp,post_bit)
685
686 if ( FSOFound ) then
687 ! to correct the btyp of SC and UA surface observation for the block
688 ! of observation value and flag
689 call BURP_Set_Property(BLOCK_OBS_SFC_CP ,BKTYP =new_bktyp, BKSTP=0)
690 call BURP_Set_Property(BLOCK_MAR_SFC_CP ,BKTYP =new_bktyp, BKSTP=0)
691 else
692 call BURP_Set_Property(BLOCK_OBS_SFC_CP ,BKTYP =new_bktyp)
693 call BURP_Set_Property(BLOCK_MAR_SFC_CP ,BKTYP =new_bktyp)
694 end if
695
696 end if
697
698 il_index=0
699
700 !call BURP_Delete_BLOCK(Rpt_in,BLOCK=Block_in)
701
702 OMA_SFC_EXIST=.true.
703
704 if (.not.WINDS) then
705
706 call BURP_New(BLOCK_OMA_SFC,NELE =NBELE,NVAL=nvale,NT=NTE,bfam=12,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=10 &
707 ,IOSTAT = error)
708 call handle_error(error, "brpr_updateBurp: BURP_New BLOCK_OMA #1")
709 call BURP_New(BLOCK_OMP_SFC,NELE =NBELE,NVAL =nvale,NT=NTE,bfam=14,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=10 &
710 ,IOSTAT = error)
711 call handle_error(error, "brpr_updateBurp: BURP_New BLOCK_OMP_SFC #1")
712 call BURP_New(BLOCK_OER_SFC, NELE =NBELE, NVAL =nvale,NT=NTE,bfam=10,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=14 &
713 ,IOSTAT = error)
714 call handle_error(error, "brpr_updateBurp: BURP_New BLOCK_OER_SFC #1")
715 call BURP_New(BLOCK_FGE_SFC, NELE =NBELE, NVAL =nvale,NT=NTE,bfam=10,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=15 &
716 ,IOSTAT = error)
717 call handle_error(error, "brpr_updateBurp: BURP_New BLOCK_FGE_SFC #1")
718 call BURP_New(BLOCK_FSO_SFC, NELE =NBELE, NVAL =nvale,NT=NTE,bfam=1,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=2 &
719 ,IOSTAT = error)
720 call handle_error(error, "brpr_updateBurp: BURP_New BLOCK_FSO_SFC #1")
721 else
722
723 IND_eleu = BURP_Find_Element(Block_in, ELEMENT=11215)
724 IND_elef = BURP_Find_Element(Block_in, ELEMENT=11011)
725
726 call BURP_New(BLOCK_OMA_SFC,NELE =NBELE+2,NVAL=nvale,NT=NTE,bfam=12,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=10 &
727 ,IOSTAT = error)
728 call handle_error(error, "brpr_updateBurp: BURP_New BLOCK_OMA_SFC #2")
729 call BURP_New(BLOCK_OMP_SFC,NELE =NBELE+2,NVAL =nvale,NT=NTE,bfam=14,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=10 &
730 ,IOSTAT = error)
731 call handle_error(error, "brpr_updateBurp: BURP_New BLOCK_OMP_SFC #2")
732 call BURP_New(BLOCK_OER_SFC, NELE =NBELE+2, NVAL =nvale,NT=NTE,bfam=10,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=14 &
733 ,IOSTAT = error)
734 call handle_error(error, "brpr_updateBurp: BURP_New BLOCK_OER_SFC #2")
735 call BURP_New(BLOCK_FGE_SFC, NELE =NBELE+2, NVAL =nvale,NT=NTE,bfam=10,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=15 &
736 ,IOSTAT = error)
737 call handle_error(error, "brpr_updateBurp: BURP_New BLOCK_FGE_SFC #2")
738 call BURP_New(BLOCK_FSO_SFC, NELE =NBELE+2, NVAL =nvale,NT=NTE,bfam=1,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=2 &
739 ,IOSTAT = error)
740 call handle_error(error, "brpr_updateBurp: BURP_New BLOCK_FSO_SFC #2")
741 ILEMU = 11215
742 ILEMV = 11216
743 call BURP_Set_Element( BLOCK_OMA_SFC,NELE_IND = 1,ElEMENT=ILEMU,IOSTAT=error)
744 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OMA_SFC ILEMU")
745 call BURP_Set_Element( BLOCK_OMA_SFC,NELE_IND = 2,ElEMENT=ILEMV,IOSTAT=error)
746 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OMA_SFC ILEMV")
747
748 call BURP_Set_Element( BLOCK_OMP_SFC,NELE_IND = 1,ElEMENT=ILEMU,IOSTAT=error)
749 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OMP_SFC ILEMU")
750 call BURP_Set_Element( BLOCK_OMP_SFC,NELE_IND = 2,ElEMENT=ILEMV,IOSTAT=error)
751 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OMP_SFC ILEMV")
752
753 call BURP_Set_Element( BLOCK_OER_SFC,NELE_IND = 1,ElEMENT=ILEMU,IOSTAT=error)
754 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OER_SFC ILEMU")
755 call BURP_Set_Element( BLOCK_OER_SFC,NELE_IND = 2,ElEMENT=ILEMV,IOSTAT=error)
756 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OER_SFC ILEMV")
757
758 call BURP_Set_Element( BLOCK_FGE_SFC,NELE_IND = 1,ElEMENT=ILEMU,IOSTAT=error)
759 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_FGE_SFC ILEMU")
760 call BURP_Set_Element( BLOCK_FGE_SFC,NELE_IND = 2,ElEMENT=ILEMV,IOSTAT=error)
761 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_FGE_SFC ILEMV")
762
763 call BURP_Set_Element( BLOCK_FSO_SFC,NELE_IND = 1,ElEMENT=ILEMU,IOSTAT=error)
764 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_FSO_SFC ILEMU")
765 call BURP_Set_Element( BLOCK_FSO_SFC,NELE_IND = 2,ElEMENT=ILEMV,IOSTAT=error)
766 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_FSO_SFC ILEMV")
767
768 do k =1,nte
769 call BURP_Set_Rval(Block_OMA_SFC,NELE_IND =1,NVAL_IND =1,NT_IND = k,RVAL = MPC_missingValue_R4 )
770 call BURP_Set_Rval(Block_OMA_SFC,NELE_IND =2,NVAL_IND =1,NT_IND = k,RVAL = MPC_missingValue_R4 )
771 call BURP_Set_Rval(Block_OMP_SFC,NELE_IND =1,NVAL_IND =1,NT_IND = k,RVAL = MPC_missingValue_R4 )
772 call BURP_Set_Rval(Block_OMP_SFC,NELE_IND =2,NVAL_IND =1,NT_IND = k,RVAL = MPC_missingValue_R4 )
773 call BURP_Set_Rval(Block_OER_SFC,NELE_IND =1,NVAL_IND =1,NT_IND = k,RVAL = MPC_missingValue_R4 )
774 call BURP_Set_Rval(Block_OER_SFC,NELE_IND =2,NVAL_IND =1,NT_IND = k,RVAL = MPC_missingValue_R4 )
775 call BURP_Set_Rval(Block_FGE_SFC,NELE_IND =1,NVAL_IND =1,NT_IND = k,RVAL = MPC_missingValue_R4 )
776 call BURP_Set_Rval(Block_FGE_SFC,NELE_IND =2,NVAL_IND =1,NT_IND = k,RVAL = MPC_missingValue_R4 )
777 call BURP_Set_Rval(Block_FSO_SFC,NELE_IND =1,NVAL_IND =1,NT_IND = k,RVAL = MPC_missingValue_R4 )
778 call BURP_Set_Rval(Block_FSO_SFC,NELE_IND =2,NVAL_IND =1,NT_IND = k,RVAL = MPC_missingValue_R4 )
779 end do
780 il_index=2
781
782 IF (IND_eleu < 0 .and. IND_elef > 0) THEN
783 call BURP_Resize_Block(BLOCK_OBS_SFC_CP,ADD_NELE = 2 ,IOSTAT=error)
784 call handle_error(error, "brpr_updateBurp: BURP_Resize_Block #1")
785 call BURP_Set_Element( BLOCK_OBS_SFC_CP,NELE_IND = nbele+1,ElEMENT=ILEMU,IOSTAT=error)
786 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OBS_SFC_CP ILEMU")
787 call BURP_Set_Element( BLOCK_OBS_SFC_CP,NELE_IND = nbele+2,ElEMENT=ILEMV,IOSTAT=error)
788 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OBS_SFC_CP ILEMV")
789 do k =1,nte
790 call BURP_Set_Rval(Block_OBS_SFC_CP,NELE_IND =nbele+1,NVAL_IND =1,NT_IND = k,RVAL = MPC_missingValue_R4 )
791 call BURP_Set_Rval(Block_OBS_SFC_CP,NELE_IND =nbele+2,NVAL_IND =1,NT_IND = k,RVAL = MPC_missingValue_R4 )
792 end do
793
794 call BURP_Resize_Block(BLOCK_MAR_SFC_CP,ADD_NELE = 2 ,IOSTAT=error)
795 call handle_error(error, "brpr_updateBurp: BURP_Resize_Block #2")
796 call BURP_Set_Element( BLOCK_MAR_SFC_CP,NELE_IND = nbele+1,ElEMENT=ILEMU+200000,IOSTAT=error)
797 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_MAR_SFC_CP ILEMU")
798 call BURP_Set_Element( BLOCK_MAR_SFC_CP,NELE_IND = nbele+2,ElEMENT=ILEMV+200000,IOSTAT=error)
799 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_MAR_SFC_CP ILEMV")
800 do k =1,nte
801 call BURP_Set_tblval(Block_MAR_SFC_CP,NELE_IND =nbele+1,NVAL_IND =1,NT_IND = k,tblval = 0 )
802 call BURP_Set_tblval(Block_MAR_SFC_CP,NELE_IND =nbele+2,NVAL_IND =1,NT_IND = k,tblval = 0 )
803 end do
804 il_index=2
805 nbele=nbele +2
806 end if
807
808 end if
809
810!=========================================
811 REGRUP_SFC: do k=1,nte
812!=========================================
813 KOBSN=0
814
815!-------------------------------------------
816 elems_sfc: do IL = 1, NBELE
817!-------------------------------------------
818
819 iele=-1
820 iele=BURP_Get_Element(BLOCK_OBS_SFC_CP,INDEX =il,IOSTAT= error)
821 call handle_error(error, "brpr_updateBurp: BURP_GET_ELEMENT #1")
822
823 IND_ELE_MAR= BURP_Find_Element(Block_MAR_SFC_CP, ELEMENT=iele+200000)
824 if (IND_ele_mar <= 0 ) cycle
825
826 IND_ele = BURP_Find_Element(BLOCK_OBS_SFC_CP, ELEMENT=iele)
827 if (ind_ele==-1) call handle_error(IND_ELE, "brpr_updateBurp: element not found in BLOCK_OBS_SFC_CP")
828
829 if ( k == 1 ) then
830 if( OMA_SFC_EXIST ) then
831 if (iele /= ILEMU .and. iele /= ILEMV) then
832 il_index=il_index +1
833 call BURP_Set_Element (BLOCK_OMA_SFC,NELE_IND= il_index,ElEMENT=iele,IOSTAT=error)
834 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OMA_SFC")
835 call BURP_Set_Element (BLOCK_OMP_SFC,NELE_IND= il_index,ElEMENT=iele,IOSTAT=error)
836 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OMP_SFC")
837 call BURP_Set_Element (BLOCK_OER_SFC,NELE_IND= il_index,ElEMENT=iele,IOSTAT=error)
838 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OER_SFC")
839 call BURP_Set_Element (BLOCK_FGE_SFC,NELE_IND= il_index,ElEMENT=iele,IOSTAT=error)
840 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_FGE_SFC")
841 call BURP_Set_Element (BLOCK_FSO_SFC,NELE_IND= il_index,ElEMENT=iele,IOSTAT=error)
842 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_FSO_SFC")
843 end if
844 end if
845 end if
846
847 is_in_list=-1
848 is_in_list=FIND_INDEX(LISTE_ELE_SFC,iele)
849 if (is_in_list < 0 .and. iele /= ILEMU .and. iele /= ILEMV) cycle ELEMS_SFC
850 IND_ele_stat = BURP_Find_Element(BLOCK_OMA_SFC, ELEMENT=iele)
851 if (IND_ele_stat==-1) call handle_error(IND_ele_stat, "brpr_updateBurp: element not found in BLOCK_OMA_SFC #1")
852 call BURP_Set_Rval(Block_OMA_SFC, NELE_IND =IND_ELE_stat ,NVAL_IND =1 , NT_IND = k , RVAL = MPC_missingValue_R4)
853 call BURP_Set_Rval(Block_OMP_SFC, NELE_IND =IND_ELE_stat ,NVAL_IND =1 , NT_IND = k , RVAL = MPC_missingValue_R4)
854 call BURP_Set_Rval(Block_OER_SFC, NELE_IND =IND_ELE_stat ,NVAL_IND =1 , NT_IND = k , RVAL = MPC_missingValue_R4)
855 call BURP_Set_Rval(Block_FGE_SFC, NELE_IND =IND_ELE_stat ,NVAL_IND =1 , NT_IND = k , RVAL = MPC_missingValue_R4)
856 call BURP_Set_Rval(Block_FSO_SFC, NELE_IND =IND_ELE_stat ,NVAL_IND =1 , NT_IND = k , RVAL = MPC_missingValue_R4)
857
858 IFLAG = BURP_Get_Tblval(Block_MAR_SFC_CP,NELE_IND = IND_ele_mar,NVAL_IND = 1, NT_IND = k)
859 OBSVA = BURP_Get_Rval (Block_OBS_SFC_CP,NELE_IND = IND_ele ,NVAL_IND = 1, NT_IND = k)
860 if (OBSVA == MPC_missingValue_R4 .and. iele /= ILEMU .and. iele /= ILEMV ) cycle
861
862 if (OBSN > obs_numHeader(obsdat) ) then
863 write(*,*) ' debordement surface OBS_START=',OBS_START
864 cycle
865 end if
866
867 IRLN=obs_headElem_i(obsdat,OBS_RLN,OBSN )
868 INLV=obs_headElem_i(obsdat,OBS_NLV,OBSN )
869
870 IND_ELE_stat = BURP_Find_Element(BLOCK_OMA_SFC, ELEMENT=iele, IOSTAT=error)
871 if (IND_ELE_stat==-1) call handle_error(error, "brpr_updateBurp: element not found in BLOCK_OMA_SFC #2")
872 STID=obs_elem_c(obsdat,'STID',obs_start)
873 if ( STID /= stnid ) cycle
874
875 OBSDATA: do LK=IRLN,IRLN+INLV-1
876
877 VNM=obs_bodyElem_i(obsdat,OBS_VNM ,LK)
878 if( VNM == iele ) then
879 OBS=obs_bodyElem_r(obsdat,OBS_VAR,LK)
880 OMA=obs_bodyElem_r(obsdat,OBS_OMA ,LK)
881 OMP=obs_bodyElem_r(obsdat,OBS_OMP ,LK)
882 OER=obs_bodyElem_r(obsdat,OBS_OER ,LK)
883 FGE=obs_bodyElem_r(obsdat,OBS_HPHT,LK)
884 if ( obs_columnActive_RB(obsdat,OBS_FSO) ) then
885 FSO=obs_bodyElem_r(obsdat,OBS_FSO,LK)
886 else
887 FSO = MPC_missingValue_R4
888 end if
889 if ( obs_columnActive_RB(obsdat,OBS_BCOR) ) then
890 BCOR = obs_bodyElem_r(obsdat,OBS_BCOR,LK)
891 else
892 BCOR = MPC_missingValue_R4
893 end if
894 FLG=obs_bodyElem_i(obsdat,OBS_FLG ,LK)
895 KOBSN= KOBSN + 1
896 SUM=SUM +1
897 call BURP_Set_Rval( Block_OER_SFC, NELE_IND =IND_ele_stat ,NVAL_IND =1,NT_IND = k , RVAL = OER )
898 call BURP_Set_Rval( Block_FGE_SFC, NELE_IND =IND_ele_stat ,NVAL_IND =1,NT_IND = k , RVAL = FGE )
899 call BURP_Set_Rval( Block_FSO_SFC, NELE_IND =IND_ele_stat ,NVAL_IND =1,NT_IND = k , RVAL = FSO )
900
901 IND_ELE_stat = BURP_Find_Element(BLOCK_OMA_SFC, ELEMENT=iele)
902 if (IND_ELE_stat==-1) call handle_error(IND_ELE_stat, "brpr_updateBurp: element not found in BLOCK_OMA_SFC #3")
903 call BURP_Set_Rval( Block_OMA_SFC, NELE_IND =IND_ele_stat ,NVAL_IND =1,NT_IND = k , RVAL = OMA)
904
905 IND_ELE_stat = BURP_Find_Element(BLOCK_OMP_SFC, ELEMENT=iele)
906 if (IND_ELE_stat==-1)call handle_error(IND_ELE_stat, "brpr_updateBurp: element not found in BLOCK_OMP_SFC #1")
907 call BURP_Set_Rval( Block_OMP_SFC, NELE_IND =IND_ele_stat ,NVAL_IND =1,NT_IND = k , RVAL = OMP)
908
909 IND_ELE_stat = BURP_Find_Element(BLOCK_FSO_SFC, ELEMENT=iele)
910 if (IND_ELE_stat==-1)call handle_error(IND_ELE_stat, "brpr_updateBurp: element not found in BLOCK_FSO_SFC #1")
911 call BURP_Set_Rval( Block_FSO_SFC, NELE_IND =IND_ele_stat ,NVAL_IND =1,NT_IND = k , RVAL = FSO)
912
913 call BURP_Set_tblval(Block_MAR_SFC_CP,NELE_IND =IND_ele_mar,NVAL_IND =1,NT_IND = k ,TBLVAL= FLG)
914
915 !OBS=obs_bodyElem_r(obsdat,OBS_VAR,LK)
916 IND_ele = BURP_Find_Element(BLOCK_OBS_SFC_CP, ELEMENT=iele)
917 if (IND_ELE==-1) call handle_error(IND_ele, "brpr_updateBurp: element not found in BLOCK_OBS_SFC #1")
918 call BURP_Set_Rval(Block_OBS_SFC_CP,NELE_IND =IND_ele,NVAL_IND =1,NT_IND = k,RVAL = OBS )
919
920 if (iele == BUFR_NEZD) then
921 IND_ele = BURP_Find_Element(BLOCK_OBS_SFC_CP, ELEMENT=ILEMZBCOR)
922 if (IND_ele > 0 .and. obs_columnActive_RB(obsdat,OBS_BCOR)) &
923 call BURP_Set_Rval(Block_OBS_SFC_CP,NELE_IND =IND_ele,NVAL_IND =1,NT_IND = k,RVAL = BCOR )
924 end if
925
926 exit
927 end if
928
929 end do OBSDATA
930!-------------------------------------------
931 end do elems_sfc
932!-------------------------------------------
933
934 if ( REGRUP .and. KOBSN > 0 ) then
935 STATUS=obs_headElem_i(obsdat,OBS_ST1,OBS_START )
936 STATUS=IBSET(STATUS,BIT_STATUS)
937 ind055200 = BURP_Find_Element(Block_FLG_CP, ELEMENT=055200)
938 if (ind055200==-1)call handle_error(ind055200, "brpr_updateBurp: element 055200 not found in Block_FLG_CP")
939 call BURP_Set_tblval( Block_FLG_CP, NELE_IND =ind055200,NVAL_IND =1,NT_IND = k ,TBLVAL = STATUS )
940 OBSN=OBSN +1
941 OBS_START=OBS_START +1
942 end if
943!==============================================
944 end do REGRUP_SFC
945!=============================================
946
947 do item=1,BN_ITEMS
948
949 if ( BITEMLIST(item) == 'OMA') then
950 call BURP_Reduce_Block(BLOCK_OMA_SFC, NEW_NELE =il_index )
951 call BURP_Write_Block( CP_RPT, BLOCK_OMA_SFC,&
952 ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
953 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_OMA_SFC")
954 cycle
955 end if
956 if ( BITEMLIST(item) == 'OMP') then
957 call BURP_Reduce_Block(BLOCK_OMP_SFC, NEW_NELE =il_index )
958 call BURP_Write_Block( CP_RPT, BLOCK_OMP_SFC,&
959 ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
960 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_OMP_SFC")
961 cycle
962 end if
963 if ( BITEMLIST(item) == 'OER') then
964 if (.not.LBLOCK_OER_CP) then
965 call BURP_Reduce_Block(BLOCK_OER_SFC, NEW_NELE =il_index )
966 call BURP_Write_Block( CP_RPT, BLOCK_OER_SFC,&
967 ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
968 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_OER_SFC")
969 else
970 call BURP_Set_Property(BLOCK_OER_CP ,BKTYP =new_bktyp)
971 call BURP_Write_Block( CP_RPT, BLOCK_OER_CP,&
972 ENCODE_BLOCK = .FALSE., CONVERT_BLOCK = .FALSE., IOSTAT= error)
973 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_OER_CP")
974 end if
975 cycle
976 end if
977 if ( BITEMLIST(item) == 'FGE') then
978 if (.not.LBLOCK_FGE_CP) then
979 call BURP_Reduce_Block(BLOCK_FGE_SFC, NEW_NELE =il_index )
980 call BURP_Write_Block( CP_RPT, BLOCK_FGE_SFC,&
981 ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
982 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_FGE_SFC")
983 else
984 call BURP_Set_Property(BLOCK_FGE_CP ,BKTYP =new_bktyp)
985 call BURP_Write_Block( CP_RPT, BLOCK_FGE_CP,&
986 ENCODE_BLOCK = .FALSE., CONVERT_BLOCK = .FALSE., IOSTAT= error)
987 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_FGE_CP")
988 end if
989 cycle
990 end if
991
992 if ( BITEMLIST(item) == 'FSO') then
993 call BURP_Reduce_Block(BLOCK_FSO_SFC, NEW_NELE =il_index )
994 call BURP_Write_Block( CP_RPT, BLOCK_FSO_SFC,&
995 ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
996 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_FSO_SFC")
997 cycle
998 end if
999
1000 end do
1001
1002 call BURP_Set_Property(BLOCK_OBS_SFC_CP ,BFAM =0)
1003 call BURP_Set_Property(BLOCK_MAR_SFC_CP ,BFAM =0)
1004
1005 call BURP_Write_Block( CP_RPT, BLOCK_OBS_SFC_CP,&
1006 ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
1007 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_OBS_SFC_CP")
1008 call BURP_Write_Block( CP_RPT, BLOCK_MAR_SFC_CP,&
1009 ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .FALSE., IOSTAT= error)
1010 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_MAR_SFC_CP")
1011 IF ( KOBSN > 0 .and. .not. REGRUP ) THEN
1012 STATUS=obs_headElem_i(obsdat,OBS_ST1,OBS_START)
1013 STATUS=IBSET(STATUS,BIT_STATUS)
1014 call BURP_Set_Property(CP_RPT ,FLGS =STATUS)
1015 END IF
1016
1017 SAVE_OBS=OBS_START
1018 NDATA_SF=KOBSN
1019 if (BLOCK_LIST(4) == -1 .and. KOBSN > 0 .and. .not. regrup ) THEN
1020 SAVE_OBS=SAVE_OBS+1
1021 OBS_START=OBS_START+1
1022 end if
1023
1024 end if ! bl == 2
1025
1026
1027 !if ( btyp10 - btyp10obs == 0 .and. bfam == 0 ) then
1028 if ( bl == 4 ) then
1029 ILEMU=11003
1030 ILEMV=11004
1031 new_bktyp=bktyp
1032 if ( post_bit > 0 ) then
1033 new_bktyp=IBSET(bktyp,post_bit)
1034 call BURP_Set_Property(BLOCK_OBS_MUL_CP ,BKTYP =new_bktyp)
1035 call BURP_Set_Property(BLOCK_MAR_MUL_CP ,BKTYP =new_bktyp)
1036 end if
1037 OBSN=OBS_START
1038 NVAL=NVALE ; NT=NTE
1039
1040 il_index=1
1041 call BURP_New(BLOCK_OMA, NELE =1, NVAL =nvale,NT=NTE,bfam=12,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=10 &
1042 ,IOSTAT = error)
1043 call handle_error(error, "brpr_updateBurp: BURP_New BLOCK_OMA")
1044 call BURP_New(BLOCK_OMP, NELE =1, NVAL =nvale,NT=NTE,bfam=14,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=10 &
1045 ,IOSTAT = error)
1046 call handle_error(error, "brpr_updateBurp: BURP_New BLOCK_OMP")
1047 call BURP_New(BLOCK_OER, NELE =1, NVAL =nvale,NT=NTE,bfam=10,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=14 &
1048 ,IOSTAT = error)
1049 call handle_error(error, "brpr_updateBurp: BURP_New BLOCK_OER")
1050 call BURP_New(BLOCK_FGE, NELE =1, NVAL =nvale,NT=NTE,bfam=10,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=15 &
1051 ,IOSTAT = error)
1052 call handle_error(error, "brpr_updateBurp: BURP_New BLOCK_FGE")
1053 call BURP_New(BLOCK_FSO, NELE =1, NVAL =nvale,NT=NTE,bfam=1,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=2 &
1054 ,IOSTAT = error)
1055 call handle_error(error, "brpr_updateBurp: BURP_New BLOCK_FSO")
1056
1057 VCOORD_POS=0
1058 k=0
1059 IND_VCOORD=-1
1060 do while (vcord_type(k+1) /= -1 .and. IND_VCOORD == -1)
1061 k=k+1
1062 IND_VCOORD = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=vcord_type(k))
1063 end do
1064 IF ( IND_VCOORD > 0 ) then
1065 IF (trim(FAMILYTYPE) == trim('CH')) THEN
1066 ELEVFACT=0.0
1067 IF (vcord_type(k) == 7006) ELEVFACT=1.0
1068 END IF
1069 call BURP_Set_Element(BLOCK_OMA,NELE_IND= 1,ElEMENT=vcord_type(k),IOSTAT=error)
1070 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OMA")
1071 call BURP_Set_Element(BLOCK_OMP,NELE_IND= 1,ElEMENT=vcord_type(k),IOSTAT=error)
1072 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OMP")
1073 call BURP_Set_Element(BLOCK_OER,NELE_IND= 1,ElEMENT=vcord_type(k),IOSTAT=error)
1074 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OER")
1075 call BURP_Set_Element(BLOCK_FGE,NELE_IND= 1,ElEMENT=vcord_type(k),IOSTAT=error)
1076 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_FGE")
1077 call BURP_Set_Element(BLOCK_FSO,NELE_IND= 1,ElEMENT=vcord_type(k),IOSTAT=error)
1078 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_FSO #1")
1079 VCOORD_POS=1
1080 ELSE IF (IND_VCOORD == -1) then
1081 !write(*,*) ' PAS DE COORDONNEE VERTICALE famille ',trim(FAMILYTYPE)
1082 il_index=0
1083 end if
1084 VCOORD = -999.
1085
1086 IND_eleu = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=ILEMU)
1087 IND_elef = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=ILEMD)
1088
1089 OMA_ALT_EXIST=.false.
1090 if(WINDS .and. IND_eleu < 0 .and. IND_elef > 0) then
1091 call BURP_Resize_Block(BLOCK_OMA,ADD_NELE = 2 ,IOSTAT=error)
1092 call handle_error(error, "brpr_updateBurp: BURP_Resize_Block BLOCK_OMA #1")
1093 call BURP_Set_Element( BLOCK_OMA,NELE_IND = VCOORD_POS+1,ElEMENT=ILEMU,IOSTAT=error)
1094 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OMA ILEMU")
1095 call BURP_Set_Element( BLOCK_OMA,NELE_IND = VCOORD_POS+2,ElEMENT=ILEMV,IOSTAT=error)
1096 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OMA ILEMV")
1097 OMA_ALT_EXIST=.true.
1098
1099 call BURP_Resize_Block(BLOCK_OMP,ADD_NELE = 2 ,IOSTAT=error)
1100 call handle_error(error, "brpr_updateBurp: BURP_Resize_Block BLOCK_OMP #1")
1101 call BURP_Set_Element( BLOCK_OMP,NELE_IND = VCOORD_POS+1,ElEMENT=ILEMU,IOSTAT=error)
1102 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OMP ILEMU")
1103 call BURP_Set_Element( BLOCK_OMP,NELE_IND = VCOORD_POS+2,ElEMENT=ILEMV,IOSTAT=error)
1104 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OMP ILEMV")
1105
1106 call BURP_Resize_Block(BLOCK_OER,ADD_NELE = 2 ,IOSTAT=error)
1107 call handle_error(error, "brpr_updateBurp: BURP_Resize_Block BLOCK_OER #1")
1108 call BURP_Set_Element( BLOCK_OER,NELE_IND = VCOORD_POS+1,ElEMENT=ILEMU,IOSTAT=error)
1109 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OER ILEMU")
1110 call BURP_Set_Element( BLOCK_OER,NELE_IND = VCOORD_POS+2,ElEMENT=ILEMV,IOSTAT=error)
1111 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OER ILEMV")
1112
1113 call BURP_Resize_Block(BLOCK_FGE,ADD_NELE = 2 ,IOSTAT=error)
1114 call handle_error(error, "brpr_updateBurp: BURP_Resize_Block BLOCK_FGE #1")
1115 call BURP_Set_Element( BLOCK_FGE,NELE_IND = VCOORD_POS+1,ElEMENT=ILEMU,IOSTAT=error)
1116 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_FGE ILEMU")
1117 call BURP_Set_Element( BLOCK_FGE,NELE_IND = VCOORD_POS+2,ElEMENT=ILEMV,IOSTAT=error)
1118 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_FGE ILEMV")
1119
1120 call BURP_Resize_Block(BLOCK_FSO,ADD_NELE = 2 ,IOSTAT=error)
1121 call handle_error(error, "brpr_updateBurp: BURP_Resize_Block BLOCK_FSO #1")
1122 call BURP_Set_Element( BLOCK_FSO,NELE_IND = VCOORD_POS+1,ElEMENT=ILEMU,IOSTAT=error)
1123 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_FSO ILEMU")
1124 call BURP_Set_Element( BLOCK_FSO,NELE_IND = VCOORD_POS+2,ElEMENT=ILEMV,IOSTAT=error)
1125 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_FSO ILEMV")
1126
1127 call BURP_Resize_Block(BLOCK_OBS_MUL_CP,ADD_NELE = 2 ,IOSTAT=error)
1128 call handle_error(error, "brpr_updateBurp: BURP_Resize_Block BLOCK_OBS_MUL_CP")
1129 call BURP_Set_Element( BLOCK_OBS_MUL_CP,NELE_IND = nbele+1,ElEMENT=ILEMU,IOSTAT=error)
1130 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OBS_MUL_CP ILEMU")
1131 call BURP_Set_Element( BLOCK_OBS_MUL_CP,NELE_IND = nbele+2,ElEMENT=ILEMV,IOSTAT=error)
1132 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OBS_MUL_CP ILEMV")
1133
1134 call BURP_Resize_Block(BLOCK_MAR_MUL_CP,ADD_NELE = 2 ,IOSTAT=error)
1135 call handle_error(error, "brpr_updateBurp: BURP_Resize_Block BLOCK_MAR_MUL_CP")
1136 call BURP_Set_Element( BLOCK_MAR_MUL_CP,NELE_IND = nbele+1,ElEMENT=ILEMU+200000,IOSTAT=error)
1137 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_MAR_MUL_CP ILEMU")
1138 call BURP_Set_Element( BLOCK_MAR_MUL_CP,NELE_IND = nbele+2,ElEMENT=ILEMV+200000,IOSTAT=error)
1139 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_MAR_MUL_CP ILEMV")
1140
1141 do k=1,nte
1142 do jj=1,nvale
1143 call BURP_Set_Rval( Block_OMA, NELE_IND =VCOORD_POS+1 ,NVAL_IND =jj , NT_IND = k , RVAL = MPC_missingValue_R4 )
1144 call BURP_Set_Rval( Block_OMA, NELE_IND =VCOORD_POS+2 ,NVAL_IND =jj , NT_IND = k , RVAL = MPC_missingValue_R4 )
1145 call BURP_Set_Rval( Block_OMP, NELE_IND =VCOORD_POS+1 ,NVAL_IND =jj , NT_IND = k , RVAL = MPC_missingValue_R4 )
1146 call BURP_Set_Rval( Block_OMP, NELE_IND =VCOORD_POS+2 ,NVAL_IND =jj , NT_IND = k , RVAL = MPC_missingValue_R4 )
1147 call BURP_Set_Rval( Block_OER, NELE_IND =VCOORD_POS+1 ,NVAL_IND =jj , NT_IND = k , RVAL = MPC_missingValue_R4 )
1148 call BURP_Set_Rval( Block_OER, NELE_IND =VCOORD_POS+2 ,NVAL_IND =jj , NT_IND = k , RVAL = MPC_missingValue_R4 )
1149 call BURP_Set_Rval( Block_FGE, NELE_IND =VCOORD_POS+1 ,NVAL_IND =jj , NT_IND = k , RVAL = MPC_missingValue_R4 )
1150 call BURP_Set_Rval( Block_FGE, NELE_IND =VCOORD_POS+2 ,NVAL_IND =jj , NT_IND = k , RVAL = MPC_missingValue_R4 )
1151 call BURP_Set_Rval( Block_FSO, NELE_IND =VCOORD_POS+1 ,NVAL_IND =jj , NT_IND = k , RVAL = MPC_missingValue_R4 )
1152 call BURP_Set_Rval( Block_FSO, NELE_IND =VCOORD_POS+2 ,NVAL_IND =jj , NT_IND = k , RVAL = MPC_missingValue_R4 )
1153
1154 call BURP_Set_Rval( BLOCK_OBS_MUL_CP, NELE_IND =nbele+1 ,NVAL_IND =jj , NT_IND = k , RVAL = MPC_missingValue_R4)
1155 call BURP_Set_Rval( BLOCK_OBS_MUL_CP, NELE_IND =nbele+2 ,NVAL_IND =jj , NT_IND = k , RVAL = MPC_missingValue_R4)
1156 call BURP_Set_tblval(BLOCK_MAR_MUL_CP, NELE_IND =nbele+1 ,NVAL_IND =jj , NT_IND = k , TBLVAL = 0 )
1157 call BURP_Set_tblval(BLOCK_MAR_MUL_CP, NELE_IND =nbele+2 ,NVAL_IND =jj , NT_IND = k , TBLVAL = 0 )
1158 end do
1159 end do
1160 nbele=nbele+2
1161
1162 il_index=il_index+2
1163 end if
1164 !call BURP_Delete_BLOCK(Rpt_in,BLOCK=Block_in)
1165
1166 ! LAT LON TIME IN DATA BLOCK
1167 IND_LAT = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=5001)
1168 IND_LON = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=6001)
1169 IND_TIME = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=4015)
1170 if (IND_LAT > 0 .and. IND_LON > 0 .and. IND_TIME > 0 ) HIRES=.true.
1171 if(ENFORCE_CLASSIC_SONDES) hires=.false.
1172
1173 if( (TRIM(FAMILYTYPE2) == 'UA') .and. UA_HIGH_PRECISION_TT_ES ) HIPCS=.true.
1174
1175 !print * , ' hires =true ? ndata_sf ',stnid,hires,NDATA_SF
1176
1177 if ( HIRES .AND. NDATA_SF > 0 ) OBS_START =OBS_START +1
1178 OBSN=OBS_START
1179 STATUS_HIRES=0
1180
1181 regrup_LOOP: do k=1,nte
1182 KOBSN=0
1183
1184 levels: do j=1,nvale
1185
1186 if (OBSN > obs_numHeader(obsdat)) then
1187 write(*,*) ' debordement altitude OBSN=',OBSN
1188 else
1189 IRLN=obs_headElem_i(obsdat,OBS_RLN,OBSN)
1190 INLV=obs_headElem_i(obsdat,OBS_NLV,OBSN)
1191 if ((j == 1 .or. HIRES) .and. INLV > 0) then
1192 if (allocated(PPPandVNM)) deallocate(PPPandVNM)
1193 if (allocated(bodyIndexList)) deallocate(bodyIndexList)
1194 allocate(PPPandVNM(2,INLV))
1195 allocate(bodyIndexList(INLV))
1196 bodyCount = 0
1197 do LK = IRLN, IRLN+INLV-1
1198 bodyCount = bodyCount + 1
1199 PPPandVNM(1,bodyCount) = obs_bodyElem_r(obsdat,OBS_PPP,LK) - (ELEV-400.)*ELEVFACT
1200 PPPandVNM(2,bodyCount) = real(obs_bodyElem_i(obsdat,OBS_VNM,LK),8)
1201 bodyIndexList(bodyCount) = lk
1202 end do
1203 if (associated(tree)) call kdtree2_destroy(tree)
1204 tree => kdtree2_create(PPPandVNM, sort=.true., rearrange=.true.)
1205 end if
1206 end if
1207
1208 !pikpik
1209 if(HIRES) KOBSN=0
1210 !pikpik
1211
1212 ! Loop over elements to add all to the new blocks and the initialize values
1213 elems0: do IL = 1, NBELE
1214
1215 iele=BURP_Get_Element(BLOCK_OBS_MUL_CP,INDEX =il,IOSTAT= error)
1216 call handle_error(error, "brpr_updateBurp: BURP_Get_Element BLOCK_OBS_MUL_CP")
1217
1218 IND_ELE_MAR= BURP_Find_Element(Block_MAR_MUL_CP, ELEMENT=iele+200000)
1219 if (IND_ele_mar < 0 ) cycle
1220
1221 IND_ele = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=iele)
1222 if (IND_ele == IND_LAT .and. hires ) cycle
1223 if (IND_ele == IND_LON .and. hires ) cycle
1224 if (IND_ele == IND_TIME .and. hires ) cycle
1225 IND_ELE_STAT=-1
1226 IND_ele_STAT = BURP_Find_Element(BLOCK_OMA, ELEMENT=iele)
1227
1228 if(j == 1 .and. il /= ind_vcoord .and. IND_ELE_STAT < 1 ) then
1229
1230 il_index=il_index +1
1231 call BURP_Resize_Block(BLOCK_OMA,ADD_NELE = 1 ,IOSTAT=error)
1232 call handle_error(error, "brpr_updateBurp: BURP_Resize_Block BLOCK_OMA #2")
1233 call BURP_Set_Element (BLOCK_OMA,NELE_IND = il_index,ElEMENT=iele,IOSTAT=error)
1234 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OMA")
1235
1236 call BURP_Resize_Block(BLOCK_OMP,ADD_NELE = 1 ,IOSTAT=error)
1237 call handle_error(error, "brpr_updateBurp: BURP_Resize_Block BLOCK_OMP #2")
1238 call BURP_Set_Element (BLOCK_OMP,NELE_IND = il_index,ElEMENT=iele,IOSTAT=error)
1239 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OMP")
1240
1241 call BURP_Resize_Block(BLOCK_OER,ADD_NELE = 1 ,IOSTAT=error)
1242 call handle_error(error, "brpr_updateBurp: BURP_Resize_Block BLOCK_OER #2")
1243 call BURP_Set_Element (BLOCK_OER,NELE_IND = il_index,ElEMENT=iele,IOSTAT=error)
1244 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_OER")
1245
1246 call BURP_Resize_Block(BLOCK_FGE,ADD_NELE = 1 ,IOSTAT=error)
1247 call handle_error(error, "brpr_updateBurp: BURP_Resize_Block BLOCK_FGE #2")
1248 call BURP_Set_Element (BLOCK_FGE,NELE_IND = il_index,ElEMENT=iele,IOSTAT=error)
1249 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_FGE")
1250
1251 call BURP_Resize_Block(BLOCK_FSO,ADD_NELE = 1 ,IOSTAT=error)
1252 call handle_error(error, "brpr_updateBurp: BURP_Resize_Block BLOCK_FSO #2")
1253 call BURP_Set_Element (BLOCK_FSO,NELE_IND = il_index,ElEMENT=iele,IOSTAT=error)
1254 call handle_error(error, "brpr_updateBurp: BURP_Set_Element BLOCK_FSO #2")
1255
1256 do ki=1,nte
1257 do jj=1,nvale
1258 call BURP_Set_Rval( Block_OMA, NELE_IND =il_index ,NVAL_IND =jj , NT_IND = ki, RVAL = MPC_missingValue_R4 )
1259 call BURP_Set_Rval( Block_OMP, NELE_IND =il_index ,NVAL_IND =jj , NT_IND = ki, RVAL = MPC_missingValue_R4 )
1260 call BURP_Set_Rval( Block_OER, NELE_IND =il_index ,NVAL_IND =jj , NT_IND = ki, RVAL = MPC_missingValue_R4 )
1261 call BURP_Set_Rval( Block_FGE, NELE_IND =il_index ,NVAL_IND =jj , NT_IND = ki, RVAL = MPC_missingValue_R4 )
1262 call BURP_Set_Rval( Block_FSO, NELE_IND =il_index ,NVAL_IND =jj , NT_IND = ki, RVAL = MPC_missingValue_R4 )
1263 end do
1264 end do
1265
1266 end if
1267
1268 end do elems0
1269
1270 ! Loop over elements to update the values
1271 elems: do IL = 1, NBELE
1272
1273 iele=-1
1274 iele=BURP_Get_Element(BLOCK_OBS_MUL_CP,INDEX =il,IOSTAT= error)
1275 call handle_error(error, "brpr_updateBurp: BURP_Get_Element BLOCK_OBS_MUL_CP")
1276
1277 IND_ELE_MAR= BURP_Find_Element(Block_MAR_MUL_CP, ELEMENT=iele+200000)
1278 if (IND_ele_mar < 0 ) cycle
1279
1280 IND_ele = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=iele)
1281 if (IND_ele == IND_LAT .and. hires ) cycle
1282 if (IND_ele == IND_LON .and. hires ) cycle
1283 if (IND_ele == IND_TIME .and. hires ) cycle
1284 IND_ELE_STAT=-1
1285 IND_ele_STAT = BURP_Find_Element(BLOCK_OMA, ELEMENT=iele)
1286 VCOORD = BURP_Get_Rval(BLOCK_OBS_MUL_CP, &
1287 & NELE_IND = IND_VCOORD, &
1288 & NVAL_IND = j, &
1289 & NT_IND = k)
1290 IF (il == IND_VCOORD) THEN
1291 call BURP_Set_Rval( Block_OMA, NELE_IND =1 ,NVAL_IND =j , NT_IND = k , RVAL = VCOORD )
1292 call BURP_Set_Rval( Block_OMP, NELE_IND =1 ,NVAL_IND =j , NT_IND = k , RVAL = VCOORD )
1293 call BURP_Set_Rval( Block_OER, NELE_IND =1 ,NVAL_IND =j , NT_IND = k , RVAL = VCOORD )
1294 call BURP_Set_Rval( Block_FGE, NELE_IND =1 ,NVAL_IND =j , NT_IND = k , RVAL = VCOORD )
1295 call BURP_Set_Rval( Block_FSO, NELE_IND =1 ,NVAL_IND =j , NT_IND = k , RVAL = VCOORD )
1296 END IF
1297
1298 IND_ele = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=iele)
1299 if (IND_ELE==-1)call handle_error(IND_ele, "brpr_updateBurp: element not found in BLOCK_OBS_MUL_CP")
1300
1301 is_in_list=-1
1302 is_in_list=FIND_INDEX(LISTE_ELE,iele)
1303 if (is_in_list < 0 .and. iele /= ILEMU .and. iele /= ILEMV) cycle
1304
1305 IFLAG = BURP_Get_Tblval(Block_MAR_MUL_CP,NELE_IND = IND_ELE_MAR,NVAL_IND = J, NT_IND = k)
1306 OBSVA = BURP_Get_Rval (Block_OBS_MUL_CP,NELE_IND = IND_ele ,NVAL_IND = J, NT_IND = k)
1307 !if( idtyp == 168 ) print * , ' bobossmi avant vcoord obsva stnid =', VCOORD,OBSVA,stnid
1308
1309 if (VCOORD == MPC_missingValue_R4 ) CYCLE ELEMS
1310 if (OBSVA == MPC_missingValue_R4 .and. iele /= ILEMU .and. iele /= ILEMV ) CYCLE ELEMS
1311
1312 if (OBSN > obs_numHeader(obsdat)) write(*,*) ' debordement altitude OBSN=',OBSN
1313 if (OBSN > obs_numHeader(obsdat)) cycle
1314 TIME=obs_headElem_i(obsdat,OBS_ETM,OBSN)
1315 STID=obs_elem_c(obsdat,'STID',OBSN)
1316 if ( STID /= stnid ) cycle
1317
1318 convfact=1.
1319 if (iele == 10194) convfact=1./ec_rg
1320
1321 if (INLV > 0) then
1322 refPosition(1) = vcoord
1323 refPosition(2) = iele
1324 call kdtree2_r_nearest(tp=tree, &
1325 qv=refPosition, r2=maxRadius, &
1326 nfound=numFoundSearch, &
1327 nalloc=maxNumSearch, &
1328 results=searchResults)
1329 if (numFoundSearch == 0) cycle ELEMS
1330 if (numFoundSearch > 1) then
1331 write(*,*) 'vcoord, iele = ', vcoord, iele
1332 do resultIndex = 1, numFoundSearch
1333 write(*,*) 'ppp = ', PPPandVNM(1,searchResults(resultIndex)%idx)
1334 write(*,*) 'vnm = ', PPPandVNM(2,searchResults(resultIndex)%idx)
1335 end do
1336 write(*,*) 'brpr_updateBurp: multiple obs matches found, taking closest'
1337 end if
1338 lk = bodyIndexList(searchResults(1)%idx)
1339 else
1340 cycle ELEMS
1341 end if
1342
1343
1344 OBS=obs_bodyElem_r(obsdat,OBS_VAR,LK)*convfact
1345 OMA=obs_bodyElem_r(obsdat,OBS_OMA,LK)
1346 OMP=obs_bodyElem_r(obsdat,OBS_OMP,LK)
1347 OER=obs_bodyElem_r(obsdat,OBS_OER,LK)
1348 FGE=obs_bodyElem_r(obsdat,OBS_HPHT,LK)
1349 if ( obs_columnActive_RB(obsdat,OBS_FSO) ) then
1350 FSO=obs_bodyElem_r(obsdat,OBS_FSO,LK)
1351 else
1352 FSO = MPC_missingValue_R4
1353 end if
1354 if ( obs_columnActive_RB(obsdat,OBS_BCOR) ) then
1355 BCOR = obs_bodyElem_r(obsdat,OBS_BCOR,LK)
1356 else
1357 BCOR = MPC_missingValue_R4
1358 end if
1359 if ( obs_columnActive_RB(obsdat,OBS_BTCL) ) then
1360 obsClear = obs_bodyElem_r(obsdat,OBS_BTCL,LK)
1361 else
1362 obsClear = MPC_missingValue_R4
1363 end if
1364 FLG=obs_bodyElem_i(obsdat,OBS_FLG,LK)
1365 KOBSN= KOBSN + 1
1366 IND_ELE_stat = BURP_Find_Element(BLOCK_OMA, ELEMENT=iele)
1367 if (IND_ELE_stat==-1)call handle_error(IND_ELE_stat, "brpr_updateBurp: element not found in BLOCK_OMA")
1368 if ( OMA /= MPC_missingValue_R4 ) then
1369 OMA=OMA*convfact
1370 end if
1371
1372 call BURP_Set_Rval(Block_OMA, NELE_IND =IND_ele_stat ,NVAL_IND =j , NT_IND = k , RVAL = OMA )
1373
1374 if(HIPCS) then
1375 IND_ELE_tth = BURP_Find_Element(BLOCK_OMA, ELEMENT=12101)
1376 if (IND_ELE_tth==-1) call handle_error(IND_ELE_tth, "brpr_updateBurp: element 12101 not found in BLOCK_OMA")
1377 IND_ELE_esh = BURP_Find_Element(BLOCK_OMA, ELEMENT=12239)
1378 if (IND_ELE_esh==-1) call handle_error(IND_ELE_esh, "brpr_updateBurp: element 12239 not found in BLOCK_OMA")
1379 if(iele == 12001) then
1380 if (IND_ele_tth==-1) write(*,*) 'PB1 SYLVAIN TTH'
1381 call BURP_Set_Rval(Block_OMA, NELE_IND =IND_ele_tth ,NVAL_IND =j , NT_IND = k , RVAL = OMA )
1382 end if
1383 if(iele == 12192) then
1384 if (IND_ele_esh==-1) write(*,*) 'PB1 SYLVAIN ESH'
1385 call BURP_Set_Rval(Block_OMA, NELE_IND =IND_ele_esh ,NVAL_IND =j , NT_IND = k , RVAL = OMA )
1386 end if
1387 endif
1388
1389 !if(trim(familytype) == 'TO' )print *,' bingo stnid kk vnm ppp flg omp ',stnid,kk,vnm,ppp,flg,omp,oma
1390 SUM=SUM +1
1391 IND_ELE_stat = BURP_Find_Element(BLOCK_OMP, ELEMENT=iele)
1392 if (IND_ELE_stat==-1)call handle_error(IND_ELE_stat, "element not found in BLOCK_OMP")
1393 if ( OMP /= MPC_missingValue_R4 ) then
1394 OMP=OMP*convfact
1395 end if
1396 call BURP_Set_Rval( Block_OMP, NELE_IND =IND_ele_stat ,NVAL_IND =j , NT_IND = k , RVAL = OMP)
1397
1398 if(HIPCS) then
1399 if(iele == 12001) call BURP_Set_Rval(Block_OMP, NELE_IND =IND_ele_tth ,NVAL_IND =j , NT_IND = k , RVAL = OMP )
1400 if(iele == 12192) call BURP_Set_Rval(Block_OMP, NELE_IND =IND_ele_esh ,NVAL_IND =j , NT_IND = k , RVAL = OMP )
1401 endif
1402
1403 call BURP_Set_Rval( Block_OER, NELE_IND =IND_ele_stat ,NVAL_IND =j , NT_IND = k , RVAL = OER )
1404
1405 if(HIPCS) then
1406 if(iele == 12001) call BURP_Set_Rval(Block_OER, NELE_IND =IND_ele_tth ,NVAL_IND =j , NT_IND = k , RVAL = OER )
1407 if(iele == 12192) call BURP_Set_Rval(Block_OER, NELE_IND =IND_ele_esh ,NVAL_IND =j , NT_IND = k , RVAL = OER )
1408 endif
1409
1410 call BURP_Set_Rval( Block_FGE, NELE_IND =IND_ele_stat ,NVAL_IND =j , NT_IND = k , RVAL = FGE )
1411
1412 if(HIPCS) then
1413 if(iele == 12001) call BURP_Set_Rval(Block_FGE, NELE_IND =IND_ele_tth ,NVAL_IND =j , NT_IND = k , RVAL = FGE )
1414 if(iele == 12192) call BURP_Set_Rval(Block_FGE, NELE_IND =IND_ele_esh ,NVAL_IND =j , NT_IND = k , RVAL = FGE )
1415 endif
1416
1417 call BURP_Set_Rval( Block_FSO, NELE_IND =IND_ele_stat ,NVAL_IND =j , NT_IND = k , RVAL = FSO )
1418
1419 if(HIPCS) then
1420 if(iele == 12001) call BURP_Set_Rval(Block_FSO, NELE_IND =IND_ele_tth ,NVAL_IND =j , NT_IND = k , RVAL = FSO )
1421 if(iele == 12192) call BURP_Set_Rval(Block_FSO, NELE_IND =IND_ele_esh ,NVAL_IND =j , NT_IND = k , RVAL = FSO )
1422 endif
1423
1424 IND_ele_mar = BURP_Find_Element(Block_MAR_MUL_CP, ELEMENT=iele+200000, IOSTAT=error)
1425 if (IND_ELE_mar==-1)call handle_error(IND_ele_mar, "brpr_updateBurp: element not found in Block_MAR_MUL_CP")
1426
1427 call BURP_Set_tblval(Block_MAR_MUL_CP,NELE_IND =IND_ELE_MAR ,NVAL_IND =j , NT_IND = k,TBLVAL = FLG )
1428
1429 if(HIPCS) then
1430 if(iele == 12001) then
1431 IND_ele_mar = BURP_Find_Element(Block_MAR_MUL_CP, ELEMENT=212101)
1432 if (IND_ELE_mar==-1)call handle_error(IND_ele_mar, "brpr_updateBurp: element 212001 not found in Block_MAR_MUL_CP")
1433 call BURP_Set_tblval(Block_MAR_MUL_CP,NELE_IND =IND_ELE_MAR ,NVAL_IND =j , NT_IND = k,TBLVAL = FLG )
1434 endif
1435 if(iele == 12192) then
1436 IND_ele_mar = BURP_Find_Element(Block_MAR_MUL_CP, ELEMENT=212239)
1437 if (IND_ELE_mar==-1)call handle_error(IND_ele_mar, "brpr_updateBurp: element 212239 not found in Block_MAR_MUL_CP")
1438 call BURP_Set_tblval(Block_MAR_MUL_CP,NELE_IND =IND_ELE_MAR ,NVAL_IND =j , NT_IND = k,TBLVAL = FLG )
1439 endif
1440 endif
1441
1442 IND_ele = -1
1443 if (iele == BUFR_NBT3) then
1444 IND_ele = BURP_Find_Element(Block_OBS_MUL_CP, ELEMENT=12233)
1445 elseif (iele == BUFR_NETT) then
1446 IND_ele = BURP_Find_Element(Block_OBS_MUL_CP, ELEMENT=ILEMTBCOR)
1447 elseif (iele == BUFR_NEES) then
1448 IND_ele = BURP_Find_Element(Block_OBS_MUL_CP, ELEMENT=ILEMHBCOR)
1449 end if
1450
1451 if (IND_ele > 0 .and. obs_columnActive_RB(obsdat,OBS_BCOR)) then
1452 call BURP_Set_Rval(Block_OBS_MUL_CP,NELE_IND =IND_ele,NVAL_IND =j,NT_IND = k,RVAL = BCOR)
1453 end if
1454
1455 IND_obsClear = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=btClearElementId)
1456 if ( IND_obsClear > 0 .and. obs_columnActive_RB(obsdat,OBS_BTCL) ) then
1457 Call BURP_Set_Rval(Block_OBS_MUL_CP,NELE_IND =IND_obsClear,NVAL_IND =j,NT_IND = k,RVAL = obsClear)
1458 end if
1459
1460 IND_ele = BURP_Find_Element(Block_OBS_MUL_CP, ELEMENT=iele)
1461 if (IND_ele==-1)call handle_error(IND_ele, "brpr_updateBurp: element not found in Block_OBS_MUL_CP")
1462
1463 call BURP_Set_Rval(Block_OBS_MUL_CP,NELE_IND =IND_ele,NVAL_IND =j,NT_IND = k,RVAL = OBS)
1464
1465 if (HIPCS) then
1466 if (iele == 12001) then
1467 IND_ele = BURP_Find_Element(Block_OBS_MUL_CP, ELEMENT=12101, IOSTAT=error)
1468 if (IND_ele==-1)call handle_error(IND_ele, "brpr_updateBurp: element 12101 not found in Block_OBS_MUL_CP")
1469 Call BURP_Set_Rval(Block_OBS_MUL_CP,NELE_IND =IND_ele,NVAL_IND =j,NT_IND = k,RVAL = OBS)
1470 end if
1471 if (iele == 12192) then
1472 IND_ele = BURP_Find_Element(Block_OBS_MUL_CP, ELEMENT=12239, IOSTAT=error)
1473 if (IND_ele==-1)call handle_error(IND_ele, "brpr_updateBurp: element 12239 not found in Block_OBS_MUL_CP")
1474 Call BURP_Set_Rval(Block_OBS_MUL_CP,NELE_IND =IND_ele,NVAL_IND =j,NT_IND = k,RVAL = OBS)
1475 end if
1476 end if
1477
1478 IF (HIRES .and. KOBSN > 0 ) THEN
1479 STATUS=obs_headElem_i(obsdat,OBS_ST1,OBSN )
1480 STATUS_HIRES=ior(STATUS_HIRES,STATUS)
1481 END IF
1482
1483 end do ELEMS
1484
1485 IF (HIRES .and. KOBSN > 0 ) OBSN=OBSN +1
1486
1487 end do LEVELS
1488
1489 if ( REGRUP .and. KOBSN > 0 ) then
1490 STATUS=obs_headElem_i(obsdat,OBS_ST1,OBS_START )
1491 STATUS=IBSET(STATUS,BIT_STATUS)
1492 ind055200 = BURP_Find_Element(Block_FLG_CP, ELEMENT=055200)
1493 if (ind055200==-1)call handle_error(ind055200, "brpr_updateBurp: element 55200 not found in Block_FLG_CP")
1494 call BURP_Set_tblval( Block_FLG_CP, NELE_IND =ind055200,NVAL_IND =1,NT_IND = k ,TBLVAL = STATUS )
1495 OBSN=OBSN +1
1496 OBS_START=OBS_START +1
1497 end if
1498
1499 end do regrup_LOOP
1500
1501 IF (HIRES .and. KOBSN > 0 .and. .not. regrup ) THEN
1502 STATUS=obs_headElem_i(obsdat,OBS_ST1,OBS_START)
1503!pik 8-2014 STATUS=IBSET(STATUS,BIT_STATUS)
1504 STATUS_HIRES=IBSET(STATUS_HIRES,BIT_STATUS)
1505 call BURP_Set_Property(CP_RPT ,FLGS =STATUS_HIRES)
1506 END IF
1507 IF (HIRES )OBS_START=OBSN
1508 IF (HIRES )SAVE_OBS=OBS_START
1509 IF (REGRUP)OBS_START=OBSN
1510
1511 IF ( .not. HIRES .and. .not. regrup .and. KOBSN > 0 ) THEN
1512 STATUS=obs_headElem_i(obsdat,OBS_ST1,OBS_START)
1513 STATUS=IBSET(STATUS,BIT_STATUS)
1514 OBS_START=OBSN +1
1515 OBSN=OBSN +1
1516 call BURP_Set_Property(CP_RPT ,FLGS =STATUS)
1517 END IF
1518 IF ( .not. HIRES .and. .not. regrup .and. KOBSN == 0 ) THEN
1519 write(*,*) ' KOBSN=0 stnid=',stnid
1520 END IF
1521 IF ( .not. HIRES .and. regrup .and. KOBSN == 0 ) THEN
1522 numHeader = obs_numHeader(obsdat)
1523 write(*,*)' KOBSN=0 regrup stnid=',kk,stnid,obsn,numHeader
1524 END IF
1525
1526 IF (REGRUP) SAVE_OBS=OBS_START
1527
1528 call BURP_Reduce_Block(BLOCK_OMA, NEW_NELE =il_index )
1529 call BURP_Reduce_Block(BLOCK_OMP, NEW_NELE =il_index )
1530 call BURP_Reduce_Block(BLOCK_OER, NEW_NELE =il_index )
1531 call BURP_Reduce_Block(BLOCK_FGE, NEW_NELE =il_index )
1532 call BURP_Reduce_Block(BLOCK_FSO, NEW_NELE =il_index )
1533 call BURP_Set_Property(BLOCK_OBS_MUL_CP ,BFAM =0)
1534 call BURP_Set_Property(BLOCK_MAR_MUL_CP ,BFAM =0)
1535
1536 call BURP_Write_Block( CP_RPT, BLOCK_OBS_MUL_CP,&
1537 ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
1538 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_OBS_MUL_CP")
1539 call BURP_Write_Block( CP_RPT, BLOCK_MAR_MUL_CP,&
1540 ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .FALSE., IOSTAT= error)
1541 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_MAR_MUL_CP")
1542
1543 do item=1,BN_ITEMS
1544
1545 if ( BITEMLIST(item) == 'OMA') then
1546 call BURP_Write_Block( CP_RPT, BLOCK_OMA,&
1547 ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
1548 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_OMA")
1549 end if
1550 if ( BITEMLIST(item) == 'OMP') then
1551 call BURP_Write_Block( CP_RPT, BLOCK_OMP,&
1552 ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
1553 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_OMP")
1554 end if
1555 if ( BITEMLIST(item) == 'OER') then
1556 if (.not.LBLOCK_OER_CP) then
1557 call BURP_Write_Block( CP_RPT, BLOCK_OER,&
1558 ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
1559 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_OER")
1560 else
1561 call BURP_Set_Property(BLOCK_OER_CP ,BKTYP =new_bktyp)
1562 call BURP_Write_Block( CP_RPT, BLOCK_OER_CP,&
1563 ENCODE_BLOCK = .FALSE., CONVERT_BLOCK = .FALSE., IOSTAT= error)
1564 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_OER_CP")
1565 end if
1566 end if
1567 if ( BITEMLIST(item) == 'FGE') then
1568 if (.not.LBLOCK_FGE_CP) then
1569 call BURP_Write_Block( CP_RPT, BLOCK_FGE,&
1570 ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
1571 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_FGE")
1572 else
1573 call BURP_Set_Property(BLOCK_FGE_CP ,BKTYP =new_bktyp)
1574 call BURP_Write_Block( CP_RPT, BLOCK_FGE_CP,&
1575 ENCODE_BLOCK = .FALSE., CONVERT_BLOCK = .FALSE., IOSTAT= error)
1576 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_FGE_CP")
1577 end if
1578 end if
1579 if ( BITEMLIST(item) == 'FSO') then
1580 call BURP_Write_Block( CP_RPT, BLOCK_FSO,&
1581 ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
1582 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_FSO")
1583 end if
1584
1585 end do
1586
1587 if (regrup ) OBS_START = OBSN
1588 if( .not. hires ) SAVE_OBS = OBS_START
1589
1590 end if ! bl == 4
1591
1592 if ( bl == 6 ) then
1593 call BURP_Write_Block( CP_RPT, BLOCK_GEN, ENCODE_BLOCK = .FALSE., &
1594 CONVERT_BLOCK = .FALSE., IOSTAT = error)
1595 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_GEN")
1596 end if
1597
1598 ! descriptor block (btyp = 0010 100000X XXXX)
1599
1600 BTYP10des = 160
1601
1602 !if ( BTYP10 - BTYP10des == 0 ) then
1603 if ( bl == 1 ) then
1604 OBS_START=SAVE_OBS
1605 end if
1606
1607 !==================== IASI SPECIAL BLOCK==================
1608 if ( (BTYP == 9217 .or. BTYP == 15361) .and. IDTYP == 186 ) then
1609 call BURP_Write_Block( CP_RPT, BLOCK_in, ENCODE_BLOCK = .FALSE., &
1610 CONVERT_BLOCK = .FALSE., IOSTAT= error)
1611 call handle_error(error, "brpr_updateBurp: BURP_Write_Block bloc special IASI")
1612 end if
1613 !==================== IASI SPECIAL BLOCK==================
1614
1615 !==================== GPSRO BLOCKS TO KEEP IF THEY EXIST===
1616 if ( IDTYP == codtyp_get_codtyp('ro') ) then
1617 if (BTYP == 9217) then
1618 Call BURP_Write_Block( CP_RPT, BLOCK_OBS_BND, &
1619 ENCODE_BLOCK = .FALSE., CONVERT_BLOCK = .FALSE., &
1620 IOSTAT= error)
1621 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_OBS_BND")
1622 end if
1623 if (BTYP == 15361) then
1624 Call BURP_Write_Block( CP_RPT, BLOCK_MAR_BND, &
1625 ENCODE_BLOCK = .FALSE., CONVERT_BLOCK = .FALSE., &
1626 IOSTAT= error)
1627 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_MAR_BND")
1628 end if
1629 if (BTYP == 9220) then
1630 Call BURP_Write_Block( CP_RPT, BLOCK_ORB, &
1631 ENCODE_BLOCK = .FALSE., CONVERT_BLOCK = .FALSE., &
1632 IOSTAT= error)
1633 call handle_error(error, "brpr_updateBurp: BURP_Write_Block CP_RPT BLOCK_ORB")
1634 end if
1635 end if
1636 !==================== GPSRO BLOCKS=========================
1637 end do BLOCKS1
1638
1639 if ( REGRUP ) then
1640 call BURP_Write_Block( CP_RPT, Block_FLG_CP, ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .FALSE.)
1641 end if
1642
1643 call BURP_Delete_Report(File_in,Rpt_in, IOSTAT=error)
1644 call handle_error(error, "brpr_updateBurp: BURP_Delete_Report")
1645 call BURP_Write_Report(File_in,CP_RPT,IOSTAT= error)
1646 call handle_error(error, "brpr_updateBurp: BURP_Write_Report")
1647
1648 end do REPORTS
1649
1650 end if
1651
1652 call cleanup()
1653
1654 write(*,*) ' BURPFILE UPDATED SUM = ',trim(brp_file),SUM
1655
1656 contains
1657
1658 !--------- cleanup -----
1659 subroutine cleanup()
1660 implicit none
1661
1662 ! Locals:
1663 integer :: errors(26)
1664
1665 errors(:) = 0
1666 deallocate(address, stat=errors(1))
1667 call BURP_Free(Rpt_in,CP_RPT, iostat=errors(2))
1668 call BURP_Free(Block_in, iostat=errors(3))
1669 call BURP_Free(Block_OMA, iostat=errors(4))
1670 call BURP_Free(Block_OMP, iostat=errors(5))
1671 call BURP_Free(Block_OER, iostat=errors(6))
1672 call BURP_Free(Block_FGE, iostat=errors(7))
1673 call BURP_Free(Block_FSO, iostat=errors(8))
1674 call BURP_Free(Block_OMA_SFC, iostat=errors(9))
1675 call BURP_Free(Block_OMP_SFC, iostat=errors(10))
1676 call BURP_Free(Block_OER_SFC, iostat=errors(11))
1677 call BURP_Free(Block_FGE_SFC, iostat=errors(12))
1678 call BURP_Free(Block_FSO_SFC, iostat=errors(13))
1679 call BURP_Free(Block_FLG_SFC, iostat=errors(14))
1680 call BURP_Free(Block_FLG, iostat=errors(15))
1681 call BURP_Free(Block_FLG_CP, iostat=errors(16))
1682 call BURP_Free(Block_MAR_MUL_CP, iostat=errors(17))
1683 call BURP_Free(Block_MAR_SFC_CP, iostat=errors(18))
1684 call BURP_Free(Block_OBS_MUL_CP, iostat=errors(19))
1685 call BURP_Free(Block_OBS_SFC_CP, iostat=errors(20))
1686 call BURP_Free(Block_GEN, iostat=errors(21))
1687 call BURP_Free(Block_OBS_BND, iostat=errors(23))
1688 call BURP_Free(Block_MAR_BND, iostat=errors(24))
1689 call BURP_Free(Block_ORB, iostat=errors(25))
1690 call BURP_Free(File_in, iostat=errors(26))
1691 !Should we abort here ?
1692 if (any(errors /= 0)) write(*,*) "brpr_updateBurp: error while deallocating memory: ", errors(:)
1693 if (associated(tree)) call kdtree2_destroy(tree)
1694 if (allocated(PPPandVNM)) deallocate(PPPandVNM)
1695 if (allocated(bodyIndexList)) deallocate(bodyIndexList)
1696
1697 end subroutine cleanup
1698
1699 !--------- handle_error -----
1700 subroutine handle_error(icode, errorMessage)
1701 implicit none
1702
1703 ! Arguments:
1704 character(len=*), intent(in) :: errorMessage
1705 integer, intent(in) :: icode
1706
1707 if ( icode /= burp_noerr ) then
1708 write(*,*) 'error code', icode
1709 write(*,*) BURP_STR_ERROR()
1710 write(*,*) "history"
1711 call BURP_STR_ERROR_HISTORY()
1712 call cleanup()
1713 call utl_abort(trim(errorMessage))
1714 end if
1715 end subroutine handle_error
1716
1717 end subroutine brpr_updateBurp
1718
1719
1720 SUBROUTINE BRPACMA_NML(NML_SECTION, beSilent_opt)
1721
1722 IMPLICIT NONE
1723
1724 ! Arguments:
1725 character(len=*), intent(in) :: NML_SECTION
1726 logical, optional, intent(in) :: beSilent_opt
1727
1728 ! Locals:
1729 logical :: beSilent
1730 INTEGER :: NULNAM,IER,FNOM,FCLOS
1731 CHARACTER *256 :: NAMFILE
1732 integer :: itemIndex
1733
1734 NAMELIST /NAMBURP_FILTER_CONV/NELEMS, BLISTELEMENTS, &
1735 ENFORCE_CLASSIC_SONDES, UA_HIGH_PRECISION_TT_ES, UA_FLAG_HIGH_PRECISION_TT_ES, READ_QI_GA_MT_SW
1736 NAMELIST /NAMBURP_FILTER_SFC/ NELEMS_SFC, BLISTELEMENTS_SFC, &
1737 NELEMS_GPS, LISTE_ELE_GPS
1738 NAMELIST /NAMBURP_FILTER_TOVS/NELEMS, BLISTELEMENTS
1739 NAMELIST /NAMBURP_FILTER_CHM_SFC/NELEMS_SFC, BLISTELEMENTS_SFC
1740 NAMELIST /NAMBURP_FILTER_CHM/NELEMS, BLISTELEMENTS
1741 NAMELIST /NAMBURP_UPDATE/BN_ITEMS, BITEMLIST, TYPE_RESUME
1742
1743 if (present(beSilent_opt)) then
1744 beSilent = beSilent_opt
1745 else
1746 beSilent = .false.
1747 end if
1748
1749 NAMFILE=trim("flnml")
1750 nulnam=0
1751 IER=FNOM(NULNAM,NAMFILE,'R/O',0)
1752 write(*,*) ' READ NML_SECTION =',trim(NML_SECTION)
1753
1754 SELECT CASE(trim(NML_SECTION))
1755 CASE( 'namburp_filter_gp')
1756 nElems_gps = MPC_missingValue_INT
1757 LISTE_ELE_GPS(:) = mpc_missingValue_int
1758 READ(NULNAM,NML=NAMBURP_FILTER_SFC)
1759 call getListAndSize(nElems_gps, LISTE_ELE_GPS, "nElems_gps")
1760 if (.not.beSilent) write(*,nml=NAMBURP_FILTER_SFC)
1761 if (nElems_gps == 0) then
1762 call utl_abort('brpacma_nml (burpread_mod): no GPS elements specified in NAMBURP_FILTER_SFC')
1763 end if
1764 CASE( 'namburp_filter_sfc')
1765 nElems_sfc = MPC_missingValue_INT
1766 bListElements_sfc(:) = mpc_missingValue_int
1767 READ(NULNAM,NML=NAMBURP_FILTER_SFC)
1768 call getListAndSize(nelems_sfc, blistelements_sfc, "nelems_sfc")
1769 if (.not.beSilent) write(*,nml=NAMBURP_FILTER_SFC)
1770 if (nElems_sfc == 0) then
1771 call utl_abort('brpacma_nml (burpread_mod): no SFC elements specified in NAMBURP_FILTER_SFC')
1772 end if
1773 CASE( 'namburp_filter_conv')
1774 nElems = MPC_missingValue_INT
1775 bListElements(:) = mpc_missingValue_int
1776 READ(NULNAM,NML=NAMBURP_FILTER_CONV)
1777 call getListAndSize(nelems, blistelements, "nelems")
1778 if (.not.beSilent) write(*,nml=NAMBURP_FILTER_CONV)
1779 if (nElems == 0) then
1780 call utl_abort('brpacma_nml (burpread_mod): no elements specified in NAMBURP_FILTER_CONV')
1781 end if
1782 CASE( 'namburp_filter_tovs')
1783 nElems = MPC_missingValue_INT
1784 bListElements(:) = mpc_missingValue_int
1785 READ(NULNAM,NML=NAMBURP_FILTER_TOVS)
1786 call getListAndSize(nelems, blistelements, "nelems")
1787 if (.not.beSilent) write(*,nml=NAMBURP_FILTER_TOVS)
1788 if (nElems == 0) then
1789 call utl_abort('brpacma_nml (burpread_mod): no elements specified in NAMBURP_FILTER_TOVS')
1790 end if
1791 CASE( 'namburp_filter_chm_sfc')
1792 nElems_sfc = MPC_missingValue_INT
1793 bListElements_sfc(:) = mpc_missingValue_int
1794 READ(NULNAM,NML=NAMBURP_FILTER_CHM_SFC)
1795 call getListAndSize(nelems_sfc, blistelements_sfc, "nelems_sfc")
1796 if (.not.beSilent) write(*,nml=NAMBURP_FILTER_CHM_SFC)
1797 if (nElems_sfc == 0) then
1798 call utl_abort('brpacma_nml (burpread_mod): no elements specified in NAMBURP_FILTER_CHM_SFC')
1799 end if
1800 CASE( 'namburp_filter_chm')
1801 nElems = MPC_missingValue_INT
1802 bListElements(:) = mpc_missingValue_int
1803 READ(NULNAM,NML=NAMBURP_FILTER_CHM)
1804 call getListAndSize(nelems, blistelements, "nelems")
1805 if (.not.beSilent) write(*,nml=NAMBURP_FILTER_CHM)
1806 if (nElems == 0) then
1807 call utl_abort('brpacma_nml (burpread_mod): no elements specified in NAMBURP_FILTER_CHM')
1808 end if
1809 CASE( 'namburp_update')
1810 BN_ITEMS = MPC_missingValue_INT
1811 bItemList(:) = '***'
1812 READ(NULNAM,NML=NAMBURP_UPDATE)
1813 if (BN_ITEMS /= MPC_missingValue_INT) then
1814 call utl_abort('brpacma_nml: check namburp_update namelist section, you should remove BN_ITEMS')
1815 end if
1816 BN_ITEMS = 0
1817 do itemIndex = 1, maxItems
1818 if (bItemList(itemIndex) == '***') exit
1819 BN_ITEMS = BN_ITEMS + 1
1820 end do
1821 if (.not.beSilent) write(*,nml=NAMBURP_UPDATE)
1822 CASE default
1823 call utl_abort('brpacma_nml: unknown namelist section ' // trim(NML_SECTION))
1824 END SELECT
1825
1826 ier=FCLOS(NULNAM)
1827
1828 contains
1829
1830 subroutine getListAndSize(numberElements, list, variable)
1831 implicit none
1832
1833 ! Arguments:
1834 integer, intent(inout) :: numberElements
1835 integer, intent(in) :: list(:)
1836 character(len=*), intent(in) :: variable
1837
1838 ! Locals:
1839 integer :: listIndex
1840
1841 if (numberElements /= MPC_missingValue_INT) then
1842 call utl_abort('brpacma_nml: check '//trim(nml_section)//' namelist section, you should remove '//trim(variable))
1843 end if
1844 numberElements = 0
1845 do listIndex = 1, size(list)
1846 if (list(listIndex) == MPC_missingValue_INT) exit
1847 numberElements = numberElements + 1
1848 end do
1849
1850 end subroutine getListAndSize
1851
1852 END SUBROUTINE BRPACMA_NML
1853
1854
1855 subroutine brpr_readBurp(obsdat,familytype,brp_file,filenumb)
1856 !
1857 !:Purpose: Select variables relative to airs in burp file. Read burp file.
1858
1859 !***********************************************************************
1860 !
1861 ! WHEN SEARCHING FOR A SPECIFIC BLOCK BY ITS BTYP, VALUES OF
1862 ! BIT 0 TO 3 ARE IRRELEVANT WHILE BIT 4 IS 0 FOR GLOBAL AND 1
1863 ! FOR REGIONAL MODEL. HERE, WE SEARCH BLOCK BY THEIR FIRST
1864 ! 10 BITS (BIT 5 TO 14).
1865 !
1866 !***********************************************************************
1867 IMPLICIT NONE
1868
1869 ! Arguments:
1870 type (struct_obs), intent(inout) :: obsdat
1871 character(len=2), intent(in) :: FAMILYTYPE
1872 character(len=*), intent(in) :: BRP_FILE ! name of burp file
1873 integer, intent(in) :: FILENUMB
1874
1875 ! Locals:
1876 CHARACTER *2 :: UNI_FAMILYTYPE
1877
1878 TYPE(BURP_FILE) :: FILE_IN
1879 TYPE(BURP_RPT) :: RPT_IN
1880 TYPE(BURP_BLOCK) :: BLOCK_IN
1881
1882 CHARACTER(LEN=5) :: FAMILYTYPE2
1883 CHARACTER(LEN=9) :: OPT_MISSING
1884 integer :: BTYP,BFAM,BKSTP,BTYP10,BTYP10FLG_uni,BTYP10obs_uni
1885 integer :: BTYP10DES,BTYP10INF,BTYP10OBS,BTYP10FLG
1886
1887 integer :: NB_RPTS,REF_RPT,REF_BLK,COUNT, numHeader
1888 INTEGER, ALLOCATABLE :: ADDRESS(:)
1889
1890 real , ALLOCATABLE :: OBSVALUE(:,:,:),OBSVALUE_SFC(:,:,:)
1891 real , ALLOCATABLE :: OBSERV (:,:), OBSERV_SFC(:,:)
1892 real , ALLOCATABLE :: BiasCorrection_sfc(:,:,:)
1893 real , ALLOCATABLE :: BCOR_SFC(:,:)
1894 INTEGER, PARAMETER :: MAXRONVAL=500
1895 real :: ROLAT(MAXRONVAL), ROLON(MAXRONVAL)
1896
1897 INTEGER, ALLOCATABLE :: MTVAL(:)
1898 INTEGER, ALLOCATABLE :: HAVAL(:), GAVAL(:), QI1VAL(:) ,QI2VAL(:), LSVAL(:)
1899 real(pre_obsReal) , ALLOCATABLE :: azimuth(:)
1900 INTEGER, ALLOCATABLE :: QCFLAG (:,:,:), QCFLAG_SFC(:,:,:)
1901 INTEGER, ALLOCATABLE :: QCFLAGS (:,:), QCFLAGS_SFC(:,:)
1902 integer, allocatable :: hiresTimeFlag(:,:), hiresLatFlag(:,:)
1903
1904 real , ALLOCATABLE :: VCOORD (:,:), VCOORD_SFC(:)
1905 real , ALLOCATABLE :: VCORD (:)
1906
1907 INTEGER, ALLOCATABLE :: LAT(:),LON(:),HHMM(:),DATE(:),GLBFLAG(:)
1908 real , ALLOCATABLE :: HLAT(:,:), HLON(:,:), HTIME(:,:)
1909 INTEGER, ALLOCATABLE :: PHASE(:,:)
1910 INTEGER, ALLOCATABLE :: dataQcFlagLEV(:),dataQcFlag2(:,:)
1911 integer :: dataQcFlagLEV_sfc(1)
1912 INTEGER, ALLOCATABLE :: dataCloudFracLEV(:),dataCloudFrac(:,:)
1913 integer :: dataCloudFracLEV_sfc(1)
1914 real , ALLOCATABLE :: HLAT_SFC(:),HLON_SFC(:),HTIME_SFC(:)
1915
1916 real , ALLOCATABLE :: RINFO(:,:)
1917 real , ALLOCATABLE :: TRINFO(:)
1918
1919 real , ALLOCATABLE :: EMIS(:,:), SURF_EMIS(:)
1920 real , ALLOCATABLE :: BCOR(:,:), BiasCorrection(:,:)
1921 real , ALLOCATABLE :: BCOR2(:,:,:), BiasCorrection2(:,:)
1922
1923 REAL(pre_obsReal), ALLOCATABLE :: CFRAC(:,:)
1924
1925 REAL(pre_obsReal), ALLOCATABLE :: RADMOY(:,:,:)
1926 REAL(pre_obsReal), ALLOCATABLE :: radstd(:,:,:)
1927
1928 integer :: LISTE_INFO(31),LISTE_ELE(maxElements),LISTE_ELE_SFC(maxElements)
1929
1930 integer :: NBELE,NVALE,NTE
1931 integer :: J,JJ,K,KK,KL,IL,ERROR,OBSN
1932 integer :: info_elepos,IND_ELE,IND_VCOORD,IND_QCFLAG,IND_SW
1933 integer :: IND055200,IND4208,ind4197,IND5002,IND6002,ind_al,IND5001,IND6001
1934 integer :: IND_LAT,IND_LON,IND_TIME,IND_EMIS,IND_BCOR,IND_PHASE,IND_BCOR_TT,IND_BCOR_HU
1935 integer :: FLAG_PASSAGE1,FLAG_PASSAGE2,FLAG_PASSAGE3,FLAG_PASSAGE4
1936 integer :: IND_dataQcFlag0, IND_dataQcFlag1, IND_dataQcFlag2, IND_dataCloudFrac
1937
1938 integer :: vcord_type(10),SUM,vcoord_type
1939 REAL(pre_obsReal) :: RELEV,XLAT,XLON,RELEV2
1940 real :: XTIME,ROLAT0,ROLON0,ROLAT1,ROLON1
1941 integer :: status ,idtyp,lati,long,dx,dy,elev
1942 integer :: drnd,date_h,hhmm_h,oars,runn,YMD_DATE,HM,kstamp,kstamp2,HM_SFC,YMD_DATE_SFC
1943
1944 integer :: iele,NELE,NELE_SFC,NVAL,NT,NELE_INFO,LN
1945 integer :: bit_alt,btyp_offset,btyp_offset_uni
1946 character(len = 5) :: BURP_TYP
1947 CHARACTER(LEN=9) :: STNID,STN_RESUME
1948 LOGICAL :: HIRES,HIRES_SFC,HIPCS,phasePresent,LOK,LROK
1949 integer :: NDATA,NDATA_SF
1950 integer :: IER,date2,time2,time_sonde,NEWDATE
1951 real :: RAD_MOY,RAD_STD
1952 integer :: iclass,NCHANAVHRR,NCLASSAVHRR,ichan,iobs,inorm
1953 integer :: infot
1954 integer :: ILEMZBCOR, ILEMTBCOR, ILEMHBCOR
1955
1956
1957 LISTE_INFO(1:31) = (/ &
1958 1007,002019,007024,007025 ,005021, 005022, 008012, 013039,020010,2048, &
1959 2022,33060,33062,33039,10035,10036,08046,5043, 013209,clwFgElementId, &
1960 1033,2011,4197,siFgElementId,13208,5040,33078,33079,33080,020029, &
1961 25174 /)
1962
1963 RELEV2=0.0
1964 FAMILYTYPE2= 'SCRAP'
1965 vcord_type(:)=-1
1966 vcord_type(1)=0
1967 NELE_INFO=1
1968 NELE_SFC=0
1969 NELE=0
1970 NELEMS=0
1971 NELEMS_SFC=0
1972 NELEMS_GPS=0
1973 ILEMZBCOR=15234 ! bcor element for GP ZTD observations
1974 ILEMTBCOR=12204 ! bcor element for altitude TT observations
1975 ILEMHBCOR=12243 ! bcor element for altitude ES observations
1976 ENFORCE_CLASSIC_SONDES=.false.
1977 UA_HIGH_PRECISION_TT_ES=.false.
1978 UA_FLAG_HIGH_PRECISION_TT_ES=.false.
1979 READ_QI_GA_MT_SW=.false.
1980 UNI_FAMILYTYPE = 'SF'
1981 LISTE_ELE_SFC(:)=-1
1982 LISTE_ELE(:)=-1
1983 SELECT CASE(trim(FAMILYTYPE))
1984 CASE('UA')
1985 BURP_TYP='multi'
1986 vcord_type(1)=7004
1987
1988 call BRPACMA_NML('namburp_filter_sfc')
1989
1990 FAMILYTYPE2= 'UA'
1991 ENFORCE_CLASSIC_SONDES=.false.
1992
1993 call BRPACMA_NML('namburp_filter_conv')
1994 NELE_INFO=23
1995 CASE('AI')
1996 BURP_TYP='uni'
1997 vcord_type(1)=7004
1998
1999 call BRPACMA_NML('namburp_filter_conv')
2000 CASE('AL')
2001 BURP_TYP='uni'
2002 vcord_type(1)=7071
2003
2004 call BRPACMA_NML('namburp_filter_conv')
2005 CASE('SW')
2006 BURP_TYP='uni'
2007 vcord_type(1)=7004
2008
2009 call BRPACMA_NML('namburp_filter_conv')
2010 CASE('SF')
2011 BURP_TYP='uni'
2012 vcord_type(1)=0
2013
2014 call BRPACMA_NML('namburp_filter_sfc')
2015
2016 FAMILYTYPE2= 'SFC'
2017 CASE('GP')
2018 BURP_TYP='uni'
2019 vcord_type(1)=0
2020
2021 call BRPACMA_NML('namburp_filter_gp')
2022
2023 FAMILYTYPE2= 'SFC'
2024 UNI_FAMILYTYPE = 'GP'
2025 CASE('SC')
2026 vcord_type(1)=0
2027 BURP_TYP='uni'
2028
2029 call BRPACMA_NML('namburp_filter_sfc')
2030 ! The following 2 lines are necessary because when this routine reads scatterometer
2031 ! burp files they are considered (possibly incorrectly) as non-surface observations
2032 ! but during update they are considered as surface observations
2033 NELEMS=NELEMS_SFC
2034 BLISTELEMENTS(1:NELEMS) = BLISTELEMENTS_SFC(1:NELEMS)
2035 NELEMS_SFC=0
2036
2037 FAMILYTYPE2= 'UASFC2'
2038 CASE('PR')
2039 BURP_TYP='multi'
2040 vcord_type(1)=7006
2041
2042 call BRPACMA_NML('namburp_filter_conv')
2043 CASE('RO')
2044 BURP_TYP='multi'
2045 vcord_type(1)=7007
2046 vcord_type(2)=7040
2047
2048 call BRPACMA_NML('namburp_filter_conv')
2049 NELE_INFO=18
2050 CASE('TO')
2051 BURP_TYP='multi'
2052 vcord_type(1)=5042
2053 vcord_type(2)=2150
2054
2055 call BRPACMA_NML('namburp_filter_tovs')
2056
2057 NELE_INFO=31
2058 CASE('CH')
2059
2060 BURP_TYP='multi' ! Both 'multi' and 'uni' are possible for this family.
2061 ! 'uni' level data are assumed not to have any accompanynig vertical
2062 ! coordinate element in addition to having only one level.
2063 vcord_type(1:8) = (/7004,7204,7006,7007,5042,2150,2071,0/) ! 0 must be at end.
2064 NELE_INFO=18
2065
2066 UNI_FAMILYTYPE = 'CH'
2067 call BRPACMA_NML('namburp_filter_chm_sfc')
2068
2069 FAMILYTYPE2='CH'
2070 call BRPACMA_NML('namburp_filter_chm')
2071 CASE default
2072 call utl_abort('brpr_readBurp: unknown familyType : ' // trim(familyType))
2073 END SELECT
2074
2075 NELE=NELEMS
2076 LISTE_ELE(1:NELE)=BLISTELEMENTS(1:NELE)
2077 if (trim(FAMILYTYPE) == 'GP') then
2078 ! for GP ignore BLISTELEMENTS_SFC, and use instead LISTE_ELE_GPS
2079 NELE_SFC = NELEMS_GPS
2080 LISTE_ELE_SFC(1:NELE_SFC)=LISTE_ELE_GPS(1:NELE_SFC)
2081 else
2082 NELE_SFC = NELEMS_SFC
2083 LISTE_ELE_SFC(1:NELE_SFC)=BLISTELEMENTS_SFC(1:NELE_SFC)
2084 end if
2085
2086 if (NELE > 0) then
2087 write(*,*) ' LISTE_ELE =',LISTE_ELE
2088 call ovt_setup(LISTE_ELE(1:NELE))
2089 end if
2090 if (NELE_SFC > 0) then
2091 write(*,*) ' LISTE_ELE_SFC =',LISTE_ELE_SFC(1:NELE_SFC)
2092 call ovt_setup(LISTE_ELE_SFC(1:NELE_SFC))
2093 end if
2094
2095 btyp_offset_uni=-999
2096 btyp_offset=-999
2097 if (trim(BURP_TYP) == 'uni') then
2098 btyp_offset=256
2099 else
2100 btyp_offset=0
2101 end if
2102
2103 if (trim(familytype) == 'AL') then
2104 btyp_offset=255
2105 end if
2106
2107 if (TRIM(FAMILYTYPE2) == 'SFC') then
2108 btyp_offset= btyp_offset+32
2109 btyp_offset_uni= 256 +32
2110 elseif ( TRIM(FAMILYTYPE2) == 'UA') then
2111 btyp_offset_uni= 256 +32
2112 elseif (TRIM(FAMILYTYPE2) == 'CH') then
2113 btyp_offset_uni= 256
2114 else
2115 btyp_offset_uni= -999 ! set to -999 when not used
2116 end if
2117
2118 write(*,*) '-----------------------------------------------'
2119 write(*,*) '----------- BEGIN brpr_readBurp ------------'
2120 write(*,*) 'FAMILYTYPE vcord_type =',FAMILYTYPE,vcord_type
2121 write(*,*) 'BURP_TYP btyp_offset =',BURP_TYP, btyp_offset
2122 write(*,*) '-----------------------------------------------'
2123
2124
2125 ! initialisation
2126 ! --------------
2127 SUM=0
2128 flag_passage1 = 0
2129 flag_passage2 = 0
2130 flag_passage3 = 0
2131 flag_passage4 = 0
2132 ! initialiase the qc flag2 indice
2133
2134 opt_missing = 'MISSING'
2135
2136
2137 call BURP_Set_Options( &
2138 & REAL_OPTNAME = opt_missing, &
2139 & REAL_OPTNAME_VALUE = MPC_missingValue_R4, &
2140 & CHAR_OPTNAME = 'MSGLVL', &
2141 & CHAR_OPTNAME_VALUE = 'FATAL', &
2142 & IOSTAT = error )
2143 call handle_error(error, "brpr_readBurp: BURP_Set_Options")
2144
2145 call BURP_Init(File_in ,IOSTAT=error)
2146 call handle_error(error, "brpr_readBurp: BURP_init File_in")
2147 call BURP_Init(Rpt_in)
2148 call BURP_Init(Block_in)
2149
2150 ! opening file
2151 write(*,*) 'OPENING BURP FILE FOR READING = ', trim(brp_file)
2152
2153 call BURP_New(File_in, FILENAME = brp_file, &
2154 & MODE = FILE_ACC_READ, &
2155 & IOSTAT = error )
2156 call handle_error(error, "brpr_readBurp: Burp_New. Problem opening " // trim(brp_file))
2157
2158
2159 ! obtain input burp file number of reports
2160
2161 call BURP_Get_Property(File_in, NRPTS=nb_rpts)
2162
2163 write(*,*) '-----------------------------------------'
2164 write(*,*) 'IOSTAT =',error
2165 write(*,*) 'NUMBER OF REPORTS IN FILE = ',nb_rpts
2166 write(*,*) '-----------------------------------------'
2167
2168
2169 ! scan input burp file to get all reports address
2170
2171 Allocate(address(nb_rpts))
2172 address(:) = 0
2173 count = 0
2174 ref_rpt = 0
2175 bit_alt = 0
2176 stn_resume='NOT_FOUND'
2177
2178 do
2179 ref_rpt = BURP_Find_Report(File_in, &
2180 & REPORT = Rpt_in, &
2181 & SEARCH_FROM = ref_rpt, &
2182 & IOSTAT = error)
2183 call handle_error(error, "brpr_readBurp: BURP_Find_Report")
2184 call burp_get_property(Rpt_in, STNID = stnid )
2185 IF ( stnid(1:2) == ">>" ) then
2186 STN_RESUME=stnid
2187 TYPE_RESUME=STN_RESUME(3:9)
2188 SELECT CASE(stnid)
2189 CASE(">>BGCKALT", ">>POSTALT")
2190 bit_alt=1
2191 CASE(">>DERIALT")
2192 bit_alt=2
2193 CASE DEFAULT
2194 write(*,*) 'brpr_readBurp: WARNING: Unknown RESUME record found, assume BGCKALT'
2195 bit_alt=1
2196 END SELECT
2197 END IF
2198
2199 if (ref_rpt < 0) Exit
2200
2201 if (count == nb_rpts) then
2202 write(*,*) 'brpr_readBurp: ERROR: count = nb_rpts:',count,nb_rpts
2203 exit
2204 end if
2205
2206 count = count + 1
2207 address(count) = ref_rpt
2208 end do
2209
2210 if (stn_resume == 'NOT_FOUND') then
2211 write(*,*) 'brpr_readBurp: WARNING: No RESUME record found in this file, ' // &
2212 'check if already read in another file'
2213 ! try to get value from previously read file
2214 if ( type_resume /= 'UNKNOWN' ) then
2215 stn_resume = '>>' // type_resume
2216 SELECT CASE(stn_resume)
2217 CASE(">>BGCKALT", ">>POSTALT")
2218 bit_alt=1
2219 CASE(">>DERIALT")
2220 bit_alt=2
2221 CASE DEFAULT
2222 write(*,*) 'brpr_readBurp: WARNING: Unknown RESUME record found, assume BGCKALT'
2223 stn_resume = '>>BGCKALT'
2224 bit_alt=1
2225 END SELECT
2226 else
2227 write(*,*) 'brpr_readBurp: WARNING: No file read has RESUME record, assume BGCKALT'
2228 stn_resume = '>>BGCKALT'
2229 bit_alt=1
2230 end if
2231 end if
2232
2233 write(*,*) STN_RESUME,' bit_alt==== > ',bit_alt
2234
2235
2236 BTYP10obs = 291 -btyp_offset
2237 BTYP10obs_uni = 291 -btyp_offset_uni
2238 if (bit_alt == 2) btyp10obs = BTYP10obs - 2
2239 if (bit_alt == 2) btyp10obs_uni = BTYP10obs_uni - 2
2240
2241 BTYP10flg = 483 -btyp_offset
2242 BTYP10flg_uni = 483 -btyp_offset_uni
2243 if (bit_alt == 2) BTYP10flg = BTYP10flg - 2
2244 if (bit_alt == 2) BTYP10flg_uni = BTYP10flg_uni - 2
2245
2246 write(*, *) ' NUMBER OF VALID REPORTS IN FILE = ',count
2247 write(*, *) ' BTYP10obs BTYP10obs_uni = ',BTYP10obs,BTYP10obs_uni
2248
2249 if ( count > 0 ) then
2250 ! LOOP ON REPORTS
2251 REPORTS: do kk = 1, count
2252
2253 call BURP_Get_Report(File_in, &
2254 & REPORT = Rpt_in, &
2255 & REF = address(kk), &
2256 & IOSTAT = error)
2257 call handle_error(error, "brpr_readBurp: BURP_Get_Report")
2258 call burp_get_property(Rpt_in, &
2259 STNID = stnid ,TEMPS =hhmm_h,FLGS = status ,IDTYP =idtyp,LATI = lati &
2260 ,LONG = long ,DX = dx ,DY = dy,ELEV=elev,DRND =drnd,DATE =date_h &
2261 ,OARS =oars,RUNN=runn ,IOSTAT=error)
2262 call handle_error(error, "brpr_readBurp: burp_get_property")
2263 IF ( stnid(1:2) == ">>" ) cycle
2264 ! LOOP ON BLOCKS
2265
2266 ! Ensure the dataQcFlag arrays are not allocated before looping over blocks
2267 if (allocated(dataQcFlag2)) deallocate(dataQcFlag2)
2268 if (allocated(dataQcFlagLEV)) deallocate(dataQcFlagLEV)
2269
2270 ! Ensure the dataCloudFrac arrays are not allocated before looping over blocks
2271 if (allocated(dataCloudFrac)) deallocate(dataCloudFrac)
2272 if (allocated(dataCloudFracLEV)) deallocate(dataCloudFracLEV)
2273
2274 ref_blk = 0
2275
2276 HIRES=.FALSE.
2277 HIPCS=.FALSE.
2278 HIRES_SFC=.FALSE.
2279 phasePresent = .false.
2280 LROK = .false.
2281
2282 BLOCKS1: do
2283
2284 ref_blk = BURP_Find_Block(Rpt_in, &
2285 & BLOCK = Block_in, &
2286 & SEARCH_FROM = ref_blk, &
2287 & IOSTAT = error)
2288 call handle_error(error, "brpr_readBurp: BURP_Find_Block")
2289
2290 if (ref_blk < 0) EXIT BLOCKS1
2291
2292 call BURP_Get_Property(Block_in, &
2293 & NELE = nbele, &
2294 & NVAL = nvale, &
2295 & NT = nte, &
2296 & BFAM = bfam, &
2297 & BTYP = btyp, &
2298 & BKSTP = BKSTP, &
2299 & IOSTAT = error)
2300 call handle_error(error, "brpr_readBurp: BURP_Get_Property")
2301
2302 ! Read slant latlon if type is RO
2303 if (trim(familytype) == 'RO' .and. bfam == 0 .and. LROK == .FALSE.) then
2304 ROLAT0 = 0.01*lati- 90.
2305 ROLON0 = 0.01*long
2306 if (ROLON0 > 180.) ROLON0 = ROLON0-360.
2307 ROLAT(:) = ROLAT0
2308 ROLON(:) = ROLON0
2309 IND5001 = BURP_Find_Element(Block_in, ELEMENT = 5001)
2310 IND6001 = BURP_Find_Element(Block_in, ELEMENT = 6001)
2311 if (IND5001 > 0 .and. IND6001 > 0) then
2312 do j = 1, nvale
2313 ROLAT1 = BURP_Get_Rval(Block_in, &
2314 NELE_IND = IND5001, &
2315 NVAL_IND = j, &
2316 NT_IND = 1, IOSTAT = error)
2317 call handle_error(error, "brpr_readBurp: BURP_Get_Rval Block_in 5001")
2318 ROLON1 = BURP_Get_Rval(Block_in, &
2319 NELE_IND = IND6001, &
2320 NVAL_IND = j, &
2321 NT_IND = 1, IOSTAT = error)
2322 call handle_error(error, "brpr_readBurp: BURP_Get_Rval Block_in 6001")
2323 lok = ( -90.1 < ROLAT1 .and. ROLAT1 < 90.1) .and. &
2324 (-180.1 < ROLON1 .and. ROLON1 < 360.1)
2325 if (lok .and. j<=MAXRONVAL) then
2326 ROLAT(j) = ROLAT1
2327 ROLON(j) = ROLON1
2328 LROK = .TRUE.
2329 end if
2330 end do
2331 end if
2332 end if
2333
2334 ! observation block (btyp = 0100 100011X XXXX)
2335 if(trim(familytype) == 'AL')then
2336
2337 ! Fudge the block type, because the data are simulated
2338 if(btyp == 1024) then
2339 btyp=1152
2340 else if(btyp == 7168)then
2341 btyp=7296
2342 end if
2343 end if
2344 btyp10 = ishft(btyp,-5)
2345 if ( btyp10 == btyp10obs_uni .and. bkstp <= 4 ) then ! FAMILYTYPE = SF, GP data blocks
2346
2347 flag_passage3 = 1
2348
2349 allocate(obsvalue_sfc(NELE_SFC,1,nte))
2350 allocate(BiasCorrection_sfc(NELE_SFC,1,nte))
2351 allocate( OBSERV_SFC(NELE_SFC,1) )
2352 allocate( BCOR_SFC(NELE_SFC,1) )
2353
2354 allocate( vcoord_sfc(1))
2355
2356 vcoord_type=0
2357 vcoord_SFC(:) = 0
2358 obsvalue_sfc(:,:,:) = MPC_missingValue_R4
2359 BiasCorrection_sfc(:,:,:) = MPC_missingValue_R4
2360 IND_LAT = BURP_Find_Element(Block_in, ELEMENT=5001)
2361 IND_LON = BURP_Find_Element(Block_in, ELEMENT=6001)
2362 IND_TIME = BURP_Find_Element(Block_in, ELEMENT=4015)
2363 if (IND_LAT > 0 .and. IND_LON > 0 .and. IND_TIME > 0 ) HIRES_SFC=.true.
2364 if (HIRES_SFC) allocate(HLAT_SFC(nte),HLON_SFC(nte),HTIME_SFC(nte) )
2365 IF (HIRES_SFC) THEN
2366 do k=1,nte
2367 HLAT_SFC(k) =BURP_Get_Rval(Block_in, &
2368 & NELE_IND = IND_LAT, &
2369 & NVAL_IND = 1, &
2370 & NT_IND = k)
2371 HLON_SFC(k) =BURP_Get_Rval(Block_in, &
2372 & NELE_IND = IND_LON, &
2373
2374 & NVAL_IND = 1, &
2375 & NT_IND = k)
2376 HTIME_SFC(k)=BURP_Get_Rval(Block_in, &
2377 & NELE_IND = IND_TIME, &
2378 & NVAL_IND = 1, &
2379 & NT_IND = k)
2380 end do
2381 END IF
2382
2383 do IL = 1, NELE_SFC
2384
2385 iele = LISTE_ELE_SFC(IL)
2386 IND_ele = BURP_Find_Element(Block_in, ELEMENT=iele)
2387 if (IND_ele < 0 ) cycle
2388
2389 do k=1,nte
2390 obsvalue_sfc(IL,1,k) = BURP_Get_Rval(Block_in, &
2391 & NELE_IND = IND_ele, &
2392 & NVAL_IND = 1, &
2393 & NT_IND = k)
2394 end do
2395
2396 IND_ele = -1
2397 if (iele == BUFR_NEZD) then
2398 IND_ele = BURP_Find_Element(Block_in, ELEMENT=ILEMZBCOR)
2399 end if
2400 if (IND_ele > 0) then
2401 do k=1,nte
2402 BiasCorrection_sfc(IL,1,k) = BURP_Get_Rval(Block_in, &
2403 & NELE_IND = IND_ele, &
2404 & NVAL_IND = 1, &
2405 & NT_IND = k)
2406 end do
2407 end if
2408
2409 end do
2410
2411 end if
2412
2413 if ( btyp10 == btyp10flg_uni .and. bkstp <= 4 ) then ! FAMILYTYPE = SF, GP flag blocks
2414
2415 flag_passage4 = 1
2416
2417 allocate( qcflag_sfc (NELE_SFC,1,nte))
2418 allocate( qcflags_SFC(NELE_SFC,1) )
2419 QCFLAGS_SFC(:,:)=0
2420
2421 do IL = 1, NELE_SFC
2422 iele=LISTE_ELE_SFC(IL) + 200000
2423 IND_QCFLAG = BURP_Find_Element(Block_in, ELEMENT=iele)
2424 if (IND_QCFLAG < 0 ) cycle
2425 DO k=1,nte
2426 QCFLAG_sfc(IL,1,k) = BURP_Get_Tblval(Block_in, &
2427 & NELE_IND = IND_QCFLAG, &
2428 & NVAL_IND = 1, &
2429 & NT_IND = k)
2430 SUM = SUM +1
2431 END DO
2432 end do
2433 end if
2434
2435 if ( btyp10 == btyp10obs .and. bfam == 0 ) then ! non sfc-type DATA block
2436
2437 flag_passage3 = 1
2438
2439 NVAL=NVALE ; NT=NTE
2440 allocate(obsvalue(NELE,nvale,nte),VCOORD(nvale,nte))
2441 allocate(OBSERV(NELE,nvale))
2442 allocate(VCORD(nvale))
2443
2444 obsvalue(:,:,:) = MPC_missingValue_R4
2445 OBSERV (:,:) = MPC_missingValue_R4
2446 VCOORD (:,:) = 0.
2447 VCORD (:) = 0.
2448
2449 k=0
2450 IND_VCOORD=-1
2451 do while (vcord_type(k+1) /= -1 .and. IND_VCOORD == -1)
2452 k=k+1
2453 IND_VCOORD = BURP_Find_Element(Block_in, ELEMENT=vcord_type(k))
2454 end do
2455 vcoord_type=0
2456 IF (IND_VCOORD > 0) vcoord_type=vcord_type(k)
2457 !if (IND_VCOORD == -1)write(*,*) 'PAS DE COORDONNEE VERTICALE STNID=',STNID,trim(FAMILYTYPE)
2458
2459 ! LAT LON TIME IN DATA BLOCK
2460 IND_LAT = BURP_Find_Element(Block_in, ELEMENT=5001 )
2461 IND_LON = BURP_Find_Element(Block_in, ELEMENT=6001 )
2462 IND_TIME = BURP_Find_Element(Block_in, ELEMENT=4015 )
2463 IND_EMIS = BURP_Find_Element(Block_in, ELEMENT=55043)
2464
2465 if (IND_LAT > 0 .and. IND_LON > 0 .and. IND_TIME > 0 ) HIRES=.true.
2466
2467 IND_BCOR = -1
2468 IND_BCOR_TT = -1
2469 IND_BCOR_HU = -1
2470 IND_PHASE = -1
2471 phasePresent = .false.
2472 if ( FAMILYTYPE == 'TO' ) IND_BCOR = BURP_Find_Element(Block_in, ELEMENT=12233)
2473 if ( FAMILYTYPE == 'AI' .or. FAMILYTYPE2 == 'UA') then
2474 IND_BCOR_TT = BURP_Find_Element(Block_in, ELEMENT=ILEMTBCOR)
2475 IND_BCOR_HU = BURP_Find_Element(Block_in, ELEMENT=ILEMHBCOR)
2476 end if
2477 if ( FAMILYTYPE == 'AI' ) then
2478 IND_PHASE = BURP_Find_Element(Block_in, ELEMENT=8004)
2479 if (IND_PHASE > 0) then
2480 allocate( phase(nvale,nte) )
2481 phase(:,:) = MPC_missingValue_R4
2482 phasePresent = .true.
2483 end if
2484 end if
2485
2486 if( (TRIM(FAMILYTYPE2) == 'UA') .and. UA_HIGH_PRECISION_TT_ES ) HIPCS=.true.
2487
2488 if(HIRES) allocate(HLAT(nvale,nte),HLON(nvale,nte),HTIME(nvale,nte) )
2489
2490 ! If ATMS or AMSUA, or AMSUB read the element 33081 or 33082
2491 IND_dataQcFlag2 = -1
2492 if ( idtyp == 192 .or. idtyp == 164 .or. idtyp == 181 .or. idtyp == 182) then
2493 IND_dataQcFlag0 = BURP_Find_Element(Block_in, ELEMENT=33081)
2494 IND_dataQcFlag1 = BURP_Find_Element(Block_in, ELEMENT=33032)
2495 if ( IND_dataQcFlag0 > 0 .and. IND_dataQcFlag1 > 0 ) then
2496 call utl_abort('readBurp : Got two valid indices for IND_dataQcFlag2 in family' // trim(familyType))
2497 elseif ( IND_dataQcFlag0 > 0 .and. IND_dataQcFlag1 < 0 ) then
2498 IND_dataQcFlag2 = IND_dataQcFlag0
2499 elseif ( IND_dataQcFlag0 < 0 .and. IND_dataQcFlag1 > 0 ) then
2500 IND_dataQcFlag2 = IND_dataQcFlag1
2501 end if
2502 end if
2503
2504 ! Allocate arrays for dataQcFlag if they are found in the file
2505 if (IND_dataQcFlag2 > 0) then
2506 allocate(dataQcFlag2(nvale,nte))
2507 allocate(dataQcFlagLEV(nvale))
2508 dataQcFlag2(:,:) = MPC_missingValue_INT
2509 dataQcFlagLEV(:) = MPC_missingValue_INT
2510 end if
2511
2512 ! if CSR data idtyp = 185, then read ele 020081
2513 IND_dataCloudFrac = -1
2514 if ( idtyp == 185) then
2515 IND_dataCloudFrac = BURP_Find_Element(Block_in, ELEMENT=020081)
2516 end if
2517 ! Allocate arrays for dataCloudFrac if they are found in the file
2518 if (IND_dataCloudFrac > 0) then
2519 allocate(dataCloudFrac(nvale,nte))
2520 allocate(dataCloudFracLEV(nvale))
2521 dataCloudFrac(:,:) = MPC_missingValue_INT
2522 dataCloudFracLEV(:) = MPC_missingValue_INT
2523 end if
2524
2525
2526 allocate(EMIS(nvale,nte))
2527 allocate(SURF_EMIS(nvale))
2528 EMIS(:,:) = MPC_missingValue_R4
2529
2530 OBSVALUE(:,:,:) = MPC_missingValue_R4
2531
2532 if (IND_BCOR > 0) then ! TOVS
2533 allocate(BCOR(nvale,nte))
2534 allocate(BiasCorrection(nele,nvale))
2535 BiasCorrection(:,:) = 0.0
2536 BCOR(:,:) = MPC_missingValue_R4
2537 elseif (IND_BCOR_TT > 0 .or. IND_BCOR_HU > 0) then ! conventional (UA or AI)
2538 allocate(BCOR2(nele,nvale,nte))
2539 allocate(BiasCorrection2(nele,nvale))
2540 BCOR2(:,:,:) = MPC_missingValue_R4
2541 end if
2542
2543
2544 ! Get the observations and conventional data bias corrections for each element in LISTE_ELE
2545
2546 do IL = 1, NELE
2547
2548 iele = LISTE_ELE(IL)
2549 IND_ele = BURP_Find_Element(Block_in, ELEMENT=iele)
2550 if (IND_ele < 0 ) cycle
2551
2552 if (HIPCS .and. iele == 12001) then
2553 IND_ele = BURP_Find_Element(Block_in, ELEMENT=12101)
2554 if (IND_ele == -1) call handle_error(IND_ele, "brpr_readBurp: cannot find element 12101 in Block_in")
2555 end if
2556 if (HIPCS .and. iele == 12192) then
2557 IND_ele = BURP_Find_Element(Block_in, ELEMENT=12239)
2558 if (IND_ele == -1) call handle_error(IND_ele, "brpr_readBurp: cannot find element 12239 in Block_in")
2559 end if
2560 do k=1,nte
2561 do j=1,nvale
2562 obsvalue(IL,j,k) = BURP_Get_Rval(Block_in,NELE_IND=IND_ele,NVAL_IND=j,NT_IND=k)
2563 if (iele == BUFR_NETT .and. IND_BCOR_TT > 0) &
2564 & BCOR2(IL,j,k) = BURP_Get_Rval(Block_in,NELE_IND=IND_BCOR_TT,NVAL_IND=j,NT_IND=k)
2565 if (iele == BUFR_NEES .and. IND_BCOR_HU > 0) &
2566 & BCOR2(IL,j,k) = BURP_Get_Rval(Block_in,NELE_IND=IND_BCOR_HU,NVAL_IND=j,NT_IND=k)
2567 end do
2568 end do
2569
2570 end do
2571
2572 ! Get other needed elements including vccord, TOVS bias corrections and AI phase of flight
2573 do k=1,nte
2574 do j=1,nvale
2575 IF (HIRES) THEN
2576 HLAT(j,k) = BURP_Get_Rval(Block_in,NELE_IND = IND_LAT,NVAL_IND = j,NT_IND = k)
2577 HLON(j,k) = BURP_Get_Rval(Block_in,NELE_IND = IND_LON,NVAL_IND = j,NT_IND = k)
2578 HTIME(j,k)= BURP_Get_Rval(Block_in,NELE_IND = IND_TIME,NVAL_IND = j,NT_IND = k)
2579 END IF
2580 if ( phasePresent ) then
2581 phase(j,k) = BURP_Get_Tblval(Block_in,NELE_IND = IND_phase,NVAL_IND = j,NT_IND = k)
2582 end if
2583 if ( IND_dataQcFlag2 > 0 ) then
2584 dataQcFlag2(j,k) = BURP_Get_Tblval(Block_in,NELE_IND = IND_dataQcFlag2,NVAL_IND = j,NT_IND = k)
2585 end if
2586 if ( IND_dataCloudFrac > 0 ) then
2587 dataCloudFrac(j,k) = BURP_Get_Tblval(Block_in,NELE_IND = IND_dataCloudFrac,NVAL_IND = j,NT_IND = k)
2588 end if
2589 IF (IND_EMIS > 0) THEN
2590 EMIS(j,k) = BURP_Get_Rval(Block_in,NELE_IND = IND_EMIS,NVAL_IND = j,NT_IND = k)
2591 END IF
2592 IF (IND_BCOR > 0) THEN
2593 BCOR(j,k) = BURP_Get_Rval(Block_in,NELE_IND = IND_BCOR,NVAL_IND = j,NT_IND = k)
2594 END IF
2595 if (IND_VCOORD > 0) then
2596 VCOORD(j,k) = BURP_Get_Rval(Block_in,NELE_IND = IND_VCOORD,NVAL_IND = j,NT_IND = k)
2597 end if
2598 end do
2599 end do
2600
2601!==================================================================================
2602!
2603! Lire les divers elements de la famille SW
2604!
2605 allocate(qi1val(nte))
2606 allocate(qi2val(nte))
2607 allocate(mtval(nte))
2608 allocate(lsval(nte))
2609 allocate(haval(nte))
2610 allocate(gaval(nte))
2611 QI1VAL(:) = 0
2612 QI2VAL(:) = 0
2613 MTVAL (:) = 0
2614 LSVAL (:) = 0
2615 HAVAL (:) = 0
2616 GAVAL (:) = 0
2617
2618 if (TRIM(FAMILYTYPE) == 'SW' .and. READ_QI_GA_MT_SW) then
2619
2620 IND_SW = BURP_Find_Element(Block_in, ELEMENT=33007)
2621 if (IND_SW <= 0 ) cycle
2622 do k = 1, nte
2623 QI1VAL(k)= BURP_Get_Tblval(Block_in, &
2624 NELE_IND = IND_SW, &
2625 NVAL_IND = 1, &
2626 NT_IND = k, &
2627 IOSTAT = error)
2628 call handle_error(error, "brpr_readBurp: BURP_Get_Tblval 33007")
2629 end do
2630
2631 IND_SW = BURP_Find_Element(Block_in, ELEMENT=33194)
2632 if (IND_SW <= 0 ) cycle
2633 do k = 1, nte
2634 QI2VAL(k)= BURP_Get_Tblval(Block_in, &
2635 NELE_IND = IND_SW, &
2636 NVAL_IND = 1, &
2637 NT_IND = k, &
2638 IOSTAT = error)
2639 call handle_error(error, "brpr_readBurp: BURP_Get_Tblval 33194")
2640 end do
2641
2642 IND_SW = BURP_Find_Element(Block_in, ELEMENT=2023)
2643 if (IND_SW <= 0 ) cycle
2644 do k = 1, nte
2645 MTVAL(k)= BURP_Get_Tblval(Block_in, &
2646 NELE_IND = IND_SW, &
2647 NVAL_IND = 1, &
2648 NT_IND = k, &
2649 IOSTAT = error)
2650 call handle_error(error, "brpr_readBurp: BURP_Get_Tblval 2023")
2651 end do
2652
2653 IND_SW = BURP_Find_Element(Block_in, ELEMENT=8012)
2654 if (IND_SW <= 0 ) cycle
2655 do k = 1, nte
2656 LSVAL(k)= BURP_Get_Tblval(Block_in, &
2657 NELE_IND = IND_SW, &
2658 NVAL_IND = 1, &
2659 NT_IND = k, &
2660 IOSTAT = error)
2661 call handle_error(error, "brpr_readBurp: BURP_Get_Tblval 8012")
2662 end do
2663
2664 IND_SW = BURP_Find_Element(Block_in, ELEMENT=13039)
2665 if (IND_SW <= 0 ) cycle
2666 do k = 1, nte
2667 GAVAL(k)= BURP_Get_Tblval(Block_in, &
2668 NELE_IND = IND_SW, &
2669 NVAL_IND = 1, &
2670 NT_IND = k, &
2671 IOSTAT = error)
2672 call handle_error(error, "brpr_readBurp: BURP_Get_Tblval 13039")
2673 end do
2674
2675 IND_SW = BURP_Find_Element(Block_in, ELEMENT=2163)
2676 if (IND_SW <= 0 ) cycle
2677 do k = 1, nte
2678 HAVAL(k)= BURP_Get_Tblval(Block_in, &
2679 NELE_IND = IND_SW, &
2680 NVAL_IND = 1, &
2681 NT_IND = k, &
2682 IOSTAT = error)
2683 call handle_error(error, "brpr_readBurp: BURP_Get_Tblval 2163")
2684 end do
2685
2686 !====================================================================
2687 !
2688 ! Lire les divers elements de la famille AL
2689 !
2690 else if (trim(familytype) == 'AL') then
2691 if (.not. allocated(azimuth)) then
2692 allocate(azimuth(nte))
2693 azimuth(:) = 0.
2694 end if
2695
2696 ! Read in the azimuth)
2697 ind_al=burp_find_element(block_in, element=BUFR_NEAZ)
2698 if (ind_al <= 0 ) cycle
2699
2700 do k = 1, nte
2701 azimuth(k)= BURP_Get_Rval(Block_in, &
2702 nele_ind = ind_al, &
2703 nval_ind = 1, &
2704 nt_ind = k, &
2705 iostat = error)
2706 call handle_error(error, "brpr_readBurp: BURP_Get_Rval BUFR_NEAZ")
2707 end do
2708 end if ! AL
2709 !
2710 !====================================================================
2711
2712 end if
2713
2714
2715 ! flag block (btyp = 0111 100011X XXXX)
2716 if ( btyp10 == btyp10flg ) then ! non-sfc type flag block
2717
2718 flag_passage4 = 1
2719 allocate(qcflag( NELE,nvale,nte))
2720 allocate(qcflags(NELE,nvale) )
2721 QCFLAG (:,:,:) = 0
2722 QCFLAGS(:,:) = 0
2723
2724 allocate(hiresTimeFlag(nvale,nte))
2725 allocate(hiresLatFlag(nvale,nte))
2726 hiresTimeFlag(:,:) = 0
2727 hiresLatFlag(:,:) = 0
2728
2729 do IL = 1, NELE
2730
2731 iele=LISTE_ELE(IL)
2732
2733 IND_QCFLAG = BURP_Find_Element(Block_in, ELEMENT=200000+iele)
2734 if (IND_QCFLAG <= 0 ) cycle
2735
2736 if (UA_FLAG_HIGH_PRECISION_TT_ES) then
2737 if (HIPCS .and. iele == 12001) then
2738 IND_QCFLAG = BURP_Find_Element(Block_in, ELEMENT=212101)
2739 if (IND_QCFLAG == -1) call handle_error(IND_QCFLAG, "brpr_readBurp: cannot find element 212101 in Block_in")
2740 end if
2741 if (HIPCS .and. iele == 12192) then
2742 IND_QCFLAG = BURP_Find_Element(Block_in, ELEMENT=212239)
2743 if (IND_QCFLAG == -1) call handle_error(IND_QCFLAG, "brpr_readBurp: cannot find element 212239 in Block_in")
2744 end if
2745 end if
2746
2747 do k = 1, nte
2748 do j = 1, nvale
2749 QCFLAG(IL,j,k)= BURP_Get_Tblval(Block_in, &
2750 & NELE_IND = IND_QCFLAG, &
2751 & NVAL_IND = j, &
2752 & NT_IND = k, &
2753 & IOSTAT = error)
2754 call handle_error(error, "brpr_readBurp: BURP_Get_Tblval IND_QCFLAG")
2755 SUM = SUM +1
2756 end do
2757 end do
2758
2759 end do
2760
2761 ! read the hires time and latitude flags, needed for UA thinning procedure
2762 IND_QCFLAG = BURP_Find_Element(Block_in, ELEMENT=204015)
2763 if (IND_QCFLAG > 0) then
2764 do k = 1, nte
2765 do j = 1, nvale
2766 hiresTimeFlag(j,k)= BURP_Get_Tblval(Block_in, &
2767 & NELE_IND = IND_QCFLAG, &
2768 & NVAL_IND = j, &
2769 & NT_IND = k, &
2770 & IOSTAT = error)
2771 call handle_error(error, "brpr_readBurp: BURP_Get_Tblval 204015")
2772 SUM = SUM +1
2773 end do
2774 end do
2775 end if
2776 IND_QCFLAG = BURP_Find_Element(Block_in, ELEMENT=205001)
2777 if (IND_QCFLAG > 0) then
2778 do k = 1, nte
2779 do j = 1, nvale
2780 hiresLatFlag(j,k)= BURP_Get_Tblval(Block_in, &
2781 & NELE_IND = IND_QCFLAG, &
2782 & NVAL_IND = j, &
2783 & NT_IND = k, &
2784 & IOSTAT = error)
2785 call handle_error(error, "brpr_readBurp: BURP_Get_Tblval 205001")
2786 SUM = SUM +1
2787 end do
2788 end do
2789 end if
2790
2791 end if
2792
2793 ! info block (btyp = 0001 100000X XXXX)
2794 BTYP10inf = 96
2795
2796 if ( (btyp10 == btyp10inf) .or. (btyp10 - btyp10inf == 1) ) then
2797
2798 allocate( RINFO(NELE_INFO,nte))
2799 allocate(TRINFO(NELE_INFO))
2800
2801 flag_passage2 = 1
2802
2803 do kl=1,NELE_INFO
2804 info_elepos = BURP_Find_Element(Block_in, &
2805 & ELEMENT = LISTE_INFO(kl) )
2806 if ( info_elepos >= 0 )then
2807
2808 do k =1 , nte
2809 RINFO(kl,k)= BURP_Get_rval(Block_in, &
2810 & NELE_IND = info_elepos, &
2811 & NVAL_IND = 1, &
2812 & NT_IND = k, &
2813 & IOSTAT = error)
2814 call handle_error(error, "brpr_readBurp: BURP_Get_rval info_elepos")
2815 if (RINFO(kl,k) == MPC_missingValue_R4) THEN
2816 infot= BURP_Get_tblval(Block_in, &
2817 & NELE_IND = info_elepos, &
2818 & NVAL_IND = 1, &
2819 & NT_IND = k, &
2820 & IOSTAT = error)
2821 call handle_error(error, "brpr_readBurp: BURP_Get_tblval info_elepos")
2822 if (infot /= -1) RINFO(kl,k) =real(infot)
2823 END IF
2824
2825 end do
2826
2827 else
2828 RINFO(kl,1:nte)=MPC_missingValue_R4
2829 end if
2830
2831 end do
2832
2833 end if
2834
2835
2836 ! descriptor block (btyp = 0010 100000X XXXX)
2837 BTYP10des = 160
2838
2839 if ( BTYP10 == BTYP10des ) then
2840
2841 flag_passage1 = 1
2842
2843 allocate(GLBFLAG(nte))
2844 allocate( lat(nte))
2845 allocate( lon(nte))
2846 allocate( date(nte))
2847 allocate( hhmm(nte))
2848
2849 ! DATE 004208 HHMM 004197 STATUS 055200 LAT 005002 LON 006002 DELAY 004195
2850 ind055200 = BURP_Find_Element(Block_in, ELEMENT=055200)
2851 if (ind055200 == -1) call handle_error(ind055200, "brpr_readBurp: cannot find element 55200 in Block_in")
2852 ind5002 = BURP_Find_Element(Block_in, ELEMENT=5002)
2853 if (ind5002 == -1) call handle_error(ind5002, "brpr_readBurp: cannot find element 5002 in Block_in")
2854 ind6002 = BURP_Find_Element(Block_in, ELEMENT=6002)
2855 if (ind6002 == -1) call handle_error(ind6002, "brpr_readBurp: cannot find element 6002 in Block_in")
2856 ind4208 = BURP_Find_Element(Block_in, ELEMENT=4208)
2857 if (ind4208 == -1) call handle_error(ind4208, "brpr_readBurp: cannot find element 4208 in Block_in")
2858 ind4197 = BURP_Find_Element(Block_in, ELEMENT=4197)
2859 if (ind4197 == -1) call handle_error(ind4197, "brpr_readBurp: cannot find element 4197 in Block_in")
2860
2861 do k = 1, nte
2862 LAT(k) = BURP_Get_Tblval(Block_in, &
2863 & NELE_IND = ind5002, &
2864 & NVAL_IND = 1, &
2865 & NT_IND = k)
2866 LON(k) = BURP_Get_Tblval(Block_in, &
2867 & NELE_IND = ind6002, &
2868 & NVAL_IND = 1, &
2869 & NT_IND = k)
2870 HHMM(k) = BURP_Get_Tblval(Block_in, &
2871 & NELE_IND = ind4197, &
2872 & NVAL_IND = 1, &
2873 & NT_IND = k)
2874 DATE(k) = BURP_Get_Tblval(Block_in, &
2875 & NELE_IND = ind4208, &
2876 & NVAL_IND = 1, &
2877 & NT_IND = k)
2878 GLBFLAG(k) = BURP_Get_Tblval(Block_in, &
2879 & NELE_IND = ind055200, &
2880 & NVAL_IND = 1, &
2881 & NT_IND = k)
2882 end do
2883
2884 end if
2885
2886 !==================== IASI SPECIAL BLOCK==================
2887 if ( BTYP == 9217 .and. IDTYP == 186 ) then
2888 NCLASSAVHRR=obs_getNclassAvhrr()
2889 NCHANAVHRR=obs_getNchanAvhrr()
2890 if (.not. allocated(CFRAC) ) allocate( CFRAC(NCLASSAVHRR,nte) )
2891 if (.not. allocated(RADMOY)) allocate(RADMOY(NCLASSAVHRR,NCHANAVHRR,nte))
2892 if (.not. allocated(radstd)) allocate(radstd(NCLASSAVHRR,NCHANAVHRR,nte))
2893
2894 RADMOY(:,:,:)=MPC_missingValue_R4
2895 RADSTD(:,:,:)=MPC_missingValue_R4
2896 CFRAC(:,:)=MPC_missingValue_R4
2897
2898 IASIQUAL: DO k = 1, nte
2899 iclass=1
2900
2901 NVALS :do j=1,nvale
2902 DO il=1,nbele
2903 iele=BURP_Get_Element(Block_in,INDEX =il)
2904 SELECT CASE(iele)
2905 CASE(25085)
2906 CFRAC(iclass,k)= BURP_Get_RVAL(Block_in,NELE_IND = il, NVAL_IND = j, NT_IND = k, IOSTAT = error)
2907 call handle_error(error, "brpr_readBurp: BURP_Get_RVAL 25085")
2908 CASE(5042)
2909 !ICHAN= BURP_Get_TBLVAL(Block_in,NELE_IND = il, NVAL_IND = j, NT_IND = k, IOSTAT = error)
2910 ICHAN= BURP_Get_RVAL(Block_in,NELE_IND = il, NVAL_IND = j, NT_IND = k, IOSTAT = error)
2911 call handle_error(error, "brpr_readBurp: BURP_Get_RVAL 5042")
2912 CASE(25142)
2913 !INORM= BURP_Get_TBLVAL(Block_in,NELE_IND = il, NVAL_IND = j, NT_IND = k, IOSTAT = error)
2914 INORM= BURP_Get_RVAL(Block_in,NELE_IND = il, NVAL_IND = j, NT_IND = k, IOSTAT = error)
2915 call handle_error(error, "brpr_readBurp: BURP_Get_RVAL 25142")
2916 CASE(14047)
2917 RAD_MOY=BURP_Get_RVAL(Block_in,NELE_IND = il, NVAL_IND = j, NT_IND = k, IOSTAT = error)
2918 call handle_error(error, "brpr_readBurp: BURP_Get_RVAL 14047")
2919 RADMOY(iclass,ICHAN,k)=RAD_MOY * 10.d0**(-1.d0 * INORM ) * 100000.d0
2920 CASE(14048)
2921 RAD_STD=BURP_Get_RVAL(Block_in,NELE_IND = il, NVAL_IND = j, NT_IND = k, IOSTAT = error)
2922 call handle_error(error, "brpr_readBurp: BURP_Get_RVAL 14048")
2923 RADSTD(iclass,ICHAN,k)= RAD_STD * 10.d0**(-1.d0 * INORM ) * 100000.d0
2924 IF (ICHAN==NCHANAVHRR) iclass=iclass+1
2925 IF ( iclass==(NCLASSAVHRR+1) ) EXIT NVALS
2926 END SELECT
2927 END DO
2928 end do NVALS
2929
2930 END DO IASIQUAL
2931
2932 end if
2933
2934 end do BLOCKS1
2935
2936 ! Loop over observations/locations (nte > 1 for families with grouped data like AI and TO)
2937 ! Fill obsSpaceData HEADER and BODY
2938 do k = 1, nte
2939
2940 IF ( allocated(lat) ) then
2941
2942 XLON = (lon(k)*1.-18000.)*.01
2943 XLAT = (lat(k)*1.- 9000.)*.01
2944 IF ( xlon < 0. ) xlon = 360. + xlon
2945 XLON = XLON*MPC_RADIANS_PER_DEGREE_R8
2946 XLAT = XLAT*MPC_RADIANS_PER_DEGREE_R8
2947 YMD_DATE=date(k)
2948 HM =hhmm(k)
2949 STATUS =GLBFLAG(K)
2950 RELEV =REAL(ELEV) - 400.
2951 ELSE
2952 XLON =.01*LONG
2953 XLAT =LATI*.01 -90.
2954 XLON = XLON*MPC_RADIANS_PER_DEGREE_R8
2955 XLAT = XLAT*MPC_RADIANS_PER_DEGREE_R8
2956 YMD_DATE=date_h
2957 HM =hhmm_h
2958 RELEV =REAL(ELEV,pre_obsReal) - 400.
2959 END IF
2960
2961 if (allocated(RINFO)) TRINFO(1:NELE_INFO) =RINFO (1:NELE_INFO,k)
2962
2963
2964 if(ENFORCE_CLASSIC_SONDES) hires=.false.
2965
2966 IF (HIRES ) THEN ! LAT LON TIME IN DATA BLOCK (e.g. UA family)
2967
2968 if (allocated(EMIS)) SURF_EMIS(1:NVAL) = EMIS(1:NVAL,k)
2969 if (allocated(BCOR)) BiasCorrection(1,1:NVAL) = BCOR(1:NVAL,k)
2970
2971 NDATA =0
2972 NDATA_SF=0
2973 IF ( allocated(obsvalue_sfc) ) THEN
2974 OBSERV_SFC(1:NELE_SFC,1:1) = obsvalue_sfc(1:NELE_SFC,1:1,k)
2975 BCOR_SFC(1:NELE_SFC,1:1) = BiasCorrection_sfc(1:NELE_SFC,1:1,k)
2976 QCFLAGS_sfc(1:NELE_SFC,1:1) = qcflag_sfc(1:NELE_SFC,1:1,k)
2977 IF ( HIRES_SFC) THEN
2978 XLAT=HLAT_SFC(k);XLON=HLON_SFC(k);XTIME=HTIME_SFC(k)
2979 IF ( XLON < 0. ) XLON = 360. + XLON
2980 ier= NEWDATE(kstamp2,YMD_DATE,HM*10000,3)
2981 XLAT=XLAT*MPC_RADIANS_PER_DEGREE_R8
2982 XLON=XLON*MPC_RADIANS_PER_DEGREE_R8
2983
2984 call INCDATR(kstamp, kstamp2, XTIME/60.d0 )
2985 IER=newdate(kstamp,date2,time_sonde,-3)
2986 time2=time_sonde/10000
2987 YMD_DATE_SFC=date2
2988 HM_SFC=time2
2989 END IF
2990
2991 ! dataQcFlagLev does not exist for surface data
2992 dataQcFlagLev_sfc(:) = MPC_missingValue_INT
2993 dataCloudFracLev_sfc(:) = MPC_missingValue_INT
2994
2995 NDATA_SF= WRITE_BODY(obsdat,UNI_FAMILYTYPE,RELEV,vcoord_sfc,vcoord_type, &
2996 OBSERV_SFC,qcflags_sfc,NELE_SFC,1,LISTE_ELE_SFC, &
2997 dataQcFlagLEV_sfc,dataCloudFracLev_sfc, ROLAT,ROLON,&
2998 BiasCorrection_opt=BCOR_SFC)
2999
3000 IF ( NDATA_SF > 0) THEN
3001 call WRITE_HEADER(obsdat,STNID,XLAT,XLON,YMD_DATE_SFC,HM_SFC,idtyp,STATUS,RELEV,FILENUMB)
3002 OBSN=obs_numHeader(obsdat)
3003 if (obs_columnActive_IH(obsdat,obs_prfl)) call obs_headSet_i(obsdat,OBS_PRFL,OBSN,kk)
3004 if (obs_columnActive_IH(obsdat,obs_hdd)) call obs_headSet_i(obsdat,OBS_HDD,OBSN,date_h)
3005 if (obs_columnActive_IH(obsdat,obs_hdt)) call obs_headSet_i(obsdat,OBS_HDT,OBSN,hhmm_h)
3006 call obs_setFamily(obsdat,trim(FAMILYTYPE), OBSN )
3007 call obs_headSet_i(obsdat,OBS_NLV,OBSN,NDATA_SF)
3008 IF (OBSN > 1 ) THEN
3009 LN= obs_headElem_i(obsdat,OBS_RLN,OBSN-1) + obs_headElem_i(obsdat,OBS_NLV,OBSN-1)
3010 call obs_headSet_i(obsdat,OBS_RLN,OBSN,LN)
3011 ELSE
3012 call obs_headSet_i(obsdat,OBS_RLN,OBSN,1)
3013 END IF
3014
3015 ! write info block to header (same values for all headers associated with report)
3016 if (allocated(TRINFO)) then
3017 call writeInfo(obsdat,familytype, TRINFO,LISTE_INFO,NELE_INFO )
3018 else
3019 call setInfoToMissing(obsdat)
3020 end if
3021
3022 END IF
3023
3024 END IF
3025
3026 IF ( allocated(obsvalue) ) THEN
3027
3028 if (.not. allocated(dataQcFlag2)) then
3029 if (.not. allocated(dataQcFlagLEV)) allocate(dataQcFlagLEV(1))
3030 dataQcFlagLEV(:) = MPC_missingValue_INT
3031 end if
3032
3033 if (.not. allocated(dataCloudFrac)) then
3034 if (.not. allocated(dataCloudFracLEV)) allocate(dataCloudFracLEV(1))
3035 dataCloudFracLEV(:) = MPC_missingValue_INT
3036 end if
3037
3038 ier= NEWDATE(kstamp2,YMD_DATE,HM*10000,3)
3039 do JJ =1,nval
3040 OBSERV(1:NELE,1:1) = obsvalue(1:NELE,jj:jj,k)
3041 if (allocated(BCOR2)) BiasCorrection2(1:NELE,1:1) = BCOR2(1:NELE,jj:jj,k)
3042 if (allocated(qcflag)) QCFLAGS(1:NELE,1:1) = qcflag(1:NELE,jj:jj,k)
3043 if (allocated(dataQcFlag2)) dataQcFlagLEV(1:NVAL) = dataQcFlag2(1:NVAL,k)
3044 if (allocated(dataCloudFrac)) dataCloudFracLEV(1:NVAL) = dataCloudFrac(1:NVAL,k)
3045
3046 XLAT=HLAT(jj,k);XLON=HLON(jj,k);XTIME=HTIME(jj,k)
3047 IF ( XLON < 0. ) XLON = 360. + XLON
3048
3049 XLAT=XLAT*MPC_RADIANS_PER_DEGREE_R8
3050 XLON=XLON*MPC_RADIANS_PER_DEGREE_R8
3051
3052 call INCDATR(kstamp, kstamp2, XTIME/60.d0 )
3053 IER=newdate(kstamp,date2,time_sonde,-3)
3054
3055 time2=time_sonde/10000
3056
3057 VCORD(1)=VCOORD(jj,k)
3058 if (allocated(BCOR)) then
3059 NDATA= WRITE_BODY(obsdat,familytype,RELEV,VCORD,vcoord_type, &
3060 OBSERV,qcflags,NELE,1,LISTE_ELE,dataQcFlagLEV,dataCloudFracLEV, &
3061 ROLAT,ROLON, SURF_EMIS_opt=SURF_EMIS, BiasCorrection_opt=BiasCorrection)
3062 elseif (allocated(BCOR2)) then
3063 NDATA= WRITE_BODY(obsdat,familytype,RELEV,VCORD,vcoord_type, &
3064 OBSERV,qcflags,NELE,1,LISTE_ELE,dataQcFlagLEV,dataCloudFracLEV, &
3065 ROLAT,ROLON, SURF_EMIS_opt=SURF_EMIS, BiasCorrection_opt=BiasCorrection2)
3066 else
3067 NDATA= WRITE_BODY(obsdat,familytype,RELEV,VCORD,vcoord_type, &
3068 OBSERV,qcflags,NELE,1,LISTE_ELE,dataQcFlagLEV,dataCloudFracLEV, ROLAT,ROLON, &
3069 SURF_EMIS_opt=SURF_EMIS)
3070 end if
3071
3072 IF (NDATA > 0) THEN
3073 if ( phasePresent ) then
3074 call WRITE_HEADER(obsdat,STNID,XLAT,XLON,date2,time2,idtyp,STATUS,RELEV,FILENUMB,phase(jj,k))
3075 else
3076 call WRITE_HEADER(obsdat,STNID,XLAT,XLON,date2,time2,idtyp,STATUS,RELEV,FILENUMB)
3077 end if
3078!==================================================================================
3079!
3080! Ajoute qivals dans les argument de WRITE_QI
3081
3082 if (TRIM(FAMILYTYPE) == 'SW' .and. READ_QI_GA_MT_SW) call WRITE_QI(obsdat,QI1VAL(k),QI2VAL(k),MTVAL(k),LSVAL(k),HAVAL(k),GAVAL(k))
3083
3084 if(trim(familytype) == 'AL')call write_al(obsdat, azimuth(k))
3085
3086 OBSN=obs_numHeader(obsdat)
3087 if (obs_columnActive_IH(obsdat,obs_prfl)) call obs_headSet_i(obsdat,OBS_PRFL,OBSN,kk)
3088 if (obs_columnActive_IH(obsdat,obs_hdd)) call obs_headSet_i(obsdat,OBS_HDD,OBSN,date_h)
3089 if (obs_columnActive_IH(obsdat,obs_hdt)) call obs_headSet_i(obsdat,OBS_HDT,OBSN,hhmm_h)
3090 if (obs_columnActive_IH(obsdat,obs_tflg)) call obs_headSet_i(obsdat,OBS_TFLG,OBSN,hiresTimeFlag(jj,k))
3091 if (obs_columnActive_IH(obsdat,obs_lflg)) call obs_headSet_i(obsdat,OBS_LFLG,OBSN,hiresLatFlag(jj,k))
3092 call obs_setFamily(obsdat,trim(FAMILYTYPE), OBSN )
3093 call obs_headSet_i(obsdat,OBS_NLV,OBSN,NDATA)
3094 IF (OBSN > 1 ) THEN
3095 LN= obs_headElem_i(obsdat,OBS_RLN,OBSN-1) + obs_headElem_i(obsdat,OBS_NLV,OBSN-1)
3096 call obs_headSet_i(obsdat,OBS_RLN,OBSN,LN)
3097 ELSE
3098 call obs_headSet_i(obsdat,OBS_RLN,OBSN,1)
3099 END IF
3100
3101 ! write info block to header (same values for all headers associated with report)
3102 if (allocated(TRINFO)) then
3103 call writeInfo(obsdat,familytype, TRINFO,LISTE_INFO,NELE_INFO )
3104 else
3105 call setInfoToMissing(obsdat)
3106 end if
3107
3108 END IF
3109
3110 end do
3111
3112 END IF
3113
3114 ELSE ! not HIRES
3115
3116 if (allocated(EMIS)) SURF_EMIS(1:NVAL) = EMIS(1:NVAL,k)
3117 if (allocated(BCOR)) BiasCorrection(1,1:NVAL) = BCOR(1:NVAL,k)
3118 NDATA =0
3119 NDATA_SF=0
3120 IF ( allocated(obsvalue_sfc) ) THEN
3121 IF ( HIRES_SFC) THEN
3122 XLAT=HLAT_SFC(k);XLON=HLON_SFC(k);XTIME=HTIME_SFC(k)
3123 IF ( XLON < 0. ) XLON = 360. + XLON
3124 ier= NEWDATE(kstamp2,YMD_DATE,HM*10000,3)
3125 XLAT=XLAT*MPC_RADIANS_PER_DEGREE_R8
3126 XLON=XLON*MPC_RADIANS_PER_DEGREE_R8
3127
3128 call INCDATR(kstamp, kstamp2, XTIME/60.d0 )
3129 IER=newdate(kstamp,date2,time_sonde,-3)
3130 time2=time_sonde/10000
3131 YMD_DATE=date2
3132 HM=time2
3133 END IF
3134
3135 OBSERV_SFC (1:NELE_SFC,1:1) = obsvalue_sfc(1:NELE_SFC,1:1,k)
3136 QCFLAGS_sfc(1:NELE_SFC,1:1) = qcflag_sfc (1:NELE_SFC,1:1,k)
3137 BCOR_SFC(1:NELE_SFC,1:1) = BiasCorrection_sfc (1:NELE_SFC,1:1,k)
3138
3139 ! dataQcFlagLev does not exist for surface data
3140 dataQcFlagLev_sfc(:) = MPC_missingValue_INT
3141 dataCloudFracLev_sfc(:) = MPC_missingValue_INT
3142
3143 NDATA_SF= WRITE_BODY(obsdat,UNI_FAMILYTYPE,RELEV,vcoord_sfc,vcoord_type, &
3144 OBSERV_sfc,qcflags_sfc,NELE_SFC,1,LISTE_ELE_SFC, &
3145 dataQcFlagLEV_sfc,dataCloudFracLev_sfc, ROLAT,ROLON, &
3146 BiasCorrection_opt=BCOR_SFC)
3147
3148 IF ( NDATA_SF > 0) THEN
3149 call WRITE_HEADER(obsdat,STNID,XLAT,XLON,YMD_DATE,HM,idtyp,STATUS,RELEV,FILENUMB)
3150 OBSN=obs_numHeader(obsdat)
3151 if (obs_columnActive_IH(obsdat,obs_prfl)) call obs_headSet_i(obsdat,OBS_PRFL,OBSN,kk)
3152 if (obs_columnActive_IH(obsdat,obs_hdd)) call obs_headSet_i(obsdat,OBS_HDD,OBSN,date_h)
3153 if (obs_columnActive_IH(obsdat,obs_hdt)) call obs_headSet_i(obsdat,OBS_HDT,OBSN,hhmm_h)
3154 call obs_setFamily(obsdat,trim(FAMILYTYPE), OBSN )
3155 call obs_headSet_i(obsdat,OBS_NLV ,OBSN,NDATA_SF)
3156 IF (OBSN > 1 ) THEN
3157 LN= obs_headElem_i(obsdat,OBS_RLN,OBSN-1) + obs_headElem_i(obsdat,OBS_NLV,OBSN-1)
3158 call obs_headSet_i(obsdat,OBS_RLN,OBSN,LN)
3159 ELSE
3160 call obs_headSet_i(obsdat,OBS_RLN,OBSN,1)
3161 END IF
3162 END IF
3163 END IF
3164
3165 IF ( allocated(obsvalue) ) THEN
3166 OBSERV(1:NELE,1:NVAL) = obsvalue(1:NELE,1:NVAL,k)
3167 if (allocated(BCOR2)) BiasCorrection2(1:NELE,1:NVAL) = BCOR2(1:NELE,1:NVAL,k)
3168 if (allocated(qcflag)) QCFLAGS(1:NELE,1:NVAL) = qcflag(1:NELE,1:NVAL,k)
3169 if (allocated(dataQcFlag2)) then
3170 dataQcFlagLEV(1:NVAL) = dataQcFlag2(1:NVAL,k)
3171 else
3172 if (.not. allocated(dataQcFlagLev)) allocate(dataQcFlagLEV(1))
3173 dataQcFlagLEV(:) = MPC_missingValue_INT
3174 end if
3175 if (allocated(dataCloudFrac)) then
3176 dataCloudFracLEV(1:NVAL) = dataCloudFrac(1:NVAL,k)
3177 else
3178 if (.not. allocated(dataCloudFracLev)) allocate(dataCloudFracLEV(1))
3179 dataCloudFracLEV(:) = MPC_missingValue_INT
3180 end if
3181
3182 VCORD(1:NVAL) = VCOORD(1:NVAL,k)
3183
3184 !CASES DEPENDING ON WETHER ON NOT WE HAVE MW DATA
3185 if (allocated(BCOR)) then
3186 NDATA= WRITE_BODY(obsdat,familytype,RELEV,VCORD,vcoord_type,OBSERV, &
3187 qcflags,NELE,NVAL,LISTE_ELE,dataQcFlagLEV,dataCloudFracLEV,ROLAT,ROLON, &
3188 SURF_EMIS_opt=SURF_EMIS,BiasCorrection_opt=BiasCorrection)
3189 elseif (allocated(BCOR2)) then
3190 NDATA= WRITE_BODY(obsdat,familytype,RELEV,VCORD,vcoord_type,OBSERV, &
3191 qcflags,NELE,NVAL,LISTE_ELE,dataQcFlagLEV,dataCloudFracLEV, ROLAT,ROLON, &
3192 SURF_EMIS_opt=SURF_EMIS,BiasCorrection_opt=BiasCorrection2)
3193 else
3194 NDATA= WRITE_BODY(obsdat,familytype,RELEV,VCORD,vcoord_type,OBSERV, &
3195 qcflags,NELE,NVAL,LISTE_ELE,dataQcFlagLEV,dataCloudFracLEV, &
3196 ROLAT,ROLON, SURF_EMIS_opt=SURF_EMIS)
3197 end if
3198
3199 IF (NDATA > 0) THEN
3200
3201 IF (NDATA_SF == 0) THEN
3202 if ( phasePresent ) then
3203 call WRITE_HEADER(obsdat,STNID,XLAT,XLON,YMD_DATE,HM,idtyp,STATUS,RELEV,FILENUMB,phase(1,k))
3204 else
3205 call WRITE_HEADER(obsdat,STNID,XLAT,XLON,YMD_DATE,HM,idtyp,STATUS,RELEV,FILENUMB)
3206 end if
3207
3208!==================================================================================
3209!
3210! Ajoute qivals dans les argument de WRITE_QI
3211
3212 if (TRIM(FAMILYTYPE) == 'SW') call WRITE_QI(obsdat,QI1VAL(k),QI2VAL(k),MTVAL(k),LSVAL(k),HAVAL(k),GAVAL(k))
3213
3214 if(trim(familytype) == 'AL')call write_al(obsdat, azimuth(k))
3215
3216 OBSN=obs_numHeader(obsdat)
3217 call obs_setFamily(obsdat,trim(FAMILYTYPE), OBSN )
3218 END IF
3219 OBSN=obs_numHeader(obsdat)
3220 call obs_headSet_i(obsdat,OBS_NLV,OBSN,NDATA+NDATA_SF)
3221 IF (OBSN > 1 ) THEN
3222 LN= obs_headElem_i(obsdat,OBS_RLN,OBSN-1) + obs_headElem_i(obsdat,OBS_NLV,OBSN-1)
3223 call obs_headSet_i(obsdat,OBS_RLN,OBSN,LN)
3224 ELSE
3225 call obs_headSet_i(obsdat,OBS_RLN,OBSN,1)
3226 END IF
3227
3228 END IF
3229
3230 END IF
3231
3232 !============ IASI =====================================
3233 if ( allocated(RADMOY) .and. NDATA > 0 ) then
3234 OBSN=obs_numHeader(obsdat)
3235
3236 iclass=1
3237 do iobs=OBS_CF1,OBS_CF7
3238 if(obs_columnActive_RH(obsdat,iobs)) then
3239 call obs_headSet_r(obsdat,iobs,OBSN,CFRAC(iclass,k))
3240 iclass=iclass+1
3241 end if
3242 end do
3243
3244 iclass=1
3245 ichan=1
3246 do iobs=OBS_M1C1,OBS_M7C6
3247 if(obs_columnActive_RH(obsdat,iobs)) then
3248 call obs_headSet_r(obsdat,iobs,OBSN,RADMOY(iclass,ichan,k))
3249 ichan=ichan+1
3250 if (ichan>obs_getNchanAvhrr()) then
3251 ichan=1
3252 iclass=iclass+1
3253 end if
3254 end if
3255 end do
3256
3257 iclass=1
3258 ichan=1
3259 do iobs=OBS_S1C1,OBS_S7C6
3260 if(obs_columnActive_RH(obsdat,iobs)) then
3261 call obs_headSet_r(obsdat,iobs,OBSN,radstd(iclass,ichan,k))
3262 ichan=ichan+1
3263 if (ichan>obs_getNchanAvhrr()) then
3264 ichan=1
3265 iclass=iclass+1
3266 end if
3267 end if
3268 end do
3269
3270 end if
3271 !============ IASI =====================================
3272
3273 END IF
3274
3275 if (allocated(TRINFO)) then
3276 IF ( NDATA > 0.or.NDATA_SF > 0 ) then
3277 call writeInfo(obsdat,familytype, TRINFO,LISTE_INFO,NELE_INFO )
3278 END IF
3279 end if
3280
3281 end do
3282
3283 !---------UPPER AIR---------------------------
3284 if ( allocated(obsvalue) ) then
3285 deallocate ( obsvalue,VCOORD,VCORD,observ)
3286 end if
3287 if ( allocated(qcflag) ) then
3288 deallocate (qcflag,qcflags)
3289 end if
3290 if ( allocated(hiresTimeFlag) ) then
3291 deallocate (hiresTimeFlag)
3292 end if
3293 if ( allocated(hiresLatFlag) ) then
3294 deallocate (hiresLatFlag)
3295 end if
3296 if ( allocated(qi1val) ) then
3297 deallocate (qi1val)
3298 end if
3299 if ( allocated(qi2val) ) then
3300 deallocate (qi2val)
3301 end if
3302 if ( allocated(mtval) ) then
3303 deallocate (mtval)
3304 end if
3305 if ( allocated(lsval) ) then
3306 deallocate (lsval)
3307 end if
3308 if ( allocated(haval) ) then
3309 deallocate (haval)
3310 end if
3311 if ( allocated(gaval) ) then
3312 deallocate (gaval)
3313 end if
3314 if ( allocated(EMIS) ) then
3315 deallocate (EMIS,SURF_EMIS)
3316 end if
3317 if ( allocated(dataQcFlag2) ) then
3318 deallocate (dataQcFlag2)
3319 end if
3320 if ( allocated(dataQcFlagLEV) ) then
3321 deallocate (dataQcFlagLEV)
3322 end if
3323 if ( allocated(dataCloudFrac) ) then
3324 deallocate (dataCloudFrac)
3325 end if
3326 if ( allocated(dataCloudFracLEV) ) then
3327 deallocate (dataCloudFracLEV)
3328 end if
3329 if (allocated(azimuth)) then
3330 deallocate(azimuth)
3331 end if
3332 if ( allocated(BCOR) ) then
3333 deallocate (BCOR,BiasCorrection)
3334 end if
3335 if ( allocated(BCOR2) ) then
3336 deallocate (BCOR2,BiasCorrection2)
3337 end if
3338
3339 !---------SURFACE-----------------------------
3340 if ( allocated(obsvalue_sfc) ) then
3341 DEallocate(obsvalue_sfc,vcoord_sfc,OBSERV_SFC,BiasCorrection_sfc,BCOR_SFC)
3342 end if
3343
3344 if ( allocated(qcflag_sfc) ) then
3345 DEallocate( qcflag_sfc, qcflags_SFC)
3346 end if
3347 !--------SURFACE------------------------------
3348
3349 if ( allocated(lat) ) then
3350 deallocate (lat,lon,date,hhmm,glbflag)
3351 end if
3352 if ( allocated(hlat) ) then
3353 deallocate (hlat,hlon,htime)
3354 end if
3355 if ( allocated(hlat_sfc) ) then
3356 deallocate (hlat_sfc,hlon_sfc,htime_sfc)
3357 end if
3358 if ( allocated(rinfo) ) then
3359 deallocate (rinfo,trinfo)
3360 end if
3361 if ( allocated(RADMOY) ) then
3362 deallocate (RADMOY,CFRAC,radstd)
3363 end if
3364 if ( allocated(phase) ) then
3365 deallocate (phase)
3366 end if
3367
3368
3369 end do REPORTS
3370
3371 end if
3372
3373 Deallocate(address)
3374
3375 if ( flag_passage1 == 1 ) then
3376 write(*,*)
3377 write(*,*) ' descriptor block for grouped data present '
3378 end if
3379 if ( flag_passage2 == 1 ) then
3380 write(*,*)
3381 write(*,*) '- info block Present '
3382 end if
3383 if ( flag_passage3 == 0 ) then
3384 write(*,*)
3385 write(*,*) 'ERROR - observation block not seen ? Verify btyp'
3386 end if
3387 if ( flag_passage4 == 0 ) then
3388 write(*,*)
3389 write(*,*) 'ERROR - flag block not seen ? Verify btyp'
3390 end if
3391
3392 call cleanup()
3393
3394 numHeader = obs_numHeader(obsdat)
3395 write(*,*)' file Nobs SUM = ',trim(brp_file),numHeader,SUM
3396
3397 contains
3398
3399 !--------- cleanup -----
3400 subroutine cleanup()
3401 implicit none
3402
3403 ! Locals:
3404 integer :: errors(4)
3405
3406 errors(:) = 0
3407 if (allocated(address)) deallocate(address, stat=errors(1))
3408 call BURP_Free(File_in, iostat=errors(2))
3409 call BURP_Free(Rpt_in, iostat=errors(3))
3410 call BURP_Free(Block_in, iostat=errors(4))
3411 !Should we abort here ?
3412 if (any(errors /= 0)) write(*,*) "brpr_readBurp: error while deallocating memory: ", errors(:)
3413 end subroutine cleanup
3414
3415 !--------- handle_error -----
3416 subroutine handle_error(icode,errormessage)
3417 implicit none
3418
3419 ! Arguments:
3420 character(len=*), intent(in) :: errormessage
3421 integer, intent(in) :: icode
3422
3423 if ( icode /= burp_noerr ) then
3424 write(*,*) 'error code', icode
3425 write(*,*) BURP_STR_ERROR()
3426 write(*,*) "history"
3427 call BURP_STR_ERROR_HISTORY()
3428 call cleanup()
3429 call utl_abort(trim(errormessage))
3430 end if
3431 end subroutine handle_error
3432
3433 end subroutine brpr_readBurp
3434
3435 !--------------------------------------------------------------------------
3436 ! WRITE_BODY
3437 !--------------------------------------------------------------------------
3438 FUNCTION WRITE_BODY(obsdat,FAMTYP, ELEV,VERTCOORD,VCOORD_TYPE, &
3439 obsvalue,qcflag,NELE,NVAL,LISTE_ELE,dataQcFlagLEV, &
3440 dataCloudFracLEV, ROLAT,ROLON, SURF_EMIS_opt,BiasCorrection_opt)
3441
3442 implicit none
3443
3444 ! Arguments:
3445 type (struct_obs), intent(inout) :: obsdat
3446 INTEGER, intent(in) :: VCOORD_TYPE
3447 REAL , allocatable, intent(in) :: OBSVALUE(:,:)
3448 INTEGER, allocatable, intent(in) :: QCFLAG(:,:)
3449 REAL , allocatable, intent(in) :: VERTCOORD(:)
3450 REAL , intent(in) :: ROLAT(:), ROLON(:)
3451 REAL , allocatable, optional, intent(in) :: SURF_EMIS_opt(:)
3452 REAL , allocatable, optional, intent(in) :: BiasCorrection_opt(:,:)
3453 integer, intent(in) :: dataQcFlagLEV(:)
3454 integer, intent(in) :: dataCloudFracLEV(:)
3455 ! Result:
3456 INTEGER :: WRITE_BODY
3457
3458 ! Locals:
3459 CHARACTER(len=2) :: FAMTYP
3460 REAL :: ELEVFACT,VCOORD,ZEMFACT
3461 INTEGER :: NELE,NVAL,VCO,NONELEV
3462 integer :: LISTE_ELE(:),NOBS,VARNO,IL,J,COUNT,NLV
3463 INTEGER :: IFLAG,IFLAG2,cloudFrac
3464 REAL(pre_obsReal) :: MISG,OBSV,ELEV,ELEV_R,REMIS,BCOR,rolat1,rolon1
3465 LOGICAL :: L_EMISS,L_BCOR,L_dataQcFlag2, L_dataCloudFrac
3466
3467 L_EMISS = present( SURF_EMIS_opt )
3468 L_BCOR = present( BiasCorrection_opt )
3469 L_dataQcFlag2 = any(dataQcFlagLEV(:) /= MPC_missingValue_INT)
3470 L_dataCloudFrac = any(dataCloudFracLEV(:) /= MPC_missingValue_INT)
3471
3472 NONELEV =-1
3473 MISG=MPC_missingValue_R4
3474 ZEMFACT=0.01
3475
3476 REMIS = MISG
3477
3478 NOBS =obs_numHeader(obsdat) +1
3479 COUNT=obs_numBody (obsdat)
3480
3481 NLV=0
3482
3483! Special test for GB-GPS
3484! Reports with missing ZTD cause problems with output of subsequent reports (missing OMP, OER, FLAG bits)
3485! Since July 2019, reports with missing ZTD are removed in the GB-GPS dbase files.
3486 if ( trim(FAMTYP) == trim('GP') ) then
3487 DO il = 1, NELE
3488 varno = LISTE_ELE(il)
3489 DO j = 1, NVAL
3490 obsv = obsvalue(il,j)
3491 if ( varno == 15031 .and. obsv == MISG ) then
3492 print * , 'write body: report rejected no ZTD'
3493 WRITE_BODY = NLV
3494 return
3495 endif
3496 END DO
3497 END DO
3498 endif
3499! Special test for GB-GPS
3500
3501 if ( trim(FAMTYP) == trim('PR') .OR. trim(FAMTYP) == trim('SF') .OR. trim(FAMTYP) == trim('GP') ) then
3502 ELEVFACT=1.
3503 else
3504 ELEVFACT=0.
3505 end if
3506 if ( trim(FAMTYP) == trim('TO') ) then
3507 !ELEV=0.
3508 END IF
3509
3510 SELECT CASE(FAMTYP)
3511 CASE ( 'UA' , 'SW' , 'AI')
3512 VCO=2 ! PRESSURE COORD
3513 CASE ( 'SF' , 'SC', 'PR', 'RO', 'GP', 'AL' )
3514 VCO=1 ! HEIGHT COORD
3515 CASE ( 'TO' )
3516 VCO=3 ! CHANNEL NUMBER
3517 CASE ( 'CH' ) ! CONSTITUENTS (consider different possibilities)
3518 IF (VCOORD_TYPE == 7006 .OR. VCOORD_TYPE == 7007) THEN
3519 VCO=1
3520 IF (VCOORD_TYPE == 7006) ELEVFACT=1.0
3521 ELSE IF (VCOORD_TYPE == 7004 .OR. VCOORD_TYPE == 7204) THEN
3522 VCO=2
3523 ELSE IF (VCOORD_TYPE == 2150) THEN
3524 VCO=3
3525 ELSE
3526 ! Vertical coordinate not provided or not recognized.
3527 IF (NVAL == 1) THEN
3528 VCO=5 ! Initializes as surface point measurement
3529 DO il = 1, NELE
3530 if ( obsvalue(il,1) /= MPC_missingValue_R4) then
3531 if (liste_ele(il) == 15198.OR.liste_ele(il) == 15009.OR. &
3532 liste_ele(il) == 15020.OR.liste_ele(il) == 15021.OR. &
3533 liste_ele(il) == 15024.OR.liste_ele(il) == 15200.OR. &
3534 liste_ele(il) == 15001.OR.liste_ele(il) == 15005) then
3535
3536 VCO=4 ! Assumes this is a total column measurement
3537 exit
3538 end if
3539 end if
3540 END DO
3541 ELSE
3542 call utl_abort('write_body: Invalid BURP vertical coordinate type.')
3543 END IF
3544 END IF
3545 END SELECT
3546
3547 !-------------------SPECIAL CASES--------------
3548 DO il = 1, NELE
3549 varno=LISTE_ELE(il)
3550 DO j = 1, NVAL
3551 VCOORD=VERTCOORD(j)
3552 OBSV = obsvalue(il,j)
3553 if( L_EMISS ) then
3554 if( SURF_EMIS_opt(j) /= MISG) then
3555 REMIS = SURF_EMIS_opt(j)*ZEMFACT
3556 else
3557 REMIS = MISG
3558 end if
3559 end if
3560 if ( L_BCOR ) then
3561 BCOR = BiasCorrection_opt(il,j)
3562 end if
3563 if ( L_dataQcFlag2 ) then
3564 IFLAG2 = dataQcFlagLEV(j)
3565 end if
3566 if ( L_dataCloudFrac ) then
3567 cloudFrac = dataCloudFracLEV(j)
3568 end if
3569 IFLAG = INT(qCflag(il,j))
3570
3571 if ( obsv /= MPC_missingValue_R4 .and. VCOORD /= MPC_missingValue_R4 ) then
3572 count = count + 1
3573 NLV= NLV +1
3574 IFLAG = IBCLR(IFLAG,12)
3575
3576 call obs_bodySet_r(obsdat,OBS_VAR,count,OBSV)
3577 call obs_bodySet_i(obsdat,OBS_VNM,count,VARNO)
3578 call obs_bodySet_i(obsdat,OBS_VCO,count,VCO)
3579 ELEV_R=VCOORD + ELEV*ELEVFACT
3580 call obs_bodySet_r(obsdat,OBS_PPP,count, ELEV_R)
3581 call obs_bodySet_i(obsdat,OBS_FLG,count,IFLAG)
3582 if ( FAMTYP == 'RO' ) then
3583 rolat1 = rolat(j)*MPC_RADIANS_PER_DEGREE_R8
3584 rolon1 = rolon(j)*MPC_RADIANS_PER_DEGREE_R8
3585 call obs_bodySet_r(obsdat,OBS_LATD,count,rolat1)
3586 call obs_bodySet_r(obsdat,OBS_LOND,count,rolon1)
3587 else
3588 call obs_bodySet_r(obsdat,OBS_LATD,count,obs_missingValue_R)
3589 call obs_bodySet_r(obsdat,OBS_LOND,count,obs_missingValue_R)
3590 end if
3591 if ( L_BCOR .and. obs_columnActive_RB(obsdat,OBS_BCOR) ) then
3592 call obs_bodySet_r(obsdat,OBS_BCOR,count,BCOR)
3593 end if
3594
3595 if ( L_dataQcFlag2 ) then
3596 call obs_bodySet_i(obsdat,OBS_QCF2,count,IFLAG2)
3597 end if
3598
3599 if ( L_dataCloudFrac ) then
3600 call obs_bodySet_i(obsdat,OBS_CLA,count,cloudFrac)
3601 end if
3602
3603 if ( REMIS /= MPC_missingValue_R4 .and. FAMTYP == 'TO') THEN
3604 call obs_bodySet_r(obsdat,OBS_SEM,count,REMIS)
3605 else
3606 if ( FAMTYP == 'TO') then
3607 call obs_bodySet_r(obsdat,OBS_SEM,count,tvs_defaultEmissivity)
3608 else
3609 call obs_bodySet_r(obsdat,OBS_SEM,count,MISG)
3610 end if
3611 end if
3612
3613 call obs_bodySet_i(obsdat,OBS_VCO,count,VCO)
3614
3615 if (.not. filt_bufrCodeAssimilated(varno) .and. &
3616 .not. ovt_bufrCodeSkipped(varno)) then
3617 ! Add a row for the destination transform variable
3618 call obs_bodySet_i(obsdat,OBS_VNM,count+1,ovt_getDestinationBufrCode(varno))
3619 call obs_bodySet_i(obsdat,OBS_FLG,count+1,0)
3620 ELEV_R=VCOORD + ELEV*ELEVFACT
3621 call obs_bodySet_r(obsdat,OBS_PPP, count+1,ELEV_R)
3622 call obs_bodySet_i(obsdat,OBS_VCO, count+1,VCO)
3623 call obs_bodySet_r(obsdat,OBS_VAR, count+1,MISG)
3624 call obs_bodySet_r(obsdat,OBS_LATD,count+1,MISG)
3625 call obs_bodySet_r(obsdat,OBS_LOND,count+1,MISG)
3626 count = count + 1
3627 NLV = NLV + 1
3628 if (ovt_isWindObs(varno)) then
3629 ! Add an extra row for the other wind component
3630 call obs_bodySet_i(obsdat,OBS_VNM, count+1,ovt_getDestinationBufrCode(varno,extra_opt=.true.))
3631 call obs_bodySet_i(obsdat,OBS_FLG, count+1,0)
3632 call obs_bodySet_r(obsdat,OBS_PPP, count+1,ELEV_R)
3633 call obs_bodySet_i(obsdat,OBS_VCO, count+1,VCO)
3634 call obs_bodySet_r(obsdat,OBS_VAR, count+1,MISG)
3635 call obs_bodySet_r(obsdat,OBS_LATD,count+1,MISG)
3636 call obs_bodySet_r(obsdat,OBS_LOND,count+1,MISG)
3637 count = count + 1
3638 NLV = NLV + 1
3639 end if
3640 end if
3641
3642 end if
3643
3644 END DO
3645
3646 END DO
3647
3648 WRITE_BODY=NLV
3649
3650 END FUNCTION WRITE_BODY
3651
3652
3653 SUBROUTINE WRITE_HEADER(obsdat, STNID,LAT,LON,DATE,TIME,CODTYP,STATUS,ELEV,FILENUMB,PHASE_Opt)
3654
3655 implicit none
3656
3657 ! Arguments:
3658 type (struct_obs), intent(inout) :: obsdat
3659 CHARACTER(LEN=*) , intent(in) :: STNID
3660 integer , intent(in) :: DATE
3661 integer , intent(in) :: TIME
3662 integer , intent(in) :: CODTYP
3663 integer , intent(in) :: STATUS
3664 integer , intent(in) :: FILENUMB
3665 INTEGER, optional, intent(in) :: phase_opt
3666 REAL(pre_obsReal), intent(in) :: ELEV
3667 REAL(pre_obsReal), intent(in) :: LAT
3668 REAL(pre_obsReal), intent(in) :: LON
3669
3670 ! Locals:
3671 integer :: NOBS
3672
3673 NOBS=obs_numHeader(obsdat) +1
3674
3675 call obs_headSet_i(obsdat,OBS_ONM,nobs,nobs)
3676 call obs_headSet_r(obsdat,OBS_LAT,nobs,LAT)
3677 call obs_headSet_r(obsdat,OBS_LON,nobs,LON)
3678 call obs_headSet_i(obsdat,OBS_DAT,nobs,DATE)
3679 call obs_headSet_i(obsdat,OBS_ETM,nobs,TIME)
3680 call obs_headSet_i(obsdat,OBS_ITY,nobs,CODTYP)
3681 call obs_headSet_i(obsdat,OBS_ST1,nobs,STATUS)
3682 call obs_headSet_r(obsdat,OBS_ALT,nobs,ELEV)
3683 call obs_headSet_i(obsdat,OBS_IDF,nobs,FILENUMB)
3684 call obs_set_c(obsdat,'STID',nobs,STNID )
3685 if ( present(phase_opt) .and. &
3686 obs_columnActive_IH(obsdat,OBS_PHAS) ) then
3687 call obs_headSet_i(obsdat,OBS_PHAS,nobs,phase_opt)
3688 end if
3689
3690 END SUBROUTINE WRITE_HEADER
3691
3692!!------------------------------------------------------------------------------------
3693!!------------------------------------------------------------------------------------
3694
3695 SUBROUTINE WRITE_QI(obsdat, QI1value, QI2value, MTvalue, LSvalue, HAvalue, GAvalue)
3696
3697 implicit none
3698
3699 ! Arguments:
3700 type(struct_obs), intent(inout) :: obsdat
3701 integer, intent(in) :: MTvalue
3702 integer, intent(in) :: HAvalue
3703 integer, intent(in) :: GAvalue
3704 integer, intent(in) :: QI1value
3705 integer, intent(in) :: QI2value
3706 integer, intent(in) :: LSvalue
3707
3708 ! Locals:
3709 integer :: NOBS
3710
3711 NOBS = obs_numHeader(obsdat)
3712
3713 call obs_headSet_i(obsdat,OBS_SWQ1,nobs,QI1value)
3714 call obs_headSet_i(obsdat,OBS_SWQ2,nobs,QI2value)
3715 call obs_headSet_i(obsdat,OBS_SWMT,nobs,MTvalue)
3716 call obs_headSet_i(obsdat,OBS_SWLS,nobs,LSvalue)
3717 call obs_headSet_i(obsdat,OBS_SWGA,nobs,GAvalue)
3718 call obs_headSet_i(obsdat,OBS_SWHA,nobs,HAvalue)
3719
3720 END SUBROUTINE WRITE_QI
3721
3722!!------------------------------------------------------------------------------------
3723!!------------------------------------------------------------------------------------
3724
3725 subroutine write_al(obsdat, azimuth)
3726 implicit none
3727
3728 ! Arguments:
3729 type(struct_obs), intent(inout) :: obsdat
3730 real(pre_obsReal), intent(in) :: azimuth
3731
3732 ! Locals:
3733 integer :: nobs
3734
3735 nobs = obs_numHeader(obsdat)
3736
3737 call obs_headSet_r(obsdat,OBS_AZA,nobs,azimuth)
3738 end subroutine write_al
3739
3740 !--------------------------------------------------------------------------
3741 ! writeInfo
3742 !--------------------------------------------------------------------------
3743 subroutine writeInfo(obsdat, FAMTYP, RINFO, LISTE_INFO, NELE_INFO)
3744 !
3745 !:Purpose: Write values in obsSpaceData related to the info block
3746 !
3747 implicit none
3748
3749 ! Arguments:
3750 type (struct_obs), intent(inout) :: obsdat
3751 real, intent(in) :: RINFO(NELE_INFO)
3752 CHARACTER*2, intent(in) :: FAMTYP
3753 integer , intent(in) :: NELE_INFO
3754 integer , intent(in) :: LISTE_INFO(NELE_INFO)
3755
3756 ! Locals:
3757 REAL*4 :: INFOV
3758 integer :: CODTYP
3759 integer :: IL,NOBS
3760 integer :: SENSOR,ORBIT,ID_SAT,INSTRUMENT,LAND_SEA,CONSTITUENT_TYPE
3761 integer :: TERRAIN_TYPE,QCFLAG1,QCFLAG2,QCFLAG3,RAINFLAG
3762 integer :: IGQISFLAGQUAL,IGQISQUALINDEXLOC,IRO_QCFLAG
3763 integer :: IFOV,ORIGIN_CENTRE,RAOBSTYPE, LAUNCHTIME
3764 real :: RIGQISFLAGQUAL,RIGQISQUALINDEXLOC,RCONSTITUENT,RQCFLAG1,RQCFLAG2,RQCFLAG3,RRAINFLAG
3765 real :: RTERRAIN_TYPE,RLAND_SEA,RID_SAT,RSENSOR,RINSTRUMENT,RRO_QCFLAG,RORIGIN_CENTRE
3766 real :: RORBIT, RIWV
3767 REAL(pre_obsReal) :: RTANGENT_RADIUS,RGEOID,RSOLAR_AZIMUTH,RCLOUD_COVER,RSOLAR_ZENITH,RZENITH,RAZIMUTH
3768 real :: RFOV
3769 REAL(pre_obsReal) :: cloudLiquidWaterObs, cloudLiquidWaterFG
3770 REAL(pre_obsReal) :: scatteringIndexObs, scatteringIndexFG
3771
3772 NOBS=obs_numHeader(obsdat)
3773 CODTYP=obs_headElem_i(obsdat,OBS_ITY,NOBS)
3774 !write(*,*)' DEBUT WRITE_INFO NOBS CODTYP ----> ',NOBS,CODTYP,size(liste_info),size(RINFO),liste_info
3775 LAND_SEA = 0
3776 INSTRUMENT = 0
3777 ID_SAT = 0
3778 SENSOR = 0
3779 ORIGIN_CENTRE = 0
3780 RAOBSTYPE = MPC_missingValue_INT
3781 LAUNCHTIME = MPC_missingValue_INT
3782 ORBIT = 0
3783 QCFLAG1 = 0
3784 QCFLAG2 = 0
3785 QCFLAG3 = 0
3786 RAINFLAG = 0
3787
3788 IRO_QCFLAG=MPC_missingValue_INT
3789 IGQISQUALINDEXLOC=0
3790 IGQISFLAGQUAL=0
3791
3792 RTANGENT_RADIUS=real(MPC_missingValue_R8,pre_obsReal)
3793 RGEOID=real(MPC_missingValue_R8,pre_obsReal)
3794 TERRAIN_TYPE=-1
3795 RIWV= MPC_missingValue_R4
3796 RCLOUD_COVER = MPC_missingValue_R4
3797 CONSTITUENT_TYPE = MPC_missingValue_INT
3798 IFOV = MPC_missingValue_INT
3799 RIGQISQUALINDEXLOC = MPC_missingValue_R4
3800 RIGQISFLAGQUAL = MPC_missingValue_R4
3801 RRO_QCFLAG = MPC_missingValue_R4
3802 RSOLAR_AZIMUTH = real(MPC_missingValue_R8,pre_obsReal)
3803 RSOLAR_ZENITH = real(MPC_missingValue_R8,pre_obsReal)
3804 RZENITH = 90.
3805 RAZIMUTH = 0.
3806 cloudLiquidWaterObs = real(MPC_missingValue_R8,pre_obsReal)
3807 cloudLiquidWaterFG = real(MPC_missingValue_R8,pre_obsReal)
3808 scatteringIndexObs = real(MPC_missingValue_R8,pre_obsReal)
3809 scatteringIndexFG = real(MPC_missingValue_R8,pre_obsReal)
3810
3811 do il=1,NELE_INFO
3812 INFOV=rinfo(il)
3813 SELECT CASE( liste_info(il) )
3814 CASE( 1007)
3815 RID_SAT=INFOV
3816 IF (RID_SAT == MPC_missingValue_R4 ) THEN
3817 ID_SAT=0
3818 ELSE
3819 ID_SAT=NINT(RID_SAT)
3820 END IF
3821 CASE( 1033)
3822 RORIGIN_CENTRE=INFOV
3823 IF (RORIGIN_CENTRE == MPC_missingValue_R4 ) THEN
3824 ORIGIN_CENTRE=0
3825 ELSE
3826 ORIGIN_CENTRE=NINT(RORIGIN_CENTRE)
3827 END IF
3828 CASE( 2048)
3829 RSENSOR = INFOV
3830 if (RSENSOR == MPC_missingValue_R4 ) THEN
3831 SENSOR = MPC_missingValue_INT
3832 ELSE
3833 SENSOR = NINT(RSENSOR)
3834 END IF
3835 CASE( 5040)
3836 RORBIT = INFOV
3837 if (RORBIT == MPC_missingValue_R4 ) THEN
3838 ORBIT = MPC_missingValue_INT
3839 ELSE
3840 ORBIT = NINT(RORBIT)
3841 END IF
3842 CASE( 33078)
3843 RQCFLAG1 = INFOV
3844 if (RQCFLAG1 == MPC_missingValue_R4 ) THEN
3845 QCFLAG1 = MPC_missingValue_INT
3846 ELSE
3847 QCFLAG1 = NINT(RQCFLAG1)
3848 END IF
3849 CASE( 33079)
3850 RQCFLAG2 = INFOV
3851 if (RQCFLAG2 == MPC_missingValue_R4 ) THEN
3852 QCFLAG2 = MPC_missingValue_INT
3853 ELSE
3854 QCFLAG2 = NINT(RQCFLAG2)
3855 END IF
3856 CASE( 020029)
3857 RRAINFLAG = INFOV
3858 if (RRAINFLAG == MPC_missingValue_R4 ) THEN
3859 RAINFLAG = MPC_missingValue_INT
3860 ELSE
3861 RAINFLAG = NINT(RRAINFLAG)
3862 END IF
3863 CASE( 33080)
3864 RQCFLAG3 = INFOV
3865 if (RQCFLAG3 == MPC_missingValue_R4 ) THEN
3866 QCFLAG3 = MPC_missingValue_INT
3867 ELSE
3868 QCFLAG3 = NINT(RQCFLAG3)
3869 END IF
3870
3871 CASE( 2019)
3872 RINSTRUMENT = INFOV
3873 if (RINSTRUMENT == MPC_missingValue_R4 ) THEN
3874 INSTRUMENT = 0
3875 ELSE
3876 INSTRUMENT = NINT(RINSTRUMENT)
3877 END IF
3878 CASE( 5043)
3879 RFOV = INFOV
3880 if (RFOV == MPC_missingValue_R4 ) THEN
3881 IFOV = 0
3882 ELSE
3883 IFOV = NINT(RFOV)
3884 END IF
3885 CASE( 7024)
3886 RZENITH = INFOV
3887 if (RZENITH == MPC_missingValue_R4 ) THEN
3888 RZENITH = 90.
3889 END IF
3890 CASE( 7025)
3891 RSOLAR_ZENITH = INFOV
3892 CASE( 5021)
3893 RAZIMUTH=INFOV
3894 if (RAZIMUTH == MPC_missingValue_R4 ) THEN
3895 RAZIMUTH = 0.
3896 END IF
3897 CASE( 33060)
3898 RIGQISFLAGQUAL=INFOV
3899 if (RIGQISFLAGQUAL == MPC_missingValue_R4 ) then
3900 IGQISFLAGQUAL=0
3901 ELSE
3902 IGQISFLAGQUAL=NINT ( RIGQISFLAGQUAL )
3903 END IF
3904 CASE( 33062)
3905 RIGQISQUALINDEXLOC=INFOV
3906 if (RIGQISQUALINDEXLOC == MPC_missingValue_R4 ) then
3907 IGQISQUALINDEXLOC=0
3908 ELSE
3909 IGQISQUALINDEXLOC=NINT ( RIGQISQUALINDEXLOC )
3910 END IF
3911 CASE( 5022)
3912 RSOLAR_AZIMUTH=INFOV
3913 CASE( 8012)
3914 RLAND_SEA=INFOV
3915 if (RLAND_SEA == MPC_missingValue_R4 ) THEN
3916 LAND_SEA=99
3917 ELSE
3918 LAND_SEA=NINT ( RLAND_SEA )
3919 END IF
3920 CASE( 13095)
3921 RIWV=INFOV
3922 if (RIWV == MPC_missingValue_R4 ) THEN
3923 RIWV=0.
3924 END IF
3925 CASE( 13039)
3926 RTERRAIN_TYPE=INFOV
3927 if (RTERRAIN_TYPE == MPC_missingValue_R4 ) THEN
3928 TERRAIN_TYPE=-1
3929 ELSE
3930 TERRAIN_TYPE=NINT ( RTERRAIN_TYPE )
3931 END IF
3932 CASE( 20010)
3933 RCLOUD_COVER=INFOV
3934 CASE( 10035)
3935 RTANGENT_RADIUS=INFOV
3936 CASE( 10036)
3937 RGEOID=INFOV
3938 CASE( 33039)
3939 RRO_QCFLAG=INFOV
3940 if (RRO_QCFLAG == MPC_missingValue_R4 ) THEN
3941 IRO_QCFLAG=MPC_missingValue_INT
3942 ELSE
3943 IRO_QCFLAG=NINT ( RRO_QCFLAG )
3944 END IF
3945 CASE( 08046)
3946 IF (trim(FAMTYP) == 'CH') THEN
3947 RCONSTITUENT=INFOV
3948 IF (RCONSTITUENT == MPC_missingValue_R4) THEN
3949 call utl_abort('writeInfo: Missing 08046 element for the CH family.')
3950 ELSE
3951 CONSTITUENT_TYPE=NINT(RCONSTITUENT)
3952 END IF
3953 END IF
3954 CASE(13208)
3955 scatteringIndexObs = INFOV
3956 CASE(13209)
3957 cloudLiquidWaterObs = INFOV
3958 CASE(2011)
3959 raobsType = nint(infov)
3960 CASE(4197)
3961 launchTime = nint(infov)
3962 END SELECT
3963 if (liste_info(il) == clwFgElementId ) cloudLiquidWaterFG = INFOV
3964 if (liste_info(il) == siFgElementId ) scatteringIndexFG = INFOV
3965 end do
3966
3967 !-------------------SPECIAL CASES--------------
3968
3969 ! INSTRUMENT
3970 IF ( SENSOR == MPC_missingValue_INT) then
3971 IF ( INSTRUMENT == MPC_missingValue_INT) then
3972 INSTRUMENT=0
3973 END IF
3974 ELSE
3975 INSTRUMENT = obsu_cvt_obs_instrum(sensor)
3976 END IF
3977
3978 ! AIRS
3979 IF ( INSTRUMENT == 420 ) ID_SAT = 784
3980
3981 ! CrIS FSR
3982 if (codtyp == 202 .and. INSTRUMENT == 620) then
3983 INSTRUMENT = 2046
3984 end if
3985
3986 if ( trim(FAMTYP) == trim('GO') ) then
3987 call utl_abort('writeInfo: unknown familyType : ' // trim(FAMTYP))
3988 END IF
3989
3990
3991 !-------------------SPECIAL CASES--------------
3992
3993 if ( obs_columnActive_IH(obsdat,OBS_TTYP)) call obs_headSet_i(obsdat,OBS_TTYP,nobs,TERRAIN_TYPE)
3994 if ( obs_columnActive_IH(obsdat,OBS_STYP)) call obs_headSet_i(obsdat,OBS_STYP,nobs,LAND_SEA)
3995 if ( obs_columnActive_IH(obsdat,OBS_ORBI)) call obs_headSet_i(obsdat,OBS_ORBI,nobs,ORBIT)
3996 if ( obs_columnActive_IH(obsdat,OBS_AQF1)) call obs_headSet_i(obsdat,OBS_AQF1,nobs,QCFLAG1)
3997 if ( obs_columnActive_IH(obsdat,OBS_AQF2)) call obs_headSet_i(obsdat,OBS_AQF2,nobs,QCFLAG2)
3998 if ( obs_columnActive_IH(obsdat,OBS_AQF3)) call obs_headSet_i(obsdat,OBS_AQF3,nobs,QCFLAG3)
3999 if ( obs_columnActive_IH(obsdat,OBS_RAIN)) call obs_headSet_i(obsdat,OBS_RAIN,nobs,RAINFLAG)
4000 if ( obs_columnActive_IH(obsdat,OBS_INS) ) call obs_headSet_i(obsdat,OBS_INS,nobs,INSTRUMENT )
4001 if ( obs_columnActive_IH(obsdat,OBS_FOV) ) call obs_headSet_i(obsdat,OBS_FOV,nobs,IFOV )
4002 if ( obs_columnActive_IH(obsdat,OBS_SAT) ) call obs_headSet_i(obsdat,OBS_SAT,nobs,ID_SAT)
4003 if ( obs_columnActive_IH(obsdat,OBS_ORI) ) call obs_headSet_i(obsdat,OBS_ORI,nobs,ORIGIN_CENTRE)
4004 if ( obs_columnActive_IH(obsdat,OBS_TEC) ) call obs_headSet_i(obsdat,OBS_TEC,nobs,0)
4005 if ( obs_columnActive_IH(obsdat,OBS_GQF) ) call obs_headSet_i(obsdat,OBS_GQF,nobs,IGQISFLAGQUAL)
4006 if ( obs_columnActive_IH(obsdat,OBS_GQL) ) call obs_headSet_i(obsdat,OBS_GQL,nobs,IGQISQUALINDEXLOC)
4007 if ( obs_columnActive_IH(obsdat,OBS_ROQF) ) call obs_headSet_i(obsdat,OBS_ROQF,nobs,IRO_QCFLAG)
4008 if ( obs_columnActive_IH(obsdat,OBS_RTP) ) call obs_headSet_i(obsdat,OBS_RTP,nobs,raobsType)
4009 if ( obs_columnActive_IH(obsdat,OBS_LCH) ) call obs_headSet_i(obsdat,OBS_LCH,nobs,launchTime)
4010 if ( obs_columnActive_RH(obsdat,OBS_CLF) ) call obs_headSet_r(obsdat,OBS_CLF,nobs,RCLOUD_COVER )
4011 if ( obs_columnActive_RH(obsdat,OBS_SUN) ) call obs_headSet_r(obsdat,OBS_SUN,nobs,RSOLAR_ZENITH )
4012 if ( obs_columnActive_RH(obsdat,OBS_SAZ) ) call obs_headSet_r(obsdat,OBS_SAZ,nobs,RSOLAR_AZIMUTH )
4013 if ( obs_columnActive_RH(obsdat,OBS_SZA) ) call obs_headSet_r(obsdat,OBS_SZA,nobs,RZENITH )
4014 if ( obs_columnActive_RH(obsdat,OBS_AZA) ) call obs_headSet_r(obsdat,OBS_AZA,nobs,RAZIMUTH )
4015 if ( obs_columnActive_RH(obsdat,OBS_TRAD) ) call obs_headSet_r(obsdat,OBS_TRAD,nobs,RTANGENT_RADIUS)
4016 if ( obs_columnActive_RH(obsdat,OBS_IWV)) call obs_headSet_r(obsdat,OBS_IWV,nobs,RIWV)
4017 if ( obs_columnActive_RH(obsdat,OBS_GEOI) ) call obs_headSet_r(obsdat,OBS_GEOI,nobs,RGEOID)
4018 if (trim(FAMTYP) == trim('CH')) then
4019 if ( obs_columnActive_IH(obsdat,OBS_CHM) ) call obs_headSet_i(obsdat,OBS_CHM,nobs,CONSTITUENT_TYPE)
4020 else
4021 if ( obs_columnActive_IH(obsdat,OBS_CHM) ) call obs_headSet_i(obsdat,OBS_CHM,nobs,-1)
4022 end if
4023 if ( obs_columnActive_RH(obsdat,OBS_CLWO) ) call obs_headSet_r(obsdat,OBS_CLWO,nobs,cloudLiquidWaterObs)
4024 if ( obs_columnActive_RH(obsdat,OBS_CLWB) ) call obs_headSet_r(obsdat,OBS_CLWB,nobs,cloudLiquidWaterFG)
4025 if ( obs_columnActive_RH(obsdat,OBS_SIO) ) call obs_headSet_r(obsdat,OBS_SIO,nobs,scatteringIndexObs)
4026 if ( obs_columnActive_RH(obsdat,OBS_SIB) ) call obs_headSet_r(obsdat,OBS_SIB,nobs,scatteringIndexFG)
4027
4028 END SUBROUTINE writeInfo
4029
4030 !--------------------------------------------------------------------------
4031 ! setInfoToMissing
4032 !--------------------------------------------------------------------------
4033 subroutine setInfoToMissing(obsdat)
4034 !:Purpose: Set the obsSpaceData column related to the info block with
4035 ! missing values
4036
4037 implicit none
4038
4039 ! Arguments:
4040 type (struct_obs), intent(inout) :: obsdat
4041
4042 ! Locals:
4043 integer :: nobs
4044
4045 nobs = obs_numHeader(obsdat)
4046
4047 if ( obs_columnActive_IH(obsdat,OBS_STYP)) call obs_headSet_i(obsdat,OBS_STYP,nobs,mpc_missingValue_int)
4048 if ( obs_columnActive_IH(obsdat,OBS_INS) ) call obs_headSet_i(obsdat,OBS_INS,nobs,mpc_missingValue_int)
4049 if ( obs_columnActive_IH(obsdat,OBS_FOV) ) call obs_headSet_i(obsdat,OBS_FOV,nobs,mpc_missingValue_int)
4050 if ( obs_columnActive_IH(obsdat,OBS_SAT) ) call obs_headSet_i(obsdat,OBS_SAT,nobs,mpc_missingValue_int)
4051 if ( obs_columnActive_IH(obsdat,OBS_ORI) ) call obs_headSet_i(obsdat,OBS_ORI,nobs,mpc_missingValue_int)
4052 if ( obs_columnActive_IH(obsdat,OBS_TEC) ) call obs_headSet_i(obsdat,OBS_TEC,nobs,mpc_missingValue_int)
4053 if ( obs_columnActive_IH(obsdat,OBS_GQF) ) call obs_headSet_i(obsdat,OBS_GQF,nobs,mpc_missingValue_int)
4054 if ( obs_columnActive_IH(obsdat,OBS_GQL) ) call obs_headSet_i(obsdat,OBS_GQL,nobs,mpc_missingValue_int)
4055 if ( obs_columnActive_IH(obsdat,OBS_ROQF) ) call obs_headSet_i(obsdat,OBS_ROQF,nobs,mpc_missingValue_int)
4056 if ( obs_columnActive_IH(obsdat,OBS_RTP) ) call obs_headSet_i(obsdat,OBS_RTP,nobs,mpc_missingValue_int)
4057 if ( obs_columnActive_IH(obsdat,OBS_LCH) ) call obs_headSet_i(obsdat,OBS_LCH,nobs,mpc_missingValue_int)
4058
4059 if ( obs_columnActive_RH(obsdat,OBS_CLF) ) call obs_headSet_r(obsdat,OBS_CLF,nobs,obs_missingValue_r)
4060 if ( obs_columnActive_RH(obsdat,OBS_SUN) ) call obs_headSet_r(obsdat,OBS_SUN,nobs,obs_missingValue_r)
4061 if ( obs_columnActive_RH(obsdat,OBS_SAZ) ) call obs_headSet_r(obsdat,OBS_SAZ,nobs,obs_missingValue_r)
4062 if ( obs_columnActive_RH(obsdat,OBS_SZA) ) call obs_headSet_r(obsdat,OBS_SZA,nobs,obs_missingValue_r)
4063 if ( obs_columnActive_RH(obsdat,OBS_AZA) ) call obs_headSet_r(obsdat,OBS_AZA,nobs,obs_missingValue_r)
4064 if ( obs_columnActive_RH(obsdat,OBS_TRAD) ) call obs_headSet_r(obsdat,OBS_TRAD,nobs,obs_missingValue_r)
4065 if ( obs_columnActive_RH(obsdat,OBS_GEOI) ) call obs_headSet_r(obsdat,OBS_GEOI,nobs,obs_missingValue_r)
4066 if ( obs_columnActive_RH(obsdat,OBS_CLWO) ) call obs_headSet_r(obsdat,OBS_CLWO,nobs,obs_missingValue_r)
4067 if ( obs_columnActive_RH(obsdat,OBS_CLWB) ) call obs_headSet_r(obsdat,OBS_CLWB,nobs,obs_missingValue_r)
4068 if ( obs_columnActive_RH(obsdat,OBS_SIO) ) call obs_headSet_r(obsdat,OBS_SIO,nobs,obs_missingValue_r)
4069 if ( obs_columnActive_RH(obsdat,OBS_SIB) ) call obs_headSet_r(obsdat,OBS_SIB,nobs,obs_missingValue_r)
4070
4071 end subroutine setInfoToMissing
4072
4073 !--------------------------------------------------------------------------
4074 ! find_index
4075 !--------------------------------------------------------------------------
4076 integer FUNCTION FIND_INDEX(LIST,ELEMENT)
4077 implicit none
4078
4079 ! Arguments:
4080 integer, intent(in) :: LIST(:)
4081 integer, intent(in) :: ELEMENT
4082
4083 ! Locals:
4084 integer :: I
4085
4086 FIND_INDEX=-1
4087 do I = 1, size(LIST)
4088 if (list(i) == element) THEN
4089 FIND_INDEX=i
4090 exit
4091 end if
4092 end do
4093 return
4094 END FUNCTION FIND_INDEX
4095
4096 !--------------------------------------------------------------------------
4097 ! brpr_addCloudParametersandEmissivity
4098 !--------------------------------------------------------------------------
4099 subroutine brpr_addCloudParametersandEmissivity( obsSpaceData, fileIndex, burpFile )
4100 !
4101 !:Purpose: Add to the input BURP file number fileIndex cloud parameters and emissivity.
4102 !
4103 implicit none
4104
4105 ! Arguments:
4106 type(struct_obs), intent(inout) :: obsSpaceData ! obsSpacedata structure
4107 integer, intent(in) :: fileIndex ! number of the burp file to update
4108 character (len=*), intent(in) :: burpFile
4109
4110 ! Locals:
4111 type(BURP_FILE) :: inputFile
4112 type(BURP_RPT) :: inputReport,copyReport
4113 type(BURP_BLOCK) :: inputBlock
4114 character(len=9) :: opt_missing
4115 integer :: btyp10, btyp, bfam, error
4116 integer :: btyp10des, btyp10inf, btyp10obs, btyp10flg, btyp10omp
4117 integer :: nb_rpts, ref_rpt, ref_blk, count
4118 integer, allocatable :: address(:), goodprof(:), reportsToUpdate(:)
4119 real(8), allocatable :: btobs(:,:)
4120 real(8) :: emisfc
4121 integer :: nbele,nvale,nte
4122 integer, allocatable :: glbflag(:)
4123 integer :: headerIndex, valIndex, tIndex, reportIndex, bodyIndex, headElem_i
4124 integer :: ind008012,ind012163,ind055200,indEmis,indchan,ichn,ichnb
4125 integer :: ind5021, ind7024, ind13039
4126 integer :: ind14213, ind14214, ind14215, ind14216, ind14217, ind14218
4127 integer :: ind14219, ind14220, ind14221, ind13214, ind59182, indSiFG
4128 integer :: ind13209, indClwFG, ind13208, ind13095, ind25174, indtmp
4129 integer :: idata2,idata3,idata,idatend
4130 integer :: flag_passage1,flag_passage2,flag_passage3
4131 integer :: flag_passage4,flag_passage5
4132 integer :: idatyp, val
4133 real :: valBurpMissing_r4, val_r4
4134 character(len=9) :: station_id
4135
4136 write(*,*) '----------------------------------------------------------'
4137 write(*,*) '------- Begin brpr_addCloudParametersandEmissivity -------'
4138 write(*,*) '----------------------------------------------------------'
4139
4140 ! Initialisation
4141
4142 flag_passage1 = 0
4143 flag_passage2 = 0
4144 flag_passage3 = 0
4145 flag_passage4 = 0
4146 flag_passage5 = 0
4147
4148 opt_missing = 'MISSING'
4149 valBurpMissing_r4 = -7777.77
4150
4151 call BURP_Set_Options( &
4152 REAL_OPTNAME = opt_missing, &
4153 REAL_OPTNAME_VALUE = valBurpMissing_r4, &
4154 iostat = error )
4155 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Options")
4156
4157 call BURP_Init(inputFile, iostat=error)
4158 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_init inputFile")
4159 call BURP_Init(inputReport,copyReport)
4160 call BURP_Init(inputBlock)
4161
4162 ! Opening file
4163 write(*,*) 'OPENED FILE = ', trim(burpFile)
4164
4165 call BURP_New(inputFile, &
4166 FILENAME = burpFile, &
4167 MODE = FILE_ACC_APPEND, &
4168 iostat = error )
4169 call handle_error(error, "brpr_addCloudParametersandEmissivity: problem opening input file")
4170 ! Obtain input burp file number of reports
4171
4172 call BURP_Get_Property(inputFile, NRPTS=nb_rpts)
4173
4174 ! Scan input burp file to get all reports address
4175
4176 allocate(address(nb_rpts))
4177 address(:) = 0
4178 count = 0
4179 ref_rpt = 0
4180
4181 do
4182 ref_rpt = BURP_Find_Report(inputFile, &
4183 report = inputReport, &
4184 SEARCH_FROM = ref_rpt, &
4185 iostat = error)
4186 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Find_Report")
4187 if (ref_rpt < 0) Exit
4188
4189 call BURP_Get_Property(inputReport, STNID=station_id)
4190 if (station_id(1:2)==">>") cycle
4191
4192 count = count + 1
4193 address(count) = ref_rpt
4194 end do
4195
4196 write(*,*)
4197 write(*,*) 'NUMBER OF REPORTS WITH OBSERVATIONS = ',count
4198 write(*,*)
4199
4200 if ( count > 0 ) then
4201
4202 ! Create a new report
4203
4204 call BURP_New(copyReport, ALLOC_SPACE=20000000, iostat=error)
4205 call handle_error(error, "brpr_addCloudParametersandEmissivity: problem allocating copyReport")
4206
4207 ! first identify reports that have observations in obsSpaceData
4208 allocate(reportsToUpdate(count))
4209 reportsToUpdate(:) = .false.
4210 idata2 = -1
4211 REPORTS0: do reportIndex = 1, count
4212 call BURP_Get_Report(inputFile, &
4213 report = inputReport, &
4214 REF = address(reportIndex), &
4215 iostat = error)
4216 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Get_Report")
4217
4218 call BURP_Get_Property(inputReport, IDTYP=idatyp, iostat = error)
4219 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Get_Property REPORTS0")
4220
4221 call obs_set_current_header_list(obsSpaceData, 'TO')
4222 HEADER0: do
4223 headerIndex = obs_getHeaderIndex(obsSpaceData)
4224 if (headerIndex < 0) exit HEADER0
4225
4226 if (obs_headElem_i(obsSpaceData,OBS_ITY,headerIndex) == idatyp .and. &
4227 obs_headElem_i(obsSpaceData,OBS_IDF,headerIndex) == fileIndex) then
4228 reportsToUpdate(reportIndex) = .true.
4229 if (idata2 == -1) idata2 = headerIndex
4230 cycle REPORTS0
4231 end if
4232 end do HEADER0
4233 end do REPORTS0
4234
4235 if (idata2 == -1) then
4236 write(*,*) 'brpr_addCloudParametersandEmissivity: for datyp=', idatyp, &
4237 ' there is no report found in input file for update! Exiting ...'
4238 call cleanup()
4239 return
4240 end if
4241 idata3 = idata2
4242
4243 ! Loop on reports
4244
4245 REPORTS: do reportIndex = 1, count
4246
4247 call BURP_Get_Report(inputFile, &
4248 report = inputReport, &
4249 REF = address(reportIndex), &
4250 iostat = error)
4251 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Get_Report")
4252
4253 if (.not. reportsToUpdate(reportIndex)) cycle REPORTS
4254
4255 call BURP_Get_Property(inputReport, IDTYP=idatyp, iostat = error)
4256 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Get_Property REPORTS")
4257
4258 ! First loop on blocks
4259
4260 ! Find bad profiles not in CMA. This occurs if :
4261 ! - all observations are -1 and/or have a quality flag not zero
4262
4263 ref_blk = 0
4264
4265 BLOCKS1: do
4266
4267 ref_blk = BURP_Find_Block(inputReport, &
4268 BLOCK = inputBlock, &
4269 SEARCH_FROM = ref_blk, &
4270 iostat = error)
4271 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Find_Block #1")
4272 if (ref_blk < 0) EXIT BLOCKS1
4273
4274 call BURP_Get_Property(inputBlock, &
4275 NELE = nbele, &
4276 NVAL = nvale, &
4277 NT = nte, &
4278 BFAM = bfam, &
4279 BTYP = btyp, &
4280 iostat = error)
4281 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Get_Property #2")
4282
4283 ! observation block (btyp = 0100 100011X XXXX)
4284 ! 0100 1000110 0000 = 9312
4285 btyp10 = ishft(btyp,-5)
4286 btyp10obs = 291
4287
4288 if ( btyp10 == btyp10obs .and. bfam == 0 ) then
4289 allocate(goodprof(nte), btobs(nvale,nte))
4290
4291 goodprof(:) = 0
4292 btobs(:,:) = 0.
4293
4294 ind012163 = BURP_Find_Element(inputBlock, ELEMENT=012163)
4295 if (ind012163 == -1) call handle_error(ind012163, "brpr_addCloudParametersandEmissivity: cannot find element 12163 in inputBlock")
4296
4297 do tIndex=1,nte
4298 do valIndex=1,nvale
4299 btobs(valIndex,tIndex) = BURP_Get_Rval(inputBlock, &
4300 NELE_IND = ind012163, &
4301 NVAL_IND = valIndex, &
4302 NT_IND = tIndex )
4303 if ( btobs(valIndex,tIndex) > 0. ) goodprof(tIndex) = 1
4304 end do
4305 end do
4306
4307 end if
4308
4309 end do BLOCKS1
4310
4311 call BURP_copy_Header(TO=copyReport, FROM=inputReport)
4312
4313 call BURP_Init_Report_Write(inputFile, copyReport, iostat=error)
4314 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Init_Report_Write")
4315
4316 ! Second loop on blocks
4317
4318 ! add new informations
4319 ref_blk = 0
4320
4321 BLOCKS2: do
4322
4323 if ( .not. allocated(goodprof) ) then
4324 write(*,*)
4325 write(*,*) 'Resume report is position # ',reportIndex
4326 EXIT BLOCKS2
4327 end if
4328
4329 ref_blk = BURP_Find_Block(inputReport, &
4330 BLOCK = inputBlock, &
4331 SEARCH_FROM = ref_blk, &
4332 iostat = error)
4333 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Find_Block #2")
4334 if (ref_blk < 0) EXIT BLOCKS2
4335
4336 call BURP_Get_Property(inputBlock, &
4337 NELE = nbele, &
4338 NVAL = nvale, &
4339 NT = nte, &
4340 BFAM = bfam, &
4341 BTYP = btyp, &
4342 iostat = error)
4343 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Get_Property #3")
4344
4345 ! descriptor block (btyp = 0010 100000X XXXX)
4346 ! 0010 1000000 0000==5120 )
4347 ! if profile contains rejected observations (apart from blacklisted channels),
4348 ! set bit 6 in global flags.
4349
4350 btyp10 = ishft(btyp,-5)
4351 btyp10des = 160
4352
4353 if ( btyp10 == btyp10des ) then
4354 flag_passage1 = 1
4355
4356 allocate(glbflag(nte))
4357
4358 ind055200 = BURP_Find_Element(inputBlock, ELEMENT=055200)
4359 if (ind055200 == -1) call handle_error(ind055200, "brpr_addCloudParametersandEmissivity: cannot find element 55200 in inputBlock")
4360 do tIndex = 1, nte
4361 glbflag(tIndex) = BURP_Get_Tblval(inputBlock, &
4362 NELE_IND = ind055200, &
4363 NVAL_IND = 1, &
4364 NT_IND = tIndex )
4365 end do
4366
4367 do tIndex = 1, nte
4368 if (goodprof(tIndex)/= 1) glbflag(tIndex) = ibset(glbflag(tIndex),6)
4369 end do
4370
4371 do tIndex = 1, nte
4372 call BURP_Set_Tblval(inputBlock, &
4373 NELE_IND = ind055200, &
4374 NVAL_IND = 1, &
4375 NT_IND = tIndex, &
4376 TBLVAL = glbflag(tIndex), &
4377 iostat = error)
4378 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Tblval 55200")
4379 end do
4380
4381 deallocate(glbflag)
4382
4383 end if
4384 ! For Hyperspectral data
4385 !
4386 if ( tvs_isIdBurpHyperSpectral(idatyp) ) then
4387
4388 write(*,*) 'brpr_addCloudParametersandEmissivity for IR data'
4389 ! info block (btyp = 0001 100000X XXXX)
4390 ! 0001 100000X XXXX = 3072
4391 btyp10 = ishft(btyp,-5)
4392 btyp10inf = 96
4393 if ( btyp10 == btyp10inf ) then
4394 flag_passage2 = 1
4395 ind14213 = BURP_Find_Element(inputBlock, ELEMENT=014213)
4396 ind14214 = BURP_Find_Element(inputBlock, ELEMENT=014214)
4397 ind14215 = BURP_Find_Element(inputBlock, ELEMENT=014215)
4398 ind14216 = BURP_Find_Element(inputBlock, ELEMENT=014216)
4399 ind14217 = BURP_Find_Element(inputBlock, ELEMENT=014217)
4400 ind14218 = BURP_Find_Element(inputBlock, ELEMENT=014218)
4401 ind14219 = BURP_Find_Element(inputBlock, ELEMENT=014219)
4402 ind14220 = BURP_Find_Element(inputBlock, ELEMENT=014220)
4403 ind14221 = BURP_Find_Element(inputBlock, ELEMENT=014221)
4404 ind13214 = BURP_Find_Element(inputBlock, ELEMENT=013214)
4405 ind59182 = BURP_Find_Element(inputBlock, ELEMENT=59182)
4406 if (ind14213 < 0) then
4407 call BURP_Resize_Block(inputBlock, ADD_NELE=11, iostat=error)
4408 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #1")
4409 ind14213 = nbele+ 1
4410 ind14214 = nbele+ 2
4411 ind14215 = nbele+ 3
4412 ind14216 = nbele+ 4
4413 ind14217 = nbele+ 5
4414 ind14218 = nbele+ 6
4415 ind14219 = nbele+ 7
4416 ind14220 = nbele+ 8
4417 ind14221 = nbele+ 9
4418 ind13214 = nbele+ 10
4419 ind59182 = nbele+ 11
4420 call BURP_Set_Element(inputBlock, NELE_IND=ind14213, ELEMENT=014213, iostat=error)
4421 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 14213")
4422 call BURP_Set_Element(inputBlock, NELE_IND=ind14214, ELEMENT=014214, iostat=error)
4423 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 14214")
4424 call BURP_Set_Element(inputBlock, NELE_IND=ind14215, ELEMENT=014215, iostat=error)
4425 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 14215")
4426 call BURP_Set_Element(inputBlock, NELE_IND=ind14216, ELEMENT=014216, iostat=error)
4427 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 14216")
4428 call BURP_Set_Element(inputBlock, NELE_IND=ind14217, ELEMENT=014217, iostat=error)
4429 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 14217")
4430 call BURP_Set_Element(inputBlock, NELE_IND=ind14218, ELEMENT=014218, iostat=error)
4431 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 14218")
4432 call BURP_Set_Element(inputBlock, NELE_IND=ind14219, ELEMENT=014219, iostat=error)
4433 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 14219")
4434 call BURP_Set_Element(inputBlock, NELE_IND=ind14220, ELEMENT=014220, iostat=error)
4435 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 14220")
4436 call BURP_Set_Element(inputBlock, NELE_IND=ind14221, ELEMENT=014221, iostat=error)
4437 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 14221")
4438 call BURP_Set_Element(inputBlock, NELE_IND=ind13214, ELEMENT=013214, iostat=error)
4439 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 13214")
4440 call BURP_Set_Element(inputBlock, NELE_IND=ind59182, ELEMENT=059182, iostat=error)
4441 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 59182")
4442 end if
4443
4444 ind008012 = BURP_Find_Element(inputBlock, ELEMENT = 008012)
4445 if (ind008012 == -1) call handle_error(ind008012, "brpr_addCloudParametersandEmissivity: cannot find element 8012 in inputBlock #1")
4446
4447 do tIndex = 1, nte
4448
4449 if ( goodprof(tIndex) == 1 ) then
4450
4451 if ( obs_headElem_i(obsSpaceData,OBS_IDF,idata2) /= fileIndex) then
4452 headElem_i = obs_headElem_i(obsSpaceData,OBS_IDF,idata2)
4453 write(*,*) "File Inconsistency ", headElem_i, fileIndex
4454 write(*,*) "Should not happen..."
4455 call utl_abort('brpr_addCloudParametersandEmissivity')
4456 end if
4457
4458 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_ETOP, idata2))
4459 call Insert_into_burp_r4(val_r4, ind14213, 1, tIndex, valueIsMissing=(val_r4<0.0))
4460 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_VTOP, idata2))
4461 call Insert_into_burp_r4(val_r4, ind14214, 1, tIndex, valueIsMissing=(val_r4<0.0))
4462 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_ECF, idata2))
4463 call Insert_into_burp_r4(val_r4, ind14215, 1, tIndex, valueIsMissing=(val_r4<0.0))
4464 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_VCF, idata2))
4465 call Insert_into_burp_r4(val_r4, ind14216, 1, tIndex, valueIsMissing=(val_r4<0.0))
4466 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_HE, idata2))
4467 call Insert_into_burp_r4(val_r4, ind14217, 1, tIndex, valueIsMissing=(val_r4<0.0))
4468 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_ZTSR, idata2))
4469 call Insert_into_burp_r4(val_r4, ind14218, 1, tIndex, valueIsMissing=(val_r4<0.0))
4470 val = obs_headElem_i(obsSpaceData, OBS_NCO2, idata2)
4471 call Insert_into_burp_i(val, ind14219, 1, tIndex)
4472 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_ZTM, idata2))
4473 call Insert_into_burp_r4(val_r4, ind14220, 1, tIndex, valueIsMissing=(val_r4<0.0))
4474 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_ZTGM, idata2))
4475 call Insert_into_burp_r4(val_r4, ind14221, 1, tIndex, valueIsMissing=(val_r4<0.0))
4476 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_ZLQM, idata2))
4477 call Insert_into_burp_r4(val_r4, ind13214, 1, tIndex, valueIsMissing=(val_r4<0.0))
4478 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_ZPS, idata2))
4479 call Insert_into_burp_r4(val_r4, ind59182, 1, tIndex, valueIsMissing=(val_r4<0.0))
4480 val = tvs_ChangedStypValue(obsSpaceData, idata2)
4481 call Insert_into_burp_i(val, ind008012, 1, tIndex)
4482 idata2 = idata2 + 1
4483
4484 else
4485
4486 val_r4 = -1.0
4487 call Insert_into_burp_r4(val_r4, ind14213, 1, tIndex, valueIsMissing=.true.)
4488 call Insert_into_burp_r4(val_r4, ind14214, 1, tIndex, valueIsMissing=.true.)
4489 call Insert_into_burp_r4(val_r4, ind14215, 1, tIndex, valueIsMissing=.true.)
4490 call Insert_into_burp_r4(val_r4, ind14216, 1, tIndex, valueIsMissing=.true.)
4491 call Insert_into_burp_r4(val_r4, ind14217, 1, tIndex, valueIsMissing=.true.)
4492 call Insert_into_burp_r4(val_r4, ind14218, 1, tIndex, valueIsMissing=.true.)
4493 call Insert_into_burp_i(-1, ind14219, 1, tIndex)
4494 call Insert_into_burp_r4(val_r4, ind14220, 1, tIndex, valueIsMissing=.true.)
4495 call Insert_into_burp_r4(val_r4, ind14221, 1, tIndex, valueIsMissing=.true.)
4496 call Insert_into_burp_r4(val_r4, ind13214, 1, tIndex, valueIsMissing=.true.)
4497 call Insert_into_burp_r4(val_r4, ind59182, 1, tIndex, valueIsMissing=.true.)
4498 call Insert_into_burp_i(-1, ind008012, 1, tIndex)
4499
4500 end if
4501
4502
4503 end do
4504
4505 end if
4506
4507 ! observation block (btyp = 0100 100011X XXXX)
4508 ! 0100 1000110 0000 = 9312
4509 btyp10 = ishft(btyp,-5)
4510 btyp10obs = 291
4511
4512 if ( btyp10 == btyp10obs .and. bfam == 0 ) then
4513 flag_passage3 = 1
4514
4515 indEmis = BURP_Find_Element(inputBlock, ELEMENT=055043)
4516 if (indEmis < 0) then
4517 indEmis=nbele+1
4518 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
4519 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block data")
4520 call BURP_Set_Element(inputBlock, NELE_IND=indEmis, ELEMENT=055043, iostat=error)
4521 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 55043 #1")
4522 indEmis=nbele+1
4523 end if
4524 indchan = BURP_Find_Element(inputBlock, ELEMENT=005042)
4525 if (indchan == -1) call handle_error(indchan, "brpr_addCloudParametersandEmissivity: cannot find element 5042 in inputBlock")
4526 do tIndex = 1, nte
4527 do valIndex = 1, nvale
4528 call Insert_into_burp_i(-1,indEmis,valIndex,tIndex)
4529 end do
4530
4531 if ( goodprof(tIndex) == 1 ) then
4532
4533 if ( obs_headElem_i(obsSpaceData,OBS_IDF,idata3) /= fileIndex) then
4534 headElem_i = obs_headElem_i(obsSpaceData,OBS_IDF,idata3)
4535 write(*,*) "File Inconsistency emissivity block", &
4536 headElem_i, fileIndex, idata3
4537 write(*,*) "Should not happen..."
4538 call utl_abort('brpr_addCloudParametersandEmissivity')
4539 end if
4540 idata = obs_headElem_i(obsSpaceData,OBS_RLN,idata3)
4541 idatend = obs_headElem_i(obsSpaceData,OBS_NLV,idata3) + idata - 1
4542 do bodyIndex = idata, idatend
4543 emisfc = 100.d0 * obs_bodyElem_r(obsspacedata,OBS_SEM,bodyIndex)
4544 ichn = NINT(obs_bodyElem_r(obsSpaceData,OBS_PPP,bodyIndex))
4545 ichn = MAX(0,MIN(ichn,tvs_maxChannelNumber+1))
4546 bl: do valIndex=1, nvale
4547 ichnb=BURP_Get_Tblval(inputBlock, &
4548 NELE_IND = indchan, &
4549 NVAL_IND = valIndex, &
4550 NT_IND = tIndex)
4551 if (ichn==ichnb) then
4552 val_r4 = sngl(emisfc)
4553 call Insert_into_burp_r4(val_r4, indEmis, valIndex, tIndex, &
4554 valueIsMissing=(val_r4<0.0))
4555 exit bl
4556 end if
4557 end do bl
4558
4559 end do
4560
4561 idata3 = idata3 + 1
4562
4563 end if
4564
4565 end do
4566
4567 end if
4568
4569 ! flag block (btyp = 0111 100011X XXXX)
4570 ! 0111 1000110 0000 = 15456
4571 btyp10 = ishft(btyp,-5)
4572 btyp10flg = 483
4573
4574 if ( btyp10 == btyp10flg ) then
4575 flag_passage4 = 1
4576
4577 indEmis = BURP_Find_Element(inputBlock, ELEMENT=255043)
4578 if (indEmis < 0) then
4579 indEmis=nbele+1
4580 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
4581 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block marqueur")
4582 call BURP_Set_Element(inputBlock, NELE_IND=indEmis, ELEMENT=255043, iostat=error)
4583 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 255043")
4584 end if
4585
4586 do tIndex = 1, nte
4587 do valIndex = 1, nvale
4588 call BURP_Set_Tblval(inputBlock, &
4589 NELE_IND = indEmis, &
4590 NVAL_IND = valIndex, &
4591 NT_IND = tIndex, &
4592 TBLVAL = 0, &
4593 iostat = error)
4594 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Tblval 255043")
4595 end do
4596 end do
4597 end if
4598
4599 ! O-P block (btyp = 0100 100011X XXXX)
4600 ! 0100 1000110 0000 = 9312
4601 btyp10 = ishft(btyp,-5)
4602 btyp10omp = 291
4603
4604 if ( btyp10 == btyp10omp .and. bfam == 14 ) then
4605 flag_passage5 = 1
4606
4607 indEmis = BURP_Find_Element(inputBlock, ELEMENT=055043)
4608 if (indEmis < 0) then
4609 indEmis=nbele+1
4610 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
4611 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block O-P")
4612 call BURP_Set_Element(inputBlock, NELE_IND=nbele+1, ELEMENT=055043, iostat=error)
4613 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 55043 #2")
4614 end if
4615
4616 do tIndex = 1, nte
4617 do valIndex = 1, nvale
4618 call Insert_into_burp_i(-1,indEmis,valIndex,tIndex)
4619 end do
4620 end do
4621
4622 end if
4623
4624 end if ! hyper Spectral
4625
4626 if (tvs_isIdBurpInst(idatyp,'atms' ) .or. tvs_isIdBurpInst(idatyp,'amsua')) then
4627 ! info block (btyp = 0001 100000X XXXX)
4628 ! 0001 100000X XXXX = 3072
4629 btyp10 = ishft(btyp,-5)
4630 btyp10inf = 96
4631 if ( btyp10 == btyp10inf ) then
4632 flag_passage2 = 1
4633 indtmp = nbele
4634 ! CLW
4635 ind13209 = BURP_Find_Element(inputBlock, ELEMENT=013209)
4636 if (ind13209 < 0) then
4637 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
4638 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #2")
4639 ind13209 = indtmp + 1
4640 call BURP_Set_Element(inputBlock, NELE_IND=ind13209, ELEMENT=013209, iostat=error)
4641 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 13209 #1")
4642 indtmp = indtmp + 1
4643 end if
4644
4645 ! clwFG
4646 if (tvs_isInstrumAllskyTtAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
4647 indClwFG = BURP_Find_Element(inputBlock, ELEMENT=clwFgElementId)
4648 if (indClwFG < 0) then
4649 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
4650 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #3")
4651 indClwFG = indtmp + 1
4652 call BURP_Set_Element(inputBlock, NELE_IND=indClwFG, ELEMENT=clwFgElementId, iostat=error)
4653 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element clwFG #1")
4654 indtmp = indtmp + 1
4655 end if
4656 end if
4657
4658 ! SCATTERING INDEX
4659 ind13208 = BURP_Find_Element(inputBlock, ELEMENT=013208)
4660 if (ind13208 < 0) then
4661 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
4662 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #4")
4663 ind13208 = indtmp + 1
4664 call BURP_Set_Element(inputBlock, NELE_IND=ind13208, ELEMENT=013208, iostat=error)
4665 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 013208")
4666 indtmp = indtmp + 1
4667 end if
4668
4669 ! siFG
4670 if (tvs_isInstrumAllskyHuAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
4671 indSiFG = BURP_Find_Element(inputBlock, ELEMENT=siFgElementId)
4672 if (indSiFG < 0) then
4673 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
4674 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #5")
4675 indSiFG = indtmp + 1
4676 call BURP_Set_Element(inputBlock, NELE_IND=indSiFG, ELEMENT=siFgElementId, iostat=error)
4677 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element siFG #1")
4678 indtmp = indtmp + 1
4679 end if
4680 end if
4681
4682 ind008012 = BURP_Find_Element(inputBlock, ELEMENT = 008012)
4683 if (ind008012 == -1) call handle_error(ind008012, "brpr_addCloudParametersandEmissivity: cannot find element 8012 in inputBlock #2")
4684
4685 do tIndex = 1, nte
4686
4687 if ( goodprof(tIndex) == 1 ) then
4688
4689 if ( obs_headElem_i(obsSpaceData,OBS_IDF,idata2) /= fileIndex) then
4690 headElem_i = obs_headElem_i(obsSpaceData,OBS_IDF,idata2)
4691 write(*,*) "File Inconsistency ", headElem_i, fileIndex
4692 write(*,*) "Should not happen..."
4693 call utl_abort('brpr_addCloudParametersandEmissivity')
4694 end if
4695
4696 ! clwObs
4697 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_CLWO, idata2))
4698 call Insert_into_burp_r4(val_r4, ind13209, 1, tIndex, valueIsMissing=(val_r4<0.0))
4699 ! clwFG
4700 if (tvs_isInstrumAllskyTtAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
4701 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_CLWB, idata2))
4702 call Insert_into_burp_r4(val_r4, indClwFG, 1, tIndex, valueIsMissing=(val_r4<0.0))
4703 end if
4704
4705 ! siObs
4706 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_SIO, idata2))
4707 call Insert_into_burp_r4(val_r4, ind13208, 1, tIndex, &
4708 valueIsMissing=(val_r4==mpc_missingValue_r4))
4709 ! siFG
4710 if (tvs_isInstrumAllskyHuAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
4711 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_SIB, idata2))
4712 call Insert_into_burp_r4(val_r4, indSiFG, 1, tIndex, &
4713 valueIsMissing=(val_r4==mpc_missingValue_r4))
4714 end if
4715
4716 val = obs_headElem_i(obsSpaceData, OBS_STYP, idata2)
4717 call Insert_into_burp_i(val, ind008012, 1, tIndex)
4718 idata2 = idata2 + 1
4719
4720 else
4721 val_r4 = -1.0
4722 call Insert_into_burp_r4(val_r4, ind13209, 1, tIndex, valueIsMissing=.true.)
4723 if (tvs_isInstrumAllskyTtAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
4724 call Insert_into_burp_r4(val_r4, indClwFG, 1, tIndex, valueIsMissing=.true.)
4725 end if
4726
4727 call Insert_into_burp_r4(val_r4, ind13208, 1, tIndex, valueIsMissing=.true.)
4728 if (tvs_isInstrumAllskyHuAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
4729 call Insert_into_burp_r4(val_r4, indSiFG, 1, tIndex, valueIsMissing=.true.)
4730 end if
4731
4732 call Insert_into_burp_i(-1, ind008012, 1, tIndex)
4733
4734 end if
4735
4736 end do
4737
4738 end if
4739 end if ! tvs_isIdBurpInst(idatyp,'atms')) .or. (tvs_isIdBurpInst(idatyp,'amsua')
4740
4741 if (tvs_isIdBurpInst(idatyp,'amsub') .or. tvs_isIdBurpInst(idatyp,'mhs')) then
4742 ! info block (btyp = 0001 100000X XXXX)
4743 ! 0001 100000X XXXX = 3072
4744 btyp10 = ishft(btyp,-5)
4745 btyp10inf = 96
4746 if ( btyp10 == btyp10inf ) then
4747 flag_passage2 = 1
4748 indtmp = nbele
4749
4750 ! SCATTERING INDEX
4751 ind13208 = BURP_Find_Element(inputBlock, ELEMENT=013208)
4752 if (ind13208 < 0) then
4753 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
4754 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #4")
4755 ind13208 = indtmp + 1
4756 call BURP_Set_Element(inputBlock, NELE_IND=ind13208, ELEMENT=013208, iostat=error)
4757 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 013208")
4758 indtmp = indtmp + 1
4759 end if
4760
4761 ! siFG
4762 if (tvs_isInstrumAllskyHuAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
4763 indSiFG = BURP_Find_Element(inputBlock, ELEMENT=siFgElementId)
4764 if (indSiFG < 0) then
4765 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
4766 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #5")
4767 indSiFG = indtmp + 1
4768 call BURP_Set_Element(inputBlock, NELE_IND=indSiFG, ELEMENT=siFgElementId, iostat=error)
4769 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element siFG #1")
4770 indtmp = indtmp + 1
4771 end if
4772 end if
4773
4774 ind008012 = BURP_Find_Element(inputBlock, ELEMENT = 008012)
4775 if (ind008012 == -1) call handle_error(ind008012, "brpr_addCloudParametersandEmissivity: cannot find element 8012 in inputBlock #2")
4776
4777 do tIndex = 1, nte
4778
4779 if ( goodprof(tIndex) == 1 ) then
4780
4781 if ( obs_headElem_i(obsSpaceData,OBS_IDF,idata2) /= fileIndex) then
4782 headElem_i = obs_headElem_i(obsSpaceData,OBS_IDF,idata2)
4783 write(*,*) "File Inconsistency ", headElem_i, fileIndex
4784 write(*,*) "Should not happen..."
4785 call utl_abort('brpr_addCloudParametersandEmissivity')
4786 end if
4787
4788 ! siObs
4789 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_SIO, idata2))
4790 call Insert_into_burp_r4(val_r4, ind13208, 1, tIndex, &
4791 valueIsMissing=(val_r4==mpc_missingValue_r4))
4792 ! siFG
4793 if (tvs_isInstrumAllskyHuAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
4794 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_SIB, idata2))
4795 call Insert_into_burp_r4(val_r4, indSiFG, 1, tIndex, &
4796 valueIsMissing=(val_r4==mpc_missingValue_r4))
4797 end if
4798
4799 val = obs_headElem_i(obsSpaceData, OBS_STYP, idata2)
4800 call Insert_into_burp_i(val, ind008012, 1, tIndex)
4801 idata2 = idata2 + 1
4802
4803 else
4804 val_r4 = mpc_missingValue_r4
4805 call Insert_into_burp_r4(val_r4, ind13208, 1, tIndex, valueIsMissing=.true.)
4806 if (tvs_isInstrumAllskyHuAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
4807 call Insert_into_burp_r4(val_r4, indSiFG, 1, tIndex, valueIsMissing=.true.)
4808 end if
4809
4810 call Insert_into_burp_i(-1, ind008012, 1, tIndex)
4811
4812 end if
4813
4814 end do
4815
4816 end if
4817 end if ! tvs_isIdBurpInst(idatyp,'amsub') .or. tvs_isIdBurpInst(idatyp,'mhs')
4818
4819 if (tvs_isIdBurpInst(idatyp,'ssmis' )) then
4820 ! info block (btyp = 0001 100000X XXXX)
4821 ! 0001 100000X XXXX = 3072
4822 btyp10 = ishft(btyp,-5)
4823 btyp10inf = 96
4824 if ( btyp10 == btyp10inf ) then
4825 flag_passage2 = 1
4826 indtmp = nbele
4827
4828 ! LAND SEA QUALIFIER ELE 8012
4829 ind008012 = BURP_Find_Element(inputBlock, ELEMENT = 008012)
4830 if (ind008012 < 0) then
4831 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
4832 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #6")
4833 ind008012 = indtmp + 1
4834 call BURP_Set_Element(inputBlock, NELE_IND=ind008012, ELEMENT=008012, iostat=error)
4835 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 8012 ssmis")
4836 indtmp = indtmp + 1
4837 end if
4838
4839 ! TERRAIN TYPE ELE 13039
4840 ind13039 = BURP_Find_Element(inputBlock, ELEMENT = 13039)
4841 if (ind13039 < 0) then
4842 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
4843 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #7")
4844 ind13039 = indtmp + 1
4845 call BURP_Set_Element(inputBlock, NELE_IND=ind13039, ELEMENT=13039, iostat=error)
4846 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 13039")
4847 indtmp = indtmp + 1
4848 end if
4849
4850 ! SAT ZENITH ANGLE ELE 7024
4851 ind7024 = BURP_Find_Element(inputBlock, ELEMENT = 7024)
4852 if (ind7024 < 0) then
4853 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
4854 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #8")
4855 ind7024 = indtmp + 1
4856 call BURP_Set_Element(inputBlock, NELE_IND=ind7024, ELEMENT=7024, iostat=error)
4857 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 7024")
4858 indtmp = indtmp + 1
4859 end if
4860
4861 ! SAT AZIMUTH ANGLE ELE 5021
4862 ind5021 = BURP_Find_Element(inputBlock, ELEMENT = 5021)
4863 if (ind5021 < 0) then
4864 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
4865 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #9")
4866 ind5021 = indtmp + 1
4867 call BURP_Set_Element(inputBlock, NELE_IND=ind5021, ELEMENT=5021, iostat=error)
4868 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 5021")
4869 indtmp = indtmp + 1
4870 end if
4871
4872 ! CLW
4873 ind13209 = BURP_Find_Element(inputBlock, ELEMENT=013209)
4874 if (ind13209 < 0) then
4875 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
4876 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #10")
4877 ind13209 = indtmp + 1
4878 call BURP_Set_Element(inputBlock, NELE_IND=ind13209, ELEMENT=013209, iostat=error)
4879 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 13209 #2")
4880 indtmp = indtmp + 1
4881 end if
4882
4883 ! clwFG
4884 if (tvs_isInstrumAllskyTtAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
4885 indClwFG = BURP_Find_Element(inputBlock, ELEMENT=clwFgElementId)
4886 if (indClwFG < 0) then
4887 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
4888 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #11")
4889 indClwFG = indtmp + 1
4890 call BURP_Set_Element(inputBlock, NELE_IND=indClwFG, ELEMENT=clwFgElementId, iostat=error)
4891 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element clwFG #2")
4892 indtmp = indtmp + 1
4893 end if
4894 end if
4895
4896 ! SSMIS INTEGRATED WATER VAPOR
4897 ind13095 = BURP_Find_Element(inputBlock, ELEMENT=013095)
4898 if (ind13095 < 0) then
4899 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
4900 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #12")
4901 ind13095 = indtmp + 1
4902 call BURP_Set_Element(inputBlock, NELE_IND=ind13095, ELEMENT=013095, iostat=error)
4903 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 13095")
4904 indtmp = indtmp + 1
4905 end if
4906
4907 ! SCATERING INDEX
4908 ind13208 = BURP_Find_Element(inputBlock, ELEMENT=013208)
4909 if (ind13208 < 0) then
4910 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
4911 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #13")
4912 ind13208 = indtmp + 1
4913 call BURP_Set_Element(inputBlock, NELE_IND=ind13208, ELEMENT=013208, iostat=error)
4914 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 13208")
4915 indtmp = indtmp + 1
4916 end if
4917
4918 ! siFG
4919 if (tvs_isInstrumAllskyHuAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
4920 indSiFG = BURP_Find_Element(inputBlock, ELEMENT=siFgElementId)
4921 if (indSiFG < 0) then
4922 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
4923 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #14")
4924 indSiFG = indtmp + 1
4925 call BURP_Set_Element(inputBlock, NELE_IND=indSiFG, ELEMENT=siFgElementId, iostat=error)
4926 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element siFG #2")
4927 indtmp = indtmp + 1
4928 end if
4929 end if
4930
4931 do tIndex = 1, nte
4932
4933 if ( goodprof(tIndex) == 1 ) then
4934
4935 if ( obs_headElem_i(obsSpaceData,OBS_IDF,idata2) /= fileIndex) then
4936 headElem_i = obs_headElem_i(obsSpaceData,OBS_IDF,idata2)
4937 write(*,*) "File Inconsistency ", headElem_i, fileIndex
4938 write(*,*) "Should not happen..."
4939 call utl_abort('brpr_addCloudParametersandEmissivity')
4940 end if
4941
4942 ! clwObs
4943 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_CLWO, idata2))
4944 call Insert_into_burp_r4(val_r4, ind13209, 1, tIndex, valueIsMissing=(val_r4<0.0))
4945 ! clwFG
4946 if (tvs_isInstrumAllskyTtAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
4947 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_CLWB, idata2))
4948 call Insert_into_burp_r4(val_r4, indClwFG, 1, tIndex, valueIsMissing=(val_r4<0.0))
4949 end if
4950
4951 ! siObs
4952 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_SIO, idata2))
4953 call Insert_into_burp_r4(val_r4, ind13208, 1, tIndex, &
4954 valueIsMissing=(val_r4==mpc_missingValue_r4))
4955 ! siFG
4956 if (tvs_isInstrumAllskyHuAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
4957 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_SIB, idata2))
4958 call Insert_into_burp_r4(val_r4, indSiFG, 1, tIndex, &
4959 valueIsMissing=(val_r4==mpc_missingValue_r4))
4960 end if
4961
4962 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_IWV, idata2))
4963 call Insert_into_burp_r4(val_r4, ind13095, 1, tIndex, valueIsMissing=(val_r4<0.0))
4964 val = obs_headElem_i(obsSpaceData, OBS_STYP, idata2)
4965 call Insert_into_burp_i(val, ind008012, 1, tIndex)
4966 val = obs_headElem_i(obsSpaceData, OBS_TTYP, idata2)
4967 call Insert_into_burp_i(val, ind13039, 1, tIndex)
4968 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_SZA, idata2))
4969 call Insert_into_burp_r4(val_r4, ind7024, 1, tIndex, valueIsMissing=(val_r4<0.0))
4970 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_AZA, idata2))
4971 call Insert_into_burp_r4(val_r4, ind5021, 1, tIndex, valueIsMissing=(val_r4<0.0))
4972 idata2 = idata2 + 1
4973 else
4974 val_r4 = -1.0
4975 call Insert_into_burp_r4(val_r4, ind13209, 1, tIndex, valueIsMissing=.true.)
4976 if (tvs_isInstrumAllskyTtAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
4977 call Insert_into_burp_r4(val_r4, indClwFG, 1, tIndex, valueIsMissing=.true.)
4978 end if
4979
4980 call Insert_into_burp_r4(val_r4, ind13208, 1, tIndex, valueIsMissing=.true.)
4981 if (tvs_isInstrumAllskyHuAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
4982 call Insert_into_burp_r4(val_r4, indSiFG, 1, tIndex, valueIsMissing=.true.)
4983 end if
4984
4985 !call Insert_into_burp_r4(-1.0,ind13095,1,tIndex)
4986 call Insert_into_burp_i(-1, ind008012, 1, tIndex)
4987 call Insert_into_burp_i(-1, ind13039, 1, tIndex)
4988 call Insert_into_burp_r4(val_r4, ind7024, 1, tIndex, valueIsMissing=.true.)
4989 call Insert_into_burp_r4(val_r4, ind5021, 1, tIndex, valueIsMissing=.true.)
4990 end if
4991 end do
4992
4993 end if
4994 end if ! tvs_isIdBurpInst(idatyp,'ssmis')
4995
4996 if (tvs_isIdBurpInst(idatyp,'mwhs2' )) then
4997 ! info block (btyp = 0001 100000X XXXX)
4998 ! 0001 100000X XXXX = 3072
4999 btyp10 = ishft(btyp,-5)
5000 btyp10inf = 96
5001 if ( btyp10 == btyp10inf ) then
5002 flag_passage2 = 1
5003 indtmp = nbele
5004
5005 ! LAND SEA QUALIFIER ELE 8012
5006 ind008012 = BURP_Find_Element(inputBlock, ELEMENT = 008012)
5007 if (ind008012 < 0) then
5008 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
5009 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #15")
5010 ind008012 = indtmp + 1
5011 call BURP_Set_Element(inputBlock, NELE_IND=ind008012, ELEMENT=008012, iostat=error)
5012 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 8012 ssmis")
5013 indtmp = indtmp + 1
5014 end if
5015
5016 ! TERRAIN TYPE ELE 13039
5017 ind13039 = BURP_Find_Element(inputBlock, ELEMENT = 13039)
5018 if (ind13039 < 0) then
5019 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
5020 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #16")
5021 ind13039 = indtmp + 1
5022 call BURP_Set_Element(inputBlock, NELE_IND=ind13039, ELEMENT=13039, iostat=error)
5023 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 13039")
5024 indtmp = indtmp + 1
5025 end if
5026
5027 ! SPECIAL QC FLAG INTEGER
5028 ind25174 = BURP_Find_Element(inputBlock, ELEMENT=025174)
5029 if (ind25174 < 0) then
5030 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
5031 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #17")
5032 ind25174 = indtmp + 1
5033 call BURP_Set_Element(inputBlock, NELE_IND=ind25174, ELEMENT=025174, iostat=error)
5034 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 25174")
5035 indtmp = indtmp + 1
5036 end if
5037
5038 ! CLW
5039 ind13209 = BURP_Find_Element(inputBlock, ELEMENT=013209)
5040 if (ind13209 < 0) then
5041 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
5042 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #18")
5043 ind13209 = indtmp + 1
5044 call BURP_Set_Element(inputBlock, NELE_IND=ind13209, ELEMENT=013209, iostat=error)
5045 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 13209 #3")
5046 indtmp = indtmp + 1
5047 end if
5048
5049 ! clwFG
5050 if (tvs_isInstrumAllskyTtAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
5051 indClwFG = BURP_Find_Element(inputBlock, ELEMENT=clwFgElementId)
5052 if (indClwFG < 0) then
5053 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
5054 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #19")
5055 indClwFG = indtmp + 1
5056 call BURP_Set_Element(inputBlock, NELE_IND=indClwFG, ELEMENT=clwFgElementId, iostat=error)
5057 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element clwFG #3")
5058 indtmp = indtmp + 1
5059 end if
5060 end if
5061
5062 ! SCATERING INDEX
5063 ind13208 = BURP_Find_Element(inputBlock, ELEMENT=013208)
5064 if (ind13208 < 0) then
5065 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
5066 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #20")
5067 ind13208 = indtmp + 1
5068 call BURP_Set_Element(inputBlock, NELE_IND=ind13208, ELEMENT=013208, iostat=error)
5069 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element 13208")
5070 indtmp = indtmp + 1
5071 end if
5072
5073 ! siFG
5074 if (tvs_isInstrumAllskyHuAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
5075 indSiFG = BURP_Find_Element(inputBlock, ELEMENT=siFgElementId)
5076 if (indSiFG < 0) then
5077 call BURP_Resize_Block(inputBlock, ADD_NELE=1, iostat=error)
5078 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Resize_Block info #21")
5079 indSiFG = indtmp + 1
5080 call BURP_Set_Element(inputBlock, NELE_IND=indSiFG, ELEMENT=siFgElementId, iostat=error)
5081 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Set_Element siFG #3")
5082 indtmp = indtmp + 1
5083 end if
5084 end if
5085
5086 do tIndex = 1, nte
5087
5088 if ( goodprof(tIndex) == 1 ) then
5089
5090 if ( obs_headElem_i(obsSpaceData,OBS_IDF,idata2) /= fileIndex) then
5091 headElem_i = obs_headElem_i(obsSpaceData,OBS_IDF,idata2)
5092 write(*,*) "File Inconsistency ", headElem_i, fileIndex
5093 write(*,*) "Should not happen..."
5094 call utl_abort('brpr_addCloudParametersandEmissivity')
5095 end if
5096
5097 ! clwObs
5098 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_CLWO, idata2))
5099 call Insert_into_burp_r4(val_r4, ind13209, 1, tIndex, valueIsMissing=(val_r4<0.0))
5100 ! clwFG
5101 if (tvs_isInstrumAllskyTtAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
5102 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_CLWB, idata2))
5103 call Insert_into_burp_r4(val_r4, indClwFG, 1, tIndex, valueIsMissing=(val_r4<0.0))
5104 end if
5105
5106 ! siObs
5107 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_SIO, idata2))
5108 call Insert_into_burp_r4(val_r4, ind13208, 1, tIndex, &
5109 valueIsMissing=(val_r4==mpc_missingValue_r4))
5110 ! siFG
5111 if (tvs_isInstrumAllskyHuAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
5112 val_r4 = sngl(obs_headElem_r(obsSpaceData, OBS_SIB, idata2))
5113 call Insert_into_burp_r4(val_r4, indSiFG, 1, tIndex, &
5114 valueIsMissing=(val_r4==mpc_missingValue_r4))
5115 end if
5116
5117 val = obs_headElem_i(obsSpaceData, OBS_STYP, idata2)
5118 call Insert_into_burp_i(val, ind008012, 1, tIndex)
5119 val = obs_headElem_i(obsSpaceData, OBS_TTYP, idata2)
5120 call Insert_into_burp_i(val, ind13039, 1, tIndex)
5121 val = obs_headElem_i(obsSpaceData, OBS_INFG, idata2)
5122 call Insert_into_burp_i(val, ind25174, 1, tIndex)
5123 idata2 = idata2 + 1
5124 else
5125 val_r4 = -1.0
5126 call Insert_into_burp_r4(val_r4, ind13209, 1, tIndex, valueIsMissing=.true.)
5127 if (tvs_isInstrumAllskyTtAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
5128 call Insert_into_burp_r4(val_r4, indClwFG, 1, tIndex, valueIsMissing=.true.)
5129 end if
5130
5131 call Insert_into_burp_r4(val_r4, ind13208, 1, tIndex, valueIsMissing=.true.)
5132 if (tvs_isInstrumAllskyHuAssim(tvs_getInstrumentId(codtyp_get_name(idatyp)))) then
5133 call Insert_into_burp_r4(val_r4, indSiFG, 1, tIndex, valueIsMissing=.true.)
5134 end if
5135
5136 call Insert_into_burp_i(-1, ind008012, 1, tIndex)
5137 call Insert_into_burp_i(-1, ind13039, 1, tIndex)
5138 call Insert_into_burp_i(-1, ind25174, 1, tIndex)
5139 end if
5140 end do
5141
5142 end if
5143 end if ! tvs_isIdBurpInst(idatyp,'mwhs2')
5144
5145 ! Add block into new report
5146
5147 if ( btyp == 5120 ) then
5148 call BURP_Write_Block(copyReport, inputBlock, &
5149 ENCODE_BLOCK = .true., &
5150 iostat = error)
5151 else
5152 call BURP_Write_Block(copyReport, inputBlock, &
5153 ENCODE_BLOCK = .true., &
5154 CONVERT_BLOCK = .true., &
5155 iostat = error)
5156 end if
5157 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Write_Block")
5158 end do BLOCKS2
5159
5160 if ( allocated(goodprof) ) then
5161 deallocate (goodprof,btobs)
5162 end if
5163 ! Write new report into file
5164 call BURP_Delete_Report(inputFile, inputReport, iostat=error)
5165 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Delete_Report")
5166 call BURP_Write_Report(inputFile, copyReport, iostat=error)
5167 call handle_error(error, "brpr_addCloudParametersandEmissivity: BURP_Write_Report")
5168 end do REPORTS
5169
5170 deallocate(reportsToUpdate)
5171
5172 if ( tvs_isIdBurpHyperSpectral(idatyp) ) then
5173 if ( flag_passage1 == 0 ) then
5174 write(*,*)
5175 write(*,*) 'ERROR - descriptor block not seen ? Verify btyp'
5176 end if
5177 if ( flag_passage2 == 0 ) then
5178 write(*,*)
5179 write(*,*) 'ERROR - info block not seen ? Verify btyp'
5180 end if
5181 if ( flag_passage3 == 0 ) then
5182 write(*,*)
5183 write(*,*) 'ERROR - observation block not seen ? Verify btyp'
5184 end if
5185 if ( flag_passage4 == 0 ) then
5186 write(*,*)
5187 write(*,*) 'ERROR - flag block not seen ? Verify btyp'
5188 end if
5189 if ( flag_passage5 == 0 ) then
5190 write(*,*)
5191 write(*,*) 'ERROR - O-P block not seen ? Verify btyp'
5192 end if
5193 else if ( (tvs_isIdBurpInst(idatyp,'atms' )) .or. &
5194 (tvs_isIdBurpInst(idatyp,'amsua')) .or. &
5195 (tvs_isIdBurpInst(idatyp,'ssmis')) ) then
5196 if ( flag_passage1 == 0 ) then
5197 write(*,*)
5198 write(*,*) 'ERROR - descriptor block not seen ? Verify btyp'
5199 end if
5200 if ( flag_passage2 == 0 ) then
5201 write(*,*)
5202 write(*,*) 'ERROR - info block not seen ? Verify btyp'
5203 end if
5204 end if
5205
5206 end if !! End of 'if ( count > 0 )'
5207
5208 call cleanup()
5209
5210 contains
5211
5212 !--------- cleanup -----
5213 subroutine cleanup()
5214 implicit none
5215
5216 ! Locals:
5217 integer :: errors(5)
5218
5219 errors(:) = 0
5220 if (allocated(address)) deallocate(address, stat = errors(1))
5221 call BURP_Free(InputFile, iostat=errors(2))
5222 call BURP_Free(InputReport, iostat=errors(3))
5223 call BURP_Free(InputReport, iostat=errors(4))
5224 call BURP_Free(InputBlock, iostat=errors(5))
5225 !Should we abort here ?
5226 if (any(errors /= 0)) write(*,*) "brpr_addCloudParametersandEmissivity: error while deallocating memory: ", errors(:)
5227 end subroutine cleanup
5228
5229 !--------- handle_error -----
5230 subroutine handle_error(icode,errormessage)
5231 implicit none
5232
5233 ! Arguments:
5234 character(len=*), intent(in) :: errormessage
5235 integer, intent(in) :: icode
5236
5237 if ( icode /= burp_noerr ) then
5238 write(*,*) 'error code', icode
5239 write(*,*) BURP_STR_ERROR()
5240 write(*,*) "history"
5241 call BURP_STR_ERROR_HISTORY()
5242 call cleanup()
5243 call utl_abort(trim(errormessage))
5244 end if
5245 end subroutine handle_error
5246
5247 !--------- insert_into_burp_r4 -----
5248 subroutine Insert_into_burp_r4(r4val, pele, pval, pt, valueIsMissing)
5249
5250 implicit none
5251
5252 ! Arguments:
5253 real(4), intent(in) :: r4val
5254 integer, intent(in) :: pele
5255 integer, intent(in) :: pval
5256 integer, intent(in) :: pt
5257 logical, intent(in) :: valueIsMissing
5258
5259 ! Locals:
5260 integer :: error
5261
5262 if (valueIsMissing) then
5263 call BURP_Set_Rval(inputBlock, &
5264 NELE_IND = pele, &
5265 NVAL_IND = pval, &
5266 NT_IND = pt, &
5267 RVAL = valBurpMissing_r4, &
5268 iostat = error)
5269 else
5270 call BURP_Set_Rval(inputBlock, &
5271 NELE_IND = pele, &
5272 NVAL_IND = pval, &
5273 NT_IND = pt, &
5274 RVAL = r4val, &
5275 iostat = error)
5276 end if
5277 if (error/=burp_noerr) then
5278 write(*,*) "Insert_into_burp_r4: r4val,pele,pval,pt,valueIsMissing", r4val, pele, &
5279 pval, pt, valueIsMissing
5280 call handle_error(error, "brpr_addCloudParametersandEmissivity: Insert_into_burp_r4")
5281 end if
5282
5283 end subroutine Insert_into_burp_r4
5284
5285 !--------- insert_into_burp_i -----
5286 subroutine Insert_into_burp_i( ival, pele, pval, pt )
5287 !
5288 implicit none
5289
5290 ! Arguments:
5291 integer, intent(in) :: ival
5292 integer, intent(in) :: pele
5293 integer, intent(in) :: pval
5294 integer, intent(in) :: pt
5295
5296 ! Locals:
5297 integer :: error
5298
5299 if ( ival >= 0 ) then
5300 call BURP_Set_Rval(inputBlock, &
5301 NELE_IND = pele, &
5302 NVAL_IND = pval, &
5303 NT_IND = pt, &
5304 RVAL = real(ival), &
5305 iostat = error)
5306 else
5307 call BURP_Set_Rval(inputBlock, &
5308 NELE_IND = pele, &
5309 NVAL_IND = pval, &
5310 NT_IND = pt, &
5311 RVAL = valBurpMissing_r4, &
5312 iostat = error)
5313 end if
5314
5315 if (error/=burp_noerr) then
5316 write(*,*) "Insert_into_burp_i: ival,pele,pval,pt", ival, pele, pval, pt
5317 call handle_error(error, "brpr_addCloudParametersandEmissivity: Insert_into_burp_i")
5318 end if
5319 end subroutine Insert_into_burp_i
5320
5321 end subroutine brpr_addCloudParametersandEmissivity
5322
5323 !--------------------------------------------------------------------------
5324 ! brpr_updateMissingObsFlags
5325 !--------------------------------------------------------------------------
5326 subroutine brpr_updateMissingObsFlags( burpFile )
5327 !
5328 !:Purpose: Open burp file and set missing data flags to 2048.
5329 !
5330 implicit none
5331
5332 ! Arguments:
5333 character(len=*), intent(in) :: burpFile
5334
5335 ! Locals:
5336 type(BURP_FILE) :: inputFile
5337 type(BURP_RPT) :: inputReport,copyReport
5338 type(BURP_BLOCK) :: inputBlock
5339 integer :: btyp10, btyp, bfam, error
5340 integer :: btyp10obs, btyp10flg
5341 integer :: nb_rpts, ref_rpt, ref_blk, count
5342 integer, allocatable :: address(:)
5343 integer, allocatable :: btobs(:,:)
5344 logical, allocatable :: goodTB(:,:)
5345 integer :: nbele,nvale,nte
5346 integer :: valIndex, tIndex, reportIndex
5347 integer :: ind012163,ind212163
5348 integer :: flag_passage, flagval
5349 character(len=9) :: station_id
5350 !! This is for 'burp_set_options'
5351 character(len=7), parameter :: opt_missing='MISSING'
5352 real, parameter :: val_option = -9999.0
5353
5354 write(*,*) '----------------------------------------------------------'
5355 write(*,*) '-- Begin subroutine brpr_updateMissingObsFlags----'
5356 write(*,*) '----------------------------------------------------------'
5357
5358 ! Initialisation
5359 call burp_set_options( &
5360 real_optname = opt_missing, &
5361 real_optname_value = val_option, &
5362 iostat = error )
5363 call handle_error(error, "brpr_updateMissingObsFlags: burp_set_options")
5364
5365 call burp_init(inputFile,iostat=error)
5366 call handle_error(error, "brpr_updateMissingObsFlags: burp_init inputFile")
5367 call burp_init(inputReport,copyReport)
5368 call burp_init(inputBlock)
5369
5370 ! Opening file
5371 write(*,*) 'OPENED FILE = ', trim(burpFile)
5372
5373 call BURP_New(inputFile, &
5374 FILENAME = burpFile, &
5375 MODE = FILE_ACC_APPEND, &
5376 iostat = error )
5377 call handle_error(error, "brpr_updateMissingObsFlags: BURP_New inputFile")
5378 ! Obtain input burp file number of reports
5379
5380 call BURP_Get_Property(inputFile, NRPTS=nb_rpts)
5381
5382 ! Scan input burp file to get all reports address
5383
5384 allocate(address(nb_rpts))
5385 address(:) = 0
5386 count = 0
5387 ref_rpt = 0
5388
5389 do
5390 ref_rpt = BURP_Find_Report(inputFile, &
5391 report = inputReport, &
5392 SEARCH_FROM = ref_rpt, &
5393 iostat = error)
5394 call handle_error(error, "brpr_updateMissingObsFlags: BURP_Find_Report")
5395 if (ref_rpt < 0) Exit
5396
5397 call BURP_Get_Property(inputReport, STNID=station_id)
5398 if (station_id(1:2)==">>") cycle
5399
5400 count = count + 1
5401 address(count) = ref_rpt
5402 end do
5403
5404 write(*,*)
5405 write(*,*) 'NUMBER OF REPORTS WITH OBSERVATIONS = ',count
5406 write(*,*)
5407
5408 if ( count > 0 ) then
5409
5410 ! Create a new report
5411
5412 call BURP_New(copyReport, ALLOC_SPACE=20000000, iostat=error)
5413 call handle_error(error, "brpr_updateMissingObsFlags: Error creating new directory")
5414
5415 ! Loop on reports
5416
5417 REPORTS: do reportIndex = 1, count
5418
5419 call BURP_Get_Report(inputFile, &
5420 report = inputReport, &
5421 REF = address(reportIndex), &
5422 iostat = error)
5423 call handle_error(error, "brpr_updateMissingObsFlags: BURP_Get_Report")
5424 ! Find bad/missing TB.
5425
5426 ref_blk = 0
5427
5428 BLOCKS1: do
5429
5430 ref_blk = BURP_Find_Block(inputReport, &
5431 BLOCK = inputBlock, &
5432 SEARCH_FROM = ref_blk, &
5433 convert = .false., &
5434 iostat = error)
5435 call handle_error(error, "brpr_updateMissingObsFlags: BURP_Find_Block #1")
5436 if (ref_blk < 0) exit BLOCKS1
5437
5438 call BURP_Get_Property(inputBlock, &
5439 NELE = nbele, &
5440 NVAL = nvale, &
5441 NT = nte, &
5442 BFAM = bfam, &
5443 BTYP = btyp, &
5444 iostat = error)
5445 call handle_error(error, "brpr_updateMissingObsFlags: BURP_Get_Property #1")
5446
5447 ! observation block (btyp = 0100 100011X XXXX)
5448 ! 0100 1000110 0000 = 9312
5449 btyp10 = ishft(btyp,-5)
5450 btyp10obs = 291
5451
5452 if ( btyp10 == btyp10obs .and. bfam == 0 ) then
5453
5454 ind012163 = BURP_Find_Element(inputBlock, ELEMENT=012163)
5455 if ( ind012163 < 0 ) exit BLOCKS1
5456 allocate(btobs( nvale,nte))
5457 allocate(goodTB(nvale,nte))
5458 goodTB(:,:) = .false.
5459 btobs(:,:) = 0
5460 do tIndex=1,nte
5461 do valIndex=1,nvale
5462 btobs(valIndex,tIndex) = BURP_Get_Tblval(inputBlock, &
5463 NELE_IND = ind012163, &
5464 NVAL_IND = valIndex, &
5465 NT_IND = tIndex )
5466 if ( btobs(valIndex,tIndex) /= -1 ) goodTB(valIndex,tIndex) = .true.
5467 end do
5468 end do
5469
5470 end if
5471
5472 end do BLOCKS1
5473
5474 call BURP_copy_Header(TO=copyReport, FROM=inputReport)
5475
5476 call BURP_Init_Report_Write(inputFile, copyReport, iostat=error)
5477 call handle_error(error, "brpr_updateMissingObsFlags: BURP_Init_Report_Write")
5478
5479 ! Second loop on blocks
5480
5481 ! to set missingFlag when not goodTB
5482
5483 ref_blk = 0
5484
5485 BLOCKS2: do
5486
5487 if ( .not. allocated(goodTB) ) then
5488 write(*,*)
5489 write(*,*) 'Resume report is position # ',reportIndex
5490 exit BLOCKS2
5491 end if
5492 ref_blk = BURP_Find_Block(inputReport, &
5493 BLOCK = inputBlock, &
5494 SEARCH_FROM = ref_blk, &
5495 convert = .false., &
5496 iostat = error)
5497 call handle_error(error, "brpr_updateMissingObsFlags: BURP_Find_Block #2")
5498 if (ref_blk < 0) exit BLOCKS2
5499
5500 call BURP_Get_Property(inputBlock, &
5501 NELE = nbele, &
5502 NVAL = nvale, &
5503 NT = nte, &
5504 BFAM = bfam, &
5505 BTYP = btyp, &
5506 iostat = error)
5507 call handle_error(error, "brpr_updateMissingObsFlags: BURP_Get_Property #2")
5508
5509 ! flag block (btyp = 0111 100011X XXXX)
5510 ! 0111 1000110 0000 = 15456
5511 btyp10 = ishft(btyp,-5)
5512 btyp10flg = 483
5513
5514 if ( btyp10 == btyp10flg ) then
5515 flag_passage = 1
5516
5517 ind212163 = BURP_Find_Element(inputBlock, ELEMENT=212163)
5518 if (ind212163 == -1) call handle_error(ind212163, "brpr_updateMissingObsFlags: cannot find element 212163 in inputBlock")
5519
5520 do tIndex = 1, nte
5521 do valIndex = 1, nvale
5522 if ( .not. goodTB(valIndex, tIndex) ) then
5523 flagval = BURP_Get_Tblval(inputBlock, &
5524 NELE_IND = ind212163, &
5525 NVAL_IND = valIndex, &
5526 NT_IND = tIndex, &
5527 iostat = error)
5528 call handle_error(error, "brpr_updateMissingObsFlags: BURP_Get_Tblval pour ind212163")
5529 flagval = ibset(flagval,11)
5530 flagval = ibset(flagval,7)
5531 flagval = ibset(flagval,9)
5532 call BURP_Set_Tblval(inputBlock, &
5533 NELE_IND = ind212163, &
5534 NVAL_IND = valIndex, &
5535 NT_IND = tIndex, &
5536 TBLVAL = flagval, &
5537 iostat = error)
5538 call handle_error(error, "brpr_updateMissingObsFlags: BURP_Set_Tblval pour ind212163")
5539 end if
5540 end do
5541 end do
5542 end if
5543 ! Add block into new report
5544 call BURP_Write_Block(copyReport, inputBlock, &
5545 ENCODE_BLOCK = .false., &
5546 CONVERT_BLOCK = .false., &
5547 iostat = error)
5548 if (error/=burp_noerr) then
5549 write(*,*)"Btyp= ",btyp
5550 call handle_error(error, "brpr_updateMissingObsFlags: BURP_Write_Block")
5551 end if
5552 end do BLOCKS2
5553 if (allocated(goodTB) ) then
5554 deallocate(goodTB)
5555 deallocate(btobs)
5556 end if
5557 ! Write new report into file
5558 call BURP_Delete_Report(inputFile, inputReport, iostat=error)
5559 call handle_error(error, "brpr_updateMissingObsFlags: BURP_Delete_Report")
5560 call BURP_Write_Report(inputFile, copyReport, iostat=error)
5561 call handle_error(error, "brpr_updateMissingObsFlags: BURP_Write_Report")
5562 end do REPORTS
5563 end if !! End of 'if ( count > 0 )'
5564
5565 call cleanup()
5566
5567 contains
5568
5569 !--------- cleanup -----
5570 subroutine cleanup()
5571 implicit none
5572
5573 ! Locals:
5574 integer :: errors(5)
5575
5576 errors(:) = 0
5577 if (allocated(address)) deallocate(address, stat=errors(1))
5578 call BURP_Free(InputFile, iostat=errors(2))
5579 call BURP_Free(InputReport, iostat=errors(3))
5580 call BURP_Free(CopyReport, iostat=errors(4))
5581 call BURP_Free(InputBlock, iostat=errors(5))
5582 !Should we abort here ?
5583 if (any(errors /= 0)) write(*,*) "brpr_updateMissingObsFlags: error while deallocating memory: ", errors(:)
5584 end subroutine cleanup
5585
5586 !--------- handle_error -----
5587 subroutine handle_error(icode,errormessage)
5588 implicit none
5589
5590 ! Arguments:
5591 character(len=*), intent(in) :: errormessage
5592 integer, intent(in) :: icode
5593
5594 if ( icode /= burp_noerr ) then
5595 write(*,*) 'error code', icode
5596 write(*,*) BURP_STR_ERROR()
5597 write(*,*) "history"
5598 call BURP_STR_ERROR_HISTORY()
5599 call cleanup()
5600 call utl_abort(trim(errormessage))
5601 end if
5602 end subroutine handle_error
5603
5604 end subroutine brpr_updateMissingObsFlags
5605
5606
5607 !-----------------------------------------------------------------------
5608 ! brpr_addElementsToBurp
5609 !-----------------------------------------------------------------------
5610 subroutine brpr_addElementsToBurp(inputFileName, familyType, beSilent_opt)
5611 !
5612 !:Purpose: to add element(s) for bias correction to data block of DERIALT BURP file
5613 !
5614 implicit none
5615
5616 ! Arguments:
5617 character(len=*), intent(in) :: inputFileName
5618 character(len=*), intent(in) :: familyType
5619 logical, optional, intent(in) :: beSilent_opt
5620
5621 ! Locals:
5622 type(burp_file) :: inputFile
5623 type(burp_rpt) :: inputReport, copyReport
5624 type(burp_block) :: inputBlock
5625 integer :: nb_rpts, ref_rpt, ref_blk, count
5626 integer, allocatable :: address(:)
5627 integer :: nbele, nvale, nte
5628 integer :: valIndex, tIndex, reportIndex, btyp, idatyp, bfam, error
5629 integer :: ind, indele, nsize, iun_burpin
5630 integer :: nulnam
5631 character(len=9) :: station_id
5632 character(len=7), parameter :: opt_missing='MISSING'
5633 character(len=codtyp_name_length) :: instrumName
5634 integer :: instrumID, previousInstrumID
5635 integer :: icodele(3)
5636 integer :: icodeleMrq(3)
5637 integer :: btClearMrqElementID
5638 real, parameter :: val_option = -9999.0
5639 integer, external :: mrfmxl
5640 logical :: isDerialt
5641 logical :: isInstrumUsingCLW, isInstrumUsingHydrometeors
5642 logical :: beSilent
5643 integer :: nElem, elemIndex, burpIndex
5644
5645 namelist /NAMADDTOBURP/ addBtClearToBurp, clwFgElementId, siFgElementId, btClearElementId
5646
5647 write(*,*) '-----------------------------------------------'
5648 write(*,*) '- begin brpr_addElementsToBurp -'
5649 write(*,*) '-----------------------------------------------'
5650
5651 icodele(:) = 0
5652 icodeleMrq(:) = 0
5653
5654 if ( present(beSilent_opt) ) then
5655 beSilent = beSilent_opt
5656 else
5657 beSilent = .true.
5658 end if
5659
5660 select case(familyType)
5661 case("TO")
5662 nElem = 1
5663 icodele(1) = 12233
5664 case("GP")
5665 nElem = 1
5666 icodele(1) = 15234
5667 case("UA")
5668 nElem = 2
5669 icodele(1:2) = (/12204,12243/)
5670 case default
5671 return
5672 end select
5673
5674 icodeleMrq(1:nElem) = 200000 + icodele(1:nElem)
5675
5676 ! Read the NAMADDTOBURP namelist (if it exists)
5677
5678 addBtClearToBurp = .false.
5679 clwFgElementId = -1
5680 siFgElementId = -1
5681 btClearElementId = -1
5682 btClearMrqElementID = -200001
5683
5684 if ( familyType == "TO" ) then
5685 if (utl_isNamelistPresent('NAMADDTOBURP','./flnml')) then
5686 ! read the namelist
5687 nulnam = 0
5688 error = fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
5689 read(nulnam, nml=NAMADDTOBURP, iostat=error)
5690 if ( error /= 0 ) call utl_abort('brpr_addElementsToBurp: Error reading namelist')
5691 write(*,nml=NAMADDTOBURP)
5692 error = fclos(nulnam)
5693 else
5694 write(*,*)
5695 write(*,*) 'brpr_addElementsToBurp: Namelist block NAMADDTOBURP is missing in the namelist.'
5696 write(*,*) ' The default value will be taken.'
5697 write(*,nml=NAMADDTOBURP)
5698 end if
5699
5700 ! check clear-sky radiance element is in the namelist
5701 if ( addBtClearToBurp .and. btClearElementId < 0 ) then
5702 call utl_abort('brpr_addElementsToBurp: btClearElementId missing in the namelist')
5703 end if
5704
5705 btClearMrqElementID = 200000 + btClearElementId
5706 end if
5707
5708 ! initialisation
5709 ! --------------
5710 call burp_set_options( &
5711 real_optname = opt_missing, &
5712 real_optname_value = val_option, &
5713 iostat = error )
5714 call handle_error(error, "brpr_addElementsToBurp: burp_set_options")
5715
5716 call burp_init(inputFile,iostat=error)
5717 call handle_error(error, "brpr_addElementsToBurp: burp_init inputFile")
5718 call burp_init(inputReport,copyReport)
5719 call burp_init(inputBlock)
5720
5721 ! opening file
5722 ! ------------
5723 write(*,*) 'opened file = ', trim( inputFileName )
5724
5725 call burp_new(inputFile, &
5726 filename = inputFileName, &
5727 mode = file_acc_append, &
5728 iostat = error )
5729
5730 if (error /= burp_noerr) then
5731 write(*,*) "cannot open BURP input file ", inputFileName
5732 call utl_abort('brpr_addElementsToBurp')
5733 end if
5734
5735 ! obtain input burp file number of reports
5736 ! ----------------------------------------
5737 call burp_get_property(inputFile, nrpts=nb_rpts, io_unit= iun_burpin)
5738
5739 nsize = mrfmxl(iun_burpin)
5740 if ( addBtClearToBurp ) then
5741 nsize = 4 * nsize
5742 else
5743 nsize = 3 * nsize
5744 end if
5745
5746 write(*,*) "nsize= ", nsize
5747 write(*,*)
5748 write(*,*) 'number of reports with observations in input file = ', nb_rpts - 1
5749 write(*,*)
5750
5751 ! scan input burp file to get all reports address
5752 ! -----------------------------------------------
5753 allocate(address(nb_rpts))
5754 address(:) = 0
5755 count = 0
5756 ref_rpt = 0
5757 isDerialt = .false.
5758 previousInstrumID = -1
5759 do
5760 ref_rpt = burp_find_report(inputFile, &
5761 report = inputReport, &
5762 search_from = ref_rpt, &
5763 iostat = error)
5764 if (ref_rpt < 0) exit
5765 count = count + 1
5766 address(count) = ref_rpt
5767
5768 call burp_get_property(inputReport, stnid = station_id, idtyp = idatyp )
5769 if (station_id == ">>DERIALT") isDerialt = .true.
5770 if (station_id(1:2) == '>>') cycle
5771
5772 if ( familyType == "TO" ) then
5773 if ( .not. beSilent ) then
5774 if ( count == 1 ) then
5775 write(*,*) 'brpr_addElementsToBurp: tvs_mwAllskyAssim =', tvs_mwAllskyAssim
5776 write(*,*) 'brpr_addElementsToBurp: clwFgElementId =', clwFgElementId
5777 write(*,*) 'brpr_addElementsToBurp: siFgElementId =', siFgElementId
5778 end if
5779
5780 instrumName = codtyp_get_name(idatyp)
5781 instrumID = tvs_getInstrumentId(instrumName)
5782 isInstrumUsingCLW = tvs_isInstrumUsingCLW(tvs_getInstrumentId(instrumName))
5783 isInstrumUsingHydrometeors = tvs_isInstrumUsingHydrometeors(tvs_getInstrumentId(instrumName))
5784 if (instrumID /= previousInstrumID) then
5785 write(*,*) 'brpr_addElementsToBurp: for report count =', count, &
5786 ', instrumentName=', instrumName, &
5787 ', instrumentId =', instrumID, &
5788 ', isInstrumUsingCLW =', isInstrumUsingCLW, &
5789 ', isInstrumUsingHydrometeors =', isInstrumUsingHydrometeors
5790 previousInstrumID = instrumID
5791 end if
5792 end if
5793
5794 ! check clwFG element is in the namelist in all-sky mode.
5795 if (tvs_isInstrumAllskyTtAssim(tvs_getInstrumentId(codtyp_get_name(idatyp))) .and. &
5796 clwFgElementId < 0) then
5797 call utl_abort('brpr_addElementsToBurp: clwFgElementId missing in the namelist')
5798 end if
5799
5800 ! check siFG element is in the namelist in all-sky mode.
5801 if (tvs_isInstrumAllskyHuAssim(tvs_getInstrumentId(codtyp_get_name(idatyp))) .and. &
5802 siFgElementId < 0) then
5803 call utl_abort('brpr_addElementsToBurp: siFgElementId missing in the namelist')
5804 end if
5805 end if
5806
5807 end do
5808
5809 if ( count > 0 .and. isDerialt) then
5810 write(*,*) "brpr_addElementsToBurp: modifying file..."
5811
5812
5813
5814 ! create a new report
5815 ! ------------------
5816 call burp_new(copyReport, alloc_space=nsize, iostat=error)
5817 call handle_error(error, "brpr_addElementsToBurp: burp_new problem allocating copyReport")
5818
5819 ! loop on reports
5820 ! ---------------
5821 reports: do reportIndex = 1, count
5822
5823 call burp_get_report(inputFile, &
5824 report = inputReport, &
5825 ref = address(reportIndex), &
5826 iostat = error)
5827
5828 call burp_copy_header(to=copyReport,from=inputReport)
5829
5830 call burp_get_property(inputReport, stnid = station_id, idtyp = idatyp )
5831
5832 call burp_init_report_write(inputFile, copyReport, iostat=error)
5833 call handle_error(error, "brpr_addElementsToBurp: burp_init_report_write")
5834
5835 call burp_get_property(inputReport, stnid = station_id)
5836
5837 ! loop on blocks
5838 ! --------------------
5839 ref_blk = 0
5840
5841 blocks: do
5842 ! We skip the writing of the block in the resume record
5843 ! because writing it may lead to 'floating point exception'
5844 ! with 'mrbcvt' as called inside 'burp_write_block'.
5845 if (station_id(1:2) == ">>") then
5846 exit blocks
5847 end if
5848
5849 ref_blk = burp_find_block(inputReport, &
5850 block = inputBlock, &
5851 search_from = ref_blk, &
5852 iostat = error)
5853
5854 if (ref_blk < 0) exit blocks
5855
5856 call burp_get_property(inputBlock, &
5857 nele = nbele, &
5858 nval = nvale, &
5859 nt = nte, &
5860 bfam = bfam, &
5861 btyp = btyp, &
5862 iostat = error)
5863 call handle_error(error, "brpr_addElementsToBurp: burp_get_property")
5864
5865 if ( isObsBlock(familyType,btyp) .and. bfam == 0 ) then
5866
5867 do elemIndex = 1, nElem
5868 burpIndex = burp_find_element(inputBlock, element=icodele(elemIndex), iostat=error)
5869 if ( burpIndex <= 0 ) then
5870 nbele = nbele + 1
5871 call burp_resize_block(InputBlock, ADD_NELE = 1, IOSTAT = error)
5872 call handle_error(error, "brpr_addElementsToBurp: burp_resize_block #1")
5873 call burp_set_element(InputBlock, NELE_IND = nbele, ELEMENT = icodele(elemIndex), IOSTAT = error)
5874 call handle_error(error, "brpr_addElementsToBurp: burp_set_element #1")
5875 do valIndex = 1,nvale
5876 do tIndex = 1,nte
5877 call burp_set_rval( inputBlock, &
5878 nele_ind = nbele, &
5879 nval_ind = valIndex, &
5880 nt_ind = tIndex, &
5881 rval = val_option, iostat=error)
5882 call handle_error(error, "brpr_addElementsToBurp: burp_set_rval #1")
5883 end do
5884 end do
5885 end if
5886 end do
5887
5888 ! Adding clear-sky radiance to data block for instrument in all-sky mode.
5889 if (addBtClearToBurp .and. &
5890 (tvs_isInstrumAllskyTtAssim(tvs_getInstrumentId(codtyp_get_name(idatyp))) .or. &
5891 tvs_isInstrumAllskyHuAssim(tvs_getInstrumentId(codtyp_get_name(idatyp))))) then
5892
5893 indele = burp_find_element(inputBlock, element=btClearElementId)
5894
5895 if ( indele <= 0 ) then
5896 nbele = nbele + 1
5897 call burp_resize_block(InputBlock, ADD_NELE = 1, IOSTAT = error)
5898 call handle_error(error, "brpr_addElementsToBurp: burp_resize")
5899 Call burp_set_element(InputBlock, NELE_IND = nbele, ELEMENT = btClearElementId, IOSTAT = error)
5900 call handle_error(error, "brpr_addElementsToBurp: burp_set_element #2")
5901 do valIndex = 1,nvale
5902 do tIndex = 1,nte
5903 call burp_set_Rval( inputBlock, &
5904 nele_ind = nbele, &
5905 nval_ind = valIndex, &
5906 nt_ind = tIndex, &
5907 Rval = MPC_missingValue_R4, iostat=error)
5908 call handle_error(error, "brpr_addElementsToBurp: burp_set_rval #2")
5909 end do
5910 end do
5911 end if
5912
5913 end if
5914
5915 call burp_write_block(copyReport, block = inputBlock, &
5916 convert_block =.true., encode_block=.true., iostat=error)
5917 call handle_error(error, "brpr_addElementsToBurp: burp_write_block #1")
5918
5919 else if ( isFlagBlock(familyType,btyp) .and. bfam == 0 ) then ! MRQ block
5920 do elemIndex = 1, nElem
5921 ind = burp_find_element(inputBlock, element=icodeleMrq(elemIndex), iostat=error)
5922 if ( ind <= 0 ) then
5923 nbele = nbele + 1
5924 call burp_resize_block(InputBlock, ADD_NELE = 1, IOSTAT = error)
5925 call handle_error(error, "brpr_addElementsToBurp: burp_resize_block #2")
5926 Call burp_set_element(InputBlock, NELE_IND = nbele, ELEMENT = icodeleMrq(elemIndex), IOSTAT = error)
5927 call handle_error(error, "brpr_addElementsToBurp: burp_set_element #3")
5928 do valIndex = 1,nvale
5929 do tIndex = 1, nte
5930 call burp_set_tblval( inputBlock, &
5931 nele_ind = nbele, &
5932 nval_ind = valIndex, &
5933 nt_ind = tIndex, &
5934 tblval = 0, iostat=error)
5935 call handle_error(error, "brpr_addElementsToBurp: burp_set_tblval #1")
5936 end do
5937 end do
5938 end if
5939 end do
5940
5941 ! Adding clear-sky radiance to MRQ block for instrument in all-sky mode.
5942 if (addBtClearToBurp .and. &
5943 (tvs_isInstrumAllskyTtAssim(tvs_getInstrumentId(codtyp_get_name(idatyp))) .or. &
5944 tvs_isInstrumAllskyHuAssim(tvs_getInstrumentId(codtyp_get_name(idatyp))))) then
5945
5946 indele = burp_find_element(inputBlock, element=btClearMrqElementID)
5947 if ( indele <= 0 ) then
5948 nbele = nbele + 1
5949 call burp_resize_block(InputBlock, ADD_NELE = 1, IOSTAT = error)
5950 call handle_error(error, "brpr_addElementsToBurp: burp_resize_block #3")
5951 Call burp_set_element(InputBlock, NELE_IND = nbele, ELEMENT = btClearMrqElementID, IOSTAT = error)
5952 call handle_error(error, "brpr_addElementsToBurp: burp_set_element #4")
5953 do valIndex = 1,nvale
5954 do tIndex = 1, nte
5955 call burp_set_tblval( inputBlock, &
5956 nele_ind = nbele, &
5957 nval_ind = valIndex, &
5958 nt_ind = tIndex, &
5959 tblval = 0, iostat=error)
5960 call handle_error(error, "brpr_addElementsToBurp: burp_set_tblval #2")
5961 end do
5962 end do
5963 end if
5964
5965 end if
5966
5967 call burp_write_block(copyReport, block = inputBlock, &
5968 convert_block =.false., encode_block=.true.,iostat=error)
5969 call handle_error(error, "brpr_addElementsToBurp: burp_write_block #2")
5970
5971 else !other blocks
5972
5973 call burp_write_block(copyReport, block = inputBlock, &
5974 convert_block = ( btyp /= 5120 .and. btyp /= 2080), iostat=error)
5975 call handle_error(error, "brpr_addElementsToBurp: burp_write_block #3")
5976
5977 end if
5978
5979 end do blocks
5980
5981 ! write new report into file
5982 ! --------------------------
5983 call BURP_Delete_Report(inputFile, inputReport, iostat=error)
5984 call handle_error(error, "brpr_addElementsToBurp: burp_delete_report")
5985 call burp_write_report(inputFile,copyReport, iostat=error)
5986 call handle_error(error, "brpr_addElementsToBurp: burp_write_report")
5987
5988 end do reports
5989
5990 end if
5991
5992 call cleanup()
5993
5994 write(*,*) '---------------------------------------------'
5995 write(*,*) '- end brpr_addElementsToBurp -'
5996 write(*,*) '---------------------------------------------'
5997
5998 contains
5999
6000 !-------- cleanup -----
6001 subroutine cleanup()
6002 implicit none
6003
6004 ! Locals:
6005 integer :: errors(5)
6006
6007 errors(:) = 0
6008 if (allocated(address)) deallocate(address, stat=errors(1))
6009 call burp_free(inputFile, iostat=errors(2))
6010 call burp_free(inputReport, iostat=errors(3))
6011 call burp_free(copyReport, iostat=errors(4))
6012 call burp_free(inputBlock, iostat=errors(5))
6013 !Should we abort here ?
6014 if (any(errors /= 0)) write(*,*) "brpr_addElementsToBurp: error while deallocating memory: ", errors(:)
6015 end subroutine cleanup
6016
6017 !-------- handle_error -----
6018 subroutine handle_error(icode, errorMessage)
6019 implicit none
6020
6021 ! Arguments:
6022 character(len=*), intent(in) :: errorMessage
6023 integer, intent(in) :: icode
6024
6025 if ( icode /= burp_noerr ) then
6026 write(*,*) 'error code', icode
6027 write(*,*) BURP_STR_ERROR()
6028 write(*,*) "history"
6029 call BURP_STR_ERROR_HISTORY()
6030 call cleanup()
6031 call utl_abort(trim(errorMessage))
6032 end if
6033 end subroutine handle_error
6034
6035 end subroutine brpr_addElementsToBurp
6036
6037 !-----------------------------------------------------------------------
6038 ! brpr_burpClean
6039 !-----------------------------------------------------------------------
6040 subroutine brpr_burpClean(inputFileName, familyType)
6041 !
6042 !:Purpose: to remove observations that are flagged not to be assimilated
6043 !
6044 implicit none
6045
6046 ! Arguments:
6047 character(len=*), intent(in) :: inputFileName
6048 character(len=*), intent(in) :: familyType
6049
6050 ! Locals:
6051 type(burp_file) :: inputFile
6052 type(burp_rpt) :: inputReport, copyReport
6053 type(burp_block) :: inputBlock, inputBlock2
6054 integer, allocatable :: addresses(:), elementIdsRead(:), elementIdsBlock(:)
6055 integer, allocatable :: flagValues(:,:,:)
6056 real(4), allocatable :: obsValues(:,:,:)
6057 logical, allocatable :: rejectObs(:,:)
6058 integer :: numReports, refBlock, intBurpValue
6059 integer :: numElem, numLevels, numObsProfiles, numElem2
6060 integer :: numLevels2, newNumLevels
6061 integer :: numObsProfiles2, newNumObsProfiles
6062 integer :: elemIndex, levelIndex, levelIndexGood
6063 integer :: obsProfIndex, obsProfIndexGood
6064 integer :: reportIndex, btyp, datyp, error
6065 integer :: nsize, iun_burpin, numReject, numRejectTotal
6066 character(len=7), parameter :: opt_missing='MISSING'
6067 real, parameter :: missingValue = -9999.0
6068 integer, external :: mrfbfl
6069 logical :: groupedData, foundFlags, foundObs, emptyReport
6070 logical :: resumeReport, cleanLevels, checkBlock
6071 character(len=2) :: familyTypesToDo(7) = (/'AI','SW','TO','SC','GP','UA','SF'/)
6072 character(len=9) :: stnid
6073 logical :: debug = .false.
6074
6075 write(*,*)
6076 write(*,*) 'brpr_burpClean: starting'
6077
6078 ! only apply for certain obs families for now
6079 if ( all( trim(familyType) /= familyTypesToDo(:) ) ) then
6080 write(*,*) 'brpr_burpClean: not applied to obs family = ', trim(familyType)
6081 return
6082 end if
6083
6084 ! for some obs types we will remove levels/channels, not just complete profiles
6085 cleanLevels = (trim(familyType) == 'UA')
6086
6087 ! obtain input burp file report addresses and number of reports
6088 call getBurpReportAddresses(inputFileName, addresses)
6089 numReports = size(addresses)
6090
6091 ! initialisation
6092 call burp_set_options( &
6093 real_optname = opt_missing, &
6094 real_optname_value = missingValue, &
6095 iostat = error )
6096 call handle_error(error, "brpr_burpClean: burp_set_options")
6097
6098 ! initialize burp objects
6099 call burp_init(inputFile,iostat=error)
6100 call handle_error(error, "brpr_burpClean: burp_init inputFile")
6101 call burp_init(inputReport)
6102 call burp_init(copyReport)
6103 call burp_init(inputBlock)
6104 call burp_init(inputBlock2)
6105
6106 ! opening file
6107 write(*,*) 'brpr_burpClean: opening burp file = ', trim(inputFileName), ', ', trim(familyType)
6108
6109 call burp_new(inputFile, &
6110 filename = inputFileName, &
6111 mode = file_acc_append, &
6112 iostat = error )
6113 call handle_error(error, "brpr_burpClean: problem opening BURP input file " // trim(inputFileName))
6114
6115 call burp_get_property(inputFile, nrpts=numReports, io_unit= iun_burpin)
6116 nsize = mrfbfl(iun_burpin)
6117 if (debug) write(*,*) 'nsize= ', nsize
6118
6119 ! determine if file contains grouped data
6120 groupedData = isGroupedData(inputFile, addresses)
6121 write(*,*) 'brpr_burpClean: Grouped data = ', groupedData
6122
6123 ! get list of element ids used for checking flags
6124 call getElementIdsRead(familyType, elementIdsRead)
6125
6126 ! ignore some elements when checking the flags
6127 do elemIndex = 1, size(elementIdsRead)
6128 if ( (elementIdsRead(elemIndex) == 10194) ) then
6129 elementIdsRead(elemIndex) = -1
6130 end if
6131 end do
6132 write(*,*) 'brpr_burpClean: Flags checked for these element IDs: ', elementIdsRead(:)
6133
6134 numRejectTotal = 0 ! summed over entire file
6135
6136 ! loop on reports
6137 reports: do reportIndex = 1, numReports
6138
6139 numReject = 0
6140
6141 call burp_get_report(inputFile, &
6142 report = inputReport, &
6143 ref = addresses(reportIndex), &
6144 iostat = error)
6145 call handle_error(error, "brpr_burpClean: burp_get_report")
6146
6147 call burp_get_property(inputReport, stnid=stnid)
6148 resumeReport = (stnid(1:2) == ">>")
6149
6150 ! create and initialize a new report
6151 if (reportIndex == 1) then
6152 call burp_new(copyReport, alloc_space=nsize, iostat=error)
6153 call handle_error(error, "brpr_burpClean: burp_new copyReport creation")
6154 end if
6155 call burp_copy_header(to=copyReport, from=inputReport)
6156 call burp_init_report_write(inputFile, copyReport, iostat=error)
6157 call handle_error(error, "brpr_burpClean: burp_init_report_write inputFile copyReport")
6158
6159 ! get the flags block, check if obs missing, and list of element IDs
6160 foundFlags = .false.
6161 foundObs = .false.
6162 refBlock = 0
6163 blocks: do
6164
6165 refBlock = burp_find_block(inputReport, &
6166 block = inputBlock, &
6167 search_from = refBlock, &
6168 iostat = error)
6169 call handle_error(error, "brpr_burpClean: burp_find_block #1")
6170 if (refBlock < 0) exit blocks
6171
6172 call burp_get_property(inputBlock, &
6173 nele = numElem, &
6174 nval = numLevels, &
6175 nt = numObsProfiles, &
6176 btyp = btyp, &
6177 iostat = error)
6178 call handle_error(error, "brpr_burpClean: burp_get_property #1")
6179
6180 ! only check "multi" blocks when cleanLevels is true
6181 if (cleanLevels) then
6182 checkBlock = btest(btyp,13)
6183 else
6184 checkBlock = .true.
6185 end if
6186
6187 if (isFlagBlock(familyType, btyp) .and. checkBlock) then
6188 foundFlags = .true.
6189 if (debug) write(*,*) 'Found a block with flags: ', reportIndex, familyType, btyp
6190 if (debug) write(*,*) 'numObsProfiles, numLevels, numElem = ', numObsProfiles, numLevels, numElem
6191 if (allocated(flagValues)) deallocate(flagValues)
6192 allocate(flagValues(numElem,numLevels,numObsProfiles))
6193 if (allocated(elementIdsBlock)) deallocate(elementIdsBlock)
6194 allocate(elementIdsBlock(numElem))
6195 do elemIndex = 1, numElem
6196 elementIdsBlock(elemIndex) = burp_get_element(inputBlock, index=elemIndex)
6197 do obsProfIndex = 1, numObsProfiles
6198 do levelIndex = 1, numLevels
6199 flagValues(elemIndex,levelIndex,obsProfIndex) = burp_get_tblval(inputBlock, &
6200 nele_ind=elemIndex, nval_ind=levelIndex, nt_ind=obsProfIndex)
6201 end do
6202 end do
6203 end do
6204 end if
6205
6206 if (isObsBlock(familyType, btyp) .and. checkBlock) then
6207 foundObs = .true.
6208 if (debug) write(*,*) 'Found a block with obs: ', reportIndex, familyType, btyp
6209 if (debug) write(*,*) 'numObsProfiles, numLevels, numElem = ', numObsProfiles, numLevels, numElem
6210 if (allocated(obsValues)) deallocate(obsValues)
6211 allocate(obsValues(numElem,numLevels,numObsProfiles))
6212 do elemIndex = 1, numElem
6213 do obsProfIndex = 1, numObsProfiles
6214 do levelIndex = 1, numLevels
6215 obsValues(elemIndex,levelIndex,obsProfIndex) = burp_get_rval(inputBlock, &
6216 nele_ind=elemIndex, nval_ind=levelIndex, nt_ind=obsProfIndex)
6217 end do
6218 end do
6219 end do
6220 end if
6221
6222 if (foundFlags .and. foundObs) exit blocks
6223
6224 end do blocks
6225
6226 if (.not.foundFlags .or. .not.foundObs) then
6227
6228 if (debug) write(*,*) 'No flag or obs block found for this report ', reportIndex
6229
6230 else
6231
6232 if (debug) write(*,*) 'numObsProfiles, numLevels, numElem = ', numObsProfiles, numLevels, numElem
6233 ! determine which observations to keep
6234 if (allocated(rejectObs)) deallocate(rejectObs)
6235 allocate(rejectObs(numLevels,numObsProfiles))
6236 rejectObs(:,:) = .true.
6237 obsProfiles: do obsProfIndex = 1, numObsProfiles
6238 obsLevels: do levelIndex = 1, numLevels
6239 elements: do elemIndex = 1, numElem
6240 ! skip this element if it is not normally read
6241 if ( all(elementIdsBlock(elemIndex) /= (200000 + elementIdsRead(:))) ) cycle elements
6242
6243 ! if at least one element in profile is 'good', then cannot reject
6244 if ( (.not.btest(flagValues(elemIndex,levelIndex,obsProfIndex),11)) .and. &
6245 (obsValues(elemIndex,levelIndex,obsProfIndex) /= missingValue) ) then
6246 if (debug) write(*,*) 'found a GOOD observation: ', levelIndex, obsProfIndex, &
6247 elementIdsBlock(elemIndex), flagValues(elemIndex,levelIndex,obsProfIndex), &
6248 obsValues(elemIndex,levelIndex,obsProfIndex)
6249 rejectObs(levelIndex,obsProfIndex) = .false.
6250 else if (obsValues(elemIndex,levelIndex,obsProfIndex) == missingValue) then
6251 if (debug) write(*,*) 'found a MISSING observation: ', levelIndex, obsProfIndex, &
6252 elementIdsBlock(elemIndex), flagValues(elemIndex,levelIndex,obsProfIndex), &
6253 obsValues(elemIndex,levelIndex,obsProfIndex)
6254 else if (btest(flagValues(elemIndex,levelIndex,obsProfIndex),11)) then
6255 if (debug) write(*,*) 'found a BAD observation: ', levelIndex, obsProfIndex, &
6256 elementIdsBlock(elemIndex), flagValues(elemIndex,levelIndex,obsProfIndex), &
6257 obsValues(elemIndex,levelIndex,obsProfIndex)
6258 end if
6259
6260 end do elements
6261 if (cleanLevels) then
6262 ! count number of individual rejected levels
6263 if (rejectObs(levelIndex,obsProfIndex)) numReject = numReject + 1
6264 end if
6265 end do obsLevels
6266 if (debug) write(*,*) 'rejectObs = ',obsProfIndex,rejectObs(1,obsProfIndex)
6267 if (.not. cleanLevels) then
6268 ! count number of rejected complete profiles (all levels must be rejected)
6269 if (all(rejectObs(:,obsProfIndex))) numReject = numReject + 1
6270 end if
6271 end do obsProfiles
6272
6273 numRejectTotal = numRejectTotal + numReject
6274
6275 end if
6276
6277 ! copy reduced blocks output report
6278 emptyReport = .false.
6279 refBlock = 0
6280 blocks2: do
6281
6282 refBlock = burp_find_block(inputReport, &
6283 block = inputBlock2, &
6284 search_from = refBlock, &
6285 convert = .false., &
6286 iostat = error)
6287 call handle_error(error, "brpr_burpClean: burp_find_block #2")
6288 if (refBlock < 0) exit blocks2
6289
6290 call burp_get_property(inputBlock2, &
6291 nele = numElem2, &
6292 nval = numLevels2, &
6293 nt = numObsProfiles2, &
6294 btyp = btyp, &
6295 datyp = datyp, &
6296 iostat = error)
6297 call handle_error(error, "brpr_burpClean: burp_get_property #2")
6298
6299 ! only modify "multi" blocks when cleanLevels is true
6300 if (cleanLevels) then
6301 checkBlock = btest(btyp,13)
6302 else
6303 checkBlock = .true.
6304 end if
6305
6306 if (checkBlock) then
6307
6308 if (debug) write(*,*) 'btyp, datyp = ', btyp, datyp
6309 if (cleanLevels) then
6310 newNumLevels = numLevels2 - numReject
6311 if (debug) write(*,*) 'ReportIndex = ', reportIndex
6312 if (debug) write(*,*) 'Reducing the number of levels from ', numLevels2, ' to ', newNumLevels
6313
6314 if (newNumLevels >= 1) then
6315
6316 ! shuffle the data
6317 do obsProfIndex = 1, numObsProfiles2
6318 levelIndexGood = 0
6319 do levelIndex = 1, numLevels2
6320 if (rejectObs(levelIndex,obsProfIndex)) cycle
6321 levelIndexGood = levelIndexGood + 1
6322 do elemIndex = 1, numElem2
6323 intBurpValue = burp_get_tblval(inputBlock2, nele_ind=elemIndex, &
6324 nval_ind=levelIndex, nt_ind=obsProfIndex, iostat=error)
6325 call handle_error(error, "brpr_burpClean: burp_get_tblval")
6326 call burp_set_tblval(inputBlock2, nele_ind=elemIndex, &
6327 nval_ind=levelIndexGood, nt_ind=obsProfIndex, tblval=intBurpValue, iostat=error)
6328 call handle_error(error, "brpr_burpClean: burp_set_tblval")
6329 if (debug .and. levelIndex /= levelIndexGood) then
6330 write(*,*) 'shuffling data: ', elemIndex, levelIndex, levelIndexGood, intBurpValue, reportIndex
6331 end if
6332 end do
6333 end do
6334 end do
6335
6336 ! reduce the size of the block
6337 call burp_reduce_block(inputBlock2, new_nval=newNumLevels, iostat=error)
6338 call handle_error(error, "brpr_burpClean: burp_reduce_block")
6339
6340 else ! newNumLevels < 1
6341
6342 if (debug) write(*,*) 'All observation levels rejected for this report: ', reportIndex
6343 emptyReport = .true.
6344
6345 end if
6346
6347 else
6348
6349 newNumObsProfiles = numObsProfiles2 - numReject
6350 if (debug) write(*,*) 'ReportIndex = ', reportIndex
6351 if (debug) write(*,*) 'Reducing the number of observation profiles from ', numObsProfiles2, ' to ', newNumObsProfiles
6352
6353 if (newNumObsProfiles >= 1) then
6354
6355 ! shuffle the data
6356 obsProfIndexGood = 0
6357 do obsProfIndex = 1, numObsProfiles2
6358 if (all(rejectObs(:,obsProfIndex))) cycle ! all levels rejected
6359 obsProfIndexGood = obsProfIndexGood + 1
6360 do elemIndex = 1, numElem2
6361 do levelIndex = 1, numLevels2
6362 intBurpValue = burp_get_tblval(inputBlock2, nele_ind=elemIndex, &
6363 nval_ind=levelIndex, nt_ind=obsProfIndex, iostat=error)
6364 call handle_error(error, "brpr_burpClean: burp_get_tblval #2")
6365 call burp_set_tblval(inputBlock2, nele_ind=elemIndex, &
6366 nval_ind=levelIndex, nt_ind=obsProfIndexGood, tblval=intBurpValue, iostat=error)
6367 call handle_error(error, "brpr_burpClean: burp_set_tblval #2")
6368 if (debug .and. obsProfIndex /= obsProfIndexGood) then
6369 write(*,*) 'shuffling data: ', obsProfIndex, obsProfIndexGood, intBurpValue, reportIndex
6370 end if
6371 end do
6372 end do
6373 end do
6374
6375 ! reduce the size of the block
6376 call burp_reduce_block(inputBlock2, new_nt=newNumObsProfiles, iostat=error)
6377 call handle_error(error, "brpr_burpClean: burp_reduce_block #2")
6378
6379 else ! newNumObsProfiles < 1
6380
6381 if (debug) write(*,*) 'All observation profiles rejected for this report: ', reportIndex
6382 emptyReport = .true.
6383
6384 end if
6385
6386 end if ! cleanLevels
6387
6388 end if ! checkBlock
6389
6390 if (.not. emptyReport) then
6391 call burp_write_block(copyReport, block=inputBlock2, &
6392 convert_block=.false., iostat=error)
6393 call handle_error(error, "brpr_burpClean: burp_write_block")
6394 end if
6395
6396 end do blocks2
6397
6398 ! delete existing report and write new report into file
6399 call burp_delete_report(inputFile, inputReport, iostat=error)
6400 call handle_error(error, "brpr_burpClean: burp_delete_report")
6401 if (.not. emptyReport) then
6402 ! for grouped data modify "elev" to new number of obs profiles
6403 if (groupedData .and. .not.resumeReport) then
6404 call burp_set_property(copyReport, &
6405 elev=newNumObsProfiles, &
6406 iostat=error)
6407 call handle_error(error, "brpr_burpClean: burp_set_property")
6408 end if
6409 call burp_write_report(inputFile, copyReport, iostat=error)
6410 call handle_error(error, "brpr_burpClean: burp_write_report")
6411 end if
6412
6413 end do reports
6414
6415 write(*,*) 'brpr_burpClean: finished - total number of obs profiles cleaned:', numRejectTotal
6416 write(*,*)
6417
6418 call cleanup()
6419
6420 contains
6421
6422 !-------- cleanup -----
6423 subroutine cleanup()
6424 implicit none
6425
6426 ! Locals:
6427 integer :: errors(11)
6428
6429 errors(:) = 0
6430 if (allocated(addresses)) deallocate(addresses, stat=errors(1))
6431 if (allocated(obsValues)) deallocate(obsValues, stat=errors(2))
6432 if (allocated(flagValues)) deallocate(flagValues, stat=errors(3))
6433 if (allocated(rejectObs)) deallocate(rejectObs, stat=errors(4))
6434 if (allocated(elementIdsBlock)) deallocate(elementIdsBlock, stat=errors(5))
6435 if (allocated(elementIdsRead)) deallocate(elementIdsRead, stat=errors(6))
6436 call burp_free(inputFile, iostat=errors(7))
6437 call burp_free(inputReport, iostat=errors(8))
6438 call burp_free(copyReport, iostat=errors(9))
6439 call burp_free(inputBlock, iostat=errors(10))
6440 call burp_free(inputBlock2, iostat=errors(11))
6441 !Should we abort here ?
6442 if (any(errors /= 0)) write(*,*) "brpr_burpClean: error while deallocating memory: ", errors(:)
6443 end subroutine cleanup
6444
6445 !-------- handle_error -----
6446 subroutine handle_error(icode, errorMessage)
6447 implicit none
6448
6449 ! Arguments:
6450 character(len=*), intent(in) :: errorMessage
6451 integer, intent(in) :: icode
6452
6453 if ( icode /= burp_noerr ) then
6454 write(*,*) 'error code', icode
6455 write(*,*) BURP_STR_ERROR()
6456 write(*,*) "history"
6457 call BURP_STR_ERROR_HISTORY()
6458 call cleanup()
6459 call utl_abort(trim(errorMessage))
6460 end if
6461 end subroutine handle_error
6462
6463 end subroutine brpr_burpClean
6464
6465
6466 subroutine getBurpReportAddresses(fileName, addresses)
6467 !
6468 !:Purpose: Initial scan of file to get number of reports. Store address
6469 ! of each report in array addresses(numReports).
6470 !
6471 implicit none
6472
6473 ! Arguments:
6474 character(len=*), intent(in) :: fileName
6475 integer, allocatable, intent(inout) :: addresses(:)
6476
6477 ! Locals:
6478 type(burp_file) :: burpFile
6479 type(BURP_RPT) :: report
6480 integer :: numReports, refReport, error
6481
6482 ! initialisation
6483 call burp_init(burpFile, iostat=error)
6484 call handle_error(error, "getBurpReportAddresses: burp_init inputfile")
6485 call burp_init(report)
6486
6487 ! ouverture du fichier burp
6488 call burp_new(burpFile, filename=fileName, mode=file_acc_read, iostat=error)
6489 call handle_error(error, "getBurpReportAddresses: problem opening " // trim(fileName) )
6490
6491 ! number of reports and maximum report size from BURP file
6492 call burp_get_property(burpFile, nrpts=numReports)
6493 if (numReports <= 1) then
6494 write(*,*) 'getBurpReportAddresses: BURP file ', trim(fileName)
6495 write(*,*) 'getBurpReportAddresses: WARNING: no observations in file'
6496 end if
6497 write(*,*)
6498 write(*,*) 'getBurpReportAddresses: Total number of reports = ', numReports
6499 write(*,*)
6500
6501 if (allocated(addresses)) deallocate(addresses)
6502 allocate(addresses(numReports))
6503
6504 addresses(:) = 0
6505 refReport = 0
6506 numReports = 0
6507 do
6508 refReport = burp_find_report(burpFile, report=report, search_from=refReport, iostat=error)
6509 call handle_error(error, "getBurpReportAddresses: burp_find_report error finding next burp report")
6510 if (refReport < 0) exit
6511 numReports = numReports+1
6512 addresses(numReports) = refReport
6513 end do
6514
6515 call cleanup()
6516
6517 contains
6518
6519 !-------- cleanup -----
6520 subroutine cleanup()
6521 implicit none
6522
6523 ! Locals:
6524 integer :: errors(2)
6525
6526 errors(:) = 0
6527 call burp_free(report, iostat=errors(1))
6528 call burp_free(burpFile, iostat=errors(2))
6529 !Should we abort here ?
6530 if (any(errors /= 0)) write(*,*) "getBurpReportAddresses: error while deallocating memory: ", errors(:)
6531 end subroutine cleanup
6532
6533 !-------- handle_error -----
6534 subroutine handle_error(icode, errorMessage)
6535 implicit none
6536
6537 ! Arguments:
6538 character(len=*), intent(in) :: errorMessage
6539 integer, intent(in) :: icode
6540
6541 if ( icode /= burp_noerr ) then
6542 write(*,*) 'error code', icode
6543 write(*,*) BURP_STR_ERROR()
6544 write(*,*) "history"
6545 call BURP_STR_ERROR_HISTORY()
6546 call cleanup()
6547 call utl_abort(trim(errorMessage))
6548 end if
6549 end subroutine handle_error
6550
6551 end subroutine getBurpReportAddresses
6552
6553
6554 function isGroupedData(burpFile,address) result(isGrouped)
6555 implicit none
6556
6557 ! Arguments:
6558 type(burp_file), intent(inout) :: burpFile
6559 integer, intent(in) :: address(:)
6560 ! Result:
6561 logical :: isGrouped
6562
6563 ! Locals:
6564 type(burp_rpt) :: report
6565 type(burp_block) :: block
6566 integer :: reportIndex, refBlock, btyp, btyp10, error
6567
6568 call burp_init(report)
6569 call burp_init(block)
6570
6571 ! determine if this file contains grouped data
6572 isGrouped = .false.
6573 reports: do reportIndex = 1, size(address)
6574
6575 call burp_get_report(burpFile, &
6576 report = report, &
6577 ref = address(reportIndex), &
6578 iostat = error)
6579 call handle_error(error, "isGroupedData: burp_get_report error getting next burp report")
6580 ! loop on blocks
6581 refBlock = 0
6582 blocks: do
6583
6584 refBlock = burp_find_block(report, &
6585 block = block, &
6586 search_from = refBlock, &
6587 iostat = error)
6588 call handle_error(error, "isGroupedData: burp_find_block error finding next burp block")
6589 if (refBlock < 0) exit blocks
6590
6591 call burp_get_property(block, btyp=btyp)
6592 btyp10 = ishft(btyp,-5)
6593 if ( btyp10 == 160 ) then
6594 isGrouped = .true.
6595 exit reports
6596 end if
6597
6598 end do blocks
6599
6600 end do reports
6601
6602 call cleanup()
6603
6604 contains
6605
6606 !-------- cleanup -----
6607 subroutine cleanup()
6608 implicit none
6609
6610 ! Locals:
6611 integer :: errors(2)
6612
6613 errors(:) = 0
6614 call burp_free(report, iostat=errors(1))
6615 call burp_free(block, iostat=errors(2))
6616 !Should we abort here ?
6617 if (any(errors /= 0)) write(*,*) "isGroupedData: error while deallocating memory: ", errors(:)
6618 end subroutine cleanup
6619
6620 !-------- handle_error -----
6621 subroutine handle_error(icode, errorMessage)
6622 implicit none
6623
6624 ! Arguments:
6625 character(len=*), intent(in) :: errorMessage
6626 integer, intent(in) :: icode
6627
6628 if ( icode /= burp_noerr ) then
6629 write(*,*) 'error code', icode
6630 write(*,*) BURP_STR_ERROR()
6631 write(*,*) "history"
6632 call BURP_STR_ERROR_HISTORY()
6633 call cleanup()
6634 call utl_abort(trim(errorMessage))
6635 end if
6636 end subroutine handle_error
6637
6638 end function isGroupedData
6639
6640
6641 function isFlagBlock(familyType, btyp) result(isFlag)
6642 implicit none
6643
6644 ! Arguments:
6645 character(len=*), intent(in) :: familyType
6646 integer, intent(in) :: btyp
6647 ! Result:
6648 logical :: isFlag
6649
6650 ! Locals:
6651 integer :: btyp10, btyp10flg, offset
6652
6653 isFlag = .false.
6654
6655 btyp10 = ishft(btyp,-5)
6656 btyp10flg = 483
6657
6658 if (trim(familyType)=='UA') then
6659 offset = 288
6660 isFlag = (btyp10 == btyp10flg .or. btyp10 == btyp10flg-offset)
6661 if ( .not.isFlag ) then
6662 isFlag = (btyp10 == btyp10flg-2 .or. btyp10 == btyp10flg-offset-2)
6663 end if
6664 else
6665 select case(trim(familyType))
6666 case('AI','SW','SC')
6667 offset = 256
6668 case('RO','TO')
6669 offset = 0
6670 case('SF','GP')
6671 offset = 288
6672 end select
6673 isFlag = (btyp10 == btyp10flg-offset .or. btyp10 == btyp10flg-offset-2)
6674 end if
6675
6676 end function isFlagBlock
6677
6678
6679 function isObsBlock(familyType, btyp) result(isObs)
6680 implicit none
6681
6682 ! Arguments:
6683 character(len=*), intent(in) :: familyType
6684 integer, intent(in) :: btyp
6685 ! Result:
6686 logical :: isObs
6687
6688 ! Locals:
6689 integer :: btyp10, btyp10obs, offset
6690
6691 isObs = .false.
6692
6693 btyp10 = ishft(btyp,-5)
6694 btyp10obs = 291
6695
6696 if (trim(familyType)=='UA') then
6697 offset = 288
6698 isObs = (btyp10 == btyp10obs .or. btyp10 + offset == btyp10obs)
6699 if ( .not.isObs ) then
6700 isObs = (btyp10 == btyp10obs-2 .or. btyp10 == btyp10obs-offset-2)
6701 end if
6702 else
6703 select case(trim(familyType))
6704 case('AI','SW','SC')
6705 offset = 256
6706 case('RO','TO')
6707 offset = 0
6708 case('SF','GP')
6709 offset = 288
6710 end select
6711 isObs = (btyp10 == btyp10obs-offset .or. btyp10 == btyp10obs-offset-2)
6712 end if
6713
6714 end function isObsBlock
6715
6716
6717 subroutine getElementIdsRead(familyType, elementIds)
6718 implicit none
6719
6720 ! Arguments:
6721 character(len=*), intent(in) :: familyType
6722 integer, allocatable, intent(out) :: elementIds(:)
6723
6724 ! Locals:
6725 integer :: elementIndex, elementCount
6726
6727 if (allocated(elementIds)) deallocate(elementIds)
6728
6729 select case(trim(familyType))
6730
6731 case('UA','AI','AL','SW','PR','RO')
6732 call brpacma_nml('namburp_filter_conv', beSilent_opt=.true.)
6733 allocate(elementIds(nelems))
6734 elementIds(:) = blistelements(1:nelems)
6735
6736 case('SF','SC')
6737 call brpacma_nml('namburp_filter_sfc', beSilent_opt=.true.)
6738 allocate(elementIds(nelems_sfc))
6739 elementIds(:) = blistelements_sfc(1:nelems_sfc)
6740
6741 case('GP')
6742 call brpacma_nml('namburp_filter_gp', beSilent_opt=.true.)
6743 ! do not include "formal error", since it was removed from obsSpaceData
6744 if (any(liste_ele_gps(1:nelems_gps) == bufr_nefe)) then
6745 allocate(elementIds(nelems_gps-1))
6746 elementCount = 0
6747 do elementIndex = 1, nelems_gps
6748 if (liste_ele_gps(elementIndex) /= bufr_nefe) then
6749 elementCount = elementCount + 1
6750 elementIds(elementCount) = liste_ele_gps(elementIndex)
6751 end if
6752 end do
6753 else
6754 allocate(elementIds(nelems_gps))
6755 elementIds(:) = liste_ele_gps(1:nelems_gps)
6756 end if
6757
6758 case('TO')
6759 call brpacma_nml('namburp_filter_tovs', beSilent_opt=.true.)
6760 allocate(elementIds(nelems))
6761 elementIds(:) = blistelements(1:nelems)
6762
6763 case default
6764 call utl_abort('getElementIdsRead: unknown familyType: ' // trim(familyType))
6765
6766 end select
6767
6768 end subroutine getElementIdsRead
6769
6770end module burpRead_mod
