da_write_noise_to_ob.inc
References to this file elsewhere.
1 subroutine da_write_noise_to_ob (iv)
2
3 !-------------------------------------------------------------------------
4 ! Purpose: Write consolidated obs noise created in da_add_noise_to_ob
5 !-------------------------------------------------------------------------
6
7 implicit none
8
9 type (ob_type), intent(in) :: iv ! Obs and header structure.
10 integer :: n, k,kk,i, iunit
11 integer :: num_obs
12 character(len=filename_len), allocatable :: filename(:)
13 character*20 :: ob_name
14
15 call da_trace_entry("da_write_noise_to_ob")
16
17 #ifdef DM_PARALLEL
18 ! Ensure other processors have written their temporary files
19 call mpi_barrier(comm, ierr)
20 #endif
21 call da_get_unit (iunit)
22 allocate (filename(0:num_procs-1))
23 do k = 0,num_procs-1
24 write(unit=filename(k), fmt='(a,i3.3)')'rand_obs_error.',k
25 end do
26 if (rootproc) then
27 open(unit=rand_unit,file='rand_obs_error',form='formatted', &
28 iostat=ierr,status='new')
29 if (ierr /= 0) &
30 call da_error(__FILE__,__LINE__, (/"Cannot open file rand_obs_error"/))
31 end if
32
33 num_obs = 0
34 if (iv % num_synop > 0) then
35 do n = 1, iv % num_synop
36 if (iv%synop(n)%loc%proc_domain) num_obs = num_obs + 1
37 end do
38 end if
39 call da_proc_sum_int(num_obs)
40 if (num_obs > 0 .and. rootproc) then
41 write(rand_unit,'(a20,i8)')'synop', num_obs
42 num_obs = 0
43 do k = 0,num_procs-1
44 call da_read_rand_unit(filename(k),iunit,num_obs,'synop',5)
45 end do
46 end if
47
48 !------------------------------------------------------------------
49 ! [2] writing Metar
50 !------------------------------------------------------------------
51
52 num_obs = 0
53 if (iv % num_metar > 0) then
54 do n = 1, iv % num_metar
55 if (iv%metar(n)%loc%proc_domain) num_obs = num_obs + 1
56 end do
57 end if
58 call da_proc_sum_int(num_obs)
59 if (num_obs > 0 .and. rootproc) then
60 write(rand_unit,'(a20,20i8)')'metar', num_obs
61 num_obs = 0
62 do k = 0,num_procs-1
63 call da_read_rand_unit(filename(k),iunit,num_obs,'metar',5)
64 end do
65 end if
66
67 !------------------------------------------------------------------
68 ! [3] writing Ships
69 !------------------------------------------------------------------
70
71 num_obs = 0
72 if (iv % num_ships > 0) then
73 do n = 1, iv % num_ships
74 if (iv%ships(n)%loc%proc_domain) num_obs = num_obs + 1
75 end do
76 end if
77 call da_proc_sum_int(num_obs)
78 if (num_obs > 0 .and. rootproc) then
79 write(rand_unit,'(a20,i8)')'ships', num_obs
80 num_obs = 0
81 do k = 0,num_procs-1
82 call da_read_rand_unit(filename(k),iunit,num_obs,'ships',5)
83 end do
84 end if
85
86 !------------------------------------------------------------------
87 ! [4] writing GeoAMV
88 !------------------------------------------------------------------
89
90 num_obs = 0
91 if (iv % num_geoamv > 0) then
92 do n = 1, iv % num_geoamv
93 if (iv%geoamv(n)%loc%proc_domain) num_obs = num_obs + 1
94 end do
95 end if
96 call da_proc_sum_int(num_obs)
97 if (num_obs > 0 .and. rootproc) then
98 write(rand_unit,'(a20,i8)')'geoamv', num_obs
99 num_obs = 0
100 do k = 0,num_procs-1
101 call da_read_rand_unit(filename(k),iunit,num_obs,'geoamv',6)
102 end do
103 end if
104
105 !------------------------------------------------------------------
106 ! [5] writing PolarAMV
107 !------------------------------------------------------------------
108
109 num_obs = 0
110 if (iv % num_polaramv > 0) then
111 do n = 1, iv % num_polaramv
112 if (iv%polaramv(n)%loc%proc_domain) num_obs = num_obs + 1
113 end do
114 end if
115 call da_proc_sum_int(num_obs)
116 if (num_obs > 0 .and. rootproc) then
117 if (rootproc) write(rand_unit,'(a20,i8)')'polaramv', num_obs
118 num_obs = 0
119 do k = 0,num_procs-1
120 call da_read_rand_unit(filename(k),iunit,num_obs,'polaramv',8)
121 end do
122 end if
123
124 !------------------------------------------------------------------
125 ! [5] writing GPSPW
126 !------------------------------------------------------------------
127
128 num_obs = 0
129 if (iv % num_gpspw > 0) then
130 do n = 1, iv % num_gpspw
131 if (iv%gpspw(n)%loc%proc_domain) num_obs = num_obs + 1
132 end do
133 end if
134 call da_proc_sum_int(num_obs)
135 if (num_obs > 0 .and. rootproc) then
136 write(rand_unit,'(a20,i8)')'gpspw', num_obs
137 num_obs = 0
138 do k = 0,num_procs-1
139 call da_read_rand_unit(filename(k),iunit,num_obs,'gpspw',5)
140 end do
141 end if
142
143 !------------------------------------------------------------------
144 ! [6] writing Sonde
145 !------------------------------------------------------------------
146
147 num_obs = 0
148 if (iv % num_sound > 0) then
149 do n = 1, iv % num_sound
150 if (iv%sound(n)%loc%proc_domain) num_obs = num_obs + 1
151 end do
152 end if
153 call da_proc_sum_int(num_obs)
154 if (num_obs > 0 .and. rootproc) then
155 write(rand_unit,'(a20,i8)')'sound', num_obs
156 num_obs = 0
157 do k = 0,num_procs-1
158 call da_read_rand_unit(filename(k),iunit,num_obs,'sound',5)
159 end do
160 ! writing Sonde_sfc
161 if (rootproc) write(rand_unit,'(a20,i8)')'sonde_sfc', num_obs
162 num_obs = 0
163 do k = 0,num_procs-1
164 call da_read_rand_unit(filename(k),iunit,num_obs,'sonde_sfc',9)
165 end do
166 end if
167
168 !------------------------------------------------------------------
169 ! [7] writing Airep
170 !------------------------------------------------------------------
171
172 num_obs = 0
173 if (iv % num_airep > 0) then
174 do n = 1, iv % num_airep
175 if (iv%airep(n)%loc%proc_domain) num_obs = num_obs + 1
176 end do
177 end if
178 call da_proc_sum_int(num_obs)
179 if (num_obs > 0 .and. rootproc) then
180 write(rand_unit,'(a20,i8)')'airep', num_obs
181 num_obs = 0
182 do k = 0,num_procs-1
183 call da_read_rand_unit(filename(k),iunit,num_obs,'airep',5)
184 end do
185 end if
186
187 !------------------------------------------------------------------
188 ! [8] writing Pilot
189 !------------------------------------------------------------------
190
191 num_obs = 0
192 if (iv % num_pilot > 0) then
193 do n = 1, iv % num_pilot
194 if (iv%pilot(n)%loc%proc_domain) num_obs = num_obs + 1
195 end do
196 end if
197 call da_proc_sum_int(num_obs)
198 if (num_obs > 0 .and. rootproc) then
199 write(rand_unit,'(a20,i8)')'pilot', num_obs
200 num_obs = 0
201 do k = 0,num_procs-1
202 call da_read_rand_unit(filename(k),iunit,num_obs,'pilot',5)
203 end do
204 end if
205
206 !------------------------------------------------------------------
207 ! [9] writing SSMI_RETRIEVAL
208 !------------------------------------------------------------------
209
210 num_obs = 0
211 if (iv % num_ssmi_retrieval > 0) then
212 do n = 1, iv % num_ssmi_retrieval
213 if (iv%ssmi_retrieval(n)%loc%proc_domain) num_obs = num_obs + 1
214 end do
215 end if
216 call da_proc_sum_int(num_obs)
217 if (num_obs > 0 .and. rootproc) then
218 write(rand_unit,'(a20,i8)')'ssmir', num_obs
219 num_obs = 0
220 do k = 0,num_procs-1
221 call da_read_rand_unit(filename(k),iunit,num_obs,'ssmir',5)
222 end do
223 end if
224
225 !------------------------------------------------------------------
226 ! [10] writing SSMITB
227 !------------------------------------------------------------------
228
229 num_obs = 0
230 if (iv % num_ssmi_tb > 0) then
231 do n = 1, iv % num_ssmi_tb
232 if (iv%ssmi_tb(n)%loc%proc_domain) num_obs = num_obs + 1
233 end do
234 end if
235 call da_proc_sum_int(num_obs)
236 if (num_obs > 0 .and. rootproc) then
237 write(rand_unit,'(a20,i8)')'ssmiT', num_obs
238 num_obs = 0
239 do k = 0,num_procs-1
240 call da_read_rand_unit(filename(k),iunit,num_obs,'ssmiT',5)
241 end do
242 end if
243
244 !------------------------------------------------------------------
245 ! [11] writing SATEM
246 !------------------------------------------------------------------
247
248 num_obs = 0
249 if (iv % num_satem > 0) then
250 do n = 1, iv % num_satem
251 if (iv%satem(n)%loc%proc_domain) num_obs = num_obs + 1
252 end do
253 end if
254 call da_proc_sum_int(num_obs)
255 if (num_obs > 0 .and. rootproc) then
256 write(rand_unit,'(a20,i8)')'satem', num_obs
257 num_obs = 0
258 do k = 0,num_procs-1
259 call da_read_rand_unit(filename(k),iunit,num_obs,'satem',5)
260 end do
261 end if
262
263 !------------------------------------------------------------------
264 ! [12] writing SSMT1
265 !------------------------------------------------------------------
266
267 num_obs = 0
268 if (iv % num_ssmt1 > 0) then
269 do n = 1, iv % num_ssmt1
270 if (iv%ssmt1(n)%loc%proc_domain) num_obs = num_obs + 1
271 end do
272 end if
273 call da_proc_sum_int(num_obs)
274 if (num_obs > 0 .and. rootproc) then
275 write(rand_unit,'(a20,i8)')'ssmt1', num_obs
276 num_obs = 0
277 do k = 0,num_procs-1
278 call da_read_rand_unit(filename(k),iunit,num_obs,'ssmt1',5)
279 end do
280 end if
281
282 !------------------------------------------------------------------
283 ! [13] writing SSMT2
284 !------------------------------------------------------------------
285
286 num_obs = 0
287 if (iv % num_ssmt2 > 0) then
288 do n = 1, iv % num_ssmt2
289 if (iv%ssmt2(n)%loc%proc_domain) num_obs = num_obs + 1
290 end do
291 end if
292 call da_proc_sum_int(num_obs)
293 if (num_obs > 0 .and. rootproc) then
294 write(rand_unit,'(a20,i8)')'ssmt2', num_obs
295 num_obs = 0
296 do k = 0,num_procs-1
297 call da_read_rand_unit(filename(k),iunit,num_obs,'ssmt2',5)
298 end do
299 end if
300
301 !------------------------------------------------------------------
302 ! [14] writing QSCAT
303 !------------------------------------------------------------------
304
305 num_obs = 0
306 if (iv % num_qscat > 0) then
307 do n = 1, iv % num_qscat
308 if (iv%qscat(n)%loc%proc_domain) num_obs = num_obs + 1
309 end do
310 end if
311 call da_proc_sum_int(num_obs)
312 if (num_obs > 0 .and. rootproc) then
313 write(rand_unit,'(a20,i8)')'qscat', num_obs
314 num_obs = 0
315 do k = 0,num_procs-1
316 call da_read_rand_unit(filename(k),iunit,num_obs,'qscat',5)
317 end do
318 end if
319
320 !------------------------------------------------------------------
321 ! [15] writing Profiler
322 !------------------------------------------------------------------
323
324 num_obs = 0
325 if (iv % num_profiler > 0) then
326 do n = 1, iv % num_profiler
327 if (iv%profiler(n)%loc%proc_domain) num_obs = num_obs + 1
328 end do
329 end if
330 call da_proc_sum_int(num_obs)
331 if (num_obs > 0 .and. rootproc) then
332 write(rand_unit,'(a20,i8)')'profiler', num_obs
333 num_obs = 0
334 do k = 0,num_procs-1
335 call da_read_rand_unit(filename(k),iunit,num_obs,'profiler',8)
336 end do
337 end if
338
339 !------------------------------------------------------------------
340 ! [16] writing Buoy
341 !------------------------------------------------------------------
342
343 num_obs = 0
344 if (iv % num_buoy > 0) then
345 do n = 1, iv % num_buoy
346 if (iv%buoy(n)%loc%proc_domain) num_obs = num_obs + 1
347 end do
348 end if
349 call da_proc_sum_int(num_obs)
350 if (num_obs > 0 .and. rootproc) then
351 write(rand_unit,'(a20,i8)')'buoy', num_obs
352 num_obs = 0
353 do k = 0,num_procs-1
354 call da_read_rand_unit(filename(k),iunit,num_obs,'buoy',4)
355 end do
356 end if
357
358 !------------------------------------------------------------------
359 ! [17] writing Bogus
360 !------------------------------------------------------------------
361
362 num_obs = 0
363 if (iv % num_bogus > 0) then
364 do n = 1, iv % num_bogus
365 if (iv%bogus(n)%loc%proc_domain) num_obs = num_obs + 1
366 end do
367 end if
368 call da_proc_sum_int(num_obs)
369 if (num_obs > 0 .and. rootproc) then
370 write(rand_unit,'(a20,i8)')'bogus', num_obs
371 num_obs = 0
372 do k = 0,num_procs-1
373 call da_read_rand_unit(filename(k),iunit,num_obs,'bogus',5)
374 end do
375 end if
376
377 !------------------------------------------------------------------
378 ! writing AIRS retrievals
379 !------------------------------------------------------------------
380
381 num_obs = 0
382 if (iv % num_airsr > 0) then
383 do n = 1, iv % num_airsr
384 if (iv%airsr(n)%loc%proc_domain) num_obs = num_obs + 1
385 end do
386 end if
387 call da_proc_sum_int(num_obs)
388 if (num_obs > 0 .and. rootproc) then
389 write(rand_unit,'(a20,i8)')'airsr', num_obs
390 num_obs = 0
391 do k = 0,num_procs-1
392 call da_read_rand_unit(filename(k),iunit,num_obs,'airsr',5)
393 end do
394 end if
395
396 !------------------------------------------------------------------
397 ! writing gpsref
398 !------------------------------------------------------------------
399
400 num_obs = 0
401 if (iv % num_gpsref > 0) then
402 do n = 1, iv % num_gpsref
403 if (iv%gpsref(n)%loc%proc_domain) num_obs = num_obs + 1
404 end do
405 end if
406 call da_proc_sum_int(num_obs)
407 if (num_obs > 0 .and. rootproc) then
408 write(rand_unit,'(a20,20i8)')'gpsref', num_obs
409 num_obs = 0
410 do k = 0,num_procs-1
411 call da_read_rand_unit(filename(k),iunit,num_obs,'gpsref',6)
412 end do
413 end if
414
415
416 !------------------------------------------------------------------
417 ! writing Radiance data:
418 !------------------------------------------------------------------
419
420 if (iv%num_inst > 0) then
421 do i = 1, iv%num_inst ! loop for sensor
422 if (iv%instid(i)%num_rad < 1) cycle
423 do k = 1,iv%instid(i)%nchan ! loop for channel
424 ! Counting number of obs for channle k
425 num_obs = 0
426 do n = 1,iv%instid(i)%num_rad ! loop for pixel
427 if (iv%instid(i)%loc(n)%proc_domain .and. &
428 (iv%instid(i)%tb_qc(k,n) >= obs_qc_pointer)) then
429 num_obs = num_obs + 1
430 end if
431 end do ! end loop for pixel
432 call da_proc_sum_int(num_obs)
433 if (rootproc .and. num_obs > 0) then
434 write (ob_name,'(a,a,i2.2)') &
435 trim(iv%instid(i)%rttovid_string),'-',k
436 write (rand_unit,'(a20,i8)') ob_name,num_obs
437 num_obs = 0
438 do kk = 0,num_procs-1
439 call da_read_rand_unit(filename(kk),iunit,num_obs, &
440 trim(ob_name),len(trim(ob_name)))
441 end do
442 end if
443 end do ! end loop for channel
444 end do ! end loop for sensor
445 end if
446
447 call da_free_unit (iunit)
448 deallocate (filename)
449 call da_trace_exit("da_write_noise_to_ob")
450
451 end subroutine da_write_noise_to_ob
452
453