1 | PROGRAM fbprint |
---|
2 | !!--------------------------------------------------------------------- |
---|
3 | !! |
---|
4 | !! ** PROGRAM fbprint ** |
---|
5 | !! |
---|
6 | !! ** Purpose : Print feedback file contents as text |
---|
7 | !! |
---|
8 | !! ** Method : Use of utilities from obs_fbm. |
---|
9 | !! |
---|
10 | !! ** Action : |
---|
11 | !! |
---|
12 | !! Usage : |
---|
13 | !! fbprint.exe [options] inputfile |
---|
14 | !! Options : |
---|
15 | !! -b shorter output |
---|
16 | !! -q QC flags (nqc=1) select observations based on QC flags |
---|
17 | !! -Q QC flags (nqc=2) select observations based on QC flags |
---|
18 | !! -B QC flags (nqc=3) select observations based on QC flags |
---|
19 | !! -u unsorted |
---|
20 | !! -s ID select station ID |
---|
21 | !! -t TYPE select observation type |
---|
22 | !! -v NUM1-NUM2 select variable range to print by number (default all) |
---|
23 | !! -a NUM1-NUM2 select additional variable range to print by number (default all) |
---|
24 | !! -e NUM1-NUM2 select extra variable range to print by number (default all) |
---|
25 | !! -d output date range |
---|
26 | !! -D print depths |
---|
27 | !! -z use zipped files |
---|
28 | !! |
---|
29 | !! History : |
---|
30 | !! ! 2010 (K. Mogensen) Initial version |
---|
31 | !!---------------------------------------------------------------------- |
---|
32 | USE toolspar_kind |
---|
33 | USE obs_fbm |
---|
34 | USE index_sort |
---|
35 | USE date_utils |
---|
36 | USE proftools |
---|
37 | |
---|
38 | IMPLICIT NONE |
---|
39 | ! |
---|
40 | ! Command line arguments input file |
---|
41 | ! |
---|
42 | #ifndef NOIARGCPROTO |
---|
43 | INTEGER,EXTERNAL :: iargc |
---|
44 | #endif |
---|
45 | INTEGER :: nargs |
---|
46 | CHARACTER(len=256) :: cdinfile, cdbrief |
---|
47 | LOGICAL :: lbrief, lqcflags, lstat, ltyp, lsort, ldaterange, lzinp, ldepths |
---|
48 | CHARACTER(len=ilenwmo) :: cdstat |
---|
49 | CHARACTER(len=ilentyp) :: cdtyp |
---|
50 | INTEGER :: nqc |
---|
51 | INTEGER :: nvar1, nvar2, nadd1, nadd2, next1, next2 |
---|
52 | ! |
---|
53 | ! Input data |
---|
54 | ! |
---|
55 | TYPE(obfbdata) :: obsdata |
---|
56 | ! |
---|
57 | ! Loop variables |
---|
58 | ! |
---|
59 | INTEGER :: ii, iarg, ip |
---|
60 | ! |
---|
61 | ! Sorting |
---|
62 | ! |
---|
63 | INTEGER :: iwmo |
---|
64 | REAL(KIND=dp),ALLOCATABLE :: zsort(:,:) |
---|
65 | INTEGER,ALLOCATABLE :: iindex(:) |
---|
66 | ! |
---|
67 | ! Get number of command line arguments |
---|
68 | ! |
---|
69 | nargs = IARGC() |
---|
70 | lbrief = .FALSE. |
---|
71 | lstat = .FALSE. |
---|
72 | ltyp = .FALSE. |
---|
73 | ldaterange = .FALSE. |
---|
74 | ldepths = .FALSE. |
---|
75 | cdstat = 'XXXXXXX' |
---|
76 | cdtyp = 'XXXX' |
---|
77 | lsort = .TRUE. |
---|
78 | nqc = 0 |
---|
79 | nvar1 = -1 |
---|
80 | nvar2 = -1 |
---|
81 | nadd1 = -1 |
---|
82 | nadd2 = -1 |
---|
83 | next1 = -1 |
---|
84 | next2 = -1 |
---|
85 | lzinp = .FALSE. |
---|
86 | IF ( nargs < 1 ) THEN |
---|
87 | CALL usage() |
---|
88 | ENDIF |
---|
89 | iarg = 1 |
---|
90 | DO |
---|
91 | IF ( iarg == nargs ) EXIT |
---|
92 | CALL getarg( iarg, cdbrief ) |
---|
93 | IF ( cdbrief == '-b' ) THEN |
---|
94 | lbrief = .TRUE. |
---|
95 | iarg = iarg + 1 |
---|
96 | ELSEIF( cdbrief == '-q' ) THEN |
---|
97 | lqcflags = .TRUE. |
---|
98 | nqc=1 |
---|
99 | iarg = iarg + 1 |
---|
100 | ELSEIF( cdbrief == '-Q' ) THEN |
---|
101 | lqcflags = .TRUE. |
---|
102 | nqc=2 |
---|
103 | iarg = iarg + 1 |
---|
104 | ELSEIF( cdbrief == '-B' ) THEN |
---|
105 | lqcflags = .TRUE. |
---|
106 | nqc=3 |
---|
107 | iarg = iarg + 1 |
---|
108 | ELSEIF( cdbrief == '-u' ) THEN |
---|
109 | lsort = .FALSE. |
---|
110 | iarg = iarg + 1 |
---|
111 | ELSEIF ( cdbrief == '-s' ) THEN |
---|
112 | lstat = .TRUE. |
---|
113 | CALL getarg( iarg + 1, cdstat ) |
---|
114 | iarg = iarg + 2 |
---|
115 | ELSEIF ( cdbrief == '-t' ) THEN |
---|
116 | ltyp = .TRUE. |
---|
117 | CALL getarg( iarg + 1, cdtyp ) |
---|
118 | iarg = iarg + 2 |
---|
119 | ELSEIF ( cdbrief == '-v' ) THEN |
---|
120 | CALL getarg( iarg + 1, cdbrief ) |
---|
121 | ip=INDEX(cdbrief,'-') |
---|
122 | IF (ip==0) THEN |
---|
123 | READ(cdbrief,'(I10)') nvar1 |
---|
124 | IF (nvar1==0) THEN |
---|
125 | nvar2=-1 |
---|
126 | ELSE |
---|
127 | nvar2 = nvar1 |
---|
128 | ENDIF |
---|
129 | ELSEIF(ip==1) THEN |
---|
130 | nvar1=1 |
---|
131 | READ(cdbrief(ip+1:),'(I10)') nvar2 |
---|
132 | ELSE |
---|
133 | READ(cdbrief(1:ip-1),'(I10)') nvar1 |
---|
134 | READ(cdbrief(ip+1:),'(I10)') nvar2 |
---|
135 | ENDIF |
---|
136 | iarg = iarg + 2 |
---|
137 | ELSEIF ( cdbrief == '-a' ) THEN |
---|
138 | CALL getarg( iarg + 1, cdbrief ) |
---|
139 | ip=INDEX(cdbrief,'-') |
---|
140 | IF (ip==0) THEN |
---|
141 | READ(cdbrief,'(I10)') nadd1 |
---|
142 | IF (nadd1==0) THEN |
---|
143 | nadd2=-1 |
---|
144 | ELSE |
---|
145 | nadd2 = nadd1 |
---|
146 | ENDIF |
---|
147 | ELSEIF(ip==1) THEN |
---|
148 | nadd1=1 |
---|
149 | READ(cdbrief(ip+1:),'(I10)') nadd2 |
---|
150 | ELSE |
---|
151 | READ(cdbrief(1:ip-1),'(I10)') nadd1 |
---|
152 | READ(cdbrief(ip+1:),'(I10)') nadd2 |
---|
153 | ENDIF |
---|
154 | iarg = iarg + 2 |
---|
155 | ELSEIF ( cdbrief == '-e' ) THEN |
---|
156 | CALL getarg( iarg + 1, cdbrief ) |
---|
157 | ip=INDEX(cdbrief,'-') |
---|
158 | IF (ip==0) THEN |
---|
159 | READ(cdbrief,'(I10)') next1 |
---|
160 | IF (next1==0) THEN |
---|
161 | next2=-1 |
---|
162 | ELSE |
---|
163 | next2 = next1 |
---|
164 | ENDIF |
---|
165 | ELSEIF(ip==1) THEN |
---|
166 | next1=1 |
---|
167 | READ(cdbrief(ip+1:),'(I10)') next2 |
---|
168 | ELSE |
---|
169 | READ(cdbrief(1:ip-1),'(I10)') next1 |
---|
170 | READ(cdbrief(ip+1:),'(I10)') next2 |
---|
171 | ENDIF |
---|
172 | iarg = iarg + 2 |
---|
173 | ELSEIF ( cdbrief == '-d' ) THEN |
---|
174 | ldaterange=.TRUE. |
---|
175 | iarg = iarg + 1 |
---|
176 | ELSEIF ( cdbrief == '-D' ) THEN |
---|
177 | ldepths=.TRUE. |
---|
178 | iarg = iarg + 1 |
---|
179 | ELSEIF ( cdbrief == '-z' ) THEN |
---|
180 | lzinp=.TRUE. |
---|
181 | iarg = iarg + 1 |
---|
182 | ELSE |
---|
183 | CALL usage |
---|
184 | ENDIF |
---|
185 | ENDDO |
---|
186 | CALL getarg( nargs, cdinfile ) |
---|
187 | ! |
---|
188 | ! Get input data |
---|
189 | ! |
---|
190 | IF (lzinp) THEN |
---|
191 | #if defined NOSYSTEM |
---|
192 | WRITE(*,*)'Compressed files need the system subroutine call' |
---|
193 | CALL abort |
---|
194 | #else |
---|
195 | CALL system( 'cp '//TRIM(cdinfile)//' fbprint_tmp.nc.gz' ) |
---|
196 | CALL system( 'gzip -df fbprint_tmp.nc.gz' ) |
---|
197 | CALL read_obfbdata( 'fbprint_tmp.nc', obsdata ) |
---|
198 | CALL system( 'rm -f fbprint_tmp.nc' ) |
---|
199 | #endif |
---|
200 | ELSE |
---|
201 | CALL read_obfbdata( TRIM(cdinfile), obsdata ) |
---|
202 | ENDIF |
---|
203 | CALL sealsfromargo( obsdata ) |
---|
204 | WRITE(*,'(2A,I9,A,I9,A)')TRIM(cdinfile), ' has ', obsdata%nobs ,& |
---|
205 | & ' observations and a maximum of ', obsdata%nlev, ' levels' |
---|
206 | IF (nvar1<0) THEN |
---|
207 | nvar1 = 1 |
---|
208 | nvar2 = obsdata%nvar |
---|
209 | ENDIF |
---|
210 | IF (nadd1<0) THEN |
---|
211 | nadd1 = 1 |
---|
212 | nadd2 = obsdata%nadd |
---|
213 | ENDIF |
---|
214 | IF (next1<0) THEN |
---|
215 | next1 = 1 |
---|
216 | next2 = obsdata%next |
---|
217 | ENDIF |
---|
218 | ! |
---|
219 | ! Sort the data |
---|
220 | ! |
---|
221 | ALLOCATE(zsort(5,obsdata%nobs),iindex(obsdata%nobs)) |
---|
222 | IF (lsort) THEN |
---|
223 | DO ii=1,obsdata%nobs |
---|
224 | zsort(1,ii)=obsdata%ptim(ii) |
---|
225 | zsort(2,ii)=obsdata%pphi(ii) |
---|
226 | zsort(3,ii)=obsdata%plam(ii) |
---|
227 | iwmo = TRANSFER( obsdata%cdwmo(ii)(1:4), iwmo ) |
---|
228 | zsort(4,ii) = iwmo |
---|
229 | iwmo = TRANSFER( obsdata%cdwmo(ii)(5:8), iwmo ) |
---|
230 | zsort(5,ii) = iwmo |
---|
231 | ENDDO |
---|
232 | CALL index_sort_dp_n(zsort,5,iindex,obsdata%nobs) |
---|
233 | ELSE |
---|
234 | DO ii=1,obsdata%nobs |
---|
235 | iindex(ii)=ii |
---|
236 | ENDDO |
---|
237 | ENDIF |
---|
238 | IF (ldaterange) THEN |
---|
239 | IF (obsdata%nobs>0) THEN |
---|
240 | WRITE(*,'(A)')'First observation' |
---|
241 | CALL print_time(obsdata%ptim(1)) |
---|
242 | WRITE(*,'(A)')'Last observation' |
---|
243 | CALL print_time(obsdata%ptim(obsdata%nobs)) |
---|
244 | ENDIF |
---|
245 | ELSE |
---|
246 | ! |
---|
247 | ! Print the sorted list |
---|
248 | ! |
---|
249 | DO ii=1,obsdata%nobs |
---|
250 | IF (lstat) THEN |
---|
251 | IF (TRIM(ADJUSTL(cdstat)) /= & |
---|
252 | &TRIM(ADJUSTL(obsdata%cdwmo(iindex(ii))))) CYCLE |
---|
253 | ENDIF |
---|
254 | IF (ltyp) THEN |
---|
255 | IF (TRIM(ADJUSTL(cdtyp)) /= & |
---|
256 | &TRIM(ADJUSTL(obsdata%cdtyp(iindex(ii))))) CYCLE |
---|
257 | ENDIF |
---|
258 | IF (ldepths) THEN |
---|
259 | CALL print_depths(obsdata,iindex(ii)) |
---|
260 | ELSE |
---|
261 | IF (lqcflags) THEN |
---|
262 | CALL print_obs_qc(obsdata,iindex(ii),nqc,nvar1,nvar2) |
---|
263 | ELSE |
---|
264 | CALL print_obs(obsdata,iindex(ii),lbrief,& |
---|
265 | & nvar1,nvar2,nadd1,nadd2,next1,next2) |
---|
266 | ENDIF |
---|
267 | ENDIF |
---|
268 | ENDDO |
---|
269 | |
---|
270 | ENDIF |
---|
271 | |
---|
272 | CONTAINS |
---|
273 | |
---|
274 | SUBROUTINE usage |
---|
275 | WRITE(*,'(A)')'Usage:' |
---|
276 | WRITE(*,'(A)')'fbprint [options] inputfile' |
---|
277 | CALL abort() |
---|
278 | END SUBROUTINE usage |
---|
279 | |
---|
280 | SUBROUTINE print_depths(obsdata,iindex) |
---|
281 | IMPLICIT NONE |
---|
282 | TYPE(obfbdata) :: obsdata |
---|
283 | INTEGER :: iindex |
---|
284 | INTEGER :: kj |
---|
285 | REAL :: mindep,maxdep |
---|
286 | |
---|
287 | mindep=10000 |
---|
288 | maxdep=0 |
---|
289 | DO kj=1,obsdata%nlev |
---|
290 | IF (obsdata%pdep(kj,iindex)<99999.0) THEN |
---|
291 | IF (obsdata%pdep(kj,iindex)>maxdep) maxdep=obsdata%pdep(kj,iindex) |
---|
292 | IF (obsdata%pdep(kj,iindex)<mindep) mindep=obsdata%pdep(kj,iindex) |
---|
293 | ENDIF |
---|
294 | ENDDO |
---|
295 | |
---|
296 | WRITE(*,*)'Fileindex = ',obsdata%kindex(iindex) |
---|
297 | WRITE(*,*)'Station identifier = ',obsdata%cdwmo(iindex) |
---|
298 | WRITE(*,*)'Station type = ',obsdata%cdtyp(iindex) |
---|
299 | WRITE(*,*)'Latitude = ',obsdata%pphi(iindex) |
---|
300 | WRITE(*,*)'Longtude = ',obsdata%plam(iindex) |
---|
301 | CALL print_time( obsdata%ptim(iindex) ) |
---|
302 | WRITE(*,*)'Position QC = ',obsdata%ipqc(iindex) |
---|
303 | WRITE(*,*)'Observation QC = ',obsdata%ioqc(iindex) |
---|
304 | WRITE(*,*)'Minimum obs. depth = ',mindep |
---|
305 | WRITE(*,*)'Maximum obs. depth = ',maxdep |
---|
306 | WRITE(*,*) |
---|
307 | |
---|
308 | END SUBROUTINE print_depths |
---|
309 | |
---|
310 | SUBROUTINE print_obs(obsdata,iindex,lshort,& |
---|
311 | & kvar1,kvar2,kadd1,kadd2,kext1,kext2) |
---|
312 | IMPLICIT NONE |
---|
313 | TYPE(obfbdata) :: obsdata |
---|
314 | INTEGER :: iindex |
---|
315 | LOGICAL :: lshort |
---|
316 | INTEGER :: kvar1,kvar2,kadd1,kadd2,kext1,kext2 |
---|
317 | INTEGER :: jv,ja,je,jk |
---|
318 | INTEGER :: kj |
---|
319 | LOGICAL :: lskip |
---|
320 | CHARACTER(len=1024) :: cdfmt1,cdfmt2 |
---|
321 | CHARACTER(len=16) :: cdtmp |
---|
322 | |
---|
323 | WRITE(*,*)'Fileindex = ',obsdata%kindex(iindex) |
---|
324 | WRITE(*,*)'Station identifier = ',obsdata%cdwmo(iindex) |
---|
325 | WRITE(*,*)'Station type = ',obsdata%cdtyp(iindex) |
---|
326 | WRITE(*,*)'Latitude = ',obsdata%pphi(iindex) |
---|
327 | WRITE(*,*)'Longtude = ',obsdata%plam(iindex) |
---|
328 | CALL print_time( obsdata%ptim(iindex) ) |
---|
329 | WRITE(*,*)'Position QC = ',obsdata%ipqc(iindex) |
---|
330 | WRITE(*,*)'Observation QC = ',obsdata%ioqc(iindex) |
---|
331 | IF (.NOT.lshort) THEN |
---|
332 | DO jv = kvar1, kvar2 |
---|
333 | WRITE(*,*)'Variable name = ',obsdata%cname(jv) |
---|
334 | WRITE(*,*)'Variable QC = ',obsdata%ivqc(iindex,jv) |
---|
335 | IF (obsdata%lgrid) THEN |
---|
336 | WRITE(*,*)'Grid I = ',obsdata%iobsi(iindex,jv) |
---|
337 | WRITE(*,*)'Grid J = ',obsdata%iobsj(iindex,jv) |
---|
338 | ENDIF |
---|
339 | ENDDO |
---|
340 | cdfmt1='(1X,A8,1X,A8' |
---|
341 | cdfmt2='(1X,F8.2,1X,I8' |
---|
342 | DO jv = kvar1, kvar2 |
---|
343 | cdfmt1 = TRIM(cdfmt1)//',1X,A15,1X,A8' |
---|
344 | cdfmt2 = TRIM(cdfmt2)//',1X,E15.9,1X,I8' |
---|
345 | IF (kadd2-kadd1+1>0) THEN |
---|
346 | WRITE(cdtmp,'(I10)')kadd2-kadd1+1 |
---|
347 | cdfmt1 = TRIM(cdfmt1)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(1X,A15)' |
---|
348 | cdfmt2 = TRIM(cdfmt2)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(1X,E15.9)' |
---|
349 | ENDIF |
---|
350 | IF (obsdata%lgrid) THEN |
---|
351 | cdfmt1 = TRIM(cdfmt1)//',1X,A10' |
---|
352 | cdfmt2 = TRIM(cdfmt2)//',1X,I10' |
---|
353 | ENDIF |
---|
354 | ENDDO |
---|
355 | IF (kext2-kext1+1>0) THEN |
---|
356 | WRITE(cdtmp,'(I10)')kext2-kext1+1 |
---|
357 | cdfmt1 = TRIM(cdfmt1)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(1X,A15)' |
---|
358 | cdfmt2 = TRIM(cdfmt2)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(1X,E15.9)' |
---|
359 | ENDIF |
---|
360 | cdfmt1=TRIM(cdfmt1)//')' |
---|
361 | cdfmt2=TRIM(cdfmt2)//')' |
---|
362 | IF (obsdata%lgrid) THEN |
---|
363 | WRITE(*,FMT=cdfmt1)& |
---|
364 | & 'DEPTH', 'DEP_QC', & |
---|
365 | & (TRIM(obsdata%cname(jv))//'_OBS', & |
---|
366 | & TRIM(obsdata%cname(jv))//'_QC' , & |
---|
367 | & (TRIM(obsdata%cname(jv))//'_'//TRIM(obsdata%caddname(ja)),& |
---|
368 | & ja = kadd1, kadd2 ), & |
---|
369 | & TRIM(obsdata%cname(jv))//'_K' , & |
---|
370 | & jv = kvar1, kvar2 ), & |
---|
371 | & ( TRIM(obsdata%cextname(ja)),& |
---|
372 | & ja = kext1, kext2 ) |
---|
373 | DO kj=1,obsdata%nlev |
---|
374 | IF (obsdata%pdep(kj,iindex)<99999.0) THEN |
---|
375 | WRITE (*,FMT=cdfmt2) & |
---|
376 | & obsdata%pdep(kj,iindex), & |
---|
377 | & obsdata%idqc(kj,iindex), & |
---|
378 | & ( obsdata%pob(kj,iindex,jv), obsdata%ivlqc(kj,iindex,jv), & |
---|
379 | & ( obsdata%padd(kj,iindex,ja,jv) , ja = kadd1, kadd2 ), & |
---|
380 | & obsdata%iobsk(kj,iindex,jv), & |
---|
381 | & jv = kvar1, kvar2 ), & |
---|
382 | & ( obsdata%pext(kj,iindex,ja), ja = kext1, kext2 ) |
---|
383 | ENDIF |
---|
384 | ENDDO |
---|
385 | ELSE |
---|
386 | cdfmt1=TRIM(cdfmt1)//')' |
---|
387 | cdfmt2=TRIM(cdfmt2)//')' |
---|
388 | WRITE(*,FMT=cdfmt1)& |
---|
389 | & 'DEPTH', 'DEP_QC', & |
---|
390 | & (TRIM(obsdata%cname(jv))//'_OBS', & |
---|
391 | & TRIM(obsdata%cname(jv))//'_QC' , & |
---|
392 | & (TRIM(obsdata%cname(jv))//TRIM(obsdata%caddname(ja)),& |
---|
393 | & ja = kadd1, kadd2 ), & |
---|
394 | & jv = kvar1, kvar2 ), & |
---|
395 | & ( TRIM(obsdata%cextname(ja)),& |
---|
396 | & ja = kext1, kext2 ) |
---|
397 | DO kj=1,obsdata%nlev |
---|
398 | IF (obsdata%pdep(kj,iindex)<99999.0) THEN |
---|
399 | WRITE (*,FMT=cdfmt2) & |
---|
400 | & obsdata%pdep(kj,iindex), & |
---|
401 | & obsdata%idqc(kj,iindex), & |
---|
402 | & ( obsdata%pob(kj,iindex,jv), obsdata%ivlqc(kj,iindex,jv), & |
---|
403 | & ( obsdata%padd(kj,iindex,ja,jv) , ja = kadd1, kadd2 ), & |
---|
404 | & jv = kvar1, kvar2 ), & |
---|
405 | & ( obsdata%pext(kj,iindex,ja), ja = kext1, kext2 ) |
---|
406 | ENDIF |
---|
407 | ENDDO |
---|
408 | ENDIF |
---|
409 | ENDIF |
---|
410 | WRITE(*,*) |
---|
411 | END SUBROUTINE print_obs |
---|
412 | |
---|
413 | SUBROUTINE print_obs_qc(obsdata,iindex,kqc,kvar1,kvar2) |
---|
414 | IMPLICIT NONE |
---|
415 | TYPE(obfbdata) :: obsdata |
---|
416 | INTEGER :: iindex |
---|
417 | LOGICAL :: lqc |
---|
418 | INTEGER :: kqc |
---|
419 | INTEGER :: kvar1,kvar2 |
---|
420 | INTEGER :: jv,ja,je,jk |
---|
421 | INTEGER :: kj |
---|
422 | LOGICAL :: lskip |
---|
423 | CHARACTER(len=1024) :: cdfmt1,cdfmt2 |
---|
424 | CHARACTER(len=16) :: cdtmp |
---|
425 | INTEGER :: iqcf |
---|
426 | |
---|
427 | IF (kqc==2) THEN |
---|
428 | lskip=.TRUE. |
---|
429 | IF (obsdata%ipqc(iindex)>1) lskip=.FALSE. |
---|
430 | IF (obsdata%ioqc(iindex)>1) lskip=.FALSE. |
---|
431 | DO jv = kvar1, kvar2 |
---|
432 | IF (obsdata%ivqc(iindex,jv)>1) lskip=.FALSE. |
---|
433 | ENDDO |
---|
434 | DO kj=1,obsdata%nlev |
---|
435 | IF (obsdata%pdep(kj,iindex)<99999.0) THEN |
---|
436 | IF (obsdata%idqc(kj,iindex)>1) lskip=.FALSE. |
---|
437 | DO jv = kvar1, kvar2 |
---|
438 | IF (obsdata%ivlqc(kj,iindex,jv)>1) lskip=.FALSE. |
---|
439 | ENDDO |
---|
440 | ENDIF |
---|
441 | ENDDO |
---|
442 | IF (lskip) RETURN |
---|
443 | ELSEIF (kqc==3) THEN |
---|
444 | lskip=.TRUE. |
---|
445 | DO kj=1,obsdata%nlev |
---|
446 | IF (obsdata%pdep(kj,iindex)<99999.0) THEN |
---|
447 | iqcf=0 |
---|
448 | DO jv = kvar1, kvar2 |
---|
449 | IF (obsdata%ivlqc(kj,iindex,jv)>1) iqcf=iqcf+1 |
---|
450 | IF (iqcf==obsdata%nvar) lskip=.FALSE. |
---|
451 | ENDDO |
---|
452 | ENDIF |
---|
453 | ENDDO |
---|
454 | IF (lskip) RETURN |
---|
455 | ENDIF |
---|
456 | WRITE(*,*)'Fileindex = ',obsdata%kindex(iindex) |
---|
457 | WRITE(*,*)'Station identifier = ',obsdata%cdwmo(iindex) |
---|
458 | WRITE(*,*)'Station type = ',obsdata%cdtyp(iindex) |
---|
459 | WRITE(*,*)'Latitude = ',obsdata%pphi(iindex) |
---|
460 | WRITE(*,*)'Longtude = ',obsdata%plam(iindex) |
---|
461 | CALL print_time( obsdata%ptim(iindex) ) |
---|
462 | WRITE(*,*)'Position QC = ',obsdata%ipqc(iindex) |
---|
463 | WRITE(*,*)'Position QC flags = ',obsdata%ipqcf(:,iindex) |
---|
464 | WRITE(*,*)'Observation QC = ',obsdata%ioqc(iindex) |
---|
465 | WRITE(*,*)'Observation QC flags= ',obsdata%ioqcf(:,iindex) |
---|
466 | DO jv = kvar1, kvar2 |
---|
467 | WRITE(*,*)'Variable name = ',obsdata%cname(jv) |
---|
468 | WRITE(*,*)'Variable QC = ',obsdata%ivqc(iindex,jv) |
---|
469 | WRITE(*,*)'Variable QC flags = ',obsdata%ivqcf(:,iindex,jv) |
---|
470 | ENDDO |
---|
471 | cdfmt1='(1X,A8,1X,A8' |
---|
472 | cdfmt2='(1X,F8.2,1X,I8' |
---|
473 | WRITE(cdtmp,'(I10)')obsdata%nqcf |
---|
474 | cdfmt1 = TRIM(cdfmt1)//',1X,A18' |
---|
475 | cdfmt2 = TRIM(cdfmt2)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(I9)' |
---|
476 | DO jv = kvar1, kvar2 |
---|
477 | cdfmt1 = TRIM(cdfmt1)//',1X,A15,1X,A8' |
---|
478 | cdfmt2 = TRIM(cdfmt2)//',1X,E15.9,1X,I8' |
---|
479 | WRITE(cdtmp,'(I10)')obsdata%nqcf |
---|
480 | cdfmt1 = TRIM(cdfmt1)//',1X,A18' |
---|
481 | cdfmt2 = TRIM(cdfmt2)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(I9)' |
---|
482 | ENDDO |
---|
483 | IF (obsdata%next>0) THEN |
---|
484 | WRITE(cdtmp,'(I10)')obsdata%next |
---|
485 | cdfmt1 = TRIM(cdfmt1)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(1X,A15)' |
---|
486 | cdfmt2 = TRIM(cdfmt2)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(1X,E15.9)' |
---|
487 | ENDIF |
---|
488 | cdfmt1=TRIM(cdfmt1)//')' |
---|
489 | cdfmt2=TRIM(cdfmt2)//')' |
---|
490 | WRITE(*,FMT=cdfmt1)& |
---|
491 | & 'DEPTH', 'DEP_QC', 'DEP_QC_FLAGS', & |
---|
492 | & (TRIM(obsdata%cname(jv))//'_OBS', & |
---|
493 | & TRIM(obsdata%cname(jv))//'_QC' , & |
---|
494 | & TRIM(obsdata%cname(jv))//'_QC_FLAGS',& |
---|
495 | & jv = kvar1, kvar2 ), & |
---|
496 | & ( TRIM(obsdata%cextname(ja)),& |
---|
497 | & ja = 1, obsdata%next ) |
---|
498 | DO kj=1,obsdata%nlev |
---|
499 | IF (kqc>=2) THEN |
---|
500 | lskip=.TRUE. |
---|
501 | IF (obsdata%idqc(kj,iindex)>1) lskip=.FALSE. |
---|
502 | DO jv = kvar1, kvar2 |
---|
503 | IF (obsdata%ivlqc(kj,iindex,jv)>1) lskip=.FALSE. |
---|
504 | ENDDO |
---|
505 | IF (lskip) CYCLE |
---|
506 | ENDIF |
---|
507 | IF (obsdata%pdep(kj,iindex)<99999.0) THEN |
---|
508 | WRITE (*,FMT=cdfmt2) & |
---|
509 | & obsdata%pdep(kj,iindex), & |
---|
510 | & obsdata%idqc(kj,iindex), & |
---|
511 | & ( obsdata%idqcf(ja,kj,iindex), ja = 1, obsdata%nqcf ), & |
---|
512 | & ( obsdata%pob(kj,iindex,jv), obsdata%ivlqc(kj,iindex,jv), & |
---|
513 | & ( obsdata%ivlqcf(ja,kj,iindex,jv) , ja=1, obsdata%nqcf ), & |
---|
514 | & jv = kvar1, kvar2 ), & |
---|
515 | & ( obsdata%pext(kj,iindex,ja), ja=1, obsdata%next ) |
---|
516 | ENDIF |
---|
517 | ENDDO |
---|
518 | WRITE(*,*) |
---|
519 | |
---|
520 | END SUBROUTINE print_obs_qc |
---|
521 | |
---|
522 | SUBROUTINE print_time(ptim) |
---|
523 | IMPLICIT NONE |
---|
524 | REAL(fbdp) :: ptim |
---|
525 | INTEGER:: iyr,imon,iday,ihou,imin,isec |
---|
526 | WRITE(*,*)'Julian date = ',ptim |
---|
527 | CALL jul2greg(isec,imin,ihou,iday,imon,iyr,ptim) |
---|
528 | WRITE(*,'(1X,A,I4,2I2.2)') & |
---|
529 | & 'Gregorian date = ',iyr,imon,iday |
---|
530 | WRITE(*,'(1X,A,I2.2,A1,I2.2,A1,I2.2)') & |
---|
531 | & 'Time = ',ihou,':',imin,':',isec |
---|
532 | END SUBROUTINE print_time |
---|
533 | |
---|
534 | END PROGRAM fbprint |
---|
535 | |
---|
536 | |
---|