- Timestamp:
- 2022-04-25T17:15:21+02:00 (2 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/UKMO/NEMO_4.0.4_FOAM_package/src/OCE/OBS/diaobs.F90
r14075 r15799 26 26 !! fin_date : Compute the final date YYYYMMDD.HHMMSS 27 27 !!---------------------------------------------------------------------- 28 USE par_kind ! Precision variables 29 USE in_out_manager ! I/O manager 30 USE par_oce ! ocean parameter 31 USE dom_oce ! Ocean space and time domain variables 32 USE sbc_oce ! Sea-ice fraction 28 USE par_kind ! Precision variables 29 USE in_out_manager ! I/O manager 30 USE timing ! Timing 31 USE par_oce ! ocean parameter 32 USE dom_oce ! Ocean space and time domain variables 33 USE sbc_oce ! Sea-ice fraction 33 34 ! 34 USE obs_read_prof ! Reading and allocation of profile obs 35 USE obs_read_surf ! Reading and allocation of surface obs 36 USE obs_sstbias ! Bias correction routine for SST 37 USE obs_readmdt ! Reading and allocation of MDT for SLA. 38 USE obs_prep ! Preparation of obs. (grid search etc). 39 USE obs_oper ! Observation operators 40 USE obs_write ! Writing of observation related diagnostics 41 USE obs_grid ! Grid searching 42 USE obs_read_altbias ! Bias treatment for altimeter 43 USE obs_profiles_def ! Profile data definitions 44 USE obs_surf_def ! Surface data definitions 45 USE obs_types ! Definitions for observation types 35 USE obs_read_prof ! Reading and allocation of profile obs 36 USE obs_read_surf ! Reading and allocation of surface obs 37 USE obs_bias ! Bias correction routine 38 USE obs_readmdt ! Reading and allocation of MDT for SLA. 39 USE obs_readsnowdepth ! Get model snow depth for conversion of freeboard to ice thickness 40 USE obs_prep ! Preparation of obs. (grid search etc). 41 USE obs_oper ! Observation operators 42 USE obs_write ! Writing of observation related diagnostics 43 USE obs_grid ! Grid searching 44 USE obs_read_altbias ! Bias treatment for altimeter 45 USE obs_profiles_def ! Profile data definitions 46 USE obs_surf_def ! Surface data definitions 47 USE obs_types ! Definitions for observation types 48 USE obs_group_def ! Definitions for observation groups 46 49 ! 47 USE mpp_map ! MPP mapping48 USE lib_mpp ! For ctl_warn/stop50 USE mpp_map ! MPP mapping 51 USE lib_mpp ! For ctl_warn/stop 49 52 50 53 IMPLICIT NONE … … 54 57 PUBLIC dia_obs ! Compute model equivalent to observations 55 58 PUBLIC dia_obs_wri ! Write model equivalent to observations 56 PUBLIC dia_obs_dealloc ! Deallocate dia_obs data57 59 PUBLIC calc_date ! Compute the date of a timestep 58 60 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 81 INTEGER, DIMENSION(imaxavtypes) :: nn_profdavtypes ! Profile data types representing a daily average 82 INTEGER :: nproftypes ! Number of profile obs types 83 INTEGER :: nsurftypes ! Number of surface obs types 84 INTEGER , DIMENSION(:), ALLOCATABLE :: nvarsprof, nvarssurf ! Number of profile & surface variables 85 INTEGER , DIMENSION(:), ALLOCATABLE :: nextrprof, nextrsurf ! Number of profile & surface extra variables 86 INTEGER , DIMENSION(:), ALLOCATABLE :: n2dintsurf ! Interpolation option for surface variables 87 REAL(wp), DIMENSION(:), ALLOCATABLE :: zavglamscl, zavgphiscl ! E/W & N/S diameter of averaging footprint for surface variables 88 LOGICAL , DIMENSION(:), ALLOCATABLE :: lfpindegs ! T=> surface obs footprint size specified in degrees, F=> in metres 89 LOGICAL , DIMENSION(:), ALLOCATABLE :: llnightav ! Logical for calculating night-time averages 90 91 TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) :: surfdata !: Initial surface data 92 TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) :: surfdataqc !: Surface data after quality control 93 TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: profdata !: Initial profile data 94 TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: profdataqc !: Profile data after quality control 95 96 CHARACTER(len=6), PUBLIC, DIMENSION(:), ALLOCATABLE :: cobstypesprof, cobstypessurf !: Profile & surface obs types 61 LOGICAL, PUBLIC :: ln_diaobs !: Logical switch for the obs operator 62 63 INTEGER :: nn_obsgroups 64 65 TYPE(obs_group), DIMENSION(:), ALLOCATABLE :: sobsgroups ! Obs groups 97 66 98 67 !!---------------------------------------------------------------------- … … 114 83 !! 115 84 !!---------------------------------------------------------------------- 116 INTEGER, PARAMETER :: jpmaxnfiles = 1000 ! Maximum number of files for each obs type 117 INTEGER, DIMENSION(:), ALLOCATABLE :: ifilesprof, ifilessurf ! Number of profile & surface files 85 #if defined key_si3 86 USE ice, ONLY : & ! Sea ice variables 87 & hm_s ! Snow depth for freeboard conversion 88 #elif defined key_cice 89 USE sbc_oce, ONLY : & ! Sea ice variables 90 & thick_s ! Snow depth for freeboard conversion 91 #endif 92 USE obs_fbm, ONLY : & 93 & fbrmdi ! Real missing data indicator 94 95 IMPLICIT NONE 96 97 INTEGER, PARAMETER :: jpmaxngroups = 1000 ! Maximum number of obs groups 118 98 INTEGER :: ios ! Local integer output status for namelist read 119 99 INTEGER :: jtype ! Counter for obs types 120 100 INTEGER :: jvar ! Counter for variables 121 101 INTEGER :: jfile ! Counter for files 122 INTEGER :: jnumsstbias 102 INTEGER :: jenabled 103 INTEGER :: jgroup 123 104 ! 124 CHARACTER(len=128), DIMENSION(jpmaxnfiles) :: & 125 & cn_profbfiles, & ! T/S profile input filenames 126 & cn_sstfbfiles, & ! Sea surface temperature input filenames 127 & cn_sssfbfiles, & ! Sea surface salinity input filenames 128 & cn_slafbfiles, & ! Sea level anomaly input filenames 129 & cn_sicfbfiles, & ! Seaice concentration input filenames 130 & cn_velfbfiles, & ! Velocity profile input filenames 131 & cn_sstbiasfiles ! SST bias input filenames 132 CHARACTER(LEN=128) :: & 133 & cn_altbiasfile ! Altimeter bias input filename 134 CHARACTER(len=128), DIMENSION(:,:), ALLOCATABLE :: & 135 & clproffiles, & ! Profile filenames 136 & clsurffiles ! Surface filenames 137 ! 138 LOGICAL :: ln_t3d ! Logical switch for temperature profiles 139 LOGICAL :: ln_s3d ! Logical switch for salinity profiles 140 LOGICAL :: ln_sla ! Logical switch for sea level anomalies 141 LOGICAL :: ln_sst ! Logical switch for sea surface temperature 142 LOGICAL :: ln_sss ! Logical switch for sea surface salinity 143 LOGICAL :: ln_sic ! Logical switch for sea ice concentration 144 LOGICAL :: ln_vel3d ! Logical switch for velocity (u,v) obs 145 LOGICAL :: ln_nea ! Logical switch to remove obs near land 146 LOGICAL :: ln_altbias ! Logical switch for altimeter bias 147 LOGICAL :: ln_sstbias ! Logical switch for bias corection of SST 148 LOGICAL :: ln_ignmis ! Logical switch for ignoring missing files 149 LOGICAL :: ln_s_at_t ! Logical switch to compute model S at T obs 150 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 153 LOGICAL, DIMENSION(jpmaxnfiles) :: lmask ! Used for finding number of sstbias files 105 LOGICAL, DIMENSION(:), ALLOCATABLE :: llvar 154 106 ! 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 160 !! 161 NAMELIST/namobs/ln_diaobs, ln_t3d, ln_s3d, ln_sla, & 162 & ln_sst, ln_sic, ln_sss, ln_vel3d, & 163 & ln_altbias, ln_sstbias, ln_nea, & 164 & ln_grid_global, ln_grid_search_lookup, & 165 & ln_ignmis, ln_s_at_t, ln_bound_reject, & 166 & ln_sstnight, & 167 & ln_sla_fp_indegs, ln_sst_fp_indegs, & 168 & ln_sss_fp_indegs, ln_sic_fp_indegs, & 169 & cn_profbfiles, cn_slafbfiles, & 170 & cn_sstfbfiles, cn_sicfbfiles, & 171 & cn_velfbfiles, cn_sssfbfiles, & 172 & cn_sstbiasfiles, cn_altbiasfile, & 173 & cn_gridsearchfile, rn_gridsearchres, & 174 & rn_dobsini, rn_dobsend, & 175 & rn_sla_avglamscl, rn_sla_avgphiscl, & 176 & rn_sst_avglamscl, rn_sst_avgphiscl, & 177 & rn_sss_avglamscl, rn_sss_avgphiscl, & 178 & rn_sic_avglamscl, rn_sic_avgphiscl, & 179 & nn_1dint, nn_2dint, & 180 & nn_2dint_sla, nn_2dint_sst, & 181 & nn_2dint_sss, nn_2dint_sic, & 182 & nn_msshc, rn_mdtcorr, rn_mdtcutoff, & 183 & nn_profdavtypes 107 REAL(dp) :: rn_dobsini ! Obs window start date YYYYMMDD.HHMMSS 108 REAL(dp) :: rn_dobsend ! Obs window end date YYYYMMDD.HHMMSS 109 !! 110 NAMELIST/namobs/ln_diaobs, nn_obsgroups, & 111 & ln_grid_global, ln_grid_search_lookup, & 112 & cn_gridsearchfile, rn_gridsearchres, & 113 & rn_dobsini, rn_dobsend 184 114 !----------------------------------------------------------------------- 185 115 … … 187 117 ! Read namelist parameters 188 118 !----------------------------------------------------------------------- 189 ! Some namelist arrays need initialising 190 cn_profbfiles (:) = '' 191 cn_slafbfiles (:) = '' 192 cn_sstfbfiles (:) = '' 193 cn_sicfbfiles (:) = '' 194 cn_velfbfiles (:) = '' 195 cn_sssfbfiles (:) = '' 196 cn_sstbiasfiles(:) = '' 197 nn_profdavtypes(:) = -1 198 119 ! Initialise time window 199 120 CALL ini_date( rn_dobsini ) 200 121 CALL fin_date( rn_dobsend ) … … 220 141 WRITE(numout,*) 'dia_obs_init : Observation diagnostic initialization' 221 142 WRITE(numout,*) '~~~~~~~~~~~~' 222 WRITE(numout,*) ' Namelist namobs : set observation diagnostic parameters' 223 WRITE(numout,*) ' Logical switch for T profile observations ln_t3d = ', ln_t3d 224 WRITE(numout,*) ' Logical switch for S profile observations ln_s3d = ', ln_s3d 225 WRITE(numout,*) ' Logical switch for SLA observations ln_sla = ', ln_sla 226 WRITE(numout,*) ' Logical switch for SST observations ln_sst = ', ln_sst 227 WRITE(numout,*) ' Logical switch for Sea Ice observations ln_sic = ', ln_sic 228 WRITE(numout,*) ' Logical switch for velocity observations ln_vel3d = ', ln_vel3d 229 WRITE(numout,*) ' Logical switch for SSS observations ln_sss = ', ln_sss 143 WRITE(numout,*) ' Namelist namobs : set observation diagnostic parameters' 144 WRITE(numout,*) ' Number of namobs_dta namelists to read nn_obsgroups = ', nn_obsgroups 230 145 WRITE(numout,*) ' Global distribution of observations ln_grid_global = ', ln_grid_global 231 146 WRITE(numout,*) ' Logical switch for obs grid search lookup ln_grid_search_lookup = ', ln_grid_search_lookup 232 IF (ln_grid_search_lookup) &147 IF (ln_grid_search_lookup) THEN 233 148 WRITE(numout,*) ' Grid search lookup file header cn_gridsearchfile = ', cn_gridsearchfile 234 WRITE(numout,*) ' Initial date in window YYYYMMDD.HHMMSS rn_dobsini = ', rn_dobsini 235 WRITE(numout,*) ' Final date in window YYYYMMDD.HHMMSS rn_dobsend = ', rn_dobsend 236 WRITE(numout,*) ' Type of vertical interpolation method nn_1dint = ', nn_1dint 237 WRITE(numout,*) ' Type of horizontal interpolation method nn_2dint = ', nn_2dint 238 WRITE(numout,*) ' Rejection of observations near land switch ln_nea = ', ln_nea 239 WRITE(numout,*) ' Rejection of obs near open bdys ln_bound_reject = ', ln_bound_reject 240 WRITE(numout,*) ' MSSH correction scheme nn_msshc = ', nn_msshc 241 WRITE(numout,*) ' MDT correction rn_mdtcorr = ', rn_mdtcorr 242 WRITE(numout,*) ' MDT cutoff for computed correction rn_mdtcutoff = ', rn_mdtcutoff 243 WRITE(numout,*) ' Logical switch for alt bias ln_altbias = ', ln_altbias 244 WRITE(numout,*) ' Logical switch for sst bias ln_sstbias = ', ln_sstbias 245 WRITE(numout,*) ' Logical switch for ignoring missing files ln_ignmis = ', ln_ignmis 246 WRITE(numout,*) ' Daily average types nn_profdavtypes = ', nn_profdavtypes 247 WRITE(numout,*) ' Logical switch for night-time SST obs ln_sstnight = ', ln_sstnight 149 WRITE(numout,*) ' Grid search resolution rn_gridsearchres = ', rn_gridsearchres 150 ENDIF 248 151 ENDIF 249 !----------------------------------------------------------------------- 250 ! Set up list of observation types to be used 251 ! and the files associated with each type 252 !----------------------------------------------------------------------- 253 254 nproftypes = COUNT( (/ln_t3d .OR. ln_s3d, ln_vel3d /) ) 255 nsurftypes = COUNT( (/ln_sla, ln_sst, ln_sic, ln_sss /) ) 256 257 IF( ln_sstbias ) THEN 258 lmask(:) = .FALSE. 259 WHERE( cn_sstbiasfiles(:) /= '' ) lmask(:) = .TRUE. 260 jnumsstbias = COUNT(lmask) 261 lmask(:) = .FALSE. 262 ENDIF 263 264 IF( nproftypes == 0 .AND. nsurftypes == 0 ) THEN 265 CALL ctl_warn( 'dia_obs_init: ln_diaobs is set to true, but all obs operator logical flags', & 266 & ' (ln_t3d, ln_s3d, ln_sla, ln_sst, ln_sic, ln_vel3d)', & 267 & ' are set to .FALSE. so turning off calls to dia_obs' ) 152 153 IF( ln_grid_global ) THEN 154 CALL ctl_warn( 'dia_obs_init: ln_grid_global=T may cause memory issues when used with a large number of processors' ) 155 ENDIF 156 157 !----------------------------------------------------------------------- 158 ! Read namobs_dta namelists and set up observation groups 159 !----------------------------------------------------------------------- 160 161 IF( nn_obsgroups == 0 ) THEN 162 CALL ctl_warn( 'dia_obs_init: ln_diaobs is set to true, but nn_obsgroups == 0', & 163 & ' so turning off calls to dia_obs' ) 268 164 ln_diaobs = .FALSE. 269 165 RETURN 270 166 ENDIF 271 167 272 IF( nproftypes > 0 ) THEN 273 ! 274 ALLOCATE( cobstypesprof(nproftypes) ) 275 ALLOCATE( ifilesprof (nproftypes) ) 276 ALLOCATE( clproffiles (nproftypes,jpmaxnfiles) ) 277 ! 278 jtype = 0 279 IF( ln_t3d .OR. ln_s3d ) THEN 280 jtype = jtype + 1 281 CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'prof ', & 282 & cn_profbfiles, ifilesprof, cobstypesprof, clproffiles ) 168 ALLOCATE( sobsgroups(nn_obsgroups) ) 169 170 jenabled = 0 171 DO jgroup = 1, nn_obsgroups 172 CALL obs_group_read_namelist( sobsgroups(jgroup) ) 173 CALL obs_group_check( sobsgroups(jgroup), jgroup ) 174 IF (sobsgroups(jgroup)%lenabled) THEN 175 jenabled = jenabled + 1 283 176 ENDIF 284 IF( ln_vel3d ) THEN 285 jtype = jtype + 1 286 CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'vel ', & 287 & cn_velfbfiles, ifilesprof, cobstypesprof, clproffiles ) 288 ENDIF 289 ! 290 ENDIF 291 292 IF( nsurftypes > 0 ) THEN 293 ! 294 ALLOCATE( cobstypessurf(nsurftypes) ) 295 ALLOCATE( ifilessurf (nsurftypes) ) 296 ALLOCATE( clsurffiles (nsurftypes,jpmaxnfiles) ) 297 ALLOCATE( n2dintsurf (nsurftypes) ) 298 ALLOCATE( zavglamscl (nsurftypes) ) 299 ALLOCATE( zavgphiscl (nsurftypes) ) 300 ALLOCATE( lfpindegs (nsurftypes) ) 301 ALLOCATE( llnightav (nsurftypes) ) 302 ! 303 jtype = 0 304 IF( ln_sla ) THEN 305 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 ) 314 ENDIF 315 IF( ln_sst ) THEN 316 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 ) 325 ENDIF 326 #if defined key_si3 || defined key_cice 327 IF( ln_sic ) THEN 328 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 ) 337 ENDIF 338 #endif 339 IF( ln_sss ) THEN 340 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 ) 349 ENDIF 350 ! 351 ENDIF 352 353 354 !----------------------------------------------------------------------- 355 ! Obs operator parameter checking and initialisations 356 !----------------------------------------------------------------------- 357 ! 358 IF( ln_vel3d .AND. .NOT.ln_grid_global ) THEN 359 CALL ctl_stop( 'Velocity data only works with ln_grid_global=.true.' ) 177 END DO 178 179 IF( jenabled == 0 ) THEN 180 CALL ctl_warn( 'dia_obs_init: ln_diaobs is set to true, and nn_obsgroups > 0', & 181 & ' but no groups are enabled so turning off calls to dia_obs' ) 182 ln_diaobs = .FALSE. 360 183 RETURN 361 184 ENDIF 362 ! 363 IF( ln_grid_global ) THEN 364 CALL ctl_warn( 'dia_obs_init: ln_grid_global=T may cause memory issues when used with a large number of processors' ) 365 ENDIF 366 ! 367 IF( nn_1dint < 0 .OR. nn_1dint > 1 ) THEN 368 CALL ctl_stop('dia_obs_init: Choice of vertical (1D) interpolation method is not available') 369 ENDIF 370 ! 371 IF( nn_2dint < 0 .OR. nn_2dint > 6 ) THEN 372 CALL ctl_stop('dia_obs_init: Choice of horizontal (2D) interpolation method is not available') 373 ENDIF 185 186 !----------------------------------------------------------------------- 187 ! Obs operator parameter checking and initialisations 188 !----------------------------------------------------------------------- 374 189 ! 375 190 CALL obs_typ_init … … 382 197 !----------------------------------------------------------------------- 383 198 ! 384 IF( nproftypes > 0 ) THEN 385 ! 386 ALLOCATE( profdata (nproftypes) , nvarsprof (nproftypes) ) 387 ALLOCATE( profdataqc(nproftypes) , nextrprof (nproftypes) ) 388 ! 389 DO jtype = 1, nproftypes 390 ! 391 nvarsprof(jtype) = 2 392 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 199 DO jgroup = 1, nn_obsgroups 200 IF ( sobsgroups(jgroup)%lenabled ) THEN 201 IF ( sobsgroups(jgroup)%lprof ) THEN 202 ! 203 ! Read in profile or profile obs types 204 ! 205 ALLOCATE( llvar(sobsgroups(jgroup)%nobstypes) ) 206 llvar(:) = .TRUE. 207 ! 208 CALL obs_rea_prof( sobsgroups(jgroup)%sprofdata, & 209 & sobsgroups(jgroup)%nobsfiles, & 210 & sobsgroups(jgroup)%cobsfiles, & 211 & sobsgroups(jgroup)%nobstypes, & 212 & sobsgroups(jgroup)%naddvars, & 213 & sobsgroups(jgroup)%nextvars, & 214 & nitend-nit000+2, & 215 & rn_dobsini, & 216 & rn_dobsend, & 217 & llvar, & 218 & sobsgroups(jgroup)%lignmis, & 219 & sobsgroups(jgroup)%lall_at_all, & 220 & .FALSE., & 221 & sobsgroups(jgroup)%cobstypes, & 222 & kdailyavtypes = sobsgroups(jgroup)%nprofdavtypes ) 223 ! 224 DO jvar = 1, sobsgroups(jgroup)%nobstypes 225 CALL obs_prof_staend( sobsgroups(jgroup)%sprofdata, jvar ) 226 END DO 227 ! 228 IF ( sobsgroups(jgroup)%sprofdata%next > 0 ) THEN 229 CALL obs_prof_staend_ext( sobsgroups(jgroup)%sprofdata ) 230 ENDIF 231 ! 232 IF( sobsgroups(jgroup)%loutput_clim ) THEN 233 sobsgroups(jgroup)%sprofdata%caddvars(sobsgroups(jgroup)%nadd_clm) = 'CLM' 234 DO jvar = 1, sobsgroups(jgroup)%nobstypes 235 sobsgroups(jgroup)%sprofdata%var(jvar)%vadd(:,sobsgroups(jgroup)%nadd_clm) = fbrmdi 236 sobsgroups(jgroup)%sprofdata%caddlong(sobsgroups(jgroup)%nadd_clm,jvar) = 'Climatology' 237 sobsgroups(jgroup)%sprofdata%caddunit(sobsgroups(jgroup)%nadd_clm,jvar) = sobsgroups(jgroup)%sprofdata%cunit(jvar) 238 END DO 239 ENDIF 240 ! 241 sobsgroups(jgroup)%sprofdata%cgrid = sobsgroups(jgroup)%cgrid 242 ! 243 CALL obs_pre_prof( sobsgroups(jgroup)%sprofdata, & 244 & sobsgroups(jgroup)%sprofdataqc, & 245 & llvar, & 246 & jpi, jpj, jpk, & 247 & sobsgroups(jgroup)%rmask, & 248 & sobsgroups(jgroup)%rglam, & 249 & sobsgroups(jgroup)%rgphi, & 250 & sobsgroups(jgroup)%lnea, & 251 & sobsgroups(jgroup)%lbound_reject, & 252 & kdailyavtypes = sobsgroups(jgroup)%nprofdavtypes ) 253 ! 254 DEALLOCATE( llvar ) 255 ! 256 ELSEIF (sobsgroups(jgroup)%lsurf) THEN 257 ! 258 ! Read in surface obs types 259 ! 260 CALL obs_rea_surf( sobsgroups(jgroup)%ssurfdata, & 261 & sobsgroups(jgroup)%nobsfiles, & 262 & sobsgroups(jgroup)%cobsfiles, & 263 & sobsgroups(jgroup)%nobstypes, & 264 & sobsgroups(jgroup)%naddvars, & 265 & sobsgroups(jgroup)%nextvars, & 266 & nitend-nit000+2, & 267 & rn_dobsini, & 268 & rn_dobsend, & 269 & sobsgroups(jgroup)%rtime_mean_period, & 270 & sobsgroups(jgroup)%ltime_mean_bkg, & 271 & sobsgroups(jgroup)%lignmis, & 272 & .FALSE., & 273 & sobsgroups(jgroup)%lnight, & 274 & sobsgroups(jgroup)%cobstypes ) 275 ! 276 IF( sobsgroups(jgroup)%lsla ) THEN 277 sobsgroups(jgroup)%ssurfdata%cextvars(sobsgroups(jgroup)%next_mdt) = 'MDT' 278 sobsgroups(jgroup)%ssurfdata%cextlong(sobsgroups(jgroup)%next_mdt) = 'Mean dynamic topography' 279 sobsgroups(jgroup)%ssurfdata%cextunit(sobsgroups(jgroup)%next_mdt) = 'Metres' 280 sobsgroups(jgroup)%ssurfdata%caddvars(sobsgroups(jgroup)%nadd_ssh) = 'SSH' 281 DO jvar = 1, sobsgroups(jgroup)%nobstypes 282 sobsgroups(jgroup)%ssurfdata%caddlong(sobsgroups(jgroup)%nadd_ssh,jvar) = 'Model Sea surface height' 283 sobsgroups(jgroup)%ssurfdata%caddunit(sobsgroups(jgroup)%nadd_ssh,jvar) = 'Metres' 284 END DO 285 ENDIF 286 ! 287 IF( sobsgroups(jgroup)%lfbd ) THEN 288 sobsgroups(jgroup)%ssurfdata%cextvars(sobsgroups(jgroup)%next_snow) = 'SNOW' 289 sobsgroups(jgroup)%ssurfdata%cextlong(sobsgroups(jgroup)%next_snow) = 'Snow thickness' 290 sobsgroups(jgroup)%ssurfdata%cextunit(sobsgroups(jgroup)%next_snow) = 'Metres' 291 sobsgroups(jgroup)%ssurfdata%caddvars(sobsgroups(jgroup)%nadd_fbd) = 'FBD' 292 DO jvar = 1, sobsgroups(jgroup)%nobstypes 293 sobsgroups(jgroup)%ssurfdata%caddlong(sobsgroups(jgroup)%nadd_fbd,jvar) = 'Freeboard' 294 sobsgroups(jgroup)%ssurfdata%caddunit(sobsgroups(jgroup)%nadd_fbd,jvar) = 'Metres' 295 END DO 296 ENDIF 297 ! 298 IF( sobsgroups(jgroup)%loutput_clim ) THEN 299 sobsgroups(jgroup)%ssurfdata%caddvars(sobsgroups(jgroup)%nadd_clm) = 'CLM' 300 DO jvar = 1, sobsgroups(jgroup)%nobstypes 301 sobsgroups(jgroup)%ssurfdata%radd(:,:,jvar) = fbrmdi 302 sobsgroups(jgroup)%ssurfdata%caddlong(sobsgroups(jgroup)%nadd_clm,jvar) = 'Climatology' 303 sobsgroups(jgroup)%ssurfdata%caddunit(sobsgroups(jgroup)%nadd_clm,jvar) = sobsgroups(jgroup)%ssurfdata%cunit(jvar) 304 END DO 305 ENDIF 306 ! 307 sobsgroups(jgroup)%ssurfdata%cgrid = sobsgroups(jgroup)%cgrid 308 ! 309 CALL obs_pre_surf( sobsgroups(jgroup)%ssurfdata, & 310 & sobsgroups(jgroup)%ssurfdataqc, & 311 & jpi, jpj, & 312 & sobsgroups(jgroup)%rmask(:,:,1,:), & 313 & sobsgroups(jgroup)%rglam, & 314 & sobsgroups(jgroup)%rgphi, & 315 & sobsgroups(jgroup)%lnea, & 316 & sobsgroups(jgroup)%lbound_reject ) 317 ! 318 IF( sobsgroups(jgroup)%lsla ) THEN 319 CALL obs_rea_mdt( sobsgroups(jgroup)%ssurfdataqc, & 320 & sobsgroups(jgroup)%n2dint, & 321 & sobsgroups(jgroup)%next_mdt, & 322 & sobsgroups(jgroup)%nmsshc, & 323 & sobsgroups(jgroup)%rmdtcorr, & 324 & sobsgroups(jgroup)%rmdtcutoff ) 325 IF( sobsgroups(jgroup)%laltbias ) THEN 326 CALL obs_app_bias( sobsgroups(jgroup)%ssurfdataqc, & 327 & sobsgroups(jgroup)%next_mdt, & 328 & sobsgroups(jgroup)%n2dint, & 329 & 1, & 330 & sobsgroups(jgroup)%caltbiasfile, & 331 & 'altbias', & 332 & ld_extvar=.TRUE. ) 333 ENDIF 334 ENDIF 335 ! 336 #if defined key_si3 337 IF( sobsgroups(jgroup)%lfbd ) THEN 338 CALL obs_rea_snowdepth( sobsgroups(jgroup)%ssurfdataqc, & 339 & sobsgroups(jgroup)%n2dint, & 340 & sobsgroups(jgroup)%next_snow, & 341 & hm_s(:,:) ) 342 ENDIF 343 #elif defined key_cice 344 IF( sobsgroups(jgroup)%lfbd ) THEN 345 CALL obs_rea_snowdepth( sobsgroups(jgroup)%ssurfdataqc, & 346 & sobsgroups(jgroup)%n2dint, & 347 & sobsgroups(jgroup)%next_snow, & 348 & thick_s(:,:) ) 349 ENDIF 350 #endif 351 ! 352 IF( sobsgroups(jgroup)%lobsbias ) THEN 353 CALL obs_app_bias( sobsgroups(jgroup)%ssurfdataqc, & 354 & sobsgroups(jgroup)%nbiasvar, & 355 & sobsgroups(jgroup)%n2dint, & 356 & sobsgroups(jgroup)%nobsbiasfiles, & 357 & sobsgroups(jgroup)%cobsbiasfiles, & 358 & sobsgroups(jgroup)%cbiasvarname ) 359 ENDIF 360 ! 402 361 ENDIF 403 IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN 404 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 413 ENDIF 414 ! 415 ! Read in profile or profile obs types 416 CALL obs_rea_prof( profdata(jtype), ifilesprof(jtype), & 417 & clproffiles(jtype,1:ifilesprof(jtype)), & 418 & nvarsprof(jtype), nextrprof(jtype), nitend-nit000+2, & 419 & rn_dobsini, rn_dobsend, llvar1, llvar2, & 420 & ln_ignmis, ln_s_at_t, .FALSE., & 421 & kdailyavtypes = nn_profdavtypes ) 422 ! 423 DO jvar = 1, nvarsprof(jtype) 424 CALL obs_prof_staend( profdata(jtype), jvar ) 425 END DO 426 ! 427 CALL obs_pre_prof( profdata(jtype), profdataqc(jtype), & 428 & llvar1, llvar2, & 429 & jpi, jpj, jpk, & 430 & zmask1, zglam1, zgphi1, zmask2, zglam2, zgphi2, & 431 & ln_nea, ln_bound_reject, & 432 & kdailyavtypes = nn_profdavtypes ) 433 END DO 434 ! 435 DEALLOCATE( ifilesprof, clproffiles ) 436 ! 437 ENDIF 438 ! 439 IF( nsurftypes > 0 ) THEN 440 ! 441 ALLOCATE( surfdata (nsurftypes) , nvarssurf(nsurftypes) ) 442 ALLOCATE( surfdataqc(nsurftypes) , nextrsurf(nsurftypes) ) 443 ! 444 DO jtype = 1, nsurftypes 445 ! 446 nvarssurf(jtype) = 1 447 nextrsurf(jtype) = 0 448 llnightav(jtype) = .FALSE. 449 IF( TRIM(cobstypessurf(jtype)) == 'sla' ) nextrsurf(jtype) = 2 450 IF( TRIM(cobstypessurf(jtype)) == 'sst' ) llnightav(jtype) = ln_sstnight 451 ! 452 ! Read in surface obs types 453 CALL obs_rea_surf( surfdata(jtype), ifilessurf(jtype), & 454 & clsurffiles(jtype,1:ifilessurf(jtype)), & 455 & nvarssurf(jtype), nextrsurf(jtype), nitend-nit000+2, & 456 & rn_dobsini, rn_dobsend, ln_ignmis, .FALSE., llnightav(jtype) ) 457 ! 458 CALL obs_pre_surf( surfdata(jtype), surfdataqc(jtype), ln_nea, ln_bound_reject ) 459 ! 460 IF( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN 461 CALL obs_rea_mdt( surfdataqc(jtype), n2dintsurf(jtype) ) 462 IF( ln_altbias ) & 463 & CALL obs_rea_altbias ( surfdataqc(jtype), n2dintsurf(jtype), cn_altbiasfile ) 464 ENDIF 465 ! 466 IF( TRIM(cobstypessurf(jtype)) == 'sst' .AND. ln_sstbias ) THEN 467 jnumsstbias = 0 468 DO jfile = 1, jpmaxnfiles 469 IF( TRIM(cn_sstbiasfiles(jfile)) /= '' ) jnumsstbias = jnumsstbias + 1 470 END DO 471 IF( jnumsstbias == 0 ) CALL ctl_stop("ln_sstbias set but no bias files to read in") 472 ! 473 CALL obs_app_sstbias( surfdataqc(jtype), n2dintsurf(jtype) , & 474 & jnumsstbias , cn_sstbiasfiles(1:jnumsstbias) ) 475 ENDIF 476 END DO 477 ! 478 DEALLOCATE( ifilessurf, clsurffiles ) 479 ! 480 ENDIF 362 ENDIF 363 END DO 481 364 ! 482 365 END SUBROUTINE dia_obs_init … … 500 383 USE oce , ONLY : tsn, un, vn, sshn ! Ocean dynamics and tracers variables 501 384 USE phycst , ONLY : rday ! Physical constants 502 #if defined key_si3 503 USE ice , ONLY : at_i ! SI3 Ice model variables 385 #if defined key_si3 386 USE ice , ONLY : at_i, hm_i ! SI3 Ice model variables 387 #elif defined key_cice 388 USE sbc_oce, ONLY : fr_i, thick_i ! CICE Ice model variables 504 389 #endif 505 #if defined key_cice 506 USE sbc_oce, ONLY : fr_i ! ice fraction 507 #endif 390 USE tradmp, ONLY : tclim, sclim ! T&S climatology 391 USE obs_fbm, ONLY : fbrmdi ! Real missing data indicator 508 392 509 393 IMPLICIT NONE … … 513 397 !! * Local declarations 514 398 INTEGER :: idaystp ! Number of timesteps per day 399 INTEGER :: imeanstp ! Number of timesteps for time averaging 515 400 INTEGER :: jtype ! Data loop variable 516 401 INTEGER :: jvar ! Variable number 517 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 524 REAL(wp), DIMENSION(jpi,jpj) :: & 525 & zsurfvar, & ! Model values equivalent to surface ob. 526 & 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 532 533 !----------------------------------------------------------------------- 402 INTEGER :: jgroup 403 INTEGER :: ji, jj, jobs ! Loop counters 404 LOGICAL :: lstp0 ! Flag special treatment on zeroth time step 405 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 406 & zprofvar, & ! Model values for variables in a prof ob 407 & zprofclim ! Climatology values for variables in a prof ob 408 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: & 409 & zsurfvar, & ! Model values for variables in a surf ob 410 & zsurfclim ! Climatology values for variables in a surf ob 411 412 !----------------------------------------------------------------------- 413 414 IF( ln_timing ) CALL timing_start('dia_obs') 534 415 535 416 IF(lwp) THEN … … 545 426 !----------------------------------------------------------------------- 546 427 547 IF ( nproftypes > 0 ) THEN 548 549 DO jtype = 1, nproftypes 550 551 SELECT CASE ( TRIM(cobstypesprof(jtype)) ) 552 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(:,:) 561 CASE('vel') 562 zprofvar1(:,:,:) = un(:,:,:) 563 zprofvar2(:,:,:) = vn(:,:,:) 564 zprofmask1(:,:,:) = umask(:,:,:) 565 zprofmask2(:,:,:) = vmask(:,:,:) 566 zglam1(:,:) = glamu(:,:) 567 zglam2(:,:) = glamv(:,:) 568 zgphi1(:,:) = gphiu(:,:) 569 zgphi2(:,:) = gphiv(:,:) 570 CASE DEFAULT 571 CALL ctl_stop( 'Unknown profile observation type '//TRIM(cobstypesprof(jtype))//' in dia_obs' ) 572 END SELECT 573 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 ) 582 583 END DO 584 585 ENDIF 586 587 IF ( nsurftypes > 0 ) THEN 588 589 DO jtype = 1, nsurftypes 590 591 !Defaults which might be changed 592 zsurfmask(:,:) = tmask(:,:,1) 593 594 SELECT CASE ( TRIM(cobstypessurf(jtype)) ) 595 CASE('sst') 596 zsurfvar(:,:) = tsn(:,:,1,jp_tem) 597 CASE('sla') 598 zsurfvar(:,:) = sshn(:,:) 599 CASE('sss') 600 zsurfvar(:,:) = tsn(:,:,1,jp_sal) 601 CASE('sic') 602 IF ( kstp == 0 ) THEN 603 IF ( lwp .AND. surfdataqc(jtype)%nsstpmpp(1) > 0 ) THEN 604 CALL ctl_warn( 'Sea-ice not initialised on zeroth '// & 605 & 'time-step but some obs are valid then.' ) 606 WRITE(numout,*)surfdataqc(jtype)%nsstpmpp(1), & 607 & ' sea-ice obs will be missed' 428 ALLOCATE( zprofvar(jpi,jpj,jpk), & 429 & zprofclim(jpi,jpj,jpk), & 430 & zsurfvar(jpi,jpj), & 431 & zsurfclim(jpi,jpj) ) 432 433 DO jgroup = 1, nn_obsgroups 434 IF ( sobsgroups(jgroup)%lenabled ) THEN 435 436 IF ( sobsgroups(jgroup)%lprof ) THEN 437 438 zprofclim(:,:,:) = fbrmdi 439 440 DO jvar = 1, sobsgroups(jgroup)%nobstypes 441 442 SELECT CASE ( TRIM(sobsgroups(jgroup)%cobstypes(jvar)) ) 443 CASE('POTM') 444 zprofvar(:,:,:) = tsn(:,:,:,jp_tem) 445 IF (sobsgroups(jgroup)%loutput_clim) THEN 446 zprofclim(:,:,:) = tclim(:,:,:) 447 ENDIF 448 CASE('PSAL') 449 zprofvar(:,:,:) = tsn(:,:,:,jp_sal) 450 IF (sobsgroups(jgroup)%loutput_clim) THEN 451 zprofclim(:,:,:) = sclim(:,:,:) 452 ENDIF 453 CASE('UVEL') 454 zprofvar(:,:,:) = un(:,:,:) 455 CASE('VVEL') 456 zprofvar(:,:,:) = vn(:,:,:) 457 CASE DEFAULT 458 CALL ctl_stop( 'Unknown profile observation type '//TRIM(sobsgroups(jgroup)%cobstypes(jvar))//' in dia_obs' ) 459 END SELECT 460 461 CALL obs_prof_opt( sobsgroups(jgroup)%sprofdataqc, & 462 & kstp, jpi, jpj, jpk, & 463 & nit000, idaystp, jvar, & 464 & zprofvar, & 465 & sobsgroups(jgroup)%loutput_clim, & 466 & sobsgroups(jgroup)%nadd_clm, & 467 & zprofclim, & 468 & gdept_n, & 469 & gdepw_n, & 470 & sobsgroups(jgroup)%rmask(:,:,:,jvar), & 471 & sobsgroups(jgroup)%rglam(:,:,jvar), & 472 & sobsgroups(jgroup)%rgphi(:,:,jvar), & 473 & sobsgroups(jgroup)%n1dint, & 474 & sobsgroups(jgroup)%n2dint, & 475 & kdailyavtypes = sobsgroups(jgroup)%nprofdavtypes ) 476 477 END DO 478 479 ELSEIF (sobsgroups(jgroup)%lsurf) THEN 480 481 zsurfclim(:,:) = fbrmdi 482 483 DO jvar = 1, sobsgroups(jgroup)%nobstypes 484 485 lstp0 = .FALSE. 486 SELECT CASE ( TRIM(sobsgroups(jgroup)%cobstypes(jvar)) ) 487 CASE('SST') 488 zsurfvar(:,:) = tsn(:,:,1,jp_tem) 489 IF (sobsgroups(jgroup)%loutput_clim) THEN 490 zsurfclim(:,:) = tclim(:,:,1) 491 ENDIF 492 CASE('SLA') 493 zsurfvar(:,:) = sshn(:,:) 494 CASE('SSS') 495 zsurfvar(:,:) = tsn(:,:,1,jp_sal) 496 IF (sobsgroups(jgroup)%loutput_clim) THEN 497 zsurfclim(:,:) = sclim(:,:,1) 498 ENDIF 499 CASE('UVEL') 500 zsurfvar(:,:) = un(:,:,1) 501 CASE('VVEL') 502 zsurfvar(:,:) = vn(:,:,1) 503 CASE('ICECONC') 504 IF ( kstp == 0 ) THEN 505 lstp0 = .TRUE. 506 ELSE 507 #if defined key_si3 508 zsurfvar(:,:) = at_i(:,:) 509 #elif defined key_cice 510 zsurfvar(:,:) = fr_i(:,:) 511 #else 512 CALL ctl_stop( ' Trying to run sea-ice observation operator', & 513 & ' but no sea-ice model appears to have been defined' ) 514 #endif 515 ENDIF 516 CASE('SIT','FBD') 517 IF ( kstp == 0 ) THEN 518 lstp0 = .TRUE. 519 ELSE 520 #if defined key_si3 521 zsurfvar(:,:) = hm_i(:,:) 522 #elif defined key_cice 523 zsurfvar(:,:) = thick_i(:,:) 524 #else 525 CALL ctl_stop( ' Trying to run sea-ice observation operator', & 526 & ' but no sea-ice model appears to have been defined' ) 527 #endif 528 ENDIF 529 END SELECT 530 531 IF ( lstp0 ) THEN 532 IF ( sobsgroups(jgroup)%ssurfdataqc%nsstpmpp(1) > 0 ) THEN 533 DO jobs = sobsgroups(jgroup)%ssurfdataqc%nsurfup + 1, & 534 & sobsgroups(jgroup)%ssurfdataqc%nsurfup + sobsgroups(jgroup)%ssurfdataqc%nsstp(1) 535 sobsgroups(jgroup)%ssurfdata%nqc(jobs) = IBSET(sobsgroups(jgroup)%ssurfdata%nqc(jobs),13) 536 END DO 537 IF ( lwp ) THEN 538 CALL ctl_warn( TRIM(sobsgroups(jgroup)%cobstypes(jvar))// & 539 & ' not initialised on zeroth ' // & 540 & 'time-step but some obs are valid then.' ) 541 WRITE(numout,*)sobsgroups(jgroup)%ssurfdataqc%nsstpmpp(1), & 542 & TRIM(sobsgroups(jgroup)%cobstypes(jvar)), & 543 & 'observations will be flagged as bad' 544 ENDIF 545 ENDIF 546 IF ( jvar == sobsgroups(jgroup)%ssurfdataqc%nvar ) THEN 547 sobsgroups(jgroup)%ssurfdataqc%nsurfup = sobsgroups(jgroup)%ssurfdataqc%nsurfup + & 548 & sobsgroups(jgroup)%ssurfdataqc%nsstp(1) 549 ENDIF 550 ELSE 551 IF ( sobsgroups(jgroup)%ltime_mean_bkg ) THEN 552 ! Number of time-steps in meaning period 553 imeanstp = NINT( ( sobsgroups(jgroup)%rtime_mean_period * 60.0 * 60.0 ) / rdt ) 554 ENDIF 555 CALL obs_surf_opt( sobsgroups(jgroup)%ssurfdataqc, & 556 & kstp, jpi, jpj, & 557 & nit000, idaystp, & 558 & jvar, zsurfvar, & 559 & sobsgroups(jgroup)%loutput_clim, & 560 & sobsgroups(jgroup)%nadd_clm, & 561 & zsurfclim, & 562 & sobsgroups(jgroup)%rmask(:,:,1,jvar), & 563 & sobsgroups(jgroup)%n2dint, & 564 & sobsgroups(jgroup)%lnight, & 565 & sobsgroups(jgroup)%ravglamscl, & 566 & sobsgroups(jgroup)%ravgphiscl, & 567 & sobsgroups(jgroup)%lfp_indegs, & 568 & sobsgroups(jgroup)%ltime_mean_bkg, & 569 & imeanstp, & 570 & kssh=sobsgroups(jgroup)%nadd_ssh, & 571 & kmdt=sobsgroups(jgroup)%next_mdt, & 572 & kfbd=sobsgroups(jgroup)%nadd_fbd, & 573 & ksnow=sobsgroups(jgroup)%next_snow ) 608 574 ENDIF 609 surfdataqc(jtype)%nsurfup = surfdataqc(jtype)%nsurfup + & 610 & surfdataqc(jtype)%nsstp(1) 611 CYCLE 612 ELSE 613 #if defined key_cice || defined key_si3 614 zsurfvar(:,:) = fr_i(:,:) 615 #else 616 CALL ctl_stop( ' Trying to run sea-ice observation operator', & 617 & ' but no sea-ice model appears to have been defined' ) 618 #endif 619 ENDIF 620 621 END SELECT 622 623 CALL obs_surf_opt( surfdataqc(jtype), kstp, jpi, jpj, & 624 & nit000, idaystp, zsurfvar, zsurfmask, & 625 & n2dintsurf(jtype), llnightav(jtype), & 626 & zavglamscl(jtype), zavgphiscl(jtype), & 627 & lfpindegs(jtype) ) 628 629 END DO 630 631 ENDIF 575 576 END DO 577 578 ENDIF 579 580 ENDIF 581 END DO 582 583 DEALLOCATE( zprofvar, zprofclim, & 584 & zsurfvar, zsurfclim ) 585 586 IF( ln_timing ) CALL timing_stop('dia_obs') 632 587 633 588 END SUBROUTINE dia_obs … … 657 612 658 613 !! * Local declarations 659 INTEGER :: jtype ! Data set loop variable 660 INTEGER :: jo, jvar, jk 614 INTEGER :: jgroup ! Data set loop variable 615 INTEGER :: jo, jvar, jk, jadd, jext, jadd2, jext2 616 INTEGER :: iuvar, ivvar 661 617 REAL(wp), DIMENSION(:), ALLOCATABLE :: & 662 618 & zu, & 663 619 & zv 620 LOGICAL, DIMENSION(:), ALLOCATABLE :: ll_write 621 TYPE(obswriinfo) :: sladd, slext 622 623 IF( ln_timing ) CALL timing_start('dia_obs_wri') 664 624 665 625 !----------------------------------------------------------------------- … … 667 627 !----------------------------------------------------------------------- 668 628 669 IF ( nproftypes > 0 ) THEN 670 671 DO jtype = 1, nproftypes 672 673 IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN 674 675 ! For velocity data, rotate the model velocities to N/S, E/W 676 ! using the compressed data structure. 677 ALLOCATE( & 678 & zu(profdataqc(jtype)%nvprot(1)), & 679 & zv(profdataqc(jtype)%nvprot(2)) & 680 & ) 681 682 CALL obs_rotvel( profdataqc(jtype), nn_2dint, zu, zv ) 683 684 DO jo = 1, profdataqc(jtype)%nprof 685 DO jvar = 1, 2 686 DO jk = profdataqc(jtype)%npvsta(jo,jvar), profdataqc(jtype)%npvend(jo,jvar) 687 688 IF ( jvar == 1 ) THEN 689 profdataqc(jtype)%var(jvar)%vmod(jk) = zu(jk) 690 ELSE 691 profdataqc(jtype)%var(jvar)%vmod(jk) = zv(jk) 629 DO jgroup = 1, nn_obsgroups 630 IF (sobsgroups(jgroup)%lenabled) THEN 631 632 IF (sobsgroups(jgroup)%lprof) THEN 633 634 IF (sobsgroups(jgroup)%lvel) THEN 635 iuvar = 0 636 ivvar = 0 637 DO jvar = 1, sobsgroups(jgroup)%nobstypes 638 IF ( TRIM(sobsgroups(jgroup)%cobstypes(jvar)) == cobsname_uvel ) THEN 639 iuvar = jvar 640 ELSEIF ( TRIM(sobsgroups(jgroup)%cobstypes(jvar)) == cobsname_vvel ) THEN 641 ivvar = jvar 642 ENDIF 643 END DO 644 IF ( (iuvar > 0) .AND. (ivvar > 0) ) THEN 645 646 ! For velocity data, rotate the model velocities to N/S, E/W 647 ! using the compressed data structure. 648 ALLOCATE( & 649 & zu(sobsgroups(jgroup)%sprofdataqc%nvprot(iuvar)), & 650 & zv(sobsgroups(jgroup)%sprofdataqc%nvprot(ivvar)) & 651 & ) 652 653 CALL obs_rotvel_pro( sobsgroups(jgroup)%sprofdataqc, sobsgroups(jgroup)%n2dint, & 654 & iuvar, ivvar, zu, zv ) 655 656 DO jo = 1, sobsgroups(jgroup)%sprofdataqc%nprof 657 DO jk = sobsgroups(jgroup)%sprofdataqc%npvsta(jo,iuvar), sobsgroups(jgroup)%sprofdataqc%npvend(jo,iuvar) 658 sobsgroups(jgroup)%sprofdataqc%var(iuvar)%vmod(jk) = zu(jk) 659 END DO 660 DO jk = sobsgroups(jgroup)%sprofdataqc%npvsta(jo,ivvar), sobsgroups(jgroup)%sprofdataqc%npvend(jo,ivvar) 661 sobsgroups(jgroup)%sprofdataqc%var(ivvar)%vmod(jk) = zv(jk) 662 END DO 663 END DO 664 665 DEALLOCATE( zu ) 666 DEALLOCATE( zv ) 667 668 ELSE 669 CALL ctl_stop( 'Could not identify velocity observation variables to rotate' ) 670 END IF 671 END IF 672 673 CALL obs_prof_decompress( sobsgroups(jgroup)%sprofdataqc, & 674 & sobsgroups(jgroup)%sprofdata, .TRUE., numout ) 675 676 ! Put additional and extra variable information into obswriinfo structure 677 ! used by obs_write. 678 ! add/ext variables generated by the OBS code (1...sobsgroups(jgroup)%naddvars) 679 ! may duplicate ones read in (%naddvars+1...sobsgroups(jgroup)%sprofdata%nadd) 680 ! Check for this, and if so only write out the version generated by the OBS code 681 sladd%inum = sobsgroups(jgroup)%sprofdata%nadd 682 ALLOCATE( ll_write(sobsgroups(jgroup)%sprofdata%nadd) ) 683 ll_write(:) = .TRUE. 684 IF ( (sobsgroups(jgroup)%naddvars > 0) .AND. & 685 & (sobsgroups(jgroup)%sprofdata%nadd > sobsgroups(jgroup)%naddvars) ) THEN 686 DO jadd = sobsgroups(jgroup)%naddvars + 1, sobsgroups(jgroup)%sprofdata%nadd 687 DO jadd2 = 1, sobsgroups(jgroup)%naddvars 688 IF ( TRIM(sobsgroups(jgroup)%sprofdata%caddvars(jadd )) == & 689 & TRIM(sobsgroups(jgroup)%sprofdata%caddvars(jadd2)) ) THEN 690 sladd%inum = sladd%inum - 1 691 ll_write(jadd) = .FALSE. 692 692 ENDIF 693 694 693 END DO 695 694 END DO 696 END DO 697 698 DEALLOCATE( zu ) 699 DEALLOCATE( zv ) 700 701 END IF 702 703 CALL obs_prof_decompress( profdataqc(jtype), & 704 & profdata(jtype), .TRUE., numout ) 705 706 CALL obs_wri_prof( profdata(jtype) ) 707 708 END DO 709 710 ENDIF 711 712 IF ( nsurftypes > 0 ) THEN 713 714 DO jtype = 1, nsurftypes 715 716 CALL obs_surf_decompress( surfdataqc(jtype), & 717 & surfdata(jtype), .TRUE., numout ) 718 719 CALL obs_wri_surf( surfdata(jtype) ) 720 721 END DO 722 723 ENDIF 695 ENDIF 696 IF ( sladd%inum > 0 ) THEN 697 ALLOCATE( sladd%ipoint(sladd%inum), & 698 & sladd%cdname(sladd%inum), & 699 & sladd%cdlong(sladd%inum,sobsgroups(jgroup)%sprofdata%nvar), & 700 & sladd%cdunit(sladd%inum,sobsgroups(jgroup)%sprofdata%nvar) ) 701 jadd2 = 0 702 DO jadd = 1, sobsgroups(jgroup)%sprofdata%nadd 703 IF ( ll_write(jadd) ) THEN 704 jadd2 = jadd2 + 1 705 sladd%ipoint(jadd2) = jadd 706 sladd%cdname(jadd2) = sobsgroups(jgroup)%sprofdata%caddvars(jadd) 707 DO jvar = 1, sobsgroups(jgroup)%sprofdata%nvar 708 sladd%cdlong(jadd2,jvar) = sobsgroups(jgroup)%sprofdata%caddlong(jadd,jvar) 709 sladd%cdunit(jadd2,jvar) = sobsgroups(jgroup)%sprofdata%caddunit(jadd,jvar) 710 END DO 711 ENDIF 712 END DO 713 ENDIF 714 DEALLOCATE( ll_write ) 715 716 slext%inum = sobsgroups(jgroup)%sprofdata%next 717 ALLOCATE( ll_write(sobsgroups(jgroup)%sprofdata%next) ) 718 ll_write(:) = .TRUE. 719 IF ( (sobsgroups(jgroup)%nextvars > 0) .AND. & 720 & (sobsgroups(jgroup)%sprofdata%next > sobsgroups(jgroup)%nextvars) ) THEN 721 DO jext = sobsgroups(jgroup)%nextvars + 1, sobsgroups(jgroup)%sprofdata%next 722 DO jext2 = 1, sobsgroups(jgroup)%nextvars 723 IF ( TRIM(sobsgroups(jgroup)%sprofdata%cextvars(jext )) == & 724 & TRIM(sobsgroups(jgroup)%sprofdata%cextvars(jext2)) ) THEN 725 slext%inum = slext%inum - 1 726 ll_write(jext) = .FALSE. 727 ENDIF 728 END DO 729 END DO 730 ENDIF 731 IF ( slext%inum > 0 ) THEN 732 ALLOCATE( slext%ipoint(slext%inum), & 733 & slext%cdname(slext%inum), & 734 & slext%cdlong(slext%inum,1), & 735 & slext%cdunit(slext%inum,1) ) 736 jext2 = 0 737 DO jext = 1, sobsgroups(jgroup)%sprofdata%next 738 IF ( ll_write(jext) ) THEN 739 jext2 = jext2 + 1 740 slext%ipoint(jext2) = jext 741 slext%cdname(jext2) = sobsgroups(jgroup)%sprofdata%cextvars(jext) 742 slext%cdlong(jext2,1) = sobsgroups(jgroup)%sprofdata%cextlong(jext) 743 slext%cdunit(jext2,1) = sobsgroups(jgroup)%sprofdata%cextunit(jext) 744 ENDIF 745 END DO 746 ENDIF 747 DEALLOCATE( ll_write ) 748 749 CALL obs_wri_prof( sobsgroups(jgroup)%sprofdata, sobsgroups(jgroup)%cgroupname, sladd, slext ) 750 751 IF ( sladd%inum > 0 ) THEN 752 DEALLOCATE( sladd%ipoint, sladd%cdname, sladd%cdlong, sladd%cdunit ) 753 ENDIF 754 IF ( slext%inum > 0 ) THEN 755 DEALLOCATE( slext%ipoint, slext%cdname, slext%cdlong, slext%cdunit ) 756 ENDIF 757 758 ELSEIF (sobsgroups(jgroup)%lsurf) THEN 759 760 IF (sobsgroups(jgroup)%lvel) THEN 761 iuvar = 0 762 ivvar = 0 763 DO jvar = 1, sobsgroups(jgroup)%nobstypes 764 IF ( TRIM(sobsgroups(jgroup)%cobstypes(jvar)) == cobsname_uvel ) THEN 765 iuvar = jvar 766 ELSEIF ( TRIM(sobsgroups(jgroup)%cobstypes(jvar)) == cobsname_vvel ) THEN 767 ivvar = jvar 768 ENDIF 769 END DO 770 IF ( (iuvar > 0) .AND. (ivvar > 0) ) THEN 771 772 ! For velocity data, rotate the model velocities to N/S, E/W 773 ! using the compressed data structure. 774 ALLOCATE( & 775 & zu(sobsgroups(jgroup)%ssurfdataqc%nsurf), & 776 & zv(sobsgroups(jgroup)%ssurfdataqc%nsurf) & 777 & ) 778 779 CALL obs_rotvel_surf( sobsgroups(jgroup)%ssurfdataqc, sobsgroups(jgroup)%n2dint, & 780 & iuvar, ivvar, zu, zv ) 781 782 DO jo = 1, sobsgroups(jgroup)%ssurfdataqc%nsurf 783 sobsgroups(jgroup)%ssurfdataqc%rmod(jo,iuvar) = zu(jo) 784 sobsgroups(jgroup)%ssurfdataqc%rmod(jo,ivvar) = zv(jo) 785 END DO 786 787 DEALLOCATE( zu ) 788 DEALLOCATE( zv ) 789 790 ELSE 791 CALL ctl_stop( 'Could not identify velocity observation variables to rotate' ) 792 END IF 793 END IF 794 795 CALL obs_surf_decompress( sobsgroups(jgroup)%ssurfdataqc, & 796 & sobsgroups(jgroup)%ssurfdata, .TRUE., numout ) 797 798 IF (sobsgroups(jgroup)%lfbd) THEN 799 ! Input observations were freeboard, but we're outputting ice thickness 800 DO jvar = 1, sobsgroups(jgroup)%nobstypes 801 IF ( sobsgroups(jgroup)%cobstypes(jvar) == cobsname_fbd ) THEN 802 sobsgroups(jgroup)%ssurfdata%cvars(jvar) = 'SIT' 803 sobsgroups(jgroup)%ssurfdata%clong(jvar) = 'Sea ice thickness' 804 sobsgroups(jgroup)%ssurfdata%cunit(jvar) = 'm' 805 EXIT 806 ENDIF 807 END DO 808 ENDIF 809 810 ! Put additional and extra variable information into obswriinfo structure 811 ! used by obs_write. 812 ! add/ext variables generated by the OBS code (1...sobsgroups(jgroup)%naddvars) 813 ! may duplicate ones read in (%naddvars+1...sobsgroups(jgroup)%ssurfdata%nadd) 814 ! Check for this, and if so only write out the version generated by the OBS code 815 sladd%inum = sobsgroups(jgroup)%ssurfdata%nadd 816 ALLOCATE( ll_write(sobsgroups(jgroup)%ssurfdata%nadd) ) 817 ll_write(:) = .TRUE. 818 IF ( (sobsgroups(jgroup)%naddvars > 0) .AND. & 819 & (sobsgroups(jgroup)%ssurfdata%nadd > sobsgroups(jgroup)%naddvars) ) THEN 820 DO jadd = sobsgroups(jgroup)%naddvars + 1, sobsgroups(jgroup)%ssurfdata%nadd 821 DO jadd2 = 1, sobsgroups(jgroup)%naddvars 822 IF ( TRIM(sobsgroups(jgroup)%ssurfdata%caddvars(jadd )) == & 823 & TRIM(sobsgroups(jgroup)%ssurfdata%caddvars(jadd2)) ) THEN 824 sladd%inum = sladd%inum - 1 825 ll_write(jadd) = .FALSE. 826 ENDIF 827 END DO 828 END DO 829 ENDIF 830 IF ( sladd%inum > 0 ) THEN 831 ALLOCATE( sladd%ipoint(sladd%inum), & 832 & sladd%cdname(sladd%inum), & 833 & sladd%cdlong(sladd%inum,sobsgroups(jgroup)%ssurfdata%nvar), & 834 & sladd%cdunit(sladd%inum,sobsgroups(jgroup)%ssurfdata%nvar) ) 835 jadd2 = 0 836 DO jadd = 1, sobsgroups(jgroup)%ssurfdata%nadd 837 IF ( ll_write(jadd) ) THEN 838 jadd2 = jadd2 + 1 839 sladd%ipoint(jadd2) = jadd 840 sladd%cdname(jadd2) = sobsgroups(jgroup)%ssurfdata%caddvars(jadd) 841 DO jvar = 1, sobsgroups(jgroup)%ssurfdata%nvar 842 sladd%cdlong(jadd2,jvar) = sobsgroups(jgroup)%ssurfdata%caddlong(jadd,jvar) 843 sladd%cdunit(jadd2,jvar) = sobsgroups(jgroup)%ssurfdata%caddunit(jadd,jvar) 844 END DO 845 ENDIF 846 END DO 847 ENDIF 848 DEALLOCATE( ll_write ) 849 850 slext%inum = sobsgroups(jgroup)%ssurfdata%nextra 851 ALLOCATE( ll_write(sobsgroups(jgroup)%ssurfdata%nextra) ) 852 ll_write(:) = .TRUE. 853 IF ( (sobsgroups(jgroup)%nextvars > 0) .AND. & 854 & (sobsgroups(jgroup)%ssurfdata%nextra > sobsgroups(jgroup)%nextvars) ) THEN 855 DO jext = sobsgroups(jgroup)%nextvars + 1, sobsgroups(jgroup)%ssurfdata%nextra 856 DO jext2 = 1, sobsgroups(jgroup)%nextvars 857 IF ( TRIM(sobsgroups(jgroup)%ssurfdata%cextvars(jext )) == & 858 & TRIM(sobsgroups(jgroup)%ssurfdata%cextvars(jext2)) ) THEN 859 slext%inum = slext%inum - 1 860 ll_write(jext) = .FALSE. 861 ENDIF 862 END DO 863 END DO 864 ENDIF 865 IF ( slext%inum > 0 ) THEN 866 ALLOCATE( slext%ipoint(slext%inum), & 867 & slext%cdname(slext%inum), & 868 & slext%cdlong(slext%inum,1), & 869 & slext%cdunit(slext%inum,1) ) 870 jext2 = 0 871 DO jext = 1, sobsgroups(jgroup)%ssurfdata%nextra 872 IF ( ll_write(jext) ) THEN 873 jext2 = jext2 + 1 874 slext%ipoint(jext2) = jext 875 slext%cdname(jext2) = sobsgroups(jgroup)%ssurfdata%cextvars(jext) 876 slext%cdlong(jext2,1) = sobsgroups(jgroup)%ssurfdata%cextlong(jext) 877 slext%cdunit(jext2,1) = sobsgroups(jgroup)%ssurfdata%cextunit(jext) 878 ENDIF 879 END DO 880 ENDIF 881 DEALLOCATE( ll_write ) 882 883 CALL obs_wri_surf( sobsgroups(jgroup)%ssurfdata, sobsgroups(jgroup)%cgroupname, sladd, slext ) 884 885 IF ( sladd%inum > 0 ) THEN 886 DEALLOCATE( sladd%ipoint, sladd%cdname, sladd%cdlong, sladd%cdunit ) 887 ENDIF 888 IF ( slext%inum > 0 ) THEN 889 DEALLOCATE( slext%ipoint, slext%cdname, slext%cdlong, slext%cdunit ) 890 ENDIF 891 892 ENDIF 893 894 ENDIF 895 896 END DO 897 898 IF( ln_timing ) CALL timing_stop('dia_obs_wri') 724 899 725 900 END SUBROUTINE dia_obs_wri 726 727 SUBROUTINE dia_obs_dealloc728 IMPLICIT NONE729 !!----------------------------------------------------------------------730 !! *** ROUTINE dia_obs_dealloc ***731 !!732 !! ** Purpose : To deallocate data to enable the obs_oper online loop.733 !! Specifically: dia_obs_init --> dia_obs --> dia_obs_wri734 !!735 !! ** Method : Clean up various arrays left behind by the obs_oper.736 !!737 !! ** Action :738 !!739 !!----------------------------------------------------------------------740 ! obs_grid deallocation741 CALL obs_grid_deallocate742 743 ! diaobs deallocation744 IF ( nproftypes > 0 ) &745 & DEALLOCATE( cobstypesprof, profdata, profdataqc, nvarsprof, nextrprof )746 747 IF ( nsurftypes > 0 ) &748 & DEALLOCATE( cobstypessurf, surfdata, surfdataqc, nvarssurf, nextrsurf, &749 & n2dintsurf, zavglamscl, zavgphiscl, lfpindegs, llnightav )750 751 END SUBROUTINE dia_obs_dealloc752 901 753 902 SUBROUTINE calc_date( kstp, ddobs ) … … 895 1044 896 1045 END SUBROUTINE fin_date 897 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 all types914 915 !Local variables916 INTEGER :: jfile917 918 cfiles(jtype,:) = cfilestype(:)919 cobstypes(jtype) = ctypein920 ifiles(jtype) = 0921 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 ENDIF937 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 interpolation type950 INTEGER, INTENT(IN) :: n2dint_type ! Option for interpolation type951 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 metres955 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, zavgphiscl962 LOGICAL, DIMENSION(ntypes), INTENT(INOUT) :: &963 & lfpindegs, lavnight964 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 END SUBROUTINE obs_setinterpopts1012 1046 1013 1047 END MODULE diaobs
Note: See TracChangeset
for help on using the changeset viewer.
