New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
fbprint.F90 in branches/2014/dev_r4650_UKMO12_CFL_diags_take2/NEMOGCM/TOOLS/OBSTOOLS/src – NEMO

source: branches/2014/dev_r4650_UKMO12_CFL_diags_take2/NEMOGCM/TOOLS/OBSTOOLS/src/fbprint.F90 @ 5947

Last change on this file since 5947 was 5947, checked in by timgraham, 8 years ago

Reinstate svn Id keywords before merge
  • Property svn:keywords set to Id
File size: 17.7 KB
RevLine 
[2945]1PROGRAM fbprint
[3000]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 :
[3002]13   !!     fbprint.exe [options] inputfile
[3000]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   !!----------------------------------------------------------------------
[2945]32   USE toolspar_kind 
33   USE obs_fbm
34   USE index_sort
[3000]35   USE date_utils
36   USE proftools
37
[2945]38   IMPLICIT NONE
39   !
40   ! Command line arguments input file
41   !
42#ifndef NOIARGCPROTO
43   INTEGER,EXTERNAL :: iargc
44#endif
45   INTEGER :: nargs
[3000]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
[2945]50   INTEGER :: nqc
[3000]51   INTEGER :: nvar1, nvar2, nadd1, nadd2, next1, next2
[2945]52   !
53   ! Input data
54   !
55   TYPE(obfbdata) :: obsdata
56   !
57   ! Loop variables
58   !
[3000]59   INTEGER :: ii, iarg, ip
[2945]60   !
61   ! Sorting
62   !
[3000]63   INTEGER :: iwmo
[2945]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.
[3000]72   ltyp = .FALSE.
73   ldaterange = .FALSE.
74   ldepths = .FALSE.
[2945]75   cdstat = 'XXXXXXX'
[3000]76   cdtyp = 'XXXX'
77   lsort = .TRUE.
[2945]78   nqc = 0
[3000]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
[2945]87      CALL usage()
88   ENDIF
[3000]89   iarg = 1
90   DO
91      IF ( iarg == nargs ) EXIT
92      CALL getarg( iarg, cdbrief )
[2945]93      IF ( cdbrief == '-b' ) THEN
94         lbrief = .TRUE.
[3000]95         iarg = iarg + 1
[2945]96      ELSEIF( cdbrief == '-q' ) THEN
97         lqcflags = .TRUE.
98         nqc=1
[3000]99         iarg = iarg + 1
[2945]100      ELSEIF( cdbrief == '-Q' ) THEN
101         lqcflags = .TRUE.
102         nqc=2
[3000]103         iarg = iarg + 1
[2945]104      ELSEIF( cdbrief == '-B' ) THEN
105         lqcflags = .TRUE.
106         nqc=3
[3000]107         iarg = iarg + 1
108      ELSEIF( cdbrief == '-u' ) THEN
109         lsort = .FALSE.
110         iarg = iarg + 1
111      ELSEIF ( cdbrief == '-s' ) THEN
[2945]112         lstat = .TRUE.
[3000]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
[2945]182      ELSE
183         CALL usage
184      ENDIF
[3000]185   ENDDO
[2945]186   CALL getarg( nargs, cdinfile )
187   !
188   ! Get input data
189   !
[3000]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 )
[2945]204   WRITE(*,'(2A,I9,A,I9,A)')TRIM(cdinfile), ' has ', obsdata%nobs ,&
205      & ' observations and a maximum of ', obsdata%nlev, ' levels'
[3000]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
[2945]218   !
219   ! Sort the data
220   !   
[3000]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))
[2945]244      ENDIF
[3000]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
[2945]269
[3000]270   ENDIF
[2945]271
[3000]272CONTAINS
[2945]273
[3000]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
[2945]286
[3000]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)
[2945]293         ENDIF
294      ENDDO
[3000]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
[2945]357            cdfmt1 = TRIM(cdfmt1)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(1X,A15)'
358            cdfmt2 = TRIM(cdfmt2)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(1X,E15.9)'
359         ENDIF
[3000]360         cdfmt1=TRIM(cdfmt1)//')'
361         cdfmt2=TRIM(cdfmt2)//')'
[2945]362         IF (obsdata%lgrid) THEN
[3000]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
[2945]408         ENDIF
409      ENDIF
[3000]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
[2945]434         DO kj=1,obsdata%nlev
435            IF (obsdata%pdep(kj,iindex)<99999.0) THEN
[3000]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
[2945]440            ENDIF
441         ENDDO
[3000]442         IF (lskip) RETURN
443      ELSEIF (kqc==3) THEN
444         lskip=.TRUE.
[2945]445         DO kj=1,obsdata%nlev
446            IF (obsdata%pdep(kj,iindex)<99999.0) THEN
[3000]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
[2945]452            ENDIF
453         ENDDO
[3000]454         IF (lskip) RETURN
[2945]455      ENDIF
[3000]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)
[2945]470      ENDDO
[3000]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 )
[2945]498      DO kj=1,obsdata%nlev
[3000]499         IF (kqc>=2)  THEN
500            lskip=.TRUE.
[2945]501            IF (obsdata%idqc(kj,iindex)>1) lskip=.FALSE.
[3000]502            DO jv = kvar1, kvar2
[2945]503               IF (obsdata%ivlqc(kj,iindex,jv)>1) lskip=.FALSE.
504            ENDDO
[3000]505            IF (lskip) CYCLE
[2945]506         ENDIF
507         IF (obsdata%pdep(kj,iindex)<99999.0) THEN
[3000]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 )
[2945]516         ENDIF
517      ENDDO
[3000]518      WRITE(*,*)
519     
520   END SUBROUTINE print_obs_qc
[2945]521
[3000]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
534END PROGRAM fbprint
535
[2945]536   
Note: See TracBrowser for help on using the repository browser.