- Timestamp:
- 2017-10-30T10:28:45+01:00 (6 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_r8657_UKMO_OBSoper/NEMOGCM/NEMO/OPA_SRC/OBS/obs_prep.F90
r7646 r8667 23 23 USE obs_oper ! Observation operators 24 24 USE lib_mpp, ONLY : ctl_warn, ctl_stop 25 USE bdy_oce, ONLY : & ! Boundary information 26 idx_bdy, nb_bdy, ln_bdy 25 27 26 28 IMPLICIT NONE … … 40 42 CONTAINS 41 43 42 SUBROUTINE obs_pre_surf( surfdata, surfdataqc, ld_nea ) 44 SUBROUTINE obs_pre_surf( surfdata, surfdataqc, ld_nea, ld_bound_reject, & 45 kqc_cutoff ) 43 46 !!---------------------------------------------------------------------- 44 47 !! *** ROUTINE obs_pre_sla *** … … 57 60 !! ! 2015-02 (M. Martin) Combined routine for surface types. 58 61 !!---------------------------------------------------------------------- 62 !! * Modules used 63 USE domstp ! Domain: set the time-step 59 64 USE par_oce ! Ocean parameters 60 65 USE dom_oce, ONLY : glamt, gphit, tmask, nproc ! Geographical information … … 63 68 TYPE(obs_surf), INTENT(INOUT) :: surfdataqc ! Subset of surface data not failing screening 64 69 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 65 ! 70 LOGICAL, INTENT(IN) :: ld_bound_reject ! Switch for rejecting obs near the boundary 71 INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff ! cut off for QC value 72 !! * Local declarations 73 INTEGER :: iqc_cutoff = 255 ! cut off for QC value 66 74 INTEGER :: iyea0 ! Initial date 67 75 INTEGER :: imon0 ! - (year, month, day, hour, minute) … … 76 84 INTEGER :: inlasobs ! - close to land 77 85 INTEGER :: igrdobs ! - fail the grid search 86 INTEGER :: ibdysobs ! - close to open boundary 78 87 ! Global counters for observations that 79 88 INTEGER :: iotdobsmpp ! - outside time domain … … 82 91 INTEGER :: inlasobsmpp ! - close to land 83 92 INTEGER :: igrdobsmpp ! - fail the grid search 84 LOGICAL, DIMENSION(:), ALLOCATABLE :: llvalid ! SLA data selection 93 INTEGER :: ibdysobsmpp ! - close to open boundary 94 LOGICAL, DIMENSION(:), ALLOCATABLE :: & 95 & llvalid ! SLA data selection 85 96 INTEGER :: jobs ! Obs. loop variable 86 97 INTEGER :: jstp ! Time loop variable … … 107 118 ilansobs = 0 108 119 inlasobs = 0 120 ibdysobs = 0 121 122 ! Set QC cutoff to optional value if provided 123 IF ( PRESENT(kqc_cutoff) ) iqc_cutoff=kqc_cutoff 109 124 110 125 ! ----------------------------------------------------------------------- … … 140 155 & tmask(:,:,1), surfdata%nqc, & 141 156 & iosdsobs, ilansobs, & 142 & inlasobs, ld_nea ) 157 & inlasobs, ld_nea, & 158 & ibdysobs, ld_bound_reject, & 159 & iqc_cutoff ) 143 160 144 161 CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) 145 162 CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) 146 163 CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) 164 CALL obs_mpp_sum_integer( ibdysobs, ibdysobsmpp ) 147 165 148 166 ! ----------------------------------------------------------------------- … … 155 173 ALLOCATE( llvalid(surfdata%nsurf) ) 156 174 157 ! We want all data which has qc flags <= 10158 159 llvalid(:) = ( surfdata%nqc(:) <= 10)175 ! We want all data which has qc flags <= iqc_cutoff 176 177 llvalid(:) = ( surfdata%nqc(:) <= iqc_cutoff ) 160 178 161 179 ! The actual copying … … 190 208 & inlasobsmpp 191 209 ENDIF 210 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near open boundary (removed) = ', & 211 & ibdysobsmpp 192 212 WRITE(numout,*) ' '//surfdataqc%cvars(1)//' data accepted = ', & 193 213 & surfdataqc%nsurfmpp … … 225 245 & kpi, kpj, kpk, & 226 246 & zmask1, pglam1, pgphi1, zmask2, pglam2, pgphi2, & 227 & ld_nea, kdailyavtypes)247 & ld_nea, ld_bound_reject, kdailyavtypes, kqc_cutoff ) 228 248 229 249 !!---------------------------------------------------------------------- … … 241 261 !! 242 262 !!---------------------------------------------------------------------- 243 USE par_oce ! Ocean parameters 244 USE dom_oce, ONLY : gdept_1d, nproc ! Geographical information 263 !! * Modules used 264 USE domstp ! Domain: set the time-step 265 USE par_oce ! Ocean parameters 266 USE dom_oce, ONLY : & ! Geographical information 267 & gdept_1d, & 268 & nproc 245 269 246 270 !! * Arguments … … 250 274 LOGICAL, INTENT(IN) :: ld_var2 251 275 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 276 LOGICAL, INTENT(IN) :: ld_bound_reject ! Switch for rejecting observations near the boundary 252 277 INTEGER, INTENT(IN) :: kpi, kpj, kpk ! Local domain sizes 253 278 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & … … 261 286 & pgphi1, & 262 287 & pgphi2 288 INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff ! cut off for QC value 263 289 264 290 !! * Local declarations 291 INTEGER :: iqc_cutoff = 255 ! cut off for QC value 265 292 INTEGER :: iyea0 ! Initial date 266 293 INTEGER :: imon0 ! - (year, month, day, hour, minute) … … 277 304 INTEGER :: inlav1obs ! - close to land (variable 1) 278 305 INTEGER :: inlav2obs ! - close to land (variable 2) 306 INTEGER :: ibdyv1obs ! - boundary (variable 1) 307 INTEGER :: ibdyv2obs ! - boundary (variable 2) 279 308 INTEGER :: igrdobs ! - fail the grid search 280 309 INTEGER :: iuvchku ! - reject u if v rejected and vice versa … … 288 317 INTEGER :: inlav1obsmpp ! - close to land (variable 1) 289 318 INTEGER :: inlav2obsmpp ! - close to land (variable 2) 319 INTEGER :: ibdyv1obsmpp ! - boundary (variable 1) 320 INTEGER :: ibdyv2obsmpp ! - boundary (variable 2) 290 321 INTEGER :: igrdobsmpp ! - fail the grid search 291 322 INTEGER :: iuvchkumpp ! - reject var1 if var2 rejected and vice versa … … 322 353 inlav1obs = 0 323 354 inlav2obs = 0 324 iuvchku = 0 325 iuvchkv = 0 355 ibdyv1obs = 0 356 ibdyv2obs = 0 357 iuvchku = 0 358 iuvchkv = 0 359 360 361 ! Set QC cutoff to optional value if provided 362 IF ( PRESENT(kqc_cutoff) ) iqc_cutoff=kqc_cutoff 326 363 327 364 ! ----------------------------------------------------------------------- … … 335 372 & profdata%nday, profdata%nhou, profdata%nmin, & 336 373 & profdata%ntyp, profdata%nqc, profdata%mstp, & 337 & iotdobs, kdailyavtypes = kdailyavtypes ) 374 & iotdobs, kdailyavtypes = kdailyavtypes, & 375 & kqc_cutoff = iqc_cutoff ) 338 376 ELSE 339 377 CALL obs_coo_tim_prof( icycle, & … … 342 380 & profdata%nday, profdata%nhou, profdata%nmin, & 343 381 & profdata%ntyp, profdata%nqc, profdata%mstp, & 344 & iotdobs )382 & iotdobs, kqc_cutoff = iqc_cutoff ) 345 383 ENDIF 346 384 … … 359 397 360 398 ! ----------------------------------------------------------------------- 361 ! Reject all observations for profiles with nqc > 10362 ! ----------------------------------------------------------------------- 363 364 CALL obs_pro_rej( profdata )399 ! Reject all observations for profiles with nqc > iqc_cutoff 400 ! ----------------------------------------------------------------------- 401 402 CALL obs_pro_rej( profdata, kqc_cutoff = iqc_cutoff ) 365 403 366 404 ! ----------------------------------------------------------------------- … … 381 419 & gdept_1d, zmask1, & 382 420 & profdata%nqc, profdata%var(1)%nvqc, & 383 & iosdv1obs, ilanv1obs, & 384 & inlav1obs, ld_nea ) 421 & iosdv1obs, ilanv1obs, & 422 & inlav1obs, ld_nea, & 423 & ibdyv1obs, ld_bound_reject, & 424 & iqc_cutoff ) 385 425 386 426 CALL obs_mpp_sum_integer( iosdv1obs, iosdv1obsmpp ) 387 427 CALL obs_mpp_sum_integer( ilanv1obs, ilanv1obsmpp ) 388 428 CALL obs_mpp_sum_integer( inlav1obs, inlav1obsmpp ) 429 CALL obs_mpp_sum_integer( ibdyv1obs, ibdyv1obsmpp ) 389 430 390 431 ! Variable 2 … … 400 441 & gdept_1d, zmask2, & 401 442 & profdata%nqc, profdata%var(2)%nvqc, & 402 & iosdv2obs, ilanv2obs, & 403 & inlav2obs, ld_nea ) 443 & iosdv2obs, ilanv2obs, & 444 & inlav2obs, ld_nea, & 445 & ibdyv2obs, ld_bound_reject, & 446 & iqc_cutoff ) 404 447 405 448 CALL obs_mpp_sum_integer( iosdv2obs, iosdv2obsmpp ) 406 449 CALL obs_mpp_sum_integer( ilanv2obs, ilanv2obsmpp ) 407 450 CALL obs_mpp_sum_integer( inlav2obs, inlav2obsmpp ) 451 CALL obs_mpp_sum_integer( ibdyv2obs, ibdyv2obsmpp ) 408 452 409 453 ! ----------------------------------------------------------------------- … … 412 456 413 457 IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 414 CALL obs_uv_rej( profdata, iuvchku, iuvchkv )458 CALL obs_uv_rej( profdata, iuvchku, iuvchkv, iqc_cutoff ) 415 459 CALL obs_mpp_sum_integer( iuvchku, iuvchkumpp ) 416 460 CALL obs_mpp_sum_integer( iuvchkv, iuvchkvmpp ) … … 429 473 END DO 430 474 431 ! We want all data which has qc flags = 0432 433 llvalid%luse(:) = ( profdata%nqc(:) <= 10)475 ! We want all data which has qc flags <= iqc_cutoff 476 477 llvalid%luse(:) = ( profdata%nqc(:) <= iqc_cutoff ) 434 478 DO jvar = 1,profdata%nvar 435 llvvalid(jvar)%luse(:) = ( profdata%var(jvar)%nvqc(:) <= 10)479 llvvalid(jvar)%luse(:) = ( profdata%var(jvar)%nvqc(:) <= iqc_cutoff ) 436 480 END DO 437 481 … … 475 519 & iuvchku 476 520 ENDIF 521 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near open boundary (removed) = ',& 522 & ibdyv1obsmpp 477 523 WRITE(numout,*) ' '//prodatqc%cvars(1)//' data accepted = ', & 478 524 & prodatqc%nvprotmpp(1) … … 492 538 & iuvchkv 493 539 ENDIF 540 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near open boundary (removed) = ',& 541 & ibdyv2obsmpp 494 542 WRITE(numout,*) ' '//prodatqc%cvars(2)//' data accepted = ', & 495 543 & prodatqc%nvprotmpp(2) … … 644 692 & .AND. ( kobsmin(jobs) <= kmin0 ) ) ) THEN 645 693 kobsstp(jobs) = -1 646 kobsqc(jobs) = kobsqc(jobs) + 11694 kobsqc(jobs) = IBSET(kobsqc(jobs),13) 647 695 kotdobs = kotdobs + 1 648 696 CYCLE … … 695 743 IF ( ( kobsstp(jobs) < ( nit000 - 1 ) ) & 696 744 & .OR.( kobsstp(jobs) > nitend ) ) THEN 697 kobsqc(jobs) = kobsqc(jobs) + 12745 kobsqc(jobs) = IBSET(kobsqc(jobs),13) 698 746 kotdobs = kotdobs + 1 699 747 CYCLE … … 739 787 & kobsno, & 740 788 & kobsyea, kobsmon, kobsday, kobshou, kobsmin, & 741 & ktyp, kobsqc, kobsstp, kotdobs, kdailyavtypes ) 789 & ktyp, kobsqc, kobsstp, kotdobs, kdailyavtypes, & 790 & kqc_cutoff ) 742 791 !!---------------------------------------------------------------------- 743 792 !! *** ROUTINE obs_coo_tim *** … … 783 832 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 784 833 & kdailyavtypes ! Types for daily averages 834 INTEGER, OPTIONAL, INTENT(IN) :: kqc_cutoff ! QC cutoff value 835 785 836 !! * Local declarations 786 837 INTEGER :: jobs 838 INTEGER :: iqc_cutoff=255 787 839 788 840 !----------------------------------------------------------------------- … … 803 855 DO jobs = 1, kobsno 804 856 805 IF ( kobsqc(jobs) <= 10) THEN857 IF ( kobsqc(jobs) <= iqc_cutoff ) THEN 806 858 807 859 IF ( ( kobsstp(jobs) == (nit000 - 1) ).AND.& 808 860 & ( ANY (kdailyavtypes(:) == ktyp(jobs)) ) ) THEN 809 kobsqc(jobs) = kobsqc(jobs) + 14861 kobsqc(jobs) = IBSET(kobsqc(jobs),13) 810 862 kotdobs = kotdobs + 1 811 863 CYCLE … … 850 902 DO jobs = 1, kobsno 851 903 IF ( ( kobsi(jobs) <= 0 ) .AND. ( kobsj(jobs) <= 0 ) ) THEN 852 kobsqc(jobs) = kobsqc(jobs) + 18904 kobsqc(jobs) = IBSET(kobsqc(jobs),12) 853 905 kgrdobs = kgrdobs + 1 854 906 ENDIF … … 861 913 & plam, pphi, pmask, & 862 914 & kobsqc, kosdobs, klanobs, & 863 & knlaobs,ld_nea ) 915 & knlaobs,ld_nea, & 916 & kbdyobs,ld_bound_reject, & 917 & kqc_cutoff ) 864 918 !!---------------------------------------------------------------------- 865 919 !! *** ROUTINE obs_coo_spc_2d *** … … 894 948 INTEGER, DIMENSION(kobsno), INTENT(INOUT) :: & 895 949 & 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 950 INTEGER, INTENT(INOUT) :: kosdobs ! Observations outside space domain 951 INTEGER, INTENT(INOUT) :: klanobs ! Observations within a model land cell 952 INTEGER, INTENT(INOUT) :: knlaobs ! Observations near land 953 INTEGER, INTENT(INOUT) :: kbdyobs ! Observations near boundary 954 LOGICAL, INTENT(IN) :: ld_nea ! Flag observations near land 955 LOGICAL, INTENT(IN) :: ld_bound_reject ! Flag observations near open boundary 956 INTEGER, INTENT(IN) :: kqc_cutoff ! Cutoff QC value 957 900 958 !! * Local declarations 901 959 REAL(KIND=wp), DIMENSION(2,2,kobsno) :: & 902 960 & zgmsk ! Grid mask 961 962 REAL(KIND=wp), DIMENSION(2,2,kobsno) :: & 963 & zbmsk ! Boundary mask 964 REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask 903 965 REAL(KIND=wp), DIMENSION(2,2,kobsno) :: & 904 966 & zglam, & ! Model longitude at grid points … … 917 979 ! For invalid points use 2,2 918 980 919 IF ( kobsqc(jobs) >= 10) THEN981 IF ( kobsqc(jobs) >= kqc_cutoff ) THEN 920 982 921 983 igrdi(1,1,jobs) = 1 … … 942 1004 943 1005 END DO 1006 1007 IF (ln_bdy) THEN 1008 ! Create a mask grid points in boundary rim 1009 IF (ld_bound_reject) THEN 1010 zbdymask(:,:) = 1.0_wp 1011 DO ji = 1, nb_bdy 1012 DO jj = 1, idx_bdy(ji)%nblen(1) 1013 zbdymask(idx_bdy(ji)%nbi(jj,1),idx_bdy(ji)%nbj(jj,1)) = 0.0_wp 1014 ENDDO 1015 ENDDO 1016 1017 CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, zbdymask, zbmsk ) 1018 ENDIF 1019 ENDIF 1020 944 1021 945 1022 CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, pmask, zgmsk ) … … 950 1027 951 1028 ! Skip bad observations 952 IF ( kobsqc(jobs) >= 10) CYCLE1029 IF ( kobsqc(jobs) >= kqc_cutoff ) CYCLE 953 1030 954 1031 ! Flag if the observation falls outside the model spatial domain … … 957 1034 & .OR. ( pobsphi(jobs) < -90. ) & 958 1035 & .OR. ( pobsphi(jobs) > 90. ) ) THEN 959 kobsqc(jobs) = kobsqc(jobs) + 111036 kobsqc(jobs) = IBSET(kobsqc(jobs),11) 960 1037 kosdobs = kosdobs + 1 961 1038 CYCLE … … 964 1041 ! Flag if the observation falls with a model land cell 965 1042 IF ( SUM( zgmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN 966 kobsqc(jobs) = kobsqc(jobs) + 121043 kobsqc(jobs) = IBSET(kobsqc(jobs),10) 967 1044 klanobs = klanobs + 1 968 1045 CYCLE … … 978 1055 IF ( ( ABS( zgphi(ji,jj,jobs) - pobsphi(jobs) ) < 1.0e-6_wp ) & 979 1056 & .AND. & 980 & ( ABS( zglam(ji,jj,jobs) - pobslam(jobs) ) < 1.0e-6_wp )&981 & ) THEN1057 & ( ABS( MOD( zglam(ji,jj,jobs) - pobslam(jobs),360.0) ) & 1058 & < 1.0e-6_wp ) ) THEN 982 1059 lgridobs = .TRUE. 983 1060 iig = ji … … 992 1069 IF (lgridobs) THEN 993 1070 IF (zgmsk(iig,ijg,jobs) == 0.0_wp ) THEN 994 kobsqc(jobs) = kobsqc(jobs) + 121071 kobsqc(jobs) = IBSET(kobsqc(jobs),10) 995 1072 klanobs = klanobs + 1 996 1073 CYCLE … … 1000 1077 ! Flag if the observation falls is close to land 1001 1078 IF ( MINVAL( zgmsk(1:2,1:2,jobs) ) == 0.0_wp) THEN 1002 IF (ld_nea) kobsqc(jobs) = kobsqc(jobs) + 141003 1079 knlaobs = knlaobs + 1 1004 CYCLE 1080 IF (ld_nea) THEN 1081 kobsqc(jobs) = IBSET(kobsqc(jobs),9) 1082 CYCLE 1083 ENDIF 1084 ENDIF 1085 1086 IF (ln_bdy) THEN 1087 ! Flag if the observation falls close to the boundary rim 1088 IF (ld_bound_reject) THEN 1089 IF ( MINVAL( zbmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN 1090 kobsqc(jobs) = IBSET(kobsqc(jobs),8) 1091 kbdyobs = kbdyobs + 1 1092 CYCLE 1093 ENDIF 1094 ! for observations on the grid... 1095 IF (lgridobs) THEN 1096 IF (zbmsk(iig,ijg,jobs) == 0.0_wp ) THEN 1097 kobsqc(jobs) = IBSET(kobsqc(jobs),8) 1098 kbdyobs = kbdyobs + 1 1099 CYCLE 1100 ENDIF 1101 ENDIF 1102 ENDIF 1005 1103 ENDIF 1006 1104 … … 1015 1113 & plam, pphi, pdep, pmask, & 1016 1114 & kpobsqc, kobsqc, kosdobs, & 1017 & klanobs, knlaobs, ld_nea ) 1115 & klanobs, knlaobs, ld_nea, & 1116 & kbdyobs, ld_bound_reject, & 1117 & kqc_cutoff ) 1018 1118 !!---------------------------------------------------------------------- 1019 1119 !! *** ROUTINE obs_coo_spc_3d *** … … 1077 1177 INTEGER, INTENT(INOUT) :: klanobs ! Observations within a model land cell 1078 1178 INTEGER, INTENT(INOUT) :: knlaobs ! Observations near land 1179 INTEGER, INTENT(INOUT) :: kbdyobs ! Observations near boundary 1079 1180 LOGICAL, INTENT(IN) :: ld_nea ! Flag observations near land 1181 LOGICAL, INTENT(IN) :: ld_bound_reject ! Flag observations near open boundary 1182 INTEGER, INTENT(IN) :: kqc_cutoff ! Cutoff QC value 1183 1080 1184 !! * Local declarations 1081 1185 REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: & 1082 1186 & zgmsk ! Grid mask 1187 REAL(KIND=wp), DIMENSION(2,2,kprofno) :: & 1188 & zbmsk ! Boundary mask 1189 REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask 1083 1190 REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: & 1084 1191 & zgdepw … … 1100 1207 ! For invalid points use 2,2 1101 1208 1102 IF ( kpobsqc(jobs) >= 10) THEN1209 IF ( kpobsqc(jobs) >= kqc_cutoff ) THEN 1103 1210 1104 1211 igrdi(1,1,jobs) = 1 … … 1125 1232 1126 1233 END DO 1234 1235 IF (ln_bdy) THEN 1236 ! Create a mask grid points in boundary rim 1237 IF (ld_bound_reject) THEN 1238 zbdymask(:,:) = 1.0_wp 1239 DO ji = 1, nb_bdy 1240 DO jj = 1, idx_bdy(ji)%nblen(1) 1241 zbdymask(idx_bdy(ji)%nbi(jj,1),idx_bdy(ji)%nbj(jj,1)) = 0.0_wp 1242 ENDDO 1243 ENDDO 1244 ENDIF 1245 1246 CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, zbdymask, zbmsk ) 1247 ENDIF 1127 1248 1128 1249 CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, pmask, zgmsk ) 1129 1250 CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, plam, zglam ) 1130 1251 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(:,:,:), & 1252 CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, gdepw_n(:,:,:), & 1134 1253 & zgdepw ) 1135 ENDIF1136 1254 1137 1255 DO jobs = 1, kprofno 1138 1256 1139 1257 ! Skip bad profiles 1140 IF ( kpobsqc(jobs) >= 10) CYCLE1258 IF ( kpobsqc(jobs) >= kqc_cutoff ) CYCLE 1141 1259 1142 1260 ! Check if this observation is on a grid point … … 1149 1267 IF ( ( ABS( zgphi(ji,jj,jobs) - pobsphi(jobs) ) < 1.0e-6_wp ) & 1150 1268 & .AND. & 1151 & ( ABS( zglam(ji,jj,jobs) - pobslam(jobs) ) < 1.0e-6_wp ) &1269 & ( ABS( MOD( zglam(ji,jj,jobs) - pobslam(jobs),360.0) ) < 1.0e-6_wp ) & 1152 1270 & ) THEN 1153 1271 lgridobs = .TRUE. … … 1176 1294 & .OR. ( pobsdep(jobsp) < 0.0 ) & 1177 1295 & .OR. ( pobsdep(jobsp) > gdepw_1d(kpk)) ) THEN 1178 kobsqc(jobsp) = kobsqc(jobsp) + 111296 kobsqc(jobsp) = IBSET(kobsqc(jobsp),11) 1179 1297 kosdobs = kosdobs + 1 1180 1298 CYCLE 1181 1299 ENDIF 1182 1300 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 1301 ! To check if an observations falls within land: 1187 1302 1188 IF( ln_zps .OR. ln_zco ) THEN !(CASE 1) 1303 ! Flag if the observation is deeper than the bathymetry 1304 ! Or if it is within the mask 1305 IF ( ALL( zgdepw(1:2,1:2,kpk,jobs) < pobsdep(jobsp) ) & 1306 & .OR. & 1307 & ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) & 1308 & == 0.0_wp) ) THEN 1309 kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) 1310 klanobs = klanobs + 1 1311 CYCLE 1312 ENDIF 1189 1313 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 1194 klanobs = klanobs + 1 1195 CYCLE 1196 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 1314 ! Flag if the observation is close to land 1315 IF ( ll_next_to_land ) THEN 1316 knlaobs = knlaobs + 1 1317 IF (ld_nea) THEN 1318 kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) 1319 ENDIF 1227 1320 ENDIF 1228 1321 … … 1232 1325 IF (lgridobs) THEN 1233 1326 IF (zgmsk(iig,ijg,kobsk(jobsp)-1,jobs) == 0.0_wp ) THEN 1234 kobsqc(jobsp) = kobsqc(jobsp) + 121327 kobsqc(jobsp) = IBSET(kobsqc(jobs),10) 1235 1328 klanobs = klanobs + 1 1236 1329 CYCLE … … 1250 1343 ENDIF 1251 1344 1345 IF (ln_bdy) THEN 1346 ! Flag if the observation falls close to the boundary rim 1347 IF (ld_bound_reject) THEN 1348 IF ( MINVAL( zbmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN 1349 kobsqc(jobsp) = IBSET(kobsqc(jobs),8) 1350 kbdyobs = kbdyobs + 1 1351 CYCLE 1352 ENDIF 1353 ! for observations on the grid... 1354 IF (lgridobs) THEN 1355 IF (zbmsk(iig,ijg,jobs) == 0.0_wp ) THEN 1356 kobsqc(jobsp) = IBSET(kobsqc(jobs),8) 1357 kbdyobs = kbdyobs + 1 1358 CYCLE 1359 ENDIF 1360 ENDIF 1361 ENDIF 1362 ENDIF 1363 1252 1364 END DO 1253 1365 END DO … … 1255 1367 END SUBROUTINE obs_coo_spc_3d 1256 1368 1257 SUBROUTINE obs_pro_rej( profdata )1369 SUBROUTINE obs_pro_rej( profdata, kqc_cutoff ) 1258 1370 !!---------------------------------------------------------------------- 1259 1371 !! *** ROUTINE obs_pro_rej *** … … 1273 1385 !! * Arguments 1274 1386 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Profile data 1387 INTEGER, INTENT(IN) :: kqc_cutoff ! QC cutoff value 1388 1275 1389 !! * Local declarations 1276 1390 INTEGER :: jprof … … 1282 1396 DO jprof = 1, profdata%nprof 1283 1397 1284 IF ( profdata%nqc(jprof) > 10) THEN1398 IF ( profdata%nqc(jprof) > kqc_cutoff ) THEN 1285 1399 1286 1400 DO jvar = 1, profdata%nvar … … 1290 1404 1291 1405 profdata%var(jvar)%nvqc(jobs) = & 1292 & profdata%var(jvar)%nvqc(jobs) + 261406 & IBSET(profdata%var(jvar)%nvqc(jobs),14) 1293 1407 1294 1408 END DO … … 1302 1416 END SUBROUTINE obs_pro_rej 1303 1417 1304 SUBROUTINE obs_uv_rej( profdata, knumu, knumv )1418 SUBROUTINE obs_uv_rej( profdata, knumu, knumv, kqc_cutoff ) 1305 1419 !!---------------------------------------------------------------------- 1306 1420 !! *** ROUTINE obs_uv_rej *** … … 1322 1436 INTEGER, INTENT(INOUT) :: knumu ! Number of u rejected 1323 1437 INTEGER, INTENT(INOUT) :: knumv ! Number of v rejected 1438 INTEGER, INTENT(IN) :: kqc_cutoff ! QC cutoff value 1439 1324 1440 !! * Local declarations 1325 1441 INTEGER :: jprof … … 1341 1457 DO jobs = profdata%npvsta(jprof,1), profdata%npvend(jprof,1) 1342 1458 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) + 421459 IF ( ( profdata%var(1)%nvqc(jobs) > kqc_cutoff ) .AND. & 1460 & ( profdata%var(2)%nvqc(jobs) <= kqc_cutoff) ) THEN 1461 profdata%var(2)%nvqc(jobs) = IBSET(profdata%var(1)%nvqc(jobs),15) 1346 1462 knumv = knumv + 1 1347 1463 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) + 421464 IF ( ( profdata%var(2)%nvqc(jobs) > kqc_cutoff ) .AND. & 1465 & ( profdata%var(1)%nvqc(jobs) <= kqc_cutoff) ) THEN 1466 profdata%var(1)%nvqc(jobs) = IBSET(profdata%var(1)%nvqc(jobs),15) 1351 1467 knumu = knumu + 1 1352 1468 ENDIF
Note: See TracChangeset
for help on using the changeset viewer.
