Context Navigation

diaobs.F90 @ 15497

Last change on this file since 15497 was 15497, checked in by dford, 3 years ago
Updates following review.
File size: 49.8 KB

Line
1	MODULE diaobs
2	!!======================================================================
3	!! * MODULE diaobs *
4	!! Observation diagnostics: Computation of the misfit between data and
5	!! their model equivalent
6	!!======================================================================
7	!! History : 1.0 ! 2006-03 (K. Mogensen) Original code
8	!! - ! 2006-05 (K. Mogensen, A. Weaver) Reformatted
9	!! - ! 2006-10 (A. Weaver) Cleaning and add controls
10	!! - ! 2007-03 (K. Mogensen) General handling of profiles
11	!! - ! 2007-04 (G. Smith) Generalized surface operators
12	!! 2.0 ! 2008-10 (M. Valdivieso) obs operator for velocity profiles
13	!! 3.4 ! 2014-08 (J. While) observation operator for profiles in all vertical coordinates
14	!! - ! Incorporated SST bias correction
15	!! 3.6 ! 2015-02 (M. Martin) Simplification of namelist and code
16	!! - ! 2015-08 (M. Martin) Combined surface/profile routines.
17	!! 4.0 ! 2017-11 (G. Madec) style only
18	!!----------------------------------------------------------------------
19
20	!!----------------------------------------------------------------------
21	!! dia_obs_init : Reading and prepare observations
22	!! dia_obs : Compute model equivalent to observations
23	!! dia_obs_wri : Write observational diagnostics
24	!! calc_date : Compute the date of timestep in YYYYMMDD.HHMMSS format
25	!! ini_date : Compute the initial date YYYYMMDD.HHMMSS
26	!! fin_date : Compute the final date YYYYMMDD.HHMMSS
27	!!----------------------------------------------------------------------
28	USE par_kind ! Precision variables
29	USE in_out_manager ! I/O manager
30	USE timing ! Timing
31	USE par_oce ! ocean parameter
32	USE dom_oce ! Ocean space and time domain variables
33	USE sbc_oce ! Sea-ice fraction
34	!
35	USE obs_read_prof ! Reading and allocation of profile obs
36	USE obs_read_surf ! Reading and allocation of surface obs
37	USE obs_bias ! Bias correction routine
38	USE obs_readmdt ! Reading and allocation of MDT for SLA.
39	USE obs_readsnowdepth ! Get model snow depth for conversion of freeboard to ice thickness
40	USE obs_prep ! Preparation of obs. (grid search etc).
41	USE obs_oper ! Observation operators
42	USE obs_write ! Writing of observation related diagnostics
43	USE obs_grid ! Grid searching
44	USE obs_read_altbias ! Bias treatment for altimeter
45	USE obs_profiles_def ! Profile data definitions
46	USE obs_surf_def ! Surface data definitions
47	USE obs_types ! Definitions for observation types
48	USE obs_group_def ! Definitions for observation groups
49	!
50	USE mpp_map ! MPP mapping
51	USE lib_mpp ! For ctl_warn/stop
52
53	IMPLICIT NONE
54	PRIVATE
55
56	PUBLIC dia_obs_init ! Initialize and read observations
57	PUBLIC dia_obs ! Compute model equivalent to observations
58	PUBLIC dia_obs_wri ! Write model equivalent to observations
59	PUBLIC calc_date ! Compute the date of a timestep
60
61	LOGICAL, PUBLIC :: ln_diaobs !: Logical switch for the obs operator
62
63	INTEGER :: nn_obsgroups
64
65	TYPE(obs_group), DIMENSION(:), ALLOCATABLE :: sobsgroups ! Obs groups
66
67	!!----------------------------------------------------------------------
68	!! NEMO/OCE 4.0 , NEMO Consortium (2018)
69	!! $Id$
70	!! Software governed by the CeCILL license (see ./LICENSE)
71	!!----------------------------------------------------------------------
72	CONTAINS
73
74	SUBROUTINE dia_obs_init
75	!!----------------------------------------------------------------------
76	!! * ROUTINE dia_obs_init *
77	!!
78	!! ** Purpose : Initialize and read observations
79	!!
80	!! ** Method : Read the namelist and call reading routines
81	!!
82	!! ** Action : Read the namelist and call reading routines
83	!!
84	!!----------------------------------------------------------------------
85	#if defined key_si3
86	USE ice, ONLY : & ! Sea ice variables
87	& hm_s ! Snow depth for freeboard conversion
88	#elif defined key_cice
89	USE sbc_oce, ONLY : & ! Sea ice variables
90	& thick_s ! Snow depth for freeboard conversion
91	#endif
92	USE obs_fbm, ONLY : &
93	& fbrmdi ! Real missing data indicator
94
95	IMPLICIT NONE
96
97	INTEGER, PARAMETER :: jpmaxngroups = 1000 ! Maximum number of obs groups
98	INTEGER :: ios ! Local integer output status for namelist read
99	INTEGER :: jtype ! Counter for obs types
100	INTEGER :: jvar ! Counter for variables
101	INTEGER :: jfile ! Counter for files
102	INTEGER :: jenabled
103	INTEGER :: jgroup
104	!
105	LOGICAL, DIMENSION(:), ALLOCATABLE :: llvar
106	!
107	REAL(dp) :: rn_dobsini ! Obs window start date YYYYMMDD.HHMMSS
108	REAL(dp) :: rn_dobsend ! Obs window end date YYYYMMDD.HHMMSS
109	!!
110	NAMELIST/namobs/ln_diaobs, nn_obsgroups, &
111	& ln_grid_global, ln_grid_search_lookup, &
112	& cn_gridsearchfile, rn_gridsearchres, &
113	& rn_dobsini, rn_dobsend
114	!-----------------------------------------------------------------------
115
116	!-----------------------------------------------------------------------
117	! Read namelist parameters
118	!-----------------------------------------------------------------------
119	! Initialise time window
120	CALL ini_date( rn_dobsini )
121	CALL fin_date( rn_dobsend )
122
123	! Read namelist namobs : control observation diagnostics
124	REWIND( numnam_ref ) ! Namelist namobs in reference namelist
125	READ ( numnam_ref, namobs, IOSTAT = ios, ERR = 901)
126	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobs in reference namelist' )
127	REWIND( numnam_cfg ) ! Namelist namobs in configuration namelist
128	READ ( numnam_cfg, namobs, IOSTAT = ios, ERR = 902 )
129	902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namobs in configuration namelist' )
130	IF(lwm) WRITE ( numond, namobs )
131
132	IF( .NOT.ln_diaobs ) THEN
133	IF(lwp) WRITE(numout,*)
134	IF(lwp) WRITE(numout,*) 'dia_obs_init : NO Observation diagnostic used'
135	IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~'
136	RETURN
137	ENDIF
138
139	IF(lwp) THEN
140	WRITE(numout,*)
141	WRITE(numout,*) 'dia_obs_init : Observation diagnostic initialization'
142	WRITE(numout,*) '~~~~~~~~~~~~'
143	WRITE(numout,*) ' Namelist namobs : set observation diagnostic parameters'
144	WRITE(numout,*) ' Number of namobs_dta namelists to read nn_obsgroups = ', nn_obsgroups
145	WRITE(numout,*) ' Global distribution of observations ln_grid_global = ', ln_grid_global
146	WRITE(numout,*) ' Logical switch for obs grid search lookup ln_grid_search_lookup = ', ln_grid_search_lookup
147	IF (ln_grid_search_lookup) THEN
148	WRITE(numout,*) ' Grid search lookup file header cn_gridsearchfile = ', cn_gridsearchfile
149	WRITE(numout,*) ' Grid search resolution rn_gridsearchres = ', rn_gridsearchres
150	ENDIF
151	ENDIF
152
153	IF( ln_grid_global ) THEN
154	CALL ctl_warn( 'dia_obs_init: ln_grid_global=T may cause memory issues when used with a large number of processors' )
155	ENDIF
156
157	!-----------------------------------------------------------------------
158	! Read namobs_dta namelists and set up observation groups
159	!-----------------------------------------------------------------------
160
161	IF( nn_obsgroups == 0 ) THEN
162	CALL ctl_warn( 'dia_obs_init: ln_diaobs is set to true, but nn_obsgroups == 0', &
163	& ' so turning off calls to dia_obs' )
164	ln_diaobs = .FALSE.
165	RETURN
166	ENDIF
167
168	ALLOCATE( sobsgroups(nn_obsgroups) )
169
170	jenabled = 0
171	DO jgroup = 1, nn_obsgroups
172	CALL obs_group_read_namelist( sobsgroups(jgroup) )
173	CALL obs_group_check( sobsgroups(jgroup), jgroup )
174	IF (sobsgroups(jgroup)%lenabled) THEN
175	jenabled = jenabled + 1
176	ENDIF
177	END DO
178
179	IF( jenabled == 0 ) THEN
180	CALL ctl_warn( 'dia_obs_init: ln_diaobs is set to true, and nn_obsgroups > 0', &
181	& ' but no groups are enabled so turning off calls to dia_obs' )
182	ln_diaobs = .FALSE.
183	RETURN
184	ENDIF
185
186	!-----------------------------------------------------------------------
187	! Obs operator parameter checking and initialisations
188	!-----------------------------------------------------------------------
189	!
190	CALL obs_typ_init
191	IF( ln_grid_global ) CALL mppmap_init
192	!
193	CALL obs_grid_setup( )
194
195	!-----------------------------------------------------------------------
196	! Depending on switches read the various observation types
197	!-----------------------------------------------------------------------
198	!
199	DO jgroup = 1, nn_obsgroups
200	IF ( sobsgroups(jgroup)%lenabled ) THEN
201	IF ( sobsgroups(jgroup)%lprof ) THEN
202	!
203	! Read in profile or profile obs types
204	!
205	ALLOCATE( llvar(sobsgroups(jgroup)%nobstypes) )
206	llvar(:) = .TRUE.
207	!
208	CALL obs_rea_prof( sobsgroups(jgroup)%sprofdata, &
209	& sobsgroups(jgroup)%nobsfiles, &
210	& sobsgroups(jgroup)%cobsfiles, &
211	& sobsgroups(jgroup)%nobstypes, &
212	& sobsgroups(jgroup)%naddvars, &
213	& sobsgroups(jgroup)%nextvars, &
214	& nitend-nit000+2, &
215	& rn_dobsini, &
216	& rn_dobsend, &
217	& llvar, &
218	& sobsgroups(jgroup)%lignmis, &
219	& sobsgroups(jgroup)%lall_at_all, &
220	& .FALSE., &
221	& sobsgroups(jgroup)%cobstypes, &
222	& kdailyavtypes = sobsgroups(jgroup)%nprofdavtypes )
223	!
224	DO jvar = 1, sobsgroups(jgroup)%nobstypes
225	CALL obs_prof_staend( sobsgroups(jgroup)%sprofdata, jvar )
226	END DO
227	!
228	IF ( sobsgroups(jgroup)%sprofdata%next > 0 ) THEN
229	CALL obs_prof_staend_ext( sobsgroups(jgroup)%sprofdata )
230	ENDIF
231	!
232	IF( sobsgroups(jgroup)%loutput_clim ) THEN
233	sobsgroups(jgroup)%sprofdata%caddvars(sobsgroups(jgroup)%nadd_clm) = 'CLM'
234	DO jvar = 1, sobsgroups(jgroup)%nobstypes
235	sobsgroups(jgroup)%sprofdata%var(jvar)%vadd(:,sobsgroups(jgroup)%nadd_clm) = fbrmdi
236	sobsgroups(jgroup)%sprofdata%caddlong(sobsgroups(jgroup)%nadd_clm,jvar) = 'Climatology'
237	sobsgroups(jgroup)%sprofdata%caddunit(sobsgroups(jgroup)%nadd_clm,jvar) = sobsgroups(jgroup)%sprofdata%cunit(jvar)
238	END DO
239	ENDIF
240	!
241	sobsgroups(jgroup)%sprofdata%cgrid = sobsgroups(jgroup)%cgrid
242	!
243	CALL obs_pre_prof( sobsgroups(jgroup)%sprofdata, &
244	& sobsgroups(jgroup)%sprofdataqc, &
245	& llvar, &
246	& jpi, jpj, jpk, &
247	& sobsgroups(jgroup)%rmask, &
248	& sobsgroups(jgroup)%rglam, &
249	& sobsgroups(jgroup)%rgphi, &
250	& sobsgroups(jgroup)%lnea, &
251	& sobsgroups(jgroup)%lbound_reject, &
252	& kdailyavtypes = sobsgroups(jgroup)%nprofdavtypes )
253	!
254	DEALLOCATE( llvar )
255	!
256	ELSEIF (sobsgroups(jgroup)%lsurf) THEN
257	!
258	! Read in surface obs types
259	!
260	CALL obs_rea_surf( sobsgroups(jgroup)%ssurfdata, &
261	& sobsgroups(jgroup)%nobsfiles, &
262	& sobsgroups(jgroup)%cobsfiles, &
263	& sobsgroups(jgroup)%nobstypes, &
264	& sobsgroups(jgroup)%naddvars, &
265	& sobsgroups(jgroup)%nextvars, &
266	& nitend-nit000+2, &
267	& rn_dobsini, &
268	& rn_dobsend, &
269	& sobsgroups(jgroup)%rtime_mean_period, &
270	& sobsgroups(jgroup)%ltime_mean_bkg, &
271	& sobsgroups(jgroup)%lignmis, &
272	& .FALSE., &
273	& sobsgroups(jgroup)%lnight, &
274	& sobsgroups(jgroup)%cobstypes )
275	!
276	IF( sobsgroups(jgroup)%lsla ) THEN
277	sobsgroups(jgroup)%ssurfdata%cextvars(sobsgroups(jgroup)%next_mdt) = 'MDT'
278	sobsgroups(jgroup)%ssurfdata%cextlong(sobsgroups(jgroup)%next_mdt) = 'Mean dynamic topography'
279	sobsgroups(jgroup)%ssurfdata%cextunit(sobsgroups(jgroup)%next_mdt) = 'Metres'
280	sobsgroups(jgroup)%ssurfdata%caddvars(sobsgroups(jgroup)%nadd_ssh) = 'SSH'
281	DO jvar = 1, sobsgroups(jgroup)%nobstypes
282	sobsgroups(jgroup)%ssurfdata%caddlong(sobsgroups(jgroup)%nadd_ssh,jvar) = 'Model Sea surface height'
283	sobsgroups(jgroup)%ssurfdata%caddunit(sobsgroups(jgroup)%nadd_ssh,jvar) = 'Metres'
284	END DO
285	ENDIF
286	!
287	IF( sobsgroups(jgroup)%lfbd ) THEN
288	sobsgroups(jgroup)%ssurfdata%cextvars(sobsgroups(jgroup)%next_snow) = 'SNOW'
289	sobsgroups(jgroup)%ssurfdata%cextlong(sobsgroups(jgroup)%next_snow) = 'Snow thickness'
290	sobsgroups(jgroup)%ssurfdata%cextunit(sobsgroups(jgroup)%next_snow) = 'Metres'
291	sobsgroups(jgroup)%ssurfdata%caddvars(sobsgroups(jgroup)%nadd_fbd) = 'FBD'
292	DO jvar = 1, sobsgroups(jgroup)%nobstypes
293	sobsgroups(jgroup)%ssurfdata%caddlong(sobsgroups(jgroup)%nadd_fbd,jvar) = 'Freeboard'
294	sobsgroups(jgroup)%ssurfdata%caddunit(sobsgroups(jgroup)%nadd_fbd,jvar) = 'Metres'
295	END DO
296	ENDIF
297	!
298	IF( sobsgroups(jgroup)%loutput_clim ) THEN
299	sobsgroups(jgroup)%ssurfdata%caddvars(sobsgroups(jgroup)%nadd_clm) = 'CLM'
300	DO jvar = 1, sobsgroups(jgroup)%nobstypes
301	sobsgroups(jgroup)%ssurfdata%radd(:,:,jvar) = fbrmdi
302	sobsgroups(jgroup)%ssurfdata%caddlong(sobsgroups(jgroup)%nadd_clm,jvar) = 'Climatology'
303	sobsgroups(jgroup)%ssurfdata%caddunit(sobsgroups(jgroup)%nadd_clm,jvar) = sobsgroups(jgroup)%ssurfdata%cunit(jvar)
304	END DO
305	ENDIF
306	!
307	sobsgroups(jgroup)%ssurfdata%cgrid = sobsgroups(jgroup)%cgrid
308	!
309	CALL obs_pre_surf( sobsgroups(jgroup)%ssurfdata, &
310	& sobsgroups(jgroup)%ssurfdataqc, &
311	& jpi, jpj, &
312	& sobsgroups(jgroup)%rmask(:,:,1,:), &
313	& sobsgroups(jgroup)%rglam, &
314	& sobsgroups(jgroup)%rgphi, &
315	& sobsgroups(jgroup)%lnea, &
316	& sobsgroups(jgroup)%lbound_reject )
317	!
318	IF( sobsgroups(jgroup)%lsla ) THEN
319	CALL obs_rea_mdt( sobsgroups(jgroup)%ssurfdataqc, &
320	& sobsgroups(jgroup)%n2dint, &
321	& sobsgroups(jgroup)%next_mdt, &
322	& sobsgroups(jgroup)%nmsshc, &
323	& sobsgroups(jgroup)%rmdtcorr, &
324	& sobsgroups(jgroup)%rmdtcutoff )
325	IF( sobsgroups(jgroup)%laltbias ) THEN
326	CALL obs_app_bias( sobsgroups(jgroup)%ssurfdataqc, &
327	& sobsgroups(jgroup)%next_mdt, &
328	& sobsgroups(jgroup)%n2dint, &
329	& 1, &
330	& sobsgroups(jgroup)%caltbiasfile, &
331	& 'altbias', &
332	& ld_extvar=.TRUE. )
333	ENDIF
334	ENDIF
335	!
336	#if defined key_si3
337	IF( sobsgroups(jgroup)%lfbd ) THEN
338	CALL obs_rea_snowdepth( sobsgroups(jgroup)%ssurfdataqc, &
339	& sobsgroups(jgroup)%n2dint, &
340	& sobsgroups(jgroup)%next_snow, &
341	& hm_s(:,:) )
342	ENDIF
343	#elif defined key_cice
344	IF( sobsgroups(jgroup)%lfbd ) THEN
345	CALL obs_rea_snowdepth( sobsgroups(jgroup)%ssurfdataqc, &
346	& sobsgroups(jgroup)%n2dint, &
347	& sobsgroups(jgroup)%next_snow, &
348	& thick_s(:,:) )
349	ENDIF
350	#endif
351	!
352	IF( sobsgroups(jgroup)%lobsbias ) THEN
353	CALL obs_app_bias( sobsgroups(jgroup)%ssurfdataqc, &
354	& sobsgroups(jgroup)%nbiasvar, &
355	& sobsgroups(jgroup)%n2dint, &
356	& sobsgroups(jgroup)%nobsbiasfiles, &
357	& sobsgroups(jgroup)%cobsbiasfiles, &
358	& sobsgroups(jgroup)%cbiasvarname )
359	ENDIF
360	!
361	ENDIF
362	ENDIF
363	END DO
364	!
365	END SUBROUTINE dia_obs_init
366
367
368	SUBROUTINE dia_obs( kstp )
369	!!----------------------------------------------------------------------
370	!! * ROUTINE dia_obs *
371	!!
372	!! ** Purpose : Call the observation operators on each time step
373	!!
374	!! ** Method : Call the observation operators on each time step to
375	!! compute the model equivalent of the following data:
376	!! - Profile data, currently T/S or U/V
377	!! - Surface data, currently SST, SLA or sea-ice concentration.
378	!!
379	!! ** Action :
380	!!----------------------------------------------------------------------
381	USE dom_oce, ONLY : gdept_n, gdept_1d ! Ocean space and time domain variables
382	USE phycst , ONLY : rday ! Physical constants
383	USE oce , ONLY : tsn, un, vn, sshn ! Ocean dynamics and tracers variables
384	USE phycst , ONLY : rday ! Physical constants
385	#if defined key_si3
386	USE ice , ONLY : at_i, hm_i ! SI3 Ice model variables
387	#elif defined key_cice
388	USE sbc_oce, ONLY : fr_i, thick_i ! CICE Ice model variables
389	#endif
390	USE tradmp, ONLY : tclim, sclim ! T&S climatology
391	USE obs_fbm, ONLY : fbrmdi ! Real missing data indicator
392
393	IMPLICIT NONE
394
395	!! * Arguments
396	INTEGER, INTENT(IN) :: kstp ! Current timestep
397	!! * Local declarations
398	INTEGER :: idaystp ! Number of timesteps per day
399	INTEGER :: imeanstp ! Number of timesteps for time averaging
400	INTEGER :: jtype ! Data loop variable
401	INTEGER :: jvar ! Variable number
402	INTEGER :: jgroup
403	INTEGER :: ji, jj, jobs ! Loop counters
404	LOGICAL :: lstp0 ! Flag special treatment on zeroth time step
405	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: &
406	& zprofvar, & ! Model values for variables in a prof ob
407	& zprofclim ! Climatology values for variables in a prof ob
408	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: &
409	& zsurfvar, & ! Model values for variables in a surf ob
410	& zsurfclim ! Climatology values for variables in a surf ob
411
412	!-----------------------------------------------------------------------
413
414	IF( ln_timing ) CALL timing_start('dia_obs')
415
416	IF(lwp) THEN
417	WRITE(numout,*)
418	WRITE(numout,*) 'dia_obs : Call the observation operators', kstp
419	WRITE(numout,*) '~~~~~~~'
420	ENDIF
421
422	idaystp = NINT( rday / rdt )
423
424	!-----------------------------------------------------------------------
425	! Call the profile and surface observation operators
426	!-----------------------------------------------------------------------
427
428	ALLOCATE( zprofvar(jpi,jpj,jpk), &
429	& zprofclim(jpi,jpj,jpk), &
430	& zsurfvar(jpi,jpj), &
431	& zsurfclim(jpi,jpj) )
432
433	DO jgroup = 1, nn_obsgroups
434	IF ( sobsgroups(jgroup)%lenabled ) THEN
435
436	IF ( sobsgroups(jgroup)%lprof ) THEN
437
438	zprofclim(:,:,:) = fbrmdi
439
440	DO jvar = 1, sobsgroups(jgroup)%nobstypes
441
442	SELECT CASE ( TRIM(sobsgroups(jgroup)%cobstypes(jvar)) )
443	CASE('POTM')
444	zprofvar(:,:,:) = tsn(:,:,:,jp_tem)
445	IF (sobsgroups(jgroup)%loutput_clim) THEN
446	zprofclim(:,:,:) = tclim(:,:,:)
447	ENDIF
448	CASE('PSAL')
449	zprofvar(:,:,:) = tsn(:,:,:,jp_sal)
450	IF (sobsgroups(jgroup)%loutput_clim) THEN
451	zprofclim(:,:,:) = sclim(:,:,:)
452	ENDIF
453	CASE('UVEL')
454	zprofvar(:,:,:) = un(:,:,:)
455	CASE('VVEL')
456	zprofvar(:,:,:) = vn(:,:,:)
457	CASE DEFAULT
458	CALL ctl_stop( 'Unknown profile observation type '//TRIM(sobsgroups(jgroup)%cobstypes(jvar))//' in dia_obs' )
459	END SELECT
460
461	CALL obs_prof_opt( sobsgroups(jgroup)%sprofdataqc, &
462	& kstp, jpi, jpj, jpk, &
463	& nit000, idaystp, jvar, &
464	& zprofvar, &
465	& sobsgroups(jgroup)%loutput_clim, &
466	& sobsgroups(jgroup)%nadd_clm, &
467	& zprofclim, &
468	& gdept_n, &
469	& gdepw_n, &
470	& sobsgroups(jgroup)%rmask(:,:,:,jvar), &
471	& sobsgroups(jgroup)%rglam(:,:,jvar), &
472	& sobsgroups(jgroup)%rgphi(:,:,jvar), &
473	& sobsgroups(jgroup)%n1dint, &
474	& sobsgroups(jgroup)%n2dint, &
475	& kdailyavtypes = sobsgroups(jgroup)%nprofdavtypes )
476
477	END DO
478
479	ELSEIF (sobsgroups(jgroup)%lsurf) THEN
480
481	zsurfclim(:,:) = fbrmdi
482
483	DO jvar = 1, sobsgroups(jgroup)%nobstypes
484
485	lstp0 = .FALSE.
486	SELECT CASE ( TRIM(sobsgroups(jgroup)%cobstypes(jvar)) )
487	CASE('SST')
488	zsurfvar(:,:) = tsn(:,:,1,jp_tem)
489	IF (sobsgroups(jgroup)%loutput_clim) THEN
490	zsurfclim(:,:) = tclim(:,:,1)
491	ENDIF
492	CASE('SLA')
493	zsurfvar(:,:) = sshn(:,:)
494	CASE('SSS')
495	zsurfvar(:,:) = tsn(:,:,1,jp_sal)
496	IF (sobsgroups(jgroup)%loutput_clim) THEN
497	zsurfclim(:,:) = sclim(:,:,1)
498	ENDIF
499	CASE('UVEL')
500	zsurfvar(:,:) = un(:,:,1)
501	CASE('VVEL')
502	zsurfvar(:,:) = vn(:,:,1)
503	CASE('ICECONC')
504	IF ( kstp == 0 ) THEN
505	lstp0 = .TRUE.
506	ELSE
507	#if defined key_si3
508	zsurfvar(:,:) = at_i(:,:)
509	#elif defined key_cice
510	zsurfvar(:,:) = fr_i(:,:)
511	#else
512	CALL ctl_stop( ' Trying to run sea-ice observation operator', &
513	& ' but no sea-ice model appears to have been defined' )
514	#endif
515	ENDIF
516	CASE('SIT','FBD')
517	IF ( kstp == 0 ) THEN
518	lstp0 = .TRUE.
519	ELSE
520	#if defined key_si3
521	zsurfvar(:,:) = hm_i(:,:)
522	#elif defined key_cice
523	zsurfvar(:,:) = thick_i(:,:)
524	#else
525	CALL ctl_stop( ' Trying to run sea-ice observation operator', &
526	& ' but no sea-ice model appears to have been defined' )
527	#endif
528	ENDIF
529	END SELECT
530
531	IF ( lstp0 ) THEN
532	IF ( sobsgroups(jgroup)%ssurfdataqc%nsstpmpp(1) > 0 ) THEN
533	DO jobs = sobsgroups(jgroup)%ssurfdataqc%nsurfup + 1, &
534	& sobsgroups(jgroup)%ssurfdataqc%nsurfup + sobsgroups(jgroup)%ssurfdataqc%nsstp(1)
535	sobsgroups(jgroup)%ssurfdata%nqc(jobs) = IBSET(sobsgroups(jgroup)%ssurfdata%nqc(jobs),13)
536	END DO
537	IF ( lwp ) THEN
538	CALL ctl_warn( TRIM(sobsgroups(jgroup)%cobstypes(jvar))// &
539	& ' not initialised on zeroth ' // &
540	& 'time-step but some obs are valid then.' )
541	WRITE(numout,*)sobsgroups(jgroup)%ssurfdataqc%nsstpmpp(1), &
542	& TRIM(sobsgroups(jgroup)%cobstypes(jvar)), &
543	& 'observations will be flagged as bad'
544	ENDIF
545	ENDIF
546	IF ( jvar == sobsgroups(jgroup)%ssurfdataqc%nvar ) THEN
547	sobsgroups(jgroup)%ssurfdataqc%nsurfup = sobsgroups(jgroup)%ssurfdataqc%nsurfup + &
548	& sobsgroups(jgroup)%ssurfdataqc%nsstp(1)
549	ENDIF
550	ELSE
551	IF ( sobsgroups(jgroup)%ltime_mean_bkg ) THEN
552	! Number of time-steps in meaning period
553	imeanstp = NINT( ( sobsgroups(jgroup)%rtime_mean_period * 60.0 * 60.0 ) / rdt )
554	ENDIF
555	CALL obs_surf_opt( sobsgroups(jgroup)%ssurfdataqc, &
556	& kstp, jpi, jpj, &
557	& nit000, idaystp, &
558	& jvar, zsurfvar, &
559	& sobsgroups(jgroup)%loutput_clim, &
560	& sobsgroups(jgroup)%nadd_clm, &
561	& zsurfclim, &
562	& sobsgroups(jgroup)%rmask(:,:,1,jvar), &
563	& sobsgroups(jgroup)%n2dint, &
564	& sobsgroups(jgroup)%lnight, &
565	& sobsgroups(jgroup)%ravglamscl, &
566	& sobsgroups(jgroup)%ravgphiscl, &
567	& sobsgroups(jgroup)%lfp_indegs, &
568	& sobsgroups(jgroup)%ltime_mean_bkg, &
569	& imeanstp, &
570	& kssh=sobsgroups(jgroup)%nadd_ssh, &
571	& kmdt=sobsgroups(jgroup)%next_mdt, &
572	& kfbd=sobsgroups(jgroup)%nadd_fbd, &
573	& ksnow=sobsgroups(jgroup)%next_snow )
574	ENDIF
575
576	END DO
577
578	ENDIF
579
580	ENDIF
581	END DO
582
583	DEALLOCATE( zprofvar, zprofclim, &
584	& zsurfvar, zsurfclim )
585
586	IF( ln_timing ) CALL timing_stop('dia_obs')
587
588	END SUBROUTINE dia_obs
589
590	SUBROUTINE dia_obs_wri
591	!!----------------------------------------------------------------------
592	!! * ROUTINE dia_obs_wri *
593	!!
594	!! ** Purpose : Call observation diagnostic output routines
595	!!
596	!! ** Method : Call observation diagnostic output routines
597	!!
598	!! ** Action :
599	!!
600	!! History :
601	!! ! 06-03 (K. Mogensen) Original code
602	!! ! 06-05 (K. Mogensen) Reformatted
603	!! ! 06-10 (A. Weaver) Cleaning
604	!! ! 07-03 (K. Mogensen) General handling of profiles
605	!! ! 08-09 (M. Valdivieso) Velocity component (U,V) profiles
606	!! ! 15-08 (M. Martin) Combined writing for prof and surf types
607	!!----------------------------------------------------------------------
608	!! * Modules used
609	USE obs_rot_vel ! Rotation of velocities
610
611	IMPLICIT NONE
612
613	!! * Local declarations
614	INTEGER :: jgroup ! Data set loop variable
615	INTEGER :: jo, jvar, jk, jadd, jext, jadd2, jext2
616	INTEGER :: iuvar, ivvar
617	REAL(wp), DIMENSION(:), ALLOCATABLE :: &
618	& zu, &
619	& zv
620	LOGICAL, DIMENSION(:), ALLOCATABLE :: ll_write
621	TYPE(obswriinfo) :: sladd, slext
622
623	IF( ln_timing ) CALL timing_start('dia_obs_wri')
624
625	!-----------------------------------------------------------------------
626	! Depending on switches call various observation output routines
627	!-----------------------------------------------------------------------
628
629	DO jgroup = 1, nn_obsgroups
630	IF (sobsgroups(jgroup)%lenabled) THEN
631
632	IF (sobsgroups(jgroup)%lprof) THEN
633
634	IF (sobsgroups(jgroup)%lvel) THEN
635	iuvar = 0
636	ivvar = 0
637	DO jvar = 1, sobsgroups(jgroup)%nobstypes
638	IF ( TRIM(sobsgroups(jgroup)%cobstypes(jvar)) == cobsname_uvel ) THEN
639	iuvar = jvar
640	ELSEIF ( TRIM(sobsgroups(jgroup)%cobstypes(jvar)) == cobsname_vvel ) THEN
641	ivvar = jvar
642	ENDIF
643	END DO
644	IF ( (iuvar > 0) .AND. (ivvar > 0) ) THEN
645
646	! For velocity data, rotate the model velocities to N/S, E/W
647	! using the compressed data structure.
648	ALLOCATE( &
649	& zu(sobsgroups(jgroup)%sprofdataqc%nvprot(iuvar)), &
650	& zv(sobsgroups(jgroup)%sprofdataqc%nvprot(ivvar)) &
651	& )
652
653	CALL obs_rotvel_pro( sobsgroups(jgroup)%sprofdataqc, sobsgroups(jgroup)%n2dint, &
654	& iuvar, ivvar, zu, zv )
655
656	DO jo = 1, sobsgroups(jgroup)%sprofdataqc%nprof
657	DO jk = sobsgroups(jgroup)%sprofdataqc%npvsta(jo,iuvar), sobsgroups(jgroup)%sprofdataqc%npvend(jo,iuvar)
658	sobsgroups(jgroup)%sprofdataqc%var(iuvar)%vmod(jk) = zu(jk)
659	END DO
660	DO jk = sobsgroups(jgroup)%sprofdataqc%npvsta(jo,ivvar), sobsgroups(jgroup)%sprofdataqc%npvend(jo,ivvar)
661	sobsgroups(jgroup)%sprofdataqc%var(ivvar)%vmod(jk) = zv(jk)
662	END DO
663	END DO
664
665	DEALLOCATE( zu )
666	DEALLOCATE( zv )
667
668	ELSE
669	CALL ctl_stop( 'Could not identify velocity observation variables to rotate' )
670	END IF
671	END IF
672
673	CALL obs_prof_decompress( sobsgroups(jgroup)%sprofdataqc, &
674	& sobsgroups(jgroup)%sprofdata, .TRUE., numout )
675
676	! Put additional and extra variable information into obswriinfo structure
677	! used by obs_write.
678	! add/ext variables generated by the OBS code (1...sobsgroups(jgroup)%naddvars)
679	! may duplicate ones read in (%naddvars+1...sobsgroups(jgroup)%sprofdata%nadd)
680	! Check for this, and if so only write out the version generated by the OBS code
681	sladd%inum = sobsgroups(jgroup)%sprofdata%nadd
682	ALLOCATE( ll_write(sobsgroups(jgroup)%sprofdata%nadd) )
683	ll_write(:) = .TRUE.
684	IF ( (sobsgroups(jgroup)%naddvars > 0) .AND. &
685	& (sobsgroups(jgroup)%sprofdata%nadd > sobsgroups(jgroup)%naddvars) ) THEN
686	DO jadd = sobsgroups(jgroup)%naddvars + 1, sobsgroups(jgroup)%sprofdata%nadd
687	DO jadd2 = 1, sobsgroups(jgroup)%naddvars
688	IF ( TRIM(sobsgroups(jgroup)%sprofdata%caddvars(jadd )) == &
689	& TRIM(sobsgroups(jgroup)%sprofdata%caddvars(jadd2)) ) THEN
690	sladd%inum = sladd%inum - 1
691	ll_write(jadd) = .FALSE.
692	ENDIF
693	END DO
694	END DO
695	ENDIF
696	IF ( sladd%inum > 0 ) THEN
697	ALLOCATE( sladd%ipoint(sladd%inum), &
698	& sladd%cdname(sladd%inum), &
699	& sladd%cdlong(sladd%inum,sobsgroups(jgroup)%sprofdata%nvar), &
700	& sladd%cdunit(sladd%inum,sobsgroups(jgroup)%sprofdata%nvar) )
701	jadd2 = 0
702	DO jadd = 1, sobsgroups(jgroup)%sprofdata%nadd
703	IF ( ll_write(jadd) ) THEN
704	jadd2 = jadd2 + 1
705	sladd%ipoint(jadd2) = jadd
706	sladd%cdname(jadd2) = sobsgroups(jgroup)%sprofdata%caddvars(jadd)
707	DO jvar = 1, sobsgroups(jgroup)%sprofdata%nvar
708	sladd%cdlong(jadd2,jvar) = sobsgroups(jgroup)%sprofdata%caddlong(jadd,jvar)
709	sladd%cdunit(jadd2,jvar) = sobsgroups(jgroup)%sprofdata%caddunit(jadd,jvar)
710	END DO
711	ENDIF
712	END DO
713	ENDIF
714	DEALLOCATE( ll_write )
715
716	slext%inum = sobsgroups(jgroup)%sprofdata%next
717	ALLOCATE( ll_write(sobsgroups(jgroup)%sprofdata%next) )
718	ll_write(:) = .TRUE.
719	IF ( (sobsgroups(jgroup)%nextvars > 0) .AND. &
720	& (sobsgroups(jgroup)%sprofdata%next > sobsgroups(jgroup)%nextvars) ) THEN
721	DO jext = sobsgroups(jgroup)%nextvars + 1, sobsgroups(jgroup)%sprofdata%next
722	DO jext2 = 1, sobsgroups(jgroup)%nextvars
723	IF ( TRIM(sobsgroups(jgroup)%sprofdata%cextvars(jext )) == &
724	& TRIM(sobsgroups(jgroup)%sprofdata%cextvars(jext2)) ) THEN
725	slext%inum = slext%inum - 1
726	ll_write(jext) = .FALSE.
727	ENDIF
728	END DO
729	END DO
730	ENDIF
731	IF ( slext%inum > 0 ) THEN
732	ALLOCATE( slext%ipoint(slext%inum), &
733	& slext%cdname(slext%inum), &
734	& slext%cdlong(slext%inum,1), &
735	& slext%cdunit(slext%inum,1) )
736	jext2 = 0
737	DO jext = 1, sobsgroups(jgroup)%sprofdata%next
738	IF ( ll_write(jext) ) THEN
739	jext2 = jext2 + 1
740	slext%ipoint(jext2) = jext
741	slext%cdname(jext2) = sobsgroups(jgroup)%sprofdata%cextvars(jext)
742	slext%cdlong(jext2,1) = sobsgroups(jgroup)%sprofdata%cextlong(jext)
743	slext%cdunit(jext2,1) = sobsgroups(jgroup)%sprofdata%cextunit(jext)
744	ENDIF
745	END DO
746	ENDIF
747	DEALLOCATE( ll_write )
748
749	CALL obs_wri_prof( sobsgroups(jgroup)%sprofdata, sobsgroups(jgroup)%cgroupname, sladd, slext )
750
751	IF ( sladd%inum > 0 ) THEN
752	DEALLOCATE( sladd%ipoint, sladd%cdname, sladd%cdlong, sladd%cdunit )
753	ENDIF
754	IF ( slext%inum > 0 ) THEN
755	DEALLOCATE( slext%ipoint, slext%cdname, slext%cdlong, slext%cdunit )
756	ENDIF
757
758	ELSEIF (sobsgroups(jgroup)%lsurf) THEN
759
760	IF (sobsgroups(jgroup)%lvel) THEN
761	iuvar = 0
762	ivvar = 0
763	DO jvar = 1, sobsgroups(jgroup)%nobstypes
764	IF ( TRIM(sobsgroups(jgroup)%cobstypes(jvar)) == cobsname_uvel ) THEN
765	iuvar = jvar
766	ELSEIF ( TRIM(sobsgroups(jgroup)%cobstypes(jvar)) == cobsname_vvel ) THEN
767	ivvar = jvar
768	ENDIF
769	END DO
770	IF ( (iuvar > 0) .AND. (ivvar > 0) ) THEN
771
772	! For velocity data, rotate the model velocities to N/S, E/W
773	! using the compressed data structure.
774	ALLOCATE( &
775	& zu(sobsgroups(jgroup)%ssurfdataqc%nsurf), &
776	& zv(sobsgroups(jgroup)%ssurfdataqc%nsurf) &
777	& )
778
779	CALL obs_rotvel_surf( sobsgroups(jgroup)%ssurfdataqc, sobsgroups(jgroup)%n2dint, &
780	& iuvar, ivvar, zu, zv )
781
782	DO jo = 1, sobsgroups(jgroup)%ssurfdataqc%nsurf
783	sobsgroups(jgroup)%ssurfdataqc%rmod(jo,iuvar) = zu(jo)
784	sobsgroups(jgroup)%ssurfdataqc%rmod(jo,ivvar) = zv(jo)
785	END DO
786
787	DEALLOCATE( zu )
788	DEALLOCATE( zv )
789
790	ELSE
791	CALL ctl_stop( 'Could not identify velocity observation variables to rotate' )
792	END IF
793	END IF
794
795	CALL obs_surf_decompress( sobsgroups(jgroup)%ssurfdataqc, &
796	& sobsgroups(jgroup)%ssurfdata, .TRUE., numout )
797
798	IF (sobsgroups(jgroup)%lfbd) THEN
799	! Input observations were freeboard, but we're outputting ice thickness
800	DO jvar = 1, sobsgroups(jgroup)%nobstypes
801	IF ( sobsgroups(jgroup)%cobstypes(jvar) == cobsname_fbd ) THEN
802	sobsgroups(jgroup)%ssurfdata%cvars(jvar) = 'SIT'
803	sobsgroups(jgroup)%ssurfdata%clong(jvar) = 'Sea ice thickness'
804	sobsgroups(jgroup)%ssurfdata%cunit(jvar) = 'm'
805	EXIT
806	ENDIF
807	END DO
808	ENDIF
809
810	! Put additional and extra variable information into obswriinfo structure
811	! used by obs_write.
812	! add/ext variables generated by the OBS code (1...sobsgroups(jgroup)%naddvars)
813	! may duplicate ones read in (%naddvars+1...sobsgroups(jgroup)%ssurfdata%nadd)
814	! Check for this, and if so only write out the version generated by the OBS code
815	sladd%inum = sobsgroups(jgroup)%ssurfdata%nadd
816	ALLOCATE( ll_write(sobsgroups(jgroup)%ssurfdata%nadd) )
817	ll_write(:) = .TRUE.
818	IF ( (sobsgroups(jgroup)%naddvars > 0) .AND. &
819	& (sobsgroups(jgroup)%ssurfdata%nadd > sobsgroups(jgroup)%naddvars) ) THEN
820	DO jadd = sobsgroups(jgroup)%naddvars + 1, sobsgroups(jgroup)%ssurfdata%nadd
821	DO jadd2 = 1, sobsgroups(jgroup)%naddvars
822	IF ( TRIM(sobsgroups(jgroup)%ssurfdata%caddvars(jadd )) == &
823	& TRIM(sobsgroups(jgroup)%ssurfdata%caddvars(jadd2)) ) THEN
824	sladd%inum = sladd%inum - 1
825	ll_write(jadd) = .FALSE.
826	ENDIF
827	END DO
828	END DO
829	ENDIF
830	IF ( sladd%inum > 0 ) THEN
831	ALLOCATE( sladd%ipoint(sladd%inum), &
832	& sladd%cdname(sladd%inum), &
833	& sladd%cdlong(sladd%inum,sobsgroups(jgroup)%ssurfdata%nvar), &
834	& sladd%cdunit(sladd%inum,sobsgroups(jgroup)%ssurfdata%nvar) )
835	jadd2 = 0
836	DO jadd = 1, sobsgroups(jgroup)%ssurfdata%nadd
837	IF ( ll_write(jadd) ) THEN
838	jadd2 = jadd2 + 1
839	sladd%ipoint(jadd2) = jadd
840	sladd%cdname(jadd2) = sobsgroups(jgroup)%ssurfdata%caddvars(jadd)
841	DO jvar = 1, sobsgroups(jgroup)%ssurfdata%nvar
842	sladd%cdlong(jadd2,jvar) = sobsgroups(jgroup)%ssurfdata%caddlong(jadd,jvar)
843	sladd%cdunit(jadd2,jvar) = sobsgroups(jgroup)%ssurfdata%caddunit(jadd,jvar)
844	END DO
845	ENDIF
846	END DO
847	ENDIF
848	DEALLOCATE( ll_write )
849
850	slext%inum = sobsgroups(jgroup)%ssurfdata%nextra
851	ALLOCATE( ll_write(sobsgroups(jgroup)%ssurfdata%nextra) )
852	ll_write(:) = .TRUE.
853	IF ( (sobsgroups(jgroup)%nextvars > 0) .AND. &
854	& (sobsgroups(jgroup)%ssurfdata%nextra > sobsgroups(jgroup)%nextvars) ) THEN
855	DO jext = sobsgroups(jgroup)%nextvars + 1, sobsgroups(jgroup)%ssurfdata%nextra
856	DO jext2 = 1, sobsgroups(jgroup)%nextvars
857	IF ( TRIM(sobsgroups(jgroup)%ssurfdata%cextvars(jext )) == &
858	& TRIM(sobsgroups(jgroup)%ssurfdata%cextvars(jext2)) ) THEN
859	slext%inum = slext%inum - 1
860	ll_write(jext) = .FALSE.
861	ENDIF
862	END DO
863	END DO
864	ENDIF
865	IF ( slext%inum > 0 ) THEN
866	ALLOCATE( slext%ipoint(slext%inum), &
867	& slext%cdname(slext%inum), &
868	& slext%cdlong(slext%inum,1), &
869	& slext%cdunit(slext%inum,1) )
870	jext2 = 0
871	DO jext = 1, sobsgroups(jgroup)%ssurfdata%nextra
872	IF ( ll_write(jext) ) THEN
873	jext2 = jext2 + 1
874	slext%ipoint(jext2) = jext
875	slext%cdname(jext2) = sobsgroups(jgroup)%ssurfdata%cextvars(jext)
876	slext%cdlong(jext2,1) = sobsgroups(jgroup)%ssurfdata%cextlong(jext)
877	slext%cdunit(jext2,1) = sobsgroups(jgroup)%ssurfdata%cextunit(jext)
878	ENDIF
879	END DO
880	ENDIF
881	DEALLOCATE( ll_write )
882
883	CALL obs_wri_surf( sobsgroups(jgroup)%ssurfdata, sobsgroups(jgroup)%cgroupname, sladd, slext )
884
885	IF ( sladd%inum > 0 ) THEN
886	DEALLOCATE( sladd%ipoint, sladd%cdname, sladd%cdlong, sladd%cdunit )
887	ENDIF
888	IF ( slext%inum > 0 ) THEN
889	DEALLOCATE( slext%ipoint, slext%cdname, slext%cdlong, slext%cdunit )
890	ENDIF
891
892	ENDIF
893
894	ENDIF
895
896	END DO
897
898	IF( ln_timing ) CALL timing_stop('dia_obs_wri')
899
900	END SUBROUTINE dia_obs_wri
901
902	SUBROUTINE calc_date( kstp, ddobs )
903	!!----------------------------------------------------------------------
904	!! * ROUTINE calc_date *
905	!!
906	!! ** Purpose : Get date in double precision YYYYMMDD.HHMMSS format
907	!!
908	!! ** Method : Get date in double precision YYYYMMDD.HHMMSS format
909	!!
910	!! ** Action : Get date in double precision YYYYMMDD.HHMMSS format
911	!!
912	!! ** Action : Get initial date in double precision YYYYMMDD.HHMMSS format
913	!!
914	!! History :
915	!! ! 06-03 (K. Mogensen) Original code
916	!! ! 06-05 (K. Mogensen) Reformatted
917	!! ! 06-10 (A. Weaver) Cleaning
918	!! ! 06-10 (G. Smith) Calculates initial date the same as method for final date
919	!! ! 10-05 (D. Lea) Update to month length calculation for NEMO vn3.2
920	!! ! 2014-09 (D. Lea) New generic routine now deals with arbitrary initial time of day
921	!!----------------------------------------------------------------------
922	USE phycst, ONLY : & ! Physical constants
923	& rday
924	USE dom_oce, ONLY : & ! Ocean space and time domain variables
925	& rdt
926
927	IMPLICIT NONE
928
929	!! * Arguments
930	REAL(KIND=dp), INTENT(OUT) :: ddobs ! Date in YYYYMMDD.HHMMSS
931	INTEGER :: kstp
932
933	!! * Local declarations
934	INTEGER :: iyea ! date - (year, month, day, hour, minute)
935	INTEGER :: imon
936	INTEGER :: iday
937	INTEGER :: ihou
938	INTEGER :: imin
939	INTEGER :: imday ! Number of days in month.
940	REAL(wp) :: zdayfrc ! Fraction of day
941
942	INTEGER, DIMENSION(12) :: imonth_len !: length in days of the months of the current year
943
944	!!----------------------------------------------------------------------
945	!! Initial date initialization (year, month, day, hour, minute)
946	!!----------------------------------------------------------------------
947	iyea = ndate0 / 10000
948	imon = ( ndate0 - iyea * 10000 ) / 100
949	iday = ndate0 - iyea * 10000 - imon * 100
950	ihou = nn_time0 / 100
951	imin = ( nn_time0 - ihou * 100 )
952
953	!!----------------------------------------------------------------------
954	!! Compute number of days + number of hours + min since initial time
955	!!----------------------------------------------------------------------
956	zdayfrc = kstp * rdt / rday
957	zdayfrc = zdayfrc - aint(zdayfrc)
958	imin = imin + int( zdayfrc * 24 * 60 )
959	DO WHILE (imin >= 60)
960	imin=imin-60
961	ihou=ihou+1
962	END DO
963	DO WHILE (ihou >= 24)
964	ihou=ihou-24
965	iday=iday+1
966	END DO
967	iday = iday + kstp * rdt / rday
968
969	!-----------------------------------------------------------------------
970	! Convert number of days (iday) into a real date
971	!----------------------------------------------------------------------
972
973	CALL calc_month_len( iyea, imonth_len )
974
975	DO WHILE ( iday > imonth_len(imon) )
976	iday = iday - imonth_len(imon)
977	imon = imon + 1
978	IF ( imon > 12 ) THEN
979	imon = 1
980	iyea = iyea + 1
981	CALL calc_month_len( iyea, imonth_len ) ! update month lengths
982	ENDIF
983	END DO
984
985	!----------------------------------------------------------------------
986	! Convert it into YYYYMMDD.HHMMSS format.
987	!----------------------------------------------------------------------
988	ddobs = iyea * 10000_dp + imon * 100_dp + &
989	& iday + ihou * 0.01_dp + imin * 0.0001_dp
990
991	END SUBROUTINE calc_date
992
993	SUBROUTINE ini_date( ddobsini )
994	!!----------------------------------------------------------------------
995	!! * ROUTINE ini_date *
996	!!
997	!! ** Purpose : Get initial date in double precision YYYYMMDD.HHMMSS format
998	!!
999	!! ** Method :
1000	!!
1001	!! ** Action :
1002	!!
1003	!! History :
1004	!! ! 06-03 (K. Mogensen) Original code
1005	!! ! 06-05 (K. Mogensen) Reformatted
1006	!! ! 06-10 (A. Weaver) Cleaning
1007	!! ! 10-05 (D. Lea) Update to month length calculation for NEMO vn3.2
1008	!! ! 2014-09 (D. Lea) Change to call generic routine calc_date
1009	!!----------------------------------------------------------------------
1010
1011	IMPLICIT NONE
1012
1013	!! * Arguments
1014	REAL(KIND=dp), INTENT(OUT) :: ddobsini ! Initial date in YYYYMMDD.HHMMSS
1015
1016	CALL calc_date( nit000 - 1, ddobsini )
1017
1018	END SUBROUTINE ini_date
1019
1020	SUBROUTINE fin_date( ddobsfin )
1021	!!----------------------------------------------------------------------
1022	!! * ROUTINE fin_date *
1023	!!
1024	!! ** Purpose : Get final date in double precision YYYYMMDD.HHMMSS format
1025	!!
1026	!! ** Method :
1027	!!
1028	!! ** Action :
1029	!!
1030	!! History :
1031	!! ! 06-03 (K. Mogensen) Original code
1032	!! ! 06-05 (K. Mogensen) Reformatted
1033	!! ! 06-10 (A. Weaver) Cleaning
1034	!! ! 10-05 (D. Lea) Update to month length calculation for NEMO vn3.2
1035	!! ! 2014-09 (D. Lea) Change to call generic routine calc_date
1036	!!----------------------------------------------------------------------
1037
1038	IMPLICIT NONE
1039
1040	!! * Arguments
1041	REAL(dp), INTENT(OUT) :: ddobsfin ! Final date in YYYYMMDD.HHMMSS
1042
1043	CALL calc_date( nitend, ddobsfin )
1044
1045	END SUBROUTINE fin_date
1046
1047	END MODULE diaobs

Note: See TracBrowser for help on using the repository browser.

New URL for NEMO forge! http://forge.nemo-ocean.eu

Context Navigation

source: NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS/diaobs.F90 @ 15497

Download in other formats: