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/dev_2802_OBStools/NEMOGCM/TOOLS/OBSTOOLS – NEMO

source: branches/dev_2802_OBStools/NEMOGCM/TOOLS/OBSTOOLS/fbprint.F90 @ 2893

Last change on this file since 2893 was 2893, checked in by djlea, 13 years ago

Adding obs tools to branch
File size: 10.9 KB
Line 
1PROGRAM fbprint
2   USE toolspar_kind 
3   USE obs_fbm
4   USE index_sort
5   IMPLICIT NONE
6   !
7   ! Command line arguments input file
8   !
9#ifndef NOIARGCPROTO
10   INTEGER,EXTERNAL :: iargc
11#endif
12   INTEGER :: nargs
13   CHARACTER(len=256) :: cdinfile,cdbrief
14   LOGICAL :: lbrief, lqcflags, lstat
15   CHARACTER(len=8) :: cdstat
16   INTEGER :: nqc
17   !
18   ! Input data
19   !
20   TYPE(obfbdata) :: obsdata
21   !
22   ! Loop variables
23   !
24   INTEGER :: ii
25   !
26   ! Sorting
27   !
28   REAL(KIND=dp),ALLOCATABLE :: zsort(:,:)
29   INTEGER,ALLOCATABLE  :: iindex(:)
30   !
31   ! Get number of command line arguments
32   !
33   nargs  = IARGC()
34   lbrief = .FALSE.
35   lstat = .FALSE.
36   cdstat = 'XXXXXXX'
37   nqc = 0
38   IF ( (nargs < 1) .OR. (nargs > 3) ) THEN
39      CALL usage()
40   ENDIF
41   IF (( nargs == 2 )) THEN
42      CALL getarg( 1, cdbrief )
43      IF ( cdbrief == '-b' ) THEN
44         lbrief = .TRUE.
45      ELSEIF( cdbrief == '-q' ) THEN
46         lqcflags = .TRUE.
47         nqc=1
48      ELSEIF( cdbrief == '-Q' ) THEN
49         lqcflags = .TRUE.
50         nqc=2
51      ELSEIF( cdbrief == '-B' ) THEN
52         lqcflags = .TRUE.
53         nqc=3
54      ELSE
55         CALL usage
56      ENDIF
57   ENDIF
58   IF (( nargs == 3 )) THEN
59      CALL getarg( 1, cdbrief )
60      IF ( cdbrief == '-s' ) THEN
61         lstat = .TRUE.
62         CALL getarg( 2, cdstat )
63      ELSE
64         CALL usage
65      ENDIF
66   ENDIF
67   CALL getarg( nargs, cdinfile )
68   !
69   ! Get input data
70   !
71   CALL read_obfbdata( TRIM(cdinfile), obsdata )
72   WRITE(*,'(2A,I9,A,I9,A)')TRIM(cdinfile), ' has ', obsdata%nobs ,&
73      & ' observations and a maximum of ', obsdata%nlev, ' levels'
74   !
75   ! Sort the data
76   !   
77   ALLOCATE(zsort(3,obsdata%nobs),iindex(obsdata%nobs))
78   DO ii=1,obsdata%nobs
79      zsort(1,ii)=obsdata%ptim(ii)
80      zsort(2,ii)=obsdata%pphi(ii)
81      zsort(3,ii)=obsdata%plam(ii)
82   ENDDO
83   CALL index_sort_dp_n(zsort,3,iindex,obsdata%nobs)
84   !
85   ! Print the sorted list
86   !   
87   DO ii=1,obsdata%nobs
88      IF (lstat) THEN
89         IF (cdstat /= obsdata%cdwmo(ii)) CYCLE
90      ENDIF
91      IF (lqcflags) THEN
92         CALL print_obs_qc(obsdata,iindex(ii),nqc)
93      ELSE
94         CALL print_obs(obsdata,iindex(ii),lbrief,lqcflags,nqc)
95      ENDIF
96   ENDDO
97
98END PROGRAM fbprint
99
100SUBROUTINE usage
101   WRITE(*,'(A)')'Usage:'
102   WRITE(*,'(A)')'fbprint [-b] [-q] inputfile'
103   WRITE(*,'(A)')'where -b selects brief output'
104   WRITE(*,'(A)')'  and -q selects qc flags rather than extra fields'
105   CALL abort()
106END SUBROUTINE usage
107
108SUBROUTINE print_obs(obsdata,iindex,lshort)
109   USE obs_fbm
110   USE date_utils
111   IMPLICIT NONE
112   TYPE(obfbdata) :: obsdata
113   INTEGER :: iindex
114   LOGICAL :: lshort
115   INTEGER :: jv,ja,je,jk
116   INTEGER :: kj,iyr,imon,iday,ihou,imin,isec
117   LOGICAL :: lskip
118   CHARACTER(len=1024) :: cdfmt1,cdfmt2
119   CHARACTER(len=16) :: cdtmp
120
121   WRITE(*,*)'Fileindex           = ',obsdata%kindex(iindex)
122   WRITE(*,*)'Station identifier  = ',obsdata%cdwmo(iindex)
123   WRITE(*,*)'Station type        = ',obsdata%cdtyp(iindex)
124   WRITE(*,*)'Latitude            = ',obsdata%pphi(iindex)
125   WRITE(*,*)'Longtude            = ',obsdata%plam(iindex)
126   WRITE(*,*)'Position QC         = ',obsdata%ipqc(iindex)
127   WRITE(*,*)'Observation QC      = ',obsdata%ioqc(iindex)
128   WRITE(*,*)'Julian date         = ',obsdata%ptim(iindex)
129   CALL jul2greg(isec,imin,ihou,iday,imon,iyr,obsdata%ptim(iindex))
130   WRITE(*,'(1X,A,I4,2I2.2)') &
131      &      'Gregorian date      = ',iyr,imon,iday
132   WRITE(*,'(1X,A,I2.2,A1,I2.2,A1,I2.2)') &
133      &      'Time                = ',ihou,':',imin,':',isec
134   IF (.NOT.lshort) THEN
135      DO jv = 1,obsdata%nvar
136         WRITE(*,*)'Variable name       = ',obsdata%cname(jv)
137         WRITE(*,*)'Variable QC         = ',obsdata%ivqc(iindex,jv)
138         IF (obsdata%lgrid) THEN
139            WRITE(*,*)'Grid I              = ',obsdata%iobsi(iindex,jv)
140            WRITE(*,*)'Grid J              = ',obsdata%iobsj(iindex,jv)
141         ENDIF
142      ENDDO
143      cdfmt1='(1X,A8,1X,A8'
144      cdfmt2='(1X,F8.2,1X,I8'
145      DO jv=1, obsdata%nvar
146         cdfmt1 = TRIM(cdfmt1)//',1X,A15,1X,A8'
147         cdfmt2 = TRIM(cdfmt2)//',1X,E15.9,1X,I8'
148         IF (obsdata%nadd>0) THEN
149            WRITE(cdtmp,'(I10)')obsdata%nadd
150            cdfmt1 = TRIM(cdfmt1)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(1X,A15)'
151            cdfmt2 = TRIM(cdfmt2)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(1X,E15.9)'
152         ENDIF
153         IF (obsdata%lgrid) THEN
154            cdfmt1 = TRIM(cdfmt1)//',1X,A10'
155            cdfmt2 = TRIM(cdfmt2)//',1X,I10'
156         ENDIF
157      ENDDO
158      IF (obsdata%next>0) THEN
159         WRITE(cdtmp,'(I10)')obsdata%next
160         cdfmt1 = TRIM(cdfmt1)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(1X,A15)'
161         cdfmt2 = TRIM(cdfmt2)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(1X,E15.9)'
162      ENDIF
163      cdfmt1=TRIM(cdfmt1)//')'
164      cdfmt2=TRIM(cdfmt2)//')'
165      IF (obsdata%lgrid) THEN
166         WRITE(*,FMT=cdfmt1)&
167            & 'DEPTH', 'DEP_QC', &
168            & (TRIM(obsdata%cname(jv))//'_OBS', &
169            & TRIM(obsdata%cname(jv))//'_QC' , &
170            & (TRIM(obsdata%cname(jv))//'_'//TRIM(obsdata%caddname(ja)),&
171            & ja = 1, obsdata%nadd ), &
172            & TRIM(obsdata%cname(jv))//'_K' , &
173            & jv = 1, obsdata%nvar ), &
174            & ( TRIM(obsdata%cextname(ja)),&
175            & ja = 1, obsdata%next )
176         DO kj=1,obsdata%nlev
177            IF (obsdata%pdep(kj,iindex)<99999.0) THEN
178               WRITE (*,FMT=cdfmt2) &
179                  & obsdata%pdep(kj,iindex),   &
180                  & obsdata%idqc(kj,iindex),   &
181                  & ( obsdata%pob(kj,iindex,jv), obsdata%ivlqc(kj,iindex,jv), &
182                  & ( obsdata%padd(kj,iindex,ja,jv) , ja=1, obsdata%nadd ), &
183                  & obsdata%iobsk(kj,iindex,jv), &
184                  & jv = 1, obsdata%nvar ), &
185                  & ( obsdata%pext(kj,iindex,ja), ja=1, obsdata%next )
186            ENDIF
187         ENDDO
188      ELSE
189         cdfmt1=TRIM(cdfmt1)//')'
190         cdfmt2=TRIM(cdfmt2)//')'
191         WRITE(*,FMT=cdfmt1)&
192            & 'DEPTH', 'DEP_QC', &
193            & (TRIM(obsdata%cname(jv))//'_OBS', &
194            & TRIM(obsdata%cname(jv))//'_QC' , &
195            & (TRIM(obsdata%cname(jv))//TRIM(obsdata%caddname(ja)),&
196            & ja = 1, obsdata%nadd ), &
197            & jv = 1, obsdata%nvar ), &
198            & ( TRIM(obsdata%cextname(ja)),&
199            & ja = 1, obsdata%next )
200         DO kj=1,obsdata%nlev
201            IF (obsdata%pdep(kj,iindex)<99999.0) THEN
202               WRITE (*,FMT=cdfmt2) &
203                  & obsdata%pdep(kj,iindex),   &
204                  & obsdata%idqc(kj,iindex),   &
205                  & ( obsdata%pob(kj,iindex,jv), obsdata%ivlqc(kj,iindex,jv), &
206                  & ( obsdata%padd(kj,iindex,ja,jv) , ja=1, obsdata%nadd ), &
207                  & jv = 1, obsdata%nvar ), &
208                     & ( obsdata%pext(kj,iindex,ja), ja=1, obsdata%next )
209            ENDIF
210         ENDDO
211      ENDIF
212   ENDIF
213   WRITE(*,*)
214END SUBROUTINE print_obs
215
216SUBROUTINE print_obs_qc(obsdata,iindex,kqc)
217   USE obs_fbm
218   USE date_utils
219   IMPLICIT NONE
220   TYPE(obfbdata) :: obsdata
221   INTEGER :: iindex
222   LOGICAL :: lqc
223   INTEGER :: kqc
224   INTEGER :: jv,ja,je,jk
225   INTEGER :: kj,iyr,imon,iday,ihou,imin,isec
226   LOGICAL :: lskip
227   CHARACTER(len=1024) :: cdfmt1,cdfmt2
228   CHARACTER(len=16) :: cdtmp
229   integer :: iqcf
230
231   IF (kqc==2) THEN
232      lskip=.TRUE.
233      IF (obsdata%ipqc(iindex)>1) lskip=.FALSE.
234      IF (obsdata%ioqc(iindex)>1) lskip=.FALSE.
235      DO jv = 1,obsdata%nvar
236         IF (obsdata%ivqc(iindex,jv)>1) lskip=.FALSE.
237      ENDDO
238      DO kj=1,obsdata%nlev
239         IF (obsdata%pdep(kj,iindex)<99999.0) THEN
240            IF (obsdata%idqc(kj,iindex)>1) lskip=.FALSE.
241            DO jv = 1, obsdata%nvar
242               IF (obsdata%ivlqc(kj,iindex,jv)>1) lskip=.FALSE.
243            ENDDO
244         ENDIF
245      ENDDO
246      IF (lskip) RETURN
247   ELSEIF (kqc==3) THEN
248      lskip=.TRUE.
249      DO kj=1,obsdata%nlev
250         IF (obsdata%pdep(kj,iindex)<99999.0) THEN
251            iqcf=0
252            DO jv = 1, obsdata%nvar
253               IF (obsdata%ivlqc(kj,iindex,jv)>1) iqcf=iqcf+1
254               IF (iqcf==obsdata%nvar) lskip=.FALSE.
255            ENDDO
256         ENDIF
257      ENDDO
258      IF (lskip) RETURN
259   ENDIF
260   WRITE(*,*)'Fileindex           = ',obsdata%kindex(iindex)
261   WRITE(*,*)'Station identifier  = ',obsdata%cdwmo(iindex)
262   WRITE(*,*)'Station type        = ',obsdata%cdtyp(iindex)
263   WRITE(*,*)'Latitude            = ',obsdata%pphi(iindex)
264   WRITE(*,*)'Longtude            = ',obsdata%plam(iindex)
265   WRITE(*,*)'Position QC         = ',obsdata%ipqc(iindex)
266   WRITE(*,*)'Position QC flags   = ',obsdata%ipqcf(:,iindex)
267   WRITE(*,*)'Observation QC      = ',obsdata%ioqc(iindex)
268   WRITE(*,*)'Observation QC flags= ',obsdata%ioqcf(:,iindex)
269   WRITE(*,*)'Julian date         = ',obsdata%ptim(iindex)
270   CALL jul2greg(isec,imin,ihou,iday,imon,iyr,obsdata%ptim(iindex))
271   WRITE(*,'(1X,A,I4,2I2.2)') &
272      &      'Gregorian date      = ',iyr,imon,iday
273   WRITE(*,'(1X,A,I2.2,A1,I2.2,A1,I2.2)') &
274      &      'Time                = ',ihou,':',imin,':',isec
275   DO jv = 1,obsdata%nvar
276      WRITE(*,*)'Variable name       = ',obsdata%cname(jv)
277      WRITE(*,*)'Variable QC         = ',obsdata%ivqc(iindex,jv)
278      WRITE(*,*)'Variable QC flags   = ',obsdata%ivqcf(:,iindex,jv)
279   ENDDO
280   cdfmt1='(1X,A8,1X,A8'
281   cdfmt2='(1X,F8.2,1X,I8'
282   WRITE(cdtmp,'(I10)')obsdata%nqcf
283   cdfmt1 = TRIM(cdfmt1)//',1X,A18'
284   cdfmt2 = TRIM(cdfmt2)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(I9)'
285   DO jv=1, obsdata%nvar
286      cdfmt1 = TRIM(cdfmt1)//',1X,A15,1X,A8'
287      cdfmt2 = TRIM(cdfmt2)//',1X,E15.9,1X,I8'
288      WRITE(cdtmp,'(I10)')obsdata%nqcf
289      cdfmt1 = TRIM(cdfmt1)//',1X,A18'
290      cdfmt2 = TRIM(cdfmt2)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(I9)'
291   ENDDO
292   IF (obsdata%next>0) THEN
293      WRITE(cdtmp,'(I10)')obsdata%next
294      cdfmt1 = TRIM(cdfmt1)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(1X,A15)'
295      cdfmt2 = TRIM(cdfmt2)//',1X,'//TRIM(ADJUSTL(cdtmp))//'(1X,E15.9)'
296   ENDIF
297   cdfmt1=TRIM(cdfmt1)//')'
298   cdfmt2=TRIM(cdfmt2)//')'
299   WRITE(*,FMT=cdfmt1)&
300      & 'DEPTH', 'DEP_QC', 'DEP_QC_FLAGS', &
301      & (TRIM(obsdata%cname(jv))//'_OBS', &
302      & TRIM(obsdata%cname(jv))//'_QC' , &
303      & TRIM(obsdata%cname(jv))//'_QC_FLAGS',&
304      & jv = 1, obsdata%nvar ), &
305      & ( TRIM(obsdata%cextname(ja)),&
306      & ja = 1, obsdata%next )
307   DO kj=1,obsdata%nlev
308      IF (kqc>=2)  THEN
309         lskip=.TRUE.
310         IF (obsdata%idqc(kj,iindex)>1) lskip=.FALSE.
311         DO jv = 1, obsdata%nvar
312            IF (obsdata%ivlqc(kj,iindex,jv)>1) lskip=.FALSE.
313         ENDDO
314         IF (lskip) CYCLE
315      ENDIF
316      IF (obsdata%pdep(kj,iindex)<99999.0) THEN
317         WRITE (*,FMT=cdfmt2) &
318            & obsdata%pdep(kj,iindex),   &
319            & obsdata%idqc(kj,iindex),   &
320            & ( obsdata%idqcf(ja,kj,iindex), ja = 1, obsdata%nqcf ), &
321            & ( obsdata%pob(kj,iindex,jv), obsdata%ivlqc(kj,iindex,jv), &
322            & ( obsdata%ivlqcf(ja,kj,iindex,jv) , ja=1, obsdata%nqcf ), &
323            & jv = 1, obsdata%nvar ), &
324            & ( obsdata%pext(kj,iindex,ja), ja=1, obsdata%next )
325      ENDIF
326   ENDDO
327   WRITE(*,*)
328
329END SUBROUTINE print_obs_qc
330   
Note: See TracBrowser for help on using the repository browser.