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