1module obsUtil_mod
2 ! MODULE obsUtil_mod (prefix='obsu' category='3. Observation input/output')
3 !
4 !:Purpose: Common routines used by burpfiles_mod and sqlitefiles_mod
5 !
6 use obsSpaceData_mod
7 use bufr_mod
8 use mathPhysConstants_mod
9 use codePrecision_mod
10 use codtyp_mod
11 use obsVariableTransforms_mod
12 use utilities_mod
13
14 implicit none
15 save
16 private
17 public :: obsu_setassflg, obsu_updateSourceVariablesFlag
18 public :: obsu_computeVertCoordSurfObs, obsu_setGbgpsError, obsu_cvt_obs_instrum
19
20contains
21
22 !--------------------------------------------------------------------------
23 ! obsu_updateSourceVariablesFlag
24 !--------------------------------------------------------------------------
25 subroutine obsu_updateSourceVariablesFlag(obsSpaceData)
26 implicit none
27
28 ! Arguments:
29 type(struct_obs), intent(inout) :: obsSpaceData
30
31 ! Locals:
32 integer :: transformBufrCode, transformBufrCodeExtra
33 integer :: flag, flagExtra, mergedFlag
34 integer :: sourceBufrCode, sourceBufrCodeExtra
35 integer :: headerIndex, bodyIndexStart, bodyIndexEnd, bodyIndex, bodyIndex2
36 real(pre_obsReal) :: level
37
38 body : do bodyIndex = 1, obs_numBody(obsSpaceData)
39
40 if (ovt_isTransformedVariable(obs_bodyElem_i(obsSpaceData,OBS_VNM,bodyIndex))) then
41
42 ! We have found a transformed variable
43 transformBufrCode = obs_bodyElem_i(obsSpaceData,OBS_VNM,bodyIndex)
44
45 ! We will assign his assimilation flag to its source variable
46 sourceBufrCode = ovt_getSourceBufrCode(transformBufrCode)
47
48 headerIndex = obs_bodyElem_i(obsSpaceData, OBS_HIND, bodyIndex )
49 bodyIndexStart = obs_headElem_i(obsSpaceData, OBS_RLN , headerIndex )
50 bodyIndexEnd = obs_headElem_i(obsSpaceData, OBS_NLV , headerIndex ) + bodyIndexStart - 1
51 level = obs_bodyElem_r(obsSpaceData, OBS_PPP , bodyIndex )
52 flag = obs_bodyElem_i(obsSpaceData, OBS_FLG , bodyIndex )
53
54 if (ovt_isWindObs(sourceBufrCode)) then
55
56 ! Get the flag of the companion transformed variable
57 transformBufrCodeExtra = ovt_getDestinationBufrCode(sourceBufrCode, &
58 extra_opt=.true.)
59
60 flagExtra = -999
61 do bodyIndex2 = bodyIndexStart, bodyIndexEnd
62 if ( obs_bodyElem_i(obsSpaceData, OBS_VNM, bodyIndex2 ) == transformBufrCodeExtra .and. &
63 obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex2 ) == level ) then
64 flagExtra = obs_bodyElem_i(obsSpaceData, OBS_FLG , bodyIndex2)
65 end if
66 end do
67
68 ! Combine flags
69 if (flagExtra /= -999) then
70 mergedFlag = ior(flag,flagExtra)
71 else
72 call utl_abort('obsu_updateSourceVariablesFlag: could not find the wind companion variable')
73 end if
74
75 ! Find sourceBufrCode and sourceBufrCodeExtra and update their flag
76 sourceBufrCodeExtra = ovt_getSourceBufrCode(transformBufrCode,&
77 extra_opt=.true.)
78 do bodyIndex2 = bodyIndexStart, bodyIndexEnd
79 if ( obs_bodyElem_i(obsSpaceData, OBS_VNM, bodyIndex2 ) == sourceBufrCode .and. &
80 obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex2 ) == level ) then
81 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex2, mergedFlag )
82 end if
83 if ( obs_bodyElem_i(obsSpaceData, OBS_VNM, bodyIndex2 ) == sourceBufrCodeExtra .and. &
84 obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex2 ) == level ) then
85 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex2, mergedFlag )
86 end if
87 end do
88
89 else
90
91 ! Find sourceBufrCode and update its flag
92 do bodyIndex2 = bodyIndexStart, bodyIndexEnd
93 if ( obs_bodyElem_i(obsSpaceData, OBS_VNM, bodyIndex2 ) == sourceBufrCode .and. &
94 obs_bodyElem_r(obsSpaceData, OBS_PPP, bodyIndex2 ) == level ) then
95 call obs_bodySet_i(obsSpaceData, OBS_FLG, bodyIndex2, flag )
96 end if
97 end do
98
99 end if
100
101 end if
102
103 end do body
104
105 end subroutine obsu_updateSourceVariablesFlag
106
107 !--------------------------------------------------------------------------
108 ! obsu_setassflg
109 !--------------------------------------------------------------------------
110 subroutine obsu_setassflg(obsSpaceData)
111 !
112 !:Purpose: Set banco quality control bit #12 for all data assimilated
113 ! by current analysis.
114 !
115 implicit none
116
117 ! Argument:
118 type(struct_obs), intent(inout) :: obsSpaceData
119
120 ! Locals:
121 integer :: bodyIndex
122
123 ! Process all data
124 BODY: do bodyIndex = 1, obs_numBody(obsSpaceData)
125
126 if (obs_bodyElem_i(obsSpaceData, OBS_ASS, bodyIndex ) == obs_assimilated ) &
127 call obs_bodySet_i( obsSpaceData, OBS_FLG, bodyIndex, &
128 ibset( obs_bodyElem_i(obsSpaceData, OBS_FLG,bodyIndex), 12 ))
129 end do BODY
130
131 end subroutine obsu_setassflg
132
133 !--------------------------------------------------------------------------
134 ! surfvcord
135 !--------------------------------------------------------------------------
136 real function surfvcord( varno, codtyp )
137
138 implicit none
139
140 ! Arguments:
141 integer, intent(in) :: varno
142 integer, intent(in) :: codtyp
143
144 ! Locals:
145 character(len=9) :: family
146
147 family = codtypfam(codtyp)
148 surfvcord = 0.0
149
150 select case(family)
151 case ('synop')
152 select case(varno)
153 case (bufr_neds, bufr_nefs, bufr_neus, bufr_nevs, bufr_gust)
154 surfvcord = 10.0
155 case (bufr_nets, bufr_nees, bufr_ness, bufr_vis, bufr_logVis)
156 surfvcord = 1.5
157 end select
158 case ('ship')
159 select case(varno)
160 case (bufr_neds, bufr_nefs, bufr_neus, bufr_nevs, bufr_gust)
161 surfvcord = 20.0
162 case (bufr_nets, bufr_nees, bufr_ness, bufr_vis, bufr_logVis)
163 surfvcord = 11.5
164 end select
165 case ('upairland')
166 select case(varno)
167 case (bufr_neds, bufr_nefs, bufr_neus, bufr_nevs, bufr_gust)
168 surfvcord = 10.0
169 case (bufr_nets, bufr_ness, bufr_vis, bufr_logVis)
170 surfvcord = 1.5
171 end select
172 case ('upairship')
173 select case(varno)
174 case (bufr_neds, bufr_nefs, bufr_neus, bufr_nevs, bufr_gust)
175 surfvcord = 20.0
176 case (bufr_nets, bufr_ness, bufr_vis, bufr_logVis)
177 surfvcord = 1.5
178 end select
179 case ('scatwinds')
180 select case(varno)
181 case (bufr_neds, bufr_nefs, bufr_neus, bufr_nevs)
182 surfvcord = 10.0
183 end select
184 end select
185
186 end function surfvcord
187
188 !--------------------------------------------------------------------------
189 ! codtypfam
190 !--------------------------------------------------------------------------
191 function codtypfam(codtyp) result(family)
192 implicit none
193
194 ! Arguments:
195 integer, intent(in) :: codtyp
196 ! Result:
197 character(len=9) :: family
198
199 if ( codtyp == codtyp_get_codtyp('synopnonauto') .or. codtyp == codtyp_get_codtyp('synopmobil') &
200 .or. codtyp == codtyp_get_codtyp('asynopauto') ) then
201 family = 'synop'
202 else if ( codtyp == codtyp_get_codtyp('shipnonauto') .or. codtyp == codtyp_get_codtyp('drifter') &
203 .or. codtyp == codtyp_get_codtyp('synoppatrol') .or. codtyp == codtyp_get_codtyp('ashipauto') ) then
204 family = 'ship'
205 else if ( codtyp == codtyp_get_codtyp('temppilot') .or. codtyp == codtyp_get_codtyp('tempsynop') &
206 .or. codtyp == codtyp_get_codtyp('pilotsynop') .or. codtyp == codtyp_get_codtyp('temppilotsynop') &
207 .or. codtyp == codtyp_get_codtyp('pilot') .or. codtyp == codtyp_get_codtyp('pilotmobil') &
208 .or. codtyp == codtyp_get_codtyp('temp') .or. codtyp == codtyp_get_codtyp('tempdrop') &
209 .or. codtyp == codtyp_get_codtyp('tempmobil') .or. codtyp == codtyp_get_codtyp('temppilotmobil') &
210 .or. codtyp == codtyp_get_codtyp('tempsynopmobil') .or. codtyp == codtyp_get_codtyp('pilotsynopmobil') &
211 .or. codtyp == codtyp_get_codtyp('temppilotsynopmobil') ) then
212 family = 'upairland'
213 else if ( codtyp == codtyp_get_codtyp('temppilotship') .or. codtyp ==codtyp_get_codtyp('tempshipship') &
214 .or. codtyp == codtyp_get_codtyp('tempsshipship') .or. codtyp ==codtyp_get_codtyp('pilotshipship') &
215 .or. codtyp == codtyp_get_codtyp('pilotship') .or. codtyp ==codtyp_get_codtyp('tempship') ) then
216 family = 'upairship'
217 else if ( codtyp == codtyp_get_codtyp('ascat') ) then
218 family = 'scatwinds'
219 else
220 family = 'other'
221 end if
222
223 end function codtypfam
224
225 !--------------------------------------------------------------------------
226 ! obsu_computeVertCoordSurfObs
227 !--------------------------------------------------------------------------
228 subroutine obsu_computeVertCoordSurfObs(obsdat, headerIndexStart, headerIndexEnd )
229 !
230 implicit none
231
232 ! Arguments:
233 type (struct_obs), intent(inout) :: obsdat
234 integer , intent(in) :: headerIndexStart
235 integer , intent(in) :: headerIndexEnd
236
237 ! Locals:
238 integer :: bodyIndex, headerIndex, bodyIndexStart, bodyIndexEnd
239 integer :: varno, codtyp
240 real(4) :: sfc_vco, elev
241 real(pre_obsReal) :: ppp
242
243 HEADER: do headerIndex = headerIndexStart, headerIndexEnd
244
245 bodyIndexStart = obs_headElem_i(obsdat, OBS_RLN, headerIndex )
246 bodyIndexEnd = obs_headElem_i(obsdat, OBS_NLV, headerIndex ) + bodyIndexStart - 1
247 codtyp = obs_headElem_i(obsdat, OBS_ITY, headerIndex )
248 elev = obs_headElem_r(obsdat, OBS_ALT, headerIndex )
249
250 BODY: do bodyIndex = bodyIndexStart, bodyIndexEnd
251 varno = obs_bodyElem_i(obsdat, OBS_VNM, bodyIndex )
252
253 select case(varno)
254 case(bufr_neds, bufr_nefs, bufr_neus, bufr_nevs, bufr_nets, bufr_ness, bufr_nepn, bufr_neps, bufr_nehs, &
255 bufr_nezd, bufr_vis, bufr_logVis, bufr_gust )
256 sfc_vco = surfvcord(varno, codtyp )
257 if ( varno /= bufr_nepn) then
258 ppp = elev + sfc_vco
259 call obs_bodySet_r(obsdat, OBS_PPP, bodyIndex, ppp )
260 call obs_bodySet_i(obsdat, OBS_VCO, bodyIndex, 1 )
261 else
262 ppp = 0.
263 call obs_bodySet_r(obsdat,OBS_PPP, bodyIndex, ppp )
264 call obs_bodySet_i(obsdat,OBS_VCO, bodyIndex, 1 )
265 end if
266 end select
267
268 end do BODY
269
270 end do HEADER
271
272 end subroutine obsu_computeVertCoordSurfObs
273
274 !--------------------------------------------------------------------------
275 ! obsu_setGbgpsError
276 !--------------------------------------------------------------------------
277 subroutine obsu_setGbgpsError(obsdat, headerIndexStart, headerIndexEnd )
278 !
279 implicit none
280
281 ! Arguments:
282 type (struct_obs), intent(inout) :: obsdat
283 integer , intent(in) :: headerIndexStart
284 integer , intent(in) :: headerIndexEnd
285
286 ! Locals:
287 real(pre_obsReal) :: obsv
288 integer :: bodyIndex, headerIndex,bodyIndexStart, bodyIndexEnd
289 integer :: varno
290
291 HEADER: do headerIndex = headerIndexStart, headerIndexEnd
292
293 bodyIndexStart = obs_headElem_i(obsdat, OBS_RLN, headerIndex )
294 bodyIndexEnd = obs_headElem_i(obsdat, OBS_NLV, headerIndex ) + bodyIndexStart - 1
295 obsv = real(MPC_missingValue_R8, pre_obsReal)
296
297 BODY: do bodyIndex = bodyIndexStart, bodyIndexEnd
298
299 varno = obs_bodyElem_i(obsdat,OBS_VNM,bodyIndex )
300
301 if ( varno == bufr_nefe ) then
302 obsv = obs_bodyElem_r(obsdat,OBS_VAR, bodyIndex )
303 call obs_bodySet_i(obsdat, OBS_VNM, bodyIndex, 999 )
304 exit BODY
305 end if
306
307 end do BODY
308
309 BODY2: do bodyIndex = bodyIndexStart, bodyIndexEnd
310
311 varno = obs_bodyElem_i(obsdat, OBS_VNM, bodyIndex )
312
313 if ( varno == bufr_nezd .and. obsv /= real(MPC_missingValue_R8, pre_obsReal)) then
314 call obs_bodySet_r(obsdat, OBS_OER, bodyIndex, obsv )
315 exit BODY2
316 end if
317
318 end do BODY2
319
320 end do HEADER
321
322 end subroutine obsu_setGbgpsError
323
324 !--------------------------------------------------------------------------
325 ! obsu_cvt_obs_instrum
326 !--------------------------------------------------------------------------
327 integer function obsu_cvt_obs_instrum(sensor)
328 !
329 !:Purpose: Map burp satellite sensor indicator (element #2048) to
330 ! burp satellite instrument (element #2019). This is a more
331 ! complete common element, allowing for future expansion.
332 !
333 !:Table of BURP satellite sensor indicator element #002048:
334 ! ================== ===============================
335 ! Satellite sensor BURP satellite sensor indicator
336 ! ================== ===============================
337 ! HIRS 0
338 ! MSU 1
339 ! SSU 2
340 ! AMSUA 3
341 ! AMSUB 4
342 ! AVHRR 5
343 ! SSMI 6
344 ! NSCAT 7
345 ! SEAWINDS 8
346 ! Reserved 9-14
347 ! Missing value 15
348 ! ================== ===============================
349 !
350 implicit none
351
352 ! Arguments:
353 integer, intent(in) :: sensor ! BURP satellite sensor indicator (element #2048)
354
355 ! Locals:
356 integer :: instrument ! BURP satellite instrument (element #2019)
357
358 select case (sensor)
359 case (000); instrument = 606 ! HIRS
360 case (001); instrument = 623 ! MSU
361 case (002); instrument = 627 ! SSU
362 case (003); instrument = 570 ! AMSUA
363 case (004); instrument = 574 ! AMSUB
364 case (005); instrument = 591 ! AVHRR
365 case (006); instrument = 905 ! SSMI
366 case (007); instrument = 312 ! NSCAT
367 case (008); instrument = 313 ! SEAWINDS
368 case (015); instrument = 2047 ! Missing value
369 case default; instrument = 2047 ! Unrecognized value
370 end select
371
372 obsu_cvt_obs_instrum = instrument
373
374 end function obsu_cvt_obs_instrum
375
376end module obsUtil_mod
