Context Navigation

obs_fbm.F90 @ 15660

Last change on this file since 15660 was 15607, checked in by sparonuz, 3 years ago
Fixed type declaration missing :: marker
Property svn:keywords set to `Id`
File size: 78.2 KB

Line
1	MODULE obs_fbm
2	!!======================================================================
3	!! * MODULE obs_fbm *
4	!! Observation operators : I/O + tools for feedback files
5	!!======================================================================
6	!! History :
7	!! ! 08-11 (K. Mogensen) Initial version
8	!!----------------------------------------------------------------------
9
10	!!----------------------------------------------------------------------
11	!! init_obfbdata : Initialize sizes in obfbdata structure
12	!! alloc_obfbdata : Allocate data in an obfbdata structure
13	!! dealloc_obfbdata : Dellocate data in an obfbdata structure
14	!! copy_obfbdata : Copy an obfbdata structure
15	!! subsamp_obfbdata : Sumsample an obfbdata structure
16	!! merge_obfbdata : Merge multiple obfbdata structures into an one.
17	!! write_obfbdata : Write an obfbdata structure into a netCDF file.
18	!! read_obfbdata : Read an obfbdata structure from a netCDF file.
19	!!----------------------------------------------------------------------
20	USE netcdf
21	USE obs_utils ! Various utilities for observation operators
22	USE par_kind
23
24	IMPLICIT NONE
25	PUBLIC
26
27	! Parameters for string lengths.
28
29	INTEGER, PARAMETER :: ilenwmo = 8 !: Length of station identifier
30	INTEGER, PARAMETER :: ilentyp = 4 !: Length of type
31	INTEGER, PARAMETER :: ilenname = 8 !: Length of variable names
32	INTEGER, PARAMETER :: ilengrid = 1 !: Grid (e.g. 'T') length
33	INTEGER, PARAMETER :: ilenjuld = 14 !: Lenght of reference julian date
34	INTEGER, PARAMETER :: idefnqcf = 2 !: Default number of words in QC
35	! flags
36	INTEGER, PARAMETER :: ilenlong = 128 !: Length of long name
37	INTEGER, PARAMETER :: ilenunit = 32 !: Length of units
38
39	! Missinge data indicators
40
41	INTEGER, PARAMETER :: fbimdi = -99999 !: Integers
42	REAL(sp), PARAMETER :: fbrmdi = 99999 !: Reals
43
44	! Main data structure for observation feedback data.
45
46	TYPE :: obfbdata
47	LOGICAL :: lalloc !: Allocation status for data
48	LOGICAL :: lgrid !: Include grid search info
49	INTEGER :: nvar !: Number of variables
50	INTEGER :: nobs !: Number of observations
51	INTEGER :: nlev !: Number of levels
52	INTEGER :: nadd !: Number of additional entries
53	INTEGER :: next !: Number of extra variables
54	INTEGER :: nqcf !: Number of words per qc flag
55	CHARACTER(LEN=ilenwmo), DIMENSION(:), POINTER :: &
56	& cdwmo !: Identifier
57	CHARACTER(LEN=ilentyp), DIMENSION(:), POINTER :: &
58	& cdtyp !: Instrument type
59	CHARACTER(LEN=ilenjuld) :: &
60	& cdjuldref !: Julian date reference
61	INTEGER, DIMENSION(:), POINTER :: &
62	& kindex !: Index of observations in the original file
63	INTEGER, DIMENSION(:), POINTER :: &
64	& ioqc, & !: Observation QC
65	& ipqc, & !: Position QC
66	& itqc !: Time QC
67	INTEGER, DIMENSION(:,:), POINTER :: &
68	& ioqcf, & !: Observation QC flags
69	& ipqcf, & !: Position QC flags
70	& itqcf !: Time QC flags
71	INTEGER, DIMENSION(:,:), POINTER :: &
72	& idqc !: Depth QC
73	INTEGER, DIMENSION(:,:,:), POINTER :: &
74	& idqcf !: Depth QC flags
75	REAL(KIND=dp), DIMENSION(:), POINTER :: &
76	& plam, & !: Longitude
77	& pphi, & !: Latitude
78	& ptim !: Time
79	REAL(KIND=sp), DIMENSION(:,:), POINTER :: &
80	& pdep !: Depth
81	CHARACTER(LEN=ilenname), DIMENSION(:), POINTER :: &
82	& cname !: Name of variable
83	REAL(sp), DIMENSION(:,:,:), POINTER :: &
84	& pob !: Observation
85	CHARACTER(LEN=ilenlong), DIMENSION(:), POINTER :: &
86	& coblong !: Observation long name (for output)
87	CHARACTER(LEN=ilenunit), DIMENSION(:), POINTER :: &
88	& cobunit !: Observation units (for output)
89	INTEGER, DIMENSION(:,:), POINTER :: &
90	& ivqc !: Variable QC
91	INTEGER, DIMENSION(:,:,:), POINTER :: &
92	& ivqcf !: Variable QC flags
93	INTEGER, DIMENSION(:,:,:), POINTER :: &
94	& ivlqc !: Variable level QC
95	INTEGER, DIMENSION(:,:,:,:), POINTER :: &
96	& ivlqcf !: Variable level QC flags
97	INTEGER, DIMENSION(:,:), POINTER :: &
98	& iproc, & !: Processor of obs (no I/O for this variable).
99	& iobsi, & !: Global i index
100	& iobsj !: Global j index
101	INTEGER, DIMENSION(:,:,:), POINTER :: &
102	& iobsk !: k index
103	CHARACTER(LEN=ilengrid), DIMENSION(:), POINTER :: &
104	& cgrid !: Grid for this variable
105	CHARACTER(LEN=ilenname), DIMENSION(:), POINTER :: &
106	& caddname !: Additional entries names
107	CHARACTER(LEN=ilenlong), DIMENSION(:,:), POINTER :: &
108	& caddlong !: Additional entries long name (for output)
109	CHARACTER(LEN=ilenunit), DIMENSION(:,:), POINTER :: &
110	& caddunit !: Additional entries units (for output)
111	REAL(sp), DIMENSION(:,:,:,:) , POINTER :: &
112	& padd !: Additional entries
113	CHARACTER(LEN=ilenname), DIMENSION(:), POINTER :: &
114	& cextname !: Extra variables names
115	CHARACTER(LEN=ilenlong), DIMENSION(:), POINTER :: &
116	& cextlong !: Extra variables long name (for output)
117	CHARACTER(LEN=ilenunit), DIMENSION(:), POINTER :: &
118	& cextunit !: Extra variables units (for output)
119	REAL(sp), DIMENSION(:,:,:) , POINTER :: &
120	& pext !: Extra variables
121	END TYPE obfbdata
122
123	PRIVATE putvaratt_obfbdata
124
125	!!----------------------------------------------------------------------
126	!! NEMO/OCE 4.0 , NEMO Consortium (2018)
127	!! $Id$
128	!! Software governed by the CeCILL license (see ./LICENSE)
129	!!----------------------------------------------------------------------
130
131	CONTAINS
132
133	SUBROUTINE init_obfbdata( fbdata )
134	!!----------------------------------------------------------------------
135	!! * ROUTINE init_obfbdata *
136	!!
137	!! ** Purpose : Initialize sizes in obfbdata structure
138	!!
139	!! ** Method :
140	!!
141	!! ** Action :
142	!!
143	!!----------------------------------------------------------------------
144	!! * Arguments
145	TYPE(obfbdata) :: fbdata ! obsfbdata structure
146
147	fbdata%nvar = 0
148	fbdata%nobs = 0
149	fbdata%nlev = 0
150	fbdata%nadd = 0
151	fbdata%next = 0
152	fbdata%nqcf = idefnqcf
153	fbdata%lalloc = .FALSE.
154	fbdata%lgrid = .FALSE.
155
156	END SUBROUTINE init_obfbdata
157
158	SUBROUTINE alloc_obfbdata( fbdata, kvar, kobs, klev, kadd, kext, lgrid, &
159	& kqcf)
160	!!----------------------------------------------------------------------
161	!! * ROUTINE alloc_obfbdata *
162	!!
163	!! ** Purpose : Allocate data in an obfbdata structure
164	!!
165	!! ** Method :
166	!!
167	!! ** Action :
168	!!
169	!!----------------------------------------------------------------------
170	!! * Arguments
171	TYPE(obfbdata) :: fbdata ! obsfbdata structure to be allocated
172	INTEGER, INTENT(IN) :: kvar ! Number of variables
173	INTEGER, INTENT(IN) :: kobs ! Number of observations
174	INTEGER, INTENT(IN) :: klev ! Number of levels
175	INTEGER, INTENT(IN) :: kadd ! Number of additional entries
176	INTEGER, INTENT(IN) :: kext ! Number of extra variables
177	LOGICAL, INTENT(IN) :: lgrid ! Include grid search information
178	INTEGER, OPTIONAL :: kqcf ! Number of words for QC flags
179	!! * Local variables
180	INTEGER :: ji
181	INTEGER :: jv
182
183	! Check allocation status and deallocate previous allocated structures
184
185	IF ( fbdata%lalloc ) THEN
186	CALL dealloc_obfbdata( fbdata )
187	ENDIF
188
189	! Set dimensions
190
191	fbdata%lalloc = .TRUE.
192	fbdata%nvar = kvar
193	fbdata%nobs = kobs
194	fbdata%nlev = MAX( klev, 1 )
195	fbdata%nadd = kadd
196	fbdata%next = kext
197	IF ( PRESENT(kqcf) ) THEN
198	fbdata%nqcf = kqcf
199	ELSE
200	fbdata%nqcf = idefnqcf
201	ENDIF
202
203	! Set data not depending on number of observations
204
205	fbdata%cdjuldref = REPEAT( 'X', ilenjuld )
206
207	! Allocate and initialize standard data
208
209	ALLOCATE( &
210	& fbdata%cname(fbdata%nvar), &
211	& fbdata%coblong(fbdata%nvar), &
212	& fbdata%cobunit(fbdata%nvar) &
213	& )
214	DO ji = 1, fbdata%nvar
215	WRITE(fbdata%cname(ji),'(A,I2.2)')'V_',ji
216	fbdata%coblong(ji) = REPEAT( ' ', ilenlong )
217	fbdata%cobunit(ji) = REPEAT( ' ', ilenunit )
218	END DO
219
220	! Optionally also store grid search information
221
222	IF ( lgrid ) THEN
223	ALLOCATE ( &
224	& fbdata%cgrid(fbdata%nvar) &
225	& )
226	fbdata%cgrid(:) = REPEAT( 'X', ilengrid )
227	fbdata%lgrid = .TRUE.
228	ENDIF
229
230	! Allocate and initialize additional entries if present
231
232	IF ( fbdata%nadd > 0 ) THEN
233	ALLOCATE( &
234	& fbdata%caddname(fbdata%nadd), &
235	& fbdata%caddlong(fbdata%nadd, fbdata%nvar), &
236	& fbdata%caddunit(fbdata%nadd, fbdata%nvar) &
237	& )
238	DO ji = 1, fbdata%nadd
239	WRITE(fbdata%caddname(ji),'(A,I2.2)')'A',ji
240	END DO
241	DO jv = 1, fbdata%nvar
242	DO ji = 1, fbdata%nadd
243	fbdata%caddlong(ji,jv) = REPEAT( ' ', ilenlong )
244	fbdata%caddunit(ji,jv) = REPEAT( ' ', ilenunit )
245	END DO
246	END DO
247	ENDIF
248
249	! Allocate and initialize additional variables if present
250
251	IF ( fbdata%next > 0 ) THEN
252	ALLOCATE( &
253	& fbdata%cextname(fbdata%next), &
254	& fbdata%cextlong(fbdata%next), &
255	& fbdata%cextunit(fbdata%next) &
256	& )
257	DO ji = 1, fbdata%next
258	WRITE(fbdata%cextname(ji),'(A,I2.2)')'E_',ji
259	fbdata%cextlong(ji) = REPEAT( ' ', ilenlong )
260	fbdata%cextunit(ji) = REPEAT( ' ', ilenunit )
261	END DO
262	ENDIF
263
264	! Data depending on number of observations is only allocated if nobs>0
265
266	IF ( fbdata%nobs > 0 ) THEN
267
268	ALLOCATE( &
269	& fbdata%cdwmo(fbdata%nobs), &
270	& fbdata%cdtyp(fbdata%nobs), &
271	& fbdata%ioqc(fbdata%nobs), &
272	& fbdata%ioqcf(fbdata%nqcf,fbdata%nobs), &
273	& fbdata%ipqc(fbdata%nobs), &
274	& fbdata%ipqcf(fbdata%nqcf,fbdata%nobs), &
275	& fbdata%itqc(fbdata%nobs), &
276	& fbdata%itqcf(fbdata%nqcf,fbdata%nobs), &
277	& fbdata%idqc(fbdata%nlev,fbdata%nobs), &
278	& fbdata%idqcf(fbdata%nqcf,fbdata%nlev,fbdata%nobs), &
279	& fbdata%plam(fbdata%nobs), &
280	& fbdata%pphi(fbdata%nobs), &
281	& fbdata%pdep(fbdata%nlev,fbdata%nobs), &
282	& fbdata%ptim(fbdata%nobs), &
283	& fbdata%kindex(fbdata%nobs), &
284	& fbdata%ivqc(fbdata%nobs,fbdata%nvar), &
285	& fbdata%ivqcf(fbdata%nqcf,fbdata%nobs,fbdata%nvar), &
286	& fbdata%ivlqc(fbdata%nlev,fbdata%nobs,fbdata%nvar), &
287	& fbdata%ivlqcf(fbdata%nqcf,fbdata%nlev,fbdata%nobs,fbdata%nvar), &
288	& fbdata%pob(fbdata%nlev,fbdata%nobs,fbdata%nvar) &
289	& )
290	fbdata%kindex(:) = fbimdi
291	fbdata%cdwmo(:) = REPEAT( 'X', ilenwmo )
292	fbdata%cdtyp(:) = REPEAT( 'X', ilentyp )
293	fbdata%ioqc(:) = fbimdi
294	fbdata%ioqcf(:,:) = fbimdi
295	fbdata%ipqc(:) = fbimdi
296	fbdata%ipqcf(:,:) = fbimdi
297	fbdata%itqc(:) = fbimdi
298	fbdata%itqcf(:,:) = fbimdi
299	fbdata%idqc(:,:) = fbimdi
300	fbdata%idqcf(:,:,:) = fbimdi
301	fbdata%plam(:) = fbrmdi
302	fbdata%pphi(:) = fbrmdi
303	fbdata%pdep(:,:) = fbrmdi
304	fbdata%ptim(:) = fbrmdi
305	fbdata%ivqc(:,:) = fbimdi
306	fbdata%ivqcf(:,:,:) = fbimdi
307	fbdata%ivlqc(:,:,:) = fbimdi
308	fbdata%ivlqcf(:,:,:,:) = fbimdi
309	fbdata%pob(:,:,:) = fbrmdi
310
311	! Optionally also store grid search information
312
313	IF ( lgrid ) THEN
314	ALLOCATE ( &
315	& fbdata%iproc(fbdata%nobs,fbdata%nvar), &
316	& fbdata%iobsi(fbdata%nobs,fbdata%nvar), &
317	& fbdata%iobsj(fbdata%nobs,fbdata%nvar), &
318	& fbdata%iobsk(fbdata%nlev,fbdata%nobs,fbdata%nvar) &
319	& )
320	fbdata%iproc(:,:) = fbimdi
321	fbdata%iobsi(:,:) = fbimdi
322	fbdata%iobsj(:,:) = fbimdi
323	fbdata%iobsk(:,:,:) = fbimdi
324	fbdata%lgrid = .TRUE.
325	ENDIF
326
327	! Allocate and initialize additional entries if present
328
329	IF ( fbdata%nadd > 0 ) THEN
330	ALLOCATE( &
331	& fbdata%padd(fbdata%nlev,fbdata%nobs,fbdata%nadd,fbdata%nvar) &
332	& )
333	fbdata%padd(:,:,:,:) = fbrmdi
334	ENDIF
335
336	! Allocate and initialize additional variables if present
337
338	IF ( fbdata%next > 0 ) THEN
339	ALLOCATE( &
340	& fbdata%pext(fbdata%nlev,fbdata%nobs,fbdata%next) &
341	& )
342	fbdata%pext(:,:,:) = fbrmdi
343	ENDIF
344
345	ENDIF
346
347	END SUBROUTINE alloc_obfbdata
348
349	SUBROUTINE dealloc_obfbdata( fbdata )
350	!!----------------------------------------------------------------------
351	!! * ROUTINE dealloc_obfbdata *
352	!!
353	!! ** Purpose : Deallocate data in an obfbdata strucure
354	!!
355	!! ** Method :
356	!!
357	!! ** Action :
358	!!
359	!!----------------------------------------------------------------------
360	!! * Arguments
361	TYPE(obfbdata) :: fbdata ! obsfbdata structure
362
363	! Deallocate data
364
365	DEALLOCATE( &
366	& fbdata%cname, &
367	& fbdata%coblong,&
368	& fbdata%cobunit &
369	& )
370
371	! Deallocate optional grid search information
372
373	IF ( fbdata%lgrid ) THEN
374	DEALLOCATE ( &
375	& fbdata%cgrid &
376	& )
377	ENDIF
378
379	! Deallocate additional entries
380
381	IF ( fbdata%nadd > 0 ) THEN
382	DEALLOCATE( &
383	& fbdata%caddname, &
384	& fbdata%caddlong, &
385	& fbdata%caddunit &
386	& )
387	ENDIF
388
389	! Deallocate extra variables
390
391	IF ( fbdata%next > 0 ) THEN
392	DEALLOCATE( &
393	& fbdata%cextname, &
394	& fbdata%cextlong, &
395	& fbdata%cextunit &
396	& )
397	ENDIF
398
399	! Deallocate arrays depending on number of obs (if nobs>0 only).
400
401	IF ( fbdata%nobs > 0 ) THEN
402
403	DEALLOCATE( &
404	& fbdata%cdwmo, &
405	& fbdata%cdtyp, &
406	& fbdata%ioqc, &
407	& fbdata%ioqcf, &
408	& fbdata%ipqc, &
409	& fbdata%ipqcf, &
410	& fbdata%itqc, &
411	& fbdata%itqcf, &
412	& fbdata%idqc, &
413	& fbdata%idqcf, &
414	& fbdata%plam, &
415	& fbdata%pphi, &
416	& fbdata%pdep, &
417	& fbdata%ptim, &
418	& fbdata%kindex, &
419	& fbdata%ivqc, &
420	& fbdata%ivqcf, &
421	& fbdata%ivlqc, &
422	& fbdata%ivlqcf, &
423	& fbdata%pob &
424	& )
425
426
427	! Deallocate optional grid search information
428
429	IF ( fbdata%lgrid ) THEN
430	DEALLOCATE ( &
431	& fbdata%iproc, &
432	& fbdata%iobsi, &
433	& fbdata%iobsj, &
434	& fbdata%iobsk &
435	& )
436	ENDIF
437
438	! Deallocate additional entries
439
440	IF ( fbdata%nadd > 0 ) THEN
441	DEALLOCATE( &
442	& fbdata%padd &
443	& )
444	ENDIF
445
446	! Deallocate extra variables
447
448	IF ( fbdata%next > 0 ) THEN
449	DEALLOCATE( &
450	& fbdata%pext &
451	& )
452	ENDIF
453
454	ENDIF
455
456	! Reset arrays sizes
457
458	fbdata%lalloc = .FALSE.
459	fbdata%lgrid = .FALSE.
460	fbdata%nvar = 0
461	fbdata%nobs = 0
462	fbdata%nlev = 0
463	fbdata%nadd = 0
464	fbdata%next = 0
465
466	END SUBROUTINE dealloc_obfbdata
467
468	SUBROUTINE copy_obfbdata( fbdata1, fbdata2, kadd, kext, lgrid, kqcf )
469	!!----------------------------------------------------------------------
470	!! * ROUTINE copy_obfbdata *
471	!!
472	!! ** Purpose : Copy an obfbdata structure
473	!!
474	!! ** Method : Copy all data from fbdata1 to fbdata2
475	!! If fbdata2 is allocated it needs to be compliant
476	!! with fbdata1.
477	!! Additional entries can be added by setting nadd
478	!! Additional extra fields can be added by setting next
479	!! Grid information can be included with lgrid=.true.
480	!!
481	!! ** Action :
482	!!
483	!!----------------------------------------------------------------------
484	!! * Arguments
485	TYPE(obfbdata) :: fbdata1 ! Input obsfbdata structure
486	TYPE(obfbdata) :: fbdata2 ! Output obsfbdata structure
487	INTEGER, INTENT(IN), OPTIONAL :: kadd ! Number of additional entries
488	INTEGER, INTENT(IN), OPTIONAL :: kext ! Number of extra variables
489	INTEGER, INTENT(IN), OPTIONAL :: kqcf ! Number of words per qc flags
490	LOGICAL, OPTIONAL :: lgrid ! Grid info on output file
491
492	!! * Local variables
493	INTEGER :: nadd
494	INTEGER :: next
495	INTEGER :: nqcf
496	LOGICAL :: llgrid
497	INTEGER :: jv
498	INTEGER :: je
499	INTEGER :: ji
500	INTEGER :: jk
501	INTEGER :: jq
502
503	! Check allocation status of fbdata1
504
505	IF ( .NOT. fbdata1%lalloc ) THEN
506	CALL fatal_error( 'copy_obfbdata: input data not allocated', &
507	& __LINE__ )
508	ENDIF
509
510	! If nadd,next not specified use the ones from fbdata1
511	! Otherwise check that they have large than the original ones
512
513	IF ( PRESENT(kadd) ) THEN
514	nadd = kadd
515	IF ( nadd < fbdata1%nadd ) THEN
516	CALL warning ( 'copy_obfbdata: ' // &
517	& 'nadd smaller than input nadd', __LINE__ )
518	ENDIF
519	ELSE
520	nadd = fbdata1%nadd
521	ENDIF
522	IF ( PRESENT(kext) ) THEN
523	next = kext
524	IF ( next < fbdata1%next ) THEN
525	CALL fatal_error( 'copy_obfbdata: ' // &
526	& 'next smaller than input next', __LINE__ )
527	ENDIF
528	ELSE
529	next = fbdata1%next
530	ENDIF
531	IF ( PRESENT(lgrid) ) THEN
532	llgrid = lgrid
533	IF ( fbdata1%lgrid .AND. (.NOT. llgrid) ) THEN
534	CALL fatal_error( 'copy_obfbdata: ' // &
535	& 'switching off grid info not possible', &
536	& __LINE__ )
537	ENDIF
538	ELSE
539	llgrid = fbdata1%lgrid
540	ENDIF
541	IF ( PRESENT(kqcf) ) THEN
542	nqcf = kqcf
543	IF ( nqcf < fbdata1%nqcf ) THEN
544	CALL fatal_error( 'copy_obfbdata: ' // &
545	& 'nqcf smaller than input nqcf', __LINE__ )
546	ENDIF
547	ELSE
548	nqcf = fbdata1%nqcf
549	ENDIF
550
551	! Check allocation status of fbdata2 and
552	! a) check that it conforms in size if already allocated
553	! b) allocate it if not already allocated
554
555	IF ( fbdata2%lalloc ) THEN
556	IF ( fbdata1%nvar > fbdata2%nvar ) THEN
557	CALL fatal_error( 'copy_obfbdata: ' // &
558	& 'output kvar smaller than input kvar', __LINE__ )
559	ENDIF
560	IF ( fbdata1%nobs > fbdata2%nobs ) THEN
561	CALL fatal_error( 'copy_obfbdata: ' // &
562	& 'output kobs smaller than input kobs', __LINE__ )
563	ENDIF
564	IF ( fbdata1%nlev > fbdata2%nlev ) THEN
565	CALL fatal_error( 'copy_obfbdata: ' // &
566	& 'output klev smaller than input klev', __LINE__ )
567	ENDIF
568	IF ( fbdata1%nadd > fbdata2%nadd ) THEN
569	CALL warning ( 'copy_obfbdata: ' // &
570	& 'output nadd smaller than input nadd', __LINE__ )
571	ENDIF
572	IF ( fbdata1%next > fbdata2%next ) THEN
573	CALL fatal_error( 'copy_obfbdata: ' // &
574	& 'output next smaller than input next', __LINE__ )
575	ENDIF
576	IF ( fbdata1%lgrid .NEQV. fbdata2%lgrid ) THEN
577	CALL fatal_error( 'copy_obfbdata: ' // &
578	& 'lgrid inconsistent', __LINE__ )
579	ENDIF
580	IF ( fbdata1%next > fbdata2%next ) THEN
581	CALL fatal_error( 'copy_obfbdata: ' // &
582	& 'output next smaller than input next', __LINE__ )
583	ENDIF
584	IF ( fbdata1%nqcf > fbdata2%nqcf ) THEN
585	CALL fatal_error( 'copy_obfbdata: ' // &
586	& 'output smaller than input kext', __LINE__ )
587	ENDIF
588	ELSE
589	CALL alloc_obfbdata( fbdata2, fbdata1%nvar, fbdata1%nobs, &
590	& fbdata1%nlev, nadd, next, llgrid, kqcf = nqcf )
591	ENDIF
592
593	! Copy the header data
594
595	fbdata2%cdjuldref = fbdata1%cdjuldref
596
597	DO ji = 1, fbdata1%nobs
598	fbdata2%cdwmo(ji) = fbdata1%cdwmo(ji)
599	fbdata2%cdtyp(ji) = fbdata1%cdtyp(ji)
600	fbdata2%ioqc(ji) = fbdata1%ioqc(ji)
601	fbdata2%ipqc(ji) = fbdata1%ipqc(ji)
602	fbdata2%itqc(ji) = fbdata1%itqc(ji)
603	fbdata2%plam(ji) = fbdata1%plam(ji)
604	fbdata2%pphi(ji) = fbdata1%pphi(ji)
605	fbdata2%ptim(ji) = fbdata1%ptim(ji)
606	fbdata2%kindex(ji) = fbdata1%kindex(ji)
607	DO jq = 1, fbdata1%nqcf
608	fbdata2%ioqcf(jq,ji) = fbdata1%ioqcf(jq,ji)
609	fbdata2%ipqcf(jq,ji) = fbdata1%ipqcf(jq,ji)
610	fbdata2%itqcf(jq,ji) = fbdata1%itqcf(jq,ji)
611	END DO
612	DO jk = 1, fbdata1%nlev
613	fbdata2%idqc(jk,ji) = fbdata1%idqc(jk,ji)
614	fbdata2%pdep(jk,ji) = fbdata1%pdep(jk,ji)
615	DO jq = 1, fbdata1%nqcf
616	fbdata2%idqcf(jq,jk,ji) = fbdata1%idqcf(jq,jk,ji)
617	END DO
618	END DO
619	END DO
620
621	! Copy the variable data
622
623	DO jv = 1, fbdata1%nvar
624	fbdata2%cname(jv) = fbdata1%cname(jv)
625	fbdata2%coblong(jv) = fbdata1%coblong(jv)
626	fbdata2%cobunit(jv) = fbdata1%cobunit(jv)
627	DO ji = 1, fbdata1%nobs
628	fbdata2%ivqc(ji,jv) = fbdata1%ivqc(ji,jv)
629	DO jq = 1, fbdata1%nqcf
630	fbdata2%ivqcf(jq,ji,jv) = fbdata1%ivqcf(jq,ji,jv)
631	END DO
632	DO jk = 1, fbdata1%nlev
633	fbdata2%ivlqc(jk,ji,jv) = fbdata1%ivlqc(jk,ji,jv)
634	fbdata2%pob(jk,ji,jv) = fbdata1%pob(jk,ji,jv)
635	DO jq = 1, fbdata1%nqcf
636	fbdata2%ivlqcf(jq,jk,ji,jv) = fbdata1%ivlqcf(jq,jk,ji,jv)
637	END DO
638	END DO
639	END DO
640	END DO
641
642	! Copy grid information
643
644	IF ( fbdata1%lgrid ) THEN
645	DO jv = 1, fbdata1%nvar
646	fbdata2%cgrid(jv) = fbdata1%cgrid(jv)
647	DO ji = 1, fbdata1%nobs
648	fbdata2%iproc(ji,jv) = fbdata1%iproc(ji,jv)
649	fbdata2%iobsi(ji,jv) = fbdata1%iobsi(ji,jv)
650	fbdata2%iobsj(ji,jv) = fbdata1%iobsj(ji,jv)
651	DO jk = 1, fbdata1%nlev
652	fbdata2%iobsk(jk,ji,jv) = fbdata1%iobsk(jk,ji,jv)
653	END DO
654	END DO
655	END DO
656	ENDIF
657
658	! Copy additional information
659
660	DO je = 1, MIN( fbdata1%nadd, fbdata2%nadd )
661	fbdata2%caddname(je) = fbdata1%caddname(je)
662	END DO
663	DO jv = 1, fbdata1%nvar
664	DO je = 1, MIN( fbdata1%nadd, fbdata2%nadd )
665	fbdata2%caddlong(je,jv) = fbdata1%caddlong(je,jv)
666	fbdata2%caddunit(je,jv) = fbdata1%caddunit(je,jv)
667	DO ji = 1, fbdata1%nobs
668	DO jk = 1, fbdata1%nlev
669	fbdata2%padd(jk,ji,je,jv) = fbdata1%padd(jk,ji,je,jv)
670	END DO
671	END DO
672	END DO
673	END DO
674
675	! Copy extra information
676
677	DO je = 1, fbdata1%next
678	fbdata2%cextname(je) = fbdata1%cextname(je)
679	fbdata2%cextlong(je) = fbdata1%cextlong(je)
680	fbdata2%cextunit(je) = fbdata1%cextunit(je)
681	END DO
682	DO je = 1, fbdata1%next
683	DO ji = 1, fbdata1%nobs
684	DO jk = 1, fbdata1%nlev
685	fbdata2%pext(jk,ji,je) = fbdata1%pext(jk,ji,je)
686	END DO
687	END DO
688	END DO
689
690	END SUBROUTINE copy_obfbdata
691
692	SUBROUTINE subsamp_obfbdata( fbdata1, fbdata2, llvalid )
693	!!----------------------------------------------------------------------
694	!! * ROUTINE susbamp_obfbdata *
695	!!
696	!! ** Purpose : Subsample an obfbdata structure based on the
697	!! logical mask.
698	!!
699	!! ** Method : Copy all data from fbdata1 to fbdata2 if
700	!! llvalid(obs)==true
701	!!
702	!! ** Action :
703	!!
704	!!----------------------------------------------------------------------
705	!! * Arguments
706	TYPE(obfbdata) :: fbdata1 ! Input obsfbdata structure
707	TYPE(obfbdata) :: fbdata2 ! Output obsfbdata structure
708	LOGICAL, DIMENSION(fbdata1%nobs) :: llvalid ! Grid info on output file
709	!! * Local variables
710	INTEGER :: nobs
711	INTEGER :: jv
712	INTEGER :: je
713	INTEGER :: ji
714	INTEGER :: jk
715	INTEGER :: jq
716	INTEGER :: ij
717
718	! Check allocation status of fbdata1
719
720	IF ( .NOT. fbdata1%lalloc ) THEN
721	CALL fatal_error( 'copy_obfbdata: input data not allocated', &
722	& __LINE__ )
723	ENDIF
724
725	! Check allocation status of fbdata2 and abort if already allocated
726
727	IF ( fbdata2%lalloc ) THEN
728	CALL fatal_error( 'subsample_obfbdata: ' // &
729	& 'fbdata2 already allocated', __LINE__ )
730	ENDIF
731
732	! Count number of subsampled observations
733
734	nobs = COUNT(llvalid)
735
736	! Allocate new data structure
737
738	CALL alloc_obfbdata( fbdata2, fbdata1%nvar, nobs, &
739	& fbdata1%nlev, fbdata1%nadd, fbdata1%next, &
740	& fbdata1%lgrid, kqcf = fbdata1%nqcf )
741
742	! Copy the header data
743
744	fbdata2%cdjuldref = fbdata1%cdjuldref
745
746	ij = 0
747	DO ji = 1, fbdata1%nobs
748	IF ( llvalid(ji) ) THEN
749	ij = ij +1
750	fbdata2%cdwmo(ij) = fbdata1%cdwmo(ji)
751	fbdata2%cdtyp(ij) = fbdata1%cdtyp(ji)
752	fbdata2%ioqc(ij) = fbdata1%ioqc(ji)
753	fbdata2%ipqc(ij) = fbdata1%ipqc(ji)
754	fbdata2%itqc(ij) = fbdata1%itqc(ji)
755	fbdata2%plam(ij) = fbdata1%plam(ji)
756	fbdata2%pphi(ij) = fbdata1%pphi(ji)
757	fbdata2%ptim(ij) = fbdata1%ptim(ji)
758	fbdata2%kindex(ij) = fbdata1%kindex(ji)
759	DO jq = 1, fbdata1%nqcf
760	fbdata2%ioqcf(jq,ij) = fbdata1%ioqcf(jq,ji)
761	fbdata2%ipqcf(jq,ij) = fbdata1%ipqcf(jq,ji)
762	fbdata2%itqcf(jq,ij) = fbdata1%itqcf(jq,ji)
763	END DO
764	DO jk = 1, fbdata1%nlev
765	fbdata2%idqc(jk,ij) = fbdata1%idqc(jk,ji)
766	fbdata2%pdep(jk,ij) = fbdata1%pdep(jk,ji)
767	DO jq = 1, fbdata1%nqcf
768	fbdata2%idqcf(jq,jk,ij) = fbdata1%idqcf(jq,jk,ji)
769	END DO
770	END DO
771	ENDIF
772	END DO
773
774	! Copy the variable data
775
776	DO jv = 1, fbdata1%nvar
777	fbdata2%cname(jv) = fbdata1%cname(jv)
778	fbdata2%coblong(jv) = fbdata1%coblong(jv)
779	fbdata2%cobunit(jv) = fbdata1%cobunit(jv)
780	ij = 0
781	DO ji = 1, fbdata1%nobs
782	IF ( llvalid(ji) ) THEN
783	ij = ij + 1
784	fbdata2%ivqc(ij,jv) = fbdata1%ivqc(ji,jv)
785	DO jq = 1, fbdata1%nqcf
786	fbdata2%ivqcf(jq,ij,jv) = fbdata1%ivqcf(jq,ji,jv)
787	END DO
788	DO jk = 1, fbdata1%nlev
789	fbdata2%ivlqc(jk,ij,jv) = fbdata1%ivlqc(jk,ji,jv)
790	fbdata2%pob(jk,ij,jv) = fbdata1%pob(jk,ji,jv)
791	DO jq = 1, fbdata1%nqcf
792	fbdata2%ivlqcf(jq,jk,ij,jv) = fbdata1%ivlqcf(jq,jk,ji,jv)
793	END DO
794	END DO
795	ENDIF
796	END DO
797	END DO
798
799	! Copy grid information
800
801	IF ( fbdata1%lgrid ) THEN
802	DO jv = 1, fbdata1%nvar
803	fbdata2%cgrid(jv) = fbdata1%cgrid(jv)
804	ij = 0
805	DO ji = 1, fbdata1%nobs
806	IF ( llvalid(ji) ) THEN
807	ij = ij + 1
808	fbdata2%iproc(ij,jv) = fbdata1%iproc(ji,jv)
809	fbdata2%iobsi(ij,jv) = fbdata1%iobsi(ji,jv)
810	fbdata2%iobsj(ij,jv) = fbdata1%iobsj(ji,jv)
811	DO jk = 1, fbdata1%nlev
812	fbdata2%iobsk(jk,ij,jv) = fbdata1%iobsk(jk,ji,jv)
813	END DO
814	ENDIF
815	END DO
816	END DO
817	ENDIF
818
819	! Copy additional information
820
821	DO je = 1, fbdata1%nadd
822	fbdata2%caddname(je) = fbdata1%caddname(je)
823	END DO
824	DO jv = 1, fbdata1%nvar
825	DO je = 1, fbdata1%nadd
826	fbdata2%caddlong(je,jv) = fbdata1%caddlong(je,jv)
827	fbdata2%caddunit(je,jv) = fbdata1%caddunit(je,jv)
828	ij = 0
829	DO ji = 1, fbdata1%nobs
830	IF ( llvalid(ji) ) THEN
831	ij = ij + 1
832	DO jk = 1, fbdata1%nlev
833	fbdata2%padd(jk,ij,je,jv) = fbdata1%padd(jk,ji,je,jv)
834	END DO
835	ENDIF
836	END DO
837	END DO
838	END DO
839
840	! Copy extra information
841
842	DO je = 1, fbdata1%next
843	fbdata2%cextname(je) = fbdata1%cextname(je)
844	fbdata2%cextlong(je) = fbdata1%cextlong(je)
845	fbdata2%cextunit(je) = fbdata1%cextunit(je)
846	END DO
847	DO je = 1, fbdata1%next
848	ij = 0
849	DO ji = 1, fbdata1%nobs
850	IF ( llvalid(ji) ) THEN
851	ij = ij + 1
852	DO jk = 1, fbdata1%nlev
853	fbdata2%pext(jk,ij,je) = fbdata1%pext(jk,ji,je)
854	END DO
855	ENDIF
856	END DO
857	END DO
858
859	END SUBROUTINE subsamp_obfbdata
860
861	SUBROUTINE merge_obfbdata( nsets, fbdatain, fbdataout, iset, inum, iind )
862	!!----------------------------------------------------------------------
863	!! * ROUTINE merge_obfbdata *
864	!!
865	!! ** Purpose : Merge multiple obfbdata structures into an one.
866	!!
867	!! ** Method : The order of elements is based on the indices in
868	!! iind.
869	!! All input data are assumed to be consistent. This
870	!! is assumed to be checked before calling this routine.
871	!! Likewise output data is assume to be consistent as
872	!! well without error checking.
873	!!
874	!! ** Action :
875	!!
876	!!----------------------------------------------------------------------
877	!! * Arguments
878	INTEGER, INTENT(IN):: nsets ! Number of input data sets
879	TYPE(obfbdata), DIMENSION(nsets) :: fbdatain ! Input obsfbdata structure
880	TYPE(obfbdata) :: fbdataout ! Output obsfbdata structure
881	INTEGER, INTENT(IN), DIMENSION(fbdataout%nobs) :: &
882	& iset ! Set number for a given obs.
883	INTEGER, INTENT(IN), DIMENSION(fbdataout%nobs) :: &
884	& inum ! Number within set for an obs
885	INTEGER, INTENT(IN), DIMENSION(fbdataout%nobs) :: &
886	& iind ! Indices for copying.
887	!! * Local variables
888
889	INTEGER :: js
890	INTEGER :: jo
891	INTEGER :: jv
892	INTEGER :: je
893	INTEGER :: ji
894	INTEGER :: jk
895	INTEGER :: jq
896
897	! Check allocation status of fbdatain
898
899	DO js = 1, nsets
900	IF ( .NOT. fbdatain(js)%lalloc ) THEN
901	CALL fatal_error( 'merge_obfbdata: input data not allocated', &
902	& __LINE__ )
903	ENDIF
904	END DO
905
906	! Check allocation status of fbdataout
907
908	IF ( .NOT.fbdataout%lalloc ) THEN
909	CALL fatal_error( 'merge_obfbdata: output data not allocated', &
910	& __LINE__ )
911	ENDIF
912
913	! Merge various names
914
915	DO jv = 1, fbdatain(1)%nvar
916	fbdataout%cname(jv) = fbdatain(1)%cname(jv)
917	fbdataout%coblong(jv) = fbdatain(1)%coblong(jv)
918	fbdataout%cobunit(jv) = fbdatain(1)%cobunit(jv)
919	IF ( fbdatain(1)%lgrid ) THEN
920	fbdataout%cgrid(jv) = fbdatain(1)%cgrid(jv)
921	ENDIF
922	END DO
923	DO jv = 1, fbdatain(1)%nadd
924	fbdataout%caddname(jv) = fbdatain(1)%caddname(jv)
925	END DO
926	DO jv = 1, fbdatain(1)%nvar
927	DO je = 1, fbdatain(1)%nadd
928	fbdataout%caddlong(je,jv) = fbdatain(1)%caddlong(je,jv)
929	fbdataout%caddunit(je,jv) = fbdatain(1)%caddunit(je,jv)
930	END DO
931	END DO
932	DO jv = 1, fbdatain(1)%next
933	fbdataout%cextname(jv) = fbdatain(1)%cextname(jv)
934	fbdataout%cextlong(jv) = fbdatain(1)%cextlong(jv)
935	fbdataout%cextunit(jv) = fbdatain(1)%cextunit(jv)
936	END DO
937	fbdataout%cdjuldref = fbdatain(1)%cdjuldref
938
939	! Loop over total views
940
941	DO jo = 1, fbdataout%nobs
942
943	js = iset(iind(jo))
944	ji = inum(iind(jo))
945
946	! Merge the header data
947
948	fbdataout%cdwmo(jo) = fbdatain(js)%cdwmo(ji)
949	fbdataout%cdtyp(jo) = fbdatain(js)%cdtyp(ji)
950	fbdataout%ioqc(jo) = fbdatain(js)%ioqc(ji)
951	fbdataout%ipqc(jo) = fbdatain(js)%ipqc(ji)
952	fbdataout%itqc(jo) = fbdatain(js)%itqc(ji)
953	fbdataout%plam(jo) = fbdatain(js)%plam(ji)
954	fbdataout%pphi(jo) = fbdatain(js)%pphi(ji)
955	fbdataout%ptim(jo) = fbdatain(js)%ptim(ji)
956	fbdataout%kindex(jo) = fbdatain(js)%kindex(ji)
957	DO jq = 1, fbdatain(js)%nqcf
958	fbdataout%ioqcf(jq,jo) = fbdatain(js)%ioqcf(jq,ji)
959	fbdataout%ipqcf(jq,jo) = fbdatain(js)%ipqcf(jq,ji)
960	fbdataout%itqcf(jq,jo) = fbdatain(js)%itqcf(jq,ji)
961	END DO
962	DO jk = 1, fbdatain(js)%nlev
963	fbdataout%pdep(jk,jo) = fbdatain(js)%pdep(jk,ji)
964	fbdataout%idqc(jk,jo) = fbdatain(js)%idqc(jk,ji)
965	DO jq = 1, fbdatain(js)%nqcf
966	fbdataout%idqcf(jq,jk,jo) = fbdatain(js)%idqcf(jq,jk,ji)
967	END DO
968	END DO
969
970	! Merge the variable data
971
972	DO jv = 1, fbdatain(js)%nvar
973	fbdataout%ivqc(jo,jv) = fbdatain(js)%ivqc(ji,jv)
974	DO jq = 1, fbdatain(js)%nqcf
975	fbdataout%ivqcf(jq,jo,jv) = fbdatain(js)%ivqcf(jq,ji,jv)
976	END DO
977	DO jk = 1, fbdatain(js)%nlev
978	fbdataout%ivlqc(jk,jo,jv) = fbdatain(js)%ivlqc(jk,ji,jv)
979	fbdataout%pob(jk,jo,jv) = fbdatain(js)%pob(jk,ji,jv)
980	DO jq = 1, fbdatain(js)%nqcf
981	fbdataout%ivlqcf(jq,jk,jo,jv) = &
982	& fbdatain(js)%ivlqcf(jq,jk,ji,jv)
983	END DO
984	END DO
985	END DO
986
987	! Merge grid information
988
989	IF ( fbdatain(js)%lgrid ) THEN
990	DO jv = 1, fbdatain(js)%nvar
991	fbdataout%cgrid(jv) = fbdatain(js)%cgrid(jv)
992	fbdataout%iproc(jo,jv) = fbdatain(js)%iproc(ji,jv)
993	fbdataout%iobsi(jo,jv) = fbdatain(js)%iobsi(ji,jv)
994	fbdataout%iobsj(jo,jv) = fbdatain(js)%iobsj(ji,jv)
995	DO jk = 1, fbdatain(js)%nlev
996	fbdataout%iobsk(jk,jo,jv) = fbdatain(js)%iobsk(jk,ji,jv)
997	END DO
998	END DO
999	ENDIF
1000
1001	! Merge additional information
1002
1003	DO jv = 1, fbdatain(js)%nvar
1004	DO je = 1, fbdatain(js)%nadd
1005	DO jk = 1, fbdatain(js)%nlev
1006	fbdataout%padd(jk,jo,je,jv) = fbdatain(js)%padd(jk,ji,je,jv)
1007	END DO
1008	END DO
1009	END DO
1010
1011	! Merge extra information
1012
1013	DO je = 1, fbdatain(js)%next
1014	DO jk = 1, fbdatain(js)%nlev
1015	fbdataout%pext(jk,jo,je) = fbdatain(js)%pext(jk,ji,je)
1016	END DO
1017	END DO
1018
1019	END DO
1020
1021	END SUBROUTINE merge_obfbdata
1022
1023	SUBROUTINE write_obfbdata( cdfilename, fbdata )
1024	!!----------------------------------------------------------------------
1025	!! * ROUTINE write_obfbdata *
1026	!!
1027	!! ** Purpose : Write an obfbdata structure into a netCDF file.
1028	!!
1029	!! ** Method :
1030	!!
1031	!! ** Action :
1032	!!
1033	!!----------------------------------------------------------------------
1034	!! * Arguments
1035	CHARACTER(len=*) :: cdfilename ! Output filename
1036	TYPE(obfbdata) :: fbdata ! obsfbdata structure
1037	!! * Local variables
1038	CHARACTER(LEN=14), PARAMETER :: cpname = 'write_obfbdata'
1039	! Dimension ids
1040	INTEGER :: idfile
1041	INTEGER :: idodim
1042	INTEGER :: idldim
1043	INTEGER :: idvdim
1044	INTEGER :: idadim
1045	INTEGER :: idedim
1046	INTEGER :: idsndim
1047	INTEGER :: idsgdim
1048	INTEGER :: idswdim
1049	INTEGER :: idstdim
1050	INTEGER :: idjddim
1051	INTEGER :: idqcdim
1052	INTEGER :: idvard
1053	INTEGER :: idaddd
1054	INTEGER :: idextd
1055	INTEGER :: idcdwmo
1056	INTEGER :: idcdtyp
1057	INTEGER :: idplam
1058	INTEGER :: idpphi
1059	INTEGER :: idpdep
1060	INTEGER :: idptim
1061	INTEGER :: idptimr
1062	INTEGER :: idioqc
1063	INTEGER :: idioqcf
1064	INTEGER :: idipqc
1065	INTEGER :: idipqcf
1066	INTEGER :: iditqc
1067	INTEGER :: iditqcf
1068	INTEGER :: ididqc
1069	INTEGER :: ididqcf
1070	INTEGER :: idkindex
1071	INTEGER, DIMENSION(fbdata%nvar) :: &
1072	& idpob, &
1073	& idivqc, &
1074	& idivqcf, &
1075	& idivlqc, &
1076	& idivlqcf, &
1077	& idiobsi, &
1078	& idiobsj, &
1079	& idiobsk, &
1080	& idcgrid
1081	INTEGER, DIMENSION(fbdata%nadd,fbdata%nvar) :: idpadd
1082	INTEGER, DIMENSION(fbdata%next) :: idpext
1083	INTEGER, DIMENSION(1) :: incdim1
1084	INTEGER, DIMENSION(2) :: incdim2
1085	INTEGER, DIMENSION(3) :: incdim3
1086	INTEGER, DIMENSION(4) :: incdim4
1087
1088	INTEGER :: jv
1089	INTEGER :: je
1090	INTEGER :: ioldfill
1091	CHARACTER(len=nf90_max_name) :: &
1092	& cdtmp
1093	CHARACTER(len=16), PARAMETER :: &
1094	& cdqcconv = 'q where q =[0,9]'
1095	CHARACTER(len=24), PARAMETER :: &
1096	& cdqcfconv = 'NEMOVAR flag conventions'
1097	CHARACTER(len=ilenlong) :: &
1098	& cdltmp
1099
1100	! Open output filename
1101
1102	CALL chkerr( nf90_create( TRIM( cdfilename ), nf90_clobber, idfile ), &
1103	& cpname, __LINE__ )
1104	CALL chkerr( nf90_set_fill( idfile, nf90_nofill, ioldfill ), &
1105	& cpname, __LINE__ )
1106	CALL chkerr( nf90_put_att( idfile, nf90_global, 'title', &
1107	& 'NEMO observation operator output' ), &
1108	& cpname, __LINE__ )
1109	CALL chkerr( nf90_put_att( idfile, nf90_global, 'Convention', &
1110	& 'NEMO unified observation operator output' ),&
1111	& cpname,__LINE__ )
1112
1113	! Create the dimensions
1114
1115	CALL chkerr( nf90_def_dim( idfile, 'N_OBS' , fbdata%nobs, idodim ), &
1116	& cpname,__LINE__ )
1117	CALL chkerr( nf90_def_dim( idfile, 'N_LEVELS', fbdata%nlev, idldim ), &
1118	& cpname,__LINE__ )
1119	CALL chkerr( nf90_def_dim( idfile, 'N_VARS', fbdata%nvar, idvdim ), &
1120	& cpname,__LINE__ )
1121	CALL chkerr( nf90_def_dim( idfile, 'N_QCF', fbdata%nqcf, idqcdim ),&
1122	& cpname,__LINE__ )
1123	IF ( fbdata%nadd > 0 ) THEN
1124	CALL chkerr( nf90_def_dim( idfile, 'N_ENTRIES', fbdata%nadd, idadim ), &
1125	& cpname,__LINE__ )
1126	ENDIF
1127	IF ( fbdata%next > 0 ) THEN
1128	CALL chkerr( nf90_def_dim( idfile, 'N_EXTRA', fbdata%next, idedim ), &
1129	& cpname,__LINE__ )
1130	ENDIF
1131	CALL chkerr( nf90_def_dim( idfile, 'STRINGNAM', ilenname, idsndim ), &
1132	& cpname,__LINE__ )
1133	IF (fbdata%lgrid) THEN
1134	CALL chkerr( nf90_def_dim( idfile, 'STRINGGRID', ilengrid, idsgdim ),&
1135	& cpname,__LINE__ )
1136	ENDIF
1137	CALL chkerr( nf90_def_dim( idfile, 'STRINGWMO', ilenwmo, idswdim ), &
1138	& cpname,__LINE__ )
1139	CALL chkerr( nf90_def_dim( idfile, 'STRINGTYP', ilentyp, idstdim ), &
1140	& cpname,__LINE__ )
1141	CALL chkerr( nf90_def_dim( idfile, 'STRINGJULD', ilenjuld, idjddim ), &
1142	& cpname,__LINE__ )
1143
1144	! Define netCDF variables for header information
1145
1146	incdim2(1) = idsndim
1147	incdim2(2) = idvdim
1148
1149	CALL chkerr( nf90_def_var( idfile, 'VARIABLES', nf90_char, incdim2, &
1150	& idvard ), cpname, __LINE__ )
1151	CALL putvaratt_obfbdata( idfile, idvard, &
1152	& 'List of variables in feedback files' )
1153
1154	IF ( fbdata%nadd > 0 ) THEN
1155	incdim2(1) = idsndim
1156	incdim2(2) = idadim
1157	CALL chkerr( nf90_def_var( idfile, 'ENTRIES', nf90_char, incdim2, &
1158	& idaddd ), cpname, __LINE__ )
1159	CALL putvaratt_obfbdata( idfile, idaddd, &
1160	& 'List of additional entries for each '// &
1161	& 'variable in feedback files' )
1162	ENDIF
1163
1164	IF ( fbdata%next > 0 ) THEN
1165	incdim2(1) = idsndim
1166	incdim2(2) = idedim
1167	CALL chkerr( nf90_def_var( idfile, 'EXTRA', nf90_char, incdim2, &
1168	& idextd ), cpname, __LINE__ )
1169	CALL putvaratt_obfbdata( idfile, idextd, &
1170	& 'List of extra variables' )
1171	ENDIF
1172
1173	incdim2(1) = idswdim
1174	incdim2(2) = idodim
1175	CALL chkerr( nf90_def_var( idfile, 'STATION_IDENTIFIER', &
1176	& nf90_char, incdim2, &
1177	& idcdwmo ), cpname, __LINE__ )
1178	CALL putvaratt_obfbdata( idfile, idcdwmo, &
1179	& 'Station identifier' )
1180	incdim2(1) = idstdim
1181	incdim2(2) = idodim
1182	CALL chkerr( nf90_def_var( idfile, 'STATION_TYPE', &
1183	& nf90_char, incdim2, &
1184	& idcdtyp ), cpname, __LINE__ )
1185	CALL putvaratt_obfbdata( idfile, idcdtyp, &
1186	& 'Code instrument type' )
1187	incdim1(1) = idodim
1188	CALL chkerr( nf90_def_var( idfile, 'LONGITUDE', &
1189	& nf90_double, incdim1, &
1190	& idplam ), cpname, __LINE__ )
1191	CALL putvaratt_obfbdata( idfile, idplam, &
1192	& 'Longitude', cdunits = 'degrees_east', &
1193	& rfillvalue = fbrmdi )
1194	CALL chkerr( nf90_def_var( idfile, 'LATITUDE', &
1195	& nf90_double, incdim1, &
1196	& idpphi ), cpname, __LINE__ )
1197	CALL putvaratt_obfbdata( idfile, idpphi, &
1198	& 'Latitude', cdunits = 'degrees_north', &
1199	& rfillvalue = fbrmdi )
1200	incdim2(1) = idldim
1201	incdim2(2) = idodim
1202	CALL chkerr( nf90_def_var( idfile, 'DEPTH', &
1203	& nf90_double, incdim2, &
1204	& idpdep ), cpname, __LINE__ )
1205	CALL putvaratt_obfbdata( idfile, idpdep, &
1206	& 'Depth', cdunits = 'metre', &
1207	& rfillvalue = fbrmdi )
1208	incdim3(1) = idqcdim
1209	incdim3(2) = idldim
1210	incdim3(3) = idodim
1211	CALL chkerr( nf90_def_var( idfile, 'DEPTH_QC', &
1212	& nf90_int, incdim2, &
1213	& ididqc ), cpname, __LINE__ )
1214	CALL putvaratt_obfbdata( idfile, ididqc, &
1215	& 'Quality on depth', &
1216	& conventions = cdqcconv, &
1217	& ifillvalue = 0 )
1218	CALL chkerr( nf90_def_var( idfile, 'DEPTH_QC_FLAGS', &
1219	& nf90_int, incdim3, &
1220	& ididqcf ), cpname, __LINE__ )
1221	CALL putvaratt_obfbdata( idfile, ididqcf, &
1222	& 'Quality flags on depth', &
1223	& conventions = cdqcfconv )
1224	CALL chkerr( nf90_def_var( idfile, 'JULD', &
1225	& nf90_double, incdim1, &
1226	& idptim ), cpname, __LINE__ )
1227	CALL putvaratt_obfbdata( idfile, idptim, &
1228	& 'Julian day', &
1229	& cdunits = 'days since JULD_REFERENCE', &
1230	& conventions = 'relative julian days with '// &
1231	& 'decimal part (as parts of day)', &
1232	& rfillvalue = fbrmdi )
1233	incdim1(1) = idjddim
1234	CALL chkerr( nf90_def_var( idfile, 'JULD_REFERENCE', &
1235	& nf90_char, incdim1, &
1236	& idptimr ), cpname, __LINE__ )
1237	CALL putvaratt_obfbdata( idfile, idptimr, &
1238	& 'Date of reference for julian days ', &
1239	& conventions = 'YYYYMMDDHHMMSS' )
1240	incdim1(1) = idodim
1241	CALL chkerr( nf90_def_var( idfile, 'OBSERVATION_QC', &
1242	& nf90_int, incdim1, &
1243	& idioqc ), cpname, __LINE__ )
1244	CALL putvaratt_obfbdata( idfile, idioqc, &
1245	& 'Quality on observation', &
1246	& conventions = cdqcconv, &
1247	& ifillvalue = 0 )
1248	incdim2(1) = idqcdim
1249	incdim2(2) = idodim
1250	CALL chkerr( nf90_def_var( idfile, 'OBSERVATION_QC_FLAGS', &
1251	& nf90_int, incdim2, &
1252	& idioqcf ), cpname, __LINE__ )
1253	CALL putvaratt_obfbdata( idfile, idioqcf, &
1254	& 'Quality flags on observation', &
1255	& conventions = cdqcfconv, &
1256	& ifillvalue = 0 )
1257	CALL chkerr( nf90_def_var( idfile, 'POSITION_QC', &
1258	& nf90_int, incdim1, &
1259	& idipqc ), cpname, __LINE__ )
1260	CALL putvaratt_obfbdata( idfile, idipqc, &
1261	& 'Quality on position (latitude and longitude)', &
1262	& conventions = cdqcconv, &
1263	& ifillvalue = 0 )
1264	CALL chkerr( nf90_def_var( idfile, 'POSITION_QC_FLAGS', &
1265	& nf90_int, incdim2, &
1266	& idipqcf ), cpname, __LINE__ )
1267	CALL putvaratt_obfbdata( idfile, idipqcf, &
1268	& 'Quality flags on position', &
1269	& conventions = cdqcfconv, &
1270	& ifillvalue = 0 )
1271	CALL chkerr( nf90_def_var( idfile, 'JULD_QC', &
1272	& nf90_int, incdim1, &
1273	& iditqc ), cpname, __LINE__ )
1274	CALL putvaratt_obfbdata( idfile, iditqc, &
1275	& 'Quality on date and time', &
1276	& conventions = cdqcconv, &
1277	& ifillvalue = 0 )
1278	CALL chkerr( nf90_def_var( idfile, 'JULD_QC_FLAGS', &
1279	& nf90_int, incdim2, &
1280	& iditqcf ), cpname, __LINE__ )
1281	CALL putvaratt_obfbdata( idfile, iditqcf, &
1282	& 'Quality flags on date and time', &
1283	& conventions = cdqcfconv, &
1284	& ifillvalue = 0 )
1285	CALL chkerr( nf90_def_var( idfile, 'ORIGINAL_FILE_INDEX', &
1286	& nf90_int, incdim1, &
1287	& idkindex ), cpname, __LINE__ )
1288	CALL putvaratt_obfbdata( idfile, idkindex, &
1289	& 'Index in original data file', &
1290	& ifillvalue = fbimdi )
1291
1292	! Define netCDF variables for individual variables
1293
1294	DO jv = 1, fbdata%nvar
1295
1296	incdim1(1) = idodim
1297	incdim2(1) = idldim
1298	incdim2(2) = idodim
1299	WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_OBS'
1300	CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_float, &
1301	& incdim2, idpob(jv) ), &
1302	& cpname, __LINE__ )
1303	CALL putvaratt_obfbdata( idfile, idpob(jv), &
1304	& fbdata%coblong(jv), &
1305	& cdunits = fbdata%cobunit(jv), &
1306	& rfillvalue = fbrmdi )
1307
1308	IF ( fbdata%nadd > 0 ) THEN
1309	DO je = 1, fbdata%nadd
1310	WRITE(cdtmp,'(3A)') TRIM(fbdata%cname(jv)),'_',&
1311	& TRIM(fbdata%caddname(je))
1312	CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_float, &
1313	& incdim2, idpadd(je,jv) ), &
1314	& cpname, __LINE__ )
1315	CALL putvaratt_obfbdata( idfile, idpadd(je,jv), &
1316	& fbdata%caddlong(je,jv), &
1317	& cdunits = fbdata%caddunit(je,jv), &
1318	& rfillvalue = fbrmdi )
1319	END DO
1320	ENDIF
1321
1322	cdltmp = fbdata%coblong(jv)
1323	IF (( cdltmp(1:1) >= 'A' ).AND.( cdltmp(1:1) <= 'Z' )) &
1324	& cdltmp(1:1) = ACHAR(IACHAR(cdltmp(1:1)) + 32)
1325	WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC'
1326	CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, &
1327	& incdim1, idivqc(jv) ), &
1328	& cpname, __LINE__ )
1329	CALL putvaratt_obfbdata( idfile, idivqc(jv), &
1330	& 'Quality on '//cdltmp, &
1331	& conventions = cdqcconv, &
1332	& ifillvalue = 0 )
1333	incdim2(1) = idqcdim
1334	incdim2(2) = idodim
1335	WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC_FLAGS'
1336	CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, &
1337	& incdim2, idivqcf(jv) ), &
1338	& cpname, __LINE__ )
1339	CALL putvaratt_obfbdata( idfile, idivqcf(jv), &
1340	& 'Quality flags on '//cdltmp, &
1341	& conventions = cdqcfconv, &
1342	& ifillvalue = 0 )
1343	incdim2(1) = idldim
1344	incdim2(2) = idodim
1345	WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC'
1346	CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, &
1347	& incdim2, idivlqc(jv) ), &
1348	& cpname, __LINE__ )
1349	CALL putvaratt_obfbdata( idfile, idivlqc(jv), &
1350	& 'Quality for each level on '//cdltmp, &
1351	& conventions = cdqcconv, &
1352	& ifillvalue = 0 )
1353	incdim3(1) = idqcdim
1354	incdim3(2) = idldim
1355	incdim3(3) = idodim
1356	WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC_FLAGS'
1357	CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, &
1358	& incdim3, idivlqcf(jv) ), &
1359	& cpname, __LINE__ )
1360	CALL putvaratt_obfbdata( idfile, idivlqcf(jv), &
1361	& 'Quality flags for each level on '//&
1362	& cdltmp, &
1363	& conventions = cdqcfconv, &
1364	& ifillvalue = 0 )
1365
1366	IF (fbdata%lgrid) THEN
1367	incdim2(1) = idldim
1368	incdim2(2) = idodim
1369	WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSI'
1370	CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, &
1371	& incdim1, idiobsi(jv) ), &
1372	& cpname, __LINE__ )
1373	CALL putvaratt_obfbdata( idfile, idiobsi(jv), &
1374	& 'ORCA grid search I coordinate')
1375	WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSJ'
1376	CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, &
1377	& incdim1, idiobsj(jv) ), &
1378	& cpname, __LINE__ )
1379	CALL putvaratt_obfbdata( idfile, idiobsj(jv), &
1380	& 'ORCA grid search J coordinate')
1381	WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSK'
1382	CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, &
1383	& incdim2, idiobsk(jv) ), &
1384	& cpname, __LINE__ )
1385	CALL putvaratt_obfbdata( idfile, idiobsk(jv), &
1386	& 'ORCA grid search K coordinate')
1387	incdim1(1) = idsgdim
1388	WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_GRID'
1389	CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_char, incdim1, &
1390	& idcgrid(jv) ), cpname, __LINE__ )
1391	CALL putvaratt_obfbdata( idfile, idcgrid(jv), &
1392	& 'ORCA grid search grid (T,U,V)')
1393	ENDIF
1394
1395	END DO
1396
1397	IF ( fbdata%next > 0 ) THEN
1398	DO je = 1, fbdata%next
1399	incdim2(1) = idldim
1400	incdim2(2) = idodim
1401	WRITE(cdtmp,'(A)') TRIM(fbdata%cextname(je))
1402	CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_float, &
1403	& incdim2, idpext(je) ), &
1404	& cpname, __LINE__ )
1405	CALL putvaratt_obfbdata( idfile, idpext(je), &
1406	& fbdata%cextlong(je), &
1407	& cdunits = fbdata%cextunit(je), &
1408	& rfillvalue = fbrmdi )
1409	END DO
1410	ENDIF
1411
1412	! Stop definitions
1413
1414	CALL chkerr( nf90_enddef( idfile ), cpname, __LINE__ )
1415
1416	! Write the variables
1417
1418	CALL chkerr( nf90_put_var( idfile, idvard, fbdata%cname ), &
1419	& cpname, __LINE__ )
1420
1421	IF ( fbdata%nadd > 0 ) THEN
1422	CALL chkerr( nf90_put_var( idfile, idaddd, fbdata%caddname ), &
1423	& cpname, __LINE__ )
1424	ENDIF
1425
1426	IF ( fbdata%next > 0 ) THEN
1427	CALL chkerr( nf90_put_var( idfile, idextd, fbdata%cextname ), &
1428	& cpname, __LINE__ )
1429	ENDIF
1430
1431	CALL chkerr( nf90_put_var( idfile, idptimr, fbdata%cdjuldref ), &
1432	& cpname, __LINE__ )
1433
1434	! Only write the data if observation is available
1435
1436	IF ( fbdata%nobs > 0 ) THEN
1437
1438	CALL chkerr( nf90_put_var( idfile, idcdwmo, fbdata%cdwmo ), &
1439	& cpname, __LINE__ )
1440	CALL chkerr( nf90_put_var( idfile, idcdtyp, fbdata%cdtyp ), &
1441	& cpname, __LINE__ )
1442	CALL chkerr( nf90_put_var( idfile, idplam, fbdata%plam ), &
1443	& cpname, __LINE__ )
1444	CALL chkerr( nf90_put_var( idfile, idpphi, fbdata%pphi ), &
1445	& cpname, __LINE__ )
1446	CALL chkerr( nf90_put_var( idfile, idpdep, fbdata%pdep ), &
1447	& cpname, __LINE__ )
1448	CALL chkerr( nf90_put_var( idfile, idptim, fbdata%ptim ), &
1449	& cpname, __LINE__ )
1450	CALL chkerr( nf90_put_var( idfile, idioqc, fbdata%ioqc ), &
1451	& cpname, __LINE__ )
1452	CALL chkerr( nf90_put_var( idfile, idioqcf, fbdata%ioqcf ), &
1453	& cpname, __LINE__ )
1454	CALL chkerr( nf90_put_var( idfile, idipqc, fbdata%ipqc ), &
1455	& cpname, __LINE__ )
1456	CALL chkerr( nf90_put_var( idfile, idipqcf, fbdata%ipqcf ), &
1457	& cpname, __LINE__ )
1458	CALL chkerr( nf90_put_var( idfile, iditqc, fbdata%itqc ), &
1459	& cpname, __LINE__ )
1460	CALL chkerr( nf90_put_var( idfile, iditqcf, fbdata%itqcf ), &
1461	& cpname, __LINE__ )
1462	CALL chkerr( nf90_put_var( idfile, ididqc, fbdata%idqc ), &
1463	& cpname, __LINE__ )
1464	CALL chkerr( nf90_put_var( idfile, ididqcf, fbdata%idqcf ), &
1465	& cpname, __LINE__ )
1466	CALL chkerr( nf90_put_var( idfile, idkindex, fbdata%kindex ), &
1467	& cpname, __LINE__ )
1468
1469	DO jv = 1, fbdata%nvar
1470	CALL chkerr( nf90_put_var( idfile, idpob(jv), fbdata%pob(:,:,jv) ), &
1471	& cpname, __LINE__ )
1472	IF ( fbdata%nadd > 0 ) THEN
1473	DO je = 1, fbdata%nadd
1474	CALL chkerr( nf90_put_var( idfile, idpadd(je,jv), &
1475	& fbdata%padd(:,:,je,jv) ), &
1476	& cpname, __LINE__ )
1477	END DO
1478	ENDIF
1479	CALL chkerr( nf90_put_var( idfile, idivqc(jv), &
1480	& fbdata%ivqc(:,jv) ),&
1481	& cpname, __LINE__ )
1482	CALL chkerr( nf90_put_var( idfile, idivqcf(jv), &
1483	& fbdata%ivqcf(:,:,jv) ),&
1484	& cpname, __LINE__ )
1485	CALL chkerr( nf90_put_var( idfile, idivlqc(jv), &
1486	& fbdata%ivlqc(:,:,jv) ),&
1487	& cpname, __LINE__ )
1488	CALL chkerr( nf90_put_var( idfile, idivlqcf(jv), &
1489	& fbdata%ivlqcf(:,:,:,jv) ),&
1490	& cpname, __LINE__ )
1491	IF (fbdata%lgrid) THEN
1492	CALL chkerr( nf90_put_var( idfile, idiobsi(jv), &
1493	& fbdata%iobsi(:,jv) ),&
1494	& cpname, __LINE__ )
1495	CALL chkerr( nf90_put_var( idfile, idiobsj(jv), &
1496	& fbdata%iobsj(:,jv) ),&
1497	& cpname, __LINE__ )
1498	CALL chkerr( nf90_put_var( idfile, idiobsk(jv), &
1499	& fbdata%iobsk(:,:,jv) ),&
1500	& cpname, __LINE__ )
1501	CALL chkerr( nf90_put_var( idfile, idcgrid(jv), &
1502	& fbdata%cgrid(jv) ), &
1503	& cpname, __LINE__ )
1504	ENDIF
1505	END DO
1506
1507	IF ( fbdata%next > 0 ) THEN
1508	DO je = 1, fbdata%next
1509	CALL chkerr( nf90_put_var( idfile, idpext(je), &
1510	& fbdata%pext(:,:,je) ), &
1511	& cpname, __LINE__ )
1512	END DO
1513	ENDIF
1514
1515	ENDIF
1516
1517	! Close the file
1518
1519	CALL chkerr( nf90_close( idfile ), cpname, __LINE__ )
1520
1521
1522	END SUBROUTINE write_obfbdata
1523
1524	SUBROUTINE putvaratt_obfbdata( idfile, idvar, cdlongname, cdunits, &
1525	& conventions, cfillvalue, &
1526	& ifillvalue, rfillvalue )
1527	!!----------------------------------------------------------------------
1528	!! * ROUTINE putvaratt_obfbdata *
1529	!!
1530	!! ** Purpose : Write netcdf attributes for variable
1531	!!
1532	!! ** Method :
1533	!!
1534	!! ** Action :
1535	!!
1536	!!----------------------------------------------------------------------
1537	!! * Arguments
1538	INTEGER , INTENT(IN) :: idfile ! File netcdf id.
1539	INTEGER , INTENT(IN) :: idvar ! Variable netcdf id.
1540	CHARACTER(len=*) , INTENT(IN) :: cdlongname ! Long name for variable
1541	CHARACTER(len=*), OPTIONAL , INTENT(IN) :: cdunits ! Units for variable
1542	CHARACTER(len=*), OPTIONAL , INTENT(IN) :: cfillvalue ! Fill value for character variables
1543	INTEGER, OPTIONAL , INTENT(IN) :: ifillvalue ! Fill value for integer variables
1544	REAL(kind=sp), OPTIONAL , INTENT(IN) :: rfillvalue ! Fill value for real variables
1545	CHARACTER(len=*), OPTIONAL, INTENT(IN) :: conventions ! Conventions for variable
1546	!! * Local variables
1547	CHARACTER(LEN=18), PARAMETER :: &
1548	& cpname = 'putvaratt_obfbdata'
1549
1550	CALL chkerr( nf90_put_att( idfile, idvar, 'long_name', &
1551	& TRIM(cdlongname) ), &
1552	& cpname, __LINE__ )
1553
1554	IF ( PRESENT(cdunits) ) THEN
1555
1556	CALL chkerr( nf90_put_att( idfile, idvar, 'units', &
1557	& TRIM(cdunits) ), &
1558	& cpname, __LINE__ )
1559
1560	ENDIF
1561
1562	IF ( PRESENT(conventions) ) THEN
1563
1564	CALL chkerr( nf90_put_att( idfile, idvar, 'Conventions', &
1565	& TRIM(conventions) ), &
1566	& cpname, __LINE__ )
1567
1568	ENDIF
1569
1570	IF ( PRESENT(cfillvalue) ) THEN
1571
1572	CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', &
1573	& TRIM(cfillvalue) ), &
1574	& cpname, __LINE__ )
1575
1576	ENDIF
1577
1578	IF ( PRESENT(ifillvalue) ) THEN
1579
1580	CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', &
1581	& ifillvalue ), &
1582	& cpname, __LINE__ )
1583
1584	ENDIF
1585
1586	IF ( PRESENT(rfillvalue) ) THEN
1587
1588	CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', &
1589	& rfillvalue ), &
1590	& cpname, __LINE__ )
1591
1592	ENDIF
1593
1594	END SUBROUTINE putvaratt_obfbdata
1595
1596	SUBROUTINE read_obfbdata( cdfilename, fbdata, ldgrid )
1597	!!----------------------------------------------------------------------
1598	!! * ROUTINE read_obfbdata *
1599	!!
1600	!! ** Purpose : Read an obfbdata structure from a netCDF file.
1601	!!
1602	!! ** Method :
1603	!!
1604	!! ** Action :
1605	!!
1606	!!----------------------------------------------------------------------
1607	!! * Arguments
1608	CHARACTER(len=*), INTENT(IN) :: cdfilename ! Input filename
1609	TYPE(obfbdata) :: fbdata ! obsfbdata structure
1610	LOGICAL, OPTIONAL, INTENT(IN) :: ldgrid ! Allow forcing of grid info
1611	!! * Local variables
1612	CHARACTER(LEN=14), PARAMETER :: cpname = 'read_obfbdata'
1613	INTEGER :: idfile
1614	INTEGER :: idodim
1615	INTEGER :: idldim
1616	INTEGER :: idvdim
1617	INTEGER :: idadim
1618	INTEGER :: idedim
1619	INTEGER :: idgdim
1620	INTEGER :: idvard
1621	INTEGER :: idaddd
1622	INTEGER :: idextd
1623	INTEGER :: idcdwmo
1624	INTEGER :: idcdtyp
1625	INTEGER :: idplam
1626	INTEGER :: idpphi
1627	INTEGER :: idpdep
1628	INTEGER :: idptim
1629	INTEGER :: idptimr
1630	INTEGER :: idioqc
1631	INTEGER :: idioqcf
1632	INTEGER :: idipqc
1633	INTEGER :: idipqcf
1634	INTEGER :: ididqc
1635	INTEGER :: ididqcf
1636	INTEGER :: iditqc
1637	INTEGER :: iditqcf
1638	INTEGER :: idkindex
1639	INTEGER, DIMENSION(:), ALLOCATABLE :: &
1640	& idpob, &
1641	& idivqc, &
1642	& idivqcf, &
1643	& idivlqc, &
1644	& idivlqcf, &
1645	& idiobsi, &
1646	& idiobsj, &
1647	& idiobsk, &
1648	& idcgrid, &
1649	& idpext
1650	INTEGER, DIMENSION(:,:), ALLOCATABLE :: &
1651	& idpadd
1652	INTEGER :: jv
1653	INTEGER :: je
1654	INTEGER :: nvar
1655	INTEGER :: nobs
1656	INTEGER :: nlev
1657	INTEGER :: nadd
1658	INTEGER :: next
1659	LOGICAL :: lgrid
1660	CHARACTER(len=NF90_MAX_NAME) :: cdtmp
1661
1662	! Check allocation status and deallocate previous allocated structures
1663
1664	IF ( fbdata%lalloc ) THEN
1665	CALL dealloc_obfbdata( fbdata )
1666	ENDIF
1667
1668	! Open input filename
1669
1670	CALL chkerr( nf90_open( TRIM( cdfilename ), nf90_nowrite, idfile ), &
1671	& cpname, __LINE__ )
1672
1673	! Get input dimensions
1674
1675	CALL chkerr( nf90_inq_dimid( idfile, 'N_OBS' , idodim ), &
1676	& cpname,__LINE__ )
1677	CALL chkerr( nf90_inquire_dimension( idfile, idodim, len=nobs ), &
1678	& cpname,__LINE__ )
1679	CALL chkerr( nf90_inq_dimid( idfile, 'N_LEVELS', idldim ), &
1680	& cpname,__LINE__ )
1681	CALL chkerr( nf90_inquire_dimension( idfile, idldim, len=nlev ), &
1682	& cpname,__LINE__ )
1683	CALL chkerr( nf90_inq_dimid( idfile, 'N_VARS', idvdim ), &
1684	& cpname,__LINE__ )
1685	CALL chkerr( nf90_inquire_dimension( idfile, idvdim, len=nvar ), &
1686	& cpname,__LINE__ )
1687	IF ( nf90_inq_dimid( idfile, 'N_ENTRIES', idadim ) == 0 ) THEN
1688	CALL chkerr( nf90_inquire_dimension( idfile, idadim, len=nadd ), &
1689	& cpname,__LINE__ )
1690	ELSE
1691	nadd = 0
1692	ENDIF
1693	IF ( nf90_inq_dimid( idfile, 'N_EXTRA', idedim ) == 0 ) THEN
1694	CALL chkerr( nf90_inquire_dimension( idfile, idedim, len=next ), &
1695	& cpname,__LINE__ )
1696	ELSE
1697	next = 0
1698	ENDIF
1699	!
1700	! Check if this input file contains grid search informations
1701	!
1702	lgrid = ( nf90_inq_dimid( idfile, 'STRINGGRID', idgdim ) == 0 )
1703
1704	! Allocate data structure
1705
1706	IF ( PRESENT(ldgrid) ) THEN
1707	CALL alloc_obfbdata( fbdata, nvar, nobs, nlev, nadd, next, &
1708	& lgrid.OR.ldgrid )
1709	ELSE
1710	CALL alloc_obfbdata( fbdata, nvar, nobs, nlev, nadd, next, &
1711	& lgrid )
1712	ENDIF
1713
1714	! Allocate netcdf identifiers
1715
1716	ALLOCATE( &
1717	& idpob(fbdata%nvar), &
1718	& idivqc(fbdata%nvar), &
1719	& idivqcf(fbdata%nvar), &
1720	& idivlqc(fbdata%nvar), &
1721	& idivlqcf(fbdata%nvar), &
1722	& idiobsi(fbdata%nvar), &
1723	& idiobsj(fbdata%nvar), &
1724	& idiobsk(fbdata%nvar), &
1725	& idcgrid(fbdata%nvar) &
1726	& )
1727	IF ( fbdata%nadd > 0 ) THEN
1728	ALLOCATE( &
1729	& idpadd(fbdata%nadd,fbdata%nvar) &
1730	& )
1731	ENDIF
1732	IF ( fbdata%next > 0 ) THEN
1733	ALLOCATE( &
1734	& idpext(fbdata%next) &
1735	& )
1736	ENDIF
1737
1738	! Read variables for header information
1739
1740	CALL chkerr( nf90_inq_varid( idfile, 'VARIABLES',idvard ), &
1741	& cpname, __LINE__ )
1742	CALL chkerr( nf90_get_var( idfile, idvard, fbdata%cname ), &
1743	& cpname, __LINE__ )
1744	IF ( fbdata%nadd > 0 ) THEN
1745	CALL chkerr( nf90_inq_varid( idfile, 'ENTRIES', idaddd ), &
1746	& cpname, __LINE__ )
1747	CALL chkerr( nf90_get_var( idfile, idaddd, fbdata%caddname ), &
1748	& cpname, __LINE__ )
1749	ENDIF
1750	IF ( fbdata%next > 0 ) THEN
1751	CALL chkerr( nf90_inq_varid( idfile, 'EXTRA', idextd ), &
1752	& cpname, __LINE__ )
1753	CALL chkerr( nf90_get_var( idfile, idextd, fbdata%cextname ), &
1754	& cpname, __LINE__ )
1755	ENDIF
1756
1757	CALL chkerr( nf90_inq_varid( idfile, 'JULD_REFERENCE', idptimr ), &
1758	& cpname, __LINE__ )
1759	CALL chkerr( nf90_get_var( idfile, idptimr, fbdata%cdjuldref ), &
1760	& cpname, __LINE__ )
1761
1762	IF ( fbdata%nobs > 0 ) THEN
1763
1764	CALL chkerr( nf90_inq_varid( idfile, 'STATION_IDENTIFIER', idcdwmo ),&
1765	& cpname, __LINE__ )
1766	CALL chkerr( nf90_get_var( idfile, idcdwmo, fbdata%cdwmo ), &
1767	& cpname, __LINE__ )
1768	CALL chkerr( nf90_inq_varid( idfile, 'STATION_TYPE', idcdtyp ), &
1769	& cpname, __LINE__ )
1770	CALL chkerr( nf90_get_var( idfile, idcdtyp, fbdata%cdtyp), &
1771	& cpname, __LINE__ )
1772	CALL chkerr( nf90_inq_varid( idfile, 'LONGITUDE', idplam ), &
1773	& cpname, __LINE__ )
1774	CALL chkerr( nf90_get_var( idfile, idplam, fbdata%plam ), &
1775	& cpname, __LINE__ )
1776	CALL chkerr( nf90_inq_varid( idfile, 'LATITUDE', idpphi ), &
1777	& cpname, __LINE__ )
1778	CALL chkerr( nf90_get_var( idfile, idpphi, fbdata%pphi ), &
1779	& cpname, __LINE__ )
1780	CALL chkerr( nf90_inq_varid( idfile, 'DEPTH', idpdep ), &
1781	& cpname, __LINE__ )
1782	CALL chkerr( nf90_get_var( idfile, idpdep, fbdata%pdep ), &
1783	& cpname, __LINE__ )
1784	CALL chkerr( nf90_inq_varid( idfile, 'JULD', idptim ), &
1785	& cpname, __LINE__ )
1786	CALL chkerr( nf90_get_var( idfile, idptim, fbdata%ptim ), &
1787	& cpname, __LINE__ )
1788	CALL chkerr( nf90_inq_varid( idfile, 'OBSERVATION_QC', idioqc ), &
1789	& cpname, __LINE__ )
1790	CALL chkerr( nf90_get_var( idfile, idioqc, fbdata%ioqc ), &
1791	& cpname, __LINE__ )
1792	CALL chkerr( nf90_inq_varid( idfile, 'OBSERVATION_QC_FLAGS', idioqcf ), &
1793	& cpname, __LINE__ )
1794	CALL chkerr( nf90_get_var( idfile, idioqcf, fbdata%ioqcf ), &
1795	& cpname, __LINE__ )
1796	CALL chkerr( nf90_inq_varid( idfile, 'POSITION_QC', idipqc ), &
1797	& cpname, __LINE__ )
1798	CALL chkerr( nf90_get_var( idfile, idipqc, fbdata%ipqc ), &
1799	& cpname, __LINE__ )
1800	CALL chkerr( nf90_inq_varid( idfile, 'POSITION_QC_FLAGS', idipqcf ), &
1801	& cpname, __LINE__ )
1802	CALL chkerr( nf90_get_var( idfile, idipqcf, fbdata%ipqcf ), &
1803	& cpname, __LINE__ )
1804	CALL chkerr( nf90_inq_varid( idfile, 'DEPTH_QC', ididqc ), &
1805	& cpname, __LINE__ )
1806	CALL chkerr( nf90_get_var( idfile, ididqc, fbdata%idqc ), &
1807	& cpname, __LINE__ )
1808	CALL chkerr( nf90_inq_varid( idfile, 'DEPTH_QC_FLAGS', ididqcf ), &
1809	& cpname, __LINE__ )
1810	CALL chkerr( nf90_get_var( idfile, ididqcf, fbdata%idqcf ), &
1811	& cpname, __LINE__ )
1812	CALL chkerr( nf90_inq_varid( idfile, 'JULD_QC', iditqc ), &
1813	& cpname, __LINE__ )
1814	CALL chkerr( nf90_get_var( idfile, iditqc, fbdata%itqc ), &
1815	& cpname, __LINE__ )
1816	CALL chkerr( nf90_inq_varid( idfile, 'JULD_QC_FLAGS', iditqcf ), &
1817	& cpname, __LINE__ )
1818	CALL chkerr( nf90_get_var( idfile, iditqcf, fbdata%itqcf ), &
1819	& cpname, __LINE__ )
1820	CALL chkerr( nf90_inq_varid( idfile, 'ORIGINAL_FILE_INDEX', idkindex ), &
1821	& cpname, __LINE__ )
1822	CALL chkerr( nf90_get_var( idfile, idkindex, fbdata%kindex ), &
1823	& cpname, __LINE__ )
1824
1825	! Read netCDF variables for individual variables
1826
1827	DO jv = 1, fbdata%nvar
1828
1829	WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_OBS'
1830	CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpob(jv) ), &
1831	& cpname, __LINE__ )
1832	CALL chkerr( nf90_get_var( idfile, idpob(jv), &
1833	& fbdata%pob(:,:,jv) ), &
1834	& cpname, __LINE__ )
1835	CALL getvaratt_obfbdata( idfile, idpob(jv), &
1836	& fbdata%coblong(jv), &
1837	& fbdata%cobunit(jv) )
1838
1839	IF ( fbdata%nadd > 0 ) THEN
1840	DO je = 1, fbdata%nadd
1841	WRITE(cdtmp,'(3A)') TRIM(fbdata%cname(jv)),'_',&
1842	& TRIM(fbdata%caddname(je))
1843	CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpadd(je,jv) ), &
1844	& cpname, __LINE__ )
1845	CALL chkerr( nf90_get_var( idfile, idpadd(je,jv), &
1846	& fbdata%padd(:,:,je,jv) ), &
1847	& cpname, __LINE__ )
1848	CALL getvaratt_obfbdata( idfile, idpadd(je,jv), &
1849	& fbdata%caddlong(je,jv), &
1850	& fbdata%caddunit(je,jv) )
1851	END DO
1852	ENDIF
1853
1854	WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC'
1855	CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivqc(jv) ), &
1856	& cpname, __LINE__ )
1857	CALL chkerr( nf90_get_var( idfile, idivqc(jv), &
1858	& fbdata%ivqc(:,jv) ), &
1859	& cpname, __LINE__ )
1860	WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC_FLAGS'
1861	CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivqcf(jv) ), &
1862	& cpname, __LINE__ )
1863	CALL chkerr( nf90_get_var( idfile, idivqcf(jv), &
1864	& fbdata%ivqcf(:,:,jv) ), &
1865	& cpname, __LINE__ )
1866	WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC'
1867	CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivlqc(jv) ), &
1868	& cpname, __LINE__ )
1869	CALL chkerr( nf90_get_var( idfile, idivlqc(jv), &
1870	& fbdata%ivlqc(:,:,jv) ), &
1871	& cpname, __LINE__ )
1872	WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC_FLAGS'
1873	CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivlqcf(jv) ), &
1874	& cpname, __LINE__ )
1875	CALL chkerr( nf90_get_var( idfile, idivlqcf(jv), &
1876	& fbdata%ivlqcf(:,:,:,jv) ), &
1877	& cpname, __LINE__ )
1878	IF ( lgrid ) THEN
1879	WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSI'
1880	CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsi(jv) ), &
1881	& cpname, __LINE__ )
1882	CALL chkerr( nf90_get_var( idfile, idiobsi(jv), &
1883	& fbdata%iobsi(:,jv) ), &
1884	& cpname, __LINE__ )
1885	WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSJ'
1886	CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsj(jv) ), &
1887	& cpname, __LINE__ )
1888	CALL chkerr( nf90_get_var( idfile, idiobsj(jv), &
1889	& fbdata%iobsj(:,jv) ), &
1890	& cpname, __LINE__ )
1891	WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSK'
1892	CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsk(jv) ), &
1893	& cpname, __LINE__ )
1894	CALL chkerr( nf90_get_var( idfile, idiobsk(jv), &
1895	& fbdata%iobsk(:,:,jv) ), &
1896	& cpname, __LINE__ )
1897	WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_GRID'
1898	CALL chkerr( nf90_inq_varid( idfile, cdtmp, idcgrid(jv) ), &
1899	& cpname, __LINE__ )
1900	CALL chkerr( nf90_get_var( idfile, idcgrid(jv), &
1901	& fbdata%cgrid(jv) ), &
1902	& cpname, __LINE__ )
1903	ENDIF
1904
1905	END DO
1906
1907	IF ( fbdata%next > 0 ) THEN
1908	DO je = 1, fbdata%next
1909	WRITE(cdtmp,'(A)') TRIM(fbdata%cextname(je))
1910	CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpext(je) ), &
1911	& cpname, __LINE__ )
1912	CALL chkerr( nf90_get_var( idfile, idpext(je), &
1913	& fbdata%pext(:,:,je) ), &
1914	& cpname, __LINE__ )
1915	CALL getvaratt_obfbdata( idfile, idpext(je), &
1916	& fbdata%cextlong(je), &
1917	& fbdata%cextunit(je) )
1918	END DO
1919	ENDIF
1920
1921	ELSE ! if no observations only get attributes
1922
1923	DO jv = 1, fbdata%nvar
1924
1925	WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_OBS'
1926	CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpob(jv) ), &
1927	& cpname, __LINE__ )
1928	CALL getvaratt_obfbdata( idfile, idpob(jv), &
1929	& fbdata%coblong(jv), &
1930	& fbdata%cobunit(jv) )
1931
1932	IF ( fbdata%nadd > 0 ) THEN
1933	DO je = 1, fbdata%nadd
1934	WRITE(cdtmp,'(3A)') TRIM(fbdata%cname(jv)),'_',&
1935	& TRIM(fbdata%caddname(je))
1936	CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpadd(je,jv) ), &
1937	& cpname, __LINE__ )
1938	CALL getvaratt_obfbdata( idfile, idpadd(je,jv), &
1939	& fbdata%caddlong(je,jv), &
1940	& fbdata%caddunit(je,jv) )
1941	END DO
1942	ENDIF
1943
1944	END DO
1945
1946	IF ( fbdata%next > 0 ) THEN
1947	DO je = 1, fbdata%next
1948	WRITE(cdtmp,'(A)') TRIM(fbdata%cextname(je))
1949	CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpext(je) ), &
1950	& cpname, __LINE__ )
1951	CALL getvaratt_obfbdata( idfile, idpext(je), &
1952	& fbdata%cextlong(je), &
1953	& fbdata%cextunit(je) )
1954	END DO
1955	ENDIF
1956
1957	ENDIF
1958
1959	! Close the file
1960
1961	CALL chkerr( nf90_close( idfile ), cpname, __LINE__ )
1962
1963	END SUBROUTINE read_obfbdata
1964
1965	SUBROUTINE getvaratt_obfbdata( idfile, idvar, cdlongname, cdunits )
1966	!!----------------------------------------------------------------------
1967	!! * ROUTINE putvaratt_obfbdata *
1968	!!
1969	!! ** Purpose : Read netcdf attributes for variable
1970	!!
1971	!! ** Method :
1972	!!
1973	!! ** Action :
1974	!!
1975	!!----------------------------------------------------------------------
1976	!! * Arguments
1977	INTEGER :: idfile ! File netcdf id.
1978	INTEGER :: idvar ! Variable netcdf id.
1979	CHARACTER(len=*) :: cdlongname ! Long name for variable
1980	CHARACTER(len=*) :: cdunits ! Units for variable
1981	!! * Local variables
1982	CHARACTER(LEN=18), PARAMETER :: cpname = 'getvaratt_obfbdata'
1983
1984	CALL chkerr( nf90_get_att( idfile, idvar, 'long_name', &
1985	& cdlongname ), &
1986	& cpname, __LINE__ )
1987
1988	CALL chkerr( nf90_get_att( idfile, idvar, 'units', &
1989	& cdunits ), &
1990	& cpname, __LINE__ )
1991
1992	END SUBROUTINE getvaratt_obfbdata
1993
1994	END MODULE obs_fbm

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/2021/dev_r14116_HPC-10_mcastril_Mixed_Precision_implementation/src/OCE/OBS/obs_fbm.F90 @ 15660

Download in other formats: