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

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

obs_fbm.F90 in branches/devukmo2010/NEMO/OPA_SRC/OBS – NEMO

Context Navigation

source: branches/devukmo2010/NEMO/OPA_SRC/OBS/obs_fbm.F90 @ 2128

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

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

Download in other formats: