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 branches/2017/dev_merge_2017/NEMOGCM/NEMO/OPA_SRC/OBS – NEMO

source: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OPA_SRC/OBS/diaobs.F90 @ 9040

Last change on this file since 9040 was 9040, checked in by timgraham, 7 years ago

Fix in diaobs

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