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 NEMO/trunk/src/SAO – NEMO

source: NEMO/trunk/src/SAO/obs_fbm.F90

Last change on this file was 10068, checked in by nicolasmartin, 6 years ago

First part of modifications to have a common default header : fix typos and SVN keywords properties

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