da_write_y.inc
References to this file elsewhere.
1 subroutine da_write_y (iv, y)
2
3 !-------------------------------------------------------------------------
4 ! Purpose: Writes out components of y=H(x_inc) structure.
5 !-------------------------------------------------------------------------
6
7 implicit none
8
9 type (iv_type), intent(in) :: iv ! O-B structure.
10 type (y_type), intent(in) :: y ! y = H(x_inc) structure.
11
12 integer :: ounit ! Output file unit.
13 integer :: n, k, num_obs, i, ios
14 real :: f1, f2, f3, f4, f5, f6, f7, dum
15 character(len=filename_len) :: ob_name, filename, file_prefix
16
17 if (trace_use) call da_trace_entry("da_write_y")
18
19 !-------------------------------------------------------------------------
20 ! Fix output unit
21 !-------------------------------------------------------------------------
22
23 if (omb_add_noise) then
24 file_prefix='pert_obs.'
25 else
26 file_prefix='unpert_obs.'
27 end if
28
29 dum = -999999.9
30
31 #ifdef DM_PARALLEL
32 write (unit=filename, fmt='(a,i3.3)') trim(file_prefix), myproc
33 #else
34 write (unit=filename, fmt='(a)') trim(file_prefix)//'000'
35 #endif
36
37 call da_get_unit(ounit)
38 open (unit=ounit,file=trim(filename),form='formatted', &
39 status='replace', iostat=ios )
40 if (ios /= 0) then
41 call da_error(__FILE__,__LINE__, &
42 (/"Cannot open (un)perturbed observation file"//filename/))
43 end if
44
45 ! [1] Transfer surface obs:
46
47 if (iv%info(synop)%nlocal > 0) then
48 num_obs = 0
49 do n = 1, iv%info(synop)%nlocal
50 if (iv%info(synop)%proc_domain(1,n)) num_obs = num_obs + 1
51 end do
52 if (num_obs > 0) then
53 write(ounit,'(a20,i8)')'synop', num_obs
54 num_obs = 0
55 do n = 1, iv%info(synop)%nlocal
56 if (iv%info(synop)%proc_domain(1,n)) then
57 num_obs = num_obs + 1
58 write(ounit,'(i8)') 1
59 call da_check_missing(iv%synop(n)%u%qc, y%synop(n)%u, f1)
60 call da_check_missing(iv%synop(n)%v%qc, y%synop(n)%v, f2)
61 call da_check_missing(iv%synop(n)%t%qc, y%synop(n)%t, f3)
62 call da_check_missing(iv%synop(n)%p%qc, y%synop(n)%p, f4)
63 call da_check_missing(iv%synop(n)%q%qc, y%synop(n)%q, f5)
64 write(ounit,'(2i8,7e15.7)')num_obs, 1, f1, f2, f3, f4, f5, &
65 dum,dum
66 end if
67 end do
68 end if
69 end if
70
71 ! [2] Transfer metar obs:
72
73 if (iv%info(metar)%nlocal > 0) then
74 num_obs = 0
75 do n = 1, iv%info(metar)%nlocal
76 if(iv%info(metar)%proc_domain(1,n)) num_obs = num_obs + 1
77 end do
78 if (num_obs > 0) then
79 write(ounit,'(a20,i8)')'metar', num_obs
80 num_obs = 0
81 do n = 1, iv%info(metar)%nlocal
82 if (iv%info(metar)%proc_domain(1,n)) then
83 num_obs = num_obs + 1
84 write(ounit,'(i8)') 1
85 call da_check_missing(iv%metar(n)%u%qc, y%metar(n)%u, f1)
86 call da_check_missing(iv%metar(n)%v%qc, y%metar(n)%v, f2)
87 call da_check_missing(iv%metar(n)%t%qc, y%metar(n)%t, f3)
88 call da_check_missing(iv%metar(n)%p%qc, y%metar(n)%p, f4)
89 call da_check_missing(iv%metar(n)%q%qc, y%metar(n)%q, f5)
90 write(ounit,'(2i8,7e15.7)')num_obs, 1, f1, f2, f3, f4, f5, &
91 dum,dum
92 end if
93 end do
94 end if
95 end if
96
97 ! [3] Transfer ships obs:
98
99 if (iv%info(ships)%nlocal > 0) then
100 num_obs = 0
101 do n = 1, iv%info(ships)%nlocal
102 if (iv%info(ships)%proc_domain(1,n)) num_obs = num_obs + 1
103 end do
104 if (num_obs > 0) then
105 write(ounit,'(a20,i8)')'ships', num_obs
106 num_obs = 0
107 do n = 1, iv%info(ships)%nlocal
108 if (iv%info(ships)%proc_domain(1,n)) then
109 num_obs = num_obs + 1
110 write(ounit,'(i8)') 1
111 call da_check_missing(iv%ships(n)%u%qc, y%ships(n)%u, f1)
112 call da_check_missing(iv%ships(n)%v%qc, y%ships(n)%v, f2)
113 call da_check_missing(iv%ships(n)%t%qc, y%ships(n)%t, f3)
114 call da_check_missing(iv%ships(n)%p%qc, y%ships(n)%p, f4)
115 call da_check_missing(iv%ships(n)%q%qc, y%ships(n)%q, f5)
116 write(ounit,'(2i8,7e15.7)')num_obs, 1, f1, f2, f3, f4, f5, &
117 dum,dum
118 end if
119 end do
120 end if
121 end if
122
123 ! [4.1] Transfer Geo. AMVs Obs:
124
125 if (iv%info(geoamv)%nlocal > 0) then
126 num_obs = 0
127 do n = 1, iv%info(geoamv)%nlocal
128 if (iv%info(geoamv)%proc_domain(1,n)) num_obs = num_obs + 1
129 end do
130 if (num_obs > 0) then
131 write(ounit,'(a20,i8)')'geoamv', num_obs
132 num_obs = 0
133 do n = 1, iv%info(geoamv)%nlocal
134 if (iv%info(geoamv)%proc_domain(1,n)) then
135 num_obs = num_obs + 1
136 write(ounit,'(i8)')iv%info(geoamv)%levels(n)
137 do k = 1, iv%info(geoamv)%levels(n)
138 call da_check_missing(iv%geoamv(n)%u(k)%qc, &
139 y%geoamv(n)%u(k), f1)
140 call da_check_missing(iv%geoamv(n)%v(k)%qc, &
141 y%geoamv(n)%v(k), f2)
142 write(ounit,'(2i8,7e15.7)')num_obs, k, f1, f2 , dum,dum,dum, &
143 dum,dum
144 end do
145 end if
146 end do
147 end if
148 end if
149
150 ! [4.2] Transfer Polar AMVs Obs:
151
152 if (iv%info(polaramv)%nlocal > 0) then
153 num_obs = 0
154 do n = 1, iv%info(polaramv)%nlocal
155 if (iv%info(polaramv)%proc_domain(1,n)) num_obs = num_obs + 1
156 end do
157 if (num_obs > 0) then
158 write(ounit,'(a20,i8)')'polaramv', num_obs
159 num_obs = 0
160 do n = 1, iv%info(polaramv)%nlocal
161 if (iv%info(polaramv)%proc_domain(1,n)) then
162 num_obs = num_obs + 1
163 write(ounit,'(i8)') iv%info(polaramv)%levels(n)
164 do k = 1, iv%info(polaramv)%levels(n)
165 call da_check_missing(iv%polaramv(n)%u(k)%qc, &
166 y%polaramv(n)%u(k), f1)
167 call da_check_missing(iv%polaramv(n)%v(k)%qc, &
168 y%polaramv(n)%v(k), f2)
169 write(ounit,'(2i8,7e15.7)')num_obs, k, f1, f2 , dum,dum,dum,&
170 dum,dum
171 end do
172 end if
173 end do
174 end if
175 end if
176
177 ! [5] Transfer gpspw obs:
178
179 if (iv%info(gpspw)%nlocal > 0) then
180 num_obs = 0
181 do n = 1, iv%info(gpspw)%nlocal
182 if (iv%info(gpspw)%proc_domain(1,n)) num_obs = num_obs + 1
183 end do
184 if (num_obs > 0) then
185 write(ounit,'(a20,i8)')'gpspw', num_obs
186 num_obs = 0
187 do n = 1, iv%info(gpspw)%nlocal
188 if (iv%info(gpspw)%proc_domain(1,n)) then
189 num_obs = num_obs + 1
190 write(ounit,'(i8)') 1
191 call da_check_missing(iv%gpspw(n)%tpw%qc, y%gpspw(n)%tpw, f1)
192 write(ounit,'(2i8,7e15.7)')num_obs, 1, f1, dum,dum,dum,dum, &
193 dum,dum
194 end if
195 end do
196 end if
197 end if
198
199 ! [6] Transfer sonde obs:
200
201 if (iv%info(sound)%nlocal > 0) then
202 num_obs = 0
203 do n = 1, iv%info(sound)%nlocal
204 if (iv%info(sound)%proc_domain(1,n)) num_obs = num_obs + 1
205 end do
206 if (num_obs > 0) then
207 write(ounit,'(a20,i8)')'sound', num_obs
208 num_obs = 0
209 do n = 1, iv%info(sound)%nlocal
210 if (iv%info(sound)%proc_domain(1,n)) then
211 num_obs = num_obs + 1
212 write(ounit,'(i8)')iv%info(sound)%levels(n)
213 do k = 1, iv%info(sound)%levels(n)
214 call da_check_missing(iv%sound(n)%u(k)%qc, y%sound(n)%u(k), f1)
215 call da_check_missing(iv%sound(n)%v(k)%qc, y%sound(n)%v(k), f2)
216 call da_check_missing(iv%sound(n)%t(k)%qc, y%sound(n)%t(k), f3)
217 call da_check_missing(iv%sound(n)%q(k)%qc, y%sound(n)%q(k), f4)
218 write(ounit,'(2i8,7e15.7)')num_obs, k, f1, f2, f3, f4, dum, &
219 dum,dum
220 end do
221 end if
222 end do
223 end if
224
225 num_obs = 0
226 do n = 1, iv%info(sound)%nlocal
227 if (iv%info(sound)%proc_domain(1,n)) num_obs = num_obs + 1
228 end do
229 if (num_obs > 0) then
230 write(ounit,'(a20,i8)')'sonde_sfc', num_obs
231 num_obs = 0
232 do n = 1, iv%info(sound)%nlocal
233 if (iv%info(sound)%proc_domain(1,n)) then
234 num_obs = num_obs + 1
235 write(ounit,'(i8)') 1
236 call da_check_missing(iv%sonde_sfc(n)%u%qc, y%sonde_sfc(n)%u, f1)
237 call da_check_missing(iv%sonde_sfc(n)%v%qc, y%sonde_sfc(n)%v, f2)
238 call da_check_missing(iv%sonde_sfc(n)%t%qc, y%sonde_sfc(n)%t, f3)
239 call da_check_missing(iv%sonde_sfc(n)%p%qc, y%sonde_sfc(n)%p, f4)
240 call da_check_missing(iv%sonde_sfc(n)%q%qc, y%sonde_sfc(n)%q, f5)
241 write(ounit,'(2i8,7e15.7)')num_obs, 1, f1, f2, f3, f4, f5, &
242 dum,dum
243 end if
244 end do
245 end if
246 end if
247
248 ! [7] Transfer airep obs:
249
250 if (iv%info(airep)%nlocal > 0) then
251 num_obs = 0
252 do n = 1, iv%info(airep)%nlocal
253 if (iv%info(airep)%proc_domain(1,n)) num_obs = num_obs + 1
254 end do
255 if (num_obs > 0) then
256 write(ounit,'(a20,i8)')'airep', num_obs
257 num_obs = 0
258 do n = 1, iv%info(airep)%nlocal
259 if (iv%info(airep)%proc_domain(1,n)) then
260 num_obs = num_obs + 1
261 write(ounit,'(i8)') iv%info(airep)%levels(n)
262 do k = 1, iv%info(airep)%levels(n)
263 call da_check_missing(iv%airep(n)%u(k)%qc, y%airep(n)%u(k), f1)
264 call da_check_missing(iv%airep(n)%v(k)%qc, y%airep(n)%v(k), f2)
265 call da_check_missing(iv%airep(n)%t(k)%qc, y%airep(n)%t(k), f3)
266 write(ounit,'(2i8,7e15.7)')num_obs, k, f1, f2, f3, dum,dum, &
267 dum,dum
268 end do
269 end if
270 end do
271 end if
272 end if
273
274 ! [8] Transfer pilot obs:
275
276 if (iv%info(pilot)%nlocal > 0) then
277 num_obs = 0
278 do n = 1, iv%info(pilot)%nlocal
279 if (iv%info(pilot)%proc_domain(1,n)) num_obs = num_obs + 1
280 end do
281 if (num_obs > 0) then
282 write(ounit,'(a20,i8)')'pilot', num_obs
283 num_obs = 0
284 do n = 1, iv%info(pilot)%nlocal
285 if (iv%info(pilot)%proc_domain(1,n)) then
286 num_obs = num_obs + 1
287 write(ounit,'(i8)')iv%info(pilot)%levels(n)
288 do k = 1, iv%info(pilot)%levels(n)
289 call da_check_missing(iv%pilot(n)%u(k)%qc, y%pilot(n)%u(k), f1)
290 call da_check_missing(iv%pilot(n)%v(k)%qc, y%pilot(n)%v(k), f2)
291 write(ounit,'(2i8,7e15.7)')num_obs, k, f1, f2, dum,dum,dum, &
292 dum,dum
293 end do
294 end if
295 end do
296 end if
297 end if
298
299 ! [9] Transfer SSM/I obs:SSMI:
300
301 if (iv%info(ssmi_rv)%nlocal > 0) then
302 num_obs = 0
303 do n = 1, iv%info(ssmi_rv)%nlocal
304 if (iv%info(ssmi_rv)%proc_domain(1,n)) num_obs = num_obs + 1
305 end do
306 if (num_obs > 0) then
307 write(ounit,'(a20,i8)')'ssmir', num_obs
308 num_obs = 0
309 do n = 1, iv%info(ssmi_rv)%nlocal
310 if (iv%info(ssmi_rv)%proc_domain(1,n)) then
311 num_obs = num_obs + 1
312 write(ounit,'(i8)') 1
313 call da_check_missing(iv%ssmi_rv(n)%speed%qc, &
314 y % ssmi_rv(n) % speed, f1)
315 call da_check_missing(iv%ssmi_rv(n)% tpw % qc, &
316 y % ssmi_rv(n) % tpw, f2)
317 write(ounit,'(2i8,7e15.7)')num_obs, 1, f1, f2, dum,dum,dum, &
318 dum,dum
319 end if
320 end do
321 end if
322 end if
323
324 if (iv%info(ssmi_tb)%nlocal > 0) then
325 num_obs = 0
326 do n = 1, iv%info(ssmi_tb)%nlocal
327 if (iv%info(ssmi_tb)%proc_domain(1,n)) num_obs = num_obs + 1
328 end do
329 if (num_obs > 0) then
330 write(ounit,'(a20,i8)')'ssmit', num_obs
331 num_obs = 0
332 do n = 1, iv%info(ssmi_tb)%nlocal
333 if (iv%info(ssmi_tb)%proc_domain(1,n)) then
334 num_obs = num_obs + 1
335 write(ounit,'(i8)') 1
336 call da_check_missing(iv%ssmi_tb(n)%tb19h%qc, &
337 y %ssmi_tb(n)%tb19h, f1)
338 call da_check_missing(iv%ssmi_tb(n)%tb19v%qc, &
339 y %ssmi_tb(n)%tb19v, f2)
340 call da_check_missing(iv%ssmi_tb(n)%tb22v%qc, &
341 y %ssmi_tb(n)%tb22v, f3)
342 call da_check_missing(iv%ssmi_tb(n)%tb37h%qc, &
343 y %ssmi_tb(n)%tb37h, f4)
344 call da_check_missing(iv%ssmi_tb(n)%tb37v%qc, &
345 y %ssmi_tb(n)%tb37v, f5)
346 call da_check_missing(iv%ssmi_tb(n)%tb85h%qc, &
347 y %ssmi_tb(n)%tb85h, f6)
348 call da_check_missing(iv%ssmi_tb(n)%tb85v%qc, &
349 y %ssmi_tb(n)%tb85v, f7)
350 write(ounit,'(2i8,7e15.7)')num_obs, 1, f1, f2, f3, f4, f5, f6, f7
351 end if
352 end do
353 end if
354 end if
355
356 ! [10] Transfer satem obs:
357
358 if (iv%info(satem)%nlocal > 0) then
359 num_obs = 0
360 do n = 1, iv%info(satem)%nlocal
361 if (iv%info(satem)%proc_domain(1,n)) num_obs = num_obs + 1
362 end do
363 if (num_obs > 0) then
364 write(ounit,'(a20,i8)')'satem', num_obs
365 num_obs = 0
366 do n = 1, iv%info(satem)%nlocal
367 if (iv%info(satem)%proc_domain(1,n)) then
368 num_obs = num_obs + 1
369 write(ounit,'(i8)')iv%info(satem)%levels(n)
370 do k = 1, iv%info(satem)%levels(n)
371 call da_check_missing(iv%satem(n)%thickness(k)%qc, &
372 y % satem(n) % thickness(k), f1)
373 write(ounit,'(2i8,7e15.7)')num_obs, k, f1, dum,dum,dum,dum, &
374 dum,dum
375 end do
376 end if
377 end do
378 end if
379 end if
380
381 ! [11] Transfer ssmt1 obs:
382
383 if (iv%info(ssmt1)%nlocal > 0) then
384 num_obs = 0
385 do n = 1, iv%info(ssmt1)%nlocal
386 if (iv%info(ssmt1)%proc_domain(1,n)) num_obs = num_obs + 1
387 end do
388 if (num_obs > 0) then
389 write(ounit,'(a20,i8)')'ssmt1', num_obs
390 num_obs = 0
391 do n = 1, iv%info(ssmt1)%nlocal
392 if (iv%info(ssmt1)%proc_domain(1,n)) then
393 num_obs = num_obs + 1
394 write(ounit,'(i8)')iv%info(ssmt1)%levels(n)
395 do k = 1, iv%info(ssmt1)%levels(n)
396 call da_check_missing(iv%ssmt1(n)%t(k)%qc, &
397 y % ssmt1(n) % t(k), f1)
398 write(ounit,'(2i8,7e15.7)')num_obs, k, f1, dum,dum,dum,dum, &
399 dum,dum
400 end do
401 end if
402 end do
403 end if
404 end if
405
406 ! [12] Transfer ssmt2 obs:
407
408 if (iv%info(ssmt2)%nlocal > 0) then
409 num_obs = 0
410 do n = 1, iv%info(ssmt2)%nlocal
411 if (iv%info(ssmt2)%proc_domain(1,n)) num_obs = num_obs + 1
412 end do
413 if (num_obs > 0) then
414 write(ounit,'(a20,i8)')'ssmt2', num_obs
415 num_obs = 0
416 do n = 1, iv%info(ssmt2)%nlocal
417 if (iv%info(ssmt2)%proc_domain(1,n)) then
418 num_obs = num_obs + 1
419 write(ounit,'(i8)')iv%info(ssmt2)%levels(n)
420 do k = 1, iv%info(ssmt2)%levels(n)
421 call da_check_missing(iv%ssmt2(n)%rh(k)%qc, &
422 y % ssmt2(n) % rh(k), f1)
423 write(ounit,'(2i8,7e15.7)')num_obs, k, f1, dum,dum,dum,dum, &
424 dum,dum
425 end do
426 end if
427 end do
428 end if
429 end if
430
431 ! [13] Transfer scatterometer obs:
432
433 if (iv%info(qscat)%nlocal > 0) then
434 num_obs = 0
435 do n = 1, iv%info(qscat)%nlocal
436 if (iv%info(qscat)%proc_domain(1,n)) num_obs = num_obs + 1
437 end do
438 if (num_obs > 0) then
439 write(ounit,'(a20,i8)')'qscat', num_obs
440 num_obs = 0
441 do n = 1, iv%info(qscat)%nlocal
442 if (iv%info(qscat)%proc_domain(1,n)) then
443 num_obs = num_obs + 1
444 write(ounit,'(i8)') 1
445 call da_check_missing(iv%qscat(n)%u%qc, y%qscat(n)%u, f1)
446 call da_check_missing(iv%qscat(n)%v%qc, y%qscat(n)%v, f2)
447 write(ounit,'(2i8,7e15.7)')num_obs, 1, f1, f2, dum,dum,dum, &
448 dum,dum
449 end if
450 end do
451 end if
452 end if
453
454 ! [14] Transfer profiler obs:
455
456 if (iv%info(profiler)%nlocal > 0) then
457 num_obs = 0
458 do n = 1, iv%info(profiler)%nlocal
459 if (iv%info(profiler)%proc_domain(1,n)) num_obs = num_obs + 1
460 end do
461 if (num_obs > 0) then
462 write(ounit,'(a20,i8)')'profiler', num_obs
463 num_obs = 0
464 do n = 1, iv%info(profiler)%nlocal
465 if (iv%info(profiler)%proc_domain(1,n)) then
466 num_obs = num_obs + 1
467 write(ounit,'(i8)')iv%info(profiler)%levels(n)
468 do k = 1, iv%info(profiler)%levels(n)
469 call da_check_missing(iv%profiler(n)%u(k)%qc, &
470 y%profiler(n)%u(k), f1)
471 call da_check_missing(iv%profiler(n)%v(k)%qc, &
472 y%profiler(n)%v(k), f2)
473 write(ounit,'(2i8,7e15.7)')num_obs, k, f1, f2, dum,dum,dum, &
474 dum,dum
475 end do
476 end if
477 end do
478 end if
479 end if
480
481 ! [15] Transfer buoy obs:
482
483 if (iv%info(buoy)%nlocal > 0) then
484 num_obs = 0
485 do n = 1, iv%info(buoy)%nlocal
486 if (iv%info(buoy)%proc_domain(1,n)) num_obs = num_obs + 1
487 end do
488 if (num_obs > 0) then
489 write(ounit,'(a20,i8)')'buoy', num_obs
490 num_obs = 0
491 do n = 1, iv%info(buoy)%nlocal
492 if (iv%info(buoy)%proc_domain(1,n)) then
493 num_obs = num_obs + 1
494 write(ounit,'(i8)') 1
495 call da_check_missing(iv%buoy(n)%u%qc, y%buoy(n)%u, f1)
496 call da_check_missing(iv%buoy(n)%v%qc, y%buoy(n)%v, f2)
497 call da_check_missing(iv%buoy(n)%t%qc, y%buoy(n)%t, f3)
498 call da_check_missing(iv%buoy(n)%p%qc, y%buoy(n)%p, f4)
499 call da_check_missing(iv%buoy(n)%q%qc, y%buoy(n)%q, f5)
500 write(ounit,'(2i8,7e15.7)')num_obs, 1, f1, f2, f3, f4, f5, &
501 dum,dum
502 end if
503 end do
504 end if
505 end if
506
507 ! [16] Transfer TC bogus obs:
508
509 if (iv%info(bogus)%nlocal > 0) then
510 num_obs = 0
511 do n = 1, iv%info(bogus)%nlocal
512 if (iv%info(bogus)%proc_domain(1,n)) num_obs = num_obs + 1
513 end do
514 if (num_obs > 0) then
515 write(ounit,'(a20,i8)')'bogus', num_obs
516 num_obs = 0
517 do n = 1, iv%info(bogus)%nlocal
518 if (iv%info(bogus)%proc_domain(1,n)) then
519 num_obs = num_obs + 1
520 write(ounit,'(i8)') 1
521 write(ounit,'(2i8,7e15.7)')num_obs, 1, f1, dum,dum,dum,dum,dum,dum
522 write(ounit,'(i8)')iv%info(bogus)%levels(n)
523 do k = 1, iv%info(bogus)%levels(n)
524 call da_check_missing(iv%bogus(n)%u(k)%qc, y%bogus(n)%u(k), f2)
525 call da_check_missing(iv%bogus(n)%v(k)%qc, y%bogus(n)%v(k), f3)
526 call da_check_missing(iv%bogus(n)%t(k)%qc, y%bogus(n)%t(k), f4)
527 call da_check_missing(iv%bogus(n)%q(k)%qc, y%bogus(n)%q(k), f5)
528 write(ounit,'(2i8,7e15.7)')num_obs, k, f2, f3, f4, f5, dum, &
529 dum,dum
530 end do
531 end if
532 end do
533 end if
534 end if
535
536 ! [17] Transfer AIRS retrievals:
537
538 if (iv%info(airsr)%nlocal > 0) then
539 num_obs = 0
540 do n = 1, iv%info(airsr)%nlocal
541 if (iv%info(airsr)%proc_domain(1,n)) num_obs = num_obs + 1
542 end do
543 if (num_obs > 0) then
544 write(ounit,'(a20,i8)')'airsr', num_obs
545 num_obs = 0
546 do n = 1, iv%info(airsr)%nlocal
547 if (iv%info(airsr)%proc_domain(1,n)) then
548 num_obs = num_obs + 1
549 write(ounit,'(i8)')iv%info(airsr)%levels(n)
550 do k = 1, iv%info(airsr)%levels(n)
551 call da_check_missing(iv%airsr(n)%t(k)%qc, y%airsr(n)%t(k), f1)
552 call da_check_missing(iv%airsr(n)%q(k)%qc, y%airsr(n)%q(k), f2)
553 write(ounit,'(2i8,7e15.7)')num_obs, k, f1, f2, dum, dum, &
554 dum, dum,dum
555 end do
556 end if
557 end do
558 end if
559 end if
560
561 ! [18] Transfer Radiance obs:
562
563 if (iv%num_inst > 0) then
564 do i = 1, iv%num_inst ! loop for sensor
565 if (iv%instid(i)%num_rad < 1) cycle
566 do k = 1,iv%instid(i)%nchan ! loop for channel
567 ! Counting number of obs for channel k
568 num_obs = 0
569 do n = 1,iv%instid(i)%num_rad ! loop for pixel
570 if (iv%instid(i)%info%proc_domain(1,n) .and. &
571 (iv%instid(i)%tb_qc(k,n) >= obs_qc_pointer)) then
572 num_obs = num_obs + 1
573 end if
574 end do ! end loop for pixel
575 if (num_obs < 1) cycle
576
577 write(ob_name,'(a,a,i4.4)') trim(iv%instid(i)%rttovid_string),'-',k
578 write(ounit,'(a20,i8)') ob_name,num_obs
579
580 num_obs = 0
581 do n= 1, iv%instid(i)%num_rad ! loop for pixel
582 if(iv%instid(i)%info%proc_domain(1,n) .and. &
583 (iv%instid(i)%tb_qc(k,n) >= obs_qc_pointer)) then
584 num_obs = num_obs + 1
585 write(ounit,'(2i8,e15.7)')num_obs, 1, y%instid(i)%tb(k,n)
586 end if
587 end do ! end loop for pixel
588 end do ! end loop for channel
589 end do ! end loop for sensor
590 end if
591
592 ! Transfer gpsref obs:
593
594 if (iv%info(gpsref)%nlocal > 0) then
595 num_obs = 0
596 do n = 1, iv%info(gpsref)%nlocal
597 if (iv%info(gpsref)%proc_domain(1,n)) num_obs = num_obs + 1
598 end do
599 if (num_obs > 0) then
600 write(ounit,'(a20,i8)')'gpsref', num_obs
601 num_obs = 0
602 do n = 1, iv%info(gpsref)%nlocal
603 if (iv%info(gpsref)%proc_domain(1,n)) then
604 num_obs = num_obs + 1
605 write(ounit,'(i8)')iv%info(gpsref)%levels(n)
606 do k = 1, iv%info(gpsref)%levels(n)
607 call da_check_missing(iv%gpsref(n)%ref(k)%qc, y%gpsref(n)%ref(k), f1)
608 write(ounit,'(2i8,7e15.7)')num_obs, k, f1, dum, dum, dum, dum, dum,dum
609 end do
610 end if
611 end do
612 end if
613 end if
614
615 close (ounit)
616 call da_free_unit(ounit)
617
618 if (trace_use) call da_trace_exit("da_write_y")
619
620 end subroutine da_write_y
621
622