Changeset 5682 for branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/OPA_SRC/OBS/diaobs.F90
- Timestamp:
- 2015-08-12T17:46:45+02:00 (9 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/OPA_SRC/OBS/diaobs.F90
r5659 r5682 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_surf ! Reading and allocation of SLA observations 21 USE obs_read_prof ! Reading and allocation of profile obs 22 USE obs_read_surf ! Reading and allocation of surface obs 26 23 USE obs_readmdt ! Reading and allocation of MDT for SLA. 27 24 USE obs_prep ! Preparation of obs. (grid search etc). … … 45 42 & dia_obs_dealloc ! Deallocate dia_obs data 46 43 47 !! * Shared Module variables48 LOGICAL, PUBLIC, PARAMETER :: &49 #if defined key_diaobs50 & lk_diaobs = .TRUE. !: Logical switch for observation diangostics51 #else52 & lk_diaobs = .FALSE. !: Logical switch for observation diangostics53 #endif54 55 44 !! * Module variables 56 LOGICAL, PUBLIC :: ln_t3d !: Logical switch for temperature profiles 57 LOGICAL, PUBLIC :: ln_s3d !: Logical switch for salinity profiles 58 LOGICAL, PUBLIC :: ln_sla !: Logical switch for sea level anomalies 59 LOGICAL, PUBLIC :: ln_sst !: Logical switch for sea surface temperature 60 LOGICAL, PUBLIC :: ln_seaice !: Logical switch for sea ice concentration 61 LOGICAL, PUBLIC :: ln_vel3d !: Logical switch for velocity component (u,v) observations 62 LOGICAL, PUBLIC :: ln_ssh !: Logical switch for sea surface height 63 LOGICAL, PUBLIC :: ln_sss !: Logical switch for sea surface salinity 64 LOGICAL, PUBLIC :: ln_sstnight !: Logical switch for night mean SST observations 65 LOGICAL, PUBLIC :: ln_nea !: Remove observations near land 66 LOGICAL, PUBLIC :: ln_altbias !: Logical switch for altimeter bias 67 LOGICAL, PUBLIC :: ln_ignmis !: Logical switch for ignoring missing files 68 LOGICAL, PUBLIC :: ln_s_at_t !: Logical switch to compute model S at T observations 69 70 REAL(KIND=dp), PUBLIC :: dobsini !: Observation window start date YYYYMMDD.HHMMSS 71 REAL(KIND=dp), PUBLIC :: dobsend !: Observation window end date YYYYMMDD.HHMMSS 72 73 INTEGER, PUBLIC :: numobtypes !: Number of observation types to read in. 74 INTEGER, PUBLIC :: n1dint !: Vertical interpolation method 75 INTEGER, PUBLIC :: n2dint !: Horizontal interpolation method 76 INTEGER, DIMENSION(:), ALLOCATABLE :: nvarsprof !Number of profile variables 77 INTEGER, DIMENSION(:), ALLOCATABLE :: nextrprof !Number of profile extra variables 78 INTEGER, DIMENSION(:), ALLOCATABLE :: nvarssurf !Number of surface variables 79 INTEGER, DIMENSION(:), ALLOCATABLE :: nextrsurf !Number of surface extra variables 45 LOGICAL, PUBLIC :: ln_diaobs !: Logical switch for the obs operator 46 LOGICAL :: ln_sstnight !: Logical switch for night mean SST obs 47 48 INTEGER :: nn_1dint !: Vertical interpolation method 49 INTEGER :: nn_2dint !: Horizontal interpolation method 80 50 INTEGER, DIMENSION(imaxavtypes) :: & 81 & dailyavtypes !: Data types which are daily average 82 83 TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) :: surfdata ! Initial surface data 84 TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) :: surfdataqc ! Surface data after quality control 85 TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: profdata ! Initial profile data 86 TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: profdataqc ! Profile data after quality control 87 88 CHARACTER(len=6), PUBLIC, DIMENSION(:), ALLOCATABLE :: obstypesprof 89 CHARACTER(len=6), PUBLIC, DIMENSION(:), ALLOCATABLE :: obstypessurf 90 91 92 93 INTEGER, PARAMETER :: MaxNumFiles = 1000 94 95 LOGICAL, DIMENSION(MaxNumFiles) :: & 96 & ln_profb_ena, & !: Is the feedback files from ENACT data ? 97 ! !: If so use dailyavtypes 98 & ln_profb_enatim !: Change tim for 820 enact data set. 99 100 LOGICAL, DIMENSION(MaxNumFiles) :: & 101 & ln_velfb_av !: Is the velocity feedback files daily average? 102 LOGICAL, DIMENSION(:), ALLOCATABLE :: & 103 & ld_enact !: Profile data is ENACT so use dailyavtypes 104 LOGICAL, DIMENSION(:), ALLOCATABLE :: & 105 & ld_velav !: Velocity data is daily averaged 106 LOGICAL, DIMENSION(:), ALLOCATABLE :: & 107 & ld_sstnight !: SST observation corresponds to night mean 51 & nn_profdavtypes !: Profile data types representing a daily average 52 INTEGER :: nproftypes !: Number of profile obs types 53 INTEGER :: nsurftypes !: Number of surface obs types 54 INTEGER, DIMENSION(:), ALLOCATABLE :: & 55 & nvarsprof, & !: Number of profile variables 56 & nvarssurf !: Number of surface variables 57 INTEGER, DIMENSION(:), ALLOCATABLE :: & 58 & nextrprof, & !: Number of profile extra variables 59 & nextrsurf !: Number of surface extra variables 60 61 TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) :: & 62 & surfdata, & !: Initial surface data 63 & surfdataqc !: Surface data after quality control 64 TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: & 65 & profdata, & !: Initial profile data 66 & profdataqc !: Profile data after quality control 67 68 CHARACTER(len=6), PUBLIC, DIMENSION(:), ALLOCATABLE :: & 69 & cobstypesprof, & !: Profile obs types 70 & cobstypessurf !: Surface obs types 108 71 109 72 !!---------------------------------------------------------------------- … … 136 99 137 100 !! * Local declarations 138 CHARACTER(len=128) :: profbfiles(MaxNumFiles) 139 CHARACTER(len=128) :: sstfbfiles(MaxNumFiles) 140 CHARACTER(len=128) :: slafbfiles(MaxNumFiles) 141 CHARACTER(len=128) :: seaicefbfiles(MaxNumFiles) 142 CHARACTER(len=128) :: velfbfiles(MaxNumFiles) 143 CHARACTER(LEN=128) :: bias_file 144 CHARACTER(LEN=20) :: datestr=" ", timestr=" " 145 146 NAMELIST/namobs/ln_t3d, ln_s3d, ln_sla, ln_sss, ln_ssh, & 147 & ln_sst, ln_seaice, ln_vel3d, & 101 INTEGER, PARAMETER :: & 102 & jpmaxnfiles = 1000 ! Maximum number of files for each obs type 103 INTEGER, DIMENSION(:), ALLOCATABLE :: & 104 & ifilesprof, & ! Number of profile files 105 & ifilessurf ! Number of surface files 106 INTEGER :: ios ! Local integer output status for namelist read 107 INTEGER :: jtype ! Counter for obs types 108 INTEGER :: jvar ! Counter for variables 109 INTEGER :: jfile ! Counter for files 110 111 CHARACTER(len=128), DIMENSION(jpmaxnfiles) :: & 112 & cn_profbfiles, & ! T/S profile input filenames 113 & cn_sstfbfiles, & ! Sea surface temperature input filenames 114 & cn_slafbfiles, & ! Sea level anomaly input filenames 115 & cn_sicfbfiles, & ! Seaice concentration input filenames 116 & cn_velfbfiles ! Velocity profile input filenames 117 CHARACTER(LEN=128) :: & 118 & cn_altbiasfile ! Altimeter bias input filename 119 CHARACTER(len=128), DIMENSION(:,:), ALLOCATABLE :: & 120 & clproffiles, & ! Profile filenames 121 & clsurffiles ! Surface filenames 122 123 LOGICAL :: ln_t3d ! Logical switch for temperature profiles 124 LOGICAL :: ln_s3d ! Logical switch for salinity profiles 125 LOGICAL :: ln_sla ! Logical switch for sea level anomalies 126 LOGICAL :: ln_sst ! Logical switch for sea surface temperature 127 LOGICAL :: ln_sic ! Logical switch for sea ice concentration 128 LOGICAL :: ln_vel3d ! Logical switch for velocity (u,v) obs 129 LOGICAL :: ln_nea ! Logical switch to remove obs near land 130 LOGICAL :: ln_altbias ! Logical switch for altimeter bias 131 LOGICAL :: ln_ignmis ! Logical switch for ignoring missing files 132 LOGICAL :: ln_s_at_t ! Logical switch to compute model S at T obs 133 LOGICAL :: llvar1 ! Logical for profile variable 1 134 LOGICAL :: llvar2 ! Logical for profile variable 1 135 LOGICAL :: llnightav ! Logical for calculating night-time averages 136 137 REAL(dp) :: rn_dobsini ! Obs window start date YYYYMMDD.HHMMSS 138 REAL(dp) :: rn_dobsend ! Obs window end date YYYYMMDD.HHMMSS 139 REAL(wp), DIMENSION(jpi,jpj) :: & 140 & zglam1, & ! Model longitudes for profile variable 1 141 & zglam2 ! Model longitudes for profile variable 2 142 REAL(wp), DIMENSION(jpi,jpj) :: & 143 & zgphi1, & ! Model latitudes for profile variable 1 144 & zgphi2 ! Model latitudes for profile variable 2 145 REAL(wp), DIMENSION(jpi,jpj,jpk) :: & 146 & zmask1, & ! Model land/sea mask associated with variable 1 147 & zmask2 ! Model land/sea mask associated with variable 2 148 149 NAMELIST/namobs/ln_diaobs, ln_t3d, ln_s3d, ln_sla, & 150 & ln_sst, ln_sic, ln_vel3d, & 148 151 & ln_altbias, ln_nea, ln_grid_global, & 149 & ln_grid_search_lookup, ln_cl4,&152 & ln_grid_search_lookup, & 150 153 & ln_ignmis, ln_s_at_t, ln_sstnight, & 151 & ln_profb_ena, ln_profb_enatim, & 152 & profbfiles, slafbfiles, sssfbfiles, & 153 & sshfbfiles, sstfbfiles, seaicefbfiles, & 154 & velfbfiles, bias_file, grid_search_file, & 155 & dobsini, dobsend, n1dint, n2dint, & 156 & nmsshc, mdtcorr, mdtcutoff, & 157 & grid_search_res, dailyavtypes 158 159 INTEGER :: jtype 160 INTEGER :: ios ! Local integer output status for namelist read 161 INTEGER, DIMENSION(:), ALLOCATABLE :: jnumfilesprof 162 INTEGER, DIMENSION(:), ALLOCATABLE :: jnumfilessurf 163 CHARACTER(len=128), DIMENSION(:,:), ALLOCATABLE :: obsfilesprof 164 CHARACTER(len=128), DIMENSION(:,:), ALLOCATABLE :: obsfilessurf 165 LOGICAL :: lmask(MaxNumFiles) 154 & cn_profbfiles, cn_slafbfiles, & 155 & cn_sstfbfiles, cn_sicfbfiles, & 156 & cn_velfbfiles, cn_altbiasfile, & 157 & cn_gridsearchfile, rn_gridsearchres, & 158 & rn_dobsini, rn_dobsend, nn_1dint, nn_2dint, & 159 & nn_msshc, rn_mdtcorr, rn_mdtcutoff, & 160 & nn_profdavtypes 161 166 162 !----------------------------------------------------------------------- 167 163 ! Read namelist parameters 168 164 !----------------------------------------------------------------------- 169 165 170 profbfiles(:) = '' 171 slafbfiles(:) = '' 172 sstfbfiles(:) = '' 173 seaicefbfiles(:) = '' 174 velfbfiles(:) = '' 175 dailyavtypes(:) = -1 176 dailyavtypes(1) = 820 177 ln_profb_ena(:) = .FALSE. 178 ln_profb_enatim(:) = .TRUE. 179 ln_velfb_av(:) = .FALSE. 180 ln_ignmis = .FALSE. 181 182 CALL ini_date( dobsini ) 183 CALL fin_date( dobsend ) 184 185 ! Read Namelist namobs : control observation diagnostics 186 REWIND( numnam_ref ) ! Namelist namobs in reference namelist : Diagnostic: control observation 166 ! Some namelist arrays need initialising 167 cn_profbfiles(:) = '' 168 cn_slafbfiles(:) = '' 169 cn_sstfbfiles(:) = '' 170 cn_sicfbfiles(:) = '' 171 cn_velfbfiles(:) = '' 172 nn_profdavtypes(:) = -1 173 174 CALL ini_date( rn_dobsini ) 175 CALL fin_date( rn_dobsend ) 176 177 ! Read namelist namobs : control observation diagnostics 178 REWIND( numnam_ref ) ! Namelist namobs in reference namelist 187 179 READ ( numnam_ref, namobs, IOSTAT = ios, ERR = 901) 188 180 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobs in reference namelist', lwp ) 189 181 190 REWIND( numnam_cfg ) ! Namelist namobs in configuration namelist : Diagnostic: control observation182 REWIND( numnam_cfg ) ! Namelist namobs in configuration namelist 191 183 READ ( numnam_cfg, namobs, IOSTAT = ios, ERR = 902 ) 192 184 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobs in configuration namelist', lwp ) 193 185 IF(lwm) WRITE ( numond, namobs ) 194 186 195 !Set up list of observation types to be used 196 numproftypes = COUNT( (/ln_t3d .OR. ln_s3d, ln_vel3d /) ) 197 numsurftypes = COUNT( (/ln_sla, ln_sss, ln_sst, ln_seaice /) ) 198 IF ( numproftypes > 0 ) THEN 199 200 ALLOCATE( obstypesprof(numproftypes) ) 201 ALLOCATE( jnumfilesprof(numproftypes) ) 202 ALLOCATE( obsfilesprof(numproftypes, MaxNumFiles) ) 203 204 DO jtype = 1, numproftypes 205 IF (ln_t3d .OR. ln_s3d) THEN 206 obsfilesprof(:,jtype) = profbfiles(:) 207 obstypesprof(jtype) = 'prof' 208 ENDIF 209 IF (ln_vel3d) THEN 210 obsfilesprof(:,jtype) = velfbfiles(:) 211 obstypesprof(jtype) = 'vel' 212 ENDIF 213 214 lmask(:) = .FALSE. 215 WHERE (obsfilesprof(jtype,:) /= '') lmask(:) = .TRUE. 216 jnumfilesprof(jtype) = COUNT(lmask) 217 END DO 218 219 ENDIF 220 221 IF ( numsurftypes > 0 ) THEN 222 223 ALLOCATE( obstypessurf(numsurftypes) ) 224 ALLOCATE( jnumfilessurf(numproftypes) ) 225 ALLOCATE( obsfilessurf(numsurftypes, MaxNumFiles) ) 226 227 DO jtype = 1, numsurftypes 228 IF (ln_sla) THEN 229 obsfilessurf(:,jtype) = slafbfiles(:) 230 obstypessurf(jtype) = 'sla' 231 ENDIF 232 IF (ln_sss) THEN 233 obsfilessurf(:,jtype) = sssfbfiles(:) 234 obstypessurf(jtype) = 'sss' 235 ENDIF 236 IF (ln_sst) THEN 237 obsfilessurf(:,jtype) = sstfbfiles(:) 238 obstypessurf(jtype) = 'sst' 239 ENDIF 187 IF ( .NOT. ln_diaobs ) THEN 188 IF(lwp) WRITE(numout,cform_war) 189 IF(lwp) WRITE(numout,*)' ln_diaobs is set to false so not calling dia_obs' 190 RETURN 191 ENDIF 192 193 !----------------------------------------------------------------------- 194 ! Set up list of observation types to be used 195 ! and the files associated with each type 196 !----------------------------------------------------------------------- 197 198 nproftypes = COUNT( (/ln_t3d .OR. ln_s3d, ln_vel3d /) ) 199 nsurftypes = COUNT( (/ln_sla, ln_sst, ln_sic /) ) 200 201 IF ( nproftypes == 0 .AND. nsurftypes == 0 ) THEN 202 IF(lwp) WRITE(numout,cform_war) 203 IF(lwp) WRITE(numout,*) ' ln_diaobs is set to true, but all obs operator logical flags', & 204 & ' ln_t3d, ln_s3d, ln_sla, ln_sst, ln_sic, ln_vel3d', & 205 & ' are set to .FALSE. so turning off calls to dia_obs' 206 nwarn = nwarn + 1 207 ln_diaobs = .FALSE. 208 RETURN 209 ENDIF 210 211 IF ( nproftypes > 0 ) THEN 212 213 ALLOCATE( cobstypesprof(nproftypes) ) 214 ALLOCATE( ifilesprof(nproftypes) ) 215 ALLOCATE( clproffiles(nproftypes,jpmaxnfiles) ) 216 217 jtype = 0 218 IF (ln_t3d .OR. ln_s3d) THEN 219 jtype = jtype + 1 220 clproffiles(jtype,:) = cn_profbfiles(:) 221 cobstypesprof(jtype) = 'prof ' 222 ifilesprof(jtype) = 0 223 DO jfile = 1, jpmaxnfiles 224 IF ( trim(clproffiles(jtype,jfile)) /= '' ) & 225 ifilesprof(jtype) = ifilesprof(jtype) + 1 226 END DO 227 ENDIF 228 IF (ln_vel3d) THEN 229 jtype = jtype + 1 230 clproffiles(jtype,:) = cn_velfbfiles(:) 231 cobstypesprof(jtype) = 'vel ' 232 ifilesprof(jtype) = 0 233 DO jfile = 1, jpmaxnfiles 234 IF ( trim(clproffiles(jtype,jfile)) /= '' ) & 235 ifilesprof(jtype) = ifilesprof(jtype) + 1 236 END DO 237 ENDIF 238 239 ENDIF 240 241 IF ( nsurftypes > 0 ) THEN 242 243 ALLOCATE( cobstypessurf(nsurftypes) ) 244 ALLOCATE( ifilessurf(nsurftypes) ) 245 ALLOCATE( clsurffiles(nsurftypes, jpmaxnfiles) ) 246 247 jtype = 0 248 IF (ln_sla) THEN 249 jtype = jtype + 1 250 clsurffiles(jtype,:) = cn_slafbfiles(:) 251 cobstypessurf(jtype) = 'sla ' 252 ifilessurf(jtype) = 0 253 DO jfile = 1, jpmaxnfiles 254 IF ( trim(clsurffiles(jtype,jfile)) /= '' ) & 255 ifilessurf(jtype) = ifilessurf(jtype) + 1 256 END DO 257 ENDIF 258 IF (ln_sst) THEN 259 jtype = jtype + 1 260 clsurffiles(jtype,:) = cn_sstfbfiles(:) 261 cobstypessurf(jtype) = 'sst ' 262 ifilessurf(jtype) = 0 263 DO jfile = 1, jpmaxnfiles 264 IF ( trim(clsurffiles(jtype,jfile)) /= '' ) & 265 ifilessurf(jtype) = ifilessurf(jtype) + 1 266 END DO 267 ENDIF 240 268 #if defined key_lim2 || defined key_lim3 241 IF (ln_seaice) THEN 242 obsfilessurf(:,jtype) = seaicefbfiles(:) 243 obstypessurf(jtype) = 'seaice' 244 ENDIF 269 IF (ln_sic) THEN 270 jtype = jtype + 1 271 clsurffiles(jtype,:) = cn_sicfbfiles(:) 272 cobstypessurf(jtype) = 'sic ' 273 ifilessurf(jtype) = 0 274 DO jfile = 1, jpmaxnfiles 275 IF ( trim(clsurffiles(jtype,jfile)) /= '' ) & 276 ifilessurf(jtype) = ifilessurf(jtype) + 1 277 END DO 278 ENDIF 245 279 #endif 246 280 247 lmask(:) = .FALSE.248 WHERE (obsfilessurf(jtype,:) /= '') lmask(:) = .TRUE.249 jnumfilessurf(jtype) = COUNT(lmask)250 251 END DO252 253 281 ENDIF 254 282 … … 259 287 WRITE(numout,*) '~~~~~~~~~~~~' 260 288 WRITE(numout,*) ' Namelist namobs : set observation diagnostic parameters' 261 WRITE(numout,*) ' Logical switch for T profile observations ln_t3d = ', ln_t3d 262 WRITE(numout,*) ' Logical switch for S profile observations ln_s3d = ', ln_s3d 263 WRITE(numout,*) ' Logical switch for SLA observations ln_sla = ', ln_sla 264 WRITE(numout,*) ' Logical switch for SSH observations ln_ssh = ', ln_ssh 265 WRITE(numout,*) ' Logical switch for SST observations ln_sst = ', ln_sst 266 WRITE(numout,*) ' Logical switch for night-time SST obs ln_sstnight = ', ln_sstnight 267 WRITE(numout,*) ' Logical switch for SSS observations ln_sss = ', ln_sss 268 WRITE(numout,*) ' Logical switch for Sea Ice observations ln_seaice = ', ln_seaice 269 WRITE(numout,*) ' Logical switch for velocity observations ln_vel3d = ', ln_vel3d 270 WRITE(numout,*) ' Global distribution of observations ln_grid_global = ',ln_grid_global 271 WRITE(numout,*) & 272 ' Logical switch for obs grid search w/lookup table ln_grid_search_lookup = ',ln_grid_search_lookup 289 WRITE(numout,*) ' Logical switch for T profile observations ln_t3d = ', ln_t3d 290 WRITE(numout,*) ' Logical switch for S profile observations ln_s3d = ', ln_s3d 291 WRITE(numout,*) ' Logical switch for SLA observations ln_sla = ', ln_sla 292 WRITE(numout,*) ' Logical switch for SST observations ln_sst = ', ln_sst 293 WRITE(numout,*) ' Logical switch for Sea Ice observations ln_sic = ', ln_sic 294 WRITE(numout,*) ' Logical switch for velocity observations ln_vel3d = ', ln_vel3d 295 WRITE(numout,*) ' Global distribution of observations ln_grid_global = ',ln_grid_global 296 WRITE(numout,*) ' Logical switch for obs grid search lookup ln_grid_search_lookup = ',ln_grid_search_lookup 273 297 IF (ln_grid_search_lookup) & 274 WRITE(numout,*) ' Grid search lookup file header grid_search_file = ', grid_search_file275 WRITE(numout,*) ' Initial date in window YYYYMMDD.HHMMSS dobsini = ', dobsin276 WRITE(numout,*) ' Final date in window YYYYMMDD.HHMMSS dobsend = ',dobsend277 WRITE(numout,*) ' Type of vertical interpolation method n1dint = ', n1dint278 WRITE(numout,*) ' Type of horizontal interpolation method n2dint = ', n2dint279 WRITE(numout,*) ' Rejection of observations near land swit hchln_nea = ', ln_nea280 WRITE(numout,*) ' MSSH correction scheme nmsshc = ', nmsshc281 WRITE(numout,*) ' MDT correction mdtcorr = ',mdtcorr282 WRITE(numout,*) ' MDT cutoff for computed correction mdtcutoff = ',mdtcutoff283 WRITE(numout,*) ' Logical switch for alt bias ln_altbias = ', ln_altbias284 WRITE(numout,*) ' Logical switch for ignoring missing files ln_ignmis = ', ln_ignmis285 WRITE(numout,*) ' Daily average types = ', dailyavtypes286 287 IF ( numproftypes > 0 ) THEN288 DO jtype = 1, numproftypes 289 DO ji = 1, jnumfilesprof(jtype)290 WRITE(numout,'(1X,2A)') ' '//obstypesprof(jtype)//' input observation file names = ', &291 TRIM(obsfilesprof(jtype,ji))292 IF ( TRIM(obstypesprof(jtype)) == 'prof' )&293 WRITE(numout,'(1X,2A)') ' Enact feedback input time setting switch ln_profb_enatim = ', ln_profb_enatim(ji)298 WRITE(numout,*) ' Grid search lookup file header cn_gridsearchfile = ', cn_gridsearchfile 299 WRITE(numout,*) ' Initial date in window YYYYMMDD.HHMMSS rn_dobsini = ', rn_dobsini 300 WRITE(numout,*) ' Final date in window YYYYMMDD.HHMMSS rn_dobsend = ', rn_dobsend 301 WRITE(numout,*) ' Type of vertical interpolation method nn_1dint = ', nn_1dint 302 WRITE(numout,*) ' Type of horizontal interpolation method nn_2dint = ', nn_2dint 303 WRITE(numout,*) ' Rejection of observations near land switch ln_nea = ', ln_nea 304 WRITE(numout,*) ' MSSH correction scheme nn_msshc = ', nn_msshc 305 WRITE(numout,*) ' MDT correction rn_mdtcorr = ', rn_mdtcorr 306 WRITE(numout,*) ' MDT cutoff for computed correction rn_mdtcutoff = ', rn_mdtcutoff 307 WRITE(numout,*) ' Logical switch for alt bias ln_altbias = ', ln_altbias 308 WRITE(numout,*) ' Logical switch for ignoring missing files ln_ignmis = ', ln_ignmis 309 WRITE(numout,*) ' Daily average types nn_profdavtypes = ', nn_profdavtypes 310 WRITE(numout,*) ' Logical switch for night-time SST obs ln_sstnight = ', ln_sstnight 311 WRITE(numout,*) ' Number of profile obs types: ',nproftypes 312 313 IF ( nproftypes > 0 ) THEN 314 DO jtype = 1, nproftypes 315 DO jfile = 1, ifilesprof(jtype) 316 WRITE(numout,'(1X,2A)') ' '//cobstypesprof(jtype)//' input observation file names = ', & 317 TRIM(clproffiles(jtype,jfile)) 294 318 END DO 295 319 END DO 296 320 ENDIF 297 298 IF ( numsurftypes > 0 ) THEN 299 DO jtype = 1, numsurftypes 300 DO ji = 1, jnumfilessurf(jtype) 301 WRITE(numout,'(1X,2A)') ' '//obstypessurf(jtype)//' input observation file names = ', & 302 TRIM(obsfilessurf(jtype,ji)) 321 322 WRITE(numout,*)' Number of surface obs types: ',nsurftypes 323 IF ( nsurftypes > 0 ) THEN 324 DO jtype = 1, nsurftypes 325 DO jfile = 1, ifilessurf(jtype) 326 WRITE(numout,'(1X,2A)') ' '//cobstypessurf(jtype)//' input observation file names = ', & 327 TRIM(clsurffiles(jtype,jfile)) 303 328 END DO 304 329 END DO 305 330 ENDIF 306 307 ENDIF 308 331 WRITE(numout,*) '~~~~~~~~~~~~' 332 333 ENDIF 334 335 !----------------------------------------------------------------------- 336 ! Obs operator parameter checking and initialisations 337 !----------------------------------------------------------------------- 338 309 339 IF ( ln_vel3d .AND. ( .NOT. ln_grid_global ) ) THEN 310 340 CALL ctl_stop( 'Velocity data only works with ln_grid_global=.true.' ) … … 312 342 ENDIF 313 343 314 CALL obs_typ_init 315 316 CALL mppmap_init 317 318 ! Parameter control 319 #if defined key_diaobs 320 IF ( numobtypes == 0 ) THEN 321 IF(lwp) WRITE(numout,cform_war) 322 IF(lwp) WRITE(numout,*) ' key_diaobs is activated but logical flags', & 323 & ' ln_t3d, ln_s3d, ln_sla, ln_ssh, ln_sst, ln_sss, ln_seaice, ln_vel3d are all set to .FALSE.' 324 nwarn = nwarn + 1 325 ENDIF 326 #endif 327 328 CALL obs_grid_setup( ) 329 IF ( ( n1dint < 0 ).OR.( n1dint > 1 ) ) THEN 344 IF ( ( nn_1dint < 0 ) .OR. ( nn_1dint > 1 ) ) THEN 330 345 CALL ctl_stop(' Choice of vertical (1D) interpolation method', & 331 346 & ' is not available') 332 347 ENDIF 333 IF ( ( n2dint < 0 ).OR.( n2dint > 4 ) ) THEN 348 349 IF ( ( nn_2dint < 0 ) .OR. ( nn_2dint > 4 ) ) THEN 334 350 CALL ctl_stop(' Choice of horizontal (2D) interpolation method', & 335 351 & ' is not available') 336 352 ENDIF 337 353 354 CALL obs_typ_init 355 356 CALL mppmap_init 357 358 CALL obs_grid_setup( ) 359 338 360 !----------------------------------------------------------------------- 339 361 ! Depending on switches read the various observation types 340 362 !----------------------------------------------------------------------- 341 342 IF ( n umproftypes > 0 ) THEN343 344 ALLOCATE(profdata(n umproftypes))345 ALLOCATE(profdataqc(n umproftypes))346 ALLOCATE(nvarsprof(n umproftypes))347 ALLOCATE(nextrprof(n umproftypes))348 349 DO jtype = 1, n umproftypes350 363 364 IF ( nproftypes > 0 ) THEN 365 366 ALLOCATE(profdata(nproftypes)) 367 ALLOCATE(profdataqc(nproftypes)) 368 ALLOCATE(nvarsprof(nproftypes)) 369 ALLOCATE(nextrprof(nproftypes)) 370 371 DO jtype = 1, nproftypes 372 351 373 nvarsprof(jtype) = 2 352 IF ( TRIM(obstypesprof(jtype)) == 'prof' ) nextrprof(jtype) = 1 353 IF ( TRIM(obstypesprof(jtype)) == 'vel' ) nextrprof(jtype) = 2 354 355 !Read in profile or velocity obs types 356 CALL obs_rea_prof( profdata(jtype), & 357 & jnumfilesprof(jtype), & 358 & obsfilesprof(jtype,1:jnumfilesprof(jtype)), & 359 & nvarsprof(jtype), nextrprof(jtype), nitend-nit000+2, & 360 & dobsini, dobsend, ln_t3d, ln_s3d, & 361 & ln_ignmis, ln_s_at_t, .TRUE., .FALSE., & 362 & kdailyavtypes = dailyavtypes ) 363 364 DO jvar = 1, nvars 374 IF ( TRIM(cobstypesprof(jtype)) == 'prof' ) THEN 375 nextrprof(jtype) = 1 376 llvar1 = ln_t3d 377 llvar2 = ln_s3d 378 zglam1 = glamt 379 zgphi1 = gphit 380 zmask1 = tmask 381 zglam2 = glamt 382 zgphi2 = gphit 383 zmask2 = tmask 384 ENDIF 385 IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN 386 nextrprof(jtype) = 2 387 llvar1 = ln_vel3d 388 llvar2 = ln_vel3d 389 zglam1 = glamu 390 zgphi1 = gphiu 391 zmask1 = umask 392 zglam2 = glamv 393 zgphi2 = gphiv 394 zmask2 = vmask 395 ENDIF 396 397 !Read in profile or profile obs types 398 CALL obs_rea_prof( profdata(jtype), ifilesprof(jtype), & 399 & clproffiles(jtype,1:ifilesprof(jtype)), & 400 & nvarsprof(jtype), nextrprof(jtype), nitend-nit000+2, & 401 & rn_dobsini, rn_dobsend, llvar1, llvar2, & 402 & ln_ignmis, ln_s_at_t, .FALSE., & 403 & kdailyavtypes = nn_profdavtypes ) 404 405 DO jvar = 1, nvarsprof(jtype) 365 406 CALL obs_prof_staend( profdata(jtype), jvar ) 366 407 END DO 367 368 CALL obs_pre_prof( profdata(jtype), profdataqc(jtype), & 369 & ln_t3d, ln_s3d, ln_nea, & 370 & kdailyavtypes = dailyavtypes ) 408 409 CALL obs_pre_prof( profdata(jtype), profdataqc(jtype), & 410 & llvar1, llvar2, & 411 & zmask1, zglam1, zgphi1, zmask2, zglam2, zgphi2, & 412 & ln_nea, kdailyavtypes = nn_profdavtypes ) 371 413 372 414 END DO 373 415 374 DEALLOCATE( jnumfilesprof, obsfilesprof)375 376 ENDIF 377 378 IF ( n umsurftypes > 0 ) THEN379 380 ALLOCATE(surfdata(n umsurftypes))381 ALLOCATE(surfdata tqc(numsurftypes))382 ALLOCATE(nvarssurf(n umsurftypes))383 ALLOCATE(nextrsurf(n umsurftypes))384 385 DO jtype = 1, n umsurftypes386 416 DEALLOCATE( ifilesprof, clproffiles ) 417 418 ENDIF 419 420 IF ( nsurftypes > 0 ) THEN 421 422 ALLOCATE(surfdata(nsurftypes)) 423 ALLOCATE(surfdataqc(nsurftypes)) 424 ALLOCATE(nvarssurf(nsurftypes)) 425 ALLOCATE(nextrsurf(nsurftypes)) 426 427 DO jtype = 1, nsurftypes 428 387 429 nvarssurf(jtype) = 1 388 430 nextrsurf(jtype) = 0 389 IF ( TRIM(obstypessurf(jtype)) == 'sla' ) nextrsurf(jtype) = 2 431 llnightav = .FALSE. 432 IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) nextrsurf(jtype) = 2 433 IF ( TRIM(cobstypessurf(jtype)) == 'sst' ) llnightav = ln_sstnight 390 434 391 435 !Read in surface obs types 392 CALL obs_rea_surf( surfdata(jtype), jnumfilessurf(jtype), &393 & obsfilessurf(jtype,1:jnumfilessurf(jtype)), &436 CALL obs_rea_surf( surfdata(jtype), ifilessurf(jtype), & 437 & clsurffiles(jtype,1:ifilessurf(jtype)), & 394 438 & nvarssurf(jtype), nextrsurf(jtype), nitend-nit000+2, & 395 & dobsini, dobsend, ln_ignmis, .FALSE.)439 & rn_dobsini, rn_dobsend, ln_ignmis, .FALSE., llnightav ) 396 440 397 441 CALL obs_pre_surf( surfdata(jtype), surfdataqc(jtype), ln_nea ) 398 399 IF ( TRIM( obstypessurf(jtype)) == 'sla' ) THEN400 CALL obs_rea_mdt( surfdataqc(jtype), n 2dint )401 IF ( ln_altbias ) CALL obs_rea_altbias ( surfdataqc(jtype), n 2dint, bias_file )442 443 IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN 444 CALL obs_rea_mdt( surfdataqc(jtype), nn_2dint ) 445 IF ( ln_altbias ) CALL obs_rea_altbias ( surfdataqc(jtype), nn_2dint, cn_altbiasfile ) 402 446 ENDIF 403 447 404 DEALLOCATE( jnumfilessurf, obsfilessurf )405 406 448 END DO 449 450 DEALLOCATE( ifilessurf, clsurffiles ) 451 452 ENDIF 407 453 408 454 END SUBROUTINE dia_obs_init … … 415 461 !! 416 462 !! ** Method : Call the observation operators on each time step to 417 !! compute the model equivalent of the following date: 418 !! - T profiles 419 !! - S profiles 420 !! - Sea surface height (referenced to a mean) 421 !! - Sea surface temperature 422 !! - Sea surface salinity 423 !! - Velocity component (U,V) profiles 424 !! 425 !! ** Action : 463 !! compute the model equivalent of the following data: 464 !! - Profile data, currently T/S or U/V 465 !! - Surface data, currently SST, SLA or sea-ice concentration. 466 !! 467 !! ** Action : 426 468 !! 427 469 !! History : … … 432 474 !! ! 07-04 (G. Smith) Generalized surface operators 433 475 !! ! 08-10 (M. Valdivieso) obs operator for velocity profiles 476 !! ! 15-08 (M. Martin) Combined surface/profile routines. 434 477 !!---------------------------------------------------------------------- 435 478 !! * Modules used 436 USE dom_oce, ONLY : & ! Ocean space and time domain variables 437 & rdt, & 438 & gdept_1d, & 439 & tmask, umask, vmask 440 USE phycst, ONLY : & ! Physical constants 441 & rday 442 USE oce, ONLY : & ! Ocean dynamics and tracers variables 443 & tsn, & 444 & un, vn, & 479 USE phycst, ONLY : & ! Physical constants 480 & rday 481 USE oce, ONLY : & ! Ocean dynamics and tracers variables 482 & tsn, & 483 & un, & 484 & vn, & 445 485 & sshn 446 486 #if defined key_lim3 447 USE ice, ONLY : & ! LIMIce model variables487 USE ice, ONLY : & ! LIM3 Ice model variables 448 488 & frld 449 489 #endif 450 490 #if defined key_lim2 451 USE ice_2, ONLY : & ! LIMIce model variables491 USE ice_2, ONLY : & ! LIM2 Ice model variables 452 492 & frld 453 493 #endif … … 455 495 456 496 !! * Arguments 457 INTEGER, INTENT(IN) :: kstp 497 INTEGER, INTENT(IN) :: kstp ! Current timestep 458 498 !! * Local declarations 459 INTEGER :: idaystp ! Number of timesteps per day 460 INTEGER :: jtype ! data loop variable 461 INTEGER :: jvar ! Variable number 499 INTEGER :: idaystp ! Number of timesteps per day 500 INTEGER :: jtype ! Data loop variable 501 INTEGER :: jvar ! Variable number 502 REAL(wp), DIMENSION(jpi,jpj,jpk) :: & 503 & zprofvar1, & ! Model values for 1st variable in a prof ob 504 & zprofvar2 ! Model values for 2nd variable in a prof ob 505 REAL(wp), DIMENSION(jpi,jpj,jpk) :: & 506 & zprofmask1, & ! Mask associated with zprofvar1 507 & zprofmask2 ! Mask associated with zprofvar2 508 REAL(wp), DIMENSION(jpi,jpj) :: & 509 & zsurfvar ! Model values equivalent to surface ob. 510 REAL(wp), DIMENSION(jpi,jpj) :: & 511 & zglam1, & ! Model longitudes for prof variable 1 512 & zglam2, & ! Model longitudes for prof variable 2 513 & zgphi1, & ! Model latitudes for prof variable 1 514 & zgphi2 ! Model latitudes for prof variable 2 462 515 #if ! defined key_lim2 && ! defined key_lim3 463 REAL(wp), POINTER, DIMENSION(:,:) :: frld 516 REAL(wp), POINTER, DIMENSION(:,:) :: frld 464 517 #endif 465 CHARACTER(LEN=20) :: datestr=" ",timestr=" "466 518 LOGICAL :: llnightav ! Logical for calculating night-time average 519 467 520 #if ! defined key_lim2 && ! defined key_lim3 468 521 CALL wrk_alloc(jpi,jpj,frld) … … 473 526 WRITE(numout,*) 'dia_obs : Call the observation operators', kstp 474 527 WRITE(numout,*) '~~~~~~~' 528 CALL FLUSH(numout) 475 529 ENDIF 476 530 … … 484 538 #endif 485 539 !----------------------------------------------------------------------- 486 ! Depending on switches call various observation operators 487 !----------------------------------------------------------------------- 488 489 IF ( numproftypes > 0 ) THEN 490 DO jtype = 1, numproftypes 491 492 SELECT CASE ( TRIM(obstypesprof(jtype)) ) 540 ! Call the profile and surface observation operators 541 !----------------------------------------------------------------------- 542 543 IF ( nproftypes > 0 ) THEN 544 545 DO jtype = 1, nproftypes 546 547 SELECT CASE ( TRIM(cobstypesprof(jtype)) ) 493 548 CASE('prof') 494 profvar1(:,:,:) = tsn(:,:,:,jp_tem) 495 profvar2(:,:,:) = tsn(:,:,:,jp_sal) 496 profmask1(:,:,:) = tmask(:,:,:) 497 profmask2(:,:,:) = tmask(:,:,:) 549 zprofvar1(:,:,:) = tsn(:,:,:,jp_tem) 550 zprofvar2(:,:,:) = tsn(:,:,:,jp_sal) 551 zprofmask1(:,:,:) = tmask(:,:,:) 552 zprofmask2(:,:,:) = tmask(:,:,:) 553 zglam1(:,:) = glamt(:,:) 554 zglam2(:,:) = glamt(:,:) 555 zgphi1(:,:) = gphit(:,:) 556 zgphi2(:,:) = gphit(:,:) 498 557 CASE('vel') 499 profvar1(:,:,:) = un(:,:,:) 500 profvar2(:,:,:) = vn(:,:,:) 501 profmask1(:,:,:) = umask(:,:,:) 502 profmask2(:,:,:) = vmask(:,:,:) 558 zprofvar1(:,:,:) = un(:,:,:) 559 zprofvar2(:,:,:) = vn(:,:,:) 560 zprofmask1(:,:,:) = umask(:,:,:) 561 zprofmask2(:,:,:) = vmask(:,:,:) 562 zglam1(:,:) = glamu(:,:) 563 zglam2(:,:) = glamv(:,:) 564 zgphi1(:,:) = gphiu(:,:) 565 zgphi2(:,:) = gphiv(:,:) 503 566 END SELECT 504 505 CALL obs_prof_opt( profdataqc(jtype), & 506 & kstp, jpi, jpj, jpk, nit000, idaystp, & 507 & profvar1, profvar2, & 508 & gdept_1d, profmask1, profmask2, n1dint, n2dint, & 509 & kdailyavtypes = dailyavtypes ) 510 567 568 CALL obs_prof_opt( profdataqc(jtype), kstp, jpi, jpj, jpk, & 569 & nit000, idaystp, & 570 & zprofvar1, zprofvar2, & 571 & gdept_1d, zprofmask1, zprofmask2, & 572 & zglam1, zglam2, zgphi1, zgphi2, & 573 & nn_1dint, nn_2dint, & 574 & kdailyavtypes = nn_profdavtypes ) 575 511 576 END DO 512 577 513 578 ENDIF 514 579 515 IF ( numsurftypes > 0 ) THEN 516 DO jtype = 1, numsurftypes 517 518 SELECT CASE ( TRIM(obstypessurf(jtype)) ) 580 IF ( nsurftypes > 0 ) THEN 581 582 DO jtype = 1, nsurftypes 583 584 SELECT CASE ( TRIM(cobstypessurf(jtype)) ) 519 585 CASE('sst') 520 surfvar(:,:) = tsn(:,:,1,jp_tem) 586 zsurfvar(:,:) = tsn(:,:,1,jp_tem) 587 llnightav = ln_sstnight 521 588 CASE('sla') 522 surfvar(:,:) = sshn(:,:) 523 CASE('sss') 524 surfvar(:,:) = tsn(:,:,1,jp_sal) 589 zsurfvar(:,:) = sshn(:,:) 590 llnightav = .FALSE. 525 591 #if defined key_lim2 || defined key_lim3 526 CASE('seaice') 527 surfvar(:,:) = 1._wp - frld(:,:) 592 CASE('sic') 593 zsurfvar(:,:) = 1._wp - frld(:,:) 594 llnightav = .FALSE. 528 595 #endif 529 596 END SELECT 530 531 CALL obs_surf_opt( surfdat qc(jtype),&532 & kstp, jpi, jpj, nit000, surfvar, &533 & tmask(:,:,1), n2dint, ld_sstnight)534 597 598 CALL obs_surf_opt( surfdataqc(jtype), kstp, jpi, jpj, & 599 & nit000, idaystp, zsurfvar, tmask(:,:,1), & 600 & nn_2dint, llnightav ) 601 535 602 END DO 536 537 ENDIF 538 603 604 ENDIF 605 539 606 #if ! defined key_lim2 && ! defined key_lim3 540 607 CALL wrk_dealloc(jpi,jpj,frld) … … 542 609 543 610 END SUBROUTINE dia_obs 544 611 545 612 SUBROUTINE dia_obs_wri 546 613 !!---------------------------------------------------------------------- … … 559 626 !! ! 07-03 (K. Mogensen) General handling of profiles 560 627 !! ! 08-09 (M. Valdivieso) Velocity component (U,V) profiles 628 !! ! 15-08 (M. Martin) Combined writing for prof and surf types 561 629 !!---------------------------------------------------------------------- 562 630 IMPLICIT NONE 563 631 564 632 !! * Local declarations 565 566 633 INTEGER :: jtype ! Data set loop variable 634 567 635 !----------------------------------------------------------------------- 568 636 ! Depending on switches call various observation output routines 569 637 !----------------------------------------------------------------------- 570 638 571 IF ( numproftypes > 0 ) THEN 572 DO jtype = 1, numproftypes 573 639 IF ( nproftypes > 0 ) THEN 640 641 DO jtype = 1, nproftypes 642 574 643 CALL obs_prof_decompress( profdataqc(jtype), & 575 644 & profdata(jtype), .TRUE., numout ) 576 645 577 CALL obs_wri_prof( obstypesprof(jtype), profdata(jtype), n2dint )578 646 CALL obs_wri_prof( profdata(jtype), nn_2dint ) 647 579 648 END DO 580 581 ENDIF 582 583 IF ( numsurftypes > 0 ) THEN 584 DO jtype = 1, numsurftypes 585 586 CALL obs_surf_decompress( surfdatqc(jtype), & 649 650 ENDIF 651 652 IF ( nsurftypes > 0 ) THEN 653 654 DO jtype = 1, nsurftypes 655 656 CALL obs_surf_decompress( surfdataqc(jtype), & 587 657 & surfdata(jtype), .TRUE., numout ) 588 658 589 CALL obs_wri_surf( obstypessurf(jtype), surfdata(jtype), n2dint)659 CALL obs_wri_surf( surfdata(jtype) ) 590 660 591 661 END DO 592 593 ENDIF 594 662 663 ENDIF 595 664 596 665 END SUBROUTINE dia_obs_wri … … 609 678 !! 610 679 !!---------------------------------------------------------------------- 611 ! !obs_grid deallocation680 ! obs_grid deallocation 612 681 CALL obs_grid_deallocate 613 682 614 !! diaobs deallocation 615 IF ( numproftypes > 0 ) DEALLOCATE(profdata, profdataqc, nvarsprof, nextrprof) 616 IF ( numsurftypes > 0 ) DEALLOCATE(surfdata, surfdataqc, nvarssurf, nextrsurf) 617 683 ! diaobs deallocation 684 IF ( nproftypes > 0 ) & 685 & DEALLOCATE( cobstypesprof, profdata, profdataqc, nvarsprof, nextrprof ) 686 687 IF ( nsurftypes > 0 ) & 688 & DEALLOCATE( cobstypessurf, surfdata, surfdataqc, nvarssurf, nextrsurf ) 689 618 690 END SUBROUTINE dia_obs_dealloc 619 691 … … 621 693 !!---------------------------------------------------------------------- 622 694 !! *** ROUTINE ini_date *** 623 !! 624 !! ** Purpose : Get initial dat ain double precision YYYYMMDD.HHMMSS format625 !! 626 !! ** Method : Get initial dat ain double precision YYYYMMDD.HHMMSS format627 !! 628 !! ** Action : Get initial dat ain double precision YYYYMMDD.HHMMSS format695 !! 696 !! ** Purpose : Get initial date in double precision YYYYMMDD.HHMMSS format 697 !! 698 !! ** Method : Get initial date in double precision YYYYMMDD.HHMMSS format 699 !! 700 !! ** Action : Get initial date in double precision YYYYMMDD.HHMMSS format 629 701 !! 630 702 !! History : … … 637 709 USE phycst, ONLY : & ! Physical constants 638 710 & rday 639 ! USE daymod, ONLY : & ! Time variables640 ! & nmonth_len641 711 USE dom_oce, ONLY : & ! Ocean space and time domain variables 642 712 & rdt … … 645 715 646 716 !! * Arguments 647 REAL( KIND=dp), INTENT(OUT) :: ddobsini! Initial date in YYYYMMDD.HHMMSS717 REAL(dp), INTENT(OUT) :: ddobsini ! Initial date in YYYYMMDD.HHMMSS 648 718 649 719 !! * Local declarations … … 653 723 INTEGER :: ihou 654 724 INTEGER :: imin 655 INTEGER :: imday 656 REAL(KIND=wp) :: zdayfrc ! Fraction of day657 658 INTEGER, DIMENSION(12) :: imonth_len !: length in days of the months of the current year659 660 ! !----------------------------------------------------------------------661 ! !Initial date initialization (year, month, day, hour, minute)662 ! !(This assumes that the initial date is for 00z))663 ! !----------------------------------------------------------------------725 INTEGER :: imday ! Number of days in month. 726 INTEGER, DIMENSION(12) :: & 727 & imonth_len ! Length in days of the months of the current year 728 REAL(wp) :: zdayfrc ! Fraction of day 729 730 !---------------------------------------------------------------------- 731 ! Initial date initialization (year, month, day, hour, minute) 732 ! (This assumes that the initial date is for 00z)) 733 !---------------------------------------------------------------------- 664 734 iyea = ndate0 / 10000 665 735 imon = ( ndate0 - iyea * 10000 ) / 100 … … 668 738 imin = 0 669 739 670 ! !----------------------------------------------------------------------671 ! !Compute number of days + number of hours + min since initial time672 ! !----------------------------------------------------------------------740 !---------------------------------------------------------------------- 741 ! Compute number of days + number of hours + min since initial time 742 !---------------------------------------------------------------------- 673 743 iday = iday + ( nit000 -1 ) * rdt / rday 674 744 zdayfrc = ( nit000 -1 ) * rdt / rday … … 677 747 imin = int( (zdayfrc * 24 - ihou) * 60 ) 678 748 679 ! !-----------------------------------------------------------------------680 ! !Convert number of days (iday) into a real date681 ! !----------------------------------------------------------------------749 !----------------------------------------------------------------------- 750 ! Convert number of days (iday) into a real date 751 !---------------------------------------------------------------------- 682 752 683 753 CALL calc_month_len( iyea, imonth_len ) 684 754 685 755 DO WHILE ( iday > imonth_len(imon) ) 686 756 iday = iday - imonth_len(imon) … … 693 763 END DO 694 764 695 ! !----------------------------------------------------------------------696 ! !Convert it into YYYYMMDD.HHMMSS format.697 ! !----------------------------------------------------------------------765 !---------------------------------------------------------------------- 766 ! Convert it into YYYYMMDD.HHMMSS format. 767 !---------------------------------------------------------------------- 698 768 ddobsini = iyea * 10000_dp + imon * 100_dp + & 699 769 & iday + ihou * 0.01_dp + imin * 0.0001_dp … … 705 775 !!---------------------------------------------------------------------- 706 776 !! *** ROUTINE fin_date *** 707 !! 708 !! ** Purpose : Get final dat ain double precision YYYYMMDD.HHMMSS format709 !! 710 !! ** Method : Get final dat ain double precision YYYYMMDD.HHMMSS format711 !! 712 !! ** Action : Get final dat ain double precision YYYYMMDD.HHMMSS format777 !! 778 !! ** Purpose : Get final date in double precision YYYYMMDD.HHMMSS format 779 !! 780 !! ** Method : Get final date in double precision YYYYMMDD.HHMMSS format 781 !! 782 !! ** Action : Get final date in double precision YYYYMMDD.HHMMSS format 713 783 !! 714 784 !! History : … … 720 790 USE phycst, ONLY : & ! Physical constants 721 791 & rday 722 ! USE daymod, ONLY : & ! Time variables723 ! & nmonth_len724 792 USE dom_oce, ONLY : & ! Ocean space and time domain variables 725 793 & rdt … … 728 796 729 797 !! * Arguments 730 REAL( KIND=dp), INTENT(OUT) :: ddobsfin! Final date in YYYYMMDD.HHMMSS798 REAL(dp), INTENT(OUT) :: ddobsfin ! Final date in YYYYMMDD.HHMMSS 731 799 732 800 !! * Local declarations … … 736 804 INTEGER :: ihou 737 805 INTEGER :: imin 738 INTEGER :: imday 739 REAL(KIND=wp) :: zdayfrc ! Fraction of day740 741 INTEGER, DIMENSION(12) :: imonth_len !: length in days of the months of the current year742 806 INTEGER :: imday ! Number of days in month. 807 INTEGER, DIMENSION(12) :: & 808 & imonth_len ! Length in days of the months of the current year 809 REAL(wp) :: zdayfrc ! Fraction of day 810 743 811 !----------------------------------------------------------------------- 744 812 ! Initial date initialization (year, month, day, hour, minute) … … 750 818 ihou = 0 751 819 imin = 0 752 820 753 821 !----------------------------------------------------------------------- 754 822 ! Compute number of days + number of hours + min since initial time … … 765 833 766 834 CALL calc_month_len( iyea, imonth_len ) 767 835 768 836 DO WHILE ( iday > imonth_len(imon) ) 769 837 iday = iday - imonth_len(imon) … … 783 851 784 852 END SUBROUTINE fin_date 785 853 786 854 END MODULE diaobs
Note: See TracChangeset
for help on using the changeset viewer.
