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

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

source: branches/UKMO/dev_r4650_general_vert_coord_obsoper_pfts/NEMOGCM/NEMO/OPA_SRC/OBS/obs_write.F90 @ 8105

Last change on this file since 8105 was 8105, checked in by dford, 8 years ago

Implement initial version of PFT logchl obs operator, developed by Jozef S.
File size: 55.4 KB
Line 
1MODULE obs_write
2   !!======================================================================
3   !!                       ***  MODULE obs_write   ***
4   !! Observation diagnosticss: Write observation related diagnostics
5   !!=====================================================================
6
7   !!----------------------------------------------------------------------
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
13   !!   obs_wri_logchl: Write logchl observation related diagnostics
14   !!   obs_wri_spm   : Write spm observation related diagnostics
15   !!   obs_wri_fco2  : Write fco2 observation related diagnostics
16   !!   obs_wri_pco2  : Write fco2 observation related diagnostics
17   !!   obs_wri_stats : Print basic statistics on the data being written out
18   !!----------------------------------------------------------------------
19
20   !! * Modules used
21   USE par_kind, ONLY : &   ! Precision variables
22      & wp
23   USE in_out_manager       ! I/O manager
24   USE dom_oce              ! Ocean space and time domain variables
25   USE obs_types            ! Observation type integer to character translation
26   USE julian, ONLY : &         ! Julian date routines
27      & greg2jul
28   USE obs_utils, ONLY : &  ! Observation operator utility functions
29      & chkerr
30   USE obs_profiles_def     ! Type definitions for profiles
31   USE obs_surf_def         ! Type defintions for surface observations
32   USE obs_fbm              ! Observation feedback I/O
33   USE obs_grid             ! Grid tools
34   USE obs_conv             ! Conversion between units
35   USE obs_const
36   USE obs_sla_types
37   USE obs_rot_vel          ! Rotation of velocities
38   USE obs_mpp              ! MPP support routines for observation diagnostics
39   USE lib_mpp        ! MPP routines
40
41   IMPLICIT NONE
42
43   !! * Routine accessibility
44   PRIVATE
45   PUBLIC obs_wri_p3d, &    ! Write profile observation related diagnostics
46      &   obs_wri_sla, &    ! Write SLA observation related diagnostics
47      &   obs_wri_sst, &    ! Write SST observation related diagnostics
48      &   obs_wri_sss, &    ! Write SSS observation related diagnostics
49      &   obs_wri_seaice, & ! Write seaice observation related diagnostics
50      &   obs_wri_vel, &    ! Write velocity observation related diagnostics
51      &   obs_wri_logchl, & ! Write logchl observation related diagnostics
52      &   obs_wri_spm, &    ! Write spm observation related diagnostics
53      &   obs_wri_fco2, &   ! Write fco2 observation related diagnostics
54      &   obs_wri_pco2, &   ! Write pco2 observation related diagnostics
55      &   obswriinfo
56   
57   TYPE obswriinfo
58      INTEGER :: inum
59      INTEGER, POINTER, DIMENSION(:) :: ipoint
60      CHARACTER(len=ilenname), POINTER, DIMENSION(:) :: cdname
61      CHARACTER(len=ilenlong), POINTER, DIMENSION(:,:) :: cdlong
62      CHARACTER(len=ilenunit), POINTER, DIMENSION(:,:) :: cdunit
63   END TYPE obswriinfo
64
65   !!----------------------------------------------------------------------
66   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
67   !! $Id$
68   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
69   !!----------------------------------------------------------------------
70
71CONTAINS
72
73   SUBROUTINE obs_wri_p3d( cprefix, profdata, padd, pext )
74      !!-----------------------------------------------------------------------
75      !!
76      !!                     *** ROUTINE obs_wri_p3d  ***
77      !!
78      !! ** Purpose : Write temperature and salinity (profile) observation
79      !!              related diagnostics
80      !!
81      !! ** Method  : NetCDF
82      !!
83      !! ** Action  :
84      !!
85      !! History :
86      !!      ! 06-04  (A. Vidard) Original
87      !!      ! 06-04  (A. Vidard) Reformatted
88      !!      ! 06-10  (A. Weaver) Cleanup
89      !!      ! 07-01  (K. Mogensen) Use profile data types
90      !!      ! 07-03  (K. Mogensen) General handling of profiles
91      !!      ! 09-01  (K. Mogensen) New feedback format
92      !!-----------------------------------------------------------------------
93
94      !! * Modules used
95
96      !! * Arguments
97      CHARACTER(LEN=*), INTENT(IN) :: cprefix        ! Prefix for output files
98      TYPE(obs_prof), INTENT(INOUT) :: profdata      ! Full set of profile data
99      TYPE(obswriinfo), OPTIONAL :: padd             ! Additional info for each variable
100      TYPE(obswriinfo), OPTIONAL :: pext             ! Extra info
101     
102      !! * Local declarations
103      TYPE(obfbdata) :: fbdata
104      CHARACTER(LEN=40) :: cfname
105      INTEGER :: ilevel
106      INTEGER :: jvar
107      INTEGER :: jo
108      INTEGER :: jk
109      INTEGER :: ik
110      INTEGER :: ja
111      INTEGER :: je
112      REAL(wp) :: zpres
113      INTEGER :: nadd
114      INTEGER :: next
115
116      IF ( PRESENT( padd ) ) THEN
117         nadd = padd%inum
118      ELSE
119         nadd = 0
120      ENDIF
121
122      IF ( PRESENT( pext ) ) THEN
123         next = pext%inum
124      ELSE
125         next = 0
126      ENDIF
127     
128      CALL init_obfbdata( fbdata )
129
130      ! Find maximum level
131      ilevel = 0
132      DO jvar = 1, 2
133         ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) )
134      END DO
135      CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, &
136         &                 1 + nadd, 1 + next, .TRUE. )
137
138      fbdata%cname(1)      = 'POTM'
139      fbdata%cname(2)      = 'PSAL'
140      fbdata%coblong(1)    = 'Potential temperature'
141      fbdata%coblong(2)    = 'Practical salinity'
142      fbdata%cobunit(1)    = 'Degrees centigrade'
143      fbdata%cobunit(2)    = 'PSU'
144      fbdata%cextname(1)   = 'TEMP'
145      fbdata%cextlong(1)   = 'Insitu temperature'
146      fbdata%cextunit(1)   = 'Degrees centigrade'
147      DO je = 1, next
148         fbdata%cextname(1+je) = pext%cdname(je)
149         fbdata%cextlong(1+je) = pext%cdlong(je,1)
150         fbdata%cextunit(1+je) = pext%cdunit(je,1)
151      END DO
152      fbdata%caddname(1)   = 'Hx'
153      fbdata%caddlong(1,1) = 'Model interpolated potential temperature'
154      fbdata%caddlong(1,2) = 'Model interpolated practical salinity'
155      fbdata%caddunit(1,1) = 'Degrees centigrade'
156      fbdata%caddunit(1,2) = 'PSU'
157      fbdata%cgrid(:)      = 'T'
158      DO ja = 1, nadd
159         fbdata%caddname(1+ja) = padd%cdname(ja)
160         DO jvar = 1, 2
161            fbdata%caddlong(1+ja,jvar) = padd%cdlong(ja,jvar)
162            fbdata%caddunit(1+ja,jvar) = padd%cdunit(ja,jvar)
163         END DO
164      END DO
165         
166      WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc
167
168      IF(lwp) THEN
169         WRITE(numout,*)
170         WRITE(numout,*)'obs_wri_p3d :'
171         WRITE(numout,*)'~~~~~~~~~~~~~'
172         WRITE(numout,*)'Writing profile feedback file : ',TRIM(cfname)
173      ENDIF
174
175      ! Transform obs_prof data structure into obfbdata structure
176      fbdata%cdjuldref = '19500101000000'
177      DO jo = 1, profdata%nprof
178         fbdata%plam(jo)      = profdata%rlam(jo)
179         fbdata%pphi(jo)      = profdata%rphi(jo)
180         WRITE(fbdata%cdtyp(jo),'(I4)') profdata%ntyp(jo)
181         fbdata%ivqc(jo,:)    = profdata%ivqc(jo,:)
182         fbdata%ivqcf(:,jo,:) = profdata%ivqcf(:,jo,:)
183         IF ( profdata%nqc(jo) > 10 ) THEN
184            fbdata%ioqc(jo)    = 4
185            fbdata%ioqcf(1,jo) = profdata%nqcf(1,jo)
186            fbdata%ioqcf(2,jo) = profdata%nqc(jo) - 10
187         ELSE
188            fbdata%ioqc(jo)    = profdata%nqc(jo)
189            fbdata%ioqcf(:,jo) = profdata%nqcf(:,jo)
190         ENDIF
191         fbdata%ipqc(jo)      = profdata%ipqc(jo)
192         fbdata%ipqcf(:,jo)   = profdata%ipqcf(:,jo)
193         fbdata%itqc(jo)      = profdata%itqc(jo)
194         fbdata%itqcf(:,jo)   = profdata%itqcf(:,jo)
195         fbdata%cdwmo(jo)     = profdata%cwmo(jo)
196         fbdata%kindex(jo)    = profdata%npfil(jo)
197         DO jvar = 1, profdata%nvar
198            IF (ln_grid_global) THEN
199               fbdata%iobsi(jo,jvar) = profdata%mi(jo,jvar)
200               fbdata%iobsj(jo,jvar) = profdata%mj(jo,jvar)
201            ELSE
202               fbdata%iobsi(jo,jvar) = mig(profdata%mi(jo,jvar))
203               fbdata%iobsj(jo,jvar) = mjg(profdata%mj(jo,jvar))
204            ENDIF
205         END DO
206         CALL greg2jul( 0, &
207            &           profdata%nmin(jo), &
208            &           profdata%nhou(jo), &
209            &           profdata%nday(jo), &
210            &           profdata%nmon(jo), &
211            &           profdata%nyea(jo), &
212            &           fbdata%ptim(jo),   &
213            &           krefdate = 19500101 )
214         ! Reform the profiles arrays for output
215         DO jvar = 1, 2
216            DO jk = profdata%npvsta(jo,jvar), profdata%npvend(jo,jvar)
217               ik = profdata%var(jvar)%nvlidx(jk)
218               fbdata%padd(ik,jo,1,jvar) = profdata%var(jvar)%vmod(jk)
219               fbdata%pob(ik,jo,jvar)    = profdata%var(jvar)%vobs(jk)
220               fbdata%pdep(ik,jo)        = profdata%var(jvar)%vdep(jk)
221               fbdata%idqc(ik,jo)        = profdata%var(jvar)%idqc(jk)
222               fbdata%idqcf(:,ik,jo)     = profdata%var(jvar)%idqcf(:,jk)
223               IF ( profdata%var(jvar)%nvqc(jk) > 10 ) THEN
224                  fbdata%ivlqc(ik,jo,jvar) = 4
225                  fbdata%ivlqcf(1,ik,jo,jvar) = profdata%var(jvar)%nvqcf(1,jk)
226                  fbdata%ivlqcf(2,ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) - 10
227               ELSE
228                  fbdata%ivlqc(ik,jo,jvar) = profdata%var(jvar)%nvqc(jk)
229                  fbdata%ivlqcf(:,ik,jo,jvar) = profdata%var(jvar)%nvqcf(:,jk)
230               ENDIF
231               fbdata%iobsk(ik,jo,jvar)  = profdata%var(jvar)%mvk(jk)
232               DO ja = 1, nadd
233                  fbdata%padd(ik,jo,1+ja,jvar) = &
234                     & profdata%var(jvar)%vext(jk,padd%ipoint(ja))
235               END DO
236               DO je = 1, next
237                  fbdata%pext(ik,jo,1+je) = &
238                     & profdata%var(jvar)%vext(jk,pext%ipoint(je))
239               END DO
240               IF ( jvar == 1 ) THEN
241                  fbdata%pext(ik,jo,1) = profdata%var(jvar)%vext(jk,1)
242               ENDIF
243            END DO
244         END DO
245      END DO
246
247      ! Convert insitu temperature to potential temperature using the model
248      ! salinity if no potential temperature
249      DO jo = 1, fbdata%nobs
250         IF ( fbdata%pphi(jo) < 9999.0 ) THEN
251            DO jk = 1, fbdata%nlev
252               IF ( ( fbdata%pob(jk,jo,1) >= 9999.0 ) .AND. &
253                  & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. &
254                  & ( fbdata%padd(jk,jo,1,2) < 9999.0 ) .AND. &
255                  & ( fbdata%pext(jk,jo,1) < 9999.0 ) ) THEN
256                  zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), &
257                     &              REAL(fbdata%pphi(jo),wp) )
258                  fbdata%pob(jk,jo,1) = potemp( &
259                     &                     REAL(fbdata%padd(jk,jo,1,2), wp),  &
260                     &                     REAL(fbdata%pext(jk,jo,1), wp), &
261                     &                     zpres, 0.0_wp )
262               ENDIF
263            END DO
264         ENDIF
265      END DO
266     
267      ! Write the obfbdata structure
268      CALL write_obfbdata( cfname, fbdata )
269
270      ! Output some basic statistics
271      CALL obs_wri_stats( fbdata )
272
273      CALL dealloc_obfbdata( fbdata )
274     
275   END SUBROUTINE obs_wri_p3d
276
277   SUBROUTINE obs_wri_sla( cprefix, sladata, padd, pext )
278      !!-----------------------------------------------------------------------
279      !!
280      !!                     *** ROUTINE obs_wri_sla  ***
281      !!
282      !! ** Purpose : Write SLA observation diagnostics
283      !!              related
284      !!
285      !! ** Method  : NetCDF
286      !!
287      !! ** Action  :
288      !!
289      !!      ! 07-03  (K. Mogensen) Original
290      !!      ! 09-01  (K. Mogensen) New feedback format.
291      !!-----------------------------------------------------------------------
292
293      !! * Modules used
294      IMPLICIT NONE
295
296      !! * Arguments
297      CHARACTER(LEN=*), INTENT(IN) :: cprefix          ! Prefix for output files
298      TYPE(obs_surf), INTENT(INOUT) :: sladata         ! Full set of SLAa
299      TYPE(obswriinfo), OPTIONAL :: padd               ! Additional info for each variable
300      TYPE(obswriinfo), OPTIONAL :: pext               ! Extra info
301
302      !! * Local declarations
303      TYPE(obfbdata) :: fbdata
304      CHARACTER(LEN=40) :: cfname         ! netCDF filename
305      CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_sla'
306      INTEGER :: jo
307      INTEGER :: ja
308      INTEGER :: je
309      INTEGER :: nadd
310      INTEGER :: next
311
312      IF ( PRESENT( padd ) ) THEN
313         nadd = padd%inum
314      ELSE
315         nadd = 0
316      ENDIF
317
318      IF ( PRESENT( pext ) ) THEN
319         next = pext%inum
320      ELSE
321         next = 0
322      ENDIF
323
324      CALL init_obfbdata( fbdata )
325
326      CALL alloc_obfbdata( fbdata, 1, sladata%nsurf, 1, &
327         &                 2 + nadd, 1 + next, .TRUE. )
328
329      fbdata%cname(1)      = 'SLA'
330      fbdata%coblong(1)    = 'Sea level anomaly'
331      fbdata%cobunit(1)    = 'Metres'
332      fbdata%cextname(1)   = 'MDT'
333      fbdata%cextlong(1)   = 'Mean dynamic topography'
334      fbdata%cextunit(1)   = 'Metres'
335      DO je = 1, next
336         fbdata%cextname(1+je) = pext%cdname(je)
337         fbdata%cextlong(1+je) = pext%cdlong(je,1)
338         fbdata%cextunit(1+je) = pext%cdunit(je,1)
339      END DO
340      fbdata%caddname(1)   = 'Hx'
341      fbdata%caddlong(1,1) = 'Model interpolated SSH - MDT'
342      fbdata%caddunit(1,1) = 'Metres' 
343      fbdata%caddname(2)   = 'SSH'
344      fbdata%caddlong(2,1) = 'Model Sea surface height'
345      fbdata%caddunit(2,1) = 'Metres'
346      fbdata%cgrid(1)      = 'T'
347      DO ja = 1, nadd
348         fbdata%caddname(2+ja) = padd%cdname(ja)
349         fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1)
350         fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1)
351      END DO
352
353      WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc
354
355      IF(lwp) THEN
356         WRITE(numout,*)
357         WRITE(numout,*)'obs_wri_sla :'
358         WRITE(numout,*)'~~~~~~~~~~~~~'
359         WRITE(numout,*)'Writing SLA feedback file : ',TRIM(cfname)
360      ENDIF
361
362      ! Transform obs_prof data structure into obfbdata structure
363      fbdata%cdjuldref = '19500101000000'
364      DO jo = 1, sladata%nsurf
365         fbdata%plam(jo)      = sladata%rlam(jo)
366         fbdata%pphi(jo)      = sladata%rphi(jo)
367         WRITE(fbdata%cdtyp(jo),'(I4)') sladata%ntyp(jo)
368         fbdata%ivqc(jo,:)    = 0
369         fbdata%ivqcf(:,jo,:) = 0
370         IF ( sladata%nqc(jo) > 10 ) THEN
371            fbdata%ioqc(jo)    = 4
372            fbdata%ioqcf(1,jo) = 0
373            fbdata%ioqcf(2,jo) = sladata%nqc(jo) - 10
374         ELSE
375            fbdata%ioqc(jo)    = sladata%nqc(jo)
376            fbdata%ioqcf(:,jo) = 0
377         ENDIF
378         fbdata%ipqc(jo)      = 0
379         fbdata%ipqcf(:,jo)   = 0
380         fbdata%itqc(jo)      = 0
381         fbdata%itqcf(:,jo)   = 0
382         fbdata%cdwmo(jo)     = sladata%cwmo(jo)
383         fbdata%kindex(jo)    = sladata%nsfil(jo)
384         IF (ln_grid_global) THEN
385            fbdata%iobsi(jo,1) = sladata%mi(jo)
386            fbdata%iobsj(jo,1) = sladata%mj(jo)
387         ELSE
388            fbdata%iobsi(jo,1) = mig(sladata%mi(jo))
389            fbdata%iobsj(jo,1) = mjg(sladata%mj(jo))
390         ENDIF
391         CALL greg2jul( 0, &
392            &           sladata%nmin(jo), &
393            &           sladata%nhou(jo), &
394            &           sladata%nday(jo), &
395            &           sladata%nmon(jo), &
396            &           sladata%nyea(jo), &
397            &           fbdata%ptim(jo),   &
398            &           krefdate = 19500101 )
399         fbdata%padd(1,jo,1,1) = sladata%rmod(jo,1)
400         fbdata%padd(1,jo,2,1) = sladata%rext(jo,1)
401         fbdata%pob(1,jo,1)    = sladata%robs(jo,1) 
402         fbdata%pdep(1,jo)     = 0.0
403         fbdata%idqc(1,jo)     = 0
404         fbdata%idqcf(:,1,jo)  = 0
405         IF ( sladata%nqc(jo) > 10 ) THEN
406            fbdata%ivqc(jo,1)       = 4
407            fbdata%ivlqc(1,jo,1)    = 4
408            fbdata%ivlqcf(1,1,jo,1) = 0
409            fbdata%ivlqcf(2,1,jo,1) = sladata%nqc(jo) - 10
410         ELSE
411            fbdata%ivqc(jo,1)       = sladata%nqc(jo)
412            fbdata%ivlqc(1,jo,1)    = sladata%nqc(jo)
413            fbdata%ivlqcf(:,1,jo,1) = 0
414         ENDIF
415         fbdata%iobsk(1,jo,1)  = 0
416         fbdata%pext(1,jo,1) = sladata%rext(jo,2)
417         DO ja = 1, nadd
418            fbdata%padd(1,jo,2+ja,1) = &
419               & sladata%rext(jo,padd%ipoint(ja))
420         END DO
421         DO je = 1, next
422            fbdata%pext(1,jo,1+je) = &
423               & sladata%rext(jo,pext%ipoint(je))
424         END DO
425      END DO
426
427      ! Write the obfbdata structure
428      CALL write_obfbdata( cfname, fbdata )
429
430      ! Output some basic statistics
431      CALL obs_wri_stats( fbdata )
432
433      CALL dealloc_obfbdata( fbdata )
434
435   END SUBROUTINE obs_wri_sla
436
437   SUBROUTINE obs_wri_sst( cprefix, sstdata, padd, pext )
438      !!-----------------------------------------------------------------------
439      !!
440      !!                     *** ROUTINE obs_wri_sst  ***
441      !!
442      !! ** Purpose : Write SST observation diagnostics
443      !!              related
444      !!
445      !! ** Method  : NetCDF
446      !!
447      !! ** Action  :
448      !!
449      !!      ! 07-07  (S. Ricci) Original
450      !!      ! 09-01  (K. Mogensen) New feedback format.
451      !!-----------------------------------------------------------------------
452
453      !! * Modules used
454      IMPLICIT NONE
455
456      !! * Arguments
457      CHARACTER(LEN=*), INTENT(IN) :: cprefix       ! Prefix for output files
458      TYPE(obs_surf), INTENT(INOUT) :: sstdata      ! Full set of SST
459      TYPE(obswriinfo), OPTIONAL :: padd            ! Additional info for each variable
460      TYPE(obswriinfo), OPTIONAL :: pext            ! Extra info
461
462      !! * Local declarations
463      TYPE(obfbdata) :: fbdata
464      CHARACTER(LEN=40) ::  cfname             ! netCDF filename
465      CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_sst'
466      INTEGER :: jo
467      INTEGER :: ja
468      INTEGER :: je
469      INTEGER :: nadd
470      INTEGER :: next
471
472      IF ( PRESENT( padd ) ) THEN
473         nadd = padd%inum
474      ELSE
475         nadd = 0
476      ENDIF
477
478      IF ( PRESENT( pext ) ) THEN
479         next = pext%inum
480      ELSE
481         next = 0
482      ENDIF
483
484      CALL init_obfbdata( fbdata )
485
486      CALL alloc_obfbdata( fbdata, 1, sstdata%nsurf, 1, &
487         &                 1 + nadd, next, .TRUE. )
488
489      fbdata%cname(1)      = 'SST'
490      fbdata%coblong(1)    = 'Sea surface temperature'
491      fbdata%cobunit(1)    = 'Degree centigrade'
492      DO je = 1, next
493         fbdata%cextname(je) = pext%cdname(je)
494         fbdata%cextlong(je) = pext%cdlong(je,1)
495         fbdata%cextunit(je) = pext%cdunit(je,1)
496      END DO
497      fbdata%caddname(1)   = 'Hx'
498      fbdata%caddlong(1,1) = 'Model interpolated SST'
499      fbdata%caddunit(1,1) = 'Degree centigrade'
500      fbdata%cgrid(1)      = 'T'
501      DO ja = 1, nadd
502         fbdata%caddname(1+ja) = padd%cdname(ja)
503         fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1)
504         fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1)
505      END DO
506
507      WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc
508
509      IF(lwp) THEN
510         WRITE(numout,*)
511         WRITE(numout,*)'obs_wri_sst :'
512         WRITE(numout,*)'~~~~~~~~~~~~~'
513         WRITE(numout,*)'Writing SST feedback file : ',TRIM(cfname)
514      ENDIF
515
516      ! Transform obs_prof data structure into obfbdata structure
517      fbdata%cdjuldref = '19500101000000'
518      DO jo = 1, sstdata%nsurf
519         fbdata%plam(jo)      = sstdata%rlam(jo)
520         fbdata%pphi(jo)      = sstdata%rphi(jo)
521         WRITE(fbdata%cdtyp(jo),'(I4)') sstdata%ntyp(jo)
522         fbdata%ivqc(jo,:)    = 0
523         fbdata%ivqcf(:,jo,:) = 0
524         IF ( sstdata%nqc(jo) > 10 ) THEN
525            fbdata%ioqc(jo)    = 4
526            fbdata%ioqcf(1,jo) = 0
527            fbdata%ioqcf(2,jo) = sstdata%nqc(jo) - 10
528         ELSE
529            fbdata%ioqc(jo)    = MAX(sstdata%nqc(jo),1)
530            fbdata%ioqcf(:,jo) = 0
531         ENDIF
532         fbdata%ipqc(jo)      = 0
533         fbdata%ipqcf(:,jo)   = 0
534         fbdata%itqc(jo)      = 0
535         fbdata%itqcf(:,jo)   = 0
536         fbdata%cdwmo(jo)     = ''
537         fbdata%kindex(jo)    = sstdata%nsfil(jo)
538         IF (ln_grid_global) THEN
539            fbdata%iobsi(jo,1) = sstdata%mi(jo)
540            fbdata%iobsj(jo,1) = sstdata%mj(jo)
541         ELSE
542            fbdata%iobsi(jo,1) = mig(sstdata%mi(jo))
543            fbdata%iobsj(jo,1) = mjg(sstdata%mj(jo))
544         ENDIF
545         CALL greg2jul( 0, &
546            &           sstdata%nmin(jo), &
547            &           sstdata%nhou(jo), &
548            &           sstdata%nday(jo), &
549            &           sstdata%nmon(jo), &
550            &           sstdata%nyea(jo), &
551            &           fbdata%ptim(jo),   &
552            &           krefdate = 19500101 )
553         fbdata%padd(1,jo,1,1) = sstdata%rmod(jo,1)
554         fbdata%pob(1,jo,1)    = sstdata%robs(jo,1)
555         fbdata%pdep(1,jo)     = 0.0
556         fbdata%idqc(1,jo)     = 0
557         fbdata%idqcf(:,1,jo)  = 0
558         IF ( sstdata%nqc(jo) > 10 ) THEN
559            fbdata%ivqc(jo,1)       = 4
560            fbdata%ivlqc(1,jo,1)    = 4
561            fbdata%ivlqcf(1,1,jo,1) = 0
562            fbdata%ivlqcf(2,1,jo,1) = sstdata%nqc(jo) - 10
563         ELSE
564            fbdata%ivqc(jo,1)       = MAX(sstdata%nqc(jo),1)
565            fbdata%ivlqc(1,jo,1)    = MAX(sstdata%nqc(jo),1)
566            fbdata%ivlqcf(:,1,jo,1) = 0
567         ENDIF
568         fbdata%iobsk(1,jo,1)  = 0
569         DO ja = 1, nadd
570            fbdata%padd(1,jo,1+ja,1) = &
571               & sstdata%rext(jo,padd%ipoint(ja))
572         END DO
573         DO je = 1, next
574            fbdata%pext(1,jo,je) = &
575               & sstdata%rext(jo,pext%ipoint(je))
576         END DO
577
578      END DO
579
580      ! Write the obfbdata structure
581
582      CALL write_obfbdata( cfname, fbdata )
583
584      ! Output some basic statistics
585      CALL obs_wri_stats( fbdata )
586
587      CALL dealloc_obfbdata( fbdata )
588
589   END SUBROUTINE obs_wri_sst
590
591   SUBROUTINE obs_wri_sss
592   END SUBROUTINE obs_wri_sss
593
594   SUBROUTINE obs_wri_seaice( cprefix, seaicedata, padd, pext )
595      !!-----------------------------------------------------------------------
596      !!
597      !!                     *** ROUTINE obs_wri_seaice  ***
598      !!
599      !! ** Purpose : Write sea ice observation diagnostics
600      !!              related
601      !!
602      !! ** Method  : NetCDF
603      !!
604      !! ** Action  :
605      !!
606      !!      ! 07-07  (S. Ricci) Original
607      !!      ! 09-01  (K. Mogensen) New feedback format.
608      !!-----------------------------------------------------------------------
609
610      !! * Modules used
611      IMPLICIT NONE
612
613      !! * Arguments
614      CHARACTER(LEN=*), INTENT(IN) :: cprefix       ! Prefix for output files
615      TYPE(obs_surf), INTENT(INOUT) :: seaicedata   ! Full set of sea ice
616      TYPE(obswriinfo), OPTIONAL :: padd            ! Additional info for each variable
617      TYPE(obswriinfo), OPTIONAL :: pext            ! Extra info
618
619      !! * Local declarations
620      TYPE(obfbdata) :: fbdata
621      CHARACTER(LEN=40) :: cfname             ! netCDF filename
622      CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_seaice'
623      INTEGER :: jo
624      INTEGER :: ja
625      INTEGER :: je
626      INTEGER :: nadd
627      INTEGER :: next
628
629      IF ( PRESENT( padd ) ) THEN
630         nadd = padd%inum
631      ELSE
632         nadd = 0
633      ENDIF
634
635      IF ( PRESENT( pext ) ) THEN
636         next = pext%inum
637      ELSE
638         next = 0
639      ENDIF
640
641      CALL init_obfbdata( fbdata )
642
643      CALL alloc_obfbdata( fbdata, 1, seaicedata%nsurf, 1, 1, 0, .TRUE. )
644
645      fbdata%cname(1)      = 'SEAICE'
646      fbdata%coblong(1)    = 'Sea ice'
647      fbdata%cobunit(1)    = 'Fraction'
648      DO je = 1, next
649         fbdata%cextname(je) = pext%cdname(je)
650         fbdata%cextlong(je) = pext%cdlong(je,1)
651         fbdata%cextunit(je) = pext%cdunit(je,1)
652      END DO
653      fbdata%caddname(1)   = 'Hx'
654      fbdata%caddlong(1,1) = 'Model interpolated ICE'
655      fbdata%caddunit(1,1) = 'Fraction'
656      fbdata%cgrid(1)      = 'T'
657      DO ja = 1, nadd
658         fbdata%caddname(1+ja) = padd%cdname(ja)
659         fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1)
660         fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1)
661      END DO
662
663      WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc
664
665      IF(lwp) THEN
666         WRITE(numout,*)
667         WRITE(numout,*)'obs_wri_seaice :'
668         WRITE(numout,*)'~~~~~~~~~~~~~~~~'
669         WRITE(numout,*)'Writing SEAICE feedback file : ',TRIM(cfname)
670      ENDIF
671
672      ! Transform obs_prof data structure into obfbdata structure
673      fbdata%cdjuldref = '19500101000000'
674      DO jo = 1, seaicedata%nsurf
675         fbdata%plam(jo)      = seaicedata%rlam(jo)
676         fbdata%pphi(jo)      = seaicedata%rphi(jo)
677         WRITE(fbdata%cdtyp(jo),'(I4)') seaicedata%ntyp(jo)
678         fbdata%ivqc(jo,:)    = 0
679         fbdata%ivqcf(:,jo,:) = 0
680         IF ( seaicedata%nqc(jo) > 10 ) THEN
681            fbdata%ioqc(jo)    = 4
682            fbdata%ioqcf(1,jo) = 0
683            fbdata%ioqcf(2,jo) = seaicedata%nqc(jo) - 10
684         ELSE
685            fbdata%ioqc(jo)    = MAX(seaicedata%nqc(jo),1)
686            fbdata%ioqcf(:,jo) = 0
687         ENDIF
688         fbdata%ipqc(jo)      = 0
689         fbdata%ipqcf(:,jo)   = 0
690         fbdata%itqc(jo)      = 0
691         fbdata%itqcf(:,jo)   = 0
692         fbdata%cdwmo(jo)     = ''
693         fbdata%kindex(jo)    = seaicedata%nsfil(jo)
694         IF (ln_grid_global) THEN
695            fbdata%iobsi(jo,1) = seaicedata%mi(jo)
696            fbdata%iobsj(jo,1) = seaicedata%mj(jo)
697         ELSE
698            fbdata%iobsi(jo,1) = mig(seaicedata%mi(jo))
699            fbdata%iobsj(jo,1) = mjg(seaicedata%mj(jo))
700         ENDIF
701         CALL greg2jul( 0, &
702            &           seaicedata%nmin(jo), &
703            &           seaicedata%nhou(jo), &
704            &           seaicedata%nday(jo), &
705            &           seaicedata%nmon(jo), &
706            &           seaicedata%nyea(jo), &
707            &           fbdata%ptim(jo),   &
708            &           krefdate = 19500101 )
709         fbdata%padd(1,jo,1,1) = seaicedata%rmod(jo,1)
710         fbdata%pob(1,jo,1)    = seaicedata%robs(jo,1)
711         fbdata%pdep(1,jo)     = 0.0
712         fbdata%idqc(1,jo)     = 0
713         fbdata%idqcf(:,1,jo)  = 0
714         IF ( seaicedata%nqc(jo) > 10 ) THEN
715            fbdata%ivlqc(1,jo,1) = 4
716            fbdata%ivlqcf(1,1,jo,1) = 0
717            fbdata%ivlqcf(2,1,jo,1) = seaicedata%nqc(jo) - 10
718         ELSE
719            fbdata%ivlqc(1,jo,1) = MAX(seaicedata%nqc(jo),1)
720            fbdata%ivlqcf(:,1,jo,1) = 0
721         ENDIF
722         fbdata%iobsk(1,jo,1)  = 0
723         DO ja = 1, nadd
724            fbdata%padd(1,jo,1+ja,1) = &
725               & seaicedata%rext(jo,padd%ipoint(ja))
726         END DO
727         DO je = 1, next
728            fbdata%pext(1,jo,je) = &
729               & seaicedata%rext(jo,pext%ipoint(je))
730         END DO
731
732      END DO
733
734      ! Write the obfbdata structure
735      CALL write_obfbdata( cfname, fbdata )
736
737      ! Output some basic statistics
738      CALL obs_wri_stats( fbdata )
739
740      CALL dealloc_obfbdata( fbdata )
741
742   END SUBROUTINE obs_wri_seaice
743
744   SUBROUTINE obs_wri_vel( cprefix, profdata, k2dint, padd, pext )
745      !!-----------------------------------------------------------------------
746      !!
747      !!                     *** ROUTINE obs_wri_vel  ***
748      !!
749      !! ** Purpose : Write current (profile) observation
750      !!              related diagnostics
751      !!
752      !! ** Method  : NetCDF
753      !!
754      !! ** Action  :
755      !!
756      !! History :
757      !!      ! 09-01  (K. Mogensen) New feedback format routine
758      !!-----------------------------------------------------------------------
759
760      !! * Modules used
761
762      !! * Arguments
763      CHARACTER(LEN=*), INTENT(IN) :: cprefix       ! Prefix for output files
764      TYPE(obs_prof), INTENT(INOUT) :: profdata     ! Full set of profile data
765      INTEGER, INTENT(IN) :: k2dint                 ! Horizontal interpolation method
766      TYPE(obswriinfo), OPTIONAL :: padd            ! Additional info for each variable
767      TYPE(obswriinfo), OPTIONAL :: pext            ! Extra info
768
769      !! * Local declarations
770      TYPE(obfbdata) :: fbdata
771      CHARACTER(LEN=40) :: cfname
772      INTEGER :: ilevel
773      INTEGER :: jvar
774      INTEGER :: jk
775      INTEGER :: ik
776      INTEGER :: jo
777      INTEGER :: ja
778      INTEGER :: je
779      INTEGER :: nadd
780      INTEGER :: next
781      REAL(wp) :: zpres
782      REAL(wp), DIMENSION(:), ALLOCATABLE :: &
783         & zu, &
784         & zv
785
786      IF ( PRESENT( padd ) ) THEN
787         nadd = padd%inum
788      ELSE
789         nadd = 0
790      ENDIF
791
792      IF ( PRESENT( pext ) ) THEN
793         next = pext%inum
794      ELSE
795         next = 0
796      ENDIF
797
798      CALL init_obfbdata( fbdata )
799
800      ! Find maximum level
801      ilevel = 0
802      DO jvar = 1, 2
803         ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) )
804      END DO
805      CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, 2, 0, .TRUE. )
806
807      fbdata%cname(1)      = 'UVEL'
808      fbdata%cname(2)      = 'VVEL'
809      fbdata%coblong(1)    = 'Zonal velocity'
810      fbdata%coblong(2)    = 'Meridional velocity'
811      fbdata%cobunit(1)    = 'm/s'
812      fbdata%cobunit(2)    = 'm/s'
813      DO je = 1, next
814         fbdata%cextname(je) = pext%cdname(je)
815         fbdata%cextlong(je) = pext%cdlong(je,1)
816         fbdata%cextunit(je) = pext%cdunit(je,1)
817      END DO
818      fbdata%caddname(1)   = 'Hx'
819      fbdata%caddlong(1,1) = 'Model interpolated zonal velocity'
820      fbdata%caddlong(1,2) = 'Model interpolated meridional velocity'
821      fbdata%caddunit(1,1) = 'm/s'
822      fbdata%caddunit(1,2) = 'm/s'
823      fbdata%caddname(2)   = 'HxG'
824      fbdata%caddlong(2,1) = 'Model interpolated zonal velocity (model grid)'
825      fbdata%caddlong(2,2) = 'Model interpolated meridional velocity (model grid)'
826      fbdata%caddunit(2,1) = 'm/s'
827      fbdata%caddunit(2,2) = 'm/s' 
828      fbdata%cgrid(1)      = 'U' 
829      fbdata%cgrid(2)      = 'V'
830      DO ja = 1, nadd
831         fbdata%caddname(2+ja) = padd%cdname(ja)
832         fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1)
833         fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1)
834      END DO
835
836      WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc
837
838      IF(lwp) THEN
839         WRITE(numout,*)
840         WRITE(numout,*)'obs_wri_vel :'
841         WRITE(numout,*)'~~~~~~~~~~~~~'
842         WRITE(numout,*)'Writing velocuty feedback file : ',TRIM(cfname)
843      ENDIF
844
845      ALLOCATE( &
846         & zu(profdata%nvprot(1)), &
847         & zv(profdata%nvprot(2))  &
848         & )
849      CALL obs_rotvel( profdata, k2dint, zu, zv )
850
851      ! Transform obs_prof data structure into obfbdata structure
852      fbdata%cdjuldref = '19500101000000'
853      DO jo = 1, profdata%nprof
854         fbdata%plam(jo)      = profdata%rlam(jo)
855         fbdata%pphi(jo)      = profdata%rphi(jo)
856         WRITE(fbdata%cdtyp(jo),'(I4)') profdata%ntyp(jo)
857         fbdata%ivqc(jo,:)    = profdata%ivqc(jo,:)
858         fbdata%ivqcf(:,jo,:) = profdata%ivqcf(:,jo,:)
859         IF ( profdata%nqc(jo) > 10 ) THEN
860            fbdata%ioqc(jo)    = 4
861            fbdata%ioqcf(1,jo) = profdata%nqcf(1,jo)
862            fbdata%ioqcf(2,jo) = profdata%nqc(jo) - 10
863         ELSE
864            fbdata%ioqc(jo)    = profdata%nqc(jo)
865            fbdata%ioqcf(:,jo) = profdata%nqcf(:,jo)
866         ENDIF
867         fbdata%ipqc(jo)      = profdata%ipqc(jo)
868         fbdata%ipqcf(:,jo)   = profdata%ipqcf(:,jo)
869         fbdata%itqc(jo)      = profdata%itqc(jo)
870         fbdata%itqcf(:,jo)   = profdata%itqcf(:,jo)
871         fbdata%cdwmo(jo)     = profdata%cwmo(jo)
872         fbdata%kindex(jo)    = profdata%npfil(jo)
873         DO jvar = 1, profdata%nvar
874            IF (ln_grid_global) THEN
875               fbdata%iobsi(jo,jvar) = profdata%mi(jo,jvar)
876               fbdata%iobsj(jo,jvar) = profdata%mj(jo,jvar)
877            ELSE
878               fbdata%iobsi(jo,jvar) = mig(profdata%mi(jo,jvar))
879               fbdata%iobsj(jo,jvar) = mjg(profdata%mj(jo,jvar))
880            ENDIF
881         END DO
882         CALL greg2jul( 0, &
883            &           profdata%nmin(jo), &
884            &           profdata%nhou(jo), &
885            &           profdata%nday(jo), &
886            &           profdata%nmon(jo), &
887            &           profdata%nyea(jo), &
888            &           fbdata%ptim(jo),   &
889            &           krefdate = 19500101 )
890         ! Reform the profiles arrays for output
891         DO jvar = 1, 2
892            DO jk = profdata%npvsta(jo,jvar), profdata%npvend(jo,jvar)
893               ik = profdata%var(jvar)%nvlidx(jk)
894               IF ( jvar == 1 ) THEN
895                  fbdata%padd(ik,jo,1,jvar) = zu(jk)
896               ELSE
897                  fbdata%padd(ik,jo,1,jvar) = zv(jk)
898               ENDIF
899               fbdata%padd(ik,jo,2,jvar) = profdata%var(jvar)%vmod(jk)
900               fbdata%pob(ik,jo,jvar)    = profdata%var(jvar)%vobs(jk)
901               fbdata%pdep(ik,jo)        = profdata%var(jvar)%vdep(jk)
902               fbdata%idqc(ik,jo)        = profdata%var(jvar)%idqc(jk)
903               fbdata%idqcf(:,ik,jo)     = profdata%var(jvar)%idqcf(:,jk)
904               IF ( profdata%var(jvar)%nvqc(jk) > 10 ) THEN
905                  fbdata%ivlqc(ik,jo,jvar) = 4
906                  fbdata%ivlqcf(1,ik,jo,jvar) = profdata%var(jvar)%nvqcf(1,jk)
907                  fbdata%ivlqcf(2,ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) - 10
908               ELSE
909                  fbdata%ivlqc(ik,jo,jvar) = profdata%var(jvar)%nvqc(jk)
910                  fbdata%ivlqcf(:,ik,jo,jvar) = profdata%var(jvar)%nvqcf(:,jk)
911               ENDIF
912               fbdata%iobsk(ik,jo,jvar)  = profdata%var(jvar)%mvk(jk)
913               DO ja = 1, nadd
914                  fbdata%padd(ik,jo,2+ja,jvar) = &
915                     & profdata%var(jvar)%vext(jk,padd%ipoint(ja))
916               END DO
917               DO je = 1, next
918                  fbdata%pext(ik,jo,je) = &
919                     & profdata%var(jvar)%vext(jk,pext%ipoint(je))
920               END DO
921            END DO
922         END DO
923      END DO
924
925      ! Write the obfbdata structure
926      CALL write_obfbdata( cfname, fbdata )
927     
928      ! Output some basic statistics
929      CALL obs_wri_stats( fbdata )
930
931      CALL dealloc_obfbdata( fbdata )
932     
933      DEALLOCATE( &
934         & zu, &
935         & zv  &
936         & )
937
938   END SUBROUTINE obs_wri_vel
939
940  ! SUBROUTINE obs_wri_logchl( cprefix, logchldata, padd, pext )
941   SUBROUTINE obs_wri_logchl( cprefix, logchldata, padd, pext, pft_num )
942      !!-----------------------------------------------------------------------
943      !!
944      !!                     *** ROUTINE obs_wri_logchl  ***
945      !!
946      !! ** Purpose : Write logchl observation diagnostics
947      !!              related
948      !!
949      !! ** Method  : NetCDF
950      !!
951      !! ** Action  :
952      !!
953      !!-----------------------------------------------------------------------
954
955      !! * Modules used
956      IMPLICIT NONE
957
958      !! * Arguments
959      CHARACTER(LEN=*), INTENT(IN) :: cprefix       ! Prefix for output files
960      TYPE(obs_surf), INTENT(INOUT) :: logchldata   ! Full set of logchl
961      TYPE(obswriinfo), OPTIONAL :: padd            ! Additional info for each variable
962      TYPE(obswriinfo), OPTIONAL :: pext            ! Extra info
963
964      !! * Local declarations
965      TYPE(obfbdata) :: fbdata
966      CHARACTER(LEN=40) :: cfname             ! netCDF filename
967      CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_logchl'
968      INTEGER :: jo
969      INTEGER :: ja
970      INTEGER :: je
971      INTEGER :: nadd
972      INTEGER :: next
973      INTEGER, OPTIONAL :: pft_num
974
975      IF ( PRESENT( padd ) ) THEN
976         nadd = padd%inum
977      ELSE
978         nadd = 0
979      ENDIF
980
981      IF ( PRESENT( pext ) ) THEN
982         next = pext%inum
983      ELSE
984         next = 0
985      ENDIF
986
987      CALL init_obfbdata( fbdata )
988
989      CALL alloc_obfbdata( fbdata, 1, logchldata%nsurf, 1, &
990         &                 1 + nadd, next, .TRUE. )
991
992      !fbdata%cname(1)      = 'LOGCHL'
993      IF ( PRESENT( pft_num ) ) THEN
994      WRITE(fbdata%cname(1),'(A,I2.2)')'LOGCHL',pft_num
995      ELSE
996          fbdata%cname(1)      = 'LOGCHL'
997      ENDIF
998
999      fbdata%coblong(1)    = 'logchl concentration'
1000      fbdata%cobunit(1)    = 'mg/m3'
1001      DO je = 1, next
1002         fbdata%cextname(je) = pext%cdname(je)
1003         fbdata%cextlong(je) = pext%cdlong(je,1)
1004         fbdata%cextunit(je) = pext%cdunit(je,1)
1005      END DO
1006      fbdata%caddname(1)   = 'Hx'
1007      fbdata%caddlong(1,1) = 'Model interpolated LOGCHL'
1008      fbdata%caddunit(1,1) = 'mg/m3'
1009      fbdata%cgrid(1)      = 'T'
1010      DO ja = 1, nadd
1011         fbdata%caddname(1+ja) = padd%cdname(ja)
1012         fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1)
1013         fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1)
1014      END DO
1015
1016      WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc
1017
1018      IF(lwp) THEN
1019         WRITE(numout,*)
1020         WRITE(numout,*)'obs_wri_logchl :'
1021         WRITE(numout,*)'~~~~~~~~~~~~~~~~'
1022         WRITE(numout,*)'Writing logchl feedback file : ',TRIM(cfname)
1023      ENDIF
1024
1025      ! Transform obs_prof data structure into obfbdata structure
1026      fbdata%cdjuldref = '19500101000000'
1027      DO jo = 1, logchldata%nsurf
1028         fbdata%plam(jo)      = logchldata%rlam(jo)
1029         fbdata%pphi(jo)      = logchldata%rphi(jo)
1030         WRITE(fbdata%cdtyp(jo),'(I4)') logchldata%ntyp(jo)
1031         fbdata%ivqc(jo,:)    = 0
1032         fbdata%ivqcf(:,jo,:) = 0
1033         IF ( logchldata%nqc(jo) > 10 ) THEN
1034            fbdata%ioqc(jo)    = 4
1035            fbdata%ioqcf(1,jo) = 0
1036            fbdata%ioqcf(2,jo) = logchldata%nqc(jo) - 10
1037         ELSE
1038            fbdata%ioqc(jo)    = MAX(logchldata%nqc(jo),1)
1039            fbdata%ioqcf(:,jo) = 0
1040         ENDIF
1041         fbdata%ipqc(jo)      = 0
1042         fbdata%ipqcf(:,jo)   = 0
1043         fbdata%itqc(jo)      = 0
1044         fbdata%itqcf(:,jo)   = 0
1045         fbdata%cdwmo(jo)     = ''
1046         fbdata%kindex(jo)    = logchldata%nsfil(jo)
1047         IF (ln_grid_global) THEN
1048            fbdata%iobsi(jo,1) = logchldata%mi(jo)
1049            fbdata%iobsj(jo,1) = logchldata%mj(jo)
1050         ELSE
1051            fbdata%iobsi(jo,1) = mig(logchldata%mi(jo))
1052            fbdata%iobsj(jo,1) = mjg(logchldata%mj(jo))
1053         ENDIF
1054         CALL greg2jul( 0, &
1055            &           logchldata%nmin(jo), &
1056            &           logchldata%nhou(jo), &
1057            &           logchldata%nday(jo), &
1058            &           logchldata%nmon(jo), &
1059            &           logchldata%nyea(jo), &
1060            &           fbdata%ptim(jo),   &
1061            &           krefdate = 19500101 )
1062         fbdata%padd(1,jo,1,1) = logchldata%rmod(jo,1)
1063         fbdata%pob(1,jo,1)    = logchldata%robs(jo,1)
1064         fbdata%pdep(1,jo)     = 0.0
1065         fbdata%idqc(1,jo)     = 0
1066         fbdata%idqcf(:,1,jo)  = 0
1067         IF ( logchldata%nqc(jo) > 10 ) THEN
1068            fbdata%ivlqc(1,jo,1) = 4
1069            fbdata%ivlqcf(1,1,jo,1) = 0
1070            fbdata%ivlqcf(2,1,jo,1) = logchldata%nqc(jo) - 10
1071         ELSE
1072            fbdata%ivlqc(1,jo,1) = MAX(logchldata%nqc(jo),1)
1073            fbdata%ivlqcf(:,1,jo,1) = 0
1074         ENDIF
1075         fbdata%iobsk(1,jo,1)  = 0
1076         DO ja = 1, nadd
1077            fbdata%padd(1,jo,1+ja,1) = &
1078               & logchldata%rext(jo,padd%ipoint(ja))
1079         END DO
1080         DO je = 1, next
1081            fbdata%pext(1,jo,je) = &
1082               & logchldata%rext(jo,pext%ipoint(je))
1083         END DO
1084
1085      END DO
1086
1087      ! Write the obfbdata structure
1088      CALL write_obfbdata( cfname, fbdata )
1089     
1090      ! Output some basic statistics
1091      CALL obs_wri_stats( fbdata )
1092
1093      CALL dealloc_obfbdata( fbdata )
1094
1095   END SUBROUTINE obs_wri_logchl
1096
1097   SUBROUTINE obs_wri_spm( cprefix, spmdata, padd, pext )
1098      !!-----------------------------------------------------------------------
1099      !!
1100      !!                     *** ROUTINE obs_wri_spm  ***
1101      !!
1102      !! ** Purpose : Write spm observation diagnostics
1103      !!              related
1104      !!
1105      !! ** Method  : NetCDF
1106      !!
1107      !! ** Action  :
1108      !!
1109      !!-----------------------------------------------------------------------
1110
1111      !! * Modules used
1112      IMPLICIT NONE
1113
1114      !! * Arguments
1115      CHARACTER(LEN=*), INTENT(IN) :: cprefix       ! Prefix for output files
1116      TYPE(obs_surf), INTENT(INOUT) :: spmdata   ! Full set of spm
1117      TYPE(obswriinfo), OPTIONAL :: padd            ! Additional info for each variable
1118      TYPE(obswriinfo), OPTIONAL :: pext            ! Extra info
1119
1120      !! * Local declarations
1121      TYPE(obfbdata) :: fbdata
1122      CHARACTER(LEN=40) :: cfname             ! netCDF filename
1123      CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_spm'
1124      INTEGER :: jo
1125      INTEGER :: ja
1126      INTEGER :: je
1127      INTEGER :: nadd
1128      INTEGER :: next
1129
1130      IF ( PRESENT( padd ) ) THEN
1131         nadd = padd%inum
1132      ELSE
1133         nadd = 0
1134      ENDIF
1135
1136      IF ( PRESENT( pext ) ) THEN
1137         next = pext%inum
1138      ELSE
1139         next = 0
1140      ENDIF
1141
1142      CALL init_obfbdata( fbdata )
1143
1144      CALL alloc_obfbdata( fbdata, 1, spmdata%nsurf, 1, &
1145         &                 1 + nadd, next, .TRUE. )
1146
1147      fbdata%cname(1)      = 'spm'
1148      fbdata%coblong(1)    = 'spm'
1149      fbdata%cobunit(1)    = 'g/m3'
1150      DO je = 1, next
1151         fbdata%cextname(je) = pext%cdname(je)
1152         fbdata%cextlong(je) = pext%cdlong(je,1)
1153         fbdata%cextunit(je) = pext%cdunit(je,1)
1154      END DO
1155      fbdata%caddname(1)   = 'Hx'
1156      fbdata%caddlong(1,1) = 'Model interpolated spm'
1157      fbdata%caddunit(1,1) = 'g/m3'
1158      fbdata%cgrid(1)      = 'T'
1159      DO ja = 1, nadd
1160         fbdata%caddname(1+ja) = padd%cdname(ja)
1161         fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1)
1162         fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1)
1163      END DO
1164
1165      WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc
1166
1167      IF(lwp) THEN
1168         WRITE(numout,*)
1169         WRITE(numout,*)'obs_wri_spm :'
1170         WRITE(numout,*)'~~~~~~~~~~~~~~~~'
1171         WRITE(numout,*)'Writing spm feedback file : ',TRIM(cfname)
1172      ENDIF
1173
1174      ! Transform obs_prof data structure into obfbdata structure
1175      fbdata%cdjuldref = '19500101000000'
1176      DO jo = 1, spmdata%nsurf
1177         fbdata%plam(jo)      = spmdata%rlam(jo)
1178         fbdata%pphi(jo)      = spmdata%rphi(jo)
1179         WRITE(fbdata%cdtyp(jo),'(I4)') spmdata%ntyp(jo)
1180         fbdata%ivqc(jo,:)    = 0
1181         fbdata%ivqcf(:,jo,:) = 0
1182         IF ( spmdata%nqc(jo) > 10 ) THEN
1183            fbdata%ioqc(jo)    = 4
1184            fbdata%ioqcf(1,jo) = 0
1185            fbdata%ioqcf(2,jo) = spmdata%nqc(jo) - 10
1186         ELSE
1187            fbdata%ioqc(jo)    = MAX(spmdata%nqc(jo),1)
1188            fbdata%ioqcf(:,jo) = 0
1189         ENDIF
1190         fbdata%ipqc(jo)      = 0
1191         fbdata%ipqcf(:,jo)   = 0
1192         fbdata%itqc(jo)      = 0
1193         fbdata%itqcf(:,jo)   = 0
1194         fbdata%cdwmo(jo)     = ''
1195         fbdata%kindex(jo)    = spmdata%nsfil(jo)
1196         IF (ln_grid_global) THEN
1197            fbdata%iobsi(jo,1) = spmdata%mi(jo)
1198            fbdata%iobsj(jo,1) = spmdata%mj(jo)
1199         ELSE
1200            fbdata%iobsi(jo,1) = mig(spmdata%mi(jo))
1201            fbdata%iobsj(jo,1) = mjg(spmdata%mj(jo))
1202         ENDIF
1203         CALL greg2jul( 0, &
1204            &           spmdata%nmin(jo), &
1205            &           spmdata%nhou(jo), &
1206            &           spmdata%nday(jo), &
1207            &           spmdata%nmon(jo), &
1208            &           spmdata%nyea(jo), &
1209            &           fbdata%ptim(jo),   &
1210            &           krefdate = 19500101 )
1211         fbdata%padd(1,jo,1,1) = spmdata%rmod(jo,1)
1212         fbdata%pob(1,jo,1)    = spmdata%robs(jo,1)
1213         fbdata%pdep(1,jo)     = 0.0
1214         fbdata%idqc(1,jo)     = 0
1215         fbdata%idqcf(:,1,jo)  = 0
1216         IF ( spmdata%nqc(jo) > 10 ) THEN
1217            fbdata%ivlqc(1,jo,1) = 4
1218            fbdata%ivlqcf(1,1,jo,1) = 0
1219            fbdata%ivlqcf(2,1,jo,1) = spmdata%nqc(jo) - 10
1220         ELSE
1221            fbdata%ivlqc(1,jo,1) = MAX(spmdata%nqc(jo),1)
1222            fbdata%ivlqcf(:,1,jo,1) = 0
1223         ENDIF
1224         fbdata%iobsk(1,jo,1)  = 0
1225         DO ja = 1, nadd
1226            fbdata%padd(1,jo,1+ja,1) = &
1227               & spmdata%rext(jo,padd%ipoint(ja))
1228         END DO
1229         DO je = 1, next
1230            fbdata%pext(1,jo,je) = &
1231               & spmdata%rext(jo,pext%ipoint(je))
1232         END DO
1233
1234      END DO
1235
1236      ! Write the obfbdata structure
1237      CALL write_obfbdata( cfname, fbdata )
1238     
1239      ! Output some basic statistics
1240      CALL obs_wri_stats( fbdata )
1241
1242      CALL dealloc_obfbdata( fbdata )
1243
1244   END SUBROUTINE obs_wri_spm
1245
1246   SUBROUTINE obs_wri_fco2( cprefix, fco2data, padd, pext )
1247      !!-----------------------------------------------------------------------
1248      !!
1249      !!                     *** ROUTINE obs_wri_fco2  ***
1250      !!
1251      !! ** Purpose : Write fco2 observation diagnostics
1252      !!              related
1253      !!
1254      !! ** Method  : NetCDF
1255      !!
1256      !! ** Action  :
1257      !!
1258      !!-----------------------------------------------------------------------
1259
1260      !! * Modules used
1261      IMPLICIT NONE
1262
1263      !! * Arguments
1264      CHARACTER(LEN=*), INTENT(IN) :: cprefix       ! Prefix for output files
1265      TYPE(obs_surf), INTENT(INOUT) :: fco2data   ! Full set of fco2
1266      TYPE(obswriinfo), OPTIONAL :: padd            ! Additional info for each variable
1267      TYPE(obswriinfo), OPTIONAL :: pext            ! Extra info
1268
1269      !! * Local declarations
1270      TYPE(obfbdata) :: fbdata
1271      CHARACTER(LEN=40) :: cfname             ! netCDF filename
1272      CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_fco2'
1273      INTEGER :: jo
1274      INTEGER :: ja
1275      INTEGER :: je
1276      INTEGER :: nadd
1277      INTEGER :: next
1278
1279      IF ( PRESENT( padd ) ) THEN
1280         nadd = padd%inum
1281      ELSE
1282         nadd = 0
1283      ENDIF
1284
1285      IF ( PRESENT( pext ) ) THEN
1286         next = pext%inum
1287      ELSE
1288         next = 0
1289      ENDIF
1290
1291      CALL init_obfbdata( fbdata )
1292
1293      CALL alloc_obfbdata( fbdata, 1, fco2data%nsurf, 1, &
1294         &                 1 + nadd, next, .TRUE. )
1295
1296      fbdata%cname(1)      = 'fco2'
1297      fbdata%coblong(1)    = 'fco2'
1298      fbdata%cobunit(1)    = 'uatm'
1299      DO je = 1, next
1300         fbdata%cextname(je) = pext%cdname(je)
1301         fbdata%cextlong(je) = pext%cdlong(je,1)
1302         fbdata%cextunit(je) = pext%cdunit(je,1)
1303      END DO
1304      fbdata%caddname(1)   = 'Hx'
1305      fbdata%caddlong(1,1) = 'Model interpolated fco2'
1306      fbdata%caddunit(1,1) = 'uatm'
1307      fbdata%cgrid(1)      = 'T'
1308      DO ja = 1, nadd
1309         fbdata%caddname(1+ja) = padd%cdname(ja)
1310         fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1)
1311         fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1)
1312      END DO
1313
1314      WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc
1315
1316      IF(lwp) THEN
1317         WRITE(numout,*)
1318         WRITE(numout,*)'obs_wri_fco2 :'
1319         WRITE(numout,*)'~~~~~~~~~~~~~~~~'
1320         WRITE(numout,*)'Writing fco2 feedback file : ',TRIM(cfname)
1321      ENDIF
1322
1323      ! Transform obs_prof data structure into obfbdata structure
1324      fbdata%cdjuldref = '19500101000000'
1325      DO jo = 1, fco2data%nsurf
1326         fbdata%plam(jo)      = fco2data%rlam(jo)
1327         fbdata%pphi(jo)      = fco2data%rphi(jo)
1328         WRITE(fbdata%cdtyp(jo),'(I4)') fco2data%ntyp(jo)
1329         fbdata%ivqc(jo,:)    = 0
1330         fbdata%ivqcf(:,jo,:) = 0
1331         IF ( fco2data%nqc(jo) > 10 ) THEN
1332            fbdata%ioqc(jo)    = 4
1333            fbdata%ioqcf(1,jo) = 0
1334            fbdata%ioqcf(2,jo) = fco2data%nqc(jo) - 10
1335         ELSE
1336            fbdata%ioqc(jo)    = MAX(fco2data%nqc(jo),1)
1337            fbdata%ioqcf(:,jo) = 0
1338         ENDIF
1339         fbdata%ipqc(jo)      = 0
1340         fbdata%ipqcf(:,jo)   = 0
1341         fbdata%itqc(jo)      = 0
1342         fbdata%itqcf(:,jo)   = 0
1343         fbdata%cdwmo(jo)     = ''
1344         fbdata%kindex(jo)    = fco2data%nsfil(jo)
1345         IF (ln_grid_global) THEN
1346            fbdata%iobsi(jo,1) = fco2data%mi(jo)
1347            fbdata%iobsj(jo,1) = fco2data%mj(jo)
1348         ELSE
1349            fbdata%iobsi(jo,1) = mig(fco2data%mi(jo))
1350            fbdata%iobsj(jo,1) = mjg(fco2data%mj(jo))
1351         ENDIF
1352         CALL greg2jul( 0, &
1353            &           fco2data%nmin(jo), &
1354            &           fco2data%nhou(jo), &
1355            &           fco2data%nday(jo), &
1356            &           fco2data%nmon(jo), &
1357            &           fco2data%nyea(jo), &
1358            &           fbdata%ptim(jo),   &
1359            &           krefdate = 19500101 )
1360         fbdata%padd(1,jo,1,1) = fco2data%rmod(jo,1)
1361         fbdata%pob(1,jo,1)    = fco2data%robs(jo,1)
1362         fbdata%pdep(1,jo)     = 0.0
1363         fbdata%idqc(1,jo)     = 0
1364         fbdata%idqcf(:,1,jo)  = 0
1365         IF ( fco2data%nqc(jo) > 10 ) THEN
1366            fbdata%ivlqc(1,jo,1) = 4
1367            fbdata%ivlqcf(1,1,jo,1) = 0
1368            fbdata%ivlqcf(2,1,jo,1) = fco2data%nqc(jo) - 10
1369         ELSE
1370            fbdata%ivlqc(1,jo,1) = MAX(fco2data%nqc(jo),1)
1371            fbdata%ivlqcf(:,1,jo,1) = 0
1372         ENDIF
1373         fbdata%iobsk(1,jo,1)  = 0
1374         DO ja = 1, nadd
1375            fbdata%padd(1,jo,1+ja,1) = &
1376               & fco2data%rext(jo,padd%ipoint(ja))
1377         END DO
1378         DO je = 1, next
1379            fbdata%pext(1,jo,je) = &
1380               & fco2data%rext(jo,pext%ipoint(je))
1381         END DO
1382
1383      END DO
1384
1385      ! Write the obfbdata structure
1386      CALL write_obfbdata( cfname, fbdata )
1387     
1388      ! Output some basic statistics
1389      CALL obs_wri_stats( fbdata )
1390
1391      CALL dealloc_obfbdata( fbdata )
1392
1393   END SUBROUTINE obs_wri_fco2
1394
1395   SUBROUTINE obs_wri_pco2( cprefix, pco2data, padd, pext )
1396      !!-----------------------------------------------------------------------
1397      !!
1398      !!                     *** ROUTINE obs_wri_pco2  ***
1399      !!
1400      !! ** Purpose : Write pco2 observation diagnostics
1401      !!              related
1402      !!
1403      !! ** Method  : NetCDF
1404      !!
1405      !! ** Action  :
1406      !!
1407      !!-----------------------------------------------------------------------
1408
1409      !! * Modules used
1410      IMPLICIT NONE
1411
1412      !! * Arguments
1413      CHARACTER(LEN=*), INTENT(IN) :: cprefix       ! Prefix for output files
1414      TYPE(obs_surf), INTENT(INOUT) :: pco2data   ! Full set of pco2
1415      TYPE(obswriinfo), OPTIONAL :: padd            ! Additional info for each variable
1416      TYPE(obswriinfo), OPTIONAL :: pext            ! Extra info
1417
1418      !! * Local declarations
1419      TYPE(obfbdata) :: fbdata
1420      CHARACTER(LEN=40) :: cfname             ! netCDF filename
1421      CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_pco2'
1422      INTEGER :: jo
1423      INTEGER :: ja
1424      INTEGER :: je
1425      INTEGER :: nadd
1426      INTEGER :: next
1427
1428      IF ( PRESENT( padd ) ) THEN
1429         nadd = padd%inum
1430      ELSE
1431         nadd = 0
1432      ENDIF
1433
1434      IF ( PRESENT( pext ) ) THEN
1435         next = pext%inum
1436      ELSE
1437         next = 0
1438      ENDIF
1439
1440      CALL init_obfbdata( fbdata )
1441
1442      CALL alloc_obfbdata( fbdata, 1, pco2data%nsurf, 1, &
1443         &                 1 + nadd, next, .TRUE. )
1444
1445      fbdata%cname(1)      = 'pco2'
1446      fbdata%coblong(1)    = 'pco2'
1447      fbdata%cobunit(1)    = 'uatm'
1448      DO je = 1, next
1449         fbdata%cextname(je) = pext%cdname(je)
1450         fbdata%cextlong(je) = pext%cdlong(je,1)
1451         fbdata%cextunit(je) = pext%cdunit(je,1)
1452      END DO
1453      fbdata%caddname(1)   = 'Hx'
1454      fbdata%caddlong(1,1) = 'Model interpolated pco2'
1455      fbdata%caddunit(1,1) = 'uatm'
1456      fbdata%cgrid(1)      = 'T'
1457      DO ja = 1, nadd
1458         fbdata%caddname(1+ja) = padd%cdname(ja)
1459         fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1)
1460         fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1)
1461      END DO
1462
1463      WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc
1464
1465      IF(lwp) THEN
1466         WRITE(numout,*)
1467         WRITE(numout,*)'obs_wri_pco2 :'
1468         WRITE(numout,*)'~~~~~~~~~~~~~~~~'
1469         WRITE(numout,*)'Writing pco2 feedback file : ',TRIM(cfname)
1470      ENDIF
1471
1472      ! Transform obs_prof data structure into obfbdata structure
1473      fbdata%cdjuldref = '19500101000000'
1474      DO jo = 1, pco2data%nsurf
1475         fbdata%plam(jo)      = pco2data%rlam(jo)
1476         fbdata%pphi(jo)      = pco2data%rphi(jo)
1477         WRITE(fbdata%cdtyp(jo),'(I4)') pco2data%ntyp(jo)
1478         fbdata%ivqc(jo,:)    = 0
1479         fbdata%ivqcf(:,jo,:) = 0
1480         IF ( pco2data%nqc(jo) > 10 ) THEN
1481            fbdata%ioqc(jo)    = 4
1482            fbdata%ioqcf(1,jo) = 0
1483            fbdata%ioqcf(2,jo) = pco2data%nqc(jo) - 10
1484         ELSE
1485            fbdata%ioqc(jo)    = MAX(pco2data%nqc(jo),1)
1486            fbdata%ioqcf(:,jo) = 0
1487         ENDIF
1488         fbdata%ipqc(jo)      = 0
1489         fbdata%ipqcf(:,jo)   = 0
1490         fbdata%itqc(jo)      = 0
1491         fbdata%itqcf(:,jo)   = 0
1492         fbdata%cdwmo(jo)     = ''
1493         fbdata%kindex(jo)    = pco2data%nsfil(jo)
1494         IF (ln_grid_global) THEN
1495            fbdata%iobsi(jo,1) = pco2data%mi(jo)
1496            fbdata%iobsj(jo,1) = pco2data%mj(jo)
1497         ELSE
1498            fbdata%iobsi(jo,1) = mig(pco2data%mi(jo))
1499            fbdata%iobsj(jo,1) = mjg(pco2data%mj(jo))
1500         ENDIF
1501         CALL greg2jul( 0, &
1502            &           pco2data%nmin(jo), &
1503            &           pco2data%nhou(jo), &
1504            &           pco2data%nday(jo), &
1505            &           pco2data%nmon(jo), &
1506            &           pco2data%nyea(jo), &
1507            &           fbdata%ptim(jo),   &
1508            &           krefdate = 19500101 )
1509         fbdata%padd(1,jo,1,1) = pco2data%rmod(jo,1)
1510         fbdata%pob(1,jo,1)    = pco2data%robs(jo,1)
1511         fbdata%pdep(1,jo)     = 0.0
1512         fbdata%idqc(1,jo)     = 0
1513         fbdata%idqcf(:,1,jo)  = 0
1514         IF ( pco2data%nqc(jo) > 10 ) THEN
1515            fbdata%ivlqc(1,jo,1) = 4
1516            fbdata%ivlqcf(1,1,jo,1) = 0
1517            fbdata%ivlqcf(2,1,jo,1) = pco2data%nqc(jo) - 10
1518         ELSE
1519            fbdata%ivlqc(1,jo,1) = MAX(pco2data%nqc(jo),1)
1520            fbdata%ivlqcf(:,1,jo,1) = 0
1521         ENDIF
1522         fbdata%iobsk(1,jo,1)  = 0
1523         DO ja = 1, nadd
1524            fbdata%padd(1,jo,1+ja,1) = &
1525               & pco2data%rext(jo,padd%ipoint(ja))
1526         END DO
1527         DO je = 1, next
1528            fbdata%pext(1,jo,je) = &
1529               & pco2data%rext(jo,pext%ipoint(je))
1530         END DO
1531
1532      END DO
1533
1534      ! Write the obfbdata structure
1535      CALL write_obfbdata( cfname, fbdata )
1536     
1537      ! Output some basic statistics
1538      CALL obs_wri_stats( fbdata )
1539
1540      CALL dealloc_obfbdata( fbdata )
1541
1542   END SUBROUTINE obs_wri_pco2
1543
1544   SUBROUTINE obs_wri_stats( fbdata )
1545      !!-----------------------------------------------------------------------
1546      !!
1547      !!                     *** ROUTINE obs_wri_stats  ***
1548      !!
1549      !! ** Purpose : Output some basic statistics of the data being written out
1550      !!
1551      !! ** Method  :
1552      !!
1553      !! ** Action  :
1554      !!
1555      !!      ! 2014-08  (D. Lea) Initial version
1556      !!-----------------------------------------------------------------------
1557
1558      !! * Arguments
1559      TYPE(obfbdata) :: fbdata
1560
1561      !! * Local declarations
1562      INTEGER :: jvar
1563      INTEGER :: jo
1564      INTEGER :: jk
1565
1566!      INTEGER :: nlev
1567!      INTEGER :: nlevmpp
1568!      INTEGER :: nobsmpp
1569      INTEGER :: numgoodobs
1570      INTEGER :: numgoodobsmpp
1571      REAL(wp) :: zsumx
1572      REAL(wp) :: zsumx2
1573      REAL(wp) :: zomb
1574
1575      IF (lwp) THEN
1576         WRITE(numout,*) ''
1577         WRITE(numout,*) 'obs_wri_stats :'
1578         WRITE(numout,*) '~~~~~~~~~~~~~~~' 
1579      ENDIF
1580
1581      DO jvar = 1, fbdata%nvar
1582         zsumx=0.0_wp
1583         zsumx2=0.0_wp
1584         numgoodobs=0
1585         DO jo = 1, fbdata%nobs
1586            DO jk = 1, fbdata%nlev
1587               IF ( ( fbdata%pob(jk,jo,jvar) < 9999.0 ) .AND. &
1588                  & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. &
1589                  & ( fbdata%padd(jk,jo,1,jvar) < 9999.0 ) ) THEN
1590       
1591             zomb=fbdata%pob(jk, jo, jvar)-fbdata%padd(jk, jo, 1, jvar)
1592                  zsumx=zsumx+zomb
1593                  zsumx2=zsumx2+zomb**2
1594                  numgoodobs=numgoodobs+1
1595          ENDIF
1596            ENDDO
1597         ENDDO
1598
1599         CALL obs_mpp_sum_integer( numgoodobs, numgoodobsmpp )
1600         CALL mpp_sum(zsumx)
1601         CALL mpp_sum(zsumx2)
1602
1603         IF (lwp) THEN
1604       WRITE(numout,*) 'Type: ',fbdata%cname(jvar),'  Total number of good observations: ',numgoodobsmpp 
1605       WRITE(numout,*) 'Overall mean obs minus model of the good observations: ',zsumx/numgoodobsmpp
1606            WRITE(numout,*) 'Overall RMS obs minus model of the good observations: ',sqrt( zsumx2/numgoodobsmpp )
1607       WRITE(numout,*) ''
1608         ENDIF
1609 
1610      ENDDO
1611
1612   END SUBROUTINE obs_wri_stats
1613
1614END MODULE obs_write
Note: See TracBrowser for help on using the repository browser.