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/UKMO/r6232_tracer_advection/NEMOGCM/NEMO/OPA_SRC/OBS – NEMO

source: branches/UKMO/r6232_tracer_advection/NEMOGCM/NEMO/OPA_SRC/OBS/obs_fbm.F90 @ 9295

Last change on this file since 9295 was 9295, checked in by jcastill, 6 years ago

Remove svn keywords

File size: 88.6 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   ! 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
139CONTAINS
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 ooo_write
1567      !!              2. Map obfbdata into allocated memory
1568      !!              3. Pass mapped data to ooo_write
1569      !!              4. Deallocate memory
1570      !!----------------------------------------------------------------------
1571      USE dom_oce, ONLY: narea
1572      USE ooo_write
1573      USE ooo_data
1574      !! * Arguments
1575      CHARACTER(len=*) :: cdfilename ! Feedback filename
1576      TYPE(obfbdata)   :: fbdata     ! obsfbdata structure
1577      !! * Local variables
1578      CHARACTER(len=17), PARAMETER :: cpname = 'write_obfbdata_cl'
1579      CHARACTER(len=64) :: &
1580              & cdate, &   !: class 4 file validity date
1581              & cconf, &   !: model configuration
1582              & csys, &    !: model system
1583              & ccont, &   !: contact email
1584              & cinst, &   !: institution
1585              & cversion   !: model version
1586      CHARACTER(len=8) :: &
1587              & ckind      !: observation kind
1588      CHARACTER(len=3) :: cfield
1589      INTEGER :: kobs, &   !: number of observations
1590              &  kvars, &  !: number of physical variables
1591              &  kdeps, &  !: number of observed depths
1592              &  kfcst, &  !: number of forecasts
1593              &  kifcst, & !: current forecast number
1594              &  kproc     !: processor number
1595      INTEGER, DIMENSION(:, :, :), ALLOCATABLE :: &
1596              &  kqc       !: quality control counterpart
1597      INTEGER(KIND=2), DIMENSION(:, :, :), ALLOCATABLE :: &
1598              &  k2qc       !: quality control counterpart
1599      REAL(kind=fbdp) :: &
1600              &  pmodjuld  !: model Julian day
1601      REAL(kind=fbdp), DIMENSION(:), ALLOCATABLE :: &
1602              &  plead, &  !: forecast lead time
1603              &  plam, &   !: longitude of observation
1604              &  pphi, &   !: latitude of observation
1605              &  ptim      !: time of observation
1606      REAL(kind=fbdp), DIMENSION(:, :), ALLOCATABLE :: &
1607              &  pdep      !: depths of observations
1608      REAL(kind=fbdp), DIMENSION(:, :, :), ALLOCATABLE :: &
1609              &  pob, &    !: observation counterpart
1610              &  pextra    !: extra field counterpart
1611      REAL(kind=fbdp), DIMENSION(:, :, :), ALLOCATABLE :: &
1612              &  pmod      !: model counterpart
1613      CHARACTER(len=128) :: &
1614              &  clfilename  !: class 4 file name
1615      CHARACTER(len=128), DIMENSION(:), ALLOCATABLE :: &
1616              &  ctype       !: Instrument type
1617      CHARACTER(len=nf90_max_name) :: &
1618              & cdtmp        !: NetCDF variable name
1619      CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: &
1620              &  cwmo, &     !: Instrument WMO ID
1621              &  cunit, &    !: Instrument WMO ID
1622              &  cvarname    !: Instrument WMO ID
1623      INTEGER :: &
1624              &  idep, &     !: Loop variable
1625              &  ivar, &     !: Loop variable
1626              &  iobs, &     !: Loop variable
1627              &  ii, &       !: Loop variable
1628              &  ij, &       !: Loop variable
1629              &  ik, &       !: Loop variable
1630              &  il          !: Loop variable
1631      cconf = TRIM(cl4_cfg)
1632      csys = TRIM(cl4_sys)
1633      cversion = TRIM(cl4_vn)
1634      ccont = TRIM(cl4_contact)
1635      cinst = TRIM(cl4_inst)
1636      cdate = TRIM(cl4_date)
1637      CALL locate_kind(cdfilename, ckind)
1638      kproc = narea
1639      kfcst = cl4_fcst_len
1640      kobs = fbdata%nobs
1641      kdeps = fbdata%nlev
1642      kvars = fbdata%nvar
1643      IF (kobs .GT. 0) THEN
1644         ALLOCATE(plam(kobs), &
1645               &  pphi(kobs), &
1646               &  ptim(kobs), &
1647               &  plead(kfcst), &
1648               &  pdep(kdeps, kobs), &
1649               &  kqc(kdeps, kvars, kobs), &
1650               &  k2qc(kdeps, kvars, kobs), &
1651               &  pob(kdeps, kvars, kobs), &
1652               &  pmod(kdeps, kvars, kobs), &
1653               &  pextra(kdeps, kvars, kobs), &
1654               &  ctype(kobs), &
1655               &  cwmo(kobs), &
1656               &  cunit(kvars), &
1657               &  cvarname(kvars))
1658         plam(:) = fbdata%plam(:)
1659         pphi(:) = fbdata%pphi(:)
1660         ptim(:) = fbdata%ptim(:)
1661         pdep(:, :) = fbdata%pdep(:, :)
1662         kqc(:,:,:) = 1.
1663         DO ii = 1, kvars
1664            cvarname(ii)  = fbdata%cname(ii)
1665            cunit(ii)     = fbdata%cobunit(ii)
1666         END DO
1667
1668         ! Quality control algorithm
1669         k2qc(:,:,:) = NF90_FILL_SHORT
1670         DO idep = 1,kdeps
1671            DO ivar = 1, kvars
1672               DO iobs = 1, kobs
1673                  ! 1 symbolises good for fbdata
1674                  ! fbimdi symbolises that qc has not been set
1675                  ! Essentially, if any fbdata flag is not an element of {1, fbimdi}
1676                  ! then set the class 4 flag to bad.
1677                  ! Note: fbdata%ioqc is marked good if zero.
1678                  IF (((fbdata%ioqc(iobs) /= 0) .AND. &
1679                            & (fbdata%ioqc(iobs) /= fbimdi)) .OR. &
1680                    & ((fbdata%ipqc(iobs) /= 1) .AND. &
1681                            & (fbdata%ipqc(iobs) /= fbimdi)) .OR. &
1682                    & ((fbdata%idqc(idep,iobs) /= 1) .AND. &
1683                            & (fbdata%idqc(idep,iobs) /= fbimdi)) .OR. &
1684                    & ((fbdata%ivqc(iobs,ivar) /= 1) .AND. &
1685                            & (fbdata%ivqc(iobs,ivar) /= fbimdi)) .OR. &
1686                    & ((fbdata%ivlqc(idep,iobs,ivar) /= 1) .AND. &
1687                            & (fbdata%ivlqc(idep,iobs,ivar) /= fbimdi)) .OR. &
1688                    & ((fbdata%itqc(iobs) /= 1) .AND. &
1689                            & (fbdata%itqc(iobs) /= fbimdi))) THEN
1690                     ! 1 symbolises bad for class 4 file
1691                     k2qc(idep, ivar, iobs) = 1
1692                  ELSE
1693                     ! 0 symbolises good for class 4 file
1694                     k2qc(idep, ivar, iobs) = 0
1695                  END IF
1696               END DO
1697            END DO
1698         END DO
1699
1700         ! Permute observation dimensions
1701         pob(:,:,:) = RESHAPE(fbdata%pob, (/kdeps, kvars, kobs/), &
1702                            & ORDER=(/1, 3, 2/))
1703
1704         ! Explicit model counterpart dimension permutation
1705         ! 1,2,3,4 --> 1,4,2,3
1706         pmod(:,:,:) = fbrmdi
1707         ij = cl4_fcst_idx(jimatch)
1708         DO ii = 1,kdeps
1709            DO ik = 1, kvars
1710               DO il = 1, kobs
1711                  pmod(ii,ik,il) = fbdata%padd(ii,il,1,ik)
1712               END DO
1713            END DO
1714         END DO
1715
1716         ! Extra fields set to missing for now
1717         pextra(:,:,:) = fbrmdi
1718
1719         ! Lead time of class 4 file is a global parameter
1720         plead = cl4_leadtime(1:cl4_fcst_len)
1721
1722         ! Model Julian day
1723         pmodjuld = cl4_modjuld
1724
1725         ! Observation types
1726         ctype(:) = 'X'
1727         DO ii = 1,kobs
1728            ctype(ii) = fbdata%cdtyp(ii)
1729         END DO
1730
1731         ! World Meteorology Organisation codes
1732         cwmo(:) = fbdata%cdwmo(:)
1733
1734         ! Initialise class 4 file
1735         CALL ooo_wri_init(cconf, csys, ckind, cversion, ccont, cinst, cdate, &
1736                         & kproc, kobs, kvars, kdeps, kfcst, &
1737                         & clfilename)
1738
1739         ! Write standard variables
1740         CALL ooo_wri_default(clfilename, kobs, kvars, kfcst, kdeps, &
1741                            & ctype, cwmo, cunit, cvarname, &
1742                            & plam, pphi, pdep, ptim, pob, plead, &
1743                            & k2qc, pmodjuld)
1744         !! Write to optional variables
1745         cdtmp = cl4_vars(jimatch)
1746         IF ( (TRIM(cdtmp) == "forecast") .OR. &
1747              (TRIM(cdtmp) == "persistence") ) THEN
1748            !! 4D variables
1749            CALL ooo_wri_extra(clfilename, TRIM(cdtmp), kdeps, kfcst, &
1750                            &  kvars, kobs, (/ 1,ij,1,1 /), (/ kdeps,1,kvars,kobs /), pmod)
1751         ELSE
1752            !! 3D variables
1753            CALL ooo_wri_extra(clfilename, TRIM(cdtmp), kdeps, &
1754                            &  kvars, kobs, (/ 1,1,1 /), (/ kdeps,kvars,kobs /), pmod)
1755         ENDIF
1756
1757         DEALLOCATE(plam, pphi, ptim, pdep, plead, kqc, k2qc, &
1758                  & pob, pmod, pextra, ctype, cwmo, &
1759                  & cunit, cvarname)
1760      END IF
1761   END SUBROUTINE write_obfbdata_cl
1762#endif
1763
1764#if defined key_offobsoper
1765   SUBROUTINE locate_kind(cdfilename, ckind)
1766      !!----------------------------------------------------------------------
1767      !!                    ***  ROUTINE locate_kind  ***
1768      !!
1769      !! ** Purpose : Detect which kind of class 4 file is being produced.
1770      !!
1771      !! ** Method  : 1. Inspect cdfilename for observation kind.
1772      !!----------------------------------------------------------------------
1773      CHARACTER(len=*) :: cdfilename ! Feedback filename
1774      CHARACTER(len=8) :: ckind
1775      IF (cdfilename(1:3) == 'sst') THEN
1776         ckind = 'SST'
1777      ELSE IF (cdfilename(1:3) == 'sla') THEN
1778         ckind = 'SLA'
1779      ELSE IF (cdfilename(1:3) == 'pro') THEN
1780         ckind = 'profile'
1781      ELSE IF (cdfilename(1:3) == 'ena') THEN
1782         ckind = 'profile'
1783      ELSE IF (cdfilename(1:3) == 'sea') THEN
1784         ckind = 'seaice'
1785      ELSE
1786         ckind = 'unknown'
1787      END IF
1788   END SUBROUTINE locate_kind
1789#endif
1790
1791   SUBROUTINE putvaratt_obfbdata( idfile, idvar, cdlongname, cdunits, &
1792      &                           conventions, cfillvalue, &
1793      &                           ifillvalue, rfillvalue )
1794      !!----------------------------------------------------------------------
1795      !!                    ***  ROUTINE putvaratt_obfbdata  ***
1796      !!
1797      !! ** Purpose :   Write netcdf attributes for variable
1798      !!
1799      !! ** Method  :   
1800      !!
1801      !! ** Action  :
1802      !!
1803      !!----------------------------------------------------------------------
1804      !! * Arguments
1805      INTEGER :: idfile                    ! File netcdf id.
1806      INTEGER :: idvar                     ! Variable netcdf id.
1807      CHARACTER(len=*) :: cdlongname       ! Long name for variable
1808      CHARACTER(len=*), OPTIONAL :: cdunits       ! Units for variable
1809      CHARACTER(len=*), OPTIONAL :: cfillvalue    ! Fill value for character variables
1810      INTEGER, OPTIONAL :: ifillvalue             ! Fill value for integer variables
1811      REAL(kind=fbsp), OPTIONAL :: rfillvalue     ! Fill value for real variables
1812      CHARACTER(len=*), OPTIONAL :: conventions   ! Conventions for variable
1813      !! * Local variables
1814      CHARACTER(LEN=18), PARAMETER :: &
1815         & cpname = 'putvaratt_obfbdata'
1816
1817      CALL chkerr( nf90_put_att( idfile, idvar, 'long_name', &
1818         &                       TRIM(cdlongname) ), &
1819         &                       cpname, __LINE__ )
1820     
1821      IF ( PRESENT(cdunits) ) THEN
1822
1823         CALL chkerr( nf90_put_att( idfile, idvar, 'units', &
1824            &                       TRIM(cdunits) ), &
1825            &                       cpname, __LINE__ )
1826
1827      ENDIF
1828
1829      IF ( PRESENT(conventions) ) THEN
1830
1831         CALL chkerr( nf90_put_att( idfile, idvar, 'Conventions', &
1832            &                       TRIM(conventions) ), &
1833            &                       cpname, __LINE__ )
1834
1835      ENDIF
1836
1837      IF ( PRESENT(cfillvalue) ) THEN
1838
1839         CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', &
1840            &                       TRIM(cfillvalue) ), &
1841            &                       cpname, __LINE__ )
1842
1843      ENDIF
1844
1845      IF ( PRESENT(ifillvalue) ) THEN
1846
1847         CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', &
1848            &                       ifillvalue ), &
1849            &                       cpname, __LINE__ )
1850
1851      ENDIF
1852
1853      IF ( PRESENT(rfillvalue) ) THEN
1854
1855         CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', &
1856            &                       rfillvalue ), &
1857            &                       cpname, __LINE__ )
1858
1859      ENDIF
1860
1861   END SUBROUTINE putvaratt_obfbdata
1862
1863   SUBROUTINE read_obfbdata( cdfilename, fbdata, ldgrid )
1864      !!----------------------------------------------------------------------
1865      !!                    ***  ROUTINE read_obfbdata  ***
1866      !!
1867      !! ** Purpose :   Read an obfbdata structure from a netCDF file.
1868      !!
1869      !! ** Method  :   
1870      !!
1871      !! ** Action  :
1872      !!
1873      !!----------------------------------------------------------------------
1874      !! * Arguments
1875      CHARACTER(len=*) :: cdfilename  ! Input filename
1876      TYPE(obfbdata)   :: fbdata      ! obsfbdata structure
1877      LOGICAL, OPTIONAL :: ldgrid     ! Allow forcing of grid info
1878      !! * Local variables
1879      CHARACTER(LEN=14), PARAMETER :: cpname = 'read_obfbdata'
1880      INTEGER :: idfile
1881      INTEGER :: idodim
1882      INTEGER :: idldim
1883      INTEGER :: idvdim
1884      INTEGER :: idadim
1885      INTEGER :: idedim
1886      INTEGER :: idgdim
1887      INTEGER :: idvard
1888      INTEGER :: idaddd
1889      INTEGER :: idextd
1890      INTEGER :: idcdwmo
1891      INTEGER :: idcdtyp
1892      INTEGER :: idplam
1893      INTEGER :: idpphi
1894      INTEGER :: idpdep
1895      INTEGER :: idptim
1896      INTEGER :: idptimr
1897      INTEGER :: idioqc       
1898      INTEGER :: idioqcf
1899      INTEGER :: idipqc
1900      INTEGER :: idipqcf
1901      INTEGER :: ididqc
1902      INTEGER :: ididqcf
1903      INTEGER :: iditqc
1904      INTEGER :: iditqcf
1905      INTEGER :: idkindex
1906      INTEGER, DIMENSION(:), ALLOCATABLE :: &
1907         & idpob,    &
1908         & idivqc,   &
1909         & idivqcf,  &
1910         & idivlqc,  &
1911         & idivlqcf, &
1912         & idiobsi,  &
1913         & idiobsj,  &
1914         & idiobsk,  &
1915         & idcgrid,  &
1916         & idpext
1917      INTEGER, DIMENSION(:,:), ALLOCATABLE :: &
1918         & idpadd
1919      INTEGER :: jv
1920      INTEGER :: je
1921      INTEGER :: nvar
1922      INTEGER :: nobs
1923      INTEGER :: nlev
1924      INTEGER :: nadd
1925      INTEGER :: next
1926      LOGICAL :: lgrid
1927      CHARACTER(len=NF90_MAX_NAME) :: cdtmp
1928
1929      ! Check allocation status and deallocate previous allocated structures
1930
1931      IF ( fbdata%lalloc ) THEN
1932         CALL dealloc_obfbdata( fbdata )
1933      ENDIF
1934
1935      ! Open input filename
1936
1937      CALL chkerr( nf90_open( TRIM( cdfilename ), nf90_nowrite, idfile ), &
1938         &         cpname, __LINE__ )
1939
1940      ! Get input dimensions
1941
1942      CALL chkerr( nf90_inq_dimid( idfile, 'N_OBS'  , idodim ),  &
1943         &         cpname,__LINE__ )
1944      CALL chkerr( nf90_inquire_dimension( idfile, idodim, len=nobs ), &
1945         &         cpname,__LINE__ )
1946      CALL chkerr( nf90_inq_dimid( idfile, 'N_LEVELS', idldim ), &
1947         &         cpname,__LINE__ )
1948      CALL chkerr( nf90_inquire_dimension( idfile, idldim, len=nlev ), &
1949         &         cpname,__LINE__ )
1950      CALL chkerr( nf90_inq_dimid( idfile, 'N_VARS', idvdim ), &
1951         &         cpname,__LINE__ )
1952      CALL chkerr( nf90_inquire_dimension( idfile, idvdim, len=nvar ), &
1953         &         cpname,__LINE__ )
1954      IF ( nf90_inq_dimid( idfile, 'N_ENTRIES',  idadim ) == 0 ) THEN
1955         CALL chkerr( nf90_inquire_dimension( idfile, idadim, len=nadd ), &
1956            &         cpname,__LINE__ )
1957      ELSE
1958         nadd = 0
1959      ENDIF
1960      IF ( nf90_inq_dimid( idfile, 'N_EXTRA',  idedim ) == 0 ) THEN
1961         CALL chkerr( nf90_inquire_dimension( idfile, idedim, len=next ), &
1962            &         cpname,__LINE__ )
1963      ELSE
1964         next = 0
1965      ENDIF
1966      !
1967      ! Check if this input file  contains grid search informations
1968      !
1969      lgrid = ( nf90_inq_dimid( idfile, 'STRINGGRID',  idgdim ) == 0 )
1970
1971      ! Allocate data structure
1972
1973      IF ( PRESENT(ldgrid) ) THEN
1974         CALL alloc_obfbdata( fbdata, nvar, nobs, nlev, nadd, next, &
1975            & lgrid.OR.ldgrid )
1976      ELSE
1977         CALL alloc_obfbdata( fbdata, nvar, nobs, nlev, nadd, next, &
1978            & lgrid )
1979      ENDIF
1980
1981      ! Allocate netcdf identifiers
1982
1983      ALLOCATE( &
1984         & idpob(fbdata%nvar),    &
1985         & idivqc(fbdata%nvar),   &
1986         & idivqcf(fbdata%nvar),  &
1987         & idivlqc(fbdata%nvar),  &
1988         & idivlqcf(fbdata%nvar), &
1989         & idiobsi(fbdata%nvar),  &
1990         & idiobsj(fbdata%nvar),  &
1991         & idiobsk(fbdata%nvar),  &
1992         & idcgrid(fbdata%nvar)   &
1993         & )
1994      IF ( fbdata%nadd > 0 ) THEN
1995         ALLOCATE( &
1996            & idpadd(fbdata%nadd,fbdata%nvar) &
1997            & )
1998      ENDIF
1999      IF ( fbdata%next > 0 ) THEN
2000         ALLOCATE( &
2001            & idpext(fbdata%next) &
2002            & )
2003      ENDIF
2004
2005      ! Read variables for header information
2006
2007      CALL chkerr( nf90_inq_varid( idfile, 'VARIABLES',idvard ), &
2008         &         cpname, __LINE__ )
2009      CALL chkerr( nf90_get_var( idfile, idvard, fbdata%cname ), &
2010         &         cpname, __LINE__ )
2011      IF ( fbdata%nadd > 0 ) THEN
2012         CALL chkerr( nf90_inq_varid( idfile, 'ENTRIES', idaddd ), &
2013            &         cpname, __LINE__ )
2014         CALL chkerr( nf90_get_var( idfile, idaddd, fbdata%caddname ), &
2015            &         cpname, __LINE__ )
2016      ENDIF
2017      IF ( fbdata%next > 0 ) THEN
2018         CALL chkerr( nf90_inq_varid( idfile, 'EXTRA', idextd ), &
2019            &         cpname, __LINE__ )
2020         CALL chkerr( nf90_get_var( idfile, idextd, fbdata%cextname ), &
2021            &         cpname, __LINE__ )
2022      ENDIF
2023
2024      CALL chkerr( nf90_inq_varid( idfile, 'JULD_REFERENCE', idptimr ), &
2025         &         cpname, __LINE__ )
2026      CALL chkerr( nf90_get_var( idfile, idptimr, fbdata%cdjuldref ), &
2027         &         cpname, __LINE__ )
2028
2029      IF  ( fbdata%nobs > 0 ) THEN
2030         
2031         CALL chkerr( nf90_inq_varid( idfile, 'STATION_IDENTIFIER', idcdwmo ),&
2032            &         cpname, __LINE__ )
2033         CALL chkerr( nf90_get_var( idfile, idcdwmo, fbdata%cdwmo ), &
2034            &         cpname, __LINE__ )
2035         CALL chkerr( nf90_inq_varid( idfile, 'STATION_TYPE', idcdtyp ), &
2036            &         cpname, __LINE__ )
2037         CALL chkerr( nf90_get_var( idfile, idcdtyp, fbdata%cdtyp), &
2038            &         cpname, __LINE__ )
2039         CALL chkerr( nf90_inq_varid( idfile, 'LONGITUDE', idplam ), &
2040            &         cpname, __LINE__ )
2041         CALL chkerr( nf90_get_var( idfile, idplam, fbdata%plam ), &
2042            &         cpname, __LINE__ )
2043         CALL chkerr( nf90_inq_varid( idfile, 'LATITUDE', idpphi ), &
2044            &         cpname, __LINE__ )
2045         CALL chkerr( nf90_get_var( idfile, idpphi, fbdata%pphi ), &
2046            &         cpname, __LINE__ )
2047         CALL chkerr( nf90_inq_varid( idfile, 'DEPTH', idpdep ), &
2048            &         cpname, __LINE__ )
2049         CALL chkerr( nf90_get_var( idfile, idpdep, fbdata%pdep ), &
2050            &         cpname, __LINE__ )
2051         CALL chkerr( nf90_inq_varid( idfile, 'JULD', idptim ), &
2052            &         cpname, __LINE__ )
2053         CALL chkerr( nf90_get_var( idfile, idptim, fbdata%ptim ), &
2054            &         cpname, __LINE__ )
2055         CALL chkerr( nf90_inq_varid( idfile, 'OBSERVATION_QC', idioqc ), &
2056            &         cpname, __LINE__ )
2057         CALL chkerr( nf90_get_var( idfile, idioqc, fbdata%ioqc ), &
2058            &         cpname, __LINE__ )
2059         CALL chkerr( nf90_inq_varid( idfile, 'OBSERVATION_QC_FLAGS', idioqcf ), &
2060            &         cpname, __LINE__ )
2061         CALL chkerr( nf90_get_var( idfile, idioqcf, fbdata%ioqcf ), &
2062            &         cpname, __LINE__ )
2063         CALL chkerr( nf90_inq_varid( idfile, 'POSITION_QC', idipqc ), &
2064            &         cpname, __LINE__ )
2065         CALL chkerr( nf90_get_var( idfile, idipqc, fbdata%ipqc ), &
2066            &         cpname, __LINE__ )
2067         CALL chkerr( nf90_inq_varid( idfile, 'POSITION_QC_FLAGS', idipqcf ), &
2068            &         cpname, __LINE__ )
2069         CALL chkerr( nf90_get_var( idfile, idipqcf, fbdata%ipqcf ), &
2070            &         cpname, __LINE__ )
2071         CALL chkerr( nf90_inq_varid( idfile, 'DEPTH_QC', ididqc ), &
2072            &         cpname, __LINE__ )
2073         CALL chkerr( nf90_get_var( idfile, ididqc, fbdata%idqc ), &
2074            &         cpname, __LINE__ )
2075         CALL chkerr( nf90_inq_varid( idfile, 'DEPTH_QC_FLAGS', ididqcf ), &
2076            &         cpname, __LINE__ )
2077         CALL chkerr( nf90_get_var( idfile, ididqcf, fbdata%idqcf ), &
2078            &         cpname, __LINE__ )
2079         CALL chkerr( nf90_inq_varid( idfile, 'JULD_QC', iditqc ), &
2080            &         cpname, __LINE__ )
2081         CALL chkerr( nf90_get_var( idfile, iditqc, fbdata%itqc ), &
2082            &         cpname, __LINE__ )
2083         CALL chkerr( nf90_inq_varid( idfile, 'JULD_QC_FLAGS', iditqcf ), &
2084            &         cpname, __LINE__ )
2085         CALL chkerr( nf90_get_var( idfile, iditqcf, fbdata%itqcf ), &
2086            &         cpname, __LINE__ )
2087         CALL chkerr( nf90_inq_varid( idfile, 'ORIGINAL_FILE_INDEX', idkindex ), &
2088            &         cpname, __LINE__ )
2089         CALL chkerr( nf90_get_var( idfile, idkindex, fbdata%kindex ), &
2090            &         cpname, __LINE__ )
2091         
2092         ! Read netCDF variables for individual variables
2093         
2094         DO jv = 1, fbdata%nvar
2095           
2096            WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_OBS'
2097            CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpob(jv) ), &
2098               &         cpname, __LINE__ )
2099            CALL chkerr( nf90_get_var( idfile, idpob(jv), &
2100               &                       fbdata%pob(:,:,jv) ), &
2101               &         cpname, __LINE__ )
2102            CALL getvaratt_obfbdata( idfile, idpob(jv), &
2103               &                     fbdata%coblong(jv), &
2104               &                     fbdata%cobunit(jv) )
2105           
2106            IF ( fbdata%nadd > 0 ) THEN
2107               DO je = 1, fbdata%nadd
2108                  WRITE(cdtmp,'(3A)') TRIM(fbdata%cname(jv)),'_',&
2109                     &                TRIM(fbdata%caddname(je))
2110                  CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpadd(je,jv) ), &
2111                     &         cpname, __LINE__ )
2112                  CALL chkerr( nf90_get_var( idfile, idpadd(je,jv), &
2113                     &                       fbdata%padd(:,:,je,jv) ), &
2114                     &         cpname, __LINE__ )
2115                  CALL getvaratt_obfbdata( idfile, idpadd(je,jv), &
2116                     &                     fbdata%caddlong(je,jv), &
2117                     &                     fbdata%caddunit(je,jv) )
2118               END DO
2119            ENDIF
2120           
2121            WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC'
2122            CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivqc(jv) ), &
2123            &         cpname, __LINE__ )
2124            CALL chkerr( nf90_get_var( idfile, idivqc(jv), &
2125               &                       fbdata%ivqc(:,jv) ), &
2126               &         cpname, __LINE__ )
2127            WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC_FLAGS'
2128            CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivqcf(jv) ), &
2129               &         cpname, __LINE__ )
2130            CALL chkerr( nf90_get_var( idfile, idivqcf(jv), &
2131               &                       fbdata%ivqcf(:,:,jv) ), &
2132               &         cpname, __LINE__ )
2133            WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC'
2134            CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivlqc(jv) ), &
2135               &         cpname, __LINE__ )
2136            CALL chkerr( nf90_get_var( idfile, idivlqc(jv), &
2137               &                       fbdata%ivlqc(:,:,jv) ), &
2138               &         cpname, __LINE__ )
2139            WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC_FLAGS'
2140            CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivlqcf(jv) ), &
2141               &         cpname, __LINE__ )
2142            CALL chkerr( nf90_get_var( idfile, idivlqcf(jv), &
2143               &                       fbdata%ivlqcf(:,:,:,jv) ), &
2144               &         cpname, __LINE__ )
2145            IF ( lgrid ) THEN
2146               WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSI'
2147               CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsi(jv) ), &
2148                  &         cpname, __LINE__ )
2149               CALL chkerr( nf90_get_var( idfile, idiobsi(jv), &
2150                  &                       fbdata%iobsi(:,jv) ), &
2151                  &         cpname, __LINE__ )
2152               WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSJ'
2153               CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsj(jv) ), &
2154                  &         cpname, __LINE__ )
2155               CALL chkerr( nf90_get_var( idfile, idiobsj(jv), &
2156                  &                       fbdata%iobsj(:,jv) ), &
2157                  &         cpname, __LINE__ )
2158               WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSK'
2159               CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsk(jv) ), &
2160                  &         cpname, __LINE__ )
2161               CALL chkerr( nf90_get_var( idfile, idiobsk(jv), &
2162                  &                       fbdata%iobsk(:,:,jv) ), &
2163                  &         cpname, __LINE__ )
2164               WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_GRID'
2165               CALL chkerr( nf90_inq_varid( idfile, cdtmp, idcgrid(jv) ), &
2166                  &         cpname, __LINE__ )
2167               CALL chkerr( nf90_get_var( idfile, idcgrid(jv), &
2168                  &                       fbdata%cgrid(jv) ), &
2169                  &         cpname, __LINE__ )
2170            ENDIF
2171           
2172         END DO
2173         
2174         IF ( fbdata%next > 0 ) THEN
2175            DO je = 1, fbdata%next
2176               WRITE(cdtmp,'(A)') TRIM(fbdata%cextname(je))
2177               CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpext(je) ), &
2178                  &         cpname, __LINE__ )
2179               CALL chkerr( nf90_get_var( idfile, idpext(je), &
2180                  &                       fbdata%pext(:,:,je) ), &
2181                  &         cpname, __LINE__ )
2182               CALL getvaratt_obfbdata( idfile, idpext(je), &
2183                  &                     fbdata%cextlong(je), &
2184                  &                     fbdata%cextunit(je) )
2185            END DO
2186         ENDIF
2187
2188      ELSE ! if no observations only get attributes
2189
2190         DO jv = 1, fbdata%nvar           
2191
2192            WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_OBS'
2193            CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpob(jv) ), &
2194               &         cpname, __LINE__ )
2195            CALL getvaratt_obfbdata( idfile, idpob(jv), &
2196               &                     fbdata%coblong(jv), &
2197               &                     fbdata%cobunit(jv) )
2198           
2199            IF ( fbdata%nadd > 0 ) THEN
2200               DO je = 1, fbdata%nadd
2201                  WRITE(cdtmp,'(3A)') TRIM(fbdata%cname(jv)),'_',&
2202                     &                TRIM(fbdata%caddname(je))
2203                  CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpadd(je,jv) ), &
2204                     &         cpname, __LINE__ )
2205                  CALL getvaratt_obfbdata( idfile, idpadd(je,jv), &
2206                     &                     fbdata%caddlong(je,jv), &
2207                     &                     fbdata%caddunit(je,jv) )
2208               END DO
2209            ENDIF
2210           
2211         END DO
2212         
2213         IF ( fbdata%next > 0 ) THEN
2214            DO je = 1, fbdata%next
2215               WRITE(cdtmp,'(A)') TRIM(fbdata%cextname(je))
2216               CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpext(je) ), &
2217                  &         cpname, __LINE__ )
2218               CALL getvaratt_obfbdata( idfile, idpext(je), &
2219                  &                     fbdata%cextlong(je), &
2220                  &                     fbdata%cextunit(je) )
2221            END DO
2222         ENDIF
2223
2224      ENDIF
2225
2226      ! Close the file
2227
2228      CALL chkerr( nf90_close( idfile ), cpname, __LINE__ )
2229
2230   END SUBROUTINE read_obfbdata
2231
2232   SUBROUTINE getvaratt_obfbdata( idfile, idvar, cdlongname, cdunits )
2233      !!----------------------------------------------------------------------
2234      !!                    ***  ROUTINE putvaratt_obfbdata  ***
2235      !!
2236      !! ** Purpose :   Read netcdf attributes for variable
2237      !!
2238      !! ** Method  :   
2239      !!
2240      !! ** Action  :
2241      !!
2242      !!----------------------------------------------------------------------
2243      !! * Arguments
2244      INTEGER :: idfile      ! File netcdf id.
2245      INTEGER :: idvar       ! Variable netcdf id.
2246      CHARACTER(len=*) :: cdlongname  ! Long name for variable
2247      CHARACTER(len=*) :: cdunits     ! Units for variable
2248      !! * Local variables
2249      CHARACTER(LEN=18), PARAMETER :: cpname = 'getvaratt_obfbdata'
2250
2251      CALL chkerr( nf90_get_att( idfile, idvar, 'long_name', &
2252         &                       cdlongname ), &
2253         &                       cpname, __LINE__ )
2254
2255      CALL chkerr( nf90_get_att( idfile, idvar, 'units', &
2256         &                       cdunits ), &
2257         &                       cpname, __LINE__ )
2258
2259   END SUBROUTINE getvaratt_obfbdata
2260
2261END MODULE obs_fbm
Note: See TracBrowser for help on using the repository browser.