source: branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/NEMO/OPA_SRC/OBS/obs_readsnowdepth.F90 @ 10276

Last change on this file since 10276 was 10276, checked in by emmafiedler, 3 years ago

Freeboard assimilation updates

File size: 5.7 KB
Line 
1MODULE obs_readsnowdepth
2   !!======================================================================
3   !!                       ***  MODULE obs_readsnowdepth  ***
4   !! Observation diagnostics: Get the snow depth for freeboard conversion to thickness
5   !!======================================================================
6   !! History :      ! 2018-10 (E. Fiedler) Initial version
7   !!----------------------------------------------------------------------
8
9   !!----------------------------------------------------------------------
10   !!   obs_rea_snowdepth    : Driver for reading MDT
11   !!----------------------------------------------------------------------
12   USE wrk_nemo         ! Memory Allocation
13   USE par_kind         ! Precision variables
14   USE par_oce          ! Domain parameters
15   USE in_out_manager   ! I/O manager
16   USE obs_surf_def     ! Surface observation definitions
17   USE obs_inter_sup    ! Interpolation support routines
18   USE obs_inter_h2d    ! 2D interpolation
19   USE obs_utils        ! Various observation tools
20   USE iom_nf90         ! IOM NetCDF
21   USE netcdf           ! NetCDF library
22   USE lib_mpp          ! MPP library
23   USE dom_oce, ONLY : &                  ! Domain variables
24      &                    tmask, tmask_i, e1t, e2t, gphit, glamt
25   USE obs_const, ONLY :   obfillflt      ! Fillvalue
26   USE oce      , ONLY :   sshn           ! Model variables
27
28
29
30   IMPLICIT NONE
31   PRIVATE
32   
33   PUBLIC   obs_rea_snowdepth     ! called by dia_obs
34
35   !!----------------------------------------------------------------------
36   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
37   !! $Id$
38   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
39   !!----------------------------------------------------------------------
40CONTAINS
41
42   SUBROUTINE obs_rea_snowdepth( fbddata, k2dint, thick_s )
43      !!---------------------------------------------------------------------
44      !!
45      !!                   *** ROUTINE obs_rea_snowdepth ***
46      !!
47      !! ** Purpose : Get snowdepth from CICE
48      !!
49      !! ** Method  :
50      !!
51      !! ** Action  :
52      !!----------------------------------------------------------------------
53      USE iom
54      !
55      TYPE(obs_surf), INTENT(inout)  ::   fbddata   ! Sea ice freeboard data
56      INTEGER       , INTENT(in)     ::   k2dint    ! ?
57      REAL(wp), INTENT(IN), DIMENSION(jpi,jpj) :: thick_s ! Model snow depth
58     
59      CHARACTER(LEN=12), PARAMETER ::   cpname  = 'obs_rea_snowdepth'
60
61      INTEGER ::   jobs                ! Obs loop variable
62      INTEGER ::   jpi_thick_s, jpj_thick_s      ! Number of grid point in lat/lon for the snow depth
63      INTEGER ::   iico, ijco          ! Grid point indices
64
65      !
66      REAL(wp), DIMENSION(1)     ::   zext, zobsmask
67      REAL(wp), DIMENSION(2,2,1) ::   zweig
68      !
69      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   zmask, z_thick_s_l, zglam, zgphi
70      INTEGER , DIMENSION(:,:,:), ALLOCATABLE ::   igrdi, igrdj
71      !
72      REAL(wp), POINTER, DIMENSION(:,:) ::  z_thick_s, thick_s_mask
73         
74      REAL(wp) :: zlam, zphi, zfill, zinfill    ! local scalar
75      !!----------------------------------------------------------------------
76
77      CALL wrk_alloc(jpi,jpj,z_thick_s,thick_s_mask) 
78
79      IF(lwp)WRITE(numout,*) 
80      IF(lwp)WRITE(numout,*) ' obs_rea_snowdepth : Get model snow depth for freeboard conversion to sea ice thickness'
81      IF(lwp)WRITE(numout,*) ' ------------- '
82      CALL FLUSH(numout)
83
84      ! Get ice thickness information
85      z_thick_s = thick_s
86
87      ! Setup mask based on tmask
88      thick_s_mask(:,:) = tmask(:,:,1)
89
90      ! Interpolate the snow depth already on the model grid at the observation point
91 
92      ALLOCATE( &
93         & igrdi(2,2,fbddata%nsurf), &
94         & igrdj(2,2,fbddata%nsurf), &
95         & zglam(2,2,fbddata%nsurf), &
96         & zgphi(2,2,fbddata%nsurf), &
97         & zmask(2,2,fbddata%nsurf), &
98         & z_thick_s_l(2,2,fbddata%nsurf)  &
99         & )
100         
101      DO jobs = 1, fbddata%nsurf
102
103         igrdi(1,1,jobs) = fbddata%mi(jobs)-1
104         igrdj(1,1,jobs) = fbddata%mj(jobs)-1
105         igrdi(1,2,jobs) = fbddata%mi(jobs)-1
106         igrdj(1,2,jobs) = fbddata%mj(jobs)
107         igrdi(2,1,jobs) = fbddata%mi(jobs)
108         igrdj(2,1,jobs) = fbddata%mj(jobs)-1
109         igrdi(2,2,jobs) = fbddata%mi(jobs)
110         igrdj(2,2,jobs) = fbddata%mj(jobs)
111
112      END DO
113
114      CALL obs_int_comm_2d( 2, 2, fbddata%nsurf, jpi, jpj, igrdi, igrdj, glamt  , zglam )
115      CALL obs_int_comm_2d( 2, 2, fbddata%nsurf, jpi, jpj, igrdi, igrdj, gphit  , zgphi )
116      CALL obs_int_comm_2d( 2, 2, fbddata%nsurf, jpi, jpj, igrdi, igrdj, thick_s_mask, zmask )
117      CALL obs_int_comm_2d( 2, 2, fbddata%nsurf, jpi, jpj, igrdi, igrdj, z_thick_s  , z_thick_s_l )
118
119      DO jobs = 1, fbddata%nsurf
120           
121         zlam = fbddata%rlam(jobs)
122         zphi = fbddata%rphi(jobs)
123
124         CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,         &
125            &                   zglam(:,:,jobs), zgphi(:,:,jobs), &
126            &                   zmask(:,:,jobs), zweig, zobsmask )
127           
128         CALL obs_int_h2d( 1, 1, zweig, z_thick_s_l(:,:,jobs),  zext )
129 
130         fbddata%rext(jobs,2) = zext(1)
131
132! mark any masked data with a QC flag
133         IF( zobsmask(1) == 0 )   fbddata%nqc(jobs) = IBSET(fbddata%nqc(jobs),15)
134
135         END DO
136         
137      DEALLOCATE( &
138         & igrdi, &
139         & igrdj, &
140         & zglam, &
141         & zgphi, &
142         & zmask, &
143         & z_thick_s_l  &
144         & )
145
146      CALL wrk_dealloc(jpi,jpj,z_thick_s,thick_s_mask) 
147      IF(lwp)WRITE(numout,*) ' ------------- '
148      !
149   END SUBROUTINE obs_rea_snowdepth
150   
151   !!======================================================================
152END MODULE obs_readsnowdepth
Note: See TracBrowser for help on using the repository browser.