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