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/2019/dev_r11943_MERGE_2019/src/OCE/OBS – NEMO

source: NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/OBS/diaobs.F90 @ 11949

Last change on this file since 11949 was 11949, checked in by acc, 4 years ago

Merge in changes from 2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps. This just creates a fresh copy of this branch to use as the merge base. See ticket #2341
  • Property svn:keywords set to Id
File size: 46.5 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      REWIND( numnam_ref )   ! Namelist namobs in reference namelist
205      READ  ( numnam_ref, namobs, IOSTAT = ios, ERR = 901)
206901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namobs in reference namelist' )
207      REWIND( numnam_cfg )   ! Namelist namobs in configuration namelist
208      READ  ( numnam_cfg, namobs, IOSTAT = ios, ERR = 902 )
209902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namobs in configuration namelist' )
210      IF(lwm) WRITE ( numond, namobs )
211
212      IF( .NOT.ln_diaobs ) THEN
213         IF(lwp) WRITE(numout,*)
214         IF(lwp) WRITE(numout,*) 'dia_obs_init : NO Observation diagnostic used'
215         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~'
216         RETURN
217      ENDIF
218
219      IF(lwp) THEN
220         WRITE(numout,*)
221         WRITE(numout,*) 'dia_obs_init : Observation diagnostic initialization'
222         WRITE(numout,*) '~~~~~~~~~~~~'
223         WRITE(numout,*) '   Namelist namobs : set observation diagnostic parameters' 
224         WRITE(numout,*) '      Logical switch for T profile observations                ln_t3d = ', ln_t3d
225         WRITE(numout,*) '      Logical switch for S profile observations                ln_s3d = ', ln_s3d
226         WRITE(numout,*) '      Logical switch for SLA observations                      ln_sla = ', ln_sla
227         WRITE(numout,*) '      Logical switch for SST observations                      ln_sst = ', ln_sst
228         WRITE(numout,*) '      Logical switch for Sea Ice observations                  ln_sic = ', ln_sic
229         WRITE(numout,*) '      Logical switch for velocity observations               ln_vel3d = ', ln_vel3d
230         WRITE(numout,*) '      Logical switch for SSS observations                      ln_sss = ', ln_sss
231         WRITE(numout,*) '      Global distribution of observations              ln_grid_global = ', ln_grid_global
232         WRITE(numout,*) '      Logical switch for obs grid search lookup ln_grid_search_lookup = ', ln_grid_search_lookup
233         IF (ln_grid_search_lookup) &
234            WRITE(numout,*) '      Grid search lookup file header                cn_gridsearchfile = ', cn_gridsearchfile
235         WRITE(numout,*) '      Initial date in window YYYYMMDD.HHMMSS               rn_dobsini = ', rn_dobsini
236         WRITE(numout,*) '      Final date in window YYYYMMDD.HHMMSS                 rn_dobsend = ', rn_dobsend
237         WRITE(numout,*) '      Type of vertical interpolation method                  nn_1dint = ', nn_1dint
238         WRITE(numout,*) '      Type of horizontal interpolation method                nn_2dint = ', nn_2dint
239         WRITE(numout,*) '      Rejection of observations near land switch               ln_nea = ', ln_nea
240         WRITE(numout,*) '      Rejection of obs near open bdys                 ln_bound_reject = ', ln_bound_reject
241         WRITE(numout,*) '      MSSH correction scheme                                 nn_msshc = ', nn_msshc
242         WRITE(numout,*) '      MDT  correction                                      rn_mdtcorr = ', rn_mdtcorr
243         WRITE(numout,*) '      MDT cutoff for computed correction                 rn_mdtcutoff = ', rn_mdtcutoff
244         WRITE(numout,*) '      Logical switch for alt bias                          ln_altbias = ', ln_altbias
245         WRITE(numout,*) '      Logical switch for sst bias                          ln_sstbias = ', ln_sstbias
246         WRITE(numout,*) '      Logical switch for ignoring missing files             ln_ignmis = ', ln_ignmis
247         WRITE(numout,*) '      Daily average types                             nn_profdavtypes = ', nn_profdavtypes
248         WRITE(numout,*) '      Logical switch for night-time SST obs               ln_sstnight = ', ln_sstnight
249      ENDIF
250      !-----------------------------------------------------------------------
251      ! Set up list of observation types to be used
252      ! and the files associated with each type
253      !-----------------------------------------------------------------------
254
255      nproftypes = COUNT( (/ln_t3d .OR. ln_s3d, ln_vel3d /) )
256      nsurftypes = COUNT( (/ln_sla, ln_sst, ln_sic, ln_sss /) )
257
258      IF( ln_sstbias ) THEN
259         lmask(:) = .FALSE. 
260         WHERE( cn_sstbiasfiles(:) /= '' )   lmask(:) = .TRUE. 
261         jnumsstbias = COUNT(lmask) 
262         lmask(:) = .FALSE. 
263      ENDIF     
264
265      IF( nproftypes == 0 .AND. nsurftypes == 0 ) THEN
266         CALL ctl_warn( 'dia_obs_init: ln_diaobs is set to true, but all obs operator logical flags',   &
267            &           ' (ln_t3d, ln_s3d, ln_sla, ln_sst, ln_sic, ln_vel3d)',                          &
268            &           ' are set to .FALSE. so turning off calls to dia_obs'  )
269         ln_diaobs = .FALSE.
270         RETURN
271      ENDIF
272
273      IF( nproftypes > 0 ) THEN
274         !
275         ALLOCATE( cobstypesprof(nproftypes)             )
276         ALLOCATE( ifilesprof   (nproftypes)             )
277         ALLOCATE( clproffiles  (nproftypes,jpmaxnfiles) )
278         !
279         jtype = 0
280         IF( ln_t3d .OR. ln_s3d ) THEN
281            jtype = jtype + 1
282            CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'prof  ', &
283               &                   cn_profbfiles, ifilesprof, cobstypesprof, clproffiles )
284         ENDIF
285         IF( ln_vel3d ) THEN
286            jtype = jtype + 1
287            CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'vel   ', &
288               &                   cn_velfbfiles, ifilesprof, cobstypesprof, clproffiles )
289         ENDIF
290         !
291      ENDIF
292
293      IF( nsurftypes > 0 ) THEN
294         !
295         ALLOCATE( cobstypessurf(nsurftypes)             )
296         ALLOCATE( ifilessurf   (nsurftypes)             )
297         ALLOCATE( clsurffiles  (nsurftypes,jpmaxnfiles) )
298         ALLOCATE( n2dintsurf   (nsurftypes)             )
299         ALLOCATE( zavglamscl   (nsurftypes)             )
300         ALLOCATE( zavgphiscl   (nsurftypes)             )
301         ALLOCATE( lfpindegs    (nsurftypes)             )
302         ALLOCATE( llnightav    (nsurftypes)             )
303         !
304         jtype = 0
305         IF( ln_sla ) THEN
306            jtype = jtype + 1
307            CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sla   ', &
308               &                   cn_slafbfiles, ifilessurf, cobstypessurf, clsurffiles )
309            CALL obs_setinterpopts( nsurftypes, jtype, 'sla   ',      &
310               &                  nn_2dint, nn_2dint_sla,             &
311               &                  rn_sla_avglamscl, rn_sla_avgphiscl, &
312               &                  ln_sla_fp_indegs, .FALSE.,          &
313               &                  n2dintsurf, zavglamscl, zavgphiscl, &
314               &                  lfpindegs, llnightav )
315         ENDIF
316         IF( ln_sst ) THEN
317            jtype = jtype + 1
318            CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sst   ', &
319               &                   cn_sstfbfiles, ifilessurf, cobstypessurf, clsurffiles )
320            CALL obs_setinterpopts( nsurftypes, jtype, 'sst   ',      &
321               &                  nn_2dint, nn_2dint_sst,             &
322               &                  rn_sst_avglamscl, rn_sst_avgphiscl, &
323               &                  ln_sst_fp_indegs, ln_sstnight,      &
324               &                  n2dintsurf, zavglamscl, zavgphiscl, &
325               &                  lfpindegs, llnightav )
326         ENDIF
327#if defined key_si3 || defined key_cice
328         IF( ln_sic ) THEN
329            jtype = jtype + 1
330            CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sic   ', &
331               &                   cn_sicfbfiles, ifilessurf, cobstypessurf, clsurffiles )
332            CALL obs_setinterpopts( nsurftypes, jtype, 'sic   ',      &
333               &                  nn_2dint, nn_2dint_sic,             &
334               &                  rn_sic_avglamscl, rn_sic_avgphiscl, &
335               &                  ln_sic_fp_indegs, .FALSE.,          &
336               &                  n2dintsurf, zavglamscl, zavgphiscl, &
337               &                  lfpindegs, llnightav )
338         ENDIF
339#endif
340         IF( ln_sss ) THEN
341            jtype = jtype + 1
342            CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sss   ', &
343               &                   cn_sssfbfiles, ifilessurf, cobstypessurf, clsurffiles )
344            CALL obs_setinterpopts( nsurftypes, jtype, 'sss   ',      &
345               &                  nn_2dint, nn_2dint_sss,             &
346               &                  rn_sss_avglamscl, rn_sss_avgphiscl, &
347               &                  ln_sss_fp_indegs, .FALSE.,          &
348               &                  n2dintsurf, zavglamscl, zavgphiscl, &
349               &                  lfpindegs, llnightav )
350         ENDIF
351         !
352      ENDIF
353
354
355      !-----------------------------------------------------------------------
356      ! Obs operator parameter checking and initialisations
357      !-----------------------------------------------------------------------
358      !
359      IF( ln_vel3d  .AND.  .NOT.ln_grid_global ) THEN
360         CALL ctl_stop( 'Velocity data only works with ln_grid_global=.true.' )
361         RETURN
362      ENDIF
363      !
364      IF( ln_grid_global ) THEN
365         CALL ctl_warn( 'dia_obs_init: ln_grid_global=T may cause memory issues when used with a large number of processors' )
366      ENDIF
367      !
368      IF( nn_1dint < 0  .OR.  nn_1dint > 1 ) THEN
369         CALL ctl_stop('dia_obs_init: Choice of vertical (1D) interpolation method is not available')
370      ENDIF
371      !
372      IF( nn_2dint < 0  .OR.  nn_2dint > 6  ) THEN
373         CALL ctl_stop('dia_obs_init: Choice of horizontal (2D) interpolation method is not available')
374      ENDIF
375      !
376      CALL obs_typ_init
377      IF( ln_grid_global )   CALL mppmap_init
378      !
379      CALL obs_grid_setup( )
380
381      !-----------------------------------------------------------------------
382      ! Depending on switches read the various observation types
383      !-----------------------------------------------------------------------
384      !
385      IF( nproftypes > 0 ) THEN
386         !
387         ALLOCATE( profdata  (nproftypes) , nvarsprof (nproftypes) )
388         ALLOCATE( profdataqc(nproftypes) , nextrprof (nproftypes) )
389         !
390         DO jtype = 1, nproftypes
391            !
392            nvarsprof(jtype) = 2
393            IF ( TRIM(cobstypesprof(jtype)) == 'prof' ) THEN
394               nextrprof(jtype) = 1
395               llvar1 = ln_t3d
396               llvar2 = ln_s3d
397               zglam1 = glamt
398               zgphi1 = gphit
399               zmask1 = tmask
400               zglam2 = glamt
401               zgphi2 = gphit
402               zmask2 = tmask
403            ENDIF
404            IF ( TRIM(cobstypesprof(jtype)) == 'vel' )  THEN
405               nextrprof(jtype) = 2
406               llvar1 = ln_vel3d
407               llvar2 = ln_vel3d
408               zglam1 = glamu
409               zgphi1 = gphiu
410               zmask1 = umask
411               zglam2 = glamv
412               zgphi2 = gphiv
413               zmask2 = vmask
414            ENDIF
415            !
416            ! Read in profile or profile obs types
417            CALL obs_rea_prof( profdata(jtype), ifilesprof(jtype),       &
418               &               clproffiles(jtype,1:ifilesprof(jtype)), &
419               &               nvarsprof(jtype), nextrprof(jtype), nitend-nit000+2, &
420               &               rn_dobsini, rn_dobsend, llvar1, llvar2, &
421               &               ln_ignmis, ln_s_at_t, .FALSE., &
422               &               kdailyavtypes = nn_profdavtypes )
423               !
424            DO jvar = 1, nvarsprof(jtype)
425               CALL obs_prof_staend( profdata(jtype), jvar )
426            END DO
427            !
428            CALL obs_pre_prof( profdata(jtype), profdataqc(jtype), &
429               &               llvar1, llvar2, &
430               &               jpi, jpj, jpk, &
431               &               zmask1, zglam1, zgphi1, zmask2, zglam2, zgphi2,  &
432               &               ln_nea, ln_bound_reject, Kmm, &
433               &               kdailyavtypes = nn_profdavtypes )
434         END DO
435         !
436         DEALLOCATE( ifilesprof, clproffiles )
437         !
438      ENDIF
439      !
440      IF( nsurftypes > 0 ) THEN
441         !
442         ALLOCATE( surfdata  (nsurftypes) , nvarssurf(nsurftypes) )
443         ALLOCATE( surfdataqc(nsurftypes) , nextrsurf(nsurftypes) )
444         !
445         DO jtype = 1, nsurftypes
446            !
447            nvarssurf(jtype) = 1
448            nextrsurf(jtype) = 0
449            llnightav(jtype) = .FALSE.
450            IF( TRIM(cobstypessurf(jtype)) == 'sla' )   nextrsurf(jtype) = 2
451            IF( TRIM(cobstypessurf(jtype)) == 'sst' )   llnightav(jtype) = ln_sstnight
452            !
453            ! Read in surface obs types
454            CALL obs_rea_surf( surfdata(jtype), ifilessurf(jtype), &
455               &               clsurffiles(jtype,1:ifilessurf(jtype)), &
456               &               nvarssurf(jtype), nextrsurf(jtype), nitend-nit000+2, &
457               &               rn_dobsini, rn_dobsend, ln_ignmis, .FALSE., llnightav(jtype) )
458               !
459            CALL obs_pre_surf( surfdata(jtype), surfdataqc(jtype), ln_nea, ln_bound_reject )
460            !
461            IF( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN
462               CALL obs_rea_mdt( surfdataqc(jtype), n2dintsurf(jtype), Kmm )
463               IF( ln_altbias )   &
464                  & CALL obs_rea_altbias ( surfdataqc(jtype), n2dintsurf(jtype), cn_altbiasfile )
465            ENDIF
466            !
467            IF( TRIM(cobstypessurf(jtype)) == 'sst' .AND. ln_sstbias ) THEN
468               jnumsstbias = 0
469               DO jfile = 1, jpmaxnfiles
470                  IF( TRIM(cn_sstbiasfiles(jfile)) /= '' )   jnumsstbias = jnumsstbias + 1
471               END DO
472               IF( jnumsstbias == 0 )   CALL ctl_stop("ln_sstbias set but no bias files to read in")   
473               !
474               CALL obs_app_sstbias( surfdataqc(jtype), n2dintsurf(jtype)             ,   & 
475                  &                  jnumsstbias      , cn_sstbiasfiles(1:jnumsstbias) ) 
476            ENDIF
477         END DO
478         !
479         DEALLOCATE( ifilessurf, clsurffiles )
480         !
481      ENDIF
482      !
483   END SUBROUTINE dia_obs_init
484
485
486   SUBROUTINE dia_obs( kstp, Kmm )
487      !!----------------------------------------------------------------------
488      !!                    ***  ROUTINE dia_obs  ***
489      !!         
490      !! ** Purpose : Call the observation operators on each time step
491      !!
492      !! ** Method  : Call the observation operators on each time step to
493      !!              compute the model equivalent of the following data:
494      !!               - Profile data, currently T/S or U/V
495      !!               - Surface data, currently SST, SLA or sea-ice concentration.
496      !!
497      !! ** Action  :
498      !!----------------------------------------------------------------------
499      USE dom_oce, ONLY : gdept, gdept_1d     ! Ocean space domain variables (Kmm time-level only)
500      USE phycst , ONLY : rday                ! Physical constants
501      USE oce    , ONLY : ts, uu, vv, ssh     ! Ocean dynamics and tracers variables (Kmm time-level only)
502      USE phycst , ONLY : rday                ! Physical constants
503#if defined  key_si3
504      USE ice    , ONLY : at_i                ! SI3 Ice model variables
505#endif
506#if defined key_cice
507      USE sbc_oce, ONLY : fr_i     ! ice fraction
508#endif
509
510      IMPLICIT NONE
511
512      !! * Arguments
513      INTEGER, INTENT(IN) :: kstp  ! Current timestep
514      INTEGER, INTENT(in) :: Kmm   ! ocean time level indices
515      !! * Local declarations
516      INTEGER :: idaystp           ! Number of timesteps per day
517      INTEGER :: jtype             ! Data loop variable
518      INTEGER :: jvar              ! Variable number
519      INTEGER :: ji, jj            ! Loop counters
520      REAL(wp), DIMENSION(jpi,jpj,jpk) :: &
521         & zprofvar1, &            ! Model values for 1st variable in a prof ob
522         & zprofvar2               ! Model values for 2nd variable in a prof ob
523      REAL(wp), DIMENSION(jpi,jpj,jpk) :: &
524         & zprofmask1, &           ! Mask associated with zprofvar1
525         & zprofmask2              ! Mask associated with zprofvar2
526      REAL(wp), DIMENSION(jpi,jpj) :: &
527         & zsurfvar, &             ! Model values equivalent to surface ob.
528         & zsurfmask               ! Mask associated with surface variable
529      REAL(wp), DIMENSION(jpi,jpj) :: &
530         & zglam1,    &            ! Model longitudes for prof variable 1
531         & zglam2,    &            ! Model longitudes for prof variable 2
532         & zgphi1,    &            ! Model latitudes for prof variable 1
533         & zgphi2                  ! Model latitudes for prof variable 2
534
535      !-----------------------------------------------------------------------
536
537      IF(lwp) THEN
538         WRITE(numout,*)
539         WRITE(numout,*) 'dia_obs : Call the observation operators', kstp
540         WRITE(numout,*) '~~~~~~~'
541      ENDIF
542
543      idaystp = NINT( rday / rdt )
544
545      !-----------------------------------------------------------------------
546      ! Call the profile and surface observation operators
547      !-----------------------------------------------------------------------
548
549      IF ( nproftypes > 0 ) THEN
550
551         DO jtype = 1, nproftypes
552
553            SELECT CASE ( TRIM(cobstypesprof(jtype)) )
554            CASE('prof')
555               zprofvar1(:,:,:) = ts(:,:,:,jp_tem,Kmm)
556               zprofvar2(:,:,:) = ts(:,:,:,jp_sal,Kmm)
557               zprofmask1(:,:,:) = tmask(:,:,:)
558               zprofmask2(:,:,:) = tmask(:,:,:)
559               zglam1(:,:) = glamt(:,:)
560               zglam2(:,:) = glamt(:,:)
561               zgphi1(:,:) = gphit(:,:)
562               zgphi2(:,:) = gphit(:,:)
563            CASE('vel')
564               zprofvar1(:,:,:) = uu(:,:,:,Kmm)
565               zprofvar2(:,:,:) = vv(:,:,:,Kmm)
566               zprofmask1(:,:,:) = umask(:,:,:)
567               zprofmask2(:,:,:) = vmask(:,:,:)
568               zglam1(:,:) = glamu(:,:)
569               zglam2(:,:) = glamv(:,:)
570               zgphi1(:,:) = gphiu(:,:)
571               zgphi2(:,:) = gphiv(:,:)
572            CASE DEFAULT
573               CALL ctl_stop( 'Unknown profile observation type '//TRIM(cobstypesprof(jtype))//' in dia_obs' )
574            END SELECT
575
576            CALL obs_prof_opt( profdataqc(jtype), kstp, jpi, jpj, jpk,  &
577               &               nit000, idaystp,                         &
578               &               zprofvar1, zprofvar2,                    &
579               &               gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm),      & 
580               &               zprofmask1, zprofmask2,                  &
581               &               zglam1, zglam2, zgphi1, zgphi2,          &
582               &               nn_1dint, nn_2dint,                      &
583               &               kdailyavtypes = nn_profdavtypes )
584
585         END DO
586
587      ENDIF
588
589      IF ( nsurftypes > 0 ) THEN
590
591         DO jtype = 1, nsurftypes
592
593            !Defaults which might be changed
594            zsurfmask(:,:) = tmask(:,:,1)
595
596            SELECT CASE ( TRIM(cobstypessurf(jtype)) )
597            CASE('sst')
598               zsurfvar(:,:) = ts(:,:,1,jp_tem,Kmm)
599            CASE('sla')
600               zsurfvar(:,:) = ssh(:,:,Kmm)
601            CASE('sss')
602               zsurfvar(:,:) = ts(:,:,1,jp_sal,Kmm)
603            CASE('sic')
604               IF ( kstp == 0 ) THEN
605                  IF ( lwp .AND. surfdataqc(jtype)%nsstpmpp(1) > 0 ) THEN
606                     CALL ctl_warn( 'Sea-ice not initialised on zeroth '// &
607                        &           'time-step but some obs are valid then.' )
608                     WRITE(numout,*)surfdataqc(jtype)%nsstpmpp(1), &
609                        &           ' sea-ice obs will be missed'
610                  ENDIF
611                  surfdataqc(jtype)%nsurfup = surfdataqc(jtype)%nsurfup + &
612                     &                        surfdataqc(jtype)%nsstp(1)
613                  CYCLE
614               ELSE
615#if defined key_cice || defined key_si3
616                  zsurfvar(:,:) = fr_i(:,:)
617#else
618                  CALL ctl_stop( ' Trying to run sea-ice observation operator', &
619                     &           ' but no sea-ice model appears to have been defined' )
620#endif
621               ENDIF
622
623            END SELECT
624
625            CALL obs_surf_opt( surfdataqc(jtype), kstp, jpi, jpj,       &
626               &               nit000, idaystp, zsurfvar, zsurfmask,    &
627               &               n2dintsurf(jtype), llnightav(jtype),     &
628               &               zavglamscl(jtype), zavgphiscl(jtype),     &
629               &               lfpindegs(jtype) )
630
631         END DO
632
633      ENDIF
634
635   END SUBROUTINE dia_obs
636
637   SUBROUTINE dia_obs_wri
638      !!----------------------------------------------------------------------
639      !!                    ***  ROUTINE dia_obs_wri  ***
640      !!         
641      !! ** Purpose : Call observation diagnostic output routines
642      !!
643      !! ** Method  : Call observation diagnostic output routines
644      !!
645      !! ** Action  :
646      !!
647      !! History :
648      !!        !  06-03  (K. Mogensen) Original code
649      !!        !  06-05  (K. Mogensen) Reformatted
650      !!        !  06-10  (A. Weaver) Cleaning
651      !!        !  07-03  (K. Mogensen) General handling of profiles
652      !!        !  08-09  (M. Valdivieso) Velocity component (U,V) profiles
653      !!        !  15-08  (M. Martin) Combined writing for prof and surf types
654      !!----------------------------------------------------------------------
655      !! * Modules used
656      USE obs_rot_vel          ! Rotation of velocities
657
658      IMPLICIT NONE
659
660      !! * Local declarations
661      INTEGER :: jtype                    ! Data set loop variable
662      INTEGER :: jo, jvar, jk
663      REAL(wp), DIMENSION(:), ALLOCATABLE :: &
664         & zu, &
665         & zv
666
667      !-----------------------------------------------------------------------
668      ! Depending on switches call various observation output routines
669      !-----------------------------------------------------------------------
670
671      IF ( nproftypes > 0 ) THEN
672
673         DO jtype = 1, nproftypes
674
675            IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN
676
677               ! For velocity data, rotate the model velocities to N/S, E/W
678               ! using the compressed data structure.
679               ALLOCATE( &
680                  & zu(profdataqc(jtype)%nvprot(1)), &
681                  & zv(profdataqc(jtype)%nvprot(2))  &
682                  & )
683
684               CALL obs_rotvel( profdataqc(jtype), nn_2dint, zu, zv )
685
686               DO jo = 1, profdataqc(jtype)%nprof
687                  DO jvar = 1, 2
688                     DO jk = profdataqc(jtype)%npvsta(jo,jvar), profdataqc(jtype)%npvend(jo,jvar)
689
690                        IF ( jvar == 1 ) THEN
691                           profdataqc(jtype)%var(jvar)%vmod(jk) = zu(jk)
692                        ELSE
693                           profdataqc(jtype)%var(jvar)%vmod(jk) = zv(jk)
694                        ENDIF
695
696                     END DO
697                  END DO
698               END DO
699
700               DEALLOCATE( zu )
701               DEALLOCATE( zv )
702
703            END IF
704
705            CALL obs_prof_decompress( profdataqc(jtype), &
706               &                      profdata(jtype), .TRUE., numout )
707
708            CALL obs_wri_prof( profdata(jtype) )
709
710         END DO
711
712      ENDIF
713
714      IF ( nsurftypes > 0 ) THEN
715
716         DO jtype = 1, nsurftypes
717
718            CALL obs_surf_decompress( surfdataqc(jtype), &
719               &                      surfdata(jtype), .TRUE., numout )
720
721            CALL obs_wri_surf( surfdata(jtype) )
722
723         END DO
724
725      ENDIF
726
727   END SUBROUTINE dia_obs_wri
728
729   SUBROUTINE dia_obs_dealloc
730      IMPLICIT NONE
731      !!----------------------------------------------------------------------
732      !!                    *** ROUTINE dia_obs_dealloc ***
733      !!
734      !!  ** Purpose : To deallocate data to enable the obs_oper online loop.
735      !!               Specifically: dia_obs_init --> dia_obs --> dia_obs_wri
736      !!
737      !!  ** Method : Clean up various arrays left behind by the obs_oper.
738      !!
739      !!  ** Action :
740      !!
741      !!----------------------------------------------------------------------
742      ! obs_grid deallocation
743      CALL obs_grid_deallocate
744
745      ! diaobs deallocation
746      IF ( nproftypes > 0 ) &
747         &   DEALLOCATE( cobstypesprof, profdata, profdataqc, nvarsprof, nextrprof )
748
749      IF ( nsurftypes > 0 ) &
750         &   DEALLOCATE( cobstypessurf, surfdata, surfdataqc, nvarssurf, nextrsurf, &
751         &               n2dintsurf, zavglamscl, zavgphiscl, lfpindegs, llnightav )
752
753   END SUBROUTINE dia_obs_dealloc
754
755   SUBROUTINE calc_date( kstp, ddobs )
756      !!----------------------------------------------------------------------
757      !!                    ***  ROUTINE calc_date  ***
758      !!         
759      !! ** Purpose : Get date in double precision YYYYMMDD.HHMMSS format
760      !!
761      !! ** Method  : Get date in double precision YYYYMMDD.HHMMSS format
762      !!
763      !! ** Action  : Get date in double precision YYYYMMDD.HHMMSS format
764      !!
765      !! ** Action  : Get initial date in double precision YYYYMMDD.HHMMSS format
766      !!
767      !! History :
768      !!        !  06-03  (K. Mogensen)  Original code
769      !!        !  06-05  (K. Mogensen)  Reformatted
770      !!        !  06-10  (A. Weaver) Cleaning
771      !!        !  06-10  (G. Smith) Calculates initial date the same as method for final date
772      !!        !  10-05  (D. Lea) Update to month length calculation for NEMO vn3.2
773      !!        !  2014-09  (D. Lea) New generic routine now deals with arbitrary initial time of day
774      !!----------------------------------------------------------------------
775      USE phycst, ONLY : &            ! Physical constants
776         & rday
777      USE dom_oce, ONLY : &           ! Ocean space and time domain variables
778         & rdt
779
780      IMPLICIT NONE
781
782      !! * Arguments
783      REAL(KIND=dp), INTENT(OUT) :: ddobs                        ! Date in YYYYMMDD.HHMMSS
784      INTEGER :: kstp
785
786      !! * Local declarations
787      INTEGER :: iyea        ! date - (year, month, day, hour, minute)
788      INTEGER :: imon
789      INTEGER :: iday
790      INTEGER :: ihou
791      INTEGER :: imin
792      INTEGER :: imday       ! Number of days in month.
793      REAL(wp) :: zdayfrc    ! Fraction of day
794
795      INTEGER, DIMENSION(12) ::   imonth_len    !: length in days of the months of the current year
796
797      !!----------------------------------------------------------------------
798      !! Initial date initialization (year, month, day, hour, minute)
799      !!----------------------------------------------------------------------
800      iyea =   ndate0 / 10000
801      imon = ( ndate0 - iyea * 10000 ) / 100
802      iday =   ndate0 - iyea * 10000 - imon * 100
803      ihou =   nn_time0 / 100
804      imin = ( nn_time0 - ihou * 100 ) 
805
806      !!----------------------------------------------------------------------
807      !! Compute number of days + number of hours + min since initial time
808      !!----------------------------------------------------------------------
809      zdayfrc = kstp * rdt / rday
810      zdayfrc = zdayfrc - aint(zdayfrc)
811      imin = imin + int( zdayfrc * 24 * 60 ) 
812      DO WHILE (imin >= 60) 
813        imin=imin-60
814        ihou=ihou+1
815      END DO
816      DO WHILE (ihou >= 24)
817        ihou=ihou-24
818        iday=iday+1
819      END DO
820      iday = iday + kstp * rdt / rday 
821
822      !-----------------------------------------------------------------------
823      ! Convert number of days (iday) into a real date
824      !----------------------------------------------------------------------
825
826      CALL calc_month_len( iyea, imonth_len )
827
828      DO WHILE ( iday > imonth_len(imon) )
829         iday = iday - imonth_len(imon)
830         imon = imon + 1 
831         IF ( imon > 12 ) THEN
832            imon = 1
833            iyea = iyea + 1
834            CALL calc_month_len( iyea, imonth_len )  ! update month lengths
835         ENDIF
836      END DO
837
838      !----------------------------------------------------------------------
839      ! Convert it into YYYYMMDD.HHMMSS format.
840      !----------------------------------------------------------------------
841      ddobs = iyea * 10000_dp + imon * 100_dp + &
842         &    iday + ihou * 0.01_dp + imin * 0.0001_dp
843
844   END SUBROUTINE calc_date
845
846   SUBROUTINE ini_date( ddobsini )
847      !!----------------------------------------------------------------------
848      !!                    ***  ROUTINE ini_date  ***
849      !!         
850      !! ** Purpose : Get initial date in double precision YYYYMMDD.HHMMSS format
851      !!
852      !! ** Method  :
853      !!
854      !! ** Action  :
855      !!
856      !! History :
857      !!        !  06-03  (K. Mogensen)  Original code
858      !!        !  06-05  (K. Mogensen)  Reformatted
859      !!        !  06-10  (A. Weaver) Cleaning
860      !!        !  10-05  (D. Lea) Update to month length calculation for NEMO vn3.2
861      !!        !  2014-09  (D. Lea) Change to call generic routine calc_date
862      !!----------------------------------------------------------------------
863
864      IMPLICIT NONE
865
866      !! * Arguments
867      REAL(KIND=dp), INTENT(OUT) :: ddobsini                   ! Initial date in YYYYMMDD.HHMMSS
868
869      CALL calc_date( nit000 - 1, ddobsini )
870
871   END SUBROUTINE ini_date
872
873   SUBROUTINE fin_date( ddobsfin )
874      !!----------------------------------------------------------------------
875      !!                    ***  ROUTINE fin_date  ***
876      !!         
877      !! ** Purpose : Get final date in double precision YYYYMMDD.HHMMSS format
878      !!
879      !! ** Method  :
880      !!
881      !! ** Action  :
882      !!
883      !! History :
884      !!        !  06-03  (K. Mogensen)  Original code
885      !!        !  06-05  (K. Mogensen)  Reformatted
886      !!        !  06-10  (A. Weaver) Cleaning
887      !!        !  10-05  (D. Lea) Update to month length calculation for NEMO vn3.2
888      !!        !  2014-09  (D. Lea) Change to call generic routine calc_date
889      !!----------------------------------------------------------------------
890
891      IMPLICIT NONE
892
893      !! * Arguments
894      REAL(dp), INTENT(OUT) :: ddobsfin ! Final date in YYYYMMDD.HHMMSS
895
896      CALL calc_date( nitend, ddobsfin )
897
898   END SUBROUTINE fin_date
899   
900    SUBROUTINE obs_settypefiles( ntypes, jpmaxnfiles, jtype, ctypein, &
901       &                         cfilestype, ifiles, cobstypes, cfiles )
902
903    INTEGER, INTENT(IN) :: ntypes      ! Total number of obs types
904    INTEGER, INTENT(IN) :: jpmaxnfiles ! Maximum number of files allowed for each type
905    INTEGER, INTENT(IN) :: jtype       ! Index of the current type of obs
906    INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: &
907       &                   ifiles      ! Out appended number of files for this type
908
909    CHARACTER(len=6), INTENT(IN) :: ctypein 
910    CHARACTER(len=128), DIMENSION(jpmaxnfiles), INTENT(IN) :: &
911       &                   cfilestype  ! In list of files for this obs type
912    CHARACTER(len=6), DIMENSION(ntypes), INTENT(INOUT) :: &
913       &                   cobstypes   ! Out appended list of obs types
914    CHARACTER(len=128), DIMENSION(ntypes, jpmaxnfiles), INTENT(INOUT) :: &
915       &                   cfiles      ! Out appended list of files for all types
916
917    !Local variables
918    INTEGER :: jfile
919
920    cfiles(jtype,:) = cfilestype(:)
921    cobstypes(jtype) = ctypein
922    ifiles(jtype) = 0
923    DO jfile = 1, jpmaxnfiles
924       IF ( trim(cfiles(jtype,jfile)) /= '' ) &
925                 ifiles(jtype) = ifiles(jtype) + 1
926    END DO
927
928    IF ( ifiles(jtype) == 0 ) THEN
929         CALL ctl_stop( 'Logical for observation type '//TRIM(ctypein)//   &
930            &           ' set to true but no files available to read' )
931    ENDIF
932
933    IF(lwp) THEN   
934       WRITE(numout,*) '             '//cobstypes(jtype)//' input observation file names:'
935       DO jfile = 1, ifiles(jtype)
936          WRITE(numout,*) '                '//TRIM(cfiles(jtype,jfile))
937       END DO
938    ENDIF
939
940    END SUBROUTINE obs_settypefiles
941
942    SUBROUTINE obs_setinterpopts( ntypes, jtype, ctypein,             &
943               &                  n2dint_default, n2dint_type,        &
944               &                  zavglamscl_type, zavgphiscl_type,   &
945               &                  lfp_indegs_type, lavnight_type,     &
946               &                  n2dint, zavglamscl, zavgphiscl,     &
947               &                  lfpindegs, lavnight )
948
949    INTEGER, INTENT(IN)  :: ntypes             ! Total number of obs types
950    INTEGER, INTENT(IN)  :: jtype              ! Index of the current type of obs
951    INTEGER, INTENT(IN)  :: n2dint_default     ! Default option for interpolation type
952    INTEGER, INTENT(IN)  :: n2dint_type        ! Option for interpolation type
953    REAL(wp), INTENT(IN) :: &
954       &                    zavglamscl_type, & !E/W diameter of obs footprint for this type
955       &                    zavgphiscl_type    !N/S diameter of obs footprint for this type
956    LOGICAL, INTENT(IN)  :: lfp_indegs_type    !T=> footprint in degrees, F=> in metres
957    LOGICAL, INTENT(IN)  :: lavnight_type      !T=> obs represent night time average
958    CHARACTER(len=6), INTENT(IN) :: ctypein 
959
960    INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: &
961       &                    n2dint 
962    REAL(wp), DIMENSION(ntypes), INTENT(INOUT) :: &
963       &                    zavglamscl, zavgphiscl
964    LOGICAL, DIMENSION(ntypes), INTENT(INOUT) :: &
965       &                    lfpindegs, lavnight
966
967    lavnight(jtype) = lavnight_type
968
969    IF ( (n2dint_type >= 1) .AND. (n2dint_type <= 6) ) THEN
970       n2dint(jtype) = n2dint_type
971    ELSE
972       n2dint(jtype) = n2dint_default
973    ENDIF
974
975    ! For averaging observation footprints set options for size of footprint
976    IF ( (n2dint(jtype) > 4) .AND. (n2dint(jtype) <= 6) ) THEN
977       IF ( zavglamscl_type > 0._wp ) THEN
978          zavglamscl(jtype) = zavglamscl_type
979       ELSE
980          CALL ctl_stop( 'Incorrect value set for averaging footprint '// &
981                         'scale (zavglamscl) for observation type '//TRIM(ctypein) )     
982       ENDIF
983
984       IF ( zavgphiscl_type > 0._wp ) THEN
985          zavgphiscl(jtype) = zavgphiscl_type
986       ELSE
987          CALL ctl_stop( 'Incorrect value set for averaging footprint '// &
988                         'scale (zavgphiscl) for observation type '//TRIM(ctypein) )     
989       ENDIF
990
991       lfpindegs(jtype) = lfp_indegs_type 
992
993    ENDIF
994
995    ! Write out info
996    IF(lwp) THEN
997       IF ( n2dint(jtype) <= 4 ) THEN
998          WRITE(numout,*) '             '//TRIM(ctypein)// &
999             &            ' model counterparts will be interpolated horizontally'
1000       ELSE IF ( n2dint(jtype) <= 6 ) THEN
1001          WRITE(numout,*) '             '//TRIM(ctypein)// &
1002             &            ' model counterparts will be averaged horizontally'
1003          WRITE(numout,*) '             '//'    with E/W scale: ',zavglamscl(jtype)
1004          WRITE(numout,*) '             '//'    with N/S scale: ',zavgphiscl(jtype)
1005          IF ( lfpindegs(jtype) ) THEN
1006              WRITE(numout,*) '             '//'    (in degrees)'
1007          ELSE
1008              WRITE(numout,*) '             '//'    (in metres)'
1009          ENDIF
1010       ENDIF
1011    ENDIF
1012
1013    END SUBROUTINE obs_setinterpopts
1014
1015END MODULE diaobs
Note: See TracBrowser for help on using the repository browser.