- Timestamp:
- 2018-10-29T11:08:56+01:00 (5 years ago)
- Location:
- branches/UKMO/dev_r5518_AMM15_package
- Files:
-
- 19 deleted
- 22 edited
- 5 copied
Legend:
- Unmodified
- Added
- Removed
-
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/CONFIG/SHARED/namelist_ref
r5501 r10247 1193 1193 &namobs ! observation usage switch ('key_diaobs') 1194 1194 !----------------------------------------------------------------------- 1195 ln_t3d = .false. ! Logical switch for T profile observations 1196 ln_s3d = .false. ! Logical switch for S profile observations 1197 ln_ena = .false. ! Logical switch for ENACT insitu data set 1198 ! ! ln_cor Logical switch for Coriolis insitu data set 1199 ln_profb = .false. ! Logical switch for feedback insitu data set 1200 ln_sla = .false. ! Logical switch for SLA observations 1201 1202 ln_sladt = .false. ! Logical switch for AVISO SLA data 1203 1204 ln_slafb = .false. ! Logical switch for feedback SLA data 1205 ! ln_ssh Logical switch for SSH observations 1206 1207 ln_sst = .false. ! Logical switch for SST observations 1208 ln_reysst = .false. ! ln_reysst Logical switch for Reynolds observations 1209 ln_ghrsst = .false. ! ln_ghrsst Logical switch for GHRSST observations 1210 1211 ln_sstfb = .false. ! Logical switch for feedback SST data 1212 ! ln_sss Logical switch for SSS observations 1213 ln_seaice = .false. ! Logical switch for Sea Ice observations 1214 ! ln_vel3d Logical switch for velocity observations 1215 ! ln_velavcur Logical switch for velocity daily av. cur. 1216 ! ln_velhrcur Logical switch for velocity high freq. cur. 1217 ! ln_velavadcp Logical switch for velocity daily av. ADCP 1218 ! ln_velhradcp Logical switch for velocity high freq. ADCP 1219 ! ln_velfb Logical switch for feedback velocity data 1220 ! ln_grid_global Global distribtion of observations 1221 ! ln_grid_search_lookup Logical switch for obs grid search w/lookup table 1222 ! grid_search_file Grid search lookup file header 1223 ! enactfiles ENACT input observation file names 1224 ! coriofiles Coriolis input observation file name 1225 ! ! profbfiles: Profile feedback input observation file name 1226 profbfiles = 'profiles_01.nc' 1227 ! ln_profb_enatim Enact feedback input time setting switch 1228 ! slafilesact Active SLA input observation file name 1229 ! slafilespas Passive SLA input observation file name 1230 ! ! slafbfiles: Feedback SLA input observation file name 1231 slafbfiles = 'sla_01.nc' 1232 ! sstfiles GHRSST input observation file name 1233 ! ! sstfbfiles: Feedback SST input observation file name 1234 sstfbfiles = 'sst_01.nc' 1235 ! seaicefiles Sea Ice input observation file names 1236 seaicefiles = 'seaice_01.nc' 1237 ! velavcurfiles Vel. cur. daily av. input file name 1238 ! velhvcurfiles Vel. cur. high freq. input file name 1239 ! velavadcpfiles Vel. ADCP daily av. input file name 1240 ! velhvadcpfiles Vel. ADCP high freq. input file name 1241 ! velfbfiles Vel. feedback input observation file name 1242 ! dobsini Initial date in window YYYYMMDD.HHMMSS 1243 ! dobsend Final date in window YYYYMMDD.HHMMSS 1244 ! n1dint Type of vertical interpolation method 1245 ! n2dint Type of horizontal interpolation method 1246 ! ln_nea Rejection of observations near land switch 1247 nmsshc = 0 ! MSSH correction scheme 1248 ! mdtcorr MDT correction 1249 ! mdtcutoff MDT cutoff for computed correction 1250 ln_altbias = .false. ! Logical switch for alt bias 1251 ln_ignmis = .true. ! Logical switch for ignoring missing files 1252 ! endailyavtypes ENACT daily average types 1253 ln_grid_global = .true. 1254 ln_grid_search_lookup = .false. 1195 ln_diaobs = .false. ! Logical switch for the observation operator 1196 ln_t3d = .false. ! Logical switch for T profile observations 1197 ln_s3d = .false. ! Logical switch for S profile observations 1198 ln_sla = .false. ! Logical switch for SLA observations 1199 ln_sst = .false. ! Logical switch for SST observations 1200 ln_sic = .false. ! Logical switch for Sea Ice observations 1201 ln_vel3d = .false. ! Logical switch for velocity observations 1202 ln_sss = .false. ! Logical swithc for SSS observations 1203 ln_slchltot = .false. ! Logical switch for surface total log10(chlorophyll) obs 1204 ln_slchldia = .false. ! Logical switch for surface diatom log10(chlorophyll) obs 1205 ln_slchlnon = .false. ! Logical switch for surface non-diatom log10(chlorophyll) obs 1206 ln_slchldin = .false. ! Logical switch for surface dinoflagellate log10(chlorophyll) obs 1207 ln_slchlmic = .false. ! Logical switch for surface microphytoplankton log10(chlorophyll) obs 1208 ln_slchlnan = .false. ! Logical switch for surface nanophytoplankton log10(chlorophyll) obs 1209 ln_slchlpic = .false. ! Logical switch for surface picophytoplankton log10(chlorophyll) obs 1210 ln_schltot = .false. ! Logical switch for surface total chlorophyll obs 1211 ln_slphytot = .false. ! Logical switch for surface total log10(phytoplankton carbon) obs 1212 ln_slphydia = .false. ! Logical switch for surface diatom log10(phytoplankton carbon) obs 1213 ln_slphynon = .false. ! Logical switch for surface non-diatom log10(phytoplankton carbon) obs 1214 ln_sspm = .false. ! Logical switch for surface suspended particulate matter obs 1215 ln_sfco2 = .false. ! Logical switch for surface fugacity of carbon dioxide obs 1216 ln_spco2 = .false. ! Logical switch for surface partial pressure of carbon dioxide obs 1217 ln_plchltot = .false. ! Logical switch for profile total log10(chlorophyll) obs 1218 ln_pchltot = .false. ! Logical switch for profile total chlorophyll obs 1219 ln_pno3 = .false. ! Logical switch for profile nitrate obs 1220 ln_psi4 = .false. ! Logical switch for profile silicate obs 1221 ln_ppo4 = .false. ! Logical switch for profile phosphate obs 1222 ln_pdic = .false. ! Logical switch for profile dissolved inorganic carbon obs 1223 ln_palk = .false. ! Logical switch for profile alkalinity obs 1224 ln_pph = .false. ! Logical switch for profile pH obs 1225 ln_po2 = .false. ! Logical switch for profile dissolved oxygen obs 1226 ln_altbias = .false. ! Logical switch for altimeter bias correction 1227 ln_sstbias = .false. ! Logical switch for SST bias correction 1228 ln_nea = .false. ! Logical switch for rejection of observations near land 1229 ln_grid_global = .true. ! Logical switch for global distribution of observations 1230 ln_grid_search_lookup = .false. ! Logical switch for obs grid search w/lookup table 1231 ln_ignmis = .true. ! Logical switch for ignoring missing files 1232 ln_s_at_t = .false. ! Logical switch for computing model S at T obs if not there 1233 ln_sstnight = .false. ! Logical switch for calculating night-time average for SST obs 1234 ln_default_fp_indegs = .true. ! Logical: T=> averaging footprint is in degrees, F=> in metres 1235 ln_sla_fp_indegs = .true. ! Logical: T=> averaging footprint is in degrees, F=> in metres 1236 ln_sst_fp_indegs = .true. 1237 ln_sss_fp_indegs = .true. 1238 ln_sic_fp_indegs = .true. 1239 ! All of the *files* variables below are arrays. Use namelist_cfg to add more files 1240 cn_profbfiles = 'profiles_01.nc' ! Profile feedback input observation file names 1241 cn_slafbfiles = 'sla_01.nc' ! SLA feedback input observation file names 1242 cn_sstfbfiles = 'sst_01.nc' ! SST feedback input observation file names 1243 cn_sicfbfiles = 'sic_01.nc' ! SIC feedback input observation file names 1244 cn_velfbfiles = 'vel_01.nc' ! Velocity feedback input observation file names 1245 cn_sssfbfiles = 'sss_01.nc' ! SSS feedback input observation file names 1246 cn_slchltotfbfiles = 'slchltot_01.nc' ! Surface total log10(chlorophyll) obs file names 1247 cn_slchldiafbfiles = 'slchldia_01.nc' ! Surface diatom log10(chlorophyll) obs file names 1248 cn_slchlnonfbfiles = 'slchlnon_01.nc' ! Surface non-diatom log10(chlorophyll) obs file names 1249 cn_slchldinfbfiles = 'slchldin_01.nc' ! Surface dinoflagellate log10(chlorophyll) obs file names 1250 cn_slchlmicfbfiles = 'slchlmic_01.nc' ! Surface microphytoplankton log10(chlorophyll) obs file names 1251 cn_slchlnanfbfiles = 'slchlnan_01.nc' ! Surface nanophytoplankton log10(chlorophyll) obs file names 1252 cn_slchlpicfbfiles = 'slchlpic_01.nc' ! Surface picophytoplankton log10(chlorophyll) obs file names 1253 cn_schltotfbfiles = 'schltot_01.nc' ! Surface total chlorophyll obs file names 1254 cn_slphytotfbfiles = 'slphytot_01.nc' ! Surface total log10(phytoplankton carbon) obs file names 1255 cn_slphydiafbfiles = 'slphydia_01.nc' ! Surface diatom log10(phytoplankton carbon) obs file names 1256 cn_slphynonfbfiles = 'slphynon_01.nc' ! Surface non-diatom log10(phytoplankton carbon) obs file names 1257 cn_sspmfbfiles = 'sspm_01.nc' ! Surface suspended particulate matter obs file names 1258 cn_sfco2fbfiles = 'sfco2_01.nc' ! Surface fugacity of carbon dioxide obs file names 1259 cn_spco2fbfiles = 'spco2_01.nc' ! Surface partial pressure of carbon dioxide obs file names 1260 cn_plchltotfbfiles = 'plchltot_01.nc' ! Profile total log10(chlorophyll) obs file names 1261 cn_pchltotfbfiles = 'pchltot_01.nc' ! Profile total chlorophyll obs file names 1262 cn_pno3fbfiles = 'pno3_01.nc' ! Profile nitrate obs file names 1263 cn_psi4fbfiles = 'psi4_01.nc' ! Profile silicate obs file names 1264 cn_ppo4fbfiles = 'ppo4_01.nc' ! Profile phosphate obs file names 1265 cn_pdicfbfiles = 'pdic_01.nc' ! Profile dissolved inorganic carbon obs file names 1266 cn_palkfbfiles = 'palk_01.nc' ! Profile alkalinity obs file names 1267 cn_pphfbfiles = 'pph_01.nc' ! Profile pH obs file names 1268 cn_po2fbfiles = 'po2_01.nc' ! Profile dissolved oxygen obs file names 1269 cn_altbiasfile = 'altbias.nc' ! Altimeter bias input file name 1270 cn_sstbiasfiles = 'sstbias.nc' ! SST bias input file names 1271 cn_gridsearchfile = 'gridsearch.nc' ! Grid search file name 1272 rn_gridsearchres = 0.5 ! Grid search resolution 1273 rn_default_avglamscl = 0. ! Default E/W diameter of observation footprint (metres/degrees) 1274 rn_default_avgphiscl = 0. ! Default N/S diameter of observation footprint (metres/degrees) 1275 rn_sla_avglamscl = 0. ! E/W diameter of SLA observation footprint (metres/degrees) 1276 rn_sla_avgphiscl = 0. ! N/S diameter of SLA observation footprint (metres/degrees) 1277 rn_sst_avglamscl = 0. ! E/W diameter of SST observation footprint (metres/degrees) 1278 rn_sst_avgphiscl = 0. ! N/S diameter of SST observation footprint (metres/degrees) 1279 rn_sss_avglamscl = 0. ! E/W diameter of SSS observation footprint (metres/degrees) 1280 rn_sss_avgphiscl = 0. ! N/S diameter of SSS observation footprint (metres/degrees) 1281 rn_sic_avglamscl = 0. ! E/W diameter of SIC observation footprint (metres/degrees) 1282 rn_sic_avgphiscl = 0. ! N/S diameter of SIC observation footprint (metres/degrees) 1283 nn_1dint = 0 ! Type of vertical interpolation method 1284 nn_2dint_default = 0 ! Default horizontal interpolation method 1285 nn_2dint_sla = -1 ! Horizontal interpolation method for SLA 1286 nn_2dint_sst = -1 ! Horizontal interpolation method for SST 1287 nn_2dint_sss = -1 ! Horizontal interpolation method for SSS 1288 nn_2dint_sic = -1 ! Horizontal interpolation method for SIC 1289 nn_msshc = 0 ! MSSH correction scheme 1290 rn_mdtcorr = 1.61 ! MDT correction 1291 rn_mdtcutoff = 65.0 ! MDT cutoff for computed correction 1292 nn_profdavtypes = -1 ! Profile daily average types - array 1293 1255 1294 / 1256 1295 !----------------------------------------------------------------------- -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/ASM/asminc.F90
r10246 r10247 72 72 REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: u_bkginc, v_bkginc !: Increment to the u- & v-components 73 73 REAL(wp), PUBLIC, DIMENSION(:) , ALLOCATABLE :: wgtiau !: IAU weights for each time step 74 #if defined key_asminc75 74 REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ssh_iau !: IAU-weighted sea surface height increment 76 #endif77 75 ! !!! time steps relative to the cycle interval [0,nitend-nit000-1] 78 76 INTEGER , PUBLIC :: nitbkg !: Time step of the background state used in the Jb term -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90
r10246 r10247 465 465 ENDIF 466 466 #endif 467 ! !* Fill boundary data arrays withAGRIF468 ! ! ------------------------------------ -467 ! !* Fill boundary data arrays for AGRIF 468 ! ! ------------------------------------ 469 469 #if defined key_agrif 470 470 IF( .NOT.Agrif_Root() ) CALL agrif_dta_ts( kt ) -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/OBS/diaobs.F90
r10246 r10247 6 6 !!====================================================================== 7 7 8 !!----------------------------------------------------------------------9 !! 'key_diaobs' : Switch on the observation diagnostic computation10 8 !!---------------------------------------------------------------------- 11 9 !! dia_obs_init : Reading and prepare observations … … 15 13 !! fin_date : Compute the final date YYYYMMDD.HHMMSS 16 14 !!---------------------------------------------------------------------- 17 !! * Modules used 15 !! * Modules used 18 16 USE wrk_nemo ! Memory Allocation 19 17 USE par_kind ! Precision variables … … 21 19 USE par_oce 22 20 USE dom_oce ! Ocean space and time domain variables 23 USE obs_fbm, ONLY: ln_cl4 ! Class 4 diagnostic switch 24 USE obs_read_prof ! Reading and allocation of observations (Coriolis) 25 USE obs_read_sla ! Reading and allocation of SLA observations 26 USE obs_read_sst ! Reading and allocation of SST observations 21 USE obs_read_prof ! Reading and allocation of profile obs 22 USE obs_read_surf ! Reading and allocation of surface obs 27 23 USE obs_readmdt ! Reading and allocation of MDT for SLA. 28 USE obs_read_seaice ! Reading and allocation of Sea Ice observations29 USE obs_read_vel ! Reading and allocation of velocity component observations30 24 USE obs_prep ! Preparation of obs. (grid search etc). 31 25 USE obs_oper ! Observation operators … … 33 27 USE obs_grid ! Grid searching 34 28 USE obs_read_altbias ! Bias treatment for altimeter 29 USE obs_sstbias ! Bias correction routine for SST 35 30 USE obs_profiles_def ! Profile data definitions 36 USE obs_profiles ! Profile data storage37 31 USE obs_surf_def ! Surface data definitions 38 USE obs_sla ! SLA data storage39 USE obs_sst ! SST data storage40 USE obs_seaice ! Sea Ice data storage41 32 USE obs_types ! Definitions for observation types 42 33 USE mpp_map ! MPP mapping … … 52 43 & dia_obs_dealloc ! Deallocate dia_obs data 53 44 54 !! * Shared Module variables55 LOGICAL, PUBLIC, PARAMETER :: &56 #if defined key_diaobs57 & lk_diaobs = .TRUE. !: Logical switch for observation diangostics58 #else59 & lk_diaobs = .FALSE. !: Logical switch for observation diangostics60 #endif61 62 45 !! * Module variables 63 LOGICAL, PUBLIC :: ln_t3d !: Logical switch for temperature profiles 64 LOGICAL, PUBLIC :: ln_s3d !: Logical switch for salinity profiles 65 LOGICAL, PUBLIC :: ln_ena !: Logical switch for the ENACT data set 66 LOGICAL, PUBLIC :: ln_cor !: Logical switch for the Coriolis data set 67 LOGICAL, PUBLIC :: ln_profb !: Logical switch for profile feedback datafiles 68 LOGICAL, PUBLIC :: ln_sla !: Logical switch for sea level anomalies 69 LOGICAL, PUBLIC :: ln_sladt !: Logical switch for SLA from AVISO files 70 LOGICAL, PUBLIC :: ln_slafb !: Logical switch for SLA from feedback files 71 LOGICAL, PUBLIC :: ln_sst !: Logical switch for sea surface temperature 72 LOGICAL, PUBLIC :: ln_reysst !: Logical switch for Reynolds sea surface temperature 73 LOGICAL, PUBLIC :: ln_ghrsst !: Logical switch for GHRSST data 74 LOGICAL, PUBLIC :: ln_sstfb !: Logical switch for SST from feedback files 75 LOGICAL, PUBLIC :: ln_seaice !: Logical switch for sea ice concentration 76 LOGICAL, PUBLIC :: ln_vel3d !: Logical switch for velocity component (u,v) observations 77 LOGICAL, PUBLIC :: ln_velavcur !: Logical switch for raw daily averaged netCDF current meter vel. data 78 LOGICAL, PUBLIC :: ln_velhrcur !: Logical switch for raw high freq netCDF current meter vel. data 79 LOGICAL, PUBLIC :: ln_velavadcp !: Logical switch for raw daily averaged netCDF ADCP vel. data 80 LOGICAL, PUBLIC :: ln_velhradcp !: Logical switch for raw high freq netCDF ADCP vel. data 81 LOGICAL, PUBLIC :: ln_velfb !: Logical switch for velocities from feedback files 82 LOGICAL, PUBLIC :: ln_ssh !: Logical switch for sea surface height 83 LOGICAL, PUBLIC :: ln_sss !: Logical switch for sea surface salinity 84 LOGICAL, PUBLIC :: ln_sstnight !: Logical switch for night mean SST observations 85 LOGICAL, PUBLIC :: ln_nea !: Remove observations near land 86 LOGICAL, PUBLIC :: ln_altbias !: Logical switch for altimeter bias 87 LOGICAL, PUBLIC :: ln_ignmis !: Logical switch for ignoring missing files 88 LOGICAL, PUBLIC :: ln_s_at_t !: Logical switch to compute model S at T observations 89 90 REAL(KIND=dp), PUBLIC :: dobsini !: Observation window start date YYYYMMDD.HHMMSS 91 REAL(KIND=dp), PUBLIC :: dobsend !: Observation window end date YYYYMMDD.HHMMSS 92 93 INTEGER, PUBLIC :: n1dint !: Vertical interpolation method 94 INTEGER, PUBLIC :: n2dint !: Horizontal interpolation method 95 46 LOGICAL, PUBLIC :: & 47 & lk_diaobs = .TRUE. !: Include this for backwards compatibility at NEMO 3.6. 48 LOGICAL :: ln_diaobs !: Logical switch for the obs operator 49 LOGICAL :: ln_sstnight !: Logical switch for night mean SST obs 50 LOGICAL :: ln_default_fp_indegs !: T=> Default obs footprint size specified in degrees, F=> in metres 51 LOGICAL :: ln_sla_fp_indegs !: T=> SLA obs footprint size specified in degrees, F=> in metres 52 LOGICAL :: ln_sst_fp_indegs !: T=> SST obs footprint size specified in degrees, F=> in metres 53 LOGICAL :: ln_sss_fp_indegs !: T=> SSS obs footprint size specified in degrees, F=> in metres 54 LOGICAL :: ln_sic_fp_indegs !: T=> sea-ice obs footprint size specified in degrees, F=> in metres 55 56 REAL(wp) :: rn_default_avglamscl !: Default E/W diameter of observation footprint 57 REAL(wp) :: rn_default_avgphiscl !: Default N/S diameter of observation footprint 58 REAL(wp) :: rn_sla_avglamscl !: E/W diameter of SLA observation footprint 59 REAL(wp) :: rn_sla_avgphiscl !: N/S diameter of SLA observation footprint 60 REAL(wp) :: rn_sst_avglamscl !: E/W diameter of SST observation footprint 61 REAL(wp) :: rn_sst_avgphiscl !: N/S diameter of SST observation footprint 62 REAL(wp) :: rn_sss_avglamscl !: E/W diameter of SSS observation footprint 63 REAL(wp) :: rn_sss_avgphiscl !: N/S diameter of SSS observation footprint 64 REAL(wp) :: rn_sic_avglamscl !: E/W diameter of sea-ice observation footprint 65 REAL(wp) :: rn_sic_avgphiscl !: N/S diameter of sea-ice observation footprint 66 67 INTEGER :: nn_1dint !: Vertical interpolation method 68 INTEGER :: nn_2dint_default !: Default horizontal interpolation method 69 INTEGER :: nn_2dint_sla !: SLA horizontal interpolation method (-1 = default) 70 INTEGER :: nn_2dint_sst !: SST horizontal interpolation method (-1 = default) 71 INTEGER :: nn_2dint_sss !: SSS horizontal interpolation method (-1 = default) 72 INTEGER :: nn_2dint_sic !: Seaice horizontal interpolation method (-1 = default) 73 96 74 INTEGER, DIMENSION(imaxavtypes) :: & 97 & endailyavtypes !: ENACT data types which are daily average 98 99 INTEGER, PARAMETER :: MaxNumFiles = 1000 100 LOGICAL, DIMENSION(MaxNumFiles) :: & 101 & ln_profb_ena, & !: Is the feedback files from ENACT data ? 102 ! !: If so use endailyavtypes 103 & ln_profb_enatim !: Change tim for 820 enact data set. 104 105 LOGICAL, DIMENSION(MaxNumFiles) :: & 106 & ln_velfb_av !: Is the velocity feedback files daily average? 75 & nn_profdavtypes !: Profile data types representing a daily average 76 INTEGER :: nproftypes !: Number of profile obs types 77 INTEGER :: nsurftypes !: Number of surface obs types 78 INTEGER, DIMENSION(:), ALLOCATABLE :: & 79 & nvarsprof, & !: Number of profile variables 80 & nvarssurf !: Number of surface variables 81 INTEGER, DIMENSION(:), ALLOCATABLE :: & 82 & nextrprof, & !: Number of profile extra variables 83 & nextrsurf !: Number of surface extra variables 84 INTEGER, DIMENSION(:), ALLOCATABLE :: & 85 & n2dintsurf !: Interpolation option for surface variables 86 REAL(wp), DIMENSION(:), ALLOCATABLE :: & 87 & ravglamscl, & !: E/W diameter of averaging footprint for surface variables 88 & ravgphiscl !: N/S diameter of averaging footprint for surface variables 107 89 LOGICAL, DIMENSION(:), ALLOCATABLE :: & 108 & ld_enact !: Profile data is ENACT so use endailyavtypes 109 LOGICAL, DIMENSION(:), ALLOCATABLE :: & 110 & ld_velav !: Velocity data is daily averaged 111 LOGICAL, DIMENSION(:), ALLOCATABLE :: & 112 & ld_sstnight !: SST observation corresponds to night mean 90 & lfpindegs, & !: T=> surface obs footprint size specified in degrees, F=> in metres 91 & llnightav !: Logical for calculating night-time averages 92 93 TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) :: & 94 & surfdata, & !: Initial surface data 95 & surfdataqc !: Surface data after quality control 96 TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: & 97 & profdata, & !: Initial profile data 98 & profdataqc !: Profile data after quality control 99 100 CHARACTER(len=8), PUBLIC, DIMENSION(:), ALLOCATABLE :: & 101 & cobstypesprof, & !: Profile obs types 102 & cobstypessurf !: Surface obs types 113 103 114 104 !!---------------------------------------------------------------------- … … 118 108 !!---------------------------------------------------------------------- 119 109 110 !! * Substitutions 111 # include "domzgr_substitute.h90" 120 112 CONTAINS 121 113 … … 135 127 !! ! 06-10 (A. Weaver) Cleaning and add controls 136 128 !! ! 07-03 (K. Mogensen) General handling of profiles 129 !! ! 14-08 (J.While) Incorporated SST bias correction 130 !! ! 15-02 (M. Martin) Simplification of namelist and code 137 131 !!---------------------------------------------------------------------- 138 132 … … 140 134 141 135 !! * Local declarations 142 CHARACTER(len=128) :: enactfiles(MaxNumFiles) 143 CHARACTER(len=128) :: coriofiles(MaxNumFiles) 144 CHARACTER(len=128) :: profbfiles(MaxNumFiles) 145 CHARACTER(len=128) :: sstfiles(MaxNumFiles) 146 CHARACTER(len=128) :: sstfbfiles(MaxNumFiles) 147 CHARACTER(len=128) :: slafilesact(MaxNumFiles) 148 CHARACTER(len=128) :: slafilespas(MaxNumFiles) 149 CHARACTER(len=128) :: slafbfiles(MaxNumFiles) 150 CHARACTER(len=128) :: seaicefiles(MaxNumFiles) 151 CHARACTER(len=128) :: velcurfiles(MaxNumFiles) 152 CHARACTER(len=128) :: veladcpfiles(MaxNumFiles) 153 CHARACTER(len=128) :: velavcurfiles(MaxNumFiles) 154 CHARACTER(len=128) :: velhrcurfiles(MaxNumFiles) 155 CHARACTER(len=128) :: velavadcpfiles(MaxNumFiles) 156 CHARACTER(len=128) :: velhradcpfiles(MaxNumFiles) 157 CHARACTER(len=128) :: velfbfiles(MaxNumFiles) 158 CHARACTER(LEN=128) :: reysstname 159 CHARACTER(LEN=12) :: reysstfmt 160 CHARACTER(LEN=128) :: bias_file 161 CHARACTER(LEN=20) :: datestr=" ", timestr=" " 162 NAMELIST/namobs/ln_ena, ln_cor, ln_profb, ln_t3d, ln_s3d, & 163 & ln_sla, ln_sladt, ln_slafb, & 164 & ln_ssh, ln_sst, ln_sstfb, ln_sss, ln_nea, & 165 & enactfiles, coriofiles, profbfiles, & 166 & slafilesact, slafilespas, slafbfiles, & 167 & sstfiles, sstfbfiles, & 168 & ln_seaice, seaicefiles, & 169 & dobsini, dobsend, n1dint, n2dint, & 170 & nmsshc, mdtcorr, mdtcutoff, & 171 & ln_reysst, ln_ghrsst, reysstname, reysstfmt, & 172 & ln_sstnight, & 173 & ln_grid_search_lookup, & 174 & grid_search_file, grid_search_res, & 175 & ln_grid_global, bias_file, ln_altbias, & 176 & endailyavtypes, ln_s_at_t, ln_profb_ena, & 177 & ln_vel3d, ln_velavcur, velavcurfiles, & 178 & ln_velhrcur, velhrcurfiles, & 179 & ln_velavadcp, velavadcpfiles, & 180 & ln_velhradcp, velhradcpfiles, & 181 & ln_velfb, velfbfiles, ln_velfb_av, & 182 & ln_profb_enatim, ln_ignmis, ln_cl4 183 184 INTEGER :: jprofset 185 INTEGER :: jveloset 186 INTEGER :: jvar 187 INTEGER :: jnumenact 188 INTEGER :: jnumcorio 189 INTEGER :: jnumprofb 190 INTEGER :: jnumslaact 191 INTEGER :: jnumslapas 192 INTEGER :: jnumslafb 193 INTEGER :: jnumsst 194 INTEGER :: jnumsstfb 195 INTEGER :: jnumseaice 196 INTEGER :: jnumvelavcur 197 INTEGER :: jnumvelhrcur 198 INTEGER :: jnumvelavadcp 199 INTEGER :: jnumvelhradcp 200 INTEGER :: jnumvelfb 201 INTEGER :: ji 202 INTEGER :: jset 203 INTEGER :: ios ! Local integer output status for namelist read 204 LOGICAL :: lmask(MaxNumFiles), ll_u3d, ll_v3d 136 INTEGER, PARAMETER :: & 137 & jpmaxnfiles = 1000 ! Maximum number of files for each obs type 138 INTEGER, DIMENSION(:), ALLOCATABLE :: & 139 & ifilesprof, & ! Number of profile files 140 & ifilessurf ! Number of surface files 141 INTEGER :: ios ! Local integer output status for namelist read 142 INTEGER :: jtype ! Counter for obs types 143 INTEGER :: jvar ! Counter for variables 144 INTEGER :: jfile ! Counter for files 145 INTEGER :: jnumsstbias ! Number of SST bias files to read and apply 146 INTEGER :: n2dint_type ! Local version of nn_2dint* 147 148 CHARACTER(len=128), DIMENSION(jpmaxnfiles) :: & 149 & cn_profbfiles, & ! T/S profile input filenames 150 & cn_sstfbfiles, & ! Sea surface temperature input filenames 151 & cn_slafbfiles, & ! Sea level anomaly input filenames 152 & cn_sicfbfiles, & ! Seaice concentration input filenames 153 & cn_velfbfiles, & ! Velocity profile input filenames 154 & cn_sssfbfiles, & ! Sea surface salinity input filenames 155 & cn_slchltotfbfiles, & ! Surface total log10(chlorophyll) input filenames 156 & cn_slchldiafbfiles, & ! Surface diatom log10(chlorophyll) input filenames 157 & cn_slchlnonfbfiles, & ! Surface non-diatom log10(chlorophyll) input filenames 158 & cn_slchldinfbfiles, & ! Surface dinoflagellate log10(chlorophyll) input filenames 159 & cn_slchlmicfbfiles, & ! Surface microphytoplankton log10(chlorophyll) input filenames 160 & cn_slchlnanfbfiles, & ! Surface nanophytoplankton log10(chlorophyll) input filenames 161 & cn_slchlpicfbfiles, & ! Surface picophytoplankton log10(chlorophyll) input filenames 162 & cn_schltotfbfiles, & ! Surface total chlorophyll input filenames 163 & cn_slphytotfbfiles, & ! Surface total log10(phytoplankton carbon) input filenames 164 & cn_slphydiafbfiles, & ! Surface diatom log10(phytoplankton carbon) input filenames 165 & cn_slphynonfbfiles, & ! Surface non-diatom log10(phytoplankton carbon) input filenames 166 & cn_sspmfbfiles, & ! Surface suspended particulate matter input filenames 167 & cn_sfco2fbfiles, & ! Surface fugacity of carbon dioxide input filenames 168 & cn_spco2fbfiles, & ! Surface partial pressure of carbon dioxide input filenames 169 & cn_plchltotfbfiles, & ! Profile total log10(chlorophyll) input filenames 170 & cn_pchltotfbfiles, & ! Profile total chlorophyll input filenames 171 & cn_pno3fbfiles, & ! Profile nitrate input filenames 172 & cn_psi4fbfiles, & ! Profile silicate input filenames 173 & cn_ppo4fbfiles, & ! Profile phosphate input filenames 174 & cn_pdicfbfiles, & ! Profile dissolved inorganic carbon input filenames 175 & cn_palkfbfiles, & ! Profile alkalinity input filenames 176 & cn_pphfbfiles, & ! Profile pH input filenames 177 & cn_po2fbfiles, & ! Profile dissolved oxygen input filenames 178 & cn_sstbiasfiles ! SST bias input filenames 179 180 CHARACTER(LEN=128) :: & 181 & cn_altbiasfile ! Altimeter bias input filename 182 183 184 LOGICAL :: ln_t3d ! Logical switch for temperature profiles 185 LOGICAL :: ln_s3d ! Logical switch for salinity profiles 186 LOGICAL :: ln_sla ! Logical switch for sea level anomalies 187 LOGICAL :: ln_sst ! Logical switch for sea surface temperature 188 LOGICAL :: ln_sic ! Logical switch for sea ice concentration 189 LOGICAL :: ln_sss ! Logical switch for sea surface salinity obs 190 LOGICAL :: ln_vel3d ! Logical switch for velocity (u,v) obs 191 LOGICAL :: ln_slchltot ! Logical switch for surface total log10(chlorophyll) obs 192 LOGICAL :: ln_slchldia ! Logical switch for surface diatom log10(chlorophyll) obs 193 LOGICAL :: ln_slchlnon ! Logical switch for surface non-diatom log10(chlorophyll) obs 194 LOGICAL :: ln_slchldin ! Logical switch for surface dinoflagellate log10(chlorophyll) obs 195 LOGICAL :: ln_slchlmic ! Logical switch for surface microphytoplankton log10(chlorophyll) obs 196 LOGICAL :: ln_slchlnan ! Logical switch for surface nanophytoplankton log10(chlorophyll) obs 197 LOGICAL :: ln_slchlpic ! Logical switch for surface picophytoplankton log10(chlorophyll) obs 198 LOGICAL :: ln_schltot ! Logical switch for surface total chlorophyll obs 199 LOGICAL :: ln_slphytot ! Logical switch for surface total log10(phytoplankton carbon) obs 200 LOGICAL :: ln_slphydia ! Logical switch for surface diatom log10(phytoplankton carbon) obs 201 LOGICAL :: ln_slphynon ! Logical switch for surface non-diatom log10(phytoplankton carbon) obs 202 LOGICAL :: ln_sspm ! Logical switch for surface suspended particulate matter obs 203 LOGICAL :: ln_sfco2 ! Logical switch for surface fugacity of carbon dioxide obs 204 LOGICAL :: ln_spco2 ! Logical switch for surface partial pressure of carbon dioxide obs 205 LOGICAL :: ln_plchltot ! Logical switch for profile total log10(chlorophyll) obs 206 LOGICAL :: ln_pchltot ! Logical switch for profile total chlorophyll obs 207 LOGICAL :: ln_pno3 ! Logical switch for profile nitrate obs 208 LOGICAL :: ln_psi4 ! Logical switch for profile silicate obs 209 LOGICAL :: ln_ppo4 ! Logical switch for profile phosphate obs 210 LOGICAL :: ln_pdic ! Logical switch for profile dissolved inorganic carbon obs 211 LOGICAL :: ln_palk ! Logical switch for profile alkalinity obs 212 LOGICAL :: ln_pph ! Logical switch for profile pH obs 213 LOGICAL :: ln_po2 ! Logical switch for profile dissolved oxygen obs 214 LOGICAL :: ln_nea ! Logical switch to remove obs near land 215 LOGICAL :: ln_altbias ! Logical switch for altimeter bias 216 LOGICAL :: ln_sstbias ! Logical switch for bias correction of SST 217 LOGICAL :: ln_ignmis ! Logical switch for ignoring missing files 218 LOGICAL :: ln_s_at_t ! Logical switch to compute model S at T obs 219 LOGICAL :: ln_bound_reject ! Logical switch for rejecting obs near the boundary 220 221 REAL(dp) :: rn_dobsini ! Obs window start date YYYYMMDD.HHMMSS 222 REAL(dp) :: rn_dobsend ! Obs window end date YYYYMMDD.HHMMSS 223 224 REAL(wp) :: ztype_avglamscl ! Local version of rn_*_avglamscl 225 REAL(wp) :: ztype_avgphiscl ! Local version of rn_*_avgphiscl 226 227 CHARACTER(len=128), DIMENSION(:,:), ALLOCATABLE :: & 228 & clproffiles, & ! Profile filenames 229 & clsurffiles ! Surface filenames 230 231 LOGICAL, DIMENSION(:), ALLOCATABLE :: llvar ! Logical for profile variable read 232 LOGICAL :: ltype_fp_indegs ! Local version of ln_*_fp_indegs 233 LOGICAL :: ltype_night ! Local version of ln_sstnight (false for other variables) 234 235 REAL(wp), POINTER, DIMENSION(:,:,:) :: & 236 & zglam ! Model longitudes for profile variables 237 REAL(wp), POINTER, DIMENSION(:,:,:) :: & 238 & zgphi ! Model latitudes for profile variables 239 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: & 240 & zmask ! Model land/sea mask associated with variables 241 242 243 NAMELIST/namobs/ln_diaobs, ln_t3d, ln_s3d, ln_sla, & 244 & ln_sst, ln_sic, ln_sss, ln_vel3d, & 245 & ln_slchltot, ln_slchldia, ln_slchlnon, & 246 & ln_slchldin, ln_slchlmic, ln_slchlnan, & 247 & ln_slchlpic, ln_schltot, & 248 & ln_slphytot, ln_slphydia, ln_slphynon, & 249 & ln_sspm, ln_sfco2, ln_spco2, & 250 & ln_plchltot, ln_pchltot, ln_pno3, & 251 & ln_psi4, ln_ppo4, ln_pdic, & 252 & ln_palk, ln_pph, ln_po2, & 253 & ln_altbias, ln_sstbias, ln_nea, & 254 & ln_grid_global, ln_grid_search_lookup, & 255 & ln_ignmis, ln_s_at_t, ln_bound_reject, & 256 & ln_sstnight, ln_default_fp_indegs, & 257 & ln_sla_fp_indegs, ln_sst_fp_indegs, & 258 & ln_sss_fp_indegs, ln_sic_fp_indegs, & 259 & cn_profbfiles, cn_slafbfiles, & 260 & cn_sstfbfiles, cn_sicfbfiles, & 261 & cn_velfbfiles, cn_sssfbfiles, & 262 & cn_slchltotfbfiles, cn_slchldiafbfiles, & 263 & cn_slchlnonfbfiles, cn_slchldinfbfiles, & 264 & cn_slchlmicfbfiles, cn_slchlnanfbfiles, & 265 & cn_slchlpicfbfiles, cn_schltotfbfiles, & 266 & cn_slphytotfbfiles, cn_slphydiafbfiles, & 267 & cn_slphynonfbfiles, cn_sspmfbfiles, & 268 & cn_sfco2fbfiles, cn_spco2fbfiles, & 269 & cn_plchltotfbfiles, cn_pchltotfbfiles, & 270 & cn_pno3fbfiles, cn_psi4fbfiles, cn_ppo4fbfiles, & 271 & cn_pdicfbfiles, cn_palkfbfiles, cn_pphfbfiles, & 272 & cn_po2fbfiles, & 273 & cn_sstbiasfiles, cn_altbiasfile, & 274 & cn_gridsearchfile, rn_gridsearchres, & 275 & rn_dobsini, rn_dobsend, & 276 & rn_default_avglamscl, rn_default_avgphiscl, & 277 & rn_sla_avglamscl, rn_sla_avgphiscl, & 278 & rn_sst_avglamscl, rn_sst_avgphiscl, & 279 & rn_sss_avglamscl, rn_sss_avgphiscl, & 280 & rn_sic_avglamscl, rn_sic_avgphiscl, & 281 & nn_1dint, nn_2dint_default, & 282 & nn_2dint_sla, nn_2dint_sst, & 283 & nn_2dint_sss, nn_2dint_sic, & 284 & nn_msshc, rn_mdtcorr, rn_mdtcutoff, & 285 & nn_profdavtypes 205 286 206 287 !----------------------------------------------------------------------- … … 208 289 !----------------------------------------------------------------------- 209 290 210 enactfiles(:) = '' 211 coriofiles(:) = '' 212 profbfiles(:) = '' 213 slafilesact(:) = '' 214 slafilespas(:) = '' 215 slafbfiles(:) = '' 216 sstfiles(:) = '' 217 sstfbfiles(:) = '' 218 seaicefiles(:) = '' 219 velcurfiles(:) = '' 220 veladcpfiles(:) = '' 221 velavcurfiles(:) = '' 222 velhrcurfiles(:) = '' 223 velavadcpfiles(:) = '' 224 velhradcpfiles(:) = '' 225 velfbfiles(:) = '' 226 velcurfiles(:) = '' 227 veladcpfiles(:) = '' 228 endailyavtypes(:) = -1 229 endailyavtypes(1) = 820 230 ln_profb_ena(:) = .FALSE. 231 ln_profb_enatim(:) = .TRUE. 232 ln_velfb_av(:) = .FALSE. 233 ln_ignmis = .FALSE. 234 235 CALL ini_date( dobsini ) 236 CALL fin_date( dobsend ) 237 238 ! Read Namelist namobs : control observation diagnostics 239 REWIND( numnam_ref ) ! Namelist namobs in reference namelist : Diagnostic: control observation 291 ! Some namelist arrays need initialising 292 cn_profbfiles(:) = '' 293 cn_slafbfiles(:) = '' 294 cn_sstfbfiles(:) = '' 295 cn_sicfbfiles(:) = '' 296 cn_velfbfiles(:) = '' 297 cn_sssfbfiles(:) = '' 298 cn_slchltotfbfiles(:) = '' 299 cn_slchldiafbfiles(:) = '' 300 cn_slchlnonfbfiles(:) = '' 301 cn_slchldinfbfiles(:) = '' 302 cn_slchlmicfbfiles(:) = '' 303 cn_slchlnanfbfiles(:) = '' 304 cn_slchlpicfbfiles(:) = '' 305 cn_schltotfbfiles(:) = '' 306 cn_slphytotfbfiles(:) = '' 307 cn_slphydiafbfiles(:) = '' 308 cn_slphynonfbfiles(:) = '' 309 cn_sspmfbfiles(:) = '' 310 cn_sfco2fbfiles(:) = '' 311 cn_spco2fbfiles(:) = '' 312 cn_plchltotfbfiles(:) = '' 313 cn_pchltotfbfiles(:) = '' 314 cn_pno3fbfiles(:) = '' 315 cn_psi4fbfiles(:) = '' 316 cn_ppo4fbfiles(:) = '' 317 cn_pdicfbfiles(:) = '' 318 cn_palkfbfiles(:) = '' 319 cn_pphfbfiles(:) = '' 320 cn_po2fbfiles(:) = '' 321 cn_sstbiasfiles(:) = '' 322 nn_profdavtypes(:) = -1 323 324 CALL ini_date( rn_dobsini ) 325 CALL fin_date( rn_dobsend ) 326 327 ! Read namelist namobs : control observation diagnostics 328 REWIND( numnam_ref ) ! Namelist namobs in reference namelist 240 329 READ ( numnam_ref, namobs, IOSTAT = ios, ERR = 901) 241 330 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobs in reference namelist', lwp ) 242 331 243 REWIND( numnam_cfg ) ! Namelist namobs in configuration namelist : Diagnostic: control observation332 REWIND( numnam_cfg ) ! Namelist namobs in configuration namelist 244 333 READ ( numnam_cfg, namobs, IOSTAT = ios, ERR = 902 ) 245 334 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobs in configuration namelist', lwp ) 246 335 IF(lwm) WRITE ( numond, namobs ) 247 336 248 ! Count number of files for each type 249 IF (ln_ena) THEN 250 lmask(:) = .FALSE. 251 WHERE (enactfiles(:) /= '') lmask(:) = .TRUE. 252 jnumenact = COUNT(lmask) 337 lk_diaobs = .FALSE. 338 #if defined key_diaobs 339 IF ( ln_diaobs ) lk_diaobs = .TRUE. 340 #endif 341 342 IF ( .NOT. lk_diaobs ) THEN 343 IF(lwp) WRITE(numout,cform_war) 344 IF(lwp) WRITE(numout,*)' ln_diaobs is set to false or key_diaobs is not set, so not calling dia_obs' 345 RETURN 253 346 ENDIF 254 IF (ln_cor) THEN 255 lmask(:) = .FALSE. 256 WHERE (coriofiles(:) /= '') lmask(:) = .TRUE. 257 jnumcorio = COUNT(lmask) 258 ENDIF 259 IF (ln_profb) THEN 260 lmask(:) = .FALSE. 261 WHERE (profbfiles(:) /= '') lmask(:) = .TRUE. 262 jnumprofb = COUNT(lmask) 263 ENDIF 264 IF (ln_sladt) THEN 265 lmask(:) = .FALSE. 266 WHERE (slafilesact(:) /= '') lmask(:) = .TRUE. 267 jnumslaact = COUNT(lmask) 268 lmask(:) = .FALSE. 269 WHERE (slafilespas(:) /= '') lmask(:) = .TRUE. 270 jnumslapas = COUNT(lmask) 271 ENDIF 272 IF (ln_slafb) THEN 273 lmask(:) = .FALSE. 274 WHERE (slafbfiles(:) /= '') lmask(:) = .TRUE. 275 jnumslafb = COUNT(lmask) 276 lmask(:) = .FALSE. 277 ENDIF 278 IF (ln_ghrsst) THEN 279 lmask(:) = .FALSE. 280 WHERE (sstfiles(:) /= '') lmask(:) = .TRUE. 281 jnumsst = COUNT(lmask) 282 ENDIF 283 IF (ln_sstfb) THEN 284 lmask(:) = .FALSE. 285 WHERE (sstfbfiles(:) /= '') lmask(:) = .TRUE. 286 jnumsstfb = COUNT(lmask) 287 lmask(:) = .FALSE. 288 ENDIF 289 IF (ln_seaice) THEN 290 lmask(:) = .FALSE. 291 WHERE (seaicefiles(:) /= '') lmask(:) = .TRUE. 292 jnumseaice = COUNT(lmask) 293 ENDIF 294 IF (ln_velavcur) THEN 295 lmask(:) = .FALSE. 296 WHERE (velavcurfiles(:) /= '') lmask(:) = .TRUE. 297 jnumvelavcur = COUNT(lmask) 298 ENDIF 299 IF (ln_velhrcur) THEN 300 lmask(:) = .FALSE. 301 WHERE (velhrcurfiles(:) /= '') lmask(:) = .TRUE. 302 jnumvelhrcur = COUNT(lmask) 303 ENDIF 304 IF (ln_velavadcp) THEN 305 lmask(:) = .FALSE. 306 WHERE (velavadcpfiles(:) /= '') lmask(:) = .TRUE. 307 jnumvelavadcp = COUNT(lmask) 308 ENDIF 309 IF (ln_velhradcp) THEN 310 lmask(:) = .FALSE. 311 WHERE (velhradcpfiles(:) /= '') lmask(:) = .TRUE. 312 jnumvelhradcp = COUNT(lmask) 313 ENDIF 314 IF (ln_velfb) THEN 315 lmask(:) = .FALSE. 316 WHERE (velfbfiles(:) /= '') lmask(:) = .TRUE. 317 jnumvelfb = COUNT(lmask) 318 lmask(:) = .FALSE. 319 ENDIF 320 321 ! Control print 347 322 348 IF(lwp) THEN 323 349 WRITE(numout,*) … … 325 351 WRITE(numout,*) '~~~~~~~~~~~~' 326 352 WRITE(numout,*) ' Namelist namobs : set observation diagnostic parameters' 327 WRITE(numout,*) ' Logical switch for T profile observations ln_t3d = ', ln_t3d 328 WRITE(numout,*) ' Logical switch for S profile observations ln_s3d = ', ln_s3d 329 WRITE(numout,*) ' Logical switch for ENACT insitu data set ln_ena = ', ln_ena 330 WRITE(numout,*) ' Logical switch for Coriolis insitu data set ln_cor = ', ln_cor 331 WRITE(numout,*) ' Logical switch for feedback insitu data set ln_profb = ', ln_profb 332 WRITE(numout,*) ' Logical switch for SLA observations ln_sla = ', ln_sla 333 WRITE(numout,*) ' Logical switch for AVISO SLA data ln_sladt = ', ln_sladt 334 WRITE(numout,*) ' Logical switch for feedback SLA data ln_slafb = ', ln_slafb 335 WRITE(numout,*) ' Logical switch for SSH observations ln_ssh = ', ln_ssh 336 WRITE(numout,*) ' Logical switch for SST observations ln_sst = ', ln_sst 337 WRITE(numout,*) ' Logical switch for Reynolds observations ln_reysst = ', ln_reysst 338 WRITE(numout,*) ' Logical switch for GHRSST observations ln_ghrsst = ', ln_ghrsst 339 WRITE(numout,*) ' Logical switch for feedback SST data ln_sstfb = ', ln_sstfb 340 WRITE(numout,*) ' Logical switch for night-time SST obs ln_sstnight = ', ln_sstnight 341 WRITE(numout,*) ' Logical switch for SSS observations ln_sss = ', ln_sss 342 WRITE(numout,*) ' Logical switch for Sea Ice observations ln_seaice = ', ln_seaice 343 WRITE(numout,*) ' Logical switch for velocity observations ln_vel3d = ', ln_vel3d 344 WRITE(numout,*) ' Logical switch for velocity daily av. cur. ln_velavcur = ', ln_velavcur 345 WRITE(numout,*) ' Logical switch for velocity high freq. cur. ln_velhrcur = ', ln_velhrcur 346 WRITE(numout,*) ' Logical switch for velocity daily av. ADCP ln_velavadcp = ', ln_velavadcp 347 WRITE(numout,*) ' Logical switch for velocity high freq. ADCP ln_velhradcp = ', ln_velhradcp 348 WRITE(numout,*) ' Logical switch for feedback velocity data ln_velfb = ', ln_velfb 349 WRITE(numout,*) ' Global distribtion of observations ln_grid_global = ',ln_grid_global 350 WRITE(numout,*) & 351 ' Logical switch for obs grid search w/lookup table ln_grid_search_lookup = ',ln_grid_search_lookup 353 WRITE(numout,*) ' Logical switch for T profile observations ln_t3d = ', ln_t3d 354 WRITE(numout,*) ' Logical switch for S profile observations ln_s3d = ', ln_s3d 355 WRITE(numout,*) ' Logical switch for SLA observations ln_sla = ', ln_sla 356 WRITE(numout,*) ' Logical switch for SST observations ln_sst = ', ln_sst 357 WRITE(numout,*) ' Logical switch for Sea Ice observations ln_sic = ', ln_sic 358 WRITE(numout,*) ' Logical switch for velocity observations ln_vel3d = ', ln_vel3d 359 WRITE(numout,*) ' Logical switch for SSS observations ln_sss = ', ln_sss 360 WRITE(numout,*) ' Logical switch for surface total logchl obs ln_slchltot = ', ln_slchltot 361 WRITE(numout,*) ' Logical switch for surface diatom logchl obs ln_slchldia = ', ln_slchldia 362 WRITE(numout,*) ' Logical switch for surface non-diatom logchl obs ln_slchlnon = ', ln_slchlnon 363 WRITE(numout,*) ' Logical switch for surface dino logchl obs ln_slchldin = ', ln_slchldin 364 WRITE(numout,*) ' Logical switch for surface micro logchl obs ln_slchlmic = ', ln_slchlmic 365 WRITE(numout,*) ' Logical switch for surface nano logchl obs ln_slchlnan = ', ln_slchlnan 366 WRITE(numout,*) ' Logical switch for surface pico logchl obs ln_slchlpic = ', ln_slchlpic 367 WRITE(numout,*) ' Logical switch for surface total chl obs ln_schltot = ', ln_schltot 368 WRITE(numout,*) ' Logical switch for surface total log(phyC) obs ln_slphytot = ', ln_slphytot 369 WRITE(numout,*) ' Logical switch for surface diatom log(phyC) obs ln_slphydia = ', ln_slphydia 370 WRITE(numout,*) ' Logical switch for surface non-diatom log(phyC) obs ln_slphynon = ', ln_slphynon 371 WRITE(numout,*) ' Logical switch for surface SPM observations ln_sspm = ', ln_sspm 372 WRITE(numout,*) ' Logical switch for surface fCO2 observations ln_sfco2 = ', ln_sfco2 373 WRITE(numout,*) ' Logical switch for surface pCO2 observations ln_spco2 = ', ln_spco2 374 WRITE(numout,*) ' Logical switch for profile total logchl obs ln_plchltot = ', ln_plchltot 375 WRITE(numout,*) ' Logical switch for profile total chl obs ln_pchltot = ', ln_pchltot 376 WRITE(numout,*) ' Logical switch for profile nitrate obs ln_pno3 = ', ln_pno3 377 WRITE(numout,*) ' Logical switch for profile silicate obs ln_psi4 = ', ln_psi4 378 WRITE(numout,*) ' Logical switch for profile phosphate obs ln_ppo4 = ', ln_ppo4 379 WRITE(numout,*) ' Logical switch for profile DIC obs ln_pdic = ', ln_pdic 380 WRITE(numout,*) ' Logical switch for profile alkalinity obs ln_palk = ', ln_palk 381 WRITE(numout,*) ' Logical switch for profile pH obs ln_pph = ', ln_pph 382 WRITE(numout,*) ' Logical switch for profile oxygen obs ln_po2 = ', ln_po2 383 WRITE(numout,*) ' Global distribution of observations ln_grid_global = ', ln_grid_global 384 WRITE(numout,*) ' Logical switch for obs grid search lookup ln_grid_search_lookup = ', ln_grid_search_lookup 352 385 IF (ln_grid_search_lookup) & 353 WRITE(numout,*) ' Grid search lookup file header grid_search_file = ', grid_search_file 354 IF (ln_ena) THEN 355 DO ji = 1, jnumenact 356 WRITE(numout,'(1X,2A)') ' ENACT input observation file name enactfiles = ', & 357 TRIM(enactfiles(ji)) 358 END DO 359 ENDIF 360 IF (ln_cor) THEN 361 DO ji = 1, jnumcorio 362 WRITE(numout,'(1X,2A)') ' Coriolis input observation file name coriofiles = ', & 363 TRIM(coriofiles(ji)) 364 END DO 365 ENDIF 366 IF (ln_profb) THEN 367 DO ji = 1, jnumprofb 368 IF (ln_profb_ena(ji)) THEN 369 WRITE(numout,'(1X,2A)') ' Enact feedback input observation file name profbfiles = ', & 370 TRIM(profbfiles(ji)) 386 WRITE(numout,*) ' Grid search lookup file header cn_gridsearchfile = ', cn_gridsearchfile 387 WRITE(numout,*) ' Initial date in window YYYYMMDD.HHMMSS rn_dobsini = ', rn_dobsini 388 WRITE(numout,*) ' Final date in window YYYYMMDD.HHMMSS rn_dobsend = ', rn_dobsend 389 WRITE(numout,*) ' Type of vertical interpolation method nn_1dint = ', nn_1dint 390 WRITE(numout,*) ' Default horizontal interpolation method nn_2dint_default = ', nn_2dint_default 391 WRITE(numout,*) ' Type of horizontal interpolation method for SLA nn_2dint_sla = ', nn_2dint_sla 392 WRITE(numout,*) ' Type of horizontal interpolation method for SST nn_2dint_sst = ', nn_2dint_sst 393 WRITE(numout,*) ' Type of horizontal interpolation method for SSS nn_2dint_sss = ', nn_2dint_sss 394 WRITE(numout,*) ' Type of horizontal interpolation method for SIC nn_2dint_sic = ', nn_2dint_sic 395 WRITE(numout,*) ' Default E/W diameter of obs footprint rn_default_avglamscl = ', rn_default_avglamscl 396 WRITE(numout,*) ' Default N/S diameter of obs footprint rn_default_avgphiscl = ', rn_default_avgphiscl 397 WRITE(numout,*) ' Default obs footprint in deg [T] or m [F] ln_default_fp_indegs = ', ln_default_fp_indegs 398 WRITE(numout,*) ' SLA E/W diameter of obs footprint rn_sla_avglamscl = ', rn_sla_avglamscl 399 WRITE(numout,*) ' SLA N/S diameter of obs footprint rn_sla_avgphiscl = ', rn_sla_avgphiscl 400 WRITE(numout,*) ' SLA obs footprint in deg [T] or m [F] ln_sla_fp_indegs = ', ln_sla_fp_indegs 401 WRITE(numout,*) ' SST E/W diameter of obs footprint rn_sst_avglamscl = ', rn_sst_avglamscl 402 WRITE(numout,*) ' SST N/S diameter of obs footprint rn_sst_avgphiscl = ', rn_sst_avgphiscl 403 WRITE(numout,*) ' SST obs footprint in deg [T] or m [F] ln_sst_fp_indegs = ', ln_sst_fp_indegs 404 WRITE(numout,*) ' SIC E/W diameter of obs footprint rn_sic_avglamscl = ', rn_sic_avglamscl 405 WRITE(numout,*) ' SIC N/S diameter of obs footprint rn_sic_avgphiscl = ', rn_sic_avgphiscl 406 WRITE(numout,*) ' SIC obs footprint in deg [T] or m [F] ln_sic_fp_indegs = ', ln_sic_fp_indegs 407 WRITE(numout,*) ' Rejection of observations near land switch ln_nea = ', ln_nea 408 WRITE(numout,*) ' Rejection of obs near open bdys ln_bound_reject = ', ln_bound_reject 409 WRITE(numout,*) ' MSSH correction scheme nn_msshc = ', nn_msshc 410 WRITE(numout,*) ' MDT correction rn_mdtcorr = ', rn_mdtcorr 411 WRITE(numout,*) ' MDT cutoff for computed correction rn_mdtcutoff = ', rn_mdtcutoff 412 WRITE(numout,*) ' Logical switch for alt bias ln_altbias = ', ln_altbias 413 WRITE(numout,*) ' Logical switch for sst bias ln_sstbias = ', ln_sstbias 414 WRITE(numout,*) ' Logical switch for ignoring missing files ln_ignmis = ', ln_ignmis 415 WRITE(numout,*) ' Daily average types nn_profdavtypes = ', nn_profdavtypes 416 WRITE(numout,*) ' Logical switch for night-time SST obs ln_sstnight = ', ln_sstnight 417 ENDIF 418 !----------------------------------------------------------------------- 419 ! Set up list of observation types to be used 420 ! and the files associated with each type 421 !----------------------------------------------------------------------- 422 423 nproftypes = COUNT( (/ln_t3d .OR. ln_s3d, ln_vel3d, ln_plchltot, & 424 & ln_pchltot, ln_pno3, ln_psi4, ln_ppo4, & 425 & ln_pdic, ln_palk, ln_pph, ln_po2 /) ) 426 nsurftypes = COUNT( (/ln_sla, ln_sst, ln_sic, ln_sss, & 427 & ln_slchltot, ln_slchldia, ln_slchlnon, ln_slchldin, & 428 & ln_slchlmic, ln_slchlnan, ln_slchlpic, ln_schltot, & 429 & ln_slphytot, ln_slphydia, ln_slphynon, ln_sspm, & 430 & ln_sfco2, ln_spco2 /) ) 431 432 IF ( nproftypes == 0 .AND. nsurftypes == 0 ) THEN 433 IF(lwp) WRITE(numout,cform_war) 434 IF(lwp) WRITE(numout,*) ' ln_diaobs is set to true, but all obs operator logical flags', & 435 & ' are set to .FALSE. so turning off calls to dia_obs' 436 nwarn = nwarn + 1 437 lk_diaobs = .FALSE. 438 RETURN 439 ENDIF 440 441 IF(lwp) WRITE(numout,*) ' Number of profile obs types: ',nproftypes 442 IF ( nproftypes > 0 ) THEN 443 444 ALLOCATE( cobstypesprof(nproftypes) ) 445 ALLOCATE( ifilesprof(nproftypes) ) 446 ALLOCATE( clproffiles(nproftypes,jpmaxnfiles) ) 447 448 jtype = 0 449 IF (ln_t3d .OR. ln_s3d) THEN 450 jtype = jtype + 1 451 cobstypesprof(jtype) = 'prof' 452 clproffiles(jtype,:) = cn_profbfiles 453 ENDIF 454 IF (ln_vel3d) THEN 455 jtype = jtype + 1 456 cobstypesprof(jtype) = 'vel' 457 clproffiles(jtype,:) = cn_velfbfiles 458 ENDIF 459 IF (ln_plchltot) THEN 460 jtype = jtype + 1 461 cobstypesprof(jtype) = 'plchltot' 462 clproffiles(jtype,:) = cn_plchltotfbfiles 463 ENDIF 464 IF (ln_pchltot) THEN 465 jtype = jtype + 1 466 cobstypesprof(jtype) = 'pchltot' 467 clproffiles(jtype,:) = cn_pchltotfbfiles 468 ENDIF 469 IF (ln_pno3) THEN 470 jtype = jtype + 1 471 cobstypesprof(jtype) = 'pno3' 472 clproffiles(jtype,:) = cn_pno3fbfiles 473 ENDIF 474 IF (ln_psi4) THEN 475 jtype = jtype + 1 476 cobstypesprof(jtype) = 'psi4' 477 clproffiles(jtype,:) = cn_psi4fbfiles 478 ENDIF 479 IF (ln_ppo4) THEN 480 jtype = jtype + 1 481 cobstypesprof(jtype) = 'ppo4' 482 clproffiles(jtype,:) = cn_ppo4fbfiles 483 ENDIF 484 IF (ln_pdic) THEN 485 jtype = jtype + 1 486 cobstypesprof(jtype) = 'pdic' 487 clproffiles(jtype,:) = cn_pdicfbfiles 488 ENDIF 489 IF (ln_palk) THEN 490 jtype = jtype + 1 491 cobstypesprof(jtype) = 'palk' 492 clproffiles(jtype,:) = cn_palkfbfiles 493 ENDIF 494 IF (ln_pph) THEN 495 jtype = jtype + 1 496 cobstypesprof(jtype) = 'pph' 497 clproffiles(jtype,:) = cn_pphfbfiles 498 ENDIF 499 IF (ln_po2) THEN 500 jtype = jtype + 1 501 cobstypesprof(jtype) = 'po2' 502 clproffiles(jtype,:) = cn_po2fbfiles 503 ENDIF 504 505 CALL obs_settypefiles( nproftypes, jpmaxnfiles, ifilesprof, cobstypesprof, clproffiles ) 506 507 ENDIF 508 509 IF(lwp) WRITE(numout,*)' Number of surface obs types: ',nsurftypes 510 IF ( nsurftypes > 0 ) THEN 511 512 ALLOCATE( cobstypessurf(nsurftypes) ) 513 ALLOCATE( ifilessurf(nsurftypes) ) 514 ALLOCATE( clsurffiles(nsurftypes, jpmaxnfiles) ) 515 ALLOCATE(n2dintsurf(nsurftypes)) 516 ALLOCATE(ravglamscl(nsurftypes)) 517 ALLOCATE(ravgphiscl(nsurftypes)) 518 ALLOCATE(lfpindegs(nsurftypes)) 519 ALLOCATE(llnightav(nsurftypes)) 520 521 jtype = 0 522 IF (ln_sla) THEN 523 jtype = jtype + 1 524 cobstypessurf(jtype) = 'sla' 525 clsurffiles(jtype,:) = cn_slafbfiles 526 ENDIF 527 IF (ln_sst) THEN 528 jtype = jtype + 1 529 cobstypessurf(jtype) = 'sst' 530 clsurffiles(jtype,:) = cn_sstfbfiles 531 ENDIF 532 IF (ln_sic) THEN 533 jtype = jtype + 1 534 cobstypessurf(jtype) = 'sic' 535 clsurffiles(jtype,:) = cn_sicfbfiles 536 ENDIF 537 IF (ln_sss) THEN 538 jtype = jtype + 1 539 cobstypessurf(jtype) = 'sss' 540 clsurffiles(jtype,:) = cn_sssfbfiles 541 ENDIF 542 IF (ln_slchltot) THEN 543 jtype = jtype + 1 544 cobstypessurf(jtype) = 'slchltot' 545 clsurffiles(jtype,:) = cn_slchltotfbfiles 546 ENDIF 547 IF (ln_slchldia) THEN 548 jtype = jtype + 1 549 cobstypessurf(jtype) = 'slchldia' 550 clsurffiles(jtype,:) = cn_slchldiafbfiles 551 ENDIF 552 IF (ln_slchlnon) THEN 553 jtype = jtype + 1 554 cobstypessurf(jtype) = 'slchlnon' 555 clsurffiles(jtype,:) = cn_slchlnonfbfiles 556 ENDIF 557 IF (ln_slchldin) THEN 558 jtype = jtype + 1 559 cobstypessurf(jtype) = 'slchldin' 560 clsurffiles(jtype,:) = cn_slchldinfbfiles 561 ENDIF 562 IF (ln_slchlmic) THEN 563 jtype = jtype + 1 564 cobstypessurf(jtype) = 'slchlmic' 565 clsurffiles(jtype,:) = cn_slchlmicfbfiles 566 ENDIF 567 IF (ln_slchlnan) THEN 568 jtype = jtype + 1 569 cobstypessurf(jtype) = 'slchlnan' 570 clsurffiles(jtype,:) = cn_slchlnanfbfiles 571 ENDIF 572 IF (ln_slchlpic) THEN 573 jtype = jtype + 1 574 cobstypessurf(jtype) = 'slchlpic' 575 clsurffiles(jtype,:) = cn_slchlpicfbfiles 576 ENDIF 577 IF (ln_schltot) THEN 578 jtype = jtype + 1 579 cobstypessurf(jtype) = 'schltot' 580 clsurffiles(jtype,:) = cn_schltotfbfiles 581 ENDIF 582 IF (ln_slphytot) THEN 583 jtype = jtype + 1 584 cobstypessurf(jtype) = 'slphytot' 585 clsurffiles(jtype,:) = cn_slphytotfbfiles 586 ENDIF 587 IF (ln_slphydia) THEN 588 jtype = jtype + 1 589 cobstypessurf(jtype) = 'slphydia' 590 clsurffiles(jtype,:) = cn_slphydiafbfiles 591 ENDIF 592 IF (ln_slphynon) THEN 593 jtype = jtype + 1 594 cobstypessurf(jtype) = 'slphynon' 595 clsurffiles(jtype,:) = cn_slphynonfbfiles 596 ENDIF 597 IF (ln_sspm) THEN 598 jtype = jtype + 1 599 cobstypessurf(jtype) = 'sspm' 600 clsurffiles(jtype,:) = cn_sspmfbfiles 601 ENDIF 602 IF (ln_sfco2) THEN 603 jtype = jtype + 1 604 cobstypessurf(jtype) = 'sfco2' 605 clsurffiles(jtype,:) = cn_sfco2fbfiles 606 ENDIF 607 IF (ln_spco2) THEN 608 jtype = jtype + 1 609 cobstypessurf(jtype) = 'spco2' 610 clsurffiles(jtype,:) = cn_spco2fbfiles 611 ENDIF 612 613 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, ifilessurf, cobstypessurf, clsurffiles ) 614 615 DO jtype = 1, nsurftypes 616 617 IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN 618 IF ( nn_2dint_sla == -1 ) THEN 619 n2dint_type = nn_2dint_default 371 620 ELSE 372 WRITE(numout,'(1X,2A)') ' Feedback input observation file name profbfiles = ', & 373 TRIM(profbfiles(ji)) 621 n2dint_type = nn_2dint_sla 374 622 ENDIF 375 WRITE(numout,'(1X,2A)') ' Enact feedback input time setting switch ln_profb_enatim = ', ln_profb_enatim(ji) 376 END DO 377 ENDIF 378 IF (ln_sladt) THEN 379 DO ji = 1, jnumslaact 380 WRITE(numout,'(1X,2A)') ' Active SLA input observation file name slafilesact = ', & 381 TRIM(slafilesact(ji)) 382 END DO 383 DO ji = 1, jnumslapas 384 WRITE(numout,'(1X,2A)') ' Passive SLA input observation file name slafilespas = ', & 385 TRIM(slafilespas(ji)) 386 END DO 387 ENDIF 388 IF (ln_slafb) THEN 389 DO ji = 1, jnumslafb 390 WRITE(numout,'(1X,2A)') ' Feedback SLA input observation file name slafbfiles = ', & 391 TRIM(slafbfiles(ji)) 392 END DO 393 ENDIF 394 IF (ln_ghrsst) THEN 395 DO ji = 1, jnumsst 396 WRITE(numout,'(1X,2A)') ' GHRSST input observation file name sstfiles = ', & 397 TRIM(sstfiles(ji)) 398 END DO 399 ENDIF 400 IF (ln_sstfb) THEN 401 DO ji = 1, jnumsstfb 402 WRITE(numout,'(1X,2A)') ' Feedback SST input observation file name sstfbfiles = ', & 403 TRIM(sstfbfiles(ji)) 404 END DO 405 ENDIF 406 IF (ln_seaice) THEN 407 DO ji = 1, jnumseaice 408 WRITE(numout,'(1X,2A)') ' Sea Ice input observation file name seaicefiles = ', & 409 TRIM(seaicefiles(ji)) 410 END DO 411 ENDIF 412 IF (ln_velavcur) THEN 413 DO ji = 1, jnumvelavcur 414 WRITE(numout,'(1X,2A)') ' Vel. cur. daily av. input file name velavcurfiles = ', & 415 TRIM(velavcurfiles(ji)) 416 END DO 417 ENDIF 418 IF (ln_velhrcur) THEN 419 DO ji = 1, jnumvelhrcur 420 WRITE(numout,'(1X,2A)') ' Vel. cur. high freq. input file name velhvcurfiles = ', & 421 TRIM(velhrcurfiles(ji)) 422 END DO 423 ENDIF 424 IF (ln_velavadcp) THEN 425 DO ji = 1, jnumvelavadcp 426 WRITE(numout,'(1X,2A)') ' Vel. ADCP daily av. input file name velavadcpfiles = ', & 427 TRIM(velavadcpfiles(ji)) 428 END DO 429 ENDIF 430 IF (ln_velhradcp) THEN 431 DO ji = 1, jnumvelhradcp 432 WRITE(numout,'(1X,2A)') ' Vel. ADCP high freq. input file name velhvadcpfiles = ', & 433 TRIM(velhradcpfiles(ji)) 434 END DO 435 ENDIF 436 IF (ln_velfb) THEN 437 DO ji = 1, jnumvelfb 438 IF (ln_velfb_av(ji)) THEN 439 WRITE(numout,'(1X,2A)') ' Vel. feedback daily av. input file name velfbfiles = ', & 440 TRIM(velfbfiles(ji)) 623 ztype_avglamscl = rn_sla_avglamscl 624 ztype_avgphiscl = rn_sla_avgphiscl 625 ltype_fp_indegs = ln_sla_fp_indegs 626 ltype_night = .FALSE. 627 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sst' ) THEN 628 IF ( nn_2dint_sst == -1 ) THEN 629 n2dint_type = nn_2dint_default 441 630 ELSE 442 WRITE(numout,'(1X,2A)') ' Vel. feedback input observation file name velfbfiles = ', & 443 TRIM(velfbfiles(ji)) 631 n2dint_type = nn_2dint_sst 444 632 ENDIF 445 END DO 446 ENDIF 447 WRITE(numout,*) ' Initial date in window YYYYMMDD.HHMMSS dobsini = ', dobsini 448 WRITE(numout,*) ' Final date in window YYYYMMDD.HHMMSS dobsend = ', dobsend 449 WRITE(numout,*) ' Type of vertical interpolation method n1dint = ', n1dint 450 WRITE(numout,*) ' Type of horizontal interpolation method n2dint = ', n2dint 451 WRITE(numout,*) ' Rejection of observations near land swithch ln_nea = ', ln_nea 452 WRITE(numout,*) ' MSSH correction scheme nmsshc = ', nmsshc 453 WRITE(numout,*) ' MDT correction mdtcorr = ', mdtcorr 454 WRITE(numout,*) ' MDT cutoff for computed correction mdtcutoff = ', mdtcutoff 455 WRITE(numout,*) ' Logical switch for alt bias ln_altbias = ', ln_altbias 456 WRITE(numout,*) ' Logical switch for ignoring missing files ln_ignmis = ', ln_ignmis 457 WRITE(numout,*) ' ENACT daily average types = ',endailyavtypes 633 ztype_avglamscl = rn_sst_avglamscl 634 ztype_avgphiscl = rn_sst_avgphiscl 635 ltype_fp_indegs = ln_sst_fp_indegs 636 ltype_night = ln_sstnight 637 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sic' ) THEN 638 IF ( nn_2dint_sic == -1 ) THEN 639 n2dint_type = nn_2dint_default 640 ELSE 641 n2dint_type = nn_2dint_sic 642 ENDIF 643 ztype_avglamscl = rn_sic_avglamscl 644 ztype_avgphiscl = rn_sic_avgphiscl 645 ltype_fp_indegs = ln_sic_fp_indegs 646 ltype_night = .FALSE. 647 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sss' ) THEN 648 IF ( nn_2dint_sss == -1 ) THEN 649 n2dint_type = nn_2dint_default 650 ELSE 651 n2dint_type = nn_2dint_sss 652 ENDIF 653 ztype_avglamscl = rn_sss_avglamscl 654 ztype_avgphiscl = rn_sss_avgphiscl 655 ltype_fp_indegs = ln_sss_fp_indegs 656 ltype_night = .FALSE. 657 ELSE 658 n2dint_type = nn_2dint_default 659 ztype_avglamscl = rn_default_avglamscl 660 ztype_avgphiscl = rn_default_avgphiscl 661 ltype_fp_indegs = ln_default_fp_indegs 662 ltype_night = .FALSE. 663 ENDIF 664 665 CALL obs_setinterpopts( nsurftypes, jtype, TRIM(cobstypessurf(jtype)), & 666 & nn_2dint_default, n2dint_type, & 667 & ztype_avglamscl, ztype_avgphiscl, & 668 & ltype_fp_indegs, ltype_night, & 669 & n2dintsurf, ravglamscl, ravgphiscl, & 670 & lfpindegs, llnightav ) 671 672 END DO 458 673 459 674 ENDIF 460 675 676 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 677 678 679 !----------------------------------------------------------------------- 680 ! Obs operator parameter checking and initialisations 681 !----------------------------------------------------------------------- 682 461 683 IF ( ln_vel3d .AND. ( .NOT. ln_grid_global ) ) THEN 462 684 CALL ctl_stop( 'Velocity data only works with ln_grid_global=.true.' ) … … 464 686 ENDIF 465 687 466 CALL obs_typ_init 467 468 CALL mppmap_init 469 470 ! Parameter control 471 #if defined key_diaobs 472 IF ( ( .NOT. ln_t3d ).AND.( .NOT. ln_s3d ).AND.( .NOT. ln_sla ).AND. & 473 & ( .NOT. ln_vel3d ).AND. & 474 & ( .NOT. ln_ssh ).AND.( .NOT. ln_sst ).AND.( .NOT. ln_sss ).AND. & 475 & ( .NOT. ln_seaice ).AND.( .NOT. ln_vel3d ) ) THEN 476 IF(lwp) WRITE(numout,cform_war) 477 IF(lwp) WRITE(numout,*) ' key_diaobs is activated but logical flags', & 478 & ' ln_t3d, ln_s3d, ln_sla, ln_ssh, ln_sst, ln_sss, ln_seaice, ln_vel3d are all set to .FALSE.' 479 nwarn = nwarn + 1 480 ENDIF 481 #endif 482 483 CALL obs_grid_setup( ) 484 IF ( ( n1dint < 0 ).OR.( n1dint > 1 ) ) THEN 688 IF ( ( nn_1dint < 0 ) .OR. ( nn_1dint > 1 ) ) THEN 485 689 CALL ctl_stop(' Choice of vertical (1D) interpolation method', & 486 690 & ' is not available') 487 691 ENDIF 488 IF ( ( n2dint < 0 ).OR.( n2dint > 4 ) ) THEN 489 CALL ctl_stop(' Choice of horizontal (2D) interpolation method', & 692 693 IF ( ( nn_2dint_default < 0 ) .OR. ( nn_2dint_default > 6 ) ) THEN 694 CALL ctl_stop(' Choice of default horizontal (2D) interpolation method', & 490 695 & ' is not available') 491 696 ENDIF 492 697 698 CALL obs_typ_init 699 700 CALL mppmap_init 701 702 CALL obs_grid_setup( ) 703 493 704 !----------------------------------------------------------------------- 494 705 ! Depending on switches read the various observation types 495 706 !----------------------------------------------------------------------- 496 ! - Temperature/salinity profiles 497 498 IF ( ln_t3d .OR. ln_s3d ) THEN 499 500 ! Set the number of variables for profiles to 2 (T and S) 501 nprofvars = 2 502 ! Set the number of extra variables for profiles to 1 (insitu temp). 503 nprofextr = 1 504 505 ! Count how may insitu data sets we have and allocate data. 506 jprofset = 0 507 IF ( ln_ena ) jprofset = jprofset + 1 508 IF ( ln_cor ) jprofset = jprofset + 1 509 IF ( ln_profb ) jprofset = jprofset + jnumprofb 510 nprofsets = jprofset 511 IF ( nprofsets > 0 ) THEN 512 ALLOCATE(ld_enact(nprofsets)) 513 ALLOCATE(profdata(nprofsets)) 514 ALLOCATE(prodatqc(nprofsets)) 515 ENDIF 516 517 jprofset = 0 518 519 ! ENACT insitu data 520 521 IF ( ln_ena ) THEN 522 523 jprofset = jprofset + 1 707 708 IF ( nproftypes > 0 ) THEN 709 710 ALLOCATE(profdata(nproftypes)) 711 ALLOCATE(profdataqc(nproftypes)) 712 ALLOCATE(nvarsprof(nproftypes)) 713 ALLOCATE(nextrprof(nproftypes)) 714 715 DO jtype = 1, nproftypes 716 717 IF ( TRIM(cobstypesprof(jtype)) == 'prof' ) THEN 718 nvarsprof(jtype) = 2 719 nextrprof(jtype) = 1 720 ALLOCATE(llvar(nvarsprof(jtype))) 721 CALL wrk_alloc( jpi, jpj, nvarsprof(jtype), zglam ) 722 CALL wrk_alloc( jpi, jpj, nvarsprof(jtype), zgphi ) 723 CALL wrk_alloc( jpi, jpj, jpk, nvarsprof(jtype), zmask ) 724 llvar(1) = ln_t3d 725 llvar(2) = ln_s3d 726 zglam(:,:,1) = glamt(:,:) 727 zglam(:,:,2) = glamt(:,:) 728 zgphi(:,:,1) = gphit(:,:) 729 zgphi(:,:,2) = gphit(:,:) 730 zmask(:,:,:,1) = tmask(:,:,:) 731 zmask(:,:,:,2) = tmask(:,:,:) 732 ELSE IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN 733 nvarsprof(jtype) = 2 734 nextrprof(jtype) = 2 735 ALLOCATE(llvar(nvarsprof(jtype))) 736 CALL wrk_alloc( jpi, jpj, nvarsprof(jtype), zglam ) 737 CALL wrk_alloc( jpi, jpj, nvarsprof(jtype), zgphi ) 738 CALL wrk_alloc( jpi, jpj, jpk, nvarsprof(jtype), zmask ) 739 llvar(1) = ln_vel3d 740 llvar(2) = ln_vel3d 741 zglam(:,:,1) = glamu(:,:) 742 zglam(:,:,2) = glamv(:,:) 743 zgphi(:,:,1) = gphiu(:,:) 744 zgphi(:,:,2) = gphiv(:,:) 745 zmask(:,:,:,1) = umask(:,:,:) 746 zmask(:,:,:,2) = vmask(:,:,:) 747 ELSE 748 nvarsprof(jtype) = 1 749 nextrprof(jtype) = 0 750 ALLOCATE(llvar(nvarsprof(jtype))) 751 CALL wrk_alloc( jpi, jpj, nvarsprof(jtype), zglam ) 752 CALL wrk_alloc( jpi, jpj, nvarsprof(jtype), zgphi ) 753 CALL wrk_alloc( jpi, jpj, jpk, nvarsprof(jtype), zmask ) 754 llvar(1) = .TRUE. 755 zglam(:,:,1) = glamt(:,:) 756 zgphi(:,:,1) = gphit(:,:) 757 zmask(:,:,:,1) = tmask(:,:,:) 758 ENDIF 759 760 !Read in profile or profile obs types 761 CALL obs_rea_prof( profdata(jtype), ifilesprof(jtype), & 762 & clproffiles(jtype,1:ifilesprof(jtype)), & 763 & nvarsprof(jtype), nextrprof(jtype), nitend-nit000+2, & 764 & rn_dobsini, rn_dobsend, llvar, & 765 & ln_ignmis, ln_s_at_t, .FALSE., & 766 & kdailyavtypes = nn_profdavtypes ) 767 768 DO jvar = 1, nvarsprof(jtype) 769 CALL obs_prof_staend( profdata(jtype), jvar ) 770 END DO 771 772 CALL obs_pre_prof( profdata(jtype), profdataqc(jtype), & 773 & llvar, & 774 & jpi, jpj, jpk, & 775 & zmask, zglam, zgphi, & 776 & ln_nea, ln_bound_reject, & 777 & kdailyavtypes = nn_profdavtypes ) 524 778 525 ld_enact(jprofset) = .TRUE. 526 527 CALL obs_rea_pro_dri( 1, profdata(jprofset), & 528 & jnumenact, enactfiles(1:jnumenact), & 529 & nprofvars, nprofextr, & 530 & nitend-nit000+2, & 531 & dobsini, dobsend, ln_t3d, ln_s3d, & 532 & ln_ignmis, ln_s_at_t, .TRUE., .FALSE., & 533 & kdailyavtypes = endailyavtypes ) 534 535 DO jvar = 1, 2 536 537 CALL obs_prof_staend( profdata(jprofset), jvar ) 538 539 END DO 540 541 CALL obs_pre_pro( profdata(jprofset), prodatqc(jprofset), & 542 & ln_t3d, ln_s3d, ln_nea, & 543 & kdailyavtypes=endailyavtypes ) 544 545 ENDIF 546 547 ! Coriolis insitu data 548 549 IF ( ln_cor ) THEN 550 551 jprofset = jprofset + 1 552 553 ld_enact(jprofset) = .FALSE. 554 555 CALL obs_rea_pro_dri( 2, profdata(jprofset), & 556 & jnumcorio, coriofiles(1:jnumcorio), & 557 & nprofvars, nprofextr, & 558 & nitend-nit000+2, & 559 & dobsini, dobsend, ln_t3d, ln_s3d, & 560 & ln_ignmis, ln_s_at_t, .FALSE., .FALSE. ) 561 562 DO jvar = 1, 2 563 564 CALL obs_prof_staend( profdata(jprofset), jvar ) 565 566 END DO 567 568 CALL obs_pre_pro( profdata(jprofset), prodatqc(jprofset), & 569 & ln_t3d, ln_s3d, ln_nea ) 570 571 ENDIF 572 573 ! Feedback insitu data 574 575 IF ( ln_profb ) THEN 576 577 DO jset = 1, jnumprofb 578 579 jprofset = jprofset + 1 580 ld_enact (jprofset) = ln_profb_ena(jset) 581 582 CALL obs_rea_pro_dri( 0, profdata(jprofset), & 583 & 1, profbfiles(jset:jset), & 584 & nprofvars, nprofextr, & 585 & nitend-nit000+2, & 586 & dobsini, dobsend, ln_t3d, ln_s3d, & 587 & ln_ignmis, ln_s_at_t, & 588 & ld_enact(jprofset).AND.& 589 & ln_profb_enatim(jset), & 590 & .FALSE., kdailyavtypes = endailyavtypes ) 591 592 DO jvar = 1, 2 593 594 CALL obs_prof_staend( profdata(jprofset), jvar ) 595 779 DEALLOCATE( llvar ) 780 CALL wrk_dealloc( jpi, jpj, nvarsprof(jtype), zglam ) 781 CALL wrk_dealloc( jpi, jpj, nvarsprof(jtype), zgphi ) 782 CALL wrk_dealloc( jpi, jpj, jpk, nvarsprof(jtype), zmask ) 783 784 END DO 785 786 DEALLOCATE( ifilesprof, clproffiles ) 787 788 ENDIF 789 790 IF ( nsurftypes > 0 ) THEN 791 792 ALLOCATE(surfdata(nsurftypes)) 793 ALLOCATE(surfdataqc(nsurftypes)) 794 ALLOCATE(nvarssurf(nsurftypes)) 795 ALLOCATE(nextrsurf(nsurftypes)) 796 797 DO jtype = 1, nsurftypes 798 799 nvarssurf(jtype) = 1 800 nextrsurf(jtype) = 0 801 IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) nextrsurf(jtype) = 2 802 803 !Read in surface obs types 804 CALL obs_rea_surf( surfdata(jtype), ifilessurf(jtype), & 805 & clsurffiles(jtype,1:ifilessurf(jtype)), & 806 & nvarssurf(jtype), nextrsurf(jtype), nitend-nit000+2, & 807 & rn_dobsini, rn_dobsend, ln_ignmis, .FALSE., llnightav(jtype) ) 808 809 CALL obs_pre_surf( surfdata(jtype), surfdataqc(jtype), ln_nea, ln_bound_reject ) 810 811 IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN 812 CALL obs_rea_mdt( surfdataqc(jtype), n2dintsurf(jtype) ) 813 IF ( ln_altbias ) & 814 & CALL obs_rea_altbias ( surfdataqc(jtype), n2dintsurf(jtype), cn_altbiasfile ) 815 ENDIF 816 817 IF ( TRIM(cobstypessurf(jtype)) == 'sst' .AND. ln_sstbias ) THEN 818 jnumsstbias = 0 819 DO jfile = 1, jpmaxnfiles 820 IF ( TRIM(cn_sstbiasfiles(jfile)) /= '' ) & 821 & jnumsstbias = jnumsstbias + 1 596 822 END DO 597 598 IF ( ld_enact(jprofset) ) THEN 599 CALL obs_pre_pro( profdata(jprofset), prodatqc(jprofset), & 600 & ln_t3d, ln_s3d, ln_nea, & 601 & kdailyavtypes = endailyavtypes ) 602 ELSE 603 CALL obs_pre_pro( profdata(jprofset), prodatqc(jprofset), & 604 & ln_t3d, ln_s3d, ln_nea ) 823 IF ( jnumsstbias == 0 ) THEN 824 CALL ctl_stop("ln_sstbias set but no bias files to read in") 605 825 ENDIF 606 607 END DO 608 609 ENDIF 826 827 CALL obs_app_sstbias( surfdataqc(jtype), n2dintsurf(jtype), & 828 & jnumsstbias, cn_sstbiasfiles(1:jnumsstbias) ) 829 830 ENDIF 831 832 END DO 833 834 DEALLOCATE( ifilessurf, clsurffiles ) 610 835 611 836 ENDIF 612 837 613 ! - Sea level anomalies614 IF ( ln_sla ) THEN615 ! Set the number of variables for sla to 1616 nslavars = 1617 618 ! Set the number of extra variables for sla to 2619 nslaextr = 2620 621 ! Set the number of sla data sets to 2622 nslasets = 0623 IF ( ln_sladt ) THEN624 nslasets = nslasets + 2625 ENDIF626 IF ( ln_slafb ) THEN627 nslasets = nslasets + jnumslafb628 ENDIF629 630 ALLOCATE(sladata(nslasets))631 ALLOCATE(sladatqc(nslasets))632 sladata(:)%nsurf=0633 sladatqc(:)%nsurf=0634 635 nslasets = 0636 637 ! AVISO SLA data638 639 IF ( ln_sladt ) THEN640 641 ! Active SLA observations642 643 nslasets = nslasets + 1644 645 CALL obs_rea_sla( 1, sladata(nslasets), jnumslaact, &646 & slafilesact(1:jnumslaact), &647 & nslavars, nslaextr, nitend-nit000+2, &648 & dobsini, dobsend, ln_ignmis, .FALSE. )649 CALL obs_pre_sla( sladata(nslasets), sladatqc(nslasets), &650 & ln_sla, ln_nea )651 652 ! Passive SLA observations653 654 nslasets = nslasets + 1655 656 CALL obs_rea_sla( 1, sladata(nslasets), jnumslapas, &657 & slafilespas(1:jnumslapas), &658 & nslavars, nslaextr, nitend-nit000+2, &659 & dobsini, dobsend, ln_ignmis, .FALSE. )660 661 CALL obs_pre_sla( sladata(nslasets), sladatqc(nslasets), &662 & ln_sla, ln_nea )663 664 ENDIF665 666 ! Feedback SLA data667 668 IF ( ln_slafb ) THEN669 670 DO jset = 1, jnumslafb671 672 nslasets = nslasets + 1673 674 CALL obs_rea_sla( 0, sladata(nslasets), 1, &675 & slafbfiles(jset:jset), &676 & nslavars, nslaextr, nitend-nit000+2, &677 & dobsini, dobsend, ln_ignmis, .FALSE. )678 CALL obs_pre_sla( sladata(nslasets), sladatqc(nslasets), &679 & ln_sla, ln_nea )680 681 END DO682 683 ENDIF684 685 CALL obs_rea_mdt( nslasets, sladatqc, n2dint )686 687 ! read in altimeter bias688 689 IF ( ln_altbias ) THEN690 CALL obs_rea_altbias ( nslasets, sladatqc, n2dint, bias_file )691 ENDIF692 693 ENDIF694 695 ! - Sea surface height696 IF ( ln_ssh ) THEN697 IF(lwp) WRITE(numout,*) ' SSH currently not available'698 ENDIF699 700 ! - Sea surface temperature701 IF ( ln_sst ) THEN702 703 ! Set the number of variables for sst to 1704 nsstvars = 1705 706 ! Set the number of extra variables for sst to 0707 nsstextr = 0708 709 nsstsets = 0710 711 IF (ln_reysst) nsstsets = nsstsets + 1712 IF (ln_ghrsst) nsstsets = nsstsets + 1713 IF ( ln_sstfb ) THEN714 nsstsets = nsstsets + jnumsstfb715 ENDIF716 717 ALLOCATE(sstdata(nsstsets))718 ALLOCATE(sstdatqc(nsstsets))719 ALLOCATE(ld_sstnight(nsstsets))720 sstdata(:)%nsurf=0721 sstdatqc(:)%nsurf=0722 ld_sstnight(:)=.false.723 724 nsstsets = 0725 726 IF (ln_reysst) THEN727 728 nsstsets = nsstsets + 1729 730 ld_sstnight(nsstsets) = ln_sstnight731 732 CALL obs_rea_sst_rey( reysstname, reysstfmt, sstdata(nsstsets), &733 & nsstvars, nsstextr, &734 & nitend-nit000+2, dobsini, dobsend )735 CALL obs_pre_sst( sstdata(nsstsets), sstdatqc(nsstsets), ln_sst, &736 & ln_nea )737 738 ENDIF739 740 IF (ln_ghrsst) THEN741 742 nsstsets = nsstsets + 1743 744 ld_sstnight(nsstsets) = ln_sstnight745 746 CALL obs_rea_sst( 1, sstdata(nsstsets), jnumsst, &747 & sstfiles(1:jnumsst), &748 & nsstvars, nsstextr, nitend-nit000+2, &749 & dobsini, dobsend, ln_ignmis, .FALSE. )750 CALL obs_pre_sst( sstdata(nsstsets), sstdatqc(nsstsets), ln_sst, &751 & ln_nea )752 753 ENDIF754 755 ! Feedback SST data756 757 IF ( ln_sstfb ) THEN758 759 DO jset = 1, jnumsstfb760 761 nsstsets = nsstsets + 1762 763 ld_sstnight(nsstsets) = ln_sstnight764 765 CALL obs_rea_sst( 0, sstdata(nsstsets), 1, &766 & sstfbfiles(jset:jset), &767 & nsstvars, nsstextr, nitend-nit000+2, &768 & dobsini, dobsend, ln_ignmis, .FALSE. )769 CALL obs_pre_sst( sstdata(nsstsets), sstdatqc(nsstsets), &770 & ln_sst, ln_nea )771 772 END DO773 774 ENDIF775 776 ENDIF777 778 ! - Sea surface salinity779 IF ( ln_sss ) THEN780 IF(lwp) WRITE(numout,*) ' SSS currently not available'781 ENDIF782 783 ! - Sea Ice Concentration784 785 IF ( ln_seaice ) THEN786 787 ! Set the number of variables for seaice to 1788 nseaicevars = 1789 790 ! Set the number of extra variables for seaice to 0791 nseaiceextr = 0792 793 ! Set the number of data sets to 1794 nseaicesets = 1795 796 ALLOCATE(seaicedata(nseaicesets))797 ALLOCATE(seaicedatqc(nseaicesets))798 seaicedata(:)%nsurf=0799 seaicedatqc(:)%nsurf=0800 801 CALL obs_rea_seaice( 1, seaicedata(nseaicesets), jnumseaice, &802 & seaicefiles(1:jnumseaice), &803 & nseaicevars, nseaiceextr, nitend-nit000+2, &804 & dobsini, dobsend, ln_ignmis, .FALSE. )805 806 CALL obs_pre_seaice( seaicedata(nseaicesets), seaicedatqc(nseaicesets), &807 & ln_seaice, ln_nea )808 809 ENDIF810 811 IF (ln_vel3d) THEN812 813 ! Set the number of variables for profiles to 2 (U and V)814 nvelovars = 2815 816 ! Set the number of extra variables for profiles to 2 to store817 ! rotation parameters818 nveloextr = 2819 820 jveloset = 0821 822 IF ( ln_velavcur ) jveloset = jveloset + 1823 IF ( ln_velhrcur ) jveloset = jveloset + 1824 IF ( ln_velavadcp ) jveloset = jveloset + 1825 IF ( ln_velhradcp ) jveloset = jveloset + 1826 IF (ln_velfb) jveloset = jveloset + jnumvelfb827 828 nvelosets = jveloset829 IF ( nvelosets > 0 ) THEN830 ALLOCATE( velodata(nvelosets) )831 ALLOCATE( veldatqc(nvelosets) )832 ALLOCATE( ld_velav(nvelosets) )833 ENDIF834 835 jveloset = 0836 837 ! Daily averaged data838 839 IF ( ln_velavcur ) THEN840 841 jveloset = jveloset + 1842 843 ld_velav(jveloset) = .TRUE.844 845 CALL obs_rea_vel_dri( 1, velodata(jveloset), jnumvelavcur, &846 & velavcurfiles(1:jnumvelavcur), &847 & nvelovars, nveloextr, &848 & nitend-nit000+2, &849 & dobsini, dobsend, ln_ignmis, &850 & ld_velav(jveloset), &851 & .FALSE. )852 853 DO jvar = 1, 2854 CALL obs_prof_staend( velodata(jveloset), jvar )855 END DO856 857 CALL obs_pre_vel( velodata(jveloset), veldatqc(jveloset), &858 & ln_vel3d, ln_nea, ld_velav(jveloset) )859 860 ENDIF861 862 ! High frequency data863 864 IF ( ln_velhrcur ) THEN865 866 jveloset = jveloset + 1867 868 ld_velav(jveloset) = .FALSE.869 870 CALL obs_rea_vel_dri( 1, velodata(jveloset), jnumvelhrcur, &871 & velhrcurfiles(1:jnumvelhrcur), &872 & nvelovars, nveloextr, &873 & nitend-nit000+2, &874 & dobsini, dobsend, ln_ignmis, &875 & ld_velav(jveloset), &876 & .FALSE. )877 878 DO jvar = 1, 2879 CALL obs_prof_staend( velodata(jveloset), jvar )880 END DO881 882 CALL obs_pre_vel( velodata(jveloset), veldatqc(jveloset), &883 & ln_vel3d, ln_nea, ld_velav(jveloset) )884 885 ENDIF886 887 ! Daily averaged data888 889 IF ( ln_velavadcp ) THEN890 891 jveloset = jveloset + 1892 893 ld_velav(jveloset) = .TRUE.894 895 CALL obs_rea_vel_dri( 1, velodata(jveloset), jnumvelavadcp, &896 & velavadcpfiles(1:jnumvelavadcp), &897 & nvelovars, nveloextr, &898 & nitend-nit000+2, &899 & dobsini, dobsend, ln_ignmis, &900 & ld_velav(jveloset), &901 & .FALSE. )902 903 DO jvar = 1, 2904 CALL obs_prof_staend( velodata(jveloset), jvar )905 END DO906 907 CALL obs_pre_vel( velodata(jveloset), veldatqc(jveloset), &908 & ln_vel3d, ln_nea, ld_velav(jveloset) )909 910 ENDIF911 912 ! High frequency data913 914 IF ( ln_velhradcp ) THEN915 916 jveloset = jveloset + 1917 918 ld_velav(jveloset) = .FALSE.919 920 CALL obs_rea_vel_dri( 1, velodata(jveloset), jnumvelhradcp, &921 & velhradcpfiles(1:jnumvelhradcp), &922 & nvelovars, nveloextr, &923 & nitend-nit000+2, &924 & dobsini, dobsend, ln_ignmis, &925 & ld_velav(jveloset), &926 & .FALSE. )927 928 DO jvar = 1, 2929 CALL obs_prof_staend( velodata(jveloset), jvar )930 END DO931 932 CALL obs_pre_vel( velodata(jveloset), veldatqc(jveloset), &933 & ln_vel3d, ln_nea, ld_velav(jveloset) )934 935 ENDIF936 937 IF ( ln_velfb ) THEN938 939 DO jset = 1, jnumvelfb940 941 jveloset = jveloset + 1942 943 ld_velav(jveloset) = ln_velfb_av(jset)944 945 CALL obs_rea_vel_dri( 0, velodata(jveloset), 1, &946 & velfbfiles(jset:jset), &947 & nvelovars, nveloextr, &948 & nitend-nit000+2, &949 & dobsini, dobsend, ln_ignmis, &950 & ld_velav(jveloset), &951 & .FALSE. )952 953 DO jvar = 1, 2954 CALL obs_prof_staend( velodata(jveloset), jvar )955 END DO956 957 CALL obs_pre_vel( velodata(jveloset), veldatqc(jveloset), &958 & ln_vel3d, ln_nea, ld_velav(jveloset) )959 960 961 END DO962 963 ENDIF964 965 ENDIF966 967 838 END SUBROUTINE dia_obs_init 968 839 … … 974 845 !! 975 846 !! ** Method : Call the observation operators on each time step to 976 !! compute the model equivalent of the following date: 977 !! - T profiles 978 !! - S profiles 979 !! - Sea surface height (referenced to a mean) 980 !! - Sea surface temperature 981 !! - Sea surface salinity 982 !! - Velocity component (U,V) profiles 983 !! 984 !! ** Action : 847 !! compute the model equivalent of the following data: 848 !! - Profile data, currently T/S or U/V 849 !! - Surface data, currently SST, SLA or sea-ice concentration. 850 !! 851 !! ** Action : 985 852 !! 986 853 !! History : … … 991 858 !! ! 07-04 (G. Smith) Generalized surface operators 992 859 !! ! 08-10 (M. Valdivieso) obs operator for velocity profiles 860 !! ! 15-08 (M. Martin) Combined surface/profile routines. 993 861 !!---------------------------------------------------------------------- 994 862 !! * Modules used 995 USE dom_oce, ONLY : & ! Ocean space and time domain variables 996 & rdt, & 997 & gdept_1d, & 998 & tmask, umask, vmask 999 USE phycst, ONLY : & ! Physical constants 1000 & rday 1001 USE oce, ONLY : & ! Ocean dynamics and tracers variables 1002 & tsn, & 1003 & un, vn, & 863 USE phycst, ONLY : & ! Physical constants 864 & rday 865 USE oce, ONLY : & ! Ocean dynamics and tracers variables 866 & tsn, & 867 & un, & 868 & vn, & 1004 869 & sshn 1005 870 #if defined key_lim3 1006 USE ice, ONLY : & ! LIMIce model variables871 USE ice, ONLY : & ! LIM3 Ice model variables 1007 872 & frld 1008 873 #endif 1009 874 #if defined key_lim2 1010 USE ice_2, ONLY : & ! LIMIce model variables875 USE ice_2, ONLY : & ! LIM2 Ice model variables 1011 876 & frld 1012 877 #endif 878 #if defined key_cice 879 USE sbc_oce, ONLY : fr_i ! ice fraction 880 #endif 881 #if defined key_hadocc 882 USE trc, ONLY : & ! HadOCC variables 883 & trn, & 884 & HADOCC_CHL, & 885 & HADOCC_FCO2, & 886 & HADOCC_PCO2, & 887 & HADOCC_FILL_FLT 888 USE par_hadocc 889 USE had_bgc_const, ONLY: c2n_p 890 #elif defined key_medusa 891 USE trc, ONLY : & ! MEDUSA variables 892 & trn 893 USE par_medusa 894 USE sms_medusa, ONLY: & 895 & xthetapn, & 896 & xthetapd 897 #if defined key_roam 898 USE sms_medusa, ONLY: & 899 & f2_pco2w, & 900 & f2_fco2w, & 901 & f3_pH 902 #endif 903 #elif defined key_fabm 904 USE fabm 905 USE par_fabm 906 #endif 907 #if defined key_spm 908 USE par_spm, ONLY: & ! ERSEM/SPM sediments 909 & jp_spm 910 USE trc, ONLY : & 911 & trn 912 #endif 913 1013 914 IMPLICIT NONE 1014 915 1015 916 !! * Arguments 1016 INTEGER, INTENT(IN) :: kstp 917 INTEGER, INTENT(IN) :: kstp ! Current timestep 1017 918 !! * Local declarations 1018 INTEGER :: idaystp ! Number of timesteps per day 1019 INTEGER :: jprofset ! Profile data set loop variable 1020 INTEGER :: jslaset ! SLA data set loop variable 1021 INTEGER :: jsstset ! SST data set loop variable 1022 INTEGER :: jseaiceset ! sea ice data set loop variable 1023 INTEGER :: jveloset ! velocity profile data loop variable 1024 INTEGER :: jvar ! Variable number 1025 #if ! defined key_lim2 && ! defined key_lim3 1026 REAL(wp), POINTER, DIMENSION(:,:) :: frld 1027 #endif 1028 CHARACTER(LEN=20) :: datestr=" ",timestr=" " 1029 1030 #if ! defined key_lim2 && ! defined key_lim3 1031 CALL wrk_alloc(jpi,jpj,frld) 1032 #endif 919 INTEGER :: idaystp ! Number of timesteps per day 920 INTEGER :: jtype ! Data loop variable 921 INTEGER :: jvar ! Variable number 922 INTEGER :: ji, jj, jk ! Loop counters 923 REAL(wp) :: tiny ! small number 924 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: & 925 & zprofvar ! Model values for variables in a prof ob 926 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: & 927 & zprofmask ! Mask associated with zprofvar 928 REAL(wp), POINTER, DIMENSION(:,:) :: & 929 & zsurfvar, & ! Model values equivalent to surface ob. 930 & zsurfmask ! Mask associated with surface variable 931 REAL(wp), POINTER, DIMENSION(:,:,:) :: & 932 & zglam, & ! Model longitudes for prof variables 933 & zgphi ! Model latitudes for prof variables 934 LOGICAL :: llog10 ! Perform log10 transform of variable 935 1033 936 1034 937 IF(lwp) THEN … … 1036 939 WRITE(numout,*) 'dia_obs : Call the observation operators', kstp 1037 940 WRITE(numout,*) '~~~~~~~' 941 CALL FLUSH(numout) 1038 942 ENDIF 1039 943 … … 1041 945 1042 946 !----------------------------------------------------------------------- 1043 ! No LIM => frld == 0.0_wp 1044 !----------------------------------------------------------------------- 1045 #if ! defined key_lim2 && ! defined key_lim3 1046 frld(:,:) = 0.0_wp 1047 #endif 1048 !----------------------------------------------------------------------- 1049 ! Depending on switches call various observation operators 1050 !----------------------------------------------------------------------- 1051 1052 ! - Temperature/salinity profiles 1053 IF ( ln_t3d .OR. ln_s3d ) THEN 1054 DO jprofset = 1, nprofsets 1055 IF ( ld_enact(jprofset) ) THEN 1056 CALL obs_pro_opt( prodatqc(jprofset), & 1057 & kstp, jpi, jpj, jpk, nit000, idaystp, & 1058 & tsn(:,:,:,jp_tem), tsn(:,:,:,jp_sal), & 1059 & gdept_1d, tmask, n1dint, n2dint, & 1060 & kdailyavtypes = endailyavtypes ) 1061 ELSE 1062 CALL obs_pro_opt( prodatqc(jprofset), & 1063 & kstp, jpi, jpj, jpk, nit000, idaystp, & 1064 & tsn(:,:,:,jp_tem), tsn(:,:,:,jp_sal), & 1065 & gdept_1d, tmask, n1dint, n2dint ) 947 ! Call the profile and surface observation operators 948 !----------------------------------------------------------------------- 949 950 IF ( nproftypes > 0 ) THEN 951 952 DO jtype = 1, nproftypes 953 954 ! Allocate local work arrays 955 CALL wrk_alloc( jpi, jpj, jpk, profdataqc(jtype)%nvar, zprofvar ) 956 CALL wrk_alloc( jpi, jpj, jpk, profdataqc(jtype)%nvar, zprofmask ) 957 CALL wrk_alloc( jpi, jpj, profdataqc(jtype)%nvar, zglam ) 958 CALL wrk_alloc( jpi, jpj, profdataqc(jtype)%nvar, zgphi ) 959 960 ! Defaults which might change 961 DO jvar = 1, profdataqc(jtype)%nvar 962 zprofmask(:,:,:,jvar) = tmask(:,:,:) 963 zglam(:,:,jvar) = glamt(:,:) 964 zgphi(:,:,jvar) = gphit(:,:) 965 END DO 966 967 SELECT CASE ( TRIM(cobstypesprof(jtype)) ) 968 969 CASE('prof') 970 zprofvar(:,:,:,1) = tsn(:,:,:,jp_tem) 971 zprofvar(:,:,:,2) = tsn(:,:,:,jp_sal) 972 973 CASE('vel') 974 zprofvar(:,:,:,1) = un(:,:,:) 975 zprofvar(:,:,:,2) = vn(:,:,:) 976 zprofmask(:,:,:,1) = umask(:,:,:) 977 zprofmask(:,:,:,2) = vmask(:,:,:) 978 zglam(:,:,1) = glamu(:,:) 979 zglam(:,:,2) = glamv(:,:) 980 zgphi(:,:,1) = gphiu(:,:) 981 zgphi(:,:,2) = gphiv(:,:) 982 983 CASE('plchltot') 984 #if defined key_hadocc 985 ! Chlorophyll from HadOCC 986 zprofvar(:,:,:,1) = HADOCC_CHL(:,:,:) 987 #elif defined key_medusa 988 ! Add non-diatom and diatom chlorophyll from MEDUSA 989 zprofvar(:,:,:,1) = trn(:,:,:,jpchn) + trn(:,:,:,jpchd) 990 #elif defined key_fabm 991 ! Add all chlorophyll groups from ERSEM 992 zprofvar(:,:,:,1) = trn(:,:,:,jp_fabm_chl1) + trn(:,:,:,jp_fabm_chl2) + & 993 & trn(:,:,:,jp_fabm_chl3) + trn(:,:,:,jp_fabm_chl4) 994 #else 995 CALL ctl_stop( ' Trying to run plchltot observation operator', & 996 & ' but no biogeochemical model appears to have been defined' ) 997 #endif 998 ! Take the log10 where we can, otherwise exclude 999 tiny = 1.0e-20 1000 WHERE(zprofvar(:,:,:,:) > tiny .AND. zprofvar(:,:,:,:) /= obfillflt ) 1001 zprofvar(:,:,:,:) = LOG10(zprofvar(:,:,:,:)) 1002 ELSEWHERE 1003 zprofvar(:,:,:,:) = obfillflt 1004 zprofmask(:,:,:,:) = 0 1005 END WHERE 1006 ! Mask out model below any excluded values, 1007 ! to avoid interpolation issues 1008 DO jvar = 1, profdataqc(jtype)%nvar 1009 DO jj = 1, jpj 1010 DO ji = 1, jpi 1011 depth_loop: DO jk = 1, jpk 1012 IF ( zprofmask(ji,jj,jk,jvar) == 0 ) THEN 1013 zprofmask(ji,jj,jk:jpk,jvar) = 0 1014 EXIT depth_loop 1015 ENDIF 1016 END DO depth_loop 1017 END DO 1018 END DO 1019 END DO 1020 1021 CASE('pchltot') 1022 #if defined key_hadocc 1023 ! Chlorophyll from HadOCC 1024 zprofvar(:,:,:,1) = HADOCC_CHL(:,:,:) 1025 #elif defined key_medusa 1026 ! Add non-diatom and diatom chlorophyll from MEDUSA 1027 zprofvar(:,:,:,1) = trn(:,:,:,jpchn) + trn(:,:,:,jpchd) 1028 #elif defined key_fabm 1029 ! Add all chlorophyll groups from ERSEM 1030 zprofvar(:,:,:,1) = trn(:,:,:,jp_fabm_chl1) + trn(:,:,:,jp_fabm_chl2) + & 1031 & trn(:,:,:,jp_fabm_chl3) + trn(:,:,:,jp_fabm_chl4) 1032 #else 1033 CALL ctl_stop( ' Trying to run pchltot observation operator', & 1034 & ' but no biogeochemical model appears to have been defined' ) 1035 #endif 1036 1037 CASE('pno3') 1038 #if defined key_hadocc 1039 ! Dissolved inorganic nitrogen from HadOCC 1040 zprofvar(:,:,:,1) = trn(:,:,:,jp_had_nut) 1041 #elif defined key_medusa 1042 ! Dissolved inorganic nitrogen from MEDUSA 1043 zprofvar(:,:,:,1) = trn(:,:,:,jpdin) 1044 #elif defined key_fabm 1045 ! Nitrate from ERSEM 1046 zprofvar(:,:,:,1) = trn(:,:,:,jp_fabm_n3n) 1047 #else 1048 CALL ctl_stop( ' Trying to run pno3 observation operator', & 1049 & ' but no biogeochemical model appears to have been defined' ) 1050 #endif 1051 1052 CASE('psi4') 1053 #if defined key_hadocc 1054 CALL ctl_stop( ' Trying to run psi4 observation operator', & 1055 & ' but HadOCC does not simulate silicate' ) 1056 #elif defined key_medusa 1057 ! Silicate from MEDUSA 1058 zprofvar(:,:,:,1) = trn(:,:,:,jpsil) 1059 #elif defined key_fabm 1060 ! Silicate from ERSEM 1061 zprofvar(:,:,:,1) = trn(:,:,:,jp_fabm_n5s) 1062 #else 1063 CALL ctl_stop( ' Trying to run psi4 observation operator', & 1064 & ' but no biogeochemical model appears to have been defined' ) 1065 #endif 1066 1067 CASE('ppo4') 1068 #if defined key_hadocc 1069 CALL ctl_stop( ' Trying to run ppo4 observation operator', & 1070 & ' but HadOCC does not simulate phosphate' ) 1071 #elif defined key_medusa 1072 CALL ctl_stop( ' Trying to run ppo4 observation operator', & 1073 & ' but MEDUSA does not simulate phosphate' ) 1074 #elif defined key_fabm 1075 ! Phosphate from ERSEM 1076 zprofvar(:,:,:,1) = trn(:,:,:,jp_fabm_n1p) 1077 #else 1078 CALL ctl_stop( ' Trying to run ppo4 observation operator', & 1079 & ' but no biogeochemical model appears to have been defined' ) 1080 #endif 1081 1082 CASE('pdic') 1083 #if defined key_hadocc 1084 ! Dissolved inorganic carbon from HadOCC 1085 zprofvar(:,:,:,1) = trn(:,:,:,jp_had_dic) 1086 #elif defined key_medusa 1087 ! Dissolved inorganic carbon from MEDUSA 1088 zprofvar(:,:,:,1) = trn(:,:,:,jpdic) 1089 #elif defined key_fabm 1090 ! Dissolved inorganic carbon from ERSEM 1091 zprofvar(:,:,:,1) = trn(:,:,:,jp_fabm_o3c) 1092 #else 1093 CALL ctl_stop( ' Trying to run pdic observation operator', & 1094 & ' but no biogeochemical model appears to have been defined' ) 1095 #endif 1096 1097 CASE('palk') 1098 #if defined key_hadocc 1099 ! Alkalinity from HadOCC 1100 zprofvar(:,:,:,1) = trn(:,:,:,jp_had_alk) 1101 #elif defined key_medusa 1102 ! Alkalinity from MEDUSA 1103 zprofvar(:,:,:,1) = trn(:,:,:,jpalk) 1104 #elif defined key_fabm 1105 ! Alkalinity from ERSEM 1106 zprofvar(:,:,:,1) = trn(:,:,:,jp_fabm_o3a) 1107 #else 1108 CALL ctl_stop( ' Trying to run palk observation operator', & 1109 & ' but no biogeochemical model appears to have been defined' ) 1110 #endif 1111 1112 CASE('pph') 1113 #if defined key_hadocc 1114 CALL ctl_stop( ' Trying to run pph observation operator', & 1115 & ' but HadOCC has no pH diagnostic defined' ) 1116 #elif defined key_medusa && defined key_roam 1117 ! pH from MEDUSA 1118 zprofvar(:,:,:,1) = f3_pH(:,:,:) 1119 #elif defined key_fabm 1120 ! pH from ERSEM 1121 zprofvar(:,:,:,1) = trn(:,:,:,jp_fabm_o3ph) 1122 #else 1123 CALL ctl_stop( ' Trying to run pph observation operator', & 1124 & ' but no biogeochemical model appears to have been defined' ) 1125 #endif 1126 1127 CASE('po2') 1128 #if defined key_hadocc 1129 CALL ctl_stop( ' Trying to run po2 observation operator', & 1130 & ' but HadOCC does not simulate oxygen' ) 1131 #elif defined key_medusa 1132 ! Oxygen from MEDUSA 1133 zprofvar(:,:,:,1) = trn(:,:,:,jpoxy) 1134 #elif defined key_fabm 1135 ! Oxygen from ERSEM 1136 zprofvar(:,:,:,1) = trn(:,:,:,jp_fabm_o2o) 1137 #else 1138 CALL ctl_stop( ' Trying to run po2 observation operator', & 1139 & ' but no biogeochemical model appears to have been defined' ) 1140 #endif 1141 1142 CASE DEFAULT 1143 CALL ctl_stop( 'Unknown profile observation type '//TRIM(cobstypesprof(jtype))//' in dia_obs' ) 1144 1145 END SELECT 1146 1147 DO jvar = 1, profdataqc(jtype)%nvar 1148 CALL obs_prof_opt( profdataqc(jtype), kstp, jpi, jpj, jpk, & 1149 & nit000, idaystp, jvar, & 1150 & zprofvar(:,:,:,jvar), & 1151 & fsdept(:,:,:), fsdepw(:,:,:), & 1152 & zprofmask(:,:,:,jvar), & 1153 & zglam(:,:,jvar), zgphi(:,:,jvar), & 1154 & nn_1dint, nn_2dint_default, & 1155 & kdailyavtypes = nn_profdavtypes ) 1156 END DO 1157 1158 CALL wrk_dealloc( jpi, jpj, jpk, profdataqc(jtype)%nvar, zprofvar ) 1159 CALL wrk_dealloc( jpi, jpj, jpk, profdataqc(jtype)%nvar, zprofmask ) 1160 CALL wrk_dealloc( jpi, jpj, profdataqc(jtype)%nvar, zglam ) 1161 CALL wrk_dealloc( jpi, jpj, profdataqc(jtype)%nvar, zgphi ) 1162 1163 END DO 1164 1165 ENDIF 1166 1167 IF ( nsurftypes > 0 ) THEN 1168 1169 !Allocate local work arrays 1170 CALL wrk_alloc( jpi, jpj, zsurfvar ) 1171 CALL wrk_alloc( jpi, jpj, zsurfmask ) 1172 1173 DO jtype = 1, nsurftypes 1174 1175 !Defaults which might be changed 1176 zsurfmask(:,:) = tmask(:,:,1) 1177 llog10 = .FALSE. 1178 1179 SELECT CASE ( TRIM(cobstypessurf(jtype)) ) 1180 CASE('sst') 1181 zsurfvar(:,:) = tsn(:,:,1,jp_tem) 1182 CASE('sla') 1183 zsurfvar(:,:) = sshn(:,:) 1184 CASE('sss') 1185 zsurfvar(:,:) = tsn(:,:,1,jp_sal) 1186 CASE('sic') 1187 IF ( kstp == 0 ) THEN 1188 IF ( lwp .AND. surfdataqc(jtype)%nsstpmpp(1) > 0 ) THEN 1189 CALL ctl_warn( 'Sea-ice not initialised on zeroth '// & 1190 & 'time-step but some obs are valid then.' ) 1191 WRITE(numout,*)surfdataqc(jtype)%nsstpmpp(1), & 1192 & ' sea-ice obs will be missed' 1193 ENDIF 1194 surfdataqc(jtype)%nsurfup = surfdataqc(jtype)%nsurfup + & 1195 & surfdataqc(jtype)%nsstp(1) 1196 CYCLE 1197 ELSE 1198 #if defined key_cice 1199 zsurfvar(:,:) = fr_i(:,:) 1200 #elif defined key_lim2 || defined key_lim3 1201 zsurfvar(:,:) = 1._wp - frld(:,:) 1202 #else 1203 CALL ctl_stop( ' Trying to run sea-ice observation operator', & 1204 & ' but no sea-ice model appears to have been defined' ) 1205 #endif 1206 ENDIF 1207 1208 CASE('slchltot') 1209 #if defined key_hadocc 1210 ! Surface chlorophyll from HadOCC 1211 zsurfvar(:,:) = HADOCC_CHL(:,:,1) 1212 #elif defined key_medusa 1213 ! Add non-diatom and diatom surface chlorophyll from MEDUSA 1214 zsurfvar(:,:) = trn(:,:,1,jpchn) + trn(:,:,1,jpchd) 1215 #elif defined key_fabm 1216 ! Add all surface chlorophyll groups from ERSEM 1217 zsurfvar(:,:) = trn(:,:,1,jp_fabm_chl1) + trn(:,:,1,jp_fabm_chl2) + & 1218 & trn(:,:,1,jp_fabm_chl3) + trn(:,:,1,jp_fabm_chl4) 1219 #else 1220 CALL ctl_stop( ' Trying to run slchltot observation operator', & 1221 & ' but no biogeochemical model appears to have been defined' ) 1222 #endif 1223 llog10 = .TRUE. 1224 1225 CASE('slchldia') 1226 #if defined key_hadocc 1227 CALL ctl_stop( ' Trying to run slchldia observation operator', & 1228 & ' but HadOCC does not explicitly simulate diatoms' ) 1229 #elif defined key_medusa 1230 ! Diatom surface chlorophyll from MEDUSA 1231 zsurfvar(:,:) = trn(:,:,1,jpchd) 1232 #elif defined key_fabm 1233 ! Diatom surface chlorophyll from ERSEM 1234 zsurfvar(:,:) = trn(:,:,1,jp_fabm_chl1) 1235 #else 1236 CALL ctl_stop( ' Trying to run slchldia observation operator', & 1237 & ' but no biogeochemical model appears to have been defined' ) 1238 #endif 1239 llog10 = .TRUE. 1240 1241 CASE('slchlnon') 1242 #if defined key_hadocc 1243 CALL ctl_stop( ' Trying to run slchlnon observation operator', & 1244 & ' but HadOCC does not explicitly simulate non-diatoms' ) 1245 #elif defined key_medusa 1246 ! Non-diatom surface chlorophyll from MEDUSA 1247 zsurfvar(:,:) = trn(:,:,1,jpchn) 1248 #elif defined key_fabm 1249 ! Add all non-diatom surface chlorophyll groups from ERSEM 1250 zsurfvar(:,:) = trn(:,:,1,jp_fabm_chl2) + & 1251 & trn(:,:,1,jp_fabm_chl3) + trn(:,:,1,jp_fabm_chl4) 1252 #else 1253 CALL ctl_stop( ' Trying to run slchlnon observation operator', & 1254 & ' but no biogeochemical model appears to have been defined' ) 1255 #endif 1256 llog10 = .TRUE. 1257 1258 CASE('slchldin') 1259 #if defined key_hadocc 1260 CALL ctl_stop( ' Trying to run slchldin observation operator', & 1261 & ' but HadOCC does not explicitly simulate dinoflagellates' ) 1262 #elif defined key_medusa 1263 CALL ctl_stop( ' Trying to run slchldin observation operator', & 1264 & ' but MEDUSA does not explicitly simulate dinoflagellates' ) 1265 #elif defined key_fabm 1266 ! Dinoflagellate surface chlorophyll from ERSEM 1267 zsurfvar(:,:) = trn(:,:,1,jp_fabm_chl4) 1268 #else 1269 CALL ctl_stop( ' Trying to run slchldin observation operator', & 1270 & ' but no biogeochemical model appears to have been defined' ) 1271 #endif 1272 llog10 = .TRUE. 1273 1274 CASE('slchlmic') 1275 #if defined key_hadocc 1276 CALL ctl_stop( ' Trying to run slchlmic observation operator', & 1277 & ' but HadOCC does not explicitly simulate microphytoplankton' ) 1278 #elif defined key_medusa 1279 CALL ctl_stop( ' Trying to run slchlmic observation operator', & 1280 & ' but MEDUSA does not explicitly simulate microphytoplankton' ) 1281 #elif defined key_fabm 1282 ! Add diatom and dinoflagellate surface chlorophyll from ERSEM 1283 zsurfvar(:,:) = trn(:,:,1,jp_fabm_chl1) + trn(:,:,1,jp_fabm_chl4) 1284 #else 1285 CALL ctl_stop( ' Trying to run slchlmic observation operator', & 1286 & ' but no biogeochemical model appears to have been defined' ) 1287 #endif 1288 llog10 = .TRUE. 1289 1290 CASE('slchlnan') 1291 #if defined key_hadocc 1292 CALL ctl_stop( ' Trying to run slchlnan observation operator', & 1293 & ' but HadOCC does not explicitly simulate nanophytoplankton' ) 1294 #elif defined key_medusa 1295 CALL ctl_stop( ' Trying to run slchlnan observation operator', & 1296 & ' but MEDUSA does not explicitly simulate nanophytoplankton' ) 1297 #elif defined key_fabm 1298 ! Nanophytoplankton surface chlorophyll from ERSEM 1299 zsurfvar(:,:) = trn(:,:,1,jp_fabm_chl2) 1300 #else 1301 CALL ctl_stop( ' Trying to run slchlnan observation operator', & 1302 & ' but no biogeochemical model appears to have been defined' ) 1303 #endif 1304 llog10 = .TRUE. 1305 1306 CASE('slchlpic') 1307 #if defined key_hadocc 1308 CALL ctl_stop( ' Trying to run slchlpic observation operator', & 1309 & ' but HadOCC does not explicitly simulate picophytoplankton' ) 1310 #elif defined key_medusa 1311 CALL ctl_stop( ' Trying to run slchlpic observation operator', & 1312 & ' but MEDUSA does not explicitly simulate picophytoplankton' ) 1313 #elif defined key_fabm 1314 ! Picophytoplankton surface chlorophyll from ERSEM 1315 zsurfvar(:,:) = trn(:,:,1,jp_fabm_chl3) 1316 #else 1317 CALL ctl_stop( ' Trying to run slchlpic observation operator', & 1318 & ' but no biogeochemical model appears to have been defined' ) 1319 #endif 1320 llog10 = .TRUE. 1321 1322 CASE('schltot') 1323 #if defined key_hadocc 1324 ! Surface chlorophyll from HadOCC 1325 zsurfvar(:,:) = HADOCC_CHL(:,:,1) 1326 #elif defined key_medusa 1327 ! Add non-diatom and diatom surface chlorophyll from MEDUSA 1328 zsurfvar(:,:) = trn(:,:,1,jpchn) + trn(:,:,1,jpchd) 1329 #elif defined key_fabm 1330 ! Add all surface chlorophyll groups from ERSEM 1331 zsurfvar(:,:) = trn(:,:,1,jp_fabm_chl1) + trn(:,:,1,jp_fabm_chl2) + & 1332 & trn(:,:,1,jp_fabm_chl3) + trn(:,:,1,jp_fabm_chl4) 1333 #else 1334 CALL ctl_stop( ' Trying to run schltot observation operator', & 1335 & ' but no biogeochemical model appears to have been defined' ) 1336 #endif 1337 1338 CASE('slphytot') 1339 #if defined key_hadocc 1340 ! Surface phytoplankton nitrogen from HadOCC multiplied by C:N ratio 1341 zsurfvar(:,:) = trn(:,:,1,jp_had_phy) * c2n_p 1342 #elif defined key_medusa 1343 ! Add non-diatom and diatom surface phytoplankton nitrogen from MEDUSA 1344 ! multiplied by C:N ratio for each 1345 zsurfvar(:,:) = (trn(:,:,1,jpphn) * xthetapn) + (trn(:,:,1,jpphd) * xthetapd) 1346 #elif defined key_fabm 1347 ! Add all surface phytoplankton carbon groups from ERSEM 1348 zsurfvar(:,:) = trn(:,:,1,jp_fabm_p1c) + trn(:,:,1,jp_fabm_p2c) + & 1349 & trn(:,:,1,jp_fabm_p3c) + trn(:,:,1,jp_fabm_p4c) 1350 #else 1351 CALL ctl_stop( ' Trying to run slphytot observation operator', & 1352 & ' but no biogeochemical model appears to have been defined' ) 1353 #endif 1354 llog10 = .TRUE. 1355 1356 CASE('slphydia') 1357 #if defined key_hadocc 1358 CALL ctl_stop( ' Trying to run slphydia observation operator', & 1359 & ' but HadOCC does not explicitly simulate diatoms' ) 1360 #elif defined key_medusa 1361 ! Diatom surface phytoplankton nitrogen from MEDUSA multiplied by C:N ratio 1362 zsurfvar(:,:) = trn(:,:,1,jpphd) * xthetapd 1363 #elif defined key_fabm 1364 ! Diatom surface phytoplankton carbon from ERSEM 1365 zsurfvar(:,:) = trn(:,:,1,jp_fabm_p1c) 1366 #else 1367 CALL ctl_stop( ' Trying to run slphydia observation operator', & 1368 & ' but no biogeochemical model appears to have been defined' ) 1369 #endif 1370 llog10 = .TRUE. 1371 1372 CASE('slphynon') 1373 #if defined key_hadocc 1374 CALL ctl_stop( ' Trying to run slphynon observation operator', & 1375 & ' but HadOCC does not explicitly simulate non-diatoms' ) 1376 #elif defined key_medusa 1377 ! Non-diatom surface phytoplankton nitrogen from MEDUSA multiplied by C:N ratio 1378 zsurfvar(:,:) = trn(:,:,1,jpphn) * xthetapn 1379 #elif defined key_fabm 1380 ! Add all non-diatom surface phytoplankton carbon groups from ERSEM 1381 zsurfvar(:,:) = trn(:,:,1,jp_fabm_p2c) + & 1382 & trn(:,:,1,jp_fabm_p3c) + trn(:,:,1,jp_fabm_p4c) 1383 #else 1384 CALL ctl_stop( ' Trying to run slphynon observation operator', & 1385 & ' but no biogeochemical model appears to have been defined' ) 1386 #endif 1387 llog10 = .TRUE. 1388 1389 CASE('sspm') 1390 #if defined key_spm 1391 zsurfvar(:,:) = 0.0 1392 DO jn = 1, jp_spm 1393 zsurfvar(:,:) = zsurfvar(:,:) + trn(:,:,1,jn) ! sum SPM sizes 1394 END DO 1395 #else 1396 CALL ctl_stop( ' Trying to run sspm observation operator', & 1397 & ' but no spm model appears to have been defined' ) 1398 #endif 1399 1400 CASE('sfco2') 1401 #if defined key_hadocc 1402 zsurfvar(:,:) = HADOCC_FCO2(:,:) ! fCO2 from HadOCC 1403 IF ( ( MINVAL( HADOCC_FCO2 ) == HADOCC_FILL_FLT ) .AND. & 1404 & ( MAXVAL( HADOCC_FCO2 ) == HADOCC_FILL_FLT ) ) THEN 1405 zsurfvar(:,:) = obfillflt 1406 zsurfmask(:,:) = 0 1407 CALL ctl_warn( ' HadOCC fCO2 values masked out for observation operator', & 1408 & ' as HADOCC_FCO2(:,:) == HADOCC_FILL_FLT' ) 1409 ENDIF 1410 #elif defined key_medusa && defined key_roam 1411 zsurfvar(:,:) = f2_fco2w(:,:) 1412 #elif defined key_fabm 1413 ! First, get pCO2 from FABM 1414 pco2_3d(:,:,:) = fabm_get_bulk_diagnostic_data(model, jp_fabm_o3pc) 1415 zsurfvar(:,:) = pco2_3d(:,:,1) 1416 ! Now, convert pCO2 to fCO2, based on SST in K. This follows the standard methodology of: 1417 ! Pierrot et al. (2009), Recommendations for autonomous underway pCO2 measuring systems 1418 ! and data reduction routines, Deep-Sea Research II, 56: 512-522. 1419 ! and 1420 ! Weiss (1974), Carbon dioxide in water and seawater: the solubility of a non-ideal gas, 1421 ! Marine Chemistry, 2: 203-215. 1422 ! In the implementation below, atmospheric pressure has been assumed to be 1 atm and so 1423 ! not explicitly included - atmospheric pressure is not necessarily available so this is 1424 ! the best assumption. 1425 ! Further, the (1-xCO2)^2 term has been neglected. This is common practice 1426 ! (see e.g. Zeebe and Wolf-Gladrow (2001), CO2 in Seawater: Equilibrium, Kinetics, Isotopes) 1427 ! because xCO2 in atm is ~0, and so this term will only affect the result to the 3rd decimal 1428 ! place for typical values, and xCO2 would need to be approximated from pCO2 anyway. 1429 zsurfvar(:,:) = zsurfvar(:,:) * EXP((-1636.75 + & 1430 & 12.0408 * (tsn(:,:,1,jp_tem)+rt0) - & 1431 & 0.0327957 * (tsn(:,:,1,jp_tem)+rt0)*(tsn(:,:,1,jp_tem)+rt0) + & 1432 & 0.0000316528 * (tsn(:,:,1,jp_tem)+rt0)*(tsn(:,:,1,jp_tem)+rt0)*(tsn(:,:,1,jp_tem)+rt0) + & 1433 & 2.0 * (57.7 - 0.118 * (tsn(:,:,1,jp_tem)+rt0))) / & 1434 & (82.0578 * (tsn(:,:,1,jp_tem)+rt0))) 1435 #else 1436 CALL ctl_stop( ' Trying to run sfco2 observation operator', & 1437 & ' but no biogeochemical model appears to have been defined' ) 1438 #endif 1439 1440 CASE('spco2') 1441 #if defined key_hadocc 1442 zsurfvar(:,:) = HADOCC_PCO2(:,:) ! pCO2 from HadOCC 1443 IF ( ( MINVAL( HADOCC_PCO2 ) == HADOCC_FILL_FLT ) .AND. & 1444 & ( MAXVAL( HADOCC_PCO2 ) == HADOCC_FILL_FLT ) ) THEN 1445 zsurfvar(:,:) = obfillflt 1446 zsurfmask(:,:) = 0 1447 CALL ctl_warn( ' HadOCC pCO2 values masked out for observation operator', & 1448 & ' as HADOCC_PCO2(:,:) == HADOCC_FILL_FLT' ) 1449 ENDIF 1450 #elif defined key_medusa && defined key_roam 1451 zsurfvar(:,:) = f2_pco2w(:,:) 1452 #elif defined key_fabm 1453 pco2_3d(:,:,:) = fabm_get_bulk_diagnostic_data(model, jp_fabm_o3pc) 1454 zsurfvar(:,:) = pco2_3d(:,:,1) 1455 #else 1456 CALL ctl_stop( ' Trying to run spco2 observation operator', & 1457 & ' but no biogeochemical model appears to have been defined' ) 1458 #endif 1459 1460 CASE DEFAULT 1461 1462 CALL ctl_stop( 'Unknown surface observation type '//TRIM(cobstypessurf(jtype))//' in dia_obs' ) 1463 1464 END SELECT 1465 1466 IF ( llog10 ) THEN 1467 ! Take the log10 where we can, otherwise exclude 1468 tiny = 1.0e-20 1469 WHERE(zsurfvar(:,:) > tiny .AND. zsurfvar(:,:) /= obfillflt ) 1470 zsurfvar(:,:) = LOG10(zsurfvar(:,:)) 1471 ELSEWHERE 1472 zsurfvar(:,:) = obfillflt 1473 zsurfmask(:,:) = 0 1474 END WHERE 1066 1475 ENDIF 1476 1477 CALL obs_surf_opt( surfdataqc(jtype), kstp, jpi, jpj, & 1478 & nit000, idaystp, zsurfvar, zsurfmask, & 1479 & n2dintsurf(jtype), llnightav(jtype), & 1480 & ravglamscl(jtype), ravgphiscl(jtype), & 1481 & lfpindegs(jtype) ) 1482 1067 1483 END DO 1484 1485 CALL wrk_dealloc( jpi, jpj, zsurfvar ) 1486 CALL wrk_dealloc( jpi, jpj, zsurfmask ) 1487 1068 1488 ENDIF 1069 1489 1070 ! - Sea surface anomaly1071 IF ( ln_sla ) THEN1072 DO jslaset = 1, nslasets1073 CALL obs_sla_opt( sladatqc(jslaset), &1074 & kstp, jpi, jpj, nit000, sshn, &1075 & tmask(:,:,1), n2dint )1076 END DO1077 ENDIF1078 1079 ! - Sea surface temperature1080 IF ( ln_sst ) THEN1081 DO jsstset = 1, nsstsets1082 CALL obs_sst_opt( sstdatqc(jsstset), &1083 & kstp, jpi, jpj, nit000, idaystp, &1084 & tsn(:,:,1,jp_tem), tmask(:,:,1), &1085 & n2dint, ld_sstnight(jsstset) )1086 END DO1087 ENDIF1088 1089 ! - Sea surface salinity1090 IF ( ln_sss ) THEN1091 IF(lwp) WRITE(numout,*) ' SSS currently not available'1092 ENDIF1093 1094 #if defined key_lim2 || defined key_lim31095 IF ( ln_seaice ) THEN1096 DO jseaiceset = 1, nseaicesets1097 CALL obs_seaice_opt( seaicedatqc(jseaiceset), &1098 & kstp, jpi, jpj, nit000, 1.-frld, &1099 & tmask(:,:,1), n2dint )1100 END DO1101 ENDIF1102 #endif1103 1104 ! - Velocity profiles1105 IF ( ln_vel3d ) THEN1106 DO jveloset = 1, nvelosets1107 ! zonal component of velocity1108 CALL obs_vel_opt( veldatqc(jveloset), kstp, jpi, jpj, jpk, &1109 & nit000, idaystp, un, vn, gdept_1d, umask, vmask, &1110 n1dint, n2dint, ld_velav(jveloset) )1111 END DO1112 ENDIF1113 1114 #if ! defined key_lim2 && ! defined key_lim31115 CALL wrk_dealloc(jpi,jpj,frld)1116 #endif1117 1118 1490 END SUBROUTINE dia_obs 1119 1120 SUBROUTINE dia_obs_wri 1491 1492 SUBROUTINE dia_obs_wri 1121 1493 !!---------------------------------------------------------------------- 1122 1494 !! *** ROUTINE dia_obs_wri *** … … 1126 1498 !! ** Method : Call observation diagnostic output routines 1127 1499 !! 1128 !! ** Action : 1500 !! ** Action : 1129 1501 !! 1130 1502 !! History : … … 1134 1506 !! ! 07-03 (K. Mogensen) General handling of profiles 1135 1507 !! ! 08-09 (M. Valdivieso) Velocity component (U,V) profiles 1508 !! ! 15-08 (M. Martin) Combined writing for prof and surf types 1136 1509 !!---------------------------------------------------------------------- 1510 !! * Modules used 1511 USE obs_rot_vel ! Rotation of velocities 1512 1137 1513 IMPLICIT NONE 1138 1514 1139 1515 !! * Local declarations 1140 1141 INTEGER :: jprofset ! Profile data set loop variable 1142 INTEGER :: jveloset ! Velocity data set loop variable 1143 INTEGER :: jslaset ! SLA data set loop variable 1144 INTEGER :: jsstset ! SST data set loop variable 1145 INTEGER :: jseaiceset ! Sea Ice data set loop variable 1146 INTEGER :: jset 1147 INTEGER :: jfbini 1148 CHARACTER(LEN=20) :: datestr=" ",timestr=" " 1149 CHARACTER(LEN=10) :: cdtmp 1516 INTEGER :: jtype ! Data set loop variable 1517 INTEGER :: jo, jvar, jk 1518 REAL(wp), DIMENSION(:), ALLOCATABLE :: & 1519 & zu, & 1520 & zv 1521 1150 1522 !----------------------------------------------------------------------- 1151 1523 ! Depending on switches call various observation output routines 1152 1524 !----------------------------------------------------------------------- 1153 1525 1154 ! - Temperature/salinity profiles 1155 1156 IF( ln_t3d .OR. ln_s3d ) THEN 1157 1158 ! Copy data from prodatqc to profdata structures 1159 DO jprofset = 1, nprofsets 1160 1161 CALL obs_prof_decompress( prodatqc(jprofset), & 1162 & profdata(jprofset), .TRUE., numout ) 1526 IF ( nproftypes > 0 ) THEN 1527 1528 DO jtype = 1, nproftypes 1529 1530 IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN 1531 1532 ! For velocity data, rotate the model velocities to N/S, E/W 1533 ! using the compressed data structure. 1534 ALLOCATE( & 1535 & zu(profdataqc(jtype)%nvprot(1)), & 1536 & zv(profdataqc(jtype)%nvprot(2)) & 1537 & ) 1538 1539 CALL obs_rotvel( profdataqc(jtype), nn_2dint_default, zu, zv ) 1540 1541 DO jo = 1, profdataqc(jtype)%nprof 1542 DO jvar = 1, 2 1543 DO jk = profdataqc(jtype)%npvsta(jo,jvar), profdataqc(jtype)%npvend(jo,jvar) 1544 1545 IF ( jvar == 1 ) THEN 1546 profdataqc(jtype)%var(jvar)%vmod(jk) = zu(jk) 1547 ELSE 1548 profdataqc(jtype)%var(jvar)%vmod(jk) = zv(jk) 1549 ENDIF 1550 1551 END DO 1552 END DO 1553 END DO 1554 1555 DEALLOCATE( zu ) 1556 DEALLOCATE( zv ) 1557 1558 END IF 1559 1560 CALL obs_prof_decompress( profdataqc(jtype), & 1561 & profdata(jtype), .TRUE., numout ) 1562 1563 CALL obs_wri_prof( profdata(jtype) ) 1163 1564 1164 1565 END DO 1165 1566 1166 ! Write the profiles.1167 1168 jprofset = 01169 1170 ! ENACT insitu data1171 1172 IF ( ln_ena ) THEN1173 1174 jprofset = jprofset + 11175 1176 CALL obs_wri_p3d( 'enact', profdata(jprofset) )1177 1178 ENDIF1179 1180 ! Coriolis insitu data1181 1182 IF ( ln_cor ) THEN1183 1184 jprofset = jprofset + 11185 1186 CALL obs_wri_p3d( 'corio', profdata(jprofset) )1187 1188 ENDIF1189 1190 ! Feedback insitu data1191 1192 IF ( ln_profb ) THEN1193 1194 jfbini = jprofset + 11195 1196 DO jprofset = jfbini, nprofsets1197 1198 jset = jprofset - jfbini + 11199 WRITE(cdtmp,'(A,I2.2)')'profb_',jset1200 CALL obs_wri_p3d( cdtmp, profdata(jprofset) )1201 1202 END DO1203 1204 ENDIF1205 1206 1567 ENDIF 1207 1568 1208 ! - Sea surface anomaly1209 IF ( ln_sla ) THEN 1210 1211 ! Copy data from sladatqc to sladata structures 1212 DO jslaset = 1, nslasets1213 1214 CALL obs_surf_decompress( sladatqc(jslaset), & 1215 & sladata(jslaset), .TRUE., numout)1569 IF ( nsurftypes > 0 ) THEN 1570 1571 DO jtype = 1, nsurftypes 1572 1573 CALL obs_surf_decompress( surfdataqc(jtype), & 1574 & surfdata(jtype), .TRUE., numout ) 1575 1576 CALL obs_wri_surf( surfdata(jtype) ) 1216 1577 1217 1578 END DO 1218 1579 1219 jslaset = 01220 1221 ! Write the AVISO SLA data1222 1223 IF ( ln_sladt ) THEN1224 1225 jslaset = 11226 CALL obs_wri_sla( 'aviso_act', sladata(jslaset) )1227 jslaset = 21228 CALL obs_wri_sla( 'aviso_pas', sladata(jslaset) )1229 1230 ENDIF1231 1232 IF ( ln_slafb ) THEN1233 1234 jfbini = jslaset + 11235 1236 DO jslaset = jfbini, nslasets1237 1238 jset = jslaset - jfbini + 11239 WRITE(cdtmp,'(A,I2.2)')'slafb_',jset1240 CALL obs_wri_sla( cdtmp, sladata(jslaset) )1241 1242 END DO1243 1244 ENDIF1245 1246 ENDIF1247 1248 ! - Sea surface temperature1249 IF ( ln_sst ) THEN1250 1251 ! Copy data from sstdatqc to sstdata structures1252 DO jsstset = 1, nsstsets1253 1254 CALL obs_surf_decompress( sstdatqc(jsstset), &1255 & sstdata(jsstset), .TRUE., numout )1256 1257 END DO1258 1259 jsstset = 01260 1261 ! Write the AVISO SST data1262 1263 IF ( ln_reysst ) THEN1264 1265 jsstset = jsstset + 11266 CALL obs_wri_sst( 'reynolds', sstdata(jsstset) )1267 1268 ENDIF1269 1270 IF ( ln_ghrsst ) THEN1271 1272 jsstset = jsstset + 11273 CALL obs_wri_sst( 'ghr', sstdata(jsstset) )1274 1275 ENDIF1276 1277 IF ( ln_sstfb ) THEN1278 1279 jfbini = jsstset + 11280 1281 DO jsstset = jfbini, nsstsets1282 1283 jset = jsstset - jfbini + 11284 WRITE(cdtmp,'(A,I2.2)')'sstfb_',jset1285 CALL obs_wri_sst( cdtmp, sstdata(jsstset) )1286 1287 END DO1288 1289 ENDIF1290 1291 ENDIF1292 1293 ! - Sea surface salinity1294 IF ( ln_sss ) THEN1295 IF(lwp) WRITE(numout,*) ' SSS currently not available'1296 ENDIF1297 1298 ! - Sea Ice Concentration1299 IF ( ln_seaice ) THEN1300 1301 ! Copy data from seaicedatqc to seaicedata structures1302 DO jseaiceset = 1, nseaicesets1303 1304 CALL obs_surf_decompress( seaicedatqc(jseaiceset), &1305 & seaicedata(jseaiceset), .TRUE., numout )1306 1307 END DO1308 1309 ! Write the Sea Ice data1310 DO jseaiceset = 1, nseaicesets1311 1312 WRITE(cdtmp,'(A,I2.2)')'seaicefb_',jseaiceset1313 CALL obs_wri_seaice( cdtmp, seaicedata(jseaiceset) )1314 1315 END DO1316 1317 ENDIF1318 1319 ! Velocity data1320 IF( ln_vel3d ) THEN1321 1322 ! Copy data from veldatqc to velodata structures1323 DO jveloset = 1, nvelosets1324 1325 CALL obs_prof_decompress( veldatqc(jveloset), &1326 & velodata(jveloset), .TRUE., numout )1327 1328 END DO1329 1330 ! Write the profiles.1331 1332 jveloset = 01333 1334 ! Daily averaged data1335 1336 IF ( ln_velavcur ) THEN1337 1338 jveloset = jveloset + 11339 1340 CALL obs_wri_vel( 'velavcurr', velodata(jveloset), n2dint )1341 1342 ENDIF1343 1344 ! High frequency data1345 1346 IF ( ln_velhrcur ) THEN1347 1348 jveloset = jveloset + 11349 1350 CALL obs_wri_vel( 'velhrcurr', velodata(jveloset), n2dint )1351 1352 ENDIF1353 1354 ! Daily averaged data1355 1356 IF ( ln_velavadcp ) THEN1357 1358 jveloset = jveloset + 11359 1360 CALL obs_wri_vel( 'velavadcp', velodata(jveloset), n2dint )1361 1362 ENDIF1363 1364 ! High frequency data1365 1366 IF ( ln_velhradcp ) THEN1367 1368 jveloset = jveloset + 11369 1370 CALL obs_wri_vel( 'velhradcp', velodata(jveloset), n2dint )1371 1372 ENDIF1373 1374 ! Feedback velocity data1375 1376 IF ( ln_velfb ) THEN1377 1378 jfbini = jveloset + 11379 1380 DO jveloset = jfbini, nvelosets1381 1382 jset = jveloset - jfbini + 11383 WRITE(cdtmp,'(A,I2.2)')'velfb_',jset1384 CALL obs_wri_vel( cdtmp, velodata(jveloset), n2dint )1385 1386 END DO1387 1388 ENDIF1389 1390 1580 ENDIF 1391 1581 … … 1405 1595 !! 1406 1596 !!---------------------------------------------------------------------- 1407 ! !obs_grid deallocation1597 ! obs_grid deallocation 1408 1598 CALL obs_grid_deallocate 1409 1599 1410 !! diaobs deallocation 1411 IF ( nprofsets > 0 ) THEN 1412 DEALLOCATE(ld_enact, & 1413 & profdata, & 1414 & prodatqc) 1415 END IF 1416 IF ( ln_sla ) THEN 1417 DEALLOCATE(sladata, & 1418 & sladatqc) 1419 END IF 1420 IF ( ln_seaice ) THEN 1421 DEALLOCATE(sladata, & 1422 & sladatqc) 1423 END IF 1424 IF ( ln_sst ) THEN 1425 DEALLOCATE(sstdata, & 1426 & sstdatqc) 1427 END IF 1428 IF ( ln_vel3d ) THEN 1429 DEALLOCATE(ld_velav, & 1430 & velodata, & 1431 & veldatqc) 1432 END IF 1600 ! diaobs deallocation 1601 IF ( nproftypes > 0 ) & 1602 & DEALLOCATE( cobstypesprof, profdata, profdataqc, nvarsprof, nextrprof ) 1603 1604 IF ( nsurftypes > 0 ) & 1605 & DEALLOCATE( cobstypessurf, surfdata, surfdataqc, nvarssurf, nextrsurf, & 1606 & n2dintsurf, ravglamscl, ravgphiscl, lfpindegs, llnightav ) 1607 1433 1608 END SUBROUTINE dia_obs_dealloc 1434 1609 … … 1436 1611 !!---------------------------------------------------------------------- 1437 1612 !! *** ROUTINE ini_date *** 1438 !! 1439 !! ** Purpose : Get initial dat ain double precision YYYYMMDD.HHMMSS format1440 !! 1441 !! ** Method : Get initial dat ain double precision YYYYMMDD.HHMMSS format1442 !! 1443 !! ** Action : Get initial dat ain double precision YYYYMMDD.HHMMSS format1613 !! 1614 !! ** Purpose : Get initial date in double precision YYYYMMDD.HHMMSS format 1615 !! 1616 !! ** Method : Get initial date in double precision YYYYMMDD.HHMMSS format 1617 !! 1618 !! ** Action : Get initial date in double precision YYYYMMDD.HHMMSS format 1444 1619 !! 1445 1620 !! History : … … 1452 1627 USE phycst, ONLY : & ! Physical constants 1453 1628 & rday 1454 ! USE daymod, ONLY : & ! Time variables1455 ! & nmonth_len1456 1629 USE dom_oce, ONLY : & ! Ocean space and time domain variables 1457 1630 & rdt … … 1460 1633 1461 1634 !! * Arguments 1462 REAL( KIND=dp), INTENT(OUT) :: ddobsini! Initial date in YYYYMMDD.HHMMSS1635 REAL(dp), INTENT(OUT) :: ddobsini ! Initial date in YYYYMMDD.HHMMSS 1463 1636 1464 1637 !! * Local declarations … … 1468 1641 INTEGER :: ihou 1469 1642 INTEGER :: imin 1470 INTEGER :: imday 1471 REAL(KIND=wp) :: zdayfrc ! Fraction of day1472 1473 INTEGER, DIMENSION(12) :: imonth_len !: length in days of the months of the current year1474 1475 ! !----------------------------------------------------------------------1476 ! !Initial date initialization (year, month, day, hour, minute)1477 ! !(This assumes that the initial date is for 00z))1478 ! !----------------------------------------------------------------------1643 INTEGER :: imday ! Number of days in month. 1644 INTEGER, DIMENSION(12) :: & 1645 & imonth_len ! Length in days of the months of the current year 1646 REAL(wp) :: zdayfrc ! Fraction of day 1647 1648 !---------------------------------------------------------------------- 1649 ! Initial date initialization (year, month, day, hour, minute) 1650 ! (This assumes that the initial date is for 00z)) 1651 !---------------------------------------------------------------------- 1479 1652 iyea = ndate0 / 10000 1480 1653 imon = ( ndate0 - iyea * 10000 ) / 100 … … 1483 1656 imin = 0 1484 1657 1485 ! !----------------------------------------------------------------------1486 ! !Compute number of days + number of hours + min since initial time1487 ! !----------------------------------------------------------------------1658 !---------------------------------------------------------------------- 1659 ! Compute number of days + number of hours + min since initial time 1660 !---------------------------------------------------------------------- 1488 1661 iday = iday + ( nit000 -1 ) * rdt / rday 1489 1662 zdayfrc = ( nit000 -1 ) * rdt / rday … … 1492 1665 imin = int( (zdayfrc * 24 - ihou) * 60 ) 1493 1666 1494 ! !-----------------------------------------------------------------------1495 ! !Convert number of days (iday) into a real date1496 ! !----------------------------------------------------------------------1667 !----------------------------------------------------------------------- 1668 ! Convert number of days (iday) into a real date 1669 !---------------------------------------------------------------------- 1497 1670 1498 1671 CALL calc_month_len( iyea, imonth_len ) 1499 1672 1500 1673 DO WHILE ( iday > imonth_len(imon) ) 1501 1674 iday = iday - imonth_len(imon) … … 1508 1681 END DO 1509 1682 1510 ! !----------------------------------------------------------------------1511 ! !Convert it into YYYYMMDD.HHMMSS format.1512 ! !----------------------------------------------------------------------1683 !---------------------------------------------------------------------- 1684 ! Convert it into YYYYMMDD.HHMMSS format. 1685 !---------------------------------------------------------------------- 1513 1686 ddobsini = iyea * 10000_dp + imon * 100_dp + & 1514 1687 & iday + ihou * 0.01_dp + imin * 0.0001_dp … … 1520 1693 !!---------------------------------------------------------------------- 1521 1694 !! *** ROUTINE fin_date *** 1522 !! 1523 !! ** Purpose : Get final dat ain double precision YYYYMMDD.HHMMSS format1524 !! 1525 !! ** Method : Get final dat ain double precision YYYYMMDD.HHMMSS format1526 !! 1527 !! ** Action : Get final dat ain double precision YYYYMMDD.HHMMSS format1695 !! 1696 !! ** Purpose : Get final date in double precision YYYYMMDD.HHMMSS format 1697 !! 1698 !! ** Method : Get final date in double precision YYYYMMDD.HHMMSS format 1699 !! 1700 !! ** Action : Get final date in double precision YYYYMMDD.HHMMSS format 1528 1701 !! 1529 1702 !! History : … … 1535 1708 USE phycst, ONLY : & ! Physical constants 1536 1709 & rday 1537 ! USE daymod, ONLY : & ! Time variables1538 ! & nmonth_len1539 1710 USE dom_oce, ONLY : & ! Ocean space and time domain variables 1540 1711 & rdt … … 1543 1714 1544 1715 !! * Arguments 1545 REAL( KIND=dp), INTENT(OUT) :: ddobsfin! Final date in YYYYMMDD.HHMMSS1716 REAL(dp), INTENT(OUT) :: ddobsfin ! Final date in YYYYMMDD.HHMMSS 1546 1717 1547 1718 !! * Local declarations … … 1551 1722 INTEGER :: ihou 1552 1723 INTEGER :: imin 1553 INTEGER :: imday 1554 REAL(KIND=wp) :: zdayfrc ! Fraction of day1555 1556 INTEGER, DIMENSION(12) :: imonth_len !: length in days of the months of the current year1557 1724 INTEGER :: imday ! Number of days in month. 1725 INTEGER, DIMENSION(12) :: & 1726 & imonth_len ! Length in days of the months of the current year 1727 REAL(wp) :: zdayfrc ! Fraction of day 1728 1558 1729 !----------------------------------------------------------------------- 1559 1730 ! Initial date initialization (year, month, day, hour, minute) … … 1565 1736 ihou = 0 1566 1737 imin = 0 1567 1738 1568 1739 !----------------------------------------------------------------------- 1569 1740 ! Compute number of days + number of hours + min since initial time … … 1580 1751 1581 1752 CALL calc_month_len( iyea, imonth_len ) 1582 1753 1583 1754 DO WHILE ( iday > imonth_len(imon) ) 1584 1755 iday = iday - imonth_len(imon) … … 1598 1769 1599 1770 END SUBROUTINE fin_date 1600 1771 1772 SUBROUTINE obs_settypefiles( ntypes, jpmaxnfiles, ifiles, cobstypes, cfiles ) 1773 1774 INTEGER, INTENT(IN) :: ntypes ! Total number of obs types 1775 INTEGER, INTENT(IN) :: jpmaxnfiles ! Maximum number of files allowed for each type 1776 INTEGER, DIMENSION(ntypes), INTENT(OUT) :: & 1777 & ifiles ! Out number of files for each type 1778 CHARACTER(len=8), DIMENSION(ntypes), INTENT(IN) :: & 1779 & cobstypes ! List of obs types 1780 CHARACTER(len=128), DIMENSION(ntypes, jpmaxnfiles), INTENT(IN) :: & 1781 & cfiles ! List of files for all types 1782 1783 !Local variables 1784 INTEGER :: jfile 1785 INTEGER :: jtype 1786 1787 DO jtype = 1, ntypes 1788 1789 ifiles(jtype) = 0 1790 DO jfile = 1, jpmaxnfiles 1791 IF ( trim(cfiles(jtype,jfile)) /= '' ) & 1792 ifiles(jtype) = ifiles(jtype) + 1 1793 END DO 1794 1795 IF ( ifiles(jtype) == 0 ) THEN 1796 CALL ctl_stop( 'Logical for observation type '//TRIM(cobstypes(jtype))// & 1797 & ' set to true but no files available to read' ) 1798 ENDIF 1799 1800 IF(lwp) THEN 1801 WRITE(numout,*) ' '//cobstypes(jtype)//' input observation file names:' 1802 DO jfile = 1, ifiles(jtype) 1803 WRITE(numout,*) ' '//TRIM(cfiles(jtype,jfile)) 1804 END DO 1805 ENDIF 1806 1807 END DO 1808 1809 END SUBROUTINE obs_settypefiles 1810 1811 SUBROUTINE obs_setinterpopts( ntypes, jtype, ctypein, & 1812 & n2dint_default, n2dint_type, & 1813 & ravglamscl_type, ravgphiscl_type, & 1814 & lfp_indegs_type, lavnight_type, & 1815 & n2dint, ravglamscl, ravgphiscl, & 1816 & lfpindegs, lavnight ) 1817 1818 INTEGER, INTENT(IN) :: ntypes ! Total number of obs types 1819 INTEGER, INTENT(IN) :: jtype ! Index of the current type of obs 1820 INTEGER, INTENT(IN) :: n2dint_default ! Default option for interpolation type 1821 INTEGER, INTENT(IN) :: n2dint_type ! Option for interpolation type 1822 REAL(wp), INTENT(IN) :: & 1823 & ravglamscl_type, & !E/W diameter of obs footprint for this type 1824 & ravgphiscl_type !N/S diameter of obs footprint for this type 1825 LOGICAL, INTENT(IN) :: lfp_indegs_type !T=> footprint in degrees, F=> in metres 1826 LOGICAL, INTENT(IN) :: lavnight_type !T=> obs represent night time average 1827 CHARACTER(len=8), INTENT(IN) :: ctypein 1828 1829 INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: & 1830 & n2dint 1831 REAL(wp), DIMENSION(ntypes), INTENT(INOUT) :: & 1832 & ravglamscl, ravgphiscl 1833 LOGICAL, DIMENSION(ntypes), INTENT(INOUT) :: & 1834 & lfpindegs, lavnight 1835 1836 lavnight(jtype) = lavnight_type 1837 1838 IF ( (n2dint_type >= 0) .AND. (n2dint_type <= 6) ) THEN 1839 n2dint(jtype) = n2dint_type 1840 ELSE IF ( n2dint_type == -1 ) THEN 1841 n2dint(jtype) = n2dint_default 1842 ELSE 1843 CALL ctl_stop(' Choice of '//TRIM(ctypein)//' horizontal (2D) interpolation method', & 1844 & ' is not available') 1845 ENDIF 1846 1847 ! For averaging observation footprints set options for size of footprint 1848 IF ( (n2dint(jtype) > 4) .AND. (n2dint(jtype) <= 6) ) THEN 1849 IF ( ravglamscl_type > 0._wp ) THEN 1850 ravglamscl(jtype) = ravglamscl_type 1851 ELSE 1852 CALL ctl_stop( 'Incorrect value set for averaging footprint '// & 1853 'scale (ravglamscl) for observation type '//TRIM(ctypein) ) 1854 ENDIF 1855 1856 IF ( ravgphiscl_type > 0._wp ) THEN 1857 ravgphiscl(jtype) = ravgphiscl_type 1858 ELSE 1859 CALL ctl_stop( 'Incorrect value set for averaging footprint '// & 1860 'scale (ravgphiscl) for observation type '//TRIM(ctypein) ) 1861 ENDIF 1862 1863 lfpindegs(jtype) = lfp_indegs_type 1864 1865 ENDIF 1866 1867 ! Write out info 1868 IF(lwp) THEN 1869 IF ( n2dint(jtype) <= 4 ) THEN 1870 WRITE(numout,*) ' '//TRIM(ctypein)// & 1871 & ' model counterparts will be interpolated horizontally' 1872 ELSE IF ( n2dint(jtype) <= 6 ) THEN 1873 WRITE(numout,*) ' '//TRIM(ctypein)// & 1874 & ' model counterparts will be averaged horizontally' 1875 WRITE(numout,*) ' '//' with E/W scale: ',ravglamscl(jtype) 1876 WRITE(numout,*) ' '//' with N/S scale: ',ravgphiscl(jtype) 1877 IF ( lfpindegs(jtype) ) THEN 1878 WRITE(numout,*) ' '//' (in degrees)' 1879 ELSE 1880 WRITE(numout,*) ' '//' (in metres)' 1881 ENDIF 1882 ENDIF 1883 ENDIF 1884 1885 END SUBROUTINE obs_setinterpopts 1886 1601 1887 END MODULE diaobs -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/OBS/obs_grd_bruteforce.h90
r2358 r10247 325 325 CALL obs_mpp_max_integer( kobsj, kobs ) 326 326 ELSE 327 CALL obs_mpp_find_obs_proc( kproc, kobsi, kobsj,kobs )327 CALL obs_mpp_find_obs_proc( kproc,kobs ) 328 328 ENDIF 329 329 -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/OBS/obs_grid.F90
r10246 r10247 52 52 53 53 !! Default values 54 REAL, PUBLIC :: grid_search_res = 0.5! Resolution of grid54 REAL, PUBLIC :: rn_gridsearchres = 0.5 ! Resolution of grid 55 55 INTEGER, PRIVATE :: gsearch_nlons_def ! Num of longitudes 56 56 INTEGER, PRIVATE :: gsearch_nlats_def ! Num of latitudes … … 83 83 LOGICAL, PUBLIC :: ln_grid_global ! Use global distribution of observations 84 84 CHARACTER(LEN=44), PUBLIC :: & 85 & grid_search_file ! file name head for grid search lookup85 & cn_gridsearchfile ! file name head for grid search lookup 86 86 87 87 !!---------------------------------------------------------------------- … … 613 613 CALL obs_mpp_max_integer( kobsj, kobs ) 614 614 ELSE 615 CALL obs_mpp_find_obs_proc( kproc, kobs i, kobsj, kobs)615 CALL obs_mpp_find_obs_proc( kproc, kobs ) 616 616 ENDIF 617 617 … … 690 690 691 691 IF(lwp) WRITE(numout,*) 692 IF(lwp) WRITE(numout,*)'Grid search resolution : ', grid_search_res693 694 gsearch_nlons_def = NINT( 360.0_wp / grid_search_res )695 gsearch_nlats_def = NINT( 180.0_wp / grid_search_res )696 gsearch_lonmin_def = -180.0_wp + 0.5_wp * grid_search_res697 gsearch_latmin_def = -90.0_wp + 0.5_wp * grid_search_res698 gsearch_dlon_def = grid_search_res699 gsearch_dlat_def = grid_search_res692 IF(lwp) WRITE(numout,*)'Grid search resolution : ', rn_gridsearchres 693 694 gsearch_nlons_def = NINT( 360.0_wp / rn_gridsearchres ) 695 gsearch_nlats_def = NINT( 180.0_wp / rn_gridsearchres ) 696 gsearch_lonmin_def = -180.0_wp + 0.5_wp * rn_gridsearchres 697 gsearch_latmin_def = -90.0_wp + 0.5_wp * rn_gridsearchres 698 gsearch_dlon_def = rn_gridsearchres 699 gsearch_dlat_def = rn_gridsearchres 700 700 701 701 IF (lwp) THEN … … 710 710 IF ( ln_grid_global ) THEN 711 711 WRITE(cfname, FMT="(A,'_',A)") & 712 & TRIM( grid_search_file), 'global.nc'712 & TRIM(cn_gridsearchfile), 'global.nc' 713 713 ELSE 714 714 WRITE(cfname, FMT="(A,'_',I4.4,'of',I4.4,'by',I4.4,'.nc')") & 715 & TRIM( grid_search_file), nproc, jpni, jpnj715 & TRIM(cn_gridsearchfile), nproc, jpni, jpnj 716 716 ENDIF 717 717 -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/OBS/obs_inter_sup.F90
r10246 r10247 35 35 CONTAINS 36 36 37 SUBROUTINE obs_int_comm_3d( kptsi, kptsj, kobs, kp k, kgrdi, kgrdj, &37 SUBROUTINE obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & 38 38 & pval, pgval, kproc ) 39 39 !!---------------------------------------------------------------------- … … 57 57 INTEGER, INTENT(IN) :: kptsj ! Number of j horizontal points per stencil 58 58 INTEGER, INTENT(IN) :: kobs ! Local number of observations 59 INTEGER, INTENT(IN) :: kpi ! Number of points in i direction 60 INTEGER, INTENT(IN) :: kpj ! Number of points in j direction 59 61 INTEGER, INTENT(IN) :: kpk ! Number of levels 60 62 INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & … … 63 65 INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 64 66 & kproc ! Precomputed processor for each i,j,iobs points 65 REAL(KIND=wp), DIMENSION( jpi,jpj,kpk), INTENT(IN) ::&67 REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::& 66 68 & pval ! Local 3D array to extract data from 67 69 REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& … … 73 75 IF (PRESENT(kproc)) THEN 74 76 75 CALL obs_int_comm_3d_global( kptsi, kptsj, kobs, kp k, kgrdi, &77 CALL obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, & 76 78 & kgrdj, pval, pgval, kproc=kproc ) 77 79 78 80 ELSE 79 81 80 CALL obs_int_comm_3d_global( kptsi, kptsj, kobs, kp k, kgrdi, &82 CALL obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, & 81 83 & kgrdj, pval, pgval ) 82 84 … … 85 87 ELSE 86 88 87 CALL obs_int_comm_3d_local( kptsi, kptsj, kobs, kp k, kgrdi, kgrdj, &89 CALL obs_int_comm_3d_local( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & 88 90 & pval, pgval ) 89 91 … … 92 94 END SUBROUTINE obs_int_comm_3d 93 95 94 SUBROUTINE obs_int_comm_2d( kptsi, kptsj, kobs, k grdi, kgrdj, pval, pgval, &96 SUBROUTINE obs_int_comm_2d( kptsi, kptsj, kobs, kpi, kpj, kgrdi, kgrdj, pval, pgval, & 95 97 & kproc ) 96 98 !!---------------------------------------------------------------------- … … 111 113 INTEGER, INTENT(IN) :: kptsj ! Number of j horizontal points per stencil 112 114 INTEGER, INTENT(IN) :: kobs ! Local number of observations 115 INTEGER, INTENT(IN) :: kpi ! Number of model grid points in i direction 116 INTEGER, INTENT(IN) :: kpj ! Number of model grid points in j direction 113 117 INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 114 118 & kgrdi, & ! i,j indicies for each stencil … … 116 120 INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 117 121 & kproc ! Precomputed processor for each i,j,iobs points 118 REAL(KIND=wp), DIMENSION( jpi,jpj), INTENT(IN) ::&122 REAL(KIND=wp), DIMENSION(kpi,kpj), INTENT(IN) ::& 119 123 & pval ! Local 3D array to extra data from 120 124 REAL(KIND=wp), DIMENSION(kptsi,kptsj,kobs), INTENT(OUT) ::& … … 136 140 IF (PRESENT(kproc)) THEN 137 141 138 CALL obs_int_comm_3d( kptsi, kptsj, kobs, 1, kgrdi, kgrdj, zval, &142 CALL obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, 1, kgrdi, kgrdj, zval, & 139 143 & zgval, kproc=kproc ) 140 144 ELSE 141 145 142 CALL obs_int_comm_3d( kptsi, kptsj, kobs, 1, kgrdi, kgrdj, zval, &146 CALL obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, 1, kgrdi, kgrdj, zval, & 143 147 & zgval ) 144 148 … … 154 158 END SUBROUTINE obs_int_comm_2d 155 159 156 SUBROUTINE obs_int_comm_3d_global( kptsi, kptsj, kobs, kp k, kgrdi, kgrdj, &160 SUBROUTINE obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & 157 161 & pval, pgval, kproc ) 158 162 !!---------------------------------------------------------------------- … … 174 178 INTEGER, INTENT(IN) :: kptsj ! Number of j horizontal points per stencil 175 179 INTEGER, INTENT(IN) :: kobs ! Local number of observations 180 INTEGER, INTENT(IN) :: kpi ! Number of model points in i direction 181 INTEGER, INTENT(IN) :: kpj ! Number of model points in j direction 176 182 INTEGER, INTENT(IN) :: kpk ! Number of levels 177 183 INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & … … 180 186 INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 181 187 & kproc ! Precomputed processor for each i,j,iobs points 182 REAL(KIND=wp), DIMENSION( jpi,jpj,kpk), INTENT(IN) ::&188 REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::& 183 189 & pval ! Local 3D array to extract data from 184 190 REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& … … 207 213 208 214 ! Check valid points 209 215 210 216 IF ( ( MAXVAL(kgrdi) > jpiglo ) .OR. ( MINVAL(kgrdi) < 1 ) .OR. & 211 217 & ( MAXVAL(kgrdj) > jpjglo ) .OR. ( MINVAL(kgrdj) < 1 ) ) THEN 212 218 213 219 CALL ctl_stop( 'Error in obs_int_comm_3d_global', & 214 220 & 'Point outside global domain' ) 215 221 216 222 ENDIF 217 223 … … 323 329 END SUBROUTINE obs_int_comm_3d_global 324 330 325 SUBROUTINE obs_int_comm_3d_local( kptsi, kptsj, kobs, kp k, kgrdi, kgrdj, &331 SUBROUTINE obs_int_comm_3d_local( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & 326 332 & pval, pgval ) 327 333 !!---------------------------------------------------------------------- … … 343 349 INTEGER, INTENT(IN) :: kptsj ! Number of j horizontal points per stencil 344 350 INTEGER, INTENT(IN) :: kobs ! Local number of observations 351 INTEGER, INTENT(IN) :: kpi ! Number of model points in i direction 352 INTEGER, INTENT(IN) :: kpj ! Number of model points in j direction 345 353 INTEGER, INTENT(IN) :: kpk ! Number of levels 346 354 INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 347 355 & kgrdi, & ! i,j indicies for each stencil 348 356 & kgrdj 349 REAL(KIND=wp), DIMENSION( jpi,jpj,kpk), INTENT(IN) ::&357 REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::& 350 358 & pval ! Local 3D array to extract data from 351 359 REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/OBS/obs_mpp.F90
r10246 r10247 7 7 !! - ! 2006-05 (K. Mogensen) Reformatted 8 8 !! - ! 2008-01 (K. Mogensen) add mpp_global_max 9 !! 3.6 ! 2015-01 (J. Waters) obs_mpp_find_obs_proc 10 !! rewritten to avoid global arrays 9 11 !!---------------------------------------------------------------------- 10 12 # define mpivar mpi_double_precision … … 12 14 !! obs_mpp_bcast_integer : Broadcast an integer array from a processor to all processors 13 15 !! obs_mpp_max_integer : Find maximum on all processors of each value in an integer on all processors 14 !! obs_mpp_find_obs_proc : Find processors which should hold the observations 16 !! obs_mpp_find_obs_proc : Find processors which should hold the observations, avoiding global arrays 15 17 !! obs_mpp_sum_integers : Sum an integer array from all processors 16 18 !! obs_mpp_sum_integer : Sum an integer from all processors … … 96 98 ! 97 99 INTEGER :: ierr 98 INTEGER, DIMENSION(kno) :: ivals 99 ! 100 INCLUDE 'mpif.h' 101 !!---------------------------------------------------------------------- 100 INTEGER, DIMENSION(:), ALLOCATABLE :: ivals 101 ! 102 INCLUDE 'mpif.h' 103 !!---------------------------------------------------------------------- 104 105 ALLOCATE( ivals(kno) ) 102 106 103 107 ! Call the MPI library to find the maximum across processors … … 105 109 & mpi_max, mpi_comm_opa, ierr ) 106 110 kvals(:) = ivals(:) 111 112 DEALLOCATE( ivals ) 107 113 #else 108 114 ! no MPI: empty routine … … 111 117 112 118 113 SUBROUTINE obs_mpp_find_obs_proc( kobsp, kobsi, kobsj,kno )114 !!---------------------------------------------------------------------- 115 !! *** ROUTINE obs_mpp_find_obs_proc ***116 !! 117 !! ** Purpose : From the array kobsp containing the results of the grid119 SUBROUTINE obs_mpp_find_obs_proc( kobsp,kno ) 120 !!---------------------------------------------------------------------- 121 !! *** ROUTINE obs_mpp_find_obs_proc *** 122 !! 123 !! ** Purpose : From the array kobsp containing the results of the 118 124 !! grid search on each processor the processor return a 119 125 !! decision of which processors should hold the observation. 120 126 !! 121 !! ** Method : A temporary 2D array holding all the decisions is122 !! constructed using mpi_allgather on each processor.123 !! If more than one processor has found the observation124 !! with the observation in the inner domain gets it125 !! 126 !! ** Action : This does only work for MPI. 127 !! ** Method : Synchronize the processor number for each obs using 128 !! obs_mpp_max_integer. If an observation exists on two 129 !! processors it will be allocated to the lower numbered 130 !! processor. 131 !! 132 !! ** Action : This does only work for MPI. 127 133 !! It does not work for SHMEM. 128 134 !! … … 130 136 !!---------------------------------------------------------------------- 131 137 INTEGER , INTENT(in ) :: kno 132 INTEGER, DIMENSION(kno), INTENT(in ) :: kobsi, kobsj133 138 INTEGER, DIMENSION(kno), INTENT(inout) :: kobsp 134 139 ! 135 140 #if defined key_mpp_mpi 136 141 ! 137 INTEGER :: ji 138 INTEGER :: jj 139 INTEGER :: size 140 INTEGER :: ierr 141 INTEGER :: iobsip 142 INTEGER :: iobsjp 143 INTEGER :: num_sus_obs 144 INTEGER, DIMENSION(kno) :: iobsig, iobsjg 145 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iobsp, iobsi, iobsj 146 !! 147 INCLUDE 'mpif.h' 148 !!---------------------------------------------------------------------- 149 150 !----------------------------------------------------------------------- 151 ! Call the MPI library to find the maximum accross processors 152 !----------------------------------------------------------------------- 153 CALL mpi_comm_size( mpi_comm_opa, size, ierr ) 154 !----------------------------------------------------------------------- 155 ! Convert local grids points to global grid points 156 !----------------------------------------------------------------------- 142 ! 143 INTEGER :: ji, isum 144 INTEGER, DIMENSION(:), ALLOCATABLE :: iobsp 145 !! 146 !! 147 148 ALLOCATE( iobsp(kno) ) 149 150 iobsp(:)=kobsp(:) 151 152 WHERE( iobsp(:) == -1 ) 153 iobsp(:) = 9999999 154 END WHERE 155 156 iobsp(:)=-1*iobsp(:) 157 158 CALL obs_mpp_max_integer( iobsp, kno ) 159 160 kobsp(:)=-1*iobsp(:) 161 162 isum=0 157 163 DO ji = 1, kno 158 IF ( ( kobsi(ji) >= 1 ) .AND. ( kobsi(ji) <= jpi ) .AND. & 159 & ( kobsj(ji) >= 1 ) .AND. ( kobsj(ji) <= jpj ) ) THEN 160 iobsig(ji) = mig( kobsi(ji) ) 161 iobsjg(ji) = mjg( kobsj(ji) ) 162 ELSE 163 iobsig(ji) = -1 164 iobsjg(ji) = -1 164 IF ( kobsp(ji) == 9999999 ) THEN 165 isum=isum+1 166 kobsp(ji)=-1 165 167 ENDIF 166 END DO 167 !----------------------------------------------------------------------- 168 ! Get the decisions from all processors 169 !----------------------------------------------------------------------- 170 ALLOCATE( iobsp(kno,size) ) 171 ALLOCATE( iobsi(kno,size) ) 172 ALLOCATE( iobsj(kno,size) ) 173 CALL mpi_allgather( kobsp, kno, mpi_integer, & 174 & iobsp, kno, mpi_integer, & 175 & mpi_comm_opa, ierr ) 176 CALL mpi_allgather( iobsig, kno, mpi_integer, & 177 & iobsi, kno, mpi_integer, & 178 & mpi_comm_opa, ierr ) 179 CALL mpi_allgather( iobsjg, kno, mpi_integer, & 180 & iobsj, kno, mpi_integer, & 181 & mpi_comm_opa, ierr ) 182 183 !----------------------------------------------------------------------- 184 ! Find the processor with observations from the lowest processor 185 ! number among processors holding the observation. 186 !----------------------------------------------------------------------- 187 kobsp(:) = -1 188 num_sus_obs = 0 189 DO ji = 1, kno 190 DO jj = 1, size 191 IF ( ( kobsp(ji) == -1 ) .AND. ( iobsp(ji,jj) /= -1 ) ) THEN 192 kobsp(ji) = iobsp(ji,jj) 193 iobsip = iobsi(ji,jj) 194 iobsjp = iobsj(ji,jj) 195 ENDIF 196 IF ( ( kobsp(ji) /= -1 ) .AND. ( iobsp(ji,jj) /= -1 ) ) THEN 197 IF ( ( iobsip /= iobsi(ji,jj) ) .OR. & 198 & ( iobsjp /= iobsj(ji,jj) ) ) THEN 199 IF ( ( kobsp(ji) < 1000000 ) .AND. & 200 & ( iobsp(ji,jj) < 1000000 ) ) THEN 201 num_sus_obs=num_sus_obs+1 202 ENDIF 203 ENDIF 204 IF ( mppmap(iobsip,iobsjp) /= ( kobsp(ji)+1 ) ) THEN 205 IF ( ( iobsi(ji,jj) /= -1 ) .AND. & 206 & ( iobsj(ji,jj) /= -1 ) ) THEN 207 IF ((mppmap(iobsi(ji,jj),iobsj(ji,jj)) == (iobsp(ji,jj)+1))& 208 & .OR. ( iobsp(ji,jj) < kobsp(ji) ) ) THEN 209 kobsp(ji) = iobsp(ji,jj) 210 iobsip = iobsi(ji,jj) 211 iobsjp = iobsj(ji,jj) 212 ENDIF 213 ENDIF 214 ENDIF 215 ENDIF 216 END DO 217 END DO 218 IF (lwp) WRITE(numout,*) 'Number of suspicious observations: ',num_sus_obs 219 220 DEALLOCATE( iobsj ) 221 DEALLOCATE( iobsi ) 168 ENDDO 169 170 171 IF ( isum > 0 ) THEN 172 IF (lwp) WRITE(numout,*) isum, ' observations failed the grid search.' 173 IF (lwp) WRITE(numout,*)'If ln_grid_search_lookup=.TRUE., try reducing grid_search_res' 174 ENDIF 175 222 176 DEALLOCATE( iobsp ) 177 223 178 #else 224 179 ! no MPI: empty routine 225 #endif 226 !180 #endif 181 227 182 END SUBROUTINE obs_mpp_find_obs_proc 228 183 -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/OBS/obs_oper.F90
r10246 r10247 7 7 8 8 !!---------------------------------------------------------------------- 9 !! obs_pro_opt : Compute the model counterpart of temperature and 10 !! salinity observations from profiles 11 !! obs_sla_opt : Compute the model counterpart of sea level anomaly 12 !! observations 13 !! obs_sst_opt : Compute the model counterpart of sea surface temperature 14 !! observations 15 !! obs_sss_opt : Compute the model counterpart of sea surface salinity 16 !! observations 17 !! obs_seaice_opt : Compute the model counterpart of sea ice concentration 18 !! observations 19 !! 20 !! obs_vel_opt : Compute the model counterpart of zonal and meridional 21 !! components of velocity from observations. 9 !! obs_prof_opt : Compute the model counterpart of profile data 10 !! obs_surf_opt : Compute the model counterpart of surface data 22 11 !!---------------------------------------------------------------------- 23 12 24 !! * Modules used 13 !! * Modules used 25 14 USE par_kind, ONLY : & ! Precision variables 26 15 & wp 27 16 USE in_out_manager ! I/O manager 28 17 USE obs_inter_sup ! Interpolation support 29 USE obs_inter_h2d, ONLY : & ! Horizontal interpolation to the obs ervationpt18 USE obs_inter_h2d, ONLY : & ! Horizontal interpolation to the obs pt 30 19 & obs_int_h2d, & 31 20 & obs_int_h2d_init 32 USE obs_inter_z1d, ONLY : & ! Vertical interpolation to the observation pt 21 USE obs_averg_h2d, ONLY : & ! Horizontal averaging to the obs footprint 22 & obs_avg_h2d, & 23 & obs_avg_h2d_init, & 24 & obs_max_fpsize 25 USE obs_inter_z1d, ONLY : & ! Vertical interpolation to the obs pt 33 26 & obs_int_z1d, & 34 27 & obs_int_z1d_spl 35 USE obs_const, ONLY : &36 & obfillflt ! Fillvalue28 USE obs_const, ONLY : & ! Obs fill value 29 & obfillflt 37 30 USE dom_oce, ONLY : & 38 & glamt, glam u, glamv, &39 & gphit, gphi u, gphiv40 USE lib_mpp, ONLY : & 31 & glamt, glamf, & 32 & gphit, gphif 33 USE lib_mpp, ONLY : & ! Warning and stopping routines 41 34 & ctl_warn, ctl_stop 35 USE sbcdcy, ONLY : & ! For calculation of where it is night-time 36 & sbc_dcy, nday_qsr 37 USE obs_grid, ONLY : & 38 & obs_level_search 42 39 43 40 IMPLICIT NONE … … 46 43 PRIVATE 47 44 48 PUBLIC obs_pro_opt, & ! Compute the model counterpart of profile observations 49 & obs_sla_opt, & ! Compute the model counterpart of SLA observations 50 & obs_sst_opt, & ! Compute the model counterpart of SST observations 51 & obs_sss_opt, & ! Compute the model counterpart of SSS observations 52 & obs_seaice_opt, & 53 & obs_vel_opt ! Compute the model counterpart of velocity profile data 54 55 INTEGER, PARAMETER, PUBLIC :: imaxavtypes = 20 ! Max number of daily avgd obs types 45 PUBLIC obs_prof_opt, & ! Compute the model counterpart of profile obs 46 & obs_surf_opt ! Compute the model counterpart of surface obs 47 48 INTEGER, PARAMETER, PUBLIC :: & 49 & imaxavtypes = 20 ! Max number of daily avgd obs types 56 50 57 51 !!---------------------------------------------------------------------- … … 61 55 !!---------------------------------------------------------------------- 62 56 57 !! * Substitutions 58 # include "domzgr_substitute.h90" 63 59 CONTAINS 64 60 65 SUBROUTINE obs_pro_opt( prodatqc, kt, kpi, kpj, kpk, kit000, kdaystp, & 66 & ptn, psn, pgdept, ptmask, k1dint, k2dint, & 67 & kdailyavtypes ) 61 62 SUBROUTINE obs_prof_opt( prodatqc, kt, kpi, kpj, kpk, & 63 & kit000, kdaystp, kvar, & 64 & pvar, pgdept, pgdepw, & 65 & pmask, & 66 & plam, pphi, & 67 & k1dint, k2dint, kdailyavtypes ) 68 68 69 !!----------------------------------------------------------------------- 69 70 !! … … 78 79 !! 79 80 !! First, a vertical profile of horizontally interpolated model 80 !! now temperatures is computed at the obs (lon, lat) point.81 !! now values is computed at the obs (lon, lat) point. 81 82 !! Several horizontal interpolation schemes are available: 82 83 !! - distance-weighted (great circle) (k2dint = 0) … … 86 87 !! - polynomial (quadrilateral grid) (k2dint = 4) 87 88 !! 88 !! Next, the vertical temperatureprofile is interpolated to the89 !! Next, the vertical profile is interpolated to the 89 90 !! data depth points. Two vertical interpolation schemes are 90 91 !! available: … … 96 97 !! routine. 97 98 !! 98 !! For ENACT moored buoy data (e.g., TAO), the model equivalent is99 !! If the logical is switched on, the model equivalent is 99 100 !! a daily mean model temperature field. So, we first compute 100 101 !! the mean, then interpolate only at the end of the day. 101 102 !! 102 !! Note: thein situ temperature observations must be converted103 !! Note: in situ temperature observations must be converted 103 104 !! to potential temperature (the model variable) prior to 104 105 !! assimilation. 105 !!??????????????????????????????????????????????????????????????106 !! INCLUDE POTENTIAL TEMP -> IN SITU TEMP IN OBS OPERATOR???107 !!??????????????????????????????????????????????????????????????108 106 !! 109 107 !! ** Action : … … 115 113 !! ! 07-01 (K. Mogensen) Merge of temperature and salinity 116 114 !! ! 07-03 (K. Mogensen) General handling of profiles 115 !! ! 15-02 (M. Martin) Combined routine for all profile types 116 !! ! 17-02 (M. Martin) Include generalised vertical coordinate changes 117 117 !!----------------------------------------------------------------------- 118 118 119 119 !! * Modules used 120 120 USE obs_profiles_def ! Definition of storage space for profile obs. … … 123 123 124 124 !! * Arguments 125 TYPE(obs_prof), INTENT(INOUT) :: prodatqc ! Subset of profile data not failing screening 126 INTEGER, INTENT(IN) :: kt ! Time step 127 INTEGER, INTENT(IN) :: kpi ! Model grid parameters 125 TYPE(obs_prof), INTENT(INOUT) :: & 126 & prodatqc ! Subset of profile data passing QC 127 INTEGER, INTENT(IN) :: kt ! Time step 128 INTEGER, INTENT(IN) :: kpi ! Model grid parameters 128 129 INTEGER, INTENT(IN) :: kpj 129 130 INTEGER, INTENT(IN) :: kpk 130 INTEGER, INTENT(IN) :: kit000 ! Number of the first time step 131 ! (kit000-1 = restart time) 132 INTEGER, INTENT(IN) :: k1dint ! Vertical interpolation type (see header) 133 INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation type (see header) 134 INTEGER, INTENT(IN) :: kdaystp ! Number of time steps per day 131 INTEGER, INTENT(IN) :: kit000 ! Number of the first time step 132 ! (kit000-1 = restart time) 133 INTEGER, INTENT(IN) :: k1dint ! Vertical interpolation type (see header) 134 INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation type (see header) 135 INTEGER, INTENT(IN) :: kdaystp ! Number of time steps per day 136 INTEGER, INTENT(IN) :: kvar ! Number of variable in prodatqc 135 137 REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 136 & ptn, & ! Model temperature field 137 & psn, & ! Model salinity field 138 & ptmask ! Land-sea mask 139 REAL(KIND=wp), INTENT(IN), DIMENSION(kpk) :: & 140 & pgdept ! Model array of depth levels 138 & pvar, & ! Model field for variable 139 & pmask ! Land-sea mask for variable 140 REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 141 & plam, & ! Model longitudes for variable 142 & pphi ! Model latitudes for variable 143 REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 144 & pgdept, & ! Model array of depth T levels 145 & pgdepw ! Model array of depth W levels 141 146 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 142 & kdailyavtypes! Types for daily averages 147 & kdailyavtypes ! Types for daily averages 148 143 149 !! * Local declarations 144 150 INTEGER :: ji … … 152 158 INTEGER :: iend 153 159 INTEGER :: iobs 160 INTEGER :: iin, ijn, ikn, ik ! looping indices over interpolation nodes 161 INTEGER :: inum_obs 154 162 INTEGER, DIMENSION(imaxavtypes) :: & 155 163 & idailyavtypes 164 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 165 & igrdi, & 166 & igrdj 167 INTEGER, ALLOCATABLE, DIMENSION(:) :: iv_indic 168 156 169 REAL(KIND=wp) :: zlam 157 170 REAL(KIND=wp) :: zphi 158 171 REAL(KIND=wp) :: zdaystp 159 172 REAL(KIND=wp), DIMENSION(kpk) :: & 160 & zobsmask, &161 173 & zobsk, & 162 174 & zobs2k 163 REAL(KIND=wp), DIMENSION(2,2,kpk) :: & 175 REAL(KIND=wp), DIMENSION(2,2,1) :: & 176 & zweig1, & 164 177 & zweig 165 178 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 166 & zmask, &167 & zint t,&168 & zin ts,&169 & z inmt, &170 & z inms179 & zmask, & 180 & zint, & 181 & zinm, & 182 & zgdept, & 183 & zgdepw 171 184 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 172 & zglam, &185 & zglam, & 173 186 & zgphi 174 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 175 & igrdi, & 176 & igrdj 187 REAL(KIND=wp), DIMENSION(1) :: zmsk 188 REAL(KIND=wp), DIMENSION(:,:,:), ALLOCATABLE :: interp_corner 189 190 LOGICAL :: ld_dailyav 177 191 178 192 !------------------------------------------------------------------------ 179 193 ! Local initialization 180 194 !------------------------------------------------------------------------ 181 ! ...Record and data counters195 ! Record and data counters 182 196 inrc = kt - kit000 + 2 183 197 ipro = prodatqc%npstp(inrc) 184 198 185 199 ! Daily average types 200 ld_dailyav = .FALSE. 186 201 IF ( PRESENT(kdailyavtypes) ) THEN 187 202 idailyavtypes(:) = kdailyavtypes(:) 203 IF ( ANY (idailyavtypes(:) /= -1) ) ld_dailyav = .TRUE. 188 204 ELSE 189 205 idailyavtypes(:) = -1 190 206 ENDIF 191 207 192 ! Initialize daily mean for first timestep 208 ! Daily means are calculated for values over timesteps: 209 ! [1 <= kt <= kdaystp], [kdaystp+1 <= kt <= 2*kdaystp], ... 193 210 idayend = MOD( kt - kit000 + 1, kdaystp ) 194 211 195 ! Added kt == 0 test to catch restart case 196 IF ( idayend == 1 .OR. kt == 0) THEN 197 IF (lwp) WRITE(numout,*) 'Reset prodatqc%vdmean on time-step: ',kt 212 IF ( ld_dailyav ) THEN 213 214 ! Initialize daily mean for first timestep of the day 215 IF ( idayend == 1 .OR. kt == 0 ) THEN 216 DO jk = 1, jpk 217 DO jj = 1, jpj 218 DO ji = 1, jpi 219 prodatqc%vdmean(ji,jj,jk,kvar) = 0.0 220 END DO 221 END DO 222 END DO 223 ENDIF 224 198 225 DO jk = 1, jpk 199 226 DO jj = 1, jpj 200 227 DO ji = 1, jpi 201 prodatqc%vdmean(ji,jj,jk,1) = 0.0 202 prodatqc%vdmean(ji,jj,jk,2) = 0.0 228 ! Increment field for computing daily mean 229 prodatqc%vdmean(ji,jj,jk,kvar) = prodatqc%vdmean(ji,jj,jk,kvar) & 230 & + pvar(ji,jj,jk) 203 231 END DO 204 232 END DO 205 233 END DO 206 ENDIF 207 208 DO jk = 1, jpk 209 DO jj = 1, jpj 210 DO ji = 1, jpi 211 ! Increment the temperature field for computing daily mean 212 prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 213 & + ptn(ji,jj,jk) 214 ! Increment the salinity field for computing daily mean 215 prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 216 & + psn(ji,jj,jk) 217 END DO 218 END DO 219 END DO 220 221 ! Compute the daily mean at the end of day 222 zdaystp = 1.0 / REAL( kdaystp ) 223 IF ( idayend == 0 ) THEN 224 DO jk = 1, jpk 225 DO jj = 1, jpj 226 DO ji = 1, jpi 227 prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 228 & * zdaystp 229 prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 230 & * zdaystp 234 235 ! Compute the daily mean at the end of day 236 zdaystp = 1.0 / REAL( kdaystp ) 237 IF ( idayend == 0 ) THEN 238 IF (lwp) WRITE(numout,*) 'Calculating prodatqc%vdmean on time-step: ',kt 239 CALL FLUSH(numout) 240 DO jk = 1, jpk 241 DO jj = 1, jpj 242 DO ji = 1, jpi 243 prodatqc%vdmean(ji,jj,jk,kvar) = prodatqc%vdmean(ji,jj,jk,kvar) & 244 & * zdaystp 245 END DO 231 246 END DO 232 247 END DO 233 END DO 248 ENDIF 249 234 250 ENDIF 235 251 236 252 ! Get the data for interpolation 237 253 ALLOCATE( & 238 & igrdi(2,2,ipro), & 239 & igrdj(2,2,ipro), & 240 & zglam(2,2,ipro), & 241 & zgphi(2,2,ipro), & 242 & zmask(2,2,kpk,ipro), & 243 & zintt(2,2,kpk,ipro), & 244 & zints(2,2,kpk,ipro) & 254 & igrdi(2,2,ipro), & 255 & igrdj(2,2,ipro), & 256 & zglam(2,2,ipro), & 257 & zgphi(2,2,ipro), & 258 & zmask(2,2,kpk,ipro), & 259 & zint(2,2,kpk,ipro), & 260 & zgdept(2,2,kpk,ipro), & 261 & zgdepw(2,2,kpk,ipro) & 245 262 & ) 246 263 247 264 DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro 248 265 iobs = jobs - prodatqc%nprofup 249 igrdi(1,1,iobs) = prodatqc%mi(jobs, 1)-1250 igrdj(1,1,iobs) = prodatqc%mj(jobs, 1)-1251 igrdi(1,2,iobs) = prodatqc%mi(jobs, 1)-1252 igrdj(1,2,iobs) = prodatqc%mj(jobs, 1)253 igrdi(2,1,iobs) = prodatqc%mi(jobs, 1)254 igrdj(2,1,iobs) = prodatqc%mj(jobs, 1)-1255 igrdi(2,2,iobs) = prodatqc%mi(jobs, 1)256 igrdj(2,2,iobs) = prodatqc%mj(jobs, 1)266 igrdi(1,1,iobs) = prodatqc%mi(jobs,kvar)-1 267 igrdj(1,1,iobs) = prodatqc%mj(jobs,kvar)-1 268 igrdi(1,2,iobs) = prodatqc%mi(jobs,kvar)-1 269 igrdj(1,2,iobs) = prodatqc%mj(jobs,kvar) 270 igrdi(2,1,iobs) = prodatqc%mi(jobs,kvar) 271 igrdj(2,1,iobs) = prodatqc%mj(jobs,kvar)-1 272 igrdi(2,2,iobs) = prodatqc%mi(jobs,kvar) 273 igrdj(2,2,iobs) = prodatqc%mj(jobs,kvar) 257 274 END DO 258 275 259 CALL obs_int_comm_2d( 2, 2, ipro, igrdi, igrdj, glamt, zglam ) 260 CALL obs_int_comm_2d( 2, 2, ipro, igrdi, igrdj, gphit, zgphi ) 261 CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdi, igrdj, ptmask,zmask ) 262 CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdi, igrdj, ptn, zintt ) 263 CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdi, igrdj, psn, zints ) 276 ! Initialise depth arrays 277 zgdept(:,:,:,:) = 0.0 278 zgdepw(:,:,:,:) = 0.0 279 280 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi, igrdj, plam, zglam ) 281 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi, igrdj, pphi, zgphi ) 282 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pmask, zmask ) 283 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pvar, zint ) 284 285 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pgdept, zgdept ) 286 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pgdepw, zgdepw ) 264 287 265 288 ! At the end of the day also get interpolated means 266 IF ( idayend == 0 ) THEN 267 268 ALLOCATE( & 269 & zinmt(2,2,kpk,ipro), & 270 & zinms(2,2,kpk,ipro) & 271 & ) 272 273 CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdi, igrdj, & 274 & prodatqc%vdmean(:,:,:,1), zinmt ) 275 CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdi, igrdj, & 276 & prodatqc%vdmean(:,:,:,2), zinms ) 289 IF ( ld_dailyav .AND. idayend == 0 ) THEN 290 291 ALLOCATE( zinm(2,2,kpk,ipro) ) 292 293 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, & 294 & prodatqc%vdmean(:,:,:,kvar), zinm ) 277 295 278 296 ENDIF 279 297 298 ! Return if no observations to process 299 ! Has to be done after comm commands to ensure processors 300 ! stay in sync 301 IF ( ipro == 0 ) RETURN 302 280 303 DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro 281 304 … … 283 306 284 307 IF ( kt /= prodatqc%mstp(jobs) ) THEN 285 308 286 309 IF(lwp) THEN 287 310 WRITE(numout,*) … … 298 321 CALL ctl_stop( 'obs_pro_opt', 'Inconsistent time' ) 299 322 ENDIF 300 323 301 324 zlam = prodatqc%rlam(jobs) 302 325 zphi = prodatqc%rphi(jobs) 326 327 ! Horizontal weights 328 ! Masked values are calculated later. 329 IF ( prodatqc%npvend(jobs,kvar) > 0 ) THEN 330 331 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 332 & zglam(:,:,iobs), zgphi(:,:,iobs), & 333 & zmask(:,:,1,iobs), zweig1, zmsk ) 334 335 ENDIF 336 337 IF ( prodatqc%npvend(jobs,kvar) > 0 ) THEN 338 339 zobsk(:) = obfillflt 340 341 IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN 342 343 IF ( idayend == 0 ) THEN 344 ! Daily averaged data 345 346 ! vertically interpolate all 4 corners 347 ista = prodatqc%npvsta(jobs,kvar) 348 iend = prodatqc%npvend(jobs,kvar) 349 inum_obs = iend - ista + 1 350 ALLOCATE(interp_corner(2,2,inum_obs),iv_indic(inum_obs)) 351 352 DO iin=1,2 353 DO ijn=1,2 354 355 IF ( k1dint == 1 ) THEN 356 CALL obs_int_z1d_spl( kpk, & 357 & zinm(iin,ijn,:,iobs), & 358 & zobs2k, zgdept(iin,ijn,:,iobs), & 359 & zmask(iin,ijn,:,iobs)) 360 ENDIF 361 362 CALL obs_level_search(kpk, & 363 & zgdept(iin,ijn,:,iobs), & 364 & inum_obs, prodatqc%var(kvar)%vdep(ista:iend), & 365 & iv_indic) 366 367 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 368 & prodatqc%var(kvar)%vdep(ista:iend), & 369 & zinm(iin,ijn,:,iobs), & 370 & zobs2k, interp_corner(iin,ijn,:), & 371 & zgdept(iin,ijn,:,iobs), & 372 & zmask(iin,ijn,:,iobs)) 373 374 ENDDO 375 ENDDO 376 377 ENDIF !idayend 378 379 ELSE 380 381 ! Point data 382 383 ! vertically interpolate all 4 corners 384 ista = prodatqc%npvsta(jobs,kvar) 385 iend = prodatqc%npvend(jobs,kvar) 386 inum_obs = iend - ista + 1 387 ALLOCATE(interp_corner(2,2,inum_obs), iv_indic(inum_obs)) 388 DO iin=1,2 389 DO ijn=1,2 390 391 IF ( k1dint == 1 ) THEN 392 CALL obs_int_z1d_spl( kpk, & 393 & zint(iin,ijn,:,iobs),& 394 & zobs2k, zgdept(iin,ijn,:,iobs), & 395 & zmask(iin,ijn,:,iobs)) 396 397 ENDIF 398 399 CALL obs_level_search(kpk, & 400 & zgdept(iin,ijn,:,iobs),& 401 & inum_obs, prodatqc%var(kvar)%vdep(ista:iend), & 402 & iv_indic) 403 404 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 405 & prodatqc%var(kvar)%vdep(ista:iend), & 406 & zint(iin,ijn,:,iobs), & 407 & zobs2k,interp_corner(iin,ijn,:), & 408 & zgdept(iin,ijn,:,iobs), & 409 & zmask(iin,ijn,:,iobs) ) 303 410 304 ! Horizontal weights and vertical mask 305 306 IF ( ( prodatqc%npvend(jobs,1) > 0 ) .OR. & 307 & ( prodatqc%npvend(jobs,2) > 0 ) ) THEN 308 309 CALL obs_int_h2d_init( kpk, kpk, k2dint, zlam, zphi, & 310 & zglam(:,:,iobs), zgphi(:,:,iobs), & 311 & zmask(:,:,:,iobs), zweig, zobsmask ) 312 313 ENDIF 314 315 IF ( prodatqc%npvend(jobs,1) > 0 ) THEN 316 317 zobsk(:) = obfillflt 318 319 IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN 320 321 IF ( idayend == 0 ) THEN 411 ENDDO 412 ENDDO 413 414 ENDIF 415 416 !------------------------------------------------------------- 417 ! Compute the horizontal interpolation for every profile level 418 !------------------------------------------------------------- 419 420 DO ikn=1,inum_obs 421 iend=ista+ikn-1 322 422 323 ! Daily averaged moored buoy (MRB) data 324 325 CALL obs_int_h2d( kpk, kpk, & 326 & zweig, zinmt(:,:,:,iobs), zobsk ) 327 328 329 ELSE 330 331 CALL ctl_stop( ' A nonzero' // & 332 & ' number of profile T BUOY data should' // & 333 & ' only occur at the end of a given day' ) 334 335 ENDIF 336 337 ELSE 338 339 ! Point data 340 341 CALL obs_int_h2d( kpk, kpk, & 342 & zweig, zintt(:,:,:,iobs), zobsk ) 343 344 ENDIF 345 346 !------------------------------------------------------------- 347 ! Compute vertical second-derivative of the interpolating 348 ! polynomial at obs points 349 !------------------------------------------------------------- 350 351 IF ( k1dint == 1 ) THEN 352 CALL obs_int_z1d_spl( kpk, zobsk, zobs2k, & 353 & pgdept, zobsmask ) 354 ENDIF 355 356 !----------------------------------------------------------------- 357 ! Vertical interpolation to the observation point 358 !----------------------------------------------------------------- 359 ista = prodatqc%npvsta(jobs,1) 360 iend = prodatqc%npvend(jobs,1) 361 CALL obs_int_z1d( kpk, & 362 & prodatqc%var(1)%mvk(ista:iend), & 363 & k1dint, iend - ista + 1, & 364 & prodatqc%var(1)%vdep(ista:iend), & 365 & zobsk, zobs2k, & 366 & prodatqc%var(1)%vmod(ista:iend), & 367 & pgdept, zobsmask ) 368 369 ENDIF 370 371 IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 372 373 zobsk(:) = obfillflt 374 375 IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN 376 377 IF ( idayend == 0 ) THEN 378 379 ! Daily averaged moored buoy (MRB) data 380 381 CALL obs_int_h2d( kpk, kpk, & 382 & zweig, zinms(:,:,:,iobs), zobsk ) 383 384 ELSE 385 386 CALL ctl_stop( ' A nonzero' // & 387 & ' number of profile S BUOY data should' // & 388 & ' only occur at the end of a given day' ) 389 390 ENDIF 391 392 ELSE 393 394 ! Point data 395 396 CALL obs_int_h2d( kpk, kpk, & 397 & zweig, zints(:,:,:,iobs), zobsk ) 398 399 ENDIF 400 401 402 !------------------------------------------------------------- 403 ! Compute vertical second-derivative of the interpolating 404 ! polynomial at obs points 405 !------------------------------------------------------------- 406 407 IF ( k1dint == 1 ) THEN 408 CALL obs_int_z1d_spl( kpk, zobsk, zobs2k, & 409 & pgdept, zobsmask ) 410 ENDIF 411 412 !---------------------------------------------------------------- 413 ! Vertical interpolation to the observation point 414 !---------------------------------------------------------------- 415 ista = prodatqc%npvsta(jobs,2) 416 iend = prodatqc%npvend(jobs,2) 417 CALL obs_int_z1d( kpk, & 418 & prodatqc%var(2)%mvk(ista:iend),& 419 & k1dint, iend - ista + 1, & 420 & prodatqc%var(2)%vdep(ista:iend),& 421 & zobsk, zobs2k, & 422 & prodatqc%var(2)%vmod(ista:iend),& 423 & pgdept, zobsmask ) 424 425 ENDIF 426 427 END DO 423 zweig(:,:,1) = 0._wp 424 425 ! This code forces the horizontal weights to be 426 ! zero IF the observation is below the bottom of the 427 ! corners of the interpolation nodes, Or if it is in 428 ! the mask. This is important for observations near 429 ! steep bathymetry 430 DO iin=1,2 431 DO ijn=1,2 432 433 depth_loop: DO ik=kpk,2,-1 434 IF(zmask(iin,ijn,ik-1,iobs ) > 0.9 )THEN 435 436 zweig(iin,ijn,1) = & 437 & zweig1(iin,ijn,1) * & 438 & MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) & 439 & - prodatqc%var(kvar)%vdep(iend)),0._wp) 440 441 EXIT depth_loop 442 443 ENDIF 444 445 ENDDO depth_loop 446 447 ENDDO 448 ENDDO 449 450 CALL obs_int_h2d( 1, 1, zweig, interp_corner(:,:,ikn), & 451 & prodatqc%var(kvar)%vmod(iend:iend) ) 452 453 ! Set QC flag for any observations found below the bottom 454 ! needed as the check here is more strict than that in obs_prep 455 IF (sum(zweig) == 0.0_wp) prodatqc%var(kvar)%nvqc(iend:iend)=4 428 456 457 ENDDO 458 459 DEALLOCATE(interp_corner,iv_indic) 460 461 ENDIF 462 463 ENDDO 464 429 465 ! Deallocate the data for interpolation 430 DEALLOCATE( & 431 & igrdi, & 432 & igrdj, & 433 & zglam, & 434 & zgphi, & 435 & zmask, & 436 & zintt, & 437 & zints & 466 DEALLOCATE( & 467 & igrdi, & 468 & igrdj, & 469 & zglam, & 470 & zgphi, & 471 & zmask, & 472 & zint, & 473 & zgdept, & 474 & zgdepw & 438 475 & ) 476 439 477 ! At the end of the day also get interpolated means 440 IF ( idayend == 0 ) THEN 441 DEALLOCATE( & 442 & zinmt, & 443 & zinms & 444 & ) 478 IF ( ld_dailyav .AND. idayend == 0 ) THEN 479 DEALLOCATE( zinm ) 445 480 ENDIF 446 481 447 prodatqc%nprofup = prodatqc%nprofup + ipro 448 449 END SUBROUTINE obs_pro_opt 450 451 SUBROUTINE obs_sla_opt( sladatqc, kt, kpi, kpj, kit000, & 452 & psshn, psshmask, k2dint ) 482 IF ( kvar == prodatqc%nvar ) THEN 483 prodatqc%nprofup = prodatqc%nprofup + ipro 484 ENDIF 485 486 END SUBROUTINE obs_prof_opt 487 488 SUBROUTINE obs_surf_opt( surfdataqc, kt, kpi, kpj, & 489 & kit000, kdaystp, psurf, psurfmask, & 490 & k2dint, ldnightav, plamscl, pphiscl, & 491 & lindegrees ) 492 453 493 !!----------------------------------------------------------------------- 454 494 !! 455 !! *** ROUTINE obs_s la_opt ***456 !! 457 !! ** Purpose : Compute the model counterpart of s ea level anomaly495 !! *** ROUTINE obs_surf_opt *** 496 !! 497 !! ** Purpose : Compute the model counterpart of surface 458 498 !! data by interpolating from the model grid to the 459 499 !! observation point. … … 462 502 !! the model values at the corners of the surrounding grid box. 463 503 !! 464 !! The n ow model SSHis first computed at the obs (lon, lat) point.504 !! The new model value is first computed at the obs (lon, lat) point. 465 505 !! 466 506 !! Several horizontal interpolation schemes are available: … … 470 510 !! - bilinear (quadrilateral grid) (k2dint = 3) 471 511 !! - polynomial (quadrilateral grid) (k2dint = 4) 472 !! 473 !! The sea level anomaly at the observation points is then computed 474 !! by removing a mean dynamic topography (defined at the obs. point). 512 !! 513 !! Two horizontal averaging schemes are also available: 514 !! - weighted radial footprint (k2dint = 5) 515 !! - weighted rectangular footprint (k2dint = 6) 516 !! 475 517 !! 476 518 !! ** Action : … … 478 520 !! History : 479 521 !! ! 07-03 (A. Weaver) 522 !! ! 15-02 (M. Martin) Combined routine for surface types 523 !! ! 17-03 (M. Martin) Added horizontal averaging options 480 524 !!----------------------------------------------------------------------- 481 525 482 526 !! * Modules used 483 527 USE obs_surf_def ! Definition of storage space for surface observations … … 486 530 487 531 !! * Arguments 488 TYPE(obs_surf), INTENT(INOUT) :: sladatqc ! Subset of surface data not failing screening 489 INTEGER, INTENT(IN) :: kt ! Time step 490 INTEGER, INTENT(IN) :: kpi ! Model grid parameters 532 TYPE(obs_surf), INTENT(INOUT) :: & 533 & surfdataqc ! Subset of surface data passing QC 534 INTEGER, INTENT(IN) :: kt ! Time step 535 INTEGER, INTENT(IN) :: kpi ! Model grid parameters 491 536 INTEGER, INTENT(IN) :: kpj 492 INTEGER, INTENT(IN) :: kit000 ! Number of the first time step 493 ! (kit000-1 = restart time) 494 INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation type (see header) 495 REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 496 & psshn, & ! Model SSH field 497 & psshmask ! Land-sea mask 498 537 INTEGER, INTENT(IN) :: kit000 ! Number of the first time step 538 ! (kit000-1 = restart time) 539 INTEGER, INTENT(IN) :: kdaystp ! Number of time steps per day 540 INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation type (see header) 541 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 542 & psurf, & ! Model surface field 543 & psurfmask ! Land-sea mask 544 LOGICAL, INTENT(IN) :: ldnightav ! Logical for averaging night-time data 545 REAL(KIND=wp), INTENT(IN) :: & 546 & plamscl, & ! Diameter in metres of obs footprint in E/W, N/S directions 547 & pphiscl ! This is the full width (rather than half-width) 548 LOGICAL, INTENT(IN) :: & 549 & lindegrees ! T=> plamscl and pphiscl are specified in degrees, F=> in metres 550 499 551 !! * Local declarations 500 552 INTEGER :: ji … … 502 554 INTEGER :: jobs 503 555 INTEGER :: inrc 504 INTEGER :: is la556 INTEGER :: isurf 505 557 INTEGER :: iobs 506 REAL(KIND=wp) :: zlam 507 REAL(KIND=wp) :: zphi 508 REAL(KIND=wp) :: zext(1), zobsmask(1) 509 REAL(kind=wp), DIMENSION(2,2,1) :: & 510 & zweig 558 INTEGER :: imaxifp, imaxjfp 559 INTEGER :: imodi, imodj 560 INTEGER :: idayend 561 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 562 & igrdi, & 563 & igrdj, & 564 & igrdip1, & 565 & igrdjp1 566 INTEGER, DIMENSION(:,:), SAVE, ALLOCATABLE :: & 567 & icount_night, & 568 & imask_night 569 REAL(wp) :: zlam 570 REAL(wp) :: zphi 571 REAL(wp), DIMENSION(1) :: zext, zobsmask 572 REAL(wp) :: zdaystp 511 573 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 512 & zmask, & 513 & zsshl, & 514 & zglam, & 515 & zgphi 516 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 517 & igrdi, & 518 & igrdj 574 & zweig, & 575 & zmask, & 576 & zsurf, & 577 & zsurfm, & 578 & zsurftmp, & 579 & zglam, & 580 & zgphi, & 581 & zglamf, & 582 & zgphif 583 584 REAL(wp), DIMENSION(:,:), SAVE, ALLOCATABLE :: & 585 & zintmp, & 586 & zouttmp, & 587 & zmeanday ! to compute model sst in region of 24h daylight (pole) 519 588 520 589 !------------------------------------------------------------------------ 521 590 ! Local initialization 522 591 !------------------------------------------------------------------------ 523 ! ...Record and data counters592 ! Record and data counters 524 593 inrc = kt - kit000 + 2 525 isla = sladatqc%nsstp(inrc) 594 isurf = surfdataqc%nsstp(inrc) 595 596 ! Work out the maximum footprint size for the 597 ! interpolation/averaging in model grid-points - has to be even. 598 599 CALL obs_max_fpsize( k2dint, plamscl, pphiscl, lindegrees, psurfmask, imaxifp, imaxjfp ) 600 601 602 IF ( ldnightav ) THEN 603 604 ! Initialize array for night mean 605 IF ( kt == 0 ) THEN 606 ALLOCATE ( icount_night(kpi,kpj) ) 607 ALLOCATE ( imask_night(kpi,kpj) ) 608 ALLOCATE ( zintmp(kpi,kpj) ) 609 ALLOCATE ( zouttmp(kpi,kpj) ) 610 ALLOCATE ( zmeanday(kpi,kpj) ) 611 nday_qsr = -1 ! initialisation flag for nbc_dcy 612 ENDIF 613 614 ! Night-time means are calculated for night-time values over timesteps: 615 ! [1 <= kt <= kdaystp], [kdaystp+1 <= kt <= 2*kdaystp], ..... 616 idayend = MOD( kt - kit000 + 1, kdaystp ) 617 618 ! Initialize night-time mean for first timestep of the day 619 IF ( idayend == 1 .OR. kt == 0 ) THEN 620 DO jj = 1, jpj 621 DO ji = 1, jpi 622 surfdataqc%vdmean(ji,jj) = 0.0 623 zmeanday(ji,jj) = 0.0 624 icount_night(ji,jj) = 0 625 END DO 626 END DO 627 ENDIF 628 629 zintmp(:,:) = 0.0 630 zouttmp(:,:) = sbc_dcy( zintmp(:,:), .TRUE. ) 631 imask_night(:,:) = INT( zouttmp(:,:) ) 632 633 DO jj = 1, jpj 634 DO ji = 1, jpi 635 ! Increment the temperature field for computing night mean and counter 636 surfdataqc%vdmean(ji,jj) = surfdataqc%vdmean(ji,jj) & 637 & + psurf(ji,jj) * REAL( imask_night(ji,jj) ) 638 zmeanday(ji,jj) = zmeanday(ji,jj) + psurf(ji,jj) 639 icount_night(ji,jj) = icount_night(ji,jj) + imask_night(ji,jj) 640 END DO 641 END DO 642 643 ! Compute the night-time mean at the end of the day 644 zdaystp = 1.0 / REAL( kdaystp ) 645 IF ( idayend == 0 ) THEN 646 IF (lwp) WRITE(numout,*) 'Calculating surfdataqc%vdmean on time-step: ',kt 647 DO jj = 1, jpj 648 DO ji = 1, jpi 649 ! Test if "no night" point 650 IF ( icount_night(ji,jj) > 0 ) THEN 651 surfdataqc%vdmean(ji,jj) = surfdataqc%vdmean(ji,jj) & 652 & / REAL( icount_night(ji,jj) ) 653 ELSE 654 !At locations where there is no night (e.g. poles), 655 ! calculate daily mean instead of night-time mean. 656 surfdataqc%vdmean(ji,jj) = zmeanday(ji,jj) * zdaystp 657 ENDIF 658 END DO 659 END DO 660 ENDIF 661 662 ENDIF 526 663 527 664 ! Get the data for interpolation 528 665 529 666 ALLOCATE( & 530 & igrdi(2,2,isla), & 531 & igrdj(2,2,isla), & 532 & zglam(2,2,isla), & 533 & zgphi(2,2,isla), & 534 & zmask(2,2,isla), & 535 & zsshl(2,2,isla) & 667 & zweig(imaxifp,imaxjfp,1), & 668 & igrdi(imaxifp,imaxjfp,isurf), & 669 & igrdj(imaxifp,imaxjfp,isurf), & 670 & zglam(imaxifp,imaxjfp,isurf), & 671 & zgphi(imaxifp,imaxjfp,isurf), & 672 & zmask(imaxifp,imaxjfp,isurf), & 673 & zsurf(imaxifp,imaxjfp,isurf), & 674 & zsurftmp(imaxifp,imaxjfp,isurf), & 675 & zglamf(imaxifp+1,imaxjfp+1,isurf), & 676 & zgphif(imaxifp+1,imaxjfp+1,isurf), & 677 & igrdip1(imaxifp+1,imaxjfp+1,isurf), & 678 & igrdjp1(imaxifp+1,imaxjfp+1,isurf) & 536 679 & ) 537 538 DO jobs = sladatqc%nsurfup + 1, sladatqc%nsurfup + isla 539 iobs = jobs - sladatqc%nsurfup 540 igrdi(1,1,iobs) = sladatqc%mi(jobs)-1 541 igrdj(1,1,iobs) = sladatqc%mj(jobs)-1 542 igrdi(1,2,iobs) = sladatqc%mi(jobs)-1 543 igrdj(1,2,iobs) = sladatqc%mj(jobs) 544 igrdi(2,1,iobs) = sladatqc%mi(jobs) 545 igrdj(2,1,iobs) = sladatqc%mj(jobs)-1 546 igrdi(2,2,iobs) = sladatqc%mi(jobs) 547 igrdj(2,2,iobs) = sladatqc%mj(jobs) 680 681 DO jobs = surfdataqc%nsurfup + 1, surfdataqc%nsurfup + isurf 682 iobs = jobs - surfdataqc%nsurfup 683 DO ji = 0, imaxifp 684 imodi = surfdataqc%mi(jobs) - int(imaxifp/2) + ji - 1 685 686 !Deal with wrap around in longitude 687 IF ( imodi < 1 ) imodi = imodi + jpiglo 688 IF ( imodi > jpiglo ) imodi = imodi - jpiglo 689 690 DO jj = 0, imaxjfp 691 imodj = surfdataqc%mj(jobs) - int(imaxjfp/2) + jj - 1 692 !If model values are out of the domain to the north/south then 693 !set them to be the edge of the domain 694 IF ( imodj < 1 ) imodj = 1 695 IF ( imodj > jpjglo ) imodj = jpjglo 696 697 igrdip1(ji+1,jj+1,iobs) = imodi 698 igrdjp1(ji+1,jj+1,iobs) = imodj 699 700 IF ( ji >= 1 .AND. jj >= 1 ) THEN 701 igrdi(ji,jj,iobs) = imodi 702 igrdj(ji,jj,iobs) = imodj 703 ENDIF 704 705 END DO 706 END DO 548 707 END DO 549 708 550 CALL obs_int_comm_2d( 2, 2, isla, &709 CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & 551 710 & igrdi, igrdj, glamt, zglam ) 552 CALL obs_int_comm_2d( 2, 2, isla, &711 CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & 553 712 & igrdi, igrdj, gphit, zgphi ) 554 CALL obs_int_comm_2d( 2, 2, isla, & 555 & igrdi, igrdj, psshmask, zmask ) 556 CALL obs_int_comm_2d( 2, 2, isla, & 557 & igrdi, igrdj, psshn, zsshl ) 713 CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & 714 & igrdi, igrdj, psurfmask, zmask ) 715 CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & 716 & igrdi, igrdj, psurf, zsurf ) 717 CALL obs_int_comm_2d( imaxifp+1, imaxjfp+1, isurf, kpi, kpj, & 718 & igrdip1, igrdjp1, glamf, zglamf ) 719 CALL obs_int_comm_2d( imaxifp+1, imaxjfp+1, isurf, kpi, kpj, & 720 & igrdip1, igrdjp1, gphif, zgphif ) 721 722 ! At the end of the day get interpolated means 723 IF ( idayend == 0 .AND. ldnightav ) THEN 724 725 ALLOCATE( & 726 & zsurfm(imaxifp,imaxjfp,isurf) & 727 & ) 728 729 CALL obs_int_comm_2d( imaxifp,imaxjfp, isurf, kpi, kpj, igrdi, igrdj, & 730 & surfdataqc%vdmean(:,:), zsurfm ) 731 732 ENDIF 558 733 559 734 ! Loop over observations 560 561 DO jobs = sladatqc%nsurfup + 1, sladatqc%nsurfup + isla 562 563 iobs = jobs - sladatqc%nsurfup 564 565 IF ( kt /= sladatqc%mstp(jobs) ) THEN 566 735 DO jobs = surfdataqc%nsurfup + 1, surfdataqc%nsurfup + isurf 736 737 iobs = jobs - surfdataqc%nsurfup 738 739 IF ( kt /= surfdataqc%mstp(jobs) ) THEN 740 567 741 IF(lwp) THEN 568 742 WRITE(numout,*) … … 574 748 WRITE(numout,*) ' Record = ', jobs, & 575 749 & ' kt = ', kt, & 576 & ' mstp = ', s ladatqc%mstp(jobs), &577 & ' ntyp = ', s ladatqc%ntyp(jobs)750 & ' mstp = ', surfdataqc%mstp(jobs), & 751 & ' ntyp = ', surfdataqc%ntyp(jobs) 578 752 ENDIF 579 CALL ctl_stop( 'obs_sla_opt', 'Inconsistent time' ) 580 753 CALL ctl_stop( 'obs_surf_opt', 'Inconsistent time' ) 754 755 ENDIF 756 757 zlam = surfdataqc%rlam(jobs) 758 zphi = surfdataqc%rphi(jobs) 759 760 IF ( ldnightav .AND. idayend == 0 ) THEN 761 ! Night-time averaged data 762 zsurftmp(:,:,iobs) = zsurfm(:,:,iobs) 763 ELSE 764 zsurftmp(:,:,iobs) = zsurf(:,:,iobs) 765 ENDIF 766 767 IF ( k2dint <= 4 ) THEN 768 769 ! Get weights to interpolate the model value to the observation point 770 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 771 & zglam(:,:,iobs), zgphi(:,:,iobs), & 772 & zmask(:,:,iobs), zweig, zobsmask ) 773 774 ! Interpolate the model value to the observation point 775 CALL obs_int_h2d( 1, 1, zweig, zsurftmp(:,:,iobs), zext ) 776 777 ELSE 778 779 ! Get weights to average the model SLA to the observation footprint 780 CALL obs_avg_h2d_init( 1, 1, imaxifp, imaxjfp, k2dint, zlam, zphi, & 781 & zglam(:,:,iobs), zgphi(:,:,iobs), & 782 & zglamf(:,:,iobs), zgphif(:,:,iobs), & 783 & zmask(:,:,iobs), plamscl, pphiscl, & 784 & lindegrees, zweig, zobsmask ) 785 786 ! Average the model SST to the observation footprint 787 CALL obs_avg_h2d( 1, 1, imaxifp, imaxjfp, & 788 & zweig, zsurftmp(:,:,iobs), zext ) 789 790 ENDIF 791 792 IF ( TRIM(surfdataqc%cvars(1)) == 'SLA' .AND. surfdataqc%nextra == 2 ) THEN 793 ! ... Remove the MDT from the SSH at the observation point to get the SLA 794 surfdataqc%rext(jobs,1) = zext(1) 795 surfdataqc%rmod(jobs,1) = surfdataqc%rext(jobs,1) - surfdataqc%rext(jobs,2) 796 ELSE 797 surfdataqc%rmod(jobs,1) = zext(1) 581 798 ENDIF 582 799 583 zlam = sladatqc%rlam(jobs) 584 zphi = sladatqc%rphi(jobs) 585 586 ! Get weights to interpolate the model SSH to the observation point 587 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 588 & zglam(:,:,iobs), zgphi(:,:,iobs), & 589 & zmask(:,:,iobs), zweig, zobsmask ) 590 591 592 ! Interpolate the model SSH to the observation point 593 CALL obs_int_h2d( 1, 1, & 594 & zweig, zsshl(:,:,iobs), zext ) 595 596 sladatqc%rext(jobs,1) = zext(1) 597 ! ... Remove the MDT at the observation point 598 sladatqc%rmod(jobs,1) = sladatqc%rext(jobs,1) - sladatqc%rext(jobs,2) 800 IF ( zext(1) == obfillflt ) THEN 801 ! If the observation value is a fill value, set QC flag to bad 802 surfdataqc%nqc(jobs) = 4 803 ENDIF 599 804 600 805 END DO … … 602 807 ! Deallocate the data for interpolation 603 808 DEALLOCATE( & 809 & zweig, & 604 810 & igrdi, & 605 811 & igrdj, & … … 607 813 & zgphi, & 608 814 & zmask, & 609 & zsshl & 815 & zsurf, & 816 & zsurftmp, & 817 & zglamf, & 818 & zgphif, & 819 & igrdip1,& 820 & igrdjp1 & 610 821 & ) 611 822 612 sladatqc%nsurfup = sladatqc%nsurfup + isla 613 614 END SUBROUTINE obs_sla_opt 615 616 SUBROUTINE obs_sst_opt( sstdatqc, kt, kpi, kpj, kit000, kdaystp, & 617 & psstn, psstmask, k2dint, ld_nightav ) 618 !!----------------------------------------------------------------------- 619 !! 620 !! *** ROUTINE obs_sst_opt *** 621 !! 622 !! ** Purpose : Compute the model counterpart of surface temperature 623 !! data by interpolating from the model grid to the 624 !! observation point. 625 !! 626 !! ** Method : Linearly interpolate to each observation point using 627 !! the model values at the corners of the surrounding grid box. 628 !! 629 !! The now model SST is first computed at the obs (lon, lat) point. 630 !! 631 !! Several horizontal interpolation schemes are available: 632 !! - distance-weighted (great circle) (k2dint = 0) 633 !! - distance-weighted (small angle) (k2dint = 1) 634 !! - bilinear (geographical grid) (k2dint = 2) 635 !! - bilinear (quadrilateral grid) (k2dint = 3) 636 !! - polynomial (quadrilateral grid) (k2dint = 4) 637 !! 638 !! 639 !! ** Action : 640 !! 641 !! History : 642 !! ! 07-07 (S. Ricci ) : Original 643 !! 644 !!----------------------------------------------------------------------- 645 646 !! * Modules used 647 USE obs_surf_def ! Definition of storage space for surface observations 648 USE sbcdcy 649 650 IMPLICIT NONE 651 652 !! * Arguments 653 TYPE(obs_surf), INTENT(INOUT) :: & 654 & sstdatqc ! Subset of surface data not failing screening 655 INTEGER, INTENT(IN) :: kt ! Time step 656 INTEGER, INTENT(IN) :: kpi ! Model grid parameters 657 INTEGER, INTENT(IN) :: kpj 658 INTEGER, INTENT(IN) :: kit000 ! Number of the first time step 659 ! (kit000-1 = restart time) 660 INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation type (see header) 661 INTEGER, INTENT(IN) :: kdaystp ! Number of time steps per day 662 REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 663 & psstn, & ! Model SST field 664 & psstmask ! Land-sea mask 665 666 !! * Local declarations 667 INTEGER :: ji 668 INTEGER :: jj 669 INTEGER :: jobs 670 INTEGER :: inrc 671 INTEGER :: isst 672 INTEGER :: iobs 673 INTEGER :: idayend 674 REAL(KIND=wp) :: zlam 675 REAL(KIND=wp) :: zphi 676 REAL(KIND=wp) :: zext(1), zobsmask(1) 677 REAL(KIND=wp) :: zdaystp 678 INTEGER, DIMENSION(:,:), SAVE, ALLOCATABLE :: & 679 & icount_sstnight, & 680 & imask_night 681 REAL(kind=wp), DIMENSION(:,:), SAVE, ALLOCATABLE :: & 682 & zintmp, & 683 & zouttmp, & 684 & zmeanday ! to compute model sst in region of 24h daylight (pole) 685 REAL(kind=wp), DIMENSION(2,2,1) :: & 686 & zweig 687 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 688 & zmask, & 689 & zsstl, & 690 & zsstm, & 691 & zglam, & 692 & zgphi 693 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 694 & igrdi, & 695 & igrdj 696 LOGICAL, INTENT(IN) :: ld_nightav 697 698 !----------------------------------------------------------------------- 699 ! Local initialization 700 !----------------------------------------------------------------------- 701 ! ... Record and data counters 702 inrc = kt - kit000 + 2 703 isst = sstdatqc%nsstp(inrc) 704 705 IF ( ld_nightav ) THEN 706 707 ! Initialize array for night mean 708 709 IF ( kt .EQ. 0 ) THEN 710 ALLOCATE ( icount_sstnight(kpi,kpj) ) 711 ALLOCATE ( imask_night(kpi,kpj) ) 712 ALLOCATE ( zintmp(kpi,kpj) ) 713 ALLOCATE ( zouttmp(kpi,kpj) ) 714 ALLOCATE ( zmeanday(kpi,kpj) ) 715 nday_qsr = -1 ! initialisation flag for nbc_dcy 716 ENDIF 717 718 ! Initialize daily mean for first timestep 719 idayend = MOD( kt - kit000 + 1, kdaystp ) 720 721 ! Added kt == 0 test to catch restart case 722 IF ( idayend == 1 .OR. kt == 0) THEN 723 IF (lwp) WRITE(numout,*) 'Reset sstdatqc%vdmean on time-step: ',kt 724 DO jj = 1, jpj 725 DO ji = 1, jpi 726 sstdatqc%vdmean(ji,jj) = 0.0 727 zmeanday(ji,jj) = 0.0 728 icount_sstnight(ji,jj) = 0 729 END DO 730 END DO 731 ENDIF 732 733 zintmp(:,:) = 0.0 734 zouttmp(:,:) = sbc_dcy( zintmp(:,:), .TRUE. ) 735 imask_night(:,:) = INT( zouttmp(:,:) ) 736 737 DO jj = 1, jpj 738 DO ji = 1, jpi 739 ! Increment the temperature field for computing night mean and counter 740 sstdatqc%vdmean(ji,jj) = sstdatqc%vdmean(ji,jj) & 741 & + psstn(ji,jj)*imask_night(ji,jj) 742 zmeanday(ji,jj) = zmeanday(ji,jj) + psstn(ji,jj) 743 icount_sstnight(ji,jj) = icount_sstnight(ji,jj) + imask_night(ji,jj) 744 END DO 745 END DO 746 747 ! Compute the daily mean at the end of day 748 749 zdaystp = 1.0 / REAL( kdaystp ) 750 751 IF ( idayend == 0 ) THEN 752 DO jj = 1, jpj 753 DO ji = 1, jpi 754 ! Test if "no night" point 755 IF ( icount_sstnight(ji,jj) .NE. 0 ) THEN 756 sstdatqc%vdmean(ji,jj) = sstdatqc%vdmean(ji,jj) & 757 & / icount_sstnight(ji,jj) 758 ELSE 759 sstdatqc%vdmean(ji,jj) = zmeanday(ji,jj) * zdaystp 760 ENDIF 761 END DO 762 END DO 763 ENDIF 764 765 ENDIF 766 767 ! Get the data for interpolation 768 769 ALLOCATE( & 770 & igrdi(2,2,isst), & 771 & igrdj(2,2,isst), & 772 & zglam(2,2,isst), & 773 & zgphi(2,2,isst), & 774 & zmask(2,2,isst), & 775 & zsstl(2,2,isst) & 776 & ) 777 778 DO jobs = sstdatqc%nsurfup + 1, sstdatqc%nsurfup + isst 779 iobs = jobs - sstdatqc%nsurfup 780 igrdi(1,1,iobs) = sstdatqc%mi(jobs)-1 781 igrdj(1,1,iobs) = sstdatqc%mj(jobs)-1 782 igrdi(1,2,iobs) = sstdatqc%mi(jobs)-1 783 igrdj(1,2,iobs) = sstdatqc%mj(jobs) 784 igrdi(2,1,iobs) = sstdatqc%mi(jobs) 785 igrdj(2,1,iobs) = sstdatqc%mj(jobs)-1 786 igrdi(2,2,iobs) = sstdatqc%mi(jobs) 787 igrdj(2,2,iobs) = sstdatqc%mj(jobs) 788 END DO 789 790 CALL obs_int_comm_2d( 2, 2, isst, & 791 & igrdi, igrdj, glamt, zglam ) 792 CALL obs_int_comm_2d( 2, 2, isst, & 793 & igrdi, igrdj, gphit, zgphi ) 794 CALL obs_int_comm_2d( 2, 2, isst, & 795 & igrdi, igrdj, psstmask, zmask ) 796 CALL obs_int_comm_2d( 2, 2, isst, & 797 & igrdi, igrdj, psstn, zsstl ) 798 799 ! At the end of the day get interpolated means 800 IF ( idayend == 0 .AND. ld_nightav ) THEN 801 802 ALLOCATE( & 803 & zsstm(2,2,isst) & 804 & ) 805 806 CALL obs_int_comm_2d( 2, 2, isst, igrdi, igrdj, & 807 & sstdatqc%vdmean(:,:), zsstm ) 808 809 ENDIF 810 811 ! Loop over observations 812 813 DO jobs = sstdatqc%nsurfup + 1, sstdatqc%nsurfup + isst 814 815 iobs = jobs - sstdatqc%nsurfup 816 817 IF ( kt /= sstdatqc%mstp(jobs) ) THEN 818 819 IF(lwp) THEN 820 WRITE(numout,*) 821 WRITE(numout,*) ' E R R O R : Observation', & 822 & ' time step is not consistent with the', & 823 & ' model time step' 824 WRITE(numout,*) ' =========' 825 WRITE(numout,*) 826 WRITE(numout,*) ' Record = ', jobs, & 827 & ' kt = ', kt, & 828 & ' mstp = ', sstdatqc%mstp(jobs), & 829 & ' ntyp = ', sstdatqc%ntyp(jobs) 830 ENDIF 831 CALL ctl_stop( 'obs_sst_opt', 'Inconsistent time' ) 832 833 ENDIF 834 835 zlam = sstdatqc%rlam(jobs) 836 zphi = sstdatqc%rphi(jobs) 837 838 ! Get weights to interpolate the model SST to the observation point 839 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 840 & zglam(:,:,iobs), zgphi(:,:,iobs), & 841 & zmask(:,:,iobs), zweig, zobsmask ) 842 843 ! Interpolate the model SST to the observation point 844 845 IF ( ld_nightav ) THEN 846 847 IF ( idayend == 0 ) THEN 848 ! Daily averaged/diurnal cycle of SST data 849 CALL obs_int_h2d( 1, 1, & 850 & zweig, zsstm(:,:,iobs), zext ) 851 ELSE 852 CALL ctl_stop( ' ld_nightav is set to true: a nonzero' // & 853 & ' number of night SST data should' // & 854 & ' only occur at the end of a given day' ) 855 ENDIF 856 857 ELSE 858 859 CALL obs_int_h2d( 1, 1, & 860 & zweig, zsstl(:,:,iobs), zext ) 861 862 ENDIF 863 sstdatqc%rmod(jobs,1) = zext(1) 864 865 END DO 866 867 ! Deallocate the data for interpolation 868 DEALLOCATE( & 869 & igrdi, & 870 & igrdj, & 871 & zglam, & 872 & zgphi, & 873 & zmask, & 874 & zsstl & 875 & ) 876 877 ! At the end of the day also get interpolated means 878 IF ( idayend == 0 .AND. ld_nightav ) THEN 823 ! At the end of the day also deallocate night-time mean array 824 IF ( idayend == 0 .AND. ldnightav ) THEN 879 825 DEALLOCATE( & 880 & zs stm &826 & zsurfm & 881 827 & ) 882 828 ENDIF 883 884 sstdatqc%nsurfup = sstdatqc%nsurfup + isst 885 886 END SUBROUTINE obs_sst_opt 887 888 SUBROUTINE obs_sss_opt 889 !!----------------------------------------------------------------------- 890 !! 891 !! *** ROUTINE obs_sss_opt *** 892 !! 893 !! ** Purpose : Compute the model counterpart of sea surface salinity 894 !! data by interpolating from the model grid to the 895 !! observation point. 896 !! 897 !! ** Method : 898 !! 899 !! ** Action : 900 !! 901 !! History : 902 !! ! ??-?? 903 !!----------------------------------------------------------------------- 904 905 IMPLICIT NONE 906 907 END SUBROUTINE obs_sss_opt 908 909 SUBROUTINE obs_seaice_opt( seaicedatqc, kt, kpi, kpj, kit000, & 910 & pseaicen, pseaicemask, k2dint ) 911 912 !!----------------------------------------------------------------------- 913 !! 914 !! *** ROUTINE obs_seaice_opt *** 915 !! 916 !! ** Purpose : Compute the model counterpart of surface temperature 917 !! data by interpolating from the model grid to the 918 !! observation point. 919 !! 920 !! ** Method : Linearly interpolate to each observation point using 921 !! the model values at the corners of the surrounding grid box. 922 !! 923 !! The now model sea ice is first computed at the obs (lon, lat) point. 924 !! 925 !! Several horizontal interpolation schemes are available: 926 !! - distance-weighted (great circle) (k2dint = 0) 927 !! - distance-weighted (small angle) (k2dint = 1) 928 !! - bilinear (geographical grid) (k2dint = 2) 929 !! - bilinear (quadrilateral grid) (k2dint = 3) 930 !! - polynomial (quadrilateral grid) (k2dint = 4) 931 !! 932 !! 933 !! ** Action : 934 !! 935 !! History : 936 !! ! 07-07 (S. Ricci ) : Original 937 !! 938 !!----------------------------------------------------------------------- 939 940 !! * Modules used 941 USE obs_surf_def ! Definition of storage space for surface observations 942 943 IMPLICIT NONE 944 945 !! * Arguments 946 TYPE(obs_surf), INTENT(INOUT) :: seaicedatqc ! Subset of surface data not failing screening 947 INTEGER, INTENT(IN) :: kt ! Time step 948 INTEGER, INTENT(IN) :: kpi ! Model grid parameters 949 INTEGER, INTENT(IN) :: kpj 950 INTEGER, INTENT(IN) :: kit000 ! Number of the first time step 951 ! (kit000-1 = restart time) 952 INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation type (see header) 953 REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 954 & pseaicen, & ! Model sea ice field 955 & pseaicemask ! Land-sea mask 956 957 !! * Local declarations 958 INTEGER :: ji 959 INTEGER :: jj 960 INTEGER :: jobs 961 INTEGER :: inrc 962 INTEGER :: iseaice 963 INTEGER :: iobs 964 965 REAL(KIND=wp) :: zlam 966 REAL(KIND=wp) :: zphi 967 REAL(KIND=wp) :: zext(1), zobsmask(1) 968 REAL(kind=wp), DIMENSION(2,2,1) :: & 969 & zweig 970 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 971 & zmask, & 972 & zseaicel, & 973 & zglam, & 974 & zgphi 975 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 976 & igrdi, & 977 & igrdj 978 979 !------------------------------------------------------------------------ 980 ! Local initialization 981 !------------------------------------------------------------------------ 982 ! ... Record and data counters 983 inrc = kt - kit000 + 2 984 iseaice = seaicedatqc%nsstp(inrc) 985 986 ! Get the data for interpolation 987 988 ALLOCATE( & 989 & igrdi(2,2,iseaice), & 990 & igrdj(2,2,iseaice), & 991 & zglam(2,2,iseaice), & 992 & zgphi(2,2,iseaice), & 993 & zmask(2,2,iseaice), & 994 & zseaicel(2,2,iseaice) & 995 & ) 996 997 DO jobs = seaicedatqc%nsurfup + 1, seaicedatqc%nsurfup + iseaice 998 iobs = jobs - seaicedatqc%nsurfup 999 igrdi(1,1,iobs) = seaicedatqc%mi(jobs)-1 1000 igrdj(1,1,iobs) = seaicedatqc%mj(jobs)-1 1001 igrdi(1,2,iobs) = seaicedatqc%mi(jobs)-1 1002 igrdj(1,2,iobs) = seaicedatqc%mj(jobs) 1003 igrdi(2,1,iobs) = seaicedatqc%mi(jobs) 1004 igrdj(2,1,iobs) = seaicedatqc%mj(jobs)-1 1005 igrdi(2,2,iobs) = seaicedatqc%mi(jobs) 1006 igrdj(2,2,iobs) = seaicedatqc%mj(jobs) 1007 END DO 1008 1009 CALL obs_int_comm_2d( 2, 2, iseaice, & 1010 & igrdi, igrdj, glamt, zglam ) 1011 CALL obs_int_comm_2d( 2, 2, iseaice, & 1012 & igrdi, igrdj, gphit, zgphi ) 1013 CALL obs_int_comm_2d( 2, 2, iseaice, & 1014 & igrdi, igrdj, pseaicemask, zmask ) 1015 CALL obs_int_comm_2d( 2, 2, iseaice, & 1016 & igrdi, igrdj, pseaicen, zseaicel ) 1017 1018 DO jobs = seaicedatqc%nsurfup + 1, seaicedatqc%nsurfup + iseaice 1019 1020 iobs = jobs - seaicedatqc%nsurfup 1021 1022 IF ( kt /= seaicedatqc%mstp(jobs) ) THEN 1023 1024 IF(lwp) THEN 1025 WRITE(numout,*) 1026 WRITE(numout,*) ' E R R O R : Observation', & 1027 & ' time step is not consistent with the', & 1028 & ' model time step' 1029 WRITE(numout,*) ' =========' 1030 WRITE(numout,*) 1031 WRITE(numout,*) ' Record = ', jobs, & 1032 & ' kt = ', kt, & 1033 & ' mstp = ', seaicedatqc%mstp(jobs), & 1034 & ' ntyp = ', seaicedatqc%ntyp(jobs) 1035 ENDIF 1036 CALL ctl_stop( 'obs_seaice_opt', 'Inconsistent time' ) 1037 1038 ENDIF 1039 1040 zlam = seaicedatqc%rlam(jobs) 1041 zphi = seaicedatqc%rphi(jobs) 1042 1043 ! Get weights to interpolate the model sea ice to the observation point 1044 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 1045 & zglam(:,:,iobs), zgphi(:,:,iobs), & 1046 & zmask(:,:,iobs), zweig, zobsmask ) 1047 1048 ! ... Interpolate the model sea ice to the observation point 1049 CALL obs_int_h2d( 1, 1, & 1050 & zweig, zseaicel(:,:,iobs), zext ) 1051 1052 seaicedatqc%rmod(jobs,1) = zext(1) 1053 1054 END DO 1055 1056 ! Deallocate the data for interpolation 1057 DEALLOCATE( & 1058 & igrdi, & 1059 & igrdj, & 1060 & zglam, & 1061 & zgphi, & 1062 & zmask, & 1063 & zseaicel & 1064 & ) 1065 1066 seaicedatqc%nsurfup = seaicedatqc%nsurfup + iseaice 1067 1068 END SUBROUTINE obs_seaice_opt 1069 1070 SUBROUTINE obs_vel_opt( prodatqc, kt, kpi, kpj, kpk, kit000, kdaystp, & 1071 & pun, pvn, pgdept, pumask, pvmask, k1dint, k2dint, & 1072 & ld_dailyav ) 1073 !!----------------------------------------------------------------------- 1074 !! 1075 !! *** ROUTINE obs_vel_opt *** 1076 !! 1077 !! ** Purpose : Compute the model counterpart of velocity profile 1078 !! data by interpolating from the model grid to the 1079 !! observation point. 1080 !! 1081 !! ** Method : Linearly interpolate zonal and meridional components of velocity 1082 !! to each observation point using the model values at the corners of 1083 !! the surrounding grid box. The model velocity components are on a 1084 !! staggered C- grid. 1085 !! 1086 !! For velocity data from the TAO array, the model equivalent is 1087 !! a daily mean velocity field. So, we first compute 1088 !! the mean, then interpolate only at the end of the day. 1089 !! 1090 !! ** Action : 1091 !! 1092 !! History : 1093 !! ! 07-03 (K. Mogensen) : Temperature and Salinity profiles 1094 !! ! 08-10 (Maria Valdivieso) : Velocity component (U,V) profiles 1095 !!----------------------------------------------------------------------- 1096 1097 !! * Modules used 1098 USE obs_profiles_def ! Definition of storage space for profile obs. 1099 1100 IMPLICIT NONE 1101 1102 !! * Arguments 1103 TYPE(obs_prof), INTENT(INOUT) :: & 1104 & prodatqc ! Subset of profile data not failing screening 1105 INTEGER, INTENT(IN) :: kt ! Time step 1106 INTEGER, INTENT(IN) :: kpi ! Model grid parameters 1107 INTEGER, INTENT(IN) :: kpj 1108 INTEGER, INTENT(IN) :: kpk 1109 INTEGER, INTENT(IN) :: kit000 ! Number of the first time step 1110 ! (kit000-1 = restart time) 1111 INTEGER, INTENT(IN) :: k1dint ! Vertical interpolation type (see header) 1112 INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation type (see header) 1113 INTEGER, INTENT(IN) :: kdaystp ! Number of time steps per day 1114 REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 1115 & pun, & ! Model zonal component of velocity 1116 & pvn, & ! Model meridional component of velocity 1117 & pumask, & ! Land-sea mask 1118 & pvmask ! Land-sea mask 1119 REAL(KIND=wp), INTENT(IN), DIMENSION(kpk) :: & 1120 & pgdept ! Model array of depth levels 1121 LOGICAL, INTENT(IN) :: ld_dailyav 1122 1123 !! * Local declarations 1124 INTEGER :: ji 1125 INTEGER :: jj 1126 INTEGER :: jk 1127 INTEGER :: jobs 1128 INTEGER :: inrc 1129 INTEGER :: ipro 1130 INTEGER :: idayend 1131 INTEGER :: ista 1132 INTEGER :: iend 1133 INTEGER :: iobs 1134 INTEGER, DIMENSION(imaxavtypes) :: & 1135 & idailyavtypes 1136 REAL(KIND=wp) :: zlam 1137 REAL(KIND=wp) :: zphi 1138 REAL(KIND=wp) :: zdaystp 1139 REAL(KIND=wp), DIMENSION(kpk) :: & 1140 & zobsmasku, & 1141 & zobsmaskv, & 1142 & zobsmask, & 1143 & zobsk, & 1144 & zobs2k 1145 REAL(KIND=wp), DIMENSION(2,2,kpk) :: & 1146 & zweigu,zweigv 1147 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 1148 & zumask, zvmask, & 1149 & zintu, & 1150 & zintv, & 1151 & zinmu, & 1152 & zinmv 1153 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 1154 & zglamu, zglamv, & 1155 & zgphiu, zgphiv 1156 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 1157 & igrdiu, & 1158 & igrdju, & 1159 & igrdiv, & 1160 & igrdjv 1161 1162 !------------------------------------------------------------------------ 1163 ! Local initialization 1164 !------------------------------------------------------------------------ 1165 ! ... Record and data counters 1166 inrc = kt - kit000 + 2 1167 ipro = prodatqc%npstp(inrc) 1168 1169 ! Initialize daily mean for first timestep 1170 idayend = MOD( kt - kit000 + 1, kdaystp ) 1171 1172 ! Added kt == 0 test to catch restart case 1173 IF ( idayend == 1 .OR. kt == 0) THEN 1174 IF (lwp) WRITE(numout,*) 'Reset prodatqc%vdmean on time-step: ',kt 1175 prodatqc%vdmean(:,:,:,1) = 0.0 1176 prodatqc%vdmean(:,:,:,2) = 0.0 1177 ENDIF 1178 1179 ! Increment the zonal velocity field for computing daily mean 1180 prodatqc%vdmean(:,:,:,1) = prodatqc%vdmean(:,:,:,1) + pun(:,:,:) 1181 ! Increment the meridional velocity field for computing daily mean 1182 prodatqc%vdmean(:,:,:,2) = prodatqc%vdmean(:,:,:,2) + pvn(:,:,:) 1183 1184 ! Compute the daily mean at the end of day 1185 zdaystp = 1.0 / REAL( kdaystp ) 1186 IF ( idayend == 0 ) THEN 1187 prodatqc%vdmean(:,:,:,1) = prodatqc%vdmean(:,:,:,1) * zdaystp 1188 prodatqc%vdmean(:,:,:,2) = prodatqc%vdmean(:,:,:,2) * zdaystp 1189 ENDIF 1190 1191 ! Get the data for interpolation 1192 ALLOCATE( & 1193 & igrdiu(2,2,ipro), & 1194 & igrdju(2,2,ipro), & 1195 & igrdiv(2,2,ipro), & 1196 & igrdjv(2,2,ipro), & 1197 & zglamu(2,2,ipro), zglamv(2,2,ipro), & 1198 & zgphiu(2,2,ipro), zgphiv(2,2,ipro), & 1199 & zumask(2,2,kpk,ipro), zvmask(2,2,kpk,ipro), & 1200 & zintu(2,2,kpk,ipro), & 1201 & zintv(2,2,kpk,ipro) & 1202 & ) 1203 1204 DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro 1205 iobs = jobs - prodatqc%nprofup 1206 igrdiu(1,1,iobs) = prodatqc%mi(jobs,1)-1 1207 igrdju(1,1,iobs) = prodatqc%mj(jobs,1)-1 1208 igrdiu(1,2,iobs) = prodatqc%mi(jobs,1)-1 1209 igrdju(1,2,iobs) = prodatqc%mj(jobs,1) 1210 igrdiu(2,1,iobs) = prodatqc%mi(jobs,1) 1211 igrdju(2,1,iobs) = prodatqc%mj(jobs,1)-1 1212 igrdiu(2,2,iobs) = prodatqc%mi(jobs,1) 1213 igrdju(2,2,iobs) = prodatqc%mj(jobs,1) 1214 igrdiv(1,1,iobs) = prodatqc%mi(jobs,2)-1 1215 igrdjv(1,1,iobs) = prodatqc%mj(jobs,2)-1 1216 igrdiv(1,2,iobs) = prodatqc%mi(jobs,2)-1 1217 igrdjv(1,2,iobs) = prodatqc%mj(jobs,2) 1218 igrdiv(2,1,iobs) = prodatqc%mi(jobs,2) 1219 igrdjv(2,1,iobs) = prodatqc%mj(jobs,2)-1 1220 igrdiv(2,2,iobs) = prodatqc%mi(jobs,2) 1221 igrdjv(2,2,iobs) = prodatqc%mj(jobs,2) 1222 END DO 1223 1224 CALL obs_int_comm_2d( 2, 2, ipro, igrdiu, igrdju, glamu, zglamu ) 1225 CALL obs_int_comm_2d( 2, 2, ipro, igrdiu, igrdju, gphiu, zgphiu ) 1226 CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdiu, igrdju, pumask, zumask ) 1227 CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdiu, igrdju, pun, zintu ) 1228 1229 CALL obs_int_comm_2d( 2, 2, ipro, igrdiv, igrdjv, glamv, zglamv ) 1230 CALL obs_int_comm_2d( 2, 2, ipro, igrdiv, igrdjv, gphiv, zgphiv ) 1231 CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdiv, igrdjv, pvmask, zvmask ) 1232 CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdiv, igrdjv, pvn, zintv ) 1233 1234 ! At the end of the day also get interpolated means 1235 IF ( idayend == 0 ) THEN 1236 1237 ALLOCATE( & 1238 & zinmu(2,2,kpk,ipro), & 1239 & zinmv(2,2,kpk,ipro) & 1240 & ) 1241 1242 CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdiu, igrdju, & 1243 & prodatqc%vdmean(:,:,:,1), zinmu ) 1244 CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdiv, igrdjv, & 1245 & prodatqc%vdmean(:,:,:,2), zinmv ) 1246 1247 ENDIF 1248 1249 ! loop over observations 1250 1251 DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro 1252 1253 iobs = jobs - prodatqc%nprofup 1254 1255 IF ( kt /= prodatqc%mstp(jobs) ) THEN 1256 1257 IF(lwp) THEN 1258 WRITE(numout,*) 1259 WRITE(numout,*) ' E R R O R : Observation', & 1260 & ' time step is not consistent with the', & 1261 & ' model time step' 1262 WRITE(numout,*) ' =========' 1263 WRITE(numout,*) 1264 WRITE(numout,*) ' Record = ', jobs, & 1265 & ' kt = ', kt, & 1266 & ' mstp = ', prodatqc%mstp(jobs), & 1267 & ' ntyp = ', prodatqc%ntyp(jobs) 1268 ENDIF 1269 CALL ctl_stop( 'obs_pro_opt', 'Inconsistent time' ) 1270 ENDIF 1271 1272 zlam = prodatqc%rlam(jobs) 1273 zphi = prodatqc%rphi(jobs) 1274 1275 ! Initialize observation masks 1276 1277 zobsmasku(:) = 0.0 1278 zobsmaskv(:) = 0.0 1279 1280 ! Horizontal weights and vertical mask 1281 1282 IF ( prodatqc%npvend(jobs,1) > 0 ) THEN 1283 1284 CALL obs_int_h2d_init( kpk, kpk, k2dint, zlam, zphi, & 1285 & zglamu(:,:,iobs), zgphiu(:,:,iobs), & 1286 & zumask(:,:,:,iobs), zweigu, zobsmasku ) 1287 1288 ENDIF 1289 1290 1291 IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 1292 1293 CALL obs_int_h2d_init( kpk, kpk, k2dint, zlam, zphi, & 1294 & zglamv(:,:,iobs), zgphiv(:,:,iobs), & 1295 & zvmask(:,:,:,iobs), zweigv, zobsmasku ) 1296 1297 ENDIF 1298 1299 ! Ensure that the vertical mask on u and v are consistent. 1300 1301 zobsmask(:) = MIN( zobsmasku(:), zobsmaskv(:) ) 1302 1303 IF ( prodatqc%npvend(jobs,1) > 0 ) THEN 1304 1305 zobsk(:) = obfillflt 1306 1307 IF ( ld_dailyav ) THEN 1308 1309 IF ( idayend == 0 ) THEN 1310 1311 ! Daily averaged data 1312 1313 CALL obs_int_h2d( kpk, kpk, & 1314 & zweigu, zinmu(:,:,:,iobs), zobsk ) 1315 1316 1317 ELSE 1318 1319 CALL ctl_stop( ' A nonzero' // & 1320 & ' number of U profile data should' // & 1321 & ' only occur at the end of a given day' ) 1322 1323 ENDIF 1324 1325 ELSE 1326 1327 ! Point data 1328 1329 CALL obs_int_h2d( kpk, kpk, & 1330 & zweigu, zintu(:,:,:,iobs), zobsk ) 1331 1332 ENDIF 1333 1334 !------------------------------------------------------------- 1335 ! Compute vertical second-derivative of the interpolating 1336 ! polynomial at obs points 1337 !------------------------------------------------------------- 1338 1339 IF ( k1dint == 1 ) THEN 1340 CALL obs_int_z1d_spl( kpk, zobsk, zobs2k, & 1341 & pgdept, zobsmask ) 1342 ENDIF 1343 1344 !----------------------------------------------------------------- 1345 ! Vertical interpolation to the observation point 1346 !----------------------------------------------------------------- 1347 ista = prodatqc%npvsta(jobs,1) 1348 iend = prodatqc%npvend(jobs,1) 1349 CALL obs_int_z1d( kpk, & 1350 & prodatqc%var(1)%mvk(ista:iend), & 1351 & k1dint, iend - ista + 1, & 1352 & prodatqc%var(1)%vdep(ista:iend), & 1353 & zobsk, zobs2k, & 1354 & prodatqc%var(1)%vmod(ista:iend), & 1355 & pgdept, zobsmask ) 1356 1357 ENDIF 1358 1359 IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 1360 1361 zobsk(:) = obfillflt 1362 1363 IF ( ld_dailyav ) THEN 1364 1365 IF ( idayend == 0 ) THEN 1366 1367 ! Daily averaged data 1368 1369 CALL obs_int_h2d( kpk, kpk, & 1370 & zweigv, zinmv(:,:,:,iobs), zobsk ) 1371 1372 ELSE 1373 1374 CALL ctl_stop( ' A nonzero' // & 1375 & ' number of V profile data should' // & 1376 & ' only occur at the end of a given day' ) 1377 1378 ENDIF 1379 1380 ELSE 1381 1382 ! Point data 1383 1384 CALL obs_int_h2d( kpk, kpk, & 1385 & zweigv, zintv(:,:,:,iobs), zobsk ) 1386 1387 ENDIF 1388 1389 1390 !------------------------------------------------------------- 1391 ! Compute vertical second-derivative of the interpolating 1392 ! polynomial at obs points 1393 !------------------------------------------------------------- 1394 1395 IF ( k1dint == 1 ) THEN 1396 CALL obs_int_z1d_spl( kpk, zobsk, zobs2k, & 1397 & pgdept, zobsmask ) 1398 ENDIF 1399 1400 !---------------------------------------------------------------- 1401 ! Vertical interpolation to the observation point 1402 !---------------------------------------------------------------- 1403 ista = prodatqc%npvsta(jobs,2) 1404 iend = prodatqc%npvend(jobs,2) 1405 CALL obs_int_z1d( kpk, & 1406 & prodatqc%var(2)%mvk(ista:iend),& 1407 & k1dint, iend - ista + 1, & 1408 & prodatqc%var(2)%vdep(ista:iend),& 1409 & zobsk, zobs2k, & 1410 & prodatqc%var(2)%vmod(ista:iend),& 1411 & pgdept, zobsmask ) 1412 1413 ENDIF 1414 1415 END DO 1416 1417 ! Deallocate the data for interpolation 1418 DEALLOCATE( & 1419 & igrdiu, & 1420 & igrdju, & 1421 & igrdiv, & 1422 & igrdjv, & 1423 & zglamu, zglamv, & 1424 & zgphiu, zgphiv, & 1425 & zumask, zvmask, & 1426 & zintu, & 1427 & zintv & 1428 & ) 1429 ! At the end of the day also get interpolated means 1430 IF ( idayend == 0 ) THEN 1431 DEALLOCATE( & 1432 & zinmu, & 1433 & zinmv & 1434 & ) 1435 ENDIF 1436 1437 prodatqc%nprofup = prodatqc%nprofup + ipro 1438 1439 END SUBROUTINE obs_vel_opt 829 830 surfdataqc%nsurfup = surfdataqc%nsurfup + isurf 831 832 END SUBROUTINE obs_surf_opt 1440 833 1441 834 END MODULE obs_oper 1442 -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/OBS/obs_prep.F90
r10246 r10247 7 7 8 8 !!--------------------------------------------------------------------- 9 !! obs_pre_pro : First level check and screening of T/S profiles 10 !! obs_pre_sla : First level check and screening of SLA observations 11 !! obs_pre_sst : First level check and screening of SLA observations 12 !! obs_pre_seaice : First level check and screening of sea ice observations 13 !! obs_pre_vel : First level check and screening of velocity obs. 14 !! obs_scr : Basic screening of the observations 15 !! obs_coo_tim : Compute number of time steps to the observation time 16 !! obs_sor : Sort the observation arrays 9 !! obs_pre_prof : First level check and screening of profile observations 10 !! obs_pre_surf : First level check and screening of surface observations 11 !! obs_scr : Basic screening of the observations 12 !! obs_coo_tim : Compute number of time steps to the observation time 13 !! obs_sor : Sort the observation arrays 17 14 !!--------------------------------------------------------------------- 18 15 !! * Modules used … … 27 24 USE obs_inter_sup ! Interpolation support 28 25 USE obs_oper ! Observation operators 26 #if defined key_bdy 27 USE bdy_oce, ONLY : & ! Boundary information 28 idx_bdy, nb_bdy 29 #endif 29 30 USE lib_mpp, ONLY : & 30 31 & ctl_warn, ctl_stop … … 36 37 37 38 PUBLIC & 38 & obs_pre_pro, & ! First level check and screening of profiles 39 & obs_pre_sla, & ! First level check and screening of SLA data 40 & obs_pre_sst, & ! First level check and screening of SLA data 41 & obs_pre_seaice, & ! First level check and screening of sea ice data 42 & obs_pre_vel, & ! First level check and screening of velocity profiles 43 & calc_month_len ! Calculate the number of days in the months of a year 39 & obs_pre_prof, & ! First level check and screening of profile obs 40 & obs_pre_surf, & ! First level check and screening of surface obs 41 & calc_month_len ! Calculate the number of days in the months of a year 44 42 45 43 !!---------------------------------------------------------------------- … … 49 47 !!---------------------------------------------------------------------- 50 48 49 !! * Substitutions 50 # include "domzgr_substitute.h90" 51 51 52 CONTAINS 52 53 53 SUBROUTINE obs_pre_pro( profdata, prodatqc, ld_t3d, ld_s3d, ld_nea, & 54 & kdailyavtypes ) 55 !!---------------------------------------------------------------------- 56 !! *** ROUTINE obs_pre_pro *** 57 !! 58 !! ** Purpose : First level check and screening of T and S profiles 59 !! 60 !! ** Method : First level check and screening of T and S profiles 61 !! 62 !! ** Action : 63 !! 64 !! References : 65 !! 66 !! History : 67 !! ! 2007-01 (K. Mogensen) Merge of obs_pre_t3d and obs_pre_s3d 68 !! ! 2007-03 (K. Mogensen) General handling of profiles 69 !! ! 2007-06 (K. Mogensen et al) Reject obs. near land. 70 !!---------------------------------------------------------------------- 71 !! * Modules used 72 USE domstp ! Domain: set the time-step 73 USE par_oce ! Ocean parameters 74 USE dom_oce, ONLY : & ! Geographical information 75 & glamt, & 76 & gphit, & 77 & gdept_1d,& 78 & tmask, & 79 & nproc 80 !! * Arguments 81 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data 82 TYPE(obs_prof), INTENT(INOUT) :: prodatqc ! Subset of profile data not failing screening 83 LOGICAL, INTENT(IN) :: ld_t3d ! Switch for temperature 84 LOGICAL, INTENT(IN) :: ld_s3d ! Switch for salinity 85 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 86 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 87 & kdailyavtypes! Types for daily averages 88 !! * Local declarations 89 INTEGER :: iyea0 ! Initial date 90 INTEGER :: imon0 ! - (year, month, day, hour, minute) 91 INTEGER :: iday0 92 INTEGER :: ihou0 93 INTEGER :: imin0 94 INTEGER :: icycle ! Current assimilation cycle 95 ! Counters for observations that 96 INTEGER :: iotdobs ! - outside time domain 97 INTEGER :: iosdtobs ! - outside space domain (temperature) 98 INTEGER :: iosdsobs ! - outside space domain (salinity) 99 INTEGER :: ilantobs ! - within a model land cell (temperature) 100 INTEGER :: ilansobs ! - within a model land cell (salinity) 101 INTEGER :: inlatobs ! - close to land (temperature) 102 INTEGER :: inlasobs ! - close to land (salinity) 103 INTEGER :: igrdobs ! - fail the grid search 104 ! Global counters for observations that 105 INTEGER :: iotdobsmpp ! - outside time domain 106 INTEGER :: iosdtobsmpp ! - outside space domain (temperature) 107 INTEGER :: iosdsobsmpp ! - outside space domain (salinity) 108 INTEGER :: ilantobsmpp ! - within a model land cell (temperature) 109 INTEGER :: ilansobsmpp ! - within a model land cell (salinity) 110 INTEGER :: inlatobsmpp ! - close to land (temperature) 111 INTEGER :: inlasobsmpp ! - close to land (salinity) 112 INTEGER :: igrdobsmpp ! - fail the grid search 113 TYPE(obs_prof_valid) :: llvalid ! Profile selection 114 TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & 115 & llvvalid ! T,S selection 116 INTEGER :: jvar ! Variable loop variable 117 INTEGER :: jobs ! Obs. loop variable 118 INTEGER :: jstp ! Time loop variable 119 INTEGER :: inrc ! Time index variable 120 121 IF(lwp) WRITE(numout,*)'obs_pre_pro : Preparing the profile observations...' 122 123 ! Initial date initialization (year, month, day, hour, minute) 124 iyea0 = ndate0 / 10000 125 imon0 = ( ndate0 - iyea0 * 10000 ) / 100 126 iday0 = ndate0 - iyea0 * 10000 - imon0 * 100 127 ihou0 = 0 128 imin0 = 0 129 130 icycle = no ! Assimilation cycle 131 132 ! Diagnotics counters for various failures. 133 134 iotdobs = 0 135 igrdobs = 0 136 iosdtobs = 0 137 iosdsobs = 0 138 ilantobs = 0 139 ilansobs = 0 140 inlatobs = 0 141 inlasobs = 0 142 143 ! ----------------------------------------------------------------------- 144 ! Find time coordinate for profiles 145 ! ----------------------------------------------------------------------- 146 147 IF ( PRESENT(kdailyavtypes) ) THEN 148 CALL obs_coo_tim_prof( icycle, & 149 & iyea0, imon0, iday0, ihou0, imin0, & 150 & profdata%nprof, profdata%nyea, profdata%nmon, & 151 & profdata%nday, profdata%nhou, profdata%nmin, & 152 & profdata%ntyp, profdata%nqc, profdata%mstp, & 153 & iotdobs, kdailyavtypes = kdailyavtypes ) 154 ELSE 155 CALL obs_coo_tim_prof( icycle, & 156 & iyea0, imon0, iday0, ihou0, imin0, & 157 & profdata%nprof, profdata%nyea, profdata%nmon, & 158 & profdata%nday, profdata%nhou, profdata%nmin, & 159 & profdata%ntyp, profdata%nqc, profdata%mstp, & 160 & iotdobs ) 161 ENDIF 162 CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) 163 164 ! ----------------------------------------------------------------------- 165 ! Check for profiles failing the grid search 166 ! ----------------------------------------------------------------------- 167 168 CALL obs_coo_grd( profdata%nprof, profdata%mi, profdata%mj, & 169 & profdata%nqc, igrdobs ) 170 171 CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) 172 173 ! ----------------------------------------------------------------------- 174 ! Reject all observations for profiles with nqc > 10 175 ! ----------------------------------------------------------------------- 176 177 CALL obs_pro_rej( profdata ) 178 179 ! ----------------------------------------------------------------------- 180 ! Check for land points. This includes points below the model 181 ! bathymetry so this is done for every point in the profile 182 ! ----------------------------------------------------------------------- 183 184 ! Temperature 185 186 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(1), & 187 & profdata%npvsta(:,1), profdata%npvend(:,1), & 188 & jpi, jpj, & 189 & jpk, & 190 & profdata%mi, profdata%mj, & 191 & profdata%var(1)%mvk, & 192 & profdata%rlam, profdata%rphi, & 193 & profdata%var(1)%vdep, & 194 & glamt, gphit, & 195 & gdept_1d, tmask, & 196 & profdata%nqc, profdata%var(1)%nvqc, & 197 & iosdtobs, ilantobs, & 198 & inlatobs, ld_nea ) 199 200 CALL obs_mpp_sum_integer( iosdtobs, iosdtobsmpp ) 201 CALL obs_mpp_sum_integer( ilantobs, ilantobsmpp ) 202 CALL obs_mpp_sum_integer( inlatobs, inlatobsmpp ) 203 204 ! Salinity 205 206 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(2), & 207 & profdata%npvsta(:,2), profdata%npvend(:,2), & 208 & jpi, jpj, & 209 & jpk, & 210 & profdata%mi, profdata%mj, & 211 & profdata%var(2)%mvk, & 212 & profdata%rlam, profdata%rphi, & 213 & profdata%var(2)%vdep, & 214 & glamt, gphit, & 215 & gdept_1d, tmask, & 216 & profdata%nqc, profdata%var(2)%nvqc, & 217 & iosdsobs, ilansobs, & 218 & inlasobs, ld_nea ) 219 220 CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) 221 CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) 222 CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) 223 224 ! ----------------------------------------------------------------------- 225 ! Copy useful data from the profdata data structure to 226 ! the prodatqc data structure 227 ! ----------------------------------------------------------------------- 228 229 ! Allocate the selection arrays 230 231 ALLOCATE( llvalid%luse(profdata%nprof) ) 232 DO jvar = 1,profdata%nvar 233 ALLOCATE( llvvalid(jvar)%luse(profdata%nvprot(jvar)) ) 234 END DO 235 236 ! We want all data which has qc flags <= 10 237 238 llvalid%luse(:) = ( profdata%nqc(:) <= 10 ) 239 DO jvar = 1,profdata%nvar 240 llvvalid(jvar)%luse(:) = ( profdata%var(jvar)%nvqc(:) <= 10 ) 241 END DO 242 243 ! The actual copying 244 245 CALL obs_prof_compress( profdata, prodatqc, .TRUE., numout, & 246 & lvalid=llvalid, lvvalid=llvvalid ) 247 248 ! Dellocate the selection arrays 249 DEALLOCATE( llvalid%luse ) 250 DO jvar = 1,profdata%nvar 251 DEALLOCATE( llvvalid(jvar)%luse ) 252 END DO 253 254 ! ----------------------------------------------------------------------- 255 ! Print information about what observations are left after qc 256 ! ----------------------------------------------------------------------- 257 258 ! Update the total observation counter array 259 260 IF(lwp) THEN 261 WRITE(numout,*) 262 WRITE(numout,*) 'obs_pre_pro :' 263 WRITE(numout,*) '~~~~~~~~~~~' 264 WRITE(numout,*) 265 WRITE(numout,*) ' Profiles outside time domain = ', & 266 & iotdobsmpp 267 WRITE(numout,*) ' Remaining profiles that failed grid search = ', & 268 & igrdobsmpp 269 WRITE(numout,*) ' Remaining T data outside space domain = ', & 270 & iosdtobsmpp 271 WRITE(numout,*) ' Remaining T data at land points = ', & 272 & ilantobsmpp 273 IF (ld_nea) THEN 274 WRITE(numout,*) ' Remaining T data near land points (removed) = ',& 275 & inlatobsmpp 276 ELSE 277 WRITE(numout,*) ' Remaining T data near land points (kept) = ',& 278 & inlatobsmpp 279 ENDIF 280 WRITE(numout,*) ' T data accepted = ', & 281 & prodatqc%nvprotmpp(1) 282 WRITE(numout,*) ' Remaining S data outside space domain = ', & 283 & iosdsobsmpp 284 WRITE(numout,*) ' Remaining S data at land points = ', & 285 & ilansobsmpp 286 IF (ld_nea) THEN 287 WRITE(numout,*) ' Remaining S data near land points (removed) = ',& 288 & inlasobsmpp 289 ELSE 290 WRITE(numout,*) ' Remaining S data near land points (kept) = ',& 291 & inlasobsmpp 292 ENDIF 293 WRITE(numout,*) ' S data accepted = ', & 294 & prodatqc%nvprotmpp(2) 295 296 WRITE(numout,*) 297 WRITE(numout,*) ' Number of observations per time step :' 298 WRITE(numout,*) 299 WRITE(numout,997) 300 WRITE(numout,998) 301 ENDIF 302 303 DO jobs = 1, prodatqc%nprof 304 inrc = prodatqc%mstp(jobs) + 2 - nit000 305 prodatqc%npstp(inrc) = prodatqc%npstp(inrc) + 1 306 DO jvar = 1, prodatqc%nvar 307 IF ( prodatqc%npvend(jobs,jvar) > 0 ) THEN 308 prodatqc%nvstp(inrc,jvar) = prodatqc%nvstp(inrc,jvar) + & 309 & ( prodatqc%npvend(jobs,jvar) - & 310 & prodatqc%npvsta(jobs,jvar) + 1 ) 311 ENDIF 312 END DO 313 END DO 314 315 316 CALL obs_mpp_sum_integers( prodatqc%npstp, prodatqc%npstpmpp, & 317 & nitend - nit000 + 2 ) 318 DO jvar = 1, prodatqc%nvar 319 CALL obs_mpp_sum_integers( prodatqc%nvstp(:,jvar), & 320 & prodatqc%nvstpmpp(:,jvar), & 321 & nitend - nit000 + 2 ) 322 END DO 323 324 IF ( lwp ) THEN 325 DO jstp = nit000 - 1, nitend 326 inrc = jstp - nit000 + 2 327 WRITE(numout,999) jstp, prodatqc%npstpmpp(inrc), & 328 & prodatqc%nvstpmpp(inrc,1), & 329 & prodatqc%nvstpmpp(inrc,2) 330 END DO 331 ENDIF 332 333 997 FORMAT(10X,'Time step',5X,'Profiles',5X,'Temperature',5X,'Salinity') 334 998 FORMAT(10X,'---------',5X,'--------',5X,'-----------',5X,'--------') 335 999 FORMAT(10X,I9,5X,I8,5X,I11,5X,I8) 336 337 END SUBROUTINE obs_pre_pro 338 339 SUBROUTINE obs_pre_sla( sladata, sladatqc, ld_sla, ld_nea ) 54 SUBROUTINE obs_pre_surf( surfdata, surfdataqc, ld_nea, ld_bound_reject, & 55 kqc_cutoff ) 340 56 !!---------------------------------------------------------------------- 341 57 !! *** ROUTINE obs_pre_sla *** 342 58 !! 343 !! ** Purpose : First level check and screening of SLAobservations344 !! 345 !! ** Method : First level check and screening of SLAobservations59 !! ** Purpose : First level check and screening of surface observations 60 !! 61 !! ** Method : First level check and screening of surface observations 346 62 !! 347 63 !! ** Action : … … 352 68 !! ! 2007-03 (A. Weaver, K. Mogensen) Original 353 69 !! ! 2007-06 (K. Mogensen et al) Reject obs. near land. 70 !! ! 2015-02 (M. Martin) Combined routine for surface types. 354 71 !!---------------------------------------------------------------------- 355 72 !! * Modules used … … 362 79 & nproc 363 80 !! * Arguments 364 TYPE(obs_surf), INTENT(INOUT) :: sladata ! Full set of SLA data 365 TYPE(obs_surf), INTENT(INOUT) :: sladatqc ! Subset of SLA data not failing screening 366 LOGICAL, INTENT(IN) :: ld_sla ! Switch for SLA data 367 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 81 TYPE(obs_surf), INTENT(INOUT) :: surfdata ! Full set of surface data 82 TYPE(obs_surf), INTENT(INOUT) :: surfdataqc ! Subset of surface data not failing screening 83 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 84 LOGICAL, INTENT(IN) :: ld_bound_reject ! Switch for rejecting obs near the boundary 85 INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff ! cut off for QC value 368 86 !! * Local declarations 87 INTEGER :: iqc_cutoff = 255 ! cut off for QC value 369 88 INTEGER :: iyea0 ! Initial date 370 89 INTEGER :: imon0 ! - (year, month, day, hour, minute) … … 379 98 INTEGER :: inlasobs ! - close to land 380 99 INTEGER :: igrdobs ! - fail the grid search 100 INTEGER :: ibdysobs ! - close to open boundary 381 101 ! Global counters for observations that 382 102 INTEGER :: iotdobsmpp ! - outside time domain … … 385 105 INTEGER :: inlasobsmpp ! - close to land 386 106 INTEGER :: igrdobsmpp ! - fail the grid search 107 INTEGER :: ibdysobsmpp ! - close to open boundary 387 108 LOGICAL, DIMENSION(:), ALLOCATABLE :: & 388 109 & llvalid ! SLA data selection … … 391 112 INTEGER :: inrc ! Time index variable 392 113 393 IF(lwp) WRITE(numout,*)'obs_pre_sla : Preparing the SLA observations...' 394 114 IF(lwp) WRITE(numout,*)'obs_pre_surf : Preparing the surface observations...' 115 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 116 395 117 ! Initial date initialization (year, month, day, hour, minute) 396 118 iyea0 = ndate0 / 10000 … … 409 131 ilansobs = 0 410 132 inlasobs = 0 411 412 ! ----------------------------------------------------------------------- 413 ! Find time coordinate for SLA data 133 ibdysobs = 0 134 135 ! Set QC cutoff to optional value if provided 136 IF ( PRESENT(kqc_cutoff) ) iqc_cutoff=kqc_cutoff 137 138 ! ----------------------------------------------------------------------- 139 ! Find time coordinate for surface data 414 140 ! ----------------------------------------------------------------------- 415 141 416 142 CALL obs_coo_tim( icycle, & 417 143 & iyea0, imon0, iday0, ihou0, imin0, & 418 & s ladata%nsurf, sladata%nyea, sladata%nmon, &419 & s ladata%nday, sladata%nhou, sladata%nmin, &420 & s ladata%nqc, sladata%mstp, iotdobs )144 & surfdata%nsurf, surfdata%nyea, surfdata%nmon, & 145 & surfdata%nday, surfdata%nhou, surfdata%nmin, & 146 & surfdata%nqc, surfdata%mstp, iotdobs ) 421 147 422 148 CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) 423 149 424 150 ! ----------------------------------------------------------------------- 425 ! Check for SLAdata failing the grid search426 ! ----------------------------------------------------------------------- 427 428 CALL obs_coo_grd( s ladata%nsurf, sladata%mi, sladata%mj, &429 & s ladata%nqc, igrdobs )151 ! Check for surface data failing the grid search 152 ! ----------------------------------------------------------------------- 153 154 CALL obs_coo_grd( surfdata%nsurf, surfdata%mi, surfdata%mj, & 155 & surfdata%nqc, igrdobs ) 430 156 431 157 CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) … … 435 161 ! ----------------------------------------------------------------------- 436 162 437 CALL obs_coo_spc_2d( s ladata%nsurf, &163 CALL obs_coo_spc_2d( surfdata%nsurf, & 438 164 & jpi, jpj, & 439 & s ladata%mi, sladata%mj, &440 & s ladata%rlam, sladata%rphi, &165 & surfdata%mi, surfdata%mj, & 166 & surfdata%rlam, surfdata%rphi, & 441 167 & glamt, gphit, & 442 & tmask(:,:,1), s ladata%nqc, &168 & tmask(:,:,1), surfdata%nqc, & 443 169 & iosdsobs, ilansobs, & 444 & inlasobs, ld_nea ) 170 & inlasobs, ld_nea, & 171 & ibdysobs, ld_bound_reject, & 172 & iqc_cutoff ) 445 173 446 174 CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) 447 175 CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) 448 176 CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) 449 450 ! ----------------------------------------------------------------------- 451 ! Copy useful data from the sladata data structure to 452 ! the sladatqc data structure 177 CALL obs_mpp_sum_integer( ibdysobs, ibdysobsmpp ) 178 179 ! ----------------------------------------------------------------------- 180 ! Copy useful data from the surfdata data structure to 181 ! the surfdataqc data structure 453 182 ! ----------------------------------------------------------------------- 454 183 455 184 ! Allocate the selection arrays 456 185 457 ALLOCATE( llvalid(s ladata%nsurf) )458 459 ! We want all data which has qc flags <= 10460 461 llvalid(:) = ( s ladata%nqc(:) <= 10)186 ALLOCATE( llvalid(surfdata%nsurf) ) 187 188 ! We want all data which has qc flags <= iqc_cutoff 189 190 llvalid(:) = ( surfdata%nqc(:) <= iqc_cutoff ) 462 191 463 192 ! The actual copying 464 193 465 CALL obs_surf_compress( s ladata, sladatqc, .TRUE., numout, &194 CALL obs_surf_compress( surfdata, surfdataqc, .TRUE., numout, & 466 195 & lvalid=llvalid ) 467 196 … … 477 206 IF(lwp) THEN 478 207 WRITE(numout,*) 479 WRITE(numout,*) 'obs_pre_sla :' 480 WRITE(numout,*) '~~~~~~~~~~~' 481 WRITE(numout,*) 482 WRITE(numout,*) ' SLA data outside time domain = ', & 208 WRITE(numout,*) ' '//surfdataqc%cvars(1)//' data outside time domain = ', & 483 209 & iotdobsmpp 484 WRITE(numout,*) ' Remaining SLAdata that failed grid search = ', &210 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data that failed grid search = ', & 485 211 & igrdobsmpp 486 WRITE(numout,*) ' Remaining SLAdata outside space domain = ', &212 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data outside space domain = ', & 487 213 & iosdsobsmpp 488 WRITE(numout,*) ' Remaining SLAdata at land points = ', &214 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data at land points = ', & 489 215 & ilansobsmpp 490 216 IF (ld_nea) THEN 491 WRITE(numout,*) ' Remaining SLAdata near land points (removed) = ', &217 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near land points (removed) = ', & 492 218 & inlasobsmpp 493 219 ELSE 494 WRITE(numout,*) ' Remaining SLAdata near land points (kept) = ', &220 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near land points (kept) = ', & 495 221 & inlasobsmpp 496 222 ENDIF 497 WRITE(numout,*) ' SLA data accepted = ', & 498 & sladatqc%nsurfmpp 223 WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near open boundary (removed) = ', & 224 & ibdysobsmpp 225 WRITE(numout,*) ' '//surfdataqc%cvars(1)//' data accepted = ', & 226 & surfdataqc%nsurfmpp 499 227 500 228 WRITE(numout,*) 501 229 WRITE(numout,*) ' Number of observations per time step :' 502 230 WRITE(numout,*) 503 WRITE(numout,1997) 504 WRITE(numout,1998) 231 WRITE(numout,'(10X,A,10X,A)')'Time step',surfdataqc%cvars(1) 232 WRITE(numout,'(10X,A,5X,A)')'---------','-----------------' 233 CALL FLUSH(numout) 505 234 ENDIF 506 235 507 DO jobs = 1, s ladatqc%nsurf508 inrc = s ladatqc%mstp(jobs) + 2 - nit000509 s ladatqc%nsstp(inrc) = sladatqc%nsstp(inrc) + 1510 END DO 511 512 CALL obs_mpp_sum_integers( s ladatqc%nsstp, sladatqc%nsstpmpp, &236 DO jobs = 1, surfdataqc%nsurf 237 inrc = surfdataqc%mstp(jobs) + 2 - nit000 238 surfdataqc%nsstp(inrc) = surfdataqc%nsstp(inrc) + 1 239 END DO 240 241 CALL obs_mpp_sum_integers( surfdataqc%nsstp, surfdataqc%nsstpmpp, & 513 242 & nitend - nit000 + 2 ) 514 243 … … 516 245 DO jstp = nit000 - 1, nitend 517 246 inrc = jstp - nit000 + 2 518 WRITE(numout,1999) jstp, sladatqc%nsstpmpp(inrc) 247 WRITE(numout,1999) jstp, surfdataqc%nsstpmpp(inrc) 248 CALL FLUSH(numout) 519 249 END DO 520 250 ENDIF 521 251 522 1997 FORMAT(10X,'Time step',5X,'Sea level anomaly')523 1998 FORMAT(10X,'---------',5X,'-----------------')524 252 1999 FORMAT(10X,I9,5X,I17) 525 253 526 END SUBROUTINE obs_pre_sla 527 528 SUBROUTINE obs_pre_sst( sstdata, sstdatqc, ld_sst, ld_nea ) 529 !!---------------------------------------------------------------------- 530 !! *** ROUTINE obs_pre_sst *** 531 !! 532 !! ** Purpose : First level check and screening of SST observations 533 !! 534 !! ** Method : First level check and screening of SST observations 535 !! 536 !! ** Action : 537 !! 538 !! References : 539 !! 254 END SUBROUTINE obs_pre_surf 255 256 257 SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var, & 258 & kpi, kpj, kpk, & 259 & zmask, pglam, pgphi, & 260 & ld_nea, ld_bound_reject, kdailyavtypes, kqc_cutoff ) 261 262 !!---------------------------------------------------------------------- 263 !! *** ROUTINE obs_pre_prof *** 264 !! 265 !! ** Purpose : First level check and screening of profiles 266 !! 267 !! ** Method : First level check and screening of profiles 268 !! 540 269 !! History : 541 !! ! 2007-03 (S. Ricci) SST data preparation 270 !! ! 2007-06 (K. Mogensen) original : T and S profile data 271 !! ! 2008-09 (M. Valdivieso) : TAO velocity data 272 !! ! 2009-01 (K. Mogensen) : New feedback stricture 273 !! ! 2015-02 (M. Martin) : Combined profile routine. 274 !! 542 275 !!---------------------------------------------------------------------- 543 276 !! * Modules used … … 545 278 USE par_oce ! Ocean parameters 546 279 USE dom_oce, ONLY : & ! Geographical information 547 & glamt, & 548 & gphit, & 549 & tmask, & 280 & gdept_1d, & 550 281 & nproc 282 551 283 !! * Arguments 552 TYPE(obs_surf), INTENT(INOUT) :: sstdata ! Full set of SST data 553 TYPE(obs_surf), INTENT(INOUT) :: sstdatqc ! Subset of SST data not failing screening 554 LOGICAL :: ld_sst ! Switch for SST data 555 LOGICAL :: ld_nea ! Switch for rejecting observation near land 284 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data 285 TYPE(obs_prof), INTENT(INOUT) :: prodatqc ! Subset of profile data not failing screening 286 LOGICAL, DIMENSION(profdata%nvar), INTENT(IN) :: & 287 & ld_var ! Observed variables switches 288 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 289 LOGICAL, INTENT(IN) :: ld_bound_reject ! Switch for rejecting observations near the boundary 290 INTEGER, INTENT(IN) :: kpi, kpj, kpk ! Local domain sizes 291 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 292 & kdailyavtypes ! Types for daily averages 293 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk,profdata%nvar) :: & 294 & zmask 295 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,profdata%nvar) :: & 296 & pglam, & 297 & pgphi 298 INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff ! cut off for QC value 299 556 300 !! * Local declarations 301 INTEGER :: iqc_cutoff = 255 ! cut off for QC value 557 302 INTEGER :: iyea0 ! Initial date 558 303 INTEGER :: imon0 ! - (year, month, day, hour, minute) 559 INTEGER :: iday0 304 INTEGER :: iday0 560 305 INTEGER :: ihou0 561 306 INTEGER :: imin0 562 307 INTEGER :: icycle ! Current assimilation cycle 563 ! Counters for observations that 564 INTEGER :: iotdobs ! - outside time domain 565 INTEGER :: iosdsobs ! - outside space domain 566 INTEGER :: ilansobs ! - within a model land cell 567 INTEGER :: inlasobs ! - close to land 568 INTEGER :: igrdobs ! - fail the grid search 569 ! Global counters for observations that 570 INTEGER :: iotdobsmpp ! - outside time domain 571 INTEGER :: iosdsobsmpp ! - outside space domain 572 INTEGER :: ilansobsmpp ! - within a model land cell 573 INTEGER :: inlasobsmpp ! - close to land 574 INTEGER :: igrdobsmpp ! - fail the grid search 575 LOGICAL, DIMENSION(:), ALLOCATABLE :: & 576 & llvalid ! SST data selection 308 ! Counters for observations that are 309 INTEGER :: iotdobs ! - outside time domain 310 INTEGER, DIMENSION(profdata%nvar) :: iosdvobs ! - outside space domain 311 INTEGER, DIMENSION(profdata%nvar) :: ilanvobs ! - within a model land cell 312 INTEGER, DIMENSION(profdata%nvar) :: inlavobs ! - close to land 313 INTEGER, DIMENSION(profdata%nvar) :: ibdyvobs ! - boundary 314 INTEGER :: igrdobs ! - fail the grid search 315 INTEGER :: iuvchku ! - reject UVEL if VVEL rejected 316 INTEGER :: iuvchkv ! - reject VVEL if UVEL rejected 317 ! Global counters for observations that are 318 INTEGER :: iotdobsmpp ! - outside time domain 319 INTEGER, DIMENSION(profdata%nvar) :: iosdvobsmpp ! - outside space domain 320 INTEGER, DIMENSION(profdata%nvar) :: ilanvobsmpp ! - within a model land cell 321 INTEGER, DIMENSION(profdata%nvar) :: inlavobsmpp ! - close to land 322 INTEGER, DIMENSION(profdata%nvar) :: ibdyvobsmpp ! - boundary 323 INTEGER :: igrdobsmpp ! - fail the grid search 324 INTEGER :: iuvchkumpp ! - reject UVEL if VVEL rejected 325 INTEGER :: iuvchkvmpp ! - reject VVEL if UVEL rejected 326 TYPE(obs_prof_valid) :: llvalid ! Profile selection 327 TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & 328 & llvvalid ! vars selection 329 INTEGER :: jvar ! Variable loop variable 577 330 INTEGER :: jobs ! Obs. loop variable 578 331 INTEGER :: jstp ! Time loop variable 579 332 INTEGER :: inrc ! Time index variable 580 581 IF(lwp) WRITE(numout,*)'obs_pre_sst : Preparing the SST observations...' 333 CHARACTER(LEN=256) :: cout1 ! Diagnostic output line 334 CHARACTER(LEN=256) :: cout2 ! Diagnostic output line 335 336 IF(lwp) WRITE(numout,*)'obs_pre_prof: Preparing the profile data...' 337 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 582 338 583 339 ! Initial date initialization (year, month, day, hour, minute) … … 590 346 icycle = no ! Assimilation cycle 591 347 592 ! Diagnotics counters for various failures. 593 594 iotdobs = 0 595 igrdobs = 0 596 iosdsobs = 0 597 ilansobs = 0 598 inlasobs = 0 599 600 ! ----------------------------------------------------------------------- 601 ! Find time coordinate for SST data 602 ! ----------------------------------------------------------------------- 603 604 CALL obs_coo_tim( icycle, & 605 & iyea0, imon0, iday0, ihou0, imin0, & 606 & sstdata%nsurf, sstdata%nyea, sstdata%nmon, & 607 & sstdata%nday, sstdata%nhou, sstdata%nmin, & 608 & sstdata%nqc, sstdata%mstp, iotdobs ) 348 ! Diagnostics counters for various failures. 349 350 iotdobs = 0 351 igrdobs = 0 352 iosdvobs(:) = 0 353 ilanvobs(:) = 0 354 inlavobs(:) = 0 355 ibdyvobs(:) = 0 356 iuvchku = 0 357 iuvchkv = 0 358 359 360 ! Set QC cutoff to optional value if provided 361 IF ( PRESENT(kqc_cutoff) ) iqc_cutoff=kqc_cutoff 362 363 ! ----------------------------------------------------------------------- 364 ! Find time coordinate for profiles 365 ! ----------------------------------------------------------------------- 366 367 IF ( PRESENT(kdailyavtypes) ) THEN 368 CALL obs_coo_tim_prof( icycle, & 369 & iyea0, imon0, iday0, ihou0, imin0, & 370 & profdata%nprof, profdata%nyea, profdata%nmon, & 371 & profdata%nday, profdata%nhou, profdata%nmin, & 372 & profdata%ntyp, profdata%nqc, profdata%mstp, & 373 & iotdobs, kdailyavtypes = kdailyavtypes, & 374 & kqc_cutoff = iqc_cutoff ) 375 ELSE 376 CALL obs_coo_tim_prof( icycle, & 377 & iyea0, imon0, iday0, ihou0, imin0, & 378 & profdata%nprof, profdata%nyea, profdata%nmon, & 379 & profdata%nday, profdata%nhou, profdata%nmin, & 380 & profdata%ntyp, profdata%nqc, profdata%mstp, & 381 & iotdobs, kqc_cutoff = iqc_cutoff ) 382 ENDIF 383 609 384 CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) 610 ! ----------------------------------------------------------------------- 611 ! Check for SST data failing the grid search 612 ! ----------------------------------------------------------------------- 613 614 CALL obs_coo_grd( sstdata%nsurf, sstdata%mi, sstdata%mj, & 615 & sstdata%nqc, igrdobs ) 385 386 ! ----------------------------------------------------------------------- 387 ! Check for profiles failing the grid search 388 ! ----------------------------------------------------------------------- 389 390 DO jvar = 1, profdata%nvar 391 CALL obs_coo_grd( profdata%nprof, profdata%mi(:,jvar), profdata%mj(:,jvar), & 392 & profdata%nqc, igrdobs ) 393 END DO 394 616 395 CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) 617 396 618 397 ! ----------------------------------------------------------------------- 619 ! Check for land points. 620 ! ----------------------------------------------------------------------- 621 622 CALL obs_coo_spc_2d( sstdata%nsurf, & 623 & jpi, jpj, & 624 & sstdata%mi, sstdata%mj, & 625 & sstdata%rlam, sstdata%rphi, & 626 & glamt, gphit, & 627 & tmask(:,:,1), sstdata%nqc, & 628 & iosdsobs, ilansobs, & 629 & inlasobs, ld_nea ) 630 631 CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) 632 CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) 633 CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) 634 635 ! ----------------------------------------------------------------------- 636 ! Copy useful data from the sstdata data structure to 637 ! the sstdatqc data structure 638 ! ----------------------------------------------------------------------- 639 640 ! Allocate the selection arrays 641 642 ALLOCATE( llvalid(sstdata%nsurf) ) 643 644 ! We want all data which has qc flags <= 0 645 646 llvalid(:) = ( sstdata%nqc(:) <= 10 ) 647 648 ! The actual copying 649 650 CALL obs_surf_compress( sstdata, sstdatqc, .TRUE., numout, & 651 & lvalid=llvalid ) 652 653 ! Dellocate the selection arrays 654 DEALLOCATE( llvalid ) 655 656 ! ----------------------------------------------------------------------- 657 ! Print information about what observations are left after qc 658 ! ----------------------------------------------------------------------- 659 660 ! Update the total observation counter array 661 662 IF(lwp) THEN 663 WRITE(numout,*) 664 WRITE(numout,*) 'obs_pre_sst :' 665 WRITE(numout,*) '~~~~~~~~~~~' 666 WRITE(numout,*) 667 WRITE(numout,*) ' SST data outside time domain = ', & 668 & iotdobsmpp 669 WRITE(numout,*) ' Remaining SST data that failed grid search = ', & 670 & igrdobsmpp 671 WRITE(numout,*) ' Remaining SST data outside space domain = ', & 672 & iosdsobsmpp 673 WRITE(numout,*) ' Remaining SST data at land points = ', & 674 & ilansobsmpp 675 IF (ld_nea) THEN 676 WRITE(numout,*) ' Remaining SST data near land points (removed) = ', & 677 & inlasobsmpp 678 ELSE 679 WRITE(numout,*) ' Remaining SST data near land points (kept) = ', & 680 & inlasobsmpp 681 ENDIF 682 WRITE(numout,*) ' SST data accepted = ', & 683 & sstdatqc%nsurfmpp 684 685 WRITE(numout,*) 686 WRITE(numout,*) ' Number of observations per time step :' 687 WRITE(numout,*) 688 WRITE(numout,1997) 689 WRITE(numout,1998) 690 ENDIF 691 692 DO jobs = 1, sstdatqc%nsurf 693 inrc = sstdatqc%mstp(jobs) + 2 - nit000 694 sstdatqc%nsstp(inrc) = sstdatqc%nsstp(inrc) + 1 695 END DO 696 697 CALL obs_mpp_sum_integers( sstdatqc%nsstp, sstdatqc%nsstpmpp, & 698 & nitend - nit000 + 2 ) 699 700 IF ( lwp ) THEN 701 DO jstp = nit000 - 1, nitend 702 inrc = jstp - nit000 + 2 703 WRITE(numout,1999) jstp, sstdatqc%nsstpmpp(inrc) 704 END DO 705 ENDIF 706 707 1997 FORMAT(10X,'Time step',5X,'Sea surface temperature') 708 1998 FORMAT(10X,'---------',5X,'-----------------') 709 1999 FORMAT(10X,I9,5X,I17) 710 711 END SUBROUTINE obs_pre_sst 712 713 SUBROUTINE obs_pre_seaice( seaicedata, seaicedatqc, ld_seaice, ld_nea ) 714 !!---------------------------------------------------------------------- 715 !! *** ROUTINE obs_pre_seaice *** 716 !! 717 !! ** Purpose : First level check and screening of Sea Ice observations 718 !! 719 !! ** Method : First level check and screening of Sea Ice observations 720 !! 721 !! ** Action : 722 !! 723 !! References : 724 !! 725 !! History : 726 !! ! 2007-11 (D. Lea) based on obs_pre_sst 727 !!---------------------------------------------------------------------- 728 !! * Modules used 729 USE domstp ! Domain: set the time-step 730 USE par_oce ! Ocean parameters 731 USE dom_oce, ONLY : & ! Geographical information 732 & glamt, & 733 & gphit, & 734 & tmask, & 735 & nproc 736 !! * Arguments 737 TYPE(obs_surf), INTENT(INOUT) :: seaicedata ! Full set of Sea Ice data 738 TYPE(obs_surf), INTENT(INOUT) :: seaicedatqc ! Subset of sea ice data not failing screening 739 LOGICAL :: ld_seaice ! Switch for sea ice data 740 LOGICAL :: ld_nea ! Switch for rejecting observation near land 741 !! * Local declarations 742 INTEGER :: iyea0 ! Initial date 743 INTEGER :: imon0 ! - (year, month, day, hour, minute) 744 INTEGER :: iday0 745 INTEGER :: ihou0 746 INTEGER :: imin0 747 INTEGER :: icycle ! Current assimilation cycle 748 ! Counters for observations that 749 INTEGER :: iotdobs ! - outside time domain 750 INTEGER :: iosdsobs ! - outside space domain 751 INTEGER :: ilansobs ! - within a model land cell 752 INTEGER :: inlasobs ! - close to land 753 INTEGER :: igrdobs ! - fail the grid search 754 ! Global counters for observations that 755 INTEGER :: iotdobsmpp ! - outside time domain 756 INTEGER :: iosdsobsmpp ! - outside space domain 757 INTEGER :: ilansobsmpp ! - within a model land cell 758 INTEGER :: inlasobsmpp ! - close to land 759 INTEGER :: igrdobsmpp ! - fail the grid search 760 LOGICAL, DIMENSION(:), ALLOCATABLE :: & 761 & llvalid ! data selection 762 INTEGER :: jobs ! Obs. loop variable 763 INTEGER :: jstp ! Time loop variable 764 INTEGER :: inrc ! Time index variable 765 766 IF (lwp) WRITE(numout,*)'obs_pre_seaice : Preparing the sea ice observations...' 767 768 ! Initial date initialization (year, month, day, hour, minute) 769 iyea0 = ndate0 / 10000 770 imon0 = ( ndate0 - iyea0 * 10000 ) / 100 771 iday0 = ndate0 - iyea0 * 10000 - imon0 * 100 772 ihou0 = 0 773 imin0 = 0 774 775 icycle = no ! Assimilation cycle 776 777 ! Diagnotics counters for various failures. 778 779 iotdobs = 0 780 igrdobs = 0 781 iosdsobs = 0 782 ilansobs = 0 783 inlasobs = 0 784 785 ! ----------------------------------------------------------------------- 786 ! Find time coordinate for sea ice data 787 ! ----------------------------------------------------------------------- 788 789 CALL obs_coo_tim( icycle, & 790 & iyea0, imon0, iday0, ihou0, imin0, & 791 & seaicedata%nsurf, seaicedata%nyea, seaicedata%nmon, & 792 & seaicedata%nday, seaicedata%nhou, seaicedata%nmin, & 793 & seaicedata%nqc, seaicedata%mstp, iotdobs ) 794 CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) 795 ! ----------------------------------------------------------------------- 796 ! Check for sea ice data failing the grid search 797 ! ----------------------------------------------------------------------- 798 799 CALL obs_coo_grd( seaicedata%nsurf, seaicedata%mi, seaicedata%mj, & 800 & seaicedata%nqc, igrdobs ) 801 CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) 802 803 ! ----------------------------------------------------------------------- 804 ! Check for land points. 805 ! ----------------------------------------------------------------------- 806 807 CALL obs_coo_spc_2d( seaicedata%nsurf, & 808 & jpi, jpj, & 809 & seaicedata%mi, seaicedata%mj, & 810 & seaicedata%rlam, seaicedata%rphi, & 811 & glamt, gphit, & 812 & tmask(:,:,1), seaicedata%nqc, & 813 & iosdsobs, ilansobs, & 814 & inlasobs, ld_nea ) 815 816 CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) 817 CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) 818 CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) 819 820 ! ----------------------------------------------------------------------- 821 ! Copy useful data from the seaicedata data structure to 822 ! the seaicedatqc data structure 823 ! ----------------------------------------------------------------------- 824 825 ! Allocate the selection arrays 826 827 ALLOCATE( llvalid(seaicedata%nsurf) ) 828 829 ! We want all data which has qc flags <= 0 830 831 llvalid(:) = ( seaicedata%nqc(:) <= 10 ) 832 833 ! The actual copying 834 835 CALL obs_surf_compress( seaicedata, seaicedatqc, .TRUE., numout, & 836 & lvalid=llvalid ) 837 838 ! Dellocate the selection arrays 839 DEALLOCATE( llvalid ) 840 841 ! ----------------------------------------------------------------------- 842 ! Print information about what observations are left after qc 843 ! ----------------------------------------------------------------------- 844 845 ! Update the total observation counter array 846 847 IF(lwp) THEN 848 WRITE(numout,*) 849 WRITE(numout,*) 'obs_pre_seaice :' 850 WRITE(numout,*) '~~~~~~~~~~~' 851 WRITE(numout,*) 852 WRITE(numout,*) ' Sea ice data outside time domain = ', & 853 & iotdobsmpp 854 WRITE(numout,*) ' Remaining sea ice data that failed grid search = ', & 855 & igrdobsmpp 856 WRITE(numout,*) ' Remaining sea ice data outside space domain = ', & 857 & iosdsobsmpp 858 WRITE(numout,*) ' Remaining sea ice data at land points = ', & 859 & ilansobsmpp 860 IF (ld_nea) THEN 861 WRITE(numout,*) ' Remaining sea ice data near land points (removed) = ', & 862 & inlasobsmpp 863 ELSE 864 WRITE(numout,*) ' Remaining sea ice data near land points (kept) = ', & 865 & inlasobsmpp 866 ENDIF 867 WRITE(numout,*) ' Sea ice data accepted = ', & 868 & seaicedatqc%nsurfmpp 869 870 WRITE(numout,*) 871 WRITE(numout,*) ' Number of observations per time step :' 872 WRITE(numout,*) 873 WRITE(numout,1997) 874 WRITE(numout,1998) 875 ENDIF 876 877 DO jobs = 1, seaicedatqc%nsurf 878 inrc = seaicedatqc%mstp(jobs) + 2 - nit000 879 seaicedatqc%nsstp(inrc) = seaicedatqc%nsstp(inrc) + 1 880 END DO 881 882 CALL obs_mpp_sum_integers( seaicedatqc%nsstp, seaicedatqc%nsstpmpp, & 883 & nitend - nit000 + 2 ) 884 885 IF ( lwp ) THEN 886 DO jstp = nit000 - 1, nitend 887 inrc = jstp - nit000 + 2 888 WRITE(numout,1999) jstp, seaicedatqc%nsstpmpp(inrc) 889 END DO 890 ENDIF 891 892 1997 FORMAT(10X,'Time step',5X,'Sea ice data ') 893 1998 FORMAT(10X,'---------',5X,'-----------------') 894 1999 FORMAT(10X,I9,5X,I17) 895 896 END SUBROUTINE obs_pre_seaice 897 898 SUBROUTINE obs_pre_vel( profdata, prodatqc, ld_vel3d, ld_nea, ld_dailyav ) 899 !!---------------------------------------------------------------------- 900 !! *** ROUTINE obs_pre_taovel *** 901 !! 902 !! ** Purpose : First level check and screening of U and V profiles 903 !! 904 !! ** Method : First level check and screening of U and V profiles 905 !! 906 !! History : 907 !! ! 2007-06 (K. Mogensen) original : T and S profile data 908 !! ! 2008-09 (M. Valdivieso) : TAO velocity data 909 !! ! 2009-01 (K. Mogensen) : New feedback strictuer 910 !! 911 !!---------------------------------------------------------------------- 912 !! * Modules used 913 USE domstp ! Domain: set the time-step 914 USE par_oce ! Ocean parameters 915 USE dom_oce, ONLY : & ! Geographical information 916 & glamt, glamu, glamv, & 917 & gphit, gphiu, gphiv, & 918 & gdept_1d, & 919 & tmask, umask, vmask, & 920 & nproc 921 !! * Arguments 922 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data 923 TYPE(obs_prof), INTENT(INOUT) :: prodatqc ! Subset of profile data not failing screening 924 LOGICAL, INTENT(IN) :: ld_vel3d ! Switch for zonal and meridional velocity components 925 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 926 LOGICAL, INTENT(IN) :: ld_dailyav ! Switch for daily average data 927 !! * Local declarations 928 INTEGER :: iyea0 ! Initial date 929 INTEGER :: imon0 ! - (year, month, day, hour, minute) 930 INTEGER :: iday0 931 INTEGER :: ihou0 932 INTEGER :: imin0 933 INTEGER :: icycle ! Current assimilation cycle 934 ! Counters for observations that 935 INTEGER :: iotdobs ! - outside time domain 936 INTEGER :: iosduobs ! - outside space domain (zonal velocity component) 937 INTEGER :: iosdvobs ! - outside space domain (meridional velocity component) 938 INTEGER :: ilanuobs ! - within a model land cell (zonal velocity component) 939 INTEGER :: ilanvobs ! - within a model land cell (meridional velocity component) 940 INTEGER :: inlauobs ! - close to land (zonal velocity component) 941 INTEGER :: inlavobs ! - close to land (meridional velocity component) 942 INTEGER :: igrdobs ! - fail the grid search 943 INTEGER :: iuvchku ! - reject u if v rejected and vice versa 944 INTEGER :: iuvchkv ! 945 ! Global counters for observations that 946 INTEGER :: iotdobsmpp ! - outside time domain 947 INTEGER :: iosduobsmpp ! - outside space domain (zonal velocity component) 948 INTEGER :: iosdvobsmpp ! - outside space domain (meridional velocity component) 949 INTEGER :: ilanuobsmpp ! - within a model land cell (zonal velocity component) 950 INTEGER :: ilanvobsmpp ! - within a model land cell (meridional velocity component) 951 INTEGER :: inlauobsmpp ! - close to land (zonal velocity component) 952 INTEGER :: inlavobsmpp ! - close to land (meridional velocity component) 953 INTEGER :: igrdobsmpp ! - fail the grid search 954 INTEGER :: iuvchkumpp ! - reject u if v rejected and vice versa 955 INTEGER :: iuvchkvmpp ! 956 TYPE(obs_prof_valid) :: llvalid ! Profile selection 957 TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & 958 & llvvalid ! U,V selection 959 INTEGER :: jvar ! Variable loop variable 960 INTEGER :: jobs ! Obs. loop variable 961 INTEGER :: jstp ! Time loop variable 962 INTEGER :: inrc ! Time index variable 963 964 IF(lwp) WRITE(numout,*)'obs_pre_vel: Preparing the velocity profile data' 965 966 ! Initial date initialization (year, month, day, hour, minute) 967 iyea0 = ndate0 / 10000 968 imon0 = ( ndate0 - iyea0 * 10000 ) / 100 969 iday0 = ndate0 - iyea0 * 10000 - imon0 * 100 970 ihou0 = 0 971 imin0 = 0 972 973 icycle = no ! Assimilation cycle 974 975 ! Diagnotics counters for various failures. 976 977 iotdobs = 0 978 igrdobs = 0 979 iosduobs = 0 980 iosdvobs = 0 981 ilanuobs = 0 982 ilanvobs = 0 983 inlauobs = 0 984 inlavobs = 0 985 iuvchku = 0 986 iuvchkv = 0 987 988 ! ----------------------------------------------------------------------- 989 ! Find time coordinate for profiles 990 ! ----------------------------------------------------------------------- 991 992 CALL obs_coo_tim_prof( icycle, & 993 & iyea0, imon0, iday0, ihou0, imin0, & 994 & profdata%nprof, profdata%nyea, profdata%nmon, & 995 & profdata%nday, profdata%nhou, profdata%nmin, & 996 & profdata%ntyp, profdata%nqc, profdata%mstp, & 997 & iotdobs, ld_dailyav = ld_dailyav ) 998 999 CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) 1000 1001 ! ----------------------------------------------------------------------- 1002 ! Check for profiles failing the grid search 1003 ! ----------------------------------------------------------------------- 1004 1005 CALL obs_coo_grd( profdata%nprof, profdata%mi(:,1), profdata%mj(:,1), & 1006 & profdata%nqc, igrdobs ) 1007 CALL obs_coo_grd( profdata%nprof, profdata%mi(:,2), profdata%mj(:,2), & 1008 & profdata%nqc, igrdobs ) 1009 1010 CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) 1011 1012 ! ----------------------------------------------------------------------- 1013 ! Reject all observations for profiles with nqc > 10 1014 ! ----------------------------------------------------------------------- 1015 1016 CALL obs_pro_rej( profdata ) 398 ! Reject all observations for profiles with nqc > iqc_cutoff 399 ! ----------------------------------------------------------------------- 400 401 CALL obs_pro_rej( profdata, kqc_cutoff = iqc_cutoff ) 1017 402 1018 403 ! ----------------------------------------------------------------------- … … 1021 406 ! ----------------------------------------------------------------------- 1022 407 1023 ! Zonal Velocity Component 1024 1025 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(1), & 1026 & profdata%npvsta(:,1), profdata%npvend(:,1), & 1027 & jpi, jpj, & 1028 & jpk, & 1029 & profdata%mi, profdata%mj, & 1030 & profdata%var(1)%mvk, & 1031 & profdata%rlam, profdata%rphi, & 1032 & profdata%var(1)%vdep, & 1033 & glamu, gphiu, & 1034 & gdept_1d, umask, & 1035 & profdata%nqc, profdata%var(1)%nvqc, & 1036 & iosduobs, ilanuobs, & 1037 & inlauobs, ld_nea ) 1038 1039 CALL obs_mpp_sum_integer( iosduobs, iosduobsmpp ) 1040 CALL obs_mpp_sum_integer( ilanuobs, ilanuobsmpp ) 1041 CALL obs_mpp_sum_integer( inlauobs, inlauobsmpp ) 1042 1043 ! Meridional Velocity Component 1044 1045 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(2), & 1046 & profdata%npvsta(:,2), profdata%npvend(:,2), & 1047 & jpi, jpj, & 1048 & jpk, & 1049 & profdata%mi, profdata%mj, & 1050 & profdata%var(2)%mvk, & 1051 & profdata%rlam, profdata%rphi, & 1052 & profdata%var(2)%vdep, & 1053 & glamv, gphiv, & 1054 & gdept_1d, vmask, & 1055 & profdata%nqc, profdata%var(2)%nvqc, & 1056 & iosdvobs, ilanvobs, & 1057 & inlavobs, ld_nea ) 1058 1059 CALL obs_mpp_sum_integer( iosdvobs, iosdvobsmpp ) 1060 CALL obs_mpp_sum_integer( ilanvobs, ilanvobsmpp ) 1061 CALL obs_mpp_sum_integer( inlavobs, inlavobsmpp ) 408 DO jvar = 1, profdata%nvar 409 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(jvar), & 410 & profdata%npvsta(:,jvar), profdata%npvend(:,jvar), & 411 & jpi, jpj, & 412 & jpk, & 413 & profdata%mi, profdata%mj, & 414 & profdata%var(jvar)%mvk, & 415 & profdata%rlam, profdata%rphi, & 416 & profdata%var(jvar)%vdep, & 417 & pglam(:,:,jvar), pgphi(:,:,jvar), & 418 & gdept_1d, zmask(:,:,:,jvar), & 419 & profdata%nqc, profdata%var(jvar)%nvqc, & 420 & iosdvobs(jvar), ilanvobs(jvar), & 421 & inlavobs(jvar), ld_nea, & 422 & ibdyvobs(jvar), ld_bound_reject, & 423 & iqc_cutoff ) 424 425 CALL obs_mpp_sum_integer( iosdvobs(jvar), iosdvobsmpp(jvar) ) 426 CALL obs_mpp_sum_integer( ilanvobs(jvar), ilanvobsmpp(jvar) ) 427 CALL obs_mpp_sum_integer( inlavobs(jvar), inlavobsmpp(jvar) ) 428 CALL obs_mpp_sum_integer( ibdyvobs(jvar), ibdyvobsmpp(jvar) ) 429 END DO 1062 430 1063 431 ! ----------------------------------------------------------------------- … … 1065 433 ! ----------------------------------------------------------------------- 1066 434 1067 CALL obs_uv_rej( profdata, iuvchku, iuvchkv ) 1068 CALL obs_mpp_sum_integer( iuvchku, iuvchkumpp ) 1069 CALL obs_mpp_sum_integer( iuvchkv, iuvchkvmpp ) 435 IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 436 CALL obs_uv_rej( profdata, iuvchku, iuvchkv, iqc_cutoff ) 437 CALL obs_mpp_sum_integer( iuvchku, iuvchkumpp ) 438 CALL obs_mpp_sum_integer( iuvchkv, iuvchkvmpp ) 439 ENDIF 1070 440 1071 441 ! ----------------------------------------------------------------------- … … 1081 451 END DO 1082 452 1083 ! We want all data which has qc flags = 01084 1085 llvalid%luse(:) = ( profdata%nqc(:) <= 10)453 ! We want all data which has qc flags <= iqc_cutoff 454 455 llvalid%luse(:) = ( profdata%nqc(:) <= iqc_cutoff ) 1086 456 DO jvar = 1,profdata%nvar 1087 llvvalid(jvar)%luse(:) = ( profdata%var(jvar)%nvqc(:) <= 10)457 llvvalid(jvar)%luse(:) = ( profdata%var(jvar)%nvqc(:) <= iqc_cutoff ) 1088 458 END DO 1089 459 … … 1106 476 1107 477 IF(lwp) THEN 478 1108 479 WRITE(numout,*) 1109 WRITE(numout,*) 'obs_pre_vel :' 1110 WRITE(numout,*) '~~~~~~~~~~~' 1111 WRITE(numout,*) 1112 WRITE(numout,*) ' Profiles outside time domain = ', & 480 WRITE(numout,*) ' Profiles outside time domain = ', & 1113 481 & iotdobsmpp 1114 WRITE(numout,*) ' Remaining profiles that failed grid search = ', &482 WRITE(numout,*) ' Remaining profiles that failed grid search = ', & 1115 483 & igrdobsmpp 1116 WRITE(numout,*) ' Remaining U data outside space domain = ', & 1117 & iosduobsmpp 1118 WRITE(numout,*) ' Remaining U data at land points = ', & 1119 & ilanuobsmpp 1120 IF (ld_nea) THEN 1121 WRITE(numout,*) ' Remaining U data near land points (removed) = ',& 1122 & inlauobsmpp 1123 ELSE 1124 WRITE(numout,*) ' Remaining U data near land points (kept) = ',& 1125 & inlauobsmpp 1126 ENDIF 1127 WRITE(numout,*) ' U observation rejected since V rejected = ', & 1128 & iuvchku 1129 WRITE(numout,*) ' U data accepted = ', & 1130 & prodatqc%nvprotmpp(1) 1131 WRITE(numout,*) ' Remaining V data outside space domain = ', & 1132 & iosdvobsmpp 1133 WRITE(numout,*) ' Remaining V data at land points = ', & 1134 & ilanvobsmpp 1135 IF (ld_nea) THEN 1136 WRITE(numout,*) ' Remaining V data near land points (removed) = ',& 1137 & inlavobsmpp 1138 ELSE 1139 WRITE(numout,*) ' Remaining V data near land points (kept) = ',& 1140 & inlavobsmpp 1141 ENDIF 1142 WRITE(numout,*) ' V observation rejected since U rejected = ', & 1143 & iuvchkv 1144 WRITE(numout,*) ' V data accepted = ', & 1145 & prodatqc%nvprotmpp(2) 484 DO jvar = 1, profdata%nvar 485 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data outside space domain = ', & 486 & iosdvobsmpp(jvar) 487 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data at land points = ', & 488 & ilanvobsmpp(jvar) 489 IF (ld_nea) THEN 490 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (removed) = ',& 491 & inlavobsmpp(jvar) 492 ELSE 493 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (kept) = ',& 494 & inlavobsmpp(jvar) 495 ENDIF 496 IF ( TRIM(profdata%cvars(jvar)) == 'UVEL' ) THEN 497 WRITE(numout,*) ' U observation rejected since V rejected = ', & 498 & iuvchku 499 ELSE IF ( TRIM(profdata%cvars(jvar)) == 'VVEL' ) THEN 500 WRITE(numout,*) ' V observation rejected since U rejected = ', & 501 & iuvchkv 502 ENDIF 503 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near open boundary (removed) = ',& 504 & ibdyvobsmpp(jvar) 505 WRITE(numout,*) ' '//prodatqc%cvars(jvar)//' data accepted = ', & 506 & prodatqc%nvprotmpp(jvar) 507 END DO 1146 508 1147 509 WRITE(numout,*) 1148 510 WRITE(numout,*) ' Number of observations per time step :' 1149 511 WRITE(numout,*) 1150 WRITE(numout,997) 1151 WRITE(numout,998) 512 WRITE(cout1,'(10X,A9,5X,A8)') 'Time step', 'Profiles' 513 WRITE(cout2,'(10X,A9,5X,A8)') '---------', '--------' 514 DO jvar = 1, prodatqc%nvar 515 WRITE(cout1,'(A,5X,A11)') TRIM(cout1), TRIM(prodatqc%cvars(jvar)) 516 WRITE(cout2,'(A,5X,A11)') TRIM(cout2), '-----------' 517 END DO 518 WRITE(numout,*) cout1 519 WRITE(numout,*) cout2 1152 520 ENDIF 1153 521 … … 1176 544 DO jstp = nit000 - 1, nitend 1177 545 inrc = jstp - nit000 + 2 1178 WRITE(numout,999) jstp, prodatqc%npstpmpp(inrc), & 1179 & prodatqc%nvstpmpp(inrc,1), & 1180 & prodatqc%nvstpmpp(inrc,2) 546 WRITE(cout1,'(10X,I9,5X,I8)') jstp, prodatqc%npstpmpp(inrc) 547 DO jvar = 1, prodatqc%nvar 548 WRITE(cout1,'(A,5X,I11)') TRIM(cout1), prodatqc%nvstpmpp(inrc,jvar) 549 END DO 550 WRITE(numout,*) cout1 1181 551 END DO 1182 552 ENDIF 1183 553 1184 997 FORMAT(10X,'Time step',5X,'Profiles',5X,'Zonal Comp.',5X,'Meridional Comp.') 1185 998 FORMAT(10X,'---------',5X,'--------',5X,'-----------',5X,'----------------') 1186 999 FORMAT(10X,I9,5X,I8,5X,I11,5X,I8) 1187 1188 END SUBROUTINE obs_pre_vel 554 END SUBROUTINE obs_pre_prof 1189 555 1190 556 SUBROUTINE obs_coo_tim( kcycle, & … … 1293 659 & .AND. ( kobsmin(jobs) <= kmin0 ) ) ) THEN 1294 660 kobsstp(jobs) = -1 1295 kobsqc(jobs) = kobsqc(jobs) + 11661 kobsqc(jobs) = IBSET(kobsqc(jobs),13) 1296 662 kotdobs = kotdobs + 1 1297 663 CYCLE … … 1344 710 IF ( ( kobsstp(jobs) < ( nit000 - 1 ) ) & 1345 711 & .OR.( kobsstp(jobs) > nitend ) ) THEN 1346 kobsqc(jobs) = kobsqc(jobs) + 12712 kobsqc(jobs) = IBSET(kobsqc(jobs),13) 1347 713 kotdobs = kotdobs + 1 1348 714 CYCLE … … 1389 755 & kobsyea, kobsmon, kobsday, kobshou, kobsmin, & 1390 756 & ktyp, kobsqc, kobsstp, kotdobs, kdailyavtypes, & 1391 & ld_dailyav)757 & kqc_cutoff ) 1392 758 !!---------------------------------------------------------------------- 1393 759 !! *** ROUTINE obs_coo_tim *** … … 1433 799 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 1434 800 & kdailyavtypes ! Types for daily averages 1435 LOGICAL, OPTIONAL :: ld_dailyav ! All types are daily averages 801 INTEGER, OPTIONAL, INTENT(IN) :: kqc_cutoff ! QC cutoff value 802 1436 803 !! * Local declarations 1437 804 INTEGER :: jobs 805 INTEGER :: iqc_cutoff=255 1438 806 1439 807 !----------------------------------------------------------------------- … … 1454 822 DO jobs = 1, kobsno 1455 823 1456 IF ( kobsqc(jobs) <= 10) THEN824 IF ( kobsqc(jobs) <= iqc_cutoff ) THEN 1457 825 1458 826 IF ( ( kobsstp(jobs) == (nit000 - 1) ).AND.& 1459 827 & ( ANY (kdailyavtypes(:) == ktyp(jobs)) ) ) THEN 1460 kobsqc(jobs) = kobsqc(jobs) + 14828 kobsqc(jobs) = IBSET(kobsqc(jobs),13) 1461 829 kotdobs = kotdobs + 1 1462 830 CYCLE … … 1467 835 ENDIF 1468 836 1469 !------------------------------------------------------------------------1470 ! If ld_dailyav is set then all data assumed to be daily averaged1471 !------------------------------------------------------------------------1472 1473 IF ( PRESENT( ld_dailyav) ) THEN1474 IF (ld_dailyav) THEN1475 DO jobs = 1, kobsno1476 1477 IF ( kobsqc(jobs) <= 10 ) THEN1478 1479 IF ( kobsstp(jobs) == (nit000 - 1) ) THEN1480 kobsqc(jobs) = kobsqc(jobs) + 141481 kotdobs = kotdobs + 11482 CYCLE1483 ENDIF1484 1485 ENDIF1486 END DO1487 ENDIF1488 ENDIF1489 837 1490 838 END SUBROUTINE obs_coo_tim_prof … … 1521 869 DO jobs = 1, kobsno 1522 870 IF ( ( kobsi(jobs) <= 0 ) .AND. ( kobsj(jobs) <= 0 ) ) THEN 1523 kobsqc(jobs) = kobsqc(jobs) + 18871 kobsqc(jobs) = IBSET(kobsqc(jobs),12) 1524 872 kgrdobs = kgrdobs + 1 1525 873 ENDIF … … 1532 880 & plam, pphi, pmask, & 1533 881 & kobsqc, kosdobs, klanobs, & 1534 & knlaobs,ld_nea ) 882 & knlaobs,ld_nea, & 883 & kbdyobs,ld_bound_reject, & 884 & kqc_cutoff ) 1535 885 !!---------------------------------------------------------------------- 1536 886 !! *** ROUTINE obs_coo_spc_2d *** … … 1565 915 INTEGER, DIMENSION(kobsno), INTENT(INOUT) :: & 1566 916 & kobsqc ! Observation quality control 1567 INTEGER, INTENT(INOUT) :: kosdobs ! Observations outside space domain 1568 INTEGER, INTENT(INOUT) :: klanobs ! Observations within a model land cell 1569 INTEGER, INTENT(INOUT) :: knlaobs ! Observations near land 1570 LOGICAL, INTENT(IN) :: ld_nea ! Flag observations near land 917 INTEGER, INTENT(INOUT) :: kosdobs ! Observations outside space domain 918 INTEGER, INTENT(INOUT) :: klanobs ! Observations within a model land cell 919 INTEGER, INTENT(INOUT) :: knlaobs ! Observations near land 920 INTEGER, INTENT(INOUT) :: kbdyobs ! Observations near boundary 921 LOGICAL, INTENT(IN) :: ld_nea ! Flag observations near land 922 LOGICAL, INTENT(IN) :: ld_bound_reject ! Flag observations near open boundary 923 INTEGER, INTENT(IN) :: kqc_cutoff ! Cutoff QC value 924 1571 925 !! * Local declarations 1572 926 REAL(KIND=wp), DIMENSION(2,2,kobsno) :: & 1573 927 & zgmsk ! Grid mask 928 #if defined key_bdy 929 REAL(KIND=wp), DIMENSION(2,2,kobsno) :: & 930 & zbmsk ! Boundary mask 931 REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask 932 #endif 1574 933 REAL(KIND=wp), DIMENSION(2,2,kobsno) :: & 1575 934 & zglam, & ! Model longitude at grid points … … 1588 947 ! For invalid points use 2,2 1589 948 1590 IF ( kobsqc(jobs) >= 10) THEN949 IF ( kobsqc(jobs) >= kqc_cutoff ) THEN 1591 950 1592 951 igrdi(1,1,jobs) = 1 … … 1613 972 1614 973 END DO 1615 1616 CALL obs_int_comm_2d( 2, 2, kobsno, igrdi, igrdj, pmask, zgmsk ) 1617 CALL obs_int_comm_2d( 2, 2, kobsno, igrdi, igrdj, plam, zglam ) 1618 CALL obs_int_comm_2d( 2, 2, kobsno, igrdi, igrdj, pphi, zgphi ) 974 975 #if defined key_bdy 976 ! Create a mask grid points in boundary rim 977 IF (ld_bound_reject) THEN 978 zbdymask(:,:) = 1.0_wp 979 DO ji = 1, nb_bdy 980 DO jj = 1, idx_bdy(ji)%nblen(1) 981 zbdymask(idx_bdy(ji)%nbi(jj,1),idx_bdy(ji)%nbj(jj,1)) = 0.0_wp 982 ENDDO 983 ENDDO 984 985 CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, zbdymask, zbmsk ) 986 ENDIF 987 #endif 988 989 CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, pmask, zgmsk ) 990 CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, plam, zglam ) 991 CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, pphi, zgphi ) 1619 992 1620 993 DO jobs = 1, kobsno 1621 994 1622 995 ! Skip bad observations 1623 IF ( kobsqc(jobs) >= 10) CYCLE996 IF ( kobsqc(jobs) >= kqc_cutoff ) CYCLE 1624 997 1625 998 ! Flag if the observation falls outside the model spatial domain … … 1628 1001 & .OR. ( pobsphi(jobs) < -90. ) & 1629 1002 & .OR. ( pobsphi(jobs) > 90. ) ) THEN 1630 kobsqc(jobs) = kobsqc(jobs) + 111003 kobsqc(jobs) = IBSET(kobsqc(jobs),11) 1631 1004 kosdobs = kosdobs + 1 1632 1005 CYCLE … … 1635 1008 ! Flag if the observation falls with a model land cell 1636 1009 IF ( SUM( zgmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN 1637 kobsqc(jobs) = kobsqc(jobs) + 121010 kobsqc(jobs) = IBSET(kobsqc(jobs),10) 1638 1011 klanobs = klanobs + 1 1639 1012 CYCLE … … 1649 1022 IF ( ( ABS( zgphi(ji,jj,jobs) - pobsphi(jobs) ) < 1.0e-6_wp ) & 1650 1023 & .AND. & 1651 & ( ABS( zglam(ji,jj,jobs) - pobslam(jobs) ) < 1.0e-6_wp )&1652 & ) THEN1024 & ( ABS( MOD( zglam(ji,jj,jobs) - pobslam(jobs),360.0) ) & 1025 & < 1.0e-6_wp ) ) THEN 1653 1026 lgridobs = .TRUE. 1654 1027 iig = ji … … 1657 1030 END DO 1658 1031 END DO 1659 1660 ! For observations on the grid reject them if their are at 1661 ! a masked point 1662 1032 1663 1033 IF (lgridobs) THEN 1664 1034 IF (zgmsk(iig,ijg,jobs) == 0.0_wp ) THEN 1665 kobsqc(jobs) = kobsqc(jobs) + 121035 kobsqc(jobs) = IBSET(kobsqc(jobs),10) 1666 1036 klanobs = klanobs + 1 1667 1037 CYCLE 1668 1038 ENDIF 1669 1039 ENDIF 1670 1040 1041 1671 1042 ! Flag if the observation falls is close to land 1672 1043 IF ( MINVAL( zgmsk(1:2,1:2,jobs) ) == 0.0_wp) THEN 1673 IF (ld_nea) kobsqc(jobs) = kobsqc(jobs) + 141674 1044 knlaobs = knlaobs + 1 1675 CYCLE 1045 IF (ld_nea) THEN 1046 kobsqc(jobs) = IBSET(kobsqc(jobs),9) 1047 CYCLE 1048 ENDIF 1676 1049 ENDIF 1050 1051 #if defined key_bdy 1052 ! Flag if the observation falls close to the boundary rim 1053 IF (ld_bound_reject) THEN 1054 IF ( MINVAL( zbmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN 1055 kobsqc(jobs) = IBSET(kobsqc(jobs),8) 1056 kbdyobs = kbdyobs + 1 1057 CYCLE 1058 ENDIF 1059 ! for observations on the grid... 1060 IF (lgridobs) THEN 1061 IF (zbmsk(iig,ijg,jobs) == 0.0_wp ) THEN 1062 kobsqc(jobs) = IBSET(kobsqc(jobs),8) 1063 kbdyobs = kbdyobs + 1 1064 CYCLE 1065 ENDIF 1066 ENDIF 1067 ENDIF 1068 #endif 1677 1069 1678 1070 END DO … … 1686 1078 & plam, pphi, pdep, pmask, & 1687 1079 & kpobsqc, kobsqc, kosdobs, & 1688 & klanobs, knlaobs, ld_nea ) 1080 & klanobs, knlaobs, ld_nea, & 1081 & kbdyobs, ld_bound_reject, & 1082 & kqc_cutoff ) 1689 1083 !!---------------------------------------------------------------------- 1690 1084 !! *** ROUTINE obs_coo_spc_3d *** … … 1709 1103 !! * Modules used 1710 1104 USE dom_oce, ONLY : & ! Geographical information 1711 & gdepw_1d 1105 & gdepw_1d, & 1106 & gdepw_0, & 1107 #if defined key_vvl 1108 & gdepw_n, & 1109 & gdept_n, & 1110 #endif 1111 & ln_zco, & 1112 & ln_zps, & 1113 & lk_vvl 1712 1114 1713 1115 !! * Arguments … … 1743 1145 INTEGER, INTENT(INOUT) :: klanobs ! Observations within a model land cell 1744 1146 INTEGER, INTENT(INOUT) :: knlaobs ! Observations near land 1147 INTEGER, INTENT(INOUT) :: kbdyobs ! Observations near boundary 1745 1148 LOGICAL, INTENT(IN) :: ld_nea ! Flag observations near land 1149 LOGICAL, INTENT(IN) :: ld_bound_reject ! Flag observations near open boundary 1150 INTEGER, INTENT(IN) :: kqc_cutoff ! Cutoff QC value 1151 1746 1152 !! * Local declarations 1747 1153 REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: & 1748 1154 & zgmsk ! Grid mask 1155 #if defined key_bdy 1156 REAL(KIND=wp), DIMENSION(2,2,kprofno) :: & 1157 & zbmsk ! Boundary mask 1158 REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask 1159 #endif 1160 REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: & 1161 & zgdepw 1749 1162 REAL(KIND=wp), DIMENSION(2,2,kprofno) :: & 1750 1163 & zglam, & ! Model longitude at grid points … … 1754 1167 & igrdj 1755 1168 LOGICAL :: lgridobs ! Is observation on a model grid point. 1169 LOGICAL :: ll_next_to_land ! Is a profile next to land 1756 1170 INTEGER :: iig, ijg ! i,j of observation on model grid point. 1757 1171 INTEGER :: jobs, jobsp, jk, ji, jj … … 1763 1177 ! For invalid points use 2,2 1764 1178 1765 IF ( kpobsqc(jobs) >= 10) THEN1179 IF ( kpobsqc(jobs) >= kqc_cutoff ) THEN 1766 1180 1767 1181 igrdi(1,1,jobs) = 1 … … 1788 1202 1789 1203 END DO 1790 1791 CALL obs_int_comm_3d( 2, 2, kprofno, kpk, igrdi, igrdj, pmask, zgmsk ) 1792 CALL obs_int_comm_2d( 2, 2, kprofno, igrdi, igrdj, plam, zglam ) 1793 CALL obs_int_comm_2d( 2, 2, kprofno, igrdi, igrdj, pphi, zgphi ) 1204 1205 #if defined key_bdy 1206 ! Create a mask grid points in boundary rim 1207 IF (ld_bound_reject) THEN 1208 zbdymask(:,:) = 1.0_wp 1209 DO ji = 1, nb_bdy 1210 DO jj = 1, idx_bdy(ji)%nblen(1) 1211 zbdymask(idx_bdy(ji)%nbi(jj,1),idx_bdy(ji)%nbj(jj,1)) = 0.0_wp 1212 ENDDO 1213 ENDDO 1214 ENDIF 1215 1216 CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, zbdymask, zbmsk ) 1217 #endif 1218 1219 CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, pmask, zgmsk ) 1220 CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, plam, zglam ) 1221 CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, pphi, zgphi ) 1222 ! Need to know the bathy depth for each observation for sco 1223 CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, fsdepw(:,:,:), & 1224 & zgdepw ) 1794 1225 1795 1226 DO jobs = 1, kprofno 1796 1227 1797 1228 ! Skip bad profiles 1798 IF ( kpobsqc(jobs) >= 10) CYCLE1229 IF ( kpobsqc(jobs) >= kqc_cutoff ) CYCLE 1799 1230 1800 1231 ! Check if this observation is on a grid point … … 1807 1238 IF ( ( ABS( zgphi(ji,jj,jobs) - pobsphi(jobs) ) < 1.0e-6_wp ) & 1808 1239 & .AND. & 1809 & ( ABS( zglam(ji,jj,jobs) - pobslam(jobs) ) < 1.0e-6_wp ) &1240 & ( ABS( MOD( zglam(ji,jj,jobs) - pobslam(jobs),360.0) ) < 1.0e-6_wp ) & 1810 1241 & ) THEN 1811 1242 lgridobs = .TRUE. … … 1816 1247 END DO 1817 1248 1249 ! Check if next to land 1250 IF ( ANY( zgmsk(1:2,1:2,1,jobs) == 0.0_wp ) ) THEN 1251 ll_next_to_land=.TRUE. 1252 ELSE 1253 ll_next_to_land=.FALSE. 1254 ENDIF 1255 1818 1256 ! Reject observations 1819 1257 … … 1827 1265 & .OR. ( pobsdep(jobsp) < 0.0 ) & 1828 1266 & .OR. ( pobsdep(jobsp) > gdepw_1d(kpk)) ) THEN 1829 kobsqc(jobsp) = kobsqc(jobsp) + 111267 kobsqc(jobsp) = IBSET(kobsqc(jobsp),11) 1830 1268 kosdobs = kosdobs + 1 1831 1269 CYCLE 1832 1270 ENDIF 1833 1271 1834 ! Flag if the observation falls with a model land cell 1835 IF ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) & 1836 & == 0.0_wp ) THEN 1837 kobsqc(jobsp) = kobsqc(jobsp) + 12 1838 klanobs = klanobs + 1 1839 CYCLE 1272 ! To check if an observations falls within land there are two cases: 1273 ! 1: z-coordibnates, where the check uses the mask 1274 ! 2: terrain following (eg s-coordinates), 1275 ! where we use the depth of the bottom cell to mask observations 1276 1277 IF( (.NOT. lk_vvl) .AND. ( ln_zps .OR. ln_zco ) ) THEN !(CASE 1) 1278 1279 ! Flag if the observation falls with a model land cell 1280 IF ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) & 1281 & == 0.0_wp ) THEN 1282 kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) 1283 klanobs = klanobs + 1 1284 CYCLE 1285 ENDIF 1286 1287 ! Flag if the observation is close to land 1288 IF ( MINVAL( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) == & 1289 & 0.0_wp) THEN 1290 knlaobs = knlaobs + 1 1291 IF (ld_nea) THEN 1292 kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) 1293 ENDIF 1294 ENDIF 1295 1296 ELSE ! Case 2 1297 ! Flag if the observation is deeper than the bathymetry 1298 ! Or if it is within the mask 1299 IF ( ANY( zgdepw(1:2,1:2,kpk,jobs) < pobsdep(jobsp) ) & 1300 & .OR. & 1301 & ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) & 1302 & == 0.0_wp) ) THEN 1303 kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) 1304 klanobs = klanobs + 1 1305 CYCLE 1306 ENDIF 1307 1308 ! Flag if the observation is close to land 1309 IF ( ll_next_to_land ) THEN 1310 knlaobs = knlaobs + 1 1311 IF (ld_nea) THEN 1312 kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) 1313 ENDIF 1314 ENDIF 1315 1840 1316 ENDIF 1841 1317 … … 1845 1321 IF (lgridobs) THEN 1846 1322 IF (zgmsk(iig,ijg,kobsk(jobsp)-1,jobs) == 0.0_wp ) THEN 1847 kobsqc(jobsp) = kobsqc(jobsp) + 121323 kobsqc(jobsp) = IBSET(kobsqc(jobs),10) 1848 1324 klanobs = klanobs + 1 1849 1325 CYCLE … … 1851 1327 ENDIF 1852 1328 1853 ! Flag if the observation falls is close to land1854 IF ( MINVAL( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) == &1855 & 0.0_wp) THEN1856 IF (ld_nea) kobsqc(jobsp) = kobsqc(jobsp) + 141857 knlaobs = knlaobs + 11858 ENDIF1859 1860 1329 ! Set observation depth equal to that of the first model depth 1861 1330 IF ( pobsdep(jobsp) <= pdep(1) ) THEN … … 1863 1332 ENDIF 1864 1333 1334 #if defined key_bdy 1335 ! Flag if the observation falls close to the boundary rim 1336 IF (ld_bound_reject) THEN 1337 IF ( MINVAL( zbmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN 1338 kobsqc(jobsp) = IBSET(kobsqc(jobs),8) 1339 kbdyobs = kbdyobs + 1 1340 CYCLE 1341 ENDIF 1342 ! for observations on the grid... 1343 IF (lgridobs) THEN 1344 IF (zbmsk(iig,ijg,jobs) == 0.0_wp ) THEN 1345 kobsqc(jobsp) = IBSET(kobsqc(jobs),8) 1346 kbdyobs = kbdyobs + 1 1347 CYCLE 1348 ENDIF 1349 ENDIF 1350 ENDIF 1351 #endif 1352 1865 1353 END DO 1866 1354 END DO … … 1868 1356 END SUBROUTINE obs_coo_spc_3d 1869 1357 1870 SUBROUTINE obs_pro_rej( profdata )1358 SUBROUTINE obs_pro_rej( profdata, kqc_cutoff ) 1871 1359 !!---------------------------------------------------------------------- 1872 1360 !! *** ROUTINE obs_pro_rej *** … … 1886 1374 !! * Arguments 1887 1375 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Profile data 1376 INTEGER, INTENT(IN) :: kqc_cutoff ! QC cutoff value 1377 1888 1378 !! * Local declarations 1889 1379 INTEGER :: jprof … … 1895 1385 DO jprof = 1, profdata%nprof 1896 1386 1897 IF ( profdata%nqc(jprof) > 10) THEN1387 IF ( profdata%nqc(jprof) > kqc_cutoff ) THEN 1898 1388 1899 1389 DO jvar = 1, profdata%nvar … … 1903 1393 1904 1394 profdata%var(jvar)%nvqc(jobs) = & 1905 & profdata%var(jvar)%nvqc(jobs) + 261395 & IBSET(profdata%var(jvar)%nvqc(jobs),14) 1906 1396 1907 1397 END DO … … 1915 1405 END SUBROUTINE obs_pro_rej 1916 1406 1917 SUBROUTINE obs_uv_rej( profdata, knumu, knumv )1407 SUBROUTINE obs_uv_rej( profdata, knumu, knumv, kqc_cutoff ) 1918 1408 !!---------------------------------------------------------------------- 1919 1409 !! *** ROUTINE obs_uv_rej *** … … 1935 1425 INTEGER, INTENT(INOUT) :: knumu ! Number of u rejected 1936 1426 INTEGER, INTENT(INOUT) :: knumv ! Number of v rejected 1427 INTEGER, INTENT(IN) :: kqc_cutoff ! QC cutoff value 1428 1937 1429 !! * Local declarations 1938 1430 INTEGER :: jprof … … 1954 1446 DO jobs = profdata%npvsta(jprof,1), profdata%npvend(jprof,1) 1955 1447 1956 IF ( ( profdata%var(1)%nvqc(jobs) > 10) .AND. &1957 & ( profdata%var(2)%nvqc(jobs) <= 10) ) THEN1958 profdata%var(2)%nvqc(jobs) = profdata%var(2)%nvqc(jobs) + 421448 IF ( ( profdata%var(1)%nvqc(jobs) > kqc_cutoff ) .AND. & 1449 & ( profdata%var(2)%nvqc(jobs) <= kqc_cutoff) ) THEN 1450 profdata%var(2)%nvqc(jobs) = IBSET(profdata%var(1)%nvqc(jobs),15) 1959 1451 knumv = knumv + 1 1960 1452 ENDIF 1961 IF ( ( profdata%var(2)%nvqc(jobs) > 10) .AND. &1962 & ( profdata%var(1)%nvqc(jobs) <= 10) ) THEN1963 profdata%var(1)%nvqc(jobs) = profdata%var(1)%nvqc(jobs) + 421453 IF ( ( profdata%var(2)%nvqc(jobs) > kqc_cutoff ) .AND. & 1454 & ( profdata%var(1)%nvqc(jobs) <= kqc_cutoff) ) THEN 1455 profdata%var(1)%nvqc(jobs) = IBSET(profdata%var(1)%nvqc(jobs),15) 1964 1456 knumu = knumu + 1 1965 1457 ENDIF -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/OBS/obs_profiles_def.F90
r10246 r10247 104 104 ! Bookkeeping arrays with sizes equal to number of variables 105 105 106 CHARACTER(len=8), POINTER, DIMENSION(:) :: & 107 & cvars !: Variable names 108 106 109 INTEGER, POINTER, DIMENSION(:) :: & 107 110 & nvprot, & !: Local total number of profile T data … … 237 240 238 241 ALLOCATE( & 242 & prof%cvars(kvar), & 239 243 & prof%nvprot(kvar), & 240 244 & prof%nvprotmpp(kvar) & … … 242 246 243 247 DO jvar = 1, kvar 248 prof%cvars (jvar) = "NotSet" 244 249 prof%nvprot (jvar) = ko3dt(jvar) 245 250 prof%nvprotmpp(jvar) = 0 … … 452 457 453 458 DEALLOCATE( & 454 & prof%nvprot, & 459 & prof%cvars, & 460 & prof%nvprot, & 455 461 & prof%nvprotmpp & 456 462 ) … … 770 776 newprof%npj = prof%npj 771 777 newprof%npk = prof%npk 778 newprof%cvars(:) = prof%cvars(:) 772 779 773 780 ! Deallocate temporary data -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_altbias.F90
r10246 r10247 50 50 CONTAINS 51 51 52 SUBROUTINE obs_rea_altbias( kslano,sladata, k2dint, bias_file )52 SUBROUTINE obs_rea_altbias( sladata, k2dint, bias_file ) 53 53 !!--------------------------------------------------------------------- 54 54 !! … … 70 70 ! 71 71 !! * Arguments 72 INTEGER, INTENT(IN) :: kslano ! Number of SLA Products 73 TYPE(obs_surf), DIMENSION(kslano), INTENT(INOUT) :: & 72 TYPE(obs_surf), INTENT(INOUT) :: & 74 73 & sladata ! SLA data 75 74 INTEGER, INTENT(IN) :: k2dint … … 80 79 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_rea_altbias' 81 80 82 INTEGER :: jslano ! Data set loop variable83 81 INTEGER :: jobs ! Obs loop variable 84 82 INTEGER :: jpialtbias ! Number of grid point in latitude for the bias … … 130 128 ! Get the Alt bias data 131 129 132 CALL iom_get( numaltbias, jpdom_ data, 'altbias', z_altbias(:,:), 1 )130 CALL iom_get( numaltbias, jpdom_autoglo, 'altbias', z_altbias(:,:), 1 ) 133 131 134 132 ! Close the file … … 144 142 ! Intepolate the bias already on the model grid at the observation point 145 143 146 DO jslano = 1, kslano 147 148 ALLOCATE( & 149 & igrdi(2,2,sladata(jslano)%nsurf), & 150 & igrdj(2,2,sladata(jslano)%nsurf), & 151 & zglam(2,2,sladata(jslano)%nsurf), & 152 & zgphi(2,2,sladata(jslano)%nsurf), & 153 & zmask(2,2,sladata(jslano)%nsurf), & 154 & zbias(2,2,sladata(jslano)%nsurf) & 155 & ) 156 157 DO jobs = 1, sladata(jslano)%nsurf 158 159 igrdi(1,1,jobs) = sladata(jslano)%mi(jobs)-1 160 igrdj(1,1,jobs) = sladata(jslano)%mj(jobs)-1 161 igrdi(1,2,jobs) = sladata(jslano)%mi(jobs)-1 162 igrdj(1,2,jobs) = sladata(jslano)%mj(jobs) 163 igrdi(2,1,jobs) = sladata(jslano)%mi(jobs) 164 igrdj(2,1,jobs) = sladata(jslano)%mj(jobs)-1 165 igrdi(2,2,jobs) = sladata(jslano)%mi(jobs) 166 igrdj(2,2,jobs) = sladata(jslano)%mj(jobs) 167 168 END DO 169 170 CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, & 171 & igrdi, igrdj, glamt, zglam ) 172 CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, & 173 & igrdi, igrdj, gphit, zgphi ) 174 CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, & 175 & igrdi, igrdj, tmask(:,:,1), zmask ) 176 CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, & 177 & igrdi, igrdj, z_altbias, zbias ) 178 179 DO jobs = 1, sladata(jslano)%nsurf 180 181 zlam = sladata(jslano)%rlam(jobs) 182 zphi = sladata(jslano)%rphi(jobs) 183 iico = sladata(jslano)%mi(jobs) 184 ijco = sladata(jslano)%mj(jobs) 144 ALLOCATE( & 145 & igrdi(2,2,sladata%nsurf), & 146 & igrdj(2,2,sladata%nsurf), & 147 & zglam(2,2,sladata%nsurf), & 148 & zgphi(2,2,sladata%nsurf), & 149 & zmask(2,2,sladata%nsurf), & 150 & zbias(2,2,sladata%nsurf) & 151 & ) 152 153 DO jobs = 1, sladata%nsurf 154 155 igrdi(1,1,jobs) = sladata%mi(jobs)-1 156 igrdj(1,1,jobs) = sladata%mj(jobs)-1 157 igrdi(1,2,jobs) = sladata%mi(jobs)-1 158 igrdj(1,2,jobs) = sladata%mj(jobs) 159 igrdi(2,1,jobs) = sladata%mi(jobs) 160 igrdj(2,1,jobs) = sladata%mj(jobs)-1 161 igrdi(2,2,jobs) = sladata%mi(jobs) 162 igrdj(2,2,jobs) = sladata%mj(jobs) 163 164 END DO 165 166 CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, & 167 & igrdi, igrdj, glamt, zglam ) 168 CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, & 169 & igrdi, igrdj, gphit, zgphi ) 170 CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, & 171 & igrdi, igrdj, tmask(:,:,1), zmask ) 172 CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, & 173 & igrdi, igrdj, z_altbias, zbias ) 174 175 DO jobs = 1, sladata%nsurf 176 177 zlam = sladata%rlam(jobs) 178 zphi = sladata%rphi(jobs) 179 iico = sladata%mi(jobs) 180 ijco = sladata%mj(jobs) 185 181 186 187 188 182 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 183 & zglam(:,:,jobs), zgphi(:,:,jobs), & 184 & zmask(:,:,jobs), zweig, zobsmask ) 189 185 190 CALL obs_int_h2d( 1, 1, & 191 & zweig, zbias(:,:,jobs), zext ) 192 193 ! adjust mdt with bias field 194 sladata(jslano)%rext(jobs,2) = & 195 sladata(jslano)%rext(jobs,2) - zext(1) 186 CALL obs_int_h2d( 1, 1, & 187 & zweig, zbias(:,:,jobs), zext ) 188 189 ! adjust mdt with bias field 190 sladata%rext(jobs,2) = sladata%rext(jobs,2) - zext(1) 196 191 197 END DO198 199 DEALLOCATE( &200 & igrdi, &201 & igrdj, &202 & zglam, &203 & zgphi, &204 & zmask, &205 & zbias &206 & )207 208 192 END DO 209 193 194 DEALLOCATE( & 195 & igrdi, & 196 & igrdj, & 197 & zglam, & 198 & zgphi, & 199 & zmask, & 200 & zbias & 201 & ) 202 210 203 CALL wrk_dealloc(jpi,jpj,z_altbias) 211 204 -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_prof.F90
r10246 r10247 25 25 USE netcdf ! NetCDF library 26 26 USE obs_oper ! Observation operators 27 USE obs_prof_io ! Profile files I/O (non-FB files)28 27 USE lib_mpp ! For ctl_warn/stop 28 USE obs_fbm ! Feedback routines 29 29 30 30 IMPLICIT NONE … … 33 33 PRIVATE 34 34 35 PUBLIC obs_rea_pro _dri! Read the profile observations35 PUBLIC obs_rea_prof ! Read the profile observations 36 36 37 37 !!---------------------------------------------------------------------- … … 42 42 43 43 CONTAINS 44 45 SUBROUTINE obs_rea_pro_dri( kformat, & 46 & profdata, knumfiles, cfilenames, & 47 & kvars, kextr, kstp, ddobsini, ddobsend, & 48 & ldt3d, lds3d, ldignmis, ldsatt, ldavtimset, & 49 & ldmod, kdailyavtypes ) 44 45 SUBROUTINE obs_rea_prof( profdata, knumfiles, cdfilenames, & 46 & kvars, kextr, kstp, ddobsini, ddobsend, & 47 & ldvar, ldignmis, ldsatt, & 48 & ldmod, kdailyavtypes ) 50 49 !!--------------------------------------------------------------------- 51 50 !! 52 !! *** ROUTINE obs_rea_pro _dri***51 !! *** ROUTINE obs_rea_prof *** 53 52 !! 54 53 !! ** Purpose : Read from file the profile observations 55 54 !! 56 !! ** Method : Depending on kformat either ENACT, CORIOLIS or57 !! feedback data files are read55 !! ** Method : Read feedback data in and transform to NEMO internal 56 !! profile data structure 58 57 !! 59 58 !! ** Action : … … 63 62 !! History : 64 63 !! ! : 2009-09 (K. Mogensen) : New merged version of old routines 64 !! ! : 2015-08 (M. Martin) : Merged profile and velocity routines 65 65 !!---------------------------------------------------------------------- 66 !! * Modules used 67 66 68 67 !! * Arguments 69 INTEGER :: kformat ! Format of input data 70 ! ! 1: ENACT 71 ! ! 2: Coriolis 72 TYPE(obs_prof), INTENT(OUT) :: profdata ! Profile data to be read 73 INTEGER, INTENT(IN) :: knumfiles ! Number of files to read in 68 TYPE(obs_prof), INTENT(OUT) :: & 69 & profdata ! Profile data to be read 70 INTEGER, INTENT(IN) :: knumfiles ! Number of files to read 74 71 CHARACTER(LEN=128), INTENT(IN) :: & 75 & c filenames(knumfiles)! File names to read in72 & cdfilenames(knumfiles) ! File names to read in 76 73 INTEGER, INTENT(IN) :: kvars ! Number of variables in profdata 77 INTEGER, INTENT(IN) :: kextr ! Number of extra fields for each var in profdata 78 INTEGER, INTENT(IN) :: kstp ! Ocean time-step index 79 LOGICAL, INTENT(IN) :: ldt3d ! Observed variables switches 80 LOGICAL, INTENT(IN) :: lds3d 81 LOGICAL, INTENT(IN) :: ldignmis ! Ignore missing files 82 LOGICAL, INTENT(IN) :: ldsatt ! Compute salinity at all temperature points 83 LOGICAL, INTENT(IN) :: ldavtimset ! Correct time for daily averaged data 84 LOGICAL, INTENT(IN) :: ldmod ! Initialize model from input data 85 REAL(KIND=dp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS 86 REAL(KIND=dp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS 74 INTEGER, INTENT(IN) :: kextr ! Number of extra fields for each var 75 INTEGER, INTENT(IN) :: kstp ! Ocean time-step index 76 LOGICAL, DIMENSION(kvars), INTENT(IN) :: ldvar ! Observed variables switches 77 LOGICAL, INTENT(IN) :: ldignmis ! Ignore missing files 78 LOGICAL, INTENT(IN) :: ldsatt ! Compute salinity at all temperature points 79 LOGICAL, INTENT(IN) :: ldmod ! Initialize model from input data 80 REAL(dp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS 81 REAL(dp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS 87 82 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 88 & kdailyavtypes 83 & kdailyavtypes ! Types of daily average observations 89 84 90 85 !! * Local declarations 91 CHARACTER(LEN=15), PARAMETER :: cpname='obs_rea_pro_dri' 86 CHARACTER(LEN=15), PARAMETER :: cpname='obs_rea_prof' 87 CHARACTER(len=8) :: clrefdate 88 CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvars 92 89 INTEGER :: jvar 93 90 INTEGER :: ji … … 105 102 INTEGER :: imin 106 103 INTEGER :: isec 104 INTEGER :: iprof 105 INTEGER :: iproftot 106 INTEGER, DIMENSION(kvars) :: ivart0 107 INTEGER, DIMENSION(kvars) :: ivart 108 INTEGER :: ip3dt 109 INTEGER :: ios 110 INTEGER :: ioserrcount 111 INTEGER, DIMENSION(kvars) :: ivartmpp 112 INTEGER :: ip3dtmpp 113 INTEGER :: itype 107 114 INTEGER, DIMENSION(knumfiles) :: & 108 115 & irefdate 109 INTEGER, DIMENSION(ntyp1770+1) :: & 110 & itypt, & 111 & ityptmpp, & 112 & ityps, & 113 & itypsmpp 114 INTEGER :: it3dtmpp 115 INTEGER :: is3dtmpp 116 INTEGER :: ip3dtmpp 117 INTEGER, DIMENSION(:), ALLOCATABLE :: & 116 INTEGER, DIMENSION(ntyp1770+1,kvars) :: & 117 & itypvar, & 118 & itypvarmpp 119 INTEGER, DIMENSION(:,:), ALLOCATABLE :: & 118 120 & iobsi, & 119 121 & iobsj, & 120 & iproc, & 122 & iproc 123 INTEGER, DIMENSION(:), ALLOCATABLE :: & 121 124 & iindx, & 122 125 & ifileidx, & 123 126 & iprofidx 124 INTEGER :: itype125 127 INTEGER, DIMENSION(imaxavtypes) :: & 126 128 & idailyavtypes 129 INTEGER, DIMENSION(kvars) :: & 130 & iv3dt 127 131 REAL(wp), DIMENSION(:), ALLOCATABLE :: & 128 132 & zphi, & 129 133 & zlam 130 real(wp), DIMENSION(:), ALLOCATABLE :: &134 REAL(wp), DIMENSION(:), ALLOCATABLE :: & 131 135 & zdat 136 REAL(wp), DIMENSION(knumfiles) :: & 137 & djulini, & 138 & djulend 132 139 LOGICAL :: llvalprof 140 LOGICAL :: lldavtimset 141 LOGICAL :: llcycle 133 142 TYPE(obfbdata), POINTER, DIMENSION(:) :: & 134 143 & inpfiles 135 real(wp), DIMENSION(knumfiles) :: & 136 & djulini, & 137 & djulend 138 INTEGER :: iprof 139 INTEGER :: iproftot 140 INTEGER :: it3dt0 141 INTEGER :: is3dt0 142 INTEGER :: it3dt 143 INTEGER :: is3dt 144 INTEGER :: ip3dt 145 INTEGER :: ios 146 INTEGER :: ioserrcount 147 INTEGER, DIMENSION(kvars) :: & 148 & iv3dt 149 CHARACTER(len=8) :: cl_refdate 150 144 151 145 ! Local initialization 152 146 iprof = 0 153 it3dt0 = 0 154 is3dt0 = 0 147 ivart0(:) = 0 155 148 ip3dt = 0 156 149 157 150 ! Daily average types 151 lldavtimset = .FALSE. 158 152 IF ( PRESENT(kdailyavtypes) ) THEN 159 153 idailyavtypes(:) = kdailyavtypes(:) 154 IF ( ANY (idailyavtypes(:) /= -1) ) lldavtimset = .TRUE. 160 155 ELSE 161 156 idailyavtypes(:) = -1 … … 163 158 164 159 !----------------------------------------------------------------------- 165 ! Check data the model part is just with feedback data files166 !-----------------------------------------------------------------------167 IF ( ldmod .AND. ( kformat /= 0 ) ) THEN168 CALL ctl_stop( 'Model can only be read from feedback data' )169 RETURN170 ENDIF171 172 !-----------------------------------------------------------------------173 160 ! Count the number of files needed and allocate the obfbdata type 174 161 !----------------------------------------------------------------------- 175 162 176 163 inobf = knumfiles 177 164 178 165 ALLOCATE( inpfiles(inobf) ) 179 166 180 167 prof_files : DO jj = 1, inobf 181 168 182 169 !--------------------------------------------------------------------- 183 170 ! Prints … … 186 173 WRITE(numout,*) 187 174 WRITE(numout,*) ' obs_rea_pro_dri : Reading from file = ', & 188 & TRIM( TRIM( c filenames(jj) ) )175 & TRIM( TRIM( cdfilenames(jj) ) ) 189 176 WRITE(numout,*) ' ~~~~~~~~~~~~~~~' 190 177 WRITE(numout,*) … … 194 181 ! Initialization: Open file and get dimensions only 195 182 !--------------------------------------------------------------------- 196 197 iflag = nf90_open( TRIM( TRIM( cfilenames(jj)) ), nf90_nowrite, &183 184 iflag = nf90_open( TRIM( cdfilenames(jj) ), nf90_nowrite, & 198 185 & i_file_id ) 199 186 200 187 IF ( iflag /= nf90_noerr ) THEN 201 188 202 189 IF ( ldignmis ) THEN 203 190 inpfiles(jj)%nobs = 0 204 CALL ctl_warn( 'File ' // TRIM( TRIM( cfilenames(jj)) ) // &191 CALL ctl_warn( 'File ' // TRIM( cdfilenames(jj) ) // & 205 192 & ' not found' ) 206 193 ELSE 207 CALL ctl_stop( 'File ' // TRIM( TRIM( cfilenames(jj)) ) // &194 CALL ctl_stop( 'File ' // TRIM( cdfilenames(jj) ) // & 208 195 & ' not found' ) 209 196 ENDIF 210 197 211 198 ELSE 212 199 213 200 !------------------------------------------------------------------ 214 ! Close the file since it is opened in read_ proffile201 ! Close the file since it is opened in read_obfbdata 215 202 !------------------------------------------------------------------ 216 203 217 204 iflag = nf90_close( i_file_id ) 218 205 … … 220 207 ! Read the profile file into inpfiles 221 208 !------------------------------------------------------------------ 222 IF ( kformat == 0 ) THEN 223 CALL init_obfbdata( inpfiles(jj) ) 224 IF(lwp) THEN 225 WRITE(numout,*) 226 WRITE(numout,*)'Reading from feedback file :', & 227 & TRIM( cfilenames(jj) ) 228 ENDIF 229 CALL read_obfbdata( TRIM( cfilenames(jj) ), inpfiles(jj), & 230 & ldgrid = .TRUE. ) 231 IF ( inpfiles(jj)%nvar < 2 ) THEN 232 CALL ctl_stop( 'Feedback format error' ) 233 RETURN 234 ENDIF 235 IF ( TRIM(inpfiles(jj)%cname(1)) /= 'POTM' ) THEN 236 CALL ctl_stop( 'Feedback format error' ) 237 RETURN 238 ENDIF 239 IF ( TRIM(inpfiles(jj)%cname(2)) /= 'PSAL' ) THEN 240 CALL ctl_stop( 'Feedback format error' ) 241 RETURN 242 ENDIF 243 IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN 244 CALL ctl_stop( 'Model not in input data' ) 245 RETURN 246 ENDIF 247 ELSEIF ( kformat == 1 ) THEN 248 CALL read_enactfile( TRIM( cfilenames(jj) ), inpfiles(jj), & 249 & numout, lwp, .TRUE. ) 250 ELSEIF ( kformat == 2 ) THEN 251 CALL read_coriofile( TRIM( cfilenames(jj) ), inpfiles(jj), & 252 & numout, lwp, .TRUE. ) 209 CALL init_obfbdata( inpfiles(jj) ) 210 CALL read_obfbdata( TRIM( cdfilenames(jj) ), inpfiles(jj), & 211 & ldgrid = .TRUE. ) 212 213 IF ( inpfiles(jj)%nvar /= kvars ) THEN 214 CALL ctl_stop( 'Feedback format error: ', & 215 & ' unexpected number of vars in profile file' ) 216 ENDIF 217 218 IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN 219 CALL ctl_stop( 'Model not in input data' ) 220 ENDIF 221 222 IF ( jj == 1 ) THEN 223 ALLOCATE( clvars( inpfiles(jj)%nvar ) ) 224 DO ji = 1, inpfiles(jj)%nvar 225 clvars(ji) = inpfiles(jj)%cname(ji) 226 END DO 253 227 ELSE 254 CALL ctl_stop( 'File format unknown' ) 255 ENDIF 256 228 DO ji = 1, inpfiles(jj)%nvar 229 IF ( inpfiles(jj)%cname(ji) /= clvars(ji) ) THEN 230 CALL ctl_stop( 'Feedback file variables not consistent', & 231 & ' with previous files for this type' ) 232 ENDIF 233 END DO 234 ENDIF 235 257 236 !------------------------------------------------------------------ 258 237 ! Change longitude (-180,180) … … 272 251 ! Calculate the date (change eventually) 273 252 !------------------------------------------------------------------ 274 cl _refdate=inpfiles(jj)%cdjuldref(1:8)275 READ(cl _refdate,'(I8)') irefdate(jj)276 253 clrefdate=inpfiles(jj)%cdjuldref(1:8) 254 READ(clrefdate,'(I8)') irefdate(jj) 255 277 256 CALL ddatetoymdhms( ddobsini, iyea, imon, iday, ihou, imin, isec ) 278 257 CALL greg2jul( isec, imin, ihou, iday, imon, iyea, djulini(jj), & … … 283 262 284 263 ioserrcount=0 285 IF ( ldavtimset ) THEN 264 IF ( lldavtimset ) THEN 265 266 IF ( ANY ( idailyavtypes(:) /= -1 ) .AND. lwp) THEN 267 WRITE(numout,*)' Resetting time of daily averaged', & 268 & ' observations to the end of the day' 269 ENDIF 270 286 271 DO ji = 1, inpfiles(jj)%nobs 287 !288 ! for daily averaged data for example289 ! MRB data (itype==820) force the time290 ! to be the end of the day291 !292 272 READ( inpfiles(jj)%cdtyp(ji), '(I4)', IOSTAT = ios, ERR = 900 ) itype 293 273 900 IF ( ios /= 0 ) THEN 294 itype = 0 ! Set type to zero if there is a problem in the string conversion 295 ENDIF 296 IF ( ANY (idailyavtypes == itype ) ) THEN 297 inpfiles(jj)%ptim(ji) = & 298 & INT(inpfiles(jj)%ptim(ji)) + 1 299 ENDIF 274 ! Set type to zero if there is a problem in the string conversion 275 itype = 0 276 ENDIF 277 278 IF ( ANY ( idailyavtypes(:) == itype ) ) THEN 279 ! for daily averaged data force the time 280 ! to be the last time-step of the day, but still within the day. 281 IF ( inpfiles(jj)%ptim(ji) >= 0. ) THEN 282 inpfiles(jj)%ptim(ji) = & 283 & INT(inpfiles(jj)%ptim(ji)) + 0.9999 284 ELSE 285 inpfiles(jj)%ptim(ji) = & 286 & INT(inpfiles(jj)%ptim(ji)) - 0.0001 287 ENDIF 288 ENDIF 289 300 290 END DO 301 ENDIF 302 291 292 ENDIF 293 303 294 IF ( inpfiles(jj)%nobs > 0 ) THEN 304 inpfiles(jj)%iproc = -1305 inpfiles(jj)%iobsi = -1306 inpfiles(jj)%iobsj = -1295 inpfiles(jj)%iproc(:,:) = -1 296 inpfiles(jj)%iobsi(:,:) = -1 297 inpfiles(jj)%iobsj(:,:) = -1 307 298 ENDIF 308 299 inowin = 0 309 300 DO ji = 1, inpfiles(jj)%nobs 310 IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 311 IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .AND. & 312 & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 301 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 302 llcycle = .TRUE. 303 DO jvar = 1, kvars 304 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 305 llcycle = .FALSE. 306 EXIT 307 ENDIF 308 END DO 309 IF ( llcycle ) CYCLE 313 310 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 314 311 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 318 315 ALLOCATE( zlam(inowin) ) 319 316 ALLOCATE( zphi(inowin) ) 320 ALLOCATE( iobsi(inowin ) )321 ALLOCATE( iobsj(inowin ) )322 ALLOCATE( iproc(inowin ) )317 ALLOCATE( iobsi(inowin,kvars) ) 318 ALLOCATE( iobsj(inowin,kvars) ) 319 ALLOCATE( iproc(inowin,kvars) ) 323 320 inowin = 0 324 321 DO ji = 1, inpfiles(jj)%nobs 325 IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 326 IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .AND. & 327 & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 322 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 323 llcycle = .TRUE. 324 DO jvar = 1, kvars 325 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 326 llcycle = .FALSE. 327 EXIT 328 ENDIF 329 END DO 330 IF ( llcycle ) CYCLE 328 331 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 329 332 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 334 337 END DO 335 338 336 CALL obs_grid_search( inowin, zlam, zphi, iobsi, iobsj, iproc, 'T' ) 339 ! Assume anything other than velocity is on T grid 340 IF ( TRIM( inpfiles(jj)%cname(1) ) == 'UVEL' ) THEN 341 CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,1), iobsj(:,1), & 342 & iproc(:,1), 'U' ) 343 CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,2), iobsj(:,2), & 344 & iproc(:,2), 'V' ) 345 ELSE 346 CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,1), iobsj(:,1), & 347 & iproc(:,1), 'T' ) 348 IF ( kvars > 1 ) THEN 349 DO jvar = 2, kvars 350 iobsi(:,jvar) = iobsi(:,1) 351 iobsj(:,jvar) = iobsj(:,1) 352 iproc(:,jvar) = iproc(:,1) 353 END DO 354 ENDIF 355 ENDIF 337 356 338 357 inowin = 0 339 358 DO ji = 1, inpfiles(jj)%nobs 340 IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 341 IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .AND. & 342 & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 359 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 360 llcycle = .TRUE. 361 DO jvar = 1, kvars 362 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 363 llcycle = .FALSE. 364 EXIT 365 ENDIF 366 END DO 367 IF ( llcycle ) CYCLE 343 368 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 344 369 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN 345 370 inowin = inowin + 1 346 inpfiles(jj)%iproc(ji,1) = iproc(inowin) 347 inpfiles(jj)%iobsi(ji,1) = iobsi(inowin) 348 inpfiles(jj)%iobsj(ji,1) = iobsj(inowin) 371 DO jvar = 1, kvars 372 inpfiles(jj)%iproc(ji,jvar) = iproc(inowin,jvar) 373 inpfiles(jj)%iobsi(ji,jvar) = iobsi(inowin,jvar) 374 inpfiles(jj)%iobsj(ji,jvar) = iobsj(inowin,jvar) 375 END DO 376 IF ( kvars > 1 ) THEN 377 DO jvar = 2, kvars 378 IF ( inpfiles(jj)%iproc(ji,jvar) /= & 379 & inpfiles(jj)%iproc(ji,1) ) THEN 380 CALL ctl_stop( 'Error in obs_read_prof:', & 381 & 'observation on different processors for different vars') 382 ENDIF 383 END DO 384 ENDIF 349 385 ENDIF 350 386 END DO … … 352 388 353 389 DO ji = 1, inpfiles(jj)%nobs 354 IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 355 IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .AND. & 356 & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 390 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 391 llcycle = .TRUE. 392 DO jvar = 1, kvars 393 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 394 llcycle = .FALSE. 395 EXIT 396 ENDIF 397 END DO 398 IF ( llcycle ) CYCLE 357 399 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 358 400 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 363 405 ENDIF 364 406 llvalprof = .FALSE. 365 IF ( ldt3d ) THEN 366 loop_t_count : DO ij = 1,inpfiles(jj)%nlev 367 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 368 & CYCLE 369 IF ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2 ) .AND. & 370 & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) THEN 371 it3dt0 = it3dt0 + 1 372 ENDIF 373 END DO loop_t_count 374 ENDIF 375 IF ( lds3d ) THEN 376 loop_s_count : DO ij = 1,inpfiles(jj)%nlev 377 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 378 & CYCLE 379 IF ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2 ) .AND. & 380 & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) THEN 381 is3dt0 = is3dt0 + 1 382 ENDIF 383 END DO loop_s_count 384 ENDIF 385 loop_p_count : DO ij = 1,inpfiles(jj)%nlev 407 DO jvar = 1, kvars 408 IF ( ldvar(jvar) ) THEN 409 DO ij = 1,inpfiles(jj)%nlev 410 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 411 & CYCLE 412 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 413 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 414 ivart0(jvar) = ivart0(jvar) + 1 415 ENDIF 416 END DO 417 ENDIF 418 END DO 419 DO ij = 1,inpfiles(jj)%nlev 386 420 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 387 421 & CYCLE 388 IF ( ( ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2 ) .AND. &389 & ( inpfiles(jj)%idqc(ij,ji) <= 2 )) .AND. &390 & ldt3d ) .OR. &391 & ( ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2 ) .AND. &392 & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) .AND. &393 & lds3d ) ) THEN394 ip3dt = ip3dt + 1395 llvalprof = .TRUE.396 END IF397 END DO loop_p_count422 DO jvar = 1, kvars 423 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 424 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 425 & ldvar(jvar) ) ) THEN 426 ip3dt = ip3dt + 1 427 llvalprof = .TRUE. 428 EXIT 429 ENDIF 430 END DO 431 END DO 398 432 399 433 IF ( llvalprof ) iprof = iprof + 1 … … 405 439 406 440 END DO prof_files 407 441 408 442 !----------------------------------------------------------------------- 409 443 ! Get the time ordered indices of the input data … … 416 450 DO jj = 1, inobf 417 451 DO ji = 1, inpfiles(jj)%nobs 418 IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 419 IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .AND. & 420 & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 452 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 453 llcycle = .TRUE. 454 DO jvar = 1, kvars 455 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 456 llcycle = .FALSE. 457 EXIT 458 ENDIF 459 END DO 460 IF ( llcycle ) CYCLE 421 461 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 422 462 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 431 471 DO jj = 1, inobf 432 472 DO ji = 1, inpfiles(jj)%nobs 433 IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 434 IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .AND. & 435 & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 473 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 474 llcycle = .TRUE. 475 DO jvar = 1, kvars 476 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 477 llcycle = .FALSE. 478 EXIT 479 ENDIF 480 END DO 481 IF ( llcycle ) CYCLE 436 482 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 437 483 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 446 492 & zdat, & 447 493 & iindx ) 448 494 449 495 iv3dt(:) = -1 450 496 IF (ldsatt) THEN 451 iv3dt(1) = ip3dt 452 iv3dt(2) = ip3dt 497 iv3dt(:) = ip3dt 453 498 ELSE 454 iv3dt(1) = it3dt0 455 iv3dt(2) = is3dt0 499 iv3dt(:) = ivart0(:) 456 500 ENDIF 457 501 CALL obs_prof_alloc( profdata, kvars, kextr, iprof, iv3dt, & 458 502 & kstp, jpi, jpj, jpk ) 459 503 460 504 ! * Read obs/positions, QC, all variable and assign to profdata 461 505 462 506 profdata%nprof = 0 463 507 profdata%nvprot(:) = 0 464 508 profdata%cvars(:) = clvars(:) 465 509 iprof = 0 466 510 467 511 ip3dt = 0 468 it3dt = 0 469 is3dt = 0 470 itypt (:) = 0 471 ityptmpp(:) = 0 472 473 ityps (:) = 0 474 itypsmpp(:) = 0 475 476 ioserrcount = 0 512 ivart(:) = 0 513 itypvar (:,:) = 0 514 itypvarmpp(:,:) = 0 515 516 ioserrcount = 0 477 517 DO jk = 1, iproftot 478 518 479 519 jj = ifileidx(iindx(jk)) 480 520 ji = iprofidx(iindx(jk)) 481 521 482 IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 483 IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .AND. & 484 & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 522 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 523 llcycle = .TRUE. 524 DO jvar = 1, kvars 525 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 526 llcycle = .FALSE. 527 EXIT 528 ENDIF 529 END DO 530 IF ( llcycle ) CYCLE 485 531 486 532 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 487 533 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN 488 534 489 535 IF ( nproc == 0 ) THEN 490 536 IF ( inpfiles(jj)%iproc(ji,1) > nproc ) CYCLE … … 492 538 IF ( inpfiles(jj)%iproc(ji,1) /= nproc ) CYCLE 493 539 ENDIF 494 540 495 541 llvalprof = .FALSE. 496 542 497 543 IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 498 544 499 IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .AND. & 500 & ( inpfiles(jj)%ivqc(ji,2) > 2 ) ) CYCLE 545 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 546 llcycle = .TRUE. 547 DO jvar = 1, kvars 548 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 549 llcycle = .FALSE. 550 EXIT 551 ENDIF 552 END DO 553 IF ( llcycle ) CYCLE 501 554 502 555 loop_prof : DO ij = 1, inpfiles(jj)%nlev 503 556 504 557 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 505 558 & CYCLE 506 507 IF ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2 ) .AND. & 508 & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) THEN 509 510 llvalprof = .TRUE. 511 EXIT loop_prof 512 513 ENDIF 514 515 IF ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2 ) .AND. & 516 & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) THEN 517 518 llvalprof = .TRUE. 519 EXIT loop_prof 520 521 ENDIF 522 559 560 DO jvar = 1, kvars 561 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 562 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 563 564 llvalprof = .TRUE. 565 EXIT loop_prof 566 567 ENDIF 568 END DO 569 523 570 END DO loop_prof 524 571 525 572 ! Set profile information 526 573 527 574 IF ( llvalprof ) THEN 528 575 529 576 iprof = iprof + 1 530 577 … … 545 592 profdata%nhou(iprof) = ihou 546 593 profdata%nmin(iprof) = imin 547 594 548 595 ! Profile space coordinates 549 596 profdata%rlam(iprof) = inpfiles(jj)%plam(ji) … … 551 598 552 599 ! Coordinate search parameters 553 profdata%mi (iprof,:) = inpfiles(jj)%iobsi(ji,1) 554 profdata%mj (iprof,:) = inpfiles(jj)%iobsj(ji,1) 555 600 DO jvar = 1, kvars 601 profdata%mi (iprof,jvar) = inpfiles(jj)%iobsi(ji,jvar) 602 profdata%mj (iprof,jvar) = inpfiles(jj)%iobsj(ji,jvar) 603 END DO 604 556 605 ! Profile WMO number 557 606 profdata%cwmo(iprof) = inpfiles(jj)%cdwmo(ji) 558 607 559 608 ! Instrument type 560 609 READ( inpfiles(jj)%cdtyp(ji), '(I4)', IOSTAT = ios, ERR = 901 ) itype … … 564 613 itype = 0 565 614 ENDIF 566 615 567 616 profdata%ntyp(iprof) = itype 568 617 569 618 ! QC stuff 570 619 … … 585 634 profdata%nqc(iprof) = 0 !TODO 586 635 587 loop_p : DO ij = 1, inpfiles(jj)%nlev 588 636 loop_p : DO ij = 1, inpfiles(jj)%nlev 637 589 638 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 590 639 & CYCLE … … 592 641 IF (ldsatt) THEN 593 642 594 IF ( ( ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2 ) .AND. & 595 & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) .AND. & 596 & ldt3d ) .OR. & 597 & ( ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2 ) .AND. & 598 & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) .AND. & 599 & lds3d ) ) THEN 600 ip3dt = ip3dt + 1 601 ELSE 602 CYCLE 643 DO jvar = 1, kvars 644 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 645 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 646 & ldvar(jvar) ) ) THEN 647 ip3dt = ip3dt + 1 648 EXIT 649 ELSE IF ( jvar == kvars ) THEN 650 CYCLE loop_p 651 ENDIF 652 END DO 653 654 ENDIF 655 656 DO jvar = 1, kvars 657 658 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 659 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 660 & ldvar(jvar) ) .OR. ldsatt ) THEN 661 662 IF (ldsatt) THEN 663 664 ivart(jvar) = ip3dt 665 666 ELSE 667 668 ivart(jvar) = ivart(jvar) + 1 669 670 ENDIF 671 672 ! Depth of jvar observation 673 profdata%var(jvar)%vdep(ivart(jvar)) = & 674 & inpfiles(jj)%pdep(ij,ji) 675 676 ! Depth of jvar observation QC 677 profdata%var(jvar)%idqc(ivart(jvar)) = & 678 & inpfiles(jj)%idqc(ij,ji) 679 680 ! Depth of jvar observation QC flags 681 profdata%var(jvar)%idqcf(:,ivart(jvar)) = & 682 & inpfiles(jj)%idqcf(:,ij,ji) 683 684 ! Profile index 685 profdata%var(jvar)%nvpidx(ivart(jvar)) = iprof 686 687 ! Vertical index in original profile 688 profdata%var(jvar)%nvlidx(ivart(jvar)) = ij 689 690 ! Profile jvar value 691 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 692 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 693 profdata%var(jvar)%vobs(ivart(jvar)) = & 694 & inpfiles(jj)%pob(ij,ji,jvar) 695 IF ( ldmod ) THEN 696 profdata%var(jvar)%vmod(ivart(jvar)) = & 697 & inpfiles(jj)%padd(ij,ji,1,jvar) 698 ENDIF 699 ! Count number of profile var1 data as function of type 700 itypvar( profdata%ntyp(iprof) + 1, jvar ) = & 701 & itypvar( profdata%ntyp(iprof) + 1, jvar ) + 1 702 ELSE 703 profdata%var(jvar)%vobs(ivart(jvar)) = fbrmdi 704 ENDIF 705 706 ! Profile jvar qc 707 profdata%var(jvar)%nvqc(ivart(jvar)) = & 708 & inpfiles(jj)%ivlqc(ij,ji,jvar) 709 710 ! Profile jvar qc flags 711 profdata%var(jvar)%nvqcf(:,ivart(jvar)) = & 712 & inpfiles(jj)%ivlqcf(:,ij,ji,jvar) 713 714 ! Profile insitu T value 715 IF ( TRIM( inpfiles(jj)%cname(jvar) ) == 'POTM' ) THEN 716 profdata%var(jvar)%vext(ivart(jvar),1) = & 717 & inpfiles(jj)%pext(ij,ji,1) 718 ENDIF 719 603 720 ENDIF 604 605 ENDIF606 607 IF ( ( ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2 ) .AND. &608 & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) .AND. &609 & ldt3d ) .OR. ldsatt ) THEN610 611 IF (ldsatt) THEN612 613 it3dt = ip3dt614 615 ELSE616 617 it3dt = it3dt + 1618 619 ENDIF620 621 ! Depth of T observation622 profdata%var(1)%vdep(it3dt) = &623 & inpfiles(jj)%pdep(ij,ji)624 625 ! Depth of T observation QC626 profdata%var(1)%idqc(it3dt) = &627 & inpfiles(jj)%idqc(ij,ji)628 629 ! Depth of T observation QC flags630 profdata%var(1)%idqcf(:,it3dt) = &631 & inpfiles(jj)%idqcf(:,ij,ji)632 633 ! Profile index634 profdata%var(1)%nvpidx(it3dt) = iprof635 636 ! Vertical index in original profile637 profdata%var(1)%nvlidx(it3dt) = ij638 639 ! Profile potential T value640 IF ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2 ) .AND. &641 & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) THEN642 profdata%var(1)%vobs(it3dt) = &643 & inpfiles(jj)%pob(ij,ji,1)644 IF ( ldmod ) THEN645 profdata%var(1)%vmod(it3dt) = &646 & inpfiles(jj)%padd(ij,ji,1,1)647 ENDIF648 ! Count number of profile T data as function of type649 itypt( profdata%ntyp(iprof) + 1 ) = &650 & itypt( profdata%ntyp(iprof) + 1 ) + 1651 ELSE652 profdata%var(1)%vobs(it3dt) = fbrmdi653 ENDIF654 655 ! Profile T qc656 profdata%var(1)%nvqc(it3dt) = &657 & inpfiles(jj)%ivlqc(ij,ji,1)658 659 ! Profile T qc flags660 profdata%var(1)%nvqcf(:,it3dt) = &661 & inpfiles(jj)%ivlqcf(:,ij,ji,1)662 663 ! Profile insitu T value664 profdata%var(1)%vext(it3dt,1) = &665 & inpfiles(jj)%pext(ij,ji,1)666 667 ENDIF668 721 669 IF ( ( ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2 ) .AND. & 670 & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) .AND. & 671 & lds3d ) .OR. ldsatt ) THEN 672 673 IF (ldsatt) THEN 674 675 is3dt = ip3dt 676 677 ELSE 678 679 is3dt = is3dt + 1 680 681 ENDIF 682 683 ! Depth of S observation 684 profdata%var(2)%vdep(is3dt) = & 685 & inpfiles(jj)%pdep(ij,ji) 686 687 ! Depth of S observation QC 688 profdata%var(2)%idqc(is3dt) = & 689 & inpfiles(jj)%idqc(ij,ji) 690 691 ! Depth of S observation QC flags 692 profdata%var(2)%idqcf(:,is3dt) = & 693 & inpfiles(jj)%idqcf(:,ij,ji) 694 695 ! Profile index 696 profdata%var(2)%nvpidx(is3dt) = iprof 697 698 ! Vertical index in original profile 699 profdata%var(2)%nvlidx(is3dt) = ij 700 701 ! Profile S value 702 IF ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2 ) .AND. & 703 & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) THEN 704 profdata%var(2)%vobs(is3dt) = & 705 & inpfiles(jj)%pob(ij,ji,2) 706 IF ( ldmod ) THEN 707 profdata%var(2)%vmod(is3dt) = & 708 & inpfiles(jj)%padd(ij,ji,1,2) 709 ENDIF 710 ! Count number of profile S data as function of type 711 ityps( profdata%ntyp(iprof) + 1 ) = & 712 & ityps( profdata%ntyp(iprof) + 1 ) + 1 713 ELSE 714 profdata%var(2)%vobs(is3dt) = fbrmdi 715 ENDIF 716 717 ! Profile S qc 718 profdata%var(2)%nvqc(is3dt) = & 719 & inpfiles(jj)%ivlqc(ij,ji,2) 720 721 ! Profile S qc flags 722 profdata%var(2)%nvqcf(:,is3dt) = & 723 & inpfiles(jj)%ivlqcf(:,ij,ji,2) 724 725 ENDIF 726 722 END DO 723 727 724 END DO loop_p 728 725 … … 736 733 ! Sum up over processors 737 734 !----------------------------------------------------------------------- 738 739 CALL obs_mpp_sum_integer ( it3dt0, it3dtmpp ) 740 CALL obs_mpp_sum_integer ( is3dt0, is3dtmpp ) 741 CALL obs_mpp_sum_integer ( ip3dt, ip3dtmpp ) 742 743 CALL obs_mpp_sum_integers( itypt, ityptmpp, ntyp1770 + 1 ) 744 CALL obs_mpp_sum_integers( ityps, itypsmpp, ntyp1770 + 1 ) 745 735 736 DO jvar = 1, kvars 737 CALL obs_mpp_sum_integer ( ivart0(jvar), ivartmpp(jvar) ) 738 END DO 739 CALL obs_mpp_sum_integer ( ip3dt, ip3dtmpp ) 740 741 DO jvar = 1, kvars 742 CALL obs_mpp_sum_integers( itypvar(:,jvar), itypvarmpp(:,jvar), ntyp1770 + 1 ) 743 END DO 744 746 745 !----------------------------------------------------------------------- 747 746 ! Output number of observations. … … 749 748 IF(lwp) THEN 750 749 WRITE(numout,*) 751 WRITE(numout,'( 1X,A)') 'Profile data'750 WRITE(numout,'(A)') ' Profile data' 752 751 WRITE(numout,'(1X,A)') '------------' 753 752 WRITE(numout,*) 754 WRITE(numout,'(1X,A)') 'Profile T data' 755 WRITE(numout,'(1X,A)') '--------------' 756 DO ji = 0, ntyp1770 757 IF ( ityptmpp(ji+1) > 0 ) THEN 758 WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 759 & cwmonam1770(ji)(1:52),' = ', & 760 & ityptmpp(ji+1) 761 ENDIF 753 DO jvar = 1, kvars 754 WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(jvar) ) 755 WRITE(numout,'(1X,A)') '------------------------' 756 DO ji = 0, ntyp1770 757 IF ( itypvarmpp(ji+1,jvar) > 0 ) THEN 758 WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 759 & cwmonam1770(ji)(1:52),' = ', & 760 & itypvarmpp(ji+1,jvar) 761 ENDIF 762 END DO 763 WRITE(numout,'(1X,A)') & 764 & '---------------------------------------------------------------' 765 WRITE(numout,'(1X,A55,I8)') & 766 & 'Total profile data for variable '//TRIM( profdata%cvars(jvar) )// & 767 & ' = ', ivartmpp(jvar) 768 WRITE(numout,'(1X,A)') & 769 & '---------------------------------------------------------------' 770 WRITE(numout,*) 762 771 END DO 763 WRITE(numout,'(1X,A)') & 764 & '---------------------------------------------------------------' 765 WRITE(numout,'(1X,A55,I8)') & 766 & 'Total profile T data = ',& 767 & it3dtmpp 768 WRITE(numout,'(1X,A)') & 769 & '---------------------------------------------------------------' 770 WRITE(numout,*) 771 WRITE(numout,'(1X,A)') 'Profile S data' 772 WRITE(numout,'(1X,A)') '--------------' 773 DO ji = 0, ntyp1770 774 IF ( itypsmpp(ji+1) > 0 ) THEN 775 WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 776 & cwmonam1770(ji)(1:52),' = ', & 777 & itypsmpp(ji+1) 778 ENDIF 772 ENDIF 773 774 IF (ldsatt) THEN 775 profdata%nvprot(:) = ip3dt 776 profdata%nvprotmpp(:) = ip3dtmpp 777 ELSE 778 DO jvar = 1, kvars 779 profdata%nvprot(jvar) = ivart(jvar) 780 profdata%nvprotmpp(jvar) = ivartmpp(jvar) 779 781 END DO 780 WRITE(numout,'(1X,A)') &781 & '---------------------------------------------------------------'782 WRITE(numout,'(1X,A55,I8)') &783 & 'Total profile S data = ',&784 & is3dtmpp785 WRITE(numout,'(1X,A)') &786 & '---------------------------------------------------------------'787 WRITE(numout,*)788 ENDIF789 790 IF (ldsatt) THEN791 profdata%nvprot(1) = ip3dt792 profdata%nvprot(2) = ip3dt793 profdata%nvprotmpp(1) = ip3dtmpp794 profdata%nvprotmpp(2) = ip3dtmpp795 ELSE796 profdata%nvprot(1) = it3dt797 profdata%nvprot(2) = is3dt798 profdata%nvprotmpp(1) = it3dtmpp799 profdata%nvprotmpp(2) = is3dtmpp800 782 ENDIF 801 783 profdata%nprof = iprof … … 804 786 ! Model level search 805 787 !----------------------------------------------------------------------- 806 IF ( ldt3d ) THEN 807 CALL obs_level_search( jpk, gdept_1d, & 808 & profdata%nvprot(1), profdata%var(1)%vdep, & 809 & profdata%var(1)%mvk ) 810 ENDIF 811 IF ( lds3d ) THEN 812 CALL obs_level_search( jpk, gdept_1d, & 813 & profdata%nvprot(2), profdata%var(2)%vdep, & 814 & profdata%var(2)%mvk ) 815 ENDIF 816 788 DO jvar = 1, kvars 789 IF ( ldvar(jvar) ) THEN 790 CALL obs_level_search( jpk, gdept_1d, & 791 & profdata%nvprot(jvar), profdata%var(jvar)%vdep, & 792 & profdata%var(jvar)%mvk ) 793 ENDIF 794 END DO 795 817 796 !----------------------------------------------------------------------- 818 797 ! Set model equivalent to 99999 … … 826 805 ! Deallocate temporary data 827 806 !----------------------------------------------------------------------- 828 DEALLOCATE( ifileidx, iprofidx, zdat )807 DEALLOCATE( ifileidx, iprofidx, zdat, clvars ) 829 808 830 809 !----------------------------------------------------------------------- … … 836 815 DEALLOCATE( inpfiles ) 837 816 838 END SUBROUTINE obs_rea_pro _dri817 END SUBROUTINE obs_rea_prof 839 818 840 819 END MODULE obs_read_prof -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/OBS/obs_readmdt.F90
r10246 r10247 31 31 PRIVATE 32 32 33 PUBLIC obs_rea_mdt ! called by ?34 PUBLIC obs_offset_mdt ! called by ?35 36 INTEGER , PUBLIC :: nmsshc = 1 ! MDT correction scheme37 REAL(wp), PUBLIC :: mdtcorr = 1.61_wp! User specified MDT correction38 REAL(wp), PUBLIC :: mdtcutoff = 65.0_wp! MDT cutoff for computed correction33 PUBLIC obs_rea_mdt ! called by dia_obs_init 34 PUBLIC obs_offset_mdt ! called by obs_rea_mdt 35 36 INTEGER , PUBLIC :: nn_msshc = 1 ! MDT correction scheme 37 REAL(wp), PUBLIC :: rn_mdtcorr = 1.61_wp ! User specified MDT correction 38 REAL(wp), PUBLIC :: rn_mdtcutoff = 65.0_wp ! MDT cutoff for computed correction 39 39 40 40 !!---------------------------------------------------------------------- … … 45 45 CONTAINS 46 46 47 SUBROUTINE obs_rea_mdt( kslano,sladata, k2dint )47 SUBROUTINE obs_rea_mdt( sladata, k2dint ) 48 48 !!--------------------------------------------------------------------- 49 49 !! … … 58 58 USE iom 59 59 ! 60 INTEGER , INTENT(IN) :: kslano ! Number of SLA Products 61 TYPE(obs_surf), DIMENSION(kslano), INTENT(inout) :: sladata ! SLA data 62 INTEGER , INTENT(in) :: k2dint ! ? 60 TYPE(obs_surf), INTENT(inout) :: sladata ! SLA data 61 INTEGER , INTENT(in) :: k2dint ! ? 63 62 ! 64 63 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_rea_mdt' 65 64 CHARACTER(LEN=20), PARAMETER :: mdtname = 'slaReferenceLevel.nc' 66 65 67 INTEGER :: jslano ! Data set loop variable68 66 INTEGER :: jobs ! Obs loop variable 69 67 INTEGER :: jpimdt, jpjmdt ! Number of grid point in lat/lon for the MDT … … 88 86 IF(lwp)WRITE(numout,*) ' obs_rea_mdt : Read MDT for referencing altimeter anomalies' 89 87 IF(lwp)WRITE(numout,*) ' ------------- ' 88 CALL FLUSH(numout) 90 89 91 90 CALL iom_open( mdtname, nummdt ) ! Open the file … … 109 108 110 109 ! Remove the offset between the MDT used with the sla and the model MDT 111 IF( nmsshc == 1 .OR. nmsshc == 2 ) CALL obs_offset_mdt( z_mdt, zfill ) 110 IF( nn_msshc == 1 .OR. nn_msshc == 2 ) & 111 & CALL obs_offset_mdt( jpi, jpj, z_mdt, zfill ) 112 112 113 113 ! Intepolate the MDT already on the model grid at the observation point 114 114 115 DO jslano = 1, kslano 116 ALLOCATE( & 117 & igrdi(2,2,sladata(jslano)%nsurf), & 118 & igrdj(2,2,sladata(jslano)%nsurf), & 119 & zglam(2,2,sladata(jslano)%nsurf), & 120 & zgphi(2,2,sladata(jslano)%nsurf), & 121 & zmask(2,2,sladata(jslano)%nsurf), & 122 & zmdtl(2,2,sladata(jslano)%nsurf) & 123 & ) 115 ALLOCATE( & 116 & igrdi(2,2,sladata%nsurf), & 117 & igrdj(2,2,sladata%nsurf), & 118 & zglam(2,2,sladata%nsurf), & 119 & zgphi(2,2,sladata%nsurf), & 120 & zmask(2,2,sladata%nsurf), & 121 & zmdtl(2,2,sladata%nsurf) & 122 & ) 124 123 125 DO jobs = 1, sladata(jslano)%nsurf126 127 igrdi(1,1,jobs) = sladata(jslano)%mi(jobs)-1128 igrdj(1,1,jobs) = sladata(jslano)%mj(jobs)-1129 igrdi(1,2,jobs) = sladata(jslano)%mi(jobs)-1130 igrdj(1,2,jobs) = sladata(jslano)%mj(jobs)131 igrdi(2,1,jobs) = sladata(jslano)%mi(jobs)132 igrdj(2,1,jobs) = sladata(jslano)%mj(jobs)-1133 igrdi(2,2,jobs) = sladata(jslano)%mi(jobs)134 igrdj(2,2,jobs) = sladata(jslano)%mj(jobs)135 136 137 138 CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, igrdi, igrdj, glamt , zglam )139 CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, igrdi, igrdj, gphit , zgphi )140 CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, igrdi, igrdj, mdtmask, zmask )141 CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, igrdi, igrdj, z_mdt , zmdtl )142 143 DO jobs = 1, sladata(jslano)%nsurf124 DO jobs = 1, sladata%nsurf 125 126 igrdi(1,1,jobs) = sladata%mi(jobs)-1 127 igrdj(1,1,jobs) = sladata%mj(jobs)-1 128 igrdi(1,2,jobs) = sladata%mi(jobs)-1 129 igrdj(1,2,jobs) = sladata%mj(jobs) 130 igrdi(2,1,jobs) = sladata%mi(jobs) 131 igrdj(2,1,jobs) = sladata%mj(jobs)-1 132 igrdi(2,2,jobs) = sladata%mi(jobs) 133 igrdj(2,2,jobs) = sladata%mj(jobs) 134 135 END DO 136 137 CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, glamt , zglam ) 138 CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, gphit , zgphi ) 139 CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, mdtmask, zmask ) 140 CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, z_mdt , zmdtl ) 141 142 DO jobs = 1, sladata%nsurf 144 143 145 zlam = sladata(jslano)%rlam(jobs)146 zphi = sladata(jslano)%rphi(jobs)147 148 149 150 144 zlam = sladata%rlam(jobs) 145 zphi = sladata%rphi(jobs) 146 147 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 148 & zglam(:,:,jobs), zgphi(:,:,jobs), & 149 & zmask(:,:,jobs), zweig, zobsmask ) 151 150 152 151 CALL obs_int_h2d( 1, 1, zweig, zmdtl(:,:,jobs), zext ) 153 152 154 sladata(jslano)%rext(jobs,2) = zext(1)153 sladata%rext(jobs,2) = zext(1) 155 154 156 155 ! mark any masked data with a QC flag 157 IF( zobsmask(1) == 0 ) sladata(jslano)%nqc(jobs) = 11156 IF( zobsmask(1) == 0 ) sladata%nqc(jobs) = IBSET(sladata%nqc(jobs),15) 158 157 159 158 END DO 160 159 161 DEALLOCATE( & 162 & igrdi, & 163 & igrdj, & 164 & zglam, & 165 & zgphi, & 166 & zmask, & 167 & zmdtl & 168 & ) 169 170 END DO 160 DEALLOCATE( & 161 & igrdi, & 162 & igrdj, & 163 & zglam, & 164 & zgphi, & 165 & zmask, & 166 & zmdtl & 167 & ) 171 168 172 169 CALL wrk_dealloc(jpi,jpj,z_mdt,mdtmask) 170 IF(lwp)WRITE(numout,*) ' ------------- ' 173 171 ! 174 172 END SUBROUTINE obs_rea_mdt 175 173 176 174 177 SUBROUTINE obs_offset_mdt( mdt, zfill )175 SUBROUTINE obs_offset_mdt( kpi, kpj, mdt, zfill ) 178 176 !!--------------------------------------------------------------------- 179 177 !! … … 188 186 !! ** Action : 189 187 !!---------------------------------------------------------------------- 190 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: mdt ! MDT used on the model grid 191 REAL(wp) , INTENT(in ) :: zfill 188 INTEGER, INTENT(IN) :: kpi, kpj 189 REAL(wp), DIMENSION(kpi,kpj), INTENT(INOUT) :: mdt ! MDT used on the model grid 190 REAL(wp) , INTENT(IN ) :: zfill 192 191 ! 193 192 INTEGER :: ji, jj … … 205 204 DO jj = 1, jpj 206 205 zpromsk(ji,jj) = tmask_i(ji,jj) 207 IF ( ( gphit(ji,jj) .GT. mdtcutoff ) &208 &.OR.( gphit(ji,jj) .LT. - mdtcutoff ) &206 IF ( ( gphit(ji,jj) .GT. rn_mdtcutoff ) & 207 &.OR.( gphit(ji,jj) .LT. -rn_mdtcutoff ) & 209 208 &.OR.( mdt(ji,jj) .EQ. zfill ) ) & 210 209 & zpromsk(ji,jj) = 0.0 … … 212 211 END DO 213 212 214 ! Compute MSSH mean over [0,360] x [- mdtcutoff,mdtcutoff]213 ! Compute MSSH mean over [0,360] x [-rn_mdtcutoff,rn_mdtcutoff] 215 214 216 215 zarea = 0.0 … … 240 239 ! Correct spatial mean of the MSSH 241 240 242 IF( n msshc == 1 ) mdt(:,:) = mdt(:,:) - zcorr241 IF( nn_msshc == 1 ) mdt(:,:) = mdt(:,:) - zcorr 243 242 244 243 ! User defined value : 1.6 m for the Rio MDT compared to ORCA2 MDT 245 244 246 IF( n msshc == 2 ) mdt(:,:) = mdt(:,:) -mdtcorr245 IF( nn_msshc == 2 ) mdt(:,:) = mdt(:,:) - rn_mdtcorr 247 246 248 247 IF(lwp) THEN 249 248 WRITE(numout,*) 250 WRITE(numout,*) ' obs_readmdt : mdtcutoff = ',mdtcutoff249 WRITE(numout,*) ' obs_readmdt : rn_mdtcutoff = ', rn_mdtcutoff 251 250 WRITE(numout,*) ' ----------- zcorr_mdt = ', zcorr_mdt 252 251 WRITE(numout,*) ' zcorr_bcketa = ', zcorr_bcketa 253 252 WRITE(numout,*) ' zcorr = ', zcorr 254 WRITE(numout,*) ' n msshc = ', nmsshc253 WRITE(numout,*) ' nn_msshc = ', nn_msshc 255 254 ENDIF 256 255 257 IF ( n msshc == 0 ) WRITE(numout,*) ' MSSH correction is not applied'258 IF ( n msshc == 1 ) WRITE(numout,*) ' MSSH correction is applied'259 IF ( n msshc == 2 ) WRITE(numout,*) ' User defined MSSH correction'256 IF ( nn_msshc == 0 ) WRITE(numout,*) ' MSSH correction is not applied' 257 IF ( nn_msshc == 1 ) WRITE(numout,*) ' MSSH correction is applied' 258 IF ( nn_msshc == 2 ) WRITE(numout,*) ' User defined MSSH correction' 260 259 261 260 CALL wrk_dealloc( jpi,jpj, zpromsk ) -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/OBS/obs_rot_vel.F90
r10246 r10247 140 140 END DO 141 141 142 CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, &142 CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & 143 143 & glamu, zglamu ) 144 CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, &144 CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & 145 145 & gphiu, zgphiu ) 146 CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, &146 CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & 147 147 & umask(:,:,1), zmasku ) 148 CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, &148 CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & 149 149 & zsingu, zsinlu ) 150 CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, &150 CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & 151 151 & zcosgu, zcoslu ) 152 CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, &152 CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & 153 153 & glamv, zglamv ) 154 CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, &154 CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & 155 155 & gphiv, zgphiv ) 156 CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, &156 CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & 157 157 & vmask(:,:,1), zmaskv ) 158 CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, &158 CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & 159 159 & zsingv, zsinlv ) 160 CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, &160 CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & 161 161 & zcosgv, zcoslv ) 162 162 … … 195 195 DO jk = profdata%npvsta(ji,1), profdata%npvend(ji,1) 196 196 IF ( ( profdata%var(1)%vmod(jk) /= fbrmdi ) .AND. & 197 & ( profdata%var( 1)%vmod(jk) /= fbrmdi ) ) THEN197 & ( profdata%var(2)%vmod(jk) /= fbrmdi ) ) THEN 198 198 pu(jk) = profdata%var(1)%vmod(jk) * zcos - & 199 & profdata%var(2)%vmod(jk) * zsin 199 & profdata%var(2)%vmod(jk) * zsin 200 200 pv(jk) = profdata%var(2)%vmod(jk) * zcos + & 201 201 & profdata%var(1)%vmod(jk) * zsin … … 204 204 pv(jk) = fbrmdi 205 205 ENDIF 206 206 207 END DO 207 208 -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/OBS/obs_surf_def.F90
r10246 r10247 50 50 INTEGER :: npj 51 51 INTEGER :: nsurfup !: Observation counter used in obs_oper 52 INTEGER :: nrec !: Number of surface observation records in window 52 53 53 54 ! Arrays with size equal to the number of surface observations … … 56 57 & mi, & !: i-th grid coord. for interpolating to surface observation 57 58 & mj, & !: j-th grid coord. for interpolating to surface observation 59 & mt, & !: time record number for gridded data 58 60 & nsidx,& !: Surface observation number 59 61 & nsfil,& !: Surface observation number in file … … 67 69 & ntyp !: Type of surface observation product 68 70 71 CHARACTER(len=8), POINTER, DIMENSION(:) :: & 72 & cvars !: Variable names 73 74 CHARACTER(len=8), POINTER, DIMENSION(:) :: & 75 & cext !: Extra field names 76 69 77 CHARACTER(LEN=8), POINTER, DIMENSION(:) :: & 70 78 & cwmo !: WMO indentifier … … 90 98 & nsstpmpp !: Global number of surface observations per time step 91 99 100 ! Arrays with size equal to the number of observation records in the window 101 INTEGER, POINTER, DIMENSION(:) :: & 102 & mrecstp ! Time step of the records 103 92 104 ! Arrays used to store source indices when 93 105 ! compressing obs_surf derived types … … 97 109 INTEGER, POINTER, DIMENSION(:) :: & 98 110 & nsind !: Source indices of surface data in compressed data 111 112 ! Is this a gridded product? 113 114 LOGICAL :: lgrid 99 115 100 116 END TYPE obs_surf … … 130 146 !!* Local variables 131 147 INTEGER :: ji 148 INTEGER :: jvar 132 149 133 150 ! Set bookkeeping variables … … 140 157 surf%npi = kpi 141 158 surf%npj = kpj 159 160 ! Allocate arrays of size number of variables 161 162 ALLOCATE( & 163 & surf%cvars(kvar) & 164 & ) 165 166 DO jvar = 1, kvar 167 surf%cvars(jvar) = "NotSet" 168 END DO 142 169 143 170 ! Allocate arrays of number of surface data size … … 146 173 & surf%mi(ksurf), & 147 174 & surf%mj(ksurf), & 175 & surf%mt(ksurf), & 148 176 & surf%nsidx(ksurf), & 149 177 & surf%nsfil(ksurf), & … … 162 190 & ) 163 191 192 surf%mt(:) = -1 193 164 194 165 195 ! Allocate arrays of number of surface data size * number of variables … … 173 203 174 204 ALLOCATE( & 175 & surf%rext(ksurf,kextra) & 176 & ) 205 & surf%rext(ksurf,kextra), & 206 & surf%cext(kextra) & 207 & ) 208 209 surf%rext(:,:) = 0.0_wp 210 211 DO ji = 1, kextra 212 surf%cext(ji) = "NotSet" 213 END DO 177 214 178 215 ! Allocate arrays of number of time step size … … 203 240 204 241 surf%nsurfup = 0 242 243 ! Not gridded by default 244 245 surf%lgrid = .FALSE. 205 246 206 247 END SUBROUTINE obs_surf_alloc … … 228 269 & surf%mi, & 229 270 & surf%mj, & 271 & surf%mt, & 230 272 & surf%nsidx, & 231 273 & surf%nsfil, & … … 254 296 255 297 DEALLOCATE( & 256 & surf%rext & 298 & surf%rext, & 299 & surf%cext & 257 300 & ) 258 301 … … 269 312 & surf%nsstp, & 270 313 & surf%nsstpmpp & 314 & ) 315 316 ! Dellocate arrays of size number of variables 317 318 DEALLOCATE( & 319 & surf%cvars & 271 320 & ) 272 321 … … 350 399 newsurf%mi(insurf) = surf%mi(ji) 351 400 newsurf%mj(insurf) = surf%mj(ji) 401 newsurf%mt(insurf) = surf%mt(ji) 352 402 newsurf%nsidx(insurf) = surf%nsidx(ji) 353 403 newsurf%nsfil(insurf) = surf%nsfil(ji) … … 392 442 ! Set book keeping variables which do not depend on number of obs. 393 443 394 newsurf%nstp = surf%nstp 444 newsurf%nstp = surf%nstp 445 newsurf%cvars(:) = surf%cvars(:) 446 newsurf%cext(:) = surf%cext(:) 447 448 ! Set gridded stuff 449 450 newsurf%mt(insurf) = surf%mt(ji) 395 451 396 452 ! Deallocate temporary data … … 433 489 oldsurf%mi(jj) = surf%mi(ji) 434 490 oldsurf%mj(jj) = surf%mj(ji) 491 oldsurf%mt(jj) = surf%mt(ji) 435 492 oldsurf%nsidx(jj) = surf%nsidx(ji) 436 493 oldsurf%nsfil(jj) = surf%nsfil(ji) -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/OBS/obs_types.F90
r10246 r10247 117 117 118 118 cwmonam1770(ji) = 'Not defined' 119 ctypshort(ji) = ' XBT'119 ctypshort(ji) = '---' 120 120 121 121 ! IF ( ji < 1000 ) THEN -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/OBS/obs_write.F90
r10246 r10247 6 6 7 7 !!---------------------------------------------------------------------- 8 !! obs_wri_p3d : Write profile observation diagnostics in NetCDF format 9 !! obs_wri_sla : Write SLA observation related diagnostics 10 !! obs_wri_sst : Write SST observation related diagnostics 11 !! obs_wri_seaice: Write seaice observation related diagnostics 12 !! obs_wri_vel : Write velocity observation diagnostics in NetCDF format 13 !! obs_wri_stats : Print basic statistics on the data being written out 8 !! obs_wri_prof : Write profile observations in feedback format 9 !! obs_wri_surf : Write surface observations in feedback format 10 !! obs_wri_stats : Print basic statistics on the data being written out 14 11 !!---------------------------------------------------------------------- 15 12 … … 30 27 USE obs_conv ! Conversion between units 31 28 USE obs_const 32 USE obs_sla_types33 USE obs_rot_vel ! Rotation of velocities34 29 USE obs_mpp ! MPP support routines for observation diagnostics 35 30 USE lib_mpp ! MPP routines … … 39 34 !! * Routine accessibility 40 35 PRIVATE 41 PUBLIC obs_wri_p3d, & ! Write profile observation related diagnostics 42 & obs_wri_sla, & ! Write SLA observation related diagnostics 43 & obs_wri_sst, & ! Write SST observation related diagnostics 44 & obs_wri_sss, & ! Write SSS observation related diagnostics 45 & obs_wri_seaice, & ! Write seaice observation related diagnostics 46 & obs_wri_vel, & ! Write velocity observation related diagnostics 36 PUBLIC obs_wri_prof, & ! Write profile observation files 37 & obs_wri_surf, & ! Write surface observation files 47 38 & obswriinfo 48 39 … … 63 54 CONTAINS 64 55 65 SUBROUTINE obs_wri_p 3d( cprefix,profdata, padd, pext )56 SUBROUTINE obs_wri_prof( profdata, padd, pext ) 66 57 !!----------------------------------------------------------------------- 67 58 !! 68 !! *** ROUTINE obs_wri_p3d *** 69 !! 70 !! ** Purpose : Write temperature and salinity (profile) observation 71 !! related diagnostics 59 !! *** ROUTINE obs_wri_prof *** 60 !! 61 !! ** Purpose : Write profile feedback files 72 62 !! 73 63 !! ** Method : NetCDF … … 82 72 !! ! 07-03 (K. Mogensen) General handling of profiles 83 73 !! ! 09-01 (K. Mogensen) New feedback format 74 !! ! 15-02 (M. Martin) Combined routine for writing profiles 84 75 !!----------------------------------------------------------------------- 85 76 86 !! * Modules used87 88 77 !! * Arguments 89 CHARACTER(LEN=*), INTENT(IN) :: cprefix ! Prefix for output files90 78 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data 91 79 TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable 92 80 TYPE(obswriinfo), OPTIONAL :: pext ! Extra info 93 81 94 82 !! * Local declarations 95 83 TYPE(obfbdata) :: fbdata 96 CHARACTER(LEN=40) :: cfname 84 CHARACTER(LEN=40) :: clfname 85 CHARACTER(LEN=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 97 89 INTEGER :: ilevel 98 90 INTEGER :: jvar … … 102 94 INTEGER :: ja 103 95 INTEGER :: je 96 INTEGER :: iadd 97 INTEGER :: iext 104 98 REAL(wp) :: zpres 105 INTEGER :: nadd106 INTEGER :: next107 99 108 100 IF ( PRESENT( padd ) ) THEN 109 nadd = padd%inum101 iadd = padd%inum 110 102 ELSE 111 nadd = 0103 iadd = 0 112 104 ENDIF 113 105 114 106 IF ( PRESENT( pext ) ) THEN 115 next = pext%inum107 iext = pext%inum 116 108 ELSE 117 next = 0118 ENDIF 119 109 iext = 0 110 ENDIF 111 120 112 CALL init_obfbdata( fbdata ) 121 113 122 114 ! Find maximum level 123 115 ilevel = 0 124 DO jvar = 1, 2116 DO jvar = 1, profdata%nvar 125 117 ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) ) 126 118 END DO 127 CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, & 128 & 1 + nadd, 1 + next, .TRUE. ) 129 130 fbdata%cname(1) = 'POTM' 131 fbdata%cname(2) = 'PSAL' 132 fbdata%coblong(1) = 'Potential temperature' 133 fbdata%coblong(2) = 'Practical salinity' 134 fbdata%cobunit(1) = 'Degrees centigrade' 135 fbdata%cobunit(2) = 'PSU' 136 fbdata%cextname(1) = 'TEMP' 137 fbdata%cextlong(1) = 'Insitu temperature' 138 fbdata%cextunit(1) = 'Degrees centigrade' 139 DO je = 1, next 140 fbdata%cextname(1+je) = pext%cdname(je) 141 fbdata%cextlong(1+je) = pext%cdlong(je,1) 142 fbdata%cextunit(1+je) = pext%cdunit(je,1) 143 END DO 119 120 SELECT CASE ( TRIM(profdata%cvars(1)) ) 121 CASE('POTM') 122 123 clfiletype='profb' 124 CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, & 125 & 1 + iadd, 1 + iext, .TRUE. ) 126 fbdata%cname(1) = profdata%cvars(1) 127 fbdata%cname(2) = profdata%cvars(2) 128 fbdata%coblong(1) = 'Potential temperature' 129 fbdata%coblong(2) = 'Practical salinity' 130 fbdata%cobunit(1) = 'Degrees centigrade' 131 fbdata%cobunit(2) = 'PSU' 132 fbdata%cextname(1) = 'TEMP' 133 fbdata%cextlong(1) = 'Insitu temperature' 134 fbdata%cextunit(1) = 'Degrees centigrade' 135 fbdata%caddlong(1,1) = 'Model interpolated potential temperature' 136 fbdata%caddlong(1,2) = 'Model interpolated practical salinity' 137 fbdata%caddunit(1,1) = 'Degrees centigrade' 138 fbdata%caddunit(1,2) = 'PSU' 139 fbdata%cgrid(:) = 'T' 140 DO je = 1, iext 141 fbdata%cextname(1+je) = pext%cdname(je) 142 fbdata%cextlong(1+je) = pext%cdlong(je,1) 143 fbdata%cextunit(1+je) = pext%cdunit(je,1) 144 END DO 145 DO ja = 1, iadd 146 fbdata%caddname(1+ja) = padd%cdname(ja) 147 DO jvar = 1, 2 148 fbdata%caddlong(1+ja,jvar) = padd%cdlong(ja,jvar) 149 fbdata%caddunit(1+ja,jvar) = padd%cdunit(ja,jvar) 150 END DO 151 END DO 152 153 CASE('UVEL') 154 155 clfiletype='velfb' 156 CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, 1, 0, .TRUE. ) 157 fbdata%cname(1) = profdata%cvars(1) 158 fbdata%cname(2) = profdata%cvars(2) 159 fbdata%coblong(1) = 'Zonal velocity' 160 fbdata%coblong(2) = 'Meridional velocity' 161 fbdata%cobunit(1) = 'm/s' 162 fbdata%cobunit(2) = 'm/s' 163 DO je = 1, iext 164 fbdata%cextname(je) = pext%cdname(je) 165 fbdata%cextlong(je) = pext%cdlong(je,1) 166 fbdata%cextunit(je) = pext%cdunit(je,1) 167 END DO 168 fbdata%caddlong(1,1) = 'Model interpolated zonal velocity' 169 fbdata%caddlong(1,2) = 'Model interpolated meridional velocity' 170 fbdata%caddunit(1,1) = 'm/s' 171 fbdata%caddunit(1,2) = 'm/s' 172 fbdata%cgrid(1) = 'U' 173 fbdata%cgrid(2) = 'V' 174 DO ja = 1, iadd 175 fbdata%caddname(1+ja) = padd%cdname(ja) 176 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 177 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 178 END DO 179 180 CASE('PLCHLTOT') 181 182 clfiletype = 'plchltotfb' 183 cllongname = 'log10(chlorophyll concentration)' 184 clunits = 'log10(mg/m3)' 185 clgrid = 'T' 186 187 CASE('PCHLTOT') 188 189 clfiletype = 'pchltotfb' 190 cllongname = 'chlorophyll concentration' 191 clunits = 'mg/m3' 192 clgrid = 'T' 193 194 CASE('PNO3') 195 196 clfiletype = 'pno3fb' 197 cllongname = 'nitrate' 198 clunits = 'mmol/m3' 199 clgrid = 'T' 200 201 CASE('PSI4') 202 203 clfiletype = 'psi4fb' 204 cllongname = 'silicate' 205 clunits = 'mmol/m3' 206 clgrid = 'T' 207 208 CASE('PPO4') 209 210 clfiletype = 'ppo4fb' 211 cllongname = 'phosphate' 212 clunits = 'mmol/m3' 213 clgrid = 'T' 214 215 CASE('PDIC') 216 217 clfiletype = 'pdicfb' 218 cllongname = 'dissolved inorganic carbon' 219 clunits = 'mmol/m3' 220 clgrid = 'T' 221 222 CASE('PALK') 223 224 clfiletype = 'palkfb' 225 cllongname = 'alkalinity' 226 clunits = 'meq/m3' 227 clgrid = 'T' 228 229 CASE('PPH') 230 231 clfiletype = 'pphfb' 232 cllongname = 'pH' 233 clunits = '-' 234 clgrid = 'T' 235 236 CASE('PO2') 237 238 clfiletype = 'po2fb' 239 cllongname = 'dissolved oxygen' 240 clunits = 'mmol/m3' 241 clgrid = 'T' 242 243 END SELECT 244 245 IF ( ( TRIM(profdata%cvars(1)) /= 'POTM' ) .AND. & 246 & ( TRIM(profdata%cvars(1)) /= 'UVEL' ) ) THEN 247 CALL alloc_obfbdata( fbdata, 1, profdata%nprof, ilevel, & 248 & 1 + iadd, iext, .TRUE. ) 249 fbdata%cname(1) = profdata%cvars(1) 250 fbdata%coblong(1) = cllongname 251 fbdata%cobunit(1) = clunits 252 fbdata%caddlong(1,1) = 'Model interpolated ' // TRIM(cllongname) 253 fbdata%caddunit(1,1) = clunits 254 fbdata%cgrid(:) = clgrid 255 DO je = 1, iext 256 fbdata%cextname(je) = pext%cdname(je) 257 fbdata%cextlong(je) = pext%cdlong(je,1) 258 fbdata%cextunit(je) = pext%cdunit(je,1) 259 END DO 260 DO ja = 1, iadd 261 fbdata%caddname(1+ja) = padd%cdname(ja) 262 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 263 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 264 END DO 265 ENDIF 266 144 267 fbdata%caddname(1) = 'Hx' 145 fbdata%caddlong(1,1) = 'Model interpolated potential temperature' 146 fbdata%caddlong(1,2) = 'Model interpolated practical salinity' 147 fbdata%caddunit(1,1) = 'Degrees centigrade' 148 fbdata%caddunit(1,2) = 'PSU' 149 fbdata%cgrid(:) = 'T' 150 DO ja = 1, nadd 151 fbdata%caddname(1+ja) = padd%cdname(ja) 152 DO jvar = 1, 2 153 fbdata%caddlong(1+ja,jvar) = padd%cdlong(ja,jvar) 154 fbdata%caddunit(1+ja,jvar) = padd%cdunit(ja,jvar) 155 END DO 156 END DO 157 158 WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 268 269 WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc 159 270 160 271 IF(lwp) THEN 161 272 WRITE(numout,*) 162 WRITE(numout,*)'obs_wri_p 3d:'273 WRITE(numout,*)'obs_wri_prof :' 163 274 WRITE(numout,*)'~~~~~~~~~~~~~' 164 WRITE(numout,*)'Writing profile feedback file : ',TRIM(cfname)165 ENDIF 166 167 ! Transform obs_prof data structure into obfb data structure275 WRITE(numout,*)'Writing '//TRIM(clfiletype)//' feedback file : ',TRIM(clfname) 276 ENDIF 277 278 ! Transform obs_prof data structure into obfb data structure 168 279 fbdata%cdjuldref = '19500101000000' 169 280 DO jo = 1, profdata%nprof … … 173 284 fbdata%ivqc(jo,:) = profdata%ivqc(jo,:) 174 285 fbdata%ivqcf(:,jo,:) = profdata%ivqcf(:,jo,:) 175 IF ( profdata%nqc(jo) > 10) THEN176 fbdata%ioqc(jo) = 4286 IF ( profdata%nqc(jo) > 255 ) THEN 287 fbdata%ioqc(jo) = IBSET(profdata%nqc(jo),2) 177 288 fbdata%ioqcf(1,jo) = profdata%nqcf(1,jo) 178 fbdata%ioqcf(2,jo) = profdata%nqc(jo) - 10289 fbdata%ioqcf(2,jo) = profdata%nqc(jo) 179 290 ELSE 180 291 fbdata%ioqc(jo) = profdata%nqc(jo) … … 205 316 & krefdate = 19500101 ) 206 317 ! Reform the profiles arrays for output 207 DO jvar = 1, 2318 DO jvar = 1, profdata%nvar 208 319 DO jk = profdata%npvsta(jo,jvar), profdata%npvend(jo,jvar) 209 320 ik = profdata%var(jvar)%nvlidx(jk) … … 213 324 fbdata%idqc(ik,jo) = profdata%var(jvar)%idqc(jk) 214 325 fbdata%idqcf(:,ik,jo) = profdata%var(jvar)%idqcf(:,jk) 215 IF ( profdata%var(jvar)%nvqc(jk) > 10) THEN216 fbdata%ivlqc(ik,jo,jvar) = 4326 IF ( profdata%var(jvar)%nvqc(jk) > 255 ) THEN 327 fbdata%ivlqc(ik,jo,jvar) = IBSET(profdata%var(jvar)%nvqc(jk),2) 217 328 fbdata%ivlqcf(1,ik,jo,jvar) = profdata%var(jvar)%nvqcf(1,jk) 218 fbdata%ivlqcf(2,ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) - 10329 fbdata%ivlqcf(2,ik,jo,jvar) = IAND(profdata%var(jvar)%nvqc(jk),b'0000 0000 1111 1111') 219 330 ELSE 220 331 fbdata%ivlqc(ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) … … 222 333 ENDIF 223 334 fbdata%iobsk(ik,jo,jvar) = profdata%var(jvar)%mvk(jk) 224 DO ja = 1, nadd335 DO ja = 1, iadd 225 336 fbdata%padd(ik,jo,1+ja,jvar) = & 226 337 & profdata%var(jvar)%vext(jk,padd%ipoint(ja)) 227 338 END DO 228 DO je = 1, next339 DO je = 1, iext 229 340 fbdata%pext(ik,jo,1+je) = & 230 341 & profdata%var(jvar)%vext(jk,pext%ipoint(je)) 231 342 END DO 232 IF ( jvar == 1 ) THEN 343 IF ( ( jvar == 1 ) .AND. & 344 & ( TRIM(profdata%cvars(1)) == 'POTM' ) ) THEN 233 345 fbdata%pext(ik,jo,1) = profdata%var(jvar)%vext(jk,1) 234 346 ENDIF … … 237 349 END DO 238 350 239 ! Convert insitu temperature to potential temperature using the model 240 ! salinity if no potential temperature 241 DO jo = 1, fbdata%nobs 242 IF ( fbdata%pphi(jo) < 9999.0 ) THEN 243 DO jk = 1, fbdata%nlev 244 IF ( ( fbdata%pob(jk,jo,1) >= 9999.0 ) .AND. & 245 & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 246 & ( fbdata%padd(jk,jo,1,2) < 9999.0 ) .AND. & 247 & ( fbdata%pext(jk,jo,1) < 9999.0 ) ) THEN 248 zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), & 249 & REAL(fbdata%pphi(jo),wp) ) 250 fbdata%pob(jk,jo,1) = potemp( & 251 & REAL(fbdata%padd(jk,jo,1,2), wp), & 252 & REAL(fbdata%pext(jk,jo,1), wp), & 253 & zpres, 0.0_wp ) 254 ENDIF 255 END DO 256 ENDIF 257 END DO 258 351 IF ( TRIM(profdata%cvars(1)) == 'POTM' ) THEN 352 ! Convert insitu temperature to potential temperature using the model 353 ! salinity if no potential temperature 354 DO jo = 1, fbdata%nobs 355 IF ( fbdata%pphi(jo) < 9999.0 ) THEN 356 DO jk = 1, fbdata%nlev 357 IF ( ( fbdata%pob(jk,jo,1) >= 9999.0 ) .AND. & 358 & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 359 & ( fbdata%padd(jk,jo,1,2) < 9999.0 ) .AND. & 360 & ( fbdata%pext(jk,jo,1) < 9999.0 ) ) THEN 361 zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), & 362 & REAL(fbdata%pphi(jo),wp) ) 363 fbdata%pob(jk,jo,1) = potemp( & 364 & REAL(fbdata%padd(jk,jo,1,2), wp), & 365 & REAL(fbdata%pext(jk,jo,1), wp), & 366 & zpres, 0.0_wp ) 367 ENDIF 368 END DO 369 ENDIF 370 END DO 371 ENDIF 372 259 373 ! Write the obfbdata structure 260 CALL write_obfbdata( c fname, fbdata )374 CALL write_obfbdata( clfname, fbdata ) 261 375 262 376 ! Output some basic statistics … … 264 378 265 379 CALL dealloc_obfbdata( fbdata ) 266 267 END SUBROUTINE obs_wri_p 3d268 269 SUBROUTINE obs_wri_s la( cprefix, sladata, padd, pext )380 381 END SUBROUTINE obs_wri_prof 382 383 SUBROUTINE obs_wri_surf( surfdata, padd, pext ) 270 384 !!----------------------------------------------------------------------- 271 385 !! 272 !! *** ROUTINE obs_wri_sla *** 273 !! 274 !! ** Purpose : Write SLA observation diagnostics 275 !! related 386 !! *** ROUTINE obs_wri_surf *** 387 !! 388 !! ** Purpose : Write surface observation files 276 389 !! 277 390 !! ** Method : NetCDF … … 281 394 !! ! 07-03 (K. Mogensen) Original 282 395 !! ! 09-01 (K. Mogensen) New feedback format. 396 !! ! 15-02 (M. Martin) Combined surface writing routine. 283 397 !!----------------------------------------------------------------------- 284 398 … … 287 401 288 402 !! * Arguments 289 CHARACTER(LEN=*), INTENT(IN) :: cprefix ! Prefix for output files 290 TYPE(obs_surf), INTENT(INOUT) :: sladata ! Full set of SLAa 403 TYPE(obs_surf), INTENT(INOUT) :: surfdata ! Full set of surface data 291 404 TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable 292 405 TYPE(obswriinfo), OPTIONAL :: pext ! Extra info … … 294 407 !! * Local declarations 295 408 TYPE(obfbdata) :: fbdata 296 CHARACTER(LEN=40) :: cfname ! netCDF filename 297 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_sla' 409 CHARACTER(LEN=40) :: clfname ! netCDF filename 410 CHARACTER(LEN=10) :: clfiletype 411 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_surf' 412 CHARACTER(LEN=ilenlong) :: cllongname ! Long name of variable 413 CHARACTER(LEN=ilenunit) :: clunits ! Units of variable 414 CHARACTER(LEN=ilengrid) :: clgrid ! Grid of variable 298 415 INTEGER :: jo 299 416 INTEGER :: ja 300 417 INTEGER :: je 301 INTEGER :: nadd 302 INTEGER :: next 418 INTEGER :: iadd 419 INTEGER :: iext 420 INTEGER :: indx_std 421 INTEGER :: iadd_std 303 422 304 423 IF ( PRESENT( padd ) ) THEN 305 nadd = padd%inum424 iadd = padd%inum 306 425 ELSE 307 nadd = 0426 iadd = 0 308 427 ENDIF 309 428 310 429 IF ( PRESENT( pext ) ) THEN 311 next = pext%inum430 iext = pext%inum 312 431 ELSE 313 next = 0 314 ENDIF 315 432 iext = 0 433 ENDIF 434 435 iadd_std = 0 436 indx_std = -1 437 IF ( surfdata%nextra > 0 ) THEN 438 DO je = 1, surfdata%nextra 439 IF ( TRIM( surfdata%cext(je) ) == 'STD' ) THEN 440 iadd_std = 1 441 indx_std = je 442 ENDIF 443 END DO 444 ENDIF 445 316 446 CALL init_obfbdata( fbdata ) 317 447 318 CALL alloc_obfbdata( fbdata, 1, sladata%nsurf, 1, & 319 & 2 + nadd, 1 + next, .TRUE. ) 320 321 fbdata%cname(1) = 'SLA' 322 fbdata%coblong(1) = 'Sea level anomaly' 323 fbdata%cobunit(1) = 'Metres' 324 fbdata%cextname(1) = 'MDT' 325 fbdata%cextlong(1) = 'Mean dynamic topography' 326 fbdata%cextunit(1) = 'Metres' 327 DO je = 1, next 328 fbdata%cextname(1+je) = pext%cdname(je) 329 fbdata%cextlong(1+je) = pext%cdlong(je,1) 330 fbdata%cextunit(1+je) = pext%cdunit(je,1) 331 END DO 448 SELECT CASE ( TRIM(surfdata%cvars(1)) ) 449 CASE('SLA') 450 451 ! SLA needs special treatment because of MDT, so is all done here 452 ! Other variables are done more generically 453 454 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 455 & 2 + iadd + iadd_std, 1 + iext, .TRUE. ) 456 457 clfiletype = 'slafb' 458 fbdata%cname(1) = surfdata%cvars(1) 459 fbdata%coblong(1) = 'Sea level anomaly' 460 fbdata%cobunit(1) = 'Metres' 461 fbdata%cextname(1) = 'MDT' 462 fbdata%cextlong(1) = 'Mean dynamic topography' 463 fbdata%cextunit(1) = 'Metres' 464 DO je = 1, iext 465 fbdata%cextname(je) = pext%cdname(je) 466 fbdata%cextlong(je) = pext%cdlong(je,1) 467 fbdata%cextunit(je) = pext%cdunit(je,1) 468 END DO 469 fbdata%caddlong(1,1) = 'Model interpolated SSH - MDT' 470 fbdata%caddunit(1,1) = 'Metres' 471 fbdata%caddname(2) = 'SSH' 472 fbdata%caddlong(2,1) = 'Model Sea surface height' 473 fbdata%caddunit(2,1) = 'Metres' 474 fbdata%cgrid(1) = 'T' 475 DO ja = 1, iadd 476 fbdata%caddname(2+iadd_std+ja) = padd%cdname(ja) 477 fbdata%caddlong(2+iadd_std+ja,1) = padd%cdlong(ja,1) 478 fbdata%caddunit(2+iadd_std+ja,1) = padd%cdunit(ja,1) 479 END DO 480 481 CASE('SST') 482 483 clfiletype = 'sstfb' 484 cllongname = 'Sea surface temperature' 485 clunits = 'Degree centigrade' 486 clgrid = 'T' 487 488 CASE('ICECONC') 489 490 clfiletype = 'sicfb' 491 cllongname = 'Sea ice' 492 clunits = 'Fraction' 493 clgrid = 'T' 494 495 CASE('SSS') 496 497 clfiletype = 'sssfb' 498 cllongname = 'Sea surface salinity' 499 clunits = 'psu' 500 clgrid = 'T' 501 502 CASE('SLCHLTOT','LOGCHL','LogChl','logchl') 503 504 clfiletype = 'slchltotfb' 505 cllongname = 'Surface total log10(chlorophyll)' 506 clunits = 'log10(mg/m3)' 507 clgrid = 'T' 508 509 CASE('SLCHLDIA') 510 511 clfiletype = 'slchldiafb' 512 cllongname = 'Surface diatom log10(chlorophyll)' 513 clunits = 'log10(mg/m3)' 514 clgrid = 'T' 515 516 CASE('SLCHLNON') 517 518 clfiletype = 'slchlnonfb' 519 cllongname = 'Surface non-diatom log10(chlorophyll)' 520 clunits = 'log10(mg/m3)' 521 clgrid = 'T' 522 523 CASE('SLCHLDIN') 524 525 clfiletype = 'slchldinfb' 526 cllongname = 'Surface dinoflagellate log10(chlorophyll)' 527 clunits = 'log10(mg/m3)' 528 clgrid = 'T' 529 530 CASE('SLCHLMIC') 531 532 clfiletype = 'slchlmicfb' 533 cllongname = 'Surface microphytoplankton log10(chlorophyll)' 534 clunits = 'log10(mg/m3)' 535 clgrid = 'T' 536 537 CASE('SLCHLNAN') 538 539 clfiletype = 'slchlnanfb' 540 cllongname = 'Surface nanophytoplankton log10(chlorophyll)' 541 clunits = 'log10(mg/m3)' 542 clgrid = 'T' 543 544 CASE('SLCHLPIC') 545 546 clfiletype = 'slchlpicfb' 547 cllongname = 'Surface picophytoplankton log10(chlorophyll)' 548 clunits = 'log10(mg/m3)' 549 clgrid = 'T' 550 551 CASE('SCHLTOT') 552 553 clfiletype = 'schltotfb' 554 cllongname = 'Surface total chlorophyll' 555 clunits = 'mg/m3' 556 clgrid = 'T' 557 558 CASE('SLPHYTOT') 559 560 clfiletype = 'slphytotfb' 561 cllongname = 'Surface total log10(phytoplankton carbon)' 562 clunits = 'log10(mmolC/m3)' 563 clgrid = 'T' 564 565 CASE('SLPHYDIA') 566 567 clfiletype = 'slphydiafb' 568 cllongname = 'Surface diatom log10(phytoplankton carbon)' 569 clunits = 'log10(mmolC/m3)' 570 clgrid = 'T' 571 572 CASE('SLPHYNON') 573 574 clfiletype = 'slphynonfb' 575 cllongname = 'Surface non-diatom log10(phytoplankton carbon)' 576 clunits = 'log10(mmolC/m3)' 577 clgrid = 'T' 578 579 CASE('SSPM') 580 581 clfiletype = 'sspmfb' 582 cllongname = 'Surface suspended particulate matter' 583 clunits = 'g/m3' 584 clgrid = 'T' 585 586 CASE('SFCO2','FCO2','fCO2','fco2') 587 588 clfiletype = 'sfco2fb' 589 cllongname = 'Surface fugacity of carbon dioxide' 590 clunits = 'uatm' 591 clgrid = 'T' 592 593 CASE('SPCO2') 594 595 clfiletype = 'spco2fb' 596 cllongname = 'Surface partial pressure of carbon dioxide' 597 clunits = 'uatm' 598 clgrid = 'T' 599 600 CASE DEFAULT 601 602 CALL ctl_stop( 'Unknown observation type '//TRIM(surfdata%cvars(1))//' in obs_wri_surf' ) 603 604 END SELECT 605 606 ! SLA needs special treatment because of MDT, so is done above 607 ! Remaining variables treated more generically 608 609 IF ( TRIM(surfdata%cvars(1)) /= 'SLA' ) THEN 610 611 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 612 & 1 + iadd + iadd_std, iext, .TRUE. ) 613 614 fbdata%cname(1) = surfdata%cvars(1) 615 fbdata%coblong(1) = cllongname 616 fbdata%cobunit(1) = clunits 617 DO je = 1, iext 618 fbdata%cextname(je) = pext%cdname(je) 619 fbdata%cextlong(je) = pext%cdlong(je,1) 620 fbdata%cextunit(je) = pext%cdunit(je,1) 621 END DO 622 IF ( TRIM(surfdata%cvars(1)) == 'ICECONC' ) THEN 623 fbdata%caddlong(1,1) = 'Model interpolated ICE' 624 ELSE 625 fbdata%caddlong(1,1) = 'Model interpolated ' // TRIM(surfdata%cvars(1)) 626 ENDIF 627 fbdata%caddunit(1,1) = clunits 628 fbdata%cgrid(1) = clgrid 629 DO ja = 1, iadd 630 fbdata%caddname(1+iadd_std+ja) = padd%cdname(ja) 631 fbdata%caddlong(1+iadd_std+ja,1) = padd%cdlong(ja,1) 632 fbdata%caddunit(1+iadd_std+ja,1) = padd%cdunit(ja,1) 633 END DO 634 635 ENDIF 636 332 637 fbdata%caddname(1) = 'Hx' 333 fbdata%caddlong(1,1) = 'Model interpolated SSH - MDT' 334 fbdata%caddunit(1,1) = 'Metres' 335 fbdata%caddname(2) = 'SSH' 336 fbdata%caddlong(2,1) = 'Model Sea surface height' 337 fbdata%caddunit(2,1) = 'Metres' 338 fbdata%cgrid(1) = 'T' 339 DO ja = 1, nadd 340 fbdata%caddname(2+ja) = padd%cdname(ja) 341 fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1) 342 fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1) 343 END DO 344 345 WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 638 IF ( indx_std /= -1 ) THEN 639 IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) iadd_std = iadd_std + 1 640 fbdata%caddname(1+iadd_std) = surfdata%cext(indx_std) 641 fbdata%caddlong(1+iadd_std,1) = 'Obs error standard deviation' 642 fbdata%caddunit(1+iadd_std,1) = fbdata%cobunit(1) 643 ENDIF 644 645 WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc 346 646 347 647 IF(lwp) THEN 348 648 WRITE(numout,*) 349 WRITE(numout,*)'obs_wri_s la:'649 WRITE(numout,*)'obs_wri_surf :' 350 650 WRITE(numout,*)'~~~~~~~~~~~~~' 351 WRITE(numout,*)'Writing SLA feedback file : ',TRIM(cfname)352 ENDIF 353 354 ! Transform obs_prof data structure into obfbdata structure651 WRITE(numout,*)'Writing '//TRIM(surfdata%cvars(1))//' feedback file : ',TRIM(clfname) 652 ENDIF 653 654 ! Transform surf data structure into obfbdata structure 355 655 fbdata%cdjuldref = '19500101000000' 356 DO jo = 1, s ladata%nsurf357 fbdata%plam(jo) = s ladata%rlam(jo)358 fbdata%pphi(jo) = s ladata%rphi(jo)359 WRITE(fbdata%cdtyp(jo),'(I4)') s ladata%ntyp(jo)656 DO jo = 1, surfdata%nsurf 657 fbdata%plam(jo) = surfdata%rlam(jo) 658 fbdata%pphi(jo) = surfdata%rphi(jo) 659 WRITE(fbdata%cdtyp(jo),'(I4)') surfdata%ntyp(jo) 360 660 fbdata%ivqc(jo,:) = 0 361 661 fbdata%ivqcf(:,jo,:) = 0 362 IF ( s ladata%nqc(jo) > 10) THEN662 IF ( surfdata%nqc(jo) > 255 ) THEN 363 663 fbdata%ioqc(jo) = 4 364 664 fbdata%ioqcf(1,jo) = 0 365 fbdata%ioqcf(2,jo) = sladata%nqc(jo) - 10665 fbdata%ioqcf(2,jo) = IAND(surfdata%nqc(jo),b'0000 0000 1111 1111') 366 666 ELSE 367 fbdata%ioqc(jo) = s ladata%nqc(jo)667 fbdata%ioqc(jo) = surfdata%nqc(jo) 368 668 fbdata%ioqcf(:,jo) = 0 369 669 ENDIF … … 372 672 fbdata%itqc(jo) = 0 373 673 fbdata%itqcf(:,jo) = 0 374 fbdata%cdwmo(jo) = s ladata%cwmo(jo)375 fbdata%kindex(jo) = s ladata%nsfil(jo)674 fbdata%cdwmo(jo) = surfdata%cwmo(jo) 675 fbdata%kindex(jo) = surfdata%nsfil(jo) 376 676 IF (ln_grid_global) THEN 377 fbdata%iobsi(jo,1) = s ladata%mi(jo)378 fbdata%iobsj(jo,1) = s ladata%mj(jo)677 fbdata%iobsi(jo,1) = surfdata%mi(jo) 678 fbdata%iobsj(jo,1) = surfdata%mj(jo) 379 679 ELSE 380 fbdata%iobsi(jo,1) = mig(s ladata%mi(jo))381 fbdata%iobsj(jo,1) = mjg(s ladata%mj(jo))680 fbdata%iobsi(jo,1) = mig(surfdata%mi(jo)) 681 fbdata%iobsj(jo,1) = mjg(surfdata%mj(jo)) 382 682 ENDIF 383 683 CALL greg2jul( 0, & 384 & s ladata%nmin(jo), &385 & s ladata%nhou(jo), &386 & s ladata%nday(jo), &387 & s ladata%nmon(jo), &388 & s ladata%nyea(jo), &684 & surfdata%nmin(jo), & 685 & surfdata%nhou(jo), & 686 & surfdata%nday(jo), & 687 & surfdata%nmon(jo), & 688 & surfdata%nyea(jo), & 389 689 & fbdata%ptim(jo), & 390 690 & krefdate = 19500101 ) 391 fbdata%padd(1,jo,1,1) = s ladata%rmod(jo,1)392 fbdata%padd(1,jo,2,1) = sladata%rext(jo,1)393 fbdata%pob(1,jo,1) = s ladata%robs(jo,1)691 fbdata%padd(1,jo,1,1) = surfdata%rmod(jo,1) 692 IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%padd(1,jo,2,1) = surfdata%rext(jo,1) 693 fbdata%pob(1,jo,1) = surfdata%robs(jo,1) 394 694 fbdata%pdep(1,jo) = 0.0 395 695 fbdata%idqc(1,jo) = 0 396 696 fbdata%idqcf(:,1,jo) = 0 397 IF ( s ladata%nqc(jo) > 10) THEN697 IF ( surfdata%nqc(jo) > 255 ) THEN 398 698 fbdata%ivqc(jo,1) = 4 399 699 fbdata%ivlqc(1,jo,1) = 4 400 700 fbdata%ivlqcf(1,1,jo,1) = 0 401 fbdata%ivlqcf(2,1,jo,1) = sladata%nqc(jo) - 10701 fbdata%ivlqcf(2,1,jo,1) = IAND(surfdata%nqc(jo),b'0000 0000 1111 1111') 402 702 ELSE 403 fbdata%ivqc(jo,1) = s ladata%nqc(jo)404 fbdata%ivlqc(1,jo,1) = s ladata%nqc(jo)703 fbdata%ivqc(jo,1) = surfdata%nqc(jo) 704 fbdata%ivlqc(1,jo,1) = surfdata%nqc(jo) 405 705 fbdata%ivlqcf(:,1,jo,1) = 0 406 706 ENDIF 407 707 fbdata%iobsk(1,jo,1) = 0 408 fbdata%pext(1,jo,1) = sladata%rext(jo,2) 409 DO ja = 1, nadd 410 fbdata%padd(1,jo,2+ja,1) = & 411 & sladata%rext(jo,padd%ipoint(ja)) 412 END DO 413 DO je = 1, next 708 IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%pext(1,jo,1) = surfdata%rext(jo,2) 709 IF ( indx_std /= -1 ) THEN 710 fbdata%padd(1,jo,1+iadd_std,1) = surfdata%rext(jo,indx_std) 711 ENDIF 712 713 DO ja = 1, iadd 714 fbdata%padd(1,jo,2+iadd_std+ja,1) = & 715 & surfdata%rext(jo,padd%ipoint(ja)) 716 END DO 717 DO je = 1, iext 414 718 fbdata%pext(1,jo,1+je) = & 415 & s ladata%rext(jo,pext%ipoint(je))719 & surfdata%rext(jo,pext%ipoint(je)) 416 720 END DO 417 721 END DO 418 722 419 723 ! Write the obfbdata structure 420 CALL write_obfbdata( c fname, fbdata )724 CALL write_obfbdata( clfname, fbdata ) 421 725 422 726 ! Output some basic statistics … … 425 729 CALL dealloc_obfbdata( fbdata ) 426 730 427 END SUBROUTINE obs_wri_sla 428 429 SUBROUTINE obs_wri_sst( cprefix, sstdata, padd, pext ) 430 !!----------------------------------------------------------------------- 431 !! 432 !! *** ROUTINE obs_wri_sst *** 433 !! 434 !! ** Purpose : Write SST observation diagnostics 435 !! related 436 !! 437 !! ** Method : NetCDF 438 !! 439 !! ** Action : 440 !! 441 !! ! 07-07 (S. Ricci) Original 442 !! ! 09-01 (K. Mogensen) New feedback format. 443 !!----------------------------------------------------------------------- 444 445 !! * Modules used 446 IMPLICIT NONE 447 448 !! * Arguments 449 CHARACTER(LEN=*), INTENT(IN) :: cprefix ! Prefix for output files 450 TYPE(obs_surf), INTENT(INOUT) :: sstdata ! Full set of SST 451 TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable 452 TYPE(obswriinfo), OPTIONAL :: pext ! Extra info 453 454 !! * Local declarations 455 TYPE(obfbdata) :: fbdata 456 CHARACTER(LEN=40) :: cfname ! netCDF filename 457 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_sst' 458 INTEGER :: jo 459 INTEGER :: ja 460 INTEGER :: je 461 INTEGER :: nadd 462 INTEGER :: next 463 464 IF ( PRESENT( padd ) ) THEN 465 nadd = padd%inum 466 ELSE 467 nadd = 0 468 ENDIF 469 470 IF ( PRESENT( pext ) ) THEN 471 next = pext%inum 472 ELSE 473 next = 0 474 ENDIF 475 476 CALL init_obfbdata( fbdata ) 477 478 CALL alloc_obfbdata( fbdata, 1, sstdata%nsurf, 1, & 479 & 1 + nadd, next, .TRUE. ) 480 481 fbdata%cname(1) = 'SST' 482 fbdata%coblong(1) = 'Sea surface temperature' 483 fbdata%cobunit(1) = 'Degree centigrade' 484 DO je = 1, next 485 fbdata%cextname(je) = pext%cdname(je) 486 fbdata%cextlong(je) = pext%cdlong(je,1) 487 fbdata%cextunit(je) = pext%cdunit(je,1) 488 END DO 489 fbdata%caddname(1) = 'Hx' 490 fbdata%caddlong(1,1) = 'Model interpolated SST' 491 fbdata%caddunit(1,1) = 'Degree centigrade' 492 fbdata%cgrid(1) = 'T' 493 DO ja = 1, nadd 494 fbdata%caddname(1+ja) = padd%cdname(ja) 495 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 496 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 497 END DO 498 499 WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 500 501 IF(lwp) THEN 502 WRITE(numout,*) 503 WRITE(numout,*)'obs_wri_sst :' 504 WRITE(numout,*)'~~~~~~~~~~~~~' 505 WRITE(numout,*)'Writing SST feedback file : ',TRIM(cfname) 506 ENDIF 507 508 ! Transform obs_prof data structure into obfbdata structure 509 fbdata%cdjuldref = '19500101000000' 510 DO jo = 1, sstdata%nsurf 511 fbdata%plam(jo) = sstdata%rlam(jo) 512 fbdata%pphi(jo) = sstdata%rphi(jo) 513 WRITE(fbdata%cdtyp(jo),'(I4)') sstdata%ntyp(jo) 514 fbdata%ivqc(jo,:) = 0 515 fbdata%ivqcf(:,jo,:) = 0 516 IF ( sstdata%nqc(jo) > 10 ) THEN 517 fbdata%ioqc(jo) = 4 518 fbdata%ioqcf(1,jo) = 0 519 fbdata%ioqcf(2,jo) = sstdata%nqc(jo) - 10 520 ELSE 521 fbdata%ioqc(jo) = MAX(sstdata%nqc(jo),1) 522 fbdata%ioqcf(:,jo) = 0 523 ENDIF 524 fbdata%ipqc(jo) = 0 525 fbdata%ipqcf(:,jo) = 0 526 fbdata%itqc(jo) = 0 527 fbdata%itqcf(:,jo) = 0 528 fbdata%cdwmo(jo) = '' 529 fbdata%kindex(jo) = sstdata%nsfil(jo) 530 IF (ln_grid_global) THEN 531 fbdata%iobsi(jo,1) = sstdata%mi(jo) 532 fbdata%iobsj(jo,1) = sstdata%mj(jo) 533 ELSE 534 fbdata%iobsi(jo,1) = mig(sstdata%mi(jo)) 535 fbdata%iobsj(jo,1) = mjg(sstdata%mj(jo)) 536 ENDIF 537 CALL greg2jul( 0, & 538 & sstdata%nmin(jo), & 539 & sstdata%nhou(jo), & 540 & sstdata%nday(jo), & 541 & sstdata%nmon(jo), & 542 & sstdata%nyea(jo), & 543 & fbdata%ptim(jo), & 544 & krefdate = 19500101 ) 545 fbdata%padd(1,jo,1,1) = sstdata%rmod(jo,1) 546 fbdata%pob(1,jo,1) = sstdata%robs(jo,1) 547 fbdata%pdep(1,jo) = 0.0 548 fbdata%idqc(1,jo) = 0 549 fbdata%idqcf(:,1,jo) = 0 550 IF ( sstdata%nqc(jo) > 10 ) THEN 551 fbdata%ivqc(jo,1) = 4 552 fbdata%ivlqc(1,jo,1) = 4 553 fbdata%ivlqcf(1,1,jo,1) = 0 554 fbdata%ivlqcf(2,1,jo,1) = sstdata%nqc(jo) - 10 555 ELSE 556 fbdata%ivqc(jo,1) = MAX(sstdata%nqc(jo),1) 557 fbdata%ivlqc(1,jo,1) = MAX(sstdata%nqc(jo),1) 558 fbdata%ivlqcf(:,1,jo,1) = 0 559 ENDIF 560 fbdata%iobsk(1,jo,1) = 0 561 DO ja = 1, nadd 562 fbdata%padd(1,jo,1+ja,1) = & 563 & sstdata%rext(jo,padd%ipoint(ja)) 564 END DO 565 DO je = 1, next 566 fbdata%pext(1,jo,je) = & 567 & sstdata%rext(jo,pext%ipoint(je)) 568 END DO 569 570 END DO 571 572 ! Write the obfbdata structure 573 574 CALL write_obfbdata( cfname, fbdata ) 575 576 ! Output some basic statistics 577 CALL obs_wri_stats( fbdata ) 578 579 CALL dealloc_obfbdata( fbdata ) 580 581 END SUBROUTINE obs_wri_sst 582 583 SUBROUTINE obs_wri_sss 584 END SUBROUTINE obs_wri_sss 585 586 SUBROUTINE obs_wri_seaice( cprefix, seaicedata, padd, pext ) 587 !!----------------------------------------------------------------------- 588 !! 589 !! *** ROUTINE obs_wri_seaice *** 590 !! 591 !! ** Purpose : Write sea ice observation diagnostics 592 !! related 593 !! 594 !! ** Method : NetCDF 595 !! 596 !! ** Action : 597 !! 598 !! ! 07-07 (S. Ricci) Original 599 !! ! 09-01 (K. Mogensen) New feedback format. 600 !!----------------------------------------------------------------------- 601 602 !! * Modules used 603 IMPLICIT NONE 604 605 !! * Arguments 606 CHARACTER(LEN=*), INTENT(IN) :: cprefix ! Prefix for output files 607 TYPE(obs_surf), INTENT(INOUT) :: seaicedata ! Full set of sea ice 608 TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable 609 TYPE(obswriinfo), OPTIONAL :: pext ! Extra info 610 611 !! * Local declarations 612 TYPE(obfbdata) :: fbdata 613 CHARACTER(LEN=40) :: cfname ! netCDF filename 614 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_seaice' 615 INTEGER :: jo 616 INTEGER :: ja 617 INTEGER :: je 618 INTEGER :: nadd 619 INTEGER :: next 620 621 IF ( PRESENT( padd ) ) THEN 622 nadd = padd%inum 623 ELSE 624 nadd = 0 625 ENDIF 626 627 IF ( PRESENT( pext ) ) THEN 628 next = pext%inum 629 ELSE 630 next = 0 631 ENDIF 632 633 CALL init_obfbdata( fbdata ) 634 635 CALL alloc_obfbdata( fbdata, 1, seaicedata%nsurf, 1, 1, 0, .TRUE. ) 636 637 fbdata%cname(1) = 'SEAICE' 638 fbdata%coblong(1) = 'Sea ice' 639 fbdata%cobunit(1) = 'Fraction' 640 DO je = 1, next 641 fbdata%cextname(je) = pext%cdname(je) 642 fbdata%cextlong(je) = pext%cdlong(je,1) 643 fbdata%cextunit(je) = pext%cdunit(je,1) 644 END DO 645 fbdata%caddname(1) = 'Hx' 646 fbdata%caddlong(1,1) = 'Model interpolated ICE' 647 fbdata%caddunit(1,1) = 'Fraction' 648 fbdata%cgrid(1) = 'T' 649 DO ja = 1, nadd 650 fbdata%caddname(1+ja) = padd%cdname(ja) 651 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 652 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 653 END DO 654 655 WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 656 657 IF(lwp) THEN 658 WRITE(numout,*) 659 WRITE(numout,*)'obs_wri_seaice :' 660 WRITE(numout,*)'~~~~~~~~~~~~~~~~' 661 WRITE(numout,*)'Writing SEAICE feedback file : ',TRIM(cfname) 662 ENDIF 663 664 ! Transform obs_prof data structure into obfbdata structure 665 fbdata%cdjuldref = '19500101000000' 666 DO jo = 1, seaicedata%nsurf 667 fbdata%plam(jo) = seaicedata%rlam(jo) 668 fbdata%pphi(jo) = seaicedata%rphi(jo) 669 WRITE(fbdata%cdtyp(jo),'(I4)') seaicedata%ntyp(jo) 670 fbdata%ivqc(jo,:) = 0 671 fbdata%ivqcf(:,jo,:) = 0 672 IF ( seaicedata%nqc(jo) > 10 ) THEN 673 fbdata%ioqc(jo) = 4 674 fbdata%ioqcf(1,jo) = 0 675 fbdata%ioqcf(2,jo) = seaicedata%nqc(jo) - 10 676 ELSE 677 fbdata%ioqc(jo) = MAX(seaicedata%nqc(jo),1) 678 fbdata%ioqcf(:,jo) = 0 679 ENDIF 680 fbdata%ipqc(jo) = 0 681 fbdata%ipqcf(:,jo) = 0 682 fbdata%itqc(jo) = 0 683 fbdata%itqcf(:,jo) = 0 684 fbdata%cdwmo(jo) = '' 685 fbdata%kindex(jo) = seaicedata%nsfil(jo) 686 IF (ln_grid_global) THEN 687 fbdata%iobsi(jo,1) = seaicedata%mi(jo) 688 fbdata%iobsj(jo,1) = seaicedata%mj(jo) 689 ELSE 690 fbdata%iobsi(jo,1) = mig(seaicedata%mi(jo)) 691 fbdata%iobsj(jo,1) = mjg(seaicedata%mj(jo)) 692 ENDIF 693 CALL greg2jul( 0, & 694 & seaicedata%nmin(jo), & 695 & seaicedata%nhou(jo), & 696 & seaicedata%nday(jo), & 697 & seaicedata%nmon(jo), & 698 & seaicedata%nyea(jo), & 699 & fbdata%ptim(jo), & 700 & krefdate = 19500101 ) 701 fbdata%padd(1,jo,1,1) = seaicedata%rmod(jo,1) 702 fbdata%pob(1,jo,1) = seaicedata%robs(jo,1) 703 fbdata%pdep(1,jo) = 0.0 704 fbdata%idqc(1,jo) = 0 705 fbdata%idqcf(:,1,jo) = 0 706 IF ( seaicedata%nqc(jo) > 10 ) THEN 707 fbdata%ivlqc(1,jo,1) = 4 708 fbdata%ivlqcf(1,1,jo,1) = 0 709 fbdata%ivlqcf(2,1,jo,1) = seaicedata%nqc(jo) - 10 710 ELSE 711 fbdata%ivlqc(1,jo,1) = MAX(seaicedata%nqc(jo),1) 712 fbdata%ivlqcf(:,1,jo,1) = 0 713 ENDIF 714 fbdata%iobsk(1,jo,1) = 0 715 DO ja = 1, nadd 716 fbdata%padd(1,jo,1+ja,1) = & 717 & seaicedata%rext(jo,padd%ipoint(ja)) 718 END DO 719 DO je = 1, next 720 fbdata%pext(1,jo,je) = & 721 & seaicedata%rext(jo,pext%ipoint(je)) 722 END DO 723 724 END DO 725 726 ! Write the obfbdata structure 727 CALL write_obfbdata( cfname, fbdata ) 728 729 ! Output some basic statistics 730 CALL obs_wri_stats( fbdata ) 731 732 CALL dealloc_obfbdata( fbdata ) 733 734 END SUBROUTINE obs_wri_seaice 735 736 SUBROUTINE obs_wri_vel( cprefix, profdata, k2dint, padd, pext ) 737 !!----------------------------------------------------------------------- 738 !! 739 !! *** ROUTINE obs_wri_vel *** 740 !! 741 !! ** Purpose : Write current (profile) observation 742 !! related diagnostics 743 !! 744 !! ** Method : NetCDF 745 !! 746 !! ** Action : 747 !! 748 !! History : 749 !! ! 09-01 (K. Mogensen) New feedback format routine 750 !!----------------------------------------------------------------------- 751 752 !! * Modules used 753 754 !! * Arguments 755 CHARACTER(LEN=*), INTENT(IN) :: cprefix ! Prefix for output files 756 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data 757 INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation method 758 TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable 759 TYPE(obswriinfo), OPTIONAL :: pext ! Extra info 760 761 !! * Local declarations 762 TYPE(obfbdata) :: fbdata 763 CHARACTER(LEN=40) :: cfname 764 INTEGER :: ilevel 765 INTEGER :: jvar 766 INTEGER :: jk 767 INTEGER :: ik 768 INTEGER :: jo 769 INTEGER :: ja 770 INTEGER :: je 771 INTEGER :: nadd 772 INTEGER :: next 773 REAL(wp) :: zpres 774 REAL(wp), DIMENSION(:), ALLOCATABLE :: & 775 & zu, & 776 & zv 777 778 IF ( PRESENT( padd ) ) THEN 779 nadd = padd%inum 780 ELSE 781 nadd = 0 782 ENDIF 783 784 IF ( PRESENT( pext ) ) THEN 785 next = pext%inum 786 ELSE 787 next = 0 788 ENDIF 789 790 CALL init_obfbdata( fbdata ) 791 792 ! Find maximum level 793 ilevel = 0 794 DO jvar = 1, 2 795 ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) ) 796 END DO 797 CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, 2, 0, .TRUE. ) 798 799 fbdata%cname(1) = 'UVEL' 800 fbdata%cname(2) = 'VVEL' 801 fbdata%coblong(1) = 'Zonal velocity' 802 fbdata%coblong(2) = 'Meridional velocity' 803 fbdata%cobunit(1) = 'm/s' 804 fbdata%cobunit(2) = 'm/s' 805 DO je = 1, next 806 fbdata%cextname(je) = pext%cdname(je) 807 fbdata%cextlong(je) = pext%cdlong(je,1) 808 fbdata%cextunit(je) = pext%cdunit(je,1) 809 END DO 810 fbdata%caddname(1) = 'Hx' 811 fbdata%caddlong(1,1) = 'Model interpolated zonal velocity' 812 fbdata%caddlong(1,2) = 'Model interpolated meridional velocity' 813 fbdata%caddunit(1,1) = 'm/s' 814 fbdata%caddunit(1,2) = 'm/s' 815 fbdata%caddname(2) = 'HxG' 816 fbdata%caddlong(2,1) = 'Model interpolated zonal velocity (model grid)' 817 fbdata%caddlong(2,2) = 'Model interpolated meridional velocity (model grid)' 818 fbdata%caddunit(2,1) = 'm/s' 819 fbdata%caddunit(2,2) = 'm/s' 820 fbdata%cgrid(1) = 'U' 821 fbdata%cgrid(2) = 'V' 822 DO ja = 1, nadd 823 fbdata%caddname(2+ja) = padd%cdname(ja) 824 fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1) 825 fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1) 826 END DO 827 828 WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 829 830 IF(lwp) THEN 831 WRITE(numout,*) 832 WRITE(numout,*)'obs_wri_vel :' 833 WRITE(numout,*)'~~~~~~~~~~~~~' 834 WRITE(numout,*)'Writing velocuty feedback file : ',TRIM(cfname) 835 ENDIF 836 837 ALLOCATE( & 838 & zu(profdata%nvprot(1)), & 839 & zv(profdata%nvprot(2)) & 840 & ) 841 CALL obs_rotvel( profdata, k2dint, zu, zv ) 842 843 ! Transform obs_prof data structure into obfbdata structure 844 fbdata%cdjuldref = '19500101000000' 845 DO jo = 1, profdata%nprof 846 fbdata%plam(jo) = profdata%rlam(jo) 847 fbdata%pphi(jo) = profdata%rphi(jo) 848 WRITE(fbdata%cdtyp(jo),'(I4)') profdata%ntyp(jo) 849 fbdata%ivqc(jo,:) = profdata%ivqc(jo,:) 850 fbdata%ivqcf(:,jo,:) = profdata%ivqcf(:,jo,:) 851 IF ( profdata%nqc(jo) > 10 ) THEN 852 fbdata%ioqc(jo) = 4 853 fbdata%ioqcf(1,jo) = profdata%nqcf(1,jo) 854 fbdata%ioqcf(2,jo) = profdata%nqc(jo) - 10 855 ELSE 856 fbdata%ioqc(jo) = profdata%nqc(jo) 857 fbdata%ioqcf(:,jo) = profdata%nqcf(:,jo) 858 ENDIF 859 fbdata%ipqc(jo) = profdata%ipqc(jo) 860 fbdata%ipqcf(:,jo) = profdata%ipqcf(:,jo) 861 fbdata%itqc(jo) = profdata%itqc(jo) 862 fbdata%itqcf(:,jo) = profdata%itqcf(:,jo) 863 fbdata%cdwmo(jo) = profdata%cwmo(jo) 864 fbdata%kindex(jo) = profdata%npfil(jo) 865 DO jvar = 1, profdata%nvar 866 IF (ln_grid_global) THEN 867 fbdata%iobsi(jo,jvar) = profdata%mi(jo,jvar) 868 fbdata%iobsj(jo,jvar) = profdata%mj(jo,jvar) 869 ELSE 870 fbdata%iobsi(jo,jvar) = mig(profdata%mi(jo,jvar)) 871 fbdata%iobsj(jo,jvar) = mjg(profdata%mj(jo,jvar)) 872 ENDIF 873 END DO 874 CALL greg2jul( 0, & 875 & profdata%nmin(jo), & 876 & profdata%nhou(jo), & 877 & profdata%nday(jo), & 878 & profdata%nmon(jo), & 879 & profdata%nyea(jo), & 880 & fbdata%ptim(jo), & 881 & krefdate = 19500101 ) 882 ! Reform the profiles arrays for output 883 DO jvar = 1, 2 884 DO jk = profdata%npvsta(jo,jvar), profdata%npvend(jo,jvar) 885 ik = profdata%var(jvar)%nvlidx(jk) 886 IF ( jvar == 1 ) THEN 887 fbdata%padd(ik,jo,1,jvar) = zu(jk) 888 ELSE 889 fbdata%padd(ik,jo,1,jvar) = zv(jk) 890 ENDIF 891 fbdata%padd(ik,jo,2,jvar) = profdata%var(jvar)%vmod(jk) 892 fbdata%pob(ik,jo,jvar) = profdata%var(jvar)%vobs(jk) 893 fbdata%pdep(ik,jo) = profdata%var(jvar)%vdep(jk) 894 fbdata%idqc(ik,jo) = profdata%var(jvar)%idqc(jk) 895 fbdata%idqcf(:,ik,jo) = profdata%var(jvar)%idqcf(:,jk) 896 IF ( profdata%var(jvar)%nvqc(jk) > 10 ) THEN 897 fbdata%ivlqc(ik,jo,jvar) = 4 898 fbdata%ivlqcf(1,ik,jo,jvar) = profdata%var(jvar)%nvqcf(1,jk) 899 fbdata%ivlqcf(2,ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) - 10 900 ELSE 901 fbdata%ivlqc(ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) 902 fbdata%ivlqcf(:,ik,jo,jvar) = profdata%var(jvar)%nvqcf(:,jk) 903 ENDIF 904 fbdata%iobsk(ik,jo,jvar) = profdata%var(jvar)%mvk(jk) 905 DO ja = 1, nadd 906 fbdata%padd(ik,jo,2+ja,jvar) = & 907 & profdata%var(jvar)%vext(jk,padd%ipoint(ja)) 908 END DO 909 DO je = 1, next 910 fbdata%pext(ik,jo,je) = & 911 & profdata%var(jvar)%vext(jk,pext%ipoint(je)) 912 END DO 913 END DO 914 END DO 915 END DO 916 917 ! Write the obfbdata structure 918 CALL write_obfbdata( cfname, fbdata ) 919 920 ! Output some basic statistics 921 CALL obs_wri_stats( fbdata ) 922 923 CALL dealloc_obfbdata( fbdata ) 924 925 DEALLOCATE( & 926 & zu, & 927 & zv & 928 & ) 929 930 END SUBROUTINE obs_wri_vel 731 END SUBROUTINE obs_wri_surf 931 732 932 733 SUBROUTINE obs_wri_stats( fbdata ) … … 951 752 INTEGER :: jo 952 753 INTEGER :: jk 953 954 ! INTEGER :: nlev 955 ! INTEGER :: nlevmpp 956 ! INTEGER :: nobsmpp 957 INTEGER :: numgoodobs 958 INTEGER :: numgoodobsmpp 754 INTEGER :: inumgoodobs 755 INTEGER :: inumgoodobsmpp 959 756 REAL(wp) :: zsumx 960 757 REAL(wp) :: zsumx2 961 758 REAL(wp) :: zomb 759 962 760 963 761 IF (lwp) THEN 964 762 WRITE(numout,*) '' 965 763 WRITE(numout,*) 'obs_wri_stats :' 966 WRITE(numout,*) '~~~~~~~~~~~~~~~' 764 WRITE(numout,*) '~~~~~~~~~~~~~~~' 967 765 ENDIF 968 766 … … 970 768 zsumx=0.0_wp 971 769 zsumx2=0.0_wp 972 numgoodobs=0770 inumgoodobs=0 973 771 DO jo = 1, fbdata%nobs 974 772 DO jk = 1, fbdata%nlev … … 976 774 & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 977 775 & ( fbdata%padd(jk,jo,1,jvar) < 9999.0 ) ) THEN 978 979 776 777 zomb=fbdata%pob(jk, jo, jvar)-fbdata%padd(jk, jo, 1, jvar) 980 778 zsumx=zsumx+zomb 981 779 zsumx2=zsumx2+zomb**2 982 numgoodobs=numgoodobs+1983 780 inumgoodobs=inumgoodobs+1 781 ENDIF 984 782 ENDDO 985 783 ENDDO 986 784 987 CALL obs_mpp_sum_integer( numgoodobs,numgoodobsmpp )785 CALL obs_mpp_sum_integer( inumgoodobs, inumgoodobsmpp ) 988 786 CALL mpp_sum(zsumx) 989 787 CALL mpp_sum(zsumx2) 990 788 991 789 IF (lwp) THEN 992 WRITE(numout,*) 'Type: ',fbdata%cname(jvar),' Total number of good observations: ',numgoodobsmpp993 WRITE(numout,*) 'Overall mean obs minus model of the good observations: ',zsumx/numgoodobsmpp994 WRITE(numout,*) 'Overall RMS obs minus model of the good observations: ',sqrt( zsumx2/ numgoodobsmpp )995 790 WRITE(numout,*) 'Type: ',fbdata%cname(jvar),' Total number of good observations: ',inumgoodobsmpp 791 WRITE(numout,*) 'Overall mean obs minus model of the good observations: ',zsumx/inumgoodobsmpp 792 WRITE(numout,*) 'Overall RMS obs minus model of the good observations: ',sqrt( zsumx2/inumgoodobsmpp ) 793 WRITE(numout,*) '' 996 794 ENDIF 997 795 998 796 ENDDO 999 797 -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/OBS/obsinter_h2d.h90
r10246 r10247 1240 1240 & zdum, & 1241 1241 & zaamax 1242 1242 1243 imax = -1 1243 1244 ! Main computation 1244 1245 pflt = 1.0_wp -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/ZDF/zdf_oce.F90
r10246 r10247 43 43 REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avmu , avmv !: vertical viscosity coef at uw- & vw-pts [m2/s] 44 44 REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avm , avt !: vertical viscosity & diffusivity coef at w-pt [m2/s] 45 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avt_k , avm_k ! not enhanced Kz 46 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avmu_k, avmv_k ! not enhanced Kz 47 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: en !: now turbulent kinetic energy [m2/s2] 45 48 46 49 !!---------------------------------------------------------------------- … … 60 63 & tfrua(jpi, jpj), tfrva(jpi, jpj) , & 61 64 & avmu(jpi,jpj,jpk), avm(jpi,jpj,jpk) , & 62 & avmv(jpi,jpj,jpk), avt(jpi,jpj,jpk) , STAT = zdf_oce_alloc ) 65 & avmv (jpi,jpj,jpk), avt (jpi,jpj,jpk) , & 66 & avt_k (jpi,jpj,jpk), avm_k (jpi,jpj,jpk) , & 67 & avmu_k(jpi,jpj,jpk), avmv_k(jpi,jpj,jpk) , & 68 & en (jpi,jpj,jpk), STAT = zdf_oce_alloc ) 63 69 ! 64 70 IF( zdf_oce_alloc /= 0 ) CALL ctl_warn('zdf_oce_alloc: failed to allocate arrays') -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfgls.F90
r10246 r10247 42 42 LOGICAL , PUBLIC, PARAMETER :: lk_zdfgls = .TRUE. !: TKE vertical mixing flag 43 43 ! 44 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: en !: now turbulent kinetic energy45 44 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: mxln !: now mixing length 46 45 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zwall !: wall function 47 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avt_k ! not enhanced Kz48 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avm_k ! not enhanced Kz49 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avmu_k ! not enhanced Kz50 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avmv_k ! not enhanced Kz51 46 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ustars2 !: Squared surface velocity scale at T-points 52 47 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ustarb2 !: Squared bottom velocity scale at T-points … … 120 115 !! *** FUNCTION zdf_gls_alloc *** 121 116 !!---------------------------------------------------------------------- 122 ALLOCATE( en(jpi,jpj,jpk), mxln(jpi,jpj,jpk), zwall(jpi,jpj,jpk) , & 123 & avt_k (jpi,jpj,jpk) , avm_k (jpi,jpj,jpk), & 124 & avmu_k(jpi,jpj,jpk) , avmv_k(jpi,jpj,jpk), & 125 & ustars2(jpi,jpj), ustarb2(jpi,jpj) , STAT= zdf_gls_alloc ) 117 ALLOCATE( mxln(jpi,jpj,jpk), zwall(jpi,jpj,jpk) , & 118 & ustars2(jpi,jpj) , ustarb2(jpi,jpj) , STAT= zdf_gls_alloc ) 126 119 ! 127 120 IF( lk_mpp ) CALL mpp_sum ( zdf_gls_alloc ) … … 329 322 ! 330 323 ! One level below 331 en(:,:,2) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1 * ((zhsro(:,:)+fsdepw(:,:,2))/zhsro(:,:) )**(1.5_wp*ra_sf))**(2._wp/3._wp) 324 en(:,:,2) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1 * ((zhsro(:,:)+fsdepw(:,:,2)) & 325 & / zhsro(:,:) )**(1.5_wp*ra_sf))**(2._wp/3._wp) 332 326 en(:,:,2) = MAX(en(:,:,2), rn_emin ) 333 327 z_elem_a(:,:,2) = 0._wp … … 350 344 z_elem_a(:,:,2) = 0._wp 351 345 zkar(:,:) = (rl_sf + (vkarmn-rl_sf)*(1.-exp(-rtrans*fsdept(:,:,1)/zhsro(:,:)) )) 352 zflxs(:,:) = rsbc_tke2 * ustars2(:,:)**1.5_wp * zkar(:,:) * ((zhsro(:,:)+fsdept(:,:,1))/zhsro(:,:) )**(1.5_wp*ra_sf) 346 zflxs(:,:) = rsbc_tke2 * ustars2(:,:)**1.5_wp * zkar(:,:) & 347 & * ((zhsro(:,:)+fsdept(:,:,1))/zhsro(:,:) )**(1.5_wp*ra_sf) 353 348 354 349 en(:,:,2) = en(:,:,2) + zflxs(:,:)/fse3w(:,:,2) -
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90
r10246 r10247 85 85 REAL(wp) :: rhftau_scl = 1.0_wp ! scale factor applied to HF part of taum (nn_etau=3) 86 86 87 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: en !: now turbulent kinetic energy [m2/s2]88 87 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: htau ! depth of tke penetration (nn_htau) 89 88 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dissl ! now mixing lenght of dissipation 90 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avt_k , avm_k ! not enhanced Kz91 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avmu_k, avmv_k ! not enhanced Kz92 89 #if defined key_c1d 93 90 ! !!** 1D cfg only ** ('key_c1d') … … 115 112 & e_pdl(jpi,jpj,jpk) , e_ric(jpi,jpj,jpk) , & 116 113 #endif 117 & en (jpi,jpj,jpk) , htau (jpi,jpj) , dissl(jpi,jpj,jpk) , & 118 & avt_k (jpi,jpj,jpk) , avm_k (jpi,jpj,jpk), & 119 & avmu_k(jpi,jpj,jpk) , avmv_k(jpi,jpj,jpk), STAT= zdf_tke_alloc ) 114 & htau (jpi,jpj) , dissl(jpi,jpj,jpk) , STAT= zdf_tke_alloc ) 120 115 ! 121 116 IF( lk_mpp ) CALL mpp_sum ( zdf_tke_alloc )
Note: See TracChangeset
for help on using the changeset viewer.