Changeset 15752
- Timestamp:
- 2022-03-15T18:47:13+01:00 (2 years ago)
- Location:
- NEMO/branches/UKMO/NEMO_4.0.4_FOAM_package_generic_obs
- Files:
-
- 2 deleted
- 17 edited
- 3 copied
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/UKMO/NEMO_4.0.4_FOAM_package_generic_obs/cfgs/SHARED/namelist_ref
r15731 r15752 1242 1242 !! !! 1243 1243 !! namobs observation and model comparison (default: OFF) 1244 !! namobs_dta observation and model comparison - external data (see: namobs) 1244 1245 !! nam_asminc assimilation increments ('key_asminc') 1245 1246 !!====================================================================== 1246 1247 ! 1247 1248 !----------------------------------------------------------------------- 1248 &namobs ! observation usage switch (default: OFF) 1249 !----------------------------------------------------------------------- 1250 ln_diaobs = .false. ! Logical switch for the observation operator 1251 ! 1252 ln_t3d = .false. ! Logical switch for T profile observations 1253 ln_s3d = .false. ! Logical switch for S profile observations 1254 ln_sla = .false. ! Logical switch for SLA observations 1255 ln_sst = .false. ! Logical switch for SST observations 1256 ln_sss = .false. ! Logical swithc for SSS observations 1257 ln_sic = .false. ! Logical switch for Sea Ice observations 1258 ln_vel3d = .false. ! Logical switch for velocity observations 1259 ln_altbias = .false. ! Logical switch for altimeter bias correction 1260 ln_sstbias = .false. ! Logical switch for SST bias correction 1261 ln_nea = .false. ! Logical switch for rejection of observations near land 1262 ln_grid_global = .true. ! Logical switch for global distribution of observations 1263 ln_grid_search_lookup = .false. ! Logical switch for obs grid search w/lookup table 1264 ln_ignmis = .true. ! Logical switch for ignoring missing files 1265 ln_s_at_t = .false. ! Logical switch for computing model S at T obs if not there 1266 ln_sstnight = .false. ! Logical switch for calculating night-time average for SST obs 1267 ln_bound_reject = .false. ! Logical to remove obs near boundaries in LAMs. 1268 ln_sla_fp_indegs = .true. ! Logical for SLA: T=> averaging footprint is in degrees, F=> in metres 1269 ln_sst_fp_indegs = .true. ! Logical for SST: T=> averaging footprint is in degrees, F=> in metres 1270 ln_sss_fp_indegs = .true. ! Logical for SSS: T=> averaging footprint is in degrees, F=> in metres 1271 ln_sic_fp_indegs = .true. ! Logical for SIC: T=> averaging footprint is in degrees, F=> in metres 1272 ! All of the *files* variables below are arrays. Use namelist_cfg to add more files 1273 cn_profbfiles = 'profiles_01.nc' ! Profile feedback input observation file names 1274 cn_slafbfiles = 'sla_01.nc' ! SLA feedback input observation file names 1275 cn_sstfbfiles = 'sst_01.nc' ! SST feedback input observation file names 1276 cn_sssfbfiles = 'sss_01.nc' ! SSS feedback input observation file names 1277 cn_sicfbfiles = 'sic_01.nc' ! SIC feedback input observation file names 1278 cn_velfbfiles = 'vel_01.nc' ! Velocity feedback input observation file names 1279 cn_altbiasfile = 'altbias.nc' ! Altimeter bias input file name 1280 cn_sstbiasfiles = 'sstbias.nc' ! SST bias input file name 1281 cn_gridsearchfile ='gridsearch.nc' ! Grid search file name 1282 rn_gridsearchres = 0.5 ! Grid search resolution 1283 rn_mdtcorr = 1.61 ! MDT correction 1284 rn_mdtcutoff = 65.0 ! MDT cutoff for computed correction 1285 rn_dobsini = 00010101.000000 ! Initial date in window YYYYMMDD.HHMMSS 1286 rn_dobsend = 00010102.000000 ! Final date in window YYYYMMDD.HHMMSS 1287 rn_sla_avglamscl = 0. ! E/W diameter of SLA observation footprint (metres/degrees) 1288 rn_sla_avgphiscl = 0. ! N/S diameter of SLA observation footprint (metres/degrees) 1289 rn_sst_avglamscl = 0. ! E/W diameter of SST observation footprint (metres/degrees) 1290 rn_sst_avgphiscl = 0. ! N/S diameter of SST observation footprint (metres/degrees) 1291 rn_sss_avglamscl = 0. ! E/W diameter of SSS observation footprint (metres/degrees) 1292 rn_sss_avgphiscl = 0. ! N/S diameter of SSS observation footprint (metres/degrees) 1293 rn_sic_avglamscl = 0. ! E/W diameter of SIC observation footprint (metres/degrees) 1294 rn_sic_avgphiscl = 0. ! N/S diameter of SIC observation footprint (metres/degrees) 1295 nn_1dint = 0 ! Type of vertical interpolation method 1296 nn_2dint = 0 ! Default horizontal interpolation method 1297 nn_2dint_sla = 0 ! Horizontal interpolation method for SLA 1298 nn_2dint_sst = 0 ! Horizontal interpolation method for SST 1299 nn_2dint_sss = 0 ! Horizontal interpolation method for SSS 1300 nn_2dint_sic = 0 ! Horizontal interpolation method for SIC 1301 nn_msshc = 0 ! MSSH correction scheme 1302 nn_profdavtypes = -1 ! Profile daily average types - array 1249 &namobs ! observation and model comparison (default: OFF) 1250 !----------------------------------------------------------------------- 1251 ln_diaobs = .false. ! Logical switch for the observation operator 1252 nn_obsgroups = 0 ! Number of observation group namelists (namobs_dta) to read in 1253 ln_grid_global = .true. ! Logical switch for global distribution of observations 1254 ln_grid_search_lookup = .false. ! Logical switch for obs grid search w/lookup table 1255 cn_gridsearchfile = 'grid_search' ! Grid search file name header 1256 rn_gridsearchres = 0.5 ! Grid search resolution 1257 rn_dobsini = 00010101.000000 ! Initial date in window YYYYMMDD.HHMMSS 1258 rn_dobsend = 00010102.000000 ! Final date in window YYYYMMDD.HHMMSS 1259 / 1260 !----------------------------------------------------------------------- 1261 &namobs_dta ! observation and model comparison - external data (see: namobs) 1262 !----------------------------------------------------------------------- 1263 cn_groupname = '' ! Name of obs group (output file will be cn_groupname//'fb_????.nc') 1264 ln_enabled = .true. ! Logical switch for group being processed not ignored 1265 ln_prof = .false. ! Logical switch for profile data 1266 ln_surf = .false. ! Logical switch for surface data 1267 cn_obsfiles = '' ! Observation file names 1268 cn_obstypes = '' ! Observation types to read from files 1269 ln_nea = .false. ! Logical switch for rejecting observations near land 1270 ln_bound_reject = .false. ! Logical switch for rejecting obs near the boundary 1271 ln_ignmis = .true. ! Logical switch for ignoring missing files 1272 nn_2dint = 0 ! Type of horizontal interpolation method 1273 ! Relevant if ln_prof = .true.: 1274 nn_1dint = 0 ! Type of vertical interpolation method 1275 nn_profdavtypes = -1 ! Profile data types representing a daily average 1276 ln_all_at_all = .false. ! Logical switch for computing all model variables at all obs points 1277 ! Relevant if ln_surf = .true.: 1278 ln_fp_indegs = .true. ! Logical: T=> averaging footprint is in degrees, F=> in metres 1279 rn_avglamscl = 0. ! E/W diameter of observation footprint (metres/degrees) 1280 rn_avgphiscl = 0. ! N/S diameter of observation footprint (metres/degrees) 1281 ln_night = .false. ! Logical switch for calculating night-time average for obs 1282 ln_time_mean_bkg = .false. ! Logical switch for applying time mean of background (e.g. to remove tidal signal) 1283 rn_time_mean_period = 24.8333 ! Meaning period in hours if ln_time_mean_bkg (default is AMM tidal period) 1284 ln_obsbias = .false. ! Logical switch for bias correction 1285 cn_obsbiasfiles = '' ! Bias input file names 1286 cn_type_to_biascorrect = '' ! Observation type to bias correct 1287 cn_obsbiasfile_varname = '' ! Bias variable name in input file 1288 ! Relevant if 'SLA' in cn_obstypes: 1289 ln_altbias = .false. ! Logical switch for altimeter bias correction 1290 cn_altbiasfile = '' ! Altimeter bias input file name 1291 nn_msshc = 0 ! MSSH correction scheme 1292 rn_mdtcorr = 1.61 ! MDT correction 1293 rn_mdtcutoff = 65.0 ! MDT cutoff for computed correction 1294 ! Relevant if 'POTM', 'PSAL', 'SST', or 'SSS' in cn_obstypes: 1295 ln_output_clim = .false. ! Logical switch to output climatological temperature/salinity (if ln_tradmp) 1303 1296 / 1304 1297 !----------------------------------------------------------------------- -
NEMO/branches/UKMO/NEMO_4.0.4_FOAM_package_generic_obs/doc/namelists/namobs
r11703 r15752 20 20 ln_sstnight = .false. ! Logical switch for calculating night-time average for SST obs 21 21 ln_bound_reject = .false. ! Logical to remove obs near boundaries in LAMs. 22 ln_default_fp_indegs = .true. ! Logical: T=> averaging footprint is in degrees, F=> in metres 22 23 ln_sla_fp_indegs = .true. ! Logical for SLA: T=> averaging footprint is in degrees, F=> in metres 23 24 ln_sst_fp_indegs = .true. ! Logical for SST: T=> averaging footprint is in degrees, F=> in metres … … 39 40 rn_dobsini = 00010101.000000 ! Initial date in window YYYYMMDD.HHMMSS 40 41 rn_dobsend = 00010102.000000 ! Final date in window YYYYMMDD.HHMMSS 42 rn_default_avglamscl = 0. ! Default E/W diameter of observation footprint (metres/degrees) 43 rn_default_avgphiscl = 0. ! Default N/S diameter of observation footprint (metres/degrees) 41 44 rn_sla_avglamscl = 0. ! E/W diameter of SLA observation footprint (metres/degrees) 42 45 rn_sla_avgphiscl = 0. ! N/S diameter of SLA observation footprint (metres/degrees) … … 48 51 rn_sic_avgphiscl = 0. ! N/S diameter of SIC observation footprint (metres/degrees) 49 52 nn_1dint = 0 ! Type of vertical interpolation method 50 nn_2dint = 0! Default horizontal interpolation method53 nn_2dint_default = 0 ! Default horizontal interpolation method 51 54 nn_2dint_sla = 0 ! Horizontal interpolation method for SLA 52 55 nn_2dint_sst = 0 ! Horizontal interpolation method for SST -
NEMO/branches/UKMO/NEMO_4.0.4_FOAM_package_generic_obs/src/OCE/DYN/dynspg_ts.F90
r14075 r15752 51 51 USE agrif_oce 52 52 #endif 53 #if defined key_asminc54 USE asminc ! Assimilation increment55 #endif56 53 ! 57 54 USE in_out_manager ! I/O manager … … 341 338 ENDIF 342 339 ! 343 #if defined key_asminc344 ! != Add the IAU weighted SSH increment =!345 ! ! ------------------------------------ !346 IF( lk_asminc .AND. ln_sshinc .AND. ln_asmiau ) THEN347 zssh_frc(:,:) = zssh_frc(:,:) - ssh_iau(:,:)348 ENDIF349 #endif350 340 ! != Fill boundary data arrays for AGRIF 351 341 ! ! ------------------------------------ -
NEMO/branches/UKMO/NEMO_4.0.4_FOAM_package_generic_obs/src/OCE/OBS/diaobs.F90
r14075 r15752 26 26 !! fin_date : Compute the final date YYYYMMDD.HHMMSS 27 27 !!---------------------------------------------------------------------- 28 USE par_kind ! Precision variables 29 USE in_out_manager ! I/O manager 30 USE par_oce ! ocean parameter 31 USE dom_oce ! Ocean space and time domain variables 32 USE sbc_oce ! Sea-ice fraction 28 USE par_kind ! Precision variables 29 USE in_out_manager ! I/O manager 30 USE timing ! Timing 31 USE par_oce ! ocean parameter 32 USE dom_oce ! Ocean space and time domain variables 33 USE sbc_oce ! Sea-ice fraction 33 34 ! 34 USE obs_read_prof ! Reading and allocation of profile obs 35 USE obs_read_surf ! Reading and allocation of surface obs 36 USE obs_sstbias ! Bias correction routine for SST 37 USE obs_readmdt ! Reading and allocation of MDT for SLA. 38 USE obs_prep ! Preparation of obs. (grid search etc). 39 USE obs_oper ! Observation operators 40 USE obs_write ! Writing of observation related diagnostics 41 USE obs_grid ! Grid searching 42 USE obs_read_altbias ! Bias treatment for altimeter 43 USE obs_profiles_def ! Profile data definitions 44 USE obs_surf_def ! Surface data definitions 45 USE obs_types ! Definitions for observation types 35 USE obs_read_prof ! Reading and allocation of profile obs 36 USE obs_read_surf ! Reading and allocation of surface obs 37 USE obs_bias ! Bias correction routine 38 USE obs_readmdt ! Reading and allocation of MDT for SLA. 39 USE obs_readsnowdepth ! Get model snow depth for conversion of freeboard to ice thickness 40 USE obs_prep ! Preparation of obs. (grid search etc). 41 USE obs_oper ! Observation operators 42 USE obs_write ! Writing of observation related diagnostics 43 USE obs_grid ! Grid searching 44 USE obs_read_altbias ! Bias treatment for altimeter 45 USE obs_profiles_def ! Profile data definitions 46 USE obs_surf_def ! Surface data definitions 47 USE obs_types ! Definitions for observation types 48 USE obs_group_def ! Definitions for observation groups 46 49 ! 47 USE mpp_map ! MPP mapping48 USE lib_mpp ! For ctl_warn/stop50 USE mpp_map ! MPP mapping 51 USE lib_mpp ! For ctl_warn/stop 49 52 50 53 IMPLICIT NONE … … 54 57 PUBLIC dia_obs ! Compute model equivalent to observations 55 58 PUBLIC dia_obs_wri ! Write model equivalent to observations 56 PUBLIC dia_obs_dealloc ! Deallocate dia_obs data57 59 PUBLIC calc_date ! Compute the date of a timestep 58 60 59 LOGICAL, PUBLIC :: ln_diaobs !: Logical switch for the obs operator 60 LOGICAL :: ln_sstnight ! Logical switch for night mean SST obs 61 LOGICAL :: ln_sla_fp_indegs ! T=> SLA obs footprint size specified in degrees, F=> in metres 62 LOGICAL :: ln_sst_fp_indegs ! T=> SST obs footprint size specified in degrees, F=> in metres 63 LOGICAL :: ln_sss_fp_indegs ! T=> SSS obs footprint size specified in degrees, F=> in metres 64 LOGICAL :: ln_sic_fp_indegs ! T=> sea-ice obs footprint size specified in degrees, F=> in metres 65 66 REAL(wp) :: rn_sla_avglamscl ! E/W diameter of SLA observation footprint (metres) 67 REAL(wp) :: rn_sla_avgphiscl ! N/S diameter of SLA observation footprint (metres) 68 REAL(wp) :: rn_sst_avglamscl ! E/W diameter of SST observation footprint (metres) 69 REAL(wp) :: rn_sst_avgphiscl ! N/S diameter of SST observation footprint (metres) 70 REAL(wp) :: rn_sss_avglamscl ! E/W diameter of SSS observation footprint (metres) 71 REAL(wp) :: rn_sss_avgphiscl ! N/S diameter of SSS observation footprint (metres) 72 REAL(wp) :: rn_sic_avglamscl ! E/W diameter of sea-ice observation footprint (metres) 73 REAL(wp) :: rn_sic_avgphiscl ! N/S diameter of sea-ice observation footprint (metres) 74 75 INTEGER :: nn_1dint ! Vertical interpolation method 76 INTEGER :: nn_2dint ! Default horizontal interpolation method 77 INTEGER :: nn_2dint_sla ! SLA horizontal interpolation method 78 INTEGER :: nn_2dint_sst ! SST horizontal interpolation method 79 INTEGER :: nn_2dint_sss ! SSS horizontal interpolation method 80 INTEGER :: nn_2dint_sic ! Seaice horizontal interpolation method 81 INTEGER, DIMENSION(imaxavtypes) :: nn_profdavtypes ! Profile data types representing a daily average 82 INTEGER :: nproftypes ! Number of profile obs types 83 INTEGER :: nsurftypes ! Number of surface obs types 84 INTEGER , DIMENSION(:), ALLOCATABLE :: nvarsprof, nvarssurf ! Number of profile & surface variables 85 INTEGER , DIMENSION(:), ALLOCATABLE :: nextrprof, nextrsurf ! Number of profile & surface extra variables 86 INTEGER , DIMENSION(:), ALLOCATABLE :: n2dintsurf ! Interpolation option for surface variables 87 REAL(wp), DIMENSION(:), ALLOCATABLE :: zavglamscl, zavgphiscl ! E/W & N/S diameter of averaging footprint for surface variables 88 LOGICAL , DIMENSION(:), ALLOCATABLE :: lfpindegs ! T=> surface obs footprint size specified in degrees, F=> in metres 89 LOGICAL , DIMENSION(:), ALLOCATABLE :: llnightav ! Logical for calculating night-time averages 90 91 TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) :: surfdata !: Initial surface data 92 TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) :: surfdataqc !: Surface data after quality control 93 TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: profdata !: Initial profile data 94 TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: profdataqc !: Profile data after quality control 95 96 CHARACTER(len=6), PUBLIC, DIMENSION(:), ALLOCATABLE :: cobstypesprof, cobstypessurf !: Profile & surface obs types 61 LOGICAL, PUBLIC :: ln_diaobs !: Logical switch for the obs operator 62 63 INTEGER :: nn_obsgroups 64 65 TYPE(obs_group), DIMENSION(:), ALLOCATABLE :: sobsgroups ! Obs groups 97 66 98 67 !!---------------------------------------------------------------------- … … 114 83 !! 115 84 !!---------------------------------------------------------------------- 116 INTEGER, PARAMETER :: jpmaxnfiles = 1000 ! Maximum number of files for each obs type 117 INTEGER, DIMENSION(:), ALLOCATABLE :: ifilesprof, ifilessurf ! Number of profile & surface files 85 #if defined key_si3 86 USE ice, ONLY : & ! Sea ice variables 87 & hm_s ! Snow depth for freeboard conversion 88 #elif defined key_cice 89 USE sbc_oce, ONLY : & ! Sea ice variables 90 & thick_s ! Snow depth for freeboard conversion 91 #endif 92 USE obs_fbm, ONLY : & 93 & fbrmdi ! Real missing data indicator 94 95 IMPLICIT NONE 96 97 INTEGER, PARAMETER :: jpmaxngroups = 1000 ! Maximum number of obs groups 118 98 INTEGER :: ios ! Local integer output status for namelist read 119 99 INTEGER :: jtype ! Counter for obs types 120 100 INTEGER :: jvar ! Counter for variables 121 101 INTEGER :: jfile ! Counter for files 122 INTEGER :: jnumsstbias 102 INTEGER :: jenabled 103 INTEGER :: jgroup 123 104 ! 124 CHARACTER(len=128), DIMENSION(jpmaxnfiles) :: & 125 & cn_profbfiles, & ! T/S profile input filenames 126 & cn_sstfbfiles, & ! Sea surface temperature input filenames 127 & cn_sssfbfiles, & ! Sea surface salinity input filenames 128 & cn_slafbfiles, & ! Sea level anomaly input filenames 129 & cn_sicfbfiles, & ! Seaice concentration input filenames 130 & cn_velfbfiles, & ! Velocity profile input filenames 131 & cn_sstbiasfiles ! SST bias input filenames 132 CHARACTER(LEN=128) :: & 133 & cn_altbiasfile ! Altimeter bias input filename 134 CHARACTER(len=128), DIMENSION(:,:), ALLOCATABLE :: & 135 & clproffiles, & ! Profile filenames 136 & clsurffiles ! Surface filenames 137 ! 138 LOGICAL :: ln_t3d ! Logical switch for temperature profiles 139 LOGICAL :: ln_s3d ! Logical switch for salinity profiles 140 LOGICAL :: ln_sla ! Logical switch for sea level anomalies 141 LOGICAL :: ln_sst ! Logical switch for sea surface temperature 142 LOGICAL :: ln_sss ! Logical switch for sea surface salinity 143 LOGICAL :: ln_sic ! Logical switch for sea ice concentration 144 LOGICAL :: ln_vel3d ! Logical switch for velocity (u,v) obs 145 LOGICAL :: ln_nea ! Logical switch to remove obs near land 146 LOGICAL :: ln_altbias ! Logical switch for altimeter bias 147 LOGICAL :: ln_sstbias ! Logical switch for bias corection of SST 148 LOGICAL :: ln_ignmis ! Logical switch for ignoring missing files 149 LOGICAL :: ln_s_at_t ! Logical switch to compute model S at T obs 150 LOGICAL :: ln_bound_reject ! Logical to remove obs near boundaries in LAMs. 151 LOGICAL :: llvar1 ! Logical for profile variable 1 152 LOGICAL :: llvar2 ! Logical for profile variable 1 153 LOGICAL, DIMENSION(jpmaxnfiles) :: lmask ! Used for finding number of sstbias files 105 LOGICAL, DIMENSION(:), ALLOCATABLE :: llvar 154 106 ! 155 REAL(dp) :: rn_dobsini ! Obs window start date YYYYMMDD.HHMMSS 156 REAL(dp) :: rn_dobsend ! Obs window end date YYYYMMDD.HHMMSS 157 REAL(wp), DIMENSION(jpi,jpj) :: zglam1, zglam2 ! Model longitudes for profile variable 1 & 2 158 REAL(wp), DIMENSION(jpi,jpj) :: zgphi1, zgphi2 ! Model latitudes for profile variable 1 & 2 159 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask1, zmask2 ! Model land/sea mask associated with variable 1 & 2 160 !! 161 NAMELIST/namobs/ln_diaobs, ln_t3d, ln_s3d, ln_sla, & 162 & ln_sst, ln_sic, ln_sss, ln_vel3d, & 163 & ln_altbias, ln_sstbias, ln_nea, & 164 & ln_grid_global, ln_grid_search_lookup, & 165 & ln_ignmis, ln_s_at_t, ln_bound_reject, & 166 & ln_sstnight, & 167 & ln_sla_fp_indegs, ln_sst_fp_indegs, & 168 & ln_sss_fp_indegs, ln_sic_fp_indegs, & 169 & cn_profbfiles, cn_slafbfiles, & 170 & cn_sstfbfiles, cn_sicfbfiles, & 171 & cn_velfbfiles, cn_sssfbfiles, & 172 & cn_sstbiasfiles, cn_altbiasfile, & 173 & cn_gridsearchfile, rn_gridsearchres, & 174 & rn_dobsini, rn_dobsend, & 175 & rn_sla_avglamscl, rn_sla_avgphiscl, & 176 & rn_sst_avglamscl, rn_sst_avgphiscl, & 177 & rn_sss_avglamscl, rn_sss_avgphiscl, & 178 & rn_sic_avglamscl, rn_sic_avgphiscl, & 179 & nn_1dint, nn_2dint, & 180 & nn_2dint_sla, nn_2dint_sst, & 181 & nn_2dint_sss, nn_2dint_sic, & 182 & nn_msshc, rn_mdtcorr, rn_mdtcutoff, & 183 & nn_profdavtypes 107 REAL(dp) :: rn_dobsini ! Obs window start date YYYYMMDD.HHMMSS 108 REAL(dp) :: rn_dobsend ! Obs window end date YYYYMMDD.HHMMSS 109 !! 110 NAMELIST/namobs/ln_diaobs, nn_obsgroups, & 111 & ln_grid_global, ln_grid_search_lookup, & 112 & cn_gridsearchfile, rn_gridsearchres, & 113 & rn_dobsini, rn_dobsend 184 114 !----------------------------------------------------------------------- 185 115 … … 187 117 ! Read namelist parameters 188 118 !----------------------------------------------------------------------- 189 ! Some namelist arrays need initialising 190 cn_profbfiles (:) = '' 191 cn_slafbfiles (:) = '' 192 cn_sstfbfiles (:) = '' 193 cn_sicfbfiles (:) = '' 194 cn_velfbfiles (:) = '' 195 cn_sssfbfiles (:) = '' 196 cn_sstbiasfiles(:) = '' 197 nn_profdavtypes(:) = -1 198 119 ! Initialise time window 199 120 CALL ini_date( rn_dobsini ) 200 121 CALL fin_date( rn_dobsend ) … … 220 141 WRITE(numout,*) 'dia_obs_init : Observation diagnostic initialization' 221 142 WRITE(numout,*) '~~~~~~~~~~~~' 222 WRITE(numout,*) ' Namelist namobs : set observation diagnostic parameters' 223 WRITE(numout,*) ' Logical switch for T profile observations ln_t3d = ', ln_t3d 224 WRITE(numout,*) ' Logical switch for S profile observations ln_s3d = ', ln_s3d 225 WRITE(numout,*) ' Logical switch for SLA observations ln_sla = ', ln_sla 226 WRITE(numout,*) ' Logical switch for SST observations ln_sst = ', ln_sst 227 WRITE(numout,*) ' Logical switch for Sea Ice observations ln_sic = ', ln_sic 228 WRITE(numout,*) ' Logical switch for velocity observations ln_vel3d = ', ln_vel3d 229 WRITE(numout,*) ' Logical switch for SSS observations ln_sss = ', ln_sss 143 WRITE(numout,*) ' Namelist namobs : set observation diagnostic parameters' 144 WRITE(numout,*) ' Number of namobs_dta namelists to read nn_obsgroups = ', nn_obsgroups 230 145 WRITE(numout,*) ' Global distribution of observations ln_grid_global = ', ln_grid_global 231 146 WRITE(numout,*) ' Logical switch for obs grid search lookup ln_grid_search_lookup = ', ln_grid_search_lookup 232 IF (ln_grid_search_lookup) &147 IF (ln_grid_search_lookup) THEN 233 148 WRITE(numout,*) ' Grid search lookup file header cn_gridsearchfile = ', cn_gridsearchfile 234 WRITE(numout,*) ' Initial date in window YYYYMMDD.HHMMSS rn_dobsini = ', rn_dobsini 235 WRITE(numout,*) ' Final date in window YYYYMMDD.HHMMSS rn_dobsend = ', rn_dobsend 236 WRITE(numout,*) ' Type of vertical interpolation method nn_1dint = ', nn_1dint 237 WRITE(numout,*) ' Type of horizontal interpolation method nn_2dint = ', nn_2dint 238 WRITE(numout,*) ' Rejection of observations near land switch ln_nea = ', ln_nea 239 WRITE(numout,*) ' Rejection of obs near open bdys ln_bound_reject = ', ln_bound_reject 240 WRITE(numout,*) ' MSSH correction scheme nn_msshc = ', nn_msshc 241 WRITE(numout,*) ' MDT correction rn_mdtcorr = ', rn_mdtcorr 242 WRITE(numout,*) ' MDT cutoff for computed correction rn_mdtcutoff = ', rn_mdtcutoff 243 WRITE(numout,*) ' Logical switch for alt bias ln_altbias = ', ln_altbias 244 WRITE(numout,*) ' Logical switch for sst bias ln_sstbias = ', ln_sstbias 245 WRITE(numout,*) ' Logical switch for ignoring missing files ln_ignmis = ', ln_ignmis 246 WRITE(numout,*) ' Daily average types nn_profdavtypes = ', nn_profdavtypes 247 WRITE(numout,*) ' Logical switch for night-time SST obs ln_sstnight = ', ln_sstnight 149 WRITE(numout,*) ' Grid search resolution rn_gridsearchres = ', rn_gridsearchres 150 ENDIF 248 151 ENDIF 249 !----------------------------------------------------------------------- 250 ! Set up list of observation types to be used 251 ! and the files associated with each type 252 !----------------------------------------------------------------------- 253 254 nproftypes = COUNT( (/ln_t3d .OR. ln_s3d, ln_vel3d /) ) 255 nsurftypes = COUNT( (/ln_sla, ln_sst, ln_sic, ln_sss /) ) 256 257 IF( ln_sstbias ) THEN 258 lmask(:) = .FALSE. 259 WHERE( cn_sstbiasfiles(:) /= '' ) lmask(:) = .TRUE. 260 jnumsstbias = COUNT(lmask) 261 lmask(:) = .FALSE. 262 ENDIF 263 264 IF( nproftypes == 0 .AND. nsurftypes == 0 ) THEN 265 CALL ctl_warn( 'dia_obs_init: ln_diaobs is set to true, but all obs operator logical flags', & 266 & ' (ln_t3d, ln_s3d, ln_sla, ln_sst, ln_sic, ln_vel3d)', & 267 & ' are set to .FALSE. so turning off calls to dia_obs' ) 152 153 IF( ln_grid_global ) THEN 154 CALL ctl_warn( 'dia_obs_init: ln_grid_global=T may cause memory issues when used with a large number of processors' ) 155 ENDIF 156 157 !----------------------------------------------------------------------- 158 ! Read namobs_dta namelists and set up observation groups 159 !----------------------------------------------------------------------- 160 161 IF( nn_obsgroups == 0 ) THEN 162 CALL ctl_warn( 'dia_obs_init: ln_diaobs is set to true, but nn_obsgroups == 0', & 163 & ' so turning off calls to dia_obs' ) 268 164 ln_diaobs = .FALSE. 269 165 RETURN 270 166 ENDIF 271 167 272 IF( nproftypes > 0 ) THEN 273 ! 274 ALLOCATE( cobstypesprof(nproftypes) ) 275 ALLOCATE( ifilesprof (nproftypes) ) 276 ALLOCATE( clproffiles (nproftypes,jpmaxnfiles) ) 277 ! 278 jtype = 0 279 IF( ln_t3d .OR. ln_s3d ) THEN 280 jtype = jtype + 1 281 CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'prof ', & 282 & cn_profbfiles, ifilesprof, cobstypesprof, clproffiles ) 168 ALLOCATE( sobsgroups(nn_obsgroups) ) 169 170 jenabled = 0 171 DO jgroup = 1, nn_obsgroups 172 CALL obs_group_read_namelist( sobsgroups(jgroup) ) 173 CALL obs_group_check( sobsgroups(jgroup), jgroup ) 174 IF (sobsgroups(jgroup)%lenabled) THEN 175 jenabled = jenabled + 1 283 176 ENDIF 284 IF( ln_vel3d ) THEN 285 jtype = jtype + 1 286 CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'vel ', & 287 & cn_velfbfiles, ifilesprof, cobstypesprof, clproffiles ) 288 ENDIF 289 ! 290 ENDIF 291 292 IF( nsurftypes > 0 ) THEN 293 ! 294 ALLOCATE( cobstypessurf(nsurftypes) ) 295 ALLOCATE( ifilessurf (nsurftypes) ) 296 ALLOCATE( clsurffiles (nsurftypes,jpmaxnfiles) ) 297 ALLOCATE( n2dintsurf (nsurftypes) ) 298 ALLOCATE( zavglamscl (nsurftypes) ) 299 ALLOCATE( zavgphiscl (nsurftypes) ) 300 ALLOCATE( lfpindegs (nsurftypes) ) 301 ALLOCATE( llnightav (nsurftypes) ) 302 ! 303 jtype = 0 304 IF( ln_sla ) THEN 305 jtype = jtype + 1 306 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sla ', & 307 & cn_slafbfiles, ifilessurf, cobstypessurf, clsurffiles ) 308 CALL obs_setinterpopts( nsurftypes, jtype, 'sla ', & 309 & nn_2dint, nn_2dint_sla, & 310 & rn_sla_avglamscl, rn_sla_avgphiscl, & 311 & ln_sla_fp_indegs, .FALSE., & 312 & n2dintsurf, zavglamscl, zavgphiscl, & 313 & lfpindegs, llnightav ) 314 ENDIF 315 IF( ln_sst ) THEN 316 jtype = jtype + 1 317 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sst ', & 318 & cn_sstfbfiles, ifilessurf, cobstypessurf, clsurffiles ) 319 CALL obs_setinterpopts( nsurftypes, jtype, 'sst ', & 320 & nn_2dint, nn_2dint_sst, & 321 & rn_sst_avglamscl, rn_sst_avgphiscl, & 322 & ln_sst_fp_indegs, ln_sstnight, & 323 & n2dintsurf, zavglamscl, zavgphiscl, & 324 & lfpindegs, llnightav ) 325 ENDIF 326 #if defined key_si3 || defined key_cice 327 IF( ln_sic ) THEN 328 jtype = jtype + 1 329 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sic ', & 330 & cn_sicfbfiles, ifilessurf, cobstypessurf, clsurffiles ) 331 CALL obs_setinterpopts( nsurftypes, jtype, 'sic ', & 332 & nn_2dint, nn_2dint_sic, & 333 & rn_sic_avglamscl, rn_sic_avgphiscl, & 334 & ln_sic_fp_indegs, .FALSE., & 335 & n2dintsurf, zavglamscl, zavgphiscl, & 336 & lfpindegs, llnightav ) 337 ENDIF 338 #endif 339 IF( ln_sss ) THEN 340 jtype = jtype + 1 341 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sss ', & 342 & cn_sssfbfiles, ifilessurf, cobstypessurf, clsurffiles ) 343 CALL obs_setinterpopts( nsurftypes, jtype, 'sss ', & 344 & nn_2dint, nn_2dint_sss, & 345 & rn_sss_avglamscl, rn_sss_avgphiscl, & 346 & ln_sss_fp_indegs, .FALSE., & 347 & n2dintsurf, zavglamscl, zavgphiscl, & 348 & lfpindegs, llnightav ) 349 ENDIF 350 ! 351 ENDIF 352 353 354 !----------------------------------------------------------------------- 355 ! Obs operator parameter checking and initialisations 356 !----------------------------------------------------------------------- 357 ! 358 IF( ln_vel3d .AND. .NOT.ln_grid_global ) THEN 359 CALL ctl_stop( 'Velocity data only works with ln_grid_global=.true.' ) 177 END DO 178 179 IF( jenabled == 0 ) THEN 180 CALL ctl_warn( 'dia_obs_init: ln_diaobs is set to true, and nn_obsgroups > 0', & 181 & ' but no groups are enabled so turning off calls to dia_obs' ) 182 ln_diaobs = .FALSE. 360 183 RETURN 361 184 ENDIF 362 ! 363 IF( ln_grid_global ) THEN 364 CALL ctl_warn( 'dia_obs_init: ln_grid_global=T may cause memory issues when used with a large number of processors' ) 365 ENDIF 366 ! 367 IF( nn_1dint < 0 .OR. nn_1dint > 1 ) THEN 368 CALL ctl_stop('dia_obs_init: Choice of vertical (1D) interpolation method is not available') 369 ENDIF 370 ! 371 IF( nn_2dint < 0 .OR. nn_2dint > 6 ) THEN 372 CALL ctl_stop('dia_obs_init: Choice of horizontal (2D) interpolation method is not available') 373 ENDIF 185 186 !----------------------------------------------------------------------- 187 ! Obs operator parameter checking and initialisations 188 !----------------------------------------------------------------------- 374 189 ! 375 190 CALL obs_typ_init … … 382 197 !----------------------------------------------------------------------- 383 198 ! 384 IF( nproftypes > 0 ) THEN 385 ! 386 ALLOCATE( profdata (nproftypes) , nvarsprof (nproftypes) ) 387 ALLOCATE( profdataqc(nproftypes) , nextrprof (nproftypes) ) 388 ! 389 DO jtype = 1, nproftypes 390 ! 391 nvarsprof(jtype) = 2 392 IF ( TRIM(cobstypesprof(jtype)) == 'prof' ) THEN 393 nextrprof(jtype) = 1 394 llvar1 = ln_t3d 395 llvar2 = ln_s3d 396 zglam1 = glamt 397 zgphi1 = gphit 398 zmask1 = tmask 399 zglam2 = glamt 400 zgphi2 = gphit 401 zmask2 = tmask 199 DO jgroup = 1, nn_obsgroups 200 IF ( sobsgroups(jgroup)%lenabled ) THEN 201 IF ( sobsgroups(jgroup)%lprof ) THEN 202 ! 203 ! Read in profile or profile obs types 204 ! 205 ALLOCATE( llvar(sobsgroups(jgroup)%nobstypes) ) 206 llvar(:) = .TRUE. 207 ! 208 CALL obs_rea_prof( sobsgroups(jgroup)%sprofdata, & 209 & sobsgroups(jgroup)%nobsfiles, & 210 & sobsgroups(jgroup)%cobsfiles, & 211 & sobsgroups(jgroup)%nobstypes, & 212 & sobsgroups(jgroup)%naddvars, & 213 & sobsgroups(jgroup)%nextvars, & 214 & nitend-nit000+2, & 215 & rn_dobsini, & 216 & rn_dobsend, & 217 & llvar, & 218 & sobsgroups(jgroup)%lignmis, & 219 & sobsgroups(jgroup)%lall_at_all, & 220 & .FALSE., & 221 & sobsgroups(jgroup)%cobstypes, & 222 & kdailyavtypes = sobsgroups(jgroup)%nprofdavtypes ) 223 ! 224 DO jvar = 1, sobsgroups(jgroup)%nobstypes 225 CALL obs_prof_staend( sobsgroups(jgroup)%sprofdata, jvar ) 226 END DO 227 ! 228 IF ( sobsgroups(jgroup)%sprofdata%next > 0 ) THEN 229 CALL obs_prof_staend_ext( sobsgroups(jgroup)%sprofdata ) 230 ENDIF 231 ! 232 IF( sobsgroups(jgroup)%loutput_clim ) THEN 233 sobsgroups(jgroup)%sprofdata%caddvars(sobsgroups(jgroup)%nadd_clm) = 'CLM' 234 DO jvar = 1, sobsgroups(jgroup)%nobstypes 235 sobsgroups(jgroup)%sprofdata%var(jvar)%vadd(:,sobsgroups(jgroup)%nadd_clm) = fbrmdi 236 sobsgroups(jgroup)%sprofdata%caddlong(sobsgroups(jgroup)%nadd_clm,jvar) = 'Climatology' 237 sobsgroups(jgroup)%sprofdata%caddunit(sobsgroups(jgroup)%nadd_clm,jvar) = sobsgroups(jgroup)%sprofdata%cunit(jvar) 238 END DO 239 ENDIF 240 ! 241 sobsgroups(jgroup)%sprofdata%cgrid = sobsgroups(jgroup)%cgrid 242 ! 243 CALL obs_pre_prof( sobsgroups(jgroup)%sprofdata, & 244 & sobsgroups(jgroup)%sprofdataqc, & 245 & llvar, & 246 & jpi, jpj, jpk, & 247 & sobsgroups(jgroup)%rmask, & 248 & sobsgroups(jgroup)%rglam, & 249 & sobsgroups(jgroup)%rgphi, & 250 & sobsgroups(jgroup)%lnea, & 251 & sobsgroups(jgroup)%lbound_reject, & 252 & kdailyavtypes = sobsgroups(jgroup)%nprofdavtypes ) 253 ! 254 DEALLOCATE( llvar ) 255 ! 256 ELSEIF (sobsgroups(jgroup)%lsurf) THEN 257 ! 258 ! Read in surface obs types 259 ! 260 CALL obs_rea_surf( sobsgroups(jgroup)%ssurfdata, & 261 & sobsgroups(jgroup)%nobsfiles, & 262 & sobsgroups(jgroup)%cobsfiles, & 263 & sobsgroups(jgroup)%nobstypes, & 264 & sobsgroups(jgroup)%naddvars, & 265 & sobsgroups(jgroup)%nextvars, & 266 & nitend-nit000+2, & 267 & rn_dobsini, & 268 & rn_dobsend, & 269 & sobsgroups(jgroup)%rtime_mean_period, & 270 & sobsgroups(jgroup)%ltime_mean_bkg, & 271 & sobsgroups(jgroup)%lignmis, & 272 & .FALSE., & 273 & sobsgroups(jgroup)%lnight, & 274 & sobsgroups(jgroup)%cobstypes ) 275 ! 276 IF( sobsgroups(jgroup)%lsla ) THEN 277 sobsgroups(jgroup)%ssurfdata%cextvars(sobsgroups(jgroup)%next_mdt) = 'MDT' 278 sobsgroups(jgroup)%ssurfdata%cextlong(sobsgroups(jgroup)%next_mdt) = 'Mean dynamic topography' 279 sobsgroups(jgroup)%ssurfdata%cextunit(sobsgroups(jgroup)%next_mdt) = 'Metres' 280 sobsgroups(jgroup)%ssurfdata%caddvars(sobsgroups(jgroup)%nadd_ssh) = 'SSH' 281 DO jvar = 1, sobsgroups(jgroup)%nobstypes 282 sobsgroups(jgroup)%ssurfdata%caddlong(sobsgroups(jgroup)%nadd_ssh,jvar) = 'Model Sea surface height' 283 sobsgroups(jgroup)%ssurfdata%caddunit(sobsgroups(jgroup)%nadd_ssh,jvar) = 'Metres' 284 END DO 285 ENDIF 286 ! 287 IF( sobsgroups(jgroup)%lfbd ) THEN 288 sobsgroups(jgroup)%ssurfdata%cextvars(sobsgroups(jgroup)%next_snow) = 'SNOW' 289 sobsgroups(jgroup)%ssurfdata%cextlong(sobsgroups(jgroup)%next_snow) = 'Snow thickness' 290 sobsgroups(jgroup)%ssurfdata%cextunit(sobsgroups(jgroup)%next_snow) = 'Metres' 291 sobsgroups(jgroup)%ssurfdata%caddvars(sobsgroups(jgroup)%nadd_fbd) = 'FBD' 292 DO jvar = 1, sobsgroups(jgroup)%nobstypes 293 sobsgroups(jgroup)%ssurfdata%caddlong(sobsgroups(jgroup)%nadd_fbd,jvar) = 'Freeboard' 294 sobsgroups(jgroup)%ssurfdata%caddunit(sobsgroups(jgroup)%nadd_fbd,jvar) = 'Metres' 295 END DO 296 ENDIF 297 ! 298 IF( sobsgroups(jgroup)%loutput_clim ) THEN 299 sobsgroups(jgroup)%ssurfdata%caddvars(sobsgroups(jgroup)%nadd_clm) = 'CLM' 300 DO jvar = 1, sobsgroups(jgroup)%nobstypes 301 sobsgroups(jgroup)%ssurfdata%radd(:,:,jvar) = fbrmdi 302 sobsgroups(jgroup)%ssurfdata%caddlong(sobsgroups(jgroup)%nadd_clm,jvar) = 'Climatology' 303 sobsgroups(jgroup)%ssurfdata%caddunit(sobsgroups(jgroup)%nadd_clm,jvar) = sobsgroups(jgroup)%ssurfdata%cunit(jvar) 304 END DO 305 ENDIF 306 ! 307 sobsgroups(jgroup)%ssurfdata%cgrid = sobsgroups(jgroup)%cgrid 308 ! 309 CALL obs_pre_surf( sobsgroups(jgroup)%ssurfdata, & 310 & sobsgroups(jgroup)%ssurfdataqc, & 311 & jpi, jpj, & 312 & sobsgroups(jgroup)%rmask(:,:,1,:), & 313 & sobsgroups(jgroup)%rglam, & 314 & sobsgroups(jgroup)%rgphi, & 315 & sobsgroups(jgroup)%lnea, & 316 & sobsgroups(jgroup)%lbound_reject ) 317 ! 318 IF( sobsgroups(jgroup)%lsla ) THEN 319 CALL obs_rea_mdt( sobsgroups(jgroup)%ssurfdataqc, & 320 & sobsgroups(jgroup)%n2dint, & 321 & sobsgroups(jgroup)%next_mdt, & 322 & sobsgroups(jgroup)%nmsshc, & 323 & sobsgroups(jgroup)%rmdtcorr, & 324 & sobsgroups(jgroup)%rmdtcutoff ) 325 IF( sobsgroups(jgroup)%laltbias ) THEN 326 CALL obs_app_bias( sobsgroups(jgroup)%ssurfdataqc, & 327 & sobsgroups(jgroup)%next_mdt, & 328 & sobsgroups(jgroup)%n2dint, & 329 & 1, & 330 & sobsgroups(jgroup)%caltbiasfile, & 331 & 'altbias', & 332 & ld_extvar=.TRUE. ) 333 ENDIF 334 ENDIF 335 ! 336 #if defined key_si3 337 IF( sobsgroups(jgroup)%lfbd ) THEN 338 CALL obs_rea_snowdepth( sobsgroups(jgroup)%ssurfdataqc, & 339 & sobsgroups(jgroup)%n2dint, & 340 & sobsgroups(jgroup)%next_snow, & 341 & hm_s(:,:) ) 342 ENDIF 343 #elif defined key_cice 344 IF( sobsgroups(jgroup)%lfbd ) THEN 345 CALL obs_rea_snowdepth( sobsgroups(jgroup)%ssurfdataqc, & 346 & sobsgroups(jgroup)%n2dint, & 347 & sobsgroups(jgroup)%next_snow, & 348 & thick_s(:,:) ) 349 ENDIF 350 #endif 351 ! 352 IF( sobsgroups(jgroup)%lobsbias ) THEN 353 CALL obs_app_bias( sobsgroups(jgroup)%ssurfdataqc, & 354 & sobsgroups(jgroup)%nbiasvar, & 355 & sobsgroups(jgroup)%n2dint, & 356 & sobsgroups(jgroup)%nobsbiasfiles, & 357 & sobsgroups(jgroup)%cobsbiasfiles, & 358 & sobsgroups(jgroup)%cbiasvarname ) 359 ENDIF 360 ! 402 361 ENDIF 403 IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN 404 nextrprof(jtype) = 2 405 llvar1 = ln_vel3d 406 llvar2 = ln_vel3d 407 zglam1 = glamu 408 zgphi1 = gphiu 409 zmask1 = umask 410 zglam2 = glamv 411 zgphi2 = gphiv 412 zmask2 = vmask 413 ENDIF 414 ! 415 ! Read in profile or profile obs types 416 CALL obs_rea_prof( profdata(jtype), ifilesprof(jtype), & 417 & clproffiles(jtype,1:ifilesprof(jtype)), & 418 & nvarsprof(jtype), nextrprof(jtype), nitend-nit000+2, & 419 & rn_dobsini, rn_dobsend, llvar1, llvar2, & 420 & ln_ignmis, ln_s_at_t, .FALSE., & 421 & kdailyavtypes = nn_profdavtypes ) 422 ! 423 DO jvar = 1, nvarsprof(jtype) 424 CALL obs_prof_staend( profdata(jtype), jvar ) 425 END DO 426 ! 427 CALL obs_pre_prof( profdata(jtype), profdataqc(jtype), & 428 & llvar1, llvar2, & 429 & jpi, jpj, jpk, & 430 & zmask1, zglam1, zgphi1, zmask2, zglam2, zgphi2, & 431 & ln_nea, ln_bound_reject, & 432 & kdailyavtypes = nn_profdavtypes ) 433 END DO 434 ! 435 DEALLOCATE( ifilesprof, clproffiles ) 436 ! 437 ENDIF 438 ! 439 IF( nsurftypes > 0 ) THEN 440 ! 441 ALLOCATE( surfdata (nsurftypes) , nvarssurf(nsurftypes) ) 442 ALLOCATE( surfdataqc(nsurftypes) , nextrsurf(nsurftypes) ) 443 ! 444 DO jtype = 1, nsurftypes 445 ! 446 nvarssurf(jtype) = 1 447 nextrsurf(jtype) = 0 448 llnightav(jtype) = .FALSE. 449 IF( TRIM(cobstypessurf(jtype)) == 'sla' ) nextrsurf(jtype) = 2 450 IF( TRIM(cobstypessurf(jtype)) == 'sst' ) llnightav(jtype) = ln_sstnight 451 ! 452 ! Read in surface obs types 453 CALL obs_rea_surf( surfdata(jtype), ifilessurf(jtype), & 454 & clsurffiles(jtype,1:ifilessurf(jtype)), & 455 & nvarssurf(jtype), nextrsurf(jtype), nitend-nit000+2, & 456 & rn_dobsini, rn_dobsend, ln_ignmis, .FALSE., llnightav(jtype) ) 457 ! 458 CALL obs_pre_surf( surfdata(jtype), surfdataqc(jtype), ln_nea, ln_bound_reject ) 459 ! 460 IF( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN 461 CALL obs_rea_mdt( surfdataqc(jtype), n2dintsurf(jtype) ) 462 IF( ln_altbias ) & 463 & CALL obs_rea_altbias ( surfdataqc(jtype), n2dintsurf(jtype), cn_altbiasfile ) 464 ENDIF 465 ! 466 IF( TRIM(cobstypessurf(jtype)) == 'sst' .AND. ln_sstbias ) THEN 467 jnumsstbias = 0 468 DO jfile = 1, jpmaxnfiles 469 IF( TRIM(cn_sstbiasfiles(jfile)) /= '' ) jnumsstbias = jnumsstbias + 1 470 END DO 471 IF( jnumsstbias == 0 ) CALL ctl_stop("ln_sstbias set but no bias files to read in") 472 ! 473 CALL obs_app_sstbias( surfdataqc(jtype), n2dintsurf(jtype) , & 474 & jnumsstbias , cn_sstbiasfiles(1:jnumsstbias) ) 475 ENDIF 476 END DO 477 ! 478 DEALLOCATE( ifilessurf, clsurffiles ) 479 ! 480 ENDIF 362 ENDIF 363 END DO 481 364 ! 482 365 END SUBROUTINE dia_obs_init … … 500 383 USE oce , ONLY : tsn, un, vn, sshn ! Ocean dynamics and tracers variables 501 384 USE phycst , ONLY : rday ! Physical constants 502 #if defined key_si3 503 USE ice , ONLY : at_i ! SI3 Ice model variables 385 #if defined key_si3 386 USE ice , ONLY : at_i, hm_i ! SI3 Ice model variables 387 #elif defined key_cice 388 USE sbc_oce, ONLY : fr_i, thick_i ! CICE Ice model variables 504 389 #endif 505 #if defined key_cice 506 USE sbc_oce, ONLY : fr_i ! ice fraction 507 #endif 390 USE tradmp, ONLY : tclim, sclim ! T&S climatology 391 USE obs_fbm, ONLY : fbrmdi ! Real missing data indicator 508 392 509 393 IMPLICIT NONE … … 513 397 !! * Local declarations 514 398 INTEGER :: idaystp ! Number of timesteps per day 399 INTEGER :: imeanstp ! Number of timesteps for time averaging 515 400 INTEGER :: jtype ! Data loop variable 516 401 INTEGER :: jvar ! Variable number 517 INTEGER :: ji, jj ! Loop counters 518 REAL(wp), DIMENSION(jpi,jpj,jpk) :: & 519 & zprofvar1, & ! Model values for 1st variable in a prof ob 520 & zprofvar2 ! Model values for 2nd variable in a prof ob 521 REAL(wp), DIMENSION(jpi,jpj,jpk) :: & 522 & zprofmask1, & ! Mask associated with zprofvar1 523 & zprofmask2 ! Mask associated with zprofvar2 524 REAL(wp), DIMENSION(jpi,jpj) :: & 525 & zsurfvar, & ! Model values equivalent to surface ob. 526 & zsurfmask ! Mask associated with surface variable 527 REAL(wp), DIMENSION(jpi,jpj) :: & 528 & zglam1, & ! Model longitudes for prof variable 1 529 & zglam2, & ! Model longitudes for prof variable 2 530 & zgphi1, & ! Model latitudes for prof variable 1 531 & zgphi2 ! Model latitudes for prof variable 2 532 533 !----------------------------------------------------------------------- 402 INTEGER :: jgroup 403 INTEGER :: ji, jj, jobs ! Loop counters 404 LOGICAL :: lstp0 ! Flag special treatment on zeroth time step 405 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 406 & zprofvar, & ! Model values for variables in a prof ob 407 & zprofclim ! Climatology values for variables in a prof ob 408 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: & 409 & zsurfvar, & ! Model values for variables in a surf ob 410 & zsurfclim ! Climatology values for variables in a surf ob 411 412 !----------------------------------------------------------------------- 413 414 IF( ln_timing ) CALL timing_start('dia_obs') 534 415 535 416 IF(lwp) THEN … … 545 426 !----------------------------------------------------------------------- 546 427 547 IF ( nproftypes > 0 ) THEN 548 549 DO jtype = 1, nproftypes 550 551 SELECT CASE ( TRIM(cobstypesprof(jtype)) ) 552 CASE('prof') 553 zprofvar1(:,:,:) = tsn(:,:,:,jp_tem) 554 zprofvar2(:,:,:) = tsn(:,:,:,jp_sal) 555 zprofmask1(:,:,:) = tmask(:,:,:) 556 zprofmask2(:,:,:) = tmask(:,:,:) 557 zglam1(:,:) = glamt(:,:) 558 zglam2(:,:) = glamt(:,:) 559 zgphi1(:,:) = gphit(:,:) 560 zgphi2(:,:) = gphit(:,:) 561 CASE('vel') 562 zprofvar1(:,:,:) = un(:,:,:) 563 zprofvar2(:,:,:) = vn(:,:,:) 564 zprofmask1(:,:,:) = umask(:,:,:) 565 zprofmask2(:,:,:) = vmask(:,:,:) 566 zglam1(:,:) = glamu(:,:) 567 zglam2(:,:) = glamv(:,:) 568 zgphi1(:,:) = gphiu(:,:) 569 zgphi2(:,:) = gphiv(:,:) 570 CASE DEFAULT 571 CALL ctl_stop( 'Unknown profile observation type '//TRIM(cobstypesprof(jtype))//' in dia_obs' ) 572 END SELECT 573 574 CALL obs_prof_opt( profdataqc(jtype), kstp, jpi, jpj, jpk, & 575 & nit000, idaystp, & 576 & zprofvar1, zprofvar2, & 577 & gdept_n(:,:,:), gdepw_n(:,:,:), & 578 & zprofmask1, zprofmask2, & 579 & zglam1, zglam2, zgphi1, zgphi2, & 580 & nn_1dint, nn_2dint, & 581 & kdailyavtypes = nn_profdavtypes ) 582 583 END DO 584 585 ENDIF 586 587 IF ( nsurftypes > 0 ) THEN 588 589 DO jtype = 1, nsurftypes 590 591 !Defaults which might be changed 592 zsurfmask(:,:) = tmask(:,:,1) 593 594 SELECT CASE ( TRIM(cobstypessurf(jtype)) ) 595 CASE('sst') 596 zsurfvar(:,:) = tsn(:,:,1,jp_tem) 597 CASE('sla') 598 zsurfvar(:,:) = sshn(:,:) 599 CASE('sss') 600 zsurfvar(:,:) = tsn(:,:,1,jp_sal) 601 CASE('sic') 602 IF ( kstp == 0 ) THEN 603 IF ( lwp .AND. surfdataqc(jtype)%nsstpmpp(1) > 0 ) THEN 604 CALL ctl_warn( 'Sea-ice not initialised on zeroth '// & 605 & 'time-step but some obs are valid then.' ) 606 WRITE(numout,*)surfdataqc(jtype)%nsstpmpp(1), & 607 & ' sea-ice obs will be missed' 428 ALLOCATE( zprofvar(jpi,jpj,jpk), & 429 & zprofclim(jpi,jpj,jpk), & 430 & zsurfvar(jpi,jpj), & 431 & zsurfclim(jpi,jpj) ) 432 433 DO jgroup = 1, nn_obsgroups 434 IF ( sobsgroups(jgroup)%lenabled ) THEN 435 436 IF ( sobsgroups(jgroup)%lprof ) THEN 437 438 zprofclim(:,:,:) = fbrmdi 439 440 DO jvar = 1, sobsgroups(jgroup)%nobstypes 441 442 SELECT CASE ( TRIM(sobsgroups(jgroup)%cobstypes(jvar)) ) 443 CASE('POTM') 444 zprofvar(:,:,:) = tsn(:,:,:,jp_tem) 445 IF (sobsgroups(jgroup)%loutput_clim) THEN 446 zprofclim(:,:,:) = tclim(:,:,:) 447 ENDIF 448 CASE('PSAL') 449 zprofvar(:,:,:) = tsn(:,:,:,jp_sal) 450 IF (sobsgroups(jgroup)%loutput_clim) THEN 451 zprofclim(:,:,:) = sclim(:,:,:) 452 ENDIF 453 CASE('UVEL') 454 zprofvar(:,:,:) = un(:,:,:) 455 CASE('VVEL') 456 zprofvar(:,:,:) = vn(:,:,:) 457 CASE DEFAULT 458 CALL ctl_stop( 'Unknown profile observation type '//TRIM(sobsgroups(jgroup)%cobstypes(jvar))//' in dia_obs' ) 459 END SELECT 460 461 CALL obs_prof_opt( sobsgroups(jgroup)%sprofdataqc, & 462 & kstp, jpi, jpj, jpk, & 463 & nit000, idaystp, jvar, & 464 & zprofvar, & 465 & sobsgroups(jgroup)%loutput_clim, & 466 & sobsgroups(jgroup)%nadd_clm, & 467 & zprofclim, & 468 & gdept_n, & 469 & gdepw_n, & 470 & sobsgroups(jgroup)%rmask(:,:,:,jvar), & 471 & sobsgroups(jgroup)%rglam(:,:,jvar), & 472 & sobsgroups(jgroup)%rgphi(:,:,jvar), & 473 & sobsgroups(jgroup)%n1dint, & 474 & sobsgroups(jgroup)%n2dint, & 475 & kdailyavtypes = sobsgroups(jgroup)%nprofdavtypes ) 476 477 END DO 478 479 ELSEIF (sobsgroups(jgroup)%lsurf) THEN 480 481 zsurfclim(:,:) = fbrmdi 482 483 DO jvar = 1, sobsgroups(jgroup)%nobstypes 484 485 lstp0 = .FALSE. 486 SELECT CASE ( TRIM(sobsgroups(jgroup)%cobstypes(jvar)) ) 487 CASE('SST') 488 zsurfvar(:,:) = tsn(:,:,1,jp_tem) 489 IF (sobsgroups(jgroup)%loutput_clim) THEN 490 zsurfclim(:,:) = tclim(:,:,1) 491 ENDIF 492 CASE('SLA') 493 zsurfvar(:,:) = sshn(:,:) 494 CASE('SSS') 495 zsurfvar(:,:) = tsn(:,:,1,jp_sal) 496 IF (sobsgroups(jgroup)%loutput_clim) THEN 497 zsurfclim(:,:) = sclim(:,:,1) 498 ENDIF 499 CASE('UVEL') 500 zsurfvar(:,:) = un(:,:,1) 501 CASE('VVEL') 502 zsurfvar(:,:) = vn(:,:,1) 503 CASE('ICECONC') 504 IF ( kstp == 0 ) THEN 505 lstp0 = .TRUE. 506 ELSE 507 #if defined key_si3 508 zsurfvar(:,:) = at_i(:,:) 509 #elif defined key_cice 510 zsurfvar(:,:) = fr_i(:,:) 511 #else 512 CALL ctl_stop( ' Trying to run sea-ice observation operator', & 513 & ' but no sea-ice model appears to have been defined' ) 514 #endif 515 ENDIF 516 CASE('SIT','FBD') 517 IF ( kstp == 0 ) THEN 518 lstp0 = .TRUE. 519 ELSE 520 #if defined key_si3 521 zsurfvar(:,:) = hm_i(:,:) 522 #elif defined key_cice 523 zsurfvar(:,:) = thick_i(:,:) 524 #else 525 CALL ctl_stop( ' Trying to run sea-ice observation operator', & 526 & ' but no sea-ice model appears to have been defined' ) 527 #endif 528 ENDIF 529 END SELECT 530 531 IF ( lstp0 ) THEN 532 IF ( sobsgroups(jgroup)%ssurfdataqc%nsstpmpp(1) > 0 ) THEN 533 DO jobs = sobsgroups(jgroup)%ssurfdataqc%nsurfup + 1, & 534 & sobsgroups(jgroup)%ssurfdataqc%nsurfup + sobsgroups(jgroup)%ssurfdataqc%nsstp(1) 535 sobsgroups(jgroup)%ssurfdata%nqc(jobs) = IBSET(sobsgroups(jgroup)%ssurfdata%nqc(jobs),13) 536 END DO 537 IF ( lwp ) THEN 538 CALL ctl_warn( TRIM(sobsgroups(jgroup)%cobstypes(jvar))// & 539 & ' not initialised on zeroth ' // & 540 & 'time-step but some obs are valid then.' ) 541 WRITE(numout,*)sobsgroups(jgroup)%ssurfdataqc%nsstpmpp(1), & 542 & TRIM(sobsgroups(jgroup)%cobstypes(jvar)), & 543 & 'observations will be flagged as bad' 544 ENDIF 545 ENDIF 546 IF ( jvar == sobsgroups(jgroup)%ssurfdataqc%nvar ) THEN 547 sobsgroups(jgroup)%ssurfdataqc%nsurfup = sobsgroups(jgroup)%ssurfdataqc%nsurfup + & 548 & sobsgroups(jgroup)%ssurfdataqc%nsstp(1) 549 ENDIF 550 ELSE 551 IF ( sobsgroups(jgroup)%ltime_mean_bkg ) THEN 552 ! Number of time-steps in meaning period 553 imeanstp = NINT( ( sobsgroups(jgroup)%rtime_mean_period * 60.0 * 60.0 ) / rdt ) 554 ENDIF 555 CALL obs_surf_opt( sobsgroups(jgroup)%ssurfdataqc, & 556 & kstp, jpi, jpj, & 557 & nit000, idaystp, & 558 & jvar, zsurfvar, & 559 & sobsgroups(jgroup)%loutput_clim, & 560 & sobsgroups(jgroup)%nadd_clm, & 561 & zsurfclim, & 562 & sobsgroups(jgroup)%rmask(:,:,1,jvar), & 563 & sobsgroups(jgroup)%n2dint, & 564 & sobsgroups(jgroup)%lnight, & 565 & sobsgroups(jgroup)%ravglamscl, & 566 & sobsgroups(jgroup)%ravgphiscl, & 567 & sobsgroups(jgroup)%lfp_indegs, & 568 & sobsgroups(jgroup)%ltime_mean_bkg, & 569 & imeanstp, & 570 & kssh=sobsgroups(jgroup)%nadd_ssh, & 571 & kmdt=sobsgroups(jgroup)%next_mdt, & 572 & kfbd=sobsgroups(jgroup)%nadd_fbd, & 573 & ksnow=sobsgroups(jgroup)%next_snow ) 608 574 ENDIF 609 surfdataqc(jtype)%nsurfup = surfdataqc(jtype)%nsurfup + & 610 & surfdataqc(jtype)%nsstp(1) 611 CYCLE 612 ELSE 613 #if defined key_cice || defined key_si3 614 zsurfvar(:,:) = fr_i(:,:) 615 #else 616 CALL ctl_stop( ' Trying to run sea-ice observation operator', & 617 & ' but no sea-ice model appears to have been defined' ) 618 #endif 619 ENDIF 620 621 END SELECT 622 623 CALL obs_surf_opt( surfdataqc(jtype), kstp, jpi, jpj, & 624 & nit000, idaystp, zsurfvar, zsurfmask, & 625 & n2dintsurf(jtype), llnightav(jtype), & 626 & zavglamscl(jtype), zavgphiscl(jtype), & 627 & lfpindegs(jtype) ) 628 629 END DO 630 631 ENDIF 575 576 END DO 577 578 ENDIF 579 580 ENDIF 581 END DO 582 583 DEALLOCATE( zprofvar, zprofclim, & 584 & zsurfvar, zsurfclim ) 585 586 IF( ln_timing ) CALL timing_stop('dia_obs') 632 587 633 588 END SUBROUTINE dia_obs … … 657 612 658 613 !! * Local declarations 659 INTEGER :: jtype ! Data set loop variable 660 INTEGER :: jo, jvar, jk 614 INTEGER :: jgroup ! Data set loop variable 615 INTEGER :: jo, jvar, jk, jadd, jext, jadd2, jext2 616 INTEGER :: iuvar, ivvar 661 617 REAL(wp), DIMENSION(:), ALLOCATABLE :: & 662 618 & zu, & 663 619 & zv 620 LOGICAL, DIMENSION(:), ALLOCATABLE :: ll_write 621 TYPE(obswriinfo) :: sladd, slext 622 623 IF( ln_timing ) CALL timing_start('dia_obs_wri') 664 624 665 625 !----------------------------------------------------------------------- … … 667 627 !----------------------------------------------------------------------- 668 628 669 IF ( nproftypes > 0 ) THEN 670 671 DO jtype = 1, nproftypes 672 673 IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN 674 675 ! For velocity data, rotate the model velocities to N/S, E/W 676 ! using the compressed data structure. 677 ALLOCATE( & 678 & zu(profdataqc(jtype)%nvprot(1)), & 679 & zv(profdataqc(jtype)%nvprot(2)) & 680 & ) 681 682 CALL obs_rotvel( profdataqc(jtype), nn_2dint, zu, zv ) 683 684 DO jo = 1, profdataqc(jtype)%nprof 685 DO jvar = 1, 2 686 DO jk = profdataqc(jtype)%npvsta(jo,jvar), profdataqc(jtype)%npvend(jo,jvar) 687 688 IF ( jvar == 1 ) THEN 689 profdataqc(jtype)%var(jvar)%vmod(jk) = zu(jk) 690 ELSE 691 profdataqc(jtype)%var(jvar)%vmod(jk) = zv(jk) 629 DO jgroup = 1, nn_obsgroups 630 IF (sobsgroups(jgroup)%lenabled) THEN 631 632 IF (sobsgroups(jgroup)%lprof) THEN 633 634 IF (sobsgroups(jgroup)%lvel) THEN 635 iuvar = 0 636 ivvar = 0 637 DO jvar = 1, sobsgroups(jgroup)%nobstypes 638 IF ( TRIM(sobsgroups(jgroup)%cobstypes(jvar)) == cobsname_uvel ) THEN 639 iuvar = jvar 640 ELSEIF ( TRIM(sobsgroups(jgroup)%cobstypes(jvar)) == cobsname_vvel ) THEN 641 ivvar = jvar 642 ENDIF 643 END DO 644 IF ( (iuvar > 0) .AND. (ivvar > 0) ) THEN 645 646 ! For velocity data, rotate the model velocities to N/S, E/W 647 ! using the compressed data structure. 648 ALLOCATE( & 649 & zu(sobsgroups(jgroup)%sprofdataqc%nvprot(iuvar)), & 650 & zv(sobsgroups(jgroup)%sprofdataqc%nvprot(ivvar)) & 651 & ) 652 653 CALL obs_rotvel_pro( sobsgroups(jgroup)%sprofdataqc, sobsgroups(jgroup)%n2dint, & 654 & iuvar, ivvar, zu, zv ) 655 656 DO jo = 1, sobsgroups(jgroup)%sprofdataqc%nprof 657 DO jk = sobsgroups(jgroup)%sprofdataqc%npvsta(jo,iuvar), sobsgroups(jgroup)%sprofdataqc%npvend(jo,iuvar) 658 sobsgroups(jgroup)%sprofdataqc%var(iuvar)%vmod(jk) = zu(jk) 659 END DO 660 DO jk = sobsgroups(jgroup)%sprofdataqc%npvsta(jo,ivvar), sobsgroups(jgroup)%sprofdataqc%npvend(jo,ivvar) 661 sobsgroups(jgroup)%sprofdataqc%var(ivvar)%vmod(jk) = zv(jk) 662 END DO 663 END DO 664 665 DEALLOCATE( zu ) 666 DEALLOCATE( zv ) 667 668 ELSE 669 CALL ctl_stop( 'Could not identify velocity observation variables to rotate' ) 670 END IF 671 END IF 672 673 CALL obs_prof_decompress( sobsgroups(jgroup)%sprofdataqc, & 674 & sobsgroups(jgroup)%sprofdata, .TRUE., numout ) 675 676 ! Put additional and extra variable information into obswriinfo structure 677 ! used by obs_write. 678 ! add/ext variables generated by the OBS code (1...sobsgroups(jgroup)%naddvars) 679 ! may duplicate ones read in (%naddvars+1...sobsgroups(jgroup)%sprofdata%nadd) 680 ! Check for this, and if so only write out the version generated by the OBS code 681 sladd%inum = sobsgroups(jgroup)%sprofdata%nadd 682 ALLOCATE( ll_write(sobsgroups(jgroup)%sprofdata%nadd) ) 683 ll_write(:) = .TRUE. 684 IF ( (sobsgroups(jgroup)%naddvars > 0) .AND. & 685 & (sobsgroups(jgroup)%sprofdata%nadd > sobsgroups(jgroup)%naddvars) ) THEN 686 DO jadd = sobsgroups(jgroup)%naddvars + 1, sobsgroups(jgroup)%sprofdata%nadd 687 DO jadd2 = 1, sobsgroups(jgroup)%naddvars 688 IF ( TRIM(sobsgroups(jgroup)%sprofdata%caddvars(jadd )) == & 689 & TRIM(sobsgroups(jgroup)%sprofdata%caddvars(jadd2)) ) THEN 690 sladd%inum = sladd%inum - 1 691 ll_write(jadd) = .FALSE. 692 692 ENDIF 693 694 693 END DO 695 694 END DO 696 END DO 697 698 DEALLOCATE( zu ) 699 DEALLOCATE( zv ) 700 701 END IF 702 703 CALL obs_prof_decompress( profdataqc(jtype), & 704 & profdata(jtype), .TRUE., numout ) 705 706 CALL obs_wri_prof( profdata(jtype) ) 707 708 END DO 709 710 ENDIF 711 712 IF ( nsurftypes > 0 ) THEN 713 714 DO jtype = 1, nsurftypes 715 716 CALL obs_surf_decompress( surfdataqc(jtype), & 717 & surfdata(jtype), .TRUE., numout ) 718 719 CALL obs_wri_surf( surfdata(jtype) ) 720 721 END DO 722 723 ENDIF 695 ENDIF 696 IF ( sladd%inum > 0 ) THEN 697 ALLOCATE( sladd%ipoint(sladd%inum), & 698 & sladd%cdname(sladd%inum), & 699 & sladd%cdlong(sladd%inum,sobsgroups(jgroup)%sprofdata%nvar), & 700 & sladd%cdunit(sladd%inum,sobsgroups(jgroup)%sprofdata%nvar) ) 701 jadd2 = 0 702 DO jadd = 1, sobsgroups(jgroup)%sprofdata%nadd 703 IF ( ll_write(jadd) ) THEN 704 jadd2 = jadd2 + 1 705 sladd%ipoint(jadd2) = jadd 706 sladd%cdname(jadd2) = sobsgroups(jgroup)%sprofdata%caddvars(jadd) 707 DO jvar = 1, sobsgroups(jgroup)%sprofdata%nvar 708 sladd%cdlong(jadd2,jvar) = sobsgroups(jgroup)%sprofdata%caddlong(jadd,jvar) 709 sladd%cdunit(jadd2,jvar) = sobsgroups(jgroup)%sprofdata%caddunit(jadd,jvar) 710 END DO 711 ENDIF 712 END DO 713 ENDIF 714 DEALLOCATE( ll_write ) 715 716 slext%inum = sobsgroups(jgroup)%sprofdata%next 717 ALLOCATE( ll_write(sobsgroups(jgroup)%sprofdata%next) ) 718 ll_write(:) = .TRUE. 719 IF ( (sobsgroups(jgroup)%nextvars > 0) .AND. & 720 & (sobsgroups(jgroup)%sprofdata%next > sobsgroups(jgroup)%nextvars) ) THEN 721 DO jext = sobsgroups(jgroup)%nextvars + 1, sobsgroups(jgroup)%sprofdata%next 722 DO jext2 = 1, sobsgroups(jgroup)%nextvars 723 IF ( TRIM(sobsgroups(jgroup)%sprofdata%cextvars(jext )) == & 724 & TRIM(sobsgroups(jgroup)%sprofdata%cextvars(jext2)) ) THEN 725 slext%inum = slext%inum - 1 726 ll_write(jext) = .FALSE. 727 ENDIF 728 END DO 729 END DO 730 ENDIF 731 IF ( slext%inum > 0 ) THEN 732 ALLOCATE( slext%ipoint(slext%inum), & 733 & slext%cdname(slext%inum), & 734 & slext%cdlong(slext%inum,1), & 735 & slext%cdunit(slext%inum,1) ) 736 jext2 = 0 737 DO jext = 1, sobsgroups(jgroup)%sprofdata%next 738 IF ( ll_write(jext) ) THEN 739 jext2 = jext2 + 1 740 slext%ipoint(jext2) = jext 741 slext%cdname(jext2) = sobsgroups(jgroup)%sprofdata%cextvars(jext) 742 slext%cdlong(jext2,1) = sobsgroups(jgroup)%sprofdata%cextlong(jext) 743 slext%cdunit(jext2,1) = sobsgroups(jgroup)%sprofdata%cextunit(jext) 744 ENDIF 745 END DO 746 ENDIF 747 DEALLOCATE( ll_write ) 748 749 CALL obs_wri_prof( sobsgroups(jgroup)%sprofdata, sobsgroups(jgroup)%cgroupname, sladd, slext ) 750 751 IF ( sladd%inum > 0 ) THEN 752 DEALLOCATE( sladd%ipoint, sladd%cdname, sladd%cdlong, sladd%cdunit ) 753 ENDIF 754 IF ( slext%inum > 0 ) THEN 755 DEALLOCATE( slext%ipoint, slext%cdname, slext%cdlong, slext%cdunit ) 756 ENDIF 757 758 ELSEIF (sobsgroups(jgroup)%lsurf) THEN 759 760 IF (sobsgroups(jgroup)%lvel) THEN 761 iuvar = 0 762 ivvar = 0 763 DO jvar = 1, sobsgroups(jgroup)%nobstypes 764 IF ( TRIM(sobsgroups(jgroup)%cobstypes(jvar)) == cobsname_uvel ) THEN 765 iuvar = jvar 766 ELSEIF ( TRIM(sobsgroups(jgroup)%cobstypes(jvar)) == cobsname_vvel ) THEN 767 ivvar = jvar 768 ENDIF 769 END DO 770 IF ( (iuvar > 0) .AND. (ivvar > 0) ) THEN 771 772 ! For velocity data, rotate the model velocities to N/S, E/W 773 ! using the compressed data structure. 774 ALLOCATE( & 775 & zu(sobsgroups(jgroup)%ssurfdataqc%nsurf), & 776 & zv(sobsgroups(jgroup)%ssurfdataqc%nsurf) & 777 & ) 778 779 CALL obs_rotvel_surf( sobsgroups(jgroup)%ssurfdataqc, sobsgroups(jgroup)%n2dint, & 780 & iuvar, ivvar, zu, zv ) 781 782 DO jo = 1, sobsgroups(jgroup)%ssurfdataqc%nsurf 783 sobsgroups(jgroup)%ssurfdataqc%rmod(jo,iuvar) = zu(jo) 784 sobsgroups(jgroup)%ssurfdataqc%rmod(jo,ivvar) = zv(jo) 785 END DO 786 787 DEALLOCATE( zu ) 788 DEALLOCATE( zv ) 789 790 ELSE 791 CALL ctl_stop( 'Could not identify velocity observation variables to rotate' ) 792 END IF 793 END IF 794 795 CALL obs_surf_decompress( sobsgroups(jgroup)%ssurfdataqc, & 796 & sobsgroups(jgroup)%ssurfdata, .TRUE., numout ) 797 798 IF (sobsgroups(jgroup)%lfbd) THEN 799 ! Input observations were freeboard, but we're outputting ice thickness 800 DO jvar = 1, sobsgroups(jgroup)%nobstypes 801 IF ( sobsgroups(jgroup)%cobstypes(jvar) == cobsname_fbd ) THEN 802 sobsgroups(jgroup)%ssurfdata%cvars(jvar) = 'SIT' 803 sobsgroups(jgroup)%ssurfdata%clong(jvar) = 'Sea ice thickness' 804 sobsgroups(jgroup)%ssurfdata%cunit(jvar) = 'm' 805 EXIT 806 ENDIF 807 END DO 808 ENDIF 809 810 ! Put additional and extra variable information into obswriinfo structure 811 ! used by obs_write. 812 ! add/ext variables generated by the OBS code (1...sobsgroups(jgroup)%naddvars) 813 ! may duplicate ones read in (%naddvars+1...sobsgroups(jgroup)%ssurfdata%nadd) 814 ! Check for this, and if so only write out the version generated by the OBS code 815 sladd%inum = sobsgroups(jgroup)%ssurfdata%nadd 816 ALLOCATE( ll_write(sobsgroups(jgroup)%ssurfdata%nadd) ) 817 ll_write(:) = .TRUE. 818 IF ( (sobsgroups(jgroup)%naddvars > 0) .AND. & 819 & (sobsgroups(jgroup)%ssurfdata%nadd > sobsgroups(jgroup)%naddvars) ) THEN 820 DO jadd = sobsgroups(jgroup)%naddvars + 1, sobsgroups(jgroup)%ssurfdata%nadd 821 DO jadd2 = 1, sobsgroups(jgroup)%naddvars 822 IF ( TRIM(sobsgroups(jgroup)%ssurfdata%caddvars(jadd )) == & 823 & TRIM(sobsgroups(jgroup)%ssurfdata%caddvars(jadd2)) ) THEN 824 sladd%inum = sladd%inum - 1 825 ll_write(jadd) = .FALSE. 826 ENDIF 827 END DO 828 END DO 829 ENDIF 830 IF ( sladd%inum > 0 ) THEN 831 ALLOCATE( sladd%ipoint(sladd%inum), & 832 & sladd%cdname(sladd%inum), & 833 & sladd%cdlong(sladd%inum,sobsgroups(jgroup)%ssurfdata%nvar), & 834 & sladd%cdunit(sladd%inum,sobsgroups(jgroup)%ssurfdata%nvar) ) 835 jadd2 = 0 836 DO jadd = 1, sobsgroups(jgroup)%ssurfdata%nadd 837 IF ( ll_write(jadd) ) THEN 838 jadd2 = jadd2 + 1 839 sladd%ipoint(jadd2) = jadd 840 sladd%cdname(jadd2) = sobsgroups(jgroup)%ssurfdata%caddvars(jadd) 841 DO jvar = 1, sobsgroups(jgroup)%ssurfdata%nvar 842 sladd%cdlong(jadd2,jvar) = sobsgroups(jgroup)%ssurfdata%caddlong(jadd,jvar) 843 sladd%cdunit(jadd2,jvar) = sobsgroups(jgroup)%ssurfdata%caddunit(jadd,jvar) 844 END DO 845 ENDIF 846 END DO 847 ENDIF 848 DEALLOCATE( ll_write ) 849 850 slext%inum = sobsgroups(jgroup)%ssurfdata%nextra 851 ALLOCATE( ll_write(sobsgroups(jgroup)%ssurfdata%nextra) ) 852 ll_write(:) = .TRUE. 853 IF ( (sobsgroups(jgroup)%nextvars > 0) .AND. & 854 & (sobsgroups(jgroup)%ssurfdata%nextra > sobsgroups(jgroup)%nextvars) ) THEN 855 DO jext = sobsgroups(jgroup)%nextvars + 1, sobsgroups(jgroup)%ssurfdata%nextra 856 DO jext2 = 1, sobsgroups(jgroup)%nextvars 857 IF ( TRIM(sobsgroups(jgroup)%ssurfdata%cextvars(jext )) == & 858 & TRIM(sobsgroups(jgroup)%ssurfdata%cextvars(jext2)) ) THEN 859 slext%inum = slext%inum - 1 860 ll_write(jext) = .FALSE. 861 ENDIF 862 END DO 863 END DO 864 ENDIF 865 IF ( slext%inum > 0 ) THEN 866 ALLOCATE( slext%ipoint(slext%inum), & 867 & slext%cdname(slext%inum), & 868 & slext%cdlong(slext%inum,1), & 869 & slext%cdunit(slext%inum,1) ) 870 jext2 = 0 871 DO jext = 1, sobsgroups(jgroup)%ssurfdata%nextra 872 IF ( ll_write(jext) ) THEN 873 jext2 = jext2 + 1 874 slext%ipoint(jext2) = jext 875 slext%cdname(jext2) = sobsgroups(jgroup)%ssurfdata%cextvars(jext) 876 slext%cdlong(jext2,1) = sobsgroups(jgroup)%ssurfdata%cextlong(jext) 877 slext%cdunit(jext2,1) = sobsgroups(jgroup)%ssurfdata%cextunit(jext) 878 ENDIF 879 END DO 880 ENDIF 881 DEALLOCATE( ll_write ) 882 883 CALL obs_wri_surf( sobsgroups(jgroup)%ssurfdata, sobsgroups(jgroup)%cgroupname, sladd, slext ) 884 885 IF ( sladd%inum > 0 ) THEN 886 DEALLOCATE( sladd%ipoint, sladd%cdname, sladd%cdlong, sladd%cdunit ) 887 ENDIF 888 IF ( slext%inum > 0 ) THEN 889 DEALLOCATE( slext%ipoint, slext%cdname, slext%cdlong, slext%cdunit ) 890 ENDIF 891 892 ENDIF 893 894 ENDIF 895 896 END DO 897 898 IF( ln_timing ) CALL timing_stop('dia_obs_wri') 724 899 725 900 END SUBROUTINE dia_obs_wri 726 727 SUBROUTINE dia_obs_dealloc728 IMPLICIT NONE729 !!----------------------------------------------------------------------730 !! *** ROUTINE dia_obs_dealloc ***731 !!732 !! ** Purpose : To deallocate data to enable the obs_oper online loop.733 !! Specifically: dia_obs_init --> dia_obs --> dia_obs_wri734 !!735 !! ** Method : Clean up various arrays left behind by the obs_oper.736 !!737 !! ** Action :738 !!739 !!----------------------------------------------------------------------740 ! obs_grid deallocation741 CALL obs_grid_deallocate742 743 ! diaobs deallocation744 IF ( nproftypes > 0 ) &745 & DEALLOCATE( cobstypesprof, profdata, profdataqc, nvarsprof, nextrprof )746 747 IF ( nsurftypes > 0 ) &748 & DEALLOCATE( cobstypessurf, surfdata, surfdataqc, nvarssurf, nextrsurf, &749 & n2dintsurf, zavglamscl, zavgphiscl, lfpindegs, llnightav )750 751 END SUBROUTINE dia_obs_dealloc752 901 753 902 SUBROUTINE calc_date( kstp, ddobs ) … … 895 1044 896 1045 END SUBROUTINE fin_date 897 898 SUBROUTINE obs_settypefiles( ntypes, jpmaxnfiles, jtype, ctypein, &899 & cfilestype, ifiles, cobstypes, cfiles )900 901 INTEGER, INTENT(IN) :: ntypes ! Total number of obs types902 INTEGER, INTENT(IN) :: jpmaxnfiles ! Maximum number of files allowed for each type903 INTEGER, INTENT(IN) :: jtype ! Index of the current type of obs904 INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: &905 & ifiles ! Out appended number of files for this type906 907 CHARACTER(len=6), INTENT(IN) :: ctypein908 CHARACTER(len=128), DIMENSION(jpmaxnfiles), INTENT(IN) :: &909 & cfilestype ! In list of files for this obs type910 CHARACTER(len=6), DIMENSION(ntypes), INTENT(INOUT) :: &911 & cobstypes ! Out appended list of obs types912 CHARACTER(len=128), DIMENSION(ntypes, jpmaxnfiles), INTENT(INOUT) :: &913 & cfiles ! Out appended list of files for all types914 915 !Local variables916 INTEGER :: jfile917 918 cfiles(jtype,:) = cfilestype(:)919 cobstypes(jtype) = ctypein920 ifiles(jtype) = 0921 DO jfile = 1, jpmaxnfiles922 IF ( trim(cfiles(jtype,jfile)) /= '' ) &923 ifiles(jtype) = ifiles(jtype) + 1924 END DO925 926 IF ( ifiles(jtype) == 0 ) THEN927 CALL ctl_stop( 'Logical for observation type '//TRIM(ctypein)// &928 & ' set to true but no files available to read' )929 ENDIF930 931 IF(lwp) THEN932 WRITE(numout,*) ' '//cobstypes(jtype)//' input observation file names:'933 DO jfile = 1, ifiles(jtype)934 WRITE(numout,*) ' '//TRIM(cfiles(jtype,jfile))935 END DO936 ENDIF937 938 END SUBROUTINE obs_settypefiles939 940 SUBROUTINE obs_setinterpopts( ntypes, jtype, ctypein, &941 & n2dint_default, n2dint_type, &942 & zavglamscl_type, zavgphiscl_type, &943 & lfp_indegs_type, lavnight_type, &944 & n2dint, zavglamscl, zavgphiscl, &945 & lfpindegs, lavnight )946 947 INTEGER, INTENT(IN) :: ntypes ! Total number of obs types948 INTEGER, INTENT(IN) :: jtype ! Index of the current type of obs949 INTEGER, INTENT(IN) :: n2dint_default ! Default option for interpolation type950 INTEGER, INTENT(IN) :: n2dint_type ! Option for interpolation type951 REAL(wp), INTENT(IN) :: &952 & zavglamscl_type, & !E/W diameter of obs footprint for this type953 & zavgphiscl_type !N/S diameter of obs footprint for this type954 LOGICAL, INTENT(IN) :: lfp_indegs_type !T=> footprint in degrees, F=> in metres955 LOGICAL, INTENT(IN) :: lavnight_type !T=> obs represent night time average956 CHARACTER(len=6), INTENT(IN) :: ctypein957 958 INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: &959 & n2dint960 REAL(wp), DIMENSION(ntypes), INTENT(INOUT) :: &961 & zavglamscl, zavgphiscl962 LOGICAL, DIMENSION(ntypes), INTENT(INOUT) :: &963 & lfpindegs, lavnight964 965 lavnight(jtype) = lavnight_type966 967 IF ( (n2dint_type >= 1) .AND. (n2dint_type <= 6) ) THEN968 n2dint(jtype) = n2dint_type969 ELSE970 n2dint(jtype) = n2dint_default971 ENDIF972 973 ! For averaging observation footprints set options for size of footprint974 IF ( (n2dint(jtype) > 4) .AND. (n2dint(jtype) <= 6) ) THEN975 IF ( zavglamscl_type > 0._wp ) THEN976 zavglamscl(jtype) = zavglamscl_type977 ELSE978 CALL ctl_stop( 'Incorrect value set for averaging footprint '// &979 'scale (zavglamscl) for observation type '//TRIM(ctypein) )980 ENDIF981 982 IF ( zavgphiscl_type > 0._wp ) THEN983 zavgphiscl(jtype) = zavgphiscl_type984 ELSE985 CALL ctl_stop( 'Incorrect value set for averaging footprint '// &986 'scale (zavgphiscl) for observation type '//TRIM(ctypein) )987 ENDIF988 989 lfpindegs(jtype) = lfp_indegs_type990 991 ENDIF992 993 ! Write out info994 IF(lwp) THEN995 IF ( n2dint(jtype) <= 4 ) THEN996 WRITE(numout,*) ' '//TRIM(ctypein)// &997 & ' model counterparts will be interpolated horizontally'998 ELSE IF ( n2dint(jtype) <= 6 ) THEN999 WRITE(numout,*) ' '//TRIM(ctypein)// &1000 & ' model counterparts will be averaged horizontally'1001 WRITE(numout,*) ' '//' with E/W scale: ',zavglamscl(jtype)1002 WRITE(numout,*) ' '//' with N/S scale: ',zavgphiscl(jtype)1003 IF ( lfpindegs(jtype) ) THEN1004 WRITE(numout,*) ' '//' (in degrees)'1005 ELSE1006 WRITE(numout,*) ' '//' (in metres)'1007 ENDIF1008 ENDIF1009 ENDIF1010 1011 END SUBROUTINE obs_setinterpopts1012 1046 1013 1047 END MODULE diaobs -
NEMO/branches/UKMO/NEMO_4.0.4_FOAM_package_generic_obs/src/OCE/OBS/obs_grid.F90
r14075 r15752 687 687 IF (ln_grid_search_lookup) THEN 688 688 689 WRITE(numout,*) 'Calling obs_grid_setup'689 IF(lwp) WRITE(numout,*) 'Calling obs_grid_setup' 690 690 691 691 IF(lwp) WRITE(numout,*) … … 724 724 ! initially assume size is as defined (to be fixed) 725 725 726 WRITE(numout,*) 'Reading: ',cfname726 IF(lwp) WRITE(numout,*) 'Reading: ',cfname 727 727 728 728 CALL chkerr( nf90_open( TRIM( cfname ), nf90_nowrite, idfile ), & -
NEMO/branches/UKMO/NEMO_4.0.4_FOAM_package_generic_obs/src/OCE/OBS/obs_level_search.h90
r14075 r15752 13 13 !! ** Method : Straightforward search 14 14 !! 15 !! ** Action : 15 !! ** Action : Will return level associated with T-point below the obs 16 !! depth, except when observation is in the top box will 17 !! return level 2. Also, if obs depth greater than depth 18 !! of last wet T-point (kpk-1) will return level kpk. 16 19 !! 17 20 !! History : … … 43 46 DO ji = 1, kobs 44 47 kobsk(ji) = 1 45 depk: DO jk = 2, kgrd 48 depk: DO jk = 2, kgrd-1 46 49 IF ( pgrddep(jk) >= pobsdep(ji) ) EXIT depk 47 50 END DO depk -
NEMO/branches/UKMO/NEMO_4.0.4_FOAM_package_generic_obs/src/OCE/OBS/obs_oper.F90
r14075 r15752 18 18 USE lib_mpp, ONLY : ctl_warn, ctl_stop ! Warning and stopping routines 19 19 USE sbcdcy, ONLY : sbc_dcy, nday_qsr ! For calculation of where it is night-time 20 USE obs_grid, ONLY : obs_level_search 20 USE obs_grid, ONLY : obs_level_search 21 USE obs_group_def, ONLY : cobsname_sla, cobsname_fbd, imaxavtypes 22 #if defined key_si3 || defined key_cice 23 USE phycst, ONLY : rhos, rhoi, rhow ! For conversion from sea ice freeboard to thickness 24 #endif 21 25 ! 22 26 USE par_kind , ONLY : wp ! Precision variables … … 28 32 PUBLIC obs_prof_opt !: Compute the model counterpart of profile obs 29 33 PUBLIC obs_surf_opt !: Compute the model counterpart of surface obs 30 31 INTEGER, PARAMETER, PUBLIC :: imaxavtypes = 20 !: Max number of daily avgd obs types32 34 33 35 !!---------------------------------------------------------------------- … … 38 40 CONTAINS 39 41 40 SUBROUTINE obs_prof_opt( prodatqc, kt, kpi, kpj, kpk, & 41 & kit000, kdaystp, & 42 & pvar1, pvar2, pgdept, pgdepw, & 43 & pmask1, pmask2, & 44 & plam1, plam2, pphi1, pphi2, & 42 SUBROUTINE obs_prof_opt( prodatqc, kt, kpi, kpj, kpk, & 43 & kit000, kdaystp, kvar, & 44 & pvar, & 45 & ldclim, kclim, pclim, & 46 & pgdept, pgdepw, & 47 & pmask, & 48 & plam, pphi, & 45 49 & k1dint, k2dint, kdailyavtypes ) 46 50 !!----------------------------------------------------------------------- … … 103 107 INTEGER , INTENT(in ) :: k2dint ! Horizontal interpolation type (see header) 104 108 INTEGER , INTENT(in ) :: kdaystp ! Number of time steps per day 105 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pvar1 , pvar2 ! Model field 1 and 2 106 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pmask1, pmask2 ! Land-sea mask 1 and 2 107 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: plam1 , plam2 ! Model longitude 1 and 2 108 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: pphi1 , pphi2 ! Model latitudes 1 and 2 109 INTEGER , INTENT(in ) :: kvar ! Index of variable in prodatqc 110 INTEGER , INTENT(in ) :: kclim ! Index of climatology in prodatqc 111 LOGICAL , INTENT(in ) :: ldclim ! Switch to interpolate climatology 112 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pvar ! Model field 113 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pclim ! Climatology field 114 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pmask ! Land-sea mask 115 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: plam ! Model longitude 116 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: pphi ! Model latitudes 109 117 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pgdept, pgdepw ! depth of T and W levels 110 118 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: kdailyavtypes ! Types for daily averages … … 126 134 & idailyavtypes 127 135 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 128 & igrdi1, & 129 & igrdi2, & 130 & igrdj1, & 131 & igrdj2 136 & igrdi, & 137 & igrdj 132 138 INTEGER, ALLOCATABLE, DIMENSION(:) :: iv_indic 133 139 … … 136 142 REAL(KIND=wp) :: zdaystp 137 143 REAL(KIND=wp), DIMENSION(kpk) :: & 138 & zobsmask1, & 139 & zobsmask2, & 140 & zobsk, & 141 & zobs2k 144 & zobsk, & 145 & zobs2k, & 146 & zclm2k 142 147 REAL(KIND=wp), DIMENSION(2,2,1) :: & 143 148 & zweig1, & 144 & zweig2, &145 149 & zweig 146 150 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 147 & zmask1, & 148 & zmask2, & 149 & zint1, & 150 & zint2, & 151 & zinm1, & 152 & zinm2, & 151 & zmask, & 152 & zclim, & 153 & zint, & 154 & zinm, & 153 155 & zgdept, & 154 156 & zgdepw 155 157 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 156 & zglam1, & 157 & zglam2, & 158 & zgphi1, & 159 & zgphi2 160 REAL(KIND=wp), DIMENSION(1) :: zmsk_1, zmsk_2 158 & zglam, & 159 & zgphi 160 REAL(KIND=wp), DIMENSION(1) :: zmsk 161 161 REAL(KIND=wp), DIMENSION(:,:,:), ALLOCATABLE :: interp_corner 162 REAL(KIND=wp), DIMENSION(:,:,:), ALLOCATABLE :: interp_corner_clim 162 163 163 164 LOGICAL :: ld_dailyav … … 190 191 DO jj = 1, jpj 191 192 DO ji = 1, jpi 192 prodatqc%vdmean(ji,jj,jk,1) = 0.0 193 prodatqc%vdmean(ji,jj,jk,2) = 0.0 193 prodatqc%vdmean(ji,jj,jk,kvar) = 0.0 194 194 END DO 195 195 END DO … … 201 201 DO ji = 1, jpi 202 202 ! Increment field 1 for computing daily mean 203 prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 204 & + pvar1(ji,jj,jk) 205 ! Increment field 2 for computing daily mean 206 prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 207 & + pvar2(ji,jj,jk) 203 prodatqc%vdmean(ji,jj,jk,kvar) = prodatqc%vdmean(ji,jj,jk,kvar) & 204 & + pvar(ji,jj,jk) 208 205 END DO 209 206 END DO … … 213 210 zdaystp = 1.0 / REAL( kdaystp ) 214 211 IF ( idayend == 0 ) THEN 215 IF (lwp) WRITE(numout,*) 'Calculating prodatqc%vdmean on time-step: ', kt212 IF (lwp) WRITE(numout,*) 'Calculating prodatqc%vdmean on time-step: ', kt 216 213 CALL FLUSH(numout) 217 214 DO jk = 1, jpk 218 215 DO jj = 1, jpj 219 216 DO ji = 1, jpi 220 prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 221 & * zdaystp 222 prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 223 & * zdaystp 217 prodatqc%vdmean(ji,jj,jk,kvar) = prodatqc%vdmean(ji,jj,jk,kvar) & 218 & * zdaystp 224 219 END DO 225 220 END DO … … 231 226 ! Get the data for interpolation 232 227 ALLOCATE( & 233 & igrdi1(2,2,ipro), & 234 & igrdi2(2,2,ipro), & 235 & igrdj1(2,2,ipro), & 236 & igrdj2(2,2,ipro), & 237 & zglam1(2,2,ipro), & 238 & zglam2(2,2,ipro), & 239 & zgphi1(2,2,ipro), & 240 & zgphi2(2,2,ipro), & 241 & zmask1(2,2,kpk,ipro), & 242 & zmask2(2,2,kpk,ipro), & 243 & zint1(2,2,kpk,ipro), & 244 & zint2(2,2,kpk,ipro), & 245 & zgdept(2,2,kpk,ipro), & 246 & zgdepw(2,2,kpk,ipro) & 228 & igrdi(2,2,ipro), & 229 & igrdj(2,2,ipro), & 230 & zglam(2,2,ipro), & 231 & zgphi(2,2,ipro), & 232 & zmask(2,2,kpk,ipro), & 233 & zint(2,2,kpk,ipro), & 234 & zgdept(2,2,kpk,ipro), & 235 & zgdepw(2,2,kpk,ipro) & 247 236 & ) 237 238 IF ( ldclim ) THEN 239 ALLOCATE( zclim(2,2,kpk,ipro) ) 240 ENDIF 248 241 249 242 DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro 250 243 iobs = jobs - prodatqc%nprofup 251 igrdi1(1,1,iobs) = prodatqc%mi(jobs,1)-1 252 igrdj1(1,1,iobs) = prodatqc%mj(jobs,1)-1 253 igrdi1(1,2,iobs) = prodatqc%mi(jobs,1)-1 254 igrdj1(1,2,iobs) = prodatqc%mj(jobs,1) 255 igrdi1(2,1,iobs) = prodatqc%mi(jobs,1) 256 igrdj1(2,1,iobs) = prodatqc%mj(jobs,1)-1 257 igrdi1(2,2,iobs) = prodatqc%mi(jobs,1) 258 igrdj1(2,2,iobs) = prodatqc%mj(jobs,1) 259 igrdi2(1,1,iobs) = prodatqc%mi(jobs,2)-1 260 igrdj2(1,1,iobs) = prodatqc%mj(jobs,2)-1 261 igrdi2(1,2,iobs) = prodatqc%mi(jobs,2)-1 262 igrdj2(1,2,iobs) = prodatqc%mj(jobs,2) 263 igrdi2(2,1,iobs) = prodatqc%mi(jobs,2) 264 igrdj2(2,1,iobs) = prodatqc%mj(jobs,2)-1 265 igrdi2(2,2,iobs) = prodatqc%mi(jobs,2) 266 igrdj2(2,2,iobs) = prodatqc%mj(jobs,2) 244 igrdi(1,1,iobs) = prodatqc%mi(jobs,kvar)-1 245 igrdj(1,1,iobs) = prodatqc%mj(jobs,kvar)-1 246 igrdi(1,2,iobs) = prodatqc%mi(jobs,kvar)-1 247 igrdj(1,2,iobs) = prodatqc%mj(jobs,kvar) 248 igrdi(2,1,iobs) = prodatqc%mi(jobs,kvar) 249 igrdj(2,1,iobs) = prodatqc%mj(jobs,kvar)-1 250 igrdi(2,2,iobs) = prodatqc%mi(jobs,kvar) 251 igrdj(2,2,iobs) = prodatqc%mj(jobs,kvar) 267 252 END DO 268 253 … … 271 256 zgdepw(:,:,:,:) = 0.0 272 257 273 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi1, igrdj1, plam1, zglam1 ) 274 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi1, igrdj1, pphi1, zgphi1 ) 275 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pmask1, zmask1 ) 276 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pvar1, zint1 ) 277 278 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi2, igrdj2, plam2, zglam2 ) 279 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi2, igrdj2, pphi2, zgphi2 ) 280 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, pmask2, zmask2 ) 281 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, pvar2, zint2 ) 282 283 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pgdept, zgdept ) 284 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pgdepw, zgdepw ) 258 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi, igrdj, plam, zglam ) 259 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi, igrdj, pphi, zgphi ) 260 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pmask, zmask ) 261 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pvar, zint ) 262 263 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pgdept, zgdept ) 264 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pgdepw, zgdepw ) 265 266 IF ( ldclim ) THEN 267 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pclim, zclim ) 268 ENDIF 285 269 286 270 ! At the end of the day also get interpolated means 287 271 IF ( ld_dailyav .AND. idayend == 0 ) THEN 288 272 289 ALLOCATE( & 290 & zinm1(2,2,kpk,ipro), & 291 & zinm2(2,2,kpk,ipro) & 292 & ) 293 294 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, & 295 & prodatqc%vdmean(:,:,:,1), zinm1 ) 296 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, & 297 & prodatqc%vdmean(:,:,:,2), zinm2 ) 273 ALLOCATE( zinm(2,2,kpk,ipro) ) 274 275 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, & 276 & prodatqc%vdmean(:,:,:,kvar), zinm ) 298 277 299 278 ENDIF … … 330 309 ! Horizontal weights 331 310 ! Masked values are calculated later. 332 IF ( prodatqc%npvend(jobs, 1) > 0 ) THEN311 IF ( prodatqc%npvend(jobs,kvar) > 0 ) THEN 333 312 334 313 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 335 & zglam1(:,:,iobs), zgphi1(:,:,iobs), & 336 & zmask1(:,:,1,iobs), zweig1, zmsk_1 ) 337 338 ENDIF 339 340 IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 341 342 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 343 & zglam2(:,:,iobs), zgphi2(:,:,iobs), & 344 & zmask2(:,:,1,iobs), zweig2, zmsk_2 ) 345 346 ENDIF 347 348 IF ( prodatqc%npvend(jobs,1) > 0 ) THEN 314 & zglam(:,:,iobs), zgphi(:,:,iobs), & 315 & zmask(:,:,1,iobs), zweig1, zmsk ) 316 317 ENDIF 318 319 IF ( prodatqc%npvend(jobs,kvar) > 0 ) THEN 349 320 350 321 zobsk(:) = obfillflt … … 356 327 357 328 ! vertically interpolate all 4 corners 358 ista = prodatqc%npvsta(jobs, 1)359 iend = prodatqc%npvend(jobs, 1)329 ista = prodatqc%npvsta(jobs,kvar) 330 iend = prodatqc%npvend(jobs,kvar) 360 331 inum_obs = iend - ista + 1 361 332 ALLOCATE(interp_corner(2,2,inum_obs),iv_indic(inum_obs)) 333 IF ( ldclim ) THEN 334 ALLOCATE( interp_corner_clim(2,2,inum_obs) ) 335 ENDIF 362 336 363 337 DO iin=1,2 … … 366 340 IF ( k1dint == 1 ) THEN 367 341 CALL obs_int_z1d_spl( kpk, & 368 & zinm 1(iin,ijn,:,iobs), &342 & zinm(iin,ijn,:,iobs), & 369 343 & zobs2k, zgdept(iin,ijn,:,iobs), & 370 & zmask1(iin,ijn,:,iobs)) 344 & zmask(iin,ijn,:,iobs)) 345 346 IF ( ldclim ) THEN 347 CALL obs_int_z1d_spl( kpk, & 348 & zclim(iin,ijn,:,iobs), & 349 & zclm2k, zgdept(iin,ijn,:,iobs), & 350 & zmask(iin,ijn,:,iobs)) 351 ENDIF 371 352 ENDIF 372 353 373 354 CALL obs_level_search(kpk, & 374 355 & zgdept(iin,ijn,:,iobs), & 375 & inum_obs, prodatqc%var( 1)%vdep(ista:iend), &356 & inum_obs, prodatqc%var(kvar)%vdep(ista:iend), & 376 357 & iv_indic) 377 358 378 359 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 379 & prodatqc%var( 1)%vdep(ista:iend), &380 & zinm 1(iin,ijn,:,iobs), &360 & prodatqc%var(kvar)%vdep(ista:iend), & 361 & zinm(iin,ijn,:,iobs), & 381 362 & zobs2k, interp_corner(iin,ijn,:), & 382 363 & zgdept(iin,ijn,:,iobs), & 383 & zmask1(iin,ijn,:,iobs)) 364 & zmask(iin,ijn,:,iobs)) 365 366 IF ( ldclim ) THEN 367 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 368 & prodatqc%var(kvar)%vdep(ista:iend), & 369 & zclim(iin,ijn,:,iobs), & 370 & zclm2k, interp_corner_clim(iin,ijn,:), & 371 & zgdept(iin,ijn,:,iobs), & 372 & zmask(iin,ijn,:,iobs)) 373 ENDIF 384 374 385 375 ENDDO … … 393 383 394 384 ! vertically interpolate all 4 corners 395 ista = prodatqc%npvsta(jobs, 1)396 iend = prodatqc%npvend(jobs, 1)385 ista = prodatqc%npvsta(jobs,kvar) 386 iend = prodatqc%npvend(jobs,kvar) 397 387 inum_obs = iend - ista + 1 398 388 ALLOCATE(interp_corner(2,2,inum_obs), iv_indic(inum_obs)) 389 IF ( ldclim ) THEN 390 ALLOCATE( interp_corner_clim(2,2,inum_obs) ) 391 ENDIF 399 392 DO iin=1,2 400 393 DO ijn=1,2 … … 402 395 IF ( k1dint == 1 ) THEN 403 396 CALL obs_int_z1d_spl( kpk, & 404 & zint 1(iin,ijn,:,iobs),&397 & zint(iin,ijn,:,iobs),& 405 398 & zobs2k, zgdept(iin,ijn,:,iobs), & 406 & zmask1(iin,ijn,:,iobs)) 407 399 & zmask(iin,ijn,:,iobs)) 400 401 IF ( ldclim ) THEN 402 CALL obs_int_z1d_spl( kpk, & 403 & zclim(iin,ijn,:,iobs),& 404 & zclm2k, zgdept(iin,ijn,:,iobs), & 405 & zmask(iin,ijn,:,iobs)) 406 ENDIF 408 407 ENDIF 409 408 410 409 CALL obs_level_search(kpk, & 411 410 & zgdept(iin,ijn,:,iobs),& 412 & inum_obs, prodatqc%var( 1)%vdep(ista:iend), &411 & inum_obs, prodatqc%var(kvar)%vdep(ista:iend), & 413 412 & iv_indic) 414 413 415 414 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 416 & prodatqc%var( 1)%vdep(ista:iend), &417 & zint 1(iin,ijn,:,iobs), &415 & prodatqc%var(kvar)%vdep(ista:iend), & 416 & zint(iin,ijn,:,iobs), & 418 417 & zobs2k,interp_corner(iin,ijn,:), & 419 418 & zgdept(iin,ijn,:,iobs), & 420 & zmask1(iin,ijn,:,iobs) ) 419 & zmask(iin,ijn,:,iobs) ) 420 421 IF ( ldclim ) THEN 422 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 423 & prodatqc%var(kvar)%vdep(ista:iend), & 424 & zclim(iin,ijn,:,iobs), & 425 & zclm2k,interp_corner_clim(iin,ijn,:), & 426 & zgdept(iin,ijn,:,iobs), & 427 & zmask(iin,ijn,:,iobs) ) 428 ENDIF 421 429 422 430 ENDDO … … 442 450 DO ijn=1,2 443 451 444 depth_loop 1: DO ik=kpk,2,-1445 IF(zmask 1(iin,ijn,ik-1,iobs ) > 0.9 )THEN452 depth_loop: DO ik=kpk,2,-1 453 IF(zmask(iin,ijn,ik-1,iobs ) > 0.9 )THEN 446 454 447 455 zweig(iin,ijn,1) = & 448 456 & zweig1(iin,ijn,1) * & 449 457 & MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) & 450 & - prodatqc%var( 1)%vdep(iend)),0._wp)458 & - prodatqc%var(kvar)%vdep(iend)),0._wp) 451 459 452 EXIT depth_loop 1460 EXIT depth_loop 453 461 454 462 ENDIF 455 463 456 ENDDO depth_loop 1464 ENDDO depth_loop 457 465 458 466 ENDDO … … 460 468 461 469 CALL obs_int_h2d( 1, 1, zweig, interp_corner(:,:,ikn), & 462 & prodatqc%var(1)%vmod(iend:iend) ) 463 464 ! Set QC flag for any observations found below the bottom 465 ! needed as the check here is more strict than that in obs_prep 466 IF (sum(zweig) == 0.0_wp) prodatqc%var(1)%nvqc(iend:iend)=4 470 & prodatqc%var(kvar)%vmod(iend:iend) ) 471 472 IF ( ldclim ) THEN 473 CALL obs_int_h2d( 1, 1, zweig, interp_corner_clim(:,:,ikn), & 474 & prodatqc%var(kvar)%vadd(iend:iend,kclim) ) 475 ENDIF 476 477 ! Set QC flag for any observations found below the bottom 478 ! needed as the check here is more strict than that in obs_prep 479 IF (sum(zweig) == 0.0_wp) prodatqc%var(kvar)%nvqc(iend:iend)=4 467 480 468 481 ENDDO 469 482 470 483 DEALLOCATE(interp_corner,iv_indic) 484 IF ( ldclim ) THEN 485 DEALLOCATE( interp_corner_clim ) 486 ENDIF 471 487 472 ENDIF 473 474 ! For the second variable 475 IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 476 477 zobsk(:) = obfillflt 478 479 IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN 480 481 IF ( idayend == 0 ) THEN 482 ! Daily averaged data 483 484 ! vertically interpolate all 4 corners 485 ista = prodatqc%npvsta(jobs,2) 486 iend = prodatqc%npvend(jobs,2) 487 inum_obs = iend - ista + 1 488 ALLOCATE(interp_corner(2,2,inum_obs),iv_indic(inum_obs)) 489 490 DO iin=1,2 491 DO ijn=1,2 492 493 IF ( k1dint == 1 ) THEN 494 CALL obs_int_z1d_spl( kpk, & 495 & zinm2(iin,ijn,:,iobs), & 496 & zobs2k, zgdept(iin,ijn,:,iobs), & 497 & zmask2(iin,ijn,:,iobs)) 498 ENDIF 499 500 CALL obs_level_search(kpk, & 501 & zgdept(iin,ijn,:,iobs), & 502 & inum_obs, prodatqc%var(2)%vdep(ista:iend), & 503 & iv_indic) 504 505 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 506 & prodatqc%var(2)%vdep(ista:iend), & 507 & zinm2(iin,ijn,:,iobs), & 508 & zobs2k, interp_corner(iin,ijn,:), & 509 & zgdept(iin,ijn,:,iobs), & 510 & zmask2(iin,ijn,:,iobs)) 511 512 ENDDO 513 ENDDO 514 515 ENDIF !idayend 516 517 ELSE 518 519 ! Point data 520 521 ! vertically interpolate all 4 corners 522 ista = prodatqc%npvsta(jobs,2) 523 iend = prodatqc%npvend(jobs,2) 524 inum_obs = iend - ista + 1 525 ALLOCATE(interp_corner(2,2,inum_obs), iv_indic(inum_obs)) 526 DO iin=1,2 527 DO ijn=1,2 528 529 IF ( k1dint == 1 ) THEN 530 CALL obs_int_z1d_spl( kpk, & 531 & zint2(iin,ijn,:,iobs),& 532 & zobs2k, zgdept(iin,ijn,:,iobs), & 533 & zmask2(iin,ijn,:,iobs)) 534 535 ENDIF 536 537 CALL obs_level_search(kpk, & 538 & zgdept(iin,ijn,:,iobs),& 539 & inum_obs, prodatqc%var(2)%vdep(ista:iend), & 540 & iv_indic) 541 542 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 543 & prodatqc%var(2)%vdep(ista:iend), & 544 & zint2(iin,ijn,:,iobs), & 545 & zobs2k,interp_corner(iin,ijn,:), & 546 & zgdept(iin,ijn,:,iobs), & 547 & zmask2(iin,ijn,:,iobs) ) 548 549 ENDDO 550 ENDDO 551 552 ENDIF 553 554 !------------------------------------------------------------- 555 ! Compute the horizontal interpolation for every profile level 556 !------------------------------------------------------------- 557 558 DO ikn=1,inum_obs 559 iend=ista+ikn-1 560 561 zweig(:,:,1) = 0._wp 562 563 ! This code forces the horizontal weights to be 564 ! zero IF the observation is below the bottom of the 565 ! corners of the interpolation nodes, Or if it is in 566 ! the mask. This is important for observations near 567 ! steep bathymetry 568 DO iin=1,2 569 DO ijn=1,2 570 571 depth_loop2: DO ik=kpk,2,-1 572 IF(zmask2(iin,ijn,ik-1,iobs ) > 0.9 )THEN 573 574 zweig(iin,ijn,1) = & 575 & zweig2(iin,ijn,1) * & 576 & MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) & 577 & - prodatqc%var(2)%vdep(iend)),0._wp) 578 579 EXIT depth_loop2 580 581 ENDIF 582 583 ENDDO depth_loop2 584 585 ENDDO 586 ENDDO 587 588 CALL obs_int_h2d( 1, 1, zweig, interp_corner(:,:,ikn), & 589 & prodatqc%var(2)%vmod(iend:iend) ) 590 591 ! Set QC flag for any observations found below the bottom 592 ! needed as the check here is more strict than that in obs_prep 593 IF (sum(zweig) == 0.0_wp) prodatqc%var(2)%nvqc(iend:iend)=4 594 595 ENDDO 596 597 DEALLOCATE(interp_corner,iv_indic) 598 599 ENDIF 488 ENDIF 600 489 601 490 ENDDO 602 491 603 492 ! Deallocate the data for interpolation 604 DEALLOCATE( & 605 & igrdi1, & 606 & igrdi2, & 607 & igrdj1, & 608 & igrdj2, & 609 & zglam1, & 610 & zglam2, & 611 & zgphi1, & 612 & zgphi2, & 613 & zmask1, & 614 & zmask2, & 615 & zint1, & 616 & zint2, & 493 DEALLOCATE( & 494 & igrdi, & 495 & igrdj, & 496 & zglam, & 497 & zgphi, & 498 & zmask, & 499 & zint, & 617 500 & zgdept, & 618 501 & zgdepw & 619 502 & ) 620 503 504 IF ( ldclim ) THEN 505 DEALLOCATE( zclim ) 506 ENDIF 507 621 508 ! At the end of the day also get interpolated means 622 509 IF ( ld_dailyav .AND. idayend == 0 ) THEN 623 DEALLOCATE( & 624 & zinm1, & 625 & zinm2 & 626 & ) 627 ENDIF 628 629 prodatqc%nprofup = prodatqc%nprofup + ipro 510 DEALLOCATE( zinm ) 511 ENDIF 512 513 IF ( kvar == prodatqc%nvar ) THEN 514 prodatqc%nprofup = prodatqc%nprofup + ipro 515 ENDIF 630 516 631 517 END SUBROUTINE obs_prof_opt 632 518 633 SUBROUTINE obs_surf_opt( surfdataqc, kt, kpi, kpj, & 634 & kit000, kdaystp, psurf, psurfmask, & 635 & k2dint, ldnightav, plamscl, pphiscl, & 636 & lindegrees ) 519 SUBROUTINE obs_surf_opt( surfdataqc, kt, kpi, kpj, & 520 & kit000, kdaystp, kvar, psurf, & 521 & ldclim, kclim, pclim, psurfmask, & 522 & k2dint, ldnightav, plamscl, pphiscl, & 523 & lindegrees, ldtime_mean, kmeanstp, & 524 & kssh, kmdt, kfbd, ksnow ) 637 525 638 526 !!----------------------------------------------------------------------- … … 680 568 ! (kit000-1 = restart time) 681 569 INTEGER, INTENT(IN) :: kdaystp ! Number of time steps per day 570 INTEGER, INTENT(IN) :: kvar ! Index of variable in surfdataqc 571 INTEGER, INTENT(IN) :: kclim ! Index of climatology in surfdataqc 682 572 INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation type (see header) 573 LOGICAL, INTENT(IN) :: ldclim ! Switch to interpolate climatology 683 574 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 684 575 & psurf, & ! Model surface field 576 & pclim, & ! Climatology surface field 685 577 & psurfmask ! Land-sea mask 686 578 LOGICAL, INTENT(IN) :: ldnightav ! Logical for averaging night-time data … … 690 582 LOGICAL, INTENT(IN) :: & 691 583 & lindegrees ! T=> plamscl and pphiscl are specified in degrees, F=> in metres 584 LOGICAL, INTENT(IN) :: & 585 & ldtime_mean ! Observations/background represent a time mean 586 INTEGER, INTENT(IN) :: kmeanstp ! Number of time steps for meaning if ldtime_mean 587 INTEGER, OPTIONAL, INTENT(IN) :: & 588 & kssh ! Index of additional variable representing SSH 589 INTEGER, OPTIONAL, INTENT(IN) :: & 590 & kmdt ! Index of extra variable representing MDT 591 INTEGER, OPTIONAL, INTENT(IN) :: & 592 & kfbd ! Index of additional variable representing ice freeboard 593 INTEGER, OPTIONAL, INTENT(IN) :: & 594 & ksnow ! Index of extra variable representing ice snow thickness 692 595 693 596 !! * Local declarations … … 701 604 INTEGER :: imodi, imodj 702 605 INTEGER :: idayend 606 INTEGER :: imeanend 703 607 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 704 608 & igrdi, & … … 711 615 REAL(wp) :: zlam 712 616 REAL(wp) :: zphi 713 REAL(wp), DIMENSION(1) :: zext, zobsmask 617 REAL(wp), DIMENSION(1) :: zext, zobsmask, zclm 714 618 REAL(wp) :: zdaystp 619 REAL(wp) :: zmeanstp 715 620 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 716 621 & zweig, & … … 719 624 & zsurfm, & 720 625 & zsurftmp, & 626 & zclim, & 721 627 & zglam, & 722 628 & zgphi, & … … 741 647 CALL obs_max_fpsize( k2dint, plamscl, pphiscl, lindegrees, psurfmask, imaxifp, imaxjfp ) 742 648 649 IF ( ldtime_mean .AND. ldnightav ) THEN 650 CALL ctl_stop( 'obs_surf_opt: Can have ldtime_mean or ldnightav but not both' ) 651 ENDIF 652 653 IF ( ldtime_mean ) THEN 654 ! Initialize time mean for first timestep 655 imeanend = MOD( kt - kit000 + 1, kmeanstp ) 656 IF (lwp) WRITE(numout,*) 'Obs time mean ', kt, kit000, kmeanstp, imeanend 657 658 ! Added kt == 0 test to catch restart case 659 IF ( ( imeanend == 1 ) .OR. ( kt == 0 ) ) THEN 660 IF (lwp) WRITE(numout,*) 'Reset surfdataqc%vdmean on time-step: ', kt 661 DO jj = 1, jpj 662 DO ji = 1, jpi 663 surfdataqc%vdmean(ji,jj,kvar) = 0.0 664 END DO 665 END DO 666 ENDIF 667 668 ! On each time-step, increment the field for computing time mean 669 IF (lwp) WRITE(numout,*)'Accumulating surfdataqc%vdmean on time-step: ', kt 670 DO jj = 1, jpj 671 DO ji = 1, jpi 672 surfdataqc%vdmean(ji,jj,kvar) = surfdataqc%vdmean(ji,jj,kvar) & 673 & + psurf(ji,jj) 674 END DO 675 END DO 676 677 ! Compute the time mean at the end of time period 678 IF ( imeanend == 0 ) THEN 679 zmeanstp = 1.0 / REAL( kmeanstp ) 680 IF (lwp) WRITE(numout,*) 'Calculating surfdataqc%vdmean time mean on time-step: ', & 681 & kt, ' with weight: ', zmeanstp 682 DO jj = 1, jpj 683 DO ji = 1, jpi 684 surfdataqc%vdmean(ji,jj,kvar) = surfdataqc%vdmean(ji,jj,kvar) & 685 & * zmeanstp 686 END DO 687 END DO 688 ENDIF 689 ENDIF 743 690 744 691 IF ( ldnightav ) THEN 745 692 746 ! Initialize array for night mean693 ! Initialize array for night mean 747 694 IF ( kt == 0 ) THEN 748 695 ALLOCATE ( icount_night(kpi,kpj) ) … … 762 709 DO jj = 1, jpj 763 710 DO ji = 1, jpi 764 surfdataqc%vdmean(ji,jj ) = 0.0711 surfdataqc%vdmean(ji,jj,:) = 0.0 765 712 zmeanday(ji,jj) = 0.0 766 713 icount_night(ji,jj) = 0 … … 775 722 DO jj = 1, jpj 776 723 DO ji = 1, jpi 777 ! Increment the temperaturefield for computing night mean and counter778 surfdataqc%vdmean(ji,jj ) = surfdataqc%vdmean(ji,jj) &779 & + psurf(ji,jj) * REAL( imask_night(ji,jj) )724 ! Increment the model field for computing night mean and counter 725 surfdataqc%vdmean(ji,jj,kvar) = surfdataqc%vdmean(ji,jj,kvar) & 726 & + psurf(ji,jj) * REAL( imask_night(ji,jj) ) 780 727 zmeanday(ji,jj) = zmeanday(ji,jj) + psurf(ji,jj) 781 728 icount_night(ji,jj) = icount_night(ji,jj) + imask_night(ji,jj) … … 786 733 zdaystp = 1.0 / REAL( kdaystp ) 787 734 IF ( idayend == 0 ) THEN 788 IF (lwp) WRITE(numout,*) 'Calculating surfdataqc%vdmean on time-step: ', kt735 IF (lwp) WRITE(numout,*) 'Calculating surfdataqc%vdmean on time-step: ', kt 789 736 DO jj = 1, jpj 790 737 DO ji = 1, jpi 791 738 ! Test if "no night" point 792 739 IF ( icount_night(ji,jj) > 0 ) THEN 793 surfdataqc%vdmean(ji,jj ) = surfdataqc%vdmean(ji,jj) &794 & / REAL( icount_night(ji,jj) )740 surfdataqc%vdmean(ji,jj,kvar) = surfdataqc%vdmean(ji,jj,kvar) & 741 & / REAL( icount_night(ji,jj) ) 795 742 ELSE 796 743 !At locations where there is no night (e.g. poles), 797 744 ! calculate daily mean instead of night-time mean. 798 surfdataqc%vdmean(ji,jj ) = zmeanday(ji,jj) * zdaystp745 surfdataqc%vdmean(ji,jj,kvar) = zmeanday(ji,jj) * zdaystp 799 746 ENDIF 800 747 END DO … … 814 761 & zmask(imaxifp,imaxjfp,isurf), & 815 762 & zsurf(imaxifp,imaxjfp,isurf), & 816 & zsurftmp(imaxifp,imaxjfp,isurf), & 817 & zglamf(imaxifp+1,imaxjfp+1,isurf), & 818 & zgphif(imaxifp+1,imaxjfp+1,isurf), & 819 & igrdip1(imaxifp+1,imaxjfp+1,isurf), & 820 & igrdjp1(imaxifp+1,imaxjfp+1,isurf) & 763 & zsurftmp(imaxifp,imaxjfp,isurf) & 821 764 & ) 765 766 IF ( k2dint > 4 ) THEN 767 ALLOCATE( & 768 & zglamf(imaxifp+1,imaxjfp+1,isurf), & 769 & zgphif(imaxifp+1,imaxjfp+1,isurf), & 770 & igrdip1(imaxifp+1,imaxjfp+1,isurf), & 771 & igrdjp1(imaxifp+1,imaxjfp+1,isurf) & 772 & ) 773 ENDIF 774 775 IF ( ldclim ) THEN 776 ALLOCATE( zclim(imaxifp,imaxjfp,isurf) ) 777 ENDIF 822 778 823 779 DO jobs = surfdataqc%nsurfup + 1, surfdataqc%nsurfup + isurf 824 780 iobs = jobs - surfdataqc%nsurfup 825 781 DO ji = 0, imaxifp 826 imodi = surfdataqc%mi(jobs ) - int(imaxifp/2) + ji - 1782 imodi = surfdataqc%mi(jobs,kvar) - int(imaxifp/2) + ji - 1 827 783 ! 828 784 !Deal with wrap around in longitude … … 831 787 ! 832 788 DO jj = 0, imaxjfp 833 imodj = surfdataqc%mj(jobs ) - int(imaxjfp/2) + jj - 1789 imodj = surfdataqc%mj(jobs,kvar) - int(imaxjfp/2) + jj - 1 834 790 !If model values are out of the domain to the north/south then 835 791 !set them to be the edge of the domain … … 837 793 IF ( imodj > jpjglo ) imodj = jpjglo 838 794 ! 839 igrdip1(ji+1,jj+1,iobs) = imodi 840 igrdjp1(ji+1,jj+1,iobs) = imodj 795 IF ( k2dint > 4 ) THEN 796 igrdip1(ji+1,jj+1,iobs) = imodi 797 igrdjp1(ji+1,jj+1,iobs) = imodj 798 ENDIF 841 799 ! 842 800 IF ( ji >= 1 .AND. jj >= 1 ) THEN … … 855 813 CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & 856 814 & igrdi, igrdj, psurfmask, zmask ) 857 CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & 858 & igrdi, igrdj, psurf, zsurf ) 859 CALL obs_int_comm_2d( imaxifp+1, imaxjfp+1, isurf, kpi, kpj, & 860 & igrdip1, igrdjp1, glamf, zglamf ) 861 CALL obs_int_comm_2d( imaxifp+1, imaxjfp+1, isurf, kpi, kpj, & 862 & igrdip1, igrdjp1, gphif, zgphif ) 815 816 ! At the end of the averaging period get interpolated means 817 IF ( ldtime_mean ) THEN 818 IF ( imeanend == 0 ) THEN 819 ALLOCATE( zsurfm(imaxifp,imaxjfp,isurf) ) 820 IF (lwp) WRITE(numout,*)' Interpolating the time mean values on time step: ', kt 821 CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & 822 & igrdi, igrdj, surfdataqc%vdmean(:,:,kvar), zsurfm ) 823 ENDIF 824 ELSE 825 CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & 826 & igrdi, igrdj, psurf, zsurf ) 827 ENDIF 828 829 IF ( k2dint > 4 ) THEN 830 CALL obs_int_comm_2d( imaxifp+1, imaxjfp+1, isurf, kpi, kpj, & 831 & igrdip1, igrdjp1, glamf, zglamf ) 832 CALL obs_int_comm_2d( imaxifp+1, imaxjfp+1, isurf, kpi, kpj, & 833 & igrdip1, igrdjp1, gphif, zgphif ) 834 ENDIF 835 836 IF ( ldclim ) THEN 837 CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & 838 & igrdi, igrdj, pclim, zclim ) 839 ENDIF 863 840 864 841 ! At the end of the day get interpolated means … … 870 847 871 848 CALL obs_int_comm_2d( imaxifp,imaxjfp, isurf, kpi, kpj, igrdi, igrdj, & 872 & surfdataqc%vdmean(:,: ), zsurfm )849 & surfdataqc%vdmean(:,:,kvar), zsurfm ) 873 850 874 851 ENDIF … … 900 877 zphi = surfdataqc%rphi(jobs) 901 878 902 IF ( ldnightav .AND. idayend == 0) THEN903 ! Night-time averaged data879 IF ( ( ldnightav .AND. idayend == 0 ) .OR. (ldtime_mean .AND. imeanend == 0) ) THEN 880 ! Night-time or N=kmeanstp timestep averaged data 904 881 zsurftmp(:,:,iobs) = zsurfm(:,:,iobs) 905 882 ELSE … … 907 884 ENDIF 908 885 909 IF ( k2dint <= 4 ) THEN 910 911 ! Get weights to interpolate the model value to the observation point 912 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 913 & zglam(:,:,iobs), zgphi(:,:,iobs), & 914 & zmask(:,:,iobs), zweig, zobsmask ) 915 916 ! Interpolate the model value to the observation point 917 CALL obs_int_h2d( 1, 1, zweig, zsurftmp(:,:,iobs), zext ) 918 919 ELSE 920 921 ! Get weights to average the model SLA to the observation footprint 922 CALL obs_avg_h2d_init( 1, 1, imaxifp, imaxjfp, k2dint, zlam, zphi, & 923 & zglam(:,:,iobs), zgphi(:,:,iobs), & 924 & zglamf(:,:,iobs), zgphif(:,:,iobs), & 925 & zmask(:,:,iobs), plamscl, pphiscl, & 926 & lindegrees, zweig, zobsmask ) 927 928 ! Average the model SST to the observation footprint 929 CALL obs_avg_h2d( 1, 1, imaxifp, imaxjfp, & 930 & zweig, zsurftmp(:,:,iobs), zext ) 931 932 ENDIF 933 934 IF ( TRIM(surfdataqc%cvars(1)) == 'SLA' .AND. surfdataqc%nextra == 2 ) THEN 935 ! ... Remove the MDT from the SSH at the observation point to get the SLA 936 surfdataqc%rext(jobs,1) = zext(1) 937 surfdataqc%rmod(jobs,1) = surfdataqc%rext(jobs,1) - surfdataqc%rext(jobs,2) 938 ELSE 939 surfdataqc%rmod(jobs,1) = zext(1) 940 ENDIF 941 942 IF ( zext(1) == obfillflt ) THEN 943 ! If the observation value is a fill value, set QC flag to bad 944 surfdataqc%nqc(jobs) = 4 886 IF ( ( .NOT. ldtime_mean ) .OR. ( ldtime_mean .AND. imeanend == 0) ) THEN 887 888 IF ( k2dint <= 4 ) THEN 889 890 ! Get weights to interpolate the model value to the observation point 891 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 892 & zglam(:,:,iobs), zgphi(:,:,iobs), & 893 & zmask(:,:,iobs), zweig, zobsmask ) 894 895 ! Interpolate the model value to the observation point 896 CALL obs_int_h2d( 1, 1, zweig, zsurftmp(:,:,iobs), zext ) 897 898 IF ( ldclim ) THEN 899 CALL obs_int_h2d( 1, 1, zweig, zclim(:,:,iobs), zclm ) 900 ENDIF 901 902 ELSE 903 904 ! Get weights to average the model field to the observation footprint 905 CALL obs_avg_h2d_init( 1, 1, imaxifp, imaxjfp, k2dint, zlam, zphi, & 906 & zglam(:,:,iobs), zgphi(:,:,iobs), & 907 & zglamf(:,:,iobs), zgphif(:,:,iobs), & 908 & zmask(:,:,iobs), plamscl, pphiscl, & 909 & lindegrees, zweig, zobsmask ) 910 911 ! Average the model field to the observation footprint 912 CALL obs_avg_h2d( 1, 1, imaxifp, imaxjfp, & 913 & zweig, zsurftmp(:,:,iobs), zext ) 914 915 IF ( ldclim ) THEN 916 CALL obs_avg_h2d( 1, 1, imaxifp, imaxjfp, & 917 & zweig, zclim(:,:,iobs), zclm ) 918 ENDIF 919 920 ENDIF 921 922 IF ( TRIM(surfdataqc%cvars(kvar)) == cobsname_sla .AND. PRESENT(kssh) .AND. PRESENT(kmdt) ) THEN 923 ! ... Remove the MDT from the SSH at the observation point to get the SLA 924 surfdataqc%radd(jobs,kssh,kvar) = zext(1) 925 surfdataqc%rmod(jobs,kvar) = surfdataqc%radd(jobs,kssh,kvar) - surfdataqc%rext(jobs,kmdt) 926 #if defined key_si3 || defined key_cice 927 ELSE IF ( TRIM(surfdataqc%cvars(kvar)) == cobsname_fbd .AND. PRESENT(kfbd) .AND. PRESENT(ksnow) ) THEN 928 surfdataqc%rmod(jobs,kvar) = zext(1) 929 ! Convert radar freeboard to true freeboard 930 ! (add 1/4 snow depth; 1/4 based on ratio of speed of light in vacuum 931 ! compared to snow (3.0e8 vs 2.4e8 m/s)) 932 surfdataqc%radd(jobs,kfbd,kvar) = surfdataqc%robs(jobs,kvar) 933 surfdataqc%robs(jobs,kvar) = surfdataqc%radd(jobs,kfbd,kvar) + 0.25*surfdataqc%rext(jobs,ksnow) 934 ! If the corrected freeboard observation is outside -0.3 to 3.0 m (CPOM) then set the QC flag to bad 935 IF ((surfdataqc%robs(jobs,kvar) < -0.3) .OR. (surfdataqc%robs(jobs,kvar) > 3.0)) THEN 936 surfdataqc%nqc(jobs) = 4 937 ENDIF 938 ! Convert corrected freeboard to ice thickness following Tilling et al. (2016) 939 surfdataqc%robs(jobs,kvar) = (surfdataqc%robs(jobs,kvar)*rhow + surfdataqc%rext(jobs,ksnow)*rhos)/ & 940 & (rhow - rhoi) 941 #endif 942 ELSE 943 surfdataqc%rmod(jobs,kvar) = zext(1) 944 ENDIF 945 946 IF ( ldclim ) THEN 947 surfdataqc%radd(jobs,kclim,kvar) = zclm(1) 948 ENDIF 949 950 IF ( zext(1) == obfillflt ) THEN 951 ! If the observation value is a fill value, set QC flag to bad 952 surfdataqc%nqc(jobs) = 4 953 ENDIF 954 945 955 ENDIF 946 956 … … 956 966 & zmask, & 957 967 & zsurf, & 958 & zsurftmp, & 959 & zglamf, & 960 & zgphif, & 961 & igrdip1,& 962 & igrdjp1 & 968 & zsurftmp & 963 969 & ) 964 970 965 ! At the end of the day also deallocate night-time mean array 966 IF ( idayend == 0 .AND. ldnightav ) THEN 971 IF ( k2dint > 4 ) THEN 972 DEALLOCATE( & 973 & zglamf, & 974 & zgphif, & 975 & igrdip1,& 976 & igrdjp1 & 977 & ) 978 ENDIF 979 980 IF ( ldclim ) THEN 981 DEALLOCATE( zclim ) 982 ENDIF 983 984 ! At the end of the day also deallocate time mean array 985 IF ( ( idayend == 0 .AND. ldnightav ) .OR. ( imeanend == 0 .AND. ldtime_mean ) ) THEN 967 986 DEALLOCATE( & 968 987 & zsurfm & … … 970 989 ENDIF 971 990 ! 972 surfdataqc%nsurfup = surfdataqc%nsurfup + isurf 991 IF ( kvar == surfdataqc%nvar ) THEN 992 surfdataqc%nsurfup = surfdataqc%nsurfup + isurf 993 ENDIF 973 994 ! 974 995 END SUBROUTINE obs_surf_opt -
NEMO/branches/UKMO/NEMO_4.0.4_FOAM_package_generic_obs/src/OCE/OBS/obs_prep.F90
r14075 r15752 22 22 USE obs_inter_sup ! Interpolation support 23 23 USE obs_oper ! Observation operators 24 USE obs_group_def, ONLY : & ! Observation variable information 25 & cobsname_uvel, & 26 & cobsname_vvel, & 27 & imaxavtypes 24 28 USE lib_mpp, ONLY : ctl_warn, ctl_stop 25 29 USE bdy_oce, ONLY : & ! Boundary information … … 42 46 CONTAINS 43 47 44 SUBROUTINE obs_pre_surf( surfdata, surfdataqc, ld_nea, ld_bound_reject, & 45 kqc_cutoff ) 46 !!---------------------------------------------------------------------- 47 !! *** ROUTINE obs_pre_sla *** 48 SUBROUTINE obs_pre_surf( surfdata, surfdataqc, & 49 & kpi, kpj, & 50 & zmask, pglam, pgphi, & 51 & ld_nea, ld_bound_reject, & 52 & kqc_cutoff ) 53 !!---------------------------------------------------------------------- 54 !! *** ROUTINE obs_pre_surf *** 48 55 !! 49 56 !! ** Purpose : First level check and screening of surface observations … … 65 72 !! * Arguments 66 73 TYPE(obs_surf), INTENT(INOUT) :: surfdata ! Full set of surface data 67 TYPE(obs_surf), INTENT(INOUT) :: surfdataqc ! Subset of surface data not failing screening 68 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 74 TYPE(obs_surf), INTENT(INOUT) :: surfdataqc ! Subset of surface data not failing screening 75 INTEGER, INTENT(IN) :: kpi, kpj ! Local domain sizes 76 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,surfdata%nvar) :: & 77 & zmask 78 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,surfdata%nvar) :: & 79 & pglam, & 80 & pgphi 81 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 69 82 LOGICAL, INTENT(IN) :: ld_bound_reject ! Switch for rejecting obs near the boundary 70 INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff 83 INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff ! cut off for QC value 71 84 !! * Local declarations 72 85 INTEGER :: iqc_cutoff = 255 ! cut off for QC value … … 77 90 INTEGER :: imin0 78 91 INTEGER :: icycle ! Current assimilation cycle 79 ! Counters for observations that 80 INTEGER :: iotdobs ! - outside time domain 81 INTEGER :: iosdsobs ! - outside space domain 82 INTEGER :: ilansobs ! - within a model land cell 83 INTEGER :: inlasobs ! - close to land 84 INTEGER :: igrdobs ! - fail the grid search 85 INTEGER :: ibdysobs ! - close to open boundary 86 ! Global counters for observations that 87 INTEGER :: iotdobsmpp ! - outside time domain 88 INTEGER :: iosdsobsmpp ! - outside space domain 89 INTEGER :: ilansobsmpp ! - within a model land cell 90 INTEGER :: inlasobsmpp ! - close to land 91 INTEGER :: igrdobsmpp ! - fail the grid search 92 INTEGER :: ibdysobsmpp ! - close to open boundary 92 ! Counters for observations that are 93 INTEGER :: iotdobs ! - outside time domain 94 INTEGER, DIMENSION(surfdata%nvar) :: iosdsobs ! - outside space domain 95 INTEGER, DIMENSION(surfdata%nvar) :: ilansobs ! - within a model land cell 96 INTEGER, DIMENSION(surfdata%nvar) :: inlasobs ! - close to land 97 INTEGER, DIMENSION(surfdata%nvar) :: ibdysobs ! - close to open boundary 98 INTEGER :: igrdobs ! - fail the grid search 99 ! Global counters for observations that 100 INTEGER :: iotdobsmpp ! - outside time domain 101 INTEGER, DIMENSION(surfdata%nvar) :: iosdsobsmpp ! - outside space domain 102 INTEGER, DIMENSION(surfdata%nvar) :: ilansobsmpp ! - within a model land cell 103 INTEGER, DIMENSION(surfdata%nvar) :: inlasobsmpp ! - close to land 104 INTEGER, DIMENSION(surfdata%nvar) :: ibdysobsmpp ! - close to open boundary 105 INTEGER :: igrdobsmpp ! - fail the grid search 106 93 107 LOGICAL, DIMENSION(:), ALLOCATABLE :: & 94 108 & llvalid ! SLA data selection 95 INTEGER :: jobs ! Obs. loop variable 109 INTEGER :: jobs ! Obs. loop counter 110 INTEGER :: jvar ! Variable loop counter 96 111 INTEGER :: jstp ! Time loop variable 97 112 INTEGER :: inrc ! Time index variable 113 CHARACTER(LEN=256) :: cout1 ! Diagnostic output line 98 114 !!---------------------------------------------------------------------- 99 115 … … 110 126 icycle = nn_no ! Assimilation cycle 111 127 112 ! Diagno ticscounters for various failures.128 ! Diagnostic counters for various failures. 113 129 114 130 iotdobs = 0 115 131 igrdobs = 0 116 iosdsobs = 0117 ilansobs = 0118 inlasobs = 0119 ibdysobs = 0132 iosdsobs(:) = 0 133 ilansobs(:) = 0 134 inlasobs(:) = 0 135 ibdysobs(:) = 0 120 136 121 137 ! Set QC cutoff to optional value if provided 122 IF ( PRESENT(kqc_cutoff) ) iqc_cutoff =kqc_cutoff138 IF ( PRESENT(kqc_cutoff) ) iqc_cutoff = kqc_cutoff 123 139 124 140 ! ----------------------------------------------------------------------- … … 138 154 ! ----------------------------------------------------------------------- 139 155 140 CALL obs_coo_grd( surfdata%nsurf, surfdata%mi, surfdata%mj, & 141 & surfdata%nqc, igrdobs ) 156 DO jvar = 1, surfdata%nvar 157 CALL obs_coo_grd( surfdata%nsurf, surfdata%mi(:,jvar), & 158 & surfdata%mj(:,jvar), surfdata%nqc, igrdobs ) 159 END DO 142 160 143 161 CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) … … 147 165 ! ----------------------------------------------------------------------- 148 166 149 CALL obs_coo_spc_2d( surfdata%nsurf, & 150 & jpi, jpj, & 151 & surfdata%mi, surfdata%mj, & 152 & surfdata%rlam, surfdata%rphi, & 153 & glamt, gphit, & 154 & tmask(:,:,1), surfdata%nqc, & 155 & iosdsobs, ilansobs, & 156 & inlasobs, ld_nea, & 157 & ibdysobs, ld_bound_reject, & 158 & iqc_cutoff ) 159 160 CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) 161 CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) 162 CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) 163 CALL obs_mpp_sum_integer( ibdysobs, ibdysobsmpp ) 167 DO jvar = 1, surfdata%nvar 168 CALL obs_coo_spc_2d( surfdata%nsurf, & 169 & jpi, jpj, & 170 & surfdata%mi(:,jvar), surfdata%mj(:,jvar), & 171 & surfdata%rlam, surfdata%rphi, & 172 & pglam(:,:,jvar), pgphi(:,:,jvar), & 173 & zmask(:,:,jvar), surfdata%nqc, & 174 & iosdsobs(jvar), ilansobs(jvar), & 175 & inlasobs(jvar), ld_nea, & 176 & ibdysobs(jvar), ld_bound_reject, & 177 & iqc_cutoff ) 178 CALL obs_mpp_sum_integer( iosdsobs(jvar), iosdsobsmpp(jvar) ) 179 CALL obs_mpp_sum_integer( ilansobs(jvar), ilansobsmpp(jvar) ) 180 CALL obs_mpp_sum_integer( inlasobs(jvar), inlasobsmpp(jvar) ) 181 CALL obs_mpp_sum_integer( ibdysobs(jvar), ibdysobsmpp(jvar) ) 182 END DO 164 183 165 184 ! ----------------------------------------------------------------------- … … 191 210 192 211 IF(lwp) THEN 212 DO jvar = 1, surfdataqc%nvar 213 IF ( jvar == 1 ) THEN 214 cout1 = TRIM(surfdataqc%cvars(1)) 215 ELSE 216 WRITE(cout1,'(A,A1,A)') TRIM(cout1), '/', TRIM(surfdataqc%cvars(jvar)) 217 ENDIF 218 END DO 219 193 220 WRITE(numout,*) 194 WRITE(numout,*) ' '// surfdataqc%cvars(1)//' data outside time domain = ', &221 WRITE(numout,*) ' '//TRIM(cout1)//' data outside time domain = ', & 195 222 & iotdobsmpp 196 WRITE(numout,*) ' Remaining '// surfdataqc%cvars(1)//' data that failed grid search = ', &223 WRITE(numout,*) ' Remaining '//TRIM(cout1)//' data that failed grid search = ', & 197 224 & igrdobsmpp 198 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data outside space domain = ', & 199 & iosdsobsmpp 200 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data at land points = ', & 201 & ilansobsmpp 202 IF (ld_nea) THEN 203 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near land points (removed) = ', & 204 & inlasobsmpp 205 ELSE 206 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near land points (kept) = ', & 207 & inlasobsmpp 208 ENDIF 209 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near open boundary (removed) = ', & 210 & ibdysobsmpp 211 WRITE(numout,*) ' '//surfdataqc%cvars(1)//' data accepted = ', & 212 & surfdataqc%nsurfmpp 225 226 DO jvar = 1, surfdataqc%nvar 227 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(jvar)//' data outside space domain = ', & 228 & iosdsobsmpp(jvar) 229 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(jvar)//' data at land points = ', & 230 & ilansobsmpp(jvar) 231 IF (ld_nea) THEN 232 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(jvar)//' data near land points (removed) = ', & 233 & inlasobsmpp(jvar) 234 ELSE 235 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(jvar)//' data near land points (kept) = ', & 236 & inlasobsmpp(jvar) 237 ENDIF 238 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(jvar)//' data near open boundary (removed) = ', & 239 & ibdysobsmpp(jvar) 240 END DO 241 WRITE(numout,*) ' '//TRIM(cout1)//' data accepted = ', & 242 & surfdataqc%nsurfmpp 213 243 214 244 WRITE(numout,*) 215 245 WRITE(numout,*) ' Number of observations per time step :' 216 246 WRITE(numout,*) 217 WRITE(numout,'(10X,A,10X,A)') 'Time step',surfdataqc%cvars(1)218 WRITE(numout,'(10X,A,5X,A)') '---------','-----------------'247 WRITE(numout,'(10X,A,10X,A)') 'Time step', TRIM(cout1) 248 WRITE(numout,'(10X,A,5X,A)') '---------', '-----------------' 219 249 CALL FLUSH(numout) 220 250 ENDIF … … 241 271 242 272 243 SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var 1, ld_var2, &273 SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var, & 244 274 & kpi, kpj, kpk, & 245 & zmask 1, pglam1, pgphi1, zmask2, pglam2, pgphi2, &275 & zmask, pglam, pgphi, & 246 276 & ld_nea, ld_bound_reject, kdailyavtypes, kqc_cutoff ) 247 277 … … 269 299 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data 270 300 TYPE(obs_prof), INTENT(INOUT) :: prodatqc ! Subset of profile data not failing screening 271 LOGICAL, INTENT(IN) :: ld_var1 ! Observed variables switches272 LOGICAL, INTENT(IN) :: ld_var2301 LOGICAL, DIMENSION(profdata%nvar), INTENT(IN) :: & 302 & ld_var ! Observed variables switches 273 303 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 274 304 LOGICAL, INTENT(IN) :: ld_bound_reject ! Switch for rejecting observations near the boundary … … 276 306 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 277 307 & kdailyavtypes ! Types for daily averages 278 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 279 & zmask1, & 280 & zmask2 281 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 282 & pglam1, & 283 & pglam2, & 284 & pgphi1, & 285 & pgphi2 308 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk,profdata%nvar) :: & 309 & zmask 310 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,profdata%nvar) :: & 311 & pglam, & 312 & pgphi 286 313 INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff ! cut off for QC value 287 314 … … 294 321 INTEGER :: imin0 295 322 INTEGER :: icycle ! Current assimilation cycle 296 ! Counters for observations that are 297 INTEGER :: iotdobs ! - outside time domain 298 INTEGER :: iosdv1obs ! - outside space domain (variable 1) 299 INTEGER :: iosdv2obs ! - outside space domain (variable 2) 300 INTEGER :: ilanv1obs ! - within a model land cell (variable 1) 301 INTEGER :: ilanv2obs ! - within a model land cell (variable 2) 302 INTEGER :: inlav1obs ! - close to land (variable 1) 303 INTEGER :: inlav2obs ! - close to land (variable 2) 304 INTEGER :: ibdyv1obs ! - boundary (variable 1) 305 INTEGER :: ibdyv2obs ! - boundary (variable 2) 306 INTEGER :: igrdobs ! - fail the grid search 307 INTEGER :: iuvchku ! - reject u if v rejected and vice versa 308 INTEGER :: iuvchkv ! 309 ! Global counters for observations that are 310 INTEGER :: iotdobsmpp ! - outside time domain 311 INTEGER :: iosdv1obsmpp ! - outside space domain (variable 1) 312 INTEGER :: iosdv2obsmpp ! - outside space domain (variable 2) 313 INTEGER :: ilanv1obsmpp ! - within a model land cell (variable 1) 314 INTEGER :: ilanv2obsmpp ! - within a model land cell (variable 2) 315 INTEGER :: inlav1obsmpp ! - close to land (variable 1) 316 INTEGER :: inlav2obsmpp ! - close to land (variable 2) 317 INTEGER :: ibdyv1obsmpp ! - boundary (variable 1) 318 INTEGER :: ibdyv2obsmpp ! - boundary (variable 2) 319 INTEGER :: igrdobsmpp ! - fail the grid search 320 INTEGER :: iuvchkumpp ! - reject var1 if var2 rejected and vice versa 321 INTEGER :: iuvchkvmpp ! 323 ! Counters for observations that are 324 INTEGER :: iotdobs ! - outside time domain 325 INTEGER, DIMENSION(profdata%nvar) :: iosdvobs ! - outside space domain 326 INTEGER, DIMENSION(profdata%nvar) :: ilanvobs ! - within a model land cell 327 INTEGER, DIMENSION(profdata%nvar) :: inlavobs ! - close to land 328 INTEGER, DIMENSION(profdata%nvar) :: ibdyvobs ! - boundary 329 INTEGER :: igrdobs ! - fail the grid search 330 INTEGER :: iuvchku ! - reject UVEL if VVEL rejected 331 INTEGER :: iuvchkv ! - reject VVEL if UVEL rejected 332 ! Global counters for observations that are 333 INTEGER :: iotdobsmpp ! - outside time domain 334 INTEGER, DIMENSION(profdata%nvar) :: iosdvobsmpp ! - outside space domain 335 INTEGER, DIMENSION(profdata%nvar) :: ilanvobsmpp ! - within a model land cell 336 INTEGER, DIMENSION(profdata%nvar) :: inlavobsmpp ! - close to land 337 INTEGER, DIMENSION(profdata%nvar) :: ibdyvobsmpp ! - boundary 338 INTEGER :: igrdobsmpp ! - fail the grid search 339 INTEGER :: iuvchkumpp ! - reject UVEL if VVEL rejected 340 INTEGER :: iuvchkvmpp ! - reject VVEL if UVEL rejected 341 INTEGER :: iuvar ! - UVEL index 342 INTEGER :: ivvar ! - VVEL index 322 343 TYPE(obs_prof_valid) :: llvalid ! Profile selection 323 344 TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & 324 & llvvalid ! var 1,var2selection345 & llvvalid ! var selection 325 346 INTEGER :: jvar ! Variable loop variable 326 347 INTEGER :: jobs ! Obs. loop variable 327 348 INTEGER :: jstp ! Time loop variable 328 349 INTEGER :: inrc ! Time index variable 350 CHARACTER(LEN=256) :: cout1 ! Diagnostic output line 351 CHARACTER(LEN=256) :: cout2 ! Diagnostic output line 329 352 !!---------------------------------------------------------------------- 330 353 … … 341 364 icycle = nn_no ! Assimilation cycle 342 365 343 ! Diagnotics counters for various failures. 344 345 iotdobs = 0 346 igrdobs = 0 347 iosdv1obs = 0 348 iosdv2obs = 0 349 ilanv1obs = 0 350 ilanv2obs = 0 351 inlav1obs = 0 352 inlav2obs = 0 353 ibdyv1obs = 0 354 ibdyv2obs = 0 355 iuvchku = 0 356 iuvchkv = 0 366 ! Diagnostic counters for various failures. 367 368 iotdobs = 0 369 igrdobs = 0 370 iosdvobs(:) = 0 371 ilanvobs(:) = 0 372 inlavobs(:) = 0 373 ibdyvobs(:) = 0 374 iuvchku = 0 375 iuvchkv = 0 357 376 358 377 359 378 ! Set QC cutoff to optional value if provided 360 IF ( PRESENT(kqc_cutoff) ) iqc_cutoff =kqc_cutoff379 IF ( PRESENT(kqc_cutoff) ) iqc_cutoff = kqc_cutoff 361 380 362 381 ! ----------------------------------------------------------------------- … … 387 406 ! ----------------------------------------------------------------------- 388 407 389 CALL obs_coo_grd( profdata%nprof, profdata%mi(:,1), profdata%mj(:,1), &390 & profdata%nqc, igrdobs )391 CALL obs_coo_grd( profdata%nprof, profdata%mi(:,2), profdata%mj(:,2), &392 & profdata%nqc, igrdobs )408 DO jvar = 1, profdata%nvar 409 CALL obs_coo_grd( profdata%nprof, profdata%mi(:,jvar), profdata%mj(:,jvar), & 410 & profdata%nqc, igrdobs ) 411 END DO 393 412 394 413 CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) … … 405 424 ! ----------------------------------------------------------------------- 406 425 407 ! Variable 1 408 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(1), & 409 & profdata%npvsta(:,1), profdata%npvend(:,1), & 410 & jpi, jpj, & 411 & jpk, & 412 & profdata%mi, profdata%mj, & 413 & profdata%var(1)%mvk, & 414 & profdata%rlam, profdata%rphi, & 415 & profdata%var(1)%vdep, & 416 & pglam1, pgphi1, & 417 & gdept_1d, zmask1, & 418 & profdata%nqc, profdata%var(1)%nvqc, & 419 & iosdv1obs, ilanv1obs, & 420 & inlav1obs, ld_nea, & 421 & ibdyv1obs, ld_bound_reject, & 422 & iqc_cutoff ) 423 424 CALL obs_mpp_sum_integer( iosdv1obs, iosdv1obsmpp ) 425 CALL obs_mpp_sum_integer( ilanv1obs, ilanv1obsmpp ) 426 CALL obs_mpp_sum_integer( inlav1obs, inlav1obsmpp ) 427 CALL obs_mpp_sum_integer( ibdyv1obs, ibdyv1obsmpp ) 428 429 ! Variable 2 430 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(2), & 431 & profdata%npvsta(:,2), profdata%npvend(:,2), & 432 & jpi, jpj, & 433 & jpk, & 434 & profdata%mi, profdata%mj, & 435 & profdata%var(2)%mvk, & 436 & profdata%rlam, profdata%rphi, & 437 & profdata%var(2)%vdep, & 438 & pglam2, pgphi2, & 439 & gdept_1d, zmask2, & 440 & profdata%nqc, profdata%var(2)%nvqc, & 441 & iosdv2obs, ilanv2obs, & 442 & inlav2obs, ld_nea, & 443 & ibdyv2obs, ld_bound_reject, & 444 & iqc_cutoff ) 445 446 CALL obs_mpp_sum_integer( iosdv2obs, iosdv2obsmpp ) 447 CALL obs_mpp_sum_integer( ilanv2obs, ilanv2obsmpp ) 448 CALL obs_mpp_sum_integer( inlav2obs, inlav2obsmpp ) 449 CALL obs_mpp_sum_integer( ibdyv2obs, ibdyv2obsmpp ) 426 DO jvar = 1, profdata%nvar 427 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(jvar), & 428 & profdata%npvsta(:,jvar), profdata%npvend(:,jvar), & 429 & jpi, jpj, & 430 & jpk, & 431 & profdata%mi, profdata%mj, & 432 & profdata%var(jvar)%mvk, & 433 & profdata%rlam, profdata%rphi, & 434 & profdata%var(jvar)%vdep, & 435 & pglam(:,:,jvar), pgphi(:,:,jvar), & 436 & gdept_1d, zmask(:,:,:,jvar), & 437 & profdata%nqc, profdata%var(jvar)%nvqc, & 438 & iosdvobs(jvar), ilanvobs(jvar), & 439 & inlavobs(jvar), ld_nea, & 440 & ibdyvobs(jvar), ld_bound_reject, & 441 & iqc_cutoff ) 442 443 CALL obs_mpp_sum_integer( iosdvobs(jvar), iosdvobsmpp(jvar) ) 444 CALL obs_mpp_sum_integer( ilanvobs(jvar), ilanvobsmpp(jvar) ) 445 CALL obs_mpp_sum_integer( inlavobs(jvar), inlavobsmpp(jvar) ) 446 CALL obs_mpp_sum_integer( ibdyvobs(jvar), ibdyvobsmpp(jvar) ) 447 END DO 450 448 451 449 ! ----------------------------------------------------------------------- … … 453 451 ! ----------------------------------------------------------------------- 454 452 455 IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 456 CALL obs_uv_rej( profdata, iuvchku, iuvchkv, iqc_cutoff ) 453 iuvar = 0 454 ivvar = 0 455 DO jvar = 1,profdata%nvar 456 IF ( TRIM(profdata%cvars(jvar)) == cobsname_uvel ) THEN 457 iuvar = jvar 458 ELSEIF ( TRIM(profdata%cvars(jvar)) == cobsname_vvel ) THEN 459 ivvar = jvar 460 ENDIF 461 END DO 462 IF ( (iuvar > 0) .AND. (ivvar > 0) ) THEN 463 CALL obs_uv_rej( profdata, iuvchku, iuvchkv, iqc_cutoff, iuvar, ivvar ) 457 464 CALL obs_mpp_sum_integer( iuvchku, iuvchkumpp ) 458 465 CALL obs_mpp_sum_integer( iuvchkv, iuvchkvmpp ) … … 498 505 499 506 WRITE(numout,*) 500 WRITE(numout,*) ' Profiles outside time domain = ', &507 WRITE(numout,*) ' Profiles outside time domain = ', & 501 508 & iotdobsmpp 502 WRITE(numout,*) ' Remaining profiles that failed grid search = ', &509 WRITE(numout,*) ' Remaining profiles that failed grid search = ', & 503 510 & igrdobsmpp 504 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data outside space domain = ', & 505 & iosdv1obsmpp 506 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data at land points = ', & 507 & ilanv1obsmpp 508 IF (ld_nea) THEN 509 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (removed) = ',& 510 & inlav1obsmpp 511 ELSE 512 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (kept) = ',& 513 & inlav1obsmpp 514 ENDIF 515 IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 516 WRITE(numout,*) ' U observation rejected since V rejected = ', & 517 & iuvchku 518 ENDIF 519 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near open boundary (removed) = ',& 520 & ibdyv1obsmpp 521 WRITE(numout,*) ' '//prodatqc%cvars(1)//' data accepted = ', & 522 & prodatqc%nvprotmpp(1) 523 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data outside space domain = ', & 524 & iosdv2obsmpp 525 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data at land points = ', & 526 & ilanv2obsmpp 527 IF (ld_nea) THEN 528 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (removed) = ',& 529 & inlav2obsmpp 530 ELSE 531 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (kept) = ',& 532 & inlav2obsmpp 533 ENDIF 534 IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 535 WRITE(numout,*) ' V observation rejected since U rejected = ', & 536 & iuvchkv 537 ENDIF 538 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near open boundary (removed) = ',& 539 & ibdyv2obsmpp 540 WRITE(numout,*) ' '//prodatqc%cvars(2)//' data accepted = ', & 541 & prodatqc%nvprotmpp(2) 511 DO jvar = 1, profdata%nvar 512 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data outside space domain = ', & 513 & iosdvobsmpp(jvar) 514 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data at land points = ', & 515 & ilanvobsmpp(jvar) 516 IF (ld_nea) THEN 517 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (removed) = ', & 518 & inlavobsmpp(jvar) 519 ELSE 520 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (kept) = ', & 521 & inlavobsmpp(jvar) 522 ENDIF 523 IF ( (iuvar > 0) .AND. (ivvar > 0) ) THEN 524 IF ( TRIM(profdata%cvars(jvar)) == cobsname_uvel ) THEN 525 WRITE(numout,*) ' U observation rejected since V rejected = ', & 526 & iuvchku 527 ELSE IF ( TRIM(profdata%cvars(jvar)) == cobsname_vvel ) THEN 528 WRITE(numout,*) ' V observation rejected since U rejected = ', & 529 & iuvchkv 530 ENDIF 531 ENDIF 532 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near open boundary (removed) = ', & 533 & ibdyvobsmpp(jvar) 534 WRITE(numout,*) ' '//prodatqc%cvars(jvar)//' data accepted = ', & 535 & prodatqc%nvprotmpp(jvar) 536 END DO 542 537 543 538 WRITE(numout,*) 544 539 WRITE(numout,*) ' Number of observations per time step :' 545 540 WRITE(numout,*) 546 WRITE(numout,'(10X,A,5X,A,5X,A,A)')'Time step','Profiles', & 547 & ' '//prodatqc%cvars(1)//' ', & 548 & ' '//prodatqc%cvars(2)//' ' 549 WRITE(numout,998) 541 WRITE(cout1,'(10X,A9,5X,A8)') 'Time step', 'Profiles' 542 WRITE(cout2,'(10X,A9,5X,A8)') '---------', '--------' 543 DO jvar = 1, prodatqc%nvar 544 WRITE(cout1,'(A,5X,A11)') TRIM(cout1), TRIM(prodatqc%cvars(jvar)) 545 WRITE(cout2,'(A,5X,A11)') TRIM(cout2), '-----------' 546 END DO 547 WRITE(numout,*) cout1 548 WRITE(numout,*) cout2 550 549 ENDIF 551 550 … … 574 573 DO jstp = nit000 - 1, nitend 575 574 inrc = jstp - nit000 + 2 576 WRITE(numout,999) jstp, prodatqc%npstpmpp(inrc), & 577 & prodatqc%nvstpmpp(inrc,1), & 578 & prodatqc%nvstpmpp(inrc,2) 575 WRITE(cout1,'(10X,I9,5X,I8)') jstp, prodatqc%npstpmpp(inrc) 576 DO jvar = 1, prodatqc%nvar 577 WRITE(cout1,'(A,5X,I11)') TRIM(cout1), prodatqc%nvstpmpp(inrc,jvar) 578 END DO 579 WRITE(numout,*) cout1 579 580 END DO 580 581 ENDIF 581 582 998 FORMAT(10X,'---------',5X,'--------',5X,'-----------',5X,'----------------')583 999 FORMAT(10X,I9,5X,I8,5X,I11,5X,I8)584 582 585 583 END SUBROUTINE obs_pre_prof … … 834 832 !! * Local declarations 835 833 INTEGER :: jobs 836 INTEGER :: iqc_cutoff =255834 INTEGER :: iqc_cutoff = 255 837 835 838 836 !----------------------------------------------------------------------- … … 1122 1120 & gdept_n, & 1123 1121 & ln_zco, & 1124 & ln_zps 1122 & ln_zps, & 1123 & mbkt 1125 1124 1126 1125 !! * Arguments … … 1168 1167 REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask 1169 1168 REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: & 1169 & zgdept, & 1170 1170 & zgdepw 1171 1171 REAL(KIND=wp), DIMENSION(2,2,kprofno) :: & 1172 1172 & zglam, & ! Model longitude at grid points 1173 & zgphi ! Model latitude at grid points 1173 & zgphi, & ! Model latitude at grid points 1174 & zbathy ! Index of deepest wet level at grid points 1174 1175 INTEGER, DIMENSION(2,2,kprofno) :: & 1175 1176 & igrdi, & ! Grid i,j … … 1179 1180 INTEGER :: iig, ijg ! i,j of observation on model grid point. 1180 1181 INTEGER :: jobs, jobsp, jk, ji, jj 1182 REAL(KIND=wp) :: maxdept, maxdepw 1181 1183 !!---------------------------------------------------------------------- 1182 1184 … … 1230 1232 CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, plam, zglam ) 1231 1233 CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, pphi, zgphi ) 1234 CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, REAL(mbkt), zbathy ) 1235 ! Need to know the bathy depth for each observation for sco 1232 1236 CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, gdepw_n(:,:,:), & 1233 & zgdepw ) 1237 & zgdepw ) 1238 CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, gdept_n(:,:,:), & 1239 & zgdept ) 1234 1240 1235 1241 DO jobs = 1, kprofno … … 1267 1273 DO jobsp = kpstart(jobs), kpend(jobs) 1268 1274 1275 ! Calculate max T and W depths of 2x2 grid 1276 maxdept = zgdept(1,1,NINT(zbathy(1,1,jobs)),jobs) 1277 maxdepw = zgdepw(1,1,NINT(zbathy(1,1,jobs))+1,jobs) 1278 DO jj = 1, 2 1279 DO ji = 1, 2 1280 IF ( zgdept(ji,jj,NINT(zbathy(ji,jj,jobs)),jobs) > maxdept ) THEN 1281 maxdept = zgdept(ji,jj,NINT(zbathy(ji,jj,jobs)),jobs) 1282 END IF 1283 IF ( zgdepw(ji,jj,NINT(zbathy(ji,jj,jobs))+1,jobs) > maxdepw ) THEN 1284 maxdepw = zgdepw(ji,jj,NINT(zbathy(ji,jj,jobs))+1,jobs) 1285 END IF 1286 END DO 1287 END DO 1288 1269 1289 ! Flag if the observation falls outside the model spatial domain 1270 IF ( ( pobslam(jobs) < -180. 1271 & .OR. ( pobslam(jobs) > 180. 1272 & .OR. ( pobsphi(jobs) < -90. 1273 & .OR. ( pobsphi(jobs) > 90. 1274 & .OR. ( pobsdep(jobsp) < 0.0 1275 & .OR. ( pobsdep(jobsp) > gdepw_1d(kpk)) ) THEN1290 IF ( ( pobslam(jobs) < -180. ) & 1291 & .OR. ( pobslam(jobs) > 180. ) & 1292 & .OR. ( pobsphi(jobs) < -90. ) & 1293 & .OR. ( pobsphi(jobs) > 90. ) & 1294 & .OR. ( pobsdep(jobsp) < 0.0 ) & 1295 & .OR. ( pobsdep(jobsp) > maxdepw ) ) THEN 1276 1296 kobsqc(jobsp) = IBSET(kobsqc(jobsp),11) 1277 1297 kosdobs = kosdobs + 1 … … 1319 1339 1320 1340 ! Set observation depth equal to that of the first model depth 1321 IF ( pobsdep(jobsp) <= pdep(1) ) THEN 1322 pobsdep(jobsp) = pdep(1) 1323 ENDIF 1341 IF ( pobsdep(jobsp) < MINVAL(zgdept(1:2,1:2,1,jobs) ) ) THEN 1342 pobsdep(jobsp) = MINVAL(zgdept(1:2,1:2,1,jobs)) 1343 ENDIF 1344 1345 ! Set observation depth equal to that of the last wet T-point 1346 IF ( ( pobsdep(jobsp) > maxdept ) .AND. & 1347 & ( pobsdep(jobsp) < maxdepw ) ) THEN 1348 pobsdep(jobsp) = maxdept 1349 END IF 1324 1350 1325 1351 IF (ln_bdy) THEN … … 1395 1421 1396 1422 1397 SUBROUTINE obs_uv_rej( profdata, knumu, knumv, kqc_cutoff )1423 SUBROUTINE obs_uv_rej( profdata, knumu, knumv, kqc_cutoff, kuvar, kvvar ) 1398 1424 !!---------------------------------------------------------------------- 1399 1425 !! *** ROUTINE obs_uv_rej *** … … 1412 1438 INTEGER, INTENT(INOUT) :: knumu ! Number of u rejected 1413 1439 INTEGER, INTENT(INOUT) :: knumv ! Number of v rejected 1414 INTEGER, INTENT(IN) :: kqc_cutoff ! QC cutoff value 1440 INTEGER, INTENT(IN) :: kqc_cutoff ! QC cutoff value 1441 INTEGER, INTENT(IN) :: kuvar ! Index of u 1442 INTEGER, INTENT(IN) :: kvvar ! Index of v 1415 1443 ! 1416 1444 INTEGER :: jprof … … 1421 1449 DO jprof = 1, profdata%nprof !== Loop over profiles ==! 1422 1450 ! 1423 IF ( ( profdata%npvsta(jprof, 1) /= profdata%npvsta(jprof,2) ) .OR. &1424 & ( profdata%npvend(jprof, 1) /= profdata%npvend(jprof,2) ) ) THEN1451 IF ( ( profdata%npvsta(jprof,kuvar) /= profdata%npvsta(jprof,kvvar) ) .OR. & 1452 & ( profdata%npvend(jprof,kuvar) /= profdata%npvend(jprof,kvvar) ) ) THEN 1425 1453 ! 1426 1454 CALL ctl_stop('U,V profiles inconsistent in obs_uv_rej') … … 1429 1457 ENDIF 1430 1458 ! 1431 DO jobs = profdata%npvsta(jprof, 1), profdata%npvend(jprof,1)1459 DO jobs = profdata%npvsta(jprof,kuvar), profdata%npvend(jprof,kuvar) 1432 1460 ! 1433 IF ( ( profdata%var( 1)%nvqc(jobs) > kqc_cutoff ) .AND. &1434 & ( profdata%var( 2)%nvqc(jobs) <= kqc_cutoff) ) THEN1435 profdata%var( 2)%nvqc(jobs) = IBSET(profdata%var(1)%nvqc(jobs),15)1461 IF ( ( profdata%var(kuvar)%nvqc(jobs) > kqc_cutoff ) .AND. & 1462 & ( profdata%var(kvvar)%nvqc(jobs) <= kqc_cutoff) ) THEN 1463 profdata%var(kvvar)%nvqc(jobs) = IBSET(profdata%var(kuvar)%nvqc(jobs),15) 1436 1464 knumv = knumv + 1 1437 1465 ENDIF 1438 IF ( ( profdata%var( 2)%nvqc(jobs) > kqc_cutoff ) .AND. &1439 & ( profdata%var( 1)%nvqc(jobs) <= kqc_cutoff) ) THEN1440 profdata%var( 1)%nvqc(jobs) = IBSET(profdata%var(1)%nvqc(jobs),15)1466 IF ( ( profdata%var(kvvar)%nvqc(jobs) > kqc_cutoff ) .AND. & 1467 & ( profdata%var(kuvar)%nvqc(jobs) <= kqc_cutoff) ) THEN 1468 profdata%var(kuvar)%nvqc(jobs) = IBSET(profdata%var(kuvar)%nvqc(jobs),15) 1441 1469 knumu = knumu + 1 1442 1470 ENDIF -
NEMO/branches/UKMO/NEMO_4.0.4_FOAM_package_generic_obs/src/OCE/OBS/obs_profiles_def.F90
r14075 r15752 43 43 & obs_prof_alloc, & 44 44 & obs_prof_alloc_var, & 45 & obs_prof_alloc_ext, & 45 46 & obs_prof_dealloc, & 46 47 & obs_prof_compress, & 47 48 & obs_prof_decompress,& 48 & obs_prof_staend 49 & obs_prof_staend, & 50 & obs_prof_staend_ext 49 51 50 52 !! * Type definition for valid observations … … 75 77 76 78 REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & 77 & v ext !: Extravariables79 & vadd !: Additional variables 78 80 79 81 INTEGER, POINTER, DIMENSION(:) :: & … … 87 89 END TYPE obs_prof_var 88 90 91 !! * Type definition for extra variables 92 93 TYPE obs_prof_ext 94 95 ! Arrays with size equal to the number of observations 96 97 INTEGER, POINTER, DIMENSION(:) :: & 98 & nepidx,& !: Profile number 99 & nelidx !: Level number in profile 100 101 REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & 102 & eobs !: Profile data 103 104 INTEGER, POINTER, DIMENSION(:) :: & 105 & neind !: Source indices of temp. data in compressed data 106 107 END TYPE obs_prof_ext 108 89 109 !! * Type definition for profile observation type 90 110 … … 94 114 95 115 INTEGER :: nvar !: Number of variables 96 INTEGER :: next !: Number of extra fields 116 INTEGER :: next !: Number of extra variables 117 INTEGER :: nadd !: Number of additional variables 97 118 INTEGER :: nprof !: Total number of profiles within window. 98 119 INTEGER :: nstp !: Number of time steps … … 104 125 ! Bookkeeping arrays with sizes equal to number of variables 105 126 106 CHARACTER(len=8), POINTER, DIMENSION(:) :: & 107 & cvars !: Variable names 127 CHARACTER(len=ilenname), POINTER, DIMENSION(:) :: & 128 & cvars, & !: Variable names 129 & cextvars, & !: Extra variable names 130 & caddvars !: Additional variable names 131 132 CHARACTER(len=ilenlong), POINTER, DIMENSION(:) :: & 133 & clong, & !: Variable long names 134 & cextlong !: Extra variable long names 135 136 CHARACTER(len=ilenlong), POINTER, DIMENSION(:,:) :: & 137 & caddlong !: Additional variable long names 138 139 CHARACTER(len=ilenunit), POINTER, DIMENSION(:) :: & 140 & cunit, & !: Variable units 141 & cextunit !: Extra variable units 142 143 CHARACTER(len=ilenunit), POINTER, DIMENSION(:,:) :: & 144 & caddunit !: Additional variable units 145 146 CHARACTER(len=ilengrid), POINTER, DIMENSION(:) :: & 147 & cgrid !: Variable grids 108 148 109 149 INTEGER, POINTER, DIMENSION(:) :: & 110 & nvprot, & !: Local total number of profile Tdata111 & nvprotmpp !: Global total number of profile Tdata150 & nvprot, & !: Local total number of profile data 151 & nvprotmpp !: Global total number of profile data 112 152 113 153 ! Arrays with size equal to the number of profiles … … 131 171 & rphi !: Latitude coordinate of profile data 132 172 133 CHARACTER(LEN= 8), POINTER, DIMENSION(:) :: &173 CHARACTER(LEN=ilenwmo), POINTER, DIMENSION(:) :: & 134 174 & cwmo !: Profile WMO indentifier 135 175 … … 140 180 & npvsta, & !: Start of each variable profile in full arrays 141 181 & npvend, & !: End of each variable profile in full arrays 142 & mi, & !: i-th grid coord. for interpolating to profile Tdata143 & mj, & !: j-th grid coord. for interpolating to profile Tdata182 & mi, & !: i-th grid coord. for interpolating to profile data 183 & mj, & !: j-th grid coord. for interpolating to profile data 144 184 & ivqc !: QC flags for all levels for a variable 145 185 … … 160 200 TYPE(obs_prof_var), POINTER, DIMENSION(:) :: var 161 201 202 ! Extra variables 203 204 TYPE(obs_prof_ext) :: vext 205 206 INTEGER :: nvprotext !: Local total number of extra variable profile data 207 208 INTEGER, POINTER, DIMENSION(:) :: & 209 & npvstaext, & !: Start of extra variable profiles in full arrays 210 & npvendext !: End of extra variable profiles in full arrays 211 162 212 ! Arrays with size equal to the number of time steps in the window 163 213 … … 197 247 CONTAINS 198 248 199 SUBROUTINE obs_prof_alloc( prof, kvar, k ext, kprof, &200 & ko3dt, k stp, kpi, kpj, kpk )249 SUBROUTINE obs_prof_alloc( prof, kvar, kadd, kext, kprof, & 250 & ko3dt, ke3dt, kstp, kpi, kpj, kpk ) 201 251 !!---------------------------------------------------------------------- 202 252 !! *** ROUTINE obs_prof_alloc *** … … 214 264 INTEGER, INTENT(IN) :: kprof ! Number of profiles 215 265 INTEGER, INTENT(IN) :: kvar ! Number of variables 216 INTEGER, INTENT(IN) :: kext ! Number of extra fields within each variable 266 INTEGER, INTENT(IN) :: kadd ! Number of additional fields within each variable 267 INTEGER, INTENT(IN) :: kext ! Number of extra fields 217 268 INTEGER, INTENT(IN), DIMENSION(kvar) :: & 218 269 & ko3dt ! Number of observations per variables 270 INTEGER, INTENT(IN) :: ke3dt ! Number of observations per extra variables 219 271 INTEGER, INTENT(IN) :: kstp ! Number of time steps 220 272 INTEGER, INTENT(IN) :: kpi ! Number of 3D grid points … … 223 275 224 276 !!* Local variables 225 INTEGER :: jvar 277 INTEGER :: jvar, jadd, jext 226 278 INTEGER :: ji 227 279 … … 229 281 230 282 prof%nvar = kvar 283 prof%nadd = kadd 231 284 prof%next = kext 232 285 prof%nprof = kprof … … 241 294 ALLOCATE( & 242 295 & prof%cvars(kvar), & 296 & prof%clong(kvar), & 297 & prof%cunit(kvar), & 298 & prof%cgrid(kvar), & 243 299 & prof%nvprot(kvar), & 244 300 & prof%nvprotmpp(kvar) & … … 247 303 DO jvar = 1, kvar 248 304 prof%cvars (jvar) = "NotSet" 305 prof%clong (jvar) = "NotSet" 306 prof%cunit (jvar) = "NotSet" 307 prof%cgrid (jvar) = "" 249 308 prof%nvprot (jvar) = ko3dt(jvar) 250 309 prof%nvprotmpp(jvar) = 0 310 END DO 311 312 ! Allocate additional/extra variable metadata 313 314 ALLOCATE( & 315 & prof%caddvars(kadd), & 316 & prof%caddlong(kadd,kvar), & 317 & prof%caddunit(kadd,kvar), & 318 & prof%cextvars(kext), & 319 & prof%cextlong(kext), & 320 & prof%cextunit(kext) & 321 ) 322 323 DO jadd = 1, kadd 324 prof%caddvars(jadd) = "NotSet" 325 DO jvar = 1, kvar 326 prof%caddlong(jadd,jvar) = "NotSet" 327 prof%caddunit(jadd,jvar) = "NotSet" 328 END DO 329 END DO 330 331 DO jext = 1, kext 332 prof%cextvars(jext) = "NotSet" 333 prof%cextlong(jext) = "NotSet" 334 prof%cextunit(jext) = "NotSet" 251 335 END DO 252 336 … … 306 390 307 391 DO jvar = 1, kvar 308 309 392 IF ( ko3dt(jvar) >= 0 ) THEN 310 CALL obs_prof_alloc_var( prof, jvar, k ext, ko3dt(jvar) )393 CALL obs_prof_alloc_var( prof, jvar, kadd, ko3dt(jvar) ) 311 394 ENDIF 312 313 END DO 395 END DO 396 397 ! Extra variables 398 399 IF ( kext > 0 ) THEN 400 prof%nvprotext = ke3dt 401 ALLOCATE( & 402 & prof%npvstaext(kprof), & 403 & prof%npvendext(kprof) ) 404 CALL obs_prof_alloc_ext( prof, kext, ke3dt ) 405 ELSE 406 prof%nvprotext = 0 407 ENDIF 314 408 315 409 ! Allocate arrays of size number of time step size … … 346 440 END DO 347 441 END DO 442 443 IF ( kext > 0 ) THEN 444 DO ji = 1, ke3dt 445 prof%vext%neind(ji) = ji 446 END DO 447 ENDIF 348 448 349 449 ! Set defaults for number of observations per time step … … 377 477 !!* Local variables 378 478 INTEGER :: & 379 & jvar 479 & jvar, & 480 & jext 380 481 381 482 ! Deallocate arrays of size number of profiles … … 418 519 419 520 DO jvar = 1, prof%nvar 420 421 521 IF ( prof%nvprot(jvar) >= 0 ) THEN 422 423 522 CALL obs_prof_dealloc_var( prof, jvar ) 424 425 523 ENDIF 426 427 524 END DO 428 525 … … 432 529 & ) 433 530 531 ! Deallocate extra variables 532 IF ( prof%next > 0 ) THEN 533 DEALLOCATE( & 534 & prof%npvstaext, & 535 & prof%npvendext & 536 ) 537 CALL obs_prof_dealloc_ext( prof ) 538 ENDIF 539 434 540 ! Deallocate arrays of size number of time step size 435 541 … … 458 564 DEALLOCATE( & 459 565 & prof%cvars, & 566 & prof%clong, & 567 & prof%cunit, & 568 & prof%cgrid, & 460 569 & prof%nvprot, & 461 570 & prof%nvprotmpp & 462 571 ) 463 572 573 ! Dellocate additional/extra variables metadata 574 575 DEALLOCATE( & 576 & prof%caddvars, & 577 & prof%caddlong, & 578 & prof%caddunit, & 579 & prof%cextvars, & 580 & prof%cextlong, & 581 & prof%cextunit & 582 ) 464 583 465 584 END SUBROUTINE obs_prof_dealloc 466 585 467 586 468 SUBROUTINE obs_prof_alloc_var( prof, kvar, k ext, kobs )587 SUBROUTINE obs_prof_alloc_var( prof, kvar, kadd, kobs ) 469 588 470 589 !!---------------------------------------------------------------------- … … 480 599 TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be allocated 481 600 INTEGER, INTENT(IN) :: kvar ! Variable number 482 INTEGER, INTENT(IN) :: k ext ! Number of extrafields within each variable601 INTEGER, INTENT(IN) :: kadd ! Number of additional fields within each variable 483 602 INTEGER, INTENT(IN) :: kobs ! Number of observations 484 603 … … 498 617 & prof%var(kvar)%nvqcf(idefnqcf,kobs) & 499 618 & ) 500 IF (k ext>0) THEN619 IF (kadd>0) THEN 501 620 ALLOCATE( & 502 & prof%var(kvar)%v ext(kobs,kext) &621 & prof%var(kvar)%vadd(kobs,kadd) & 503 622 & ) 504 623 ENDIF … … 506 625 END SUBROUTINE obs_prof_alloc_var 507 626 627 508 628 SUBROUTINE obs_prof_dealloc_var( prof, kvar ) 509 629 510 630 !!---------------------------------------------------------------------- 511 !! *** ROUTINE obs_prof_ alloc_var ***631 !! *** ROUTINE obs_prof_dealloc_var *** 512 632 !! 513 !! ** Purpose : - Allocate data for variable data in profile arrays633 !! ** Purpose : - Deallocate data for variable data in profile arrays 514 634 !! 515 635 !! ** Method : - Fortran-90 dynamic arrays … … 518 638 !! ! 07-03 (K. Mogensen) Original code 519 639 !! * Arguments 520 TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be allocated640 TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be deallocated 521 641 INTEGER, INTENT(IN) :: kvar ! Variable number 522 642 … … 534 654 & prof%var(kvar)%nvqcf & 535 655 & ) 536 IF (prof%n ext>0) THEN656 IF (prof%nadd>0) THEN 537 657 DEALLOCATE( & 538 & prof%var(kvar)%v ext&658 & prof%var(kvar)%vadd & 539 659 & ) 540 660 ENDIF … … 542 662 END SUBROUTINE obs_prof_dealloc_var 543 663 664 665 SUBROUTINE obs_prof_alloc_ext( prof, kext, kobs ) 666 667 !!---------------------------------------------------------------------- 668 !! *** ROUTINE obs_prof_alloc_ext *** 669 !! 670 !! ** Purpose : - Allocate data for extra variables in profile arrays 671 !! 672 !! ** Method : - Fortran-90 dynamic arrays 673 !! 674 !! History : 675 !! ! 07-03 (K. Mogensen) Original code 676 !! * Arguments 677 TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be allocated 678 INTEGER, INTENT(IN) :: kext ! Number of extra variables 679 INTEGER, INTENT(IN) :: kobs ! Number of observations 680 681 ALLOCATE( & 682 & prof%vext%nepidx(kobs), & 683 & prof%vext%nelidx(kobs), & 684 & prof%vext%neind(kobs), & 685 & prof%vext%eobs(kobs,kext) & 686 & ) 687 688 END SUBROUTINE obs_prof_alloc_ext 689 690 691 SUBROUTINE obs_prof_dealloc_ext( prof ) 692 693 !!---------------------------------------------------------------------- 694 !! *** ROUTINE obs_prof_dealloc_var *** 695 !! 696 !! ** Purpose : - Deallocate data for extra variables in profile arrays 697 !! 698 !! ** Method : - Fortran-90 dynamic arrays 699 !! 700 !! History : 701 !! ! 07-03 (K. Mogensen) Original code 702 !! * Arguments 703 TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be deallocated 704 705 DEALLOCATE( & 706 & prof%vext%nepidx, & 707 & prof%vext%nelidx, & 708 & prof%vext%eobs, & 709 & prof%vext%neind & 710 & ) 711 712 END SUBROUTINE obs_prof_dealloc_ext 713 714 544 715 SUBROUTINE obs_prof_compress( prof, newprof, lallocate, & 545 & kumout, lvalid, 716 & kumout, lvalid, lvvalid ) 546 717 !!---------------------------------------------------------------------- 547 718 !! *** ROUTINE obs_prof_compress *** … … 564 735 TYPE(obs_prof), INTENT(IN) :: prof ! Original profile 565 736 TYPE(obs_prof), INTENT(INOUT) :: newprof ! New profile with the copy of the data 566 LOGICAL :: lallocate! Allocate newprof data567 INTEGER, INTENT(IN) :: kumout! Fortran unit for messages737 LOGICAL, INTENT(IN) :: lallocate ! Allocate newprof data 738 INTEGER, INTENT(IN) :: kumout ! Fortran unit for messages 568 739 TYPE(obs_prof_valid), OPTIONAL, INTENT(in) :: & 569 740 & lvalid ! Valid profiles … … 575 746 INTEGER, DIMENSION(prof%nvar) :: & 576 747 & invpro 748 INTEGER :: invproext 577 749 INTEGER :: jvar 750 INTEGER :: jadd 578 751 INTEGER :: jext 579 752 INTEGER :: ji … … 587 760 LOGICAL :: lnonepresent 588 761 589 ! Check that either all or none of the masks are p ersent.762 ! Check that either all or none of the masks are present. 590 763 591 764 lallpresent = .FALSE. … … 607 780 inprof = 0 608 781 invpro(:) = 0 782 invproext = 0 609 783 DO ji = 1, prof%nprof 610 784 IF ( lvalid%luse(ji) ) THEN 611 inprof =inprof+1785 inprof = inprof + 1 612 786 DO jvar = 1, prof%nvar 613 787 DO jj = prof%npvsta(ji,jvar), prof%npvend(ji,jvar) … … 616 790 END DO 617 791 END DO 792 IF ( prof%next > 0 ) THEN 793 DO jj = prof%npvstaext(ji), prof%npvendext(ji) 794 invproext = invproext + 1 795 END DO 796 ENDIF 618 797 ENDIF 619 798 END DO … … 621 800 inprof = prof%nprof 622 801 invpro(:) = prof%nvprot(:) 802 invproext = prof%nvprotext 623 803 ENDIF 624 804 … … 627 807 IF ( lallocate ) THEN 628 808 CALL obs_prof_alloc( newprof, prof%nvar, & 629 & prof%n ext,&809 & prof%nadd, prof%next, & 630 810 & inprof, invpro, & 811 & invproext, & 631 812 & prof%nstp, prof%npi, & 632 813 & prof%npj, prof%npk ) … … 655 836 inprof = 0 656 837 invpro(:) = 0 657 658 newprof%npvsta(:,:) = 0 659 newprof%npvend(:,:) = -1 838 invproext = 0 839 840 newprof%npvsta(:,:) = 0 841 newprof%npvend(:,:) = -1 842 newprof%npvstaext(:) = 0 843 newprof%npvendext(:) = -1 660 844 661 845 ! Loop over source profiles … … 670 854 671 855 newprof%mi(inprof,:) = prof%mi(ji,:) 672 newprof%mj(inprof,:) = prof%mj(ji,:)856 newprof%mj(inprof,:) = prof%mj(ji,:) 673 857 newprof%npidx(inprof) = prof%npidx(ji) 674 858 newprof%npfil(inprof) = prof%npfil(ji) … … 741 925 newprof%var(jvar)%vmod(invpro(jvar)) = & 742 926 & prof%var(jvar)%vmod(jj) 743 DO j ext = 1, prof%next744 newprof%var(jvar)%v ext(invpro(jvar),jext) = &745 & prof%var(jvar)%v ext(jj,jext)927 DO jadd = 1, prof%nadd 928 newprof%var(jvar)%vadd(invpro(jvar),jadd) = & 929 & prof%var(jvar)%vadd(jj,jadd) 746 930 END DO 747 931 … … 756 940 END DO 757 941 942 IF ( prof%next > 0 ) THEN 943 944 ! Extra variables 945 946 lfirst = .TRUE. 947 948 DO jj = prof%npvstaext(ji), prof%npvendext(ji) 949 950 invproext = invproext + 1 951 952 ! Book keeping information 953 954 IF ( lfirst ) THEN 955 lfirst = .FALSE. 956 newprof%npvstaext(inprof) = invproext 957 ENDIF 958 newprof%npvendext(inprof) = invproext 959 960 ! Variable data 961 962 newprof%vext%nepidx(invproext) = prof%vext%nepidx(jj) 963 newprof%vext%nelidx(invproext) = prof%vext%nelidx(jj) 964 DO jext = 1, prof%next 965 newprof%vext%eobs(invproext,jext) = prof%vext%eobs(jj,jext) 966 END DO 967 968 ! nvind is the index of the original variable data 969 970 newprof%vext%neind(invproext) = jj 971 972 END DO 973 974 ENDIF 975 758 976 ENDIF 759 977 … … 767 985 CALL obs_mpp_sum_integers ( newprof%nvprot, newprof%nvprotmpp,& 768 986 & prof%nvar ) 987 newprof%nvprotext = invproext 769 988 770 989 ! Set book keeping variables which do not depend on number of obs. 771 990 772 991 newprof%nvar = prof%nvar 992 newprof%nadd = prof%nadd 773 993 newprof%next = prof%next 774 994 newprof%nstp = prof%nstp … … 777 997 newprof%npk = prof%npk 778 998 newprof%cvars(:) = prof%cvars(:) 999 newprof%clong(:) = prof%clong(:) 1000 newprof%cunit(:) = prof%cunit(:) 1001 newprof%cgrid(:) = prof%cgrid(:) 1002 newprof%caddvars(:) = prof%caddvars(:) 1003 newprof%caddlong(:,:) = prof%caddlong(:,:) 1004 newprof%caddunit(:,:) = prof%caddunit(:,:) 1005 newprof%cextvars(:) = prof%cextvars(:) 1006 newprof%cextlong(:) = prof%cextlong(:) 1007 newprof%cextunit(:) = prof%cextunit(:) 779 1008 780 1009 ! Deallocate temporary data … … 810 1039 !!* Local variables 811 1040 INTEGER :: jvar 1041 INTEGER :: jadd 812 1042 INTEGER :: jext 813 1043 INTEGER :: ji … … 866 1096 oldprof%var(jvar)%idqcf(:,jl) = prof%var(jvar)%idqcf(:,jj) 867 1097 oldprof%var(jvar)%nvqcf(:,jl) = prof%var(jvar)%nvqcf(:,jj) 868 DO j ext = 1, prof%next869 oldprof%var(jvar)%v ext(jl,jext) = &870 & prof%var(jvar)%v ext(jj,jext)1098 DO jadd = 1, prof%nadd 1099 oldprof%var(jvar)%vadd(jl,jadd) = & 1100 & prof%var(jvar)%vadd(jj,jadd) 871 1101 END DO 872 1102 … … 874 1104 875 1105 END DO 1106 1107 IF ( prof%next > 0 ) THEN 1108 1109 DO jj = prof%npvstaext(ji), prof%npvendext(ji) 1110 1111 jl = prof%vext%neind(jj) 1112 1113 oldprof%vext%nepidx(jl) = prof%vext%nepidx(jj) 1114 oldprof%vext%nelidx(jl) = prof%vext%nelidx(jj) 1115 DO jext = 1, prof%next 1116 oldprof%vext%eobs(jl,jext) = prof%vext%eobs(jj,jext) 1117 END DO 1118 1119 END DO 1120 1121 ENDIF 876 1122 877 1123 END DO … … 883 1129 END SUBROUTINE obs_prof_decompress 884 1130 1131 885 1132 SUBROUTINE obs_prof_staend( prof, kvarno ) 886 1133 !!---------------------------------------------------------------------- 887 !! *** ROUTINE obs_prof_ decompress***1134 !! *** ROUTINE obs_prof_staend *** 888 1135 !! 889 1136 !! ** Purpose : - Set npvsta and npvend of a variable within … … 924 1171 925 1172 END SUBROUTINE obs_prof_staend 1173 1174 1175 SUBROUTINE obs_prof_staend_ext( prof ) 1176 !!---------------------------------------------------------------------- 1177 !! *** ROUTINE obs_prof_staend_ext *** 1178 !! 1179 !! ** Purpose : - Set npvsta and npvend within 1180 !! an obs_prof_ext type 1181 !! 1182 !! ** Method : - Find the start and stop of a profile by searching 1183 !! through the data 1184 !! 1185 !! History : 1186 !! ! 07-04 (K. Mogensen) Original code 1187 !!---------------------------------------------------------------------- 1188 !! * Arguments 1189 TYPE(obs_prof),INTENT(INOUT) :: prof ! Profile data 1190 1191 !!* Local variables 1192 INTEGER :: ji 1193 INTEGER :: iprofno 1194 1195 !----------------------------------------------------------------------- 1196 ! Compute start and end bookkeeping arrays 1197 !----------------------------------------------------------------------- 1198 1199 prof%npvstaext(:) = prof%nvprotext + 1 1200 prof%npvendext(:) = -1 1201 DO ji = 1, prof%nvprotext 1202 iprofno = prof%vext%nepidx(ji) 1203 prof%npvstaext(iprofno) = & 1204 & MIN( ji, prof%npvstaext(iprofno) ) 1205 prof%npvendext(iprofno) = & 1206 & MAX( ji, prof%npvendext(iprofno) ) 1207 END DO 1208 1209 DO ji = 1, prof%nprof 1210 IF ( prof%npvstaext(ji) == ( prof%nvprotext + 1 ) ) & 1211 & prof%npvstaext(ji) = 0 1212 END DO 1213 1214 END SUBROUTINE obs_prof_staend_ext 926 1215 927 1216 END MODULE obs_profiles_def -
NEMO/branches/UKMO/NEMO_4.0.4_FOAM_package_generic_obs/src/OCE/OBS/obs_read_altbias.F90
r14075 r15752 116 116 numaltbias=0 117 117 118 IF (lwp)WRITE(numout,*) 'Opening ',bias_file118 IF (lwp) WRITE(numout,*) 'Opening ', bias_file 119 119 120 120 CALL iom_open( bias_file, numaltbias, ldstop=.FALSE. ) -
NEMO/branches/UKMO/NEMO_4.0.4_FOAM_package_generic_obs/src/OCE/OBS/obs_read_prof.F90
r14075 r15752 27 27 USE lib_mpp ! For ctl_warn/stop 28 28 USE obs_fbm ! Feedback routines 29 USE obs_group_def, ONLY : & ! Observation variable information 30 & cobsname_uvel, & 31 & cobsname_vvel, & 32 & imaxavtypes 29 33 30 34 IMPLICIT NONE … … 44 48 45 49 SUBROUTINE obs_rea_prof( profdata, knumfiles, cdfilenames, & 46 & kvars, k extr, kstp, ddobsini, ddobsend, &47 & ldvar 1, ldvar2, ldignmis, ldsatt, &48 & ldmod, kdailyavtypes )50 & kvars, kadd, kextr, kstp, ddobsini, ddobsend, & 51 & ldvar, ldignmis, ldallatall, & 52 & ldmod, cdvars, kdailyavtypes ) 49 53 !!--------------------------------------------------------------------- 50 54 !! … … 72 76 & cdfilenames(knumfiles) ! File names to read in 73 77 INTEGER, INTENT(IN) :: kvars ! Number of variables in profdata 74 INTEGER, INTENT(IN) :: kextr ! Number of extra fields for each var 78 INTEGER, INTENT(IN) :: kadd ! Number of additional fields 79 ! in addition to those in the input file(s) 80 INTEGER, INTENT(IN) :: kextr ! Number of extra fields 81 ! in addition to those in the input file(s) 75 82 INTEGER, INTENT(IN) :: kstp ! Ocean time-step index 76 LOGICAL, INTENT(IN) :: ldvar1 ! Observed variables switches 77 LOGICAL, INTENT(IN) :: ldvar2 83 LOGICAL, DIMENSION(kvars), INTENT(IN) :: ldvar ! Observed variables switches 78 84 LOGICAL, INTENT(IN) :: ldignmis ! Ignore missing files 79 LOGICAL, INTENT(IN) :: ld satt! Compute salinity at all temperature points85 LOGICAL, INTENT(IN) :: ldallatall ! Compute salinity at all temperature points 80 86 LOGICAL, INTENT(IN) :: ldmod ! Initialize model from input data 81 87 REAL(dp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS 82 88 REAL(dp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS 89 CHARACTER(len=8), DIMENSION(kvars), INTENT(IN) :: cdvars 83 90 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 84 91 & kdailyavtypes ! Types of daily average observations … … 87 94 CHARACTER(LEN=15), PARAMETER :: cpname='obs_rea_prof' 88 95 CHARACTER(len=8) :: clrefdate 89 CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvars 90 INTEGER :: jvar 96 CHARACTER(len=ilenname), DIMENSION(:), ALLOCATABLE :: clvarsin 97 CHARACTER(len=ilenlong), DIMENSION(:), ALLOCATABLE :: cllongin 98 CHARACTER(len=ilenunit), DIMENSION(:), ALLOCATABLE :: clunitin 99 CHARACTER(len=ilengrid), DIMENSION(:), ALLOCATABLE :: clgridin 100 CHARACTER(len=ilenname), DIMENSION(:), ALLOCATABLE :: claddvarsin 101 CHARACTER(len=ilenlong), DIMENSION(:,:), ALLOCATABLE :: claddlongin 102 CHARACTER(len=ilenunit), DIMENSION(:,:), ALLOCATABLE :: claddunitin 103 CHARACTER(len=ilenname), DIMENSION(:), ALLOCATABLE :: clextvarsin 104 CHARACTER(len=ilenlong), DIMENSION(:), ALLOCATABLE :: clextlongin 105 CHARACTER(len=ilenunit), DIMENSION(:), ALLOCATABLE :: clextunitin 91 106 INTEGER :: ji 92 107 INTEGER :: jj 93 108 INTEGER :: jk 94 109 INTEGER :: ij 110 INTEGER :: jind 111 INTEGER :: jext 112 INTEGER :: jvar 113 INTEGER :: jadd 114 INTEGER :: jadd2 115 INTEGER :: iadd 116 INTEGER :: iaddin 117 INTEGER :: iextr 95 118 INTEGER :: iflag 96 119 INTEGER :: inobf … … 105 128 INTEGER :: iprof 106 129 INTEGER :: iproftot 107 INTEGER :: ivar1t0 108 INTEGER :: ivar2t0 109 INTEGER :: ivar1t 110 INTEGER :: ivar2t 130 INTEGER, DIMENSION(kvars) :: ivart0 131 INTEGER, DIMENSION(kvars) :: ivart 111 132 INTEGER :: ip3dt 112 133 INTEGER :: ios 113 134 INTEGER :: ioserrcount 114 INTEGER :: ivar1tmpp 115 INTEGER :: ivar2tmpp 135 INTEGER, DIMENSION(kvars) :: ivartmpp 116 136 INTEGER :: ip3dtmpp 117 137 INTEGER :: itype 118 138 INTEGER, DIMENSION(knumfiles) :: & 119 139 & irefdate 120 INTEGER, DIMENSION(ntyp1770+1) :: & 121 & itypvar1, & 122 & itypvar1mpp, & 123 & itypvar2, & 124 & itypvar2mpp 140 INTEGER, DIMENSION(ntyp1770+1,kvars) :: & 141 & itypvar, & 142 & itypvarmpp 143 INTEGER, DIMENSION(:,:), ALLOCATABLE :: & 144 & iobsi, & 145 & iobsj, & 146 & iproc 125 147 INTEGER, DIMENSION(:), ALLOCATABLE :: & 126 & iobsi1, &127 & iobsj1, &128 & iproc1, &129 & iobsi2, &130 & iobsj2, &131 & iproc2, &132 148 & iindx, & 133 149 & ifileidx, & … … 147 163 LOGICAL :: llvalprof 148 164 LOGICAL :: lldavtimset 165 LOGICAL :: llcycle 166 LOGICAL :: llpotm 149 167 TYPE(obfbdata), POINTER, DIMENSION(:) :: & 150 168 & inpfiles … … 152 170 ! Local initialization 153 171 iprof = 0 154 ivar1t0 = 0 155 ivar2t0 = 0 172 ivart0(:) = 0 156 173 ip3dt = 0 157 174 … … 172 189 173 190 ALLOCATE( inpfiles(inobf) ) 191 192 iadd = 0 193 iextr = 0 174 194 175 195 prof_files : DO jj = 1, inobf … … 219 239 & ldgrid = .TRUE. ) 220 240 221 IF ( inpfiles(jj)%nvar < 2) THEN241 IF ( inpfiles(jj)%nvar /= kvars ) THEN 222 242 CALL ctl_stop( 'Feedback format error: ', & 223 & ' less than 2 vars in profile file' ) 243 & ' unexpected number of vars in feedback file', & 244 & TRIM(cdfilenames(jj)) ) 224 245 ENDIF 225 246 226 247 IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN 227 CALL ctl_stop( 'Model not in input data' ) 248 CALL ctl_stop( 'Model not in input data in', & 249 & TRIM(cdfilenames(jj)) ) 250 RETURN 251 ENDIF 252 253 IF ( (iextr > 0) .AND. (inpfiles(jj)%next /= iextr) ) THEN 254 CALL ctl_stop( 'Number of extra variables not consistent', & 255 & ' with previous files for this type in', & 256 & TRIM(cdfilenames(jj)) ) 257 ELSE 258 iextr = inpfiles(jj)%next 259 ENDIF 260 261 ! Ignore model counterpart 262 iaddin = inpfiles(jj)%nadd 263 DO ji = 1, iaddin 264 IF ( TRIM(inpfiles(jj)%caddname(ji)) == 'Hx' ) THEN 265 iaddin = iaddin - 1 266 EXIT 267 ENDIF 268 END DO 269 IF ( ldmod .AND. ( inpfiles(jj)%nadd == iaddin ) ) THEN 270 CALL ctl_stop( 'Model not in input data', & 271 & TRIM(cdfilenames(jj)) ) 272 ENDIF 273 274 IF ( (iadd > 0) .AND. (iaddin /= iadd) ) THEN 275 CALL ctl_stop( 'Number of additional variables not consistent', & 276 & ' with previous files for this type in', & 277 & TRIM(cdfilenames(jj)) ) 278 ELSE 279 iadd = iaddin 228 280 ENDIF 229 281 230 282 IF ( jj == 1 ) THEN 231 ALLOCATE( clvars( inpfiles(jj)%nvar ) ) 283 ALLOCATE( clvarsin( inpfiles(jj)%nvar ) ) 284 ALLOCATE( cllongin( inpfiles(jj)%nvar ) ) 285 ALLOCATE( clunitin( inpfiles(jj)%nvar ) ) 286 ALLOCATE( clgridin( inpfiles(jj)%nvar ) ) 232 287 DO ji = 1, inpfiles(jj)%nvar 233 clvars(ji) = inpfiles(jj)%cname(ji) 288 clvarsin(ji) = inpfiles(jj)%cname(ji) 289 cllongin(ji) = inpfiles(jj)%coblong(ji) 290 clunitin(ji) = inpfiles(jj)%cobunit(ji) 291 clgridin(ji) = inpfiles(jj)%cgrid(ji) 292 IF ( clvarsin(ji) /= cdvars(ji) ) THEN 293 CALL ctl_stop( 'Feedback file variables do not match', & 294 & ' expected variable names for this type' ) 295 ENDIF 234 296 END DO 297 IF ( iadd > 0 ) THEN 298 ALLOCATE( claddvarsin( iadd ) ) 299 ALLOCATE( claddlongin( iadd, inpfiles(jj)%nvar ) ) 300 ALLOCATE( claddunitin( iadd, inpfiles(jj)%nvar ) ) 301 jadd = 0 302 DO ji = 1, inpfiles(jj)%nadd 303 IF ( TRIM(inpfiles(jj)%caddname(ji)) /= 'Hx' ) THEN 304 jadd = jadd + 1 305 claddvarsin(jadd) = inpfiles(jj)%caddname(ji) 306 DO jk = 1, inpfiles(jj)%nvar 307 claddlongin(jadd,jk) = inpfiles(jj)%caddlong(ji,jk) 308 claddunitin(jadd,jk) = inpfiles(jj)%caddunit(ji,jk) 309 END DO 310 ENDIF 311 END DO 312 ENDIF 313 IF ( iextr > 0 ) THEN 314 ALLOCATE( clextvarsin( iextr ) ) 315 ALLOCATE( clextlongin( iextr ) ) 316 ALLOCATE( clextunitin( iextr ) ) 317 DO ji = 1, iextr 318 clextvarsin(ji) = inpfiles(jj)%cextname(ji) 319 clextlongin(ji) = inpfiles(jj)%cextlong(ji) 320 clextunitin(ji) = inpfiles(jj)%cextunit(ji) 321 END DO 322 ENDIF 235 323 ELSE 236 324 DO ji = 1, inpfiles(jj)%nvar 237 IF ( inpfiles(jj)%cname(ji) /= clvars (ji) ) THEN325 IF ( inpfiles(jj)%cname(ji) /= clvarsin(ji) ) THEN 238 326 CALL ctl_stop( 'Feedback file variables not consistent', & 239 & ' with previous files for this type' ) 327 & ' with previous files for this type in', & 328 & TRIM(cdfilenames(jj)) ) 240 329 ENDIF 241 330 END DO 331 IF ( iadd > 0 ) THEN 332 jadd = 0 333 DO ji = 1, inpfiles(jj)%nadd 334 IF ( TRIM(inpfiles(jj)%caddname(ji)) /= 'Hx' ) THEN 335 jadd = jadd + 1 336 IF ( inpfiles(jj)%caddname(ji) /= claddvarsin(jadd) ) THEN 337 CALL ctl_stop( 'Feedback file additional variables not consistent', & 338 & ' with previous files for this type in', & 339 & TRIM(cdfilenames(jj)) ) 340 ENDIF 341 ENDIF 342 END DO 343 ENDIF 344 IF ( iextr > 0 ) THEN 345 DO ji = 1, iextr 346 IF ( inpfiles(jj)%cextname(ji) /= clextvarsin(ji) ) THEN 347 CALL ctl_stop( 'Feedback file extra variables not consistent', & 348 & ' with previous files for this type in', & 349 & TRIM(cdfilenames(jj)) ) 350 ENDIF 351 END DO 352 ENDIF 242 353 ENDIF 243 354 … … 308 419 DO ji = 1, inpfiles(jj)%nobs 309 420 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 421 llcycle = .TRUE. 422 DO jvar = 1, kvars 423 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 424 llcycle = .FALSE. 425 EXIT 426 ENDIF 427 END DO 428 IF ( llcycle ) CYCLE 312 429 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 313 430 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 317 434 ALLOCATE( zlam(inowin) ) 318 435 ALLOCATE( zphi(inowin) ) 319 ALLOCATE( iobsi1(inowin) ) 320 ALLOCATE( iobsj1(inowin) ) 321 ALLOCATE( iproc1(inowin) ) 322 ALLOCATE( iobsi2(inowin) ) 323 ALLOCATE( iobsj2(inowin) ) 324 ALLOCATE( iproc2(inowin) ) 436 ALLOCATE( iobsi(inowin,kvars) ) 437 ALLOCATE( iobsj(inowin,kvars) ) 438 ALLOCATE( iproc(inowin,kvars) ) 325 439 inowin = 0 326 440 DO ji = 1, inpfiles(jj)%nobs 327 441 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 442 llcycle = .TRUE. 443 DO jvar = 1, kvars 444 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 445 llcycle = .FALSE. 446 EXIT 447 ENDIF 448 END DO 449 IF ( llcycle ) CYCLE 330 450 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 331 451 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 336 456 END DO 337 457 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 458 ! Do grid search 459 ! Assume anything other than velocity is on T grid 460 ! Save resource by not repeating for the same grid 461 jind = 0 462 DO jvar = 1, kvars 463 IF ( TRIM(inpfiles(jj)%cname(jvar)) == cobsname_uvel ) THEN 464 CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,jvar), iobsj(:,jvar), & 465 & iproc(:,jvar), 'U' ) 466 ELSE IF ( TRIM(inpfiles(jj)%cname(jvar)) == cobsname_vvel ) THEN 467 CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,jvar), iobsj(:,jvar), & 468 & iproc(:,jvar), 'V' ) 469 ELSE 470 IF ( jind > 0 ) THEN 471 iobsi(:,jvar) = iobsi(:,jind) 472 iobsj(:,jvar) = iobsj(:,jind) 473 iproc(:,jvar) = iproc(:,jind) 474 ELSE 475 jind = jvar 476 CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,jvar), iobsj(:,jvar), & 477 & iproc(:,jvar), 'T' ) 478 ENDIF 479 ENDIF 480 END DO 350 481 351 482 inowin = 0 352 483 DO ji = 1, inpfiles(jj)%nobs 353 484 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 485 llcycle = .TRUE. 486 DO jvar = 1, kvars 487 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 488 llcycle = .FALSE. 489 EXIT 490 ENDIF 491 END DO 492 IF ( llcycle ) CYCLE 356 493 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 357 494 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN 358 495 inowin = inowin + 1 359 inpfiles(jj)%iproc(ji,1) = iproc1(inowin) 360 inpfiles(jj)%iobsi(ji,1) = iobsi1(inowin) 361 inpfiles(jj)%iobsj(ji,1) = iobsj1(inowin) 362 inpfiles(jj)%iproc(ji,2) = iproc2(inowin) 363 inpfiles(jj)%iobsi(ji,2) = iobsi2(inowin) 364 inpfiles(jj)%iobsj(ji,2) = iobsj2(inowin) 365 IF ( inpfiles(jj)%iproc(ji,1) /= & 366 & inpfiles(jj)%iproc(ji,2) ) THEN 367 CALL ctl_stop( 'Error in obs_read_prof:', & 368 & 'var1 and var2 observation on different processors') 496 DO jvar = 1, kvars 497 inpfiles(jj)%iproc(ji,jvar) = iproc(inowin,jvar) 498 inpfiles(jj)%iobsi(ji,jvar) = iobsi(inowin,jvar) 499 inpfiles(jj)%iobsj(ji,jvar) = iobsj(inowin,jvar) 500 END DO 501 IF ( kvars > 1 ) THEN 502 DO jvar = 2, kvars 503 IF ( inpfiles(jj)%iproc(ji,jvar) /= & 504 & inpfiles(jj)%iproc(ji,1) ) THEN 505 CALL ctl_stop( 'Error in obs_read_prof:', & 506 & 'observation on different processors for different vars') 507 ENDIF 508 END DO 369 509 ENDIF 370 510 ENDIF 371 511 END DO 372 DEALLOCATE( zlam, zphi, iobsi 1, iobsj1, iproc1, iobsi2, iobsj2, iproc2)512 DEALLOCATE( zlam, zphi, iobsi, iobsj, iproc ) 373 513 374 514 DO ji = 1, inpfiles(jj)%nobs 375 515 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 516 llcycle = .TRUE. 517 DO jvar = 1, kvars 518 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 519 llcycle = .FALSE. 520 EXIT 521 ENDIF 522 END DO 523 IF ( llcycle ) CYCLE 378 524 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 379 525 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 384 530 ENDIF 385 531 llvalprof = .FALSE. 386 IF ( ldvar1 ) THEN 387 loop_t_count : DO ij = 1,inpfiles(jj)%nlev 388 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 389 & CYCLE 390 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 391 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 392 ivar1t0 = ivar1t0 + 1 393 ENDIF 394 END DO loop_t_count 395 ENDIF 396 IF ( ldvar2 ) THEN 397 loop_s_count : DO ij = 1,inpfiles(jj)%nlev 398 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 399 & CYCLE 400 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 401 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 402 ivar2t0 = ivar2t0 + 1 403 ENDIF 404 END DO loop_s_count 405 ENDIF 406 loop_p_count : DO ij = 1,inpfiles(jj)%nlev 532 DO jvar = 1, kvars 533 IF ( ldvar(jvar) ) THEN 534 DO ij = 1,inpfiles(jj)%nlev 535 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 536 & CYCLE 537 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 538 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 539 ivart0(jvar) = ivart0(jvar) + 1 540 ENDIF 541 END DO 542 ENDIF 543 END DO 544 DO ij = 1,inpfiles(jj)%nlev 407 545 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 408 546 & CYCLE 409 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. &410 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. &411 & ldvar1 ) .OR. &412 & ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. &413 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. &414 & ldvar2 ) ) THEN415 ip3dt = ip3dt + 1416 llvalprof = .TRUE.417 END IF418 END DO loop_p_count547 DO jvar = 1, kvars 548 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 549 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 550 & ldvar(jvar) ) ) THEN 551 ip3dt = ip3dt + 1 552 llvalprof = .TRUE. 553 EXIT 554 ENDIF 555 END DO 556 END DO 419 557 420 558 IF ( llvalprof ) iprof = iprof + 1 … … 438 576 DO ji = 1, inpfiles(jj)%nobs 439 577 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 578 llcycle = .TRUE. 579 DO jvar = 1, kvars 580 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 581 llcycle = .FALSE. 582 EXIT 583 ENDIF 584 END DO 585 IF ( llcycle ) CYCLE 442 586 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 443 587 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 453 597 DO ji = 1, inpfiles(jj)%nobs 454 598 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 599 llcycle = .TRUE. 600 DO jvar = 1, kvars 601 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 602 llcycle = .FALSE. 603 EXIT 604 ENDIF 605 END DO 606 IF ( llcycle ) CYCLE 457 607 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 458 608 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 469 619 470 620 iv3dt(:) = -1 471 IF (ldsatt) THEN 472 iv3dt(1) = ip3dt 473 iv3dt(2) = ip3dt 621 IF (ldallatall) THEN 622 iv3dt(:) = ip3dt 474 623 ELSE 475 iv3dt(1) = ivar1t0 476 iv3dt(2) = ivar2t0 624 iv3dt(:) = ivart0(:) 477 625 ENDIF 478 CALL obs_prof_alloc( profdata, kvars, k extr, iprof, iv3dt, &479 & kstp, jpi, jpj, jpk )626 CALL obs_prof_alloc( profdata, kvars, kadd+iadd, kextr+iextr, iprof, iv3dt, & 627 & ip3dt, kstp, jpi, jpj, jpk ) 480 628 481 629 ! * Read obs/positions, QC, all variable and assign to profdata … … 483 631 profdata%nprof = 0 484 632 profdata%nvprot(:) = 0 485 profdata%cvars(:) = clvars(:) 633 profdata%cvars(:) = clvarsin(:) 634 profdata%clong(:) = cllongin(:) 635 profdata%cunit(:) = clunitin(:) 636 profdata%cgrid(:) = clgridin(:) 637 IF ( iadd > 0 ) THEN 638 profdata%caddvars(kadd+1:) = claddvarsin(:) 639 profdata%caddlong(kadd+1:,:) = claddlongin(:,:) 640 profdata%caddunit(kadd+1:,:) = claddunitin(:,:) 641 ENDIF 642 IF ( iextr > 0 ) THEN 643 profdata%cextvars(kextr+1:) = clextvarsin(:) 644 profdata%cextlong(kextr+1:) = clextlongin(:) 645 profdata%cextunit(kextr+1:) = clextunitin(:) 646 ENDIF 486 647 iprof = 0 487 648 488 649 ip3dt = 0 489 ivar1t = 0 490 ivar2t = 0 491 itypvar1 (:) = 0 492 itypvar1mpp(:) = 0 493 494 itypvar2 (:) = 0 495 itypvar2mpp(:) = 0 650 ivart(:) = 0 651 itypvar (:,:) = 0 652 itypvarmpp(:,:) = 0 496 653 497 654 ioserrcount = 0 … … 501 658 ji = iprofidx(iindx(jk)) 502 659 503 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 504 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 505 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 660 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 661 llcycle = .TRUE. 662 DO jvar = 1, kvars 663 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 664 llcycle = .FALSE. 665 EXIT 666 ENDIF 667 END DO 668 IF ( llcycle ) CYCLE 506 669 507 670 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & … … 519 682 520 683 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 684 llcycle = .TRUE. 685 DO jvar = 1, kvars 686 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 687 llcycle = .FALSE. 688 EXIT 689 ENDIF 690 END DO 691 IF ( llcycle ) CYCLE 523 692 524 693 loop_prof : DO ij = 1, inpfiles(jj)%nlev … … 527 696 & CYCLE 528 697 529 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 530 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 531 532 llvalprof = .TRUE. 533 EXIT loop_prof 534 535 ENDIF 536 537 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 538 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 539 540 llvalprof = .TRUE. 541 EXIT loop_prof 542 543 ENDIF 698 DO jvar = 1, kvars 699 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 700 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 701 702 llvalprof = .TRUE. 703 EXIT loop_prof 704 705 ENDIF 706 END DO 544 707 545 708 END DO loop_prof … … 573 736 574 737 ! Coordinate search parameters 575 profdata%mi (iprof,1) = inpfiles(jj)%iobsi(ji,1)576 profdata%mj (iprof,1) = inpfiles(jj)%iobsj(ji,1)577 profdata%mi (iprof,2) = inpfiles(jj)%iobsi(ji,2)578 profdata%mj (iprof,2) = inpfiles(jj)%iobsj(ji,2)738 DO jvar = 1, kvars 739 profdata%mi (iprof,jvar) = inpfiles(jj)%iobsi(ji,jvar) 740 profdata%mj (iprof,jvar) = inpfiles(jj)%iobsj(ji,jvar) 741 END DO 579 742 580 743 ! Profile WMO number … … 614 777 & CYCLE 615 778 616 IF (ldsatt) THEN 617 618 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 619 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 620 & ldvar1 ) .OR. & 621 & ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 622 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 623 & ldvar2 ) ) THEN 624 ip3dt = ip3dt + 1 625 ELSE 626 CYCLE 779 IF ( ldallatall .OR. (iextr > 0) ) THEN 780 781 DO jvar = 1, kvars 782 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 783 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 784 & ldvar(jvar) ) ) THEN 785 ip3dt = ip3dt + 1 786 EXIT 787 ELSE IF ( jvar == kvars ) THEN 788 CYCLE loop_p 789 ENDIF 790 END DO 791 792 ENDIF 793 794 DO jvar = 1, kvars 795 796 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 797 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 798 & ldvar(jvar) ) .OR. ldallatall ) THEN 799 800 IF (ldallatall) THEN 801 802 ivart(jvar) = ip3dt 803 804 ELSE 805 806 ivart(jvar) = ivart(jvar) + 1 807 808 ENDIF 809 810 ! Depth of jvar observation 811 profdata%var(jvar)%vdep(ivart(jvar)) = & 812 & inpfiles(jj)%pdep(ij,ji) 813 814 ! Depth of jvar observation QC 815 profdata%var(jvar)%idqc(ivart(jvar)) = & 816 & inpfiles(jj)%idqc(ij,ji) 817 818 ! Depth of jvar observation QC flags 819 profdata%var(jvar)%idqcf(:,ivart(jvar)) = & 820 & inpfiles(jj)%idqcf(:,ij,ji) 821 822 ! Profile index 823 profdata%var(jvar)%nvpidx(ivart(jvar)) = iprof 824 825 ! Vertical index in original profile 826 profdata%var(jvar)%nvlidx(ivart(jvar)) = ij 827 828 ! Profile jvar value 829 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 830 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 831 profdata%var(jvar)%vobs(ivart(jvar)) = & 832 & inpfiles(jj)%pob(ij,ji,jvar) 833 ! Count number of profile var1 data as function of type 834 itypvar( profdata%ntyp(iprof) + 1, jvar ) = & 835 & itypvar( profdata%ntyp(iprof) + 1, jvar ) + 1 836 ELSE 837 profdata%var(jvar)%vobs(ivart(jvar)) = fbrmdi 838 ENDIF 839 840 ! Profile jvar qc 841 profdata%var(jvar)%nvqc(ivart(jvar)) = & 842 & inpfiles(jj)%ivlqc(ij,ji,jvar) 843 844 ! Profile jvar qc flags 845 profdata%var(jvar)%nvqcf(:,ivart(jvar)) = & 846 & inpfiles(jj)%ivlqcf(:,ij,ji,jvar) 847 848 ! Additional variables 849 IF ( iadd > 0 ) THEN 850 jadd2 = 0 851 DO jadd = 1, inpfiles(jj)%nadd 852 IF ( TRIM(inpfiles(jj)%caddname(jadd)) == 'Hx' ) THEN 853 IF ( ldmod ) THEN 854 profdata%var(jvar)%vmod(ivart(jvar)) = & 855 & inpfiles(jj)%padd(ij,ji,jadd,jvar) 856 ENDIF 857 ELSE 858 jadd2 = jadd2 + 1 859 profdata%var(jvar)%vadd(ivart(jvar),kadd+jadd2) = & 860 & inpfiles(jj)%padd(ij,ji,jadd,jvar) 861 ENDIF 862 END DO 863 ENDIF 864 627 865 ENDIF 628 629 ENDIF 630 631 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 632 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 633 & ldvar1 ) .OR. ldsatt ) THEN 634 635 IF (ldsatt) THEN 636 637 ivar1t = ip3dt 638 639 ELSE 640 641 ivar1t = ivar1t + 1 642 643 ENDIF 644 645 ! Depth of var1 observation 646 profdata%var(1)%vdep(ivar1t) = & 647 & inpfiles(jj)%pdep(ij,ji) 648 649 ! Depth of var1 observation QC 650 profdata%var(1)%idqc(ivar1t) = & 651 & inpfiles(jj)%idqc(ij,ji) 652 653 ! Depth of var1 observation QC flags 654 profdata%var(1)%idqcf(:,ivar1t) = & 655 & inpfiles(jj)%idqcf(:,ij,ji) 656 657 ! Profile index 658 profdata%var(1)%nvpidx(ivar1t) = iprof 659 660 ! Vertical index in original profile 661 profdata%var(1)%nvlidx(ivar1t) = ij 662 663 ! Profile var1 value 664 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 665 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 666 profdata%var(1)%vobs(ivar1t) = & 667 & inpfiles(jj)%pob(ij,ji,1) 668 IF ( ldmod ) THEN 669 profdata%var(1)%vmod(ivar1t) = & 670 & inpfiles(jj)%padd(ij,ji,1,1) 866 867 END DO 868 869 ! Extra variables 870 ! Special consideration for if the extra variable is called TEMP 871 ! and there's a regular variable called POTM. These are in situ 872 ! and potential temperature respectively, and need the same QC checks 873 IF ( iextr > 0 ) THEN 874 profdata%vext%nepidx(ip3dt) = iprof 875 profdata%vext%nelidx(ip3dt) = ij 876 DO jext = 1, iextr 877 IF ( TRIM(inpfiles(jj)%cextname(jext)) == 'TEMP' ) THEN 878 llpotm = .false. 879 DO jvar = 1, kvars 880 IF ( TRIM(inpfiles(jj)%cname(jvar)) == 'POTM' ) THEN 881 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 882 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 883 & ldvar(jvar) ) ) THEN 884 profdata%vext%eobs(ip3dt,kextr+jext) = inpfiles(jj)%pext(ij,ji,jext) 885 ELSE 886 profdata%vext%eobs(ip3dt,kextr+jext) = fbrmdi 887 ENDIF 888 llpotm = .true. 889 EXIT 890 ENDIF 891 END DO 892 IF ( .NOT. llpotm ) THEN 893 profdata%vext%eobs(ip3dt,kextr+jext) = inpfiles(jj)%pext(ij,ji,jext) 894 ENDIF 895 ELSE 896 profdata%vext%eobs(ip3dt,kextr+jext) = inpfiles(jj)%pext(ij,ji,jext) 671 897 ENDIF 672 ! Count number of profile var1 data as function of type 673 itypvar1( profdata%ntyp(iprof) + 1 ) = & 674 & itypvar1( profdata%ntyp(iprof) + 1 ) + 1 675 ELSE 676 profdata%var(1)%vobs(ivar1t) = fbrmdi 677 ENDIF 678 679 ! Profile var1 qc 680 profdata%var(1)%nvqc(ivar1t) = & 681 & inpfiles(jj)%ivlqc(ij,ji,1) 682 683 ! Profile var1 qc flags 684 profdata%var(1)%nvqcf(:,ivar1t) = & 685 & inpfiles(jj)%ivlqcf(:,ij,ji,1) 686 687 ! Profile insitu T value 688 IF ( TRIM( inpfiles(jj)%cname(1) ) == 'POTM' ) THEN 689 profdata%var(1)%vext(ivar1t,1) = & 690 & inpfiles(jj)%pext(ij,ji,1) 691 ENDIF 692 693 ENDIF 694 695 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 696 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 697 & ldvar2 ) .OR. ldsatt ) THEN 698 699 IF (ldsatt) THEN 700 701 ivar2t = ip3dt 702 703 ELSE 704 705 ivar2t = ivar2t + 1 706 707 ENDIF 708 709 ! Depth of var2 observation 710 profdata%var(2)%vdep(ivar2t) = & 711 & inpfiles(jj)%pdep(ij,ji) 712 713 ! Depth of var2 observation QC 714 profdata%var(2)%idqc(ivar2t) = & 715 & inpfiles(jj)%idqc(ij,ji) 716 717 ! Depth of var2 observation QC flags 718 profdata%var(2)%idqcf(:,ivar2t) = & 719 & inpfiles(jj)%idqcf(:,ij,ji) 720 721 ! Profile index 722 profdata%var(2)%nvpidx(ivar2t) = iprof 723 724 ! Vertical index in original profile 725 profdata%var(2)%nvlidx(ivar2t) = ij 726 727 ! Profile var2 value 728 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) ) .AND. & 729 & ( .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) ) THEN 730 profdata%var(2)%vobs(ivar2t) = & 731 & inpfiles(jj)%pob(ij,ji,2) 732 IF ( ldmod ) THEN 733 profdata%var(2)%vmod(ivar2t) = & 734 & inpfiles(jj)%padd(ij,ji,1,2) 735 ENDIF 736 ! Count number of profile var2 data as function of type 737 itypvar2( profdata%ntyp(iprof) + 1 ) = & 738 & itypvar2( profdata%ntyp(iprof) + 1 ) + 1 739 ELSE 740 profdata%var(2)%vobs(ivar2t) = fbrmdi 741 ENDIF 742 743 ! Profile var2 qc 744 profdata%var(2)%nvqc(ivar2t) = & 745 & inpfiles(jj)%ivlqc(ij,ji,2) 746 747 ! Profile var2 qc flags 748 profdata%var(2)%nvqcf(:,ivar2t) = & 749 & inpfiles(jj)%ivlqcf(:,ij,ji,2) 750 898 END DO 751 899 ENDIF 752 900 … … 763 911 !----------------------------------------------------------------------- 764 912 765 CALL obs_mpp_sum_integer ( ivar1t0, ivar1tmpp ) 766 CALL obs_mpp_sum_integer ( ivar2t0, ivar2tmpp ) 913 DO jvar = 1, kvars 914 CALL obs_mpp_sum_integer ( ivart0(jvar), ivartmpp(jvar) ) 915 END DO 767 916 CALL obs_mpp_sum_integer ( ip3dt, ip3dtmpp ) 768 917 769 CALL obs_mpp_sum_integers( itypvar1, itypvar1mpp, ntyp1770 + 1 ) 770 CALL obs_mpp_sum_integers( itypvar2, itypvar2mpp, ntyp1770 + 1 ) 918 DO jvar = 1, kvars 919 CALL obs_mpp_sum_integers( itypvar(:,jvar), itypvarmpp(:,jvar), ntyp1770 + 1 ) 920 END DO 771 921 772 922 !----------------------------------------------------------------------- … … 778 928 WRITE(numout,'(1X,A)') '------------' 779 929 WRITE(numout,*) 780 WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(1) ) 781 WRITE(numout,'(1X,A)') '------------------------' 782 DO ji = 0, ntyp1770 783 IF ( itypvar1mpp(ji+1) > 0 ) THEN 784 WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 785 & cwmonam1770(ji)(1:52),' = ', & 786 & itypvar1mpp(ji+1) 787 ENDIF 930 DO jvar = 1, kvars 931 WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(jvar) ) 932 WRITE(numout,'(1X,A)') '------------------------' 933 DO ji = 0, ntyp1770 934 IF ( itypvarmpp(ji+1,jvar) > 0 ) THEN 935 WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 936 & cwmonam1770(ji)(1:52),' = ', & 937 & itypvarmpp(ji+1,jvar) 938 ENDIF 939 END DO 940 WRITE(numout,'(1X,A)') & 941 & '---------------------------------------------------------------' 942 WRITE(numout,'(1X,A55,I8)') & 943 & 'Total profile data for variable '//TRIM( profdata%cvars(jvar) )// & 944 & ' = ', ivartmpp(jvar) 945 WRITE(numout,'(1X,A)') & 946 & '---------------------------------------------------------------' 947 WRITE(numout,*) 788 948 END DO 789 WRITE(numout,'(1X,A)') & 790 & '---------------------------------------------------------------' 791 WRITE(numout,'(1X,A55,I8)') & 792 & 'Total profile data for variable '//TRIM( profdata%cvars(1) )// & 793 & ' = ', ivar1tmpp 794 WRITE(numout,'(1X,A)') & 795 & '---------------------------------------------------------------' 796 WRITE(numout,*) 797 WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(2) ) 798 WRITE(numout,'(1X,A)') '------------------------' 799 DO ji = 0, ntyp1770 800 IF ( itypvar2mpp(ji+1) > 0 ) THEN 801 WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 802 & cwmonam1770(ji)(1:52),' = ', & 803 & itypvar2mpp(ji+1) 804 ENDIF 949 ENDIF 950 951 IF (ldallatall) THEN 952 profdata%nvprot(:) = ip3dt 953 profdata%nvprotmpp(:) = ip3dtmpp 954 ELSE 955 DO jvar = 1, kvars 956 profdata%nvprot(jvar) = ivart(jvar) 957 profdata%nvprotmpp(jvar) = ivartmpp(jvar) 805 958 END DO 806 WRITE(numout,'(1X,A)') &807 & '---------------------------------------------------------------'808 WRITE(numout,'(1X,A55,I8)') &809 & 'Total profile data for variable '//TRIM( profdata%cvars(2) )// &810 & ' = ', ivar2tmpp811 WRITE(numout,'(1X,A)') &812 & '---------------------------------------------------------------'813 WRITE(numout,*)814 ENDIF815 816 IF (ldsatt) THEN817 profdata%nvprot(1) = ip3dt818 profdata%nvprot(2) = ip3dt819 profdata%nvprotmpp(1) = ip3dtmpp820 profdata%nvprotmpp(2) = ip3dtmpp821 ELSE822 profdata%nvprot(1) = ivar1t823 profdata%nvprot(2) = ivar2t824 profdata%nvprotmpp(1) = ivar1tmpp825 profdata%nvprotmpp(2) = ivar2tmpp826 959 ENDIF 827 960 profdata%nprof = iprof … … 830 963 ! Model level search 831 964 !----------------------------------------------------------------------- 832 IF ( ldvar1 ) THEN 833 CALL obs_level_search( jpk, gdept_1d, & 834 & profdata%nvprot(1), profdata%var(1)%vdep, & 835 & profdata%var(1)%mvk ) 836 ENDIF 837 IF ( ldvar2 ) THEN 838 CALL obs_level_search( jpk, gdept_1d, & 839 & profdata%nvprot(2), profdata%var(2)%vdep, & 840 & profdata%var(2)%mvk ) 841 ENDIF 965 DO jvar = 1, kvars 966 IF ( ldvar(jvar) ) THEN 967 CALL obs_level_search( jpk, gdept_1d, & 968 & profdata%nvprot(jvar), profdata%var(jvar)%vdep, & 969 & profdata%var(jvar)%mvk ) 970 ENDIF 971 END DO 842 972 843 973 !----------------------------------------------------------------------- … … 852 982 ! Deallocate temporary data 853 983 !----------------------------------------------------------------------- 854 DEALLOCATE( ifileidx, iprofidx, zdat, clvars ) 984 DEALLOCATE( ifileidx, iprofidx, zdat, & 985 & clvarsin, cllongin, clunitin, clgridin ) 986 IF ( iadd > 0 ) THEN 987 DEALLOCATE( claddvarsin, claddlongin, claddunitin) 988 ENDIF 989 IF ( iextr > 0 ) THEN 990 DEALLOCATE( clextvarsin, clextlongin, clextunitin ) 991 ENDIF 855 992 856 993 !----------------------------------------------------------------------- -
NEMO/branches/UKMO/NEMO_4.0.4_FOAM_package_generic_obs/src/OCE/OBS/obs_read_surf.F90
r14075 r15752 22 22 USE obs_fbm ! Feedback routines 23 23 USE netcdf ! NetCDF library 24 USE obs_group_def, ONLY : & ! Observation variable information 25 & cobsname_uvel, & 26 & cobsname_vvel 24 27 25 28 IMPLICIT NONE … … 39 42 40 43 SUBROUTINE obs_rea_surf( surfdata, knumfiles, cdfilenames, & 41 & kvars, kextr, kstp, ddobsini, ddobsend, & 42 & ldignmis, ldmod, ldnightav ) 44 & kvars, kadd, kextr, kstp, ddobsini, ddobsend, & 45 & ptime_mean_period, ld_time_mean_bkg, & 46 & ldignmis, ldmod, ldnightav, cdvars ) 43 47 !!--------------------------------------------------------------------- 44 48 !! … … 61 65 !! * Arguments 62 66 TYPE(obs_surf), INTENT(INOUT) :: & 63 & surfdata ! Surface data to be read64 INTEGER, INTENT(IN) :: knumfiles! Number of corio format files to read67 & surfdata ! Surface data to be read 68 INTEGER, INTENT(IN) :: knumfiles ! Number of corio format files to read 65 69 CHARACTER(LEN=128), INTENT(IN) :: & 66 & cdfilenames(knumfiles) ! File names to read in 67 INTEGER, INTENT(IN) :: kvars ! Number of variables in surfdata 68 INTEGER, INTENT(IN) :: kextr ! Number of extra fields for each var 69 INTEGER, INTENT(IN) :: kstp ! Ocean time-step index 70 LOGICAL, INTENT(IN) :: ldignmis ! Ignore missing files 71 LOGICAL, INTENT(IN) :: ldmod ! Initialize model from input data 72 LOGICAL, INTENT(IN) :: ldnightav ! Observations represent a night-time average 73 REAL(dp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS 74 REAL(dp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS 70 & cdfilenames(knumfiles) ! File names to read in 71 INTEGER, INTENT(IN) :: kvars ! Number of variables in surfdata 72 INTEGER, INTENT(IN) :: kadd ! Number of additional fields 73 ! in addition to those in the input file(s) 74 INTEGER, INTENT(IN) :: kextr ! Number of extra fields 75 ! in addition to those in the input file(s) 76 INTEGER, INTENT(IN) :: kstp ! Ocean time-step index 77 REAL(dp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS 78 REAL(dp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS 79 REAL(wp), INTENT(IN) :: ptime_mean_period ! Averaging period in hours 80 LOGICAL, INTENT(IN) :: ld_time_mean_bkg ! Will reset times to end of averaging period 81 LOGICAL, INTENT(IN) :: ldignmis ! Ignore missing files 82 LOGICAL, INTENT(IN) :: ldmod ! Initialize model from input data 83 LOGICAL, INTENT(IN) :: ldnightav ! Observations represent a night-time average 84 CHARACTER(len=8), DIMENSION(kvars), INTENT(IN) :: cdvars ! Expected variable names 75 85 76 86 !! * Local declarations 77 87 CHARACTER(LEN=11), PARAMETER :: cpname='obs_rea_surf' 78 88 CHARACTER(len=8) :: clrefdate 79 CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvars 89 CHARACTER(len=ilenname), DIMENSION(:), ALLOCATABLE :: clvarsin 90 CHARACTER(len=ilenlong), DIMENSION(:), ALLOCATABLE :: cllongin 91 CHARACTER(len=ilenunit), DIMENSION(:), ALLOCATABLE :: clunitin 92 CHARACTER(len=ilengrid), DIMENSION(:), ALLOCATABLE :: clgridin 93 CHARACTER(len=ilenname), DIMENSION(:), ALLOCATABLE :: claddvarsin 94 CHARACTER(len=ilenlong), DIMENSION(:,:), ALLOCATABLE :: claddlongin 95 CHARACTER(len=ilenunit), DIMENSION(:,:), ALLOCATABLE :: claddunitin 96 CHARACTER(len=ilenname), DIMENSION(:), ALLOCATABLE :: clextvarsin 97 CHARACTER(len=ilenlong), DIMENSION(:), ALLOCATABLE :: clextlongin 98 CHARACTER(len=ilenunit), DIMENSION(:), ALLOCATABLE :: clextunitin 80 99 INTEGER :: ji 81 100 INTEGER :: jj 82 101 INTEGER :: jk 102 INTEGER :: jind 103 INTEGER :: jvar 104 INTEGER :: jext 105 INTEGER :: jadd 106 INTEGER :: jadd2 107 INTEGER :: iadd 108 INTEGER :: iaddin 109 INTEGER :: iextr 83 110 INTEGER :: iflag 84 111 INTEGER :: inobf … … 102 129 & ityp, & 103 130 & itypmpp 104 INTEGER, DIMENSION(: ), ALLOCATABLE :: &131 INTEGER, DIMENSION(:,:), ALLOCATABLE :: & 105 132 & iobsi, & 106 133 & iobsj, & 107 & iproc, & 134 & iproc 135 INTEGER, DIMENSION(:), ALLOCATABLE :: & 108 136 & iindx, & 109 137 & ifileidx, & … … 120 148 TYPE(obfbdata), POINTER, DIMENSION(:) :: & 121 149 & inpfiles 150 CHARACTER(LEN=256) :: cout1 ! Diagnostic output line 122 151 123 152 ! Local initialization … … 131 160 132 161 ALLOCATE( inpfiles(inobf) ) 162 163 iadd = 0 164 iextr = 0 133 165 134 166 surf_files : DO jj = 1, inobf … … 178 210 & ldgrid = .TRUE. ) 179 211 212 IF ( inpfiles(jj)%nvar /= kvars ) THEN 213 CALL ctl_stop( 'Feedback format error: ', & 214 & ' unexpected number of vars in feedback file', & 215 & TRIM(cdfilenames(jj)) ) 216 ENDIF 217 180 218 IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN 181 CALL ctl_stop( 'Model not in input data' ) 219 CALL ctl_stop( 'Model not in input data in', & 220 & TRIM(cdfilenames(jj)) ) 182 221 RETURN 183 222 ENDIF 184 223 224 IF ( (iextr > 0) .AND. (inpfiles(jj)%next /= iextr) ) THEN 225 CALL ctl_stop( 'Number of extra variables not consistent', & 226 & ' with previous files for this type in', & 227 & TRIM(cdfilenames(jj)) ) 228 ELSE 229 iextr = inpfiles(jj)%next 230 ENDIF 231 232 ! Ignore model counterpart 233 iaddin = inpfiles(jj)%nadd 234 DO ji = 1, iaddin 235 IF ( TRIM(inpfiles(jj)%caddname(ji)) == 'Hx' ) THEN 236 iaddin = iaddin - 1 237 EXIT 238 ENDIF 239 END DO 240 IF ( ldmod .AND. ( inpfiles(jj)%nadd == iaddin ) ) THEN 241 CALL ctl_stop( 'Model not in input data', & 242 & TRIM(cdfilenames(jj)) ) 243 ENDIF 244 245 IF ( (iadd > 0) .AND. (iaddin /= iadd) ) THEN 246 CALL ctl_stop( 'Number of additional variables not consistent', & 247 & ' with previous files for this type in', & 248 & TRIM(cdfilenames(jj)) ) 249 ELSE 250 iadd = iaddin 251 ENDIF 252 185 253 IF ( jj == 1 ) THEN 186 ALLOCATE( clvars( inpfiles(jj)%nvar ) ) 254 ALLOCATE( clvarsin( inpfiles(jj)%nvar ) ) 255 ALLOCATE( cllongin( inpfiles(jj)%nvar ) ) 256 ALLOCATE( clunitin( inpfiles(jj)%nvar ) ) 257 ALLOCATE( clgridin( inpfiles(jj)%nvar ) ) 187 258 DO ji = 1, inpfiles(jj)%nvar 188 clvars(ji) = inpfiles(jj)%cname(ji) 259 clvarsin(ji) = inpfiles(jj)%cname(ji) 260 cllongin(ji) = inpfiles(jj)%coblong(ji) 261 clunitin(ji) = inpfiles(jj)%cobunit(ji) 262 clgridin(ji) = inpfiles(jj)%cgrid(ji) 263 IF ( clvarsin(ji) /= cdvars(ji) ) THEN 264 CALL ctl_stop( 'Feedback file variables do not match', & 265 & ' expected variable names for this type' ) 266 ENDIF 189 267 END DO 268 IF ( iadd > 0 ) THEN 269 ALLOCATE( claddvarsin( iadd ) ) 270 ALLOCATE( claddlongin( iadd, inpfiles(jj)%nvar ) ) 271 ALLOCATE( claddunitin( iadd, inpfiles(jj)%nvar ) ) 272 jadd = 0 273 DO ji = 1, inpfiles(jj)%nadd 274 IF ( TRIM(inpfiles(jj)%caddname(ji)) /= 'Hx' ) THEN 275 jadd = jadd + 1 276 claddvarsin(jadd) = inpfiles(jj)%caddname(ji) 277 DO jk = 1, inpfiles(jj)%nvar 278 claddlongin(jadd,jk) = inpfiles(jj)%caddlong(ji,jk) 279 claddunitin(jadd,jk) = inpfiles(jj)%caddunit(ji,jk) 280 END DO 281 ENDIF 282 END DO 283 ENDIF 284 IF ( iextr > 0 ) THEN 285 ALLOCATE( clextvarsin( iextr ) ) 286 ALLOCATE( clextlongin( iextr ) ) 287 ALLOCATE( clextunitin( iextr ) ) 288 DO ji = 1, iextr 289 clextvarsin(ji) = inpfiles(jj)%cextname(ji) 290 clextlongin(ji) = inpfiles(jj)%cextlong(ji) 291 clextunitin(ji) = inpfiles(jj)%cextunit(ji) 292 END DO 293 ENDIF 190 294 ELSE 191 295 DO ji = 1, inpfiles(jj)%nvar 192 IF ( inpfiles(jj)%cname(ji) /= clvars (ji) ) THEN296 IF ( inpfiles(jj)%cname(ji) /= clvarsin(ji) ) THEN 193 297 CALL ctl_stop( 'Feedback file variables not consistent', & 194 & ' with previous files for this type' ) 298 & ' with previous files for this type in', & 299 & TRIM(cdfilenames(jj)) ) 195 300 ENDIF 196 301 END DO 197 ENDIF 198 199 IF (lwp) WRITE(numout,*)'Observation file contains ',inpfiles(jj)%nobs,' observations' 302 IF ( iadd > 0 ) THEN 303 jadd = 0 304 DO ji = 1, inpfiles(jj)%nadd 305 IF ( TRIM(inpfiles(jj)%caddname(ji)) /= 'Hx' ) THEN 306 jadd = jadd + 1 307 IF ( inpfiles(jj)%caddname(ji) /= claddvarsin(jadd) ) THEN 308 CALL ctl_stop( 'Feedback file additional variables not consistent', & 309 & ' with previous files for this type in', & 310 & TRIM(cdfilenames(jj)) ) 311 ENDIF 312 ENDIF 313 END DO 314 ENDIF 315 IF ( iextr > 0 ) THEN 316 DO ji = 1, iextr 317 IF ( inpfiles(jj)%cextname(ji) /= clextvarsin(ji) ) THEN 318 CALL ctl_stop( 'Feedback file extra variables not consistent', & 319 & ' with previous files for this type in', & 320 & TRIM(cdfilenames(jj)) ) 321 ENDIF 322 END DO 323 ENDIF 324 325 ENDIF 326 327 IF (lwp) WRITE(numout,*) 'Observation file contains ', inpfiles(jj)%nobs, ' observations' 200 328 201 329 !------------------------------------------------------------------ … … 247 375 248 376 IF ( inpfiles(jj)%nobs > 0 ) THEN 249 inpfiles(jj)%iproc = -1 250 inpfiles(jj)%iobsi = -1 251 inpfiles(jj)%iobsj = -1 252 ENDIF 377 inpfiles(jj)%iproc(:,:) = -1 378 inpfiles(jj)%iobsi(:,:) = -1 379 inpfiles(jj)%iobsj(:,:) = -1 380 ENDIF 381 382 ! If observations are representing a time mean then set the time 383 ! of the obs to the end of that meaning period relative to the start of the run 384 IF ( ld_time_mean_bkg ) THEN 385 DO ji = 1, inpfiles(jj)%nobs 386 ! Only do this for obs within time window 387 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 388 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN 389 inpfiles(jj)%ptim(ji) = djulini(jj) + (ptime_mean_period/24.0) 390 ENDIF 391 END DO 392 ENDIF 393 253 394 inowin = 0 254 395 DO ji = 1, inpfiles(jj)%nobs … … 258 399 ENDIF 259 400 END DO 260 ALLOCATE( zlam (inowin))261 ALLOCATE( zphi (inowin))262 ALLOCATE( iobsi(inowin ) )263 ALLOCATE( iobsj(inowin ) )264 ALLOCATE( iproc(inowin ) )401 ALLOCATE( zlam (inowin) ) 402 ALLOCATE( zphi (inowin) ) 403 ALLOCATE( iobsi(inowin,kvars) ) 404 ALLOCATE( iobsj(inowin,kvars) ) 405 ALLOCATE( iproc(inowin,kvars) ) 265 406 inowin = 0 266 407 DO ji = 1, inpfiles(jj)%nobs … … 273 414 END DO 274 415 275 CALL obs_grid_search( inowin, zlam, zphi, iobsi, iobsj, iproc, 'T' ) 416 ! Do grid search 417 ! Assume anything other than velocity is on T grid 418 ! Save resource by not repeating for the same grid 419 jind = 0 420 DO jvar = 1, kvars 421 IF ( TRIM(inpfiles(jj)%cname(jvar)) == cobsname_uvel ) THEN 422 CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,jvar), iobsj(:,jvar), & 423 & iproc(:,jvar), 'U' ) 424 ELSE IF ( TRIM(inpfiles(jj)%cname(jvar)) == cobsname_vvel ) THEN 425 CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,jvar), iobsj(:,jvar), & 426 & iproc(:,jvar), 'V' ) 427 ELSE 428 IF ( jind > 0 ) THEN 429 iobsi(:,jvar) = iobsi(:,jind) 430 iobsj(:,jvar) = iobsj(:,jind) 431 iproc(:,jvar) = iproc(:,jind) 432 ELSE 433 jind = jvar 434 CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,jvar), iobsj(:,jvar), & 435 & iproc(:,jvar), 'T' ) 436 ENDIF 437 ENDIF 438 END DO 276 439 277 440 inowin = 0 … … 280 443 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN 281 444 inowin = inowin + 1 282 inpfiles(jj)%iproc(ji,1) = iproc(inowin) 283 inpfiles(jj)%iobsi(ji,1) = iobsi(inowin) 284 inpfiles(jj)%iobsj(ji,1) = iobsj(inowin) 445 DO jvar = 1, kvars 446 inpfiles(jj)%iproc(ji,jvar) = iproc(inowin,jvar) 447 inpfiles(jj)%iobsi(ji,jvar) = iobsi(inowin,jvar) 448 inpfiles(jj)%iobsj(ji,jvar) = iobsj(inowin,jvar) 449 END DO 285 450 ENDIF 286 451 END DO … … 341 506 & iindx ) 342 507 343 CALL obs_surf_alloc( surfdata, iobs, kvars, k extr, kstp, jpi, jpj )508 CALL obs_surf_alloc( surfdata, iobs, kvars, kadd+iadd, kextr+iextr, kstp, jpi, jpj ) 344 509 345 510 ! Read obs/positions, QC, all variable and assign to surfdata … … 347 512 iobs = 0 348 513 349 surfdata%cvars(:) = clvars(:) 514 surfdata%cvars(:) = clvarsin(:) 515 surfdata%clong(:) = cllongin(:) 516 surfdata%cunit(:) = clunitin(:) 517 surfdata%cgrid(:) = clgridin(:) 518 IF ( iadd > 0 ) THEN 519 surfdata%caddvars(kadd+1:) = claddvarsin(:) 520 surfdata%caddlong(kadd+1:,:) = claddlongin(:,:) 521 surfdata%caddunit(kadd+1:,:) = claddunitin(:,:) 522 ENDIF 523 IF ( iextr > 0 ) THEN 524 surfdata%cextvars(kextr+1:) = clextvarsin(:) 525 surfdata%cextlong(kextr+1:) = clextlongin(:) 526 surfdata%cextunit(kextr+1:) = clextunitin(:) 527 ENDIF 350 528 351 529 ityp (:) = 0 … … 395 573 396 574 ! Coordinate search parameters 397 surfdata%mi (iobs) = inpfiles(jj)%iobsi(ji,1) 398 surfdata%mj (iobs) = inpfiles(jj)%iobsj(ji,1) 575 DO jvar = 1, kvars 576 surfdata%mi(iobs,jvar) = inpfiles(jj)%iobsi(ji,jvar) 577 surfdata%mj(iobs,jvar) = inpfiles(jj)%iobsj(ji,jvar) 578 END DO 399 579 400 580 ! WMO number … … 415 595 ityp(itype+1) = ityp(itype+1) + 1 416 596 ELSE 417 IF(lwp)WRITE(numout,*) 'WARNING:Increase jpsurfmaxtype in ',&418 & cpname597 IF(lwp)WRITE(numout,*) 'WARNING: Increase jpsurfmaxtype in ', & 598 & cpname 419 599 ENDIF 420 600 … … 423 603 surfdata%nsfil(iobs) = iindx(jk) 424 604 425 ! QC flags 426 surfdata%nqc(iobs) = inpfiles(jj)%ivqc(ji,1) 427 428 ! Observed value 429 surfdata%robs(iobs,1) = inpfiles(jj)%pob(1,ji,1) 430 431 432 ! Model and MDT is set to fbrmdi unless read from file 433 IF ( ldmod ) THEN 434 surfdata%rmod(iobs,1) = inpfiles(jj)%padd(1,ji,1,1) 435 IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) THEN 436 surfdata%rext(iobs,1) = inpfiles(jj)%padd(1,ji,2,1) 437 surfdata%rext(iobs,2) = inpfiles(jj)%pext(1,ji,1) 605 DO jvar = 1, kvars 606 607 ! QC flags 608 surfdata%nqc(iobs) = inpfiles(jj)%ivqc(ji,jvar) 609 610 ! Observed value 611 surfdata%robs(iobs,jvar) = inpfiles(jj)%pob(1,ji,jvar) 612 613 ! Additional variables 614 surfdata%rmod(iobs,jvar) = fbrmdi 615 IF ( iadd > 0 ) THEN 616 jadd2 = 0 617 DO jadd = 1, inpfiles(jj)%nadd 618 IF ( TRIM(inpfiles(jj)%caddname(jadd)) == 'Hx' ) THEN 619 IF ( ldmod ) THEN 620 surfdata%rmod(iobs,jvar) = inpfiles(jj)%padd(1,ji,jadd,jvar) 621 ENDIF 622 ELSE 623 jadd2 = jadd2 + 1 624 surfdata%radd(iobs,kadd+jadd2,jvar) = & 625 & inpfiles(jj)%padd(1,ji,jadd,jvar) 626 ENDIF 627 END DO 438 628 ENDIF 439 ELSE 440 surfdata%rmod(iobs,1) = fbrmdi 441 IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) surfdata%rext(iobs,:) = fbrmdi 629 630 END DO 631 632 ! Extra variables 633 IF ( iextr > 0 ) THEN 634 DO jext = 1, iextr 635 surfdata%rext(iobs,kextr+jext) = inpfiles(jj)%pext(1,ji,jext) 636 END DO 442 637 ENDIF 443 638 ENDIF … … 457 652 !----------------------------------------------------------------------- 458 653 IF (lwp) THEN 459 654 DO jvar = 1, surfdata%nvar 655 IF ( jvar == 1 ) THEN 656 cout1=TRIM(surfdata%cvars(1)) 657 ELSE 658 WRITE(cout1,'(A,A1,A)') TRIM(cout1), '/', TRIM(surfdata%cvars(jvar)) 659 ENDIF 660 END DO 661 460 662 WRITE(numout,*) 461 WRITE(numout,'(1X,A)')TRIM( surfdata%cvars(1))//' data'663 WRITE(numout,'(1X,A)')TRIM( cout1 )//' data' 462 664 WRITE(numout,'(1X,A)')'--------------' 463 665 DO jj = 1,8 464 666 IF ( itypmpp(jj) > 0 ) THEN 465 WRITE(numout,'(1X,A4,I4,A3,I10)') 'Type ', jj,' = ',itypmpp(jj)667 WRITE(numout,'(1X,A4,I4,A3,I10)') 'Type ', jj, ' = ', itypmpp(jj) 466 668 ENDIF 467 669 END DO … … 469 671 & '---------------------------------------------------------------' 470 672 WRITE(numout,'(1X,A,I8)') & 471 & 'Total data for variable '//TRIM( surfdata%cvars(1))// &673 & 'Total data for variable '//TRIM( cout1 )// & 472 674 & ' = ', iobsmpp 473 675 WRITE(numout,'(1X,A)') & … … 480 682 ! Deallocate temporary data 481 683 !----------------------------------------------------------------------- 482 DEALLOCATE( ifileidx, isurfidx, zdat, clvars ) 684 DEALLOCATE( ifileidx, isurfidx, zdat, clvarsin, & 685 & cllongin, clunitin, clgridin ) 686 IF ( iadd > 0 ) THEN 687 DEALLOCATE( claddvarsin, claddlongin, claddunitin) 688 ENDIF 689 IF ( iextr > 0 ) THEN 690 DEALLOCATE( clextvarsin, clextlongin, clextunitin ) 691 ENDIF 483 692 484 693 !----------------------------------------------------------------------- -
NEMO/branches/UKMO/NEMO_4.0.4_FOAM_package_generic_obs/src/OCE/OBS/obs_readmdt.F90
r14075 r15752 31 31 32 32 PUBLIC obs_rea_mdt ! called by dia_obs_init 33 PUBLIC obs_offset_mdt ! called by obs_rea_mdt34 35 INTEGER , PUBLIC :: nn_msshc = 1 ! MDT correction scheme36 REAL(wp), PUBLIC :: rn_mdtcorr = 1.61_wp ! User specified MDT correction37 REAL(wp), PUBLIC :: rn_mdtcutoff = 65.0_wp ! MDT cutoff for computed correction38 33 39 34 !!---------------------------------------------------------------------- … … 44 39 CONTAINS 45 40 46 SUBROUTINE obs_rea_mdt( sladata, k2dint ) 41 SUBROUTINE obs_rea_mdt( sladata, k2dint, kmdt, nn_msshc, rn_mdtcorr, & 42 rn_mdtcutoff ) 47 43 !!--------------------------------------------------------------------- 48 44 !! … … 57 53 USE iom 58 54 ! 59 TYPE(obs_surf), INTENT(inout) :: sladata ! SLA data 60 INTEGER , INTENT(in) :: k2dint ! ? 55 TYPE(obs_surf), INTENT(inout) :: sladata ! SLA data 56 INTEGER , INTENT(in) :: k2dint ! Interpolation type 57 INTEGER , INTENT(in) :: kmdt ! Index of MDT extra var 58 INTEGER , INTENT(in) :: nn_msshc ! MDT correction scheme 59 REAL(wp) , INTENT(in) :: rn_mdtcorr ! User specified MDT correction 60 REAL(wp) , INTENT(in) :: rn_mdtcutoff ! MDT cutoff for computed correction 61 61 ! 62 62 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_rea_mdt' … … 105 105 106 106 ! Remove the offset between the MDT used with the sla and the model MDT 107 IF( nn_msshc == 1 .OR. nn_msshc == 2 ) & 108 & CALL obs_offset_mdt( jpi, jpj, z_mdt, zfill ) 109 110 ! Intepolate the MDT already on the model grid at the observation point 111 107 IF( nn_msshc == 1 .OR. nn_msshc == 2 ) THEN 108 CALL obs_offset_mdt( jpi, jpj, z_mdt, zfill, nn_msshc, & 109 & rn_mdtcorr, rn_mdtcutoff ) 110 ENDIF 111 112 ! Interpolate the MDT already on the model grid at the observation point 113 112 114 ALLOCATE( & 113 115 & igrdi(2,2,sladata%nsurf), & … … 118 120 & zmdtl(2,2,sladata%nsurf) & 119 121 & ) 120 122 121 123 DO jobs = 1, sladata%nsurf 122 124 … … 147 149 148 150 CALL obs_int_h2d( 1, 1, zweig, zmdtl(:,:,jobs), zext ) 149 150 sladata%rext(jobs, 2) = zext(1)151 152 sladata%rext(jobs,kmdt) = zext(1) 151 153 152 154 ! mark any masked data with a QC flag 153 155 IF( zobsmask(1) == 0 ) sladata%nqc(jobs) = IBSET(sladata%nqc(jobs),15) 154 156 155 156 157 END DO 158 157 159 DEALLOCATE( & 158 160 & igrdi, & … … 169 171 170 172 171 SUBROUTINE obs_offset_mdt( kpi, kpj, mdt, zfill ) 173 SUBROUTINE obs_offset_mdt( kpi, kpj, mdt, zfill, nn_msshc, rn_mdtcorr, & 174 rn_mdtcutoff ) 172 175 !!--------------------------------------------------------------------- 173 176 !! … … 183 186 !!---------------------------------------------------------------------- 184 187 INTEGER, INTENT(IN) :: kpi, kpj 185 REAL(wp), DIMENSION(kpi,kpj), INTENT(INOUT) :: mdt ! MDT used on the model grid 186 REAL(wp) , INTENT(IN ) :: zfill 188 REAL(wp), DIMENSION(kpi,kpj), INTENT(INOUT) :: mdt ! MDT used on the model grid 189 REAL(wp) , INTENT(IN ) :: zfill ! Fill value 190 INTEGER , INTENT(IN ) :: nn_msshc ! MDT correction scheme 191 REAL(wp) , INTENT(IN ) :: rn_mdtcorr ! User specified MDT correction 192 REAL(wp) , INTENT(IN ) :: rn_mdtcutoff ! MDT cutoff for computed correction 187 193 ! 188 194 INTEGER :: ji, jj … … 246 252 WRITE(numout,*) ' zcorr = ', zcorr 247 253 WRITE(numout,*) ' nn_msshc = ', nn_msshc 254 255 IF ( nn_msshc == 0 ) WRITE(numout,*) ' MSSH correction is not applied' 256 IF ( nn_msshc == 1 ) WRITE(numout,*) ' MSSH correction is applied' 257 IF ( nn_msshc == 2 ) WRITE(numout,*) ' User defined MSSH correction' 248 258 ENDIF 249 250 IF ( nn_msshc == 0 ) WRITE(numout,*) ' MSSH correction is not applied'251 IF ( nn_msshc == 1 ) WRITE(numout,*) ' MSSH correction is applied'252 IF ( nn_msshc == 2 ) WRITE(numout,*) ' User defined MSSH correction'253 259 254 260 ! -
NEMO/branches/UKMO/NEMO_4.0.4_FOAM_package_generic_obs/src/OCE/OBS/obs_rot_vel.F90
r14075 r15752 16 16 USE obs_utils ! For error handling 17 17 USE obs_profiles_def ! Profile definitions 18 USE obs_surf_def ! Surface definitions 18 19 USE obs_inter_h2d ! Horizontal interpolation 19 20 USE obs_inter_sup ! MPP support routines for interpolation … … 26 27 PRIVATE 27 28 28 PUBLIC obs_rotvel ! Rotate the observations 29 PUBLIC obs_rotvel_pro ! Rotate the profile velocity observations 30 PUBLIC obs_rotvel_surf ! Rotate the surface velocity observations 29 31 30 32 !!---------------------------------------------------------------------- … … 36 38 CONTAINS 37 39 38 SUBROUTINE obs_rotvel ( profdata, k2dint, pu, pv )40 SUBROUTINE obs_rotvel_pro( profdata, k2dint, kuvar, kvvar, pu, pv ) 39 41 !!--------------------------------------------------------------------- 40 42 !! 41 !! *** ROUTINE obs_r ea_pro_dri***43 !! *** ROUTINE obs_rotvel_pro *** 42 44 !! 43 45 !! ** Purpose : Rotate velocity data into N-S,E-W directorions … … 57 59 !! * Arguments 58 60 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Profile data to be read 59 INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation methed 61 INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation method 62 INTEGER, INTENT(IN) :: kuvar ! Index of U velocity 63 INTEGER, INTENT(IN) :: kvvar ! Index of V velocity 60 64 REAL(wp), DIMENSION(*) :: & 61 65 & pu, & … … 185 189 zsin = 0.5_wp * ( zsinu(1) + zsinv(1) ) 186 190 187 IF ( ( profdata%npvsta(ji, 1) /= profdata%npvsta(ji,2) ) .OR. &188 & ( profdata%npvend(ji, 1) /= profdata%npvend(ji,2) ) ) THEN191 IF ( ( profdata%npvsta(ji,kuvar) /= profdata%npvsta(ji,kvvar) ) .OR. & 192 & ( profdata%npvend(ji,kuvar) /= profdata%npvend(ji,kvvar) ) ) THEN 189 193 CALL fatal_error( 'Different number of U and V observations '// & 190 194 'in a profile in obs_rotvel', __LINE__ ) 191 195 ENDIF 192 196 193 DO jk = profdata%npvsta(ji, 1), profdata%npvend(ji,1)194 IF ( ( profdata%var( 1)%vmod(jk) /= fbrmdi ) .AND. &195 & ( profdata%var( 2)%vmod(jk) /= fbrmdi ) ) THEN196 pu(jk) = profdata%var( 1)%vmod(jk) * zcos - &197 & profdata%var( 2)%vmod(jk) * zsin198 pv(jk) = profdata%var( 2)%vmod(jk) * zcos + &199 & profdata%var( 1)%vmod(jk) * zsin197 DO jk = profdata%npvsta(ji,kuvar), profdata%npvend(ji,kuvar) 198 IF ( ( profdata%var(kuvar)%vmod(jk) /= fbrmdi ) .AND. & 199 & ( profdata%var(kvvar)%vmod(jk) /= fbrmdi ) ) THEN 200 pu(jk) = profdata%var(kuvar)%vmod(jk) * zcos - & 201 & profdata%var(kvvar)%vmod(jk) * zsin 202 pv(jk) = profdata%var(kvvar)%vmod(jk) * zcos + & 203 & profdata%var(kuvar)%vmod(jk) * zsin 200 204 ELSE 201 205 pu(jk) = fbrmdi … … 224 228 & ) 225 229 226 END SUBROUTINE obs_rotvel 230 END SUBROUTINE obs_rotvel_pro 231 232 SUBROUTINE obs_rotvel_surf( surfdata, k2dint, kuvar, kvvar, pu, pv ) 233 !!--------------------------------------------------------------------- 234 !! 235 !! *** ROUTINE obs_rotvel_surf *** 236 !! 237 !! ** Purpose : Rotate surface velocity data into N-S,E-W directorions 238 !! 239 !! ** Method : Interpolation of geo2ocean coefficients on U,V grid 240 !! to observation point followed by a similar computations 241 !! as in geo2ocean. 242 !! 243 !! ** Action : Review if there is a better way to do this. 244 !! 245 !! References : 246 !! 247 !! History : 248 !! ! : 2009-02 (K. Mogensen) : New routine 249 !!---------------------------------------------------------------------- 250 !! * Modules used 251 !! * Arguments 252 TYPE(obs_surf), INTENT(INOUT) :: surfdata ! Surface data to be read 253 INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation method 254 INTEGER, INTENT(IN) :: kuvar ! Index of U velocity 255 INTEGER, INTENT(IN) :: kvvar ! Index of V velocity 256 REAL(wp), DIMENSION(*) :: & 257 & pu, & 258 & pv 259 !! * Local declarations 260 REAL(wp), DIMENSION(2,2,1) :: zweig 261 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 262 & zmasku, & 263 & zmaskv, & 264 & zcoslu, & 265 & zsinlu, & 266 & zcoslv, & 267 & zsinlv, & 268 & zglamu, & 269 & zgphiu, & 270 & zglamv, & 271 & zgphiv 272 REAL(wp), DIMENSION(1) :: & 273 & zsinu, & 274 & zcosu, & 275 & zsinv, & 276 & zcosv 277 REAL(wp) :: zsin 278 REAL(wp) :: zcos 279 REAL(wp), DIMENSION(1) :: zobsmask 280 REAL(wp), DIMENSION(jpi,jpj) :: zsingu,zcosgu,zsingv,zcosgv 281 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 282 & igrdiu, & 283 & igrdju, & 284 & igrdiv, & 285 & igrdjv 286 INTEGER :: ji 287 INTEGER :: jk 288 289 !----------------------------------------------------------------------- 290 ! Allocate data for message parsing and interpolation 291 !----------------------------------------------------------------------- 292 293 ALLOCATE( & 294 & igrdiu(2,2,surfdata%nsurf), & 295 & igrdju(2,2,surfdata%nsurf), & 296 & zglamu(2,2,surfdata%nsurf), & 297 & zgphiu(2,2,surfdata%nsurf), & 298 & zmasku(2,2,surfdata%nsurf), & 299 & zcoslu(2,2,surfdata%nsurf), & 300 & zsinlu(2,2,surfdata%nsurf), & 301 & igrdiv(2,2,surfdata%nsurf), & 302 & igrdjv(2,2,surfdata%nsurf), & 303 & zglamv(2,2,surfdata%nsurf), & 304 & zgphiv(2,2,surfdata%nsurf), & 305 & zmaskv(2,2,surfdata%nsurf), & 306 & zcoslv(2,2,surfdata%nsurf), & 307 & zsinlv(2,2,surfdata%nsurf) & 308 & ) 309 310 !----------------------------------------------------------------------- 311 ! Receive the angles on the U and V grids. 312 !----------------------------------------------------------------------- 313 314 CALL obs_rot( zsingu, zcosgu, zsingv, zcosgv ) 315 316 DO ji = 1, surfdata%nsurf 317 igrdiu(1,1,ji) = surfdata%mi(ji,1)-1 318 igrdju(1,1,ji) = surfdata%mj(ji,1)-1 319 igrdiu(1,2,ji) = surfdata%mi(ji,1)-1 320 igrdju(1,2,ji) = surfdata%mj(ji,1) 321 igrdiu(2,1,ji) = surfdata%mi(ji,1) 322 igrdju(2,1,ji) = surfdata%mj(ji,1)-1 323 igrdiu(2,2,ji) = surfdata%mi(ji,1) 324 igrdju(2,2,ji) = surfdata%mj(ji,1) 325 igrdiv(1,1,ji) = surfdata%mi(ji,2)-1 326 igrdjv(1,1,ji) = surfdata%mj(ji,2)-1 327 igrdiv(1,2,ji) = surfdata%mi(ji,2)-1 328 igrdjv(1,2,ji) = surfdata%mj(ji,2) 329 igrdiv(2,1,ji) = surfdata%mi(ji,2) 330 igrdjv(2,1,ji) = surfdata%mj(ji,2)-1 331 igrdiv(2,2,ji) = surfdata%mi(ji,2) 332 igrdjv(2,2,ji) = surfdata%mj(ji,2) 333 END DO 334 335 CALL obs_int_comm_2d( 2, 2, surfdata%nsurf, jpi, jpj, igrdiu, igrdju, & 336 & glamu, zglamu ) 337 CALL obs_int_comm_2d( 2, 2, surfdata%nsurf, jpi, jpj, igrdiu, igrdju, & 338 & gphiu, zgphiu ) 339 CALL obs_int_comm_2d( 2, 2, surfdata%nsurf, jpi, jpj, igrdiu, igrdju, & 340 & umask(:,:,1), zmasku ) 341 CALL obs_int_comm_2d( 2, 2, surfdata%nsurf, jpi, jpj, igrdiu, igrdju, & 342 & zsingu, zsinlu ) 343 CALL obs_int_comm_2d( 2, 2, surfdata%nsurf, jpi, jpj, igrdiu, igrdju, & 344 & zcosgu, zcoslu ) 345 CALL obs_int_comm_2d( 2, 2, surfdata%nsurf, jpi, jpj, igrdiv, igrdjv, & 346 & glamv, zglamv ) 347 CALL obs_int_comm_2d( 2, 2, surfdata%nsurf, jpi, jpj, igrdiv, igrdjv, & 348 & gphiv, zgphiv ) 349 CALL obs_int_comm_2d( 2, 2, surfdata%nsurf, jpi, jpj, igrdiv, igrdjv, & 350 & vmask(:,:,1), zmaskv ) 351 CALL obs_int_comm_2d( 2, 2, surfdata%nsurf, jpi, jpj, igrdiv, igrdjv, & 352 & zsingv, zsinlv ) 353 CALL obs_int_comm_2d( 2, 2, surfdata%nsurf, jpi, jpj, igrdiv, igrdjv, & 354 & zcosgv, zcoslv ) 355 356 DO ji = 1, surfdata%nsurf 357 358 CALL obs_int_h2d_init( 1, 1, k2dint, & 359 & surfdata%rlam(ji), surfdata%rphi(ji), & 360 & zglamu(:,:,ji), zgphiu(:,:,ji), & 361 & zmasku(:,:,ji), zweig, zobsmask ) 362 363 CALL obs_int_h2d( 1, 1, zweig, zsinlu(:,:,ji), zsinu ) 364 365 CALL obs_int_h2d( 1, 1, zweig, zcoslu(:,:,ji), zcosu ) 366 367 CALL obs_int_h2d_init( 1, 1, k2dint, & 368 & surfdata%rlam(ji), surfdata%rphi(ji), & 369 & zglamv(:,:,ji), zgphiv(:,:,ji), & 370 & zmaskv(:,:,ji), zweig, zobsmask ) 371 372 CALL obs_int_h2d( 1, 1, zweig, zsinlv(:,:,ji), zsinv ) 373 374 CALL obs_int_h2d( 1, 1, zweig, zcoslv(:,:,ji), zcosv ) 375 376 ! Assume that the angle at observation point is the 377 ! mean of u and v cosines/sines 378 379 zcos = 0.5_wp * ( zcosu(1) + zcosv(1) ) 380 zsin = 0.5_wp * ( zsinu(1) + zsinv(1) ) 381 382 IF ( ( surfdata%rmod(ji,kuvar) /= fbrmdi ) .AND. & 383 & ( surfdata%rmod(ji,kvvar) /= fbrmdi ) ) THEN 384 pu(ji) = surfdata%rmod(ji,kuvar) * zcos - & 385 & surfdata%rmod(ji,kvvar) * zsin 386 pv(ji) = surfdata%rmod(ji,kvvar) * zcos + & 387 & surfdata%rmod(ji,kuvar) * zsin 388 ELSE 389 pu(ji) = fbrmdi 390 pv(ji) = fbrmdi 391 ENDIF 392 393 394 END DO 395 396 DEALLOCATE( & 397 & igrdiu, & 398 & igrdju, & 399 & zglamu, & 400 & zgphiu, & 401 & zmasku, & 402 & zcoslu, & 403 & zsinlu, & 404 & igrdiv, & 405 & igrdjv, & 406 & zglamv, & 407 & zgphiv, & 408 & zmaskv, & 409 & zcoslv, & 410 & zsinlv & 411 & ) 412 413 END SUBROUTINE obs_rotvel_surf 227 414 228 415 END MODULE obs_rot_vel -
NEMO/branches/UKMO/NEMO_4.0.4_FOAM_package_generic_obs/src/OCE/OBS/obs_surf_def.F90
r14075 r15752 23 23 USE obs_mpp, ONLY : & ! MPP tools 24 24 obs_mpp_sum_integer 25 USE obs_fbm ! Obs feedback format 25 26 26 27 IMPLICIT NONE … … 45 46 INTEGER :: nsurfmpp !: Global number of surface data within window 46 47 INTEGER :: nvar !: Number of variables at observation points 48 INTEGER :: nadd !: Number of additional fields at observation points 47 49 INTEGER :: nextra !: Number of extra fields at observation points 48 50 INTEGER :: nstp !: Number of time steps … … 55 57 56 58 INTEGER, POINTER, DIMENSION(:) :: & 57 & mi, & !: i-th grid coord. for interpolating to surface observation58 & mj, & !: j-th grid coord. for interpolating to surface observation59 59 & mt, & !: time record number for gridded data 60 60 & nsidx,& !: Surface observation number … … 69 69 & ntyp !: Type of surface observation product 70 70 71 CHARACTER(len=8), POINTER, DIMENSION(:) :: & 72 & cvars !: Variable names 73 74 CHARACTER(LEN=8), POINTER, DIMENSION(:) :: & 71 INTEGER, POINTER, DIMENSION(:,:) :: & 72 & mi, & !: i-th grid coord. for interpolating to surface observation 73 & mj !: j-th grid coord. for interpolating to surface observation 74 75 CHARACTER(len=ilenname), POINTER, DIMENSION(:) :: & 76 & cvars, & !: Variable names 77 & cextvars, & !: Extra variable names 78 & caddvars !: Additional variable names 79 80 CHARACTER(len=ilenlong), POINTER, DIMENSION(:) :: & 81 & clong, & !: Variable long names 82 & cextlong !: Extra variable long names 83 84 CHARACTER(len=ilenlong), POINTER, DIMENSION(:,:) :: & 85 & caddlong !: Additional variable long names 86 87 CHARACTER(len=ilenunit), POINTER, DIMENSION(:) :: & 88 & cunit, & !: Variable units 89 & cextunit !: Extra variable units 90 91 CHARACTER(len=ilenunit), POINTER, DIMENSION(:,:) :: & 92 & caddunit !: Additional variable units 93 94 CHARACTER(len=ilengrid), POINTER, DIMENSION(:) :: & 95 & cgrid !: Variable grids 96 97 CHARACTER(LEN=ilenwmo), POINTER, DIMENSION(:) :: & 75 98 & cwmo !: WMO indentifier 76 99 … … 86 109 & rext !: Extra fields interpolated to observation points 87 110 88 REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & 111 REAL(KIND=wp), POINTER, DIMENSION(:,:,:) :: & 112 & radd !: Additional fields interpolated to observation points 113 114 REAL(KIND=wp), POINTER, DIMENSION(:,:,:) :: & 89 115 & vdmean !: Time averaged of model field 90 116 … … 121 147 CONTAINS 122 148 123 SUBROUTINE obs_surf_alloc( surf, ksurf, kvar, k extra, kstp, kpi, kpj )149 SUBROUTINE obs_surf_alloc( surf, ksurf, kvar, kadd, kextra, kstp, kpi, kpj ) 124 150 !!---------------------------------------------------------------------- 125 151 !! *** ROUTINE obs_surf_alloc *** … … 136 162 INTEGER, INTENT(IN) :: ksurf ! Number of surface observations 137 163 INTEGER, INTENT(IN) :: kvar ! Number of surface variables 164 INTEGER, INTENT(IN) :: kadd ! Number of additional fields at observation points 138 165 INTEGER, INTENT(IN) :: kextra ! Number of extra fields at observation points 139 166 INTEGER, INTENT(IN) :: kstp ! Number of time steps … … 143 170 !!* Local variables 144 171 INTEGER :: ji 145 INTEGER :: jvar 172 INTEGER :: jvar, jadd, jext 146 173 147 174 ! Set bookkeeping variables … … 149 176 surf%nsurf = ksurf 150 177 surf%nsurfmpp = 0 178 surf%nadd = kadd 151 179 surf%nextra = kextra 152 180 surf%nvar = kvar … … 158 186 159 187 ALLOCATE( & 160 & surf%cvars(kvar) & 188 & surf%cvars(kvar), & 189 & surf%clong(kvar), & 190 & surf%cunit(kvar), & 191 & surf%cgrid(kvar) & 161 192 & ) 162 193 163 194 DO jvar = 1, kvar 164 195 surf%cvars(jvar) = "NotSet" 196 surf%clong(jvar) = "NotSet" 197 surf%cunit(jvar) = "NotSet" 198 surf%cgrid(jvar) = "" 199 END DO 200 201 ! Allocate additional/extra variable metadata 202 203 ALLOCATE( & 204 & surf%caddvars(kadd), & 205 & surf%caddlong(kadd,kvar), & 206 & surf%caddunit(kadd,kvar), & 207 & surf%cextvars(kextra), & 208 & surf%cextlong(kextra), & 209 & surf%cextunit(kextra) & 210 ) 211 212 DO jadd = 1, kadd 213 surf%caddvars(jadd) = "NotSet" 214 DO jvar = 1, kvar 215 surf%caddlong(jadd,jvar) = "NotSet" 216 surf%caddunit(jadd,jvar) = "NotSet" 217 END DO 218 END DO 219 220 DO jext = 1, kextra 221 surf%cextvars(jext) = "NotSet" 222 surf%cextlong(jext) = "NotSet" 223 surf%cextunit(jext) = "NotSet" 165 224 END DO 166 225 … … 168 227 169 228 ALLOCATE( & 170 & surf%mi(ksurf), &171 & surf%mj(ksurf), &172 229 & surf%mt(ksurf), & 173 230 & surf%nsidx(ksurf), & … … 187 244 & ) 188 245 246 ALLOCATE( & 247 & surf%mi(ksurf,kvar), & 248 & surf%mj(ksurf,kvar) & 249 & ) 250 189 251 surf%mt(:) = -1 190 252 … … 205 267 surf%rext(:,:) = 0.0_wp 206 268 269 ! Allocate arrays of number of additional fields at observation points 270 271 ALLOCATE( & 272 & surf%radd(ksurf,kadd,kvar) & 273 & ) 274 275 surf%radd(:,:,:) = 0.0_wp 276 207 277 ! Allocate arrays of number of time step size 208 278 … … 215 285 216 286 ALLOCATE( & 217 & surf%vdmean(kpi,kpj ) &287 & surf%vdmean(kpi,kpj,kvar) & 218 288 & ) 219 289 … … 291 361 & ) 292 362 363 ! Deallocate arrays of number of additional fields at observation points 364 365 DEALLOCATE( & 366 & surf%radd & 367 & ) 368 293 369 ! Deallocate arrays of size number of grid points size times 294 370 ! number of variables … … 308 384 309 385 DEALLOCATE( & 310 & surf%cvars & 311 & ) 386 & surf%cvars, & 387 & surf%clong, & 388 & surf%cunit, & 389 & surf%cgrid & 390 & ) 391 392 ! Dellocate additional/extra variables metadata 393 394 DEALLOCATE( & 395 & surf%caddvars, & 396 & surf%caddlong, & 397 & surf%caddunit, & 398 & surf%cextvars, & 399 & surf%cextlong, & 400 & surf%cextunit & 401 ) 312 402 313 403 END SUBROUTINE obs_surf_dealloc … … 343 433 INTEGER :: ji 344 434 INTEGER :: jk 435 INTEGER :: jadd 345 436 LOGICAL, DIMENSION(:), ALLOCATABLE :: llvalid 346 437 … … 361 452 362 453 IF ( lallocate ) THEN 363 CALL obs_surf_alloc( newsurf, insurf, surf%nvar, &454 CALL obs_surf_alloc( newsurf, insurf, surf%nvar, surf%nadd, & 364 455 & surf%nextra, surf%nstp, surf%npi, surf%npj ) 365 456 ENDIF … … 388 479 insurf = insurf + 1 389 480 390 newsurf%mi(insurf ) = surf%mi(ji)391 newsurf%mj(insurf ) = surf%mj(ji)481 newsurf%mi(insurf,:) = surf%mi(ji,:) 482 newsurf%mj(insurf,:) = surf%mj(ji,:) 392 483 newsurf%mt(insurf) = surf%mt(ji) 393 484 newsurf%nsidx(insurf) = surf%nsidx(ji) … … 410 501 newsurf%rmod(insurf,jk) = surf%rmod(ji,jk) 411 502 503 DO jadd = 1, surf%nadd 504 newsurf%radd(insurf,jadd,jk) = surf%radd(ji,jadd,jk) 505 END DO 506 412 507 END DO 413 508 … … 433 528 ! Set book keeping variables which do not depend on number of obs. 434 529 435 newsurf%nstp = surf%nstp 436 newsurf%cvars(:) = surf%cvars(:) 530 newsurf%nstp = surf%nstp 531 newsurf%cvars(:) = surf%cvars(:) 532 newsurf%clong(:) = surf%clong(:) 533 newsurf%cunit(:) = surf%cunit(:) 534 newsurf%cgrid(:) = surf%cgrid(:) 535 newsurf%caddvars(:) = surf%caddvars(:) 536 newsurf%caddlong(:,:) = surf%caddlong(:,:) 537 newsurf%caddunit(:,:) = surf%caddunit(:,:) 538 newsurf%cextvars(:) = surf%cextvars(:) 539 newsurf%cextlong(:) = surf%cextlong(:) 540 newsurf%cextunit(:) = surf%cextunit(:) 437 541 438 542 ! Set gridded stuff … … 470 574 INTEGER :: jj 471 575 INTEGER :: jk 576 INTEGER :: jadd 472 577 473 578 ! Copy data from surf to old surf … … 475 580 DO ji = 1, surf%nsurf 476 581 477 jj =surf%nsind(ji)478 479 oldsurf%mi(jj ) = surf%mi(ji)480 oldsurf%mj(jj ) = surf%mj(ji)582 jj = surf%nsind(ji) 583 584 oldsurf%mi(jj,:) = surf%mi(ji,:) 585 oldsurf%mj(jj,:) = surf%mj(ji,:) 481 586 oldsurf%mt(jj) = surf%mt(ji) 482 587 oldsurf%nsidx(jj) = surf%nsidx(ji) … … 500 605 DO ji = 1, surf%nsurf 501 606 502 jj =surf%nsind(ji)607 jj = surf%nsind(ji) 503 608 504 609 oldsurf%robs(jj,jk) = surf%robs(ji,jk) 505 610 oldsurf%rmod(jj,jk) = surf%rmod(ji,jk) 611 612 DO jadd = 1, surf%nadd 613 oldsurf%radd(jj,jadd,jk) = surf%radd(ji,jadd,jk) 614 END DO 506 615 507 616 END DO … … 513 622 DO ji = 1, surf%nsurf 514 623 515 jj =surf%nsind(ji)624 jj = surf%nsind(ji) 516 625 517 626 oldsurf%rext(jj,jk) = surf%rext(ji,jk) -
NEMO/branches/UKMO/NEMO_4.0.4_FOAM_package_generic_obs/src/OCE/OBS/obs_write.F90
r14075 r15752 54 54 CONTAINS 55 55 56 SUBROUTINE obs_wri_prof( profdata, padd, pext )56 SUBROUTINE obs_wri_prof( profdata, clfiletype, padd, pext ) 57 57 !!----------------------------------------------------------------------- 58 58 !! … … 77 77 !! * Arguments 78 78 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data 79 TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable 80 TYPE(obswriinfo), OPTIONAL :: pext ! Extra info 79 CHARACTER(LEN=25), INTENT(IN) :: clfiletype ! Base name for file name 80 TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable 81 TYPE(obswriinfo), OPTIONAL :: pext ! Extra info 81 82 82 83 !! * Local declarations 83 84 TYPE(obfbdata) :: fbdata 84 85 CHARACTER(LEN=40) :: clfname 85 CHARACTER(LEN=10) :: clfiletype 86 CHARACTER(LEN=ilenlong) :: cllongname ! Long name of variable 87 CHARACTER(LEN=ilenunit) :: clunits ! Units of variable 88 CHARACTER(LEN=ilengrid) :: clgrid ! Grid of variable 89 CHARACTER(LEN=12) :: clfmt ! writing format 90 INTEGER :: idg ! number of digits 86 91 INTEGER :: ilevel 87 92 INTEGER :: jvar 93 INTEGER :: jvar2 94 INTEGER :: jsal 88 95 INTEGER :: jo 89 96 INTEGER :: jk … … 111 118 ! Find maximum level 112 119 ilevel = 0 113 DO jvar = 1, 2120 DO jvar = 1, profdata%nvar 114 121 ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) ) 115 122 END DO 116 123 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 124 CALL alloc_obfbdata( fbdata, profdata%nvar, profdata%nprof, ilevel, & 125 & 1 + iadd, iext, .TRUE. ) 126 fbdata%caddname(1) = 'Hx' 127 DO jvar = 1, profdata%nvar 128 fbdata%cname(jvar) = profdata%cvars(jvar) 129 fbdata%coblong(jvar) = profdata%clong(jvar) 130 fbdata%cobunit(jvar) = profdata%cunit(jvar) 131 fbdata%cgrid(jvar) = profdata%cgrid(jvar) 132 fbdata%caddlong(1,jvar) = 'Model interpolated ' // TRIM(profdata%clong(jvar)) 133 fbdata%caddunit(1,jvar) = profdata%cunit(jvar) 134 IF (iadd > 0) THEN 135 DO ja = 1, iadd 136 fbdata%caddname(1+ja) = padd%cdname(ja) 145 137 fbdata%caddlong(1+ja,jvar) = padd%cdlong(ja,jvar) 146 138 fbdata%caddunit(1+ja,jvar) = padd%cdunit(ja,jvar) 147 139 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 179 fbdata%caddname(1) = 'Hx' 180 181 WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc 140 ENDIF 141 IF (iext > 0) THEN 142 DO je = 1, iext 143 fbdata%cextname(je) = pext%cdname(je) 144 fbdata%cextlong(je) = pext%cdlong(je,1) 145 fbdata%cextunit(je) = pext%cdunit(je,1) 146 END DO 147 ENDIF 148 END DO 149 150 WRITE(clfname, FMT="(A,'fb_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc 182 151 183 152 IF(lwp) THEN 184 153 WRITE(numout,*) 185 WRITE(numout,*) 'obs_wri_prof :'186 WRITE(numout,*) '~~~~~~~~~~~~~'187 WRITE(numout,*) 'Writing '//TRIM(clfiletype)//' feedback file : ',TRIM(clfname)154 WRITE(numout,*) 'obs_wri_prof :' 155 WRITE(numout,*) '~~~~~~~~~~~~~' 156 WRITE(numout,*) 'Writing '//TRIM(clfiletype)//' feedback file : ', TRIM(clfname) 188 157 ENDIF 189 158 … … 228 197 & krefdate = 19500101 ) 229 198 ! Reform the profiles arrays for output 230 DO jvar = 1, 2199 DO jvar = 1, profdata%nvar 231 200 DO jk = profdata%npvsta(jo,jvar), profdata%npvend(jo,jvar) 232 201 ik = profdata%var(jvar)%nvlidx(jk) … … 247 216 ENDIF 248 217 fbdata%iobsk(ik,jo,jvar) = profdata%var(jvar)%mvk(jk) 249 DO ja = 1, iadd 250 fbdata%padd(ik,jo,1+ja,jvar) = & 251 & profdata%var(jvar)%vext(jk,padd%ipoint(ja)) 218 IF (iadd > 0) THEN 219 DO ja = 1, iadd 220 fbdata%padd(ik,jo,1+ja,jvar) = & 221 & profdata%var(jvar)%vadd(jk,padd%ipoint(ja)) 222 END DO 223 ENDIF 224 END DO 225 END DO 226 IF (iext > 0) THEN 227 DO jk = profdata%npvstaext(jo), profdata%npvendext(jo) 228 ik = profdata%vext%nelidx(jk) 229 DO je = 1, iext 230 fbdata%pext(ik,jo,je) = & 231 & profdata%vext%eobs(jk,pext%ipoint(je)) 252 232 END DO 253 DO je = 1, iext 254 fbdata%pext(ik,jo,1+je) = & 255 & profdata%var(jvar)%vext(jk,pext%ipoint(je)) 256 END DO 257 IF ( ( jvar == 1 ) .AND. & 258 & ( TRIM(profdata%cvars(1)) == 'POTM' ) ) THEN 259 fbdata%pext(ik,jo,1) = profdata%var(jvar)%vext(jk,1) 260 ENDIF 261 END DO 262 END DO 233 END DO 234 ENDIF 263 235 END DO 264 236 265 IF ( TRIM(profdata%cvars(1)) == 'POTM' ) THEN 266 ! Convert insitu temperature to potential temperature using the model 267 ! salinity if no potential temperature 268 DO jo = 1, fbdata%nobs 269 IF ( fbdata%pphi(jo) < 9999.0 ) THEN 270 DO jk = 1, fbdata%nlev 271 IF ( ( fbdata%pob(jk,jo,1) >= 9999.0 ) .AND. & 272 & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 273 & ( fbdata%padd(jk,jo,1,2) < 9999.0 ) .AND. & 274 & ( fbdata%pext(jk,jo,1) < 9999.0 ) ) THEN 275 zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), & 276 & REAL(fbdata%pphi(jo),wp) ) 277 fbdata%pob(jk,jo,1) = potemp( & 278 & REAL(fbdata%padd(jk,jo,1,2), wp), & 279 & REAL(fbdata%pext(jk,jo,1), wp), & 280 & zpres, 0.0_wp ) 237 ! Convert insitu temperature to potential temperature using the model 238 ! salinity if no potential temperature 239 IF (iext > 0) THEN 240 DO jvar = 1, profdata%nvar 241 IF ( TRIM(profdata%cvars(jvar)) == 'POTM' ) THEN 242 jsal = 0 243 DO jvar2 = 1, profdata%nvar 244 IF ( TRIM(profdata%cvars(jvar2)) == 'PSAL' ) THEN 245 jsal = jvar2 246 EXIT 281 247 ENDIF 282 248 END DO 249 IF (jsal > 0) THEN 250 DO je = 1, iext 251 IF ( TRIM(fbdata%cextname(je)) == 'TEMP' ) THEN 252 DO jo = 1, fbdata%nobs 253 IF ( fbdata%pphi(jo) < 9999.0 ) THEN 254 DO jk = 1, fbdata%nlev 255 IF ( ( fbdata%pob(jk,jo,jvar) >= 9999.0 ) .AND. & 256 & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 257 & ( fbdata%padd(jk,jo,1,jsal) < 9999.0 ) .AND. & 258 & ( fbdata%pext(jk,jo,je) < 9999.0 ) ) THEN 259 zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), & 260 & REAL(fbdata%pphi(jo),wp) ) 261 fbdata%pob(jk,jo,jvar) = potemp( & 262 & REAL(fbdata%padd(jk,jo,1,jsal), wp), & 263 & REAL(fbdata%pext(jk,jo,je), wp), & 264 & zpres, 0.0_wp ) 265 ENDIF 266 END DO 267 ENDIF 268 END DO 269 EXIT 270 ENDIF 271 END DO 272 ENDIF 273 EXIT 283 274 ENDIF 284 275 END DO … … 295 286 END SUBROUTINE obs_wri_prof 296 287 297 SUBROUTINE obs_wri_surf( surfdata, padd, pext )288 SUBROUTINE obs_wri_surf( surfdata, clfiletype, padd, pext ) 298 289 !!----------------------------------------------------------------------- 299 290 !! … … 315 306 316 307 !! * Arguments 317 TYPE(obs_surf), INTENT(INOUT) :: surfdata ! Full set of surface data 318 TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable 319 TYPE(obswriinfo), OPTIONAL :: pext ! Extra info 308 TYPE(obs_surf), INTENT(INOUT) :: surfdata ! Full set of surface data 309 CHARACTER(LEN=25), INTENT(IN) :: clfiletype ! Base name for file name 310 TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable 311 TYPE(obswriinfo), OPTIONAL :: pext ! Extra info 320 312 321 313 !! * Local declarations 322 314 TYPE(obfbdata) :: fbdata 323 315 CHARACTER(LEN=40) :: clfname ! netCDF filename 324 CHARACTER(LEN=10) :: clfiletype 316 CHARACTER(LEN=ilenlong) :: cllongname ! Long name of variable 317 CHARACTER(LEN=ilenunit) :: clunits ! Units of variable 318 CHARACTER(LEN=ilengrid) :: clgrid ! Grid of variable 325 319 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_surf' 326 320 INTEGER :: jo 327 321 INTEGER :: ja 328 322 INTEGER :: je 323 INTEGER :: jvar 329 324 INTEGER :: iadd 330 325 INTEGER :: iext … … 344 339 CALL init_obfbdata( fbdata ) 345 340 346 SELECT CASE ( TRIM(surfdata%cvars(1)) ) 347 CASE('SLA') 348 349 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 350 & 2 + iadd, 1 + iext, .TRUE. ) 351 352 clfiletype = 'slafb' 353 fbdata%cname(1) = surfdata%cvars(1) 354 fbdata%coblong(1) = 'Sea level anomaly' 355 fbdata%cobunit(1) = 'Metres' 356 fbdata%cextname(1) = 'MDT' 357 fbdata%cextlong(1) = 'Mean dynamic topography' 358 fbdata%cextunit(1) = 'Metres' 359 DO je = 1, iext 360 fbdata%cextname(je) = pext%cdname(je) 361 fbdata%cextlong(je) = pext%cdlong(je,1) 362 fbdata%cextunit(je) = pext%cdunit(je,1) 363 END DO 364 fbdata%caddlong(1,1) = 'Model interpolated SSH - MDT' 365 fbdata%caddunit(1,1) = 'Metres' 366 fbdata%caddname(2) = 'SSH' 367 fbdata%caddlong(2,1) = 'Model Sea surface height' 368 fbdata%caddunit(2,1) = 'Metres' 369 fbdata%cgrid(1) = 'T' 370 DO ja = 1, iadd 371 fbdata%caddname(2+ja) = padd%cdname(ja) 372 fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1) 373 fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1) 374 END DO 375 376 CASE('SST') 377 378 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 341 CALL alloc_obfbdata( fbdata, surfdata%nvar, surfdata%nsurf, 1, & 379 342 & 1 + iadd, iext, .TRUE. ) 380 381 clfiletype = 'sstfb'382 fbdata%cname(1) = surfdata%cvars(1)383 fbdata%coblong(1) = 'Sea surface temperature'384 fbdata%cobunit(1) = 'Degree centigrade'385 DO je = 1, iext386 fbdata%cextname(je) = pext%cdname(je)387 fbdata%cextlong(je) = pext%cdlong(je,1)388 fbdata%cextunit(je) = pext%cdunit(je,1)389 END DO390 fbdata%caddlong(1,1) = 'Model interpolated SST'391 fbdata%caddunit(1,1) = 'Degree centigrade'392 fbdata%cgrid(1) = 'T'393 DO ja = 1, iadd394 fbdata%caddname(1+ja) = padd%cdname(ja)395 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1)396 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1)397 END DO398 399 CASE('ICECONC')400 401 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, &402 & 1 + iadd, iext, .TRUE. )403 404 clfiletype = 'sicfb'405 fbdata%cname(1) = surfdata%cvars(1)406 fbdata%coblong(1) = 'Sea ice'407 fbdata%cobunit(1) = 'Fraction'408 DO je = 1, iext409 fbdata%cextname(je) = pext%cdname(je)410 fbdata%cextlong(je) = pext%cdlong(je,1)411 fbdata%cextunit(je) = pext%cdunit(je,1)412 END DO413 fbdata%caddlong(1,1) = 'Model interpolated ICE'414 fbdata%caddunit(1,1) = 'Fraction'415 fbdata%cgrid(1) = 'T'416 DO ja = 1, iadd417 fbdata%caddname(1+ja) = padd%cdname(ja)418 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1)419 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1)420 END DO421 422 CASE('SSS')423 424 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, &425 & 1 + iadd, iext, .TRUE. )426 427 clfiletype = 'sssfb'428 fbdata%cname(1) = surfdata%cvars(1)429 fbdata%coblong(1) = 'Sea surface salinity'430 fbdata%cobunit(1) = 'psu'431 DO je = 1, iext432 fbdata%cextname(je) = pext%cdname(je)433 fbdata%cextlong(je) = pext%cdlong(je,1)434 fbdata%cextunit(je) = pext%cdunit(je,1)435 END DO436 fbdata%caddlong(1,1) = 'Model interpolated SSS'437 fbdata%caddunit(1,1) = 'psu'438 fbdata%cgrid(1) = 'T'439 DO ja = 1, iadd440 fbdata%caddname(1+ja) = padd%cdname(ja)441 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1)442 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1)443 END DO444 445 CASE DEFAULT446 447 CALL ctl_stop( 'Unknown observation type '//TRIM(surfdata%cvars(1))//' in obs_wri_surf' )448 449 END SELECT450 451 343 fbdata%caddname(1) = 'Hx' 452 453 WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc 344 DO jvar = 1, surfdata%nvar 345 fbdata%cname(jvar) = surfdata%cvars(jvar) 346 fbdata%coblong(jvar) = surfdata%clong(jvar) 347 fbdata%cobunit(jvar) = surfdata%cunit(jvar) 348 fbdata%cgrid(jvar) = surfdata%cgrid(jvar) 349 fbdata%caddlong(1,jvar) = 'Model interpolated ' // TRIM(surfdata%clong(jvar)) 350 fbdata%caddunit(1,jvar) = surfdata%cunit(jvar) 351 IF (iadd > 0) THEN 352 DO ja = 1, iadd 353 fbdata%caddname(1+ja) = padd%cdname(ja) 354 fbdata%caddlong(1+ja,jvar) = padd%cdlong(ja,jvar) 355 fbdata%caddunit(1+ja,jvar) = padd%cdunit(ja,jvar) 356 END DO 357 ENDIF 358 IF (iext > 0) THEN 359 DO je = 1, iext 360 fbdata%cextname(je) = pext%cdname(je) 361 fbdata%cextlong(je) = pext%cdlong(je,1) 362 fbdata%cextunit(je) = pext%cdunit(je,1) 363 END DO 364 ENDIF 365 END DO 366 367 WRITE(clfname, FMT="(A,'fb_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc 454 368 455 369 IF(lwp) THEN 456 370 WRITE(numout,*) 457 WRITE(numout,*) 'obs_wri_surf :'458 WRITE(numout,*) '~~~~~~~~~~~~~'459 WRITE(numout,*) 'Writing '//TRIM(surfdata%cvars(1))//' feedback file : ',TRIM(clfname)371 WRITE(numout,*) 'obs_wri_surf :' 372 WRITE(numout,*) '~~~~~~~~~~~~~' 373 WRITE(numout,*) 'Writing '//TRIM(surfdata%cvars(1))//' feedback file : ', TRIM(clfname) 460 374 ENDIF 461 375 … … 484 398 fbdata%cdwmo(jo) = surfdata%cwmo(jo) 485 399 fbdata%kindex(jo) = surfdata%nsfil(jo) 486 IF (ln_grid_global) THEN 487 fbdata%iobsi(jo,1) = surfdata%mi(jo) 488 fbdata%iobsj(jo,1) = surfdata%mj(jo) 489 ELSE 490 fbdata%iobsi(jo,1) = mig(surfdata%mi(jo)) 491 fbdata%iobsj(jo,1) = mjg(surfdata%mj(jo)) 492 ENDIF 400 DO jvar = 1, surfdata%nvar 401 IF (ln_grid_global) THEN 402 fbdata%iobsi(jo,jvar) = surfdata%mi(jo,jvar) 403 fbdata%iobsj(jo,jvar) = surfdata%mj(jo,jvar) 404 ELSE 405 fbdata%iobsi(jo,jvar) = mig(surfdata%mi(jo,jvar)) 406 fbdata%iobsj(jo,jvar) = mjg(surfdata%mj(jo,jvar)) 407 ENDIF 408 END DO 493 409 CALL greg2jul( 0, & 494 410 & surfdata%nmin(jo), & … … 498 414 & surfdata%nyea(jo), & 499 415 & fbdata%ptim(jo), & 500 & krefdate = 19500101 ) 501 fbdata%padd(1,jo,1,1) = surfdata%rmod(jo,1) 502 IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%padd(1,jo,2,1) = surfdata%rext(jo,1) 503 fbdata%pob(1,jo,1) = surfdata%robs(jo,1) 416 & krefdate = 19500101 ) 504 417 fbdata%pdep(1,jo) = 0.0 505 418 fbdata%idqc(1,jo) = 0 506 419 fbdata%idqcf(:,1,jo) = 0 507 IF ( surfdata%nqc(jo) > 255 ) THEN 508 fbdata%ivqc(jo,1) = 4 509 fbdata%ivlqc(1,jo,1) = 4 510 fbdata%ivlqcf(1,1,jo,1) = 0 420 DO jvar = 1, surfdata%nvar 421 fbdata%padd(1,jo,1,jvar) = surfdata%rmod(jo,jvar) 422 fbdata%pob(1,jo,jvar) = surfdata%robs(jo,jvar) 423 IF ( surfdata%nqc(jo) > 255 ) THEN 424 fbdata%ivqc(jo,jvar) = 4 425 fbdata%ivlqc(1,jo,jvar) = 4 426 fbdata%ivlqcf(1,1,jo,jvar) = 0 511 427 !$AGRIF_DO_NOT_TREAT 512 fbdata%ivlqcf(2,1,jo,1) = IAND(surfdata%nqc(jo),b'0000000011111111')428 fbdata%ivlqcf(2,1,jo,jvar) = IAND(surfdata%nqc(jo),b'0000000011111111') 513 429 !$AGRIF_END_DO_NOT_TREAT 514 ELSE 515 fbdata%ivqc(jo,1) = surfdata%nqc(jo) 516 fbdata%ivlqc(1,jo,1) = surfdata%nqc(jo) 517 fbdata%ivlqcf(:,1,jo,1) = 0 518 ENDIF 519 fbdata%iobsk(1,jo,1) = 0 520 IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%pext(1,jo,1) = surfdata%rext(jo,2) 521 DO ja = 1, iadd 522 fbdata%padd(1,jo,2+ja,1) = & 523 & surfdata%rext(jo,padd%ipoint(ja)) 430 ELSE 431 fbdata%ivqc(jo,jvar) = surfdata%nqc(jo) 432 fbdata%ivlqc(1,jo,jvar) = surfdata%nqc(jo) 433 fbdata%ivlqcf(:,1,jo,jvar) = 0 434 ENDIF 435 fbdata%iobsk(1,jo,jvar) = 0 436 IF (iadd > 0) THEN 437 DO ja = 1, iadd 438 fbdata%padd(1,jo,1+ja,jvar) = & 439 & surfdata%radd(jo,padd%ipoint(ja),jvar) 440 END DO 441 ENDIF 524 442 END DO 525 DO je = 1, iext 526 fbdata%pext(1,jo,1+je) = & 527 & surfdata%rext(jo,pext%ipoint(je)) 528 END DO 443 IF (iext > 0) THEN 444 DO je = 1, iext 445 fbdata%pext(1,jo,je) = & 446 & surfdata%rext(jo,pext%ipoint(je)) 447 END DO 448 ENDIF 529 449 END DO 530 450 … … 574 494 575 495 DO jvar = 1, fbdata%nvar 576 zsumx =0.0_wp577 zsumx2 =0.0_wp578 inumgoodobs =0496 zsumx = 0.0_wp 497 zsumx2 = 0.0_wp 498 inumgoodobs = 0 579 499 DO jo = 1, fbdata%nobs 580 500 DO jk = 1, fbdata%nlev … … 583 503 & ( fbdata%padd(jk,jo,1,jvar) < 9999.0 ) ) THEN 584 504 585 zomb =fbdata%pob(jk, jo, jvar)-fbdata%padd(jk, jo, 1, jvar)586 zsumx =zsumx+zomb587 zsumx2 =zsumx2+zomb**2588 inumgoodobs =inumgoodobs+1505 zomb = fbdata%pob(jk, jo, jvar)-fbdata%padd(jk, jo, 1, jvar) 506 zsumx = zsumx + zomb 507 zsumx2 = zsumx2 + zomb**2 508 inumgoodobs = inumgoodobs + 1 589 509 ENDIF 590 510 ENDDO … … 596 516 597 517 IF (lwp) THEN 598 WRITE(numout,*) 'Type: ',fbdata%cname(jvar),' Total number of good observations: ',inumgoodobsmpp 599 WRITE(numout,*) 'Overall mean obs minus model of the good observations: ',zsumx/inumgoodobsmpp 600 WRITE(numout,*) 'Overall RMS obs minus model of the good observations: ',sqrt( zsumx2/inumgoodobsmpp ) 518 WRITE(numout,*) 'Type: ', fbdata%cname(jvar), ' Total number of good observations: ', inumgoodobsmpp 519 IF ( inumgoodobsmpp > 0 ) THEN 520 WRITE(numout,*) 'Overall mean obs minus model of the good observations: ', zsumx/inumgoodobsmpp 521 WRITE(numout,*) 'Overall RMS obs minus model of the good observations: ', sqrt( zsumx2/inumgoodobsmpp ) 522 ENDIF 601 523 WRITE(numout,*) '' 602 524 ENDIF -
NEMO/branches/UKMO/NEMO_4.0.4_FOAM_package_generic_obs/src/OCE/TRA/tradmp.F90
r14075 r15752 50 50 ! 51 51 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: resto !: restoring coeff. on T and S (s-1) 52 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tclim !: temperature climatology on each time step(Celcius) 53 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sclim !: salinity climatology on each time step (psu) 52 54 53 55 !! * Substitutions … … 64 66 !! *** FUNCTION tra_dmp_alloc *** 65 67 !!---------------------------------------------------------------------- 66 ALLOCATE( resto(jpi,jpj,jpk), STAT= tra_dmp_alloc ) 68 ALLOCATE( resto(jpi,jpj,jpk), & 69 & tclim(jpi,jpj,jpk), & 70 & sclim(jpi,jpj,jpk), STAT= tra_dmp_alloc ) 67 71 ! 68 72 CALL mpp_sum ( 'tradmp', tra_dmp_alloc ) … … 106 110 CALL dta_tsd( kt, zts_dta ) ! read and interpolates T-S data at kt 107 111 ! 112 tclim(:,:,:) = zts_dta(:,:,:,jp_tem) 113 sclim(:,:,:) = zts_dta(:,:,:,jp_sal) 114 ! 108 115 SELECT CASE ( nn_zdmp ) !== type of damping ==! 109 116 !
Note: See TracChangeset
for help on using the changeset viewer.