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.
diaobs.F90 in NEMO/branches/2020/KERNEL-03_Storkey_Coward_RK3_stage2/src/OCE/OBS – NEMO

source: NEMO/branches/2020/KERNEL-03_Storkey_Coward_RK3_stage2/src/OCE/OBS/diaobs.F90 @ 12406

Last change on this file since 12406 was 12406, checked in by davestorkey, 4 years ago
  1. Rename the namelist timestep parameter: rn_rdt -> rn_Dt
  2. Use the namelist parameter instead of the non-DOCTOR parameter: rdt -> rn_Dt

This version has same SETTE results as the last version. Passes all tests but some
tests don't bit compare with the trunk.
  • Property svn:keywords set to Id
File size: 46.4 KB
Line 
1MODULE diaobs
2   !!======================================================================
3   !!                       ***  MODULE diaobs  ***
4   !! Observation diagnostics: Computation of the misfit between data and
5   !!                          their model equivalent
6   !!======================================================================
7   !! History :  1.0  !  2006-03  (K. Mogensen) Original code
8   !!             -   !  2006-05  (K. Mogensen, A. Weaver) Reformatted
9   !!             -   !  2006-10  (A. Weaver) Cleaning and add controls
10   !!             -   !  2007-03  (K. Mogensen) General handling of profiles
11   !!             -   !  2007-04  (G. Smith) Generalized surface operators
12   !!            2.0  !  2008-10  (M. Valdivieso) obs operator for velocity profiles
13   !!            3.4  !  2014-08  (J. While) observation operator for profiles in all vertical coordinates
14   !!             -   !                      Incorporated SST bias correction 
15   !!            3.6  !  2015-02  (M. Martin) Simplification of namelist and code
16   !!             -   !  2015-08  (M. Martin) Combined surface/profile routines.
17   !!            4.0  !  2017-11  (G. Madec) style only
18   !!----------------------------------------------------------------------
19
20   !!----------------------------------------------------------------------
21   !!   dia_obs_init  : Reading and prepare observations
22   !!   dia_obs       : Compute model equivalent to observations
23   !!   dia_obs_wri   : Write observational diagnostics
24   !!   calc_date     : Compute the date of timestep in YYYYMMDD.HHMMSS format
25   !!   ini_date      : Compute the initial date YYYYMMDD.HHMMSS
26   !!   fin_date      : Compute the final date YYYYMMDD.HHMMSS
27   !!----------------------------------------------------------------------
28   USE par_kind       ! Precision variables
29   USE in_out_manager ! I/O manager
30   USE par_oce        ! ocean parameter
31   USE dom_oce        ! Ocean space and time domain variables
32   USE sbc_oce        ! Sea-ice fraction
33   !
34   USE obs_read_prof  ! Reading and allocation of profile obs
35   USE obs_read_surf  ! Reading and allocation of surface obs
36   USE obs_sstbias    ! Bias correction routine for SST
37   USE obs_readmdt    ! Reading and allocation of MDT for SLA.
38   USE obs_prep       ! Preparation of obs. (grid search etc).
39   USE obs_oper       ! Observation operators
40   USE obs_write      ! Writing of observation related diagnostics
41   USE obs_grid       ! Grid searching
42   USE obs_read_altbias ! Bias treatment for altimeter
43   USE obs_profiles_def ! Profile data definitions
44   USE obs_surf_def   ! Surface data definitions
45   USE obs_types      ! Definitions for observation types
46   !
47   USE mpp_map        ! MPP mapping
48   USE lib_mpp        ! For ctl_warn/stop
49
50   IMPLICIT NONE
51   PRIVATE
52
53   PUBLIC dia_obs_init     ! Initialize and read observations
54   PUBLIC dia_obs          ! Compute model equivalent to observations
55   PUBLIC dia_obs_wri      ! Write model equivalent to observations
56   PUBLIC dia_obs_dealloc  ! Deallocate dia_obs data
57   PUBLIC calc_date        ! Compute the date of a timestep
58
59   LOGICAL, PUBLIC :: ln_diaobs          !: Logical switch for the obs operator
60   LOGICAL         :: ln_sstnight        !  Logical switch for night mean SST obs
61   LOGICAL         :: ln_sla_fp_indegs   !  T=> SLA obs footprint size specified in degrees, F=> in metres
62   LOGICAL         :: ln_sst_fp_indegs   !  T=> SST obs footprint size specified in degrees, F=> in metres
63   LOGICAL         :: ln_sss_fp_indegs   !  T=> SSS obs footprint size specified in degrees, F=> in metres
64   LOGICAL         :: ln_sic_fp_indegs   !  T=> sea-ice obs footprint size specified in degrees, F=> in metres
65
66   REAL(wp) ::   rn_sla_avglamscl   ! E/W diameter of SLA observation footprint (metres)
67   REAL(wp) ::   rn_sla_avgphiscl   ! N/S diameter of SLA observation footprint (metres)
68   REAL(wp) ::   rn_sst_avglamscl   ! E/W diameter of SST observation footprint (metres)
69   REAL(wp) ::   rn_sst_avgphiscl   ! N/S diameter of SST observation footprint (metres)
70   REAL(wp) ::   rn_sss_avglamscl   ! E/W diameter of SSS observation footprint (metres)
71   REAL(wp) ::   rn_sss_avgphiscl   ! N/S diameter of SSS observation footprint (metres)
72   REAL(wp) ::   rn_sic_avglamscl   ! E/W diameter of sea-ice observation footprint (metres)
73   REAL(wp) ::   rn_sic_avgphiscl   ! N/S diameter of sea-ice observation footprint (metres)
74
75   INTEGER :: nn_1dint       ! Vertical interpolation method
76   INTEGER :: nn_2dint       ! Default horizontal interpolation method
77   INTEGER :: nn_2dint_sla   ! SLA horizontal interpolation method
78   INTEGER :: nn_2dint_sst   ! SST horizontal interpolation method
79   INTEGER :: nn_2dint_sss   ! SSS horizontal interpolation method
80   INTEGER :: nn_2dint_sic   ! Seaice horizontal interpolation method
81   INTEGER, DIMENSION(imaxavtypes) ::   nn_profdavtypes   ! Profile data types representing a daily average
82   INTEGER :: nproftypes     ! Number of profile obs types
83   INTEGER :: nsurftypes     ! Number of surface obs types
84   INTEGER , DIMENSION(:), ALLOCATABLE ::   nvarsprof, nvarssurf   ! Number of profile & surface variables
85   INTEGER , DIMENSION(:), ALLOCATABLE ::   nextrprof, nextrsurf   ! Number of profile & surface extra variables
86   INTEGER , DIMENSION(:), ALLOCATABLE ::   n2dintsurf             ! Interpolation option for surface variables
87   REAL(wp), DIMENSION(:), ALLOCATABLE ::   zavglamscl, zavgphiscl ! E/W & N/S diameter of averaging footprint for surface variables
88   LOGICAL , DIMENSION(:), ALLOCATABLE ::   lfpindegs              ! T=> surface obs footprint size specified in degrees, F=> in metres
89   LOGICAL , DIMENSION(:), ALLOCATABLE ::   llnightav              ! Logical for calculating night-time averages
90
91   TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) ::   surfdata     !: Initial surface data
92   TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) ::   surfdataqc   !: Surface data after quality control
93   TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) ::   profdata     !: Initial profile data
94   TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) ::   profdataqc   !: Profile data after quality control
95
96   CHARACTER(len=6), PUBLIC, DIMENSION(:), ALLOCATABLE ::   cobstypesprof, cobstypessurf   !: Profile & surface obs types
97
98   !!----------------------------------------------------------------------
99   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
100   !! $Id$
101   !! Software governed by the CeCILL license (see ./LICENSE)
102   !!----------------------------------------------------------------------
103CONTAINS
104
105   SUBROUTINE dia_obs_init( Kmm )
106      !!----------------------------------------------------------------------
107      !!                    ***  ROUTINE dia_obs_init  ***
108      !!         
109      !! ** Purpose : Initialize and read observations
110      !!
111      !! ** Method  : Read the namelist and call reading routines
112      !!
113      !! ** Action  : Read the namelist and call reading routines
114      !!
115      !!----------------------------------------------------------------------
116      INTEGER, INTENT(in)                ::   Kmm                      ! ocean time level indices
117      INTEGER, PARAMETER                 ::   jpmaxnfiles = 1000       ! Maximum number of files for each obs type
118      INTEGER, DIMENSION(:), ALLOCATABLE ::   ifilesprof, ifilessurf   ! Number of profile & surface files
119      INTEGER :: ios             ! Local integer output status for namelist read
120      INTEGER :: jtype           ! Counter for obs types
121      INTEGER :: jvar            ! Counter for variables
122      INTEGER :: jfile           ! Counter for files
123      INTEGER :: jnumsstbias
124      !
125      CHARACTER(len=128), DIMENSION(jpmaxnfiles) :: &
126         & cn_profbfiles, &      ! T/S profile input filenames
127         & cn_sstfbfiles, &      ! Sea surface temperature input filenames
128         & cn_sssfbfiles, &      ! Sea surface salinity input filenames
129         & cn_slafbfiles, &      ! Sea level anomaly input filenames
130         & cn_sicfbfiles, &      ! Seaice concentration input filenames
131         & cn_velfbfiles, &      ! Velocity profile input filenames
132         & cn_sstbiasfiles      ! SST bias input filenames
133      CHARACTER(LEN=128) :: &
134         & cn_altbiasfile        ! Altimeter bias input filename
135      CHARACTER(len=128), DIMENSION(:,:), ALLOCATABLE :: &
136         & clproffiles, &        ! Profile filenames
137         & clsurffiles           ! Surface filenames
138         !
139      LOGICAL :: ln_t3d          ! Logical switch for temperature profiles
140      LOGICAL :: ln_s3d          ! Logical switch for salinity profiles
141      LOGICAL :: ln_sla          ! Logical switch for sea level anomalies
142      LOGICAL :: ln_sst          ! Logical switch for sea surface temperature
143      LOGICAL :: ln_sss          ! Logical switch for sea surface salinity
144      LOGICAL :: ln_sic          ! Logical switch for sea ice concentration
145      LOGICAL :: ln_vel3d        ! Logical switch for velocity (u,v) obs
146      LOGICAL :: ln_nea          ! Logical switch to remove obs near land
147      LOGICAL :: ln_altbias      ! Logical switch for altimeter bias
148      LOGICAL :: ln_sstbias      ! Logical switch for bias corection of SST
149      LOGICAL :: ln_ignmis       ! Logical switch for ignoring missing files
150      LOGICAL :: ln_s_at_t       ! Logical switch to compute model S at T obs
151      LOGICAL :: ln_bound_reject ! Logical to remove obs near boundaries in LAMs.
152      LOGICAL :: llvar1          ! Logical for profile variable 1
153      LOGICAL :: llvar2          ! Logical for profile variable 1
154      LOGICAL, DIMENSION(jpmaxnfiles) :: lmask ! Used for finding number of sstbias files
155      !
156      REAL(dp) :: rn_dobsini     ! Obs window start date YYYYMMDD.HHMMSS
157      REAL(dp) :: rn_dobsend     ! Obs window end date   YYYYMMDD.HHMMSS
158      REAL(wp), DIMENSION(jpi,jpj)     ::   zglam1, zglam2   ! Model longitudes for profile variable 1 & 2
159      REAL(wp), DIMENSION(jpi,jpj)     ::   zgphi1, zgphi2   ! Model latitudes  for profile variable 1 & 2
160      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zmask1, zmask2   ! Model land/sea mask associated with variable 1 & 2
161      !!
162      NAMELIST/namobs/ln_diaobs, ln_t3d, ln_s3d, ln_sla,              &
163         &            ln_sst, ln_sic, ln_sss, ln_vel3d,               &
164         &            ln_altbias, ln_sstbias, ln_nea,                 &
165         &            ln_grid_global, ln_grid_search_lookup,          &
166         &            ln_ignmis, ln_s_at_t, ln_bound_reject,          &
167         &            ln_sstnight,                                    &
168         &            ln_sla_fp_indegs, ln_sst_fp_indegs,             &
169         &            ln_sss_fp_indegs, ln_sic_fp_indegs,             &
170         &            cn_profbfiles, cn_slafbfiles,                   &
171         &            cn_sstfbfiles, cn_sicfbfiles,                   &
172         &            cn_velfbfiles, cn_sssfbfiles,                   &
173         &            cn_sstbiasfiles, cn_altbiasfile,                &
174         &            cn_gridsearchfile, rn_gridsearchres,            &
175         &            rn_dobsini, rn_dobsend,                         &
176         &            rn_sla_avglamscl, rn_sla_avgphiscl,             &
177         &            rn_sst_avglamscl, rn_sst_avgphiscl,             &
178         &            rn_sss_avglamscl, rn_sss_avgphiscl,             &
179         &            rn_sic_avglamscl, rn_sic_avgphiscl,             &
180         &            nn_1dint, nn_2dint,                             &
181         &            nn_2dint_sla, nn_2dint_sst,                     &
182         &            nn_2dint_sss, nn_2dint_sic,                     &
183         &            nn_msshc, rn_mdtcorr, rn_mdtcutoff,             &
184         &            nn_profdavtypes
185      !-----------------------------------------------------------------------
186
187      !-----------------------------------------------------------------------
188      ! Read namelist parameters
189      !-----------------------------------------------------------------------
190      ! Some namelist arrays need initialising
191      cn_profbfiles  (:) = ''
192      cn_slafbfiles  (:) = ''
193      cn_sstfbfiles  (:) = ''
194      cn_sicfbfiles  (:) = ''
195      cn_velfbfiles  (:) = ''
196      cn_sssfbfiles  (:) = ''
197      cn_sstbiasfiles(:) = ''
198      nn_profdavtypes(:) = -1
199
200      CALL ini_date( rn_dobsini )
201      CALL fin_date( rn_dobsend )
202
203      ! Read namelist namobs : control observation diagnostics
204      READ  ( numnam_ref, namobs, IOSTAT = ios, ERR = 901)
205901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namobs in reference namelist' )
206      READ  ( numnam_cfg, namobs, IOSTAT = ios, ERR = 902 )
207902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namobs in configuration namelist' )
208      IF(lwm) WRITE ( numond, namobs )
209
210      IF( .NOT.ln_diaobs ) THEN
211         IF(lwp) WRITE(numout,*)
212         IF(lwp) WRITE(numout,*) 'dia_obs_init : NO Observation diagnostic used'
213         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~'
214         RETURN
215      ENDIF
216
217      IF(lwp) THEN
218         WRITE(numout,*)
219         WRITE(numout,*) 'dia_obs_init : Observation diagnostic initialization'
220         WRITE(numout,*) '~~~~~~~~~~~~'
221         WRITE(numout,*) '   Namelist namobs : set observation diagnostic parameters' 
222         WRITE(numout,*) '      Logical switch for T profile observations                ln_t3d = ', ln_t3d
223         WRITE(numout,*) '      Logical switch for S profile observations                ln_s3d = ', ln_s3d
224         WRITE(numout,*) '      Logical switch for SLA observations                      ln_sla = ', ln_sla
225         WRITE(numout,*) '      Logical switch for SST observations                      ln_sst = ', ln_sst
226         WRITE(numout,*) '      Logical switch for Sea Ice observations                  ln_sic = ', ln_sic
227         WRITE(numout,*) '      Logical switch for velocity observations               ln_vel3d = ', ln_vel3d
228         WRITE(numout,*) '      Logical switch for SSS observations                      ln_sss = ', ln_sss
229         WRITE(numout,*) '      Global distribution of observations              ln_grid_global = ', ln_grid_global
230         WRITE(numout,*) '      Logical switch for obs grid search lookup ln_grid_search_lookup = ', ln_grid_search_lookup
231         IF (ln_grid_search_lookup) &
232            WRITE(numout,*) '      Grid search lookup file header                cn_gridsearchfile = ', cn_gridsearchfile
233         WRITE(numout,*) '      Initial date in window YYYYMMDD.HHMMSS               rn_dobsini = ', rn_dobsini
234         WRITE(numout,*) '      Final date in window YYYYMMDD.HHMMSS                 rn_dobsend = ', rn_dobsend
235         WRITE(numout,*) '      Type of vertical interpolation method                  nn_1dint = ', nn_1dint
236         WRITE(numout,*) '      Type of horizontal interpolation method                nn_2dint = ', nn_2dint
237         WRITE(numout,*) '      Rejection of observations near land switch               ln_nea = ', ln_nea
238         WRITE(numout,*) '      Rejection of obs near open bdys                 ln_bound_reject = ', ln_bound_reject
239         WRITE(numout,*) '      MSSH correction scheme                                 nn_msshc = ', nn_msshc
240         WRITE(numout,*) '      MDT  correction                                      rn_mdtcorr = ', rn_mdtcorr
241         WRITE(numout,*) '      MDT cutoff for computed correction                 rn_mdtcutoff = ', rn_mdtcutoff
242         WRITE(numout,*) '      Logical switch for alt bias                          ln_altbias = ', ln_altbias
243         WRITE(numout,*) '      Logical switch for sst bias                          ln_sstbias = ', ln_sstbias
244         WRITE(numout,*) '      Logical switch for ignoring missing files             ln_ignmis = ', ln_ignmis
245         WRITE(numout,*) '      Daily average types                             nn_profdavtypes = ', nn_profdavtypes
246         WRITE(numout,*) '      Logical switch for night-time SST obs               ln_sstnight = ', ln_sstnight
247      ENDIF
248      !-----------------------------------------------------------------------
249      ! Set up list of observation types to be used
250      ! and the files associated with each type
251      !-----------------------------------------------------------------------
252
253      nproftypes = COUNT( (/ln_t3d .OR. ln_s3d, ln_vel3d /) )
254      nsurftypes = COUNT( (/ln_sla, ln_sst, ln_sic, ln_sss /) )
255
256      IF( ln_sstbias ) THEN
257         lmask(:) = .FALSE. 
258         WHERE( cn_sstbiasfiles(:) /= '' )   lmask(:) = .TRUE. 
259         jnumsstbias = COUNT(lmask) 
260         lmask(:) = .FALSE. 
261      ENDIF     
262
263      IF( nproftypes == 0 .AND. nsurftypes == 0 ) THEN
264         CALL ctl_warn( 'dia_obs_init: ln_diaobs is set to true, but all obs operator logical flags',   &
265            &           ' (ln_t3d, ln_s3d, ln_sla, ln_sst, ln_sic, ln_vel3d)',                          &
266            &           ' are set to .FALSE. so turning off calls to dia_obs'  )
267         ln_diaobs = .FALSE.
268         RETURN
269      ENDIF
270
271      IF( nproftypes > 0 ) THEN
272         !
273         ALLOCATE( cobstypesprof(nproftypes)             )
274         ALLOCATE( ifilesprof   (nproftypes)             )
275         ALLOCATE( clproffiles  (nproftypes,jpmaxnfiles) )
276         !
277         jtype = 0
278         IF( ln_t3d .OR. ln_s3d ) THEN
279            jtype = jtype + 1
280            CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'prof  ', &
281               &                   cn_profbfiles, ifilesprof, cobstypesprof, clproffiles )
282         ENDIF
283         IF( ln_vel3d ) THEN
284            jtype = jtype + 1
285            CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'vel   ', &
286               &                   cn_velfbfiles, ifilesprof, cobstypesprof, clproffiles )
287         ENDIF
288         !
289      ENDIF
290
291      IF( nsurftypes > 0 ) THEN
292         !
293         ALLOCATE( cobstypessurf(nsurftypes)             )
294         ALLOCATE( ifilessurf   (nsurftypes)             )
295         ALLOCATE( clsurffiles  (nsurftypes,jpmaxnfiles) )
296         ALLOCATE( n2dintsurf   (nsurftypes)             )
297         ALLOCATE( zavglamscl   (nsurftypes)             )
298         ALLOCATE( zavgphiscl   (nsurftypes)             )
299         ALLOCATE( lfpindegs    (nsurftypes)             )
300         ALLOCATE( llnightav    (nsurftypes)             )
301         !
302         jtype = 0
303         IF( ln_sla ) THEN
304            jtype = jtype + 1
305            CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sla   ', &
306               &                   cn_slafbfiles, ifilessurf, cobstypessurf, clsurffiles )
307            CALL obs_setinterpopts( nsurftypes, jtype, 'sla   ',      &
308               &                  nn_2dint, nn_2dint_sla,             &
309               &                  rn_sla_avglamscl, rn_sla_avgphiscl, &
310               &                  ln_sla_fp_indegs, .FALSE.,          &
311               &                  n2dintsurf, zavglamscl, zavgphiscl, &
312               &                  lfpindegs, llnightav )
313         ENDIF
314         IF( ln_sst ) THEN
315            jtype = jtype + 1
316            CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sst   ', &
317               &                   cn_sstfbfiles, ifilessurf, cobstypessurf, clsurffiles )
318            CALL obs_setinterpopts( nsurftypes, jtype, 'sst   ',      &
319               &                  nn_2dint, nn_2dint_sst,             &
320               &                  rn_sst_avglamscl, rn_sst_avgphiscl, &
321               &                  ln_sst_fp_indegs, ln_sstnight,      &
322               &                  n2dintsurf, zavglamscl, zavgphiscl, &
323               &                  lfpindegs, llnightav )
324         ENDIF
325#if defined key_si3 || defined key_cice
326         IF( ln_sic ) THEN
327            jtype = jtype + 1
328            CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sic   ', &
329               &                   cn_sicfbfiles, ifilessurf, cobstypessurf, clsurffiles )
330            CALL obs_setinterpopts( nsurftypes, jtype, 'sic   ',      &
331               &                  nn_2dint, nn_2dint_sic,             &
332               &                  rn_sic_avglamscl, rn_sic_avgphiscl, &
333               &                  ln_sic_fp_indegs, .FALSE.,          &
334               &                  n2dintsurf, zavglamscl, zavgphiscl, &
335               &                  lfpindegs, llnightav )
336         ENDIF
337#endif
338         IF( ln_sss ) THEN
339            jtype = jtype + 1
340            CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sss   ', &
341               &                   cn_sssfbfiles, ifilessurf, cobstypessurf, clsurffiles )
342            CALL obs_setinterpopts( nsurftypes, jtype, 'sss   ',      &
343               &                  nn_2dint, nn_2dint_sss,             &
344               &                  rn_sss_avglamscl, rn_sss_avgphiscl, &
345               &                  ln_sss_fp_indegs, .FALSE.,          &
346               &                  n2dintsurf, zavglamscl, zavgphiscl, &
347               &                  lfpindegs, llnightav )
348         ENDIF
349         !
350      ENDIF
351
352
353      !-----------------------------------------------------------------------
354      ! Obs operator parameter checking and initialisations
355      !-----------------------------------------------------------------------
356      !
357      IF( ln_vel3d  .AND.  .NOT.ln_grid_global ) THEN
358         CALL ctl_stop( 'Velocity data only works with ln_grid_global=.true.' )
359         RETURN
360      ENDIF
361      !
362      IF( ln_grid_global ) THEN
363         CALL ctl_warn( 'dia_obs_init: ln_grid_global=T may cause memory issues when used with a large number of processors' )
364      ENDIF
365      !
366      IF( nn_1dint < 0  .OR.  nn_1dint > 1 ) THEN
367         CALL ctl_stop('dia_obs_init: Choice of vertical (1D) interpolation method is not available')
368      ENDIF
369      !
370      IF( nn_2dint < 0  .OR.  nn_2dint > 6  ) THEN
371         CALL ctl_stop('dia_obs_init: Choice of horizontal (2D) interpolation method is not available')
372      ENDIF
373      !
374      CALL obs_typ_init
375      IF( ln_grid_global )   CALL mppmap_init
376      !
377      CALL obs_grid_setup( )
378
379      !-----------------------------------------------------------------------
380      ! Depending on switches read the various observation types
381      !-----------------------------------------------------------------------
382      !
383      IF( nproftypes > 0 ) THEN
384         !
385         ALLOCATE( profdata  (nproftypes) , nvarsprof (nproftypes) )
386         ALLOCATE( profdataqc(nproftypes) , nextrprof (nproftypes) )
387         !
388         DO jtype = 1, nproftypes
389            !
390            nvarsprof(jtype) = 2
391            IF ( TRIM(cobstypesprof(jtype)) == 'prof' ) THEN
392               nextrprof(jtype) = 1
393               llvar1 = ln_t3d
394               llvar2 = ln_s3d
395               zglam1 = glamt
396               zgphi1 = gphit
397               zmask1 = tmask
398               zglam2 = glamt
399               zgphi2 = gphit
400               zmask2 = tmask
401            ENDIF
402            IF ( TRIM(cobstypesprof(jtype)) == 'vel' )  THEN
403               nextrprof(jtype) = 2
404               llvar1 = ln_vel3d
405               llvar2 = ln_vel3d
406               zglam1 = glamu
407               zgphi1 = gphiu
408               zmask1 = umask
409               zglam2 = glamv
410               zgphi2 = gphiv
411               zmask2 = vmask
412            ENDIF
413            !
414            ! Read in profile or profile obs types
415            CALL obs_rea_prof( profdata(jtype), ifilesprof(jtype),       &
416               &               clproffiles(jtype,1:ifilesprof(jtype)), &
417               &               nvarsprof(jtype), nextrprof(jtype), nitend-nit000+2, &
418               &               rn_dobsini, rn_dobsend, llvar1, llvar2, &
419               &               ln_ignmis, ln_s_at_t, .FALSE., &
420               &               kdailyavtypes = nn_profdavtypes )
421               !
422            DO jvar = 1, nvarsprof(jtype)
423               CALL obs_prof_staend( profdata(jtype), jvar )
424            END DO
425            !
426            CALL obs_pre_prof( profdata(jtype), profdataqc(jtype), &
427               &               llvar1, llvar2, &
428               &               jpi, jpj, jpk, &
429               &               zmask1, zglam1, zgphi1, zmask2, zglam2, zgphi2,  &
430               &               ln_nea, ln_bound_reject, Kmm, &
431               &               kdailyavtypes = nn_profdavtypes )
432         END DO
433         !
434         DEALLOCATE( ifilesprof, clproffiles )
435         !
436      ENDIF
437      !
438      IF( nsurftypes > 0 ) THEN
439         !
440         ALLOCATE( surfdata  (nsurftypes) , nvarssurf(nsurftypes) )
441         ALLOCATE( surfdataqc(nsurftypes) , nextrsurf(nsurftypes) )
442         !
443         DO jtype = 1, nsurftypes
444            !
445            nvarssurf(jtype) = 1
446            nextrsurf(jtype) = 0
447            llnightav(jtype) = .FALSE.
448            IF( TRIM(cobstypessurf(jtype)) == 'sla' )   nextrsurf(jtype) = 2
449            IF( TRIM(cobstypessurf(jtype)) == 'sst' )   llnightav(jtype) = ln_sstnight
450            !
451            ! Read in surface obs types
452            CALL obs_rea_surf( surfdata(jtype), ifilessurf(jtype), &
453               &               clsurffiles(jtype,1:ifilessurf(jtype)), &
454               &               nvarssurf(jtype), nextrsurf(jtype), nitend-nit000+2, &
455               &               rn_dobsini, rn_dobsend, ln_ignmis, .FALSE., llnightav(jtype) )
456               !
457            CALL obs_pre_surf( surfdata(jtype), surfdataqc(jtype), ln_nea, ln_bound_reject )
458            !
459            IF( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN
460               CALL obs_rea_mdt( surfdataqc(jtype), n2dintsurf(jtype), Kmm )
461               IF( ln_altbias )   &
462                  & CALL obs_rea_altbias ( surfdataqc(jtype), n2dintsurf(jtype), cn_altbiasfile )
463            ENDIF
464            !
465            IF( TRIM(cobstypessurf(jtype)) == 'sst' .AND. ln_sstbias ) THEN
466               jnumsstbias = 0
467               DO jfile = 1, jpmaxnfiles
468                  IF( TRIM(cn_sstbiasfiles(jfile)) /= '' )   jnumsstbias = jnumsstbias + 1
469               END DO
470               IF( jnumsstbias == 0 )   CALL ctl_stop("ln_sstbias set but no bias files to read in")   
471               !
472               CALL obs_app_sstbias( surfdataqc(jtype), n2dintsurf(jtype)             ,   & 
473                  &                  jnumsstbias      , cn_sstbiasfiles(1:jnumsstbias) ) 
474            ENDIF
475         END DO
476         !
477         DEALLOCATE( ifilessurf, clsurffiles )
478         !
479      ENDIF
480      !
481   END SUBROUTINE dia_obs_init
482
483
484   SUBROUTINE dia_obs( kstp, Kmm )
485      !!----------------------------------------------------------------------
486      !!                    ***  ROUTINE dia_obs  ***
487      !!         
488      !! ** Purpose : Call the observation operators on each time step
489      !!
490      !! ** Method  : Call the observation operators on each time step to
491      !!              compute the model equivalent of the following data:
492      !!               - Profile data, currently T/S or U/V
493      !!               - Surface data, currently SST, SLA or sea-ice concentration.
494      !!
495      !! ** Action  :
496      !!----------------------------------------------------------------------
497      USE dom_oce, ONLY : gdept, gdept_1d     ! Ocean space domain variables (Kmm time-level only)
498      USE phycst , ONLY : rday                ! Physical constants
499      USE oce    , ONLY : ts, uu, vv, ssh     ! Ocean dynamics and tracers variables (Kmm time-level only)
500      USE phycst , ONLY : rday                ! Physical constants
501#if defined  key_si3
502      USE ice    , ONLY : at_i                ! SI3 Ice model variables
503#endif
504#if defined key_cice
505      USE sbc_oce, ONLY : fr_i     ! ice fraction
506#endif
507
508      IMPLICIT NONE
509
510      !! * Arguments
511      INTEGER, INTENT(IN) :: kstp  ! Current timestep
512      INTEGER, INTENT(in) :: Kmm   ! ocean time level indices
513      !! * Local declarations
514      INTEGER :: idaystp           ! Number of timesteps per day
515      INTEGER :: jtype             ! Data loop variable
516      INTEGER :: jvar              ! Variable number
517      INTEGER :: ji, jj            ! Loop counters
518      REAL(wp), DIMENSION(jpi,jpj,jpk) :: &
519         & zprofvar1, &            ! Model values for 1st variable in a prof ob
520         & zprofvar2               ! Model values for 2nd variable in a prof ob
521      REAL(wp), DIMENSION(jpi,jpj,jpk) :: &
522         & zprofmask1, &           ! Mask associated with zprofvar1
523         & zprofmask2              ! Mask associated with zprofvar2
524      REAL(wp), DIMENSION(jpi,jpj) :: &
525         & zsurfvar, &             ! Model values equivalent to surface ob.
526         & zsurfmask               ! Mask associated with surface variable
527      REAL(wp), DIMENSION(jpi,jpj) :: &
528         & zglam1,    &            ! Model longitudes for prof variable 1
529         & zglam2,    &            ! Model longitudes for prof variable 2
530         & zgphi1,    &            ! Model latitudes for prof variable 1
531         & zgphi2                  ! Model latitudes for prof variable 2
532
533      !-----------------------------------------------------------------------
534
535      IF(lwp) THEN
536         WRITE(numout,*)
537         WRITE(numout,*) 'dia_obs : Call the observation operators', kstp
538         WRITE(numout,*) '~~~~~~~'
539      ENDIF
540
541      idaystp = NINT( rday / rn_Dt )
542
543      !-----------------------------------------------------------------------
544      ! Call the profile and surface observation operators
545      !-----------------------------------------------------------------------
546
547      IF ( nproftypes > 0 ) THEN
548
549         DO jtype = 1, nproftypes
550
551            SELECT CASE ( TRIM(cobstypesprof(jtype)) )
552            CASE('prof')
553               zprofvar1(:,:,:) = ts(:,:,:,jp_tem,Kmm)
554               zprofvar2(:,:,:) = ts(:,:,:,jp_sal,Kmm)
555               zprofmask1(:,:,:) = tmask(:,:,:)
556               zprofmask2(:,:,:) = tmask(:,:,:)
557               zglam1(:,:) = glamt(:,:)
558               zglam2(:,:) = glamt(:,:)
559               zgphi1(:,:) = gphit(:,:)
560               zgphi2(:,:) = gphit(:,:)
561            CASE('vel')
562               zprofvar1(:,:,:) = uu(:,:,:,Kmm)
563               zprofvar2(:,:,:) = vv(:,:,:,Kmm)
564               zprofmask1(:,:,:) = umask(:,:,:)
565               zprofmask2(:,:,:) = vmask(:,:,:)
566               zglam1(:,:) = glamu(:,:)
567               zglam2(:,:) = glamv(:,:)
568               zgphi1(:,:) = gphiu(:,:)
569               zgphi2(:,:) = gphiv(:,:)
570            CASE DEFAULT
571               CALL ctl_stop( 'Unknown profile observation type '//TRIM(cobstypesprof(jtype))//' in dia_obs' )
572            END SELECT
573
574            CALL obs_prof_opt( profdataqc(jtype), kstp, jpi, jpj, jpk,  &
575               &               nit000, idaystp,                         &
576               &               zprofvar1, zprofvar2,                    &
577               &               gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm),      & 
578               &               zprofmask1, zprofmask2,                  &
579               &               zglam1, zglam2, zgphi1, zgphi2,          &
580               &               nn_1dint, nn_2dint,                      &
581               &               kdailyavtypes = nn_profdavtypes )
582
583         END DO
584
585      ENDIF
586
587      IF ( nsurftypes > 0 ) THEN
588
589         DO jtype = 1, nsurftypes
590
591            !Defaults which might be changed
592            zsurfmask(:,:) = tmask(:,:,1)
593
594            SELECT CASE ( TRIM(cobstypessurf(jtype)) )
595            CASE('sst')
596               zsurfvar(:,:) = ts(:,:,1,jp_tem,Kmm)
597            CASE('sla')
598               zsurfvar(:,:) = ssh(:,:,Kmm)
599            CASE('sss')
600               zsurfvar(:,:) = ts(:,:,1,jp_sal,Kmm)
601            CASE('sic')
602               IF ( kstp == 0 ) THEN
603                  IF ( lwp .AND. surfdataqc(jtype)%nsstpmpp(1) > 0 ) THEN
604                     CALL ctl_warn( 'Sea-ice not initialised on zeroth '// &
605                        &           'time-step but some obs are valid then.' )
606                     WRITE(numout,*)surfdataqc(jtype)%nsstpmpp(1), &
607                        &           ' sea-ice obs will be missed'
608                  ENDIF
609                  surfdataqc(jtype)%nsurfup = surfdataqc(jtype)%nsurfup + &
610                     &                        surfdataqc(jtype)%nsstp(1)
611                  CYCLE
612               ELSE
613#if defined key_cice || defined key_si3
614                  zsurfvar(:,:) = fr_i(:,:)
615#else
616                  CALL ctl_stop( ' Trying to run sea-ice observation operator', &
617                     &           ' but no sea-ice model appears to have been defined' )
618#endif
619               ENDIF
620
621            END SELECT
622
623            CALL obs_surf_opt( surfdataqc(jtype), kstp, jpi, jpj,       &
624               &               nit000, idaystp, zsurfvar, zsurfmask,    &
625               &               n2dintsurf(jtype), llnightav(jtype),     &
626               &               zavglamscl(jtype), zavgphiscl(jtype),     &
627               &               lfpindegs(jtype) )
628
629         END DO
630
631      ENDIF
632
633   END SUBROUTINE dia_obs
634
635   SUBROUTINE dia_obs_wri
636      !!----------------------------------------------------------------------
637      !!                    ***  ROUTINE dia_obs_wri  ***
638      !!         
639      !! ** Purpose : Call observation diagnostic output routines
640      !!
641      !! ** Method  : Call observation diagnostic output routines
642      !!
643      !! ** Action  :
644      !!
645      !! History :
646      !!        !  06-03  (K. Mogensen) Original code
647      !!        !  06-05  (K. Mogensen) Reformatted
648      !!        !  06-10  (A. Weaver) Cleaning
649      !!        !  07-03  (K. Mogensen) General handling of profiles
650      !!        !  08-09  (M. Valdivieso) Velocity component (U,V) profiles
651      !!        !  15-08  (M. Martin) Combined writing for prof and surf types
652      !!----------------------------------------------------------------------
653      !! * Modules used
654      USE obs_rot_vel          ! Rotation of velocities
655
656      IMPLICIT NONE
657
658      !! * Local declarations
659      INTEGER :: jtype                    ! Data set loop variable
660      INTEGER :: jo, jvar, jk
661      REAL(wp), DIMENSION(:), ALLOCATABLE :: &
662         & zu, &
663         & zv
664
665      !-----------------------------------------------------------------------
666      ! Depending on switches call various observation output routines
667      !-----------------------------------------------------------------------
668
669      IF ( nproftypes > 0 ) THEN
670
671         DO jtype = 1, nproftypes
672
673            IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN
674
675               ! For velocity data, rotate the model velocities to N/S, E/W
676               ! using the compressed data structure.
677               ALLOCATE( &
678                  & zu(profdataqc(jtype)%nvprot(1)), &
679                  & zv(profdataqc(jtype)%nvprot(2))  &
680                  & )
681
682               CALL obs_rotvel( profdataqc(jtype), nn_2dint, zu, zv )
683
684               DO jo = 1, profdataqc(jtype)%nprof
685                  DO jvar = 1, 2
686                     DO jk = profdataqc(jtype)%npvsta(jo,jvar), profdataqc(jtype)%npvend(jo,jvar)
687
688                        IF ( jvar == 1 ) THEN
689                           profdataqc(jtype)%var(jvar)%vmod(jk) = zu(jk)
690                        ELSE
691                           profdataqc(jtype)%var(jvar)%vmod(jk) = zv(jk)
692                        ENDIF
693
694                     END DO
695                  END DO
696               END DO
697
698               DEALLOCATE( zu )
699               DEALLOCATE( zv )
700
701            END IF
702
703            CALL obs_prof_decompress( profdataqc(jtype), &
704               &                      profdata(jtype), .TRUE., numout )
705
706            CALL obs_wri_prof( profdata(jtype) )
707
708         END DO
709
710      ENDIF
711
712      IF ( nsurftypes > 0 ) THEN
713
714         DO jtype = 1, nsurftypes
715
716            CALL obs_surf_decompress( surfdataqc(jtype), &
717               &                      surfdata(jtype), .TRUE., numout )
718
719            CALL obs_wri_surf( surfdata(jtype) )
720
721         END DO
722
723      ENDIF
724
725   END SUBROUTINE dia_obs_wri
726
727   SUBROUTINE dia_obs_dealloc
728      IMPLICIT NONE
729      !!----------------------------------------------------------------------
730      !!                    *** ROUTINE dia_obs_dealloc ***
731      !!
732      !!  ** Purpose : To deallocate data to enable the obs_oper online loop.
733      !!               Specifically: dia_obs_init --> dia_obs --> dia_obs_wri
734      !!
735      !!  ** Method : Clean up various arrays left behind by the obs_oper.
736      !!
737      !!  ** Action :
738      !!
739      !!----------------------------------------------------------------------
740      ! obs_grid deallocation
741      CALL obs_grid_deallocate
742
743      ! diaobs deallocation
744      IF ( nproftypes > 0 ) &
745         &   DEALLOCATE( cobstypesprof, profdata, profdataqc, nvarsprof, nextrprof )
746
747      IF ( nsurftypes > 0 ) &
748         &   DEALLOCATE( cobstypessurf, surfdata, surfdataqc, nvarssurf, nextrsurf, &
749         &               n2dintsurf, zavglamscl, zavgphiscl, lfpindegs, llnightav )
750
751   END SUBROUTINE dia_obs_dealloc
752
753   SUBROUTINE calc_date( kstp, ddobs )
754      !!----------------------------------------------------------------------
755      !!                    ***  ROUTINE calc_date  ***
756      !!         
757      !! ** Purpose : Get date in double precision YYYYMMDD.HHMMSS format
758      !!
759      !! ** Method  : Get date in double precision YYYYMMDD.HHMMSS format
760      !!
761      !! ** Action  : Get date in double precision YYYYMMDD.HHMMSS format
762      !!
763      !! ** Action  : Get initial date in double precision YYYYMMDD.HHMMSS format
764      !!
765      !! History :
766      !!        !  06-03  (K. Mogensen)  Original code
767      !!        !  06-05  (K. Mogensen)  Reformatted
768      !!        !  06-10  (A. Weaver) Cleaning
769      !!        !  06-10  (G. Smith) Calculates initial date the same as method for final date
770      !!        !  10-05  (D. Lea) Update to month length calculation for NEMO vn3.2
771      !!        !  2014-09  (D. Lea) New generic routine now deals with arbitrary initial time of day
772      !!----------------------------------------------------------------------
773      USE phycst, ONLY : &            ! Physical constants
774         & rday
775      USE dom_oce, ONLY : &           ! Ocean space and time domain variables
776         & rn_Dt
777
778      IMPLICIT NONE
779
780      !! * Arguments
781      REAL(KIND=dp), INTENT(OUT) :: ddobs                        ! Date in YYYYMMDD.HHMMSS
782      INTEGER :: kstp
783
784      !! * Local declarations
785      INTEGER :: iyea        ! date - (year, month, day, hour, minute)
786      INTEGER :: imon
787      INTEGER :: iday
788      INTEGER :: ihou
789      INTEGER :: imin
790      INTEGER :: imday       ! Number of days in month.
791      REAL(wp) :: zdayfrc    ! Fraction of day
792
793      INTEGER, DIMENSION(12) ::   imonth_len    !: length in days of the months of the current year
794
795      !!----------------------------------------------------------------------
796      !! Initial date initialization (year, month, day, hour, minute)
797      !!----------------------------------------------------------------------
798      iyea =   ndate0 / 10000
799      imon = ( ndate0 - iyea * 10000 ) / 100
800      iday =   ndate0 - iyea * 10000 - imon * 100
801      ihou =   nn_time0 / 100
802      imin = ( nn_time0 - ihou * 100 ) 
803
804      !!----------------------------------------------------------------------
805      !! Compute number of days + number of hours + min since initial time
806      !!----------------------------------------------------------------------
807      zdayfrc = kstp * rn_Dt / rday
808      zdayfrc = zdayfrc - aint(zdayfrc)
809      imin = imin + int( zdayfrc * 24 * 60 ) 
810      DO WHILE (imin >= 60) 
811        imin=imin-60
812        ihou=ihou+1
813      END DO
814      DO WHILE (ihou >= 24)
815        ihou=ihou-24
816        iday=iday+1
817      END DO
818      iday = iday + kstp * rn_Dt / rday 
819
820      !-----------------------------------------------------------------------
821      ! Convert number of days (iday) into a real date
822      !----------------------------------------------------------------------
823
824      CALL calc_month_len( iyea, imonth_len )
825
826      DO WHILE ( iday > imonth_len(imon) )
827         iday = iday - imonth_len(imon)
828         imon = imon + 1 
829         IF ( imon > 12 ) THEN
830            imon = 1
831            iyea = iyea + 1
832            CALL calc_month_len( iyea, imonth_len )  ! update month lengths
833         ENDIF
834      END DO
835
836      !----------------------------------------------------------------------
837      ! Convert it into YYYYMMDD.HHMMSS format.
838      !----------------------------------------------------------------------
839      ddobs = iyea * 10000_dp + imon * 100_dp + &
840         &    iday + ihou * 0.01_dp + imin * 0.0001_dp
841
842   END SUBROUTINE calc_date
843
844   SUBROUTINE ini_date( ddobsini )
845      !!----------------------------------------------------------------------
846      !!                    ***  ROUTINE ini_date  ***
847      !!         
848      !! ** Purpose : Get initial date in double precision YYYYMMDD.HHMMSS format
849      !!
850      !! ** Method  :
851      !!
852      !! ** Action  :
853      !!
854      !! History :
855      !!        !  06-03  (K. Mogensen)  Original code
856      !!        !  06-05  (K. Mogensen)  Reformatted
857      !!        !  06-10  (A. Weaver) Cleaning
858      !!        !  10-05  (D. Lea) Update to month length calculation for NEMO vn3.2
859      !!        !  2014-09  (D. Lea) Change to call generic routine calc_date
860      !!----------------------------------------------------------------------
861
862      IMPLICIT NONE
863
864      !! * Arguments
865      REAL(KIND=dp), INTENT(OUT) :: ddobsini                   ! Initial date in YYYYMMDD.HHMMSS
866
867      CALL calc_date( nit000 - 1, ddobsini )
868
869   END SUBROUTINE ini_date
870
871   SUBROUTINE fin_date( ddobsfin )
872      !!----------------------------------------------------------------------
873      !!                    ***  ROUTINE fin_date  ***
874      !!         
875      !! ** Purpose : Get final date in double precision YYYYMMDD.HHMMSS format
876      !!
877      !! ** Method  :
878      !!
879      !! ** Action  :
880      !!
881      !! History :
882      !!        !  06-03  (K. Mogensen)  Original code
883      !!        !  06-05  (K. Mogensen)  Reformatted
884      !!        !  06-10  (A. Weaver) Cleaning
885      !!        !  10-05  (D. Lea) Update to month length calculation for NEMO vn3.2
886      !!        !  2014-09  (D. Lea) Change to call generic routine calc_date
887      !!----------------------------------------------------------------------
888
889      IMPLICIT NONE
890
891      !! * Arguments
892      REAL(dp), INTENT(OUT) :: ddobsfin ! Final date in YYYYMMDD.HHMMSS
893
894      CALL calc_date( nitend, ddobsfin )
895
896   END SUBROUTINE fin_date
897   
898    SUBROUTINE obs_settypefiles( ntypes, jpmaxnfiles, jtype, ctypein, &
899       &                         cfilestype, ifiles, cobstypes, cfiles )
900
901    INTEGER, INTENT(IN) :: ntypes      ! Total number of obs types
902    INTEGER, INTENT(IN) :: jpmaxnfiles ! Maximum number of files allowed for each type
903    INTEGER, INTENT(IN) :: jtype       ! Index of the current type of obs
904    INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: &
905       &                   ifiles      ! Out appended number of files for this type
906
907    CHARACTER(len=6), INTENT(IN) :: ctypein 
908    CHARACTER(len=128), DIMENSION(jpmaxnfiles), INTENT(IN) :: &
909       &                   cfilestype  ! In list of files for this obs type
910    CHARACTER(len=6), DIMENSION(ntypes), INTENT(INOUT) :: &
911       &                   cobstypes   ! Out appended list of obs types
912    CHARACTER(len=128), DIMENSION(ntypes, jpmaxnfiles), INTENT(INOUT) :: &
913       &                   cfiles      ! Out appended list of files for all types
914
915    !Local variables
916    INTEGER :: jfile
917
918    cfiles(jtype,:) = cfilestype(:)
919    cobstypes(jtype) = ctypein
920    ifiles(jtype) = 0
921    DO jfile = 1, jpmaxnfiles
922       IF ( trim(cfiles(jtype,jfile)) /= '' ) &
923                 ifiles(jtype) = ifiles(jtype) + 1
924    END DO
925
926    IF ( ifiles(jtype) == 0 ) THEN
927         CALL ctl_stop( 'Logical for observation type '//TRIM(ctypein)//   &
928            &           ' set to true but no files available to read' )
929    ENDIF
930
931    IF(lwp) THEN   
932       WRITE(numout,*) '             '//cobstypes(jtype)//' input observation file names:'
933       DO jfile = 1, ifiles(jtype)
934          WRITE(numout,*) '                '//TRIM(cfiles(jtype,jfile))
935       END DO
936    ENDIF
937
938    END SUBROUTINE obs_settypefiles
939
940    SUBROUTINE obs_setinterpopts( ntypes, jtype, ctypein,             &
941               &                  n2dint_default, n2dint_type,        &
942               &                  zavglamscl_type, zavgphiscl_type,   &
943               &                  lfp_indegs_type, lavnight_type,     &
944               &                  n2dint, zavglamscl, zavgphiscl,     &
945               &                  lfpindegs, lavnight )
946
947    INTEGER, INTENT(IN)  :: ntypes             ! Total number of obs types
948    INTEGER, INTENT(IN)  :: jtype              ! Index of the current type of obs
949    INTEGER, INTENT(IN)  :: n2dint_default     ! Default option for interpolation type
950    INTEGER, INTENT(IN)  :: n2dint_type        ! Option for interpolation type
951    REAL(wp), INTENT(IN) :: &
952       &                    zavglamscl_type, & !E/W diameter of obs footprint for this type
953       &                    zavgphiscl_type    !N/S diameter of obs footprint for this type
954    LOGICAL, INTENT(IN)  :: lfp_indegs_type    !T=> footprint in degrees, F=> in metres
955    LOGICAL, INTENT(IN)  :: lavnight_type      !T=> obs represent night time average
956    CHARACTER(len=6), INTENT(IN) :: ctypein 
957
958    INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: &
959       &                    n2dint 
960    REAL(wp), DIMENSION(ntypes), INTENT(INOUT) :: &
961       &                    zavglamscl, zavgphiscl
962    LOGICAL, DIMENSION(ntypes), INTENT(INOUT) :: &
963       &                    lfpindegs, lavnight
964
965    lavnight(jtype) = lavnight_type
966
967    IF ( (n2dint_type >= 1) .AND. (n2dint_type <= 6) ) THEN
968       n2dint(jtype) = n2dint_type
969    ELSE
970       n2dint(jtype) = n2dint_default
971    ENDIF
972
973    ! For averaging observation footprints set options for size of footprint
974    IF ( (n2dint(jtype) > 4) .AND. (n2dint(jtype) <= 6) ) THEN
975       IF ( zavglamscl_type > 0._wp ) THEN
976          zavglamscl(jtype) = zavglamscl_type
977       ELSE
978          CALL ctl_stop( 'Incorrect value set for averaging footprint '// &
979                         'scale (zavglamscl) for observation type '//TRIM(ctypein) )     
980       ENDIF
981
982       IF ( zavgphiscl_type > 0._wp ) THEN
983          zavgphiscl(jtype) = zavgphiscl_type
984       ELSE
985          CALL ctl_stop( 'Incorrect value set for averaging footprint '// &
986                         'scale (zavgphiscl) for observation type '//TRIM(ctypein) )     
987       ENDIF
988
989       lfpindegs(jtype) = lfp_indegs_type 
990
991    ENDIF
992
993    ! Write out info
994    IF(lwp) THEN
995       IF ( n2dint(jtype) <= 4 ) THEN
996          WRITE(numout,*) '             '//TRIM(ctypein)// &
997             &            ' model counterparts will be interpolated horizontally'
998       ELSE IF ( n2dint(jtype) <= 6 ) THEN
999          WRITE(numout,*) '             '//TRIM(ctypein)// &
1000             &            ' model counterparts will be averaged horizontally'
1001          WRITE(numout,*) '             '//'    with E/W scale: ',zavglamscl(jtype)
1002          WRITE(numout,*) '             '//'    with N/S scale: ',zavgphiscl(jtype)
1003          IF ( lfpindegs(jtype) ) THEN
1004              WRITE(numout,*) '             '//'    (in degrees)'
1005          ELSE
1006              WRITE(numout,*) '             '//'    (in metres)'
1007          ENDIF
1008       ENDIF
1009    ENDIF
1010
1011    END SUBROUTINE obs_setinterpopts
1012
1013END MODULE diaobs
Note: See TracBrowser for help on using the repository browser.