da_fill_obs_structures.inc
References to this file elsewhere.
1 subroutine da_fill_obs_structures(xp, iv, ob)
2
3 !----------------------------------------------------------------------------
4 ! Purpose: Allocates observation structure and fills it from iv.
5 !----------------------------------------------------------------------------
6
7 implicit none
8
9 type (xpose_type), intent(in) :: xp ! Domain decomposition vars.
10 type (ob_type), intent(inout) :: iv ! Obs and header structure.
11 type (y_type), intent(out) :: ob ! (Smaller) observation structure.
12
13 integer :: n, k ! Loop counters.
14 real :: rh_error ! RH obs. error.
15 real :: q_error ! q obs. error.
16
17 if (trace_use) call da_trace_entry("da_fill_obs_structures")
18
19 !---------------------------------------------------------------------------
20 ! Initialise obs error factors (which will be overwritten in use_obs_errfac)
21 !---------------------------------------------------------------------------
22
23 iv % synop_ef_u = 1.0
24 iv % synop_ef_v = 1.0
25 iv % synop_ef_t = 1.0
26 iv % synop_ef_p = 1.0
27 iv % synop_ef_q = 1.0
28
29 iv % metar_ef_u = 1.0
30 iv % metar_ef_v = 1.0
31 iv % metar_ef_t = 1.0
32 iv % metar_ef_p = 1.0
33 iv % metar_ef_q = 1.0
34
35 iv % ships_ef_u = 1.0
36 iv % ships_ef_v = 1.0
37 iv % ships_ef_t = 1.0
38 iv % ships_ef_p = 1.0
39 iv % ships_ef_q = 1.0
40
41 iv % geoamv_ef_u = 1.0
42 iv % geoamv_ef_v = 1.0
43
44 iv % polaramv_ef_u = 1.0
45 iv % polaramv_ef_v = 1.0
46
47 iv % gpspw_ef_tpw = 1.0
48
49 iv % gpsref_ef_ref = 1.0
50 iv % gpsref_ef_p = 1.0
51 iv % gpsref_ef_t = 1.0
52 iv % gpsref_ef_q = 1.0
53
54 iv % sound_ef_u = 1.0
55 iv % sound_ef_v = 1.0
56 iv % sound_ef_t = 1.0
57 iv % sound_ef_q = 1.0
58
59 iv % airep_ef_u = 1.0
60 iv % airep_ef_v = 1.0
61 iv % airep_ef_t = 1.0
62
63 iv % pilot_ef_u = 1.0
64 iv % pilot_ef_v = 1.0
65
66 iv % ssmir_ef_speed = 1.0
67 iv % ssmir_ef_tpw = 1.0
68
69 iv % satem_ef_thickness = 1.0
70
71 iv % ssmt1_ef_t = 1.0
72
73 iv % ssmt2_ef_rh = 1.0
74
75 iv % qscat_ef_u = 1.0
76 iv % qscat_ef_v = 1.0
77
78 iv % profiler_ef_u = 1.0
79 iv % profiler_ef_v = 1.0
80
81 iv % buoy_ef_u = 1.0
82 iv % buoy_ef_v = 1.0
83 iv % buoy_ef_t = 1.0
84 iv % buoy_ef_p = 1.0
85 iv % buoy_ef_q = 1.0
86
87 iv % Radar_ef_rv = 1.0
88 iv % Radar_ef_rf = 1.0
89
90 iv % bogus_ef_u = 1.0
91 iv % bogus_ef_v = 1.0
92 iv % bogus_ef_t = 1.0
93 iv % bogus_ef_p = 1.0
94 iv % bogus_ef_q = 1.0
95 iv % bogus_ef_slp = 1.0
96
97 iv % airsr_ef_t = 1.0
98 iv % airsr_ef_q = 1.0
99
100 !---------------------------------------------------------------------------
101 ! [1.0] Allocate innovation vector and observation structures:
102 !---------------------------------------------------------------------------
103 call da_allocate_y(iv, ob)
104
105 !----------------------------------------------------------------------
106 ! [2.0] Transfer observations:
107 !----------------------------------------------------------------------
108
109 ! [2.1] Transfer surface obs:
110
111 if (iv % num_synop > 0) then
112 do n = 1, iv % num_synop
113 ob % synop(n) % u = iv % synop(n) % u % inv
114 ob % synop(n) % v = iv % synop(n) % v % inv
115 ob % synop(n) % t = iv % synop(n) % t % inv
116 ob % synop(n) % q = iv % synop(n) % q % inv
117 ob % synop(n) % p = iv % synop(n) % p % inv
118
119 ! Calculate q error from rh error:
120
121 rh_error = iv%synop(n)%q%error ! q error is rh at this stage!
122
123 ! if((ob % synop(n) % p > iv%ptop) .AND. &
124 ! (ob % synop(n) % t > 100.0) .AND. &
125 ! (ob % synop(n) % q > 0.0) .AND. &
126 ! (iv % synop(n) % p % qc >= obs_qc_pointer) .and. &
127 ! (iv % synop(n) % t % qc >= obs_qc_pointer) .and. &
128 ! (iv % synop(n) % q % qc >= obs_qc_pointer)) then
129 call da_get_q_error(ob % synop(n) % p, &
130 ob % synop(n) % t, &
131 ob % synop(n) % q, &
132 iv % synop(n) % t % error, &
133 rh_error, iv % synop(n) % q % error)
134 if (iv%synop(n)% q % error == missing_r) iv%synop(n)% q % qc = missing_data
135
136 ! end if
137 end do
138 end if
139
140 ! [2.2] Transfer metar obs:
141
142 if (iv % num_metar > 0) then
143 do n = 1, iv % num_metar
144 ob % metar(n) % u = iv % metar(n) % u % inv
145 ob % metar(n) % v = iv % metar(n) % v % inv
146 ob % metar(n) % t = iv % metar(n) % t % inv
147 ob % metar(n) % q = iv % metar(n) % q % inv
148 ob % metar(n) % p = iv % metar(n) % p % inv
149
150 ! Calculate q error from rh error:
151
152 rh_error = iv%metar(n)%q%error ! q error is rh at this stage!
153 call da_get_q_error(iv % metar(n) % p % inv, &
154 ob % metar(n) % t, &
155 ob % metar(n) % q, &
156 iv % metar(n) % t % error, &
157 rh_error, q_error)
158 iv % metar(n) % q % error = q_error
159 if (iv%metar(n)% q % error == missing_r) &
160 iv%metar(n)% q % qc = missing_data
161 end do
162 end if
163
164 ! [2.2] Transfer ships obs:
165
166 if (iv % num_ships > 0) then
167 do n = 1, iv % num_ships
168 ob % ships(n) % u = iv % ships(n) % u % inv
169 ob % ships(n) % v = iv % ships(n) % v % inv
170 ob % ships(n) % t = iv % ships(n) % t % inv
171 ob % ships(n) % q = iv % ships(n) % q % inv
172 ob % ships(n) % p = iv % ships(n) % p % inv
173
174 ! Calculate q error from rh error:
175
176 rh_error = iv%ships(n)%q%error ! q error is rh at this stage!
177 call da_get_q_error(iv % ships(n) % p % inv, &
178 ob % ships(n) % t, &
179 ob % ships(n) % q, &
180 iv % ships(n) % t % error, &
181 rh_error, q_error)
182 iv % ships(n) % q % error = q_error
183
184 if(iv%ships(n)% q % error == missing_r) iv%ships(n)% q % qc = missing_data
185 end do
186
187 end if
188
189 ! [2.4.1] Transfer Geo. AMVs Obs:
190
191 if (iv % num_geoamv > 0) then
192 do n = 1, iv % num_geoamv
193 do k = 1, iv % geoamv(n) % info % levels
194 ob % geoamv(n) % u(k) = iv % geoamv(n) % u(k) % inv
195 ob % geoamv(n) % v(k) = iv % geoamv(n) % v(k) % inv
196 end do
197 end do
198 end if
199
200 ! [2.4.2] Transfer Polar AMVs Obs:
201
202 if (iv % num_polaramv > 0) then
203 do n = 1, iv % num_polaramv
204 do k = 1, iv % polaramv(n) % info % levels
205 ob % polaramv(n) % u(k) = iv % polaramv(n) % u(k) % inv
206 ob % polaramv(n) % v(k) = iv % polaramv(n) % v(k) % inv
207 end do
208 end do
209 end if
210
211 ! [2.5] Transfer gpspw obs:
212
213 if (iv % num_gpspw > 0) then
214 do n = 1, iv % num_gpspw
215 ob % gpspw(n) % tpw = iv % gpspw(n) % tpw % inv
216 end do
217
218 end if
219
220 ! [2.6] Transfer GPS REF obs:
221
222 if (iv % num_gpsref > 0) then
223 do n = 1, iv % num_gpsref
224 do k = 1, iv % gpsref(n) % info % levels
225 ob % gpsref(n) % ref(k) = iv % gpsref(n) % ref(k) % inv
226 ob % gpsref(n) % p(k) = iv % gpsref(n) % p(k) % inv
227 ob % gpsref(n) % t(k) = iv % gpsref(n) % t(k) % inv
228 ob % gpsref(n) % q(k) = iv % gpsref(n) % q(k) % inv
229 end do
230 end do
231 end if
232
233 ! [2.7] Transfer sonde obs:
234
235 if (iv % num_sound > 0) then
236 do n = 1, iv % num_sound
237 do k = 1, iv % sound(n) % info % levels
238 ob % sound(n) % u(k) = iv % sound(n) % u(k) % inv
239 ob % sound(n) % v(k) = iv % sound(n) % v(k) % inv
240 ob % sound(n) % t(k) = iv % sound(n) % t(k) % inv
241 ob % sound(n) % q(k) = iv % sound(n) % q(k) % inv
242
243 ! Calculate q error from rh error:
244
245 rh_error = iv%sound(n)%q(k)%error ! q error is rh at this stage!
246 call da_get_q_error(iv % sound(n) % p(k), &
247 ob % sound(n) % t(k), &
248 ob % sound(n) % q(k), &
249 iv % sound(n) % t(k) % error, &
250 rh_error, q_error)
251
252 iv % sound(n) % q(k) % error = q_error
253 if (iv%sound(n)% q(k) % error == missing_r) &
254 iv%sound(n)% q(k) % qc = missing_data
255 end do
256 ob % sonde_sfc(n) % u = iv % sonde_sfc(n) % u % inv
257 ob % sonde_sfc(n) % v = iv % sonde_sfc(n) % v % inv
258 ob % sonde_sfc(n) % t = iv % sonde_sfc(n) % t % inv
259 ob % sonde_sfc(n) % q = iv % sonde_sfc(n) % q % inv
260 ob % sonde_sfc(n) % p = iv % sonde_sfc(n) % p % inv
261
262 ! Calculate q error from rh error:
263
264 rh_error = iv%sonde_sfc(n)%q%error ! q error is rh at this stage!
265 call da_get_q_error(iv % sonde_sfc(n) % p % inv, &
266 ob % sonde_sfc(n) % t, &
267 ob % sonde_sfc(n) % q, &
268 iv % sonde_sfc(n) % t % error, &
269 rh_error, iv % sonde_sfc(n) % q % error)
270 if (iv%sonde_sfc(n)% q % error == missing_r) &
271 iv%sonde_sfc(n)% q % qc = missing_data
272 end do
273 end if
274
275 ! [2.8] Transfer airep obs:
276
277 if (iv % num_airep > 0) then
278 do n = 1, iv % num_airep
279 do k = 1, iv % airep(n) % info % levels
280 ob % airep(n) % u(k) = iv % airep(n) % u(k) % inv
281 ob % airep(n) % v(k) = iv % airep(n) % v(k) % inv
282 ob % airep(n) % t(k) = iv % airep(n) % t(k) % inv
283 end do
284 end do
285 end if
286
287 ! [2.9] Transfer pilot obs:
288
289 if (iv % num_pilot > 0) then
290 do n = 1, iv % num_pilot
291 do k = 1, iv % pilot(n) % info % levels
292 ob % pilot(n) % u(k) = iv % pilot(n) % u(k) % inv
293 ob % pilot(n) % v(k) = iv % pilot(n) % v(k) % inv
294 end do
295 end do
296 end if
297
298 ! [2.10] Transfer SSM/I obs:SSMI:
299
300 if (iv % num_ssmi_retrieval > 0) then
301 do n = 1, iv % num_ssmi_retrieval
302 ob % ssmi_retrieval(n) % speed = iv % ssmi_retrieval(n) % speed % inv
303 ob % ssmi_retrieval(n) % tpw = iv % ssmi_retrieval(n) % tpw % inv
304 end do
305 end if
306
307 if (iv % num_ssmi_tb > 0) then
308 do n = 1, iv % num_ssmi_tb
309 ob % ssmi_tb(n) % tb19v = iv % ssmi_tb(n) % tb19v % inv
310 ob % ssmi_tb(n) % tb19h = iv % ssmi_tb(n) % tb19h % inv
311 ob % ssmi_tb(n) % tb22v = iv % ssmi_tb(n) % tb22v % inv
312 ob % ssmi_tb(n) % tb37v = iv % ssmi_tb(n) % tb37v % inv
313 ob % ssmi_tb(n) % tb37h = iv % ssmi_tb(n) % tb37h % inv
314 ob % ssmi_tb(n) % tb85v = iv % ssmi_tb(n) % tb85v % inv
315 ob % ssmi_tb(n) % tb85h = iv % ssmi_tb(n) % tb85h % inv
316 end do
317 end if
318
319 ! [2.11] Transfer satem obs:
320
321 if (iv % num_satem > 0) then
322 do n = 1, iv % num_satem
323 do k = 1, iv % satem(n) % info % levels
324 ob % satem(n) % thickness(k) = iv % satem(n) % thickness(k) % inv
325 end do
326 end do
327 end if
328
329 ! [2.12] Transfer ssmt1 obs:
330
331 if (iv % num_ssmt1 > 0) then
332 do n = 1, iv % num_ssmt1
333 do k = 1, iv % ssmt1(n) % info % levels
334 ob % ssmt1(n) % t(k) = iv % ssmt1(n) % t(k) % inv
335 end do
336 end do
337
338 end if
339
340 ! [2.13] Transfer ssmt2 obs:
341
342 if (iv % num_ssmt2 > 0) then
343 do n = 1, iv % num_ssmt2
344 do k = 1, iv % ssmt2(n) % info % levels
345 ob % ssmt2(n) % rh(k) = iv % ssmt2(n) % rh(k) % inv
346 end do
347 end do
348 end if
349
350 ! [2.14] Setup pseudo observations:
351
352 if (num_pseudo > 0) call da_setup_pseudo_obs(xp, iv, ob)
353
354 ! [2.15] Transfer scatterometer obs:
355
356 if (iv % num_qscat > 0) then
357 do n = 1, iv % num_qscat
358 ob % qscat(n) % u = iv % qscat(n) % u % inv
359 ob % qscat(n) % v = iv % qscat(n) % v % inv
360 end do
361 end if
362
363 ! [2.16] Transfer profiler obs:
364
365 if (iv % num_profiler > 0) then
366 do n = 1, iv % num_profiler
367 do k = 1, iv % profiler(n) % info % levels
368 ob % profiler(n) % u(k) = iv % profiler(n) % u(k) % inv
369 ob % profiler(n) % v(k) = iv % profiler(n) % v(k) % inv
370 end do
371 end do
372 end if
373
374 ! [2.17] Transfer buoy obs:
375
376 if (iv % num_buoy > 0) then
377 do n = 1, iv % num_buoy
378 ob % buoy(n) % p = iv % buoy(n) % p % inv
379 end do
380 do n = 1, iv % num_buoy
381 ob % buoy(n) % u = iv % buoy(n) % u % inv
382 ob % buoy(n) % v = iv % buoy(n) % v % inv
383 ob % buoy(n) % t = iv % buoy(n) % t % inv
384 ob % buoy(n) % q = iv % buoy(n) % q % inv
385
386 ! Calculate q error from rh error:
387
388 rh_error = iv%buoy(n)%q%error ! q error is rh at this stage!
389 call da_get_q_error(iv % buoy(n) % p % inv, &
390 ob % buoy(n) % t, &
391 ob % buoy(n) % q, &
392 iv % buoy(n) % t % error, &
393 rh_error, q_error)
394 iv % buoy(n) % q % error = q_error
395
396 if(iv%buoy (n)% q % error == missing_r) iv%buoy (n)% q % qc = missing_data
397 end do
398 end if
399
400 ! [2.18] Transfer Radar obs:
401
402 if (iv % num_Radar > 0) then
403 do n = 1, iv % num_Radar
404 do k = 1, iv % Radar(n) % info % levels
405 ! Copy observation variables:
406 ob % Radar(n) % rv(k) = iv % Radar(n) % rv(k) % inv
407 ob % Radar(n) % rf(k) = iv % Radar(n) % rf(k) % inv
408 end do
409 end do
410 end if
411
412 ! [2.19] Transfer TC bogus:
413
414 if (iv % num_bogus > 0) then
415 do n = 1, iv % num_bogus
416 do k = 1, iv % bogus(n) % info % levels
417
418 ! Copy observation variables:
419
420 ob % bogus(n) % u(k) = iv % bogus(n) % u(k) % inv
421 ob % bogus(n) % v(k) = iv % bogus(n) % v(k) % inv
422 ob % bogus(n) % t(k) = iv % bogus(n) % t(k) % inv
423 ob % bogus(n) % q(k) = iv % bogus(n) % q(k) % inv
424
425 ! Calculate q error from rh error:
426
427 rh_error = iv%bogus(n)%q(k)%error ! q error is rh at this stage!
428 call da_get_q_error(iv % bogus(n) % p(k), &
429 ob % bogus(n) % t(k), &
430 ob % bogus(n) % q(k), &
431 iv % bogus(n) % t(k) % error, &
432 rh_error, q_error)
433
434 iv % bogus(n) % q(k) % error = q_error
435 if (iv%bogus(n)% q(k) % error == missing_r) &
436 iv%bogus(n)% q(k) % qc = missing_data
437 end do
438 ob % bogus(n) % slp = iv % bogus(n) % slp % inv
439 end do
440 end if
441
442 ! Transfer AIRS retrievals:
443
444 if (iv % num_airsr > 0) then
445 do n = 1, iv % num_airsr
446 do k = 1, iv % airsr(n) % info % levels
447
448 ! Copy observation variables:
449
450 ob % airsr(n) % t(k) = iv % airsr(n) % t(k) % inv
451 ob % airsr(n) % q(k) = iv % airsr(n) % q(k) % inv
452
453 ! Calculate q error from rh error:
454
455 rh_error = iv%airsr(n)%q(k)%error ! q error is rh at this stage!
456 call da_get_q_error(iv % airsr(n) % p(k), &
457 ob % airsr(n) % t(k), &
458 ob % airsr(n) % q(k), &
459 iv % airsr(n) % t(k) % error, &
460 rh_error, q_error)
461
462 iv % airsr(n) % q(k) % error = q_error
463 if (iv%airsr(n)% q(k) % error == missing_r) &
464 iv%airsr(n)% q(k) % qc = missing_data
465 end do
466 end do
467 end if
468
469 if (trace_use) call da_trace_exit("da_fill_obs_structures")
470
471 end subroutine da_fill_obs_structures
472
473