[2945] | 1 | PROGRAM 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] | 272 | CONTAINS |
---|
[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 | |
---|
| 534 | END PROGRAM fbprint |
---|
| 535 | |
---|
[2945] | 536 | |
---|