Ignore:
Timestamp:
2018-08-28T16:09:04+02:00 (3 years ago)
Author:
nicolasmartin
Message:

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

File:
1 edited

Legend:

Unmodified
Added
Removed
  • NEMO/trunk/src/SAO/obs_fbm.F90

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