Changeset 15089
- Timestamp:
- 2021-07-06T16:11:33+02:00 (3 years ago)
- Location:
- NEMO/branches/UKMO/NEMO_4.0.4_generic_obs
- Files:
-
- 8 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/cfgs/SHARED/namelist_ref
r14075 r15089 1266 1266 ln_sstnight = .false. ! Logical switch for calculating night-time average for SST obs 1267 1267 ln_bound_reject = .false. ! Logical to remove obs near boundaries in LAMs. 1268 ln_default_fp_indegs = .true. ! Logical: T=> averaging footprint is in degrees, F=> in metres 1268 1269 ln_sla_fp_indegs = .true. ! Logical for SLA: T=> averaging footprint is in degrees, F=> in metres 1269 1270 ln_sst_fp_indegs = .true. ! Logical for SST: T=> averaging footprint is in degrees, F=> in metres … … 1281 1282 cn_gridsearchfile ='gridsearch.nc' ! Grid search file name 1282 1283 rn_gridsearchres = 0.5 ! Grid search resolution 1284 rn_default_avglamscl = 0. ! Default E/W diameter of observation footprint (metres/degrees) 1285 rn_default_avgphiscl = 0. ! Default N/S diameter of observation footprint (metres/degrees) 1283 1286 rn_mdtcorr = 1.61 ! MDT correction 1284 1287 rn_mdtcutoff = 65.0 ! MDT cutoff for computed correction … … 1294 1297 rn_sic_avgphiscl = 0. ! N/S diameter of SIC observation footprint (metres/degrees) 1295 1298 nn_1dint = 0 ! Type of vertical interpolation method 1296 nn_2dint = 0! Default horizontal interpolation method1299 nn_2dint_default = 0 ! Default horizontal interpolation method 1297 1300 nn_2dint_sla = 0 ! Horizontal interpolation method for SLA 1298 1301 nn_2dint_sst = 0 ! Horizontal interpolation method for SST -
NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/doc/namelists/namobs
r11703 r15089 20 20 ln_sstnight = .false. ! Logical switch for calculating night-time average for SST obs 21 21 ln_bound_reject = .false. ! Logical to remove obs near boundaries in LAMs. 22 ln_default_fp_indegs = .true. ! Logical: T=> averaging footprint is in degrees, F=> in metres 22 23 ln_sla_fp_indegs = .true. ! Logical for SLA: T=> averaging footprint is in degrees, F=> in metres 23 24 ln_sst_fp_indegs = .true. ! Logical for SST: T=> averaging footprint is in degrees, F=> in metres … … 39 40 rn_dobsini = 00010101.000000 ! Initial date in window YYYYMMDD.HHMMSS 40 41 rn_dobsend = 00010102.000000 ! Final date in window YYYYMMDD.HHMMSS 42 rn_default_avglamscl = 0. ! Default E/W diameter of observation footprint (metres/degrees) 43 rn_default_avgphiscl = 0. ! Default N/S diameter of observation footprint (metres/degrees) 41 44 rn_sla_avglamscl = 0. ! E/W diameter of SLA observation footprint (metres/degrees) 42 45 rn_sla_avgphiscl = 0. ! N/S diameter of SLA observation footprint (metres/degrees) … … 48 51 rn_sic_avgphiscl = 0. ! N/S diameter of SIC observation footprint (metres/degrees) 49 52 nn_1dint = 0 ! Type of vertical interpolation method 50 nn_2dint = 0! Default horizontal interpolation method53 nn_2dint_default = 0 ! Default horizontal interpolation method 51 54 nn_2dint_sla = 0 ! Horizontal interpolation method for SLA 52 55 nn_2dint_sst = 0 ! Horizontal interpolation method for SST -
NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS/diaobs.F90
r14075 r15089 57 57 PUBLIC calc_date ! Compute the date of a timestep 58 58 59 LOGICAL, PUBLIC :: ln_diaobs !: Logical switch for the obs operator 60 LOGICAL :: ln_sstnight ! Logical switch for night mean SST obs 61 LOGICAL :: ln_sla_fp_indegs ! T=> SLA obs footprint size specified in degrees, F=> in metres 62 LOGICAL :: ln_sst_fp_indegs ! T=> SST obs footprint size specified in degrees, F=> in metres 63 LOGICAL :: ln_sss_fp_indegs ! T=> SSS obs footprint size specified in degrees, F=> in metres 64 LOGICAL :: ln_sic_fp_indegs ! T=> sea-ice obs footprint size specified in degrees, F=> in metres 65 66 REAL(wp) :: rn_sla_avglamscl ! E/W diameter of SLA observation footprint (metres) 67 REAL(wp) :: rn_sla_avgphiscl ! N/S diameter of SLA observation footprint (metres) 68 REAL(wp) :: rn_sst_avglamscl ! E/W diameter of SST observation footprint (metres) 69 REAL(wp) :: rn_sst_avgphiscl ! N/S diameter of SST observation footprint (metres) 70 REAL(wp) :: rn_sss_avglamscl ! E/W diameter of SSS observation footprint (metres) 71 REAL(wp) :: rn_sss_avgphiscl ! N/S diameter of SSS observation footprint (metres) 72 REAL(wp) :: rn_sic_avglamscl ! E/W diameter of sea-ice observation footprint (metres) 73 REAL(wp) :: rn_sic_avgphiscl ! N/S diameter of sea-ice observation footprint (metres) 74 75 INTEGER :: nn_1dint ! Vertical interpolation method 76 INTEGER :: nn_2dint ! Default horizontal interpolation method 77 INTEGER :: nn_2dint_sla ! SLA horizontal interpolation method 78 INTEGER :: nn_2dint_sst ! SST horizontal interpolation method 79 INTEGER :: nn_2dint_sss ! SSS horizontal interpolation method 80 INTEGER :: nn_2dint_sic ! Seaice horizontal interpolation method 59 LOGICAL, PUBLIC :: ln_diaobs !: Logical switch for the obs operator 60 LOGICAL :: ln_sstnight ! Logical switch for night mean SST obs 61 LOGICAL :: ln_default_fp_indegs ! T=> Default obs footprint size specified in degrees, F=> in metres 62 LOGICAL :: ln_sla_fp_indegs ! T=> SLA obs footprint size specified in degrees, F=> in metres 63 LOGICAL :: ln_sst_fp_indegs ! T=> SST obs footprint size specified in degrees, F=> in metres 64 LOGICAL :: ln_sss_fp_indegs ! T=> SSS obs footprint size specified in degrees, F=> in metres 65 LOGICAL :: ln_sic_fp_indegs ! T=> sea-ice obs footprint size specified in degrees, F=> in metres 66 67 REAL(wp) :: rn_default_avglamscl ! E/W diameter of SLA observation footprint (metres) 68 REAL(wp) :: rn_default_avgphiscl ! N/S diameter of SLA observation footprint (metre 69 REAL(wp) :: rn_sla_avglamscl ! E/W diameter of SLA observation footprint (metres) 70 REAL(wp) :: rn_sla_avgphiscl ! N/S diameter of SLA observation footprint (metres) 71 REAL(wp) :: rn_sst_avglamscl ! E/W diameter of SST observation footprint (metres) 72 REAL(wp) :: rn_sst_avgphiscl ! N/S diameter of SST observation footprint (metres) 73 REAL(wp) :: rn_sss_avglamscl ! E/W diameter of SSS observation footprint (metres) 74 REAL(wp) :: rn_sss_avgphiscl ! N/S diameter of SSS observation footprint (metres) 75 REAL(wp) :: rn_sic_avglamscl ! E/W diameter of sea-ice observation footprint (metres) 76 REAL(wp) :: rn_sic_avgphiscl ! N/S diameter of sea-ice observation footprint (metres) 77 78 INTEGER :: nn_1dint ! Vertical interpolation method 79 INTEGER :: nn_2dint_default ! Default horizontal interpolation method 80 INTEGER :: nn_2dint_sla ! SLA horizontal interpolation method 81 INTEGER :: nn_2dint_sst ! SST horizontal interpolation method 82 INTEGER :: nn_2dint_sss ! SSS horizontal interpolation method 83 INTEGER :: nn_2dint_sic ! Seaice horizontal interpolation method 81 84 INTEGER, DIMENSION(imaxavtypes) :: nn_profdavtypes ! Profile data types representing a daily average 82 85 INTEGER :: nproftypes ! Number of profile obs types … … 94 97 TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: profdataqc !: Profile data after quality control 95 98 96 CHARACTER(len= 6), PUBLIC, DIMENSION(:), ALLOCATABLE :: cobstypesprof, cobstypessurf !: Profile & surface obs types99 CHARACTER(len=8), PUBLIC, DIMENSION(:), ALLOCATABLE :: cobstypesprof, cobstypessurf !: Profile & surface obs types 97 100 98 101 !!---------------------------------------------------------------------- … … 120 123 INTEGER :: jvar ! Counter for variables 121 124 INTEGER :: jfile ! Counter for files 122 INTEGER :: jnumsstbias 125 INTEGER :: jnumsstbias ! Number of SST bias files to read and apply 126 INTEGER :: n2dint_type ! Local version of nn_2dint* 123 127 ! 124 128 CHARACTER(len=128), DIMENSION(jpmaxnfiles) :: & … … 129 133 & cn_sicfbfiles, & ! Seaice concentration input filenames 130 134 & cn_velfbfiles, & ! Velocity profile input filenames 131 & cn_sstbiasfiles ! SST bias input filenames135 & cn_sstbiasfiles ! SST bias input filenames 132 136 CHARACTER(LEN=128) :: & 133 137 & cn_altbiasfile ! Altimeter bias input filename … … 135 139 & clproffiles, & ! Profile filenames 136 140 & clsurffiles ! Surface filenames 141 CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: & 142 & clvars ! Expected variable names 137 143 ! 138 144 LOGICAL :: ln_t3d ! Logical switch for temperature profiles … … 149 155 LOGICAL :: ln_s_at_t ! Logical switch to compute model S at T obs 150 156 LOGICAL :: ln_bound_reject ! Logical to remove obs near boundaries in LAMs. 151 LOGICAL :: llvar1 ! Logical for profile variable 1 152 LOGICAL :: llvar2 ! Logical for profile variable 1 157 LOGICAL :: ltype_fp_indegs ! Local version of ln_*_fp_indegs 158 LOGICAL :: ltype_night ! Local version of ln_sstnight (false for other variables) 159 LOGICAL, DIMENSION(:), ALLOCATABLE :: llvar ! Logical for profile variable read 153 160 LOGICAL, DIMENSION(jpmaxnfiles) :: lmask ! Used for finding number of sstbias files 154 161 ! 155 REAL(dp) :: rn_dobsini ! Obs window start date YYYYMMDD.HHMMSS 156 REAL(dp) :: rn_dobsend ! Obs window end date YYYYMMDD.HHMMSS 157 REAL(wp), DIMENSION(jpi,jpj) :: zglam1, zglam2 ! Model longitudes for profile variable 1 & 2 158 REAL(wp), DIMENSION(jpi,jpj) :: zgphi1, zgphi2 ! Model latitudes for profile variable 1 & 2 159 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask1, zmask2 ! Model land/sea mask associated with variable 1 & 2 162 REAL(dp) :: rn_dobsini ! Obs window start date YYYYMMDD.HHMMSS 163 REAL(dp) :: rn_dobsend ! Obs window end date YYYYMMDD.HHMMSS 164 REAL(wp) :: ztype_avglamscl ! Local version of rn_*_avglamscl 165 REAL(wp) :: ztype_avgphiscl ! Local version of rn_*_avgphiscl 166 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zglam ! Model longitudes for profile variables 167 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zgphi ! Model latitudes for profile variables 168 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zmask ! Model land/sea mask associated with variables 160 169 !! 161 170 NAMELIST/namobs/ln_diaobs, ln_t3d, ln_s3d, ln_sla, & … … 164 173 & ln_grid_global, ln_grid_search_lookup, & 165 174 & ln_ignmis, ln_s_at_t, ln_bound_reject, & 166 & ln_sstnight, 175 & ln_sstnight, ln_default_fp_indegs, & 167 176 & ln_sla_fp_indegs, ln_sst_fp_indegs, & 168 177 & ln_sss_fp_indegs, ln_sic_fp_indegs, & … … 173 182 & cn_gridsearchfile, rn_gridsearchres, & 174 183 & rn_dobsini, rn_dobsend, & 184 & rn_default_avglamscl, rn_default_avgphiscl, & 175 185 & rn_sla_avglamscl, rn_sla_avgphiscl, & 176 186 & rn_sst_avglamscl, rn_sst_avgphiscl, & 177 187 & rn_sss_avglamscl, rn_sss_avgphiscl, & 178 188 & rn_sic_avglamscl, rn_sic_avgphiscl, & 179 & nn_1dint, nn_2dint ,&189 & nn_1dint, nn_2dint_default, & 180 190 & nn_2dint_sla, nn_2dint_sst, & 181 191 & nn_2dint_sss, nn_2dint_sic, & … … 235 245 WRITE(numout,*) ' Final date in window YYYYMMDD.HHMMSS rn_dobsend = ', rn_dobsend 236 246 WRITE(numout,*) ' Type of vertical interpolation method nn_1dint = ', nn_1dint 237 WRITE(numout,*) ' Type of horizontal interpolation method nn_2dint = ', nn_2dint 247 WRITE(numout,*) ' Default horizontal interpolation method nn_2dint_default = ', nn_2dint_default 248 WRITE(numout,*) ' Type of horizontal interpolation method for SLA nn_2dint_sla = ', nn_2dint_sla 249 WRITE(numout,*) ' Type of horizontal interpolation method for SST nn_2dint_sst = ', nn_2dint_sst 250 WRITE(numout,*) ' Type of horizontal interpolation method for SSS nn_2dint_sss = ', nn_2dint_sss 251 WRITE(numout,*) ' Type of horizontal interpolation method for SIC nn_2dint_sic = ', nn_2dint_sic 252 WRITE(numout,*) ' Default E/W diameter of obs footprint rn_default_avglamscl = ', rn_default_avglamscl 253 WRITE(numout,*) ' Default N/S diameter of obs footprint rn_default_avgphiscl = ', rn_default_avgphiscl 254 WRITE(numout,*) ' Default obs footprint in deg [T] or m [F] ln_default_fp_indegs = ', ln_default_fp_indegs 255 WRITE(numout,*) ' SLA E/W diameter of obs footprint rn_sla_avglamscl = ', rn_sla_avglamscl 256 WRITE(numout,*) ' SLA N/S diameter of obs footprint rn_sla_avgphiscl = ', rn_sla_avgphiscl 257 WRITE(numout,*) ' SLA obs footprint in deg [T] or m [F] ln_sla_fp_indegs = ', ln_sla_fp_indegs 258 WRITE(numout,*) ' SST E/W diameter of obs footprint rn_sst_avglamscl = ', rn_sst_avglamscl 259 WRITE(numout,*) ' SST N/S diameter of obs footprint rn_sst_avgphiscl = ', rn_sst_avgphiscl 260 WRITE(numout,*) ' SST obs footprint in deg [T] or m [F] ln_sst_fp_indegs = ', ln_sst_fp_indegs 261 WRITE(numout,*) ' SIC E/W diameter of obs footprint rn_sic_avglamscl = ', rn_sic_avglamscl 262 WRITE(numout,*) ' SIC N/S diameter of obs footprint rn_sic_avgphiscl = ', rn_sic_avgphiscl 263 WRITE(numout,*) ' SIC obs footprint in deg [T] or m [F] ln_sic_fp_indegs = ', ln_sic_fp_indegs 238 264 WRITE(numout,*) ' Rejection of observations near land switch ln_nea = ', ln_nea 239 265 WRITE(numout,*) ' Rejection of obs near open bdys ln_bound_reject = ', ln_bound_reject … … 279 305 IF( ln_t3d .OR. ln_s3d ) THEN 280 306 jtype = jtype + 1 281 CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'prof ', &282 & cn_profbfiles, ifilesprof, cobstypesprof, clproffiles )307 cobstypesprof(jtype) = 'prof' 308 clproffiles(jtype,:) = cn_profbfiles 283 309 ENDIF 284 310 IF( ln_vel3d ) THEN 285 311 jtype = jtype + 1 286 CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'vel ', &287 & cn_velfbfiles, ifilesprof, cobstypesprof, clproffiles )312 cobstypesprof(jtype) = 'vel' 313 clproffiles(jtype,:) = cn_velfbfiles 288 314 ENDIF 315 ! 316 CALL obs_settypefiles( nproftypes, jpmaxnfiles, ifilesprof, cobstypesprof, clproffiles ) 289 317 ! 290 318 ENDIF … … 304 332 IF( ln_sla ) THEN 305 333 jtype = jtype + 1 306 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sla ', & 307 & cn_slafbfiles, ifilessurf, cobstypessurf, clsurffiles ) 308 CALL obs_setinterpopts( nsurftypes, jtype, 'sla ', & 309 & nn_2dint, nn_2dint_sla, & 310 & rn_sla_avglamscl, rn_sla_avgphiscl, & 311 & ln_sla_fp_indegs, .FALSE., & 312 & n2dintsurf, zavglamscl, zavgphiscl, & 313 & lfpindegs, llnightav ) 334 cobstypessurf(jtype) = 'sla' 335 clsurffiles(jtype,:) = cn_slafbfiles 314 336 ENDIF 315 337 IF( ln_sst ) THEN 316 338 jtype = jtype + 1 317 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sst ', & 318 & cn_sstfbfiles, ifilessurf, cobstypessurf, clsurffiles ) 319 CALL obs_setinterpopts( nsurftypes, jtype, 'sst ', & 320 & nn_2dint, nn_2dint_sst, & 321 & rn_sst_avglamscl, rn_sst_avgphiscl, & 322 & ln_sst_fp_indegs, ln_sstnight, & 323 & n2dintsurf, zavglamscl, zavgphiscl, & 324 & lfpindegs, llnightav ) 339 cobstypessurf(jtype) = 'sst' 340 clsurffiles(jtype,:) = cn_sstfbfiles 325 341 ENDIF 326 342 #if defined key_si3 || defined key_cice 327 343 IF( ln_sic ) THEN 328 344 jtype = jtype + 1 329 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sic ', & 330 & cn_sicfbfiles, ifilessurf, cobstypessurf, clsurffiles ) 331 CALL obs_setinterpopts( nsurftypes, jtype, 'sic ', & 332 & nn_2dint, nn_2dint_sic, & 333 & rn_sic_avglamscl, rn_sic_avgphiscl, & 334 & ln_sic_fp_indegs, .FALSE., & 335 & n2dintsurf, zavglamscl, zavgphiscl, & 336 & lfpindegs, llnightav ) 345 cobstypessurf(jtype) = 'sic' 346 clsurffiles(jtype,:) = cn_sicfbfiles 337 347 ENDIF 338 348 #endif 339 349 IF( ln_sss ) THEN 340 350 jtype = jtype + 1 341 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sss ', & 342 & cn_sssfbfiles, ifilessurf, cobstypessurf, clsurffiles ) 343 CALL obs_setinterpopts( nsurftypes, jtype, 'sss ', & 344 & nn_2dint, nn_2dint_sss, & 345 & rn_sss_avglamscl, rn_sss_avgphiscl, & 346 & ln_sss_fp_indegs, .FALSE., & 347 & n2dintsurf, zavglamscl, zavgphiscl, & 348 & lfpindegs, llnightav ) 351 cobstypessurf(jtype) = 'sss' 352 clsurffiles(jtype,:) = cn_sssfbfiles 349 353 ENDIF 354 ! 355 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, ifilessurf, cobstypessurf, clsurffiles ) 356 357 DO jtype = 1, nsurftypes 358 359 IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN 360 IF ( nn_2dint_sla == -1 ) THEN 361 n2dint_type = nn_2dint_default 362 ELSE 363 n2dint_type = nn_2dint_sla 364 ENDIF 365 ztype_avglamscl = rn_sla_avglamscl 366 ztype_avgphiscl = rn_sla_avgphiscl 367 ltype_fp_indegs = ln_sla_fp_indegs 368 ltype_night = .FALSE. 369 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sst' ) THEN 370 IF ( nn_2dint_sst == -1 ) THEN 371 n2dint_type = nn_2dint_default 372 ELSE 373 n2dint_type = nn_2dint_sst 374 ENDIF 375 ztype_avglamscl = rn_sst_avglamscl 376 ztype_avgphiscl = rn_sst_avgphiscl 377 ltype_fp_indegs = ln_sst_fp_indegs 378 ltype_night = ln_sstnight 379 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sic' ) THEN 380 IF ( nn_2dint_sic == -1 ) THEN 381 n2dint_type = nn_2dint_default 382 ELSE 383 n2dint_type = nn_2dint_sic 384 ENDIF 385 ztype_avglamscl = rn_sic_avglamscl 386 ztype_avgphiscl = rn_sic_avgphiscl 387 ltype_fp_indegs = ln_sic_fp_indegs 388 ltype_night = .FALSE. 389 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sss' ) THEN 390 IF ( nn_2dint_sss == -1 ) THEN 391 n2dint_type = nn_2dint_default 392 ELSE 393 n2dint_type = nn_2dint_sss 394 ENDIF 395 ztype_avglamscl = rn_sss_avglamscl 396 ztype_avgphiscl = rn_sss_avgphiscl 397 ltype_fp_indegs = ln_sss_fp_indegs 398 ltype_night = .FALSE. 399 ELSE 400 n2dint_type = nn_2dint_default 401 ztype_avglamscl = rn_default_avglamscl 402 ztype_avgphiscl = rn_default_avgphiscl 403 ltype_fp_indegs = ln_default_fp_indegs 404 ltype_night = .FALSE. 405 ENDIF 406 407 CALL obs_setinterpopts( nsurftypes, jtype, TRIM(cobstypessurf(jtype)), & 408 & nn_2dint_default, n2dint_type, & 409 & ztype_avglamscl, ztype_avgphiscl, & 410 & ltype_fp_indegs, ltype_night, & 411 & n2dintsurf, zavglamscl, zavgphiscl, & 412 & lfpindegs, llnightav ) 413 414 END DO 350 415 ! 351 416 ENDIF … … 369 434 ENDIF 370 435 ! 371 IF( nn_2dint < 0 .OR. nn_2dint > 6 ) THEN372 CALL ctl_stop('dia_obs_init: Choice of horizontal (2D) interpolation method is not available')436 IF( nn_2dint_default < 0 .OR. nn_2dint_default > 6 ) THEN 437 CALL ctl_stop('dia_obs_init: Choice of default horizontal (2D) interpolation method is not available') 373 438 ENDIF 374 439 ! … … 389 454 DO jtype = 1, nproftypes 390 455 ! 391 nvarsprof(jtype) = 2392 456 IF ( TRIM(cobstypesprof(jtype)) == 'prof' ) THEN 393 nextrprof(jtype) = 1 394 llvar1 = ln_t3d 395 llvar2 = ln_s3d 396 zglam1 = glamt 397 zgphi1 = gphit 398 zmask1 = tmask 399 zglam2 = glamt 400 zgphi2 = gphit 401 zmask2 = tmask 402 ENDIF 403 IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN 457 nvarsprof(jtype) = 2 458 nextrprof(jtype) = 1 459 ALLOCATE( llvar (nvarsprof(jtype)) ) 460 ALLOCATE( clvars(nvarsprof(jtype)) ) 461 ALLOCATE( zglam(jpi, jpj, nvarsprof(jtype)) ) 462 ALLOCATE( zgphi(jpi, jpj, nvarsprof(jtype)) ) 463 ALLOCATE( zmask(jpi, jpj, jpk, nvarsprof(jtype)) ) 464 llvar(1) = ln_t3d 465 llvar(2) = ln_s3d 466 clvars(1) = 'POTM' 467 clvars(2) = 'PSAL' 468 zglam(:,:,1) = glamt(:,:) 469 zglam(:,:,2) = glamt(:,:) 470 zgphi(:,:,1) = gphit(:,:) 471 zgphi(:,:,2) = gphit(:,:) 472 zmask(:,:,:,1) = tmask(:,:,:) 473 zmask(:,:,:,2) = tmask(:,:,:) 474 ELSE IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN 475 nvarsprof(jtype) = 2 404 476 nextrprof(jtype) = 2 405 llvar1 = ln_vel3d 406 llvar2 = ln_vel3d 407 zglam1 = glamu 408 zgphi1 = gphiu 409 zmask1 = umask 410 zglam2 = glamv 411 zgphi2 = gphiv 412 zmask2 = vmask 477 ALLOCATE( llvar (nvarsprof(jtype)) ) 478 ALLOCATE( clvars(nvarsprof(jtype)) ) 479 ALLOCATE( zglam(jpi, jpj, nvarsprof(jtype)) ) 480 ALLOCATE( zgphi(jpi, jpj, nvarsprof(jtype)) ) 481 ALLOCATE( zmask(jpi, jpj, jpk, nvarsprof(jtype)) ) 482 llvar(1) = ln_vel3d 483 llvar(2) = ln_vel3d 484 clvars(1) = 'UVEL' 485 clvars(2) = 'VVEL' 486 zglam(:,:,1) = glamu(:,:) 487 zglam(:,:,2) = glamv(:,:) 488 zgphi(:,:,1) = gphiu(:,:) 489 zgphi(:,:,2) = gphiv(:,:) 490 zmask(:,:,:,1) = umask(:,:,:) 491 zmask(:,:,:,2) = vmask(:,:,:) 492 ELSE 493 nvarsprof(jtype) = 1 494 nextrprof(jtype) = 0 495 ALLOCATE( llvar (nvarsprof(jtype)) ) 496 ALLOCATE( clvars(nvarsprof(jtype)) ) 497 ALLOCATE( zglam(jpi, jpj, nvarsprof(jtype)) ) 498 ALLOCATE( zgphi(jpi, jpj, nvarsprof(jtype)) ) 499 ALLOCATE( zmask(jpi, jpj, jpk, nvarsprof(jtype)) ) 500 llvar(1) = .TRUE. 501 zglam(:,:,1) = glamt(:,:) 502 zgphi(:,:,1) = gphit(:,:) 503 zmask(:,:,:,1) = tmask(:,:,:) 413 504 ENDIF 414 505 ! … … 417 508 & clproffiles(jtype,1:ifilesprof(jtype)), & 418 509 & nvarsprof(jtype), nextrprof(jtype), nitend-nit000+2, & 419 & rn_dobsini, rn_dobsend, llvar 1, llvar2, &420 & ln_ignmis, ln_s_at_t, .FALSE., &510 & rn_dobsini, rn_dobsend, llvar, & 511 & ln_ignmis, ln_s_at_t, .FALSE., clvars, & 421 512 & kdailyavtypes = nn_profdavtypes ) 422 513 ! … … 426 517 ! 427 518 CALL obs_pre_prof( profdata(jtype), profdataqc(jtype), & 428 & llvar 1, llvar2, &519 & llvar, & 429 520 & jpi, jpj, jpk, & 430 & zmask 1, zglam1, zgphi1, zmask2, zglam2, zgphi2,&521 & zmask, zglam, zgphi, & 431 522 & ln_nea, ln_bound_reject, & 432 523 & kdailyavtypes = nn_profdavtypes ) 524 ! 525 DEALLOCATE( llvar, clvars, zglam, zgphi, zmask ) 526 ! 433 527 END DO 434 528 ! … … 450 544 IF( TRIM(cobstypessurf(jtype)) == 'sst' ) llnightav(jtype) = ln_sstnight 451 545 ! 546 ALLOCATE( clvars( nvarssurf(jtype) ) ) 547 IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN 548 clvars(1) = 'SLA' 549 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sst' ) THEN 550 clvars(1) = 'SST' 551 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sic' ) THEN 552 clvars(1) = 'ICECONC' 553 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sss' ) THEN 554 clvars(1) = 'SSS' 555 ENDIF 556 ! 452 557 ! Read in surface obs types 453 558 CALL obs_rea_surf( surfdata(jtype), ifilessurf(jtype), & 454 559 & clsurffiles(jtype,1:ifilessurf(jtype)), & 455 560 & nvarssurf(jtype), nextrsurf(jtype), nitend-nit000+2, & 456 & rn_dobsini, rn_dobsend, ln_ignmis, .FALSE., llnightav(jtype) ) 561 & rn_dobsini, rn_dobsend, ln_ignmis, .FALSE., llnightav(jtype), & 562 & clvars ) 457 563 ! 458 564 CALL obs_pre_surf( surfdata(jtype), surfdataqc(jtype), ln_nea, ln_bound_reject ) … … 474 580 & jnumsstbias , cn_sstbiasfiles(1:jnumsstbias) ) 475 581 ENDIF 582 ! 583 DEALLOCATE( clvars ) 476 584 END DO 477 585 ! … … 516 624 INTEGER :: jvar ! Variable number 517 625 INTEGER :: ji, jj ! Loop counters 518 REAL(wp), DIMENSION(jpi,jpj,jpk) :: & 519 & zprofvar1, & ! Model values for 1st variable in a prof ob 520 & zprofvar2 ! Model values for 2nd variable in a prof ob 521 REAL(wp), DIMENSION(jpi,jpj,jpk) :: & 522 & zprofmask1, & ! Mask associated with zprofvar1 523 & zprofmask2 ! Mask associated with zprofvar2 626 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 627 & zprofvar ! Model values for variables in a prof ob 628 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 629 & zprofmask ! Mask associated with zprofvar 524 630 REAL(wp), DIMENSION(jpi,jpj) :: & 525 631 & zsurfvar, & ! Model values equivalent to surface ob. 526 632 & zsurfmask ! Mask associated with surface variable 527 REAL(wp), DIMENSION(jpi,jpj) :: & 528 & zglam1, & ! Model longitudes for prof variable 1 529 & zglam2, & ! Model longitudes for prof variable 2 530 & zgphi1, & ! Model latitudes for prof variable 1 531 & zgphi2 ! Model latitudes for prof variable 2 633 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 634 & zglam, & ! Model longitudes for prof variables 635 & zgphi ! Model latitudes for prof variables 532 636 533 637 !----------------------------------------------------------------------- … … 549 653 DO jtype = 1, nproftypes 550 654 655 ! Allocate local work arrays 656 ALLOCATE( zprofvar (jpi, jpj, jpk, profdataqc(jtype)%nvar) ) 657 ALLOCATE( zprofmask(jpi, jpj, jpk, profdataqc(jtype)%nvar) ) 658 ALLOCATE( zglam (jpi, jpj, profdataqc(jtype)%nvar) ) 659 ALLOCATE( zgphi (jpi, jpj, profdataqc(jtype)%nvar) ) 660 661 ! Defaults which might change 662 DO jvar = 1, profdataqc(jtype)%nvar 663 zprofmask(:,:,:,jvar) = tmask(:,:,:) 664 zglam(:,:,jvar) = glamt(:,:) 665 zgphi(:,:,jvar) = gphit(:,:) 666 END DO 667 551 668 SELECT CASE ( TRIM(cobstypesprof(jtype)) ) 552 669 CASE('prof') 553 zprofvar1(:,:,:) = tsn(:,:,:,jp_tem) 554 zprofvar2(:,:,:) = tsn(:,:,:,jp_sal) 555 zprofmask1(:,:,:) = tmask(:,:,:) 556 zprofmask2(:,:,:) = tmask(:,:,:) 557 zglam1(:,:) = glamt(:,:) 558 zglam2(:,:) = glamt(:,:) 559 zgphi1(:,:) = gphit(:,:) 560 zgphi2(:,:) = gphit(:,:) 670 zprofvar(:,:,:,1) = tsn(:,:,:,jp_tem) 671 zprofvar(:,:,:,2) = tsn(:,:,:,jp_sal) 561 672 CASE('vel') 562 zprofvar 1(:,:,:) = un(:,:,:)563 zprofvar 2(:,:,:) = vn(:,:,:)564 zprofmask 1(:,:,:) = umask(:,:,:)565 zprofmask 2(:,:,:) = vmask(:,:,:)566 zglam 1(:,:) = glamu(:,:)567 zglam 2(:,:) = glamv(:,:)568 zgphi 1(:,:) = gphiu(:,:)569 zgphi 2(:,:) = gphiv(:,:)673 zprofvar(:,:,:,1) = un(:,:,:) 674 zprofvar(:,:,:,2) = vn(:,:,:) 675 zprofmask(:,:,:,1) = umask(:,:,:) 676 zprofmask(:,:,:,2) = vmask(:,:,:) 677 zglam(:,:,1) = glamu(:,:) 678 zglam(:,:,2) = glamv(:,:) 679 zgphi(:,:,1) = gphiu(:,:) 680 zgphi(:,:,2) = gphiv(:,:) 570 681 CASE DEFAULT 571 682 CALL ctl_stop( 'Unknown profile observation type '//TRIM(cobstypesprof(jtype))//' in dia_obs' ) 572 683 END SELECT 573 684 574 CALL obs_prof_opt( profdataqc(jtype), kstp, jpi, jpj, jpk, & 575 & nit000, idaystp, & 576 & zprofvar1, zprofvar2, & 577 & gdept_n(:,:,:), gdepw_n(:,:,:), & 578 & zprofmask1, zprofmask2, & 579 & zglam1, zglam2, zgphi1, zgphi2, & 580 & nn_1dint, nn_2dint, & 581 & kdailyavtypes = nn_profdavtypes ) 685 DO jvar = 1, profdataqc(jtype)%nvar 686 CALL obs_prof_opt( profdataqc(jtype), kstp, jpi, jpj, jpk, & 687 & nit000, idaystp, jvar, & 688 & zprofvar(:,:,:,jvar), & 689 & gdept_n(:,:,:), gdepw_n(:,:,:), & 690 & zprofmask(:,:,:,jvar), & 691 & zglam(:,:,jvar), zgphi(:,:,jvar), & 692 & nn_1dint, nn_2dint_default, & 693 & kdailyavtypes = nn_profdavtypes ) 694 END DO 695 696 DEALLOCATE( zprofvar, zprofmask, zglam, zgphi ) 582 697 583 698 END DO … … 680 795 & ) 681 796 682 CALL obs_rotvel( profdataqc(jtype), nn_2dint , zu, zv )797 CALL obs_rotvel( profdataqc(jtype), nn_2dint_default, zu, zv ) 683 798 684 799 DO jo = 1, profdataqc(jtype)%nprof … … 896 1011 END SUBROUTINE fin_date 897 1012 898 SUBROUTINE obs_settypefiles( ntypes, jpmaxnfiles, jtype, ctypein, &899 & cfilestype, ifiles, cobstypes, cfiles ) 900 901 INTEGER, INTENT(IN) :: ntypes ! Total number of obs types902 INTEGER, INTENT(IN) :: jpmaxnfiles ! Maximum number of files allowed for each type903 INTEGER, INTENT(IN) :: jtype ! Index of the current type of obs904 INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: &905 & ifiles ! Out appended number of files for this type906 907 CHARACTER(len=6), INTENT(IN) :: ctypein908 CHARACTER(len=128), DIMENSION(jpmaxnfiles), INTENT(IN) :: & 909 & cfilestype ! In list of files for this obs type910 CHARACTER(len=6), DIMENSION(ntypes), INTENT(INOUT) :: &911 & cobstypes ! Out appended list of obs types912 CHARACTER(len=128), DIMENSION(ntypes, jpmaxnfiles), INTENT(INOUT) :: & 913 & cfiles ! Out appended list of files for alltypes914 915 !Local variables916 INTEGER :: jfile917 918 cfiles(jtype,:) = cfilestype(:)919 cobstypes(jtype) = ctypein920 ifiles(jtype) = 0 921 DO jfile = 1, jpmaxnfiles922 IF ( trim(cfiles(jtype,jfile)) /= '' )&923 ifiles(jtype) = ifiles(jtype) + 1924 END DO925 926 IF ( ifiles(jtype) == 0 ) THEN927 CALL ctl_stop( 'Logical for observation type '//TRIM(ctypein)// &928 & ' set to true but no files available to read')929 ENDIF930 931 IF(lwp) THEN932 WRITE(numout,*) ' '//cobstypes(jtype)//' input observation file names:' 933 DO jfile = 1, ifiles(jtype)934 WRITE(numout,*) ' '//TRIM(cfiles(jtype,jfile)) 935 END DO936 ENDIF 937 938 END SUBROUTINE obs_settypefiles939 940 SUBROUTINE obs_setinterpopts( ntypes, jtype, ctypein,&941 & n2dint_default, n2dint_type,&942 & zavglamscl_type, zavgphiscl_type, &943 & lfp_indegs_type, lavnight_type, & 944 & n2dint, zavglamscl, zavgphiscl, &945 & lfpindegs, lavnight )946 947 INTEGER, INTENT(IN) :: ntypes ! Total number of obs types948 INTEGER, INTENT(IN) :: jtype ! Index of the current type of obs949 INTEGER, INTENT(IN) :: n2dint_default ! Default option for interpolationtype950 INTEGER, INTENT(IN) :: n2dint_type ! Option for interpolationtype951 REAL(wp), INTENT(IN) :: &952 & zavglamscl_type, & !E/W diameter of obs footprint for this type953 & zavgphiscl_type !N/S diameter of obs footprint for this type954 LOGICAL, INTENT(IN) :: lfp_indegs_type !T=> footprint in degrees, F=> in metres 955 LOGICAL, INTENT(IN) :: lavnight_type !T=> obs represent night time average956 CHARACTER(len=6), INTENT(IN) :: ctypein957 958 INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: &959 & n2dint960 REAL(wp), DIMENSION(ntypes), INTENT(INOUT) :: &961 & zavglamscl, zavgphiscl 962 LOGICAL, DIMENSION(ntypes), INTENT(INOUT) :: &963 & lfpindegs, lavnight 964 965 lavnight(jtype) = lavnight_type966 967 IF ( (n2dint_type >= 1) .AND. (n2dint_type <= 6) ) THEN968 n2dint(jtype) = n2dint_type969 ELSE970 n2dint(jtype) = n2dint_default971 ENDIF972 973 ! For averaging observation footprints set options for size of footprint974 IF ( (n2dint(jtype) > 4) .AND. (n2dint(jtype) <= 6) ) THEN975 IF ( zavglamscl_type > 0._wp ) THEN976 zavglamscl(jtype) = zavglamscl_type977 ELSE978 CALL ctl_stop( 'Incorrect value set for averaging footprint '// &979 'scale (zavglamscl) for observation type '//TRIM(ctypein) )980 ENDIF981 982 IF ( zavgphiscl_type > 0._wp ) THEN983 zavgphiscl(jtype) = zavgphiscl_type984 ELSE985 CALL ctl_stop( 'Incorrect value set for averaging footprint '// &986 'scale (zavgphiscl) for observation type '//TRIM(ctypein) )987 ENDIF988 989 lfpindegs(jtype) = lfp_indegs_type990 991 ENDIF992 993 ! Write out info994 IF(lwp) THEN995 IF ( n2dint(jtype) <= 4 ) THEN996 WRITE(numout,*) ' '//TRIM(ctypein)// &997 & ' model counterparts will be interpolated horizontally'998 ELSE IF ( n2dint(jtype) <= 6 ) THEN999 WRITE(numout,*) ' '//TRIM(ctypein)// &1000 & ' model counterparts will be averaged horizontally'1001 WRITE(numout,*) ' '//' with E/W scale: ',zavglamscl(jtype)1002 WRITE(numout,*) ' '//' with N/S scale: ',zavgphiscl(jtype)1003 IF ( lfpindegs(jtype) ) THEN1004 WRITE(numout,*) ' '//' (in degrees)'1005 ELSE1006 WRITE(numout,*) ' '//' (in metres)'1007 ENDIF1008 ENDIF1009 ENDIF1010 1011 1013 SUBROUTINE obs_settypefiles( ntypes, jpmaxnfiles, ifiles, cobstypes, cfiles ) 1014 1015 INTEGER, INTENT(IN) :: ntypes ! Total number of obs types 1016 INTEGER, INTENT(IN) :: jpmaxnfiles ! Maximum number of files allowed for each type 1017 INTEGER, DIMENSION(ntypes), INTENT(OUT) :: & 1018 & ifiles ! Out number of files for each type 1019 CHARACTER(len=8), DIMENSION(ntypes), INTENT(IN) :: & 1020 & cobstypes ! List of obs types 1021 CHARACTER(len=128), DIMENSION(ntypes, jpmaxnfiles), INTENT(IN) :: & 1022 & cfiles ! List of files for all types 1023 1024 !Local variables 1025 INTEGER :: jfile 1026 INTEGER :: jtype 1027 1028 DO jtype = 1, ntypes 1029 1030 ifiles(jtype) = 0 1031 DO jfile = 1, jpmaxnfiles 1032 IF ( trim(cfiles(jtype,jfile)) /= '' ) & 1033 ifiles(jtype) = ifiles(jtype) + 1 1034 END DO 1035 1036 IF ( ifiles(jtype) == 0 ) THEN 1037 CALL ctl_stop( 'Logical for observation type '//TRIM(cobstypes(jtype))// & 1038 & ' set to true but no files available to read' ) 1039 ENDIF 1040 1041 IF(lwp) THEN 1042 WRITE(numout,*) ' '//cobstypes(jtype)//' input observation file names:' 1043 DO jfile = 1, ifiles(jtype) 1044 WRITE(numout,*) ' '//TRIM(cfiles(jtype,jfile)) 1045 END DO 1046 ENDIF 1047 1048 END DO 1049 1050 END SUBROUTINE obs_settypefiles 1051 1052 SUBROUTINE obs_setinterpopts( ntypes, jtype, ctypein, & 1053 & n2dint_default, n2dint_type, & 1054 & ravglamscl_type, ravgphiscl_type, & 1055 & lfp_indegs_type, lavnight_type, & 1056 & n2dint, ravglamscl, ravgphiscl, & 1057 & lfpindegs, lavnight ) 1058 1059 INTEGER, INTENT(IN) :: ntypes ! Total number of obs types 1060 INTEGER, INTENT(IN) :: jtype ! Index of the current type of obs 1061 INTEGER, INTENT(IN) :: n2dint_default ! Default option for interpolation type 1062 INTEGER, INTENT(IN) :: n2dint_type ! Option for interpolation type 1063 REAL(wp), INTENT(IN) :: & 1064 & ravglamscl_type, & !E/W diameter of obs footprint for this type 1065 & ravgphiscl_type !N/S diameter of obs footprint for this type 1066 LOGICAL, INTENT(IN) :: lfp_indegs_type !T=> footprint in degrees, F=> in metres 1067 LOGICAL, INTENT(IN) :: lavnight_type !T=> obs represent night time average 1068 CHARACTER(len=8), INTENT(IN) :: ctypein 1069 1070 INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: & 1071 & n2dint 1072 REAL(wp), DIMENSION(ntypes), INTENT(INOUT) :: & 1073 & ravglamscl, ravgphiscl 1074 LOGICAL, DIMENSION(ntypes), INTENT(INOUT) :: & 1075 & lfpindegs, lavnight 1076 1077 lavnight(jtype) = lavnight_type 1078 1079 IF ( (n2dint_type >= 0) .AND. (n2dint_type <= 6) ) THEN 1080 n2dint(jtype) = n2dint_type 1081 ELSE IF ( n2dint_type == -1 ) THEN 1082 n2dint(jtype) = n2dint_default 1083 ELSE 1084 CALL ctl_stop(' Choice of '//TRIM(ctypein)//' horizontal (2D) interpolation method', & 1085 & ' is not available') 1086 ENDIF 1087 1088 ! For averaging observation footprints set options for size of footprint 1089 IF ( (n2dint(jtype) > 4) .AND. (n2dint(jtype) <= 6) ) THEN 1090 IF ( ravglamscl_type > 0._wp ) THEN 1091 ravglamscl(jtype) = ravglamscl_type 1092 ELSE 1093 CALL ctl_stop( 'Incorrect value set for averaging footprint '// & 1094 'scale (ravglamscl) for observation type '//TRIM(ctypein) ) 1095 ENDIF 1096 1097 IF ( ravgphiscl_type > 0._wp ) THEN 1098 ravgphiscl(jtype) = ravgphiscl_type 1099 ELSE 1100 CALL ctl_stop( 'Incorrect value set for averaging footprint '// & 1101 'scale (ravgphiscl) for observation type '//TRIM(ctypein) ) 1102 ENDIF 1103 1104 lfpindegs(jtype) = lfp_indegs_type 1105 1106 ENDIF 1107 1108 ! Write out info 1109 IF(lwp) THEN 1110 IF ( n2dint(jtype) <= 4 ) THEN 1111 WRITE(numout,*) ' '//TRIM(ctypein)// & 1112 & ' model counterparts will be interpolated horizontally' 1113 ELSE IF ( n2dint(jtype) <= 6 ) THEN 1114 WRITE(numout,*) ' '//TRIM(ctypein)// & 1115 & ' model counterparts will be averaged horizontally' 1116 WRITE(numout,*) ' '//' with E/W scale: ',ravglamscl(jtype) 1117 WRITE(numout,*) ' '//' with N/S scale: ',ravgphiscl(jtype) 1118 IF ( lfpindegs(jtype) ) THEN 1119 WRITE(numout,*) ' '//' (in degrees)' 1120 ELSE 1121 WRITE(numout,*) ' '//' (in metres)' 1122 ENDIF 1123 ENDIF 1124 ENDIF 1125 1126 END SUBROUTINE obs_setinterpopts 1012 1127 1013 1128 END MODULE diaobs -
NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS/obs_oper.F90
r14075 r15089 38 38 CONTAINS 39 39 40 SUBROUTINE obs_prof_opt( prodatqc, kt, kpi, kpj, kpk, 41 & kit000, kdaystp, 42 & pvar 1, pvar2, pgdept, pgdepw,&43 & pmask 1, pmask2, &44 & plam 1, plam2, pphi1, pphi2,&40 SUBROUTINE obs_prof_opt( prodatqc, kt, kpi, kpj, kpk, & 41 & kit000, kdaystp, kvar, & 42 & pvar, pgdept, pgdepw, & 43 & pmask, & 44 & plam, pphi, & 45 45 & k1dint, k2dint, kdailyavtypes ) 46 46 !!----------------------------------------------------------------------- … … 103 103 INTEGER , INTENT(in ) :: k2dint ! Horizontal interpolation type (see header) 104 104 INTEGER , INTENT(in ) :: kdaystp ! Number of time steps per day 105 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pvar1 , pvar2 ! Model field 1 and 2 106 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pmask1, pmask2 ! Land-sea mask 1 and 2 107 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: plam1 , plam2 ! Model longitude 1 and 2 108 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: pphi1 , pphi2 ! Model latitudes 1 and 2 105 INTEGER , INTENT(in ) :: kvar ! Number of variables in prodatqc 106 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pvar ! Model field 107 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pmask ! Land-sea mask 108 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: plam ! Model longitude 109 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: pphi ! Model latitudes 109 110 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pgdept, pgdepw ! depth of T and W levels 110 111 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: kdailyavtypes ! Types for daily averages … … 126 127 & idailyavtypes 127 128 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 128 & igrdi1, & 129 & igrdi2, & 130 & igrdj1, & 131 & igrdj2 129 & igrdi, & 130 & igrdj 132 131 INTEGER, ALLOCATABLE, DIMENSION(:) :: iv_indic 133 132 … … 136 135 REAL(KIND=wp) :: zdaystp 137 136 REAL(KIND=wp), DIMENSION(kpk) :: & 138 & zobsmask1, & 139 & zobsmask2, & 140 & zobsk, & 137 & zobsk, & 141 138 & zobs2k 142 139 REAL(KIND=wp), DIMENSION(2,2,1) :: & 143 140 & zweig1, & 144 & zweig2, &145 141 & zweig 146 142 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 147 & zmask1, & 148 & zmask2, & 149 & zint1, & 150 & zint2, & 151 & zinm1, & 152 & zinm2, & 143 & zmask, & 144 & zint, & 145 & zinm, & 153 146 & zgdept, & 154 147 & zgdepw 155 148 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 156 & zglam1, & 157 & zglam2, & 158 & zgphi1, & 159 & zgphi2 160 REAL(KIND=wp), DIMENSION(1) :: zmsk_1, zmsk_2 149 & zglam, & 150 & zgphi 151 REAL(KIND=wp), DIMENSION(1) :: zmsk 161 152 REAL(KIND=wp), DIMENSION(:,:,:), ALLOCATABLE :: interp_corner 162 153 … … 187 178 ! Initialize daily mean for first timestep of the day 188 179 IF ( idayend == 1 .OR. kt == 0 ) THEN 189 DO jk = 1, jpk 190 DO jj = 1, jpj 191 DO ji = 1, jpi 192 prodatqc%vdmean(ji,jj,jk,1) = 0.0 193 prodatqc%vdmean(ji,jj,jk,2) = 0.0 194 END DO 195 END DO 196 END DO 197 ENDIF 198 199 DO jk = 1, jpk 200 DO jj = 1, jpj 201 DO ji = 1, jpi 202 ! Increment field 1 for computing daily mean 203 prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 204 & + pvar1(ji,jj,jk) 205 ! Increment field 2 for computing daily mean 206 prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 207 & + pvar2(ji,jj,jk) 208 END DO 209 END DO 210 END DO 180 DO_3D( 1, 1, 1, 1, 1, jpk ) 181 prodatqc%vdmean(ji,jj,jk,kvar) = 0.0 182 END_3D 183 ENDIF 184 185 DO_3D( 1, 1, 1, 1, 1, jpk ) 186 ! Increment field 1 for computing daily mean 187 prodatqc%vdmean(ji,jj,jk,kvar) = prodatqc%vdmean(ji,jj,jk,kvar) & 188 & + pvar(ji,jj,jk) 189 END_3D 211 190 212 191 ! Compute the daily mean at the end of day … … 215 194 IF (lwp) WRITE(numout,*) 'Calculating prodatqc%vdmean on time-step: ',kt 216 195 CALL FLUSH(numout) 217 DO jk = 1, jpk 218 DO jj = 1, jpj 219 DO ji = 1, jpi 220 prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 221 & * zdaystp 222 prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 223 & * zdaystp 224 END DO 225 END DO 226 END DO 196 DO_3D( 1, 1, 1, 1, 1, jpk ) 197 prodatqc%vdmean(ji,jj,jk,kvar) = prodatqc%vdmean(ji,jj,jk,kvar) & 198 & * zdaystp 199 END_3D 227 200 ENDIF 228 201 … … 231 204 ! Get the data for interpolation 232 205 ALLOCATE( & 233 & igrdi1(2,2,ipro), & 234 & igrdi2(2,2,ipro), & 235 & igrdj1(2,2,ipro), & 236 & igrdj2(2,2,ipro), & 237 & zglam1(2,2,ipro), & 238 & zglam2(2,2,ipro), & 239 & zgphi1(2,2,ipro), & 240 & zgphi2(2,2,ipro), & 241 & zmask1(2,2,kpk,ipro), & 242 & zmask2(2,2,kpk,ipro), & 243 & zint1(2,2,kpk,ipro), & 244 & zint2(2,2,kpk,ipro), & 245 & zgdept(2,2,kpk,ipro), & 246 & zgdepw(2,2,kpk,ipro) & 206 & igrdi(2,2,ipro), & 207 & igrdj(2,2,ipro), & 208 & zglam(2,2,ipro), & 209 & zgphi(2,2,ipro), & 210 & zmask(2,2,kpk,ipro), & 211 & zint(2,2,kpk,ipro), & 212 & zgdept(2,2,kpk,ipro), & 213 & zgdepw(2,2,kpk,ipro) & 247 214 & ) 248 215 249 216 DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro 250 217 iobs = jobs - prodatqc%nprofup 251 igrdi1(1,1,iobs) = prodatqc%mi(jobs,1)-1 252 igrdj1(1,1,iobs) = prodatqc%mj(jobs,1)-1 253 igrdi1(1,2,iobs) = prodatqc%mi(jobs,1)-1 254 igrdj1(1,2,iobs) = prodatqc%mj(jobs,1) 255 igrdi1(2,1,iobs) = prodatqc%mi(jobs,1) 256 igrdj1(2,1,iobs) = prodatqc%mj(jobs,1)-1 257 igrdi1(2,2,iobs) = prodatqc%mi(jobs,1) 258 igrdj1(2,2,iobs) = prodatqc%mj(jobs,1) 259 igrdi2(1,1,iobs) = prodatqc%mi(jobs,2)-1 260 igrdj2(1,1,iobs) = prodatqc%mj(jobs,2)-1 261 igrdi2(1,2,iobs) = prodatqc%mi(jobs,2)-1 262 igrdj2(1,2,iobs) = prodatqc%mj(jobs,2) 263 igrdi2(2,1,iobs) = prodatqc%mi(jobs,2) 264 igrdj2(2,1,iobs) = prodatqc%mj(jobs,2)-1 265 igrdi2(2,2,iobs) = prodatqc%mi(jobs,2) 266 igrdj2(2,2,iobs) = prodatqc%mj(jobs,2) 218 igrdi(1,1,iobs) = prodatqc%mi(jobs,kvar)-1 219 igrdj(1,1,iobs) = prodatqc%mj(jobs,kvar)-1 220 igrdi(1,2,iobs) = prodatqc%mi(jobs,kvar)-1 221 igrdj(1,2,iobs) = prodatqc%mj(jobs,kvar) 222 igrdi(2,1,iobs) = prodatqc%mi(jobs,kvar) 223 igrdj(2,1,iobs) = prodatqc%mj(jobs,kvar)-1 224 igrdi(2,2,iobs) = prodatqc%mi(jobs,kvar) 225 igrdj(2,2,iobs) = prodatqc%mj(jobs,kvar) 267 226 END DO 268 227 … … 271 230 zgdepw(:,:,:,:) = 0.0 272 231 273 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi1, igrdj1, plam1, zglam1 ) 274 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi1, igrdj1, pphi1, zgphi1 ) 275 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pmask1, zmask1 ) 276 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pvar1, zint1 ) 277 278 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi2, igrdj2, plam2, zglam2 ) 279 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi2, igrdj2, pphi2, zgphi2 ) 280 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, pmask2, zmask2 ) 281 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, pvar2, zint2 ) 282 283 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pgdept, zgdept ) 284 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pgdepw, zgdepw ) 232 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi, igrdj, plam, zglam ) 233 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi, igrdj, pphi, zgphi ) 234 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pmask, zmask ) 235 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pvar, zint ) 236 237 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pgdept, zgdept ) 238 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pgdepw, zgdepw ) 285 239 286 240 ! At the end of the day also get interpolated means 287 241 IF ( ld_dailyav .AND. idayend == 0 ) THEN 288 242 289 ALLOCATE( & 290 & zinm1(2,2,kpk,ipro), & 291 & zinm2(2,2,kpk,ipro) & 292 & ) 293 294 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, & 295 & prodatqc%vdmean(:,:,:,1), zinm1 ) 296 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, & 297 & prodatqc%vdmean(:,:,:,2), zinm2 ) 243 ALLOCATE( zinm(2,2,kpk,ipro) ) 244 245 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, & 246 & prodatqc%vdmean(:,:,:,kvar), zinm ) 298 247 299 248 ENDIF … … 330 279 ! Horizontal weights 331 280 ! Masked values are calculated later. 332 IF ( prodatqc%npvend(jobs, 1) > 0 ) THEN281 IF ( prodatqc%npvend(jobs,kvar) > 0 ) THEN 333 282 334 283 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 335 & zglam1(:,:,iobs), zgphi1(:,:,iobs), & 336 & zmask1(:,:,1,iobs), zweig1, zmsk_1 ) 337 338 ENDIF 339 340 IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 341 342 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 343 & zglam2(:,:,iobs), zgphi2(:,:,iobs), & 344 & zmask2(:,:,1,iobs), zweig2, zmsk_2 ) 345 346 ENDIF 347 348 IF ( prodatqc%npvend(jobs,1) > 0 ) THEN 284 & zglam(:,:,iobs), zgphi(:,:,iobs), & 285 & zmask(:,:,1,iobs), zweig1, zmsk ) 286 287 ENDIF 288 289 IF ( prodatqc%npvend(jobs,kvar) > 0 ) THEN 349 290 350 291 zobsk(:) = obfillflt … … 356 297 357 298 ! vertically interpolate all 4 corners 358 ista = prodatqc%npvsta(jobs, 1)359 iend = prodatqc%npvend(jobs, 1)299 ista = prodatqc%npvsta(jobs,kvar) 300 iend = prodatqc%npvend(jobs,kvar) 360 301 inum_obs = iend - ista + 1 361 302 ALLOCATE(interp_corner(2,2,inum_obs),iv_indic(inum_obs)) … … 366 307 IF ( k1dint == 1 ) THEN 367 308 CALL obs_int_z1d_spl( kpk, & 368 & zinm 1(iin,ijn,:,iobs), &309 & zinm(iin,ijn,:,iobs), & 369 310 & zobs2k, zgdept(iin,ijn,:,iobs), & 370 & zmask 1(iin,ijn,:,iobs))311 & zmask(iin,ijn,:,iobs)) 371 312 ENDIF 372 313 373 314 CALL obs_level_search(kpk, & 374 315 & zgdept(iin,ijn,:,iobs), & 375 & inum_obs, prodatqc%var( 1)%vdep(ista:iend), &316 & inum_obs, prodatqc%var(kvar)%vdep(ista:iend), & 376 317 & iv_indic) 377 318 378 319 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 379 & prodatqc%var( 1)%vdep(ista:iend), &380 & zinm 1(iin,ijn,:,iobs), &320 & prodatqc%var(kvar)%vdep(ista:iend), & 321 & zinm(iin,ijn,:,iobs), & 381 322 & zobs2k, interp_corner(iin,ijn,:), & 382 323 & zgdept(iin,ijn,:,iobs), & 383 & zmask 1(iin,ijn,:,iobs))324 & zmask(iin,ijn,:,iobs)) 384 325 385 326 ENDDO … … 393 334 394 335 ! vertically interpolate all 4 corners 395 ista = prodatqc%npvsta(jobs, 1)396 iend = prodatqc%npvend(jobs, 1)336 ista = prodatqc%npvsta(jobs,kvar) 337 iend = prodatqc%npvend(jobs,kvar) 397 338 inum_obs = iend - ista + 1 398 339 ALLOCATE(interp_corner(2,2,inum_obs), iv_indic(inum_obs)) … … 402 343 IF ( k1dint == 1 ) THEN 403 344 CALL obs_int_z1d_spl( kpk, & 404 & zint 1(iin,ijn,:,iobs),&345 & zint(iin,ijn,:,iobs),& 405 346 & zobs2k, zgdept(iin,ijn,:,iobs), & 406 & zmask 1(iin,ijn,:,iobs))347 & zmask(iin,ijn,:,iobs)) 407 348 408 349 ENDIF … … 410 351 CALL obs_level_search(kpk, & 411 352 & zgdept(iin,ijn,:,iobs),& 412 & inum_obs, prodatqc%var( 1)%vdep(ista:iend), &353 & inum_obs, prodatqc%var(kvar)%vdep(ista:iend), & 413 354 & iv_indic) 414 355 415 356 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 416 & prodatqc%var( 1)%vdep(ista:iend), &417 & zint 1(iin,ijn,:,iobs), &357 & prodatqc%var(kvar)%vdep(ista:iend), & 358 & zint(iin,ijn,:,iobs), & 418 359 & zobs2k,interp_corner(iin,ijn,:), & 419 360 & zgdept(iin,ijn,:,iobs), & 420 & zmask 1(iin,ijn,:,iobs) )361 & zmask(iin,ijn,:,iobs) ) 421 362 422 363 ENDDO … … 442 383 DO ijn=1,2 443 384 444 depth_loop 1: DO ik=kpk,2,-1445 IF(zmask 1(iin,ijn,ik-1,iobs ) > 0.9 )THEN385 depth_loop: DO ik=kpk,2,-1 386 IF(zmask(iin,ijn,ik-1,iobs ) > 0.9 )THEN 446 387 447 388 zweig(iin,ijn,1) = & 448 389 & zweig1(iin,ijn,1) * & 449 390 & MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) & 450 & - prodatqc%var( 1)%vdep(iend)),0._wp)391 & - prodatqc%var(kvar)%vdep(iend)),0._wp) 451 392 452 EXIT depth_loop 1393 EXIT depth_loop 453 394 454 395 ENDIF 455 396 456 ENDDO depth_loop 1397 ENDDO depth_loop 457 398 458 399 ENDDO … … 460 401 461 402 CALL obs_int_h2d( 1, 1, zweig, interp_corner(:,:,ikn), & 462 & prodatqc%var( 1)%vmod(iend:iend) )403 & prodatqc%var(kvar)%vmod(iend:iend) ) 463 404 464 405 ! Set QC flag for any observations found below the bottom 465 406 ! needed as the check here is more strict than that in obs_prep 466 IF (sum(zweig) == 0.0_wp) prodatqc%var( 1)%nvqc(iend:iend)=4407 IF (sum(zweig) == 0.0_wp) prodatqc%var(kvar)%nvqc(iend:iend)=4 467 408 468 409 ENDDO … … 470 411 DEALLOCATE(interp_corner,iv_indic) 471 412 472 ENDIF 473 474 ! For the second variable 475 IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 476 477 zobsk(:) = obfillflt 478 479 IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN 480 481 IF ( idayend == 0 ) THEN 482 ! Daily averaged data 483 484 ! vertically interpolate all 4 corners 485 ista = prodatqc%npvsta(jobs,2) 486 iend = prodatqc%npvend(jobs,2) 487 inum_obs = iend - ista + 1 488 ALLOCATE(interp_corner(2,2,inum_obs),iv_indic(inum_obs)) 489 490 DO iin=1,2 491 DO ijn=1,2 492 493 IF ( k1dint == 1 ) THEN 494 CALL obs_int_z1d_spl( kpk, & 495 & zinm2(iin,ijn,:,iobs), & 496 & zobs2k, zgdept(iin,ijn,:,iobs), & 497 & zmask2(iin,ijn,:,iobs)) 498 ENDIF 499 500 CALL obs_level_search(kpk, & 501 & zgdept(iin,ijn,:,iobs), & 502 & inum_obs, prodatqc%var(2)%vdep(ista:iend), & 503 & iv_indic) 504 505 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 506 & prodatqc%var(2)%vdep(ista:iend), & 507 & zinm2(iin,ijn,:,iobs), & 508 & zobs2k, interp_corner(iin,ijn,:), & 509 & zgdept(iin,ijn,:,iobs), & 510 & zmask2(iin,ijn,:,iobs)) 511 512 ENDDO 513 ENDDO 514 515 ENDIF !idayend 516 517 ELSE 518 519 ! Point data 520 521 ! vertically interpolate all 4 corners 522 ista = prodatqc%npvsta(jobs,2) 523 iend = prodatqc%npvend(jobs,2) 524 inum_obs = iend - ista + 1 525 ALLOCATE(interp_corner(2,2,inum_obs), iv_indic(inum_obs)) 526 DO iin=1,2 527 DO ijn=1,2 528 529 IF ( k1dint == 1 ) THEN 530 CALL obs_int_z1d_spl( kpk, & 531 & zint2(iin,ijn,:,iobs),& 532 & zobs2k, zgdept(iin,ijn,:,iobs), & 533 & zmask2(iin,ijn,:,iobs)) 534 535 ENDIF 536 537 CALL obs_level_search(kpk, & 538 & zgdept(iin,ijn,:,iobs),& 539 & inum_obs, prodatqc%var(2)%vdep(ista:iend), & 540 & iv_indic) 541 542 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 543 & prodatqc%var(2)%vdep(ista:iend), & 544 & zint2(iin,ijn,:,iobs), & 545 & zobs2k,interp_corner(iin,ijn,:), & 546 & zgdept(iin,ijn,:,iobs), & 547 & zmask2(iin,ijn,:,iobs) ) 548 549 ENDDO 550 ENDDO 551 552 ENDIF 553 554 !------------------------------------------------------------- 555 ! Compute the horizontal interpolation for every profile level 556 !------------------------------------------------------------- 557 558 DO ikn=1,inum_obs 559 iend=ista+ikn-1 560 561 zweig(:,:,1) = 0._wp 562 563 ! This code forces the horizontal weights to be 564 ! zero IF the observation is below the bottom of the 565 ! corners of the interpolation nodes, Or if it is in 566 ! the mask. This is important for observations near 567 ! steep bathymetry 568 DO iin=1,2 569 DO ijn=1,2 570 571 depth_loop2: DO ik=kpk,2,-1 572 IF(zmask2(iin,ijn,ik-1,iobs ) > 0.9 )THEN 573 574 zweig(iin,ijn,1) = & 575 & zweig2(iin,ijn,1) * & 576 & MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) & 577 & - prodatqc%var(2)%vdep(iend)),0._wp) 578 579 EXIT depth_loop2 580 581 ENDIF 582 583 ENDDO depth_loop2 584 585 ENDDO 586 ENDDO 587 588 CALL obs_int_h2d( 1, 1, zweig, interp_corner(:,:,ikn), & 589 & prodatqc%var(2)%vmod(iend:iend) ) 590 591 ! Set QC flag for any observations found below the bottom 592 ! needed as the check here is more strict than that in obs_prep 593 IF (sum(zweig) == 0.0_wp) prodatqc%var(2)%nvqc(iend:iend)=4 594 595 ENDDO 596 597 DEALLOCATE(interp_corner,iv_indic) 598 599 ENDIF 413 ENDIF 600 414 601 415 ENDDO 602 416 603 417 ! Deallocate the data for interpolation 604 DEALLOCATE( & 605 & igrdi1, & 606 & igrdi2, & 607 & igrdj1, & 608 & igrdj2, & 609 & zglam1, & 610 & zglam2, & 611 & zgphi1, & 612 & zgphi2, & 613 & zmask1, & 614 & zmask2, & 615 & zint1, & 616 & zint2, & 418 DEALLOCATE( & 419 & igrdi, & 420 & igrdj, & 421 & zglam, & 422 & zgphi, & 423 & zmask, & 424 & zint, & 617 425 & zgdept, & 618 426 & zgdepw & … … 621 429 ! At the end of the day also get interpolated means 622 430 IF ( ld_dailyav .AND. idayend == 0 ) THEN 623 DEALLOCATE( & 624 & zinm1, & 625 & zinm2 & 626 & ) 431 DEALLOCATE( zinm ) 627 432 ENDIF 628 433 629 prodatqc%nprofup = prodatqc%nprofup + ipro 434 IF ( kvar == prodatqc%nvar ) THEN 435 prodatqc%nprofup = prodatqc%nprofup + ipro 436 ENDIF 630 437 631 438 END SUBROUTINE obs_prof_opt -
NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS/obs_prep.F90
r14075 r15089 241 241 242 242 243 SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var 1, ld_var2, &243 SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var, & 244 244 & kpi, kpj, kpk, & 245 & zmask 1, pglam1, pgphi1, zmask2, pglam2, pgphi2, &245 & zmask, pglam, pgphi, & 246 246 & ld_nea, ld_bound_reject, kdailyavtypes, kqc_cutoff ) 247 247 … … 269 269 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data 270 270 TYPE(obs_prof), INTENT(INOUT) :: prodatqc ! Subset of profile data not failing screening 271 LOGICAL, INTENT(IN) :: ld_var1 ! Observed variables switches272 LOGICAL, INTENT(IN) :: ld_var2271 LOGICAL, DIMENSION(profdata%nvar), INTENT(IN) :: & 272 & ld_var ! Observed variables switches 273 273 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 274 274 LOGICAL, INTENT(IN) :: ld_bound_reject ! Switch for rejecting observations near the boundary … … 276 276 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 277 277 & kdailyavtypes ! Types for daily averages 278 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 279 & zmask1, & 280 & zmask2 281 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 282 & pglam1, & 283 & pglam2, & 284 & pgphi1, & 285 & pgphi2 278 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk,profdata%nvar) :: & 279 & zmask 280 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,profdata%nvar) :: & 281 & pglam, & 282 & pgphi 286 283 INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff ! cut off for QC value 287 284 … … 294 291 INTEGER :: imin0 295 292 INTEGER :: icycle ! Current assimilation cycle 296 ! Counters for observations that are 297 INTEGER :: iotdobs ! - outside time domain 298 INTEGER :: iosdv1obs ! - outside space domain (variable 1) 299 INTEGER :: iosdv2obs ! - outside space domain (variable 2) 300 INTEGER :: ilanv1obs ! - within a model land cell (variable 1) 301 INTEGER :: ilanv2obs ! - within a model land cell (variable 2) 302 INTEGER :: inlav1obs ! - close to land (variable 1) 303 INTEGER :: inlav2obs ! - close to land (variable 2) 304 INTEGER :: ibdyv1obs ! - boundary (variable 1) 305 INTEGER :: ibdyv2obs ! - boundary (variable 2) 306 INTEGER :: igrdobs ! - fail the grid search 307 INTEGER :: iuvchku ! - reject u if v rejected and vice versa 308 INTEGER :: iuvchkv ! 309 ! Global counters for observations that are 310 INTEGER :: iotdobsmpp ! - outside time domain 311 INTEGER :: iosdv1obsmpp ! - outside space domain (variable 1) 312 INTEGER :: iosdv2obsmpp ! - outside space domain (variable 2) 313 INTEGER :: ilanv1obsmpp ! - within a model land cell (variable 1) 314 INTEGER :: ilanv2obsmpp ! - within a model land cell (variable 2) 315 INTEGER :: inlav1obsmpp ! - close to land (variable 1) 316 INTEGER :: inlav2obsmpp ! - close to land (variable 2) 317 INTEGER :: ibdyv1obsmpp ! - boundary (variable 1) 318 INTEGER :: ibdyv2obsmpp ! - boundary (variable 2) 319 INTEGER :: igrdobsmpp ! - fail the grid search 320 INTEGER :: iuvchkumpp ! - reject var1 if var2 rejected and vice versa 321 INTEGER :: iuvchkvmpp ! 293 ! Counters for observations that are 294 INTEGER :: iotdobs ! - outside time domain 295 INTEGER, DIMENSION(profdata%nvar) :: iosdvobs ! - outside space domain 296 INTEGER, DIMENSION(profdata%nvar) :: ilanvobs ! - within a model land cell 297 INTEGER, DIMENSION(profdata%nvar) :: inlavobs ! - close to land 298 INTEGER, DIMENSION(profdata%nvar) :: ibdyvobs ! - boundary 299 INTEGER :: igrdobs ! - fail the grid search 300 INTEGER :: iuvchku ! - reject UVEL if VVEL rejected 301 INTEGER :: iuvchkv ! - reject VVEL if UVEL rejected 302 ! Global counters for observations that are 303 INTEGER :: iotdobsmpp ! - outside time domain 304 INTEGER, DIMENSION(profdata%nvar) :: iosdvobsmpp ! - outside space domain 305 INTEGER, DIMENSION(profdata%nvar) :: ilanvobsmpp ! - within a model land cell 306 INTEGER, DIMENSION(profdata%nvar) :: inlavobsmpp ! - close to land 307 INTEGER, DIMENSION(profdata%nvar) :: ibdyvobsmpp ! - boundary 308 INTEGER :: igrdobsmpp ! - fail the grid search 309 INTEGER :: iuvchkumpp ! - reject UVEL if VVEL rejected 310 INTEGER :: iuvchkvmpp ! - reject VVEL if UVEL rejected 322 311 TYPE(obs_prof_valid) :: llvalid ! Profile selection 323 312 TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & 324 & llvvalid ! var 1,var2selection313 & llvvalid ! var selection 325 314 INTEGER :: jvar ! Variable loop variable 326 315 INTEGER :: jobs ! Obs. loop variable 327 316 INTEGER :: jstp ! Time loop variable 328 317 INTEGER :: inrc ! Time index variable 318 CHARACTER(LEN=256) :: cout1 ! Diagnostic output line 319 CHARACTER(LEN=256) :: cout2 ! Diagnostic output line 329 320 !!---------------------------------------------------------------------- 330 321 … … 341 332 icycle = nn_no ! Assimilation cycle 342 333 343 ! Diagnotics counters for various failures. 344 345 iotdobs = 0 346 igrdobs = 0 347 iosdv1obs = 0 348 iosdv2obs = 0 349 ilanv1obs = 0 350 ilanv2obs = 0 351 inlav1obs = 0 352 inlav2obs = 0 353 ibdyv1obs = 0 354 ibdyv2obs = 0 355 iuvchku = 0 356 iuvchkv = 0 334 ! Diagnostic counters for various failures. 335 336 iotdobs = 0 337 igrdobs = 0 338 iosdvobs(:) = 0 339 ilanvobs(:) = 0 340 inlavobs(:) = 0 341 ibdyvobs(:) = 0 342 iuvchku = 0 343 iuvchkv = 0 357 344 358 345 … … 387 374 ! ----------------------------------------------------------------------- 388 375 389 CALL obs_coo_grd( profdata%nprof, profdata%mi(:,1), profdata%mj(:,1), &390 & profdata%nqc, igrdobs )391 CALL obs_coo_grd( profdata%nprof, profdata%mi(:,2), profdata%mj(:,2), &392 & profdata%nqc, igrdobs )376 DO jvar = 1, profdata%nvar 377 CALL obs_coo_grd( profdata%nprof, profdata%mi(:,jvar), profdata%mj(:,jvar), & 378 & profdata%nqc, igrdobs ) 379 END DO 393 380 394 381 CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) … … 405 392 ! ----------------------------------------------------------------------- 406 393 407 ! Variable 1 408 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(1), & 409 & profdata%npvsta(:,1), profdata%npvend(:,1), & 410 & jpi, jpj, & 411 & jpk, & 412 & profdata%mi, profdata%mj, & 413 & profdata%var(1)%mvk, & 414 & profdata%rlam, profdata%rphi, & 415 & profdata%var(1)%vdep, & 416 & pglam1, pgphi1, & 417 & gdept_1d, zmask1, & 418 & profdata%nqc, profdata%var(1)%nvqc, & 419 & iosdv1obs, ilanv1obs, & 420 & inlav1obs, ld_nea, & 421 & ibdyv1obs, ld_bound_reject, & 422 & iqc_cutoff ) 423 424 CALL obs_mpp_sum_integer( iosdv1obs, iosdv1obsmpp ) 425 CALL obs_mpp_sum_integer( ilanv1obs, ilanv1obsmpp ) 426 CALL obs_mpp_sum_integer( inlav1obs, inlav1obsmpp ) 427 CALL obs_mpp_sum_integer( ibdyv1obs, ibdyv1obsmpp ) 428 429 ! Variable 2 430 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(2), & 431 & profdata%npvsta(:,2), profdata%npvend(:,2), & 432 & jpi, jpj, & 433 & jpk, & 434 & profdata%mi, profdata%mj, & 435 & profdata%var(2)%mvk, & 436 & profdata%rlam, profdata%rphi, & 437 & profdata%var(2)%vdep, & 438 & pglam2, pgphi2, & 439 & gdept_1d, zmask2, & 440 & profdata%nqc, profdata%var(2)%nvqc, & 441 & iosdv2obs, ilanv2obs, & 442 & inlav2obs, ld_nea, & 443 & ibdyv2obs, ld_bound_reject, & 444 & iqc_cutoff ) 445 446 CALL obs_mpp_sum_integer( iosdv2obs, iosdv2obsmpp ) 447 CALL obs_mpp_sum_integer( ilanv2obs, ilanv2obsmpp ) 448 CALL obs_mpp_sum_integer( inlav2obs, inlav2obsmpp ) 449 CALL obs_mpp_sum_integer( ibdyv2obs, ibdyv2obsmpp ) 394 DO jvar = 1, profdata%nvar 395 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(jvar), & 396 & profdata%npvsta(:,jvar), profdata%npvend(:,jvar), & 397 & jpi, jpj, & 398 & jpk, & 399 & profdata%mi, profdata%mj, & 400 & profdata%var(jvar)%mvk, & 401 & profdata%rlam, profdata%rphi, & 402 & profdata%var(jvar)%vdep, & 403 & pglam(:,:,jvar), pgphi(:,:,jvar), & 404 & gdept_1d, zmask(:,:,:,jvar), & 405 & profdata%nqc, profdata%var(jvar)%nvqc, & 406 & iosdvobs(jvar), ilanvobs(jvar), & 407 & inlavobs(jvar), ld_nea, & 408 & ibdyvobs(jvar), ld_bound_reject, & 409 & iqc_cutoff ) 410 411 CALL obs_mpp_sum_integer( iosdvobs(jvar), iosdvobsmpp(jvar) ) 412 CALL obs_mpp_sum_integer( ilanvobs(jvar), ilanvobsmpp(jvar) ) 413 CALL obs_mpp_sum_integer( inlavobs(jvar), inlavobsmpp(jvar) ) 414 CALL obs_mpp_sum_integer( ibdyvobs(jvar), ibdyvobsmpp(jvar) ) 415 END DO 450 416 451 417 ! ----------------------------------------------------------------------- … … 498 464 499 465 WRITE(numout,*) 500 WRITE(numout,*) ' Profiles outside time domain = ', &466 WRITE(numout,*) ' Profiles outside time domain = ', & 501 467 & iotdobsmpp 502 WRITE(numout,*) ' Remaining profiles that failed grid search = ', &468 WRITE(numout,*) ' Remaining profiles that failed grid search = ', & 503 469 & igrdobsmpp 504 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data outside space domain = ', & 505 & iosdv1obsmpp 506 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data at land points = ', & 507 & ilanv1obsmpp 508 IF (ld_nea) THEN 509 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (removed) = ',& 510 & inlav1obsmpp 511 ELSE 512 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (kept) = ',& 513 & inlav1obsmpp 514 ENDIF 515 IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 516 WRITE(numout,*) ' U observation rejected since V rejected = ', & 517 & iuvchku 518 ENDIF 519 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near open boundary (removed) = ',& 520 & ibdyv1obsmpp 521 WRITE(numout,*) ' '//prodatqc%cvars(1)//' data accepted = ', & 522 & prodatqc%nvprotmpp(1) 523 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data outside space domain = ', & 524 & iosdv2obsmpp 525 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data at land points = ', & 526 & ilanv2obsmpp 527 IF (ld_nea) THEN 528 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (removed) = ',& 529 & inlav2obsmpp 530 ELSE 531 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (kept) = ',& 532 & inlav2obsmpp 533 ENDIF 534 IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 535 WRITE(numout,*) ' V observation rejected since U rejected = ', & 536 & iuvchkv 537 ENDIF 538 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near open boundary (removed) = ',& 539 & ibdyv2obsmpp 540 WRITE(numout,*) ' '//prodatqc%cvars(2)//' data accepted = ', & 541 & prodatqc%nvprotmpp(2) 470 DO jvar = 1, profdata%nvar 471 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data outside space domain = ', & 472 & iosdvobsmpp(jvar) 473 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data at land points = ', & 474 & ilanvobsmpp(jvar) 475 IF (ld_nea) THEN 476 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (removed) = ',& 477 & inlavobsmpp(jvar) 478 ELSE 479 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (kept) = ',& 480 & inlavobsmpp(jvar) 481 ENDIF 482 IF ( TRIM(profdata%cvars(jvar)) == 'UVEL' ) THEN 483 WRITE(numout,*) ' U observation rejected since V rejected = ', & 484 & iuvchku 485 ELSE IF ( TRIM(profdata%cvars(jvar)) == 'VVEL' ) THEN 486 WRITE(numout,*) ' V observation rejected since U rejected = ', & 487 & iuvchkv 488 ENDIF 489 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near open boundary (removed) = ',& 490 & ibdyvobsmpp(jvar) 491 WRITE(numout,*) ' '//prodatqc%cvars(jvar)//' data accepted = ', & 492 & prodatqc%nvprotmpp(jvar) 493 END DO 542 494 543 495 WRITE(numout,*) 544 496 WRITE(numout,*) ' Number of observations per time step :' 545 497 WRITE(numout,*) 546 WRITE(numout,'(10X,A,5X,A,5X,A,A)')'Time step','Profiles', & 547 & ' '//prodatqc%cvars(1)//' ', & 548 & ' '//prodatqc%cvars(2)//' ' 549 WRITE(numout,998) 498 WRITE(cout1,'(10X,A9,5X,A8)') 'Time step', 'Profiles' 499 WRITE(cout2,'(10X,A9,5X,A8)') '---------', '--------' 500 DO jvar = 1, prodatqc%nvar 501 WRITE(cout1,'(A,5X,A11)') TRIM(cout1), TRIM(prodatqc%cvars(jvar)) 502 WRITE(cout2,'(A,5X,A11)') TRIM(cout2), '-----------' 503 END DO 504 WRITE(numout,*) cout1 505 WRITE(numout,*) cout2 550 506 ENDIF 551 507 … … 574 530 DO jstp = nit000 - 1, nitend 575 531 inrc = jstp - nit000 + 2 576 WRITE(numout,999) jstp, prodatqc%npstpmpp(inrc), & 577 & prodatqc%nvstpmpp(inrc,1), & 578 & prodatqc%nvstpmpp(inrc,2) 532 WRITE(cout1,'(10X,I9,5X,I8)') jstp, prodatqc%npstpmpp(inrc) 533 DO jvar = 1, prodatqc%nvar 534 WRITE(cout1,'(A,5X,I11)') TRIM(cout1), prodatqc%nvstpmpp(inrc,jvar) 535 END DO 536 WRITE(numout,*) cout1 579 537 END DO 580 538 ENDIF 581 582 998 FORMAT(10X,'---------',5X,'--------',5X,'-----------',5X,'----------------')583 999 FORMAT(10X,I9,5X,I8,5X,I11,5X,I8)584 539 585 540 END SUBROUTINE obs_pre_prof -
NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS/obs_read_prof.F90
r14075 r15089 45 45 SUBROUTINE obs_rea_prof( profdata, knumfiles, cdfilenames, & 46 46 & kvars, kextr, kstp, ddobsini, ddobsend, & 47 & ldvar 1, ldvar2, ldignmis, ldsatt, &48 & ldmod, kdailyavtypes )47 & ldvar, ldignmis, ldsatt, & 48 & ldmod, cdvars, kdailyavtypes ) 49 49 !!--------------------------------------------------------------------- 50 50 !! … … 74 74 INTEGER, INTENT(IN) :: kextr ! Number of extra fields for each var 75 75 INTEGER, INTENT(IN) :: kstp ! Ocean time-step index 76 LOGICAL, INTENT(IN) :: ldvar1 ! Observed variables switches 77 LOGICAL, INTENT(IN) :: ldvar2 76 LOGICAL, DIMENSION(kvars), INTENT(IN) :: ldvar ! Observed variables switches 78 77 LOGICAL, INTENT(IN) :: ldignmis ! Ignore missing files 79 78 LOGICAL, INTENT(IN) :: ldsatt ! Compute salinity at all temperature points … … 81 80 REAL(dp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS 82 81 REAL(dp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS 82 CHARACTER(len=8), DIMENSION(kvars), INTENT(IN) :: cdvars 83 83 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 84 84 & kdailyavtypes ! Types of daily average observations … … 87 87 CHARACTER(LEN=15), PARAMETER :: cpname='obs_rea_prof' 88 88 CHARACTER(len=8) :: clrefdate 89 CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvars 89 CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvarsin 90 90 INTEGER :: jvar 91 91 INTEGER :: ji … … 105 105 INTEGER :: iprof 106 106 INTEGER :: iproftot 107 INTEGER :: ivar1t0 108 INTEGER :: ivar2t0 109 INTEGER :: ivar1t 110 INTEGER :: ivar2t 107 INTEGER, DIMENSION(kvars) :: ivart0 108 INTEGER, DIMENSION(kvars) :: ivart 111 109 INTEGER :: ip3dt 112 110 INTEGER :: ios 113 111 INTEGER :: ioserrcount 114 INTEGER :: ivar1tmpp 115 INTEGER :: ivar2tmpp 112 INTEGER, DIMENSION(kvars) :: ivartmpp 116 113 INTEGER :: ip3dtmpp 117 114 INTEGER :: itype 118 115 INTEGER, DIMENSION(knumfiles) :: & 119 116 & irefdate 120 INTEGER, DIMENSION(ntyp1770+1) :: & 121 & itypvar1, & 122 & itypvar1mpp, & 123 & itypvar2, & 124 & itypvar2mpp 117 INTEGER, DIMENSION(ntyp1770+1,kvars) :: & 118 & itypvar, & 119 & itypvarmpp 120 INTEGER, DIMENSION(:,:), ALLOCATABLE :: & 121 & iobsi, & 122 & iobsj, & 123 & iproc 125 124 INTEGER, DIMENSION(:), ALLOCATABLE :: & 126 & iobsi1, &127 & iobsj1, &128 & iproc1, &129 & iobsi2, &130 & iobsj2, &131 & iproc2, &132 125 & iindx, & 133 126 & ifileidx, & … … 147 140 LOGICAL :: llvalprof 148 141 LOGICAL :: lldavtimset 142 LOGICAL :: llcycle 149 143 TYPE(obfbdata), POINTER, DIMENSION(:) :: & 150 144 & inpfiles … … 152 146 ! Local initialization 153 147 iprof = 0 154 ivar1t0 = 0 155 ivar2t0 = 0 148 ivart0(:) = 0 156 149 ip3dt = 0 157 150 … … 219 212 & ldgrid = .TRUE. ) 220 213 221 IF ( inpfiles(jj)%nvar < 2) THEN214 IF ( inpfiles(jj)%nvar /= kvars ) THEN 222 215 CALL ctl_stop( 'Feedback format error: ', & 223 & ' less than 2vars in profile file' )216 & ' unexpected number of vars in profile file' ) 224 217 ENDIF 225 218 … … 229 222 230 223 IF ( jj == 1 ) THEN 231 ALLOCATE( clvars ( inpfiles(jj)%nvar ) )224 ALLOCATE( clvarsin( inpfiles(jj)%nvar ) ) 232 225 DO ji = 1, inpfiles(jj)%nvar 233 clvars(ji) = inpfiles(jj)%cname(ji) 226 clvarsin(ji) = inpfiles(jj)%cname(ji) 227 IF ( clvarsin(ji) /= cdvars(ji) ) THEN 228 CALL ctl_stop( 'Feedback file variables do not match', & 229 & ' expected variable names for this type' ) 230 ENDIF 234 231 END DO 235 232 ELSE 236 233 DO ji = 1, inpfiles(jj)%nvar 237 IF ( inpfiles(jj)%cname(ji) /= clvars (ji) ) THEN234 IF ( inpfiles(jj)%cname(ji) /= clvarsin(ji) ) THEN 238 235 CALL ctl_stop( 'Feedback file variables not consistent', & 239 236 & ' with previous files for this type' ) … … 308 305 DO ji = 1, inpfiles(jj)%nobs 309 306 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 310 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 311 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 307 llcycle = .TRUE. 308 DO jvar = 1, kvars 309 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 310 llcycle = .FALSE. 311 EXIT 312 ENDIF 313 END DO 314 IF ( llcycle ) CYCLE 312 315 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 313 316 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 317 320 ALLOCATE( zlam(inowin) ) 318 321 ALLOCATE( zphi(inowin) ) 319 ALLOCATE( iobsi1(inowin) ) 320 ALLOCATE( iobsj1(inowin) ) 321 ALLOCATE( iproc1(inowin) ) 322 ALLOCATE( iobsi2(inowin) ) 323 ALLOCATE( iobsj2(inowin) ) 324 ALLOCATE( iproc2(inowin) ) 322 ALLOCATE( iobsi(inowin,kvars) ) 323 ALLOCATE( iobsj(inowin,kvars) ) 324 ALLOCATE( iproc(inowin,kvars) ) 325 325 inowin = 0 326 326 DO ji = 1, inpfiles(jj)%nobs 327 327 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 328 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 329 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 328 llcycle = .TRUE. 329 DO jvar = 1, kvars 330 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 331 llcycle = .FALSE. 332 EXIT 333 ENDIF 334 END DO 335 IF ( llcycle ) CYCLE 330 336 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 331 337 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 336 342 END DO 337 343 338 IF ( TRIM( inpfiles(jj)%cname(1) ) == 'POTM' ) THEN 339 CALL obs_grid_search( inowin, zlam, zphi, iobsi1, iobsj1, & 340 & iproc1, 'T' ) 341 iobsi2(:) = iobsi1(:) 342 iobsj2(:) = iobsj1(:) 343 iproc2(:) = iproc1(:) 344 ELSEIF ( TRIM( inpfiles(jj)%cname(1) ) == 'UVEL' ) THEN 345 CALL obs_grid_search( inowin, zlam, zphi, iobsi1, iobsj1, & 346 & iproc1, 'U' ) 347 CALL obs_grid_search( inowin, zlam, zphi, iobsi2, iobsj2, & 348 & iproc2, 'V' ) 344 ! Assume anything other than velocity is on T grid 345 IF ( TRIM( inpfiles(jj)%cname(1) ) == 'UVEL' ) THEN 346 CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,1), iobsj(:,1), & 347 & iproc(:,1), 'U' ) 348 CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,2), iobsj(:,2), & 349 & iproc(:,2), 'V' ) 350 ELSE 351 CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,1), iobsj(:,1), & 352 & iproc(:,1), 'T' ) 353 IF ( kvars > 1 ) THEN 354 DO jvar = 2, kvars 355 iobsi(:,jvar) = iobsi(:,1) 356 iobsj(:,jvar) = iobsj(:,1) 357 iproc(:,jvar) = iproc(:,1) 358 END DO 359 ENDIF 349 360 ENDIF 350 361 … … 352 363 DO ji = 1, inpfiles(jj)%nobs 353 364 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 354 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 355 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 365 llcycle = .TRUE. 366 DO jvar = 1, kvars 367 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 368 llcycle = .FALSE. 369 EXIT 370 ENDIF 371 END DO 372 IF ( llcycle ) CYCLE 356 373 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 357 374 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN 358 375 inowin = inowin + 1 359 inpfiles(jj)%iproc(ji,1) = iproc1(inowin) 360 inpfiles(jj)%iobsi(ji,1) = iobsi1(inowin) 361 inpfiles(jj)%iobsj(ji,1) = iobsj1(inowin) 362 inpfiles(jj)%iproc(ji,2) = iproc2(inowin) 363 inpfiles(jj)%iobsi(ji,2) = iobsi2(inowin) 364 inpfiles(jj)%iobsj(ji,2) = iobsj2(inowin) 365 IF ( inpfiles(jj)%iproc(ji,1) /= & 366 & inpfiles(jj)%iproc(ji,2) ) THEN 367 CALL ctl_stop( 'Error in obs_read_prof:', & 368 & 'var1 and var2 observation on different processors') 376 DO jvar = 1, kvars 377 inpfiles(jj)%iproc(ji,jvar) = iproc(inowin,jvar) 378 inpfiles(jj)%iobsi(ji,jvar) = iobsi(inowin,jvar) 379 inpfiles(jj)%iobsj(ji,jvar) = iobsj(inowin,jvar) 380 END DO 381 IF ( kvars > 1 ) THEN 382 DO jvar = 2, kvars 383 IF ( inpfiles(jj)%iproc(ji,jvar) /= & 384 & inpfiles(jj)%iproc(ji,1) ) THEN 385 CALL ctl_stop( 'Error in obs_read_prof:', & 386 & 'observation on different processors for different vars') 387 ENDIF 388 END DO 369 389 ENDIF 370 390 ENDIF 371 391 END DO 372 DEALLOCATE( zlam, zphi, iobsi 1, iobsj1, iproc1, iobsi2, iobsj2, iproc2)392 DEALLOCATE( zlam, zphi, iobsi, iobsj, iproc ) 373 393 374 394 DO ji = 1, inpfiles(jj)%nobs 375 395 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 376 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 377 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 396 llcycle = .TRUE. 397 DO jvar = 1, kvars 398 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 399 llcycle = .FALSE. 400 EXIT 401 ENDIF 402 END DO 403 IF ( llcycle ) CYCLE 378 404 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 379 405 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 384 410 ENDIF 385 411 llvalprof = .FALSE. 386 IF ( ldvar1 ) THEN 387 loop_t_count : DO ij = 1,inpfiles(jj)%nlev 388 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 389 & CYCLE 390 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 391 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 392 ivar1t0 = ivar1t0 + 1 393 ENDIF 394 END DO loop_t_count 395 ENDIF 396 IF ( ldvar2 ) THEN 397 loop_s_count : DO ij = 1,inpfiles(jj)%nlev 398 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 399 & CYCLE 400 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 401 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 402 ivar2t0 = ivar2t0 + 1 403 ENDIF 404 END DO loop_s_count 405 ENDIF 406 loop_p_count : DO ij = 1,inpfiles(jj)%nlev 412 DO jvar = 1, kvars 413 IF ( ldvar(jvar) ) THEN 414 DO ij = 1,inpfiles(jj)%nlev 415 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 416 & CYCLE 417 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 418 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 419 ivart0(jvar) = ivart0(jvar) + 1 420 ENDIF 421 END DO 422 ENDIF 423 END DO 424 DO ij = 1,inpfiles(jj)%nlev 407 425 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 408 426 & CYCLE 409 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. &410 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. &411 & ldvar1 ) .OR. &412 & ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. &413 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. &414 & ldvar2 ) ) THEN415 ip3dt = ip3dt + 1416 llvalprof = .TRUE.417 END IF418 END DO loop_p_count427 DO jvar = 1, kvars 428 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 429 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 430 & ldvar(jvar) ) ) THEN 431 ip3dt = ip3dt + 1 432 llvalprof = .TRUE. 433 EXIT 434 ENDIF 435 END DO 436 END DO 419 437 420 438 IF ( llvalprof ) iprof = iprof + 1 … … 438 456 DO ji = 1, inpfiles(jj)%nobs 439 457 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 440 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 441 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 458 llcycle = .TRUE. 459 DO jvar = 1, kvars 460 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 461 llcycle = .FALSE. 462 EXIT 463 ENDIF 464 END DO 465 IF ( llcycle ) CYCLE 442 466 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 443 467 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 453 477 DO ji = 1, inpfiles(jj)%nobs 454 478 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 455 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 456 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 479 llcycle = .TRUE. 480 DO jvar = 1, kvars 481 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 482 llcycle = .FALSE. 483 EXIT 484 ENDIF 485 END DO 486 IF ( llcycle ) CYCLE 457 487 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 458 488 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 470 500 iv3dt(:) = -1 471 501 IF (ldsatt) THEN 472 iv3dt(1) = ip3dt 473 iv3dt(2) = ip3dt 502 iv3dt(:) = ip3dt 474 503 ELSE 475 iv3dt(1) = ivar1t0 476 iv3dt(2) = ivar2t0 504 iv3dt(:) = ivart0(:) 477 505 ENDIF 478 506 CALL obs_prof_alloc( profdata, kvars, kextr, iprof, iv3dt, & … … 483 511 profdata%nprof = 0 484 512 profdata%nvprot(:) = 0 485 profdata%cvars(:) = clvars (:)513 profdata%cvars(:) = clvarsin(:) 486 514 iprof = 0 487 515 488 516 ip3dt = 0 489 ivar1t = 0 490 ivar2t = 0 491 itypvar1 (:) = 0 492 itypvar1mpp(:) = 0 493 494 itypvar2 (:) = 0 495 itypvar2mpp(:) = 0 517 ivart(:) = 0 518 itypvar (:,:) = 0 519 itypvarmpp(:,:) = 0 496 520 497 521 ioserrcount = 0 … … 501 525 ji = iprofidx(iindx(jk)) 502 526 503 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 504 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 505 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 527 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 528 llcycle = .TRUE. 529 DO jvar = 1, kvars 530 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 531 llcycle = .FALSE. 532 EXIT 533 ENDIF 534 END DO 535 IF ( llcycle ) CYCLE 506 536 507 537 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & … … 519 549 520 550 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 521 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 522 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 551 llcycle = .TRUE. 552 DO jvar = 1, kvars 553 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 554 llcycle = .FALSE. 555 EXIT 556 ENDIF 557 END DO 558 IF ( llcycle ) CYCLE 523 559 524 560 loop_prof : DO ij = 1, inpfiles(jj)%nlev … … 527 563 & CYCLE 528 564 529 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 530 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 531 532 llvalprof = .TRUE. 533 EXIT loop_prof 534 535 ENDIF 536 537 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 538 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 539 540 llvalprof = .TRUE. 541 EXIT loop_prof 542 543 ENDIF 565 DO jvar = 1, kvars 566 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 567 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 568 569 llvalprof = .TRUE. 570 EXIT loop_prof 571 572 ENDIF 573 END DO 544 574 545 575 END DO loop_prof … … 573 603 574 604 ! Coordinate search parameters 575 profdata%mi (iprof,1) = inpfiles(jj)%iobsi(ji,1)576 profdata%mj (iprof,1) = inpfiles(jj)%iobsj(ji,1)577 profdata%mi (iprof,2) = inpfiles(jj)%iobsi(ji,2)578 profdata%mj (iprof,2) = inpfiles(jj)%iobsj(ji,2)605 DO jvar = 1, kvars 606 profdata%mi (iprof,jvar) = inpfiles(jj)%iobsi(ji,jvar) 607 profdata%mj (iprof,jvar) = inpfiles(jj)%iobsj(ji,jvar) 608 END DO 579 609 580 610 ! Profile WMO number … … 616 646 IF (ldsatt) THEN 617 647 618 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 619 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 620 & ldvar1 ) .OR. & 621 & ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 622 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 623 & ldvar2 ) ) THEN 624 ip3dt = ip3dt + 1 625 ELSE 626 CYCLE 648 DO jvar = 1, kvars 649 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 650 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 651 & ldvar(jvar) ) ) THEN 652 ip3dt = ip3dt + 1 653 EXIT 654 ELSE IF ( jvar == kvars ) THEN 655 CYCLE loop_p 656 ENDIF 657 END DO 658 659 ENDIF 660 661 DO jvar = 1, kvars 662 663 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 664 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 665 & ldvar(jvar) ) .OR. ldsatt ) THEN 666 667 IF (ldsatt) THEN 668 669 ivart(jvar) = ip3dt 670 671 ELSE 672 673 ivart(jvar) = ivart(jvar) + 1 674 675 ENDIF 676 677 ! Depth of jvar observation 678 profdata%var(jvar)%vdep(ivart(jvar)) = & 679 & inpfiles(jj)%pdep(ij,ji) 680 681 ! Depth of jvar observation QC 682 profdata%var(jvar)%idqc(ivart(jvar)) = & 683 & inpfiles(jj)%idqc(ij,ji) 684 685 ! Depth of jvar observation QC flags 686 profdata%var(jvar)%idqcf(:,ivart(jvar)) = & 687 & inpfiles(jj)%idqcf(:,ij,ji) 688 689 ! Profile index 690 profdata%var(jvar)%nvpidx(ivart(jvar)) = iprof 691 692 ! Vertical index in original profile 693 profdata%var(jvar)%nvlidx(ivart(jvar)) = ij 694 695 ! Profile jvar value 696 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 697 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 698 profdata%var(jvar)%vobs(ivart(jvar)) = & 699 & inpfiles(jj)%pob(ij,ji,jvar) 700 IF ( ldmod ) THEN 701 profdata%var(jvar)%vmod(ivart(jvar)) = & 702 & inpfiles(jj)%padd(ij,ji,1,jvar) 703 ENDIF 704 ! Count number of profile var1 data as function of type 705 itypvar( profdata%ntyp(iprof) + 1, jvar ) = & 706 & itypvar( profdata%ntyp(iprof) + 1, jvar ) + 1 707 ELSE 708 profdata%var(jvar)%vobs(ivart(jvar)) = fbrmdi 709 ENDIF 710 711 ! Profile jvar qc 712 profdata%var(jvar)%nvqc(ivart(jvar)) = & 713 & inpfiles(jj)%ivlqc(ij,ji,jvar) 714 715 ! Profile jvar qc flags 716 profdata%var(jvar)%nvqcf(:,ivart(jvar)) = & 717 & inpfiles(jj)%ivlqcf(:,ij,ji,jvar) 718 719 ! Profile insitu T value 720 IF ( TRIM( inpfiles(jj)%cname(jvar) ) == 'POTM' ) THEN 721 profdata%var(jvar)%vext(ivart(jvar),1) = & 722 & inpfiles(jj)%pext(ij,ji,1) 723 ENDIF 724 627 725 ENDIF 628 629 ENDIF 630 631 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 632 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 633 & ldvar1 ) .OR. ldsatt ) THEN 634 635 IF (ldsatt) THEN 636 637 ivar1t = ip3dt 638 639 ELSE 640 641 ivar1t = ivar1t + 1 642 643 ENDIF 644 645 ! Depth of var1 observation 646 profdata%var(1)%vdep(ivar1t) = & 647 & inpfiles(jj)%pdep(ij,ji) 648 649 ! Depth of var1 observation QC 650 profdata%var(1)%idqc(ivar1t) = & 651 & inpfiles(jj)%idqc(ij,ji) 652 653 ! Depth of var1 observation QC flags 654 profdata%var(1)%idqcf(:,ivar1t) = & 655 & inpfiles(jj)%idqcf(:,ij,ji) 656 657 ! Profile index 658 profdata%var(1)%nvpidx(ivar1t) = iprof 659 660 ! Vertical index in original profile 661 profdata%var(1)%nvlidx(ivar1t) = ij 662 663 ! Profile var1 value 664 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 665 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 666 profdata%var(1)%vobs(ivar1t) = & 667 & inpfiles(jj)%pob(ij,ji,1) 668 IF ( ldmod ) THEN 669 profdata%var(1)%vmod(ivar1t) = & 670 & inpfiles(jj)%padd(ij,ji,1,1) 671 ENDIF 672 ! Count number of profile var1 data as function of type 673 itypvar1( profdata%ntyp(iprof) + 1 ) = & 674 & itypvar1( profdata%ntyp(iprof) + 1 ) + 1 675 ELSE 676 profdata%var(1)%vobs(ivar1t) = fbrmdi 677 ENDIF 678 679 ! Profile var1 qc 680 profdata%var(1)%nvqc(ivar1t) = & 681 & inpfiles(jj)%ivlqc(ij,ji,1) 682 683 ! Profile var1 qc flags 684 profdata%var(1)%nvqcf(:,ivar1t) = & 685 & inpfiles(jj)%ivlqcf(:,ij,ji,1) 686 687 ! Profile insitu T value 688 IF ( TRIM( inpfiles(jj)%cname(1) ) == 'POTM' ) THEN 689 profdata%var(1)%vext(ivar1t,1) = & 690 & inpfiles(jj)%pext(ij,ji,1) 691 ENDIF 692 693 ENDIF 694 695 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 696 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 697 & ldvar2 ) .OR. ldsatt ) THEN 698 699 IF (ldsatt) THEN 700 701 ivar2t = ip3dt 702 703 ELSE 704 705 ivar2t = ivar2t + 1 706 707 ENDIF 708 709 ! Depth of var2 observation 710 profdata%var(2)%vdep(ivar2t) = & 711 & inpfiles(jj)%pdep(ij,ji) 712 713 ! Depth of var2 observation QC 714 profdata%var(2)%idqc(ivar2t) = & 715 & inpfiles(jj)%idqc(ij,ji) 716 717 ! Depth of var2 observation QC flags 718 profdata%var(2)%idqcf(:,ivar2t) = & 719 & inpfiles(jj)%idqcf(:,ij,ji) 720 721 ! Profile index 722 profdata%var(2)%nvpidx(ivar2t) = iprof 723 724 ! Vertical index in original profile 725 profdata%var(2)%nvlidx(ivar2t) = ij 726 727 ! Profile var2 value 728 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) ) .AND. & 729 & ( .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) ) THEN 730 profdata%var(2)%vobs(ivar2t) = & 731 & inpfiles(jj)%pob(ij,ji,2) 732 IF ( ldmod ) THEN 733 profdata%var(2)%vmod(ivar2t) = & 734 & inpfiles(jj)%padd(ij,ji,1,2) 735 ENDIF 736 ! Count number of profile var2 data as function of type 737 itypvar2( profdata%ntyp(iprof) + 1 ) = & 738 & itypvar2( profdata%ntyp(iprof) + 1 ) + 1 739 ELSE 740 profdata%var(2)%vobs(ivar2t) = fbrmdi 741 ENDIF 742 743 ! Profile var2 qc 744 profdata%var(2)%nvqc(ivar2t) = & 745 & inpfiles(jj)%ivlqc(ij,ji,2) 746 747 ! Profile var2 qc flags 748 profdata%var(2)%nvqcf(:,ivar2t) = & 749 & inpfiles(jj)%ivlqcf(:,ij,ji,2) 750 751 ENDIF 726 727 END DO 752 728 753 729 END DO loop_p … … 763 739 !----------------------------------------------------------------------- 764 740 765 CALL obs_mpp_sum_integer ( ivar1t0, ivar1tmpp ) 766 CALL obs_mpp_sum_integer ( ivar2t0, ivar2tmpp ) 741 DO jvar = 1, kvars 742 CALL obs_mpp_sum_integer ( ivart0(jvar), ivartmpp(jvar) ) 743 END DO 767 744 CALL obs_mpp_sum_integer ( ip3dt, ip3dtmpp ) 768 745 769 CALL obs_mpp_sum_integers( itypvar1, itypvar1mpp, ntyp1770 + 1 ) 770 CALL obs_mpp_sum_integers( itypvar2, itypvar2mpp, ntyp1770 + 1 ) 746 DO jvar = 1, kvars 747 CALL obs_mpp_sum_integers( itypvar(:,jvar), itypvarmpp(:,jvar), ntyp1770 + 1 ) 748 END DO 771 749 772 750 !----------------------------------------------------------------------- … … 778 756 WRITE(numout,'(1X,A)') '------------' 779 757 WRITE(numout,*) 780 WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(1) ) 781 WRITE(numout,'(1X,A)') '------------------------' 782 DO ji = 0, ntyp1770 783 IF ( itypvar1mpp(ji+1) > 0 ) THEN 784 WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 785 & cwmonam1770(ji)(1:52),' = ', & 786 & itypvar1mpp(ji+1) 787 ENDIF 758 DO jvar = 1, kvars 759 WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(jvar) ) 760 WRITE(numout,'(1X,A)') '------------------------' 761 DO ji = 0, ntyp1770 762 IF ( itypvarmpp(ji+1,jvar) > 0 ) THEN 763 WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 764 & cwmonam1770(ji)(1:52),' = ', & 765 & itypvarmpp(ji+1,jvar) 766 ENDIF 767 END DO 768 WRITE(numout,'(1X,A)') & 769 & '---------------------------------------------------------------' 770 WRITE(numout,'(1X,A55,I8)') & 771 & 'Total profile data for variable '//TRIM( profdata%cvars(jvar) )// & 772 & ' = ', ivartmpp(jvar) 773 WRITE(numout,'(1X,A)') & 774 & '---------------------------------------------------------------' 775 WRITE(numout,*) 788 776 END DO 789 WRITE(numout,'(1X,A)') & 790 & '---------------------------------------------------------------' 791 WRITE(numout,'(1X,A55,I8)') & 792 & 'Total profile data for variable '//TRIM( profdata%cvars(1) )// & 793 & ' = ', ivar1tmpp 794 WRITE(numout,'(1X,A)') & 795 & '---------------------------------------------------------------' 796 WRITE(numout,*) 797 WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(2) ) 798 WRITE(numout,'(1X,A)') '------------------------' 799 DO ji = 0, ntyp1770 800 IF ( itypvar2mpp(ji+1) > 0 ) THEN 801 WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 802 & cwmonam1770(ji)(1:52),' = ', & 803 & itypvar2mpp(ji+1) 804 ENDIF 777 ENDIF 778 779 IF (ldsatt) THEN 780 profdata%nvprot(:) = ip3dt 781 profdata%nvprotmpp(:) = ip3dtmpp 782 ELSE 783 DO jvar = 1, kvars 784 profdata%nvprot(jvar) = ivart(jvar) 785 profdata%nvprotmpp(jvar) = ivartmpp(jvar) 805 786 END DO 806 WRITE(numout,'(1X,A)') &807 & '---------------------------------------------------------------'808 WRITE(numout,'(1X,A55,I8)') &809 & 'Total profile data for variable '//TRIM( profdata%cvars(2) )// &810 & ' = ', ivar2tmpp811 WRITE(numout,'(1X,A)') &812 & '---------------------------------------------------------------'813 WRITE(numout,*)814 ENDIF815 816 IF (ldsatt) THEN817 profdata%nvprot(1) = ip3dt818 profdata%nvprot(2) = ip3dt819 profdata%nvprotmpp(1) = ip3dtmpp820 profdata%nvprotmpp(2) = ip3dtmpp821 ELSE822 profdata%nvprot(1) = ivar1t823 profdata%nvprot(2) = ivar2t824 profdata%nvprotmpp(1) = ivar1tmpp825 profdata%nvprotmpp(2) = ivar2tmpp826 787 ENDIF 827 788 profdata%nprof = iprof … … 830 791 ! Model level search 831 792 !----------------------------------------------------------------------- 832 IF ( ldvar1 ) THEN 833 CALL obs_level_search( jpk, gdept_1d, & 834 & profdata%nvprot(1), profdata%var(1)%vdep, & 835 & profdata%var(1)%mvk ) 836 ENDIF 837 IF ( ldvar2 ) THEN 838 CALL obs_level_search( jpk, gdept_1d, & 839 & profdata%nvprot(2), profdata%var(2)%vdep, & 840 & profdata%var(2)%mvk ) 841 ENDIF 793 DO jvar = 1, kvars 794 IF ( ldvar(jvar) ) THEN 795 CALL obs_level_search( jpk, gdept_1d, & 796 & profdata%nvprot(jvar), profdata%var(jvar)%vdep, & 797 & profdata%var(jvar)%mvk ) 798 ENDIF 799 END DO 842 800 843 801 !----------------------------------------------------------------------- … … 852 810 ! Deallocate temporary data 853 811 !----------------------------------------------------------------------- 854 DEALLOCATE( ifileidx, iprofidx, zdat, clvars )812 DEALLOCATE( ifileidx, iprofidx, zdat, clvarsin ) 855 813 856 814 !----------------------------------------------------------------------- -
NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS/obs_read_surf.F90
r14075 r15089 40 40 SUBROUTINE obs_rea_surf( surfdata, knumfiles, cdfilenames, & 41 41 & kvars, kextr, kstp, ddobsini, ddobsend, & 42 & ldignmis, ldmod, ldnightav )42 & ldignmis, ldmod, ldnightav, cdvars ) 43 43 !!--------------------------------------------------------------------- 44 44 !! … … 73 73 REAL(dp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS 74 74 REAL(dp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS 75 CHARACTER(len=8), DIMENSION(kvars), INTENT(IN) :: cdvars 75 76 76 77 !! * Local declarations 77 78 CHARACTER(LEN=11), PARAMETER :: cpname='obs_rea_surf' 78 79 CHARACTER(len=8) :: clrefdate 79 CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvars 80 CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvarsin 80 81 INTEGER :: ji 81 82 INTEGER :: jj … … 178 179 & ldgrid = .TRUE. ) 179 180 181 IF ( inpfiles(jj)%nvar /= kvars ) THEN 182 CALL ctl_stop( 'Feedback format error: ', & 183 & ' unexpected number of vars in feedback file' ) 184 ENDIF 185 180 186 IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN 181 187 CALL ctl_stop( 'Model not in input data' ) … … 184 190 185 191 IF ( jj == 1 ) THEN 186 ALLOCATE( clvars ( inpfiles(jj)%nvar ) )192 ALLOCATE( clvarsin( inpfiles(jj)%nvar ) ) 187 193 DO ji = 1, inpfiles(jj)%nvar 188 clvars(ji) = inpfiles(jj)%cname(ji) 194 clvarsin(ji) = inpfiles(jj)%cname(ji) 195 IF ( clvarsin(ji) /= cdvars(ji) ) THEN 196 CALL ctl_stop( 'Feedback file variables do not match', & 197 & ' expected variable names for this type' ) 198 ENDIF 189 199 END DO 190 200 ELSE 191 201 DO ji = 1, inpfiles(jj)%nvar 192 IF ( inpfiles(jj)%cname(ji) /= clvars (ji) ) THEN202 IF ( inpfiles(jj)%cname(ji) /= clvarsin(ji) ) THEN 193 203 CALL ctl_stop( 'Feedback file variables not consistent', & 194 204 & ' with previous files for this type' ) … … 347 357 iobs = 0 348 358 349 surfdata%cvars(:) = clvars (:)359 surfdata%cvars(:) = clvarsin(:) 350 360 351 361 ityp (:) = 0 … … 480 490 ! Deallocate temporary data 481 491 !----------------------------------------------------------------------- 482 DEALLOCATE( ifileidx, isurfidx, zdat, clvars )492 DEALLOCATE( ifileidx, isurfidx, zdat, clvarsin ) 483 493 484 494 !----------------------------------------------------------------------- -
NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS/obs_write.F90
r14075 r15089 84 84 CHARACTER(LEN=40) :: clfname 85 85 CHARACTER(LEN=10) :: clfiletype 86 CHARACTER(LEN=ilenlong) :: cllongname ! Long name of variable 87 CHARACTER(LEN=ilenunit) :: clunits ! Units of variable 88 CHARACTER(LEN=ilengrid) :: clgrid ! Grid of variable 89 CHARACTER(LEN=12) :: clfmt ! writing format 90 INTEGER :: idg ! number of digits 86 91 INTEGER :: ilevel 87 92 INTEGER :: jvar … … 111 116 ! Find maximum level 112 117 ilevel = 0 113 DO jvar = 1, 2118 DO jvar = 1, profdata%nvar 114 119 ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) ) 115 120 END DO … … 176 181 177 182 END SELECT 183 184 IF ( ( TRIM(profdata%cvars(1)) /= 'POTM' ) .AND. & 185 & ( TRIM(profdata%cvars(1)) /= 'UVEL' ) ) THEN 186 CALL alloc_obfbdata( fbdata, 1, profdata%nprof, ilevel, & 187 & 1 + iadd, iext, .TRUE. ) 188 fbdata%cname(1) = profdata%cvars(1) 189 fbdata%coblong(1) = cllongname 190 fbdata%cobunit(1) = clunits 191 fbdata%caddlong(1,1) = 'Model interpolated ' // TRIM(cllongname) 192 fbdata%caddunit(1,1) = clunits 193 fbdata%cgrid(:) = clgrid 194 DO je = 1, iext 195 fbdata%cextname(je) = pext%cdname(je) 196 fbdata%cextlong(je) = pext%cdlong(je,1) 197 fbdata%cextunit(je) = pext%cdunit(je,1) 198 END DO 199 DO ja = 1, iadd 200 fbdata%caddname(1+ja) = padd%cdname(ja) 201 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 202 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 203 END DO 204 ENDIF 178 205 179 206 fbdata%caddname(1) = 'Hx' … … 228 255 & krefdate = 19500101 ) 229 256 ! Reform the profiles arrays for output 230 DO jvar = 1, 2257 DO jvar = 1, profdata%nvar 231 258 DO jk = profdata%npvsta(jo,jvar), profdata%npvend(jo,jvar) 232 259 ik = profdata%var(jvar)%nvlidx(jk) … … 323 350 CHARACTER(LEN=40) :: clfname ! netCDF filename 324 351 CHARACTER(LEN=10) :: clfiletype 352 CHARACTER(LEN=ilenlong) :: cllongname ! Long name of variable 353 CHARACTER(LEN=ilenunit) :: clunits ! Units of variable 354 CHARACTER(LEN=ilengrid) :: clgrid ! Grid of variable 325 355 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_surf' 326 356 INTEGER :: jo … … 346 376 SELECT CASE ( TRIM(surfdata%cvars(1)) ) 347 377 CASE('SLA') 378 379 ! SLA needs special treatment because of MDT, so is all done here 380 ! Other variables are done more generically 381 ! No climatology for SLA, MDT is our best estimate of that and is already output. 348 382 349 383 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & … … 376 410 CASE('SST') 377 411 412 clfiletype = 'sstfb' 413 cllongname = 'Sea surface temperature' 414 clunits = 'Degree centigrade' 415 clgrid = 'T' 416 417 CASE('ICECONC') 418 419 clfiletype = 'sicfb' 420 cllongname = 'Sea ice concentration' 421 clunits = 'Fraction' 422 clgrid = 'T' 423 424 CASE('SSS') 425 426 clfiletype = 'sssfb' 427 cllongname = 'Sea surface salinity' 428 clunits = 'psu' 429 clgrid = 'T' 430 431 CASE DEFAULT 432 433 CALL ctl_stop( 'Unknown observation type '//TRIM(surfdata%cvars(1))//' in obs_wri_surf' ) 434 435 END SELECT 436 437 ! SLA needs special treatment because of MDT, so is done above 438 ! Remaining variables treated more generically 439 440 IF ( TRIM(surfdata%cvars(1)) /= 'SLA' ) THEN 441 378 442 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 379 443 & 1 + iadd, iext, .TRUE. ) 380 444 381 clfiletype = 'sstfb'382 445 fbdata%cname(1) = surfdata%cvars(1) 383 fbdata%coblong(1) = 'Sea surface temperature'384 fbdata%cobunit(1) = 'Degree centigrade'446 fbdata%coblong(1) = cllongname 447 fbdata%cobunit(1) = clunits 385 448 DO je = 1, iext 386 449 fbdata%cextname(je) = pext%cdname(je) 387 450 fbdata%cextlong(je) = pext%cdlong(je,1) 388 451 fbdata%cextunit(je) = pext%cdunit(je,1) 389 END DO 390 fbdata%caddlong(1,1) = 'Model interpolated SST' 391 fbdata%caddunit(1,1) = 'Degree centigrade' 392 fbdata%cgrid(1) = 'T' 452 END DO 453 IF ( TRIM(surfdata%cvars(1)) == 'ICECONC' ) THEN 454 fbdata%caddlong(1,1) = 'Model interpolated ICE' 455 ELSE 456 fbdata%caddlong(1,1) = 'Model interpolated ' // TRIM(surfdata%cvars(1)) 457 ENDIF 458 fbdata%caddunit(1,1) = clunits 459 fbdata%cgrid(1) = clgrid 393 460 DO ja = 1, iadd 394 461 fbdata%caddname(1+ja) = padd%cdname(ja) … … 396 463 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 397 464 END DO 398 399 CASE('ICECONC') 400 401 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 402 & 1 + iadd, iext, .TRUE. ) 403 404 clfiletype = 'sicfb' 405 fbdata%cname(1) = surfdata%cvars(1) 406 fbdata%coblong(1) = 'Sea ice' 407 fbdata%cobunit(1) = 'Fraction' 408 DO je = 1, iext 409 fbdata%cextname(je) = pext%cdname(je) 410 fbdata%cextlong(je) = pext%cdlong(je,1) 411 fbdata%cextunit(je) = pext%cdunit(je,1) 412 END DO 413 fbdata%caddlong(1,1) = 'Model interpolated ICE' 414 fbdata%caddunit(1,1) = 'Fraction' 415 fbdata%cgrid(1) = 'T' 416 DO ja = 1, iadd 417 fbdata%caddname(1+ja) = padd%cdname(ja) 418 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 419 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 420 END DO 421 422 CASE('SSS') 423 424 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 425 & 1 + iadd, iext, .TRUE. ) 426 427 clfiletype = 'sssfb' 428 fbdata%cname(1) = surfdata%cvars(1) 429 fbdata%coblong(1) = 'Sea surface salinity' 430 fbdata%cobunit(1) = 'psu' 431 DO je = 1, iext 432 fbdata%cextname(je) = pext%cdname(je) 433 fbdata%cextlong(je) = pext%cdlong(je,1) 434 fbdata%cextunit(je) = pext%cdunit(je,1) 435 END DO 436 fbdata%caddlong(1,1) = 'Model interpolated SSS' 437 fbdata%caddunit(1,1) = 'psu' 438 fbdata%cgrid(1) = 'T' 439 DO ja = 1, iadd 440 fbdata%caddname(1+ja) = padd%cdname(ja) 441 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 442 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 443 END DO 444 445 CASE DEFAULT 446 447 CALL ctl_stop( 'Unknown observation type '//TRIM(surfdata%cvars(1))//' in obs_wri_surf' ) 448 449 END SELECT 465 ENDIF 450 466 451 467 fbdata%caddname(1) = 'Hx'
Note: See TracChangeset
for help on using the changeset viewer.