- Timestamp:
- 2019-07-29T11:26:23+02:00 (5 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/UKMO/r8395_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_prep.F90
r11350 r11361 13 13 !! obs_sor : Sort the observation arrays 14 14 !!--------------------------------------------------------------------- 15 USE par_kind, ONLY : wp ! Precision variables 15 !! * Modules used 16 USE par_kind, ONLY : & ! Precision variables 17 & wp 16 18 USE in_out_manager ! I/O manager 17 19 USE obs_profiles_def ! Definitions for storage arrays for profiles … … 22 24 USE obs_inter_sup ! Interpolation support 23 25 USE obs_oper ! Observation operators 24 USE lib_mpp, ONLY : ctl_warn, ctl_stop 26 #if defined key_bdy 27 USE bdy_oce, ONLY : & ! Boundary information 28 idx_bdy, nb_bdy 29 #endif 30 USE lib_mpp, ONLY : & 31 & ctl_warn, ctl_stop 25 32 26 33 IMPLICIT NONE 34 35 !! * Routine accessibility 27 36 PRIVATE 28 37 29 PUBLIC obs_pre_prof ! First level check and screening of profile obs 30 PUBLIC obs_pre_surf ! First level check and screening of surface obs 31 PUBLIC calc_month_len ! Calculate the number of days in the months of a year 38 PUBLIC & 39 & obs_pre_prof, & ! First level check and screening of profile obs 40 & obs_pre_surf, & ! First level check and screening of surface obs 41 & calc_month_len ! Calculate the number of days in the months of a year 32 42 33 43 !!---------------------------------------------------------------------- … … 37 47 !!---------------------------------------------------------------------- 38 48 39 40 49 CONTAINS 41 50 42 SUBROUTINE obs_pre_surf( surfdata, surfdataqc, ld_nea ) 51 SUBROUTINE obs_pre_surf( surfdata, surfdataqc, ld_nea, ld_bound_reject, & 52 kqc_cutoff ) 43 53 !!---------------------------------------------------------------------- 44 54 !! *** ROUTINE obs_pre_sla *** … … 57 67 !! ! 2015-02 (M. Martin) Combined routine for surface types. 58 68 !!---------------------------------------------------------------------- 69 !! * Modules used 59 70 USE par_oce ! Ocean parameters 60 USE dom_oce, ONLY : glamt, gphit, tmask, nproc ! Geographical information 71 USE dom_oce, ONLY : & ! Geographical information 72 & glamt, & 73 & gphit, & 74 & tmask, & 75 & nproc 61 76 !! * Arguments 62 77 TYPE(obs_surf), INTENT(INOUT) :: surfdata ! Full set of surface data 63 TYPE(obs_surf), INTENT(INOUT) :: surfdataqc ! Subset of surface data not failing screening 64 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 65 ! 78 TYPE(obs_surf), INTENT(INOUT) :: surfdataqc ! Subset of surface data not failing screening 79 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 80 LOGICAL, INTENT(IN) :: ld_bound_reject ! Switch for rejecting obs near the boundary 81 INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff ! cut off for QC value 82 !! * Local declarations 83 INTEGER :: iqc_cutoff = 255 ! cut off for QC value 66 84 INTEGER :: iyea0 ! Initial date 67 85 INTEGER :: imon0 ! - (year, month, day, hour, minute) … … 76 94 INTEGER :: inlasobs ! - close to land 77 95 INTEGER :: igrdobs ! - fail the grid search 96 INTEGER :: ibdysobs ! - close to open boundary 78 97 ! Global counters for observations that 79 98 INTEGER :: iotdobsmpp ! - outside time domain … … 82 101 INTEGER :: inlasobsmpp ! - close to land 83 102 INTEGER :: igrdobsmpp ! - fail the grid search 84 LOGICAL, DIMENSION(:), ALLOCATABLE :: llvalid ! SLA data selection 103 INTEGER :: ibdysobsmpp ! - close to open boundary 104 LOGICAL, DIMENSION(:), ALLOCATABLE :: & 105 & llvalid ! SLA data selection 85 106 INTEGER :: jobs ! Obs. loop variable 86 107 INTEGER :: jstp ! Time loop variable 87 108 INTEGER :: inrc ! Time index variable 88 !!---------------------------------------------------------------------- 89 90 IF(lwp) WRITE(numout,*) 'obs_pre_surf : Preparing the surface observations...' 91 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 109 110 IF(lwp) WRITE(numout,*)'obs_pre_surf : Preparing the surface observations...' 111 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 92 112 93 113 ! Initial date initialization (year, month, day, hour, minute) … … 95 115 imon0 = ( ndate0 - iyea0 * 10000 ) / 100 96 116 iday0 = ndate0 - iyea0 * 10000 - imon0 * 100 97 ihou0 = nn_time0 / 10098 imin0 = ( nn_time0 - ihou0 * 100 )117 ihou0 = 0 118 imin0 = 0 99 119 100 120 icycle = no ! Assimilation cycle … … 107 127 ilansobs = 0 108 128 inlasobs = 0 129 ibdysobs = 0 130 131 ! Set QC cutoff to optional value if provided 132 IF ( PRESENT(kqc_cutoff) ) iqc_cutoff=kqc_cutoff 109 133 110 134 ! ----------------------------------------------------------------------- … … 140 164 & tmask(:,:,1), surfdata%nqc, & 141 165 & iosdsobs, ilansobs, & 142 & inlasobs, ld_nea ) 166 & inlasobs, ld_nea, & 167 & ibdysobs, ld_bound_reject, & 168 & iqc_cutoff ) 143 169 144 170 CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) 145 171 CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) 146 172 CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) 173 CALL obs_mpp_sum_integer( ibdysobs, ibdysobsmpp ) 147 174 148 175 ! ----------------------------------------------------------------------- … … 155 182 ALLOCATE( llvalid(surfdata%nsurf) ) 156 183 157 ! We want all data which has qc flags <= 10158 159 llvalid(:) = ( surfdata%nqc(:) <= 10)184 ! We want all data which has qc flags <= iqc_cutoff 185 186 llvalid(:) = ( surfdata%nqc(:) <= iqc_cutoff ) 160 187 161 188 ! The actual copying … … 190 217 & inlasobsmpp 191 218 ENDIF 219 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near open boundary (removed) = ', & 220 & ibdysobsmpp 192 221 WRITE(numout,*) ' '//surfdataqc%cvars(1)//' data accepted = ', & 193 222 & surfdataqc%nsurfmpp … … 222 251 223 252 224 SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var 1, ld_var2, &253 SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var, & 225 254 & kpi, kpj, kpk, & 226 & zmask 1, pglam1, pgphi1, zmask2, pglam2, pgphi2, &227 & ld_nea, kdailyavtypes)255 & zmask, pglam, pgphi, & 256 & ld_nea, ld_bound_reject, kdailyavtypes, kqc_cutoff ) 228 257 229 258 !!---------------------------------------------------------------------- … … 241 270 !! 242 271 !!---------------------------------------------------------------------- 243 USE par_oce ! Ocean parameters 244 USE dom_oce, ONLY : gdept_1d, nproc ! Geographical information 272 !! * Modules used 273 USE par_oce ! Ocean parameters 274 USE dom_oce, ONLY : & ! Geographical information 275 & gdept_1d, & 276 & nproc 245 277 246 278 !! * Arguments 247 279 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data 248 280 TYPE(obs_prof), INTENT(INOUT) :: prodatqc ! Subset of profile data not failing screening 249 LOGICAL, INTENT(IN) :: ld_var1 ! Observed variables switches250 LOGICAL, INTENT(IN) :: ld_var2281 LOGICAL, DIMENSION(profdata%nvar), INTENT(IN) :: & 282 & ld_var ! Observed variables switches 251 283 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 284 LOGICAL, INTENT(IN) :: ld_bound_reject ! Switch for rejecting observations near the boundary 252 285 INTEGER, INTENT(IN) :: kpi, kpj, kpk ! Local domain sizes 253 286 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 254 287 & kdailyavtypes ! Types for daily averages 255 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 256 & zmask1, & 257 & zmask2 258 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 259 & pglam1, & 260 & pglam2, & 261 & pgphi1, & 262 & pgphi2 288 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk,profdata%nvar) :: & 289 & zmask 290 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,profdata%nvar) :: & 291 & pglam, & 292 & pgphi 293 INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff ! cut off for QC value 263 294 264 295 !! * Local declarations 296 INTEGER :: iqc_cutoff = 255 ! cut off for QC value 265 297 INTEGER :: iyea0 ! Initial date 266 298 INTEGER :: imon0 ! - (year, month, day, hour, minute) … … 269 301 INTEGER :: imin0 270 302 INTEGER :: icycle ! Current assimilation cycle 271 ! Counters for observations that are 272 INTEGER :: iotdobs ! - outside time domain 273 INTEGER :: iosdv1obs ! - outside space domain (variable 1) 274 INTEGER :: iosdv2obs ! - outside space domain (variable 2) 275 INTEGER :: ilanv1obs ! - within a model land cell (variable 1) 276 INTEGER :: ilanv2obs ! - within a model land cell (variable 2) 277 INTEGER :: inlav1obs ! - close to land (variable 1) 278 INTEGER :: inlav2obs ! - close to land (variable 2) 279 INTEGER :: igrdobs ! - fail the grid search 280 INTEGER :: iuvchku ! - reject u if v rejected and vice versa 281 INTEGER :: iuvchkv ! 282 ! Global counters for observations that are 283 INTEGER :: iotdobsmpp ! - outside time domain 284 INTEGER :: iosdv1obsmpp ! - outside space domain (variable 1) 285 INTEGER :: iosdv2obsmpp ! - outside space domain (variable 2) 286 INTEGER :: ilanv1obsmpp ! - within a model land cell (variable 1) 287 INTEGER :: ilanv2obsmpp ! - within a model land cell (variable 2) 288 INTEGER :: inlav1obsmpp ! - close to land (variable 1) 289 INTEGER :: inlav2obsmpp ! - close to land (variable 2) 290 INTEGER :: igrdobsmpp ! - fail the grid search 291 INTEGER :: iuvchkumpp ! - reject var1 if var2 rejected and vice versa 292 INTEGER :: iuvchkvmpp ! 303 ! Counters for observations that are 304 INTEGER :: iotdobs ! - outside time domain 305 INTEGER, DIMENSION(profdata%nvar) :: iosdvobs ! - outside space domain 306 INTEGER, DIMENSION(profdata%nvar) :: ilanvobs ! - within a model land cell 307 INTEGER, DIMENSION(profdata%nvar) :: inlavobs ! - close to land 308 INTEGER, DIMENSION(profdata%nvar) :: ibdyvobs ! - boundary 309 INTEGER :: igrdobs ! - fail the grid search 310 INTEGER :: iuvchku ! - reject UVEL if VVEL rejected 311 INTEGER :: iuvchkv ! - reject VVEL if UVEL rejected 312 ! Global counters for observations that are 313 INTEGER :: iotdobsmpp ! - outside time domain 314 INTEGER, DIMENSION(profdata%nvar) :: iosdvobsmpp ! - outside space domain 315 INTEGER, DIMENSION(profdata%nvar) :: ilanvobsmpp ! - within a model land cell 316 INTEGER, DIMENSION(profdata%nvar) :: inlavobsmpp ! - close to land 317 INTEGER, DIMENSION(profdata%nvar) :: ibdyvobsmpp ! - boundary 318 INTEGER :: igrdobsmpp ! - fail the grid search 319 INTEGER :: iuvchkumpp ! - reject UVEL if VVEL rejected 320 INTEGER :: iuvchkvmpp ! - reject VVEL if UVEL rejected 293 321 TYPE(obs_prof_valid) :: llvalid ! Profile selection 294 322 TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & 295 & llvvalid ! var 1,var2selection323 & llvvalid ! vars selection 296 324 INTEGER :: jvar ! Variable loop variable 297 325 INTEGER :: jobs ! Obs. loop variable 298 326 INTEGER :: jstp ! Time loop variable 299 327 INTEGER :: inrc ! Time index variable 300 !!---------------------------------------------------------------------- 328 CHARACTER(LEN=256) :: cout1 ! Diagnostic output line 329 CHARACTER(LEN=256) :: cout2 ! Diagnostic output line 301 330 302 331 IF(lwp) WRITE(numout,*)'obs_pre_prof: Preparing the profile data...' … … 307 336 imon0 = ( ndate0 - iyea0 * 10000 ) / 100 308 337 iday0 = ndate0 - iyea0 * 10000 - imon0 * 100 309 ihou0 = nn_time0 / 100310 imin0 = ( nn_time0 - ihou0 * 100 )338 ihou0 = 0 339 imin0 = 0 311 340 312 341 icycle = no ! Assimilation cycle 313 342 314 ! Diagnotics counters for various failures. 315 316 iotdobs = 0 317 igrdobs = 0 318 iosdv1obs = 0 319 iosdv2obs = 0 320 ilanv1obs = 0 321 ilanv2obs = 0 322 inlav1obs = 0 323 inlav2obs = 0 324 iuvchku = 0 325 iuvchkv = 0 343 ! Diagnostics counters for various failures. 344 345 iotdobs = 0 346 igrdobs = 0 347 iosdvobs(:) = 0 348 ilanvobs(:) = 0 349 inlavobs(:) = 0 350 ibdyvobs(:) = 0 351 iuvchku = 0 352 iuvchkv = 0 353 354 355 ! Set QC cutoff to optional value if provided 356 IF ( PRESENT(kqc_cutoff) ) iqc_cutoff=kqc_cutoff 326 357 327 358 ! ----------------------------------------------------------------------- … … 335 366 & profdata%nday, profdata%nhou, profdata%nmin, & 336 367 & profdata%ntyp, profdata%nqc, profdata%mstp, & 337 & iotdobs, kdailyavtypes = kdailyavtypes ) 368 & iotdobs, kdailyavtypes = kdailyavtypes, & 369 & kqc_cutoff = iqc_cutoff ) 338 370 ELSE 339 371 CALL obs_coo_tim_prof( icycle, & … … 342 374 & profdata%nday, profdata%nhou, profdata%nmin, & 343 375 & profdata%ntyp, profdata%nqc, profdata%mstp, & 344 & iotdobs )376 & iotdobs, kqc_cutoff = iqc_cutoff ) 345 377 ENDIF 346 378 … … 351 383 ! ----------------------------------------------------------------------- 352 384 353 CALL obs_coo_grd( profdata%nprof, profdata%mi(:,1), profdata%mj(:,1), &354 & profdata%nqc, igrdobs )355 CALL obs_coo_grd( profdata%nprof, profdata%mi(:,2), profdata%mj(:,2), &356 & profdata%nqc, igrdobs )385 DO jvar = 1, profdata%nvar 386 CALL obs_coo_grd( profdata%nprof, profdata%mi(:,jvar), profdata%mj(:,jvar), & 387 & profdata%nqc, igrdobs ) 388 END DO 357 389 358 390 CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) 359 391 360 392 ! ----------------------------------------------------------------------- 361 ! Reject all observations for profiles with nqc > 10362 ! ----------------------------------------------------------------------- 363 364 CALL obs_pro_rej( profdata )393 ! Reject all observations for profiles with nqc > iqc_cutoff 394 ! ----------------------------------------------------------------------- 395 396 CALL obs_pro_rej( profdata, kqc_cutoff = iqc_cutoff ) 365 397 366 398 ! ----------------------------------------------------------------------- … … 369 401 ! ----------------------------------------------------------------------- 370 402 371 ! Variable 1 372 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(1), & 373 & profdata%npvsta(:,1), profdata%npvend(:,1), & 374 & jpi, jpj, & 375 & jpk, & 376 & profdata%mi, profdata%mj, & 377 & profdata%var(1)%mvk, & 378 & profdata%rlam, profdata%rphi, & 379 & profdata%var(1)%vdep, & 380 & pglam1, pgphi1, & 381 & gdept_1d, zmask1, & 382 & profdata%nqc, profdata%var(1)%nvqc, & 383 & iosdv1obs, ilanv1obs, & 384 & inlav1obs, ld_nea ) 385 386 CALL obs_mpp_sum_integer( iosdv1obs, iosdv1obsmpp ) 387 CALL obs_mpp_sum_integer( ilanv1obs, ilanv1obsmpp ) 388 CALL obs_mpp_sum_integer( inlav1obs, inlav1obsmpp ) 389 390 ! Variable 2 391 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(2), & 392 & profdata%npvsta(:,2), profdata%npvend(:,2), & 393 & jpi, jpj, & 394 & jpk, & 395 & profdata%mi, profdata%mj, & 396 & profdata%var(2)%mvk, & 397 & profdata%rlam, profdata%rphi, & 398 & profdata%var(2)%vdep, & 399 & pglam2, pgphi2, & 400 & gdept_1d, zmask2, & 401 & profdata%nqc, profdata%var(2)%nvqc, & 402 & iosdv2obs, ilanv2obs, & 403 & inlav2obs, ld_nea ) 404 405 CALL obs_mpp_sum_integer( iosdv2obs, iosdv2obsmpp ) 406 CALL obs_mpp_sum_integer( ilanv2obs, ilanv2obsmpp ) 407 CALL obs_mpp_sum_integer( inlav2obs, inlav2obsmpp ) 403 DO jvar = 1, profdata%nvar 404 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(jvar), & 405 & profdata%npvsta(:,jvar), profdata%npvend(:,jvar), & 406 & jpi, jpj, & 407 & jpk, & 408 & profdata%mi, profdata%mj, & 409 & profdata%var(jvar)%mvk, & 410 & profdata%rlam, profdata%rphi, & 411 & profdata%var(jvar)%vdep, & 412 & pglam(:,:,jvar), pgphi(:,:,jvar), & 413 & gdept_1d, zmask(:,:,:,jvar), & 414 & profdata%nqc, profdata%var(jvar)%nvqc, & 415 & iosdvobs(jvar), ilanvobs(jvar), & 416 & inlavobs(jvar), ld_nea, & 417 & ibdyvobs(jvar), ld_bound_reject, & 418 & iqc_cutoff ) 419 420 CALL obs_mpp_sum_integer( iosdvobs(jvar), iosdvobsmpp(jvar) ) 421 CALL obs_mpp_sum_integer( ilanvobs(jvar), ilanvobsmpp(jvar) ) 422 CALL obs_mpp_sum_integer( inlavobs(jvar), inlavobsmpp(jvar) ) 423 CALL obs_mpp_sum_integer( ibdyvobs(jvar), ibdyvobsmpp(jvar) ) 424 END DO 408 425 409 426 ! ----------------------------------------------------------------------- … … 412 429 413 430 IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 414 CALL obs_uv_rej( profdata, iuvchku, iuvchkv )431 CALL obs_uv_rej( profdata, iuvchku, iuvchkv, iqc_cutoff ) 415 432 CALL obs_mpp_sum_integer( iuvchku, iuvchkumpp ) 416 433 CALL obs_mpp_sum_integer( iuvchkv, iuvchkvmpp ) … … 429 446 END DO 430 447 431 ! We want all data which has qc flags = 0432 433 llvalid%luse(:) = ( profdata%nqc(:) <= 10)448 ! We want all data which has qc flags <= iqc_cutoff 449 450 llvalid%luse(:) = ( profdata%nqc(:) <= iqc_cutoff ) 434 451 DO jvar = 1,profdata%nvar 435 llvvalid(jvar)%luse(:) = ( profdata%var(jvar)%nvqc(:) <= 10)452 llvvalid(jvar)%luse(:) = ( profdata%var(jvar)%nvqc(:) <= iqc_cutoff ) 436 453 END DO 437 454 … … 456 473 457 474 WRITE(numout,*) 458 WRITE(numout,*) ' Profiles outside time domain = ', &475 WRITE(numout,*) ' Profiles outside time domain = ', & 459 476 & iotdobsmpp 460 WRITE(numout,*) ' Remaining profiles that failed grid search = ', &477 WRITE(numout,*) ' Remaining profiles that failed grid search = ', & 461 478 & igrdobsmpp 462 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data outside space domain = ', & 463 & iosdv1obsmpp 464 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data at land points = ', & 465 & ilanv1obsmpp 466 IF (ld_nea) THEN 467 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (removed) = ',& 468 & inlav1obsmpp 469 ELSE 470 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (kept) = ',& 471 & inlav1obsmpp 472 ENDIF 473 IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 474 WRITE(numout,*) ' U observation rejected since V rejected = ', & 475 & iuvchku 476 ENDIF 477 WRITE(numout,*) ' '//prodatqc%cvars(1)//' data accepted = ', & 478 & prodatqc%nvprotmpp(1) 479 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data outside space domain = ', & 480 & iosdv2obsmpp 481 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data at land points = ', & 482 & ilanv2obsmpp 483 IF (ld_nea) THEN 484 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (removed) = ',& 485 & inlav2obsmpp 486 ELSE 487 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (kept) = ',& 488 & inlav2obsmpp 489 ENDIF 490 IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 491 WRITE(numout,*) ' V observation rejected since U rejected = ', & 492 & iuvchkv 493 ENDIF 494 WRITE(numout,*) ' '//prodatqc%cvars(2)//' data accepted = ', & 495 & prodatqc%nvprotmpp(2) 479 DO jvar = 1, profdata%nvar 480 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data outside space domain = ', & 481 & iosdvobsmpp(jvar) 482 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data at land points = ', & 483 & ilanvobsmpp(jvar) 484 IF (ld_nea) THEN 485 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (removed) = ',& 486 & inlavobsmpp(jvar) 487 ELSE 488 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (kept) = ',& 489 & inlavobsmpp(jvar) 490 ENDIF 491 IF ( TRIM(profdata%cvars(jvar)) == 'UVEL' ) THEN 492 WRITE(numout,*) ' U observation rejected since V rejected = ', & 493 & iuvchku 494 ELSE IF ( TRIM(profdata%cvars(jvar)) == 'VVEL' ) THEN 495 WRITE(numout,*) ' V observation rejected since U rejected = ', & 496 & iuvchkv 497 ENDIF 498 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near open boundary (removed) = ',& 499 & ibdyvobsmpp(jvar) 500 WRITE(numout,*) ' '//prodatqc%cvars(jvar)//' data accepted = ', & 501 & prodatqc%nvprotmpp(jvar) 502 END DO 496 503 497 504 WRITE(numout,*) 498 505 WRITE(numout,*) ' Number of observations per time step :' 499 506 WRITE(numout,*) 500 WRITE(numout,'(10X,A,5X,A,5X,A,A)')'Time step','Profiles', & 501 & ' '//prodatqc%cvars(1)//' ', & 502 & ' '//prodatqc%cvars(2)//' ' 503 WRITE(numout,998) 507 WRITE(cout1,'(10X,A9,5X,A8)') 'Time step', 'Profiles' 508 WRITE(cout2,'(10X,A9,5X,A8)') '---------', '--------' 509 DO jvar = 1, prodatqc%nvar 510 WRITE(cout1,'(A,5X,A11)') TRIM(cout1), TRIM(prodatqc%cvars(jvar)) 511 WRITE(cout2,'(A,5X,A11)') TRIM(cout2), '-----------' 512 END DO 513 WRITE(numout,*) cout1 514 WRITE(numout,*) cout2 504 515 ENDIF 505 516 … … 528 539 DO jstp = nit000 - 1, nitend 529 540 inrc = jstp - nit000 + 2 530 WRITE(numout,999) jstp, prodatqc%npstpmpp(inrc), & 531 & prodatqc%nvstpmpp(inrc,1), & 532 & prodatqc%nvstpmpp(inrc,2) 541 WRITE(cout1,'(10X,I9,5X,I8)') jstp, prodatqc%npstpmpp(inrc) 542 DO jvar = 1, prodatqc%nvar 543 WRITE(cout1,'(A,5X,I11)') TRIM(cout1), prodatqc%nvstpmpp(inrc,jvar) 544 END DO 545 WRITE(numout,*) cout1 533 546 END DO 534 547 ENDIF 535 536 998 FORMAT(10X,'---------',5X,'--------',5X,'-----------',5X,'----------------')537 999 FORMAT(10X,I9,5X,I8,5X,I11,5X,I8)538 548 539 549 END SUBROUTINE obs_pre_prof … … 644 654 & .AND. ( kobsmin(jobs) <= kmin0 ) ) ) THEN 645 655 kobsstp(jobs) = -1 646 kobsqc(jobs) = kobsqc(jobs) + 11656 kobsqc(jobs) = IBSET(kobsqc(jobs),13) 647 657 kotdobs = kotdobs + 1 648 658 CYCLE … … 695 705 IF ( ( kobsstp(jobs) < ( nit000 - 1 ) ) & 696 706 & .OR.( kobsstp(jobs) > nitend ) ) THEN 697 kobsqc(jobs) = kobsqc(jobs) + 12707 kobsqc(jobs) = IBSET(kobsqc(jobs),13) 698 708 kotdobs = kotdobs + 1 699 709 CYCLE … … 739 749 & kobsno, & 740 750 & kobsyea, kobsmon, kobsday, kobshou, kobsmin, & 741 & ktyp, kobsqc, kobsstp, kotdobs, kdailyavtypes ) 751 & ktyp, kobsqc, kobsstp, kotdobs, kdailyavtypes, & 752 & kqc_cutoff ) 742 753 !!---------------------------------------------------------------------- 743 754 !! *** ROUTINE obs_coo_tim *** … … 783 794 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 784 795 & kdailyavtypes ! Types for daily averages 796 INTEGER, OPTIONAL, INTENT(IN) :: kqc_cutoff ! QC cutoff value 797 785 798 !! * Local declarations 786 799 INTEGER :: jobs 800 INTEGER :: iqc_cutoff=255 787 801 788 802 !----------------------------------------------------------------------- … … 803 817 DO jobs = 1, kobsno 804 818 805 IF ( kobsqc(jobs) <= 10) THEN819 IF ( kobsqc(jobs) <= iqc_cutoff ) THEN 806 820 807 821 IF ( ( kobsstp(jobs) == (nit000 - 1) ).AND.& 808 822 & ( ANY (kdailyavtypes(:) == ktyp(jobs)) ) ) THEN 809 kobsqc(jobs) = kobsqc(jobs) + 14823 kobsqc(jobs) = IBSET(kobsqc(jobs),13) 810 824 kotdobs = kotdobs + 1 811 825 CYCLE … … 850 864 DO jobs = 1, kobsno 851 865 IF ( ( kobsi(jobs) <= 0 ) .AND. ( kobsj(jobs) <= 0 ) ) THEN 852 kobsqc(jobs) = kobsqc(jobs) + 18866 kobsqc(jobs) = IBSET(kobsqc(jobs),12) 853 867 kgrdobs = kgrdobs + 1 854 868 ENDIF … … 861 875 & plam, pphi, pmask, & 862 876 & kobsqc, kosdobs, klanobs, & 863 & knlaobs,ld_nea ) 877 & knlaobs,ld_nea, & 878 & kbdyobs,ld_bound_reject, & 879 & kqc_cutoff ) 864 880 !!---------------------------------------------------------------------- 865 881 !! *** ROUTINE obs_coo_spc_2d *** … … 894 910 INTEGER, DIMENSION(kobsno), INTENT(INOUT) :: & 895 911 & kobsqc ! Observation quality control 896 INTEGER, INTENT(INOUT) :: kosdobs ! Observations outside space domain 897 INTEGER, INTENT(INOUT) :: klanobs ! Observations within a model land cell 898 INTEGER, INTENT(INOUT) :: knlaobs ! Observations near land 899 LOGICAL, INTENT(IN) :: ld_nea ! Flag observations near land 912 INTEGER, INTENT(INOUT) :: kosdobs ! Observations outside space domain 913 INTEGER, INTENT(INOUT) :: klanobs ! Observations within a model land cell 914 INTEGER, INTENT(INOUT) :: knlaobs ! Observations near land 915 INTEGER, INTENT(INOUT) :: kbdyobs ! Observations near boundary 916 LOGICAL, INTENT(IN) :: ld_nea ! Flag observations near land 917 LOGICAL, INTENT(IN) :: ld_bound_reject ! Flag observations near open boundary 918 INTEGER, INTENT(IN) :: kqc_cutoff ! Cutoff QC value 919 900 920 !! * Local declarations 901 921 REAL(KIND=wp), DIMENSION(2,2,kobsno) :: & 902 922 & zgmsk ! Grid mask 923 #if defined key_bdy 924 REAL(KIND=wp), DIMENSION(2,2,kobsno) :: & 925 & zbmsk ! Boundary mask 926 REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask 927 #endif 903 928 REAL(KIND=wp), DIMENSION(2,2,kobsno) :: & 904 929 & zglam, & ! Model longitude at grid points … … 917 942 ! For invalid points use 2,2 918 943 919 IF ( kobsqc(jobs) >= 10) THEN944 IF ( kobsqc(jobs) >= kqc_cutoff ) THEN 920 945 921 946 igrdi(1,1,jobs) = 1 … … 942 967 943 968 END DO 969 970 #if defined key_bdy 971 ! Create a mask grid points in boundary rim 972 IF (ld_bound_reject) THEN 973 zbdymask(:,:) = 1.0_wp 974 DO ji = 1, nb_bdy 975 DO jj = 1, idx_bdy(ji)%nblen(1) 976 zbdymask(idx_bdy(ji)%nbi(jj,1),idx_bdy(ji)%nbj(jj,1)) = 0.0_wp 977 ENDDO 978 ENDDO 979 980 CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, zbdymask, zbmsk ) 981 ENDIF 982 #endif 944 983 945 984 CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, pmask, zgmsk ) … … 950 989 951 990 ! Skip bad observations 952 IF ( kobsqc(jobs) >= 10) CYCLE991 IF ( kobsqc(jobs) >= kqc_cutoff ) CYCLE 953 992 954 993 ! Flag if the observation falls outside the model spatial domain … … 957 996 & .OR. ( pobsphi(jobs) < -90. ) & 958 997 & .OR. ( pobsphi(jobs) > 90. ) ) THEN 959 kobsqc(jobs) = kobsqc(jobs) + 11998 kobsqc(jobs) = IBSET(kobsqc(jobs),11) 960 999 kosdobs = kosdobs + 1 961 1000 CYCLE … … 964 1003 ! Flag if the observation falls with a model land cell 965 1004 IF ( SUM( zgmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN 966 kobsqc(jobs) = kobsqc(jobs) + 121005 kobsqc(jobs) = IBSET(kobsqc(jobs),10) 967 1006 klanobs = klanobs + 1 968 1007 CYCLE … … 978 1017 IF ( ( ABS( zgphi(ji,jj,jobs) - pobsphi(jobs) ) < 1.0e-6_wp ) & 979 1018 & .AND. & 980 & ( ABS( zglam(ji,jj,jobs) - pobslam(jobs) ) < 1.0e-6_wp )&981 & ) THEN1019 & ( ABS( MOD( zglam(ji,jj,jobs) - pobslam(jobs),360.0) ) & 1020 & < 1.0e-6_wp ) ) THEN 982 1021 lgridobs = .TRUE. 983 1022 iig = ji … … 986 1025 END DO 987 1026 END DO 988 989 ! For observations on the grid reject them if their are at 990 ! a masked point 991 1027 992 1028 IF (lgridobs) THEN 993 1029 IF (zgmsk(iig,ijg,jobs) == 0.0_wp ) THEN 994 kobsqc(jobs) = kobsqc(jobs) + 121030 kobsqc(jobs) = IBSET(kobsqc(jobs),10) 995 1031 klanobs = klanobs + 1 996 1032 CYCLE 997 1033 ENDIF 998 1034 ENDIF 999 1035 1036 1000 1037 ! Flag if the observation falls is close to land 1001 1038 IF ( MINVAL( zgmsk(1:2,1:2,jobs) ) == 0.0_wp) THEN 1002 IF (ld_nea) kobsqc(jobs) = kobsqc(jobs) + 141003 1039 knlaobs = knlaobs + 1 1004 CYCLE 1040 IF (ld_nea) THEN 1041 kobsqc(jobs) = IBSET(kobsqc(jobs),9) 1042 CYCLE 1043 ENDIF 1005 1044 ENDIF 1045 1046 #if defined key_bdy 1047 ! Flag if the observation falls close to the boundary rim 1048 IF (ld_bound_reject) THEN 1049 IF ( MINVAL( zbmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN 1050 kobsqc(jobs) = IBSET(kobsqc(jobs),8) 1051 kbdyobs = kbdyobs + 1 1052 CYCLE 1053 ENDIF 1054 ! for observations on the grid... 1055 IF (lgridobs) THEN 1056 IF (zbmsk(iig,ijg,jobs) == 0.0_wp ) THEN 1057 kobsqc(jobs) = IBSET(kobsqc(jobs),8) 1058 kbdyobs = kbdyobs + 1 1059 CYCLE 1060 ENDIF 1061 ENDIF 1062 ENDIF 1063 #endif 1006 1064 1007 1065 END DO … … 1015 1073 & plam, pphi, pdep, pmask, & 1016 1074 & kpobsqc, kobsqc, kosdobs, & 1017 & klanobs, knlaobs, ld_nea ) 1075 & klanobs, knlaobs, ld_nea, & 1076 & kbdyobs, ld_bound_reject, & 1077 & kqc_cutoff ) 1018 1078 !!---------------------------------------------------------------------- 1019 1079 !! *** ROUTINE obs_coo_spc_3d *** … … 1040 1100 & gdepw_1d, & 1041 1101 & gdepw_0, & 1042 & gdepw_n, & 1102 & gdepw_n, & 1103 #if defined key_vvl 1043 1104 & gdept_n, & 1105 #endif 1044 1106 & ln_zco, & 1045 & ln_zps 1107 & ln_zps, & 1108 & ln_linssh 1046 1109 1047 1110 !! * Arguments … … 1077 1140 INTEGER, INTENT(INOUT) :: klanobs ! Observations within a model land cell 1078 1141 INTEGER, INTENT(INOUT) :: knlaobs ! Observations near land 1142 INTEGER, INTENT(INOUT) :: kbdyobs ! Observations near boundary 1079 1143 LOGICAL, INTENT(IN) :: ld_nea ! Flag observations near land 1144 LOGICAL, INTENT(IN) :: ld_bound_reject ! Flag observations near open boundary 1145 INTEGER, INTENT(IN) :: kqc_cutoff ! Cutoff QC value 1146 1080 1147 !! * Local declarations 1081 1148 REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: & 1082 1149 & zgmsk ! Grid mask 1150 #if defined key_bdy 1151 REAL(KIND=wp), DIMENSION(2,2,kprofno) :: & 1152 & zbmsk ! Boundary mask 1153 REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask 1154 #endif 1083 1155 REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: & 1084 & zgdepw 1156 & zgdepw 1085 1157 REAL(KIND=wp), DIMENSION(2,2,kprofno) :: & 1086 1158 & zglam, & ! Model longitude at grid points … … 1100 1172 ! For invalid points use 2,2 1101 1173 1102 IF ( kpobsqc(jobs) >= 10) THEN1174 IF ( kpobsqc(jobs) >= kqc_cutoff ) THEN 1103 1175 1104 1176 igrdi(1,1,jobs) = 1 … … 1125 1197 1126 1198 END DO 1199 1200 #if defined key_bdy 1201 ! Create a mask grid points in boundary rim 1202 IF (ld_bound_reject) THEN 1203 zbdymask(:,:) = 1.0_wp 1204 DO ji = 1, nb_bdy 1205 DO jj = 1, idx_bdy(ji)%nblen(1) 1206 zbdymask(idx_bdy(ji)%nbi(jj,1),idx_bdy(ji)%nbj(jj,1)) = 0.0_wp 1207 ENDDO 1208 ENDDO 1209 ENDIF 1210 1211 CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, zbdymask, zbmsk ) 1212 #endif 1127 1213 1128 1214 CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, pmask, zgmsk ) 1129 1215 CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, plam, zglam ) 1130 1216 CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, pphi, zgphi ) 1131 IF ( .NOT.( ln_zps .OR. ln_zco ) ) THEN 1132 ! Need to know the bathy depth for each observation for sco 1133 CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, gdepw_n(:,:,:), & 1134 & zgdepw ) 1135 ENDIF 1217 ! Need to know the bathy depth for each observation for sco 1218 CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, gdepw_n(:,:,:), & 1219 & zgdepw ) 1136 1220 1137 1221 DO jobs = 1, kprofno 1138 1222 1139 1223 ! Skip bad profiles 1140 IF ( kpobsqc(jobs) >= 10) CYCLE1224 IF ( kpobsqc(jobs) >= kqc_cutoff ) CYCLE 1141 1225 1142 1226 ! Check if this observation is on a grid point … … 1149 1233 IF ( ( ABS( zgphi(ji,jj,jobs) - pobsphi(jobs) ) < 1.0e-6_wp ) & 1150 1234 & .AND. & 1151 & ( ABS( zglam(ji,jj,jobs) - pobslam(jobs) ) < 1.0e-6_wp ) &1235 & ( ABS( MOD( zglam(ji,jj,jobs) - pobslam(jobs),360.0) ) < 1.0e-6_wp ) & 1152 1236 & ) THEN 1153 1237 lgridobs = .TRUE. … … 1158 1242 END DO 1159 1243 1160 ! Check if next to land 1161 IF ( ANY( zgmsk(1:2,1:2,1,jobs) == 0.0_wp ) ) THEN 1162 ll_next_to_land=.TRUE. 1163 ELSE 1164 ll_next_to_land=.FALSE. 1244 ! Check if next to land 1245 IF ( ANY( zgmsk(1:2,1:2,1,jobs) == 0.0_wp ) ) THEN 1246 ll_next_to_land=.TRUE. 1247 ELSE 1248 ll_next_to_land=.FALSE. 1165 1249 ENDIF 1166 1250 1167 1251 ! Reject observations 1168 1252 … … 1176 1260 & .OR. ( pobsdep(jobsp) < 0.0 ) & 1177 1261 & .OR. ( pobsdep(jobsp) > gdepw_1d(kpk)) ) THEN 1178 kobsqc(jobsp) = kobsqc(jobsp) + 111262 kobsqc(jobsp) = IBSET(kobsqc(jobsp),11) 1179 1263 kosdobs = kosdobs + 1 1180 1264 CYCLE 1181 1265 ENDIF 1182 1266 1183 ! To check if an observations falls within land there are two cases: 1184 ! 1: z-coordibnates, where the check uses the mask 1185 ! 2: terrain following (eg s-coordinates), 1186 ! where we use the depth of the bottom cell to mask observations 1267 ! To check if an observations falls within land there are two cases: 1268 ! 1: z-coordibnates, where the check uses the mask 1269 ! 2: terrain following (eg s-coordinates), 1270 ! where we use the depth of the bottom cell to mask observations 1187 1271 1188 IF( ln_zps .OR. ln_zco ) THEN !(CASE 1) 1189 1190 ! Flag if the observation falls with a model land cell 1191 IF ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) & 1192 & == 0.0_wp ) THEN 1193 kobsqc(jobsp) = kobsqc(jobsp) + 12 1272 IF( (ln_linssh) .AND. ( ln_zps .OR. ln_zco ) ) THEN !(CASE 1) 1273 1274 ! Flag if the observation falls with a model land cell 1275 IF ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) & 1276 & == 0.0_wp ) THEN 1277 kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) 1278 klanobs = klanobs + 1 1279 CYCLE 1280 ENDIF 1281 1282 ! Flag if the observation is close to land 1283 IF ( MINVAL( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) == & 1284 & 0.0_wp) THEN 1285 knlaobs = knlaobs + 1 1286 IF (ld_nea) THEN 1287 kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) 1288 ENDIF 1289 ENDIF 1290 1291 ELSE ! Case 2 1292 ! Flag if the observation is deeper than the bathymetry 1293 ! Or if it is within the mask 1294 IF ( ANY( zgdepw(1:2,1:2,kpk,jobs) < pobsdep(jobsp) ) & 1295 & .OR. & 1296 & ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) & 1297 & == 0.0_wp) ) THEN 1298 kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) 1299 klanobs = klanobs + 1 1300 CYCLE 1301 ENDIF 1302 1303 ! Flag if the observation is close to land 1304 IF ( ll_next_to_land ) THEN 1305 knlaobs = knlaobs + 1 1306 IF (ld_nea) THEN 1307 kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) 1308 ENDIF 1309 ENDIF 1310 1311 ENDIF 1312 1313 ! For observations on the grid reject them if their are at 1314 ! a masked point 1315 1316 IF (lgridobs) THEN 1317 IF (zgmsk(iig,ijg,kobsk(jobsp)-1,jobs) == 0.0_wp ) THEN 1318 kobsqc(jobsp) = IBSET(kobsqc(jobs),10) 1194 1319 klanobs = klanobs + 1 1195 1320 CYCLE 1196 1321 ENDIF 1197 1198 ! Flag if the observation is close to land 1199 IF ( MINVAL( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) == & 1200 & 0.0_wp) THEN 1201 knlaobs = knlaobs + 1 1202 IF (ld_nea) THEN 1203 kobsqc(jobsp) = kobsqc(jobsp) + 14 1204 ENDIF 1205 ENDIF 1206 1207 ELSE ! Case 2 1208 1209 ! Flag if the observation is deeper than the bathymetry 1210 ! Or if it is within the mask 1211 IF ( ALL( zgdepw(1:2,1:2,kpk,jobs) < pobsdep(jobsp) ) & 1212 & .OR. & 1213 & ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) & 1214 & == 0.0_wp) ) THEN 1215 kobsqc(jobsp) = kobsqc(jobsp) + 12 1216 klanobs = klanobs + 1 1217 CYCLE 1218 ENDIF 1219 1220 ! Flag if the observation is close to land 1221 IF ( ll_next_to_land ) THEN 1222 knlaobs = knlaobs + 1 1223 IF (ld_nea) THEN 1224 kobsqc(jobsp) = kobsqc(jobsp) + 14 1225 ENDIF 1226 ENDIF 1227 ENDIF 1228 1229 ! For observations on the grid reject them if their are at 1230 ! a masked point 1231 1232 IF (lgridobs) THEN 1233 IF (zgmsk(iig,ijg,kobsk(jobsp)-1,jobs) == 0.0_wp ) THEN 1234 kobsqc(jobsp) = kobsqc(jobsp) + 12 1235 klanobs = klanobs + 1 1236 CYCLE 1237 ENDIF 1238 ENDIF 1239 1240 ! Flag if the observation falls is close to land 1241 IF ( MINVAL( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) == & 1242 & 0.0_wp) THEN 1243 IF (ld_nea) kobsqc(jobsp) = kobsqc(jobsp) + 14 1244 knlaobs = knlaobs + 1 1245 ENDIF 1246 1322 ENDIF 1323 1247 1324 ! Set observation depth equal to that of the first model depth 1248 1325 IF ( pobsdep(jobsp) <= pdep(1) ) THEN … … 1250 1327 ENDIF 1251 1328 1329 #if defined key_bdy 1330 ! Flag if the observation falls close to the boundary rim 1331 IF (ld_bound_reject) THEN 1332 IF ( MINVAL( zbmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN 1333 kobsqc(jobsp) = IBSET(kobsqc(jobs),8) 1334 kbdyobs = kbdyobs + 1 1335 CYCLE 1336 ENDIF 1337 ! for observations on the grid... 1338 IF (lgridobs) THEN 1339 IF (zbmsk(iig,ijg,jobs) == 0.0_wp ) THEN 1340 kobsqc(jobsp) = IBSET(kobsqc(jobs),8) 1341 kbdyobs = kbdyobs + 1 1342 CYCLE 1343 ENDIF 1344 ENDIF 1345 ENDIF 1346 #endif 1347 1252 1348 END DO 1253 1349 END DO … … 1255 1351 END SUBROUTINE obs_coo_spc_3d 1256 1352 1257 SUBROUTINE obs_pro_rej( profdata )1353 SUBROUTINE obs_pro_rej( profdata, kqc_cutoff ) 1258 1354 !!---------------------------------------------------------------------- 1259 1355 !! *** ROUTINE obs_pro_rej *** … … 1273 1369 !! * Arguments 1274 1370 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Profile data 1371 INTEGER, INTENT(IN) :: kqc_cutoff ! QC cutoff value 1372 1275 1373 !! * Local declarations 1276 1374 INTEGER :: jprof … … 1282 1380 DO jprof = 1, profdata%nprof 1283 1381 1284 IF ( profdata%nqc(jprof) > 10) THEN1382 IF ( profdata%nqc(jprof) > kqc_cutoff ) THEN 1285 1383 1286 1384 DO jvar = 1, profdata%nvar … … 1290 1388 1291 1389 profdata%var(jvar)%nvqc(jobs) = & 1292 & profdata%var(jvar)%nvqc(jobs) + 261390 & IBSET(profdata%var(jvar)%nvqc(jobs),14) 1293 1391 1294 1392 END DO … … 1302 1400 END SUBROUTINE obs_pro_rej 1303 1401 1304 SUBROUTINE obs_uv_rej( profdata, knumu, knumv )1402 SUBROUTINE obs_uv_rej( profdata, knumu, knumv, kqc_cutoff ) 1305 1403 !!---------------------------------------------------------------------- 1306 1404 !! *** ROUTINE obs_uv_rej *** … … 1322 1420 INTEGER, INTENT(INOUT) :: knumu ! Number of u rejected 1323 1421 INTEGER, INTENT(INOUT) :: knumv ! Number of v rejected 1422 INTEGER, INTENT(IN) :: kqc_cutoff ! QC cutoff value 1423 1324 1424 !! * Local declarations 1325 1425 INTEGER :: jprof … … 1341 1441 DO jobs = profdata%npvsta(jprof,1), profdata%npvend(jprof,1) 1342 1442 1343 IF ( ( profdata%var(1)%nvqc(jobs) > 10) .AND. &1344 & ( profdata%var(2)%nvqc(jobs) <= 10) ) THEN1345 profdata%var(2)%nvqc(jobs) = profdata%var(2)%nvqc(jobs) + 421443 IF ( ( profdata%var(1)%nvqc(jobs) > kqc_cutoff ) .AND. & 1444 & ( profdata%var(2)%nvqc(jobs) <= kqc_cutoff) ) THEN 1445 profdata%var(2)%nvqc(jobs) = IBSET(profdata%var(1)%nvqc(jobs),15) 1346 1446 knumv = knumv + 1 1347 1447 ENDIF 1348 IF ( ( profdata%var(2)%nvqc(jobs) > 10) .AND. &1349 & ( profdata%var(1)%nvqc(jobs) <= 10) ) THEN1350 profdata%var(1)%nvqc(jobs) = profdata%var(1)%nvqc(jobs) + 421448 IF ( ( profdata%var(2)%nvqc(jobs) > kqc_cutoff ) .AND. & 1449 & ( profdata%var(1)%nvqc(jobs) <= kqc_cutoff) ) THEN 1450 profdata%var(1)%nvqc(jobs) = IBSET(profdata%var(1)%nvqc(jobs),15) 1351 1451 knumu = knumu + 1 1352 1452 ENDIF
Note: See TracChangeset
for help on using the changeset viewer.
