New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 7351 for branches/2016/dev_INGV_UKMO_2016/NEMOGCM/NEMO/OPA_SRC/OBS/obs_write.F90 – NEMO

Ignore:
Timestamp:
2016-11-28T17:04:10+01:00 (7 years ago)
Author:
emanuelaclementi
Message:

ticket #1805 step 3: /2016/dev_INGV_UKMO_2016 aligned to the trunk at revision 7161

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/2016/dev_INGV_UKMO_2016/NEMOGCM/NEMO/OPA_SRC/OBS/obs_write.F90

    r4990 r7351  
    66 
    77   !!---------------------------------------------------------------------- 
    8    !!   obs_wri_p3d   : Write profile observation diagnostics in NetCDF format 
    9    !!   obs_wri_sla   : Write SLA observation related diagnostics 
    10    !!   obs_wri_sst   : Write SST observation related diagnostics 
    11    !!   obs_wri_seaice: Write seaice observation related diagnostics 
    12    !!   obs_wri_vel   : Write velocity observation diagnostics in NetCDF format 
     8   !!   obs_wri_prof   : Write profile observations in feedback format 
     9   !!   obs_wri_surf   : Write surface observations in feedback format 
    1310   !!   obs_wri_stats : Print basic statistics on the data being written out 
    1411   !!---------------------------------------------------------------------- 
     
    3027   USE obs_conv             ! Conversion between units 
    3128   USE obs_const 
    32    USE obs_sla_types 
    33    USE obs_rot_vel          ! Rotation of velocities 
    3429   USE obs_mpp              ! MPP support routines for observation diagnostics 
    3530   USE lib_mpp        ! MPP routines 
     
    3934   !! * Routine accessibility 
    4035   PRIVATE 
    41    PUBLIC obs_wri_p3d, &    ! Write profile observation related diagnostics 
    42       &   obs_wri_sla, &    ! Write SLA observation related diagnostics 
    43       &   obs_wri_sst, &    ! Write SST observation related diagnostics 
    44       &   obs_wri_sss, &    ! Write SSS observation related diagnostics 
    45       &   obs_wri_seaice, & ! Write seaice observation related diagnostics 
    46       &   obs_wri_vel, &    ! Write velocity observation related diagnostics 
     36   PUBLIC obs_wri_prof, &    ! Write profile observation files 
     37      &   obs_wri_surf, &    ! Write surface observation files 
    4738      &   obswriinfo 
    4839    
     
    6354CONTAINS 
    6455 
    65    SUBROUTINE obs_wri_p3d( cprefix, profdata, padd, pext ) 
     56   SUBROUTINE obs_wri_prof( profdata, padd, pext ) 
    6657      !!----------------------------------------------------------------------- 
    6758      !! 
    68       !!                     *** ROUTINE obs_wri_p3d  *** 
    69       !! 
    70       !! ** Purpose : Write temperature and salinity (profile) observation  
    71       !!              related diagnostics 
     59      !!                     *** ROUTINE obs_wri_prof  *** 
     60      !! 
     61      !! ** Purpose : Write profile feedback files 
    7262      !! 
    7363      !! ** Method  : NetCDF 
     
    8272      !!      ! 07-03  (K. Mogensen) General handling of profiles 
    8373      !!      ! 09-01  (K. Mogensen) New feedback format 
     74      !!      ! 15-02  (M. Martin) Combined routine for writing profiles 
    8475      !!----------------------------------------------------------------------- 
    8576 
    86       !! * Modules used 
    87  
    8877      !! * Arguments 
    89       CHARACTER(LEN=*), INTENT(IN) :: cprefix        ! Prefix for output files 
    9078      TYPE(obs_prof), INTENT(INOUT) :: profdata      ! Full set of profile data 
    9179      TYPE(obswriinfo), OPTIONAL :: padd             ! Additional info for each variable 
    9280      TYPE(obswriinfo), OPTIONAL :: pext             ! Extra info 
    93        
     81 
    9482      !! * Local declarations 
    9583      TYPE(obfbdata) :: fbdata 
    96       CHARACTER(LEN=40) :: cfname 
     84      CHARACTER(LEN=40) :: clfname 
     85      CHARACTER(LEN=6) :: clfiletype 
    9786      INTEGER :: ilevel 
    9887      INTEGER :: jvar 
     
    10291      INTEGER :: ja 
    10392      INTEGER :: je 
     93      INTEGER :: iadd 
     94      INTEGER :: iext 
    10495      REAL(wp) :: zpres 
    105       INTEGER :: nadd 
    106       INTEGER :: next 
    10796 
    10897      IF ( PRESENT( padd ) ) THEN 
    109          nadd = padd%inum 
     98         iadd = padd%inum 
    11099      ELSE 
    111          nadd = 0 
     100         iadd = 0 
    112101      ENDIF 
    113102 
    114103      IF ( PRESENT( pext ) ) THEN 
    115          next = pext%inum 
     104         iext = pext%inum 
    116105      ELSE 
    117          next = 0 
    118       ENDIF 
    119        
     106         iext = 0 
     107      ENDIF 
     108 
    120109      CALL init_obfbdata( fbdata ) 
    121110 
     
    125114         ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) ) 
    126115      END DO 
    127       CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, & 
    128          &                 1 + nadd, 1 + next, .TRUE. ) 
    129  
    130       fbdata%cname(1)      = 'POTM' 
    131       fbdata%cname(2)      = 'PSAL' 
    132       fbdata%coblong(1)    = 'Potential temperature' 
    133       fbdata%coblong(2)    = 'Practical salinity' 
    134       fbdata%cobunit(1)    = 'Degrees centigrade' 
    135       fbdata%cobunit(2)    = 'PSU' 
    136       fbdata%cextname(1)   = 'TEMP' 
    137       fbdata%cextlong(1)   = 'Insitu temperature' 
    138       fbdata%cextunit(1)   = 'Degrees centigrade' 
    139       DO je = 1, next 
    140          fbdata%cextname(1+je) = pext%cdname(je) 
    141          fbdata%cextlong(1+je) = pext%cdlong(je,1) 
    142          fbdata%cextunit(1+je) = pext%cdunit(je,1) 
    143       END DO 
     116 
     117      SELECT CASE ( TRIM(profdata%cvars(1)) ) 
     118      CASE('POTM') 
     119 
     120         clfiletype='profb' 
     121         CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, & 
     122            &                 1 + iadd, 1 + iext, .TRUE. ) 
     123         fbdata%cname(1)      = profdata%cvars(1) 
     124         fbdata%cname(2)      = profdata%cvars(2) 
     125         fbdata%coblong(1)    = 'Potential temperature' 
     126         fbdata%coblong(2)    = 'Practical salinity' 
     127         fbdata%cobunit(1)    = 'Degrees centigrade' 
     128         fbdata%cobunit(2)    = 'PSU' 
     129         fbdata%cextname(1)   = 'TEMP' 
     130         fbdata%cextlong(1)   = 'Insitu temperature' 
     131         fbdata%cextunit(1)   = 'Degrees centigrade' 
     132         fbdata%caddlong(1,1) = 'Model interpolated potential temperature' 
     133         fbdata%caddlong(1,2) = 'Model interpolated practical salinity' 
     134         fbdata%caddunit(1,1) = 'Degrees centigrade' 
     135         fbdata%caddunit(1,2) = 'PSU' 
     136         fbdata%cgrid(:)      = 'T' 
     137         DO je = 1, iext 
     138            fbdata%cextname(1+je) = pext%cdname(je) 
     139            fbdata%cextlong(1+je) = pext%cdlong(je,1) 
     140            fbdata%cextunit(1+je) = pext%cdunit(je,1) 
     141         END DO 
     142         DO ja = 1, iadd 
     143            fbdata%caddname(1+ja) = padd%cdname(ja) 
     144            DO jvar = 1, 2 
     145               fbdata%caddlong(1+ja,jvar) = padd%cdlong(ja,jvar) 
     146               fbdata%caddunit(1+ja,jvar) = padd%cdunit(ja,jvar) 
     147            END DO 
     148         END DO 
     149 
     150      CASE('UVEL') 
     151 
     152         clfiletype='velfb' 
     153         CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, 1, 0, .TRUE. ) 
     154         fbdata%cname(1)      = profdata%cvars(1) 
     155         fbdata%cname(2)      = profdata%cvars(2) 
     156         fbdata%coblong(1)    = 'Zonal velocity' 
     157         fbdata%coblong(2)    = 'Meridional velocity' 
     158         fbdata%cobunit(1)    = 'm/s' 
     159         fbdata%cobunit(2)    = 'm/s' 
     160         DO je = 1, iext 
     161            fbdata%cextname(je) = pext%cdname(je) 
     162            fbdata%cextlong(je) = pext%cdlong(je,1) 
     163            fbdata%cextunit(je) = pext%cdunit(je,1) 
     164         END DO 
     165         fbdata%caddlong(1,1) = 'Model interpolated zonal velocity' 
     166         fbdata%caddlong(1,2) = 'Model interpolated meridional velocity' 
     167         fbdata%caddunit(1,1) = 'm/s' 
     168         fbdata%caddunit(1,2) = 'm/s' 
     169         fbdata%cgrid(1)      = 'U'  
     170         fbdata%cgrid(2)      = 'V' 
     171         DO ja = 1, iadd 
     172            fbdata%caddname(1+ja) = padd%cdname(ja) 
     173            fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 
     174            fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 
     175         END DO 
     176 
     177      END SELECT 
     178 
    144179      fbdata%caddname(1)   = 'Hx' 
    145       fbdata%caddlong(1,1) = 'Model interpolated potential temperature' 
    146       fbdata%caddlong(1,2) = 'Model interpolated practical salinity' 
    147       fbdata%caddunit(1,1) = 'Degrees centigrade' 
    148       fbdata%caddunit(1,2) = 'PSU' 
    149       fbdata%cgrid(:)      = 'T' 
    150       DO ja = 1, nadd 
    151          fbdata%caddname(1+ja) = padd%cdname(ja) 
    152          DO jvar = 1, 2 
    153             fbdata%caddlong(1+ja,jvar) = padd%cdlong(ja,jvar) 
    154             fbdata%caddunit(1+ja,jvar) = padd%cdunit(ja,jvar) 
    155          END DO 
    156       END DO 
    157           
    158       WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 
     180 
     181      WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc 
    159182 
    160183      IF(lwp) THEN 
    161184         WRITE(numout,*) 
    162          WRITE(numout,*)'obs_wri_p3d :' 
     185         WRITE(numout,*)'obs_wri_prof :' 
    163186         WRITE(numout,*)'~~~~~~~~~~~~~' 
    164          WRITE(numout,*)'Writing profile feedback file : ',TRIM(cfname) 
    165       ENDIF 
    166  
    167       ! Transform obs_prof data structure into obfbdata structure 
     187         WRITE(numout,*)'Writing '//TRIM(clfiletype)//' feedback file : ',TRIM(clfname) 
     188      ENDIF 
     189 
     190      ! Transform obs_prof data structure into obfb data structure 
    168191      fbdata%cdjuldref = '19500101000000' 
    169192      DO jo = 1, profdata%nprof 
     
    222245               ENDIF 
    223246               fbdata%iobsk(ik,jo,jvar)  = profdata%var(jvar)%mvk(jk) 
    224                DO ja = 1, nadd 
     247               DO ja = 1, iadd 
    225248                  fbdata%padd(ik,jo,1+ja,jvar) = & 
    226249                     & profdata%var(jvar)%vext(jk,padd%ipoint(ja)) 
    227250               END DO 
    228                DO je = 1, next 
     251               DO je = 1, iext 
    229252                  fbdata%pext(ik,jo,1+je) = & 
    230253                     & profdata%var(jvar)%vext(jk,pext%ipoint(je)) 
    231254               END DO 
    232                IF ( jvar == 1 ) THEN 
     255               IF ( ( jvar == 1 ) .AND. & 
     256                  & ( TRIM(profdata%cvars(1)) == 'POTM' ) ) THEN 
    233257                  fbdata%pext(ik,jo,1) = profdata%var(jvar)%vext(jk,1) 
    234258               ENDIF  
     
    237261      END DO 
    238262 
    239       ! Convert insitu temperature to potential temperature using the model 
    240       ! salinity if no potential temperature 
    241       DO jo = 1, fbdata%nobs 
    242          IF ( fbdata%pphi(jo) < 9999.0 ) THEN 
    243             DO jk = 1, fbdata%nlev 
    244                IF ( ( fbdata%pob(jk,jo,1) >= 9999.0 ) .AND. & 
    245                   & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 
    246                   & ( fbdata%padd(jk,jo,1,2) < 9999.0 ) .AND. & 
    247                   & ( fbdata%pext(jk,jo,1) < 9999.0 ) ) THEN 
    248                   zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), & 
    249                      &              REAL(fbdata%pphi(jo),wp) ) 
    250                   fbdata%pob(jk,jo,1) = potemp( & 
    251                      &                     REAL(fbdata%padd(jk,jo,1,2), wp),  & 
    252                      &                     REAL(fbdata%pext(jk,jo,1), wp), & 
    253                      &                     zpres, 0.0_wp ) 
    254                ENDIF 
    255             END DO 
    256          ENDIF 
    257       END DO 
    258        
     263      IF ( TRIM(profdata%cvars(1)) == 'POTM' ) THEN 
     264         ! Convert insitu temperature to potential temperature using the model 
     265         ! salinity if no potential temperature 
     266         DO jo = 1, fbdata%nobs 
     267            IF ( fbdata%pphi(jo) < 9999.0 ) THEN 
     268               DO jk = 1, fbdata%nlev 
     269                  IF ( ( fbdata%pob(jk,jo,1) >= 9999.0 ) .AND. & 
     270                     & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 
     271                     & ( fbdata%padd(jk,jo,1,2) < 9999.0 ) .AND. & 
     272                     & ( fbdata%pext(jk,jo,1) < 9999.0 ) ) THEN 
     273                     zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), & 
     274                        &              REAL(fbdata%pphi(jo),wp) ) 
     275                     fbdata%pob(jk,jo,1) = potemp( & 
     276                        &                     REAL(fbdata%padd(jk,jo,1,2), wp),  & 
     277                        &                     REAL(fbdata%pext(jk,jo,1), wp), & 
     278                        &                     zpres, 0.0_wp ) 
     279                  ENDIF 
     280               END DO 
     281            ENDIF 
     282         END DO 
     283      ENDIF 
     284 
    259285      ! Write the obfbdata structure 
    260       CALL write_obfbdata( cfname, fbdata ) 
     286      CALL write_obfbdata( clfname, fbdata ) 
    261287 
    262288      ! Output some basic statistics 
     
    264290 
    265291      CALL dealloc_obfbdata( fbdata ) 
    266       
    267    END SUBROUTINE obs_wri_p3d 
    268  
    269    SUBROUTINE obs_wri_sla( cprefix, sladata, padd, pext ) 
     292 
     293   END SUBROUTINE obs_wri_prof 
     294 
     295   SUBROUTINE obs_wri_surf( surfdata, padd, pext ) 
    270296      !!----------------------------------------------------------------------- 
    271297      !! 
    272       !!                     *** ROUTINE obs_wri_sla  *** 
    273       !! 
    274       !! ** Purpose : Write SLA observation diagnostics 
    275       !!              related  
     298      !!                     *** ROUTINE obs_wri_surf  *** 
     299      !! 
     300      !! ** Purpose : Write surface observation files 
    276301      !! 
    277302      !! ** Method  : NetCDF 
     
    281306      !!      ! 07-03  (K. Mogensen) Original 
    282307      !!      ! 09-01  (K. Mogensen) New feedback format. 
     308      !!      ! 15-02  (M. Martin) Combined surface writing routine. 
    283309      !!----------------------------------------------------------------------- 
    284310 
     
    287313 
    288314      !! * Arguments 
    289       CHARACTER(LEN=*), INTENT(IN) :: cprefix          ! Prefix for output files 
    290       TYPE(obs_surf), INTENT(INOUT) :: sladata         ! Full set of SLAa 
     315      TYPE(obs_surf), INTENT(INOUT) :: surfdata         ! Full set of surface data 
    291316      TYPE(obswriinfo), OPTIONAL :: padd               ! Additional info for each variable 
    292317      TYPE(obswriinfo), OPTIONAL :: pext               ! Extra info 
     
    294319      !! * Local declarations 
    295320      TYPE(obfbdata) :: fbdata 
    296       CHARACTER(LEN=40) :: cfname         ! netCDF filename 
    297       CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_sla' 
     321      CHARACTER(LEN=40) :: clfname         ! netCDF filename 
     322      CHARACTER(LEN=6)  :: clfiletype 
     323      CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_surf' 
    298324      INTEGER :: jo 
    299325      INTEGER :: ja 
    300326      INTEGER :: je 
    301       INTEGER :: nadd 
    302       INTEGER :: next 
     327      INTEGER :: iadd 
     328      INTEGER :: iext 
    303329 
    304330      IF ( PRESENT( padd ) ) THEN 
    305          nadd = padd%inum 
     331         iadd = padd%inum 
    306332      ELSE 
    307          nadd = 0 
     333         iadd = 0 
    308334      ENDIF 
    309335 
    310336      IF ( PRESENT( pext ) ) THEN 
    311          next = pext%inum 
     337         iext = pext%inum 
    312338      ELSE 
    313          next = 0 
     339         iext = 0 
    314340      ENDIF 
    315341 
    316342      CALL init_obfbdata( fbdata ) 
    317343 
    318       CALL alloc_obfbdata( fbdata, 1, sladata%nsurf, 1, & 
    319          &                 2 + nadd, 1 + next, .TRUE. ) 
    320  
    321       fbdata%cname(1)      = 'SLA' 
    322       fbdata%coblong(1)    = 'Sea level anomaly' 
    323       fbdata%cobunit(1)    = 'Metres' 
    324       fbdata%cextname(1)   = 'MDT' 
    325       fbdata%cextlong(1)   = 'Mean dynamic topography' 
    326       fbdata%cextunit(1)   = 'Metres' 
    327       DO je = 1, next 
    328          fbdata%cextname(1+je) = pext%cdname(je) 
    329          fbdata%cextlong(1+je) = pext%cdlong(je,1) 
    330          fbdata%cextunit(1+je) = pext%cdunit(je,1) 
    331       END DO 
     344      SELECT CASE ( TRIM(surfdata%cvars(1)) ) 
     345      CASE('SLA') 
     346 
     347         CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 
     348            &                 2 + iadd, 1 + iext, .TRUE. ) 
     349 
     350         clfiletype = 'slafb' 
     351         fbdata%cname(1)      = surfdata%cvars(1) 
     352         fbdata%coblong(1)    = 'Sea level anomaly' 
     353         fbdata%cobunit(1)    = 'Metres' 
     354         fbdata%cextname(1)   = 'MDT' 
     355         fbdata%cextlong(1)   = 'Mean dynamic topography' 
     356         fbdata%cextunit(1)   = 'Metres' 
     357         DO je = 1, iext 
     358            fbdata%cextname(je) = pext%cdname(je) 
     359            fbdata%cextlong(je) = pext%cdlong(je,1) 
     360            fbdata%cextunit(je) = pext%cdunit(je,1) 
     361         END DO 
     362         fbdata%caddlong(1,1) = 'Model interpolated SSH - MDT' 
     363         fbdata%caddunit(1,1) = 'Metres'  
     364         fbdata%caddname(2)   = 'SSH' 
     365         fbdata%caddlong(2,1) = 'Model Sea surface height' 
     366         fbdata%caddunit(2,1) = 'Metres' 
     367         fbdata%cgrid(1)      = 'T' 
     368         DO ja = 1, iadd 
     369            fbdata%caddname(2+ja) = padd%cdname(ja) 
     370            fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1) 
     371            fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1) 
     372         END DO 
     373 
     374      CASE('SST') 
     375 
     376         CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 
     377            &                 1 + iadd, iext, .TRUE. ) 
     378 
     379         clfiletype = 'sstfb' 
     380         fbdata%cname(1)      = surfdata%cvars(1) 
     381         fbdata%coblong(1)    = 'Sea surface temperature' 
     382         fbdata%cobunit(1)    = 'Degree centigrade' 
     383         DO je = 1, iext 
     384            fbdata%cextname(je) = pext%cdname(je) 
     385            fbdata%cextlong(je) = pext%cdlong(je,1) 
     386            fbdata%cextunit(je) = pext%cdunit(je,1) 
     387         END DO 
     388         fbdata%caddlong(1,1) = 'Model interpolated SST' 
     389         fbdata%caddunit(1,1) = 'Degree centigrade' 
     390         fbdata%cgrid(1)      = 'T' 
     391         DO ja = 1, iadd 
     392            fbdata%caddname(1+ja) = padd%cdname(ja) 
     393            fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 
     394            fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 
     395         END DO 
     396 
     397      CASE('ICECON') 
     398 
     399         CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 
     400            &                 1 + iadd, iext, .TRUE. ) 
     401 
     402         clfiletype = 'sicfb' 
     403         fbdata%cname(1)      = surfdata%cvars(1) 
     404         fbdata%coblong(1)    = 'Sea ice' 
     405         fbdata%cobunit(1)    = 'Fraction' 
     406         DO je = 1, iext 
     407            fbdata%cextname(je) = pext%cdname(je) 
     408            fbdata%cextlong(je) = pext%cdlong(je,1) 
     409            fbdata%cextunit(je) = pext%cdunit(je,1) 
     410         END DO 
     411         fbdata%caddlong(1,1) = 'Model interpolated ICE' 
     412         fbdata%caddunit(1,1) = 'Fraction' 
     413         fbdata%cgrid(1)      = 'T' 
     414         DO ja = 1, iadd 
     415            fbdata%caddname(1+ja) = padd%cdname(ja) 
     416            fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 
     417            fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 
     418         END DO 
     419 
     420      END SELECT 
     421 
    332422      fbdata%caddname(1)   = 'Hx' 
    333       fbdata%caddlong(1,1) = 'Model interpolated SSH - MDT' 
    334       fbdata%caddunit(1,1) = 'Metres'  
    335       fbdata%caddname(2)   = 'SSH' 
    336       fbdata%caddlong(2,1) = 'Model Sea surface height' 
    337       fbdata%caddunit(2,1) = 'Metres' 
    338       fbdata%cgrid(1)      = 'T' 
    339       DO ja = 1, nadd 
    340          fbdata%caddname(2+ja) = padd%cdname(ja) 
    341          fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1) 
    342          fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1) 
    343       END DO 
    344  
    345       WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 
     423 
     424      WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc 
    346425 
    347426      IF(lwp) THEN 
    348427         WRITE(numout,*) 
    349          WRITE(numout,*)'obs_wri_sla :' 
     428         WRITE(numout,*)'obs_wri_surf :' 
    350429         WRITE(numout,*)'~~~~~~~~~~~~~' 
    351          WRITE(numout,*)'Writing SLA feedback file : ',TRIM(cfname) 
    352       ENDIF 
    353  
    354       ! Transform obs_prof data structure into obfbdata structure 
     430         WRITE(numout,*)'Writing '//TRIM(surfdata%cvars(1))//' feedback file : ',TRIM(clfname) 
     431      ENDIF 
     432 
     433      ! Transform surf data structure into obfbdata structure 
    355434      fbdata%cdjuldref = '19500101000000' 
    356       DO jo = 1, sladata%nsurf 
    357          fbdata%plam(jo)      = sladata%rlam(jo) 
    358          fbdata%pphi(jo)      = sladata%rphi(jo) 
    359          WRITE(fbdata%cdtyp(jo),'(I4)') sladata%ntyp(jo) 
     435      DO jo = 1, surfdata%nsurf 
     436         fbdata%plam(jo)      = surfdata%rlam(jo) 
     437         fbdata%pphi(jo)      = surfdata%rphi(jo) 
     438         WRITE(fbdata%cdtyp(jo),'(I4)') surfdata%ntyp(jo) 
    360439         fbdata%ivqc(jo,:)    = 0 
    361440         fbdata%ivqcf(:,jo,:) = 0 
    362          IF ( sladata%nqc(jo) > 10 ) THEN 
     441         IF ( surfdata%nqc(jo) > 10 ) THEN 
    363442            fbdata%ioqc(jo)    = 4 
    364443            fbdata%ioqcf(1,jo) = 0 
    365             fbdata%ioqcf(2,jo) = sladata%nqc(jo) - 10 
     444            fbdata%ioqcf(2,jo) = surfdata%nqc(jo) - 10 
    366445         ELSE 
    367             fbdata%ioqc(jo)    = sladata%nqc(jo) 
     446            fbdata%ioqc(jo)    = surfdata%nqc(jo) 
    368447            fbdata%ioqcf(:,jo) = 0 
    369448         ENDIF 
     
    372451         fbdata%itqc(jo)      = 0 
    373452         fbdata%itqcf(:,jo)   = 0 
    374          fbdata%cdwmo(jo)     = sladata%cwmo(jo) 
    375          fbdata%kindex(jo)    = sladata%nsfil(jo) 
     453         fbdata%cdwmo(jo)     = surfdata%cwmo(jo) 
     454         fbdata%kindex(jo)    = surfdata%nsfil(jo) 
    376455         IF (ln_grid_global) THEN 
    377             fbdata%iobsi(jo,1) = sladata%mi(jo) 
    378             fbdata%iobsj(jo,1) = sladata%mj(jo) 
     456            fbdata%iobsi(jo,1) = surfdata%mi(jo) 
     457            fbdata%iobsj(jo,1) = surfdata%mj(jo) 
    379458         ELSE 
    380             fbdata%iobsi(jo,1) = mig(sladata%mi(jo)) 
    381             fbdata%iobsj(jo,1) = mjg(sladata%mj(jo)) 
     459            fbdata%iobsi(jo,1) = mig(surfdata%mi(jo)) 
     460            fbdata%iobsj(jo,1) = mjg(surfdata%mj(jo)) 
    382461         ENDIF 
    383462         CALL greg2jul( 0, & 
    384             &           sladata%nmin(jo), & 
    385             &           sladata%nhou(jo), & 
    386             &           sladata%nday(jo), & 
    387             &           sladata%nmon(jo), & 
    388             &           sladata%nyea(jo), & 
     463            &           surfdata%nmin(jo), & 
     464            &           surfdata%nhou(jo), & 
     465            &           surfdata%nday(jo), & 
     466            &           surfdata%nmon(jo), & 
     467            &           surfdata%nyea(jo), & 
    389468            &           fbdata%ptim(jo),   & 
    390469            &           krefdate = 19500101 ) 
    391          fbdata%padd(1,jo,1,1) = sladata%rmod(jo,1) 
    392          fbdata%padd(1,jo,2,1) = sladata%rext(jo,1) 
    393          fbdata%pob(1,jo,1)    = sladata%robs(jo,1)  
     470         fbdata%padd(1,jo,1,1) = surfdata%rmod(jo,1) 
     471         IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%padd(1,jo,2,1) = surfdata%rext(jo,1) 
     472         fbdata%pob(1,jo,1)    = surfdata%robs(jo,1)  
    394473         fbdata%pdep(1,jo)     = 0.0 
    395474         fbdata%idqc(1,jo)     = 0 
    396475         fbdata%idqcf(:,1,jo)  = 0 
    397          IF ( sladata%nqc(jo) > 10 ) THEN 
     476         IF ( surfdata%nqc(jo) > 10 ) THEN 
    398477            fbdata%ivqc(jo,1)       = 4 
    399478            fbdata%ivlqc(1,jo,1)    = 4 
    400479            fbdata%ivlqcf(1,1,jo,1) = 0 
    401             fbdata%ivlqcf(2,1,jo,1) = sladata%nqc(jo) - 10 
     480            fbdata%ivlqcf(2,1,jo,1) = surfdata%nqc(jo) - 10 
    402481         ELSE 
    403             fbdata%ivqc(jo,1)       = sladata%nqc(jo) 
    404             fbdata%ivlqc(1,jo,1)    = sladata%nqc(jo) 
     482            fbdata%ivqc(jo,1)       = surfdata%nqc(jo) 
     483            fbdata%ivlqc(1,jo,1)    = surfdata%nqc(jo) 
    405484            fbdata%ivlqcf(:,1,jo,1) = 0 
    406485         ENDIF 
    407486         fbdata%iobsk(1,jo,1)  = 0 
    408          fbdata%pext(1,jo,1) = sladata%rext(jo,2) 
    409          DO ja = 1, nadd 
     487         IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%pext(1,jo,1) = surfdata%rext(jo,2) 
     488         DO ja = 1, iadd 
    410489            fbdata%padd(1,jo,2+ja,1) = & 
    411                & sladata%rext(jo,padd%ipoint(ja)) 
    412          END DO 
    413          DO je = 1, next 
     490               & surfdata%rext(jo,padd%ipoint(ja)) 
     491         END DO 
     492         DO je = 1, iext 
    414493            fbdata%pext(1,jo,1+je) = & 
    415                & sladata%rext(jo,pext%ipoint(je)) 
     494               & surfdata%rext(jo,pext%ipoint(je)) 
    416495         END DO 
    417496      END DO 
    418497 
    419498      ! Write the obfbdata structure 
    420       CALL write_obfbdata( cfname, fbdata ) 
     499      CALL write_obfbdata( clfname, fbdata ) 
    421500 
    422501      ! Output some basic statistics 
     
    425504      CALL dealloc_obfbdata( fbdata ) 
    426505 
    427    END SUBROUTINE obs_wri_sla 
    428  
    429    SUBROUTINE obs_wri_sst( cprefix, sstdata, padd, pext ) 
    430       !!----------------------------------------------------------------------- 
    431       !! 
    432       !!                     *** ROUTINE obs_wri_sst  *** 
    433       !! 
    434       !! ** Purpose : Write SST observation diagnostics 
    435       !!              related  
    436       !! 
    437       !! ** Method  : NetCDF 
    438       !!  
    439       !! ** Action  : 
    440       !! 
    441       !!      ! 07-07  (S. Ricci) Original 
    442       !!      ! 09-01  (K. Mogensen) New feedback format. 
    443       !!----------------------------------------------------------------------- 
    444  
    445       !! * Modules used 
    446       IMPLICIT NONE 
    447  
    448       !! * Arguments 
    449       CHARACTER(LEN=*), INTENT(IN) :: cprefix       ! Prefix for output files 
    450       TYPE(obs_surf), INTENT(INOUT) :: sstdata      ! Full set of SST 
    451       TYPE(obswriinfo), OPTIONAL :: padd            ! Additional info for each variable 
    452       TYPE(obswriinfo), OPTIONAL :: pext            ! Extra info 
    453  
    454       !! * Local declarations  
    455       TYPE(obfbdata) :: fbdata 
    456       CHARACTER(LEN=40) ::  cfname             ! netCDF filename 
    457       CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_sst' 
    458       INTEGER :: jo 
    459       INTEGER :: ja 
    460       INTEGER :: je 
    461       INTEGER :: nadd 
    462       INTEGER :: next 
    463  
    464       IF ( PRESENT( padd ) ) THEN 
    465          nadd = padd%inum 
    466       ELSE 
    467          nadd = 0 
    468       ENDIF 
    469  
    470       IF ( PRESENT( pext ) ) THEN 
    471          next = pext%inum 
    472       ELSE 
    473          next = 0 
    474       ENDIF 
    475  
    476       CALL init_obfbdata( fbdata ) 
    477  
    478       CALL alloc_obfbdata( fbdata, 1, sstdata%nsurf, 1, & 
    479          &                 1 + nadd, next, .TRUE. ) 
    480  
    481       fbdata%cname(1)      = 'SST' 
    482       fbdata%coblong(1)    = 'Sea surface temperature' 
    483       fbdata%cobunit(1)    = 'Degree centigrade' 
    484       DO je = 1, next 
    485          fbdata%cextname(je) = pext%cdname(je) 
    486          fbdata%cextlong(je) = pext%cdlong(je,1) 
    487          fbdata%cextunit(je) = pext%cdunit(je,1) 
    488       END DO 
    489       fbdata%caddname(1)   = 'Hx' 
    490       fbdata%caddlong(1,1) = 'Model interpolated SST' 
    491       fbdata%caddunit(1,1) = 'Degree centigrade' 
    492       fbdata%cgrid(1)      = 'T' 
    493       DO ja = 1, nadd 
    494          fbdata%caddname(1+ja) = padd%cdname(ja) 
    495          fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 
    496          fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 
    497       END DO 
    498  
    499       WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 
    500  
    501       IF(lwp) THEN 
    502          WRITE(numout,*) 
    503          WRITE(numout,*)'obs_wri_sst :' 
    504          WRITE(numout,*)'~~~~~~~~~~~~~' 
    505          WRITE(numout,*)'Writing SST feedback file : ',TRIM(cfname) 
    506       ENDIF 
    507  
    508       ! Transform obs_prof data structure into obfbdata structure 
    509       fbdata%cdjuldref = '19500101000000' 
    510       DO jo = 1, sstdata%nsurf 
    511          fbdata%plam(jo)      = sstdata%rlam(jo) 
    512          fbdata%pphi(jo)      = sstdata%rphi(jo) 
    513          WRITE(fbdata%cdtyp(jo),'(I4)') sstdata%ntyp(jo) 
    514          fbdata%ivqc(jo,:)    = 0 
    515          fbdata%ivqcf(:,jo,:) = 0 
    516          IF ( sstdata%nqc(jo) > 10 ) THEN 
    517             fbdata%ioqc(jo)    = 4 
    518             fbdata%ioqcf(1,jo) = 0 
    519             fbdata%ioqcf(2,jo) = sstdata%nqc(jo) - 10 
    520          ELSE 
    521             fbdata%ioqc(jo)    = MAX(sstdata%nqc(jo),1) 
    522             fbdata%ioqcf(:,jo) = 0 
    523          ENDIF 
    524          fbdata%ipqc(jo)      = 0 
    525          fbdata%ipqcf(:,jo)   = 0 
    526          fbdata%itqc(jo)      = 0 
    527          fbdata%itqcf(:,jo)   = 0 
    528          fbdata%cdwmo(jo)     = '' 
    529          fbdata%kindex(jo)    = sstdata%nsfil(jo) 
    530          IF (ln_grid_global) THEN 
    531             fbdata%iobsi(jo,1) = sstdata%mi(jo) 
    532             fbdata%iobsj(jo,1) = sstdata%mj(jo) 
    533          ELSE 
    534             fbdata%iobsi(jo,1) = mig(sstdata%mi(jo)) 
    535             fbdata%iobsj(jo,1) = mjg(sstdata%mj(jo)) 
    536          ENDIF 
    537          CALL greg2jul( 0, & 
    538             &           sstdata%nmin(jo), & 
    539             &           sstdata%nhou(jo), & 
    540             &           sstdata%nday(jo), & 
    541             &           sstdata%nmon(jo), & 
    542             &           sstdata%nyea(jo), & 
    543             &           fbdata%ptim(jo),   & 
    544             &           krefdate = 19500101 ) 
    545          fbdata%padd(1,jo,1,1) = sstdata%rmod(jo,1) 
    546          fbdata%pob(1,jo,1)    = sstdata%robs(jo,1) 
    547          fbdata%pdep(1,jo)     = 0.0 
    548          fbdata%idqc(1,jo)     = 0 
    549          fbdata%idqcf(:,1,jo)  = 0 
    550          IF ( sstdata%nqc(jo) > 10 ) THEN 
    551             fbdata%ivqc(jo,1)       = 4 
    552             fbdata%ivlqc(1,jo,1)    = 4 
    553             fbdata%ivlqcf(1,1,jo,1) = 0 
    554             fbdata%ivlqcf(2,1,jo,1) = sstdata%nqc(jo) - 10 
    555          ELSE 
    556             fbdata%ivqc(jo,1)       = MAX(sstdata%nqc(jo),1) 
    557             fbdata%ivlqc(1,jo,1)    = MAX(sstdata%nqc(jo),1) 
    558             fbdata%ivlqcf(:,1,jo,1) = 0 
    559          ENDIF 
    560          fbdata%iobsk(1,jo,1)  = 0 
    561          DO ja = 1, nadd 
    562             fbdata%padd(1,jo,1+ja,1) = & 
    563                & sstdata%rext(jo,padd%ipoint(ja)) 
    564          END DO 
    565          DO je = 1, next 
    566             fbdata%pext(1,jo,je) = & 
    567                & sstdata%rext(jo,pext%ipoint(je)) 
    568          END DO 
    569  
    570       END DO 
    571  
    572       ! Write the obfbdata structure 
    573  
    574       CALL write_obfbdata( cfname, fbdata ) 
    575  
    576       ! Output some basic statistics 
    577       CALL obs_wri_stats( fbdata ) 
    578  
    579       CALL dealloc_obfbdata( fbdata ) 
    580  
    581    END SUBROUTINE obs_wri_sst 
    582  
    583    SUBROUTINE obs_wri_sss 
    584    END SUBROUTINE obs_wri_sss 
    585  
    586    SUBROUTINE obs_wri_seaice( cprefix, seaicedata, padd, pext ) 
    587       !!----------------------------------------------------------------------- 
    588       !! 
    589       !!                     *** ROUTINE obs_wri_seaice  *** 
    590       !! 
    591       !! ** Purpose : Write sea ice observation diagnostics 
    592       !!              related  
    593       !! 
    594       !! ** Method  : NetCDF 
    595       !!  
    596       !! ** Action  : 
    597       !! 
    598       !!      ! 07-07  (S. Ricci) Original 
    599       !!      ! 09-01  (K. Mogensen) New feedback format. 
    600       !!----------------------------------------------------------------------- 
    601  
    602       !! * Modules used 
    603       IMPLICIT NONE 
    604  
    605       !! * Arguments 
    606       CHARACTER(LEN=*), INTENT(IN) :: cprefix       ! Prefix for output files 
    607       TYPE(obs_surf), INTENT(INOUT) :: seaicedata   ! Full set of sea ice 
    608       TYPE(obswriinfo), OPTIONAL :: padd            ! Additional info for each variable 
    609       TYPE(obswriinfo), OPTIONAL :: pext            ! Extra info 
    610  
    611       !! * Local declarations  
    612       TYPE(obfbdata) :: fbdata 
    613       CHARACTER(LEN=40) :: cfname             ! netCDF filename 
    614       CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_seaice' 
    615       INTEGER :: jo 
    616       INTEGER :: ja 
    617       INTEGER :: je 
    618       INTEGER :: nadd 
    619       INTEGER :: next 
    620  
    621       IF ( PRESENT( padd ) ) THEN 
    622          nadd = padd%inum 
    623       ELSE 
    624          nadd = 0 
    625       ENDIF 
    626  
    627       IF ( PRESENT( pext ) ) THEN 
    628          next = pext%inum 
    629       ELSE 
    630          next = 0 
    631       ENDIF 
    632  
    633       CALL init_obfbdata( fbdata ) 
    634  
    635       CALL alloc_obfbdata( fbdata, 1, seaicedata%nsurf, 1, 1, 0, .TRUE. ) 
    636  
    637       fbdata%cname(1)      = 'SEAICE' 
    638       fbdata%coblong(1)    = 'Sea ice' 
    639       fbdata%cobunit(1)    = 'Fraction' 
    640       DO je = 1, next 
    641          fbdata%cextname(je) = pext%cdname(je) 
    642          fbdata%cextlong(je) = pext%cdlong(je,1) 
    643          fbdata%cextunit(je) = pext%cdunit(je,1) 
    644       END DO 
    645       fbdata%caddname(1)   = 'Hx' 
    646       fbdata%caddlong(1,1) = 'Model interpolated ICE' 
    647       fbdata%caddunit(1,1) = 'Fraction' 
    648       fbdata%cgrid(1)      = 'T' 
    649       DO ja = 1, nadd 
    650          fbdata%caddname(1+ja) = padd%cdname(ja) 
    651          fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 
    652          fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 
    653       END DO 
    654  
    655       WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 
    656  
    657       IF(lwp) THEN 
    658          WRITE(numout,*) 
    659          WRITE(numout,*)'obs_wri_seaice :' 
    660          WRITE(numout,*)'~~~~~~~~~~~~~~~~' 
    661          WRITE(numout,*)'Writing SEAICE feedback file : ',TRIM(cfname) 
    662       ENDIF 
    663  
    664       ! Transform obs_prof data structure into obfbdata structure 
    665       fbdata%cdjuldref = '19500101000000' 
    666       DO jo = 1, seaicedata%nsurf 
    667          fbdata%plam(jo)      = seaicedata%rlam(jo) 
    668          fbdata%pphi(jo)      = seaicedata%rphi(jo) 
    669          WRITE(fbdata%cdtyp(jo),'(I4)') seaicedata%ntyp(jo) 
    670          fbdata%ivqc(jo,:)    = 0 
    671          fbdata%ivqcf(:,jo,:) = 0 
    672          IF ( seaicedata%nqc(jo) > 10 ) THEN 
    673             fbdata%ioqc(jo)    = 4 
    674             fbdata%ioqcf(1,jo) = 0 
    675             fbdata%ioqcf(2,jo) = seaicedata%nqc(jo) - 10 
    676          ELSE 
    677             fbdata%ioqc(jo)    = MAX(seaicedata%nqc(jo),1) 
    678             fbdata%ioqcf(:,jo) = 0 
    679          ENDIF 
    680          fbdata%ipqc(jo)      = 0 
    681          fbdata%ipqcf(:,jo)   = 0 
    682          fbdata%itqc(jo)      = 0 
    683          fbdata%itqcf(:,jo)   = 0 
    684          fbdata%cdwmo(jo)     = '' 
    685          fbdata%kindex(jo)    = seaicedata%nsfil(jo) 
    686          IF (ln_grid_global) THEN 
    687             fbdata%iobsi(jo,1) = seaicedata%mi(jo) 
    688             fbdata%iobsj(jo,1) = seaicedata%mj(jo) 
    689          ELSE 
    690             fbdata%iobsi(jo,1) = mig(seaicedata%mi(jo)) 
    691             fbdata%iobsj(jo,1) = mjg(seaicedata%mj(jo)) 
    692          ENDIF 
    693          CALL greg2jul( 0, & 
    694             &           seaicedata%nmin(jo), & 
    695             &           seaicedata%nhou(jo), & 
    696             &           seaicedata%nday(jo), & 
    697             &           seaicedata%nmon(jo), & 
    698             &           seaicedata%nyea(jo), & 
    699             &           fbdata%ptim(jo),   & 
    700             &           krefdate = 19500101 ) 
    701          fbdata%padd(1,jo,1,1) = seaicedata%rmod(jo,1) 
    702          fbdata%pob(1,jo,1)    = seaicedata%robs(jo,1) 
    703          fbdata%pdep(1,jo)     = 0.0 
    704          fbdata%idqc(1,jo)     = 0 
    705          fbdata%idqcf(:,1,jo)  = 0 
    706          IF ( seaicedata%nqc(jo) > 10 ) THEN 
    707             fbdata%ivlqc(1,jo,1) = 4 
    708             fbdata%ivlqcf(1,1,jo,1) = 0 
    709             fbdata%ivlqcf(2,1,jo,1) = seaicedata%nqc(jo) - 10 
    710          ELSE 
    711             fbdata%ivlqc(1,jo,1) = MAX(seaicedata%nqc(jo),1) 
    712             fbdata%ivlqcf(:,1,jo,1) = 0 
    713          ENDIF 
    714          fbdata%iobsk(1,jo,1)  = 0 
    715          DO ja = 1, nadd 
    716             fbdata%padd(1,jo,1+ja,1) = & 
    717                & seaicedata%rext(jo,padd%ipoint(ja)) 
    718          END DO 
    719          DO je = 1, next 
    720             fbdata%pext(1,jo,je) = & 
    721                & seaicedata%rext(jo,pext%ipoint(je)) 
    722          END DO 
    723  
    724       END DO 
    725  
    726       ! Write the obfbdata structure 
    727       CALL write_obfbdata( cfname, fbdata ) 
    728  
    729       ! Output some basic statistics 
    730       CALL obs_wri_stats( fbdata ) 
    731  
    732       CALL dealloc_obfbdata( fbdata ) 
    733  
    734    END SUBROUTINE obs_wri_seaice 
    735  
    736    SUBROUTINE obs_wri_vel( cprefix, profdata, k2dint, padd, pext ) 
    737       !!----------------------------------------------------------------------- 
    738       !! 
    739       !!                     *** ROUTINE obs_wri_vel  *** 
    740       !! 
    741       !! ** Purpose : Write current (profile) observation  
    742       !!              related diagnostics 
    743       !! 
    744       !! ** Method  : NetCDF 
    745       !!  
    746       !! ** Action  : 
    747       !! 
    748       !! History : 
    749       !!      ! 09-01  (K. Mogensen) New feedback format routine 
    750       !!----------------------------------------------------------------------- 
    751  
    752       !! * Modules used 
    753  
    754       !! * Arguments 
    755       CHARACTER(LEN=*), INTENT(IN) :: cprefix       ! Prefix for output files 
    756       TYPE(obs_prof), INTENT(INOUT) :: profdata     ! Full set of profile data 
    757       INTEGER, INTENT(IN) :: k2dint                 ! Horizontal interpolation method 
    758       TYPE(obswriinfo), OPTIONAL :: padd            ! Additional info for each variable 
    759       TYPE(obswriinfo), OPTIONAL :: pext            ! Extra info 
    760  
    761       !! * Local declarations 
    762       TYPE(obfbdata) :: fbdata 
    763       CHARACTER(LEN=40) :: cfname 
    764       INTEGER :: ilevel 
    765       INTEGER :: jvar 
    766       INTEGER :: jk 
    767       INTEGER :: ik 
    768       INTEGER :: jo 
    769       INTEGER :: ja 
    770       INTEGER :: je 
    771       INTEGER :: nadd 
    772       INTEGER :: next 
    773       REAL(wp) :: zpres 
    774       REAL(wp), DIMENSION(:), ALLOCATABLE :: & 
    775          & zu, & 
    776          & zv 
    777  
    778       IF ( PRESENT( padd ) ) THEN 
    779          nadd = padd%inum 
    780       ELSE 
    781          nadd = 0 
    782       ENDIF 
    783  
    784       IF ( PRESENT( pext ) ) THEN 
    785          next = pext%inum 
    786       ELSE 
    787          next = 0 
    788       ENDIF 
    789  
    790       CALL init_obfbdata( fbdata ) 
    791  
    792       ! Find maximum level 
    793       ilevel = 0 
    794       DO jvar = 1, 2 
    795          ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) ) 
    796       END DO 
    797       CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, 2, 0, .TRUE. ) 
    798  
    799       fbdata%cname(1)      = 'UVEL' 
    800       fbdata%cname(2)      = 'VVEL' 
    801       fbdata%coblong(1)    = 'Zonal velocity' 
    802       fbdata%coblong(2)    = 'Meridional velocity' 
    803       fbdata%cobunit(1)    = 'm/s' 
    804       fbdata%cobunit(2)    = 'm/s' 
    805       DO je = 1, next 
    806          fbdata%cextname(je) = pext%cdname(je) 
    807          fbdata%cextlong(je) = pext%cdlong(je,1) 
    808          fbdata%cextunit(je) = pext%cdunit(je,1) 
    809       END DO 
    810       fbdata%caddname(1)   = 'Hx' 
    811       fbdata%caddlong(1,1) = 'Model interpolated zonal velocity' 
    812       fbdata%caddlong(1,2) = 'Model interpolated meridional velocity' 
    813       fbdata%caddunit(1,1) = 'm/s' 
    814       fbdata%caddunit(1,2) = 'm/s' 
    815       fbdata%caddname(2)   = 'HxG' 
    816       fbdata%caddlong(2,1) = 'Model interpolated zonal velocity (model grid)' 
    817       fbdata%caddlong(2,2) = 'Model interpolated meridional velocity (model grid)' 
    818       fbdata%caddunit(2,1) = 'm/s' 
    819       fbdata%caddunit(2,2) = 'm/s'  
    820       fbdata%cgrid(1)      = 'U'  
    821       fbdata%cgrid(2)      = 'V' 
    822       DO ja = 1, nadd 
    823          fbdata%caddname(2+ja) = padd%cdname(ja) 
    824          fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1) 
    825          fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1) 
    826       END DO 
    827  
    828       WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 
    829  
    830       IF(lwp) THEN 
    831          WRITE(numout,*) 
    832          WRITE(numout,*)'obs_wri_vel :' 
    833          WRITE(numout,*)'~~~~~~~~~~~~~' 
    834          WRITE(numout,*)'Writing velocuty feedback file : ',TRIM(cfname) 
    835       ENDIF 
    836  
    837       ALLOCATE( & 
    838          & zu(profdata%nvprot(1)), & 
    839          & zv(profdata%nvprot(2))  & 
    840          & ) 
    841       CALL obs_rotvel( profdata, k2dint, zu, zv ) 
    842  
    843       ! Transform obs_prof data structure into obfbdata structure 
    844       fbdata%cdjuldref = '19500101000000' 
    845       DO jo = 1, profdata%nprof 
    846          fbdata%plam(jo)      = profdata%rlam(jo) 
    847          fbdata%pphi(jo)      = profdata%rphi(jo) 
    848          WRITE(fbdata%cdtyp(jo),'(I4)') profdata%ntyp(jo) 
    849          fbdata%ivqc(jo,:)    = profdata%ivqc(jo,:) 
    850          fbdata%ivqcf(:,jo,:) = profdata%ivqcf(:,jo,:) 
    851          IF ( profdata%nqc(jo) > 10 ) THEN 
    852             fbdata%ioqc(jo)    = 4 
    853             fbdata%ioqcf(1,jo) = profdata%nqcf(1,jo) 
    854             fbdata%ioqcf(2,jo) = profdata%nqc(jo) - 10 
    855          ELSE 
    856             fbdata%ioqc(jo)    = profdata%nqc(jo) 
    857             fbdata%ioqcf(:,jo) = profdata%nqcf(:,jo) 
    858          ENDIF 
    859          fbdata%ipqc(jo)      = profdata%ipqc(jo) 
    860          fbdata%ipqcf(:,jo)   = profdata%ipqcf(:,jo) 
    861          fbdata%itqc(jo)      = profdata%itqc(jo) 
    862          fbdata%itqcf(:,jo)   = profdata%itqcf(:,jo) 
    863          fbdata%cdwmo(jo)     = profdata%cwmo(jo) 
    864          fbdata%kindex(jo)    = profdata%npfil(jo) 
    865          DO jvar = 1, profdata%nvar 
    866             IF (ln_grid_global) THEN 
    867                fbdata%iobsi(jo,jvar) = profdata%mi(jo,jvar) 
    868                fbdata%iobsj(jo,jvar) = profdata%mj(jo,jvar) 
    869             ELSE 
    870                fbdata%iobsi(jo,jvar) = mig(profdata%mi(jo,jvar)) 
    871                fbdata%iobsj(jo,jvar) = mjg(profdata%mj(jo,jvar)) 
    872             ENDIF 
    873          END DO 
    874          CALL greg2jul( 0, & 
    875             &           profdata%nmin(jo), & 
    876             &           profdata%nhou(jo), & 
    877             &           profdata%nday(jo), & 
    878             &           profdata%nmon(jo), & 
    879             &           profdata%nyea(jo), & 
    880             &           fbdata%ptim(jo),   & 
    881             &           krefdate = 19500101 ) 
    882          ! Reform the profiles arrays for output 
    883          DO jvar = 1, 2 
    884             DO jk = profdata%npvsta(jo,jvar), profdata%npvend(jo,jvar) 
    885                ik = profdata%var(jvar)%nvlidx(jk) 
    886                IF ( jvar == 1 ) THEN 
    887                   fbdata%padd(ik,jo,1,jvar) = zu(jk) 
    888                ELSE 
    889                   fbdata%padd(ik,jo,1,jvar) = zv(jk) 
    890                ENDIF 
    891                fbdata%padd(ik,jo,2,jvar) = profdata%var(jvar)%vmod(jk) 
    892                fbdata%pob(ik,jo,jvar)    = profdata%var(jvar)%vobs(jk) 
    893                fbdata%pdep(ik,jo)        = profdata%var(jvar)%vdep(jk) 
    894                fbdata%idqc(ik,jo)        = profdata%var(jvar)%idqc(jk) 
    895                fbdata%idqcf(:,ik,jo)     = profdata%var(jvar)%idqcf(:,jk) 
    896                IF ( profdata%var(jvar)%nvqc(jk) > 10 ) THEN 
    897                   fbdata%ivlqc(ik,jo,jvar) = 4 
    898                   fbdata%ivlqcf(1,ik,jo,jvar) = profdata%var(jvar)%nvqcf(1,jk) 
    899                   fbdata%ivlqcf(2,ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) - 10 
    900                ELSE 
    901                   fbdata%ivlqc(ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) 
    902                   fbdata%ivlqcf(:,ik,jo,jvar) = profdata%var(jvar)%nvqcf(:,jk) 
    903                ENDIF 
    904                fbdata%iobsk(ik,jo,jvar)  = profdata%var(jvar)%mvk(jk) 
    905                DO ja = 1, nadd 
    906                   fbdata%padd(ik,jo,2+ja,jvar) = & 
    907                      & profdata%var(jvar)%vext(jk,padd%ipoint(ja)) 
    908                END DO 
    909                DO je = 1, next 
    910                   fbdata%pext(ik,jo,je) = & 
    911                      & profdata%var(jvar)%vext(jk,pext%ipoint(je)) 
    912                END DO 
    913             END DO 
    914          END DO 
    915       END DO 
    916  
    917       ! Write the obfbdata structure 
    918       CALL write_obfbdata( cfname, fbdata ) 
    919        
    920       ! Output some basic statistics 
    921       CALL obs_wri_stats( fbdata ) 
    922  
    923       CALL dealloc_obfbdata( fbdata ) 
    924       
    925       DEALLOCATE( & 
    926          & zu, & 
    927          & zv  & 
    928          & ) 
    929  
    930    END SUBROUTINE obs_wri_vel 
     506   END SUBROUTINE obs_wri_surf 
    931507 
    932508   SUBROUTINE obs_wri_stats( fbdata ) 
     
    951527      INTEGER :: jo 
    952528      INTEGER :: jk 
    953  
    954 !      INTEGER :: nlev 
    955 !      INTEGER :: nlevmpp 
    956 !      INTEGER :: nobsmpp 
    957       INTEGER :: numgoodobs 
    958       INTEGER :: numgoodobsmpp 
     529      INTEGER :: inumgoodobs 
     530      INTEGER :: inumgoodobsmpp 
    959531      REAL(wp) :: zsumx 
    960532      REAL(wp) :: zsumx2 
    961533      REAL(wp) :: zomb 
     534       
    962535 
    963536      IF (lwp) THEN 
    964537         WRITE(numout,*) '' 
    965538         WRITE(numout,*) 'obs_wri_stats :' 
    966          WRITE(numout,*) '~~~~~~~~~~~~~~~'  
     539         WRITE(numout,*) '~~~~~~~~~~~~~~~' 
    967540      ENDIF 
    968541 
     
    970543         zsumx=0.0_wp 
    971544         zsumx2=0.0_wp 
    972          numgoodobs=0 
     545         inumgoodobs=0 
    973546         DO jo = 1, fbdata%nobs 
    974547            DO jk = 1, fbdata%nlev 
     
    976549                  & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 
    977550                  & ( fbdata%padd(jk,jo,1,jvar) < 9999.0 ) ) THEN 
    978         
    979              zomb=fbdata%pob(jk, jo, jvar)-fbdata%padd(jk, jo, 1, jvar) 
     551 
     552                  zomb=fbdata%pob(jk, jo, jvar)-fbdata%padd(jk, jo, 1, jvar) 
    980553                  zsumx=zsumx+zomb 
    981554                  zsumx2=zsumx2+zomb**2 
    982                   numgoodobs=numgoodobs+1 
    983           ENDIF 
     555                  inumgoodobs=inumgoodobs+1 
     556               ENDIF 
    984557            ENDDO 
    985558         ENDDO 
    986559 
    987          CALL obs_mpp_sum_integer( numgoodobs, numgoodobsmpp ) 
     560         CALL obs_mpp_sum_integer( inumgoodobs, inumgoodobsmpp ) 
    988561         CALL mpp_sum(zsumx) 
    989562         CALL mpp_sum(zsumx2) 
    990563 
    991564         IF (lwp) THEN 
    992        WRITE(numout,*) 'Type: ',fbdata%cname(jvar),'  Total number of good observations: ',numgoodobsmpp  
    993        WRITE(numout,*) 'Overall mean obs minus model of the good observations: ',zsumx/numgoodobsmpp 
    994             WRITE(numout,*) 'Overall RMS obs minus model of the good observations: ',sqrt( zsumx2/numgoodobsmpp ) 
    995        WRITE(numout,*) '' 
     565            WRITE(numout,*) 'Type: ',fbdata%cname(jvar),'  Total number of good observations: ',inumgoodobsmpp  
     566            WRITE(numout,*) 'Overall mean obs minus model of the good observations: ',zsumx/inumgoodobsmpp 
     567            WRITE(numout,*) 'Overall RMS obs minus model of the good observations: ',sqrt( zsumx2/inumgoodobsmpp ) 
     568            WRITE(numout,*) '' 
    996569         ENDIF 
    997   
     570 
    998571      ENDDO 
    999572 
Note: See TracChangeset for help on using the changeset viewer.