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/dev_1784_OBS/NEMO/OPA_SRC/OBS – NEMO

Context Navigation

source: branches/dev_1784_OBS/NEMO/OPA_SRC/OBS/obs_fbm.F90 @ 2001

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

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

Download in other formats: