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/2013/dev_r3987_UKMO4_OBS/NEMOGCM/NEMO/OPA_SRC/OBS – NEMO

Context Navigation

source: branches/2013/dev_r3987_UKMO4_OBS/NEMOGCM/NEMO/OPA_SRC/OBS/obs_fbm.F90 @ 4106

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

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

Download in other formats: