Changeset 7992 for branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO
- Timestamp:
- 2017-05-02T13:21:57+02:00 (7 years ago)
- Location:
- branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS
- Files:
-
- 4 added
- 19 deleted
- 16 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/diaobs.F90
r7960 r7992 6 6 !!====================================================================== 7 7 8 !!----------------------------------------------------------------------9 !! 'key_diaobs' : Switch on the observation diagnostic computation10 8 !!---------------------------------------------------------------------- 11 9 !! dia_obs_init : Reading and prepare observations … … 15 13 !! fin_date : Compute the final date YYYYMMDD.HHMMSS 16 14 !!---------------------------------------------------------------------- 17 !! * Modules used 15 !! * Modules used 18 16 USE wrk_nemo ! Memory Allocation 19 17 USE par_kind ! Precision variables … … 21 19 USE par_oce 22 20 USE dom_oce ! Ocean space and time domain variables 23 USE obs_fbm, ONLY: ln_cl4 ! Class 4 diagnostic switch 24 USE obs_read_prof ! Reading and allocation of observations (Coriolis) 25 USE obs_read_sla ! Reading and allocation of SLA observations 26 USE obs_read_sst ! Reading and allocation of SST observations 21 USE obs_read_prof ! Reading and allocation of profile obs 22 USE obs_read_surf ! Reading and allocation of surface obs 27 23 USE obs_readmdt ! Reading and allocation of MDT for SLA. 28 USE obs_read_seaice ! Reading and allocation of Sea Ice observations29 USE obs_read_vel ! Reading and allocation of velocity component observations30 24 USE obs_prep ! Preparation of obs. (grid search etc). 31 25 USE obs_oper ! Observation operators … … 33 27 USE obs_grid ! Grid searching 34 28 USE obs_read_altbias ! Bias treatment for altimeter 29 USE obs_sstbias ! Bias correction routine for SST 35 30 USE obs_profiles_def ! Profile data definitions 36 USE obs_profiles ! Profile data storage37 31 USE obs_surf_def ! Surface data definitions 38 USE obs_sla ! SLA data storage39 USE obs_sst ! SST data storage40 USE obs_seaice ! Sea Ice data storage41 32 USE obs_types ! Definitions for observation types 42 33 USE mpp_map ! MPP mapping … … 52 43 & dia_obs_dealloc ! Deallocate dia_obs data 53 44 54 !! * Shared Module variables55 LOGICAL, PUBLIC, PARAMETER :: &56 #if defined key_diaobs57 & lk_diaobs = .TRUE. !: Logical switch for observation diangostics58 #else59 & lk_diaobs = .FALSE. !: Logical switch for observation diangostics60 #endif61 62 45 !! * Module variables 63 LOGICAL, PUBLIC :: ln_t3d !: Logical switch for temperature profiles 64 LOGICAL, PUBLIC :: ln_s3d !: Logical switch for salinity profiles 65 LOGICAL, PUBLIC :: ln_ena !: Logical switch for the ENACT data set 66 LOGICAL, PUBLIC :: ln_cor !: Logical switch for the Coriolis data set 67 LOGICAL, PUBLIC :: ln_profb !: Logical switch for profile feedback datafiles 68 LOGICAL, PUBLIC :: ln_sla !: Logical switch for sea level anomalies 69 LOGICAL, PUBLIC :: ln_sladt !: Logical switch for SLA from AVISO files 70 LOGICAL, PUBLIC :: ln_slafb !: Logical switch for SLA from feedback files 71 LOGICAL, PUBLIC :: ln_sst !: Logical switch for sea surface temperature 72 LOGICAL, PUBLIC :: ln_reysst !: Logical switch for Reynolds sea surface temperature 73 LOGICAL, PUBLIC :: ln_ghrsst !: Logical switch for GHRSST data 74 LOGICAL, PUBLIC :: ln_sstfb !: Logical switch for SST from feedback files 75 LOGICAL, PUBLIC :: ln_seaice !: Logical switch for sea ice concentration 76 LOGICAL, PUBLIC :: ln_vel3d !: Logical switch for velocity component (u,v) observations 77 LOGICAL, PUBLIC :: ln_velavcur !: Logical switch for raw daily averaged netCDF current meter vel. data 78 LOGICAL, PUBLIC :: ln_velhrcur !: Logical switch for raw high freq netCDF current meter vel. data 79 LOGICAL, PUBLIC :: ln_velavadcp !: Logical switch for raw daily averaged netCDF ADCP vel. data 80 LOGICAL, PUBLIC :: ln_velhradcp !: Logical switch for raw high freq netCDF ADCP vel. data 81 LOGICAL, PUBLIC :: ln_velfb !: Logical switch for velocities from feedback files 82 LOGICAL, PUBLIC :: ln_ssh !: Logical switch for sea surface height 83 LOGICAL, PUBLIC :: ln_sss !: Logical switch for sea surface salinity 84 LOGICAL, PUBLIC :: ln_sstnight !: Logical switch for night mean SST observations 85 LOGICAL, PUBLIC :: ln_nea !: Remove observations near land 86 LOGICAL, PUBLIC :: ln_altbias !: Logical switch for altimeter bias 87 LOGICAL, PUBLIC :: ln_ignmis !: Logical switch for ignoring missing files 88 LOGICAL, PUBLIC :: ln_s_at_t !: Logical switch to compute model S at T observations 89 90 REAL(KIND=dp), PUBLIC :: dobsini !: Observation window start date YYYYMMDD.HHMMSS 91 REAL(KIND=dp), PUBLIC :: dobsend !: Observation window end date YYYYMMDD.HHMMSS 92 93 INTEGER, PUBLIC :: n1dint !: Vertical interpolation method 94 INTEGER, PUBLIC :: n2dint !: Horizontal interpolation method 95 46 LOGICAL, PUBLIC :: & 47 & lk_diaobs = .TRUE. !: Include this for backwards compatibility at NEMO 3.6. 48 LOGICAL :: ln_diaobs !: Logical switch for the obs operator 49 LOGICAL :: ln_sstnight !: Logical switch for night mean SST obs 50 LOGICAL :: ln_sla_fp_indegs !: T=> SLA obs footprint size specified in degrees, F=> in metres 51 LOGICAL :: ln_sst_fp_indegs !: T=> SST obs footprint size specified in degrees, F=> in metres 52 LOGICAL :: ln_sss_fp_indegs !: T=> SSS obs footprint size specified in degrees, F=> in metres 53 LOGICAL :: ln_sic_fp_indegs !: T=> sea-ice obs footprint size specified in degrees, F=> in metres 54 55 REAL(wp) :: rn_sla_avglamscl !: E/W diameter of SLA observation footprint (metres) 56 REAL(wp) :: rn_sla_avgphiscl !: N/S diameter of SLA observation footprint (metres) 57 REAL(wp) :: rn_sst_avglamscl !: E/W diameter of SST observation footprint (metres) 58 REAL(wp) :: rn_sst_avgphiscl !: N/S diameter of SST observation footprint (metres) 59 REAL(wp) :: rn_sss_avglamscl !: E/W diameter of SSS observation footprint (metres) 60 REAL(wp) :: rn_sss_avgphiscl !: N/S diameter of SSS observation footprint (metres) 61 REAL(wp) :: rn_sic_avglamscl !: E/W diameter of sea-ice observation footprint (metres) 62 REAL(wp) :: rn_sic_avgphiscl !: N/S diameter of sea-ice observation footprint (metres) 63 64 INTEGER :: nn_1dint !: Vertical interpolation method 65 INTEGER :: nn_2dint !: Default horizontal interpolation method 66 INTEGER :: nn_2dint_sla !: SLA horizontal interpolation method 67 INTEGER :: nn_2dint_sst !: SST horizontal interpolation method 68 INTEGER :: nn_2dint_sss !: SSS horizontal interpolation method 69 INTEGER :: nn_2dint_sic !: Seaice horizontal interpolation method 70 96 71 INTEGER, DIMENSION(imaxavtypes) :: & 97 & endailyavtypes !: ENACT data types which are daily average 98 99 INTEGER, PARAMETER :: MaxNumFiles = 1000 100 LOGICAL, DIMENSION(MaxNumFiles) :: & 101 & ln_profb_ena, & !: Is the feedback files from ENACT data ? 102 ! !: If so use endailyavtypes 103 & ln_profb_enatim !: Change tim for 820 enact data set. 104 105 LOGICAL, DIMENSION(MaxNumFiles) :: & 106 & ln_velfb_av !: Is the velocity feedback files daily average? 72 & nn_profdavtypes !: Profile data types representing a daily average 73 INTEGER :: nproftypes !: Number of profile obs types 74 INTEGER :: nsurftypes !: Number of surface obs types 75 INTEGER, DIMENSION(:), ALLOCATABLE :: & 76 & nvarsprof, & !: Number of profile variables 77 & nvarssurf !: Number of surface variables 78 INTEGER, DIMENSION(:), ALLOCATABLE :: & 79 & nextrprof, & !: Number of profile extra variables 80 & nextrsurf !: Number of surface extra variables 81 INTEGER, DIMENSION(:), ALLOCATABLE :: & 82 & n2dintsurf !: Interpolation option for surface variables 83 REAL(wp), DIMENSION(:), ALLOCATABLE :: & 84 & ravglamscl, & !: E/W diameter of averaging footprint for surface variables 85 & ravgphiscl !: N/S diameter of averaging footprint for surface variables 107 86 LOGICAL, DIMENSION(:), ALLOCATABLE :: & 108 & ld_enact !: Profile data is ENACT so use endailyavtypes 109 LOGICAL, DIMENSION(:), ALLOCATABLE :: & 110 & ld_velav !: Velocity data is daily averaged 111 LOGICAL, DIMENSION(:), ALLOCATABLE :: & 112 & ld_sstnight !: SST observation corresponds to night mean 87 & lfpindegs, & !: T=> surface obs footprint size specified in degrees, F=> in metres 88 & llnightav !: Logical for calculating night-time averages 89 90 TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) :: & 91 & surfdata, & !: Initial surface data 92 & surfdataqc !: Surface data after quality control 93 TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: & 94 & profdata, & !: Initial profile data 95 & profdataqc !: Profile data after quality control 96 97 CHARACTER(len=6), PUBLIC, DIMENSION(:), ALLOCATABLE :: & 98 & cobstypesprof, & !: Profile obs types 99 & cobstypessurf !: Surface obs types 113 100 114 101 !!---------------------------------------------------------------------- … … 118 105 !!---------------------------------------------------------------------- 119 106 107 !! * Substitutions 108 # include "domzgr_substitute.h90" 120 109 CONTAINS 121 110 … … 135 124 !! ! 06-10 (A. Weaver) Cleaning and add controls 136 125 !! ! 07-03 (K. Mogensen) General handling of profiles 126 !! ! 14-08 (J.While) Incorporated SST bias correction 127 !! ! 15-02 (M. Martin) Simplification of namelist and code 137 128 !!---------------------------------------------------------------------- 138 129 … … 140 131 141 132 !! * Local declarations 142 CHARACTER(len=128) :: enactfiles(MaxNumFiles) 143 CHARACTER(len=128) :: coriofiles(MaxNumFiles) 144 CHARACTER(len=128) :: profbfiles(MaxNumFiles) 145 CHARACTER(len=128) :: sstfiles(MaxNumFiles) 146 CHARACTER(len=128) :: sstfbfiles(MaxNumFiles) 147 CHARACTER(len=128) :: slafilesact(MaxNumFiles) 148 CHARACTER(len=128) :: slafilespas(MaxNumFiles) 149 CHARACTER(len=128) :: slafbfiles(MaxNumFiles) 150 CHARACTER(len=128) :: seaicefiles(MaxNumFiles) 151 CHARACTER(len=128) :: velcurfiles(MaxNumFiles) 152 CHARACTER(len=128) :: veladcpfiles(MaxNumFiles) 153 CHARACTER(len=128) :: velavcurfiles(MaxNumFiles) 154 CHARACTER(len=128) :: velhrcurfiles(MaxNumFiles) 155 CHARACTER(len=128) :: velavadcpfiles(MaxNumFiles) 156 CHARACTER(len=128) :: velhradcpfiles(MaxNumFiles) 157 CHARACTER(len=128) :: velfbfiles(MaxNumFiles) 158 CHARACTER(LEN=128) :: reysstname 159 CHARACTER(LEN=12) :: reysstfmt 160 CHARACTER(LEN=128) :: bias_file 161 CHARACTER(LEN=20) :: datestr=" ", timestr=" " 162 NAMELIST/namobs/ln_ena, ln_cor, ln_profb, ln_t3d, ln_s3d, & 163 & ln_sla, ln_sladt, ln_slafb, & 164 & ln_ssh, ln_sst, ln_sstfb, ln_sss, ln_nea, & 165 & enactfiles, coriofiles, profbfiles, & 166 & slafilesact, slafilespas, slafbfiles, & 167 & sstfiles, sstfbfiles, & 168 & ln_seaice, seaicefiles, & 169 & dobsini, dobsend, n1dint, n2dint, & 170 & nmsshc, mdtcorr, mdtcutoff, & 171 & ln_reysst, ln_ghrsst, reysstname, reysstfmt, & 133 INTEGER, PARAMETER :: & 134 & jpmaxnfiles = 1000 ! Maximum number of files for each obs type 135 INTEGER, DIMENSION(:), ALLOCATABLE :: & 136 & ifilesprof, & ! Number of profile files 137 & ifilessurf ! Number of surface files 138 INTEGER :: ios ! Local integer output status for namelist read 139 INTEGER :: jtype ! Counter for obs types 140 INTEGER :: jvar ! Counter for variables 141 INTEGER :: jfile ! Counter for files 142 INTEGER :: jnumsstbias ! Number of SST bias files to read and apply 143 144 CHARACTER(len=128), DIMENSION(jpmaxnfiles) :: & 145 & cn_profbfiles, & ! T/S profile input filenames 146 & cn_sstfbfiles, & ! Sea surface temperature input filenames 147 & cn_slafbfiles, & ! Sea level anomaly input filenames 148 & cn_sicfbfiles, & ! Seaice concentration input filenames 149 & cn_velfbfiles, & ! Velocity profile input filenames 150 & cn_sssfbfiles, & ! Sea surface salinity input filenames 151 & cn_logchlfbfiles, & ! Log(Chl) input filenames 152 & cn_spmfbfiles, & ! Sediment input filenames 153 & cn_fco2fbfiles, & ! fco2 input filenames 154 & cn_pco2fbfiles, & ! pco2 input filenames 155 & cn_sstbiasfiles ! SST bias input filenames 156 157 CHARACTER(LEN=128) :: & 158 & cn_altbiasfile ! Altimeter bias input filename 159 160 161 LOGICAL :: ln_t3d ! Logical switch for temperature profiles 162 LOGICAL :: ln_s3d ! Logical switch for salinity profiles 163 LOGICAL :: ln_sla ! Logical switch for sea level anomalies 164 LOGICAL :: ln_sst ! Logical switch for sea surface temperature 165 LOGICAL :: ln_sic ! Logical switch for sea ice concentration 166 LOGICAL :: ln_sss ! Logical switch for sea surface salinity obs 167 LOGICAL :: ln_vel3d ! Logical switch for velocity (u,v) obs 168 LOGICAL :: ln_logchl ! Logical switch for log(Chl) obs 169 LOGICAL :: ln_spm ! Logical switch for sediment obs 170 LOGICAL :: ln_fco2 ! Logical switch for fco2 obs 171 LOGICAL :: ln_pco2 ! Logical switch for pco2 obs 172 LOGICAL :: ln_nea ! Logical switch to remove obs near land 173 LOGICAL :: ln_altbias ! Logical switch for altimeter bias 174 LOGICAL :: ln_sstbias ! Logical switch for bias correction of SST 175 LOGICAL :: ln_ignmis ! Logical switch for ignoring missing files 176 LOGICAL :: ln_s_at_t ! Logical switch to compute model S at T obs 177 LOGICAL :: ln_bound_reject ! Logical switch for rejecting obs near the boundary 178 179 REAL(dp) :: rn_dobsini ! Obs window start date YYYYMMDD.HHMMSS 180 REAL(dp) :: rn_dobsend ! Obs window end date YYYYMMDD.HHMMSS 181 182 CHARACTER(len=128), DIMENSION(:,:), ALLOCATABLE :: & 183 & clproffiles, & ! Profile filenames 184 & clsurffiles ! Surface filenames 185 186 LOGICAL :: llvar1 ! Logical for profile variable 1 187 LOGICAL :: llvar2 ! Logical for profile variable 1 188 189 REAL(wp), POINTER, DIMENSION(:,:) :: & 190 & zglam1, & ! Model longitudes for profile variable 1 191 & zglam2 ! Model longitudes for profile variable 2 192 REAL(wp), POINTER, DIMENSION(:,:) :: & 193 & zgphi1, & ! Model latitudes for profile variable 1 194 & zgphi2 ! Model latitudes for profile variable 2 195 REAL(wp), POINTER, DIMENSION(:,:,:) :: & 196 & zmask1, & ! Model land/sea mask associated with variable 1 197 & zmask2 ! Model land/sea mask associated with variable 2 198 199 200 NAMELIST/namobs/ln_diaobs, ln_t3d, ln_s3d, ln_sla, & 201 & ln_sst, ln_sic, ln_sss, ln_vel3d, & 202 & ln_logchl, ln_spm, ln_fco2, ln_pco2, & 203 & ln_altbias, ln_sstbias, ln_nea, & 204 & ln_grid_global, ln_grid_search_lookup, & 205 & ln_ignmis, ln_s_at_t, ln_bound_reject, & 172 206 & ln_sstnight, & 173 & ln_grid_search_lookup, & 174 & grid_search_file, grid_search_res, & 175 & ln_grid_global, bias_file, ln_altbias, & 176 & endailyavtypes, ln_s_at_t, ln_profb_ena, & 177 & ln_vel3d, ln_velavcur, velavcurfiles, & 178 & ln_velhrcur, velhrcurfiles, & 179 & ln_velavadcp, velavadcpfiles, & 180 & ln_velhradcp, velhradcpfiles, & 181 & ln_velfb, velfbfiles, ln_velfb_av, & 182 & ln_profb_enatim, ln_ignmis, ln_cl4 183 184 INTEGER :: jprofset 185 INTEGER :: jveloset 186 INTEGER :: jvar 187 INTEGER :: jnumenact 188 INTEGER :: jnumcorio 189 INTEGER :: jnumprofb 190 INTEGER :: jnumslaact 191 INTEGER :: jnumslapas 192 INTEGER :: jnumslafb 193 INTEGER :: jnumsst 194 INTEGER :: jnumsstfb 195 INTEGER :: jnumseaice 196 INTEGER :: jnumvelavcur 197 INTEGER :: jnumvelhrcur 198 INTEGER :: jnumvelavadcp 199 INTEGER :: jnumvelhradcp 200 INTEGER :: jnumvelfb 201 INTEGER :: ji 202 INTEGER :: jset 203 INTEGER :: ios ! Local integer output status for namelist read 204 LOGICAL :: lmask(MaxNumFiles), ll_u3d, ll_v3d 207 & ln_sla_fp_indegs, ln_sst_fp_indegs, & 208 & ln_sss_fp_indegs, ln_sic_fp_indegs, & 209 & cn_profbfiles, cn_slafbfiles, & 210 & cn_sstfbfiles, cn_sicfbfiles, & 211 & cn_velfbfiles, cn_sssfbfiles, & 212 & cn_logchlfbfiles, cn_spmfbfiles, & 213 & cn_fco2fbfiles, cn_pco2fbfiles, & 214 & cn_sstbiasfiles, cn_altbiasfile, & 215 & cn_gridsearchfile, rn_gridsearchres, & 216 & rn_dobsini, rn_dobsend, & 217 & rn_sla_avglamscl, rn_sla_avgphiscl, & 218 & rn_sst_avglamscl, rn_sst_avgphiscl, & 219 & rn_sss_avglamscl, rn_sss_avgphiscl, & 220 & rn_sic_avglamscl, rn_sic_avgphiscl, & 221 & nn_1dint, nn_2dint, & 222 & nn_2dint_sla, nn_2dint_sst, & 223 & nn_2dint_sss, nn_2dint_sic, & 224 & nn_msshc, rn_mdtcorr, rn_mdtcutoff, & 225 & nn_profdavtypes 226 227 CALL wrk_alloc( jpi, jpj, zglam1 ) 228 CALL wrk_alloc( jpi, jpj, zglam2 ) 229 CALL wrk_alloc( jpi, jpj, zgphi1 ) 230 CALL wrk_alloc( jpi, jpj, zgphi2 ) 231 CALL wrk_alloc( jpi, jpj, jpk, zmask1 ) 232 CALL wrk_alloc( jpi, jpj, jpk, zmask2 ) 205 233 206 234 !----------------------------------------------------------------------- … … 208 236 !----------------------------------------------------------------------- 209 237 210 enactfiles(:) = '' 211 coriofiles(:) = '' 212 profbfiles(:) = '' 213 slafilesact(:) = '' 214 slafilespas(:) = '' 215 slafbfiles(:) = '' 216 sstfiles(:) = '' 217 sstfbfiles(:) = '' 218 seaicefiles(:) = '' 219 velcurfiles(:) = '' 220 veladcpfiles(:) = '' 221 velavcurfiles(:) = '' 222 velhrcurfiles(:) = '' 223 velavadcpfiles(:) = '' 224 velhradcpfiles(:) = '' 225 velfbfiles(:) = '' 226 velcurfiles(:) = '' 227 veladcpfiles(:) = '' 228 endailyavtypes(:) = -1 229 endailyavtypes(1) = 820 230 ln_profb_ena(:) = .FALSE. 231 ln_profb_enatim(:) = .TRUE. 232 ln_velfb_av(:) = .FALSE. 233 ln_ignmis = .FALSE. 234 235 CALL ini_date( dobsini ) 236 CALL fin_date( dobsend ) 237 238 ! Read Namelist namobs : control observation diagnostics 239 REWIND( numnam_ref ) ! Namelist namobs in reference namelist : Diagnostic: control observation 238 ! Some namelist arrays need initialising 239 cn_profbfiles(:) = '' 240 cn_slafbfiles(:) = '' 241 cn_sstfbfiles(:) = '' 242 cn_sicfbfiles(:) = '' 243 cn_velfbfiles(:) = '' 244 cn_sssfbfiles(:) = '' 245 cn_logchlfbfiles(:) = '' 246 cn_spmfbfiles(:) = '' 247 cn_fco2fbfiles(:) = '' 248 cn_pco2fbfiles(:) = '' 249 cn_sstbiasfiles(:) = '' 250 nn_profdavtypes(:) = -1 251 252 CALL ini_date( rn_dobsini ) 253 CALL fin_date( rn_dobsend ) 254 255 ! Read namelist namobs : control observation diagnostics 256 REWIND( numnam_ref ) ! Namelist namobs in reference namelist 240 257 READ ( numnam_ref, namobs, IOSTAT = ios, ERR = 901) 241 258 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobs in reference namelist', lwp ) 242 259 243 REWIND( numnam_cfg ) ! Namelist namobs in configuration namelist : Diagnostic: control observation260 REWIND( numnam_cfg ) ! Namelist namobs in configuration namelist 244 261 READ ( numnam_cfg, namobs, IOSTAT = ios, ERR = 902 ) 245 262 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobs in configuration namelist', lwp ) 246 263 IF(lwm) WRITE ( numond, namobs ) 247 264 248 ! Count number of files for each type 249 IF (ln_ena) THEN 250 lmask(:) = .FALSE. 251 WHERE (enactfiles(:) /= '') lmask(:) = .TRUE. 252 jnumenact = COUNT(lmask) 253 ENDIF 254 IF (ln_cor) THEN 255 lmask(:) = .FALSE. 256 WHERE (coriofiles(:) /= '') lmask(:) = .TRUE. 257 jnumcorio = COUNT(lmask) 258 ENDIF 259 IF (ln_profb) THEN 260 lmask(:) = .FALSE. 261 WHERE (profbfiles(:) /= '') lmask(:) = .TRUE. 262 jnumprofb = COUNT(lmask) 263 ENDIF 264 IF (ln_sladt) THEN 265 lmask(:) = .FALSE. 266 WHERE (slafilesact(:) /= '') lmask(:) = .TRUE. 267 jnumslaact = COUNT(lmask) 268 lmask(:) = .FALSE. 269 WHERE (slafilespas(:) /= '') lmask(:) = .TRUE. 270 jnumslapas = COUNT(lmask) 271 ENDIF 272 IF (ln_slafb) THEN 273 lmask(:) = .FALSE. 274 WHERE (slafbfiles(:) /= '') lmask(:) = .TRUE. 275 jnumslafb = COUNT(lmask) 276 lmask(:) = .FALSE. 277 ENDIF 278 IF (ln_ghrsst) THEN 279 lmask(:) = .FALSE. 280 WHERE (sstfiles(:) /= '') lmask(:) = .TRUE. 281 jnumsst = COUNT(lmask) 282 ENDIF 283 IF (ln_sstfb) THEN 284 lmask(:) = .FALSE. 285 WHERE (sstfbfiles(:) /= '') lmask(:) = .TRUE. 286 jnumsstfb = COUNT(lmask) 287 lmask(:) = .FALSE. 288 ENDIF 289 IF (ln_seaice) THEN 290 lmask(:) = .FALSE. 291 WHERE (seaicefiles(:) /= '') lmask(:) = .TRUE. 292 jnumseaice = COUNT(lmask) 293 ENDIF 294 IF (ln_velavcur) THEN 295 lmask(:) = .FALSE. 296 WHERE (velavcurfiles(:) /= '') lmask(:) = .TRUE. 297 jnumvelavcur = COUNT(lmask) 298 ENDIF 299 IF (ln_velhrcur) THEN 300 lmask(:) = .FALSE. 301 WHERE (velhrcurfiles(:) /= '') lmask(:) = .TRUE. 302 jnumvelhrcur = COUNT(lmask) 303 ENDIF 304 IF (ln_velavadcp) THEN 305 lmask(:) = .FALSE. 306 WHERE (velavadcpfiles(:) /= '') lmask(:) = .TRUE. 307 jnumvelavadcp = COUNT(lmask) 308 ENDIF 309 IF (ln_velhradcp) THEN 310 lmask(:) = .FALSE. 311 WHERE (velhradcpfiles(:) /= '') lmask(:) = .TRUE. 312 jnumvelhradcp = COUNT(lmask) 313 ENDIF 314 IF (ln_velfb) THEN 315 lmask(:) = .FALSE. 316 WHERE (velfbfiles(:) /= '') lmask(:) = .TRUE. 317 jnumvelfb = COUNT(lmask) 318 lmask(:) = .FALSE. 319 ENDIF 320 321 ! Control print 265 lk_diaobs = .FALSE. 266 #if defined key_diaobs 267 IF ( ln_diaobs ) lk_diaobs = .TRUE. 268 #endif 269 270 IF ( .NOT. lk_diaobs ) THEN 271 IF(lwp) WRITE(numout,cform_war) 272 IF(lwp) WRITE(numout,*)' ln_diaobs is set to false or key_diaobs is not set, so not calling dia_obs' 273 RETURN 274 ENDIF 275 322 276 IF(lwp) THEN 323 277 WRITE(numout,*) … … 325 279 WRITE(numout,*) '~~~~~~~~~~~~' 326 280 WRITE(numout,*) ' Namelist namobs : set observation diagnostic parameters' 327 WRITE(numout,*) ' Logical switch for T profile observations ln_t3d = ', ln_t3d 328 WRITE(numout,*) ' Logical switch for S profile observations ln_s3d = ', ln_s3d 329 WRITE(numout,*) ' Logical switch for ENACT insitu data set ln_ena = ', ln_ena 330 WRITE(numout,*) ' Logical switch for Coriolis insitu data set ln_cor = ', ln_cor 331 WRITE(numout,*) ' Logical switch for feedback insitu data set ln_profb = ', ln_profb 332 WRITE(numout,*) ' Logical switch for SLA observations ln_sla = ', ln_sla 333 WRITE(numout,*) ' Logical switch for AVISO SLA data ln_sladt = ', ln_sladt 334 WRITE(numout,*) ' Logical switch for feedback SLA data ln_slafb = ', ln_slafb 335 WRITE(numout,*) ' Logical switch for SSH observations ln_ssh = ', ln_ssh 336 WRITE(numout,*) ' Logical switch for SST observations ln_sst = ', ln_sst 337 WRITE(numout,*) ' Logical switch for Reynolds observations ln_reysst = ', ln_reysst 338 WRITE(numout,*) ' Logical switch for GHRSST observations ln_ghrsst = ', ln_ghrsst 339 WRITE(numout,*) ' Logical switch for feedback SST data ln_sstfb = ', ln_sstfb 340 WRITE(numout,*) ' Logical switch for night-time SST obs ln_sstnight = ', ln_sstnight 341 WRITE(numout,*) ' Logical switch for SSS observations ln_sss = ', ln_sss 342 WRITE(numout,*) ' Logical switch for Sea Ice observations ln_seaice = ', ln_seaice 343 WRITE(numout,*) ' Logical switch for velocity observations ln_vel3d = ', ln_vel3d 344 WRITE(numout,*) ' Logical switch for velocity daily av. cur. ln_velavcur = ', ln_velavcur 345 WRITE(numout,*) ' Logical switch for velocity high freq. cur. ln_velhrcur = ', ln_velhrcur 346 WRITE(numout,*) ' Logical switch for velocity daily av. ADCP ln_velavadcp = ', ln_velavadcp 347 WRITE(numout,*) ' Logical switch for velocity high freq. ADCP ln_velhradcp = ', ln_velhradcp 348 WRITE(numout,*) ' Logical switch for feedback velocity data ln_velfb = ', ln_velfb 349 WRITE(numout,*) ' Global distribtion of observations ln_grid_global = ',ln_grid_global 350 WRITE(numout,*) & 351 ' Logical switch for obs grid search w/lookup table ln_grid_search_lookup = ',ln_grid_search_lookup 281 WRITE(numout,*) ' Logical switch for T profile observations ln_t3d = ', ln_t3d 282 WRITE(numout,*) ' Logical switch for S profile observations ln_s3d = ', ln_s3d 283 WRITE(numout,*) ' Logical switch for SLA observations ln_sla = ', ln_sla 284 WRITE(numout,*) ' Logical switch for SST observations ln_sst = ', ln_sst 285 WRITE(numout,*) ' Logical switch for Sea Ice observations ln_sic = ', ln_sic 286 WRITE(numout,*) ' Logical switch for velocity observations ln_vel3d = ', ln_vel3d 287 WRITE(numout,*) ' Logical switch for SSS observations ln_sss = ', ln_sss 288 WRITE(numout,*) ' Logical switch for log(Chl) observations ln_logchl = ', ln_logchl 289 WRITE(numout,*) ' Logical switch for SPM observations ln_spm = ', ln_spm 290 WRITE(numout,*) ' Logical switch for FCO2 observations ln_fco2 = ', ln_fco2 291 WRITE(numout,*) ' Logical switch for PCO2 observations ln_pco2 = ', ln_pco2 292 WRITE(numout,*) ' Global distribution of observations ln_grid_global = ', ln_grid_global 293 WRITE(numout,*) ' Logical switch for obs grid search lookup ln_grid_search_lookup = ', ln_grid_search_lookup 352 294 IF (ln_grid_search_lookup) & 353 WRITE(numout,*) ' Grid search lookup file header grid_search_file = ', grid_search_file 354 IF (ln_ena) THEN 355 DO ji = 1, jnumenact 356 WRITE(numout,'(1X,2A)') ' ENACT input observation file name enactfiles = ', & 357 TRIM(enactfiles(ji)) 358 END DO 295 WRITE(numout,*) ' Grid search lookup file header cn_gridsearchfile = ', cn_gridsearchfile 296 WRITE(numout,*) ' Initial date in window YYYYMMDD.HHMMSS rn_dobsini = ', rn_dobsini 297 WRITE(numout,*) ' Final date in window YYYYMMDD.HHMMSS rn_dobsend = ', rn_dobsend 298 WRITE(numout,*) ' Type of vertical interpolation method nn_1dint = ', nn_1dint 299 WRITE(numout,*) ' Type of horizontal interpolation method nn_2dint = ', nn_2dint 300 WRITE(numout,*) ' Rejection of observations near land switch ln_nea = ', ln_nea 301 WRITE(numout,*) ' Rejection of obs near open bdys ln_bound_reject = ', ln_bound_reject 302 WRITE(numout,*) ' MSSH correction scheme nn_msshc = ', nn_msshc 303 WRITE(numout,*) ' MDT correction rn_mdtcorr = ', rn_mdtcorr 304 WRITE(numout,*) ' MDT cutoff for computed correction rn_mdtcutoff = ', rn_mdtcutoff 305 WRITE(numout,*) ' Logical switch for alt bias ln_altbias = ', ln_altbias 306 WRITE(numout,*) ' Logical switch for sst bias ln_sstbias = ', ln_sstbias 307 WRITE(numout,*) ' Logical switch for ignoring missing files ln_ignmis = ', ln_ignmis 308 WRITE(numout,*) ' Daily average types nn_profdavtypes = ', nn_profdavtypes 309 WRITE(numout,*) ' Logical switch for night-time SST obs ln_sstnight = ', ln_sstnight 310 ENDIF 311 !----------------------------------------------------------------------- 312 ! Set up list of observation types to be used 313 ! and the files associated with each type 314 !----------------------------------------------------------------------- 315 316 nproftypes = COUNT( (/ln_t3d .OR. ln_s3d, ln_vel3d /) ) 317 nsurftypes = COUNT( (/ln_sla, ln_sst, ln_sic, ln_sss, & 318 & ln_logchl, ln_spm, ln_fco2, ln_pco2 /) ) 319 320 IF ( nproftypes == 0 .AND. nsurftypes == 0 ) THEN 321 IF(lwp) WRITE(numout,cform_war) 322 IF(lwp) WRITE(numout,*) ' ln_diaobs is set to true, but all obs operator logical flags', & 323 & ' are set to .FALSE. so turning off calls to dia_obs' 324 nwarn = nwarn + 1 325 lk_diaobs = .FALSE. 326 RETURN 327 ENDIF 328 329 IF(lwp) WRITE(numout,*) ' Number of profile obs types: ',nproftypes 330 IF ( nproftypes > 0 ) THEN 331 332 ALLOCATE( cobstypesprof(nproftypes) ) 333 ALLOCATE( ifilesprof(nproftypes) ) 334 ALLOCATE( clproffiles(nproftypes,jpmaxnfiles) ) 335 336 jtype = 0 337 IF (ln_t3d .OR. ln_s3d) THEN 338 jtype = jtype + 1 339 CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'prof ', & 340 & cn_profbfiles, ifilesprof, cobstypesprof, clproffiles ) 359 341 ENDIF 360 IF (ln_cor) THEN 361 DO ji = 1, jnumcorio 362 WRITE(numout,'(1X,2A)') ' Coriolis input observation file name coriofiles = ', & 363 TRIM(coriofiles(ji)) 364 END DO 342 IF (ln_vel3d) THEN 343 jtype = jtype + 1 344 CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'vel ', & 345 & cn_velfbfiles, ifilesprof, cobstypesprof, clproffiles ) 365 346 ENDIF 366 IF (ln_profb) THEN 367 DO ji = 1, jnumprofb 368 IF (ln_profb_ena(ji)) THEN 369 WRITE(numout,'(1X,2A)') ' Enact feedback input observation file name profbfiles = ', & 370 TRIM(profbfiles(ji)) 371 ELSE 372 WRITE(numout,'(1X,2A)') ' Feedback input observation file name profbfiles = ', & 373 TRIM(profbfiles(ji)) 374 ENDIF 375 WRITE(numout,'(1X,2A)') ' Enact feedback input time setting switch ln_profb_enatim = ', ln_profb_enatim(ji) 376 END DO 347 348 ENDIF 349 350 IF(lwp) WRITE(numout,*)' Number of surface obs types: ',nsurftypes 351 IF ( nsurftypes > 0 ) THEN 352 353 ALLOCATE( cobstypessurf(nsurftypes) ) 354 ALLOCATE( ifilessurf(nsurftypes) ) 355 ALLOCATE( clsurffiles(nsurftypes, jpmaxnfiles) ) 356 ALLOCATE(n2dintsurf(nsurftypes)) 357 ALLOCATE(ravglamscl(nsurftypes)) 358 ALLOCATE(ravgphiscl(nsurftypes)) 359 ALLOCATE(lfpindegs(nsurftypes)) 360 ALLOCATE(llnightav(nsurftypes)) 361 362 jtype = 0 363 IF (ln_sla) THEN 364 jtype = jtype + 1 365 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sla ', & 366 & cn_slafbfiles, ifilessurf, cobstypessurf, clsurffiles ) 367 CALL obs_setinterpopts( nsurftypes, jtype, 'sla ', & 368 & nn_2dint, nn_2dint_sla, & 369 & rn_sla_avglamscl, rn_sla_avgphiscl, & 370 & ln_sla_fp_indegs, .FALSE., & 371 & n2dintsurf, ravglamscl, ravgphiscl, & 372 & lfpindegs, llnightav ) 377 373 ENDIF 378 IF (ln_sladt) THEN 379 DO ji = 1, jnumslaact 380 WRITE(numout,'(1X,2A)') ' Active SLA input observation file name slafilesact = ', & 381 TRIM(slafilesact(ji)) 382 END DO 383 DO ji = 1, jnumslapas 384 WRITE(numout,'(1X,2A)') ' Passive SLA input observation file name slafilespas = ', & 385 TRIM(slafilespas(ji)) 386 END DO 374 IF (ln_sst) THEN 375 jtype = jtype + 1 376 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sst ', & 377 & cn_sstfbfiles, ifilessurf, cobstypessurf, clsurffiles ) 378 CALL obs_setinterpopts( nsurftypes, jtype, 'sst ', & 379 & nn_2dint, nn_2dint_sst, & 380 & rn_sst_avglamscl, rn_sst_avgphiscl, & 381 & ln_sst_fp_indegs, ln_sstnight, & 382 & n2dintsurf, ravglamscl, ravgphiscl, & 383 & lfpindegs, llnightav ) 387 384 ENDIF 388 IF (ln_slafb) THEN 389 DO ji = 1, jnumslafb 390 WRITE(numout,'(1X,2A)') ' Feedback SLA input observation file name slafbfiles = ', & 391 TRIM(slafbfiles(ji)) 392 END DO 385 #if defined key_lim2 || defined key_lim3 || defined key_cice 386 IF (ln_sic) THEN 387 jtype = jtype + 1 388 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sic ', & 389 & cn_sicfbfiles, ifilessurf, cobstypessurf, clsurffiles ) 390 CALL obs_setinterpopts( nsurftypes, jtype, 'sic ', & 391 & nn_2dint, nn_2dint_sic, & 392 & rn_sic_avglamscl, rn_sic_avgphiscl, & 393 & ln_sic_fp_indegs, .FALSE., & 394 & n2dintsurf, ravglamscl, ravgphiscl, & 395 & lfpindegs, llnightav ) 393 396 ENDIF 394 IF (ln_ghrsst) THEN 395 DO ji = 1, jnumsst 396 WRITE(numout,'(1X,2A)') ' GHRSST input observation file name sstfiles = ', & 397 TRIM(sstfiles(ji)) 398 END DO 397 #endif 398 IF (ln_sss) THEN 399 jtype = jtype + 1 400 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sss ', & 401 & cn_sssfbfiles, ifilessurf, cobstypessurf, clsurffiles ) 402 CALL obs_setinterpopts( nsurftypes, jtype, 'sss ', & 403 & nn_2dint, nn_2dint_sss, & 404 & rn_sss_avglamscl, rn_sss_avgphiscl, & 405 & ln_sss_fp_indegs, .FALSE., & 406 & n2dintsurf, ravglamscl, ravgphiscl, & 407 & lfpindegs, llnightav ) 399 408 ENDIF 400 IF (ln_sstfb) THEN 401 DO ji = 1, jnumsstfb 402 WRITE(numout,'(1X,2A)') ' Feedback SST input observation file name sstfbfiles = ', & 403 TRIM(sstfbfiles(ji)) 404 END DO 409 410 IF (ln_logchl) THEN 411 jtype = jtype + 1 412 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'logchl', & 413 & cn_logchlfbfiles, ifilessurf, cobstypessurf, clsurffiles ) 414 CALL obs_setinterpopts( nsurftypes, jtype, 'logchl', & 415 & nn_2dint, -1, 0., 0., .TRUE., .FALSE., & 416 & n2dintsurf, ravglamscl, ravgphiscl, & 417 & lfpindegs, llnightav ) 405 418 ENDIF 406 IF (ln_seaice) THEN 407 DO ji = 1, jnumseaice 408 WRITE(numout,'(1X,2A)') ' Sea Ice input observation file name seaicefiles = ', & 409 TRIM(seaicefiles(ji)) 410 END DO 419 420 IF (ln_spm) THEN 421 jtype = jtype + 1 422 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'spm ', & 423 & cn_spmfbfiles, ifilessurf, cobstypessurf, clsurffiles ) 424 CALL obs_setinterpopts( nsurftypes, jtype, 'spm ', & 425 & nn_2dint, -1, 0., 0., .TRUE., .FALSE., & 426 & n2dintsurf, ravglamscl, ravgphiscl, & 427 & lfpindegs, llnightav ) 411 428 ENDIF 412 IF (ln_velavcur) THEN 413 DO ji = 1, jnumvelavcur 414 WRITE(numout,'(1X,2A)') ' Vel. cur. daily av. input file name velavcurfiles = ', & 415 TRIM(velavcurfiles(ji)) 416 END DO 429 430 IF (ln_fco2) THEN 431 jtype = jtype + 1 432 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'fco2 ', & 433 & cn_fco2fbfiles, ifilessurf, cobstypessurf, clsurffiles ) 434 CALL obs_setinterpopts( nsurftypes, jtype, 'fco2 ', & 435 & nn_2dint, -1, 0., 0., .TRUE., .FALSE., & 436 & n2dintsurf, ravglamscl, ravgphiscl, & 437 & lfpindegs, llnightav ) 417 438 ENDIF 418 IF (ln_velhrcur) THEN 419 DO ji = 1, jnumvelhrcur 420 WRITE(numout,'(1X,2A)') ' Vel. cur. high freq. input file name velhvcurfiles = ', & 421 TRIM(velhrcurfiles(ji)) 422 END DO 439 440 IF (ln_pco2) THEN 441 jtype = jtype + 1 442 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'pco2 ', & 443 & cn_pco2fbfiles, ifilessurf, cobstypessurf, clsurffiles ) 444 CALL obs_setinterpopts( nsurftypes, jtype, 'pco2 ', & 445 & nn_2dint, -1, 0., 0., .TRUE., .FALSE., & 446 & n2dintsurf, ravglamscl, ravgphiscl, & 447 & lfpindegs, llnightav ) 423 448 ENDIF 424 IF (ln_velavadcp) THEN 425 DO ji = 1, jnumvelavadcp 426 WRITE(numout,'(1X,2A)') ' Vel. ADCP daily av. input file name velavadcpfiles = ', & 427 TRIM(velavadcpfiles(ji)) 428 END DO 429 ENDIF 430 IF (ln_velhradcp) THEN 431 DO ji = 1, jnumvelhradcp 432 WRITE(numout,'(1X,2A)') ' Vel. ADCP high freq. input file name velhvadcpfiles = ', & 433 TRIM(velhradcpfiles(ji)) 434 END DO 435 ENDIF 436 IF (ln_velfb) THEN 437 DO ji = 1, jnumvelfb 438 IF (ln_velfb_av(ji)) THEN 439 WRITE(numout,'(1X,2A)') ' Vel. feedback daily av. input file name velfbfiles = ', & 440 TRIM(velfbfiles(ji)) 441 ELSE 442 WRITE(numout,'(1X,2A)') ' Vel. feedback input observation file name velfbfiles = ', & 443 TRIM(velfbfiles(ji)) 444 ENDIF 445 END DO 446 ENDIF 447 WRITE(numout,*) ' Initial date in window YYYYMMDD.HHMMSS dobsini = ', dobsini 448 WRITE(numout,*) ' Final date in window YYYYMMDD.HHMMSS dobsend = ', dobsend 449 WRITE(numout,*) ' Type of vertical interpolation method n1dint = ', n1dint 450 WRITE(numout,*) ' Type of horizontal interpolation method n2dint = ', n2dint 451 WRITE(numout,*) ' Rejection of observations near land swithch ln_nea = ', ln_nea 452 WRITE(numout,*) ' MSSH correction scheme nmsshc = ', nmsshc 453 WRITE(numout,*) ' MDT correction mdtcorr = ', mdtcorr 454 WRITE(numout,*) ' MDT cutoff for computed correction mdtcutoff = ', mdtcutoff 455 WRITE(numout,*) ' Logical switch for alt bias ln_altbias = ', ln_altbias 456 WRITE(numout,*) ' Logical switch for ignoring missing files ln_ignmis = ', ln_ignmis 457 WRITE(numout,*) ' ENACT daily average types = ',endailyavtypes 458 459 ENDIF 460 449 450 ENDIF 451 452 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 453 454 455 !----------------------------------------------------------------------- 456 ! Obs operator parameter checking and initialisations 457 !----------------------------------------------------------------------- 458 461 459 IF ( ln_vel3d .AND. ( .NOT. ln_grid_global ) ) THEN 462 460 CALL ctl_stop( 'Velocity data only works with ln_grid_global=.true.' ) … … 464 462 ENDIF 465 463 466 CALL obs_typ_init 467 468 CALL mppmap_init 469 470 ! Parameter control 471 #if defined key_diaobs 472 IF ( ( .NOT. ln_t3d ).AND.( .NOT. ln_s3d ).AND.( .NOT. ln_sla ).AND. & 473 & ( .NOT. ln_vel3d ).AND. & 474 & ( .NOT. ln_ssh ).AND.( .NOT. ln_sst ).AND.( .NOT. ln_sss ).AND. & 475 & ( .NOT. ln_seaice ).AND.( .NOT. ln_vel3d ) ) THEN 476 IF(lwp) WRITE(numout,cform_war) 477 IF(lwp) WRITE(numout,*) ' key_diaobs is activated but logical flags', & 478 & ' ln_t3d, ln_s3d, ln_sla, ln_ssh, ln_sst, ln_sss, ln_seaice, ln_vel3d are all set to .FALSE.' 479 nwarn = nwarn + 1 480 ENDIF 481 #endif 482 483 CALL obs_grid_setup( ) 484 IF ( ( n1dint < 0 ).OR.( n1dint > 1 ) ) THEN 464 IF ( ( nn_1dint < 0 ) .OR. ( nn_1dint > 1 ) ) THEN 485 465 CALL ctl_stop(' Choice of vertical (1D) interpolation method', & 486 466 & ' is not available') 487 467 ENDIF 488 IF ( ( n2dint < 0 ).OR.( n2dint > 4 ) ) THEN 468 469 IF ( ( nn_2dint < 0 ) .OR. ( nn_2dint > 6 ) ) THEN 489 470 CALL ctl_stop(' Choice of horizontal (2D) interpolation method', & 490 471 & ' is not available') 491 472 ENDIF 492 473 474 CALL obs_typ_init 475 476 CALL mppmap_init 477 478 CALL obs_grid_setup( ) 479 493 480 !----------------------------------------------------------------------- 494 481 ! Depending on switches read the various observation types 495 482 !----------------------------------------------------------------------- 496 ! - Temperature/salinity profiles 497 498 IF ( ln_t3d .OR. ln_s3d ) THEN 499 500 ! Set the number of variables for profiles to 2 (T and S) 501 nprofvars = 2 502 ! Set the number of extra variables for profiles to 1 (insitu temp). 503 nprofextr = 1 504 505 ! Count how may insitu data sets we have and allocate data. 506 jprofset = 0 507 IF ( ln_ena ) jprofset = jprofset + 1 508 IF ( ln_cor ) jprofset = jprofset + 1 509 IF ( ln_profb ) jprofset = jprofset + jnumprofb 510 nprofsets = jprofset 511 IF ( nprofsets > 0 ) THEN 512 ALLOCATE(ld_enact(nprofsets)) 513 ALLOCATE(profdata(nprofsets)) 514 ALLOCATE(prodatqc(nprofsets)) 515 ENDIF 516 517 jprofset = 0 518 519 ! ENACT insitu data 520 521 IF ( ln_ena ) THEN 522 523 jprofset = jprofset + 1 524 525 ld_enact(jprofset) = .TRUE. 526 527 CALL obs_rea_pro_dri( 1, profdata(jprofset), & 528 & jnumenact, enactfiles(1:jnumenact), & 529 & nprofvars, nprofextr, & 530 & nitend-nit000+2, & 531 & dobsini, dobsend, ln_t3d, ln_s3d, & 532 & ln_ignmis, ln_s_at_t, .TRUE., .FALSE., & 533 & kdailyavtypes = endailyavtypes ) 534 535 DO jvar = 1, 2 536 537 CALL obs_prof_staend( profdata(jprofset), jvar ) 538 483 484 IF ( nproftypes > 0 ) THEN 485 486 ALLOCATE(profdata(nproftypes)) 487 ALLOCATE(profdataqc(nproftypes)) 488 ALLOCATE(nvarsprof(nproftypes)) 489 ALLOCATE(nextrprof(nproftypes)) 490 491 DO jtype = 1, nproftypes 492 493 nvarsprof(jtype) = 2 494 IF ( TRIM(cobstypesprof(jtype)) == 'prof' ) THEN 495 nextrprof(jtype) = 1 496 llvar1 = ln_t3d 497 llvar2 = ln_s3d 498 zglam1 = glamt 499 zgphi1 = gphit 500 zmask1 = tmask 501 zglam2 = glamt 502 zgphi2 = gphit 503 zmask2 = tmask 504 ENDIF 505 IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN 506 nextrprof(jtype) = 2 507 llvar1 = ln_vel3d 508 llvar2 = ln_vel3d 509 zglam1 = glamu 510 zgphi1 = gphiu 511 zmask1 = umask 512 zglam2 = glamv 513 zgphi2 = gphiv 514 zmask2 = vmask 515 ENDIF 516 517 !Read in profile or profile obs types 518 CALL obs_rea_prof( profdata(jtype), ifilesprof(jtype), & 519 & clproffiles(jtype,1:ifilesprof(jtype)), & 520 & nvarsprof(jtype), nextrprof(jtype), nitend-nit000+2, & 521 & rn_dobsini, rn_dobsend, llvar1, llvar2, & 522 & ln_ignmis, ln_s_at_t, .FALSE., & 523 & kdailyavtypes = nn_profdavtypes ) 524 525 DO jvar = 1, nvarsprof(jtype) 526 CALL obs_prof_staend( profdata(jtype), jvar ) 539 527 END DO 540 528 541 CALL obs_pre_pro( profdata(jprofset), prodatqc(jprofset), & 542 & ln_t3d, ln_s3d, ln_nea, & 543 & kdailyavtypes=endailyavtypes ) 544 545 ENDIF 546 547 ! Coriolis insitu data 548 549 IF ( ln_cor ) THEN 550 551 jprofset = jprofset + 1 552 553 ld_enact(jprofset) = .FALSE. 554 555 CALL obs_rea_pro_dri( 2, profdata(jprofset), & 556 & jnumcorio, coriofiles(1:jnumcorio), & 557 & nprofvars, nprofextr, & 558 & nitend-nit000+2, & 559 & dobsini, dobsend, ln_t3d, ln_s3d, & 560 & ln_ignmis, ln_s_at_t, .FALSE., .FALSE. ) 561 562 DO jvar = 1, 2 563 564 CALL obs_prof_staend( profdata(jprofset), jvar ) 565 566 END DO 567 568 CALL obs_pre_pro( profdata(jprofset), prodatqc(jprofset), & 569 & ln_t3d, ln_s3d, ln_nea ) 570 571 ENDIF 572 573 ! Feedback insitu data 574 575 IF ( ln_profb ) THEN 576 577 DO jset = 1, jnumprofb 578 579 jprofset = jprofset + 1 580 ld_enact (jprofset) = ln_profb_ena(jset) 581 582 CALL obs_rea_pro_dri( 0, profdata(jprofset), & 583 & 1, profbfiles(jset:jset), & 584 & nprofvars, nprofextr, & 585 & nitend-nit000+2, & 586 & dobsini, dobsend, ln_t3d, ln_s3d, & 587 & ln_ignmis, ln_s_at_t, & 588 & ld_enact(jprofset).AND.& 589 & ln_profb_enatim(jset), & 590 & .FALSE., kdailyavtypes = endailyavtypes ) 591 592 DO jvar = 1, 2 593 594 CALL obs_prof_staend( profdata(jprofset), jvar ) 595 529 CALL obs_pre_prof( profdata(jtype), profdataqc(jtype), & 530 & llvar1, llvar2, & 531 & jpi, jpj, jpk, & 532 & zmask1, zglam1, zgphi1, zmask2, zglam2, zgphi2, & 533 & ln_nea, ln_bound_reject, & 534 & kdailyavtypes = nn_profdavtypes ) 535 536 END DO 537 538 DEALLOCATE( ifilesprof, clproffiles ) 539 540 ENDIF 541 542 IF ( nsurftypes > 0 ) THEN 543 544 ALLOCATE(surfdata(nsurftypes)) 545 ALLOCATE(surfdataqc(nsurftypes)) 546 ALLOCATE(nvarssurf(nsurftypes)) 547 ALLOCATE(nextrsurf(nsurftypes)) 548 549 DO jtype = 1, nsurftypes 550 551 nvarssurf(jtype) = 1 552 nextrsurf(jtype) = 0 553 IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) nextrsurf(jtype) = 2 554 555 !Read in surface obs types 556 CALL obs_rea_surf( surfdata(jtype), ifilessurf(jtype), & 557 & clsurffiles(jtype,1:ifilessurf(jtype)), & 558 & nvarssurf(jtype), nextrsurf(jtype), nitend-nit000+2, & 559 & rn_dobsini, rn_dobsend, ln_ignmis, .FALSE., llnightav(jtype) ) 560 561 CALL obs_pre_surf( surfdata(jtype), surfdataqc(jtype), ln_nea, ln_bound_reject ) 562 563 IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN 564 CALL obs_rea_mdt( surfdataqc(jtype), n2dintsurf(jtype) ) 565 IF ( ln_altbias ) & 566 & CALL obs_rea_altbias ( surfdataqc(jtype), n2dintsurf(jtype), cn_altbiasfile ) 567 ENDIF 568 569 IF ( TRIM(cobstypessurf(jtype)) == 'sst' .AND. ln_sstbias ) THEN 570 jnumsstbias = 0 571 DO jfile = 1, jpmaxnfiles 572 IF ( TRIM(cn_sstbiasfiles(jfile)) /= '' ) & 573 & jnumsstbias = jnumsstbias + 1 596 574 END DO 597 598 IF ( ld_enact(jprofset) ) THEN 599 CALL obs_pre_pro( profdata(jprofset), prodatqc(jprofset), & 600 & ln_t3d, ln_s3d, ln_nea, & 601 & kdailyavtypes = endailyavtypes ) 602 ELSE 603 CALL obs_pre_pro( profdata(jprofset), prodatqc(jprofset), & 604 & ln_t3d, ln_s3d, ln_nea ) 575 IF ( jnumsstbias == 0 ) THEN 576 CALL ctl_stop("ln_sstbias set but no bias files to read in") 605 577 ENDIF 606 607 END DO 608 609 ENDIF 610 611 ENDIF 612 613 ! - Sea level anomalies 614 IF ( ln_sla ) THEN 615 ! Set the number of variables for sla to 1 616 nslavars = 1 617 618 ! Set the number of extra variables for sla to 2 619 nslaextr = 2 620 621 ! Set the number of sla data sets to 2 622 nslasets = 0 623 IF ( ln_sladt ) THEN 624 nslasets = nslasets + 2 625 ENDIF 626 IF ( ln_slafb ) THEN 627 nslasets = nslasets + jnumslafb 628 ENDIF 629 630 ALLOCATE(sladata(nslasets)) 631 ALLOCATE(sladatqc(nslasets)) 632 sladata(:)%nsurf=0 633 sladatqc(:)%nsurf=0 634 635 nslasets = 0 636 637 ! AVISO SLA data 638 639 IF ( ln_sladt ) THEN 640 641 ! Active SLA observations 642 643 nslasets = nslasets + 1 644 645 CALL obs_rea_sla( 1, sladata(nslasets), jnumslaact, & 646 & slafilesact(1:jnumslaact), & 647 & nslavars, nslaextr, nitend-nit000+2, & 648 & dobsini, dobsend, ln_ignmis, .FALSE. ) 649 CALL obs_pre_sla( sladata(nslasets), sladatqc(nslasets), & 650 & ln_sla, ln_nea ) 651 652 ! Passive SLA observations 653 654 nslasets = nslasets + 1 655 656 CALL obs_rea_sla( 1, sladata(nslasets), jnumslapas, & 657 & slafilespas(1:jnumslapas), & 658 & nslavars, nslaextr, nitend-nit000+2, & 659 & dobsini, dobsend, ln_ignmis, .FALSE. ) 660 661 CALL obs_pre_sla( sladata(nslasets), sladatqc(nslasets), & 662 & ln_sla, ln_nea ) 663 664 ENDIF 665 666 ! Feedback SLA data 667 668 IF ( ln_slafb ) THEN 669 670 DO jset = 1, jnumslafb 671 672 nslasets = nslasets + 1 673 674 CALL obs_rea_sla( 0, sladata(nslasets), 1, & 675 & slafbfiles(jset:jset), & 676 & nslavars, nslaextr, nitend-nit000+2, & 677 & dobsini, dobsend, ln_ignmis, .FALSE. ) 678 CALL obs_pre_sla( sladata(nslasets), sladatqc(nslasets), & 679 & ln_sla, ln_nea ) 680 681 END DO 682 683 ENDIF 684 685 CALL obs_rea_mdt( nslasets, sladatqc, n2dint ) 686 687 ! read in altimeter bias 688 689 IF ( ln_altbias ) THEN 690 CALL obs_rea_altbias ( nslasets, sladatqc, n2dint, bias_file ) 691 ENDIF 692 693 ENDIF 694 695 ! - Sea surface height 696 IF ( ln_ssh ) THEN 697 IF(lwp) WRITE(numout,*) ' SSH currently not available' 698 ENDIF 699 700 ! - Sea surface temperature 701 IF ( ln_sst ) THEN 702 703 ! Set the number of variables for sst to 1 704 nsstvars = 1 705 706 ! Set the number of extra variables for sst to 0 707 nsstextr = 0 708 709 nsstsets = 0 710 711 IF (ln_reysst) nsstsets = nsstsets + 1 712 IF (ln_ghrsst) nsstsets = nsstsets + 1 713 IF ( ln_sstfb ) THEN 714 nsstsets = nsstsets + jnumsstfb 715 ENDIF 716 717 ALLOCATE(sstdata(nsstsets)) 718 ALLOCATE(sstdatqc(nsstsets)) 719 ALLOCATE(ld_sstnight(nsstsets)) 720 sstdata(:)%nsurf=0 721 sstdatqc(:)%nsurf=0 722 ld_sstnight(:)=.false. 723 724 nsstsets = 0 725 726 IF (ln_reysst) THEN 727 728 nsstsets = nsstsets + 1 729 730 ld_sstnight(nsstsets) = ln_sstnight 731 732 CALL obs_rea_sst_rey( reysstname, reysstfmt, sstdata(nsstsets), & 733 & nsstvars, nsstextr, & 734 & nitend-nit000+2, dobsini, dobsend ) 735 CALL obs_pre_sst( sstdata(nsstsets), sstdatqc(nsstsets), ln_sst, & 736 & ln_nea ) 737 738 ENDIF 739 740 IF (ln_ghrsst) THEN 741 742 nsstsets = nsstsets + 1 743 744 ld_sstnight(nsstsets) = ln_sstnight 745 746 CALL obs_rea_sst( 1, sstdata(nsstsets), jnumsst, & 747 & sstfiles(1:jnumsst), & 748 & nsstvars, nsstextr, nitend-nit000+2, & 749 & dobsini, dobsend, ln_ignmis, .FALSE. ) 750 CALL obs_pre_sst( sstdata(nsstsets), sstdatqc(nsstsets), ln_sst, & 751 & ln_nea ) 752 753 ENDIF 754 755 ! Feedback SST data 756 757 IF ( ln_sstfb ) THEN 758 759 DO jset = 1, jnumsstfb 760 761 nsstsets = nsstsets + 1 762 763 ld_sstnight(nsstsets) = ln_sstnight 764 765 CALL obs_rea_sst( 0, sstdata(nsstsets), 1, & 766 & sstfbfiles(jset:jset), & 767 & nsstvars, nsstextr, nitend-nit000+2, & 768 & dobsini, dobsend, ln_ignmis, .FALSE. ) 769 CALL obs_pre_sst( sstdata(nsstsets), sstdatqc(nsstsets), & 770 & ln_sst, ln_nea ) 771 772 END DO 773 774 ENDIF 775 776 ENDIF 777 778 ! - Sea surface salinity 779 IF ( ln_sss ) THEN 780 IF(lwp) WRITE(numout,*) ' SSS currently not available' 781 ENDIF 782 783 ! - Sea Ice Concentration 784 785 IF ( ln_seaice ) THEN 786 787 ! Set the number of variables for seaice to 1 788 nseaicevars = 1 789 790 ! Set the number of extra variables for seaice to 0 791 nseaiceextr = 0 792 793 ! Set the number of data sets to 1 794 nseaicesets = 1 795 796 ALLOCATE(seaicedata(nseaicesets)) 797 ALLOCATE(seaicedatqc(nseaicesets)) 798 seaicedata(:)%nsurf=0 799 seaicedatqc(:)%nsurf=0 800 801 CALL obs_rea_seaice( 1, seaicedata(nseaicesets), jnumseaice, & 802 & seaicefiles(1:jnumseaice), & 803 & nseaicevars, nseaiceextr, nitend-nit000+2, & 804 & dobsini, dobsend, ln_ignmis, .FALSE. ) 805 806 CALL obs_pre_seaice( seaicedata(nseaicesets), seaicedatqc(nseaicesets), & 807 & ln_seaice, ln_nea ) 808 809 ENDIF 810 811 IF (ln_vel3d) THEN 812 813 ! Set the number of variables for profiles to 2 (U and V) 814 nvelovars = 2 815 816 ! Set the number of extra variables for profiles to 2 to store 817 ! rotation parameters 818 nveloextr = 2 819 820 jveloset = 0 821 822 IF ( ln_velavcur ) jveloset = jveloset + 1 823 IF ( ln_velhrcur ) jveloset = jveloset + 1 824 IF ( ln_velavadcp ) jveloset = jveloset + 1 825 IF ( ln_velhradcp ) jveloset = jveloset + 1 826 IF (ln_velfb) jveloset = jveloset + jnumvelfb 827 828 nvelosets = jveloset 829 IF ( nvelosets > 0 ) THEN 830 ALLOCATE( velodata(nvelosets) ) 831 ALLOCATE( veldatqc(nvelosets) ) 832 ALLOCATE( ld_velav(nvelosets) ) 833 ENDIF 834 835 jveloset = 0 836 837 ! Daily averaged data 838 839 IF ( ln_velavcur ) THEN 840 841 jveloset = jveloset + 1 842 843 ld_velav(jveloset) = .TRUE. 844 845 CALL obs_rea_vel_dri( 1, velodata(jveloset), jnumvelavcur, & 846 & velavcurfiles(1:jnumvelavcur), & 847 & nvelovars, nveloextr, & 848 & nitend-nit000+2, & 849 & dobsini, dobsend, ln_ignmis, & 850 & ld_velav(jveloset), & 851 & .FALSE. ) 852 853 DO jvar = 1, 2 854 CALL obs_prof_staend( velodata(jveloset), jvar ) 855 END DO 856 857 CALL obs_pre_vel( velodata(jveloset), veldatqc(jveloset), & 858 & ln_vel3d, ln_nea, ld_velav(jveloset) ) 859 860 ENDIF 861 862 ! High frequency data 863 864 IF ( ln_velhrcur ) THEN 865 866 jveloset = jveloset + 1 867 868 ld_velav(jveloset) = .FALSE. 869 870 CALL obs_rea_vel_dri( 1, velodata(jveloset), jnumvelhrcur, & 871 & velhrcurfiles(1:jnumvelhrcur), & 872 & nvelovars, nveloextr, & 873 & nitend-nit000+2, & 874 & dobsini, dobsend, ln_ignmis, & 875 & ld_velav(jveloset), & 876 & .FALSE. ) 877 878 DO jvar = 1, 2 879 CALL obs_prof_staend( velodata(jveloset), jvar ) 880 END DO 881 882 CALL obs_pre_vel( velodata(jveloset), veldatqc(jveloset), & 883 & ln_vel3d, ln_nea, ld_velav(jveloset) ) 884 885 ENDIF 886 887 ! Daily averaged data 888 889 IF ( ln_velavadcp ) THEN 890 891 jveloset = jveloset + 1 892 893 ld_velav(jveloset) = .TRUE. 894 895 CALL obs_rea_vel_dri( 1, velodata(jveloset), jnumvelavadcp, & 896 & velavadcpfiles(1:jnumvelavadcp), & 897 & nvelovars, nveloextr, & 898 & nitend-nit000+2, & 899 & dobsini, dobsend, ln_ignmis, & 900 & ld_velav(jveloset), & 901 & .FALSE. ) 902 903 DO jvar = 1, 2 904 CALL obs_prof_staend( velodata(jveloset), jvar ) 905 END DO 906 907 CALL obs_pre_vel( velodata(jveloset), veldatqc(jveloset), & 908 & ln_vel3d, ln_nea, ld_velav(jveloset) ) 909 910 ENDIF 911 912 ! High frequency data 913 914 IF ( ln_velhradcp ) THEN 915 916 jveloset = jveloset + 1 917 918 ld_velav(jveloset) = .FALSE. 919 920 CALL obs_rea_vel_dri( 1, velodata(jveloset), jnumvelhradcp, & 921 & velhradcpfiles(1:jnumvelhradcp), & 922 & nvelovars, nveloextr, & 923 & nitend-nit000+2, & 924 & dobsini, dobsend, ln_ignmis, & 925 & ld_velav(jveloset), & 926 & .FALSE. ) 927 928 DO jvar = 1, 2 929 CALL obs_prof_staend( velodata(jveloset), jvar ) 930 END DO 931 932 CALL obs_pre_vel( velodata(jveloset), veldatqc(jveloset), & 933 & ln_vel3d, ln_nea, ld_velav(jveloset) ) 934 935 ENDIF 936 937 IF ( ln_velfb ) THEN 938 939 DO jset = 1, jnumvelfb 940 941 jveloset = jveloset + 1 942 943 ld_velav(jveloset) = ln_velfb_av(jset) 944 945 CALL obs_rea_vel_dri( 0, velodata(jveloset), 1, & 946 & velfbfiles(jset:jset), & 947 & nvelovars, nveloextr, & 948 & nitend-nit000+2, & 949 & dobsini, dobsend, ln_ignmis, & 950 & ld_velav(jveloset), & 951 & .FALSE. ) 952 953 DO jvar = 1, 2 954 CALL obs_prof_staend( velodata(jveloset), jvar ) 955 END DO 956 957 CALL obs_pre_vel( velodata(jveloset), veldatqc(jveloset), & 958 & ln_vel3d, ln_nea, ld_velav(jveloset) ) 959 960 961 END DO 962 963 ENDIF 964 965 ENDIF 966 578 579 CALL obs_app_sstbias( surfdataqc(jtype), n2dintsurf(jtype), & 580 & jnumsstbias, cn_sstbiasfiles(1:jnumsstbias) ) 581 582 ENDIF 583 584 END DO 585 586 DEALLOCATE( ifilessurf, clsurffiles ) 587 588 ENDIF 589 590 CALL wrk_dealloc( jpi, jpj, zglam1 ) 591 CALL wrk_dealloc( jpi, jpj, zglam2 ) 592 CALL wrk_dealloc( jpi, jpj, zgphi1 ) 593 CALL wrk_dealloc( jpi, jpj, zgphi2 ) 594 CALL wrk_dealloc( jpi, jpj, jpk, zmask1 ) 595 CALL wrk_dealloc( jpi, jpj, jpk, zmask2 ) 596 967 597 END SUBROUTINE dia_obs_init 968 598 … … 974 604 !! 975 605 !! ** Method : Call the observation operators on each time step to 976 !! compute the model equivalent of the following date: 977 !! - T profiles 978 !! - S profiles 979 !! - Sea surface height (referenced to a mean) 980 !! - Sea surface temperature 981 !! - Sea surface salinity 982 !! - Velocity component (U,V) profiles 983 !! 984 !! ** Action : 606 !! compute the model equivalent of the following data: 607 !! - Profile data, currently T/S or U/V 608 !! - Surface data, currently SST, SLA or sea-ice concentration. 609 !! 610 !! ** Action : 985 611 !! 986 612 !! History : … … 991 617 !! ! 07-04 (G. Smith) Generalized surface operators 992 618 !! ! 08-10 (M. Valdivieso) obs operator for velocity profiles 619 !! ! 15-08 (M. Martin) Combined surface/profile routines. 993 620 !!---------------------------------------------------------------------- 994 621 !! * Modules used 995 USE dom_oce, ONLY : & ! Ocean space and time domain variables 996 & rdt, & 997 & gdept_1d, & 998 & tmask, umask, vmask 999 USE phycst, ONLY : & ! Physical constants 1000 & rday 1001 USE oce, ONLY : & ! Ocean dynamics and tracers variables 1002 & tsn, & 1003 & un, vn, & 622 USE phycst, ONLY : & ! Physical constants 623 & rday 624 USE oce, ONLY : & ! Ocean dynamics and tracers variables 625 & tsn, & 626 & un, & 627 & vn, & 1004 628 & sshn 1005 629 #if defined key_lim3 1006 USE ice, ONLY : & ! LIMIce model variables630 USE ice, ONLY : & ! LIM3 Ice model variables 1007 631 & frld 1008 632 #endif 1009 633 #if defined key_lim2 1010 USE ice_2, ONLY : & ! LIMIce model variables634 USE ice_2, ONLY : & ! LIM2 Ice model variables 1011 635 & frld 1012 636 #endif 637 #if defined key_cice 638 USE sbc_oce, ONLY : fr_i ! ice fraction 639 #endif 640 #if defined key_hadocc 641 USE trc, ONLY : & ! HadOCC chlorophyll, fCO2 and pCO2 642 & HADOCC_CHL, & 643 & HADOCC_FCO2, & 644 & HADOCC_PCO2, & 645 & HADOCC_FILL_FLT 646 #elif defined key_medusa && defined key_foam_medusa 647 USE trc, ONLY : & ! MEDUSA chlorophyll, fCO2 and pCO2 648 & MEDUSA_CHL, & 649 & MEDUSA_FCO2, & 650 & MEDUSA_PCO2, & 651 & MEDUSA_FILL_FLT 652 #elif defined key_fabm 653 USE fabm 654 USE par_fabm 655 #endif 656 #if defined key_spm 657 USE par_spm, ONLY: & ! ERSEM/SPM sediments 658 & jp_spm 659 USE trc, ONLY : & 660 & trn 661 #endif 662 1013 663 IMPLICIT NONE 1014 664 1015 665 !! * Arguments 1016 INTEGER, INTENT(IN) :: kstp 666 INTEGER, INTENT(IN) :: kstp ! Current timestep 1017 667 !! * Local declarations 1018 INTEGER :: idaystp ! Number of timesteps per day 1019 INTEGER :: jprofset ! Profile data set loop variable 1020 INTEGER :: jslaset ! SLA data set loop variable 1021 INTEGER :: jsstset ! SST data set loop variable 1022 INTEGER :: jseaiceset ! sea ice data set loop variable 1023 INTEGER :: jveloset ! velocity profile data loop variable 1024 INTEGER :: jvar ! Variable number 1025 #if ! defined key_lim2 && ! defined key_lim3 1026 REAL(wp), POINTER, DIMENSION(:,:) :: frld 1027 #endif 1028 CHARACTER(LEN=20) :: datestr=" ",timestr=" " 1029 1030 #if ! defined key_lim2 && ! defined key_lim3 1031 CALL wrk_alloc(jpi,jpj,frld) 1032 #endif 668 INTEGER :: idaystp ! Number of timesteps per day 669 INTEGER :: jtype ! Data loop variable 670 INTEGER :: jvar ! Variable number 671 INTEGER :: ji, jj ! Loop counters 672 REAL(wp) :: tiny ! small number 673 REAL(wp), POINTER, DIMENSION(:,:,:) :: & 674 & zprofvar1, & ! Model values for 1st variable in a prof ob 675 & zprofvar2 ! Model values for 2nd variable in a prof ob 676 REAL(wp), POINTER, DIMENSION(:,:,:) :: & 677 & zprofmask1, & ! Mask associated with zprofvar1 678 & zprofmask2 ! Mask associated with zprofvar2 679 REAL(wp), POINTER, DIMENSION(:,:) :: & 680 & zsurfvar, & ! Model values equivalent to surface ob. 681 & zsurfmask ! Mask associated with surface variable 682 REAL(wp), POINTER, DIMENSION(:,:) :: & 683 & zglam1, & ! Model longitudes for prof variable 1 684 & zglam2, & ! Model longitudes for prof variable 2 685 & zgphi1, & ! Model latitudes for prof variable 1 686 & zgphi2 ! Model latitudes for prof variable 2 687 688 689 !Allocate local work arrays 690 CALL wrk_alloc( jpi, jpj, jpk, zprofvar1 ) 691 CALL wrk_alloc( jpi, jpj, jpk, zprofvar2 ) 692 CALL wrk_alloc( jpi, jpj, jpk, zprofmask1 ) 693 CALL wrk_alloc( jpi, jpj, jpk, zprofmask2 ) 694 CALL wrk_alloc( jpi, jpj, zsurfvar ) 695 CALL wrk_alloc( jpi, jpj, zsurfmask ) 696 CALL wrk_alloc( jpi, jpj, zglam1 ) 697 CALL wrk_alloc( jpi, jpj, zglam2 ) 698 CALL wrk_alloc( jpi, jpj, zgphi1 ) 699 CALL wrk_alloc( jpi, jpj, zgphi2 ) 1033 700 1034 701 IF(lwp) THEN … … 1036 703 WRITE(numout,*) 'dia_obs : Call the observation operators', kstp 1037 704 WRITE(numout,*) '~~~~~~~' 705 CALL FLUSH(numout) 1038 706 ENDIF 1039 707 … … 1041 709 1042 710 !----------------------------------------------------------------------- 1043 ! No LIM => frld == 0.0_wp 1044 !----------------------------------------------------------------------- 1045 #if ! defined key_lim2 && ! defined key_lim3 1046 frld(:,:) = 0.0_wp 711 ! Call the profile and surface observation operators 712 !----------------------------------------------------------------------- 713 714 IF ( nproftypes > 0 ) THEN 715 716 DO jtype = 1, nproftypes 717 718 SELECT CASE ( TRIM(cobstypesprof(jtype)) ) 719 CASE('prof') 720 zprofvar1(:,:,:) = tsn(:,:,:,jp_tem) 721 zprofvar2(:,:,:) = tsn(:,:,:,jp_sal) 722 zprofmask1(:,:,:) = tmask(:,:,:) 723 zprofmask2(:,:,:) = tmask(:,:,:) 724 zglam1(:,:) = glamt(:,:) 725 zglam2(:,:) = glamt(:,:) 726 zgphi1(:,:) = gphit(:,:) 727 zgphi2(:,:) = gphit(:,:) 728 CASE('vel') 729 zprofvar1(:,:,:) = un(:,:,:) 730 zprofvar2(:,:,:) = vn(:,:,:) 731 zprofmask1(:,:,:) = umask(:,:,:) 732 zprofmask2(:,:,:) = vmask(:,:,:) 733 zglam1(:,:) = glamu(:,:) 734 zglam2(:,:) = glamv(:,:) 735 zgphi1(:,:) = gphiu(:,:) 736 zgphi2(:,:) = gphiv(:,:) 737 CASE DEFAULT 738 CALL ctl_stop( 'Unknown profile observation type '//TRIM(cobstypesprof(jtype))//' in dia_obs' ) 739 END SELECT 740 741 CALL obs_prof_opt( profdataqc(jtype), kstp, jpi, jpj, jpk, & 742 & nit000, idaystp, & 743 & zprofvar1, zprofvar2, & 744 & fsdept(:,:,:), fsdepw(:,:,:), & 745 & zprofmask1, zprofmask2, & 746 & zglam1, zglam2, zgphi1, zgphi2, & 747 & nn_1dint, nn_2dint, & 748 & kdailyavtypes = nn_profdavtypes ) 749 750 END DO 751 752 ENDIF 753 754 IF ( nsurftypes > 0 ) THEN 755 756 DO jtype = 1, nsurftypes 757 758 !Defaults which might be changed 759 zsurfmask(:,:) = tmask(:,:,1) 760 761 SELECT CASE ( TRIM(cobstypessurf(jtype)) ) 762 CASE('sst') 763 zsurfvar(:,:) = tsn(:,:,1,jp_tem) 764 CASE('sla') 765 zsurfvar(:,:) = sshn(:,:) 766 CASE('sss') 767 zsurfvar(:,:) = tsn(:,:,1,jp_sal) 768 CASE('sic') 769 IF ( kstp == 0 ) THEN 770 IF ( lwp .AND. surfdataqc(jtype)%nsstpmpp(1) > 0 ) THEN 771 CALL ctl_warn( 'Sea-ice not initialised on zeroth '// & 772 & 'time-step but some obs are valid then.' ) 773 WRITE(numout,*)surfdataqc(jtype)%nsstpmpp(1), & 774 & ' sea-ice obs will be missed' 775 ENDIF 776 surfdataqc(jtype)%nsurfup = surfdataqc(jtype)%nsurfup + & 777 & surfdataqc(jtype)%nsstp(1) 778 CYCLE 779 ELSE 780 #if defined key_cice 781 zsurfvar(:,:) = fr_i(:,:) 782 #elif defined key_lim2 || defined key_lim3 783 zsurfvar(:,:) = 1._wp - frld(:,:) 784 #else 785 CALL ctl_stop( ' Trying to run sea-ice observation operator', & 786 & ' but no sea-ice model appears to have been defined' ) 1047 787 #endif 1048 !----------------------------------------------------------------------- 1049 ! Depending on switches call various observation operators 1050 !----------------------------------------------------------------------- 1051 1052 ! - Temperature/salinity profiles 1053 IF ( ln_t3d .OR. ln_s3d ) THEN 1054 DO jprofset = 1, nprofsets 1055 IF ( ld_enact(jprofset) ) THEN 1056 CALL obs_pro_opt( prodatqc(jprofset), & 1057 & kstp, jpi, jpj, jpk, nit000, idaystp, & 1058 & tsn(:,:,:,jp_tem), tsn(:,:,:,jp_sal), & 1059 & gdept_1d, tmask, n1dint, n2dint, & 1060 & kdailyavtypes = endailyavtypes ) 1061 ELSE 1062 CALL obs_pro_opt( prodatqc(jprofset), & 1063 & kstp, jpi, jpj, jpk, nit000, idaystp, & 1064 & tsn(:,:,:,jp_tem), tsn(:,:,:,jp_sal), & 1065 & gdept_1d, tmask, n1dint, n2dint ) 1066 ENDIF 788 ENDIF 789 790 CASE('logchl') 791 #if defined key_hadocc 792 zsurfvar(:,:) = HADOCC_CHL(:,:,1) ! (not log) chlorophyll from HadOCC 793 #elif defined key_medusa && defined key_foam_medusa 794 zsurfvar(:,:) = MEDUSA_CHL(:,:,1) ! (not log) chlorophyll from HadOCC 795 #elif defined key_fabm 796 chl_3d(:,:,:) = fabm_get_bulk_diagnostic_data(model, jp_fabmdia_chltot) 797 zsurfvar(:,:) = chl_3d(:,:,1) 798 #else 799 CALL ctl_stop( ' Trying to run logchl observation operator', & 800 & ' but no biogeochemical model appears to have been defined' ) 801 #endif 802 zsurfmask(:,:) = tmask(:,:,1) ! create a special mask to exclude certain things 803 ! Take the log10 where we can, otherwise exclude 804 tiny = 1.0e-20 805 WHERE(zsurfvar(:,:) > tiny .AND. zsurfvar(:,:) /= obfillflt ) 806 zsurfvar(:,:) = LOG10(zsurfvar(:,:)) 807 ELSEWHERE 808 zsurfvar(:,:) = obfillflt 809 zsurfmask(:,:) = 0 810 END WHERE 811 CASE('spm') 812 #if defined key_spm 813 zsurfvar(:,:) = 0.0 814 DO jn = 1, jp_spm 815 zsurfvar(:,:) = zsurfvar(:,:) + trn(:,:,1,jn) ! sum SPM sizes 816 END DO 817 #else 818 CALL ctl_stop( ' Trying to run spm observation operator', & 819 & ' but no spm model appears to have been defined' ) 820 #endif 821 CASE('fco2') 822 #if defined key_hadocc 823 zsurfvar(:,:) = HADOCC_FCO2(:,:) ! fCO2 from HadOCC 824 IF ( ( MINVAL( HADOCC_FCO2 ) == HADOCC_FILL_FLT ) .AND. & 825 & ( MAXVAL( HADOCC_FCO2 ) == HADOCC_FILL_FLT ) ) THEN 826 zsurfvar(:,:) = obfillflt 827 zsurfmask(:,:) = 0 828 CALL ctl_warn( ' HadOCC fCO2 values masked out for observation operator', & 829 & ' on timestep ' // TRIM(STR(kstp)), & 830 & ' as HADOCC_FCO2(:,:) == HADOCC_FILL_FLT' ) 831 ENDIF 832 #elif defined key_medusa && defined key_foam_medusa 833 zsurfmask(:,:) = MEDUSA_FCO2(:,:) ! fCO2 from MEDUSA 834 IF ( ( MINVAL( MEDUSA_FCO2 ) == MEDUSA_FILL_FLT ) .AND. & 835 & ( MAXVAL( MEDUSA_FCO2 ) == MEDUSA_FILL_FLT ) ) THEN 836 zsurfvar(:,:) = obfillflt 837 zsurfmask(:,:) = 0 838 CALL ctl_warn( ' MEDUSA fCO2 values masked out for observation operator', & 839 & ' on timestep ' // TRIM(STR(kstp)), & 840 & ' as MEDUSA_FCO2(:,:) == MEDUSA_FILL_FLT' ) 841 ENDIF 842 #elif defined key_fabm 843 ! First, get pCO2 from FABM 844 pco2_3d(:,:,:) = fabm_get_bulk_diagnostic_data(model, jp_fabm_o3pc) 845 zsurfvar(:,:) = pco2_3d(:,:,1) 846 ! Now, convert pCO2 to fCO2, based on SST in K. This follows the standard methodology of: 847 ! Pierrot et al. (2009), Recommendations for autonomous underway pCO2 measuring systems 848 ! and data reduction routines, Deep-Sea Research II, 56: 512-522. 849 ! and 850 ! Weiss (1974), Carbon dioxide in water and seawater: the solubility of a non-ideal gas, 851 ! Marine Chemistry, 2: 203-215. 852 ! In the implementation below, atmospheric pressure has been assumed to be 1 atm and so 853 ! not explicitly included - atmospheric pressure is not necessarily available so this is 854 ! the best assumption. 855 ! Further, the (1-xCO2)^2 term has been neglected. This is common practice 856 ! (see e.g. Zeebe and Wolf-Gladrow (2001), CO2 in Seawater: Equilibrium, Kinetics, Isotopes) 857 ! because xCO2 in atm is ~0, and so this term will only affect the result to the 3rd decimal 858 ! place for typical values, and xCO2 would need to be approximated from pCO2 anyway. 859 zsurfvar(:,:) = zsurfvar(:,:) * EXP((-1636.75 + & 860 & 12.0408 * (tsn(:,:,1,jp_tem)+rt0) - & 861 & 0.0327957 * (tsn(:,:,1,jp_tem)+rt0)*(tsn(:,:,1,jp_tem)+rt0) + & 862 & 0.0000316528 * (tsn(:,:,1,jp_tem)+rt0)*(tsn(:,:,1,jp_tem)+rt0)*(tsn(:,:,1,jp_tem)+rt0) + & 863 & 2.0 * (57.7 - 0.118 * (tsn(:,:,1,jp_tem)+rt0))) / & 864 & (82.0578 * (tsn(:,:,1,jp_tem)+rt0))) 865 #else 866 CALL ctl_stop( ' Trying to run fco2 observation operator', & 867 & ' but no biogeochemical model appears to have been defined' ) 868 #endif 869 CASE('pco2') 870 #if defined key_hadocc 871 zsurfvar(:,:) = HADOCC_PCO2(:,:) ! pCO2 from HadOCC 872 IF ( ( MINVAL( HADOCC_PCO2 ) == HADOCC_FILL_FLT ) .AND. & 873 & ( MAXVAL( HADOCC_PCO2 ) == HADOCC_FILL_FLT ) ) THEN 874 zsurfvar(:,:) = obfillflt 875 zsurfmask(:,:) = 0 876 CALL ctl_warn( ' HadOCC pCO2 values masked out for observation operator', & 877 & ' on timestep ' // TRIM(STR(kstp)), & 878 & ' as HADOCC_PCO2(:,:) == HADOCC_FILL_FLT' ) 879 ENDIF 880 #elif defined key_medusa && defined key_foam_medusa 881 zsurfvar(:,:) = MEDUSA_PCO2(:,:) ! pCO2 from MEDUSA 882 IF ( ( MINVAL( MEDUSA_PCO2 ) == MEDUSA_FILL_FLT ) .AND. & 883 & ( MAXVAL( MEDUSA_PCO2 ) == MEDUSA_FILL_FLT ) ) THEN 884 zsurfvar(:,:) = obfillflt 885 zsurfmask(:,:) = 0 886 CALL ctl_warn( ' MEDUSA pCO2 values masked out for observation operator', & 887 & ' on timestep ' // TRIM(STR(kstp)), & 888 & ' as MEDUSA_PCO2(:,:) == MEDUSA_FILL_FLT' ) 889 ENDIF 890 #elif defined key_fabm 891 pco2_3d(:,:,:) = fabm_get_bulk_diagnostic_data(model, jp_fabm_o3pc) 892 zsurfvar(:,:) = pco2_3d(:,:,1) 893 #else 894 CALL ctl_stop( ' Trying to run pCO2 observation operator', & 895 & ' but no biogeochemical model appears to have been defined' ) 896 #endif 897 898 CASE DEFAULT 899 900 CALL ctl_stop( 'Unknown surface observation type '//TRIM(cobstypessurf(jtype))//' in dia_obs' ) 901 902 END SELECT 903 904 CALL obs_surf_opt( surfdataqc(jtype), kstp, jpi, jpj, & 905 & nit000, idaystp, zsurfvar, zsurfmask, & 906 & n2dintsurf(jtype), llnightav(jtype), & 907 & ravglamscl(jtype), ravgphiscl(jtype), & 908 & lfpindegs(jtype) ) 909 1067 910 END DO 1068 ENDIF 1069 1070 ! - Sea surface anomaly 1071 IF ( ln_sla ) THEN 1072 DO jslaset = 1, nslasets 1073 CALL obs_sla_opt( sladatqc(jslaset), & 1074 & kstp, jpi, jpj, nit000, sshn, & 1075 & tmask(:,:,1), n2dint ) 1076 END DO 1077 ENDIF 1078 1079 ! - Sea surface temperature 1080 IF ( ln_sst ) THEN 1081 DO jsstset = 1, nsstsets 1082 CALL obs_sst_opt( sstdatqc(jsstset), & 1083 & kstp, jpi, jpj, nit000, idaystp, & 1084 & tsn(:,:,1,jp_tem), tmask(:,:,1), & 1085 & n2dint, ld_sstnight(jsstset) ) 1086 END DO 1087 ENDIF 1088 1089 ! - Sea surface salinity 1090 IF ( ln_sss ) THEN 1091 IF(lwp) WRITE(numout,*) ' SSS currently not available' 1092 ENDIF 1093 1094 #if defined key_lim2 || defined key_lim3 1095 IF ( ln_seaice ) THEN 1096 DO jseaiceset = 1, nseaicesets 1097 CALL obs_seaice_opt( seaicedatqc(jseaiceset), & 1098 & kstp, jpi, jpj, nit000, 1.-frld, & 1099 & tmask(:,:,1), n2dint ) 1100 END DO 1101 ENDIF 1102 #endif 1103 1104 ! - Velocity profiles 1105 IF ( ln_vel3d ) THEN 1106 DO jveloset = 1, nvelosets 1107 ! zonal component of velocity 1108 CALL obs_vel_opt( veldatqc(jveloset), kstp, jpi, jpj, jpk, & 1109 & nit000, idaystp, un, vn, gdept_1d, umask, vmask, & 1110 n1dint, n2dint, ld_velav(jveloset) ) 1111 END DO 1112 ENDIF 1113 1114 #if ! defined key_lim2 && ! defined key_lim3 1115 CALL wrk_dealloc(jpi,jpj,frld) 1116 #endif 911 912 ENDIF 913 914 CALL wrk_dealloc( jpi, jpj, jpk, zprofvar1 ) 915 CALL wrk_dealloc( jpi, jpj, jpk, zprofvar2 ) 916 CALL wrk_dealloc( jpi, jpj, jpk, zprofmask1 ) 917 CALL wrk_dealloc( jpi, jpj, jpk, zprofmask2 ) 918 CALL wrk_dealloc( jpi, jpj, zsurfvar ) 919 CALL wrk_dealloc( jpi, jpj, zsurfmask ) 920 CALL wrk_dealloc( jpi, jpj, zglam1 ) 921 CALL wrk_dealloc( jpi, jpj, zglam2 ) 922 CALL wrk_dealloc( jpi, jpj, zgphi1 ) 923 CALL wrk_dealloc( jpi, jpj, zgphi2 ) 1117 924 1118 925 END SUBROUTINE dia_obs 1119 1120 SUBROUTINE dia_obs_wri 926 927 SUBROUTINE dia_obs_wri 1121 928 !!---------------------------------------------------------------------- 1122 929 !! *** ROUTINE dia_obs_wri *** … … 1126 933 !! ** Method : Call observation diagnostic output routines 1127 934 !! 1128 !! ** Action : 935 !! ** Action : 1129 936 !! 1130 937 !! History : … … 1134 941 !! ! 07-03 (K. Mogensen) General handling of profiles 1135 942 !! ! 08-09 (M. Valdivieso) Velocity component (U,V) profiles 943 !! ! 15-08 (M. Martin) Combined writing for prof and surf types 1136 944 !!---------------------------------------------------------------------- 945 !! * Modules used 946 USE obs_rot_vel ! Rotation of velocities 947 1137 948 IMPLICIT NONE 1138 949 1139 950 !! * Local declarations 1140 1141 INTEGER :: jprofset ! Profile data set loop variable 1142 INTEGER :: jveloset ! Velocity data set loop variable 1143 INTEGER :: jslaset ! SLA data set loop variable 1144 INTEGER :: jsstset ! SST data set loop variable 1145 INTEGER :: jseaiceset ! Sea Ice data set loop variable 1146 INTEGER :: jset 1147 INTEGER :: jfbini 1148 CHARACTER(LEN=20) :: datestr=" ",timestr=" " 1149 CHARACTER(LEN=10) :: cdtmp 951 INTEGER :: jtype ! Data set loop variable 952 INTEGER :: jo, jvar, jk 953 REAL(wp), DIMENSION(:), ALLOCATABLE :: & 954 & zu, & 955 & zv 956 1150 957 !----------------------------------------------------------------------- 1151 958 ! Depending on switches call various observation output routines 1152 959 !----------------------------------------------------------------------- 1153 960 1154 ! - Temperature/salinity profiles 1155 1156 IF( ln_t3d .OR. ln_s3d ) THEN 1157 1158 ! Copy data from prodatqc to profdata structures 1159 DO jprofset = 1, nprofsets 1160 1161 CALL obs_prof_decompress( prodatqc(jprofset), & 1162 & profdata(jprofset), .TRUE., numout ) 961 IF ( nproftypes > 0 ) THEN 962 963 DO jtype = 1, nproftypes 964 965 IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN 966 967 ! For velocity data, rotate the model velocities to N/S, E/W 968 ! using the compressed data structure. 969 ALLOCATE( & 970 & zu(profdataqc(jtype)%nvprot(1)), & 971 & zv(profdataqc(jtype)%nvprot(2)) & 972 & ) 973 974 CALL obs_rotvel( profdataqc(jtype), nn_2dint, zu, zv ) 975 976 DO jo = 1, profdataqc(jtype)%nprof 977 DO jvar = 1, 2 978 DO jk = profdataqc(jtype)%npvsta(jo,jvar), profdataqc(jtype)%npvend(jo,jvar) 979 980 IF ( jvar == 1 ) THEN 981 profdataqc(jtype)%var(jvar)%vmod(jk) = zu(jk) 982 ELSE 983 profdataqc(jtype)%var(jvar)%vmod(jk) = zv(jk) 984 ENDIF 985 986 END DO 987 END DO 988 END DO 989 990 DEALLOCATE( zu ) 991 DEALLOCATE( zv ) 992 993 END IF 994 995 CALL obs_prof_decompress( profdataqc(jtype), & 996 & profdata(jtype), .TRUE., numout ) 997 998 CALL obs_wri_prof( profdata(jtype) ) 1163 999 1164 1000 END DO 1165 1001 1166 ! Write the profiles. 1167 1168 jprofset = 0 1169 1170 ! ENACT insitu data 1171 1172 IF ( ln_ena ) THEN 1173 1174 jprofset = jprofset + 1 1175 1176 CALL obs_wri_p3d( 'enact', profdata(jprofset) ) 1177 1178 ENDIF 1179 1180 ! Coriolis insitu data 1181 1182 IF ( ln_cor ) THEN 1183 1184 jprofset = jprofset + 1 1185 1186 CALL obs_wri_p3d( 'corio', profdata(jprofset) ) 1187 1188 ENDIF 1189 1190 ! Feedback insitu data 1191 1192 IF ( ln_profb ) THEN 1193 1194 jfbini = jprofset + 1 1195 1196 DO jprofset = jfbini, nprofsets 1197 1198 jset = jprofset - jfbini + 1 1199 WRITE(cdtmp,'(A,I2.2)')'profb_',jset 1200 CALL obs_wri_p3d( cdtmp, profdata(jprofset) ) 1201 1202 END DO 1203 1204 ENDIF 1205 1206 ENDIF 1207 1208 ! - Sea surface anomaly 1209 IF ( ln_sla ) THEN 1210 1211 ! Copy data from sladatqc to sladata structures 1212 DO jslaset = 1, nslasets 1213 1214 CALL obs_surf_decompress( sladatqc(jslaset), & 1215 & sladata(jslaset), .TRUE., numout ) 1002 ENDIF 1003 1004 IF ( nsurftypes > 0 ) THEN 1005 1006 DO jtype = 1, nsurftypes 1007 1008 CALL obs_surf_decompress( surfdataqc(jtype), & 1009 & surfdata(jtype), .TRUE., numout ) 1010 1011 CALL obs_wri_surf( surfdata(jtype) ) 1216 1012 1217 1013 END DO 1218 1014 1219 jslaset = 01220 1221 ! Write the AVISO SLA data1222 1223 IF ( ln_sladt ) THEN1224 1225 jslaset = 11226 CALL obs_wri_sla( 'aviso_act', sladata(jslaset) )1227 jslaset = 21228 CALL obs_wri_sla( 'aviso_pas', sladata(jslaset) )1229 1230 ENDIF1231 1232 IF ( ln_slafb ) THEN1233 1234 jfbini = jslaset + 11235 1236 DO jslaset = jfbini, nslasets1237 1238 jset = jslaset - jfbini + 11239 WRITE(cdtmp,'(A,I2.2)')'slafb_',jset1240 CALL obs_wri_sla( cdtmp, sladata(jslaset) )1241 1242 END DO1243 1244 ENDIF1245 1246 ENDIF1247 1248 ! - Sea surface temperature1249 IF ( ln_sst ) THEN1250 1251 ! Copy data from sstdatqc to sstdata structures1252 DO jsstset = 1, nsstsets1253 1254 CALL obs_surf_decompress( sstdatqc(jsstset), &1255 & sstdata(jsstset), .TRUE., numout )1256 1257 END DO1258 1259 jsstset = 01260 1261 ! Write the AVISO SST data1262 1263 IF ( ln_reysst ) THEN1264 1265 jsstset = jsstset + 11266 CALL obs_wri_sst( 'reynolds', sstdata(jsstset) )1267 1268 ENDIF1269 1270 IF ( ln_ghrsst ) THEN1271 1272 jsstset = jsstset + 11273 CALL obs_wri_sst( 'ghr', sstdata(jsstset) )1274 1275 ENDIF1276 1277 IF ( ln_sstfb ) THEN1278 1279 jfbini = jsstset + 11280 1281 DO jsstset = jfbini, nsstsets1282 1283 jset = jsstset - jfbini + 11284 WRITE(cdtmp,'(A,I2.2)')'sstfb_',jset1285 CALL obs_wri_sst( cdtmp, sstdata(jsstset) )1286 1287 END DO1288 1289 ENDIF1290 1291 ENDIF1292 1293 ! - Sea surface salinity1294 IF ( ln_sss ) THEN1295 IF(lwp) WRITE(numout,*) ' SSS currently not available'1296 ENDIF1297 1298 ! - Sea Ice Concentration1299 IF ( ln_seaice ) THEN1300 1301 ! Copy data from seaicedatqc to seaicedata structures1302 DO jseaiceset = 1, nseaicesets1303 1304 CALL obs_surf_decompress( seaicedatqc(jseaiceset), &1305 & seaicedata(jseaiceset), .TRUE., numout )1306 1307 END DO1308 1309 ! Write the Sea Ice data1310 DO jseaiceset = 1, nseaicesets1311 1312 WRITE(cdtmp,'(A,I2.2)')'seaicefb_',jseaiceset1313 CALL obs_wri_seaice( cdtmp, seaicedata(jseaiceset) )1314 1315 END DO1316 1317 ENDIF1318 1319 ! Velocity data1320 IF( ln_vel3d ) THEN1321 1322 ! Copy data from veldatqc to velodata structures1323 DO jveloset = 1, nvelosets1324 1325 CALL obs_prof_decompress( veldatqc(jveloset), &1326 & velodata(jveloset), .TRUE., numout )1327 1328 END DO1329 1330 ! Write the profiles.1331 1332 jveloset = 01333 1334 ! Daily averaged data1335 1336 IF ( ln_velavcur ) THEN1337 1338 jveloset = jveloset + 11339 1340 CALL obs_wri_vel( 'velavcurr', velodata(jveloset), n2dint )1341 1342 ENDIF1343 1344 ! High frequency data1345 1346 IF ( ln_velhrcur ) THEN1347 1348 jveloset = jveloset + 11349 1350 CALL obs_wri_vel( 'velhrcurr', velodata(jveloset), n2dint )1351 1352 ENDIF1353 1354 ! Daily averaged data1355 1356 IF ( ln_velavadcp ) THEN1357 1358 jveloset = jveloset + 11359 1360 CALL obs_wri_vel( 'velavadcp', velodata(jveloset), n2dint )1361 1362 ENDIF1363 1364 ! High frequency data1365 1366 IF ( ln_velhradcp ) THEN1367 1368 jveloset = jveloset + 11369 1370 CALL obs_wri_vel( 'velhradcp', velodata(jveloset), n2dint )1371 1372 ENDIF1373 1374 ! Feedback velocity data1375 1376 IF ( ln_velfb ) THEN1377 1378 jfbini = jveloset + 11379 1380 DO jveloset = jfbini, nvelosets1381 1382 jset = jveloset - jfbini + 11383 WRITE(cdtmp,'(A,I2.2)')'velfb_',jset1384 CALL obs_wri_vel( cdtmp, velodata(jveloset), n2dint )1385 1386 END DO1387 1388 ENDIF1389 1390 1015 ENDIF 1391 1016 … … 1405 1030 !! 1406 1031 !!---------------------------------------------------------------------- 1407 ! !obs_grid deallocation1032 ! obs_grid deallocation 1408 1033 CALL obs_grid_deallocate 1409 1034 1410 !! diaobs deallocation 1411 IF ( nprofsets > 0 ) THEN 1412 DEALLOCATE(ld_enact, & 1413 & profdata, & 1414 & prodatqc) 1415 END IF 1416 IF ( ln_sla ) THEN 1417 DEALLOCATE(sladata, & 1418 & sladatqc) 1419 END IF 1420 IF ( ln_seaice ) THEN 1421 DEALLOCATE(sladata, & 1422 & sladatqc) 1423 END IF 1424 IF ( ln_sst ) THEN 1425 DEALLOCATE(sstdata, & 1426 & sstdatqc) 1427 END IF 1428 IF ( ln_vel3d ) THEN 1429 DEALLOCATE(ld_velav, & 1430 & velodata, & 1431 & veldatqc) 1432 END IF 1035 ! diaobs deallocation 1036 IF ( nproftypes > 0 ) & 1037 & DEALLOCATE( cobstypesprof, profdata, profdataqc, nvarsprof, nextrprof ) 1038 1039 IF ( nsurftypes > 0 ) & 1040 & DEALLOCATE( cobstypessurf, surfdata, surfdataqc, nvarssurf, nextrsurf, & 1041 & n2dintsurf, ravglamscl, ravgphiscl, lfpindegs, llnightav ) 1042 1433 1043 END SUBROUTINE dia_obs_dealloc 1434 1044 … … 1436 1046 !!---------------------------------------------------------------------- 1437 1047 !! *** ROUTINE ini_date *** 1438 !! 1439 !! ** Purpose : Get initial dat ain double precision YYYYMMDD.HHMMSS format1440 !! 1441 !! ** Method : Get initial dat ain double precision YYYYMMDD.HHMMSS format1442 !! 1443 !! ** Action : Get initial dat ain double precision YYYYMMDD.HHMMSS format1048 !! 1049 !! ** Purpose : Get initial date in double precision YYYYMMDD.HHMMSS format 1050 !! 1051 !! ** Method : Get initial date in double precision YYYYMMDD.HHMMSS format 1052 !! 1053 !! ** Action : Get initial date in double precision YYYYMMDD.HHMMSS format 1444 1054 !! 1445 1055 !! History : … … 1452 1062 USE phycst, ONLY : & ! Physical constants 1453 1063 & rday 1454 ! USE daymod, ONLY : & ! Time variables1455 ! & nmonth_len1456 1064 USE dom_oce, ONLY : & ! Ocean space and time domain variables 1457 1065 & rdt … … 1460 1068 1461 1069 !! * Arguments 1462 REAL( KIND=dp), INTENT(OUT) :: ddobsini! Initial date in YYYYMMDD.HHMMSS1070 REAL(dp), INTENT(OUT) :: ddobsini ! Initial date in YYYYMMDD.HHMMSS 1463 1071 1464 1072 !! * Local declarations … … 1468 1076 INTEGER :: ihou 1469 1077 INTEGER :: imin 1470 INTEGER :: imday 1471 REAL(KIND=wp) :: zdayfrc ! Fraction of day1472 1473 INTEGER, DIMENSION(12) :: imonth_len !: length in days of the months of the current year1474 1475 ! !----------------------------------------------------------------------1476 ! !Initial date initialization (year, month, day, hour, minute)1477 ! !(This assumes that the initial date is for 00z))1478 ! !----------------------------------------------------------------------1078 INTEGER :: imday ! Number of days in month. 1079 INTEGER, DIMENSION(12) :: & 1080 & imonth_len ! Length in days of the months of the current year 1081 REAL(wp) :: zdayfrc ! Fraction of day 1082 1083 !---------------------------------------------------------------------- 1084 ! Initial date initialization (year, month, day, hour, minute) 1085 ! (This assumes that the initial date is for 00z)) 1086 !---------------------------------------------------------------------- 1479 1087 iyea = ndate0 / 10000 1480 1088 imon = ( ndate0 - iyea * 10000 ) / 100 … … 1483 1091 imin = 0 1484 1092 1485 ! !----------------------------------------------------------------------1486 ! !Compute number of days + number of hours + min since initial time1487 ! !----------------------------------------------------------------------1093 !---------------------------------------------------------------------- 1094 ! Compute number of days + number of hours + min since initial time 1095 !---------------------------------------------------------------------- 1488 1096 iday = iday + ( nit000 -1 ) * rdt / rday 1489 1097 zdayfrc = ( nit000 -1 ) * rdt / rday … … 1492 1100 imin = int( (zdayfrc * 24 - ihou) * 60 ) 1493 1101 1494 ! !-----------------------------------------------------------------------1495 ! !Convert number of days (iday) into a real date1496 ! !----------------------------------------------------------------------1102 !----------------------------------------------------------------------- 1103 ! Convert number of days (iday) into a real date 1104 !---------------------------------------------------------------------- 1497 1105 1498 1106 CALL calc_month_len( iyea, imonth_len ) 1499 1107 1500 1108 DO WHILE ( iday > imonth_len(imon) ) 1501 1109 iday = iday - imonth_len(imon) … … 1508 1116 END DO 1509 1117 1510 ! !----------------------------------------------------------------------1511 ! !Convert it into YYYYMMDD.HHMMSS format.1512 ! !----------------------------------------------------------------------1118 !---------------------------------------------------------------------- 1119 ! Convert it into YYYYMMDD.HHMMSS format. 1120 !---------------------------------------------------------------------- 1513 1121 ddobsini = iyea * 10000_dp + imon * 100_dp + & 1514 1122 & iday + ihou * 0.01_dp + imin * 0.0001_dp … … 1520 1128 !!---------------------------------------------------------------------- 1521 1129 !! *** ROUTINE fin_date *** 1522 !! 1523 !! ** Purpose : Get final dat ain double precision YYYYMMDD.HHMMSS format1524 !! 1525 !! ** Method : Get final dat ain double precision YYYYMMDD.HHMMSS format1526 !! 1527 !! ** Action : Get final dat ain double precision YYYYMMDD.HHMMSS format1130 !! 1131 !! ** Purpose : Get final date in double precision YYYYMMDD.HHMMSS format 1132 !! 1133 !! ** Method : Get final date in double precision YYYYMMDD.HHMMSS format 1134 !! 1135 !! ** Action : Get final date in double precision YYYYMMDD.HHMMSS format 1528 1136 !! 1529 1137 !! History : … … 1535 1143 USE phycst, ONLY : & ! Physical constants 1536 1144 & rday 1537 ! USE daymod, ONLY : & ! Time variables1538 ! & nmonth_len1539 1145 USE dom_oce, ONLY : & ! Ocean space and time domain variables 1540 1146 & rdt … … 1543 1149 1544 1150 !! * Arguments 1545 REAL( KIND=dp), INTENT(OUT) :: ddobsfin! Final date in YYYYMMDD.HHMMSS1151 REAL(dp), INTENT(OUT) :: ddobsfin ! Final date in YYYYMMDD.HHMMSS 1546 1152 1547 1153 !! * Local declarations … … 1551 1157 INTEGER :: ihou 1552 1158 INTEGER :: imin 1553 INTEGER :: imday 1554 REAL(KIND=wp) :: zdayfrc ! Fraction of day1555 1556 INTEGER, DIMENSION(12) :: imonth_len !: length in days of the months of the current year1557 1159 INTEGER :: imday ! Number of days in month. 1160 INTEGER, DIMENSION(12) :: & 1161 & imonth_len ! Length in days of the months of the current year 1162 REAL(wp) :: zdayfrc ! Fraction of day 1163 1558 1164 !----------------------------------------------------------------------- 1559 1165 ! Initial date initialization (year, month, day, hour, minute) … … 1565 1171 ihou = 0 1566 1172 imin = 0 1567 1173 1568 1174 !----------------------------------------------------------------------- 1569 1175 ! Compute number of days + number of hours + min since initial time … … 1580 1186 1581 1187 CALL calc_month_len( iyea, imonth_len ) 1582 1188 1583 1189 DO WHILE ( iday > imonth_len(imon) ) 1584 1190 iday = iday - imonth_len(imon) … … 1598 1204 1599 1205 END SUBROUTINE fin_date 1600 1206 1207 SUBROUTINE obs_settypefiles( ntypes, jpmaxnfiles, jtype, ctypein, & 1208 & cfilestype, ifiles, cobstypes, cfiles ) 1209 1210 INTEGER, INTENT(IN) :: ntypes ! Total number of obs types 1211 INTEGER, INTENT(IN) :: jpmaxnfiles ! Maximum number of files allowed for each type 1212 INTEGER, INTENT(IN) :: jtype ! Index of the current type of obs 1213 INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: & 1214 & ifiles ! Out appended number of files for this type 1215 1216 CHARACTER(len=6), INTENT(IN) :: ctypein 1217 CHARACTER(len=128), DIMENSION(jpmaxnfiles), INTENT(IN) :: & 1218 & cfilestype ! In list of files for this obs type 1219 CHARACTER(len=6), DIMENSION(ntypes), INTENT(INOUT) :: & 1220 & cobstypes ! Out appended list of obs types 1221 CHARACTER(len=128), DIMENSION(ntypes, jpmaxnfiles), INTENT(INOUT) :: & 1222 & cfiles ! Out appended list of files for all types 1223 1224 !Local variables 1225 INTEGER :: jfile 1226 1227 cfiles(jtype,:) = cfilestype(:) 1228 cobstypes(jtype) = ctypein 1229 ifiles(jtype) = 0 1230 DO jfile = 1, jpmaxnfiles 1231 IF ( trim(cfiles(jtype,jfile)) /= '' ) & 1232 ifiles(jtype) = ifiles(jtype) + 1 1233 END DO 1234 1235 IF ( ifiles(jtype) == 0 ) THEN 1236 CALL ctl_stop( 'Logical for observation type '//TRIM(ctypein)// & 1237 & ' set to true but no files available to read' ) 1238 ENDIF 1239 1240 IF(lwp) THEN 1241 WRITE(numout,*) ' '//cobstypes(jtype)//' input observation file names:' 1242 DO jfile = 1, ifiles(jtype) 1243 WRITE(numout,*) ' '//TRIM(cfiles(jtype,jfile)) 1244 END DO 1245 ENDIF 1246 1247 END SUBROUTINE obs_settypefiles 1248 1249 SUBROUTINE obs_setinterpopts( ntypes, jtype, ctypein, & 1250 & n2dint_default, n2dint_type, & 1251 & ravglamscl_type, ravgphiscl_type, & 1252 & lfp_indegs_type, lavnight_type, & 1253 & n2dint, ravglamscl, ravgphiscl, & 1254 & lfpindegs, lavnight ) 1255 1256 INTEGER, INTENT(IN) :: ntypes ! Total number of obs types 1257 INTEGER, INTENT(IN) :: jtype ! Index of the current type of obs 1258 INTEGER, INTENT(IN) :: n2dint_default ! Default option for interpolation type 1259 INTEGER, INTENT(IN) :: n2dint_type ! Option for interpolation type 1260 REAL(wp), INTENT(IN) :: & 1261 & ravglamscl_type, & !E/W diameter of obs footprint for this type 1262 & ravgphiscl_type !N/S diameter of obs footprint for this type 1263 LOGICAL, INTENT(IN) :: lfp_indegs_type !T=> footprint in degrees, F=> in metres 1264 LOGICAL, INTENT(IN) :: lavnight_type !T=> obs represent night time average 1265 CHARACTER(len=6), INTENT(IN) :: ctypein 1266 1267 INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: & 1268 & n2dint 1269 REAL(wp), DIMENSION(ntypes), INTENT(INOUT) :: & 1270 & ravglamscl, ravgphiscl 1271 LOGICAL, DIMENSION(ntypes), INTENT(INOUT) :: & 1272 & lfpindegs, lavnight 1273 1274 lavnight(jtype) = lavnight_type 1275 1276 IF ( (n2dint_type >= 1) .AND. (n2dint_type <= 6) ) THEN 1277 n2dint(jtype) = n2dint_type 1278 ELSE 1279 n2dint(jtype) = n2dint_default 1280 ENDIF 1281 1282 ! For averaging observation footprints set options for size of footprint 1283 IF ( (n2dint(jtype) > 4) .AND. (n2dint(jtype) <= 6) ) THEN 1284 IF ( ravglamscl_type > 0._wp ) THEN 1285 ravglamscl(jtype) = ravglamscl_type 1286 ELSE 1287 CALL ctl_stop( 'Incorrect value set for averaging footprint '// & 1288 'scale (ravglamscl) for observation type '//TRIM(ctypein) ) 1289 ENDIF 1290 1291 IF ( ravgphiscl_type > 0._wp ) THEN 1292 ravgphiscl(jtype) = ravgphiscl_type 1293 ELSE 1294 CALL ctl_stop( 'Incorrect value set for averaging footprint '// & 1295 'scale (ravgphiscl) for observation type '//TRIM(ctypein) ) 1296 ENDIF 1297 1298 lfpindegs(jtype) = lfp_indegs_type 1299 1300 ENDIF 1301 1302 ! Write out info 1303 IF(lwp) THEN 1304 IF ( n2dint(jtype) <= 4 ) THEN 1305 WRITE(numout,*) ' '//TRIM(ctypein)// & 1306 & ' model counterparts will be interpolated horizontally' 1307 ELSE IF ( n2dint(jtype) <= 6 ) THEN 1308 WRITE(numout,*) ' '//TRIM(ctypein)// & 1309 & ' model counterparts will be averaged horizontally' 1310 WRITE(numout,*) ' '//' with E/W scale: ',ravglamscl(jtype) 1311 WRITE(numout,*) ' '//' with N/S scale: ',ravgphiscl(jtype) 1312 IF ( lfpindegs(jtype) ) THEN 1313 WRITE(numout,*) ' '//' (in degrees)' 1314 ELSE 1315 WRITE(numout,*) ' '//' (in metres)' 1316 ENDIF 1317 ENDIF 1318 ENDIF 1319 1320 END SUBROUTINE obs_setinterpopts 1321 1601 1322 END MODULE diaobs -
branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_grd_bruteforce.h90
r2358 r7992 325 325 CALL obs_mpp_max_integer( kobsj, kobs ) 326 326 ELSE 327 CALL obs_mpp_find_obs_proc( kproc, kobsi, kobsj,kobs )327 CALL obs_mpp_find_obs_proc( kproc,kobs ) 328 328 ENDIF 329 329 -
branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_grid.F90
r7960 r7992 52 52 53 53 !! Default values 54 REAL, PUBLIC :: grid_search_res = 0.5! Resolution of grid54 REAL, PUBLIC :: rn_gridsearchres = 0.5 ! Resolution of grid 55 55 INTEGER, PRIVATE :: gsearch_nlons_def ! Num of longitudes 56 56 INTEGER, PRIVATE :: gsearch_nlats_def ! Num of latitudes … … 83 83 LOGICAL, PUBLIC :: ln_grid_global ! Use global distribution of observations 84 84 CHARACTER(LEN=44), PUBLIC :: & 85 & grid_search_file ! file name head for grid search lookup85 & cn_gridsearchfile ! file name head for grid search lookup 86 86 87 87 !!---------------------------------------------------------------------- … … 613 613 CALL obs_mpp_max_integer( kobsj, kobs ) 614 614 ELSE 615 CALL obs_mpp_find_obs_proc( kproc, kobs i, kobsj, kobs)615 CALL obs_mpp_find_obs_proc( kproc, kobs ) 616 616 ENDIF 617 617 … … 690 690 691 691 IF(lwp) WRITE(numout,*) 692 IF(lwp) WRITE(numout,*)'Grid search resolution : ', grid_search_res693 694 gsearch_nlons_def = NINT( 360.0_wp / grid_search_res )695 gsearch_nlats_def = NINT( 180.0_wp / grid_search_res )696 gsearch_lonmin_def = -180.0_wp + 0.5_wp * grid_search_res697 gsearch_latmin_def = -90.0_wp + 0.5_wp * grid_search_res698 gsearch_dlon_def = grid_search_res699 gsearch_dlat_def = grid_search_res692 IF(lwp) WRITE(numout,*)'Grid search resolution : ', rn_gridsearchres 693 694 gsearch_nlons_def = NINT( 360.0_wp / rn_gridsearchres ) 695 gsearch_nlats_def = NINT( 180.0_wp / rn_gridsearchres ) 696 gsearch_lonmin_def = -180.0_wp + 0.5_wp * rn_gridsearchres 697 gsearch_latmin_def = -90.0_wp + 0.5_wp * rn_gridsearchres 698 gsearch_dlon_def = rn_gridsearchres 699 gsearch_dlat_def = rn_gridsearchres 700 700 701 701 IF (lwp) THEN … … 710 710 IF ( ln_grid_global ) THEN 711 711 WRITE(cfname, FMT="(A,'_',A)") & 712 & TRIM( grid_search_file), 'global.nc'712 & TRIM(cn_gridsearchfile), 'global.nc' 713 713 ELSE 714 714 WRITE(cfname, FMT="(A,'_',I4.4,'of',I4.4,'by',I4.4,'.nc')") & 715 & TRIM( grid_search_file), nproc, jpni, jpnj715 & TRIM(cn_gridsearchfile), nproc, jpni, jpnj 716 716 ENDIF 717 717 -
branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_inter_sup.F90
r7960 r7992 35 35 CONTAINS 36 36 37 SUBROUTINE obs_int_comm_3d( kptsi, kptsj, kobs, kp k, kgrdi, kgrdj, &37 SUBROUTINE obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & 38 38 & pval, pgval, kproc ) 39 39 !!---------------------------------------------------------------------- … … 57 57 INTEGER, INTENT(IN) :: kptsj ! Number of j horizontal points per stencil 58 58 INTEGER, INTENT(IN) :: kobs ! Local number of observations 59 INTEGER, INTENT(IN) :: kpi ! Number of points in i direction 60 INTEGER, INTENT(IN) :: kpj ! Number of points in j direction 59 61 INTEGER, INTENT(IN) :: kpk ! Number of levels 60 62 INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & … … 63 65 INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 64 66 & kproc ! Precomputed processor for each i,j,iobs points 65 REAL(KIND=wp), DIMENSION( jpi,jpj,kpk), INTENT(IN) ::&67 REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::& 66 68 & pval ! Local 3D array to extract data from 67 69 REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& … … 73 75 IF (PRESENT(kproc)) THEN 74 76 75 CALL obs_int_comm_3d_global( kptsi, kptsj, kobs, kp k, kgrdi, &77 CALL obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, & 76 78 & kgrdj, pval, pgval, kproc=kproc ) 77 79 78 80 ELSE 79 81 80 CALL obs_int_comm_3d_global( kptsi, kptsj, kobs, kp k, kgrdi, &82 CALL obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, & 81 83 & kgrdj, pval, pgval ) 82 84 … … 85 87 ELSE 86 88 87 CALL obs_int_comm_3d_local( kptsi, kptsj, kobs, kp k, kgrdi, kgrdj, &89 CALL obs_int_comm_3d_local( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & 88 90 & pval, pgval ) 89 91 … … 92 94 END SUBROUTINE obs_int_comm_3d 93 95 94 SUBROUTINE obs_int_comm_2d( kptsi, kptsj, kobs, k grdi, kgrdj, pval, pgval, &96 SUBROUTINE obs_int_comm_2d( kptsi, kptsj, kobs, kpi, kpj, kgrdi, kgrdj, pval, pgval, & 95 97 & kproc ) 96 98 !!---------------------------------------------------------------------- … … 111 113 INTEGER, INTENT(IN) :: kptsj ! Number of j horizontal points per stencil 112 114 INTEGER, INTENT(IN) :: kobs ! Local number of observations 115 INTEGER, INTENT(IN) :: kpi ! Number of model grid points in i direction 116 INTEGER, INTENT(IN) :: kpj ! Number of model grid points in j direction 113 117 INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 114 118 & kgrdi, & ! i,j indicies for each stencil … … 116 120 INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 117 121 & kproc ! Precomputed processor for each i,j,iobs points 118 REAL(KIND=wp), DIMENSION( jpi,jpj), INTENT(IN) ::&122 REAL(KIND=wp), DIMENSION(kpi,kpj), INTENT(IN) ::& 119 123 & pval ! Local 3D array to extra data from 120 124 REAL(KIND=wp), DIMENSION(kptsi,kptsj,kobs), INTENT(OUT) ::& … … 136 140 IF (PRESENT(kproc)) THEN 137 141 138 CALL obs_int_comm_3d( kptsi, kptsj, kobs, 1, kgrdi, kgrdj, zval, &142 CALL obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, 1, kgrdi, kgrdj, zval, & 139 143 & zgval, kproc=kproc ) 140 144 ELSE 141 145 142 CALL obs_int_comm_3d( kptsi, kptsj, kobs, 1, kgrdi, kgrdj, zval, &146 CALL obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, 1, kgrdi, kgrdj, zval, & 143 147 & zgval ) 144 148 … … 154 158 END SUBROUTINE obs_int_comm_2d 155 159 156 SUBROUTINE obs_int_comm_3d_global( kptsi, kptsj, kobs, kp k, kgrdi, kgrdj, &160 SUBROUTINE obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & 157 161 & pval, pgval, kproc ) 158 162 !!---------------------------------------------------------------------- … … 174 178 INTEGER, INTENT(IN) :: kptsj ! Number of j horizontal points per stencil 175 179 INTEGER, INTENT(IN) :: kobs ! Local number of observations 180 INTEGER, INTENT(IN) :: kpi ! Number of model points in i direction 181 INTEGER, INTENT(IN) :: kpj ! Number of model points in j direction 176 182 INTEGER, INTENT(IN) :: kpk ! Number of levels 177 183 INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & … … 180 186 INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 181 187 & kproc ! Precomputed processor for each i,j,iobs points 182 REAL(KIND=wp), DIMENSION( jpi,jpj,kpk), INTENT(IN) ::&188 REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::& 183 189 & pval ! Local 3D array to extract data from 184 190 REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& … … 207 213 208 214 ! Check valid points 209 215 210 216 IF ( ( MAXVAL(kgrdi) > jpiglo ) .OR. ( MINVAL(kgrdi) < 1 ) .OR. & 211 217 & ( MAXVAL(kgrdj) > jpjglo ) .OR. ( MINVAL(kgrdj) < 1 ) ) THEN 212 218 213 219 CALL ctl_stop( 'Error in obs_int_comm_3d_global', & 214 220 & 'Point outside global domain' ) 215 221 216 222 ENDIF 217 223 … … 323 329 END SUBROUTINE obs_int_comm_3d_global 324 330 325 SUBROUTINE obs_int_comm_3d_local( kptsi, kptsj, kobs, kp k, kgrdi, kgrdj, &331 SUBROUTINE obs_int_comm_3d_local( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & 326 332 & pval, pgval ) 327 333 !!---------------------------------------------------------------------- … … 343 349 INTEGER, INTENT(IN) :: kptsj ! Number of j horizontal points per stencil 344 350 INTEGER, INTENT(IN) :: kobs ! Local number of observations 351 INTEGER, INTENT(IN) :: kpi ! Number of model points in i direction 352 INTEGER, INTENT(IN) :: kpj ! Number of model points in j direction 345 353 INTEGER, INTENT(IN) :: kpk ! Number of levels 346 354 INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 347 355 & kgrdi, & ! i,j indicies for each stencil 348 356 & kgrdj 349 REAL(KIND=wp), DIMENSION( jpi,jpj,kpk), INTENT(IN) ::&357 REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::& 350 358 & pval ! Local 3D array to extract data from 351 359 REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& -
branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_mpp.F90
r7960 r7992 7 7 !! - ! 2006-05 (K. Mogensen) Reformatted 8 8 !! - ! 2008-01 (K. Mogensen) add mpp_global_max 9 !! 3.6 ! 2015-01 (J. Waters) obs_mpp_find_obs_proc 10 !! rewritten to avoid global arrays 9 11 !!---------------------------------------------------------------------- 10 12 # define mpivar mpi_double_precision … … 12 14 !! obs_mpp_bcast_integer : Broadcast an integer array from a processor to all processors 13 15 !! obs_mpp_max_integer : Find maximum on all processors of each value in an integer on all processors 14 !! obs_mpp_find_obs_proc : Find processors which should hold the observations 16 !! obs_mpp_find_obs_proc : Find processors which should hold the observations, avoiding global arrays 15 17 !! obs_mpp_sum_integers : Sum an integer array from all processors 16 18 !! obs_mpp_sum_integer : Sum an integer from all processors … … 96 98 ! 97 99 INTEGER :: ierr 98 INTEGER, DIMENSION(kno) :: ivals 99 ! 100 INCLUDE 'mpif.h' 101 !!---------------------------------------------------------------------- 100 INTEGER, DIMENSION(:), ALLOCATABLE :: ivals 101 ! 102 INCLUDE 'mpif.h' 103 !!---------------------------------------------------------------------- 104 105 ALLOCATE( ivals(kno) ) 102 106 103 107 ! Call the MPI library to find the maximum across processors … … 105 109 & mpi_max, mpi_comm_opa, ierr ) 106 110 kvals(:) = ivals(:) 111 112 DEALLOCATE( ivals ) 107 113 #else 108 114 ! no MPI: empty routine … … 111 117 112 118 113 SUBROUTINE obs_mpp_find_obs_proc( kobsp, kobsi, kobsj,kno )114 !!---------------------------------------------------------------------- 115 !! *** ROUTINE obs_mpp_find_obs_proc ***116 !! 117 !! ** Purpose : From the array kobsp containing the results of the grid119 SUBROUTINE obs_mpp_find_obs_proc( kobsp,kno ) 120 !!---------------------------------------------------------------------- 121 !! *** ROUTINE obs_mpp_find_obs_proc *** 122 !! 123 !! ** Purpose : From the array kobsp containing the results of the 118 124 !! grid search on each processor the processor return a 119 125 !! decision of which processors should hold the observation. 120 126 !! 121 !! ** Method : A temporary 2D array holding all the decisions is122 !! constructed using mpi_allgather on each processor.123 !! If more than one processor has found the observation124 !! with the observation in the inner domain gets it125 !! 126 !! ** Action : This does only work for MPI. 127 !! ** Method : Synchronize the processor number for each obs using 128 !! obs_mpp_max_integer. If an observation exists on two 129 !! processors it will be allocated to the lower numbered 130 !! processor. 131 !! 132 !! ** Action : This does only work for MPI. 127 133 !! It does not work for SHMEM. 128 134 !! … … 130 136 !!---------------------------------------------------------------------- 131 137 INTEGER , INTENT(in ) :: kno 132 INTEGER, DIMENSION(kno), INTENT(in ) :: kobsi, kobsj133 138 INTEGER, DIMENSION(kno), INTENT(inout) :: kobsp 134 139 ! 135 140 #if defined key_mpp_mpi 136 141 ! 137 INTEGER :: ji 138 INTEGER :: jj 139 INTEGER :: size 140 INTEGER :: ierr 141 INTEGER :: iobsip 142 INTEGER :: iobsjp 143 INTEGER :: num_sus_obs 144 INTEGER, DIMENSION(kno) :: iobsig, iobsjg 145 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iobsp, iobsi, iobsj 146 !! 147 INCLUDE 'mpif.h' 148 !!---------------------------------------------------------------------- 149 150 !----------------------------------------------------------------------- 151 ! Call the MPI library to find the maximum accross processors 152 !----------------------------------------------------------------------- 153 CALL mpi_comm_size( mpi_comm_opa, size, ierr ) 154 !----------------------------------------------------------------------- 155 ! Convert local grids points to global grid points 156 !----------------------------------------------------------------------- 142 ! 143 INTEGER :: ji, isum 144 INTEGER, DIMENSION(:), ALLOCATABLE :: iobsp 145 !! 146 !! 147 148 ALLOCATE( iobsp(kno) ) 149 150 iobsp(:)=kobsp(:) 151 152 WHERE( iobsp(:) == -1 ) 153 iobsp(:) = 9999999 154 END WHERE 155 156 iobsp(:)=-1*iobsp(:) 157 158 CALL obs_mpp_max_integer( iobsp, kno ) 159 160 kobsp(:)=-1*iobsp(:) 161 162 isum=0 157 163 DO ji = 1, kno 158 IF ( ( kobsi(ji) >= 1 ) .AND. ( kobsi(ji) <= jpi ) .AND. & 159 & ( kobsj(ji) >= 1 ) .AND. ( kobsj(ji) <= jpj ) ) THEN 160 iobsig(ji) = mig( kobsi(ji) ) 161 iobsjg(ji) = mjg( kobsj(ji) ) 162 ELSE 163 iobsig(ji) = -1 164 iobsjg(ji) = -1 164 IF ( kobsp(ji) == 9999999 ) THEN 165 isum=isum+1 166 kobsp(ji)=-1 165 167 ENDIF 166 END DO 167 !----------------------------------------------------------------------- 168 ! Get the decisions from all processors 169 !----------------------------------------------------------------------- 170 ALLOCATE( iobsp(kno,size) ) 171 ALLOCATE( iobsi(kno,size) ) 172 ALLOCATE( iobsj(kno,size) ) 173 CALL mpi_allgather( kobsp, kno, mpi_integer, & 174 & iobsp, kno, mpi_integer, & 175 & mpi_comm_opa, ierr ) 176 CALL mpi_allgather( iobsig, kno, mpi_integer, & 177 & iobsi, kno, mpi_integer, & 178 & mpi_comm_opa, ierr ) 179 CALL mpi_allgather( iobsjg, kno, mpi_integer, & 180 & iobsj, kno, mpi_integer, & 181 & mpi_comm_opa, ierr ) 182 183 !----------------------------------------------------------------------- 184 ! Find the processor with observations from the lowest processor 185 ! number among processors holding the observation. 186 !----------------------------------------------------------------------- 187 kobsp(:) = -1 188 num_sus_obs = 0 189 DO ji = 1, kno 190 DO jj = 1, size 191 IF ( ( kobsp(ji) == -1 ) .AND. ( iobsp(ji,jj) /= -1 ) ) THEN 192 kobsp(ji) = iobsp(ji,jj) 193 iobsip = iobsi(ji,jj) 194 iobsjp = iobsj(ji,jj) 195 ENDIF 196 IF ( ( kobsp(ji) /= -1 ) .AND. ( iobsp(ji,jj) /= -1 ) ) THEN 197 IF ( ( iobsip /= iobsi(ji,jj) ) .OR. & 198 & ( iobsjp /= iobsj(ji,jj) ) ) THEN 199 IF ( ( kobsp(ji) < 1000000 ) .AND. & 200 & ( iobsp(ji,jj) < 1000000 ) ) THEN 201 num_sus_obs=num_sus_obs+1 202 ENDIF 203 ENDIF 204 IF ( mppmap(iobsip,iobsjp) /= ( kobsp(ji)+1 ) ) THEN 205 IF ( ( iobsi(ji,jj) /= -1 ) .AND. & 206 & ( iobsj(ji,jj) /= -1 ) ) THEN 207 IF ((mppmap(iobsi(ji,jj),iobsj(ji,jj)) == (iobsp(ji,jj)+1))& 208 & .OR. ( iobsp(ji,jj) < kobsp(ji) ) ) THEN 209 kobsp(ji) = iobsp(ji,jj) 210 iobsip = iobsi(ji,jj) 211 iobsjp = iobsj(ji,jj) 212 ENDIF 213 ENDIF 214 ENDIF 215 ENDIF 216 END DO 217 END DO 218 IF (lwp) WRITE(numout,*) 'Number of suspicious observations: ',num_sus_obs 219 220 DEALLOCATE( iobsj ) 221 DEALLOCATE( iobsi ) 168 ENDDO 169 170 171 IF ( isum > 0 ) THEN 172 IF (lwp) WRITE(numout,*) isum, ' observations failed the grid search.' 173 IF (lwp) WRITE(numout,*)'If ln_grid_search_lookup=.TRUE., try reducing grid_search_res' 174 ENDIF 175 222 176 DEALLOCATE( iobsp ) 177 223 178 #else 224 179 ! no MPI: empty routine 225 #endif 226 !180 #endif 181 227 182 END SUBROUTINE obs_mpp_find_obs_proc 228 183 -
branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_oper.F90
r7960 r7992 7 7 8 8 !!---------------------------------------------------------------------- 9 !! obs_pro_opt : Compute the model counterpart of temperature and 10 !! salinity observations from profiles 11 !! obs_sla_opt : Compute the model counterpart of sea level anomaly 12 !! observations 13 !! obs_sst_opt : Compute the model counterpart of sea surface temperature 14 !! observations 15 !! obs_sss_opt : Compute the model counterpart of sea surface salinity 16 !! observations 17 !! obs_seaice_opt : Compute the model counterpart of sea ice concentration 18 !! observations 19 !! 20 !! obs_vel_opt : Compute the model counterpart of zonal and meridional 21 !! components of velocity from observations. 9 !! obs_prof_opt : Compute the model counterpart of profile data 10 !! obs_surf_opt : Compute the model counterpart of surface data 22 11 !!---------------------------------------------------------------------- 23 12 24 !! * Modules used 13 !! * Modules used 25 14 USE par_kind, ONLY : & ! Precision variables 26 15 & wp 27 16 USE in_out_manager ! I/O manager 28 17 USE obs_inter_sup ! Interpolation support 29 USE obs_inter_h2d, ONLY : & ! Horizontal interpolation to the obs ervationpt18 USE obs_inter_h2d, ONLY : & ! Horizontal interpolation to the obs pt 30 19 & obs_int_h2d, & 31 20 & obs_int_h2d_init 32 USE obs_inter_z1d, ONLY : & ! Vertical interpolation to the observation pt 21 USE obs_averg_h2d, ONLY : & ! Horizontal averaging to the obs footprint 22 & obs_avg_h2d, & 23 & obs_avg_h2d_init, & 24 & obs_max_fpsize 25 USE obs_inter_z1d, ONLY : & ! Vertical interpolation to the obs pt 33 26 & obs_int_z1d, & 34 27 & obs_int_z1d_spl 35 USE obs_const, ONLY : &36 & obfillflt ! Fillvalue28 USE obs_const, ONLY : & ! Obs fill value 29 & obfillflt 37 30 USE dom_oce, ONLY : & 38 & glamt, glam u, glamv, &39 & gphit, gphi u, gphiv40 USE lib_mpp, ONLY : & 31 & glamt, glamf, & 32 & gphit, gphif 33 USE lib_mpp, ONLY : & ! Warning and stopping routines 41 34 & ctl_warn, ctl_stop 35 USE sbcdcy, ONLY : & ! For calculation of where it is night-time 36 & sbc_dcy, nday_qsr 37 USE obs_grid, ONLY : & 38 & obs_level_search 42 39 43 40 IMPLICIT NONE … … 46 43 PRIVATE 47 44 48 PUBLIC obs_pro_opt, & ! Compute the model counterpart of profile observations 49 & obs_sla_opt, & ! Compute the model counterpart of SLA observations 50 & obs_sst_opt, & ! Compute the model counterpart of SST observations 51 & obs_sss_opt, & ! Compute the model counterpart of SSS observations 52 & obs_seaice_opt, & 53 & obs_vel_opt ! Compute the model counterpart of velocity profile data 54 55 INTEGER, PARAMETER, PUBLIC :: imaxavtypes = 20 ! Max number of daily avgd obs types 45 PUBLIC obs_prof_opt, & ! Compute the model counterpart of profile obs 46 & obs_surf_opt ! Compute the model counterpart of surface obs 47 48 INTEGER, PARAMETER, PUBLIC :: & 49 & imaxavtypes = 20 ! Max number of daily avgd obs types 56 50 57 51 !!---------------------------------------------------------------------- … … 61 55 !!---------------------------------------------------------------------- 62 56 57 !! * Substitutions 58 # include "domzgr_substitute.h90" 63 59 CONTAINS 64 60 65 SUBROUTINE obs_pro_opt( prodatqc, kt, kpi, kpj, kpk, kit000, kdaystp, & 66 & ptn, psn, pgdept, ptmask, k1dint, k2dint, & 67 & kdailyavtypes ) 61 62 SUBROUTINE obs_prof_opt( prodatqc, kt, kpi, kpj, kpk, & 63 & kit000, kdaystp, & 64 & pvar1, pvar2, pgdept, pgdepw, & 65 & pmask1, pmask2, & 66 & plam1, plam2, pphi1, pphi2, & 67 & k1dint, k2dint, kdailyavtypes ) 68 68 69 !!----------------------------------------------------------------------- 69 70 !! … … 78 79 !! 79 80 !! First, a vertical profile of horizontally interpolated model 80 !! now temperatures is computed at the obs (lon, lat) point.81 !! now values is computed at the obs (lon, lat) point. 81 82 !! Several horizontal interpolation schemes are available: 82 83 !! - distance-weighted (great circle) (k2dint = 0) … … 86 87 !! - polynomial (quadrilateral grid) (k2dint = 4) 87 88 !! 88 !! Next, the vertical temperatureprofile is interpolated to the89 !! Next, the vertical profile is interpolated to the 89 90 !! data depth points. Two vertical interpolation schemes are 90 91 !! available: … … 96 97 !! routine. 97 98 !! 98 !! For ENACT moored buoy data (e.g., TAO), the model equivalent is99 !! If the logical is switched on, the model equivalent is 99 100 !! a daily mean model temperature field. So, we first compute 100 101 !! the mean, then interpolate only at the end of the day. 101 102 !! 102 !! Note: thein situ temperature observations must be converted103 !! Note: in situ temperature observations must be converted 103 104 !! to potential temperature (the model variable) prior to 104 105 !! assimilation. 105 !!??????????????????????????????????????????????????????????????106 !! INCLUDE POTENTIAL TEMP -> IN SITU TEMP IN OBS OPERATOR???107 !!??????????????????????????????????????????????????????????????108 106 !! 109 107 !! ** Action : … … 115 113 !! ! 07-01 (K. Mogensen) Merge of temperature and salinity 116 114 !! ! 07-03 (K. Mogensen) General handling of profiles 115 !! ! 15-02 (M. Martin) Combined routine for all profile types 116 !! ! 17-02 (M. Martin) Include generalised vertical coordinate changes 117 117 !!----------------------------------------------------------------------- 118 118 119 119 !! * Modules used 120 120 USE obs_profiles_def ! Definition of storage space for profile obs. … … 123 123 124 124 !! * Arguments 125 TYPE(obs_prof), INTENT(INOUT) :: prodatqc ! Subset of profile data not failing screening 126 INTEGER, INTENT(IN) :: kt ! Time step 127 INTEGER, INTENT(IN) :: kpi ! Model grid parameters 125 TYPE(obs_prof), INTENT(INOUT) :: & 126 & prodatqc ! Subset of profile data passing QC 127 INTEGER, INTENT(IN) :: kt ! Time step 128 INTEGER, INTENT(IN) :: kpi ! Model grid parameters 128 129 INTEGER, INTENT(IN) :: kpj 129 130 INTEGER, INTENT(IN) :: kpk 130 INTEGER, INTENT(IN) :: kit000 ! Number of the first time step131 132 INTEGER, INTENT(IN) :: k1dint 133 INTEGER, INTENT(IN) :: k2dint 134 INTEGER, INTENT(IN) :: kdaystp ! Number of time steps per day131 INTEGER, INTENT(IN) :: kit000 ! Number of the first time step 132 ! (kit000-1 = restart time) 133 INTEGER, INTENT(IN) :: k1dint ! Vertical interpolation type (see header) 134 INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation type (see header) 135 INTEGER, INTENT(IN) :: kdaystp ! Number of time steps per day 135 136 REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 136 & ptn, & ! Model temperature field 137 & psn, & ! Model salinity field 138 & ptmask ! Land-sea mask 139 REAL(KIND=wp), INTENT(IN), DIMENSION(kpk) :: & 140 & pgdept ! Model array of depth levels 137 & pvar1, & ! Model field 1 138 & pvar2, & ! Model field 2 139 & pmask1, & ! Land-sea mask 1 140 & pmask2 ! Land-sea mask 2 141 REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 142 & plam1, & ! Model longitudes for variable 1 143 & plam2, & ! Model longitudes for variable 2 144 & pphi1, & ! Model latitudes for variable 1 145 & pphi2 ! Model latitudes for variable 2 146 REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 147 & pgdept, & ! Model array of depth T levels 148 & pgdepw ! Model array of depth W levels 141 149 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 142 & kdailyavtypes! Types for daily averages 150 & kdailyavtypes ! Types for daily averages 151 143 152 !! * Local declarations 144 153 INTEGER :: ji … … 152 161 INTEGER :: iend 153 162 INTEGER :: iobs 163 INTEGER :: iin, ijn, ikn, ik ! looping indices over interpolation nodes 164 INTEGER :: inum_obs 154 165 INTEGER, DIMENSION(imaxavtypes) :: & 155 166 & idailyavtypes 167 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 168 & igrdi1, & 169 & igrdi2, & 170 & igrdj1, & 171 & igrdj2 172 INTEGER, ALLOCATABLE, DIMENSION(:) :: iv_indic 173 156 174 REAL(KIND=wp) :: zlam 157 175 REAL(KIND=wp) :: zphi 158 176 REAL(KIND=wp) :: zdaystp 159 177 REAL(KIND=wp), DIMENSION(kpk) :: & 160 & zobsmask, & 178 & zobsmask1, & 179 & zobsmask2, & 161 180 & zobsk, & 162 181 & zobs2k 163 REAL(KIND=wp), DIMENSION(2,2,kpk) :: & 182 REAL(KIND=wp), DIMENSION(2,2,1) :: & 183 & zweig1, & 184 & zweig2, & 164 185 & zweig 165 186 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 166 & zmask, & 167 & zintt, & 168 & zints, & 169 & zinmt, & 170 & zinms 187 & zmask1, & 188 & zmask2, & 189 & zint1, & 190 & zint2, & 191 & zinm1, & 192 & zinm2, & 193 & zgdept, & 194 & zgdepw 171 195 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 172 & zglam, & 173 & zgphi 174 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 175 & igrdi, & 176 & igrdj 196 & zglam1, & 197 & zglam2, & 198 & zgphi1, & 199 & zgphi2 200 REAL(KIND=wp), DIMENSION(1) :: zmsk_1, zmsk_2 201 REAL(KIND=wp), DIMENSION(:,:,:), ALLOCATABLE :: interp_corner 202 203 LOGICAL :: ld_dailyav 177 204 178 205 !------------------------------------------------------------------------ 179 206 ! Local initialization 180 207 !------------------------------------------------------------------------ 181 ! ...Record and data counters208 ! Record and data counters 182 209 inrc = kt - kit000 + 2 183 210 ipro = prodatqc%npstp(inrc) 184 211 185 212 ! Daily average types 213 ld_dailyav = .FALSE. 186 214 IF ( PRESENT(kdailyavtypes) ) THEN 187 215 idailyavtypes(:) = kdailyavtypes(:) 216 IF ( ANY (idailyavtypes(:) /= -1) ) ld_dailyav = .TRUE. 188 217 ELSE 189 218 idailyavtypes(:) = -1 190 219 ENDIF 191 220 192 ! Initialize daily mean for first timestep 221 ! Daily means are calculated for values over timesteps: 222 ! [1 <= kt <= kdaystp], [kdaystp+1 <= kt <= 2*kdaystp], ... 193 223 idayend = MOD( kt - kit000 + 1, kdaystp ) 194 224 195 ! Added kt == 0 test to catch restart case 196 IF ( idayend == 1 .OR. kt == 0) THEN 197 IF (lwp) WRITE(numout,*) 'Reset prodatqc%vdmean on time-step: ',kt 225 IF ( ld_dailyav ) THEN 226 227 ! Initialize daily mean for first timestep of the day 228 IF ( idayend == 1 .OR. kt == 0 ) THEN 229 DO jk = 1, jpk 230 DO jj = 1, jpj 231 DO ji = 1, jpi 232 prodatqc%vdmean(ji,jj,jk,1) = 0.0 233 prodatqc%vdmean(ji,jj,jk,2) = 0.0 234 END DO 235 END DO 236 END DO 237 ENDIF 238 198 239 DO jk = 1, jpk 199 240 DO jj = 1, jpj 200 241 DO ji = 1, jpi 201 prodatqc%vdmean(ji,jj,jk,1) = 0.0 202 prodatqc%vdmean(ji,jj,jk,2) = 0.0 242 ! Increment field 1 for computing daily mean 243 prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 244 & + pvar1(ji,jj,jk) 245 ! Increment field 2 for computing daily mean 246 prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 247 & + pvar2(ji,jj,jk) 203 248 END DO 204 249 END DO 205 250 END DO 206 ENDIF 207 208 DO jk = 1, jpk 209 DO jj = 1, jpj 210 DO ji = 1, jpi 211 ! Increment the temperature field for computing daily mean 212 prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 213 & + ptn(ji,jj,jk) 214 ! Increment the salinity field for computing daily mean 215 prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 216 & + psn(ji,jj,jk) 217 END DO 218 END DO 219 END DO 220 221 ! Compute the daily mean at the end of day 222 zdaystp = 1.0 / REAL( kdaystp ) 223 IF ( idayend == 0 ) THEN 224 DO jk = 1, jpk 225 DO jj = 1, jpj 226 DO ji = 1, jpi 227 prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 228 & * zdaystp 229 prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 230 & * zdaystp 251 252 ! Compute the daily mean at the end of day 253 zdaystp = 1.0 / REAL( kdaystp ) 254 IF ( idayend == 0 ) THEN 255 IF (lwp) WRITE(numout,*) 'Calculating prodatqc%vdmean on time-step: ',kt 256 CALL FLUSH(numout) 257 DO jk = 1, jpk 258 DO jj = 1, jpj 259 DO ji = 1, jpi 260 prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 261 & * zdaystp 262 prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 263 & * zdaystp 264 END DO 231 265 END DO 232 266 END DO 233 END DO 267 ENDIF 268 234 269 ENDIF 235 270 236 271 ! Get the data for interpolation 237 272 ALLOCATE( & 238 & igrdi(2,2,ipro), & 239 & igrdj(2,2,ipro), & 240 & zglam(2,2,ipro), & 241 & zgphi(2,2,ipro), & 242 & zmask(2,2,kpk,ipro), & 243 & zintt(2,2,kpk,ipro), & 244 & zints(2,2,kpk,ipro) & 273 & igrdi1(2,2,ipro), & 274 & igrdi2(2,2,ipro), & 275 & igrdj1(2,2,ipro), & 276 & igrdj2(2,2,ipro), & 277 & zglam1(2,2,ipro), & 278 & zglam2(2,2,ipro), & 279 & zgphi1(2,2,ipro), & 280 & zgphi2(2,2,ipro), & 281 & zmask1(2,2,kpk,ipro), & 282 & zmask2(2,2,kpk,ipro), & 283 & zint1(2,2,kpk,ipro), & 284 & zint2(2,2,kpk,ipro), & 285 & zgdept(2,2,kpk,ipro), & 286 & zgdepw(2,2,kpk,ipro) & 245 287 & ) 246 288 247 289 DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro 248 290 iobs = jobs - prodatqc%nprofup 249 igrdi(1,1,iobs) = prodatqc%mi(jobs,1)-1 250 igrdj(1,1,iobs) = prodatqc%mj(jobs,1)-1 251 igrdi(1,2,iobs) = prodatqc%mi(jobs,1)-1 252 igrdj(1,2,iobs) = prodatqc%mj(jobs,1) 253 igrdi(2,1,iobs) = prodatqc%mi(jobs,1) 254 igrdj(2,1,iobs) = prodatqc%mj(jobs,1)-1 255 igrdi(2,2,iobs) = prodatqc%mi(jobs,1) 256 igrdj(2,2,iobs) = prodatqc%mj(jobs,1) 291 igrdi1(1,1,iobs) = prodatqc%mi(jobs,1)-1 292 igrdj1(1,1,iobs) = prodatqc%mj(jobs,1)-1 293 igrdi1(1,2,iobs) = prodatqc%mi(jobs,1)-1 294 igrdj1(1,2,iobs) = prodatqc%mj(jobs,1) 295 igrdi1(2,1,iobs) = prodatqc%mi(jobs,1) 296 igrdj1(2,1,iobs) = prodatqc%mj(jobs,1)-1 297 igrdi1(2,2,iobs) = prodatqc%mi(jobs,1) 298 igrdj1(2,2,iobs) = prodatqc%mj(jobs,1) 299 igrdi2(1,1,iobs) = prodatqc%mi(jobs,2)-1 300 igrdj2(1,1,iobs) = prodatqc%mj(jobs,2)-1 301 igrdi2(1,2,iobs) = prodatqc%mi(jobs,2)-1 302 igrdj2(1,2,iobs) = prodatqc%mj(jobs,2) 303 igrdi2(2,1,iobs) = prodatqc%mi(jobs,2) 304 igrdj2(2,1,iobs) = prodatqc%mj(jobs,2)-1 305 igrdi2(2,2,iobs) = prodatqc%mi(jobs,2) 306 igrdj2(2,2,iobs) = prodatqc%mj(jobs,2) 257 307 END DO 258 308 259 CALL obs_int_comm_2d( 2, 2, ipro, igrdi, igrdj, glamt, zglam ) 260 CALL obs_int_comm_2d( 2, 2, ipro, igrdi, igrdj, gphit, zgphi ) 261 CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdi, igrdj, ptmask,zmask ) 262 CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdi, igrdj, ptn, zintt ) 263 CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdi, igrdj, psn, zints ) 309 ! Initialise depth arrays 310 zgdept(:,:,:,:) = 0.0 311 zgdepw(:,:,:,:) = 0.0 312 313 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi1, igrdj1, plam1, zglam1 ) 314 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi1, igrdj1, pphi1, zgphi1 ) 315 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pmask1, zmask1 ) 316 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pvar1, zint1 ) 317 318 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi2, igrdj2, plam2, zglam2 ) 319 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi2, igrdj2, pphi2, zgphi2 ) 320 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, pmask2, zmask2 ) 321 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, pvar2, zint2 ) 322 323 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pgdept, zgdept ) 324 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pgdepw, zgdepw ) 264 325 265 326 ! At the end of the day also get interpolated means 266 IF ( idayend == 0 ) THEN327 IF ( ld_dailyav .AND. idayend == 0 ) THEN 267 328 268 329 ALLOCATE( & 269 & zinm t(2,2,kpk,ipro), &270 & zinm s(2,2,kpk,ipro) &330 & zinm1(2,2,kpk,ipro), & 331 & zinm2(2,2,kpk,ipro) & 271 332 & ) 272 333 273 CALL obs_int_comm_3d( 2, 2, ipro, kp k, igrdi, igrdj, &274 & prodatqc%vdmean(:,:,:,1), zinm t)275 CALL obs_int_comm_3d( 2, 2, ipro, kp k, igrdi, igrdj, &276 & prodatqc%vdmean(:,:,:,2), zinm s)334 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, & 335 & prodatqc%vdmean(:,:,:,1), zinm1 ) 336 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, & 337 & prodatqc%vdmean(:,:,:,2), zinm2 ) 277 338 278 339 ENDIF 279 340 341 ! Return if no observations to process 342 ! Has to be done after comm commands to ensure processors 343 ! stay in sync 344 IF ( ipro == 0 ) RETURN 345 280 346 DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro 281 347 … … 283 349 284 350 IF ( kt /= prodatqc%mstp(jobs) ) THEN 285 351 286 352 IF(lwp) THEN 287 353 WRITE(numout,*) … … 298 364 CALL ctl_stop( 'obs_pro_opt', 'Inconsistent time' ) 299 365 ENDIF 300 366 301 367 zlam = prodatqc%rlam(jobs) 302 368 zphi = prodatqc%rphi(jobs) 369 370 ! Horizontal weights 371 ! Masked values are calculated later. 372 IF ( prodatqc%npvend(jobs,1) > 0 ) THEN 373 374 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 375 & zglam1(:,:,iobs), zgphi1(:,:,iobs), & 376 & zmask1(:,:,1,iobs), zweig1, zmsk_1 ) 377 378 ENDIF 379 380 IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 381 382 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 383 & zglam2(:,:,iobs), zgphi2(:,:,iobs), & 384 & zmask2(:,:,1,iobs), zweig2, zmsk_2 ) 385 386 ENDIF 387 388 IF ( prodatqc%npvend(jobs,1) > 0 ) THEN 389 390 zobsk(:) = obfillflt 391 392 IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN 393 394 IF ( idayend == 0 ) THEN 395 ! Daily averaged data 396 397 ! vertically interpolate all 4 corners 398 ista = prodatqc%npvsta(jobs,1) 399 iend = prodatqc%npvend(jobs,1) 400 inum_obs = iend - ista + 1 401 ALLOCATE(interp_corner(2,2,inum_obs),iv_indic(inum_obs)) 402 403 DO iin=1,2 404 DO ijn=1,2 405 406 IF ( k1dint == 1 ) THEN 407 CALL obs_int_z1d_spl( kpk, & 408 & zinm1(iin,ijn,:,iobs), & 409 & zobs2k, zgdept(iin,ijn,:,iobs), & 410 & zmask1(iin,ijn,:,iobs)) 411 ENDIF 412 413 CALL obs_level_search(kpk, & 414 & zgdept(iin,ijn,:,iobs), & 415 & inum_obs, prodatqc%var(1)%vdep(ista:iend), & 416 & iv_indic) 417 418 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 419 & prodatqc%var(1)%vdep(ista:iend), & 420 & zinm1(iin,ijn,:,iobs), & 421 & zobs2k, interp_corner(iin,ijn,:), & 422 & zgdept(iin,ijn,:,iobs), & 423 & zmask1(iin,ijn,:,iobs)) 424 425 ENDDO 426 ENDDO 427 428 ENDIF !idayend 429 430 ELSE 431 432 ! Point data 433 434 ! vertically interpolate all 4 corners 435 ista = prodatqc%npvsta(jobs,1) 436 iend = prodatqc%npvend(jobs,1) 437 inum_obs = iend - ista + 1 438 ALLOCATE(interp_corner(2,2,inum_obs), iv_indic(inum_obs)) 439 DO iin=1,2 440 DO ijn=1,2 441 442 IF ( k1dint == 1 ) THEN 443 CALL obs_int_z1d_spl( kpk, & 444 & zint1(iin,ijn,:,iobs),& 445 & zobs2k, zgdept(iin,ijn,:,iobs), & 446 & zmask1(iin,ijn,:,iobs)) 447 448 ENDIF 449 450 CALL obs_level_search(kpk, & 451 & zgdept(iin,ijn,:,iobs),& 452 & inum_obs, prodatqc%var(1)%vdep(ista:iend), & 453 & iv_indic) 454 455 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 456 & prodatqc%var(1)%vdep(ista:iend), & 457 & zint1(iin,ijn,:,iobs), & 458 & zobs2k,interp_corner(iin,ijn,:), & 459 & zgdept(iin,ijn,:,iobs), & 460 & zmask1(iin,ijn,:,iobs) ) 303 461 304 ! Horizontal weights and vertical mask 305 306 IF ( ( prodatqc%npvend(jobs,1) > 0 ) .OR. & 307 & ( prodatqc%npvend(jobs,2) > 0 ) ) THEN 308 309 CALL obs_int_h2d_init( kpk, kpk, k2dint, zlam, zphi, & 310 & zglam(:,:,iobs), zgphi(:,:,iobs), & 311 & zmask(:,:,:,iobs), zweig, zobsmask ) 312 313 ENDIF 314 315 IF ( prodatqc%npvend(jobs,1) > 0 ) THEN 462 ENDDO 463 ENDDO 464 465 ENDIF 466 467 !------------------------------------------------------------- 468 ! Compute the horizontal interpolation for every profile level 469 !------------------------------------------------------------- 470 471 DO ikn=1,inum_obs 472 iend=ista+ikn-1 473 474 zweig(:,:,1) = 0._wp 475 476 ! This code forces the horizontal weights to be 477 ! zero IF the observation is below the bottom of the 478 ! corners of the interpolation nodes, Or if it is in 479 ! the mask. This is important for observations near 480 ! steep bathymetry 481 DO iin=1,2 482 DO ijn=1,2 483 484 depth_loop1: DO ik=kpk,2,-1 485 IF(zmask1(iin,ijn,ik-1,iobs ) > 0.9 )THEN 486 487 zweig(iin,ijn,1) = & 488 & zweig1(iin,ijn,1) * & 489 & MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) & 490 & - prodatqc%var(1)%vdep(iend)),0._wp) 491 492 EXIT depth_loop1 493 494 ENDIF 495 496 ENDDO depth_loop1 497 498 ENDDO 499 ENDDO 500 501 CALL obs_int_h2d( 1, 1, zweig, interp_corner(:,:,ikn), & 502 & prodatqc%var(1)%vmod(iend:iend) ) 503 504 ! Set QC flag for any observations found below the bottom 505 ! needed as the check here is more strict than that in obs_prep 506 IF (sum(zweig) == 0.0_wp) prodatqc%var(1)%nvqc(iend:iend)=4 507 508 ENDDO 509 510 DEALLOCATE(interp_corner,iv_indic) 511 512 ENDIF 513 514 ! For the second variable 515 IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 316 516 317 517 zobsk(:) = obfillflt 318 518 319 519 IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN 320 520 321 521 IF ( idayend == 0 ) THEN 522 ! Daily averaged data 523 524 ! vertically interpolate all 4 corners 525 ista = prodatqc%npvsta(jobs,2) 526 iend = prodatqc%npvend(jobs,2) 527 inum_obs = iend - ista + 1 528 ALLOCATE(interp_corner(2,2,inum_obs),iv_indic(inum_obs)) 529 530 DO iin=1,2 531 DO ijn=1,2 532 533 IF ( k1dint == 1 ) THEN 534 CALL obs_int_z1d_spl( kpk, & 535 & zinm2(iin,ijn,:,iobs), & 536 & zobs2k, zgdept(iin,ijn,:,iobs), & 537 & zmask2(iin,ijn,:,iobs)) 538 ENDIF 539 540 CALL obs_level_search(kpk, & 541 & zgdept(iin,ijn,:,iobs), & 542 & inum_obs, prodatqc%var(2)%vdep(ista:iend), & 543 & iv_indic) 544 545 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 546 & prodatqc%var(2)%vdep(ista:iend), & 547 & zinm2(iin,ijn,:,iobs), & 548 & zobs2k, interp_corner(iin,ijn,:), & 549 & zgdept(iin,ijn,:,iobs), & 550 & zmask2(iin,ijn,:,iobs)) 551 552 ENDDO 553 ENDDO 554 555 ENDIF !idayend 556 557 ELSE 558 559 ! Point data 560 561 ! vertically interpolate all 4 corners 562 ista = prodatqc%npvsta(jobs,2) 563 iend = prodatqc%npvend(jobs,2) 564 inum_obs = iend - ista + 1 565 ALLOCATE(interp_corner(2,2,inum_obs), iv_indic(inum_obs)) 566 DO iin=1,2 567 DO ijn=1,2 568 569 IF ( k1dint == 1 ) THEN 570 CALL obs_int_z1d_spl( kpk, & 571 & zint2(iin,ijn,:,iobs),& 572 & zobs2k, zgdept(iin,ijn,:,iobs), & 573 & zmask2(iin,ijn,:,iobs)) 574 575 ENDIF 576 577 CALL obs_level_search(kpk, & 578 & zgdept(iin,ijn,:,iobs),& 579 & inum_obs, prodatqc%var(2)%vdep(ista:iend), & 580 & iv_indic) 581 582 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 583 & prodatqc%var(2)%vdep(ista:iend), & 584 & zint2(iin,ijn,:,iobs), & 585 & zobs2k,interp_corner(iin,ijn,:), & 586 & zgdept(iin,ijn,:,iobs), & 587 & zmask2(iin,ijn,:,iobs) ) 588 589 ENDDO 590 ENDDO 591 592 ENDIF 593 594 !------------------------------------------------------------- 595 ! Compute the horizontal interpolation for every profile level 596 !------------------------------------------------------------- 597 598 DO ikn=1,inum_obs 599 iend=ista+ikn-1 322 600 323 ! Daily averaged moored buoy (MRB) data 324 325 CALL obs_int_h2d( kpk, kpk, & 326 & zweig, zinmt(:,:,:,iobs), zobsk ) 327 328 329 ELSE 330 331 CALL ctl_stop( ' A nonzero' // & 332 & ' number of profile T BUOY data should' // & 333 & ' only occur at the end of a given day' ) 334 335 ENDIF 336 337 ELSE 338 339 ! Point data 340 341 CALL obs_int_h2d( kpk, kpk, & 342 & zweig, zintt(:,:,:,iobs), zobsk ) 343 344 ENDIF 345 346 !------------------------------------------------------------- 347 ! Compute vertical second-derivative of the interpolating 348 ! polynomial at obs points 349 !------------------------------------------------------------- 350 351 IF ( k1dint == 1 ) THEN 352 CALL obs_int_z1d_spl( kpk, zobsk, zobs2k, & 353 & pgdept, zobsmask ) 354 ENDIF 355 356 !----------------------------------------------------------------- 357 ! Vertical interpolation to the observation point 358 !----------------------------------------------------------------- 359 ista = prodatqc%npvsta(jobs,1) 360 iend = prodatqc%npvend(jobs,1) 361 CALL obs_int_z1d( kpk, & 362 & prodatqc%var(1)%mvk(ista:iend), & 363 & k1dint, iend - ista + 1, & 364 & prodatqc%var(1)%vdep(ista:iend), & 365 & zobsk, zobs2k, & 366 & prodatqc%var(1)%vmod(ista:iend), & 367 & pgdept, zobsmask ) 368 369 ENDIF 370 371 IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 372 373 zobsk(:) = obfillflt 374 375 IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN 376 377 IF ( idayend == 0 ) THEN 378 379 ! Daily averaged moored buoy (MRB) data 380 381 CALL obs_int_h2d( kpk, kpk, & 382 & zweig, zinms(:,:,:,iobs), zobsk ) 383 384 ELSE 385 386 CALL ctl_stop( ' A nonzero' // & 387 & ' number of profile S BUOY data should' // & 388 & ' only occur at the end of a given day' ) 389 390 ENDIF 391 392 ELSE 393 394 ! Point data 395 396 CALL obs_int_h2d( kpk, kpk, & 397 & zweig, zints(:,:,:,iobs), zobsk ) 398 399 ENDIF 400 401 402 !------------------------------------------------------------- 403 ! Compute vertical second-derivative of the interpolating 404 ! polynomial at obs points 405 !------------------------------------------------------------- 406 407 IF ( k1dint == 1 ) THEN 408 CALL obs_int_z1d_spl( kpk, zobsk, zobs2k, & 409 & pgdept, zobsmask ) 410 ENDIF 411 412 !---------------------------------------------------------------- 413 ! Vertical interpolation to the observation point 414 !---------------------------------------------------------------- 415 ista = prodatqc%npvsta(jobs,2) 416 iend = prodatqc%npvend(jobs,2) 417 CALL obs_int_z1d( kpk, & 418 & prodatqc%var(2)%mvk(ista:iend),& 419 & k1dint, iend - ista + 1, & 420 & prodatqc%var(2)%vdep(ista:iend),& 421 & zobsk, zobs2k, & 422 & prodatqc%var(2)%vmod(ista:iend),& 423 & pgdept, zobsmask ) 424 425 ENDIF 426 427 END DO 601 zweig(:,:,1) = 0._wp 602 603 ! This code forces the horizontal weights to be 604 ! zero IF the observation is below the bottom of the 605 ! corners of the interpolation nodes, Or if it is in 606 ! the mask. This is important for observations near 607 ! steep bathymetry 608 DO iin=1,2 609 DO ijn=1,2 610 611 depth_loop2: DO ik=kpk,2,-1 612 IF(zmask2(iin,ijn,ik-1,iobs ) > 0.9 )THEN 613 614 zweig(iin,ijn,1) = & 615 & zweig2(iin,ijn,1) * & 616 & MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) & 617 & - prodatqc%var(2)%vdep(iend)),0._wp) 618 619 EXIT depth_loop2 620 621 ENDIF 622 623 ENDDO depth_loop2 624 625 ENDDO 626 ENDDO 627 628 CALL obs_int_h2d( 1, 1, zweig, interp_corner(:,:,ikn), & 629 & prodatqc%var(2)%vmod(iend:iend) ) 630 631 ! Set QC flag for any observations found below the bottom 632 ! needed as the check here is more strict than that in obs_prep 633 IF (sum(zweig) == 0.0_wp) prodatqc%var(2)%nvqc(iend:iend)=4 428 634 635 ENDDO 636 637 DEALLOCATE(interp_corner,iv_indic) 638 639 ENDIF 640 641 ENDDO 642 429 643 ! Deallocate the data for interpolation 430 644 DEALLOCATE( & 431 & igrdi, & 432 & igrdj, & 433 & zglam, & 434 & zgphi, & 435 & zmask, & 436 & zintt, & 437 & zints & 645 & igrdi1, & 646 & igrdi2, & 647 & igrdj1, & 648 & igrdj2, & 649 & zglam1, & 650 & zglam2, & 651 & zgphi1, & 652 & zgphi2, & 653 & zmask1, & 654 & zmask2, & 655 & zint1, & 656 & zint2, & 657 & zgdept, & 658 & zgdepw & 438 659 & ) 660 439 661 ! At the end of the day also get interpolated means 440 IF ( idayend == 0 ) THEN662 IF ( ld_dailyav .AND. idayend == 0 ) THEN 441 663 DEALLOCATE( & 442 & zinm t, &443 & zinm s&664 & zinm1, & 665 & zinm2 & 444 666 & ) 445 667 ENDIF 446 668 447 669 prodatqc%nprofup = prodatqc%nprofup + ipro 448 449 END SUBROUTINE obs_pro_opt 450 451 SUBROUTINE obs_sla_opt( sladatqc, kt, kpi, kpj, kit000, & 452 & psshn, psshmask, k2dint ) 670 671 END SUBROUTINE obs_prof_opt 672 673 SUBROUTINE obs_surf_opt( surfdataqc, kt, kpi, kpj, & 674 & kit000, kdaystp, psurf, psurfmask, & 675 & k2dint, ldnightav, plamscl, pphiscl, & 676 & lindegrees ) 677 453 678 !!----------------------------------------------------------------------- 454 679 !! 455 !! *** ROUTINE obs_s la_opt ***456 !! 457 !! ** Purpose : Compute the model counterpart of s ea level anomaly680 !! *** ROUTINE obs_surf_opt *** 681 !! 682 !! ** Purpose : Compute the model counterpart of surface 458 683 !! data by interpolating from the model grid to the 459 684 !! observation point. … … 462 687 !! the model values at the corners of the surrounding grid box. 463 688 !! 464 !! The n ow model SSHis first computed at the obs (lon, lat) point.689 !! The new model value is first computed at the obs (lon, lat) point. 465 690 !! 466 691 !! Several horizontal interpolation schemes are available: … … 470 695 !! - bilinear (quadrilateral grid) (k2dint = 3) 471 696 !! - polynomial (quadrilateral grid) (k2dint = 4) 472 !! 473 !! The sea level anomaly at the observation points is then computed 474 !! by removing a mean dynamic topography (defined at the obs. point). 697 !! 698 !! Two horizontal averaging schemes are also available: 699 !! - weighted radial footprint (k2dint = 5) 700 !! - weighted rectangular footprint (k2dint = 6) 701 !! 475 702 !! 476 703 !! ** Action : … … 478 705 !! History : 479 706 !! ! 07-03 (A. Weaver) 707 !! ! 15-02 (M. Martin) Combined routine for surface types 708 !! ! 17-03 (M. Martin) Added horizontal averaging options 480 709 !!----------------------------------------------------------------------- 481 710 482 711 !! * Modules used 483 712 USE obs_surf_def ! Definition of storage space for surface observations … … 486 715 487 716 !! * Arguments 488 TYPE(obs_surf), INTENT(INOUT) :: sladatqc ! Subset of surface data not failing screening 489 INTEGER, INTENT(IN) :: kt ! Time step 490 INTEGER, INTENT(IN) :: kpi ! Model grid parameters 717 TYPE(obs_surf), INTENT(INOUT) :: & 718 & surfdataqc ! Subset of surface data passing QC 719 INTEGER, INTENT(IN) :: kt ! Time step 720 INTEGER, INTENT(IN) :: kpi ! Model grid parameters 491 721 INTEGER, INTENT(IN) :: kpj 492 INTEGER, INTENT(IN) :: kit000 ! Number of the first time step 493 ! (kit000-1 = restart time) 494 INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation type (see header) 495 REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 496 & psshn, & ! Model SSH field 497 & psshmask ! Land-sea mask 498 722 INTEGER, INTENT(IN) :: kit000 ! Number of the first time step 723 ! (kit000-1 = restart time) 724 INTEGER, INTENT(IN) :: kdaystp ! Number of time steps per day 725 INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation type (see header) 726 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 727 & psurf, & ! Model surface field 728 & psurfmask ! Land-sea mask 729 LOGICAL, INTENT(IN) :: ldnightav ! Logical for averaging night-time data 730 REAL(KIND=wp), INTENT(IN) :: & 731 & plamscl, & ! Diameter in metres of obs footprint in E/W, N/S directions 732 & pphiscl ! This is the full width (rather than half-width) 733 LOGICAL, INTENT(IN) :: & 734 & lindegrees ! T=> plamscl and pphiscl are specified in degrees, F=> in metres 735 499 736 !! * Local declarations 500 737 INTEGER :: ji … … 502 739 INTEGER :: jobs 503 740 INTEGER :: inrc 504 INTEGER :: is la741 INTEGER :: isurf 505 742 INTEGER :: iobs 506 REAL(KIND=wp) :: zlam 507 REAL(KIND=wp) :: zphi 508 REAL(KIND=wp) :: zext(1), zobsmask(1) 509 REAL(kind=wp), DIMENSION(2,2,1) :: & 510 & zweig 743 INTEGER :: imaxifp, imaxjfp 744 INTEGER :: imodi, imodj 745 INTEGER :: idayend 746 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 747 & igrdi, & 748 & igrdj, & 749 & igrdip1, & 750 & igrdjp1 751 INTEGER, DIMENSION(:,:), SAVE, ALLOCATABLE :: & 752 & icount_night, & 753 & imask_night 754 REAL(wp) :: zlam 755 REAL(wp) :: zphi 756 REAL(wp), DIMENSION(1) :: zext, zobsmask 757 REAL(wp) :: zdaystp 511 758 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 512 & zmask, & 513 & zsshl, & 514 & zglam, & 515 & zgphi 516 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 517 & igrdi, & 518 & igrdj 759 & zweig, & 760 & zmask, & 761 & zsurf, & 762 & zsurfm, & 763 & zsurftmp, & 764 & zglam, & 765 & zgphi, & 766 & zglamf, & 767 & zgphif 768 769 REAL(wp), DIMENSION(:,:), SAVE, ALLOCATABLE :: & 770 & zintmp, & 771 & zouttmp, & 772 & zmeanday ! to compute model sst in region of 24h daylight (pole) 519 773 520 774 !------------------------------------------------------------------------ 521 775 ! Local initialization 522 776 !------------------------------------------------------------------------ 523 ! ...Record and data counters777 ! Record and data counters 524 778 inrc = kt - kit000 + 2 525 isla = sladatqc%nsstp(inrc) 779 isurf = surfdataqc%nsstp(inrc) 780 781 ! Work out the maximum footprint size for the 782 ! interpolation/averaging in model grid-points - has to be even. 783 784 CALL obs_max_fpsize( k2dint, plamscl, pphiscl, lindegrees, psurfmask, imaxifp, imaxjfp ) 785 786 787 IF ( ldnightav ) THEN 788 789 ! Initialize array for night mean 790 IF ( kt == 0 ) THEN 791 ALLOCATE ( icount_night(kpi,kpj) ) 792 ALLOCATE ( imask_night(kpi,kpj) ) 793 ALLOCATE ( zintmp(kpi,kpj) ) 794 ALLOCATE ( zouttmp(kpi,kpj) ) 795 ALLOCATE ( zmeanday(kpi,kpj) ) 796 nday_qsr = -1 ! initialisation flag for nbc_dcy 797 ENDIF 798 799 ! Night-time means are calculated for night-time values over timesteps: 800 ! [1 <= kt <= kdaystp], [kdaystp+1 <= kt <= 2*kdaystp], ..... 801 idayend = MOD( kt - kit000 + 1, kdaystp ) 802 803 ! Initialize night-time mean for first timestep of the day 804 IF ( idayend == 1 .OR. kt == 0 ) THEN 805 DO jj = 1, jpj 806 DO ji = 1, jpi 807 surfdataqc%vdmean(ji,jj) = 0.0 808 zmeanday(ji,jj) = 0.0 809 icount_night(ji,jj) = 0 810 END DO 811 END DO 812 ENDIF 813 814 zintmp(:,:) = 0.0 815 zouttmp(:,:) = sbc_dcy( zintmp(:,:), .TRUE. ) 816 imask_night(:,:) = INT( zouttmp(:,:) ) 817 818 DO jj = 1, jpj 819 DO ji = 1, jpi 820 ! Increment the temperature field for computing night mean and counter 821 surfdataqc%vdmean(ji,jj) = surfdataqc%vdmean(ji,jj) & 822 & + psurf(ji,jj) * REAL( imask_night(ji,jj) ) 823 zmeanday(ji,jj) = zmeanday(ji,jj) + psurf(ji,jj) 824 icount_night(ji,jj) = icount_night(ji,jj) + imask_night(ji,jj) 825 END DO 826 END DO 827 828 ! Compute the night-time mean at the end of the day 829 zdaystp = 1.0 / REAL( kdaystp ) 830 IF ( idayend == 0 ) THEN 831 IF (lwp) WRITE(numout,*) 'Calculating surfdataqc%vdmean on time-step: ',kt 832 DO jj = 1, jpj 833 DO ji = 1, jpi 834 ! Test if "no night" point 835 IF ( icount_night(ji,jj) > 0 ) THEN 836 surfdataqc%vdmean(ji,jj) = surfdataqc%vdmean(ji,jj) & 837 & / REAL( icount_night(ji,jj) ) 838 ELSE 839 !At locations where there is no night (e.g. poles), 840 ! calculate daily mean instead of night-time mean. 841 surfdataqc%vdmean(ji,jj) = zmeanday(ji,jj) * zdaystp 842 ENDIF 843 END DO 844 END DO 845 ENDIF 846 847 ENDIF 526 848 527 849 ! Get the data for interpolation 528 850 529 851 ALLOCATE( & 530 & igrdi(2,2,isla), & 531 & igrdj(2,2,isla), & 532 & zglam(2,2,isla), & 533 & zgphi(2,2,isla), & 534 & zmask(2,2,isla), & 535 & zsshl(2,2,isla) & 852 & zweig(imaxifp,imaxjfp,1), & 853 & igrdi(imaxifp,imaxjfp,isurf), & 854 & igrdj(imaxifp,imaxjfp,isurf), & 855 & zglam(imaxifp,imaxjfp,isurf), & 856 & zgphi(imaxifp,imaxjfp,isurf), & 857 & zmask(imaxifp,imaxjfp,isurf), & 858 & zsurf(imaxifp,imaxjfp,isurf), & 859 & zsurftmp(imaxifp,imaxjfp,isurf), & 860 & zglamf(imaxifp+1,imaxjfp+1,isurf), & 861 & zgphif(imaxifp+1,imaxjfp+1,isurf), & 862 & igrdip1(imaxifp+1,imaxjfp+1,isurf), & 863 & igrdjp1(imaxifp+1,imaxjfp+1,isurf) & 536 864 & ) 537 538 DO jobs = sladatqc%nsurfup + 1, sladatqc%nsurfup + isla 539 iobs = jobs - sladatqc%nsurfup 540 igrdi(1,1,iobs) = sladatqc%mi(jobs)-1 541 igrdj(1,1,iobs) = sladatqc%mj(jobs)-1 542 igrdi(1,2,iobs) = sladatqc%mi(jobs)-1 543 igrdj(1,2,iobs) = sladatqc%mj(jobs) 544 igrdi(2,1,iobs) = sladatqc%mi(jobs) 545 igrdj(2,1,iobs) = sladatqc%mj(jobs)-1 546 igrdi(2,2,iobs) = sladatqc%mi(jobs) 547 igrdj(2,2,iobs) = sladatqc%mj(jobs) 865 866 DO jobs = surfdataqc%nsurfup + 1, surfdataqc%nsurfup + isurf 867 iobs = jobs - surfdataqc%nsurfup 868 DO ji = 0, imaxifp 869 imodi = surfdataqc%mi(jobs) - int(imaxifp/2) + ji - 1 870 871 !Deal with wrap around in longitude 872 IF ( imodi < 1 ) imodi = imodi + jpiglo 873 IF ( imodi > jpiglo ) imodi = imodi - jpiglo 874 875 DO jj = 0, imaxjfp 876 imodj = surfdataqc%mj(jobs) - int(imaxjfp/2) + jj - 1 877 !If model values are out of the domain to the north/south then 878 !set them to be the edge of the domain 879 IF ( imodj < 1 ) imodj = 1 880 IF ( imodj > jpjglo ) imodj = jpjglo 881 882 igrdip1(ji+1,jj+1,iobs) = imodi 883 igrdjp1(ji+1,jj+1,iobs) = imodj 884 885 IF ( ji >= 1 .AND. jj >= 1 ) THEN 886 igrdi(ji,jj,iobs) = imodi 887 igrdj(ji,jj,iobs) = imodj 888 ENDIF 889 890 END DO 891 END DO 548 892 END DO 549 893 550 CALL obs_int_comm_2d( 2, 2, isla, &894 CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & 551 895 & igrdi, igrdj, glamt, zglam ) 552 CALL obs_int_comm_2d( 2, 2, isla, &896 CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & 553 897 & igrdi, igrdj, gphit, zgphi ) 554 CALL obs_int_comm_2d( 2, 2, isla, & 555 & igrdi, igrdj, psshmask, zmask ) 556 CALL obs_int_comm_2d( 2, 2, isla, & 557 & igrdi, igrdj, psshn, zsshl ) 898 CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & 899 & igrdi, igrdj, psurfmask, zmask ) 900 CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & 901 & igrdi, igrdj, psurf, zsurf ) 902 CALL obs_int_comm_2d( imaxifp+1, imaxjfp+1, isurf, kpi, kpj, & 903 & igrdip1, igrdjp1, glamf, zglamf ) 904 CALL obs_int_comm_2d( imaxifp+1, imaxjfp+1, isurf, kpi, kpj, & 905 & igrdip1, igrdjp1, gphif, zgphif ) 906 907 ! At the end of the day get interpolated means 908 IF ( idayend == 0 .AND. ldnightav ) THEN 909 910 ALLOCATE( & 911 & zsurfm(imaxifp,imaxjfp,isurf) & 912 & ) 913 914 CALL obs_int_comm_2d( imaxifp,imaxjfp, isurf, kpi, kpj, igrdi, igrdj, & 915 & surfdataqc%vdmean(:,:), zsurfm ) 916 917 ENDIF 558 918 559 919 ! Loop over observations 560 561 DO jobs = sladatqc%nsurfup + 1, sladatqc%nsurfup + isla 562 563 iobs = jobs - sladatqc%nsurfup 564 565 IF ( kt /= sladatqc%mstp(jobs) ) THEN 566 920 DO jobs = surfdataqc%nsurfup + 1, surfdataqc%nsurfup + isurf 921 922 iobs = jobs - surfdataqc%nsurfup 923 924 IF ( kt /= surfdataqc%mstp(jobs) ) THEN 925 567 926 IF(lwp) THEN 568 927 WRITE(numout,*) … … 574 933 WRITE(numout,*) ' Record = ', jobs, & 575 934 & ' kt = ', kt, & 576 & ' mstp = ', s ladatqc%mstp(jobs), &577 & ' ntyp = ', s ladatqc%ntyp(jobs)935 & ' mstp = ', surfdataqc%mstp(jobs), & 936 & ' ntyp = ', surfdataqc%ntyp(jobs) 578 937 ENDIF 579 CALL ctl_stop( 'obs_sla_opt', 'Inconsistent time' ) 580 581 ENDIF 582 583 zlam = sladatqc%rlam(jobs) 584 zphi = sladatqc%rphi(jobs) 585 586 ! Get weights to interpolate the model SSH to the observation point 587 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 588 & zglam(:,:,iobs), zgphi(:,:,iobs), & 589 & zmask(:,:,iobs), zweig, zobsmask ) 590 591 592 ! Interpolate the model SSH to the observation point 593 CALL obs_int_h2d( 1, 1, & 594 & zweig, zsshl(:,:,iobs), zext ) 595 596 sladatqc%rext(jobs,1) = zext(1) 597 ! ... Remove the MDT at the observation point 598 sladatqc%rmod(jobs,1) = sladatqc%rext(jobs,1) - sladatqc%rext(jobs,2) 938 CALL ctl_stop( 'obs_surf_opt', 'Inconsistent time' ) 939 940 ENDIF 941 942 zlam = surfdataqc%rlam(jobs) 943 zphi = surfdataqc%rphi(jobs) 944 945 IF ( ldnightav .AND. idayend == 0 ) THEN 946 ! Night-time averaged data 947 zsurftmp(:,:,iobs) = zsurfm(:,:,iobs) 948 ELSE 949 zsurftmp(:,:,iobs) = zsurf(:,:,iobs) 950 ENDIF 951 952 IF ( k2dint <= 4 ) THEN 953 954 ! Get weights to interpolate the model value to the observation point 955 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 956 & zglam(:,:,iobs), zgphi(:,:,iobs), & 957 & zmask(:,:,iobs), zweig, zobsmask ) 958 959 ! Interpolate the model value to the observation point 960 CALL obs_int_h2d( 1, 1, zweig, zsurftmp(:,:,iobs), zext ) 961 962 ELSE 963 964 ! Get weights to average the model SLA to the observation footprint 965 CALL obs_avg_h2d_init( 1, 1, imaxifp, imaxjfp, k2dint, zlam, zphi, & 966 & zglam(:,:,iobs), zgphi(:,:,iobs), & 967 & zglamf(:,:,iobs), zgphif(:,:,iobs), & 968 & zmask(:,:,iobs), plamscl, pphiscl, & 969 & lindegrees, zweig, zobsmask ) 970 971 ! Average the model SST to the observation footprint 972 CALL obs_avg_h2d( 1, 1, imaxifp, imaxjfp, & 973 & zweig, zsurftmp(:,:,iobs), zext ) 974 975 ENDIF 976 977 IF ( TRIM(surfdataqc%cvars(1)) == 'SLA' .AND. surfdataqc%nextra == 2 ) THEN 978 ! ... Remove the MDT from the SSH at the observation point to get the SLA 979 surfdataqc%rext(jobs,1) = zext(1) 980 surfdataqc%rmod(jobs,1) = surfdataqc%rext(jobs,1) - surfdataqc%rext(jobs,2) 981 ELSE 982 surfdataqc%rmod(jobs,1) = zext(1) 983 ENDIF 599 984 600 985 END DO … … 602 987 ! Deallocate the data for interpolation 603 988 DEALLOCATE( & 989 & zweig, & 604 990 & igrdi, & 605 991 & igrdj, & … … 607 993 & zgphi, & 608 994 & zmask, & 609 & zsshl & 995 & zsurf, & 996 & zsurftmp, & 997 & zglamf, & 998 & zgphif, & 999 & igrdip1,& 1000 & igrdjp1 & 610 1001 & ) 611 1002 612 sladatqc%nsurfup = sladatqc%nsurfup + isla 613 614 END SUBROUTINE obs_sla_opt 615 616 SUBROUTINE obs_sst_opt( sstdatqc, kt, kpi, kpj, kit000, kdaystp, & 617 & psstn, psstmask, k2dint, ld_nightav ) 618 !!----------------------------------------------------------------------- 619 !! 620 !! *** ROUTINE obs_sst_opt *** 621 !! 622 !! ** Purpose : Compute the model counterpart of surface temperature 623 !! data by interpolating from the model grid to the 624 !! observation point. 625 !! 626 !! ** Method : Linearly interpolate to each observation point using 627 !! the model values at the corners of the surrounding grid box. 628 !! 629 !! The now model SST is first computed at the obs (lon, lat) point. 630 !! 631 !! Several horizontal interpolation schemes are available: 632 !! - distance-weighted (great circle) (k2dint = 0) 633 !! - distance-weighted (small angle) (k2dint = 1) 634 !! - bilinear (geographical grid) (k2dint = 2) 635 !! - bilinear (quadrilateral grid) (k2dint = 3) 636 !! - polynomial (quadrilateral grid) (k2dint = 4) 637 !! 638 !! 639 !! ** Action : 640 !! 641 !! History : 642 !! ! 07-07 (S. Ricci ) : Original 643 !! 644 !!----------------------------------------------------------------------- 645 646 !! * Modules used 647 USE obs_surf_def ! Definition of storage space for surface observations 648 USE sbcdcy 649 650 IMPLICIT NONE 651 652 !! * Arguments 653 TYPE(obs_surf), INTENT(INOUT) :: & 654 & sstdatqc ! Subset of surface data not failing screening 655 INTEGER, INTENT(IN) :: kt ! Time step 656 INTEGER, INTENT(IN) :: kpi ! Model grid parameters 657 INTEGER, INTENT(IN) :: kpj 658 INTEGER, INTENT(IN) :: kit000 ! Number of the first time step 659 ! (kit000-1 = restart time) 660 INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation type (see header) 661 INTEGER, INTENT(IN) :: kdaystp ! Number of time steps per day 662 REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 663 & psstn, & ! Model SST field 664 & psstmask ! Land-sea mask 665 666 !! * Local declarations 667 INTEGER :: ji 668 INTEGER :: jj 669 INTEGER :: jobs 670 INTEGER :: inrc 671 INTEGER :: isst 672 INTEGER :: iobs 673 INTEGER :: idayend 674 REAL(KIND=wp) :: zlam 675 REAL(KIND=wp) :: zphi 676 REAL(KIND=wp) :: zext(1), zobsmask(1) 677 REAL(KIND=wp) :: zdaystp 678 INTEGER, DIMENSION(:,:), SAVE, ALLOCATABLE :: & 679 & icount_sstnight, & 680 & imask_night 681 REAL(kind=wp), DIMENSION(:,:), SAVE, ALLOCATABLE :: & 682 & zintmp, & 683 & zouttmp, & 684 & zmeanday ! to compute model sst in region of 24h daylight (pole) 685 REAL(kind=wp), DIMENSION(2,2,1) :: & 686 & zweig 687 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 688 & zmask, & 689 & zsstl, & 690 & zsstm, & 691 & zglam, & 692 & zgphi 693 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 694 & igrdi, & 695 & igrdj 696 LOGICAL, INTENT(IN) :: ld_nightav 697 698 !----------------------------------------------------------------------- 699 ! Local initialization 700 !----------------------------------------------------------------------- 701 ! ... Record and data counters 702 inrc = kt - kit000 + 2 703 isst = sstdatqc%nsstp(inrc) 704 705 IF ( ld_nightav ) THEN 706 707 ! Initialize array for night mean 708 709 IF ( kt .EQ. 0 ) THEN 710 ALLOCATE ( icount_sstnight(kpi,kpj) ) 711 ALLOCATE ( imask_night(kpi,kpj) ) 712 ALLOCATE ( zintmp(kpi,kpj) ) 713 ALLOCATE ( zouttmp(kpi,kpj) ) 714 ALLOCATE ( zmeanday(kpi,kpj) ) 715 nday_qsr = -1 ! initialisation flag for nbc_dcy 716 ENDIF 717 718 ! Initialize daily mean for first timestep 719 idayend = MOD( kt - kit000 + 1, kdaystp ) 720 721 ! Added kt == 0 test to catch restart case 722 IF ( idayend == 1 .OR. kt == 0) THEN 723 IF (lwp) WRITE(numout,*) 'Reset sstdatqc%vdmean on time-step: ',kt 724 DO jj = 1, jpj 725 DO ji = 1, jpi 726 sstdatqc%vdmean(ji,jj) = 0.0 727 zmeanday(ji,jj) = 0.0 728 icount_sstnight(ji,jj) = 0 729 END DO 730 END DO 731 ENDIF 732 733 zintmp(:,:) = 0.0 734 zouttmp(:,:) = sbc_dcy( zintmp(:,:), .TRUE. ) 735 imask_night(:,:) = INT( zouttmp(:,:) ) 736 737 DO jj = 1, jpj 738 DO ji = 1, jpi 739 ! Increment the temperature field for computing night mean and counter 740 sstdatqc%vdmean(ji,jj) = sstdatqc%vdmean(ji,jj) & 741 & + psstn(ji,jj)*imask_night(ji,jj) 742 zmeanday(ji,jj) = zmeanday(ji,jj) + psstn(ji,jj) 743 icount_sstnight(ji,jj) = icount_sstnight(ji,jj) + imask_night(ji,jj) 744 END DO 745 END DO 746 747 ! Compute the daily mean at the end of day 748 749 zdaystp = 1.0 / REAL( kdaystp ) 750 751 IF ( idayend == 0 ) THEN 752 DO jj = 1, jpj 753 DO ji = 1, jpi 754 ! Test if "no night" point 755 IF ( icount_sstnight(ji,jj) .NE. 0 ) THEN 756 sstdatqc%vdmean(ji,jj) = sstdatqc%vdmean(ji,jj) & 757 & / icount_sstnight(ji,jj) 758 ELSE 759 sstdatqc%vdmean(ji,jj) = zmeanday(ji,jj) * zdaystp 760 ENDIF 761 END DO 762 END DO 763 ENDIF 764 765 ENDIF 766 767 ! Get the data for interpolation 768 769 ALLOCATE( & 770 & igrdi(2,2,isst), & 771 & igrdj(2,2,isst), & 772 & zglam(2,2,isst), & 773 & zgphi(2,2,isst), & 774 & zmask(2,2,isst), & 775 & zsstl(2,2,isst) & 776 & ) 777 778 DO jobs = sstdatqc%nsurfup + 1, sstdatqc%nsurfup + isst 779 iobs = jobs - sstdatqc%nsurfup 780 igrdi(1,1,iobs) = sstdatqc%mi(jobs)-1 781 igrdj(1,1,iobs) = sstdatqc%mj(jobs)-1 782 igrdi(1,2,iobs) = sstdatqc%mi(jobs)-1 783 igrdj(1,2,iobs) = sstdatqc%mj(jobs) 784 igrdi(2,1,iobs) = sstdatqc%mi(jobs) 785 igrdj(2,1,iobs) = sstdatqc%mj(jobs)-1 786 igrdi(2,2,iobs) = sstdatqc%mi(jobs) 787 igrdj(2,2,iobs) = sstdatqc%mj(jobs) 788 END DO 789 790 CALL obs_int_comm_2d( 2, 2, isst, & 791 & igrdi, igrdj, glamt, zglam ) 792 CALL obs_int_comm_2d( 2, 2, isst, & 793 & igrdi, igrdj, gphit, zgphi ) 794 CALL obs_int_comm_2d( 2, 2, isst, & 795 & igrdi, igrdj, psstmask, zmask ) 796 CALL obs_int_comm_2d( 2, 2, isst, & 797 & igrdi, igrdj, psstn, zsstl ) 798 799 ! At the end of the day get interpolated means 800 IF ( idayend == 0 .AND. ld_nightav ) THEN 801 802 ALLOCATE( & 803 & zsstm(2,2,isst) & 804 & ) 805 806 CALL obs_int_comm_2d( 2, 2, isst, igrdi, igrdj, & 807 & sstdatqc%vdmean(:,:), zsstm ) 808 809 ENDIF 810 811 ! Loop over observations 812 813 DO jobs = sstdatqc%nsurfup + 1, sstdatqc%nsurfup + isst 814 815 iobs = jobs - sstdatqc%nsurfup 816 817 IF ( kt /= sstdatqc%mstp(jobs) ) THEN 818 819 IF(lwp) THEN 820 WRITE(numout,*) 821 WRITE(numout,*) ' E R R O R : Observation', & 822 & ' time step is not consistent with the', & 823 & ' model time step' 824 WRITE(numout,*) ' =========' 825 WRITE(numout,*) 826 WRITE(numout,*) ' Record = ', jobs, & 827 & ' kt = ', kt, & 828 & ' mstp = ', sstdatqc%mstp(jobs), & 829 & ' ntyp = ', sstdatqc%ntyp(jobs) 830 ENDIF 831 CALL ctl_stop( 'obs_sst_opt', 'Inconsistent time' ) 832 833 ENDIF 834 835 zlam = sstdatqc%rlam(jobs) 836 zphi = sstdatqc%rphi(jobs) 837 838 ! Get weights to interpolate the model SST to the observation point 839 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 840 & zglam(:,:,iobs), zgphi(:,:,iobs), & 841 & zmask(:,:,iobs), zweig, zobsmask ) 842 843 ! Interpolate the model SST to the observation point 844 845 IF ( ld_nightav ) THEN 846 847 IF ( idayend == 0 ) THEN 848 ! Daily averaged/diurnal cycle of SST data 849 CALL obs_int_h2d( 1, 1, & 850 & zweig, zsstm(:,:,iobs), zext ) 851 ELSE 852 CALL ctl_stop( ' ld_nightav is set to true: a nonzero' // & 853 & ' number of night SST data should' // & 854 & ' only occur at the end of a given day' ) 855 ENDIF 856 857 ELSE 858 859 CALL obs_int_h2d( 1, 1, & 860 & zweig, zsstl(:,:,iobs), zext ) 861 862 ENDIF 863 sstdatqc%rmod(jobs,1) = zext(1) 864 865 END DO 866 867 ! Deallocate the data for interpolation 868 DEALLOCATE( & 869 & igrdi, & 870 & igrdj, & 871 & zglam, & 872 & zgphi, & 873 & zmask, & 874 & zsstl & 875 & ) 876 877 ! At the end of the day also get interpolated means 878 IF ( idayend == 0 .AND. ld_nightav ) THEN 1003 ! At the end of the day also deallocate night-time mean array 1004 IF ( idayend == 0 .AND. ldnightav ) THEN 879 1005 DEALLOCATE( & 880 & zs stm &1006 & zsurfm & 881 1007 & ) 882 1008 ENDIF 883 884 sstdatqc%nsurfup = sstdatqc%nsurfup + isst 885 886 END SUBROUTINE obs_sst_opt 887 888 SUBROUTINE obs_sss_opt 889 !!----------------------------------------------------------------------- 890 !! 891 !! *** ROUTINE obs_sss_opt *** 892 !! 893 !! ** Purpose : Compute the model counterpart of sea surface salinity 894 !! data by interpolating from the model grid to the 895 !! observation point. 896 !! 897 !! ** Method : 898 !! 899 !! ** Action : 900 !! 901 !! History : 902 !! ! ??-?? 903 !!----------------------------------------------------------------------- 904 905 IMPLICIT NONE 906 907 END SUBROUTINE obs_sss_opt 908 909 SUBROUTINE obs_seaice_opt( seaicedatqc, kt, kpi, kpj, kit000, & 910 & pseaicen, pseaicemask, k2dint ) 911 912 !!----------------------------------------------------------------------- 913 !! 914 !! *** ROUTINE obs_seaice_opt *** 915 !! 916 !! ** Purpose : Compute the model counterpart of surface temperature 917 !! data by interpolating from the model grid to the 918 !! observation point. 919 !! 920 !! ** Method : Linearly interpolate to each observation point using 921 !! the model values at the corners of the surrounding grid box. 922 !! 923 !! The now model sea ice is first computed at the obs (lon, lat) point. 924 !! 925 !! Several horizontal interpolation schemes are available: 926 !! - distance-weighted (great circle) (k2dint = 0) 927 !! - distance-weighted (small angle) (k2dint = 1) 928 !! - bilinear (geographical grid) (k2dint = 2) 929 !! - bilinear (quadrilateral grid) (k2dint = 3) 930 !! - polynomial (quadrilateral grid) (k2dint = 4) 931 !! 932 !! 933 !! ** Action : 934 !! 935 !! History : 936 !! ! 07-07 (S. Ricci ) : Original 937 !! 938 !!----------------------------------------------------------------------- 939 940 !! * Modules used 941 USE obs_surf_def ! Definition of storage space for surface observations 942 943 IMPLICIT NONE 944 945 !! * Arguments 946 TYPE(obs_surf), INTENT(INOUT) :: seaicedatqc ! Subset of surface data not failing screening 947 INTEGER, INTENT(IN) :: kt ! Time step 948 INTEGER, INTENT(IN) :: kpi ! Model grid parameters 949 INTEGER, INTENT(IN) :: kpj 950 INTEGER, INTENT(IN) :: kit000 ! Number of the first time step 951 ! (kit000-1 = restart time) 952 INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation type (see header) 953 REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 954 & pseaicen, & ! Model sea ice field 955 & pseaicemask ! Land-sea mask 956 957 !! * Local declarations 958 INTEGER :: ji 959 INTEGER :: jj 960 INTEGER :: jobs 961 INTEGER :: inrc 962 INTEGER :: iseaice 963 INTEGER :: iobs 964 965 REAL(KIND=wp) :: zlam 966 REAL(KIND=wp) :: zphi 967 REAL(KIND=wp) :: zext(1), zobsmask(1) 968 REAL(kind=wp), DIMENSION(2,2,1) :: & 969 & zweig 970 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 971 & zmask, & 972 & zseaicel, & 973 & zglam, & 974 & zgphi 975 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 976 & igrdi, & 977 & igrdj 978 979 !------------------------------------------------------------------------ 980 ! Local initialization 981 !------------------------------------------------------------------------ 982 ! ... Record and data counters 983 inrc = kt - kit000 + 2 984 iseaice = seaicedatqc%nsstp(inrc) 985 986 ! Get the data for interpolation 987 988 ALLOCATE( & 989 & igrdi(2,2,iseaice), & 990 & igrdj(2,2,iseaice), & 991 & zglam(2,2,iseaice), & 992 & zgphi(2,2,iseaice), & 993 & zmask(2,2,iseaice), & 994 & zseaicel(2,2,iseaice) & 995 & ) 996 997 DO jobs = seaicedatqc%nsurfup + 1, seaicedatqc%nsurfup + iseaice 998 iobs = jobs - seaicedatqc%nsurfup 999 igrdi(1,1,iobs) = seaicedatqc%mi(jobs)-1 1000 igrdj(1,1,iobs) = seaicedatqc%mj(jobs)-1 1001 igrdi(1,2,iobs) = seaicedatqc%mi(jobs)-1 1002 igrdj(1,2,iobs) = seaicedatqc%mj(jobs) 1003 igrdi(2,1,iobs) = seaicedatqc%mi(jobs) 1004 igrdj(2,1,iobs) = seaicedatqc%mj(jobs)-1 1005 igrdi(2,2,iobs) = seaicedatqc%mi(jobs) 1006 igrdj(2,2,iobs) = seaicedatqc%mj(jobs) 1007 END DO 1008 1009 CALL obs_int_comm_2d( 2, 2, iseaice, & 1010 & igrdi, igrdj, glamt, zglam ) 1011 CALL obs_int_comm_2d( 2, 2, iseaice, & 1012 & igrdi, igrdj, gphit, zgphi ) 1013 CALL obs_int_comm_2d( 2, 2, iseaice, & 1014 & igrdi, igrdj, pseaicemask, zmask ) 1015 CALL obs_int_comm_2d( 2, 2, iseaice, & 1016 & igrdi, igrdj, pseaicen, zseaicel ) 1017 1018 DO jobs = seaicedatqc%nsurfup + 1, seaicedatqc%nsurfup + iseaice 1019 1020 iobs = jobs - seaicedatqc%nsurfup 1021 1022 IF ( kt /= seaicedatqc%mstp(jobs) ) THEN 1023 1024 IF(lwp) THEN 1025 WRITE(numout,*) 1026 WRITE(numout,*) ' E R R O R : Observation', & 1027 & ' time step is not consistent with the', & 1028 & ' model time step' 1029 WRITE(numout,*) ' =========' 1030 WRITE(numout,*) 1031 WRITE(numout,*) ' Record = ', jobs, & 1032 & ' kt = ', kt, & 1033 & ' mstp = ', seaicedatqc%mstp(jobs), & 1034 & ' ntyp = ', seaicedatqc%ntyp(jobs) 1035 ENDIF 1036 CALL ctl_stop( 'obs_seaice_opt', 'Inconsistent time' ) 1037 1038 ENDIF 1039 1040 zlam = seaicedatqc%rlam(jobs) 1041 zphi = seaicedatqc%rphi(jobs) 1042 1043 ! Get weights to interpolate the model sea ice to the observation point 1044 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 1045 & zglam(:,:,iobs), zgphi(:,:,iobs), & 1046 & zmask(:,:,iobs), zweig, zobsmask ) 1047 1048 ! ... Interpolate the model sea ice to the observation point 1049 CALL obs_int_h2d( 1, 1, & 1050 & zweig, zseaicel(:,:,iobs), zext ) 1051 1052 seaicedatqc%rmod(jobs,1) = zext(1) 1053 1054 END DO 1055 1056 ! Deallocate the data for interpolation 1057 DEALLOCATE( & 1058 & igrdi, & 1059 & igrdj, & 1060 & zglam, & 1061 & zgphi, & 1062 & zmask, & 1063 & zseaicel & 1064 & ) 1065 1066 seaicedatqc%nsurfup = seaicedatqc%nsurfup + iseaice 1067 1068 END SUBROUTINE obs_seaice_opt 1069 1070 SUBROUTINE obs_vel_opt( prodatqc, kt, kpi, kpj, kpk, kit000, kdaystp, & 1071 & pun, pvn, pgdept, pumask, pvmask, k1dint, k2dint, & 1072 & ld_dailyav ) 1073 !!----------------------------------------------------------------------- 1074 !! 1075 !! *** ROUTINE obs_vel_opt *** 1076 !! 1077 !! ** Purpose : Compute the model counterpart of velocity profile 1078 !! data by interpolating from the model grid to the 1079 !! observation point. 1080 !! 1081 !! ** Method : Linearly interpolate zonal and meridional components of velocity 1082 !! to each observation point using the model values at the corners of 1083 !! the surrounding grid box. The model velocity components are on a 1084 !! staggered C- grid. 1085 !! 1086 !! For velocity data from the TAO array, the model equivalent is 1087 !! a daily mean velocity field. So, we first compute 1088 !! the mean, then interpolate only at the end of the day. 1089 !! 1090 !! ** Action : 1091 !! 1092 !! History : 1093 !! ! 07-03 (K. Mogensen) : Temperature and Salinity profiles 1094 !! ! 08-10 (Maria Valdivieso) : Velocity component (U,V) profiles 1095 !!----------------------------------------------------------------------- 1096 1097 !! * Modules used 1098 USE obs_profiles_def ! Definition of storage space for profile obs. 1099 1100 IMPLICIT NONE 1101 1102 !! * Arguments 1103 TYPE(obs_prof), INTENT(INOUT) :: & 1104 & prodatqc ! Subset of profile data not failing screening 1105 INTEGER, INTENT(IN) :: kt ! Time step 1106 INTEGER, INTENT(IN) :: kpi ! Model grid parameters 1107 INTEGER, INTENT(IN) :: kpj 1108 INTEGER, INTENT(IN) :: kpk 1109 INTEGER, INTENT(IN) :: kit000 ! Number of the first time step 1110 ! (kit000-1 = restart time) 1111 INTEGER, INTENT(IN) :: k1dint ! Vertical interpolation type (see header) 1112 INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation type (see header) 1113 INTEGER, INTENT(IN) :: kdaystp ! Number of time steps per day 1114 REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 1115 & pun, & ! Model zonal component of velocity 1116 & pvn, & ! Model meridional component of velocity 1117 & pumask, & ! Land-sea mask 1118 & pvmask ! Land-sea mask 1119 REAL(KIND=wp), INTENT(IN), DIMENSION(kpk) :: & 1120 & pgdept ! Model array of depth levels 1121 LOGICAL, INTENT(IN) :: ld_dailyav 1122 1123 !! * Local declarations 1124 INTEGER :: ji 1125 INTEGER :: jj 1126 INTEGER :: jk 1127 INTEGER :: jobs 1128 INTEGER :: inrc 1129 INTEGER :: ipro 1130 INTEGER :: idayend 1131 INTEGER :: ista 1132 INTEGER :: iend 1133 INTEGER :: iobs 1134 INTEGER, DIMENSION(imaxavtypes) :: & 1135 & idailyavtypes 1136 REAL(KIND=wp) :: zlam 1137 REAL(KIND=wp) :: zphi 1138 REAL(KIND=wp) :: zdaystp 1139 REAL(KIND=wp), DIMENSION(kpk) :: & 1140 & zobsmasku, & 1141 & zobsmaskv, & 1142 & zobsmask, & 1143 & zobsk, & 1144 & zobs2k 1145 REAL(KIND=wp), DIMENSION(2,2,kpk) :: & 1146 & zweigu,zweigv 1147 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 1148 & zumask, zvmask, & 1149 & zintu, & 1150 & zintv, & 1151 & zinmu, & 1152 & zinmv 1153 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 1154 & zglamu, zglamv, & 1155 & zgphiu, zgphiv 1156 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 1157 & igrdiu, & 1158 & igrdju, & 1159 & igrdiv, & 1160 & igrdjv 1161 1162 !------------------------------------------------------------------------ 1163 ! Local initialization 1164 !------------------------------------------------------------------------ 1165 ! ... Record and data counters 1166 inrc = kt - kit000 + 2 1167 ipro = prodatqc%npstp(inrc) 1168 1169 ! Initialize daily mean for first timestep 1170 idayend = MOD( kt - kit000 + 1, kdaystp ) 1171 1172 ! Added kt == 0 test to catch restart case 1173 IF ( idayend == 1 .OR. kt == 0) THEN 1174 IF (lwp) WRITE(numout,*) 'Reset prodatqc%vdmean on time-step: ',kt 1175 prodatqc%vdmean(:,:,:,1) = 0.0 1176 prodatqc%vdmean(:,:,:,2) = 0.0 1177 ENDIF 1178 1179 ! Increment the zonal velocity field for computing daily mean 1180 prodatqc%vdmean(:,:,:,1) = prodatqc%vdmean(:,:,:,1) + pun(:,:,:) 1181 ! Increment the meridional velocity field for computing daily mean 1182 prodatqc%vdmean(:,:,:,2) = prodatqc%vdmean(:,:,:,2) + pvn(:,:,:) 1183 1184 ! Compute the daily mean at the end of day 1185 zdaystp = 1.0 / REAL( kdaystp ) 1186 IF ( idayend == 0 ) THEN 1187 prodatqc%vdmean(:,:,:,1) = prodatqc%vdmean(:,:,:,1) * zdaystp 1188 prodatqc%vdmean(:,:,:,2) = prodatqc%vdmean(:,:,:,2) * zdaystp 1189 ENDIF 1190 1191 ! Get the data for interpolation 1192 ALLOCATE( & 1193 & igrdiu(2,2,ipro), & 1194 & igrdju(2,2,ipro), & 1195 & igrdiv(2,2,ipro), & 1196 & igrdjv(2,2,ipro), & 1197 & zglamu(2,2,ipro), zglamv(2,2,ipro), & 1198 & zgphiu(2,2,ipro), zgphiv(2,2,ipro), & 1199 & zumask(2,2,kpk,ipro), zvmask(2,2,kpk,ipro), & 1200 & zintu(2,2,kpk,ipro), & 1201 & zintv(2,2,kpk,ipro) & 1202 & ) 1203 1204 DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro 1205 iobs = jobs - prodatqc%nprofup 1206 igrdiu(1,1,iobs) = prodatqc%mi(jobs,1)-1 1207 igrdju(1,1,iobs) = prodatqc%mj(jobs,1)-1 1208 igrdiu(1,2,iobs) = prodatqc%mi(jobs,1)-1 1209 igrdju(1,2,iobs) = prodatqc%mj(jobs,1) 1210 igrdiu(2,1,iobs) = prodatqc%mi(jobs,1) 1211 igrdju(2,1,iobs) = prodatqc%mj(jobs,1)-1 1212 igrdiu(2,2,iobs) = prodatqc%mi(jobs,1) 1213 igrdju(2,2,iobs) = prodatqc%mj(jobs,1) 1214 igrdiv(1,1,iobs) = prodatqc%mi(jobs,2)-1 1215 igrdjv(1,1,iobs) = prodatqc%mj(jobs,2)-1 1216 igrdiv(1,2,iobs) = prodatqc%mi(jobs,2)-1 1217 igrdjv(1,2,iobs) = prodatqc%mj(jobs,2) 1218 igrdiv(2,1,iobs) = prodatqc%mi(jobs,2) 1219 igrdjv(2,1,iobs) = prodatqc%mj(jobs,2)-1 1220 igrdiv(2,2,iobs) = prodatqc%mi(jobs,2) 1221 igrdjv(2,2,iobs) = prodatqc%mj(jobs,2) 1222 END DO 1223 1224 CALL obs_int_comm_2d( 2, 2, ipro, igrdiu, igrdju, glamu, zglamu ) 1225 CALL obs_int_comm_2d( 2, 2, ipro, igrdiu, igrdju, gphiu, zgphiu ) 1226 CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdiu, igrdju, pumask, zumask ) 1227 CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdiu, igrdju, pun, zintu ) 1228 1229 CALL obs_int_comm_2d( 2, 2, ipro, igrdiv, igrdjv, glamv, zglamv ) 1230 CALL obs_int_comm_2d( 2, 2, ipro, igrdiv, igrdjv, gphiv, zgphiv ) 1231 CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdiv, igrdjv, pvmask, zvmask ) 1232 CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdiv, igrdjv, pvn, zintv ) 1233 1234 ! At the end of the day also get interpolated means 1235 IF ( idayend == 0 ) THEN 1236 1237 ALLOCATE( & 1238 & zinmu(2,2,kpk,ipro), & 1239 & zinmv(2,2,kpk,ipro) & 1240 & ) 1241 1242 CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdiu, igrdju, & 1243 & prodatqc%vdmean(:,:,:,1), zinmu ) 1244 CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdiv, igrdjv, & 1245 & prodatqc%vdmean(:,:,:,2), zinmv ) 1246 1247 ENDIF 1248 1249 ! loop over observations 1250 1251 DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro 1252 1253 iobs = jobs - prodatqc%nprofup 1254 1255 IF ( kt /= prodatqc%mstp(jobs) ) THEN 1256 1257 IF(lwp) THEN 1258 WRITE(numout,*) 1259 WRITE(numout,*) ' E R R O R : Observation', & 1260 & ' time step is not consistent with the', & 1261 & ' model time step' 1262 WRITE(numout,*) ' =========' 1263 WRITE(numout,*) 1264 WRITE(numout,*) ' Record = ', jobs, & 1265 & ' kt = ', kt, & 1266 & ' mstp = ', prodatqc%mstp(jobs), & 1267 & ' ntyp = ', prodatqc%ntyp(jobs) 1268 ENDIF 1269 CALL ctl_stop( 'obs_pro_opt', 'Inconsistent time' ) 1270 ENDIF 1271 1272 zlam = prodatqc%rlam(jobs) 1273 zphi = prodatqc%rphi(jobs) 1274 1275 ! Initialize observation masks 1276 1277 zobsmasku(:) = 0.0 1278 zobsmaskv(:) = 0.0 1279 1280 ! Horizontal weights and vertical mask 1281 1282 IF ( prodatqc%npvend(jobs,1) > 0 ) THEN 1283 1284 CALL obs_int_h2d_init( kpk, kpk, k2dint, zlam, zphi, & 1285 & zglamu(:,:,iobs), zgphiu(:,:,iobs), & 1286 & zumask(:,:,:,iobs), zweigu, zobsmasku ) 1287 1288 ENDIF 1289 1290 1291 IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 1292 1293 CALL obs_int_h2d_init( kpk, kpk, k2dint, zlam, zphi, & 1294 & zglamv(:,:,iobs), zgphiv(:,:,iobs), & 1295 & zvmask(:,:,:,iobs), zweigv, zobsmasku ) 1296 1297 ENDIF 1298 1299 ! Ensure that the vertical mask on u and v are consistent. 1300 1301 zobsmask(:) = MIN( zobsmasku(:), zobsmaskv(:) ) 1302 1303 IF ( prodatqc%npvend(jobs,1) > 0 ) THEN 1304 1305 zobsk(:) = obfillflt 1306 1307 IF ( ld_dailyav ) THEN 1308 1309 IF ( idayend == 0 ) THEN 1310 1311 ! Daily averaged data 1312 1313 CALL obs_int_h2d( kpk, kpk, & 1314 & zweigu, zinmu(:,:,:,iobs), zobsk ) 1315 1316 1317 ELSE 1318 1319 CALL ctl_stop( ' A nonzero' // & 1320 & ' number of U profile data should' // & 1321 & ' only occur at the end of a given day' ) 1322 1323 ENDIF 1324 1325 ELSE 1326 1327 ! Point data 1328 1329 CALL obs_int_h2d( kpk, kpk, & 1330 & zweigu, zintu(:,:,:,iobs), zobsk ) 1331 1332 ENDIF 1333 1334 !------------------------------------------------------------- 1335 ! Compute vertical second-derivative of the interpolating 1336 ! polynomial at obs points 1337 !------------------------------------------------------------- 1338 1339 IF ( k1dint == 1 ) THEN 1340 CALL obs_int_z1d_spl( kpk, zobsk, zobs2k, & 1341 & pgdept, zobsmask ) 1342 ENDIF 1343 1344 !----------------------------------------------------------------- 1345 ! Vertical interpolation to the observation point 1346 !----------------------------------------------------------------- 1347 ista = prodatqc%npvsta(jobs,1) 1348 iend = prodatqc%npvend(jobs,1) 1349 CALL obs_int_z1d( kpk, & 1350 & prodatqc%var(1)%mvk(ista:iend), & 1351 & k1dint, iend - ista + 1, & 1352 & prodatqc%var(1)%vdep(ista:iend), & 1353 & zobsk, zobs2k, & 1354 & prodatqc%var(1)%vmod(ista:iend), & 1355 & pgdept, zobsmask ) 1356 1357 ENDIF 1358 1359 IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 1360 1361 zobsk(:) = obfillflt 1362 1363 IF ( ld_dailyav ) THEN 1364 1365 IF ( idayend == 0 ) THEN 1366 1367 ! Daily averaged data 1368 1369 CALL obs_int_h2d( kpk, kpk, & 1370 & zweigv, zinmv(:,:,:,iobs), zobsk ) 1371 1372 ELSE 1373 1374 CALL ctl_stop( ' A nonzero' // & 1375 & ' number of V profile data should' // & 1376 & ' only occur at the end of a given day' ) 1377 1378 ENDIF 1379 1380 ELSE 1381 1382 ! Point data 1383 1384 CALL obs_int_h2d( kpk, kpk, & 1385 & zweigv, zintv(:,:,:,iobs), zobsk ) 1386 1387 ENDIF 1388 1389 1390 !------------------------------------------------------------- 1391 ! Compute vertical second-derivative of the interpolating 1392 ! polynomial at obs points 1393 !------------------------------------------------------------- 1394 1395 IF ( k1dint == 1 ) THEN 1396 CALL obs_int_z1d_spl( kpk, zobsk, zobs2k, & 1397 & pgdept, zobsmask ) 1398 ENDIF 1399 1400 !---------------------------------------------------------------- 1401 ! Vertical interpolation to the observation point 1402 !---------------------------------------------------------------- 1403 ista = prodatqc%npvsta(jobs,2) 1404 iend = prodatqc%npvend(jobs,2) 1405 CALL obs_int_z1d( kpk, & 1406 & prodatqc%var(2)%mvk(ista:iend),& 1407 & k1dint, iend - ista + 1, & 1408 & prodatqc%var(2)%vdep(ista:iend),& 1409 & zobsk, zobs2k, & 1410 & prodatqc%var(2)%vmod(ista:iend),& 1411 & pgdept, zobsmask ) 1412 1413 ENDIF 1414 1415 END DO 1416 1417 ! Deallocate the data for interpolation 1418 DEALLOCATE( & 1419 & igrdiu, & 1420 & igrdju, & 1421 & igrdiv, & 1422 & igrdjv, & 1423 & zglamu, zglamv, & 1424 & zgphiu, zgphiv, & 1425 & zumask, zvmask, & 1426 & zintu, & 1427 & zintv & 1428 & ) 1429 ! At the end of the day also get interpolated means 1430 IF ( idayend == 0 ) THEN 1431 DEALLOCATE( & 1432 & zinmu, & 1433 & zinmv & 1434 & ) 1435 ENDIF 1436 1437 prodatqc%nprofup = prodatqc%nprofup + ipro 1438 1439 END SUBROUTINE obs_vel_opt 1009 1010 surfdataqc%nsurfup = surfdataqc%nsurfup + isurf 1011 1012 END SUBROUTINE obs_surf_opt 1440 1013 1441 1014 END MODULE obs_oper 1442 -
branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_prep.F90
r7960 r7992 7 7 8 8 !!--------------------------------------------------------------------- 9 !! obs_pre_pro : First level check and screening of T/S profiles 10 !! obs_pre_sla : First level check and screening of SLA observations 11 !! obs_pre_sst : First level check and screening of SLA observations 12 !! obs_pre_seaice : First level check and screening of sea ice observations 13 !! obs_pre_vel : First level check and screening of velocity obs. 14 !! obs_scr : Basic screening of the observations 15 !! obs_coo_tim : Compute number of time steps to the observation time 16 !! obs_sor : Sort the observation arrays 9 !! obs_pre_prof : First level check and screening of profile observations 10 !! obs_pre_surf : First level check and screening of surface observations 11 !! obs_scr : Basic screening of the observations 12 !! obs_coo_tim : Compute number of time steps to the observation time 13 !! obs_sor : Sort the observation arrays 17 14 !!--------------------------------------------------------------------- 18 15 !! * Modules used … … 27 24 USE obs_inter_sup ! Interpolation support 28 25 USE obs_oper ! Observation operators 26 #if defined key_bdy 27 USE bdy_oce, ONLY : & ! Boundary information 28 idx_bdy, nb_bdy 29 #endif 29 30 USE lib_mpp, ONLY : & 30 31 & ctl_warn, ctl_stop … … 36 37 37 38 PUBLIC & 38 & obs_pre_pro, & ! First level check and screening of profiles 39 & obs_pre_sla, & ! First level check and screening of SLA data 40 & obs_pre_sst, & ! First level check and screening of SLA data 41 & obs_pre_seaice, & ! First level check and screening of sea ice data 42 & obs_pre_vel, & ! First level check and screening of velocity profiles 43 & calc_month_len ! Calculate the number of days in the months of a year 39 & obs_pre_prof, & ! First level check and screening of profile obs 40 & obs_pre_surf, & ! First level check and screening of surface obs 41 & calc_month_len ! Calculate the number of days in the months of a year 44 42 45 43 !!---------------------------------------------------------------------- … … 49 47 !!---------------------------------------------------------------------- 50 48 49 !! * Substitutions 50 # include "domzgr_substitute.h90" 51 51 52 CONTAINS 52 53 53 SUBROUTINE obs_pre_pro( profdata, prodatqc, ld_t3d, ld_s3d, ld_nea, & 54 & kdailyavtypes ) 55 !!---------------------------------------------------------------------- 56 !! *** ROUTINE obs_pre_pro *** 57 !! 58 !! ** Purpose : First level check and screening of T and S profiles 59 !! 60 !! ** Method : First level check and screening of T and S profiles 61 !! 62 !! ** Action : 63 !! 64 !! References : 65 !! 66 !! History : 67 !! ! 2007-01 (K. Mogensen) Merge of obs_pre_t3d and obs_pre_s3d 68 !! ! 2007-03 (K. Mogensen) General handling of profiles 69 !! ! 2007-06 (K. Mogensen et al) Reject obs. near land. 70 !!---------------------------------------------------------------------- 71 !! * Modules used 72 USE domstp ! Domain: set the time-step 73 USE par_oce ! Ocean parameters 74 USE dom_oce, ONLY : & ! Geographical information 75 & glamt, & 76 & gphit, & 77 & gdept_1d,& 78 & tmask, & 79 & nproc 80 !! * Arguments 81 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data 82 TYPE(obs_prof), INTENT(INOUT) :: prodatqc ! Subset of profile data not failing screening 83 LOGICAL, INTENT(IN) :: ld_t3d ! Switch for temperature 84 LOGICAL, INTENT(IN) :: ld_s3d ! Switch for salinity 85 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 86 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 87 & kdailyavtypes! Types for daily averages 88 !! * Local declarations 89 INTEGER :: iyea0 ! Initial date 90 INTEGER :: imon0 ! - (year, month, day, hour, minute) 91 INTEGER :: iday0 92 INTEGER :: ihou0 93 INTEGER :: imin0 94 INTEGER :: icycle ! Current assimilation cycle 95 ! Counters for observations that 96 INTEGER :: iotdobs ! - outside time domain 97 INTEGER :: iosdtobs ! - outside space domain (temperature) 98 INTEGER :: iosdsobs ! - outside space domain (salinity) 99 INTEGER :: ilantobs ! - within a model land cell (temperature) 100 INTEGER :: ilansobs ! - within a model land cell (salinity) 101 INTEGER :: inlatobs ! - close to land (temperature) 102 INTEGER :: inlasobs ! - close to land (salinity) 103 INTEGER :: igrdobs ! - fail the grid search 104 ! Global counters for observations that 105 INTEGER :: iotdobsmpp ! - outside time domain 106 INTEGER :: iosdtobsmpp ! - outside space domain (temperature) 107 INTEGER :: iosdsobsmpp ! - outside space domain (salinity) 108 INTEGER :: ilantobsmpp ! - within a model land cell (temperature) 109 INTEGER :: ilansobsmpp ! - within a model land cell (salinity) 110 INTEGER :: inlatobsmpp ! - close to land (temperature) 111 INTEGER :: inlasobsmpp ! - close to land (salinity) 112 INTEGER :: igrdobsmpp ! - fail the grid search 113 TYPE(obs_prof_valid) :: llvalid ! Profile selection 114 TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & 115 & llvvalid ! T,S selection 116 INTEGER :: jvar ! Variable loop variable 117 INTEGER :: jobs ! Obs. loop variable 118 INTEGER :: jstp ! Time loop variable 119 INTEGER :: inrc ! Time index variable 120 121 IF(lwp) WRITE(numout,*)'obs_pre_pro : Preparing the profile observations...' 122 123 ! Initial date initialization (year, month, day, hour, minute) 124 iyea0 = ndate0 / 10000 125 imon0 = ( ndate0 - iyea0 * 10000 ) / 100 126 iday0 = ndate0 - iyea0 * 10000 - imon0 * 100 127 ihou0 = 0 128 imin0 = 0 129 130 icycle = no ! Assimilation cycle 131 132 ! Diagnotics counters for various failures. 133 134 iotdobs = 0 135 igrdobs = 0 136 iosdtobs = 0 137 iosdsobs = 0 138 ilantobs = 0 139 ilansobs = 0 140 inlatobs = 0 141 inlasobs = 0 142 143 ! ----------------------------------------------------------------------- 144 ! Find time coordinate for profiles 145 ! ----------------------------------------------------------------------- 146 147 IF ( PRESENT(kdailyavtypes) ) THEN 148 CALL obs_coo_tim_prof( icycle, & 149 & iyea0, imon0, iday0, ihou0, imin0, & 150 & profdata%nprof, profdata%nyea, profdata%nmon, & 151 & profdata%nday, profdata%nhou, profdata%nmin, & 152 & profdata%ntyp, profdata%nqc, profdata%mstp, & 153 & iotdobs, kdailyavtypes = kdailyavtypes ) 154 ELSE 155 CALL obs_coo_tim_prof( icycle, & 156 & iyea0, imon0, iday0, ihou0, imin0, & 157 & profdata%nprof, profdata%nyea, profdata%nmon, & 158 & profdata%nday, profdata%nhou, profdata%nmin, & 159 & profdata%ntyp, profdata%nqc, profdata%mstp, & 160 & iotdobs ) 161 ENDIF 162 CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) 163 164 ! ----------------------------------------------------------------------- 165 ! Check for profiles failing the grid search 166 ! ----------------------------------------------------------------------- 167 168 CALL obs_coo_grd( profdata%nprof, profdata%mi, profdata%mj, & 169 & profdata%nqc, igrdobs ) 170 171 CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) 172 173 ! ----------------------------------------------------------------------- 174 ! Reject all observations for profiles with nqc > 10 175 ! ----------------------------------------------------------------------- 176 177 CALL obs_pro_rej( profdata ) 178 179 ! ----------------------------------------------------------------------- 180 ! Check for land points. This includes points below the model 181 ! bathymetry so this is done for every point in the profile 182 ! ----------------------------------------------------------------------- 183 184 ! Temperature 185 186 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(1), & 187 & profdata%npvsta(:,1), profdata%npvend(:,1), & 188 & jpi, jpj, & 189 & jpk, & 190 & profdata%mi, profdata%mj, & 191 & profdata%var(1)%mvk, & 192 & profdata%rlam, profdata%rphi, & 193 & profdata%var(1)%vdep, & 194 & glamt, gphit, & 195 & gdept_1d, tmask, & 196 & profdata%nqc, profdata%var(1)%nvqc, & 197 & iosdtobs, ilantobs, & 198 & inlatobs, ld_nea ) 199 200 CALL obs_mpp_sum_integer( iosdtobs, iosdtobsmpp ) 201 CALL obs_mpp_sum_integer( ilantobs, ilantobsmpp ) 202 CALL obs_mpp_sum_integer( inlatobs, inlatobsmpp ) 203 204 ! Salinity 205 206 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(2), & 207 & profdata%npvsta(:,2), profdata%npvend(:,2), & 208 & jpi, jpj, & 209 & jpk, & 210 & profdata%mi, profdata%mj, & 211 & profdata%var(2)%mvk, & 212 & profdata%rlam, profdata%rphi, & 213 & profdata%var(2)%vdep, & 214 & glamt, gphit, & 215 & gdept_1d, tmask, & 216 & profdata%nqc, profdata%var(2)%nvqc, & 217 & iosdsobs, ilansobs, & 218 & inlasobs, ld_nea ) 219 220 CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) 221 CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) 222 CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) 223 224 ! ----------------------------------------------------------------------- 225 ! Copy useful data from the profdata data structure to 226 ! the prodatqc data structure 227 ! ----------------------------------------------------------------------- 228 229 ! Allocate the selection arrays 230 231 ALLOCATE( llvalid%luse(profdata%nprof) ) 232 DO jvar = 1,profdata%nvar 233 ALLOCATE( llvvalid(jvar)%luse(profdata%nvprot(jvar)) ) 234 END DO 235 236 ! We want all data which has qc flags <= 10 237 238 llvalid%luse(:) = ( profdata%nqc(:) <= 10 ) 239 DO jvar = 1,profdata%nvar 240 llvvalid(jvar)%luse(:) = ( profdata%var(jvar)%nvqc(:) <= 10 ) 241 END DO 242 243 ! The actual copying 244 245 CALL obs_prof_compress( profdata, prodatqc, .TRUE., numout, & 246 & lvalid=llvalid, lvvalid=llvvalid ) 247 248 ! Dellocate the selection arrays 249 DEALLOCATE( llvalid%luse ) 250 DO jvar = 1,profdata%nvar 251 DEALLOCATE( llvvalid(jvar)%luse ) 252 END DO 253 254 ! ----------------------------------------------------------------------- 255 ! Print information about what observations are left after qc 256 ! ----------------------------------------------------------------------- 257 258 ! Update the total observation counter array 259 260 IF(lwp) THEN 261 WRITE(numout,*) 262 WRITE(numout,*) 'obs_pre_pro :' 263 WRITE(numout,*) '~~~~~~~~~~~' 264 WRITE(numout,*) 265 WRITE(numout,*) ' Profiles outside time domain = ', & 266 & iotdobsmpp 267 WRITE(numout,*) ' Remaining profiles that failed grid search = ', & 268 & igrdobsmpp 269 WRITE(numout,*) ' Remaining T data outside space domain = ', & 270 & iosdtobsmpp 271 WRITE(numout,*) ' Remaining T data at land points = ', & 272 & ilantobsmpp 273 IF (ld_nea) THEN 274 WRITE(numout,*) ' Remaining T data near land points (removed) = ',& 275 & inlatobsmpp 276 ELSE 277 WRITE(numout,*) ' Remaining T data near land points (kept) = ',& 278 & inlatobsmpp 279 ENDIF 280 WRITE(numout,*) ' T data accepted = ', & 281 & prodatqc%nvprotmpp(1) 282 WRITE(numout,*) ' Remaining S data outside space domain = ', & 283 & iosdsobsmpp 284 WRITE(numout,*) ' Remaining S data at land points = ', & 285 & ilansobsmpp 286 IF (ld_nea) THEN 287 WRITE(numout,*) ' Remaining S data near land points (removed) = ',& 288 & inlasobsmpp 289 ELSE 290 WRITE(numout,*) ' Remaining S data near land points (kept) = ',& 291 & inlasobsmpp 292 ENDIF 293 WRITE(numout,*) ' S data accepted = ', & 294 & prodatqc%nvprotmpp(2) 295 296 WRITE(numout,*) 297 WRITE(numout,*) ' Number of observations per time step :' 298 WRITE(numout,*) 299 WRITE(numout,997) 300 WRITE(numout,998) 301 ENDIF 302 303 DO jobs = 1, prodatqc%nprof 304 inrc = prodatqc%mstp(jobs) + 2 - nit000 305 prodatqc%npstp(inrc) = prodatqc%npstp(inrc) + 1 306 DO jvar = 1, prodatqc%nvar 307 IF ( prodatqc%npvend(jobs,jvar) > 0 ) THEN 308 prodatqc%nvstp(inrc,jvar) = prodatqc%nvstp(inrc,jvar) + & 309 & ( prodatqc%npvend(jobs,jvar) - & 310 & prodatqc%npvsta(jobs,jvar) + 1 ) 311 ENDIF 312 END DO 313 END DO 314 315 316 CALL obs_mpp_sum_integers( prodatqc%npstp, prodatqc%npstpmpp, & 317 & nitend - nit000 + 2 ) 318 DO jvar = 1, prodatqc%nvar 319 CALL obs_mpp_sum_integers( prodatqc%nvstp(:,jvar), & 320 & prodatqc%nvstpmpp(:,jvar), & 321 & nitend - nit000 + 2 ) 322 END DO 323 324 IF ( lwp ) THEN 325 DO jstp = nit000 - 1, nitend 326 inrc = jstp - nit000 + 2 327 WRITE(numout,999) jstp, prodatqc%npstpmpp(inrc), & 328 & prodatqc%nvstpmpp(inrc,1), & 329 & prodatqc%nvstpmpp(inrc,2) 330 END DO 331 ENDIF 332 333 997 FORMAT(10X,'Time step',5X,'Profiles',5X,'Temperature',5X,'Salinity') 334 998 FORMAT(10X,'---------',5X,'--------',5X,'-----------',5X,'--------') 335 999 FORMAT(10X,I9,5X,I8,5X,I11,5X,I8) 336 337 END SUBROUTINE obs_pre_pro 338 339 SUBROUTINE obs_pre_sla( sladata, sladatqc, ld_sla, ld_nea ) 54 SUBROUTINE obs_pre_surf( surfdata, surfdataqc, ld_nea, ld_bound_reject, & 55 kqc_cutoff ) 340 56 !!---------------------------------------------------------------------- 341 57 !! *** ROUTINE obs_pre_sla *** 342 58 !! 343 !! ** Purpose : First level check and screening of SLAobservations344 !! 345 !! ** Method : First level check and screening of SLAobservations59 !! ** Purpose : First level check and screening of surface observations 60 !! 61 !! ** Method : First level check and screening of surface observations 346 62 !! 347 63 !! ** Action : … … 352 68 !! ! 2007-03 (A. Weaver, K. Mogensen) Original 353 69 !! ! 2007-06 (K. Mogensen et al) Reject obs. near land. 70 !! ! 2015-02 (M. Martin) Combined routine for surface types. 354 71 !!---------------------------------------------------------------------- 355 72 !! * Modules used … … 362 79 & nproc 363 80 !! * Arguments 364 TYPE(obs_surf), INTENT(INOUT) :: sladata ! Full set of SLA data 365 TYPE(obs_surf), INTENT(INOUT) :: sladatqc ! Subset of SLA data not failing screening 366 LOGICAL, INTENT(IN) :: ld_sla ! Switch for SLA data 367 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 81 TYPE(obs_surf), INTENT(INOUT) :: surfdata ! Full set of surface data 82 TYPE(obs_surf), INTENT(INOUT) :: surfdataqc ! Subset of surface data not failing screening 83 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 84 LOGICAL, INTENT(IN) :: ld_bound_reject ! Switch for rejecting obs near the boundary 85 INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff ! cut off for QC value 368 86 !! * Local declarations 87 INTEGER :: iqc_cutoff = 255 ! cut off for QC value 369 88 INTEGER :: iyea0 ! Initial date 370 89 INTEGER :: imon0 ! - (year, month, day, hour, minute) … … 379 98 INTEGER :: inlasobs ! - close to land 380 99 INTEGER :: igrdobs ! - fail the grid search 100 INTEGER :: ibdysobs ! - close to open boundary 381 101 ! Global counters for observations that 382 102 INTEGER :: iotdobsmpp ! - outside time domain … … 385 105 INTEGER :: inlasobsmpp ! - close to land 386 106 INTEGER :: igrdobsmpp ! - fail the grid search 107 INTEGER :: ibdysobsmpp ! - close to open boundary 387 108 LOGICAL, DIMENSION(:), ALLOCATABLE :: & 388 109 & llvalid ! SLA data selection … … 391 112 INTEGER :: inrc ! Time index variable 392 113 393 IF(lwp) WRITE(numout,*)'obs_pre_sla : Preparing the SLA observations...' 394 114 IF(lwp) WRITE(numout,*)'obs_pre_surf : Preparing the surface observations...' 115 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 116 395 117 ! Initial date initialization (year, month, day, hour, minute) 396 118 iyea0 = ndate0 / 10000 … … 409 131 ilansobs = 0 410 132 inlasobs = 0 411 412 ! ----------------------------------------------------------------------- 413 ! Find time coordinate for SLA data 133 ibdysobs = 0 134 135 ! Set QC cutoff to optional value if provided 136 IF ( PRESENT(kqc_cutoff) ) iqc_cutoff=kqc_cutoff 137 138 ! ----------------------------------------------------------------------- 139 ! Find time coordinate for surface data 414 140 ! ----------------------------------------------------------------------- 415 141 416 142 CALL obs_coo_tim( icycle, & 417 143 & iyea0, imon0, iday0, ihou0, imin0, & 418 & s ladata%nsurf, sladata%nyea, sladata%nmon, &419 & s ladata%nday, sladata%nhou, sladata%nmin, &420 & s ladata%nqc, sladata%mstp, iotdobs )144 & surfdata%nsurf, surfdata%nyea, surfdata%nmon, & 145 & surfdata%nday, surfdata%nhou, surfdata%nmin, & 146 & surfdata%nqc, surfdata%mstp, iotdobs ) 421 147 422 148 CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) 423 149 424 150 ! ----------------------------------------------------------------------- 425 ! Check for SLAdata failing the grid search426 ! ----------------------------------------------------------------------- 427 428 CALL obs_coo_grd( s ladata%nsurf, sladata%mi, sladata%mj, &429 & s ladata%nqc, igrdobs )151 ! Check for surface data failing the grid search 152 ! ----------------------------------------------------------------------- 153 154 CALL obs_coo_grd( surfdata%nsurf, surfdata%mi, surfdata%mj, & 155 & surfdata%nqc, igrdobs ) 430 156 431 157 CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) … … 435 161 ! ----------------------------------------------------------------------- 436 162 437 CALL obs_coo_spc_2d( s ladata%nsurf, &163 CALL obs_coo_spc_2d( surfdata%nsurf, & 438 164 & jpi, jpj, & 439 & s ladata%mi, sladata%mj, &440 & s ladata%rlam, sladata%rphi, &165 & surfdata%mi, surfdata%mj, & 166 & surfdata%rlam, surfdata%rphi, & 441 167 & glamt, gphit, & 442 & tmask(:,:,1), s ladata%nqc, &168 & tmask(:,:,1), surfdata%nqc, & 443 169 & iosdsobs, ilansobs, & 444 & inlasobs, ld_nea ) 170 & inlasobs, ld_nea, & 171 & ibdysobs, ld_bound_reject, & 172 & iqc_cutoff ) 445 173 446 174 CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) 447 175 CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) 448 176 CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) 449 450 ! ----------------------------------------------------------------------- 451 ! Copy useful data from the sladata data structure to 452 ! the sladatqc data structure 177 CALL obs_mpp_sum_integer( ibdysobs, ibdysobsmpp ) 178 179 ! ----------------------------------------------------------------------- 180 ! Copy useful data from the surfdata data structure to 181 ! the surfdataqc data structure 453 182 ! ----------------------------------------------------------------------- 454 183 455 184 ! Allocate the selection arrays 456 185 457 ALLOCATE( llvalid(s ladata%nsurf) )458 459 ! We want all data which has qc flags <= 10460 461 llvalid(:) = ( s ladata%nqc(:) <= 10)186 ALLOCATE( llvalid(surfdata%nsurf) ) 187 188 ! We want all data which has qc flags <= iqc_cutoff 189 190 llvalid(:) = ( surfdata%nqc(:) <= iqc_cutoff ) 462 191 463 192 ! The actual copying 464 193 465 CALL obs_surf_compress( s ladata, sladatqc, .TRUE., numout, &194 CALL obs_surf_compress( surfdata, surfdataqc, .TRUE., numout, & 466 195 & lvalid=llvalid ) 467 196 … … 477 206 IF(lwp) THEN 478 207 WRITE(numout,*) 479 WRITE(numout,*) 'obs_pre_sla :' 480 WRITE(numout,*) '~~~~~~~~~~~' 481 WRITE(numout,*) 482 WRITE(numout,*) ' SLA data outside time domain = ', & 208 WRITE(numout,*) ' '//surfdataqc%cvars(1)//' data outside time domain = ', & 483 209 & iotdobsmpp 484 WRITE(numout,*) ' Remaining SLAdata that failed grid search = ', &210 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data that failed grid search = ', & 485 211 & igrdobsmpp 486 WRITE(numout,*) ' Remaining SLAdata outside space domain = ', &212 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data outside space domain = ', & 487 213 & iosdsobsmpp 488 WRITE(numout,*) ' Remaining SLAdata at land points = ', &214 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data at land points = ', & 489 215 & ilansobsmpp 490 216 IF (ld_nea) THEN 491 WRITE(numout,*) ' Remaining SLAdata near land points (removed) = ', &217 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near land points (removed) = ', & 492 218 & inlasobsmpp 493 219 ELSE 494 WRITE(numout,*) ' Remaining SLAdata near land points (kept) = ', &220 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near land points (kept) = ', & 495 221 & inlasobsmpp 496 222 ENDIF 497 WRITE(numout,*) ' SLA data accepted = ', & 498 & sladatqc%nsurfmpp 223 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near open boundary (removed) = ', & 224 & ibdysobsmpp 225 WRITE(numout,*) ' '//surfdataqc%cvars(1)//' data accepted = ', & 226 & surfdataqc%nsurfmpp 499 227 500 228 WRITE(numout,*) 501 229 WRITE(numout,*) ' Number of observations per time step :' 502 230 WRITE(numout,*) 503 WRITE(numout,1997) 504 WRITE(numout,1998) 231 WRITE(numout,'(10X,A,10X,A)')'Time step',surfdataqc%cvars(1) 232 WRITE(numout,'(10X,A,5X,A)')'---------','-----------------' 233 CALL FLUSH(numout) 505 234 ENDIF 506 235 507 DO jobs = 1, s ladatqc%nsurf508 inrc = s ladatqc%mstp(jobs) + 2 - nit000509 s ladatqc%nsstp(inrc) = sladatqc%nsstp(inrc) + 1236 DO jobs = 1, surfdataqc%nsurf 237 inrc = surfdataqc%mstp(jobs) + 2 - nit000 238 surfdataqc%nsstp(inrc) = surfdataqc%nsstp(inrc) + 1 510 239 END DO 511 240 512 CALL obs_mpp_sum_integers( s ladatqc%nsstp, sladatqc%nsstpmpp, &241 CALL obs_mpp_sum_integers( surfdataqc%nsstp, surfdataqc%nsstpmpp, & 513 242 & nitend - nit000 + 2 ) 514 243 … … 516 245 DO jstp = nit000 - 1, nitend 517 246 inrc = jstp - nit000 + 2 518 WRITE(numout,1999) jstp, sladatqc%nsstpmpp(inrc) 247 WRITE(numout,1999) jstp, surfdataqc%nsstpmpp(inrc) 248 CALL FLUSH(numout) 519 249 END DO 520 250 ENDIF 521 251 522 1997 FORMAT(10X,'Time step',5X,'Sea level anomaly')523 1998 FORMAT(10X,'---------',5X,'-----------------')524 252 1999 FORMAT(10X,I9,5X,I17) 525 253 526 END SUBROUTINE obs_pre_sla 527 528 SUBROUTINE obs_pre_sst( sstdata, sstdatqc, ld_sst, ld_nea ) 529 !!---------------------------------------------------------------------- 530 !! *** ROUTINE obs_pre_sst *** 531 !! 532 !! ** Purpose : First level check and screening of SST observations 533 !! 534 !! ** Method : First level check and screening of SST observations 535 !! 536 !! ** Action : 537 !! 538 !! References : 539 !! 254 END SUBROUTINE obs_pre_surf 255 256 257 SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var1, ld_var2, & 258 & kpi, kpj, kpk, & 259 & zmask1, pglam1, pgphi1, zmask2, pglam2, pgphi2, & 260 & ld_nea, ld_bound_reject, kdailyavtypes, kqc_cutoff ) 261 262 !!---------------------------------------------------------------------- 263 !! *** ROUTINE obs_pre_prof *** 264 !! 265 !! ** Purpose : First level check and screening of profiles 266 !! 267 !! ** Method : First level check and screening of profiles 268 !! 540 269 !! History : 541 !! ! 2007-03 (S. Ricci) SST data preparation 270 !! ! 2007-06 (K. Mogensen) original : T and S profile data 271 !! ! 2008-09 (M. Valdivieso) : TAO velocity data 272 !! ! 2009-01 (K. Mogensen) : New feedback stricture 273 !! ! 2015-02 (M. Martin) : Combined profile routine. 274 !! 542 275 !!---------------------------------------------------------------------- 543 276 !! * Modules used … … 545 278 USE par_oce ! Ocean parameters 546 279 USE dom_oce, ONLY : & ! Geographical information 547 & glamt, & 548 & gphit, & 549 & tmask, & 280 & gdept_1d, & 550 281 & nproc 282 551 283 !! * Arguments 552 TYPE(obs_surf), INTENT(INOUT) :: sstdata ! Full set of SST data 553 TYPE(obs_surf), INTENT(INOUT) :: sstdatqc ! Subset of SST data not failing screening 554 LOGICAL :: ld_sst ! Switch for SST data 555 LOGICAL :: ld_nea ! Switch for rejecting observation near land 284 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data 285 TYPE(obs_prof), INTENT(INOUT) :: prodatqc ! Subset of profile data not failing screening 286 LOGICAL, INTENT(IN) :: ld_var1 ! Observed variables switches 287 LOGICAL, INTENT(IN) :: ld_var2 288 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 289 LOGICAL, INTENT(IN) :: ld_bound_reject ! Switch for rejecting observations near the boundary 290 INTEGER, INTENT(IN) :: kpi, kpj, kpk ! Local domain sizes 291 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 292 & kdailyavtypes ! Types for daily averages 293 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 294 & zmask1, & 295 & zmask2 296 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 297 & pglam1, & 298 & pglam2, & 299 & pgphi1, & 300 & pgphi2 301 INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff ! cut off for QC value 302 556 303 !! * Local declarations 304 INTEGER :: iqc_cutoff = 255 ! cut off for QC value 557 305 INTEGER :: iyea0 ! Initial date 558 306 INTEGER :: imon0 ! - (year, month, day, hour, minute) 559 INTEGER :: iday0 307 INTEGER :: iday0 560 308 INTEGER :: ihou0 561 309 INTEGER :: imin0 562 310 INTEGER :: icycle ! Current assimilation cycle 563 ! Counters for observations that 311 ! Counters for observations that are 564 312 INTEGER :: iotdobs ! - outside time domain 565 INTEGER :: iosdsobs ! - outside space domain 566 INTEGER :: ilansobs ! - within a model land cell 567 INTEGER :: inlasobs ! - close to land 313 INTEGER :: iosdv1obs ! - outside space domain (variable 1) 314 INTEGER :: iosdv2obs ! - outside space domain (variable 2) 315 INTEGER :: ilanv1obs ! - within a model land cell (variable 1) 316 INTEGER :: ilanv2obs ! - within a model land cell (variable 2) 317 INTEGER :: inlav1obs ! - close to land (variable 1) 318 INTEGER :: inlav2obs ! - close to land (variable 2) 319 INTEGER :: ibdyv1obs ! - boundary (variable 1) 320 INTEGER :: ibdyv2obs ! - boundary (variable 2) 568 321 INTEGER :: igrdobs ! - fail the grid search 569 ! Global counters for observations that 322 INTEGER :: iuvchku ! - reject u if v rejected and vice versa 323 INTEGER :: iuvchkv ! 324 ! Global counters for observations that are 570 325 INTEGER :: iotdobsmpp ! - outside time domain 571 INTEGER :: iosdsobsmpp ! - outside space domain 572 INTEGER :: ilansobsmpp ! - within a model land cell 573 INTEGER :: inlasobsmpp ! - close to land 326 INTEGER :: iosdv1obsmpp ! - outside space domain (variable 1) 327 INTEGER :: iosdv2obsmpp ! - outside space domain (variable 2) 328 INTEGER :: ilanv1obsmpp ! - within a model land cell (variable 1) 329 INTEGER :: ilanv2obsmpp ! - within a model land cell (variable 2) 330 INTEGER :: inlav1obsmpp ! - close to land (variable 1) 331 INTEGER :: inlav2obsmpp ! - close to land (variable 2) 332 INTEGER :: ibdyv1obsmpp ! - boundary (variable 1) 333 INTEGER :: ibdyv2obsmpp ! - boundary (variable 2) 574 334 INTEGER :: igrdobsmpp ! - fail the grid search 575 LOGICAL, DIMENSION(:), ALLOCATABLE :: & 576 & llvalid ! SST data selection 335 INTEGER :: iuvchkumpp ! - reject var1 if var2 rejected and vice versa 336 INTEGER :: iuvchkvmpp ! 337 TYPE(obs_prof_valid) :: llvalid ! Profile selection 338 TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & 339 & llvvalid ! var1,var2 selection 340 INTEGER :: jvar ! Variable loop variable 577 341 INTEGER :: jobs ! Obs. loop variable 578 342 INTEGER :: jstp ! Time loop variable 579 343 INTEGER :: inrc ! Time index variable 580 344 581 IF(lwp) WRITE(numout,*)'obs_pre_sst : Preparing the SST observations...' 345 IF(lwp) WRITE(numout,*)'obs_pre_prof: Preparing the profile data...' 346 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 582 347 583 348 ! Initial date initialization (year, month, day, hour, minute) … … 592 357 ! Diagnotics counters for various failures. 593 358 594 iotdobs = 0 595 igrdobs = 0 596 iosdsobs = 0 597 ilansobs = 0 598 inlasobs = 0 599 600 ! ----------------------------------------------------------------------- 601 ! Find time coordinate for SST data 602 ! ----------------------------------------------------------------------- 603 604 CALL obs_coo_tim( icycle, & 605 & iyea0, imon0, iday0, ihou0, imin0, & 606 & sstdata%nsurf, sstdata%nyea, sstdata%nmon, & 607 & sstdata%nday, sstdata%nhou, sstdata%nmin, & 608 & sstdata%nqc, sstdata%mstp, iotdobs ) 609 CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) 610 ! ----------------------------------------------------------------------- 611 ! Check for SST data failing the grid search 612 ! ----------------------------------------------------------------------- 613 614 CALL obs_coo_grd( sstdata%nsurf, sstdata%mi, sstdata%mj, & 615 & sstdata%nqc, igrdobs ) 616 CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) 617 618 ! ----------------------------------------------------------------------- 619 ! Check for land points. 620 ! ----------------------------------------------------------------------- 621 622 CALL obs_coo_spc_2d( sstdata%nsurf, & 623 & jpi, jpj, & 624 & sstdata%mi, sstdata%mj, & 625 & sstdata%rlam, sstdata%rphi, & 626 & glamt, gphit, & 627 & tmask(:,:,1), sstdata%nqc, & 628 & iosdsobs, ilansobs, & 629 & inlasobs, ld_nea ) 630 631 CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) 632 CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) 633 CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) 634 635 ! ----------------------------------------------------------------------- 636 ! Copy useful data from the sstdata data structure to 637 ! the sstdatqc data structure 638 ! ----------------------------------------------------------------------- 639 640 ! Allocate the selection arrays 641 642 ALLOCATE( llvalid(sstdata%nsurf) ) 643 644 ! We want all data which has qc flags <= 0 645 646 llvalid(:) = ( sstdata%nqc(:) <= 10 ) 647 648 ! The actual copying 649 650 CALL obs_surf_compress( sstdata, sstdatqc, .TRUE., numout, & 651 & lvalid=llvalid ) 652 653 ! Dellocate the selection arrays 654 DEALLOCATE( llvalid ) 655 656 ! ----------------------------------------------------------------------- 657 ! Print information about what observations are left after qc 658 ! ----------------------------------------------------------------------- 659 660 ! Update the total observation counter array 661 662 IF(lwp) THEN 663 WRITE(numout,*) 664 WRITE(numout,*) 'obs_pre_sst :' 665 WRITE(numout,*) '~~~~~~~~~~~' 666 WRITE(numout,*) 667 WRITE(numout,*) ' SST data outside time domain = ', & 668 & iotdobsmpp 669 WRITE(numout,*) ' Remaining SST data that failed grid search = ', & 670 & igrdobsmpp 671 WRITE(numout,*) ' Remaining SST data outside space domain = ', & 672 & iosdsobsmpp 673 WRITE(numout,*) ' Remaining SST data at land points = ', & 674 & ilansobsmpp 675 IF (ld_nea) THEN 676 WRITE(numout,*) ' Remaining SST data near land points (removed) = ', & 677 & inlasobsmpp 678 ELSE 679 WRITE(numout,*) ' Remaining SST data near land points (kept) = ', & 680 & inlasobsmpp 681 ENDIF 682 WRITE(numout,*) ' SST data accepted = ', & 683 & sstdatqc%nsurfmpp 684 685 WRITE(numout,*) 686 WRITE(numout,*) ' Number of observations per time step :' 687 WRITE(numout,*) 688 WRITE(numout,1997) 689 WRITE(numout,1998) 359 iotdobs = 0 360 igrdobs = 0 361 iosdv1obs = 0 362 iosdv2obs = 0 363 ilanv1obs = 0 364 ilanv2obs = 0 365 inlav1obs = 0 366 inlav2obs = 0 367 ibdyv1obs = 0 368 ibdyv2obs = 0 369 iuvchku = 0 370 iuvchkv = 0 371 372 373 ! Set QC cutoff to optional value if provided 374 IF ( PRESENT(kqc_cutoff) ) iqc_cutoff=kqc_cutoff 375 376 ! ----------------------------------------------------------------------- 377 ! Find time coordinate for profiles 378 ! ----------------------------------------------------------------------- 379 380 IF ( PRESENT(kdailyavtypes) ) THEN 381 CALL obs_coo_tim_prof( icycle, & 382 & iyea0, imon0, iday0, ihou0, imin0, & 383 & profdata%nprof, profdata%nyea, profdata%nmon, & 384 & profdata%nday, profdata%nhou, profdata%nmin, & 385 & profdata%ntyp, profdata%nqc, profdata%mstp, & 386 & iotdobs, kdailyavtypes = kdailyavtypes, & 387 & kqc_cutoff = iqc_cutoff ) 388 ELSE 389 CALL obs_coo_tim_prof( icycle, & 390 & iyea0, imon0, iday0, ihou0, imin0, & 391 & profdata%nprof, profdata%nyea, profdata%nmon, & 392 & profdata%nday, profdata%nhou, profdata%nmin, & 393 & profdata%ntyp, profdata%nqc, profdata%mstp, & 394 & iotdobs, kqc_cutoff = iqc_cutoff ) 690 395 ENDIF 691 692 DO jobs = 1, sstdatqc%nsurf 693 inrc = sstdatqc%mstp(jobs) + 2 - nit000 694 sstdatqc%nsstp(inrc) = sstdatqc%nsstp(inrc) + 1 695 END DO 696 697 CALL obs_mpp_sum_integers( sstdatqc%nsstp, sstdatqc%nsstpmpp, & 698 & nitend - nit000 + 2 ) 699 700 IF ( lwp ) THEN 701 DO jstp = nit000 - 1, nitend 702 inrc = jstp - nit000 + 2 703 WRITE(numout,1999) jstp, sstdatqc%nsstpmpp(inrc) 704 END DO 705 ENDIF 706 707 1997 FORMAT(10X,'Time step',5X,'Sea surface temperature') 708 1998 FORMAT(10X,'---------',5X,'-----------------') 709 1999 FORMAT(10X,I9,5X,I17) 710 711 END SUBROUTINE obs_pre_sst 712 713 SUBROUTINE obs_pre_seaice( seaicedata, seaicedatqc, ld_seaice, ld_nea ) 714 !!---------------------------------------------------------------------- 715 !! *** ROUTINE obs_pre_seaice *** 716 !! 717 !! ** Purpose : First level check and screening of Sea Ice observations 718 !! 719 !! ** Method : First level check and screening of Sea Ice observations 720 !! 721 !! ** Action : 722 !! 723 !! References : 724 !! 725 !! History : 726 !! ! 2007-11 (D. Lea) based on obs_pre_sst 727 !!---------------------------------------------------------------------- 728 !! * Modules used 729 USE domstp ! Domain: set the time-step 730 USE par_oce ! Ocean parameters 731 USE dom_oce, ONLY : & ! Geographical information 732 & glamt, & 733 & gphit, & 734 & tmask, & 735 & nproc 736 !! * Arguments 737 TYPE(obs_surf), INTENT(INOUT) :: seaicedata ! Full set of Sea Ice data 738 TYPE(obs_surf), INTENT(INOUT) :: seaicedatqc ! Subset of sea ice data not failing screening 739 LOGICAL :: ld_seaice ! Switch for sea ice data 740 LOGICAL :: ld_nea ! Switch for rejecting observation near land 741 !! * Local declarations 742 INTEGER :: iyea0 ! Initial date 743 INTEGER :: imon0 ! - (year, month, day, hour, minute) 744 INTEGER :: iday0 745 INTEGER :: ihou0 746 INTEGER :: imin0 747 INTEGER :: icycle ! Current assimilation cycle 748 ! Counters for observations that 749 INTEGER :: iotdobs ! - outside time domain 750 INTEGER :: iosdsobs ! - outside space domain 751 INTEGER :: ilansobs ! - within a model land cell 752 INTEGER :: inlasobs ! - close to land 753 INTEGER :: igrdobs ! - fail the grid search 754 ! Global counters for observations that 755 INTEGER :: iotdobsmpp ! - outside time domain 756 INTEGER :: iosdsobsmpp ! - outside space domain 757 INTEGER :: ilansobsmpp ! - within a model land cell 758 INTEGER :: inlasobsmpp ! - close to land 759 INTEGER :: igrdobsmpp ! - fail the grid search 760 LOGICAL, DIMENSION(:), ALLOCATABLE :: & 761 & llvalid ! data selection 762 INTEGER :: jobs ! Obs. loop variable 763 INTEGER :: jstp ! Time loop variable 764 INTEGER :: inrc ! Time index variable 765 766 IF (lwp) WRITE(numout,*)'obs_pre_seaice : Preparing the sea ice observations...' 767 768 ! Initial date initialization (year, month, day, hour, minute) 769 iyea0 = ndate0 / 10000 770 imon0 = ( ndate0 - iyea0 * 10000 ) / 100 771 iday0 = ndate0 - iyea0 * 10000 - imon0 * 100 772 ihou0 = 0 773 imin0 = 0 774 775 icycle = no ! Assimilation cycle 776 777 ! Diagnotics counters for various failures. 778 779 iotdobs = 0 780 igrdobs = 0 781 iosdsobs = 0 782 ilansobs = 0 783 inlasobs = 0 784 785 ! ----------------------------------------------------------------------- 786 ! Find time coordinate for sea ice data 787 ! ----------------------------------------------------------------------- 788 789 CALL obs_coo_tim( icycle, & 790 & iyea0, imon0, iday0, ihou0, imin0, & 791 & seaicedata%nsurf, seaicedata%nyea, seaicedata%nmon, & 792 & seaicedata%nday, seaicedata%nhou, seaicedata%nmin, & 793 & seaicedata%nqc, seaicedata%mstp, iotdobs ) 794 CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) 795 ! ----------------------------------------------------------------------- 796 ! Check for sea ice data failing the grid search 797 ! ----------------------------------------------------------------------- 798 799 CALL obs_coo_grd( seaicedata%nsurf, seaicedata%mi, seaicedata%mj, & 800 & seaicedata%nqc, igrdobs ) 801 CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) 802 803 ! ----------------------------------------------------------------------- 804 ! Check for land points. 805 ! ----------------------------------------------------------------------- 806 807 CALL obs_coo_spc_2d( seaicedata%nsurf, & 808 & jpi, jpj, & 809 & seaicedata%mi, seaicedata%mj, & 810 & seaicedata%rlam, seaicedata%rphi, & 811 & glamt, gphit, & 812 & tmask(:,:,1), seaicedata%nqc, & 813 & iosdsobs, ilansobs, & 814 & inlasobs, ld_nea ) 815 816 CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) 817 CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) 818 CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) 819 820 ! ----------------------------------------------------------------------- 821 ! Copy useful data from the seaicedata data structure to 822 ! the seaicedatqc data structure 823 ! ----------------------------------------------------------------------- 824 825 ! Allocate the selection arrays 826 827 ALLOCATE( llvalid(seaicedata%nsurf) ) 828 829 ! We want all data which has qc flags <= 0 830 831 llvalid(:) = ( seaicedata%nqc(:) <= 10 ) 832 833 ! The actual copying 834 835 CALL obs_surf_compress( seaicedata, seaicedatqc, .TRUE., numout, & 836 & lvalid=llvalid ) 837 838 ! Dellocate the selection arrays 839 DEALLOCATE( llvalid ) 840 841 ! ----------------------------------------------------------------------- 842 ! Print information about what observations are left after qc 843 ! ----------------------------------------------------------------------- 844 845 ! Update the total observation counter array 846 847 IF(lwp) THEN 848 WRITE(numout,*) 849 WRITE(numout,*) 'obs_pre_seaice :' 850 WRITE(numout,*) '~~~~~~~~~~~' 851 WRITE(numout,*) 852 WRITE(numout,*) ' Sea ice data outside time domain = ', & 853 & iotdobsmpp 854 WRITE(numout,*) ' Remaining sea ice data that failed grid search = ', & 855 & igrdobsmpp 856 WRITE(numout,*) ' Remaining sea ice data outside space domain = ', & 857 & iosdsobsmpp 858 WRITE(numout,*) ' Remaining sea ice data at land points = ', & 859 & ilansobsmpp 860 IF (ld_nea) THEN 861 WRITE(numout,*) ' Remaining sea ice data near land points (removed) = ', & 862 & inlasobsmpp 863 ELSE 864 WRITE(numout,*) ' Remaining sea ice data near land points (kept) = ', & 865 & inlasobsmpp 866 ENDIF 867 WRITE(numout,*) ' Sea ice data accepted = ', & 868 & seaicedatqc%nsurfmpp 869 870 WRITE(numout,*) 871 WRITE(numout,*) ' Number of observations per time step :' 872 WRITE(numout,*) 873 WRITE(numout,1997) 874 WRITE(numout,1998) 875 ENDIF 876 877 DO jobs = 1, seaicedatqc%nsurf 878 inrc = seaicedatqc%mstp(jobs) + 2 - nit000 879 seaicedatqc%nsstp(inrc) = seaicedatqc%nsstp(inrc) + 1 880 END DO 881 882 CALL obs_mpp_sum_integers( seaicedatqc%nsstp, seaicedatqc%nsstpmpp, & 883 & nitend - nit000 + 2 ) 884 885 IF ( lwp ) THEN 886 DO jstp = nit000 - 1, nitend 887 inrc = jstp - nit000 + 2 888 WRITE(numout,1999) jstp, seaicedatqc%nsstpmpp(inrc) 889 END DO 890 ENDIF 891 892 1997 FORMAT(10X,'Time step',5X,'Sea ice data ') 893 1998 FORMAT(10X,'---------',5X,'-----------------') 894 1999 FORMAT(10X,I9,5X,I17) 895 896 END SUBROUTINE obs_pre_seaice 897 898 SUBROUTINE obs_pre_vel( profdata, prodatqc, ld_vel3d, ld_nea, ld_dailyav ) 899 !!---------------------------------------------------------------------- 900 !! *** ROUTINE obs_pre_taovel *** 901 !! 902 !! ** Purpose : First level check and screening of U and V profiles 903 !! 904 !! ** Method : First level check and screening of U and V profiles 905 !! 906 !! History : 907 !! ! 2007-06 (K. Mogensen) original : T and S profile data 908 !! ! 2008-09 (M. Valdivieso) : TAO velocity data 909 !! ! 2009-01 (K. Mogensen) : New feedback strictuer 910 !! 911 !!---------------------------------------------------------------------- 912 !! * Modules used 913 USE domstp ! Domain: set the time-step 914 USE par_oce ! Ocean parameters 915 USE dom_oce, ONLY : & ! Geographical information 916 & glamt, glamu, glamv, & 917 & gphit, gphiu, gphiv, & 918 & gdept_1d, & 919 & tmask, umask, vmask, & 920 & nproc 921 !! * Arguments 922 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data 923 TYPE(obs_prof), INTENT(INOUT) :: prodatqc ! Subset of profile data not failing screening 924 LOGICAL, INTENT(IN) :: ld_vel3d ! Switch for zonal and meridional velocity components 925 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 926 LOGICAL, INTENT(IN) :: ld_dailyav ! Switch for daily average data 927 !! * Local declarations 928 INTEGER :: iyea0 ! Initial date 929 INTEGER :: imon0 ! - (year, month, day, hour, minute) 930 INTEGER :: iday0 931 INTEGER :: ihou0 932 INTEGER :: imin0 933 INTEGER :: icycle ! Current assimilation cycle 934 ! Counters for observations that 935 INTEGER :: iotdobs ! - outside time domain 936 INTEGER :: iosduobs ! - outside space domain (zonal velocity component) 937 INTEGER :: iosdvobs ! - outside space domain (meridional velocity component) 938 INTEGER :: ilanuobs ! - within a model land cell (zonal velocity component) 939 INTEGER :: ilanvobs ! - within a model land cell (meridional velocity component) 940 INTEGER :: inlauobs ! - close to land (zonal velocity component) 941 INTEGER :: inlavobs ! - close to land (meridional velocity component) 942 INTEGER :: igrdobs ! - fail the grid search 943 INTEGER :: iuvchku ! - reject u if v rejected and vice versa 944 INTEGER :: iuvchkv ! 945 ! Global counters for observations that 946 INTEGER :: iotdobsmpp ! - outside time domain 947 INTEGER :: iosduobsmpp ! - outside space domain (zonal velocity component) 948 INTEGER :: iosdvobsmpp ! - outside space domain (meridional velocity component) 949 INTEGER :: ilanuobsmpp ! - within a model land cell (zonal velocity component) 950 INTEGER :: ilanvobsmpp ! - within a model land cell (meridional velocity component) 951 INTEGER :: inlauobsmpp ! - close to land (zonal velocity component) 952 INTEGER :: inlavobsmpp ! - close to land (meridional velocity component) 953 INTEGER :: igrdobsmpp ! - fail the grid search 954 INTEGER :: iuvchkumpp ! - reject u if v rejected and vice versa 955 INTEGER :: iuvchkvmpp ! 956 TYPE(obs_prof_valid) :: llvalid ! Profile selection 957 TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & 958 & llvvalid ! U,V selection 959 INTEGER :: jvar ! Variable loop variable 960 INTEGER :: jobs ! Obs. loop variable 961 INTEGER :: jstp ! Time loop variable 962 INTEGER :: inrc ! Time index variable 963 964 IF(lwp) WRITE(numout,*)'obs_pre_vel: Preparing the velocity profile data' 965 966 ! Initial date initialization (year, month, day, hour, minute) 967 iyea0 = ndate0 / 10000 968 imon0 = ( ndate0 - iyea0 * 10000 ) / 100 969 iday0 = ndate0 - iyea0 * 10000 - imon0 * 100 970 ihou0 = 0 971 imin0 = 0 972 973 icycle = no ! Assimilation cycle 974 975 ! Diagnotics counters for various failures. 976 977 iotdobs = 0 978 igrdobs = 0 979 iosduobs = 0 980 iosdvobs = 0 981 ilanuobs = 0 982 ilanvobs = 0 983 inlauobs = 0 984 inlavobs = 0 985 iuvchku = 0 986 iuvchkv = 0 987 988 ! ----------------------------------------------------------------------- 989 ! Find time coordinate for profiles 990 ! ----------------------------------------------------------------------- 991 992 CALL obs_coo_tim_prof( icycle, & 993 & iyea0, imon0, iday0, ihou0, imin0, & 994 & profdata%nprof, profdata%nyea, profdata%nmon, & 995 & profdata%nday, profdata%nhou, profdata%nmin, & 996 & profdata%ntyp, profdata%nqc, profdata%mstp, & 997 & iotdobs, ld_dailyav = ld_dailyav ) 998 396 999 397 CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) 1000 398 … … 1011 409 1012 410 ! ----------------------------------------------------------------------- 1013 ! Reject all observations for profiles with nqc > 101014 ! ----------------------------------------------------------------------- 1015 1016 CALL obs_pro_rej( profdata )411 ! Reject all observations for profiles with nqc > iqc_cutoff 412 ! ----------------------------------------------------------------------- 413 414 CALL obs_pro_rej( profdata, kqc_cutoff = iqc_cutoff ) 1017 415 1018 416 ! ----------------------------------------------------------------------- … … 1021 419 ! ----------------------------------------------------------------------- 1022 420 1023 ! Zonal Velocity Component 1024 421 ! Variable 1 1025 422 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(1), & 1026 423 & profdata%npvsta(:,1), profdata%npvend(:,1), & 1027 424 & jpi, jpj, & 1028 425 & jpk, & 1029 & profdata%mi, profdata%mj, & 426 & profdata%mi, profdata%mj, & 1030 427 & profdata%var(1)%mvk, & 1031 428 & profdata%rlam, profdata%rphi, & 1032 429 & profdata%var(1)%vdep, & 1033 & glamu, gphiu,&1034 & gdept_1d, umask,&430 & pglam1, pgphi1, & 431 & gdept_1d, zmask1, & 1035 432 & profdata%nqc, profdata%var(1)%nvqc, & 1036 & iosduobs, ilanuobs, & 1037 & inlauobs, ld_nea ) 1038 1039 CALL obs_mpp_sum_integer( iosduobs, iosduobsmpp ) 1040 CALL obs_mpp_sum_integer( ilanuobs, ilanuobsmpp ) 1041 CALL obs_mpp_sum_integer( inlauobs, inlauobsmpp ) 1042 1043 ! Meridional Velocity Component 1044 433 & iosdv1obs, ilanv1obs, & 434 & inlav1obs, ld_nea, & 435 & ibdyv1obs, ld_bound_reject, & 436 & iqc_cutoff ) 437 438 CALL obs_mpp_sum_integer( iosdv1obs, iosdv1obsmpp ) 439 CALL obs_mpp_sum_integer( ilanv1obs, ilanv1obsmpp ) 440 CALL obs_mpp_sum_integer( inlav1obs, inlav1obsmpp ) 441 CALL obs_mpp_sum_integer( ibdyv1obs, ibdyv1obsmpp ) 442 443 ! Variable 2 1045 444 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(2), & 1046 445 & profdata%npvsta(:,2), profdata%npvend(:,2), & … … 1051 450 & profdata%rlam, profdata%rphi, & 1052 451 & profdata%var(2)%vdep, & 1053 & glamv, gphiv,&1054 & gdept_1d, vmask,&452 & pglam2, pgphi2, & 453 & gdept_1d, zmask2, & 1055 454 & profdata%nqc, profdata%var(2)%nvqc, & 1056 & iosdvobs, ilanvobs, & 1057 & inlavobs, ld_nea ) 1058 1059 CALL obs_mpp_sum_integer( iosdvobs, iosdvobsmpp ) 1060 CALL obs_mpp_sum_integer( ilanvobs, ilanvobsmpp ) 1061 CALL obs_mpp_sum_integer( inlavobs, inlavobsmpp ) 455 & iosdv2obs, ilanv2obs, & 456 & inlav2obs, ld_nea, & 457 & ibdyv2obs, ld_bound_reject, & 458 & iqc_cutoff ) 459 460 CALL obs_mpp_sum_integer( iosdv2obs, iosdv2obsmpp ) 461 CALL obs_mpp_sum_integer( ilanv2obs, ilanv2obsmpp ) 462 CALL obs_mpp_sum_integer( inlav2obs, inlav2obsmpp ) 463 CALL obs_mpp_sum_integer( ibdyv2obs, ibdyv2obsmpp ) 1062 464 1063 465 ! ----------------------------------------------------------------------- … … 1065 467 ! ----------------------------------------------------------------------- 1066 468 1067 CALL obs_uv_rej( profdata, iuvchku, iuvchkv ) 1068 CALL obs_mpp_sum_integer( iuvchku, iuvchkumpp ) 1069 CALL obs_mpp_sum_integer( iuvchkv, iuvchkvmpp ) 469 IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 470 CALL obs_uv_rej( profdata, iuvchku, iuvchkv, iqc_cutoff ) 471 CALL obs_mpp_sum_integer( iuvchku, iuvchkumpp ) 472 CALL obs_mpp_sum_integer( iuvchkv, iuvchkvmpp ) 473 ENDIF 1070 474 1071 475 ! ----------------------------------------------------------------------- … … 1081 485 END DO 1082 486 1083 ! We want all data which has qc flags = 01084 1085 llvalid%luse(:) = ( profdata%nqc(:) <= 10)487 ! We want all data which has qc flags <= iqc_cutoff 488 489 llvalid%luse(:) = ( profdata%nqc(:) <= iqc_cutoff ) 1086 490 DO jvar = 1,profdata%nvar 1087 llvvalid(jvar)%luse(:) = ( profdata%var(jvar)%nvqc(:) <= 10)491 llvvalid(jvar)%luse(:) = ( profdata%var(jvar)%nvqc(:) <= iqc_cutoff ) 1088 492 END DO 1089 493 … … 1106 510 1107 511 IF(lwp) THEN 512 1108 513 WRITE(numout,*) 1109 WRITE(numout,*) 'obs_pre_vel :' 1110 WRITE(numout,*) '~~~~~~~~~~~' 1111 WRITE(numout,*) 1112 WRITE(numout,*) ' Profiles outside time domain = ', & 514 WRITE(numout,*) ' Profiles outside time domain = ', & 1113 515 & iotdobsmpp 1114 WRITE(numout,*) ' Remaining profiles that failed grid search = ', &516 WRITE(numout,*) ' Remaining profiles that failed grid search = ', & 1115 517 & igrdobsmpp 1116 WRITE(numout,*) ' Remaining Udata outside space domain = ', &1117 & iosd uobsmpp1118 WRITE(numout,*) ' Remaining Udata at land points = ', &1119 & ilan uobsmpp518 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data outside space domain = ', & 519 & iosdv1obsmpp 520 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data at land points = ', & 521 & ilanv1obsmpp 1120 522 IF (ld_nea) THEN 1121 WRITE(numout,*) ' Remaining Udata near land points (removed) = ',&1122 & inla uobsmpp523 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (removed) = ',& 524 & inlav1obsmpp 1123 525 ELSE 1124 WRITE(numout,*) ' Remaining U data near land points (kept) = ',& 1125 & inlauobsmpp 1126 ENDIF 1127 WRITE(numout,*) ' U observation rejected since V rejected = ', & 1128 & iuvchku 1129 WRITE(numout,*) ' U data accepted = ', & 526 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (kept) = ',& 527 & inlav1obsmpp 528 ENDIF 529 IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 530 WRITE(numout,*) ' U observation rejected since V rejected = ', & 531 & iuvchku 532 ENDIF 533 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near open boundary (removed) = ',& 534 & ibdyv1obsmpp 535 WRITE(numout,*) ' '//prodatqc%cvars(1)//' data accepted = ', & 1130 536 & prodatqc%nvprotmpp(1) 1131 WRITE(numout,*) ' Remaining Vdata outside space domain = ', &1132 & iosdv obsmpp1133 WRITE(numout,*) ' Remaining Vdata at land points = ', &1134 & ilanv obsmpp537 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data outside space domain = ', & 538 & iosdv2obsmpp 539 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data at land points = ', & 540 & ilanv2obsmpp 1135 541 IF (ld_nea) THEN 1136 WRITE(numout,*) ' Remaining Vdata near land points (removed) = ',&1137 & inlav obsmpp542 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (removed) = ',& 543 & inlav2obsmpp 1138 544 ELSE 1139 WRITE(numout,*) ' Remaining V data near land points (kept) = ',& 1140 & inlavobsmpp 1141 ENDIF 1142 WRITE(numout,*) ' V observation rejected since U rejected = ', & 1143 & iuvchkv 1144 WRITE(numout,*) ' V data accepted = ', & 545 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (kept) = ',& 546 & inlav2obsmpp 547 ENDIF 548 IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 549 WRITE(numout,*) ' V observation rejected since U rejected = ', & 550 & iuvchkv 551 ENDIF 552 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near open boundary (removed) = ',& 553 & ibdyv2obsmpp 554 WRITE(numout,*) ' '//prodatqc%cvars(2)//' data accepted = ', & 1145 555 & prodatqc%nvprotmpp(2) 1146 556 … … 1148 558 WRITE(numout,*) ' Number of observations per time step :' 1149 559 WRITE(numout,*) 1150 WRITE(numout,997) 560 WRITE(numout,'(10X,A,5X,A,5X,A,A)')'Time step','Profiles', & 561 & ' '//prodatqc%cvars(1)//' ', & 562 & ' '//prodatqc%cvars(2)//' ' 1151 563 WRITE(numout,998) 1152 564 ENDIF … … 1182 594 ENDIF 1183 595 1184 997 FORMAT(10X,'Time step',5X,'Profiles',5X,'Zonal Comp.',5X,'Meridional Comp.')1185 596 998 FORMAT(10X,'---------',5X,'--------',5X,'-----------',5X,'----------------') 1186 597 999 FORMAT(10X,I9,5X,I8,5X,I11,5X,I8) 1187 598 1188 END SUBROUTINE obs_pre_ vel599 END SUBROUTINE obs_pre_prof 1189 600 1190 601 SUBROUTINE obs_coo_tim( kcycle, & … … 1293 704 & .AND. ( kobsmin(jobs) <= kmin0 ) ) ) THEN 1294 705 kobsstp(jobs) = -1 1295 kobsqc(jobs) = kobsqc(jobs) + 11706 kobsqc(jobs) = IBSET(kobsqc(jobs),13) 1296 707 kotdobs = kotdobs + 1 1297 708 CYCLE … … 1344 755 IF ( ( kobsstp(jobs) < ( nit000 - 1 ) ) & 1345 756 & .OR.( kobsstp(jobs) > nitend ) ) THEN 1346 kobsqc(jobs) = kobsqc(jobs) + 12757 kobsqc(jobs) = IBSET(kobsqc(jobs),13) 1347 758 kotdobs = kotdobs + 1 1348 759 CYCLE … … 1389 800 & kobsyea, kobsmon, kobsday, kobshou, kobsmin, & 1390 801 & ktyp, kobsqc, kobsstp, kotdobs, kdailyavtypes, & 1391 & ld_dailyav)802 & kqc_cutoff ) 1392 803 !!---------------------------------------------------------------------- 1393 804 !! *** ROUTINE obs_coo_tim *** … … 1433 844 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 1434 845 & kdailyavtypes ! Types for daily averages 1435 LOGICAL, OPTIONAL :: ld_dailyav ! All types are daily averages 846 INTEGER, OPTIONAL, INTENT(IN) :: kqc_cutoff ! QC cutoff value 847 1436 848 !! * Local declarations 1437 849 INTEGER :: jobs 850 INTEGER :: iqc_cutoff=255 1438 851 1439 852 !----------------------------------------------------------------------- … … 1454 867 DO jobs = 1, kobsno 1455 868 1456 IF ( kobsqc(jobs) <= 10) THEN869 IF ( kobsqc(jobs) <= iqc_cutoff ) THEN 1457 870 1458 871 IF ( ( kobsstp(jobs) == (nit000 - 1) ).AND.& 1459 872 & ( ANY (kdailyavtypes(:) == ktyp(jobs)) ) ) THEN 1460 kobsqc(jobs) = kobsqc(jobs) + 14873 kobsqc(jobs) = IBSET(kobsqc(jobs),13) 1461 874 kotdobs = kotdobs + 1 1462 875 CYCLE … … 1467 880 ENDIF 1468 881 1469 !------------------------------------------------------------------------1470 ! If ld_dailyav is set then all data assumed to be daily averaged1471 !------------------------------------------------------------------------1472 1473 IF ( PRESENT( ld_dailyav) ) THEN1474 IF (ld_dailyav) THEN1475 DO jobs = 1, kobsno1476 1477 IF ( kobsqc(jobs) <= 10 ) THEN1478 1479 IF ( kobsstp(jobs) == (nit000 - 1) ) THEN1480 kobsqc(jobs) = kobsqc(jobs) + 141481 kotdobs = kotdobs + 11482 CYCLE1483 ENDIF1484 1485 ENDIF1486 END DO1487 ENDIF1488 ENDIF1489 882 1490 883 END SUBROUTINE obs_coo_tim_prof … … 1521 914 DO jobs = 1, kobsno 1522 915 IF ( ( kobsi(jobs) <= 0 ) .AND. ( kobsj(jobs) <= 0 ) ) THEN 1523 kobsqc(jobs) = kobsqc(jobs) + 18916 kobsqc(jobs) = IBSET(kobsqc(jobs),12) 1524 917 kgrdobs = kgrdobs + 1 1525 918 ENDIF … … 1532 925 & plam, pphi, pmask, & 1533 926 & kobsqc, kosdobs, klanobs, & 1534 & knlaobs,ld_nea ) 927 & knlaobs,ld_nea, & 928 & kbdyobs,ld_bound_reject, & 929 & kqc_cutoff ) 1535 930 !!---------------------------------------------------------------------- 1536 931 !! *** ROUTINE obs_coo_spc_2d *** … … 1565 960 INTEGER, DIMENSION(kobsno), INTENT(INOUT) :: & 1566 961 & kobsqc ! Observation quality control 1567 INTEGER, INTENT(INOUT) :: kosdobs ! Observations outside space domain 1568 INTEGER, INTENT(INOUT) :: klanobs ! Observations within a model land cell 1569 INTEGER, INTENT(INOUT) :: knlaobs ! Observations near land 1570 LOGICAL, INTENT(IN) :: ld_nea ! Flag observations near land 962 INTEGER, INTENT(INOUT) :: kosdobs ! Observations outside space domain 963 INTEGER, INTENT(INOUT) :: klanobs ! Observations within a model land cell 964 INTEGER, INTENT(INOUT) :: knlaobs ! Observations near land 965 INTEGER, INTENT(INOUT) :: kbdyobs ! Observations near boundary 966 LOGICAL, INTENT(IN) :: ld_nea ! Flag observations near land 967 LOGICAL, INTENT(IN) :: ld_bound_reject ! Flag observations near open boundary 968 INTEGER, INTENT(IN) :: kqc_cutoff ! Cutoff QC value 969 1571 970 !! * Local declarations 1572 971 REAL(KIND=wp), DIMENSION(2,2,kobsno) :: & 1573 972 & zgmsk ! Grid mask 973 #if defined key_bdy 974 REAL(KIND=wp), DIMENSION(2,2,kobsno) :: & 975 & zbmsk ! Boundary mask 976 REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask 977 #endif 1574 978 REAL(KIND=wp), DIMENSION(2,2,kobsno) :: & 1575 979 & zglam, & ! Model longitude at grid points … … 1588 992 ! For invalid points use 2,2 1589 993 1590 IF ( kobsqc(jobs) >= 10) THEN994 IF ( kobsqc(jobs) >= kqc_cutoff ) THEN 1591 995 1592 996 igrdi(1,1,jobs) = 1 … … 1613 1017 1614 1018 END DO 1615 1616 CALL obs_int_comm_2d( 2, 2, kobsno, igrdi, igrdj, pmask, zgmsk ) 1617 CALL obs_int_comm_2d( 2, 2, kobsno, igrdi, igrdj, plam, zglam ) 1618 CALL obs_int_comm_2d( 2, 2, kobsno, igrdi, igrdj, pphi, zgphi ) 1019 1020 #if defined key_bdy 1021 ! Create a mask grid points in boundary rim 1022 IF (ld_bound_reject) THEN 1023 zbdymask(:,:) = 1.0_wp 1024 DO ji = 1, nb_bdy 1025 DO jj = 1, idx_bdy(ji)%nblen(1) 1026 zbdymask(idx_bdy(ji)%nbi(jj,1),idx_bdy(ji)%nbj(jj,1)) = 0.0_wp 1027 ENDDO 1028 ENDDO 1029 1030 CALL obs_int_comm_2d( 2, 2, kobsno, igrdi, igrdj, zbdymask, zbmsk ) 1031 ENDIF 1032 #endif 1033 1034 CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, pmask, zgmsk ) 1035 CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, plam, zglam ) 1036 CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, pphi, zgphi ) 1619 1037 1620 1038 DO jobs = 1, kobsno 1621 1039 1622 1040 ! Skip bad observations 1623 IF ( kobsqc(jobs) >= 10) CYCLE1041 IF ( kobsqc(jobs) >= kqc_cutoff ) CYCLE 1624 1042 1625 1043 ! Flag if the observation falls outside the model spatial domain … … 1628 1046 & .OR. ( pobsphi(jobs) < -90. ) & 1629 1047 & .OR. ( pobsphi(jobs) > 90. ) ) THEN 1630 kobsqc(jobs) = kobsqc(jobs) + 111048 kobsqc(jobs) = IBSET(kobsqc(jobs),11) 1631 1049 kosdobs = kosdobs + 1 1632 1050 CYCLE … … 1635 1053 ! Flag if the observation falls with a model land cell 1636 1054 IF ( SUM( zgmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN 1637 kobsqc(jobs) = kobsqc(jobs) + 121055 kobsqc(jobs) = IBSET(kobsqc(jobs),10) 1638 1056 klanobs = klanobs + 1 1639 1057 CYCLE … … 1657 1075 END DO 1658 1076 END DO 1659 1660 ! For observations on the grid reject them if their are at 1661 ! a masked point 1662 1077 1663 1078 IF (lgridobs) THEN 1664 1079 IF (zgmsk(iig,ijg,jobs) == 0.0_wp ) THEN 1665 kobsqc(jobs) = kobsqc(jobs) + 121080 kobsqc(jobs) = IBSET(kobsqc(jobs),10) 1666 1081 klanobs = klanobs + 1 1667 1082 CYCLE 1668 1083 ENDIF 1669 1084 ENDIF 1670 1085 1086 1671 1087 ! Flag if the observation falls is close to land 1672 1088 IF ( MINVAL( zgmsk(1:2,1:2,jobs) ) == 0.0_wp) THEN 1673 IF (ld_nea) kobsqc(jobs) = kobsqc(jobs) + 141674 1089 knlaobs = knlaobs + 1 1675 CYCLE 1676 ENDIF 1090 IF (ld_nea) THEN 1091 kobsqc(jobs) = IBSET(kobsqc(jobs),9) 1092 CYCLE 1093 ENDIF 1094 ENDIF 1095 1096 #if defined key_bdy 1097 ! Flag if the observation falls close to the boundary rim 1098 IF (ld_bound_reject) THEN 1099 IF ( MINVAL( zbmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN 1100 kobsqc(jobs) = IBSET(kobsqc(jobs),8) 1101 kbdyobs = kbdyobs + 1 1102 CYCLE 1103 ENDIF 1104 ! for observations on the grid... 1105 IF (lgridobs) THEN 1106 IF (zbmsk(iig,ijg,jobs) == 0.0_wp ) THEN 1107 kobsqc(jobs) = IBSET(kobsqc(jobs),8) 1108 kbdyobs = kbdyobs + 1 1109 CYCLE 1110 ENDIF 1111 ENDIF 1112 ENDIF 1113 #endif 1677 1114 1678 1115 END DO … … 1686 1123 & plam, pphi, pdep, pmask, & 1687 1124 & kpobsqc, kobsqc, kosdobs, & 1688 & klanobs, knlaobs, ld_nea ) 1125 & klanobs, knlaobs, ld_nea, & 1126 & kbdyobs, ld_bound_reject, & 1127 & kqc_cutoff ) 1689 1128 !!---------------------------------------------------------------------- 1690 1129 !! *** ROUTINE obs_coo_spc_3d *** … … 1709 1148 !! * Modules used 1710 1149 USE dom_oce, ONLY : & ! Geographical information 1711 & gdepw_1d 1150 & gdepw_1d, & 1151 & gdepw_0, & 1152 #if defined key_vvl 1153 & gdepw_n, & 1154 & gdept_n, & 1155 #endif 1156 & ln_zco, & 1157 & ln_zps, & 1158 & lk_vvl 1712 1159 1713 1160 !! * Arguments … … 1743 1190 INTEGER, INTENT(INOUT) :: klanobs ! Observations within a model land cell 1744 1191 INTEGER, INTENT(INOUT) :: knlaobs ! Observations near land 1192 INTEGER, INTENT(INOUT) :: kbdyobs ! Observations near boundary 1745 1193 LOGICAL, INTENT(IN) :: ld_nea ! Flag observations near land 1194 LOGICAL, INTENT(IN) :: ld_bound_reject ! Flag observations near open boundary 1195 INTEGER, INTENT(IN) :: kqc_cutoff ! Cutoff QC value 1196 1746 1197 !! * Local declarations 1747 1198 REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: & 1748 1199 & zgmsk ! Grid mask 1200 #if defined key_bdy 1201 REAL(KIND=wp), DIMENSION(2,2,kprofno) :: & 1202 & zbmsk ! Boundary mask 1203 REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask 1204 #endif 1205 REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: & 1206 & zgdepw 1749 1207 REAL(KIND=wp), DIMENSION(2,2,kprofno) :: & 1750 1208 & zglam, & ! Model longitude at grid points … … 1754 1212 & igrdj 1755 1213 LOGICAL :: lgridobs ! Is observation on a model grid point. 1214 LOGICAL :: ll_next_to_land ! Is a profile next to land 1756 1215 INTEGER :: iig, ijg ! i,j of observation on model grid point. 1757 1216 INTEGER :: jobs, jobsp, jk, ji, jj … … 1763 1222 ! For invalid points use 2,2 1764 1223 1765 IF ( kpobsqc(jobs) >= 10) THEN1224 IF ( kpobsqc(jobs) >= kqc_cutoff ) THEN 1766 1225 1767 1226 igrdi(1,1,jobs) = 1 … … 1788 1247 1789 1248 END DO 1790 1791 CALL obs_int_comm_3d( 2, 2, kprofno, kpk, igrdi, igrdj, pmask, zgmsk ) 1792 CALL obs_int_comm_2d( 2, 2, kprofno, igrdi, igrdj, plam, zglam ) 1793 CALL obs_int_comm_2d( 2, 2, kprofno, igrdi, igrdj, pphi, zgphi ) 1249 1250 #if defined key_bdy 1251 ! Create a mask grid points in boundary rim 1252 IF (ld_bound_reject) THEN 1253 zbdymask(:,:) = 1.0_wp 1254 DO ji = 1, nb_bdy 1255 DO jj = 1, idx_bdy(ji)%nblen(1) 1256 zbdymask(idx_bdy(ji)%nbi(jj,1),idx_bdy(ji)%nbj(jj,1)) = 0.0_wp 1257 ENDDO 1258 ENDDO 1259 ENDIF 1260 1261 CALL obs_int_comm_2d( 2, 2, kprofno, igrdi, igrdj, zbdymask, zbmsk ) 1262 #endif 1263 1264 CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, pmask, zgmsk ) 1265 CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, plam, zglam ) 1266 CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, pphi, zgphi ) 1267 ! Need to know the bathy depth for each observation for sco 1268 CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, fsdepw(:,:,:), & 1269 & zgdepw ) 1794 1270 1795 1271 DO jobs = 1, kprofno 1796 1272 1797 1273 ! Skip bad profiles 1798 IF ( kpobsqc(jobs) >= 10) CYCLE1274 IF ( kpobsqc(jobs) >= kqc_cutoff ) CYCLE 1799 1275 1800 1276 ! Check if this observation is on a grid point … … 1816 1292 END DO 1817 1293 1294 ! Check if next to land 1295 IF ( ANY( zgmsk(1:2,1:2,1,jobs) == 0.0_wp ) ) THEN 1296 ll_next_to_land=.TRUE. 1297 ELSE 1298 ll_next_to_land=.FALSE. 1299 ENDIF 1300 1818 1301 ! Reject observations 1819 1302 … … 1827 1310 & .OR. ( pobsdep(jobsp) < 0.0 ) & 1828 1311 & .OR. ( pobsdep(jobsp) > gdepw_1d(kpk)) ) THEN 1829 kobsqc(jobsp) = kobsqc(jobsp) + 111312 kobsqc(jobsp) = IBSET(kobsqc(jobsp),11) 1830 1313 kosdobs = kosdobs + 1 1831 1314 CYCLE 1832 1315 ENDIF 1833 1316 1834 ! Flag if the observation falls with a model land cell 1835 IF ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) & 1836 & == 0.0_wp ) THEN 1837 kobsqc(jobsp) = kobsqc(jobsp) + 12 1838 klanobs = klanobs + 1 1839 CYCLE 1317 ! To check if an observations falls within land there are two cases: 1318 ! 1: z-coordibnates, where the check uses the mask 1319 ! 2: terrain following (eg s-coordinates), 1320 ! where we use the depth of the bottom cell to mask observations 1321 1322 IF( (.NOT. lk_vvl) .AND. ( ln_zps .OR. ln_zco ) ) THEN !(CASE 1) 1323 1324 ! Flag if the observation falls with a model land cell 1325 IF ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) & 1326 & == 0.0_wp ) THEN 1327 kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) 1328 klanobs = klanobs + 1 1329 CYCLE 1330 ENDIF 1331 1332 ! Flag if the observation is close to land 1333 IF ( MINVAL( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) == & 1334 & 0.0_wp) THEN 1335 knlaobs = knlaobs + 1 1336 IF (ld_nea) THEN 1337 kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) 1338 ENDIF 1339 ENDIF 1340 1341 ELSE ! Case 2 1342 ! Flag if the observation is deeper than the bathymetry 1343 ! Or if it is within the mask 1344 IF ( ANY( zgdepw(1:2,1:2,kpk,jobs) < pobsdep(jobsp) ) & 1345 & .OR. & 1346 & ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) & 1347 & == 0.0_wp) ) THEN 1348 kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) 1349 klanobs = klanobs + 1 1350 CYCLE 1351 ENDIF 1352 1353 ! Flag if the observation is close to land 1354 IF ( ll_next_to_land ) THEN 1355 knlaobs = knlaobs + 1 1356 IF (ld_nea) THEN 1357 kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) 1358 ENDIF 1359 ENDIF 1360 1840 1361 ENDIF 1841 1362 … … 1845 1366 IF (lgridobs) THEN 1846 1367 IF (zgmsk(iig,ijg,kobsk(jobsp)-1,jobs) == 0.0_wp ) THEN 1847 kobsqc(jobsp) = kobsqc(jobsp) + 121368 kobsqc(jobsp) = IBSET(kobsqc(jobs),10) 1848 1369 klanobs = klanobs + 1 1849 1370 CYCLE … … 1851 1372 ENDIF 1852 1373 1853 ! Flag if the observation falls is close to land1854 IF ( MINVAL( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) == &1855 & 0.0_wp) THEN1856 IF (ld_nea) kobsqc(jobsp) = kobsqc(jobsp) + 141857 knlaobs = knlaobs + 11858 ENDIF1859 1860 1374 ! Set observation depth equal to that of the first model depth 1861 1375 IF ( pobsdep(jobsp) <= pdep(1) ) THEN … … 1863 1377 ENDIF 1864 1378 1379 #if defined key_bdy 1380 ! Flag if the observation falls close to the boundary rim 1381 IF (ld_bound_reject) THEN 1382 IF ( MINVAL( zbmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN 1383 kobsqc(jobsp) = IBSET(kobsqc(jobs),8) 1384 kbdyobs = kbdyobs + 1 1385 CYCLE 1386 ENDIF 1387 ! for observations on the grid... 1388 IF (lgridobs) THEN 1389 IF (zbmsk(iig,ijg,jobs) == 0.0_wp ) THEN 1390 kobsqc(jobsp) = IBSET(kobsqc(jobs),8) 1391 kbdyobs = kbdyobs + 1 1392 CYCLE 1393 ENDIF 1394 ENDIF 1395 ENDIF 1396 #endif 1397 1865 1398 END DO 1866 1399 END DO … … 1868 1401 END SUBROUTINE obs_coo_spc_3d 1869 1402 1870 SUBROUTINE obs_pro_rej( profdata )1403 SUBROUTINE obs_pro_rej( profdata, kqc_cutoff ) 1871 1404 !!---------------------------------------------------------------------- 1872 1405 !! *** ROUTINE obs_pro_rej *** … … 1886 1419 !! * Arguments 1887 1420 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Profile data 1421 INTEGER, INTENT(IN) :: kqc_cutoff ! QC cutoff value 1422 1888 1423 !! * Local declarations 1889 1424 INTEGER :: jprof … … 1895 1430 DO jprof = 1, profdata%nprof 1896 1431 1897 IF ( profdata%nqc(jprof) > 10) THEN1432 IF ( profdata%nqc(jprof) > kqc_cutoff ) THEN 1898 1433 1899 1434 DO jvar = 1, profdata%nvar … … 1903 1438 1904 1439 profdata%var(jvar)%nvqc(jobs) = & 1905 & profdata%var(jvar)%nvqc(jobs) + 261440 & IBSET(profdata%var(jvar)%nvqc(jobs),14) 1906 1441 1907 1442 END DO … … 1915 1450 END SUBROUTINE obs_pro_rej 1916 1451 1917 SUBROUTINE obs_uv_rej( profdata, knumu, knumv )1452 SUBROUTINE obs_uv_rej( profdata, knumu, knumv, kqc_cutoff ) 1918 1453 !!---------------------------------------------------------------------- 1919 1454 !! *** ROUTINE obs_uv_rej *** … … 1935 1470 INTEGER, INTENT(INOUT) :: knumu ! Number of u rejected 1936 1471 INTEGER, INTENT(INOUT) :: knumv ! Number of v rejected 1472 INTEGER, INTENT(IN) :: kqc_cutoff ! QC cutoff value 1473 1937 1474 !! * Local declarations 1938 1475 INTEGER :: jprof … … 1954 1491 DO jobs = profdata%npvsta(jprof,1), profdata%npvend(jprof,1) 1955 1492 1956 IF ( ( profdata%var(1)%nvqc(jobs) > 10) .AND. &1957 & ( profdata%var(2)%nvqc(jobs) <= 10) ) THEN1958 profdata%var(2)%nvqc(jobs) = profdata%var(2)%nvqc(jobs) + 421493 IF ( ( profdata%var(1)%nvqc(jobs) > kqc_cutoff ) .AND. & 1494 & ( profdata%var(2)%nvqc(jobs) <= kqc_cutoff) ) THEN 1495 profdata%var(2)%nvqc(jobs) = IBSET(profdata%var(1)%nvqc(jobs),15) 1959 1496 knumv = knumv + 1 1960 1497 ENDIF 1961 IF ( ( profdata%var(2)%nvqc(jobs) > 10) .AND. &1962 & ( profdata%var(1)%nvqc(jobs) <= 10) ) THEN1963 profdata%var(1)%nvqc(jobs) = profdata%var(1)%nvqc(jobs) + 421498 IF ( ( profdata%var(2)%nvqc(jobs) > kqc_cutoff ) .AND. & 1499 & ( profdata%var(1)%nvqc(jobs) <= kqc_cutoff) ) THEN 1500 profdata%var(1)%nvqc(jobs) = IBSET(profdata%var(1)%nvqc(jobs),15) 1964 1501 knumu = knumu + 1 1965 1502 ENDIF -
branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_profiles_def.F90
r7960 r7992 104 104 ! Bookkeeping arrays with sizes equal to number of variables 105 105 106 CHARACTER(len=8), POINTER, DIMENSION(:) :: & 107 & cvars !: Variable names 108 106 109 INTEGER, POINTER, DIMENSION(:) :: & 107 110 & nvprot, & !: Local total number of profile T data … … 237 240 238 241 ALLOCATE( & 242 & prof%cvars(kvar), & 239 243 & prof%nvprot(kvar), & 240 244 & prof%nvprotmpp(kvar) & … … 242 246 243 247 DO jvar = 1, kvar 248 prof%cvars (jvar) = "NotSet" 244 249 prof%nvprot (jvar) = ko3dt(jvar) 245 250 prof%nvprotmpp(jvar) = 0 … … 452 457 453 458 DEALLOCATE( & 454 & prof%nvprot, & 459 & prof%cvars, & 460 & prof%nvprot, & 455 461 & prof%nvprotmpp & 456 462 ) … … 770 776 newprof%npj = prof%npj 771 777 newprof%npk = prof%npk 778 newprof%cvars(:) = prof%cvars(:) 772 779 773 780 ! Deallocate temporary data -
branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_altbias.F90
r7960 r7992 50 50 CONTAINS 51 51 52 SUBROUTINE obs_rea_altbias( kslano,sladata, k2dint, bias_file )52 SUBROUTINE obs_rea_altbias( sladata, k2dint, bias_file ) 53 53 !!--------------------------------------------------------------------- 54 54 !! … … 70 70 ! 71 71 !! * Arguments 72 INTEGER, INTENT(IN) :: kslano ! Number of SLA Products 73 TYPE(obs_surf), DIMENSION(kslano), INTENT(INOUT) :: & 72 TYPE(obs_surf), INTENT(INOUT) :: & 74 73 & sladata ! SLA data 75 74 INTEGER, INTENT(IN) :: k2dint … … 80 79 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_rea_altbias' 81 80 82 INTEGER :: jslano ! Data set loop variable83 81 INTEGER :: jobs ! Obs loop variable 84 82 INTEGER :: jpialtbias ! Number of grid point in latitude for the bias … … 130 128 ! Get the Alt bias data 131 129 132 CALL iom_get( numaltbias, jpdom_ data, 'altbias', z_altbias(:,:), 1 )130 CALL iom_get( numaltbias, jpdom_autoglo, 'altbias', z_altbias(:,:), 1 ) 133 131 134 132 ! Close the file … … 144 142 ! Intepolate the bias already on the model grid at the observation point 145 143 146 DO jslano = 1, kslano 147 148 ALLOCATE( & 149 & igrdi(2,2,sladata(jslano)%nsurf), & 150 & igrdj(2,2,sladata(jslano)%nsurf), & 151 & zglam(2,2,sladata(jslano)%nsurf), & 152 & zgphi(2,2,sladata(jslano)%nsurf), & 153 & zmask(2,2,sladata(jslano)%nsurf), & 154 & zbias(2,2,sladata(jslano)%nsurf) & 155 & ) 156 157 DO jobs = 1, sladata(jslano)%nsurf 158 159 igrdi(1,1,jobs) = sladata(jslano)%mi(jobs)-1 160 igrdj(1,1,jobs) = sladata(jslano)%mj(jobs)-1 161 igrdi(1,2,jobs) = sladata(jslano)%mi(jobs)-1 162 igrdj(1,2,jobs) = sladata(jslano)%mj(jobs) 163 igrdi(2,1,jobs) = sladata(jslano)%mi(jobs) 164 igrdj(2,1,jobs) = sladata(jslano)%mj(jobs)-1 165 igrdi(2,2,jobs) = sladata(jslano)%mi(jobs) 166 igrdj(2,2,jobs) = sladata(jslano)%mj(jobs) 167 168 END DO 169 170 CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, & 171 & igrdi, igrdj, glamt, zglam ) 172 CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, & 173 & igrdi, igrdj, gphit, zgphi ) 174 CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, & 175 & igrdi, igrdj, tmask(:,:,1), zmask ) 176 CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, & 177 & igrdi, igrdj, z_altbias, zbias ) 178 179 DO jobs = 1, sladata(jslano)%nsurf 180 181 zlam = sladata(jslano)%rlam(jobs) 182 zphi = sladata(jslano)%rphi(jobs) 183 iico = sladata(jslano)%mi(jobs) 184 ijco = sladata(jslano)%mj(jobs) 144 ALLOCATE( & 145 & igrdi(2,2,sladata%nsurf), & 146 & igrdj(2,2,sladata%nsurf), & 147 & zglam(2,2,sladata%nsurf), & 148 & zgphi(2,2,sladata%nsurf), & 149 & zmask(2,2,sladata%nsurf), & 150 & zbias(2,2,sladata%nsurf) & 151 & ) 152 153 DO jobs = 1, sladata%nsurf 154 155 igrdi(1,1,jobs) = sladata%mi(jobs)-1 156 igrdj(1,1,jobs) = sladata%mj(jobs)-1 157 igrdi(1,2,jobs) = sladata%mi(jobs)-1 158 igrdj(1,2,jobs) = sladata%mj(jobs) 159 igrdi(2,1,jobs) = sladata%mi(jobs) 160 igrdj(2,1,jobs) = sladata%mj(jobs)-1 161 igrdi(2,2,jobs) = sladata%mi(jobs) 162 igrdj(2,2,jobs) = sladata%mj(jobs) 163 164 END DO 165 166 CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, & 167 & igrdi, igrdj, glamt, zglam ) 168 CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, & 169 & igrdi, igrdj, gphit, zgphi ) 170 CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, & 171 & igrdi, igrdj, tmask(:,:,1), zmask ) 172 CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, & 173 & igrdi, igrdj, z_altbias, zbias ) 174 175 DO jobs = 1, sladata%nsurf 176 177 zlam = sladata%rlam(jobs) 178 zphi = sladata%rphi(jobs) 179 iico = sladata%mi(jobs) 180 ijco = sladata%mj(jobs) 185 181 186 187 188 182 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 183 & zglam(:,:,jobs), zgphi(:,:,jobs), & 184 & zmask(:,:,jobs), zweig, zobsmask ) 189 185 190 CALL obs_int_h2d( 1, 1, & 191 & zweig, zbias(:,:,jobs), zext ) 192 193 ! adjust mdt with bias field 194 sladata(jslano)%rext(jobs,2) = & 195 sladata(jslano)%rext(jobs,2) - zext(1) 186 CALL obs_int_h2d( 1, 1, & 187 & zweig, zbias(:,:,jobs), zext ) 188 189 ! adjust mdt with bias field 190 sladata%rext(jobs,2) = sladata%rext(jobs,2) - zext(1) 196 191 197 END DO198 199 DEALLOCATE( &200 & igrdi, &201 & igrdj, &202 & zglam, &203 & zgphi, &204 & zmask, &205 & zbias &206 & )207 208 192 END DO 209 193 194 DEALLOCATE( & 195 & igrdi, & 196 & igrdj, & 197 & zglam, & 198 & zgphi, & 199 & zmask, & 200 & zbias & 201 & ) 202 210 203 CALL wrk_dealloc(jpi,jpj,z_altbias) 211 204 -
branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_prof.F90
r7960 r7992 25 25 USE netcdf ! NetCDF library 26 26 USE obs_oper ! Observation operators 27 USE obs_prof_io ! Profile files I/O (non-FB files)28 27 USE lib_mpp ! For ctl_warn/stop 28 USE obs_fbm ! Feedback routines 29 29 30 30 IMPLICIT NONE … … 33 33 PRIVATE 34 34 35 PUBLIC obs_rea_pro _dri! Read the profile observations35 PUBLIC obs_rea_prof ! Read the profile observations 36 36 37 37 !!---------------------------------------------------------------------- … … 42 42 43 43 CONTAINS 44 45 SUBROUTINE obs_rea_pro_dri( kformat, & 46 & profdata, knumfiles, cfilenames, & 47 & kvars, kextr, kstp, ddobsini, ddobsend, & 48 & ldt3d, lds3d, ldignmis, ldsatt, ldavtimset, & 49 & ldmod, kdailyavtypes ) 44 45 SUBROUTINE obs_rea_prof( profdata, knumfiles, cdfilenames, & 46 & kvars, kextr, kstp, ddobsini, ddobsend, & 47 & ldvar1, ldvar2, ldignmis, ldsatt, & 48 & ldmod, kdailyavtypes ) 50 49 !!--------------------------------------------------------------------- 51 50 !! 52 !! *** ROUTINE obs_rea_pro _dri***51 !! *** ROUTINE obs_rea_prof *** 53 52 !! 54 53 !! ** Purpose : Read from file the profile observations 55 54 !! 56 !! ** Method : Depending on kformat either ENACT, CORIOLIS or57 !! feedback data files are read55 !! ** Method : Read feedback data in and transform to NEMO internal 56 !! profile data structure 58 57 !! 59 58 !! ** Action : … … 63 62 !! History : 64 63 !! ! : 2009-09 (K. Mogensen) : New merged version of old routines 64 !! ! : 2015-08 (M. Martin) : Merged profile and velocity routines 65 65 !!---------------------------------------------------------------------- 66 !! * Modules used 67 66 68 67 !! * Arguments 69 INTEGER :: kformat ! Format of input data 70 ! ! 1: ENACT 71 ! ! 2: Coriolis 72 TYPE(obs_prof), INTENT(OUT) :: profdata ! Profile data to be read 73 INTEGER, INTENT(IN) :: knumfiles ! Number of files to read in 68 TYPE(obs_prof), INTENT(OUT) :: & 69 & profdata ! Profile data to be read 70 INTEGER, INTENT(IN) :: knumfiles ! Number of files to read 74 71 CHARACTER(LEN=128), INTENT(IN) :: & 75 & c filenames(knumfiles)! File names to read in72 & cdfilenames(knumfiles) ! File names to read in 76 73 INTEGER, INTENT(IN) :: kvars ! Number of variables in profdata 77 INTEGER, INTENT(IN) :: kextr ! Number of extra fields for each var in profdata 78 INTEGER, INTENT(IN) :: kstp ! Ocean time-step index 79 LOGICAL, INTENT(IN) :: ldt3d ! Observed variables switches 80 LOGICAL, INTENT(IN) :: lds3d 81 LOGICAL, INTENT(IN) :: ldignmis ! Ignore missing files 82 LOGICAL, INTENT(IN) :: ldsatt ! Compute salinity at all temperature points 83 LOGICAL, INTENT(IN) :: ldavtimset ! Correct time for daily averaged data 84 LOGICAL, INTENT(IN) :: ldmod ! Initialize model from input data 85 REAL(KIND=dp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS 86 REAL(KIND=dp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS 74 INTEGER, INTENT(IN) :: kextr ! Number of extra fields for each var 75 INTEGER, INTENT(IN) :: kstp ! Ocean time-step index 76 LOGICAL, INTENT(IN) :: ldvar1 ! Observed variables switches 77 LOGICAL, INTENT(IN) :: ldvar2 78 LOGICAL, INTENT(IN) :: ldignmis ! Ignore missing files 79 LOGICAL, INTENT(IN) :: ldsatt ! Compute salinity at all temperature points 80 LOGICAL, INTENT(IN) :: ldmod ! Initialize model from input data 81 REAL(dp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS 82 REAL(dp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS 87 83 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 88 & kdailyavtypes 84 & kdailyavtypes ! Types of daily average observations 89 85 90 86 !! * Local declarations 91 CHARACTER(LEN=15), PARAMETER :: cpname='obs_rea_pro_dri' 87 CHARACTER(LEN=15), PARAMETER :: cpname='obs_rea_prof' 88 CHARACTER(len=8) :: clrefdate 89 CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvars 92 90 INTEGER :: jvar 93 91 INTEGER :: ji … … 105 103 INTEGER :: imin 106 104 INTEGER :: isec 105 INTEGER :: iprof 106 INTEGER :: iproftot 107 INTEGER :: ivar1t0 108 INTEGER :: ivar2t0 109 INTEGER :: ivar1t 110 INTEGER :: ivar2t 111 INTEGER :: ip3dt 112 INTEGER :: ios 113 INTEGER :: ioserrcount 114 INTEGER :: ivar1tmpp 115 INTEGER :: ivar2tmpp 116 INTEGER :: ip3dtmpp 117 INTEGER :: itype 107 118 INTEGER, DIMENSION(knumfiles) :: & 108 119 & irefdate 109 120 INTEGER, DIMENSION(ntyp1770+1) :: & 110 & itypt, & 111 & ityptmpp, & 112 & ityps, & 113 & itypsmpp 114 INTEGER :: it3dtmpp 115 INTEGER :: is3dtmpp 116 INTEGER :: ip3dtmpp 121 & itypvar1, & 122 & itypvar1mpp, & 123 & itypvar2, & 124 & itypvar2mpp 117 125 INTEGER, DIMENSION(:), ALLOCATABLE :: & 118 & iobsi, & 119 & iobsj, & 120 & iproc, & 126 & iobsi1, & 127 & iobsj1, & 128 & iproc1, & 129 & iobsi2, & 130 & iobsj2, & 131 & iproc2, & 121 132 & iindx, & 122 133 & ifileidx, & 123 134 & iprofidx 124 INTEGER :: itype125 135 INTEGER, DIMENSION(imaxavtypes) :: & 126 136 & idailyavtypes 137 INTEGER, DIMENSION(kvars) :: & 138 & iv3dt 127 139 REAL(wp), DIMENSION(:), ALLOCATABLE :: & 128 140 & zphi, & 129 141 & zlam 130 real(wp), DIMENSION(:), ALLOCATABLE :: &142 REAL(wp), DIMENSION(:), ALLOCATABLE :: & 131 143 & zdat 144 REAL(wp), DIMENSION(knumfiles) :: & 145 & djulini, & 146 & djulend 132 147 LOGICAL :: llvalprof 148 LOGICAL :: lldavtimset 133 149 TYPE(obfbdata), POINTER, DIMENSION(:) :: & 134 150 & inpfiles 135 real(wp), DIMENSION(knumfiles) :: & 136 & djulini, & 137 & djulend 138 INTEGER :: iprof 139 INTEGER :: iproftot 140 INTEGER :: it3dt0 141 INTEGER :: is3dt0 142 INTEGER :: it3dt 143 INTEGER :: is3dt 144 INTEGER :: ip3dt 145 INTEGER :: ios 146 INTEGER :: ioserrcount 147 INTEGER, DIMENSION(kvars) :: & 148 & iv3dt 149 CHARACTER(len=8) :: cl_refdate 150 151 151 152 ! Local initialization 152 153 iprof = 0 153 i t3dt0 = 0154 i s3dt0 = 0154 ivar1t0 = 0 155 ivar2t0 = 0 155 156 ip3dt = 0 156 157 157 158 ! Daily average types 159 lldavtimset = .FALSE. 158 160 IF ( PRESENT(kdailyavtypes) ) THEN 159 161 idailyavtypes(:) = kdailyavtypes(:) 162 IF ( ANY (idailyavtypes(:) /= -1) ) lldavtimset = .TRUE. 160 163 ELSE 161 164 idailyavtypes(:) = -1 … … 163 166 164 167 !----------------------------------------------------------------------- 165 ! Check data the model part is just with feedback data files166 !-----------------------------------------------------------------------167 IF ( ldmod .AND. ( kformat /= 0 ) ) THEN168 CALL ctl_stop( 'Model can only be read from feedback data' )169 RETURN170 ENDIF171 172 !-----------------------------------------------------------------------173 168 ! Count the number of files needed and allocate the obfbdata type 174 169 !----------------------------------------------------------------------- 175 170 176 171 inobf = knumfiles 177 172 178 173 ALLOCATE( inpfiles(inobf) ) 179 174 180 175 prof_files : DO jj = 1, inobf 181 176 182 177 !--------------------------------------------------------------------- 183 178 ! Prints … … 186 181 WRITE(numout,*) 187 182 WRITE(numout,*) ' obs_rea_pro_dri : Reading from file = ', & 188 & TRIM( TRIM( c filenames(jj) ) )183 & TRIM( TRIM( cdfilenames(jj) ) ) 189 184 WRITE(numout,*) ' ~~~~~~~~~~~~~~~' 190 185 WRITE(numout,*) … … 194 189 ! Initialization: Open file and get dimensions only 195 190 !--------------------------------------------------------------------- 196 197 iflag = nf90_open( TRIM( TRIM( cfilenames(jj)) ), nf90_nowrite, &191 192 iflag = nf90_open( TRIM( cdfilenames(jj) ), nf90_nowrite, & 198 193 & i_file_id ) 199 194 200 195 IF ( iflag /= nf90_noerr ) THEN 201 196 202 197 IF ( ldignmis ) THEN 203 198 inpfiles(jj)%nobs = 0 204 CALL ctl_warn( 'File ' // TRIM( TRIM( cfilenames(jj)) ) // &199 CALL ctl_warn( 'File ' // TRIM( cdfilenames(jj) ) // & 205 200 & ' not found' ) 206 201 ELSE 207 CALL ctl_stop( 'File ' // TRIM( TRIM( cfilenames(jj)) ) // &202 CALL ctl_stop( 'File ' // TRIM( cdfilenames(jj) ) // & 208 203 & ' not found' ) 209 204 ENDIF 210 205 211 206 ELSE 212 207 213 208 !------------------------------------------------------------------ 214 ! Close the file since it is opened in read_ proffile209 ! Close the file since it is opened in read_obfbdata 215 210 !------------------------------------------------------------------ 216 211 217 212 iflag = nf90_close( i_file_id ) 218 213 … … 220 215 ! Read the profile file into inpfiles 221 216 !------------------------------------------------------------------ 222 IF ( kformat == 0 ) THEN 223 CALL init_obfbdata( inpfiles(jj) ) 224 IF(lwp) THEN 225 WRITE(numout,*) 226 WRITE(numout,*)'Reading from feedback file :', & 227 & TRIM( cfilenames(jj) ) 228 ENDIF 229 CALL read_obfbdata( TRIM( cfilenames(jj) ), inpfiles(jj), & 230 & ldgrid = .TRUE. ) 231 IF ( inpfiles(jj)%nvar < 2 ) THEN 232 CALL ctl_stop( 'Feedback format error' ) 233 RETURN 234 ENDIF 235 IF ( TRIM(inpfiles(jj)%cname(1)) /= 'POTM' ) THEN 236 CALL ctl_stop( 'Feedback format error' ) 237 RETURN 238 ENDIF 239 IF ( TRIM(inpfiles(jj)%cname(2)) /= 'PSAL' ) THEN 240 CALL ctl_stop( 'Feedback format error' ) 241 RETURN 242 ENDIF 243 IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN 244 CALL ctl_stop( 'Model not in input data' ) 245 RETURN 246 ENDIF 247 ELSEIF ( kformat == 1 ) THEN 248 CALL read_enactfile( TRIM( cfilenames(jj) ), inpfiles(jj), & 249 & numout, lwp, .TRUE. ) 250 ELSEIF ( kformat == 2 ) THEN 251 CALL read_coriofile( TRIM( cfilenames(jj) ), inpfiles(jj), & 252 & numout, lwp, .TRUE. ) 217 CALL init_obfbdata( inpfiles(jj) ) 218 CALL read_obfbdata( TRIM( cdfilenames(jj) ), inpfiles(jj), & 219 & ldgrid = .TRUE. ) 220 221 IF ( inpfiles(jj)%nvar < 2 ) THEN 222 CALL ctl_stop( 'Feedback format error: ', & 223 & ' less than 2 vars in profile file' ) 224 ENDIF 225 226 IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN 227 CALL ctl_stop( 'Model not in input data' ) 228 ENDIF 229 230 IF ( jj == 1 ) THEN 231 ALLOCATE( clvars( inpfiles(jj)%nvar ) ) 232 DO ji = 1, inpfiles(jj)%nvar 233 clvars(ji) = inpfiles(jj)%cname(ji) 234 END DO 253 235 ELSE 254 CALL ctl_stop( 'File format unknown' ) 255 ENDIF 256 236 DO ji = 1, inpfiles(jj)%nvar 237 IF ( inpfiles(jj)%cname(ji) /= clvars(ji) ) THEN 238 CALL ctl_stop( 'Feedback file variables not consistent', & 239 & ' with previous files for this type' ) 240 ENDIF 241 END DO 242 ENDIF 243 257 244 !------------------------------------------------------------------ 258 245 ! Change longitude (-180,180) … … 272 259 ! Calculate the date (change eventually) 273 260 !------------------------------------------------------------------ 274 cl _refdate=inpfiles(jj)%cdjuldref(1:8)275 READ(cl _refdate,'(I8)') irefdate(jj)276 261 clrefdate=inpfiles(jj)%cdjuldref(1:8) 262 READ(clrefdate,'(I8)') irefdate(jj) 263 277 264 CALL ddatetoymdhms( ddobsini, iyea, imon, iday, ihou, imin, isec ) 278 265 CALL greg2jul( isec, imin, ihou, iday, imon, iyea, djulini(jj), & … … 283 270 284 271 ioserrcount=0 285 IF ( ldavtimset ) THEN 272 IF ( lldavtimset ) THEN 273 274 IF ( ANY ( idailyavtypes(:) /= -1 ) .AND. lwp) THEN 275 WRITE(numout,*)' Resetting time of daily averaged', & 276 & ' observations to the end of the day' 277 ENDIF 278 286 279 DO ji = 1, inpfiles(jj)%nobs 287 !288 ! for daily averaged data for example289 ! MRB data (itype==820) force the time290 ! to be the end of the day291 !292 280 READ( inpfiles(jj)%cdtyp(ji), '(I4)', IOSTAT = ios, ERR = 900 ) itype 293 281 900 IF ( ios /= 0 ) THEN 294 itype = 0 ! Set type to zero if there is a problem in the string conversion 295 ENDIF 296 IF ( ANY (idailyavtypes == itype ) ) THEN 297 inpfiles(jj)%ptim(ji) = & 298 & INT(inpfiles(jj)%ptim(ji)) + 1 299 ENDIF 282 ! Set type to zero if there is a problem in the string conversion 283 itype = 0 284 ENDIF 285 286 IF ( ANY ( idailyavtypes(:) == itype ) ) THEN 287 ! for daily averaged data force the time 288 ! to be the last time-step of the day, but still within the day. 289 IF ( inpfiles(jj)%ptim(ji) >= 0. ) THEN 290 inpfiles(jj)%ptim(ji) = & 291 & INT(inpfiles(jj)%ptim(ji)) + 0.9999 292 ELSE 293 inpfiles(jj)%ptim(ji) = & 294 & INT(inpfiles(jj)%ptim(ji)) - 0.0001 295 ENDIF 296 ENDIF 297 300 298 END DO 301 ENDIF 302 299 300 ENDIF 301 303 302 IF ( inpfiles(jj)%nobs > 0 ) THEN 304 inpfiles(jj)%iproc = -1305 inpfiles(jj)%iobsi = -1306 inpfiles(jj)%iobsj = -1303 inpfiles(jj)%iproc(:,:) = -1 304 inpfiles(jj)%iobsi(:,:) = -1 305 inpfiles(jj)%iobsj(:,:) = -1 307 306 ENDIF 308 307 inowin = 0 309 308 DO ji = 1, inpfiles(jj)%nobs 310 IF ( inpfiles(jj)%ioqc(ji) > 2) CYCLE311 IF ( ( inpfiles(jj)%ivqc(ji,1) > 2) .AND. &312 & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE309 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 313 312 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 314 313 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 318 317 ALLOCATE( zlam(inowin) ) 319 318 ALLOCATE( zphi(inowin) ) 320 ALLOCATE( iobsi(inowin) ) 321 ALLOCATE( iobsj(inowin) ) 322 ALLOCATE( iproc(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) ) 323 325 inowin = 0 324 326 DO ji = 1, inpfiles(jj)%nobs 325 IF ( inpfiles(jj)%ioqc(ji) > 2) CYCLE326 IF ( ( inpfiles(jj)%ivqc(ji,1) > 2) .AND. &327 & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE327 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 330 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 329 331 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 334 336 END DO 335 337 336 CALL obs_grid_search( inowin, zlam, zphi, iobsi, iobsj, iproc, 'T' ) 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' ) 349 ENDIF 337 350 338 351 inowin = 0 339 352 DO ji = 1, inpfiles(jj)%nobs 340 IF ( inpfiles(jj)%ioqc(ji) > 2) CYCLE341 IF ( ( inpfiles(jj)%ivqc(ji,1) > 2) .AND. &342 & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE353 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 343 356 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 344 357 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN 345 358 inowin = inowin + 1 346 inpfiles(jj)%iproc(ji,1) = iproc(inowin) 347 inpfiles(jj)%iobsi(ji,1) = iobsi(inowin) 348 inpfiles(jj)%iobsj(ji,1) = iobsj(inowin) 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') 369 ENDIF 349 370 ENDIF 350 371 END DO 351 DEALLOCATE( zlam, zphi, iobsi , iobsj, iproc)372 DEALLOCATE( zlam, zphi, iobsi1, iobsj1, iproc1, iobsi2, iobsj2, iproc2 ) 352 373 353 374 DO ji = 1, inpfiles(jj)%nobs 354 IF ( inpfiles(jj)%ioqc(ji) > 2) CYCLE355 IF ( ( inpfiles(jj)%ivqc(ji,1) > 2) .AND. &356 & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE375 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 357 378 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 358 379 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 363 384 ENDIF 364 385 llvalprof = .FALSE. 365 IF ( ld t3d) THEN386 IF ( ldvar1 ) THEN 366 387 loop_t_count : DO ij = 1,inpfiles(jj)%nlev 367 388 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 368 389 & CYCLE 369 IF ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2) .AND. &370 & ( inpfiles(jj)%idqc(ij,ji) <= 2) ) THEN371 i t3dt0 = it3dt0 + 1390 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 372 393 ENDIF 373 394 END DO loop_t_count 374 395 ENDIF 375 IF ( ld s3d) THEN396 IF ( ldvar2 ) THEN 376 397 loop_s_count : DO ij = 1,inpfiles(jj)%nlev 377 398 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 378 399 & CYCLE 379 IF ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2) .AND. &380 & ( inpfiles(jj)%idqc(ij,ji) <= 2) ) THEN381 i s3dt0 = is3dt0 + 1400 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 382 403 ENDIF 383 404 END DO loop_s_count … … 386 407 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 387 408 & CYCLE 388 IF ( ( ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2) .AND. &389 & ( inpfiles(jj)%idqc(ij,ji) <= 2 )) .AND. &390 & ldt3d) .OR. &391 & ( ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2) .AND. &392 & ( inpfiles(jj)%idqc(ij,ji) <= 2 )) .AND. &393 & ld s3d) ) THEN409 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 ) ) THEN 394 415 ip3dt = ip3dt + 1 395 416 llvalprof = .TRUE. … … 405 426 406 427 END DO prof_files 407 428 408 429 !----------------------------------------------------------------------- 409 430 ! Get the time ordered indices of the input data … … 416 437 DO jj = 1, inobf 417 438 DO ji = 1, inpfiles(jj)%nobs 418 IF ( inpfiles(jj)%ioqc(ji) > 2) CYCLE419 IF ( ( inpfiles(jj)%ivqc(ji,1) > 2) .AND. &420 & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE439 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 421 442 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 422 443 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 431 452 DO jj = 1, inobf 432 453 DO ji = 1, inpfiles(jj)%nobs 433 IF ( inpfiles(jj)%ioqc(ji) > 2) CYCLE434 IF ( ( inpfiles(jj)%ivqc(ji,1) > 2) .AND. &435 & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE454 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 436 457 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 437 458 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 446 467 & zdat, & 447 468 & iindx ) 448 469 449 470 iv3dt(:) = -1 450 471 IF (ldsatt) THEN … … 452 473 iv3dt(2) = ip3dt 453 474 ELSE 454 iv3dt(1) = i t3dt0455 iv3dt(2) = i s3dt0475 iv3dt(1) = ivar1t0 476 iv3dt(2) = ivar2t0 456 477 ENDIF 457 478 CALL obs_prof_alloc( profdata, kvars, kextr, iprof, iv3dt, & 458 479 & kstp, jpi, jpj, jpk ) 459 480 460 481 ! * Read obs/positions, QC, all variable and assign to profdata 461 482 462 483 profdata%nprof = 0 463 484 profdata%nvprot(:) = 0 464 485 profdata%cvars(:) = clvars(:) 465 486 iprof = 0 466 487 467 488 ip3dt = 0 468 i t3dt = 0469 i s3dt = 0470 ityp t(:) = 0471 ityp tmpp(:) = 0472 473 ityp s(:) = 0474 ityp smpp(:) = 0475 476 ioserrcount = 0 489 ivar1t = 0 490 ivar2t = 0 491 itypvar1 (:) = 0 492 itypvar1mpp(:) = 0 493 494 itypvar2 (:) = 0 495 itypvar2mpp(:) = 0 496 497 ioserrcount = 0 477 498 DO jk = 1, iproftot 478 499 479 500 jj = ifileidx(iindx(jk)) 480 501 ji = iprofidx(iindx(jk)) 481 502 482 IF ( inpfiles(jj)%ioqc(ji) > 2) CYCLE483 IF ( ( inpfiles(jj)%ivqc(ji,1) > 2) .AND. &484 & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE503 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 485 506 486 507 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 487 508 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN 488 509 489 510 IF ( nproc == 0 ) THEN 490 511 IF ( inpfiles(jj)%iproc(ji,1) > nproc ) CYCLE … … 492 513 IF ( inpfiles(jj)%iproc(ji,1) /= nproc ) CYCLE 493 514 ENDIF 494 515 495 516 llvalprof = .FALSE. 496 517 497 518 IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 498 519 499 IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .AND. & 500 & ( inpfiles(jj)%ivqc(ji,2) > 2 ) ) CYCLE 520 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 501 523 502 524 loop_prof : DO ij = 1, inpfiles(jj)%nlev 503 525 504 526 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 505 527 & CYCLE 506 507 IF ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2) .AND. &508 & ( inpfiles(jj)%idqc(ij,ji) <= 2) ) THEN509 528 529 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 530 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 531 510 532 llvalprof = .TRUE. 511 533 EXIT loop_prof 512 534 513 535 ENDIF 514 515 IF ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2) .AND. &516 & ( inpfiles(jj)%idqc(ij,ji) <= 2) ) THEN517 536 537 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 538 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 539 518 540 llvalprof = .TRUE. 519 541 EXIT loop_prof 520 542 521 543 ENDIF 522 544 523 545 END DO loop_prof 524 546 525 547 ! Set profile information 526 548 527 549 IF ( llvalprof ) THEN 528 550 529 551 iprof = iprof + 1 530 552 … … 545 567 profdata%nhou(iprof) = ihou 546 568 profdata%nmin(iprof) = imin 547 569 548 570 ! Profile space coordinates 549 571 profdata%rlam(iprof) = inpfiles(jj)%plam(ji) … … 551 573 552 574 ! Coordinate search parameters 553 profdata%mi (iprof,:) = inpfiles(jj)%iobsi(ji,1) 554 profdata%mj (iprof,:) = inpfiles(jj)%iobsj(ji,1) 555 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) 579 556 580 ! Profile WMO number 557 581 profdata%cwmo(iprof) = inpfiles(jj)%cdwmo(ji) 558 582 559 583 ! Instrument type 560 584 READ( inpfiles(jj)%cdtyp(ji), '(I4)', IOSTAT = ios, ERR = 901 ) itype … … 564 588 itype = 0 565 589 ENDIF 566 590 567 591 profdata%ntyp(iprof) = itype 568 592 569 593 ! QC stuff 570 594 … … 585 609 profdata%nqc(iprof) = 0 !TODO 586 610 587 loop_p : DO ij = 1, inpfiles(jj)%nlev 588 611 loop_p : DO ij = 1, inpfiles(jj)%nlev 612 589 613 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 590 614 & CYCLE … … 592 616 IF (ldsatt) THEN 593 617 594 IF ( ( ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2) .AND. &595 & ( inpfiles(jj)%idqc(ij,ji) <= 2 )) .AND. &596 & ldt3d) .OR. &597 & ( ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2) .AND. &598 & ( inpfiles(jj)%idqc(ij,ji) <= 2 )) .AND. &599 & lds3d) ) THEN618 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 600 624 ip3dt = ip3dt + 1 601 625 ELSE 602 626 CYCLE 603 627 ENDIF 604 605 ENDIF 606 607 IF ( ( ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2) .AND. &608 & ( inpfiles(jj)%idqc(ij,ji) <= 2 )) .AND. &609 & ldt3d) .OR. ldsatt ) THEN610 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 611 635 IF (ldsatt) THEN 612 636 613 i t3dt = ip3dt637 ivar1t = ip3dt 614 638 615 639 ELSE 616 640 617 i t3dt = it3dt + 1618 641 ivar1t = ivar1t + 1 642 619 643 ENDIF 620 644 621 ! Depth of Tobservation622 profdata%var(1)%vdep(i t3dt) = &645 ! Depth of var1 observation 646 profdata%var(1)%vdep(ivar1t) = & 623 647 & inpfiles(jj)%pdep(ij,ji) 624 625 ! Depth of Tobservation QC626 profdata%var(1)%idqc(i t3dt) = &648 649 ! Depth of var1 observation QC 650 profdata%var(1)%idqc(ivar1t) = & 627 651 & inpfiles(jj)%idqc(ij,ji) 628 629 ! Depth of Tobservation QC flags630 profdata%var(1)%idqcf(:,i t3dt) = &652 653 ! Depth of var1 observation QC flags 654 profdata%var(1)%idqcf(:,ivar1t) = & 631 655 & inpfiles(jj)%idqcf(:,ij,ji) 632 656 633 657 ! Profile index 634 profdata%var(1)%nvpidx(i t3dt) = iprof635 658 profdata%var(1)%nvpidx(ivar1t) = iprof 659 636 660 ! Vertical index in original profile 637 profdata%var(1)%nvlidx(i t3dt) = ij638 639 ! Profile potential Tvalue640 IF ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2) .AND. &641 & ( inpfiles(jj)%idqc(ij,ji) <= 2) ) THEN642 profdata%var(1)%vobs(i t3dt) = &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) = & 643 667 & inpfiles(jj)%pob(ij,ji,1) 644 668 IF ( ldmod ) THEN 645 profdata%var(1)%vmod(i t3dt) = &669 profdata%var(1)%vmod(ivar1t) = & 646 670 & inpfiles(jj)%padd(ij,ji,1,1) 647 671 ENDIF 648 ! Count number of profile Tdata as function of type649 ityp t( profdata%ntyp(iprof) + 1 ) = &650 & ityp t( profdata%ntyp(iprof) + 1 ) + 1672 ! Count number of profile var1 data as function of type 673 itypvar1( profdata%ntyp(iprof) + 1 ) = & 674 & itypvar1( profdata%ntyp(iprof) + 1 ) + 1 651 675 ELSE 652 profdata%var(1)%vobs(i t3dt) = fbrmdi676 profdata%var(1)%vobs(ivar1t) = fbrmdi 653 677 ENDIF 654 678 655 ! Profile Tqc656 profdata%var(1)%nvqc(i t3dt) = &679 ! Profile var1 qc 680 profdata%var(1)%nvqc(ivar1t) = & 657 681 & inpfiles(jj)%ivlqc(ij,ji,1) 658 682 659 ! Profile Tqc flags660 profdata%var(1)%nvqcf(:,i t3dt) = &683 ! Profile var1 qc flags 684 profdata%var(1)%nvqcf(:,ivar1t) = & 661 685 & inpfiles(jj)%ivlqcf(:,ij,ji,1) 662 686 663 687 ! Profile insitu T value 664 profdata%var(1)%vext(it3dt,1) = & 665 & inpfiles(jj)%pext(ij,ji,1) 666 667 ENDIF 668 669 IF ( ( ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2 ) .AND. & 670 & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) .AND. & 671 & lds3d ) .OR. ldsatt ) THEN 672 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 673 699 IF (ldsatt) THEN 674 700 675 i s3dt = ip3dt701 ivar2t = ip3dt 676 702 677 703 ELSE 678 704 679 i s3dt = is3dt + 1680 705 ivar2t = ivar2t + 1 706 681 707 ENDIF 682 708 683 ! Depth of Sobservation684 profdata%var(2)%vdep(i s3dt) = &709 ! Depth of var2 observation 710 profdata%var(2)%vdep(ivar2t) = & 685 711 & inpfiles(jj)%pdep(ij,ji) 686 687 ! Depth of Sobservation QC688 profdata%var(2)%idqc(i s3dt) = &712 713 ! Depth of var2 observation QC 714 profdata%var(2)%idqc(ivar2t) = & 689 715 & inpfiles(jj)%idqc(ij,ji) 690 691 ! Depth of Sobservation QC flags692 profdata%var(2)%idqcf(:,i s3dt) = &716 717 ! Depth of var2 observation QC flags 718 profdata%var(2)%idqcf(:,ivar2t) = & 693 719 & inpfiles(jj)%idqcf(:,ij,ji) 694 720 695 721 ! Profile index 696 profdata%var(2)%nvpidx(i s3dt) = iprof697 722 profdata%var(2)%nvpidx(ivar2t) = iprof 723 698 724 ! Vertical index in original profile 699 profdata%var(2)%nvlidx(i s3dt) = ij700 701 ! Profile Svalue702 IF ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2) .AND. &703 & ( inpfiles(jj)%idqc(ij,ji) <= 2 )) THEN704 profdata%var(2)%vobs(i s3dt) = &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) = & 705 731 & inpfiles(jj)%pob(ij,ji,2) 706 732 IF ( ldmod ) THEN 707 profdata%var(2)%vmod(i s3dt) = &733 profdata%var(2)%vmod(ivar2t) = & 708 734 & inpfiles(jj)%padd(ij,ji,1,2) 709 735 ENDIF 710 ! Count number of profile Sdata as function of type711 ityp s( profdata%ntyp(iprof) + 1 ) = &712 & ityp s( profdata%ntyp(iprof) + 1 ) + 1736 ! Count number of profile var2 data as function of type 737 itypvar2( profdata%ntyp(iprof) + 1 ) = & 738 & itypvar2( profdata%ntyp(iprof) + 1 ) + 1 713 739 ELSE 714 profdata%var(2)%vobs(i s3dt) = fbrmdi740 profdata%var(2)%vobs(ivar2t) = fbrmdi 715 741 ENDIF 716 717 ! Profile Sqc718 profdata%var(2)%nvqc(i s3dt) = &742 743 ! Profile var2 qc 744 profdata%var(2)%nvqc(ivar2t) = & 719 745 & inpfiles(jj)%ivlqc(ij,ji,2) 720 746 721 ! Profile Sqc flags722 profdata%var(2)%nvqcf(:,i s3dt) = &747 ! Profile var2 qc flags 748 profdata%var(2)%nvqcf(:,ivar2t) = & 723 749 & inpfiles(jj)%ivlqcf(:,ij,ji,2) 724 750 725 751 ENDIF 726 752 727 753 END DO loop_p 728 754 … … 736 762 ! Sum up over processors 737 763 !----------------------------------------------------------------------- 738 739 CALL obs_mpp_sum_integer ( i t3dt0, it3dtmpp )740 CALL obs_mpp_sum_integer ( i s3dt0, is3dtmpp )741 CALL obs_mpp_sum_integer ( ip3dt, ip3dtmpp)742 743 CALL obs_mpp_sum_integers( ityp t, ityptmpp, ntyp1770 + 1 )744 CALL obs_mpp_sum_integers( ityp s, itypsmpp, ntyp1770 + 1 )745 764 765 CALL obs_mpp_sum_integer ( ivar1t0, ivar1tmpp ) 766 CALL obs_mpp_sum_integer ( ivar2t0, ivar2tmpp ) 767 CALL obs_mpp_sum_integer ( ip3dt, ip3dtmpp ) 768 769 CALL obs_mpp_sum_integers( itypvar1, itypvar1mpp, ntyp1770 + 1 ) 770 CALL obs_mpp_sum_integers( itypvar2, itypvar2mpp, ntyp1770 + 1 ) 771 746 772 !----------------------------------------------------------------------- 747 773 ! Output number of observations. … … 749 775 IF(lwp) THEN 750 776 WRITE(numout,*) 751 WRITE(numout,'( 1X,A)') 'Profile data'777 WRITE(numout,'(A)') ' Profile data' 752 778 WRITE(numout,'(1X,A)') '------------' 753 779 WRITE(numout,*) 754 WRITE(numout,'(1X,A)') 'Profile T data'755 WRITE(numout,'(1X,A)') '-------------- '780 WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(1) ) 781 WRITE(numout,'(1X,A)') '------------------------' 756 782 DO ji = 0, ntyp1770 757 IF ( ityp tmpp(ji+1) > 0 ) THEN783 IF ( itypvar1mpp(ji+1) > 0 ) THEN 758 784 WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 759 785 & cwmonam1770(ji)(1:52),' = ', & 760 & ityp tmpp(ji+1)786 & itypvar1mpp(ji+1) 761 787 ENDIF 762 788 END DO … … 764 790 & '---------------------------------------------------------------' 765 791 WRITE(numout,'(1X,A55,I8)') & 766 & 'Total profile T data = ',&767 & it3dtmpp792 & 'Total profile data for variable '//TRIM( profdata%cvars(1) )// & 793 & ' = ', ivar1tmpp 768 794 WRITE(numout,'(1X,A)') & 769 795 & '---------------------------------------------------------------' 770 796 WRITE(numout,*) 771 WRITE(numout,'(1X,A)') 'Profile S data'772 WRITE(numout,'(1X,A)') '-------------- '797 WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(2) ) 798 WRITE(numout,'(1X,A)') '------------------------' 773 799 DO ji = 0, ntyp1770 774 IF ( ityp smpp(ji+1) > 0 ) THEN800 IF ( itypvar2mpp(ji+1) > 0 ) THEN 775 801 WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 776 802 & cwmonam1770(ji)(1:52),' = ', & 777 & ityp smpp(ji+1)803 & itypvar2mpp(ji+1) 778 804 ENDIF 779 805 END DO … … 781 807 & '---------------------------------------------------------------' 782 808 WRITE(numout,'(1X,A55,I8)') & 783 & 'Total profile S data = ',&784 & is3dtmpp809 & 'Total profile data for variable '//TRIM( profdata%cvars(2) )// & 810 & ' = ', ivar2tmpp 785 811 WRITE(numout,'(1X,A)') & 786 812 & '---------------------------------------------------------------' 787 813 WRITE(numout,*) 788 814 ENDIF 789 815 790 816 IF (ldsatt) THEN 791 817 profdata%nvprot(1) = ip3dt … … 794 820 profdata%nvprotmpp(2) = ip3dtmpp 795 821 ELSE 796 profdata%nvprot(1) = i t3dt797 profdata%nvprot(2) = i s3dt798 profdata%nvprotmpp(1) = i t3dtmpp799 profdata%nvprotmpp(2) = i s3dtmpp822 profdata%nvprot(1) = ivar1t 823 profdata%nvprot(2) = ivar2t 824 profdata%nvprotmpp(1) = ivar1tmpp 825 profdata%nvprotmpp(2) = ivar2tmpp 800 826 ENDIF 801 827 profdata%nprof = iprof … … 804 830 ! Model level search 805 831 !----------------------------------------------------------------------- 806 IF ( ld t3d) THEN832 IF ( ldvar1 ) THEN 807 833 CALL obs_level_search( jpk, gdept_1d, & 808 834 & profdata%nvprot(1), profdata%var(1)%vdep, & 809 835 & profdata%var(1)%mvk ) 810 836 ENDIF 811 IF ( ld s3d) THEN837 IF ( ldvar2 ) THEN 812 838 CALL obs_level_search( jpk, gdept_1d, & 813 839 & profdata%nvprot(2), profdata%var(2)%vdep, & 814 840 & profdata%var(2)%mvk ) 815 841 ENDIF 816 842 817 843 !----------------------------------------------------------------------- 818 844 ! Set model equivalent to 99999 … … 826 852 ! Deallocate temporary data 827 853 !----------------------------------------------------------------------- 828 DEALLOCATE( ifileidx, iprofidx, zdat )854 DEALLOCATE( ifileidx, iprofidx, zdat, clvars ) 829 855 830 856 !----------------------------------------------------------------------- … … 836 862 DEALLOCATE( inpfiles ) 837 863 838 END SUBROUTINE obs_rea_pro _dri864 END SUBROUTINE obs_rea_prof 839 865 840 866 END MODULE obs_read_prof -
branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_readmdt.F90
r7960 r7992 31 31 PRIVATE 32 32 33 PUBLIC obs_rea_mdt ! called by ?34 PUBLIC obs_offset_mdt ! called by ?35 36 INTEGER , PUBLIC :: nmsshc = 1 ! MDT correction scheme37 REAL(wp), PUBLIC :: mdtcorr = 1.61_wp! User specified MDT correction38 REAL(wp), PUBLIC :: mdtcutoff = 65.0_wp! MDT cutoff for computed correction33 PUBLIC obs_rea_mdt ! called by dia_obs_init 34 PUBLIC obs_offset_mdt ! called by obs_rea_mdt 35 36 INTEGER , PUBLIC :: nn_msshc = 1 ! MDT correction scheme 37 REAL(wp), PUBLIC :: rn_mdtcorr = 1.61_wp ! User specified MDT correction 38 REAL(wp), PUBLIC :: rn_mdtcutoff = 65.0_wp ! MDT cutoff for computed correction 39 39 40 40 !!---------------------------------------------------------------------- … … 45 45 CONTAINS 46 46 47 SUBROUTINE obs_rea_mdt( kslano,sladata, k2dint )47 SUBROUTINE obs_rea_mdt( sladata, k2dint ) 48 48 !!--------------------------------------------------------------------- 49 49 !! … … 58 58 USE iom 59 59 ! 60 INTEGER , INTENT(IN) :: kslano ! Number of SLA Products 61 TYPE(obs_surf), DIMENSION(kslano), INTENT(inout) :: sladata ! SLA data 62 INTEGER , INTENT(in) :: k2dint ! ? 60 TYPE(obs_surf), INTENT(inout) :: sladata ! SLA data 61 INTEGER , INTENT(in) :: k2dint ! ? 63 62 ! 64 63 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_rea_mdt' 65 64 CHARACTER(LEN=20), PARAMETER :: mdtname = 'slaReferenceLevel.nc' 66 65 67 INTEGER :: jslano ! Data set loop variable68 66 INTEGER :: jobs ! Obs loop variable 69 67 INTEGER :: jpimdt, jpjmdt ! Number of grid point in lat/lon for the MDT … … 88 86 IF(lwp)WRITE(numout,*) ' obs_rea_mdt : Read MDT for referencing altimeter anomalies' 89 87 IF(lwp)WRITE(numout,*) ' ------------- ' 88 CALL FLUSH(numout) 90 89 91 90 CALL iom_open( mdtname, nummdt ) ! Open the file … … 109 108 110 109 ! Remove the offset between the MDT used with the sla and the model MDT 111 IF( nmsshc == 1 .OR. nmsshc == 2 ) CALL obs_offset_mdt( z_mdt, zfill ) 110 IF( nn_msshc == 1 .OR. nn_msshc == 2 ) & 111 & CALL obs_offset_mdt( jpi, jpj, z_mdt, zfill ) 112 112 113 113 ! Intepolate the MDT already on the model grid at the observation point 114 114 115 DO jslano = 1, kslano 116 ALLOCATE( & 117 & igrdi(2,2,sladata(jslano)%nsurf), & 118 & igrdj(2,2,sladata(jslano)%nsurf), & 119 & zglam(2,2,sladata(jslano)%nsurf), & 120 & zgphi(2,2,sladata(jslano)%nsurf), & 121 & zmask(2,2,sladata(jslano)%nsurf), & 122 & zmdtl(2,2,sladata(jslano)%nsurf) & 123 & ) 115 ALLOCATE( & 116 & igrdi(2,2,sladata%nsurf), & 117 & igrdj(2,2,sladata%nsurf), & 118 & zglam(2,2,sladata%nsurf), & 119 & zgphi(2,2,sladata%nsurf), & 120 & zmask(2,2,sladata%nsurf), & 121 & zmdtl(2,2,sladata%nsurf) & 122 & ) 124 123 125 DO jobs = 1, sladata(jslano)%nsurf126 127 igrdi(1,1,jobs) = sladata(jslano)%mi(jobs)-1128 igrdj(1,1,jobs) = sladata(jslano)%mj(jobs)-1129 igrdi(1,2,jobs) = sladata(jslano)%mi(jobs)-1130 igrdj(1,2,jobs) = sladata(jslano)%mj(jobs)131 igrdi(2,1,jobs) = sladata(jslano)%mi(jobs)132 igrdj(2,1,jobs) = sladata(jslano)%mj(jobs)-1133 igrdi(2,2,jobs) = sladata(jslano)%mi(jobs)134 igrdj(2,2,jobs) = sladata(jslano)%mj(jobs)135 136 137 138 CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, igrdi, igrdj, glamt , zglam )139 CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, igrdi, igrdj, gphit , zgphi )140 CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, igrdi, igrdj, mdtmask, zmask )141 CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, igrdi, igrdj, z_mdt , zmdtl )142 143 DO jobs = 1, sladata(jslano)%nsurf124 DO jobs = 1, sladata%nsurf 125 126 igrdi(1,1,jobs) = sladata%mi(jobs)-1 127 igrdj(1,1,jobs) = sladata%mj(jobs)-1 128 igrdi(1,2,jobs) = sladata%mi(jobs)-1 129 igrdj(1,2,jobs) = sladata%mj(jobs) 130 igrdi(2,1,jobs) = sladata%mi(jobs) 131 igrdj(2,1,jobs) = sladata%mj(jobs)-1 132 igrdi(2,2,jobs) = sladata%mi(jobs) 133 igrdj(2,2,jobs) = sladata%mj(jobs) 134 135 END DO 136 137 CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, glamt , zglam ) 138 CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, gphit , zgphi ) 139 CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, mdtmask, zmask ) 140 CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, z_mdt , zmdtl ) 141 142 DO jobs = 1, sladata%nsurf 144 143 145 zlam = sladata(jslano)%rlam(jobs)146 zphi = sladata(jslano)%rphi(jobs)147 148 149 150 144 zlam = sladata%rlam(jobs) 145 zphi = sladata%rphi(jobs) 146 147 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 148 & zglam(:,:,jobs), zgphi(:,:,jobs), & 149 & zmask(:,:,jobs), zweig, zobsmask ) 151 150 152 151 CALL obs_int_h2d( 1, 1, zweig, zmdtl(:,:,jobs), zext ) 153 152 154 sladata(jslano)%rext(jobs,2) = zext(1)153 sladata%rext(jobs,2) = zext(1) 155 154 156 155 ! mark any masked data with a QC flag 157 IF( zobsmask(1) == 0 ) sladata(jslano)%nqc(jobs) = 11156 IF( zobsmask(1) == 0 ) sladata%nqc(jobs) = IBSET(sladata%nqc(jobs),15) 158 157 159 158 END DO 160 159 161 DEALLOCATE( & 162 & igrdi, & 163 & igrdj, & 164 & zglam, & 165 & zgphi, & 166 & zmask, & 167 & zmdtl & 168 & ) 169 170 END DO 160 DEALLOCATE( & 161 & igrdi, & 162 & igrdj, & 163 & zglam, & 164 & zgphi, & 165 & zmask, & 166 & zmdtl & 167 & ) 171 168 172 169 CALL wrk_dealloc(jpi,jpj,z_mdt,mdtmask) 170 IF(lwp)WRITE(numout,*) ' ------------- ' 173 171 ! 174 172 END SUBROUTINE obs_rea_mdt 175 173 176 174 177 SUBROUTINE obs_offset_mdt( mdt, zfill )175 SUBROUTINE obs_offset_mdt( kpi, kpj, mdt, zfill ) 178 176 !!--------------------------------------------------------------------- 179 177 !! … … 188 186 !! ** Action : 189 187 !!---------------------------------------------------------------------- 190 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: mdt ! MDT used on the model grid 191 REAL(wp) , INTENT(in ) :: zfill 188 INTEGER, INTENT(IN) :: kpi, kpj 189 REAL(wp), DIMENSION(kpi,kpj), INTENT(INOUT) :: mdt ! MDT used on the model grid 190 REAL(wp) , INTENT(IN ) :: zfill 192 191 ! 193 192 INTEGER :: ji, jj … … 205 204 DO jj = 1, jpj 206 205 zpromsk(ji,jj) = tmask_i(ji,jj) 207 IF ( ( gphit(ji,jj) .GT. mdtcutoff ) &208 &.OR.( gphit(ji,jj) .LT. - mdtcutoff ) &206 IF ( ( gphit(ji,jj) .GT. rn_mdtcutoff ) & 207 &.OR.( gphit(ji,jj) .LT. -rn_mdtcutoff ) & 209 208 &.OR.( mdt(ji,jj) .EQ. zfill ) ) & 210 209 & zpromsk(ji,jj) = 0.0 … … 212 211 END DO 213 212 214 ! Compute MSSH mean over [0,360] x [- mdtcutoff,mdtcutoff]213 ! Compute MSSH mean over [0,360] x [-rn_mdtcutoff,rn_mdtcutoff] 215 214 216 215 zarea = 0.0 … … 240 239 ! Correct spatial mean of the MSSH 241 240 242 IF( n msshc == 1 ) mdt(:,:) = mdt(:,:) - zcorr241 IF( nn_msshc == 1 ) mdt(:,:) = mdt(:,:) - zcorr 243 242 244 243 ! User defined value : 1.6 m for the Rio MDT compared to ORCA2 MDT 245 244 246 IF( n msshc == 2 ) mdt(:,:) = mdt(:,:) -mdtcorr245 IF( nn_msshc == 2 ) mdt(:,:) = mdt(:,:) - rn_mdtcorr 247 246 248 247 IF(lwp) THEN 249 248 WRITE(numout,*) 250 WRITE(numout,*) ' obs_readmdt : mdtcutoff = ',mdtcutoff249 WRITE(numout,*) ' obs_readmdt : rn_mdtcutoff = ', rn_mdtcutoff 251 250 WRITE(numout,*) ' ----------- zcorr_mdt = ', zcorr_mdt 252 251 WRITE(numout,*) ' zcorr_bcketa = ', zcorr_bcketa 253 252 WRITE(numout,*) ' zcorr = ', zcorr 254 WRITE(numout,*) ' n msshc = ', nmsshc253 WRITE(numout,*) ' nn_msshc = ', nn_msshc 255 254 ENDIF 256 255 257 IF ( n msshc == 0 ) WRITE(numout,*) ' MSSH correction is not applied'258 IF ( n msshc == 1 ) WRITE(numout,*) ' MSSH correction is applied'259 IF ( n msshc == 2 ) WRITE(numout,*) ' User defined MSSH correction'256 IF ( nn_msshc == 0 ) WRITE(numout,*) ' MSSH correction is not applied' 257 IF ( nn_msshc == 1 ) WRITE(numout,*) ' MSSH correction is applied' 258 IF ( nn_msshc == 2 ) WRITE(numout,*) ' User defined MSSH correction' 260 259 261 260 CALL wrk_dealloc( jpi,jpj, zpromsk ) -
branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_rot_vel.F90
r7960 r7992 140 140 END DO 141 141 142 CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, &142 CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & 143 143 & glamu, zglamu ) 144 CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, &144 CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & 145 145 & gphiu, zgphiu ) 146 CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, &146 CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & 147 147 & umask(:,:,1), zmasku ) 148 CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, &148 CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & 149 149 & zsingu, zsinlu ) 150 CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, &150 CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & 151 151 & zcosgu, zcoslu ) 152 CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, &152 CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & 153 153 & glamv, zglamv ) 154 CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, &154 CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & 155 155 & gphiv, zgphiv ) 156 CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, &156 CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & 157 157 & vmask(:,:,1), zmaskv ) 158 CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, &158 CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & 159 159 & zsingv, zsinlv ) 160 CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, &160 CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & 161 161 & zcosgv, zcoslv ) 162 162 … … 195 195 DO jk = profdata%npvsta(ji,1), profdata%npvend(ji,1) 196 196 IF ( ( profdata%var(1)%vmod(jk) /= fbrmdi ) .AND. & 197 & ( profdata%var( 1)%vmod(jk) /= fbrmdi ) ) THEN197 & ( profdata%var(2)%vmod(jk) /= fbrmdi ) ) THEN 198 198 pu(jk) = profdata%var(1)%vmod(jk) * zcos - & 199 & profdata%var(2)%vmod(jk) * zsin 199 & profdata%var(2)%vmod(jk) * zsin 200 200 pv(jk) = profdata%var(2)%vmod(jk) * zcos + & 201 201 & profdata%var(1)%vmod(jk) * zsin … … 204 204 pv(jk) = fbrmdi 205 205 ENDIF 206 206 207 END DO 207 208 -
branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_surf_def.F90
r7960 r7992 50 50 INTEGER :: npj 51 51 INTEGER :: nsurfup !: Observation counter used in obs_oper 52 INTEGER :: nrec !: Number of surface observation records in window 52 53 53 54 ! Arrays with size equal to the number of surface observations … … 56 57 & mi, & !: i-th grid coord. for interpolating to surface observation 57 58 & mj, & !: j-th grid coord. for interpolating to surface observation 59 & mt, & !: time record number for gridded data 58 60 & nsidx,& !: Surface observation number 59 61 & nsfil,& !: Surface observation number in file … … 67 69 & ntyp !: Type of surface observation product 68 70 71 CHARACTER(len=8), POINTER, DIMENSION(:) :: & 72 & cvars !: Variable names 73 69 74 CHARACTER(LEN=8), POINTER, DIMENSION(:) :: & 70 75 & cwmo !: WMO indentifier … … 90 95 & nsstpmpp !: Global number of surface observations per time step 91 96 97 ! Arrays with size equal to the number of observation records in the window 98 INTEGER, POINTER, DIMENSION(:) :: & 99 & mrecstp ! Time step of the records 100 92 101 ! Arrays used to store source indices when 93 102 ! compressing obs_surf derived types … … 97 106 INTEGER, POINTER, DIMENSION(:) :: & 98 107 & nsind !: Source indices of surface data in compressed data 108 109 ! Is this a gridded product? 110 111 LOGICAL :: lgrid 99 112 100 113 END TYPE obs_surf … … 130 143 !!* Local variables 131 144 INTEGER :: ji 145 INTEGER :: jvar 132 146 133 147 ! Set bookkeeping variables … … 140 154 surf%npi = kpi 141 155 surf%npj = kpj 156 157 ! Allocate arrays of size number of variables 158 159 ALLOCATE( & 160 & surf%cvars(kvar) & 161 & ) 162 163 DO jvar = 1, kvar 164 surf%cvars(jvar) = "NotSet" 165 END DO 142 166 143 167 ! Allocate arrays of number of surface data size … … 146 170 & surf%mi(ksurf), & 147 171 & surf%mj(ksurf), & 172 & surf%mt(ksurf), & 148 173 & surf%nsidx(ksurf), & 149 174 & surf%nsfil(ksurf), & … … 162 187 & ) 163 188 189 surf%mt(:) = -1 190 164 191 165 192 ! Allocate arrays of number of surface data size * number of variables … … 176 203 & ) 177 204 205 surf%rext(:,:) = 0.0_wp 206 178 207 ! Allocate arrays of number of time step size 179 208 … … 203 232 204 233 surf%nsurfup = 0 234 235 ! Not gridded by default 236 237 surf%lgrid = .FALSE. 205 238 206 239 END SUBROUTINE obs_surf_alloc … … 228 261 & surf%mi, & 229 262 & surf%mj, & 263 & surf%mt, & 230 264 & surf%nsidx, & 231 265 & surf%nsfil, & … … 269 303 & surf%nsstp, & 270 304 & surf%nsstpmpp & 305 & ) 306 307 ! Dellocate arrays of size number of variables 308 309 DEALLOCATE( & 310 & surf%cvars & 271 311 & ) 272 312 … … 350 390 newsurf%mi(insurf) = surf%mi(ji) 351 391 newsurf%mj(insurf) = surf%mj(ji) 392 newsurf%mt(insurf) = surf%mt(ji) 352 393 newsurf%nsidx(insurf) = surf%nsidx(ji) 353 394 newsurf%nsfil(insurf) = surf%nsfil(ji) … … 392 433 ! Set book keeping variables which do not depend on number of obs. 393 434 394 newsurf%nstp = surf%nstp 435 newsurf%nstp = surf%nstp 436 newsurf%cvars(:) = surf%cvars(:) 437 438 ! Set gridded stuff 439 440 newsurf%mt(insurf) = surf%mt(ji) 395 441 396 442 ! Deallocate temporary data … … 433 479 oldsurf%mi(jj) = surf%mi(ji) 434 480 oldsurf%mj(jj) = surf%mj(ji) 481 oldsurf%mt(jj) = surf%mt(ji) 435 482 oldsurf%nsidx(jj) = surf%nsidx(ji) 436 483 oldsurf%nsfil(jj) = surf%nsfil(ji) -
branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_types.F90
r7960 r7992 117 117 118 118 cwmonam1770(ji) = 'Not defined' 119 ctypshort(ji) = ' XBT'119 ctypshort(ji) = '---' 120 120 121 121 ! IF ( ji < 1000 ) THEN -
branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_write.F90
r7960 r7992 6 6 7 7 !!---------------------------------------------------------------------- 8 !! obs_wri_p3d : Write profile observation diagnostics in NetCDF format 9 !! obs_wri_sla : Write SLA observation related diagnostics 10 !! obs_wri_sst : Write SST observation related diagnostics 11 !! obs_wri_seaice: Write seaice observation related diagnostics 12 !! obs_wri_vel : Write velocity observation diagnostics in NetCDF format 13 !! obs_wri_stats : Print basic statistics on the data being written out 8 !! obs_wri_prof : Write profile observations in feedback format 9 !! obs_wri_surf : Write surface observations in feedback format 10 !! obs_wri_stats : Print basic statistics on the data being written out 14 11 !!---------------------------------------------------------------------- 15 12 … … 30 27 USE obs_conv ! Conversion between units 31 28 USE obs_const 32 USE obs_sla_types33 USE obs_rot_vel ! Rotation of velocities34 29 USE obs_mpp ! MPP support routines for observation diagnostics 35 30 USE lib_mpp ! MPP routines … … 39 34 !! * Routine accessibility 40 35 PRIVATE 41 PUBLIC obs_wri_p3d, & ! Write profile observation related diagnostics 42 & obs_wri_sla, & ! Write SLA observation related diagnostics 43 & obs_wri_sst, & ! Write SST observation related diagnostics 44 & obs_wri_sss, & ! Write SSS observation related diagnostics 45 & obs_wri_seaice, & ! Write seaice observation related diagnostics 46 & obs_wri_vel, & ! Write velocity observation related diagnostics 36 PUBLIC obs_wri_prof, & ! Write profile observation files 37 & obs_wri_surf, & ! Write surface observation files 47 38 & obswriinfo 48 39 … … 63 54 CONTAINS 64 55 65 SUBROUTINE obs_wri_p 3d( cprefix,profdata, padd, pext )56 SUBROUTINE obs_wri_prof( profdata, padd, pext ) 66 57 !!----------------------------------------------------------------------- 67 58 !! 68 !! *** ROUTINE obs_wri_p3d *** 69 !! 70 !! ** Purpose : Write temperature and salinity (profile) observation 71 !! related diagnostics 59 !! *** ROUTINE obs_wri_prof *** 60 !! 61 !! ** Purpose : Write profile feedback files 72 62 !! 73 63 !! ** Method : NetCDF … … 82 72 !! ! 07-03 (K. Mogensen) General handling of profiles 83 73 !! ! 09-01 (K. Mogensen) New feedback format 74 !! ! 15-02 (M. Martin) Combined routine for writing profiles 84 75 !!----------------------------------------------------------------------- 85 76 86 !! * Modules used87 88 77 !! * Arguments 89 CHARACTER(LEN=*), INTENT(IN) :: cprefix ! Prefix for output files90 78 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data 91 79 TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable 92 80 TYPE(obswriinfo), OPTIONAL :: pext ! Extra info 93 81 94 82 !! * Local declarations 95 83 TYPE(obfbdata) :: fbdata 96 CHARACTER(LEN=40) :: cfname 84 CHARACTER(LEN=40) :: clfname 85 CHARACTER(LEN=6) :: clfiletype 97 86 INTEGER :: ilevel 98 87 INTEGER :: jvar … … 102 91 INTEGER :: ja 103 92 INTEGER :: je 93 INTEGER :: iadd 94 INTEGER :: iext 104 95 REAL(wp) :: zpres 105 INTEGER :: nadd106 INTEGER :: next107 96 108 97 IF ( PRESENT( padd ) ) THEN 109 nadd = padd%inum98 iadd = padd%inum 110 99 ELSE 111 nadd = 0100 iadd = 0 112 101 ENDIF 113 102 114 103 IF ( PRESENT( pext ) ) THEN 115 next = pext%inum104 iext = pext%inum 116 105 ELSE 117 next = 0118 ENDIF 119 106 iext = 0 107 ENDIF 108 120 109 CALL init_obfbdata( fbdata ) 121 110 … … 125 114 ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) ) 126 115 END DO 127 CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, & 128 & 1 + nadd, 1 + next, .TRUE. ) 129 130 fbdata%cname(1) = 'POTM' 131 fbdata%cname(2) = 'PSAL' 132 fbdata%coblong(1) = 'Potential temperature' 133 fbdata%coblong(2) = 'Practical salinity' 134 fbdata%cobunit(1) = 'Degrees centigrade' 135 fbdata%cobunit(2) = 'PSU' 136 fbdata%cextname(1) = 'TEMP' 137 fbdata%cextlong(1) = 'Insitu temperature' 138 fbdata%cextunit(1) = 'Degrees centigrade' 139 DO je = 1, next 140 fbdata%cextname(1+je) = pext%cdname(je) 141 fbdata%cextlong(1+je) = pext%cdlong(je,1) 142 fbdata%cextunit(1+je) = pext%cdunit(je,1) 143 END DO 116 117 SELECT CASE ( TRIM(profdata%cvars(1)) ) 118 CASE('POTM') 119 120 clfiletype='profb' 121 CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, & 122 & 1 + iadd, 1 + iext, .TRUE. ) 123 fbdata%cname(1) = profdata%cvars(1) 124 fbdata%cname(2) = profdata%cvars(2) 125 fbdata%coblong(1) = 'Potential temperature' 126 fbdata%coblong(2) = 'Practical salinity' 127 fbdata%cobunit(1) = 'Degrees centigrade' 128 fbdata%cobunit(2) = 'PSU' 129 fbdata%cextname(1) = 'TEMP' 130 fbdata%cextlong(1) = 'Insitu temperature' 131 fbdata%cextunit(1) = 'Degrees centigrade' 132 fbdata%caddlong(1,1) = 'Model interpolated potential temperature' 133 fbdata%caddlong(1,2) = 'Model interpolated practical salinity' 134 fbdata%caddunit(1,1) = 'Degrees centigrade' 135 fbdata%caddunit(1,2) = 'PSU' 136 fbdata%cgrid(:) = 'T' 137 DO je = 1, iext 138 fbdata%cextname(1+je) = pext%cdname(je) 139 fbdata%cextlong(1+je) = pext%cdlong(je,1) 140 fbdata%cextunit(1+je) = pext%cdunit(je,1) 141 END DO 142 DO ja = 1, iadd 143 fbdata%caddname(1+ja) = padd%cdname(ja) 144 DO jvar = 1, 2 145 fbdata%caddlong(1+ja,jvar) = padd%cdlong(ja,jvar) 146 fbdata%caddunit(1+ja,jvar) = padd%cdunit(ja,jvar) 147 END DO 148 END DO 149 150 CASE('UVEL') 151 152 clfiletype='velfb' 153 CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, 1, 0, .TRUE. ) 154 fbdata%cname(1) = profdata%cvars(1) 155 fbdata%cname(2) = profdata%cvars(2) 156 fbdata%coblong(1) = 'Zonal velocity' 157 fbdata%coblong(2) = 'Meridional velocity' 158 fbdata%cobunit(1) = 'm/s' 159 fbdata%cobunit(2) = 'm/s' 160 DO je = 1, iext 161 fbdata%cextname(je) = pext%cdname(je) 162 fbdata%cextlong(je) = pext%cdlong(je,1) 163 fbdata%cextunit(je) = pext%cdunit(je,1) 164 END DO 165 fbdata%caddlong(1,1) = 'Model interpolated zonal velocity' 166 fbdata%caddlong(1,2) = 'Model interpolated meridional velocity' 167 fbdata%caddunit(1,1) = 'm/s' 168 fbdata%caddunit(1,2) = 'm/s' 169 fbdata%cgrid(1) = 'U' 170 fbdata%cgrid(2) = 'V' 171 DO ja = 1, iadd 172 fbdata%caddname(1+ja) = padd%cdname(ja) 173 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 174 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 175 END DO 176 177 END SELECT 178 144 179 fbdata%caddname(1) = 'Hx' 145 fbdata%caddlong(1,1) = 'Model interpolated potential temperature' 146 fbdata%caddlong(1,2) = 'Model interpolated practical salinity' 147 fbdata%caddunit(1,1) = 'Degrees centigrade' 148 fbdata%caddunit(1,2) = 'PSU' 149 fbdata%cgrid(:) = 'T' 150 DO ja = 1, nadd 151 fbdata%caddname(1+ja) = padd%cdname(ja) 152 DO jvar = 1, 2 153 fbdata%caddlong(1+ja,jvar) = padd%cdlong(ja,jvar) 154 fbdata%caddunit(1+ja,jvar) = padd%cdunit(ja,jvar) 155 END DO 156 END DO 157 158 WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 180 181 WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc 159 182 160 183 IF(lwp) THEN 161 184 WRITE(numout,*) 162 WRITE(numout,*)'obs_wri_p 3d:'185 WRITE(numout,*)'obs_wri_prof :' 163 186 WRITE(numout,*)'~~~~~~~~~~~~~' 164 WRITE(numout,*)'Writing profile feedback file : ',TRIM(cfname)165 ENDIF 166 167 ! Transform obs_prof data structure into obfb data structure187 WRITE(numout,*)'Writing '//TRIM(clfiletype)//' feedback file : ',TRIM(clfname) 188 ENDIF 189 190 ! Transform obs_prof data structure into obfb data structure 168 191 fbdata%cdjuldref = '19500101000000' 169 192 DO jo = 1, profdata%nprof … … 173 196 fbdata%ivqc(jo,:) = profdata%ivqc(jo,:) 174 197 fbdata%ivqcf(:,jo,:) = profdata%ivqcf(:,jo,:) 175 IF ( profdata%nqc(jo) > 10) THEN176 fbdata%ioqc(jo) = 4198 IF ( profdata%nqc(jo) > 255 ) THEN 199 fbdata%ioqc(jo) = IBSET(profdata%nqc(jo),2) 177 200 fbdata%ioqcf(1,jo) = profdata%nqcf(1,jo) 178 fbdata%ioqcf(2,jo) = profdata%nqc(jo) - 10201 fbdata%ioqcf(2,jo) = profdata%nqc(jo) 179 202 ELSE 180 203 fbdata%ioqc(jo) = profdata%nqc(jo) … … 213 236 fbdata%idqc(ik,jo) = profdata%var(jvar)%idqc(jk) 214 237 fbdata%idqcf(:,ik,jo) = profdata%var(jvar)%idqcf(:,jk) 215 IF ( profdata%var(jvar)%nvqc(jk) > 10) THEN216 fbdata%ivlqc(ik,jo,jvar) = 4238 IF ( profdata%var(jvar)%nvqc(jk) > 255 ) THEN 239 fbdata%ivlqc(ik,jo,jvar) = IBSET(profdata%var(jvar)%nvqc(jk),2) 217 240 fbdata%ivlqcf(1,ik,jo,jvar) = profdata%var(jvar)%nvqcf(1,jk) 218 fbdata%ivlqcf(2,ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) - 10241 fbdata%ivlqcf(2,ik,jo,jvar) = IAND(profdata%var(jvar)%nvqc(jk),b'0000 0000 1111 1111') 219 242 ELSE 220 243 fbdata%ivlqc(ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) … … 222 245 ENDIF 223 246 fbdata%iobsk(ik,jo,jvar) = profdata%var(jvar)%mvk(jk) 224 DO ja = 1, nadd247 DO ja = 1, iadd 225 248 fbdata%padd(ik,jo,1+ja,jvar) = & 226 249 & profdata%var(jvar)%vext(jk,padd%ipoint(ja)) 227 250 END DO 228 DO je = 1, next251 DO je = 1, iext 229 252 fbdata%pext(ik,jo,1+je) = & 230 253 & profdata%var(jvar)%vext(jk,pext%ipoint(je)) 231 254 END DO 232 IF ( jvar == 1 ) THEN 255 IF ( ( jvar == 1 ) .AND. & 256 & ( TRIM(profdata%cvars(1)) == 'POTM' ) ) THEN 233 257 fbdata%pext(ik,jo,1) = profdata%var(jvar)%vext(jk,1) 234 258 ENDIF … … 237 261 END DO 238 262 239 ! Convert insitu temperature to potential temperature using the model 240 ! salinity if no potential temperature 241 DO jo = 1, fbdata%nobs 242 IF ( fbdata%pphi(jo) < 9999.0 ) THEN 243 DO jk = 1, fbdata%nlev 244 IF ( ( fbdata%pob(jk,jo,1) >= 9999.0 ) .AND. & 245 & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 246 & ( fbdata%padd(jk,jo,1,2) < 9999.0 ) .AND. & 247 & ( fbdata%pext(jk,jo,1) < 9999.0 ) ) THEN 248 zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), & 249 & REAL(fbdata%pphi(jo),wp) ) 250 fbdata%pob(jk,jo,1) = potemp( & 251 & REAL(fbdata%padd(jk,jo,1,2), wp), & 252 & REAL(fbdata%pext(jk,jo,1), wp), & 253 & zpres, 0.0_wp ) 254 ENDIF 255 END DO 256 ENDIF 257 END DO 258 263 IF ( TRIM(profdata%cvars(1)) == 'POTM' ) THEN 264 ! Convert insitu temperature to potential temperature using the model 265 ! salinity if no potential temperature 266 DO jo = 1, fbdata%nobs 267 IF ( fbdata%pphi(jo) < 9999.0 ) THEN 268 DO jk = 1, fbdata%nlev 269 IF ( ( fbdata%pob(jk,jo,1) >= 9999.0 ) .AND. & 270 & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 271 & ( fbdata%padd(jk,jo,1,2) < 9999.0 ) .AND. & 272 & ( fbdata%pext(jk,jo,1) < 9999.0 ) ) THEN 273 zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), & 274 & REAL(fbdata%pphi(jo),wp) ) 275 fbdata%pob(jk,jo,1) = potemp( & 276 & REAL(fbdata%padd(jk,jo,1,2), wp), & 277 & REAL(fbdata%pext(jk,jo,1), wp), & 278 & zpres, 0.0_wp ) 279 ENDIF 280 END DO 281 ENDIF 282 END DO 283 ENDIF 284 259 285 ! Write the obfbdata structure 260 CALL write_obfbdata( c fname, fbdata )286 CALL write_obfbdata( clfname, fbdata ) 261 287 262 288 ! Output some basic statistics … … 264 290 265 291 CALL dealloc_obfbdata( fbdata ) 266 267 END SUBROUTINE obs_wri_p 3d268 269 SUBROUTINE obs_wri_s la( cprefix, sladata, padd, pext )292 293 END SUBROUTINE obs_wri_prof 294 295 SUBROUTINE obs_wri_surf( surfdata, padd, pext ) 270 296 !!----------------------------------------------------------------------- 271 297 !! 272 !! *** ROUTINE obs_wri_sla *** 273 !! 274 !! ** Purpose : Write SLA observation diagnostics 275 !! related 298 !! *** ROUTINE obs_wri_surf *** 299 !! 300 !! ** Purpose : Write surface observation files 276 301 !! 277 302 !! ** Method : NetCDF … … 281 306 !! ! 07-03 (K. Mogensen) Original 282 307 !! ! 09-01 (K. Mogensen) New feedback format. 308 !! ! 15-02 (M. Martin) Combined surface writing routine. 283 309 !!----------------------------------------------------------------------- 284 310 … … 287 313 288 314 !! * Arguments 289 CHARACTER(LEN=*), INTENT(IN) :: cprefix ! Prefix for output files 290 TYPE(obs_surf), INTENT(INOUT) :: sladata ! Full set of SLAa 315 TYPE(obs_surf), INTENT(INOUT) :: surfdata ! Full set of surface data 291 316 TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable 292 317 TYPE(obswriinfo), OPTIONAL :: pext ! Extra info … … 294 319 !! * Local declarations 295 320 TYPE(obfbdata) :: fbdata 296 CHARACTER(LEN=40) :: cfname ! netCDF filename 297 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_sla' 321 CHARACTER(LEN=40) :: clfname ! netCDF filename 322 CHARACTER(LEN=6) :: clfiletype 323 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_surf' 298 324 INTEGER :: jo 299 325 INTEGER :: ja 300 326 INTEGER :: je 301 INTEGER :: nadd302 INTEGER :: next327 INTEGER :: iadd 328 INTEGER :: iext 303 329 304 330 IF ( PRESENT( padd ) ) THEN 305 nadd = padd%inum331 iadd = padd%inum 306 332 ELSE 307 nadd = 0333 iadd = 0 308 334 ENDIF 309 335 310 336 IF ( PRESENT( pext ) ) THEN 311 next = pext%inum337 iext = pext%inum 312 338 ELSE 313 next = 0339 iext = 0 314 340 ENDIF 315 341 316 342 CALL init_obfbdata( fbdata ) 317 343 318 CALL alloc_obfbdata( fbdata, 1, sladata%nsurf, 1, & 319 & 2 + nadd, 1 + next, .TRUE. ) 320 321 fbdata%cname(1) = 'SLA' 322 fbdata%coblong(1) = 'Sea level anomaly' 323 fbdata%cobunit(1) = 'Metres' 324 fbdata%cextname(1) = 'MDT' 325 fbdata%cextlong(1) = 'Mean dynamic topography' 326 fbdata%cextunit(1) = 'Metres' 327 DO je = 1, next 328 fbdata%cextname(1+je) = pext%cdname(je) 329 fbdata%cextlong(1+je) = pext%cdlong(je,1) 330 fbdata%cextunit(1+je) = pext%cdunit(je,1) 331 END DO 344 SELECT CASE ( TRIM(surfdata%cvars(1)) ) 345 CASE('SLA') 346 347 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 348 & 2 + iadd, 1 + iext, .TRUE. ) 349 350 clfiletype = 'slafb' 351 fbdata%cname(1) = surfdata%cvars(1) 352 fbdata%coblong(1) = 'Sea level anomaly' 353 fbdata%cobunit(1) = 'Metres' 354 fbdata%cextname(1) = 'MDT' 355 fbdata%cextlong(1) = 'Mean dynamic topography' 356 fbdata%cextunit(1) = 'Metres' 357 DO je = 1, iext 358 fbdata%cextname(je) = pext%cdname(je) 359 fbdata%cextlong(je) = pext%cdlong(je,1) 360 fbdata%cextunit(je) = pext%cdunit(je,1) 361 END DO 362 fbdata%caddlong(1,1) = 'Model interpolated SSH - MDT' 363 fbdata%caddunit(1,1) = 'Metres' 364 fbdata%caddname(2) = 'SSH' 365 fbdata%caddlong(2,1) = 'Model Sea surface height' 366 fbdata%caddunit(2,1) = 'Metres' 367 fbdata%cgrid(1) = 'T' 368 DO ja = 1, iadd 369 fbdata%caddname(2+ja) = padd%cdname(ja) 370 fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1) 371 fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1) 372 END DO 373 374 CASE('SST') 375 376 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 377 & 1 + iadd, iext, .TRUE. ) 378 379 clfiletype = 'sstfb' 380 fbdata%cname(1) = surfdata%cvars(1) 381 fbdata%coblong(1) = 'Sea surface temperature' 382 fbdata%cobunit(1) = 'Degree centigrade' 383 DO je = 1, iext 384 fbdata%cextname(je) = pext%cdname(je) 385 fbdata%cextlong(je) = pext%cdlong(je,1) 386 fbdata%cextunit(je) = pext%cdunit(je,1) 387 END DO 388 fbdata%caddlong(1,1) = 'Model interpolated SST' 389 fbdata%caddunit(1,1) = 'Degree centigrade' 390 fbdata%cgrid(1) = 'T' 391 DO ja = 1, iadd 392 fbdata%caddname(1+ja) = padd%cdname(ja) 393 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 394 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 395 END DO 396 397 CASE('ICECONC') 398 399 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 400 & 1 + iadd, iext, .TRUE. ) 401 402 clfiletype = 'sicfb' 403 fbdata%cname(1) = surfdata%cvars(1) 404 fbdata%coblong(1) = 'Sea ice' 405 fbdata%cobunit(1) = 'Fraction' 406 DO je = 1, iext 407 fbdata%cextname(je) = pext%cdname(je) 408 fbdata%cextlong(je) = pext%cdlong(je,1) 409 fbdata%cextunit(je) = pext%cdunit(je,1) 410 END DO 411 fbdata%caddlong(1,1) = 'Model interpolated ICE' 412 fbdata%caddunit(1,1) = 'Fraction' 413 fbdata%cgrid(1) = 'T' 414 DO ja = 1, iadd 415 fbdata%caddname(1+ja) = padd%cdname(ja) 416 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 417 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 418 END DO 419 420 CASE('SSS') 421 422 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 423 & 1 + iadd, iext, .TRUE. ) 424 425 clfiletype = 'sssfb' 426 fbdata%cname(1) = surfdata%cvars(1) 427 fbdata%coblong(1) = 'Sea surface salinity' 428 fbdata%cobunit(1) = 'psu' 429 DO je = 1, iext 430 fbdata%cextname(je) = pext%cdname(je) 431 fbdata%cextlong(je) = pext%cdlong(je,1) 432 fbdata%cextunit(je) = pext%cdunit(je,1) 433 END DO 434 fbdata%caddlong(1,1) = 'Model interpolated SSS' 435 fbdata%caddunit(1,1) = 'psu' 436 fbdata%cgrid(1) = 'T' 437 DO ja = 1, iadd 438 fbdata%caddname(1+ja) = padd%cdname(ja) 439 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 440 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 441 END DO 442 443 CASE('LOGCHL') 444 445 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 446 & 1 + iadd, iext, .TRUE. ) 447 448 clfiletype = 'logchlfb' 449 fbdata%cname(1) = surfdata%cvars(1) 450 fbdata%coblong(1) = 'logchl concentration' 451 fbdata%cobunit(1) = 'mg/m3' 452 DO je = 1, iext 453 fbdata%cextname(je) = pext%cdname(je) 454 fbdata%cextlong(je) = pext%cdlong(je,1) 455 fbdata%cextunit(je) = pext%cdunit(je,1) 456 END DO 457 fbdata%caddlong(1,1) = 'Model interpolated LOGCHL' 458 fbdata%caddunit(1,1) = 'mg/m3' 459 fbdata%cgrid(1) = 'T' 460 DO ja = 1, iadd 461 fbdata%caddname(1+ja) = padd%cdname(ja) 462 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 463 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 464 END DO 465 466 CASE('SPM') 467 468 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 469 & 1 + iadd, iext, .TRUE. ) 470 471 clfiletype = 'spmfb' 472 fbdata%cname(1) = surfdata%cvars(1) 473 fbdata%coblong(1) = 'spm' 474 fbdata%cobunit(1) = 'g/m3' 475 DO je = 1, iext 476 fbdata%cextname(je) = pext%cdname(je) 477 fbdata%cextlong(je) = pext%cdlong(je,1) 478 fbdata%cextunit(je) = pext%cdunit(je,1) 479 END DO 480 fbdata%caddlong(1,1) = 'Model interpolated spm' 481 fbdata%caddunit(1,1) = 'g/m3' 482 fbdata%cgrid(1) = 'T' 483 DO ja = 1, iadd 484 fbdata%caddname(1+ja) = padd%cdname(ja) 485 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 486 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 487 END DO 488 489 CASE('FCO2') 490 491 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 492 & 1 + iadd, iext, .TRUE. ) 493 494 clfiletype = 'fco2fb' 495 fbdata%cname(1) = surfdata%cvars(1) 496 fbdata%coblong(1) = 'fco2' 497 fbdata%cobunit(1) = 'uatm' 498 DO je = 1, iext 499 fbdata%cextname(je) = pext%cdname(je) 500 fbdata%cextlong(je) = pext%cdlong(je,1) 501 fbdata%cextunit(je) = pext%cdunit(je,1) 502 END DO 503 fbdata%caddlong(1,1) = 'Model interpolated fco2' 504 fbdata%caddunit(1,1) = 'uatm' 505 fbdata%cgrid(1) = 'T' 506 DO ja = 1, iadd 507 fbdata%caddname(1+ja) = padd%cdname(ja) 508 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 509 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 510 END DO 511 512 CASE('PCO2') 513 514 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 515 & 1 + iadd, iext, .TRUE. ) 516 517 clfiletype = 'pco2fb' 518 fbdata%cname(1) = surfdata%cvars(1) 519 fbdata%coblong(1) = 'pco2' 520 fbdata%cobunit(1) = 'uatm' 521 DO je = 1, iext 522 fbdata%cextname(je) = pext%cdname(je) 523 fbdata%cextlong(je) = pext%cdlong(je,1) 524 fbdata%cextunit(je) = pext%cdunit(je,1) 525 END DO 526 fbdata%caddlong(1,1) = 'Model interpolated pco2' 527 fbdata%caddunit(1,1) = 'uatm' 528 fbdata%cgrid(1) = 'T' 529 DO ja = 1, iadd 530 fbdata%caddname(1+ja) = padd%cdname(ja) 531 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 532 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 533 END DO 534 535 CASE DEFAULT 536 537 CALL ctl_stop( 'Unknown observation type '//TRIM(surfdata%cvars(1))//' in obs_wri_surf' ) 538 539 END SELECT 540 332 541 fbdata%caddname(1) = 'Hx' 333 fbdata%caddlong(1,1) = 'Model interpolated SSH - MDT' 334 fbdata%caddunit(1,1) = 'Metres' 335 fbdata%caddname(2) = 'SSH' 336 fbdata%caddlong(2,1) = 'Model Sea surface height' 337 fbdata%caddunit(2,1) = 'Metres' 338 fbdata%cgrid(1) = 'T' 339 DO ja = 1, nadd 340 fbdata%caddname(2+ja) = padd%cdname(ja) 341 fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1) 342 fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1) 343 END DO 344 345 WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 542 543 WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc 346 544 347 545 IF(lwp) THEN 348 546 WRITE(numout,*) 349 WRITE(numout,*)'obs_wri_s la:'547 WRITE(numout,*)'obs_wri_surf :' 350 548 WRITE(numout,*)'~~~~~~~~~~~~~' 351 WRITE(numout,*)'Writing SLA feedback file : ',TRIM(cfname)352 ENDIF 353 354 ! Transform obs_prof data structure into obfbdata structure549 WRITE(numout,*)'Writing '//TRIM(surfdata%cvars(1))//' feedback file : ',TRIM(clfname) 550 ENDIF 551 552 ! Transform surf data structure into obfbdata structure 355 553 fbdata%cdjuldref = '19500101000000' 356 DO jo = 1, s ladata%nsurf357 fbdata%plam(jo) = s ladata%rlam(jo)358 fbdata%pphi(jo) = s ladata%rphi(jo)359 WRITE(fbdata%cdtyp(jo),'(I4)') s ladata%ntyp(jo)554 DO jo = 1, surfdata%nsurf 555 fbdata%plam(jo) = surfdata%rlam(jo) 556 fbdata%pphi(jo) = surfdata%rphi(jo) 557 WRITE(fbdata%cdtyp(jo),'(I4)') surfdata%ntyp(jo) 360 558 fbdata%ivqc(jo,:) = 0 361 559 fbdata%ivqcf(:,jo,:) = 0 362 IF ( s ladata%nqc(jo) > 10) THEN560 IF ( surfdata%nqc(jo) > 255 ) THEN 363 561 fbdata%ioqc(jo) = 4 364 562 fbdata%ioqcf(1,jo) = 0 365 fbdata%ioqcf(2,jo) = sladata%nqc(jo) - 10563 fbdata%ioqcf(2,jo) = IAND(surfdata%nqc(jo),b'0000 0000 1111 1111') 366 564 ELSE 367 fbdata%ioqc(jo) = s ladata%nqc(jo)565 fbdata%ioqc(jo) = surfdata%nqc(jo) 368 566 fbdata%ioqcf(:,jo) = 0 369 567 ENDIF … … 372 570 fbdata%itqc(jo) = 0 373 571 fbdata%itqcf(:,jo) = 0 374 fbdata%cdwmo(jo) = s ladata%cwmo(jo)375 fbdata%kindex(jo) = s ladata%nsfil(jo)572 fbdata%cdwmo(jo) = surfdata%cwmo(jo) 573 fbdata%kindex(jo) = surfdata%nsfil(jo) 376 574 IF (ln_grid_global) THEN 377 fbdata%iobsi(jo,1) = s ladata%mi(jo)378 fbdata%iobsj(jo,1) = s ladata%mj(jo)575 fbdata%iobsi(jo,1) = surfdata%mi(jo) 576 fbdata%iobsj(jo,1) = surfdata%mj(jo) 379 577 ELSE 380 fbdata%iobsi(jo,1) = mig(s ladata%mi(jo))381 fbdata%iobsj(jo,1) = mjg(s ladata%mj(jo))578 fbdata%iobsi(jo,1) = mig(surfdata%mi(jo)) 579 fbdata%iobsj(jo,1) = mjg(surfdata%mj(jo)) 382 580 ENDIF 383 581 CALL greg2jul( 0, & 384 & s ladata%nmin(jo), &385 & s ladata%nhou(jo), &386 & s ladata%nday(jo), &387 & s ladata%nmon(jo), &388 & s ladata%nyea(jo), &582 & surfdata%nmin(jo), & 583 & surfdata%nhou(jo), & 584 & surfdata%nday(jo), & 585 & surfdata%nmon(jo), & 586 & surfdata%nyea(jo), & 389 587 & fbdata%ptim(jo), & 390 588 & krefdate = 19500101 ) 391 fbdata%padd(1,jo,1,1) = s ladata%rmod(jo,1)392 fbdata%padd(1,jo,2,1) = sladata%rext(jo,1)393 fbdata%pob(1,jo,1) = s ladata%robs(jo,1)589 fbdata%padd(1,jo,1,1) = surfdata%rmod(jo,1) 590 IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%padd(1,jo,2,1) = surfdata%rext(jo,1) 591 fbdata%pob(1,jo,1) = surfdata%robs(jo,1) 394 592 fbdata%pdep(1,jo) = 0.0 395 593 fbdata%idqc(1,jo) = 0 396 594 fbdata%idqcf(:,1,jo) = 0 397 IF ( s ladata%nqc(jo) > 10) THEN595 IF ( surfdata%nqc(jo) > 255 ) THEN 398 596 fbdata%ivqc(jo,1) = 4 399 597 fbdata%ivlqc(1,jo,1) = 4 400 598 fbdata%ivlqcf(1,1,jo,1) = 0 401 fbdata%ivlqcf(2,1,jo,1) = sladata%nqc(jo) - 10599 fbdata%ivlqcf(2,1,jo,1) = IAND(surfdata%nqc(jo),b'0000 0000 1111 1111') 402 600 ELSE 403 fbdata%ivqc(jo,1) = s ladata%nqc(jo)404 fbdata%ivlqc(1,jo,1) = s ladata%nqc(jo)601 fbdata%ivqc(jo,1) = surfdata%nqc(jo) 602 fbdata%ivlqc(1,jo,1) = surfdata%nqc(jo) 405 603 fbdata%ivlqcf(:,1,jo,1) = 0 406 604 ENDIF 407 605 fbdata%iobsk(1,jo,1) = 0 408 fbdata%pext(1,jo,1) = sladata%rext(jo,2)409 DO ja = 1, nadd606 IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%pext(1,jo,1) = surfdata%rext(jo,2) 607 DO ja = 1, iadd 410 608 fbdata%padd(1,jo,2+ja,1) = & 411 & s ladata%rext(jo,padd%ipoint(ja))412 END DO 413 DO je = 1, next609 & surfdata%rext(jo,padd%ipoint(ja)) 610 END DO 611 DO je = 1, iext 414 612 fbdata%pext(1,jo,1+je) = & 415 & s ladata%rext(jo,pext%ipoint(je))613 & surfdata%rext(jo,pext%ipoint(je)) 416 614 END DO 417 615 END DO 418 616 419 617 ! Write the obfbdata structure 420 CALL write_obfbdata( c fname, fbdata )618 CALL write_obfbdata( clfname, fbdata ) 421 619 422 620 ! Output some basic statistics … … 425 623 CALL dealloc_obfbdata( fbdata ) 426 624 427 END SUBROUTINE obs_wri_sla 428 429 SUBROUTINE obs_wri_sst( cprefix, sstdata, padd, pext ) 430 !!----------------------------------------------------------------------- 431 !! 432 !! *** ROUTINE obs_wri_sst *** 433 !! 434 !! ** Purpose : Write SST observation diagnostics 435 !! related 436 !! 437 !! ** Method : NetCDF 438 !! 439 !! ** Action : 440 !! 441 !! ! 07-07 (S. Ricci) Original 442 !! ! 09-01 (K. Mogensen) New feedback format. 443 !!----------------------------------------------------------------------- 444 445 !! * Modules used 446 IMPLICIT NONE 447 448 !! * Arguments 449 CHARACTER(LEN=*), INTENT(IN) :: cprefix ! Prefix for output files 450 TYPE(obs_surf), INTENT(INOUT) :: sstdata ! Full set of SST 451 TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable 452 TYPE(obswriinfo), OPTIONAL :: pext ! Extra info 453 454 !! * Local declarations 455 TYPE(obfbdata) :: fbdata 456 CHARACTER(LEN=40) :: cfname ! netCDF filename 457 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_sst' 458 INTEGER :: jo 459 INTEGER :: ja 460 INTEGER :: je 461 INTEGER :: nadd 462 INTEGER :: next 463 464 IF ( PRESENT( padd ) ) THEN 465 nadd = padd%inum 466 ELSE 467 nadd = 0 468 ENDIF 469 470 IF ( PRESENT( pext ) ) THEN 471 next = pext%inum 472 ELSE 473 next = 0 474 ENDIF 475 476 CALL init_obfbdata( fbdata ) 477 478 CALL alloc_obfbdata( fbdata, 1, sstdata%nsurf, 1, & 479 & 1 + nadd, next, .TRUE. ) 480 481 fbdata%cname(1) = 'SST' 482 fbdata%coblong(1) = 'Sea surface temperature' 483 fbdata%cobunit(1) = 'Degree centigrade' 484 DO je = 1, next 485 fbdata%cextname(je) = pext%cdname(je) 486 fbdata%cextlong(je) = pext%cdlong(je,1) 487 fbdata%cextunit(je) = pext%cdunit(je,1) 488 END DO 489 fbdata%caddname(1) = 'Hx' 490 fbdata%caddlong(1,1) = 'Model interpolated SST' 491 fbdata%caddunit(1,1) = 'Degree centigrade' 492 fbdata%cgrid(1) = 'T' 493 DO ja = 1, nadd 494 fbdata%caddname(1+ja) = padd%cdname(ja) 495 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 496 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 497 END DO 498 499 WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 500 501 IF(lwp) THEN 502 WRITE(numout,*) 503 WRITE(numout,*)'obs_wri_sst :' 504 WRITE(numout,*)'~~~~~~~~~~~~~' 505 WRITE(numout,*)'Writing SST feedback file : ',TRIM(cfname) 506 ENDIF 507 508 ! Transform obs_prof data structure into obfbdata structure 509 fbdata%cdjuldref = '19500101000000' 510 DO jo = 1, sstdata%nsurf 511 fbdata%plam(jo) = sstdata%rlam(jo) 512 fbdata%pphi(jo) = sstdata%rphi(jo) 513 WRITE(fbdata%cdtyp(jo),'(I4)') sstdata%ntyp(jo) 514 fbdata%ivqc(jo,:) = 0 515 fbdata%ivqcf(:,jo,:) = 0 516 IF ( sstdata%nqc(jo) > 10 ) THEN 517 fbdata%ioqc(jo) = 4 518 fbdata%ioqcf(1,jo) = 0 519 fbdata%ioqcf(2,jo) = sstdata%nqc(jo) - 10 520 ELSE 521 fbdata%ioqc(jo) = MAX(sstdata%nqc(jo),1) 522 fbdata%ioqcf(:,jo) = 0 523 ENDIF 524 fbdata%ipqc(jo) = 0 525 fbdata%ipqcf(:,jo) = 0 526 fbdata%itqc(jo) = 0 527 fbdata%itqcf(:,jo) = 0 528 fbdata%cdwmo(jo) = '' 529 fbdata%kindex(jo) = sstdata%nsfil(jo) 530 IF (ln_grid_global) THEN 531 fbdata%iobsi(jo,1) = sstdata%mi(jo) 532 fbdata%iobsj(jo,1) = sstdata%mj(jo) 533 ELSE 534 fbdata%iobsi(jo,1) = mig(sstdata%mi(jo)) 535 fbdata%iobsj(jo,1) = mjg(sstdata%mj(jo)) 536 ENDIF 537 CALL greg2jul( 0, & 538 & sstdata%nmin(jo), & 539 & sstdata%nhou(jo), & 540 & sstdata%nday(jo), & 541 & sstdata%nmon(jo), & 542 & sstdata%nyea(jo), & 543 & fbdata%ptim(jo), & 544 & krefdate = 19500101 ) 545 fbdata%padd(1,jo,1,1) = sstdata%rmod(jo,1) 546 fbdata%pob(1,jo,1) = sstdata%robs(jo,1) 547 fbdata%pdep(1,jo) = 0.0 548 fbdata%idqc(1,jo) = 0 549 fbdata%idqcf(:,1,jo) = 0 550 IF ( sstdata%nqc(jo) > 10 ) THEN 551 fbdata%ivqc(jo,1) = 4 552 fbdata%ivlqc(1,jo,1) = 4 553 fbdata%ivlqcf(1,1,jo,1) = 0 554 fbdata%ivlqcf(2,1,jo,1) = sstdata%nqc(jo) - 10 555 ELSE 556 fbdata%ivqc(jo,1) = MAX(sstdata%nqc(jo),1) 557 fbdata%ivlqc(1,jo,1) = MAX(sstdata%nqc(jo),1) 558 fbdata%ivlqcf(:,1,jo,1) = 0 559 ENDIF 560 fbdata%iobsk(1,jo,1) = 0 561 DO ja = 1, nadd 562 fbdata%padd(1,jo,1+ja,1) = & 563 & sstdata%rext(jo,padd%ipoint(ja)) 564 END DO 565 DO je = 1, next 566 fbdata%pext(1,jo,je) = & 567 & sstdata%rext(jo,pext%ipoint(je)) 568 END DO 569 570 END DO 571 572 ! Write the obfbdata structure 573 574 CALL write_obfbdata( cfname, fbdata ) 575 576 ! Output some basic statistics 577 CALL obs_wri_stats( fbdata ) 578 579 CALL dealloc_obfbdata( fbdata ) 580 581 END SUBROUTINE obs_wri_sst 582 583 SUBROUTINE obs_wri_sss 584 END SUBROUTINE obs_wri_sss 585 586 SUBROUTINE obs_wri_seaice( cprefix, seaicedata, padd, pext ) 587 !!----------------------------------------------------------------------- 588 !! 589 !! *** ROUTINE obs_wri_seaice *** 590 !! 591 !! ** Purpose : Write sea ice observation diagnostics 592 !! related 593 !! 594 !! ** Method : NetCDF 595 !! 596 !! ** Action : 597 !! 598 !! ! 07-07 (S. Ricci) Original 599 !! ! 09-01 (K. Mogensen) New feedback format. 600 !!----------------------------------------------------------------------- 601 602 !! * Modules used 603 IMPLICIT NONE 604 605 !! * Arguments 606 CHARACTER(LEN=*), INTENT(IN) :: cprefix ! Prefix for output files 607 TYPE(obs_surf), INTENT(INOUT) :: seaicedata ! Full set of sea ice 608 TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable 609 TYPE(obswriinfo), OPTIONAL :: pext ! Extra info 610 611 !! * Local declarations 612 TYPE(obfbdata) :: fbdata 613 CHARACTER(LEN=40) :: cfname ! netCDF filename 614 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_seaice' 615 INTEGER :: jo 616 INTEGER :: ja 617 INTEGER :: je 618 INTEGER :: nadd 619 INTEGER :: next 620 621 IF ( PRESENT( padd ) ) THEN 622 nadd = padd%inum 623 ELSE 624 nadd = 0 625 ENDIF 626 627 IF ( PRESENT( pext ) ) THEN 628 next = pext%inum 629 ELSE 630 next = 0 631 ENDIF 632 633 CALL init_obfbdata( fbdata ) 634 635 CALL alloc_obfbdata( fbdata, 1, seaicedata%nsurf, 1, 1, 0, .TRUE. ) 636 637 fbdata%cname(1) = 'SEAICE' 638 fbdata%coblong(1) = 'Sea ice' 639 fbdata%cobunit(1) = 'Fraction' 640 DO je = 1, next 641 fbdata%cextname(je) = pext%cdname(je) 642 fbdata%cextlong(je) = pext%cdlong(je,1) 643 fbdata%cextunit(je) = pext%cdunit(je,1) 644 END DO 645 fbdata%caddname(1) = 'Hx' 646 fbdata%caddlong(1,1) = 'Model interpolated ICE' 647 fbdata%caddunit(1,1) = 'Fraction' 648 fbdata%cgrid(1) = 'T' 649 DO ja = 1, nadd 650 fbdata%caddname(1+ja) = padd%cdname(ja) 651 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 652 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 653 END DO 654 655 WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 656 657 IF(lwp) THEN 658 WRITE(numout,*) 659 WRITE(numout,*)'obs_wri_seaice :' 660 WRITE(numout,*)'~~~~~~~~~~~~~~~~' 661 WRITE(numout,*)'Writing SEAICE feedback file : ',TRIM(cfname) 662 ENDIF 663 664 ! Transform obs_prof data structure into obfbdata structure 665 fbdata%cdjuldref = '19500101000000' 666 DO jo = 1, seaicedata%nsurf 667 fbdata%plam(jo) = seaicedata%rlam(jo) 668 fbdata%pphi(jo) = seaicedata%rphi(jo) 669 WRITE(fbdata%cdtyp(jo),'(I4)') seaicedata%ntyp(jo) 670 fbdata%ivqc(jo,:) = 0 671 fbdata%ivqcf(:,jo,:) = 0 672 IF ( seaicedata%nqc(jo) > 10 ) THEN 673 fbdata%ioqc(jo) = 4 674 fbdata%ioqcf(1,jo) = 0 675 fbdata%ioqcf(2,jo) = seaicedata%nqc(jo) - 10 676 ELSE 677 fbdata%ioqc(jo) = MAX(seaicedata%nqc(jo),1) 678 fbdata%ioqcf(:,jo) = 0 679 ENDIF 680 fbdata%ipqc(jo) = 0 681 fbdata%ipqcf(:,jo) = 0 682 fbdata%itqc(jo) = 0 683 fbdata%itqcf(:,jo) = 0 684 fbdata%cdwmo(jo) = '' 685 fbdata%kindex(jo) = seaicedata%nsfil(jo) 686 IF (ln_grid_global) THEN 687 fbdata%iobsi(jo,1) = seaicedata%mi(jo) 688 fbdata%iobsj(jo,1) = seaicedata%mj(jo) 689 ELSE 690 fbdata%iobsi(jo,1) = mig(seaicedata%mi(jo)) 691 fbdata%iobsj(jo,1) = mjg(seaicedata%mj(jo)) 692 ENDIF 693 CALL greg2jul( 0, & 694 & seaicedata%nmin(jo), & 695 & seaicedata%nhou(jo), & 696 & seaicedata%nday(jo), & 697 & seaicedata%nmon(jo), & 698 & seaicedata%nyea(jo), & 699 & fbdata%ptim(jo), & 700 & krefdate = 19500101 ) 701 fbdata%padd(1,jo,1,1) = seaicedata%rmod(jo,1) 702 fbdata%pob(1,jo,1) = seaicedata%robs(jo,1) 703 fbdata%pdep(1,jo) = 0.0 704 fbdata%idqc(1,jo) = 0 705 fbdata%idqcf(:,1,jo) = 0 706 IF ( seaicedata%nqc(jo) > 10 ) THEN 707 fbdata%ivlqc(1,jo,1) = 4 708 fbdata%ivlqcf(1,1,jo,1) = 0 709 fbdata%ivlqcf(2,1,jo,1) = seaicedata%nqc(jo) - 10 710 ELSE 711 fbdata%ivlqc(1,jo,1) = MAX(seaicedata%nqc(jo),1) 712 fbdata%ivlqcf(:,1,jo,1) = 0 713 ENDIF 714 fbdata%iobsk(1,jo,1) = 0 715 DO ja = 1, nadd 716 fbdata%padd(1,jo,1+ja,1) = & 717 & seaicedata%rext(jo,padd%ipoint(ja)) 718 END DO 719 DO je = 1, next 720 fbdata%pext(1,jo,je) = & 721 & seaicedata%rext(jo,pext%ipoint(je)) 722 END DO 723 724 END DO 725 726 ! Write the obfbdata structure 727 CALL write_obfbdata( cfname, fbdata ) 728 729 ! Output some basic statistics 730 CALL obs_wri_stats( fbdata ) 731 732 CALL dealloc_obfbdata( fbdata ) 733 734 END SUBROUTINE obs_wri_seaice 735 736 SUBROUTINE obs_wri_vel( cprefix, profdata, k2dint, padd, pext ) 737 !!----------------------------------------------------------------------- 738 !! 739 !! *** ROUTINE obs_wri_vel *** 740 !! 741 !! ** Purpose : Write current (profile) observation 742 !! related diagnostics 743 !! 744 !! ** Method : NetCDF 745 !! 746 !! ** Action : 747 !! 748 !! History : 749 !! ! 09-01 (K. Mogensen) New feedback format routine 750 !!----------------------------------------------------------------------- 751 752 !! * Modules used 753 754 !! * Arguments 755 CHARACTER(LEN=*), INTENT(IN) :: cprefix ! Prefix for output files 756 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data 757 INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation method 758 TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable 759 TYPE(obswriinfo), OPTIONAL :: pext ! Extra info 760 761 !! * Local declarations 762 TYPE(obfbdata) :: fbdata 763 CHARACTER(LEN=40) :: cfname 764 INTEGER :: ilevel 765 INTEGER :: jvar 766 INTEGER :: jk 767 INTEGER :: ik 768 INTEGER :: jo 769 INTEGER :: ja 770 INTEGER :: je 771 INTEGER :: nadd 772 INTEGER :: next 773 REAL(wp) :: zpres 774 REAL(wp), DIMENSION(:), ALLOCATABLE :: & 775 & zu, & 776 & zv 777 778 IF ( PRESENT( padd ) ) THEN 779 nadd = padd%inum 780 ELSE 781 nadd = 0 782 ENDIF 783 784 IF ( PRESENT( pext ) ) THEN 785 next = pext%inum 786 ELSE 787 next = 0 788 ENDIF 789 790 CALL init_obfbdata( fbdata ) 791 792 ! Find maximum level 793 ilevel = 0 794 DO jvar = 1, 2 795 ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) ) 796 END DO 797 CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, 2, 0, .TRUE. ) 798 799 fbdata%cname(1) = 'UVEL' 800 fbdata%cname(2) = 'VVEL' 801 fbdata%coblong(1) = 'Zonal velocity' 802 fbdata%coblong(2) = 'Meridional velocity' 803 fbdata%cobunit(1) = 'm/s' 804 fbdata%cobunit(2) = 'm/s' 805 DO je = 1, next 806 fbdata%cextname(je) = pext%cdname(je) 807 fbdata%cextlong(je) = pext%cdlong(je,1) 808 fbdata%cextunit(je) = pext%cdunit(je,1) 809 END DO 810 fbdata%caddname(1) = 'Hx' 811 fbdata%caddlong(1,1) = 'Model interpolated zonal velocity' 812 fbdata%caddlong(1,2) = 'Model interpolated meridional velocity' 813 fbdata%caddunit(1,1) = 'm/s' 814 fbdata%caddunit(1,2) = 'm/s' 815 fbdata%caddname(2) = 'HxG' 816 fbdata%caddlong(2,1) = 'Model interpolated zonal velocity (model grid)' 817 fbdata%caddlong(2,2) = 'Model interpolated meridional velocity (model grid)' 818 fbdata%caddunit(2,1) = 'm/s' 819 fbdata%caddunit(2,2) = 'm/s' 820 fbdata%cgrid(1) = 'U' 821 fbdata%cgrid(2) = 'V' 822 DO ja = 1, nadd 823 fbdata%caddname(2+ja) = padd%cdname(ja) 824 fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1) 825 fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1) 826 END DO 827 828 WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 829 830 IF(lwp) THEN 831 WRITE(numout,*) 832 WRITE(numout,*)'obs_wri_vel :' 833 WRITE(numout,*)'~~~~~~~~~~~~~' 834 WRITE(numout,*)'Writing velocuty feedback file : ',TRIM(cfname) 835 ENDIF 836 837 ALLOCATE( & 838 & zu(profdata%nvprot(1)), & 839 & zv(profdata%nvprot(2)) & 840 & ) 841 CALL obs_rotvel( profdata, k2dint, zu, zv ) 842 843 ! Transform obs_prof data structure into obfbdata structure 844 fbdata%cdjuldref = '19500101000000' 845 DO jo = 1, profdata%nprof 846 fbdata%plam(jo) = profdata%rlam(jo) 847 fbdata%pphi(jo) = profdata%rphi(jo) 848 WRITE(fbdata%cdtyp(jo),'(I4)') profdata%ntyp(jo) 849 fbdata%ivqc(jo,:) = profdata%ivqc(jo,:) 850 fbdata%ivqcf(:,jo,:) = profdata%ivqcf(:,jo,:) 851 IF ( profdata%nqc(jo) > 10 ) THEN 852 fbdata%ioqc(jo) = 4 853 fbdata%ioqcf(1,jo) = profdata%nqcf(1,jo) 854 fbdata%ioqcf(2,jo) = profdata%nqc(jo) - 10 855 ELSE 856 fbdata%ioqc(jo) = profdata%nqc(jo) 857 fbdata%ioqcf(:,jo) = profdata%nqcf(:,jo) 858 ENDIF 859 fbdata%ipqc(jo) = profdata%ipqc(jo) 860 fbdata%ipqcf(:,jo) = profdata%ipqcf(:,jo) 861 fbdata%itqc(jo) = profdata%itqc(jo) 862 fbdata%itqcf(:,jo) = profdata%itqcf(:,jo) 863 fbdata%cdwmo(jo) = profdata%cwmo(jo) 864 fbdata%kindex(jo) = profdata%npfil(jo) 865 DO jvar = 1, profdata%nvar 866 IF (ln_grid_global) THEN 867 fbdata%iobsi(jo,jvar) = profdata%mi(jo,jvar) 868 fbdata%iobsj(jo,jvar) = profdata%mj(jo,jvar) 869 ELSE 870 fbdata%iobsi(jo,jvar) = mig(profdata%mi(jo,jvar)) 871 fbdata%iobsj(jo,jvar) = mjg(profdata%mj(jo,jvar)) 872 ENDIF 873 END DO 874 CALL greg2jul( 0, & 875 & profdata%nmin(jo), & 876 & profdata%nhou(jo), & 877 & profdata%nday(jo), & 878 & profdata%nmon(jo), & 879 & profdata%nyea(jo), & 880 & fbdata%ptim(jo), & 881 & krefdate = 19500101 ) 882 ! Reform the profiles arrays for output 883 DO jvar = 1, 2 884 DO jk = profdata%npvsta(jo,jvar), profdata%npvend(jo,jvar) 885 ik = profdata%var(jvar)%nvlidx(jk) 886 IF ( jvar == 1 ) THEN 887 fbdata%padd(ik,jo,1,jvar) = zu(jk) 888 ELSE 889 fbdata%padd(ik,jo,1,jvar) = zv(jk) 890 ENDIF 891 fbdata%padd(ik,jo,2,jvar) = profdata%var(jvar)%vmod(jk) 892 fbdata%pob(ik,jo,jvar) = profdata%var(jvar)%vobs(jk) 893 fbdata%pdep(ik,jo) = profdata%var(jvar)%vdep(jk) 894 fbdata%idqc(ik,jo) = profdata%var(jvar)%idqc(jk) 895 fbdata%idqcf(:,ik,jo) = profdata%var(jvar)%idqcf(:,jk) 896 IF ( profdata%var(jvar)%nvqc(jk) > 10 ) THEN 897 fbdata%ivlqc(ik,jo,jvar) = 4 898 fbdata%ivlqcf(1,ik,jo,jvar) = profdata%var(jvar)%nvqcf(1,jk) 899 fbdata%ivlqcf(2,ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) - 10 900 ELSE 901 fbdata%ivlqc(ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) 902 fbdata%ivlqcf(:,ik,jo,jvar) = profdata%var(jvar)%nvqcf(:,jk) 903 ENDIF 904 fbdata%iobsk(ik,jo,jvar) = profdata%var(jvar)%mvk(jk) 905 DO ja = 1, nadd 906 fbdata%padd(ik,jo,2+ja,jvar) = & 907 & profdata%var(jvar)%vext(jk,padd%ipoint(ja)) 908 END DO 909 DO je = 1, next 910 fbdata%pext(ik,jo,je) = & 911 & profdata%var(jvar)%vext(jk,pext%ipoint(je)) 912 END DO 913 END DO 914 END DO 915 END DO 916 917 ! Write the obfbdata structure 918 CALL write_obfbdata( cfname, fbdata ) 919 920 ! Output some basic statistics 921 CALL obs_wri_stats( fbdata ) 922 923 CALL dealloc_obfbdata( fbdata ) 924 925 DEALLOCATE( & 926 & zu, & 927 & zv & 928 & ) 929 930 END SUBROUTINE obs_wri_vel 625 END SUBROUTINE obs_wri_surf 931 626 932 627 SUBROUTINE obs_wri_stats( fbdata ) … … 951 646 INTEGER :: jo 952 647 INTEGER :: jk 953 954 ! INTEGER :: nlev 955 ! INTEGER :: nlevmpp 956 ! INTEGER :: nobsmpp 957 INTEGER :: numgoodobs 958 INTEGER :: numgoodobsmpp 648 INTEGER :: inumgoodobs 649 INTEGER :: inumgoodobsmpp 959 650 REAL(wp) :: zsumx 960 651 REAL(wp) :: zsumx2 961 652 REAL(wp) :: zomb 653 962 654 963 655 IF (lwp) THEN 964 656 WRITE(numout,*) '' 965 657 WRITE(numout,*) 'obs_wri_stats :' 966 WRITE(numout,*) '~~~~~~~~~~~~~~~' 658 WRITE(numout,*) '~~~~~~~~~~~~~~~' 967 659 ENDIF 968 660 … … 970 662 zsumx=0.0_wp 971 663 zsumx2=0.0_wp 972 numgoodobs=0664 inumgoodobs=0 973 665 DO jo = 1, fbdata%nobs 974 666 DO jk = 1, fbdata%nlev … … 976 668 & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 977 669 & ( fbdata%padd(jk,jo,1,jvar) < 9999.0 ) ) THEN 978 979 670 671 zomb=fbdata%pob(jk, jo, jvar)-fbdata%padd(jk, jo, 1, jvar) 980 672 zsumx=zsumx+zomb 981 673 zsumx2=zsumx2+zomb**2 982 numgoodobs=numgoodobs+1983 674 inumgoodobs=inumgoodobs+1 675 ENDIF 984 676 ENDDO 985 677 ENDDO 986 678 987 CALL obs_mpp_sum_integer( numgoodobs,numgoodobsmpp )679 CALL obs_mpp_sum_integer( inumgoodobs, inumgoodobsmpp ) 988 680 CALL mpp_sum(zsumx) 989 681 CALL mpp_sum(zsumx2) 990 682 991 683 IF (lwp) THEN 992 WRITE(numout,*) 'Type: ',fbdata%cname(jvar),' Total number of good observations: ',numgoodobsmpp993 WRITE(numout,*) 'Overall mean obs minus model of the good observations: ',zsumx/numgoodobsmpp994 WRITE(numout,*) 'Overall RMS obs minus model of the good observations: ',sqrt( zsumx2/ numgoodobsmpp )995 684 WRITE(numout,*) 'Type: ',fbdata%cname(jvar),' Total number of good observations: ',inumgoodobsmpp 685 WRITE(numout,*) 'Overall mean obs minus model of the good observations: ',zsumx/inumgoodobsmpp 686 WRITE(numout,*) 'Overall RMS obs minus model of the good observations: ',sqrt( zsumx2/inumgoodobsmpp ) 687 WRITE(numout,*) '' 996 688 ENDIF 997 689 998 690 ENDDO 999 691 -
branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obsinter_h2d.h90
r7960 r7992 1240 1240 & zdum, & 1241 1241 & zaamax 1242 1242 1243 imax = -1 1243 1244 ! Main computation 1244 1245 pflt = 1.0_wp
Note: See TracChangeset
for help on using the changeset viewer.