source: NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps_rewrite_time_filterswap/src/NST/agrif_oce_update.F90 @ 11463

Last change on this file since 11463 was 11463, checked in by acc, 14 months ago

Branch: dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps_rewrite_time_filterswap. Minor bugfix in step.F90 to enable AGRIF SETTE tests to run. Also merged prettification changes to NST routines from the dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps branch. Neither AGRIF_DEMO nor VORTEX restart perfectly (drifting after 8 and 121 timesteps, respectively).

  • Property svn:keywords set to Id
File size: 57.9 KB
Line 
1#define TWO_WAY        /* TWO WAY NESTING */
2#undef DECAL_FEEDBACK  /* SEPARATION of INTERFACES*/
3#undef VOL_REFLUX      /* VOLUME REFLUXING*/
4 
5MODULE agrif_oce_update
6   !!======================================================================
7   !!                   ***  MODULE  agrif_oce_interp  ***
8   !! AGRIF: update package for the ocean dynamics (OPA)
9   !!======================================================================
10   !! History :  2.0  !  2002-06  (L. Debreu)  Original code
11   !!            3.2  !  2009-04  (R. Benshila)
12   !!            3.6  !  2014-09  (R. Benshila)
13   !!----------------------------------------------------------------------
14#if defined key_agrif 
15   !!----------------------------------------------------------------------
16   !!   'key_agrif'                                              AGRIF zoom
17   !!----------------------------------------------------------------------
18   USE par_oce
19   USE oce
20   USE dom_oce
21   USE zdf_oce        ! vertical physics: ocean variables
22   USE agrif_oce
23   !
24   USE in_out_manager ! I/O manager
25   USE lib_mpp        ! MPP library
26   USE domvvl         ! Need interpolation routines
27
28   IMPLICIT NONE
29   PRIVATE
30
31   PUBLIC   Agrif_Update_Tra, Agrif_Update_Dyn, Agrif_Update_vvl, Agrif_Update_ssh
32   PUBLIC   Update_Scales
33
34   !!----------------------------------------------------------------------
35   !! NEMO/NST 4.0 , NEMO Consortium (2018)
36   !! $Id$
37   !! Software governed by the CeCILL license (see ./LICENSE)
38   !!----------------------------------------------------------------------
39CONTAINS
40
41   SUBROUTINE Agrif_Update_Tra( )
42      !!----------------------------------------------------------------------
43      !!                   *** ROUTINE Agrif_Update_Tra ***
44      !!----------------------------------------------------------------------
45      !
46      IF (Agrif_Root()) RETURN
47      !
48#if defined TWO_WAY 
49      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update tracers  from grid Number',Agrif_Fixed()
50
51      Agrif_UseSpecialValueInUpdate = .TRUE.
52      Agrif_SpecialValueFineGrid    = 0._wp
53      !
54# if ! defined DECAL_FEEDBACK
55      CALL Agrif_Update_Variable(tsn_id, procname=updateTS)
56! near boundary update:
57!      CALL Agrif_Update_Variable(tsn_id,locupdate=(/0,2/), procname=updateTS)
58# else
59      CALL Agrif_Update_Variable(tsn_id, locupdate=(/1,0/),procname=updateTS)
60! near boundary update:
61!      CALL Agrif_Update_Variable(tsn_id,locupdate=(/1,2/), procname=updateTS)
62# endif
63      !
64      Agrif_UseSpecialValueInUpdate = .FALSE.
65      !
66#endif
67      !
68   END SUBROUTINE Agrif_Update_Tra
69
70   SUBROUTINE Agrif_Update_Dyn( )
71      !!----------------------------------------------------------------------
72      !!                   *** ROUTINE Agrif_Update_Dyn ***
73      !!----------------------------------------------------------------------
74      !
75      IF (Agrif_Root()) RETURN
76      !
77#if defined TWO_WAY
78      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update momentum from grid Number',Agrif_Fixed()
79
80      Agrif_UseSpecialValueInUpdate = .FALSE.
81      Agrif_SpecialValueFineGrid = 0.
82      !     
83# if ! defined DECAL_FEEDBACK
84      CALL Agrif_Update_Variable(un_update_id,procname = updateU)
85      CALL Agrif_Update_Variable(vn_update_id,procname = updateV)
86! near boundary update:
87!      CALL Agrif_Update_Variable(un_update_id,locupdate=(/0,1/),procname = updateU)
88!      CALL Agrif_Update_Variable(vn_update_id,locupdate=(/0,1/),procname = updateV)
89# else
90      CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU)
91      CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV)
92! near boundary update:
93!      CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateU)
94!      CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updateV)
95# endif
96
97# if ! defined DECAL_FEEDBACK
98      CALL Agrif_Update_Variable(e1u_id,procname = updateU2d)
99      CALL Agrif_Update_Variable(e2v_id,procname = updateV2d) 
100# else
101      CALL Agrif_Update_Variable(e1u_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU2d)
102      CALL Agrif_Update_Variable(e2v_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV2d) 
103# endif
104      !
105# if ! defined DECAL_FEEDBACK
106      ! Account for updated thicknesses at boundary edges
107      IF (.NOT.ln_linssh) THEN
108!         CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,0/),locupdate2=(/0,0/),procname = correct_u_bdy)
109!         CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/0,0/),locupdate2=(/0,0/),procname = correct_v_bdy)
110      ENDIF
111# endif
112      !
113      IF ( ln_dynspg_ts .AND. ln_bt_fw ) THEN
114         ! Update time integrated transports
115#  if ! defined DECAL_FEEDBACK
116         CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b)
117         CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b)
118#  else
119         CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateub2b)
120         CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updatevb2b)
121#  endif
122      END IF
123#endif
124      !
125   END SUBROUTINE Agrif_Update_Dyn
126
127   SUBROUTINE Agrif_Update_ssh( )
128      !!---------------------------------------------
129      !!   *** ROUTINE Agrif_Update_ssh ***
130      !!---------------------------------------------
131      !
132      IF (Agrif_Root()) RETURN
133      !
134#if defined TWO_WAY
135      !
136      Agrif_UseSpecialValueInUpdate = .TRUE.
137      Agrif_SpecialValueFineGrid = 0.
138# if ! defined DECAL_FEEDBACK
139      CALL Agrif_Update_Variable(sshn_id,procname = updateSSH)
140# else
141      CALL Agrif_Update_Variable(sshn_id,locupdate=(/1,0/),procname = updateSSH)
142# endif
143      !
144      Agrif_UseSpecialValueInUpdate = .FALSE.
145      !
146#  if defined VOL_REFLUX
147      IF ( ln_dynspg_ts.AND.ln_bt_fw ) THEN
148         ! Refluxing on ssh:
149#  if defined DECAL_FEEDBACK
150         CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0, 0/),locupdate2=(/1, 1/),procname = reflux_sshu)
151         CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1, 1/),locupdate2=(/0, 0/),procname = reflux_sshv)
152#  else
153         CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/-1,-1/),locupdate2=(/ 0, 0/),procname = reflux_sshu)
154         CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/ 0, 0/),locupdate2=(/-1,-1/),procname = reflux_sshv)
155#  endif
156      END IF
157#  endif
158      !
159#endif
160      !
161   END SUBROUTINE Agrif_Update_ssh
162
163
164   SUBROUTINE Agrif_Update_Tke( )
165      !!---------------------------------------------
166      !!   *** ROUTINE Agrif_Update_Tke ***
167      !!---------------------------------------------
168      !!
169      !
170      IF (Agrif_Root()) RETURN
171      !       
172#  if defined TWO_WAY
173
174      Agrif_UseSpecialValueInUpdate = .TRUE.
175      Agrif_SpecialValueFineGrid = 0.
176
177      CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN  )
178      CALL Agrif_Update_Variable(avt_id, locupdate=(/0,0/), procname=updateAVT )
179      CALL Agrif_Update_Variable(avm_id, locupdate=(/0,0/), procname=updateAVM )
180
181      Agrif_UseSpecialValueInUpdate = .FALSE.
182
183#  endif
184     
185   END SUBROUTINE Agrif_Update_Tke
186
187
188   SUBROUTINE Agrif_Update_vvl( )
189      !!---------------------------------------------
190      !!   *** ROUTINE Agrif_Update_vvl ***
191      !!---------------------------------------------
192      !
193      IF (Agrif_Root()) RETURN
194      !
195#if defined TWO_WAY 
196      !
197      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update e3 from grid Number',Agrif_Fixed(), 'Step', Agrif_Nb_Step()
198      !
199      Agrif_UseSpecialValueInUpdate = .TRUE.
200      Agrif_SpecialValueFineGrid = 0.
201      !
202      ! No interface separation here, update vertical grid at T points
203      ! everywhere over the overlapping regions (one account for refluxing in that case):
204      CALL Agrif_Update_Variable(e3t_id, procname=updatee3t) 
205      !
206      Agrif_UseSpecialValueInUpdate = .FALSE.
207      !
208      CALL Agrif_ChildGrid_To_ParentGrid()
209      CALL dom_vvl_update_UVF
210      CALL Agrif_ParentGrid_To_ChildGrid()
211      !
212#endif
213      !
214   END SUBROUTINE Agrif_Update_vvl
215
216   SUBROUTINE dom_vvl_update_UVF
217      !!---------------------------------------------
218      !!       *** ROUTINE dom_vvl_update_UVF ***
219      !!---------------------------------------------
220      !!
221      INTEGER :: jk
222      REAL(wp):: zcoef
223      !!---------------------------------------------
224
225      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Finalize e3 on grid Number', &
226                  & Agrif_Fixed(), 'Step', Agrif_Nb_Step()
227
228      ! Save "old" scale factor (prior update) for subsequent asselin correction
229      ! of prognostic variables
230      ! -----------------------
231      !
232      e3u(:,:,:,Krhs_a) = e3u(:,:,:,Kmm_a)
233      e3v(:,:,:,Krhs_a) = e3v(:,:,:,Kmm_a)
234!      uu(:,:,:,Krhs_a) = e3u(:,:,:,Kbb_a)
235!      vv(:,:,:,Krhs_a) = e3v(:,:,:,Kbb_a)
236      hu(:,:,Krhs_a) = hu(:,:,Kmm_a)
237      hv(:,:,Krhs_a) = hv(:,:,Kmm_a)
238
239      ! 1) NOW fields
240      !--------------
241     
242         ! Vertical scale factor interpolations
243         ! ------------------------------------
244      CALL dom_vvl_interpol( e3t(:,:,:,Kmm_a), e3u(:,:,:,Kmm_a) ,  'U' )
245      CALL dom_vvl_interpol( e3t(:,:,:,Kmm_a), e3v(:,:,:,Kmm_a) ,  'V' )
246      CALL dom_vvl_interpol( e3u(:,:,:,Kmm_a), e3f(:,:,:) ,  'F' )
247
248      CALL dom_vvl_interpol( e3u(:,:,:,Kmm_a), e3uw(:,:,:,Kmm_a), 'UW' )
249      CALL dom_vvl_interpol( e3v(:,:,:,Kmm_a), e3vw(:,:,:,Kmm_a), 'VW' )
250
251         ! Update total depths:
252         ! --------------------
253      hu(:,:,Kmm_a) = 0._wp                        ! Ocean depth at U-points
254      hv(:,:,Kmm_a) = 0._wp                        ! Ocean depth at V-points
255      DO jk = 1, jpkm1
256         hu(:,:,Kmm_a) = hu(:,:,Kmm_a) + e3u(:,:,jk,Kmm_a) * umask(:,:,jk)
257         hv(:,:,Kmm_a) = hv(:,:,Kmm_a) + e3v(:,:,jk,Kmm_a) * vmask(:,:,jk)
258      END DO
259      !                                        ! Inverse of the local depth
260      r1_hu(:,:,Kmm_a) = ssumask(:,:) / ( hu(:,:,Kmm_a) + 1._wp - ssumask(:,:) )
261      r1_hv(:,:,Kmm_a) = ssvmask(:,:) / ( hv(:,:,Kmm_a) + 1._wp - ssvmask(:,:) )
262
263
264      ! 2) BEFORE fields:
265      !------------------
266      IF (.NOT.(lk_agrif_fstep.AND.(neuler==0) )) THEN
267         !
268         ! Vertical scale factor interpolations
269         ! ------------------------------------
270         CALL dom_vvl_interpol( e3t(:,:,:,Kbb_a), e3u(:,:,:,Kbb_a),  'U'  )
271         CALL dom_vvl_interpol( e3t(:,:,:,Kbb_a), e3v(:,:,:,Kbb_a),  'V'  )
272
273         CALL dom_vvl_interpol( e3u(:,:,:,Kbb_a), e3uw(:,:,:,Kbb_a), 'UW' )
274         CALL dom_vvl_interpol( e3v(:,:,:,Kbb_a), e3vw(:,:,:,Kbb_a), 'VW' )
275
276         ! Update total depths:
277         ! --------------------
278         hu(:,:,Kbb_a) = 0._wp                     ! Ocean depth at U-points
279         hv(:,:,Kbb_a) = 0._wp                     ! Ocean depth at V-points
280         DO jk = 1, jpkm1
281            hu(:,:,Kbb_a) = hu(:,:,Kbb_a) + e3u(:,:,jk,Kbb_a) * umask(:,:,jk)
282            hv(:,:,Kbb_a) = hv(:,:,Kbb_a) + e3v(:,:,jk,Kbb_a) * vmask(:,:,jk)
283         END DO
284         !                                     ! Inverse of the local depth
285         r1_hu(:,:,Kbb_a) = ssumask(:,:) / ( hu(:,:,Kbb_a) + 1._wp - ssumask(:,:) )
286         r1_hv(:,:,Kbb_a) = ssvmask(:,:) / ( hv(:,:,Kbb_a) + 1._wp - ssvmask(:,:) )
287      ENDIF
288      !
289   END SUBROUTINE dom_vvl_update_UVF
290
291#if defined key_vertical
292
293   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
294      !!----------------------------------------------------------------------
295      !!           *** ROUTINE updateT ***
296      !!---------------------------------------------
297      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
298      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
299      LOGICAL, INTENT(in) :: before
300      !!
301      INTEGER :: ji,jj,jk,jn
302      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: tabres_child
303      REAL(wp) :: h_in(k1:k2)
304      REAL(wp) :: h_out(1:jpk)
305      INTEGER  :: N_in, N_out
306      REAL(wp) :: zrho_xy, h_diff
307      REAL(wp) :: tabin(k1:k2,n1:n2)
308      !!---------------------------------------------
309      !
310      IF (before) THEN
311         AGRIF_SpecialValue = -999._wp
312         zrho_xy = Agrif_rhox() * Agrif_rhoy() 
313         DO jn = n1,n2-1
314            DO jk=k1,k2
315               DO jj=j1,j2
316                  DO ji=i1,i2
317                     tabres(ji,jj,jk,jn) = (    ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) )          &
318                       &                   * tmask(ji,jj,jk)       + (tmask(ji,jj,jk) - 1._wp)*999._wp
319                  END DO
320               END DO
321            END DO
322         END DO
323         DO jk=k1,k2
324            DO jj=j1,j2
325               DO ji=i1,i2
326                  tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) &
327                    &                      + (tmask(ji,jj,jk) - 1._wp)*999._wp
328               END DO
329            END DO
330         END DO
331      ELSE
332         tabres_child(:,:,:,:) = 0._wp
333         AGRIF_SpecialValue = 0._wp
334         DO jj=j1,j2
335            DO ji=i1,i2
336               N_in = 0
337               DO jk=k1,k2 !k2 = jpk of child grid
338                  IF (tabres(ji,jj,jk,n2) == 0  ) EXIT
339                  N_in = N_in + 1
340                  tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2)
341                  h_in(N_in) = tabres(ji,jj,jk,n2)
342               ENDDO
343               N_out = 0
344               DO jk=1,jpk ! jpk of parent grid
345                  IF (tmask(ji,jj,jk) < -900) EXIT ! TODO: Will not work with ISF
346                  N_out = N_out + 1
347                  h_out(N_out) = e3t(ji,jj,jk,Kmm_a) 
348               ENDDO
349               IF (N_in > 0) THEN !Remove this?
350                  h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
351                  IF (h_diff < -1.e-4) THEN
352                     print *,'CHECK YOUR bathy T points ...',ji,jj,h_diff,sum(h_in(1:N_in)),sum(h_out(1:N_out))
353                     print *,h_in(1:N_in)
354                     print *,h_out(1:N_out)
355                     STOP
356                  ENDIF
357                  DO jn=n1,n2-1
358                     CALL reconstructandremap( tabin(1:N_in,jn), h_in(1:N_in), tabres_child(ji,jj,1:N_out,jn),  &
359                       &                       h_out(1:N_out)  , N_in        , N_out                           )
360                  ENDDO
361               ENDIF
362            ENDDO
363         ENDDO
364
365         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
366            ! Add asselin part
367            DO jn = n1,n2-1
368               DO jk=1,jpk
369                  DO jj=j1,j2
370                     DO ji=i1,i2
371                        IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN
372                           ts(ji,jj,jk,jn,Kbb_a) =                     ts(ji,jj,jk,jn,Kbb_a) & 
373                                 &                + atfp * ( tabres_child(ji,jj,jk,jn)       &
374                                 &                                   - ts(ji,jj,jk,jn,Kmm_a) &
375                                 &                         ) * tmask(ji,jj,jk)
376                        ENDIF
377                     ENDDO
378                  ENDDO
379               ENDDO
380            ENDDO
381         ENDIF
382         DO jn = n1,n2-1
383            DO jk=1,jpk
384               DO jj=j1,j2
385                  DO ji=i1,i2
386                     IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN
387                        ts(ji,jj,jk,jn,Kmm_a) = tabres_child(ji,jj,jk,jn) * tmask(ji,jj,jk)
388                     END IF
389                  END DO
390               END DO
391            END DO
392         END DO
393      ENDIF
394      !
395   END SUBROUTINE updateTS
396
397# else
398
399   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
400      !!---------------------------------------------
401      !!           *** ROUTINE updateT ***
402      !!---------------------------------------------
403      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
404      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
405      LOGICAL, INTENT(in) :: before
406      !!
407      INTEGER :: ji,jj,jk,jn
408      REAL(wp) :: ztb, ztnu, ztno
409      !!---------------------------------------------
410      !
411      IF (before) THEN
412         DO jn = 1,jpts
413            DO jk=k1,k2
414               DO jj=j1,j2
415                  DO ji=i1,i2
416!> jc tmp
417                     tabres(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a)  * e3t(ji,jj,jk,Kmm_a) / e3t_0(ji,jj,jk)
418!                    tabres(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a)  * e3t(ji,jj,jk,Kmm_a)
419!< jc tmp
420                  END DO
421               END DO
422            END DO
423         END DO
424      ELSE
425!> jc tmp
426         DO jn = 1,jpts
427            tabres(i1:i2,j1:j2,k1:k2,jn) =  tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) &
428                                         & * tmask(i1:i2,j1:j2,k1:k2)
429         ENDDO
430!< jc tmp
431         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
432            ! Add asselin part
433            DO jn = 1,jpts
434               DO jk = k1, k2
435                  DO jj = j1, j2
436                     DO ji = i1, i2
437                        IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN
438                           ztb  = ts(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used
439                           ztnu = tabres(ji,jj,jk,jn)
440                           ztno = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a)
441                           ts(ji,jj,jk,jn,Kbb_a) = ( ztb + atfp * ( ztnu - ztno) )  & 
442                                     &            * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a)
443                        ENDIF
444                     END DO
445                  END DO
446               END DO
447            END DO
448         ENDIF
449         DO jn = 1,jpts
450            DO jk=k1,k2
451               DO jj=j1,j2
452                  DO ji=i1,i2
453                     IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN
454                        ts(ji,jj,jk,jn,Kmm_a) = tabres(ji,jj,jk,jn) / e3t(ji,jj,jk,Kmm_a)
455                     END IF
456                  END DO
457               END DO
458            END DO
459         END DO
460         !
461         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
462            ts(i1:i2,j1:j2,k1:k2,1:jpts,Kbb_a)  = ts(i1:i2,j1:j2,k1:k2,1:jpts,Kmm_a)
463         ENDIF
464         !
465      ENDIF
466      !
467   END SUBROUTINE updateTS
468
469# endif
470
471# if defined key_vertical
472
473   SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
474      !!---------------------------------------------
475      !!           *** ROUTINE updateu ***
476      !!---------------------------------------------
477      INTEGER                                     , INTENT(in   ) :: i1, i2, j1, j2, k1, k2, n1, n2
478      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
479      LOGICAL                                     , INTENT(in   ) :: before
480      !
481      INTEGER ::   ji, jj, jk
482      REAL(wp)::   zrhoy
483! VERTICAL REFINEMENT BEGIN
484      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child
485      REAL(wp) :: h_in(k1:k2)
486      REAL(wp) :: h_out(1:jpk)
487      INTEGER  :: N_in, N_out
488      REAL(wp) :: h_diff, excess, thick
489      REAL(wp) :: tabin(k1:k2)
490! VERTICAL REFINEMENT END
491      !!---------------------------------------------
492      !
493      IF( before ) THEN
494         zrhoy = Agrif_Rhoy()
495         AGRIF_SpecialValue = -999._wp
496         DO jk=k1,k2
497            DO jj=j1,j2
498               DO ji=i1,i2
499                  tabres(ji,jj,jk,1) = zrhoy * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * umask(ji,jj,jk) * uu(ji,jj,jk,Kmm_a)  &
500                    &                  + (umask(ji,jj,jk)-1._wp)*999._wp
501                  tabres(ji,jj,jk,2) = zrhoy * umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a)  &
502                    &                  + (umask(ji,jj,jk)-1._wp)*999._wp
503               END DO
504            END DO
505         END DO
506      ELSE
507         tabres_child(:,:,:) = 0.
508         AGRIF_SpecialValue = 0._wp
509         DO jj=j1,j2
510            DO ji=i1,i2
511               N_in = 0
512               h_in(:) = 0._wp
513               tabin(:) = 0._wp
514               DO jk=k1,k2 !k2=jpk of child grid
515                  IF( tabres(ji,jj,jk,2) < -900) EXIT
516                  N_in = N_in + 1
517                  tabin(jk)  = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2)
518                  h_in(N_in) = tabres(ji,jj,jk,2)/e2u(ji,jj)
519               ENDDO
520               N_out = 0
521               DO jk=1,jpk
522                  IF (umask(ji,jj,jk) == 0) EXIT
523                  N_out = N_out + 1
524                  h_out(N_out) = e3u(ji,jj,jk,Kmm_a)
525               ENDDO
526               IF (N_in * N_out > 0) THEN
527                  h_diff = SUM( h_out(1:N_out) ) - SUM( h_in(1:N_in) )
528                  IF (h_diff < -1.e-4) THEN
529!Even if bathy at T points match it's possible for the U points to be deeper in the child grid.
530!In this case we need to move transport from the child grid cells below bed of parent grid into the bottom cell.
531                     excess = 0._wp
532                     DO jk=N_in,1,-1
533                        thick = MIN(-1*h_diff, h_in(jk))
534                        excess = excess + tabin(jk)*thick*e2u(ji,jj)
535                        tabin(jk) = tabin(jk)*(1. - thick/h_in(jk))
536                        h_diff = h_diff + thick
537                        IF ( h_diff == 0) THEN
538                           N_in = jk
539                           h_in(jk) = h_in(jk) - thick
540                           EXIT
541                        ENDIF
542                     ENDDO
543                  ENDIF
544                  CALL reconstructandremap( tabin(1:N_in) , h_in(1:N_in), tabres_child(ji,jj,1:N_out),       &
545                    &                       h_out(1:N_out), N_in        , N_out                            )
546                  tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/( e2u(ji,jj)*h_out(N_out) )
547               ENDIF
548            ENDDO
549         ENDDO
550
551         DO jk=1,jpk
552            DO jj=j1,j2
553               DO ji=i1,i2
554                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
555                     uu(ji,jj,jk,Kbb_a) =                     uu(ji,jj,jk,Kbb_a)                                   & 
556                           &             + atfp * ( tabres_child(ji,jj,jk) - uu(ji,jj,jk,Kmm_a) ) * umask(ji,jj,jk)
557                  ENDIF
558                  !
559                  uu(ji,jj,jk,Kmm_a) = tabres_child(ji,jj,jk) * umask(ji,jj,jk)
560               END DO
561            END DO
562         END DO
563      ENDIF
564      !
565   END SUBROUTINE updateu
566
567#else
568
569   SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
570      !!---------------------------------------------
571      !!           *** ROUTINE updateu ***
572      !!---------------------------------------------
573      INTEGER                               , INTENT(in   ) :: i1, i2, j1, j2, k1, k2, n1, n2
574      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
575      LOGICAL                                     , INTENT(in   ) :: before
576      !
577      INTEGER  :: ji, jj, jk
578      REAL(wp) :: zrhoy, zub, zunu, zuno
579      !!---------------------------------------------
580      !
581      IF( before ) THEN
582         zrhoy = Agrif_Rhoy()
583         DO jk = k1, k2
584            tabres(i1:i2,j1:j2,jk,1) = zrhoy * e2u(i1:i2,j1:j2) * e3u(i1:i2,j1:j2,jk,Kmm_a) &
585              &                                                 *  uu(i1:i2,j1:j2,jk,Kmm_a)
586         END DO
587      ELSE
588         DO jk=k1,k2
589            DO jj=j1,j2
590               DO ji=i1,i2
591                  tabres(ji,jj,jk,1) = tabres(ji,jj,jk,1) * r1_e2u(ji,jj) 
592                  !
593                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
594                     zub  = uu(ji,jj,jk,Kbb_a) * e3u(ji,jj,jk,Kbb_a)  ! fse3t_b prior update should be used
595                     zuno = uu(ji,jj,jk,Kmm_a) * e3u(ji,jj,jk,Krhs_a)
596                     zunu = tabres(ji,jj,jk,1)
597                     uu(ji,jj,jk,Kbb_a) = ( zub + atfp * ( zunu - zuno ) )       &     
598                       &                  * umask(ji,jj,jk) / e3u(ji,jj,jk,Kbb_a)
599                  ENDIF
600                  !
601                  uu(ji,jj,jk,Kmm_a) = tabres(ji,jj,jk,1) * umask(ji,jj,jk) / e3u(ji,jj,jk,Kmm_a)
602               END DO
603            END DO
604         END DO
605         !
606         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
607            uu(i1:i2,j1:j2,k1:k2,Kbb_a)  = uu(i1:i2,j1:j2,k1:k2,Kmm_a)
608         ENDIF
609         !
610      ENDIF
611      !
612   END SUBROUTINE updateu
613
614# endif
615
616   SUBROUTINE correct_u_bdy( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )
617      !!---------------------------------------------
618      !!           *** ROUTINE correct_u_bdy ***
619      !!---------------------------------------------
620      INTEGER                                     , INTENT(in   ) :: i1, i2, j1, j2, k1, k2, n1, n2
621      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
622      LOGICAL                                     , INTENT(in   ) :: before
623      INTEGER                                     , INTENT(in)    :: nb, ndir
624      !!
625      LOGICAL :: western_side, eastern_side 
626      !
627      INTEGER  :: jj, jk
628      REAL(wp) :: zcor
629      !!---------------------------------------------
630      !
631      IF( .NOT.before ) THEN
632         !
633         western_side  = (nb == 1).AND.(ndir == 1)
634         eastern_side  = (nb == 1).AND.(ndir == 2)
635         !
636         IF (western_side) THEN
637            DO jj=j1,j2
638               zcor = uu_b(i1-1,jj,Kmm_a) * hu(i1-1,jj,Krhs_a) * r1_hu(i1-1,jj,Kmm_a) - uu_b(i1-1,jj,Kmm_a)
639               uu_b(i1-1,jj,Kmm_a) = uu_b(i1-1,jj,Kmm_a) + zcor
640               DO jk=1,jpkm1
641                  uu(i1-1,jj,jk,Kmm_a) = uu(i1-1,jj,jk,Kmm_a) + zcor * umask(i1-1,jj,jk)
642               END DO
643            END DO
644         ENDIF
645         !
646         IF (eastern_side) THEN
647            DO jj=j1,j2
648               zcor = uu_b(i2+1,jj,Kmm_a) * hu(i2+1,jj,Krhs_a) * r1_hu(i2+1,jj,Kmm_a) - uu_b(i2+1,jj,Kmm_a)
649               uu_b(i2+1,jj,Kmm_a) = uu_b(i2+1,jj,Kmm_a) + zcor
650               DO jk=1,jpkm1
651                  uu(i2+1,jj,jk,Kmm_a) = uu(i2+1,jj,jk,Kmm_a) + zcor * umask(i2+1,jj,jk)
652               END DO
653            END DO
654         ENDIF
655         !
656      ENDIF
657      !
658   END SUBROUTINE correct_u_bdy
659
660# if  defined key_vertical
661
662   SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
663      !!---------------------------------------------
664      !!           *** ROUTINE updatev ***
665      !!---------------------------------------------
666      INTEGER                                     , INTENT(in   ) :: i1, i2, j1, j2, k1, k2, n1, n2
667      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
668      LOGICAL                                     , INTENT(in   ) :: before
669      !
670      INTEGER  ::   ji, jj, jk
671      REAL(wp) ::   zrhox
672! VERTICAL REFINEMENT BEGIN
673      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child
674      REAL(wp) :: h_in(k1:k2)
675      REAL(wp) :: h_out(1:jpk)
676      INTEGER :: N_in, N_out
677      REAL(wp) :: h_diff, excess, thick
678      REAL(wp) :: tabin(k1:k2)
679! VERTICAL REFINEMENT END
680      !!---------------------------------------------     
681      !
682      IF( before ) THEN
683         zrhox = Agrif_Rhox()
684         AGRIF_SpecialValue = -999._wp
685         DO jk=k1,k2
686            DO jj=j1,j2
687               DO ji=i1,i2
688                  tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a)                   &
689                    &                  *  vmask(ji,jj,jk) *  vv(ji,jj,jk,Kmm_a)                   &
690                    &                  + (vmask(ji,jj,jk)-1)*999._wp
691                  tabres(ji,jj,jk,2) = vmask(ji,jj,jk) * zrhox * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) &
692                                       + (vmask(ji,jj,jk)-1)*999._wp
693               END DO
694            END DO
695         END DO
696      ELSE
697         tabres_child(:,:,:) = 0.
698         AGRIF_SpecialValue = 0._wp
699         DO jj=j1,j2
700            DO ji=i1,i2
701               N_in = 0
702               DO jk=k1,k2
703                  IF (tabres(ji,jj,jk,2) < -900) EXIT
704                  N_in = N_in + 1
705                  tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2)
706                  h_in(N_in) = tabres(ji,jj,jk,2)/e1v(ji,jj)
707               ENDDO
708               N_out = 0
709               DO jk=1,jpk
710                  IF (vmask(ji,jj,jk) == 0) EXIT
711                  N_out = N_out + 1
712                  h_out(N_out) = e3v(ji,jj,jk,Kmm_a)
713               ENDDO
714               IF (N_in * N_out > 0) THEN
715                  h_diff = SUM( h_out(1:N_out) ) - SUM( h_in(1:N_in) )
716                  IF (h_diff < -1.e-4) then
717!Even if bathy at T points match it's possible for the U points to be deeper in the child grid.
718!In this case we need to move transport from the child grid cells below bed of parent grid into the bottom cell.
719                     excess = 0._wp
720                     DO jk=N_in,1,-1
721                        thick = MIN( -1._wp*h_diff, h_in(jk) )
722                        excess = excess + tabin(jk)*thick*e2u(ji,jj)
723                        tabin(jk) = tabin(jk)*(1._wp - thick/h_in(jk))
724                        h_diff = h_diff + thick
725                        IF ( h_diff == 0) THEN
726                           N_in = jk
727                           h_in(jk) = h_in(jk) - thick
728                           EXIT
729                        ENDIF
730                     ENDDO
731                  ENDIF
732                  CALL reconstructandremap( tabin(1:N_in) , h_in(1:N_in), tabres_child(ji,jj,1:N_out),     &
733                    &                       h_out(1:N_out), N_in        , N_out                          )
734                  tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e1v(ji,jj)*h_out(N_out))
735               ENDIF
736            ENDDO
737         ENDDO
738
739         DO jk=1,jpk
740            DO jj=j1,j2
741               DO ji=i1,i2
742                  !
743                  IF( .NOT.(lk_agrif_fstep.AND.(neuler==0)) ) THEN ! Add asselin part
744                     vv(ji,jj,jk,Kbb_a) =                     vv(ji,jj,jk,Kbb_a)                  & 
745                           &             + atfp * ( tabres_child(ji,jj,jk) - vv(ji,jj,jk,Kmm_a) ) &
746                           &                      *        vmask(ji,jj,jk)
747                  ENDIF
748                  !
749                  vv(ji,jj,jk,Kmm_a) = tabres_child(ji,jj,jk) * vmask(ji,jj,jk)
750               END DO
751            END DO
752         END DO
753      ENDIF
754      !
755   END SUBROUTINE updatev
756
757# else
758
759   SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before)
760      !!---------------------------------------------
761      !!           *** ROUTINE updatev ***
762      !!---------------------------------------------
763      INTEGER                                     , INTENT(in   ) :: i1, i2, j1, j2, k1, k2, n1, n2
764      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
765      LOGICAL                                     , INTENT(in   ) :: before
766      !
767      INTEGER  :: ji, jj, jk
768      REAL(wp) :: zrhox, zvb, zvnu, zvno
769      !!---------------------------------------------     
770      !
771      IF (before) THEN
772         zrhox = Agrif_Rhox()
773         DO jk=k1,k2
774            DO jj=j1,j2
775               DO ji=i1,i2
776                  tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vv(ji,jj,jk,Kmm_a)
777               END DO
778            END DO
779         END DO
780      ELSE
781         DO jk=k1,k2
782            DO jj=j1,j2
783               DO ji=i1,i2
784                  tabres(ji,jj,jk,1) = tabres(ji,jj,jk,1) * r1_e1v(ji,jj)
785                  !
786                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
787                     zvb  = vv(ji,jj,jk,Kbb_a) * e3v(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used
788                     zvno = vv(ji,jj,jk,Kmm_a) * e3v(ji,jj,jk,Krhs_a)
789                     zvnu = tabres(ji,jj,jk,1)
790                     vv(ji,jj,jk,Kbb_a) = ( zvb + atfp * ( zvnu - zvno) )        &     
791                       &                  * vmask(ji,jj,jk) / e3v(ji,jj,jk,Kbb_a)
792                  ENDIF
793                  !
794                  vv(ji,jj,jk,Kmm_a) = tabres(ji,jj,jk,1) * vmask(ji,jj,jk) / e3v(ji,jj,jk,Kmm_a)
795               END DO
796            END DO
797         END DO
798         !
799         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
800            vv(i1:i2,j1:j2,k1:k2,Kbb_a)  = vv(i1:i2,j1:j2,k1:k2,Kmm_a)
801         ENDIF
802         !
803      ENDIF
804      !
805   END SUBROUTINE updatev
806
807# endif
808
809   SUBROUTINE correct_v_bdy( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )
810      !!---------------------------------------------
811      !!           *** ROUTINE correct_u_bdy ***
812      !!---------------------------------------------
813      INTEGER                                     , INTENT(in   ) :: i1, i2, j1, j2, k1, k2, n1, n2
814      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
815      LOGICAL                                     , INTENT(in   ) :: before
816      INTEGER                                     , INTENT(in)    :: nb, ndir
817      !!
818      LOGICAL :: southern_side, northern_side 
819      !
820      INTEGER  :: ji, jk
821      REAL(wp) :: zcor
822      !!---------------------------------------------
823      !
824      IF( .NOT.before ) THEN
825         !
826         southern_side = (nb == 2).AND.(ndir == 1)
827         northern_side = (nb == 2).AND.(ndir == 2)
828         !
829         IF (southern_side) THEN
830            DO ji=i1,i2
831               zcor = vv_b(ji,j1-1,Kmm_a) * hv(ji,j1-1,Krhs_a) * r1_hv(ji,j1-1,Kmm_a) - vv_b(ji,j1-1,Kmm_a)
832               vv_b(ji,j1-1,Kmm_a) = vv_b(ji,j1-1,Kmm_a) + zcor
833               DO jk=1,jpkm1
834                  vv(ji,j1-1,jk,Kmm_a) = vv(ji,j1-1,jk,Kmm_a) + zcor * vmask(ji,j1-1,jk)
835               END DO
836            END DO
837         ENDIF
838         !
839         IF (northern_side) THEN
840            DO ji=i1,i2
841               zcor = vv_b(ji,j2+1,Kmm_a) * hv(ji,j2+1,Krhs_a) * r1_hv(ji,j2+1,Kmm_a) - vv_b(ji,j2+1,Kmm_a)
842               vv_b(ji,j2+1,Kmm_a) = vv_b(ji,j2+1,Kmm_a) + zcor
843               DO jk=1,jpkm1
844                  vv(ji,j2+1,jk,Kmm_a) = vv(ji,j2+1,jk,Kmm_a) + zcor * vmask(ji,j2+1,jk)
845               END DO
846            END DO
847         ENDIF
848         !
849      ENDIF
850      !
851   END SUBROUTINE correct_v_bdy
852
853
854   SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before )
855      !!----------------------------------------------------------------------
856      !!                      *** ROUTINE updateu2d ***
857      !!----------------------------------------------------------------------
858      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
859      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   tabres
860      LOGICAL                         , INTENT(in   ) ::   before
861      !!
862      INTEGER  :: ji, jj, jk
863      REAL(wp) :: zrhoy
864      REAL(wp) :: zcorr
865      !!---------------------------------------------
866      !
867      IF( before ) THEN
868         zrhoy = Agrif_Rhoy()
869         DO jj=j1,j2
870            DO ji=i1,i2
871               tabres(ji,jj) = zrhoy * uu_b(ji,jj,Kmm_a) * hu(ji,jj,Kmm_a) * e2u(ji,jj)
872            END DO
873         END DO
874      ELSE
875         DO jj=j1,j2
876            DO ji=i1,i2
877               tabres(ji,jj) =  tabres(ji,jj) * r1_e2u(ji,jj) 
878               !   
879               ! Update "now" 3d velocities:
880               spgu(ji,jj) = 0._wp
881               DO jk=1,jpkm1
882                  spgu(ji,jj) = spgu(ji,jj) + e3u(ji,jj,jk,Kmm_a) * uu(ji,jj,jk,Kmm_a)
883               END DO
884               !
885               zcorr = (tabres(ji,jj) - spgu(ji,jj)) * r1_hu(ji,jj,Kmm_a)
886               DO jk=1,jpkm1             
887                  uu(ji,jj,jk,Kmm_a) = uu(ji,jj,jk,Kmm_a) + zcorr * umask(ji,jj,jk)           
888               END DO
889               !
890               ! Update barotropic velocities:
891               IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN
892                  IF ( .NOT.( lk_agrif_fstep .AND. (neuler==0) ) ) THEN                          ! Add asselin part
893                     zcorr = (tabres(ji,jj) - uu_b(ji,jj,Kmm_a) * hu(ji,jj,Krhs_a)) * r1_hu(ji,jj,Kbb_a)
894                     uu_b(ji,jj,Kbb_a) = uu_b(ji,jj,Kbb_a) + atfp * zcorr * umask(ji,jj,1)
895                  END IF
896               ENDIF   
897               uu_b(ji,jj,Kmm_a) = tabres(ji,jj) * r1_hu(ji,jj,Kmm_a) * umask(ji,jj,1)
898               !       
899               ! Correct "before" velocities to hold correct bt component:
900               spgu(ji,jj) = 0.e0
901               DO jk=1,jpkm1
902                  spgu(ji,jj) = spgu(ji,jj) + e3u(ji,jj,jk,Kbb_a) * uu(ji,jj,jk,Kbb_a)
903               END DO
904               !
905               zcorr = uu_b(ji,jj,Kbb_a) - spgu(ji,jj) * r1_hu(ji,jj,Kbb_a)
906               DO jk=1,jpkm1             
907                  uu(ji,jj,jk,Kbb_a) = uu(ji,jj,jk,Kbb_a) + zcorr * umask(ji,jj,jk)           
908               END DO
909               !
910            END DO
911         END DO
912         !
913         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
914            uu_b(i1:i2,j1:j2,Kbb_a)  = uu_b(i1:i2,j1:j2,Kmm_a)
915         ENDIF
916      ENDIF
917      !
918   END SUBROUTINE updateu2d
919
920
921   SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before )
922      !!----------------------------------------------------------------------
923      !!                   *** ROUTINE updatev2d ***
924      !!----------------------------------------------------------------------
925      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
926      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   tabres
927      LOGICAL                         , INTENT(in   ) ::   before
928      !
929      INTEGER  :: ji, jj, jk
930      REAL(wp) :: zrhox, zcorr
931      !!----------------------------------------------------------------------
932      !
933      IF( before ) THEN
934         zrhox = Agrif_Rhox()
935         DO jj=j1,j2
936            DO ji=i1,i2
937               tabres(ji,jj) = zrhox * vv_b(ji,jj,Kmm_a) * hv(ji,jj,Kmm_a) * e1v(ji,jj) 
938            END DO
939         END DO
940      ELSE
941         DO jj=j1,j2
942            DO ji=i1,i2
943               tabres(ji,jj) =  tabres(ji,jj) * r1_e1v(ji,jj) 
944               !   
945               ! Update "now" 3d velocities:
946               spgv(ji,jj) = 0.e0
947               DO jk=1,jpkm1
948                  spgv(ji,jj) = spgv(ji,jj) + e3v(ji,jj,jk,Kmm_a) * vv(ji,jj,jk,Kmm_a)
949               END DO
950               !
951               zcorr = (tabres(ji,jj) - spgv(ji,jj)) * r1_hv(ji,jj,Kmm_a)
952               DO jk=1,jpkm1             
953                  vv(ji,jj,jk,Kmm_a) = vv(ji,jj,jk,Kmm_a) + zcorr * vmask(ji,jj,jk)           
954               END DO
955               !
956               ! Update barotropic velocities:
957               IF ( .NOT.ln_dynspg_ts .OR. ( ln_dynspg_ts .AND. ( .NOT.ln_bt_fw ) ) ) THEN
958                  IF ( .NOT. ( lk_agrif_fstep .AND. ( neuler==0 ) ) ) THEN                       ! Add asselin part
959                     zcorr = (tabres(ji,jj) - vv_b(ji,jj,Kmm_a) * hv(ji,jj,Krhs_a)) * r1_hv(ji,jj,Kbb_a)
960                     vv_b(ji,jj,Kbb_a) =       vv_b(ji,jj,Kbb_a) + atfp * zcorr  *   vmask(ji,jj,1)
961                  END IF
962               ENDIF             
963               vv_b(ji,jj,Kmm_a) = tabres(ji,jj) * r1_hv(ji,jj,Kmm_a) * vmask(ji,jj,1)
964               !       
965               ! Correct "before" velocities to hold correct bt component:
966               spgv(ji,jj) = 0.e0
967               DO jk=1,jpkm1
968                  spgv(ji,jj) = spgv(ji,jj) + e3v(ji,jj,jk,Kbb_a) * vv(ji,jj,jk,Kbb_a)
969               END DO
970               !
971               zcorr = vv_b(ji,jj,Kbb_a) - spgv(ji,jj) * r1_hv(ji,jj,Kbb_a)
972               DO jk=1,jpkm1             
973                  vv(ji,jj,jk,Kbb_a) = vv(ji,jj,jk,Kbb_a) + zcorr * vmask(ji,jj,jk)           
974               END DO
975               !
976            END DO
977         END DO
978         !
979         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
980            vv_b(i1:i2,j1:j2,Kbb_a)  = vv_b(i1:i2,j1:j2,Kmm_a)
981         ENDIF
982         !
983      ENDIF
984      !
985   END SUBROUTINE updatev2d
986
987
988   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before )
989      !!----------------------------------------------------------------------
990      !!                   *** ROUTINE updateSSH ***
991      !!----------------------------------------------------------------------
992      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
993      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   tabres
994      LOGICAL                         , INTENT(in   ) ::   before
995      !!
996      INTEGER :: ji, jj
997      !!----------------------------------------------------------------------
998      !
999      IF( before ) THEN
1000         DO jj=j1,j2
1001            DO ji=i1,i2
1002               tabres(ji,jj) = ssh(ji,jj,Kmm_a)
1003            END DO
1004         END DO
1005      ELSE
1006         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
1007            DO jj=j1,j2
1008               DO ji=i1,i2
1009                  ssh(ji,jj,Kbb_a) =              ssh(ji,jj,Kbb_a)                &
1010                    &               + atfp * ( tabres(ji,jj) - ssh(ji,jj,Kmm_a) ) &
1011                    &                        *  tmask(ji,jj,1)
1012               END DO
1013            END DO
1014         ENDIF
1015         !
1016         DO jj=j1,j2
1017            DO ji=i1,i2
1018               ssh(ji,jj,Kmm_a) = tabres(ji,jj) * tmask(ji,jj,1)
1019            END DO
1020         END DO
1021         !
1022         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
1023            ssh(i1:i2,j1:j2,Kbb_a)  = ssh(i1:i2,j1:j2,Kmm_a)
1024         ENDIF
1025         !
1026
1027      ENDIF
1028      !
1029   END SUBROUTINE updateSSH
1030
1031
1032   SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before )
1033      !!----------------------------------------------------------------------
1034      !!                      *** ROUTINE updateub2b ***
1035      !!----------------------------------------------------------------------
1036      INTEGER                            , INTENT(in) ::   i1, i2, j1, j2
1037      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   tabres
1038      LOGICAL                            , INTENT(in) ::   before
1039      !!
1040      INTEGER :: ji, jj
1041      REAL(wp) :: zrhoy, za1, zcor
1042      !!---------------------------------------------
1043      !
1044      IF (before) THEN
1045         zrhoy = Agrif_Rhoy()
1046         DO jj=j1,j2
1047            DO ji=i1,i2
1048               tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj)
1049            END DO
1050         END DO
1051         tabres = zrhoy * tabres
1052      ELSE
1053         !
1054         tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e2u(i1:i2,j1:j2)
1055         !
1056         za1 = 1._wp / REAL(Agrif_rhot(), wp)
1057         DO jj=j1,j2
1058            DO ji=i1,i2
1059               zcor=tabres(ji,jj) - ub2_b(ji,jj)
1060               ! Update time integrated fluxes also in case of multiply nested grids:
1061               ub2_i_b(ji,jj) = ub2_i_b(ji,jj) + za1 * zcor 
1062               ! Update corrective fluxes:
1063               un_bf(ji,jj)  = un_bf(ji,jj) + zcor
1064               ! Update half step back fluxes:
1065               ub2_b(ji,jj) = tabres(ji,jj)
1066            END DO
1067         END DO
1068      ENDIF
1069      !
1070   END SUBROUTINE updateub2b
1071
1072   SUBROUTINE reflux_sshu( tabres, i1, i2, j1, j2, before, nb, ndir )
1073      !!---------------------------------------------
1074      !!          *** ROUTINE reflux_sshu ***
1075      !!---------------------------------------------
1076      INTEGER, INTENT(in) :: i1, i2, j1, j2
1077      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
1078      LOGICAL, INTENT(in) :: before
1079      INTEGER, INTENT(in) :: nb, ndir
1080      !!
1081      LOGICAL :: western_side, eastern_side 
1082      INTEGER :: ji, jj
1083      REAL(wp) :: zrhoy, za1, zcor
1084      !!---------------------------------------------
1085      !
1086      IF (before) THEN
1087         zrhoy = Agrif_Rhoy()
1088         DO jj=j1,j2
1089            DO ji=i1,i2
1090               tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj)
1091            END DO
1092         END DO
1093         tabres = zrhoy * tabres
1094      ELSE
1095         !
1096         tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e2u(i1:i2,j1:j2)
1097         !
1098         western_side  = (nb == 1).AND.(ndir == 1)
1099         eastern_side  = (nb == 1).AND.(ndir == 2)
1100         !
1101         IF (western_side) THEN
1102            DO jj=j1,j2
1103               zcor = rdt * r1_e1e2t(i1  ,jj) * e2u(i1,jj) * (ub2_b(i1,jj)-tabres(i1,jj)) 
1104               ssh(i1  ,jj,Kmm_a) = ssh(i1  ,jj,Kmm_a) + zcor
1105               IF ( .NOT. ( lk_agrif_fstep .AND. ( neuler==0 ) ) )  &
1106                 &                  ssh(i1  ,jj,Kbb_a) = ssh(i1  ,jj,Kbb_a) + atfp * zcor
1107            END DO
1108         ENDIF
1109         IF (eastern_side) THEN
1110            DO jj=j1,j2
1111               zcor = - rdt * r1_e1e2t(i2+1,jj) * e2u(i2,jj) * (ub2_b(i2,jj)-tabres(i2,jj))
1112               ssh(i2+1,jj,Kmm_a) = ssh(i2+1,jj,Kmm_a) + zcor
1113               IF ( .NOT. ( lk_agrif_fstep .AND. ( neuler==0 ) ) )   &
1114                 &                  ssh(i2+1,jj,Kbb_a) = ssh(i2+1,jj,Kbb_a) + atfp * zcor
1115            END DO
1116         ENDIF
1117         !
1118      ENDIF
1119      !
1120   END SUBROUTINE reflux_sshu
1121
1122   SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before )
1123      !!----------------------------------------------------------------------
1124      !!                      *** ROUTINE updatevb2b ***
1125      !!----------------------------------------------------------------------
1126      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1127      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   tabres
1128      LOGICAL                         , INTENT(in   ) ::   before
1129      !!
1130      INTEGER :: ji, jj
1131      REAL(wp) :: zrhox, za1, zcor
1132      !!---------------------------------------------
1133      !
1134      IF( before ) THEN
1135         zrhox = Agrif_Rhox()
1136         DO jj=j1,j2
1137            DO ji=i1,i2
1138               tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj) 
1139            END DO
1140         END DO
1141         tabres = zrhox * tabres
1142      ELSE
1143         !
1144         tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e1v(i1:i2,j1:j2)
1145         !
1146         za1 = 1._wp / REAL(Agrif_rhot(), wp)
1147         DO jj=j1,j2
1148            DO ji=i1,i2
1149               zcor=tabres(ji,jj) - vb2_b(ji,jj)
1150               ! Update time integrated fluxes also in case of multiply nested grids:
1151               vb2_i_b(ji,jj) = vb2_i_b(ji,jj) + za1 * zcor 
1152               ! Update corrective fluxes:
1153               vn_bf(ji,jj)  = vn_bf(ji,jj) + zcor
1154               ! Update half step back fluxes:
1155               vb2_b(ji,jj) = tabres(ji,jj)
1156            END DO
1157         END DO
1158      ENDIF
1159      !
1160   END SUBROUTINE updatevb2b
1161
1162   SUBROUTINE reflux_sshv( tabres, i1, i2, j1, j2, before, nb, ndir )
1163      !!---------------------------------------------
1164      !!          *** ROUTINE reflux_sshv ***
1165      !!---------------------------------------------
1166      INTEGER, INTENT(in) :: i1, i2, j1, j2
1167      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
1168      LOGICAL, INTENT(in) :: before
1169      INTEGER, INTENT(in) :: nb, ndir
1170      !!
1171      LOGICAL :: southern_side, northern_side 
1172      INTEGER :: ji, jj
1173      REAL(wp) :: zrhox, za1, zcor
1174      !!---------------------------------------------
1175      !
1176      IF (before) THEN
1177         zrhox = Agrif_Rhox()
1178         DO jj=j1,j2
1179            DO ji=i1,i2
1180               tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj) 
1181            END DO
1182         END DO
1183         tabres = zrhox * tabres
1184      ELSE
1185         !
1186         tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e1v(i1:i2,j1:j2)
1187         !
1188         southern_side = (nb == 2).AND.(ndir == 1)
1189         northern_side = (nb == 2).AND.(ndir == 2)
1190         !
1191         IF (southern_side) THEN
1192            DO ji=i1,i2
1193               zcor = rdt * r1_e1e2t(ji,j1  ) * e1v(ji,j1  ) * ( vb2_b(ji,j1)-tabres(ji,j1) )
1194               ssh(ji,j1  ,Kmm_a) = ssh(ji,j1  ,Kmm_a) + zcor
1195               IF ( .NOT. ( lk_agrif_fstep .AND. ( neuler==0 ) ) )   &
1196                 &                 ssh(ji,j1  ,Kbb_a) = ssh(ji,j1,Kbb_a) + atfp * zcor
1197            END DO
1198         ENDIF
1199         IF (northern_side) THEN               
1200            DO ji=i1,i2
1201               zcor = - rdt * r1_e1e2t(ji,j2+1) * e1v(ji,j2  ) * ( vb2_b(ji,j2)-tabres(ji,j2) )
1202               ssh(ji,j2+1,Kmm_a) = ssh(ji,j2+1,Kmm_a) + zcor
1203               IF ( .NOT. ( lk_agrif_fstep .AND. ( neuler==0 ) ) )   &
1204                 &                  ssh(ji,j2+1,Kbb_a) = ssh(ji,j2+1,Kbb_a) + atfp * zcor
1205            END DO
1206         ENDIF
1207         !
1208      ENDIF
1209      !
1210   END SUBROUTINE reflux_sshv
1211
1212   SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before )
1213      !
1214      ! ====>>>>>>>>>>    currently not used
1215      !
1216      !!----------------------------------------------------------------------
1217      !!                      *** ROUTINE updateT ***
1218      !!----------------------------------------------------------------------
1219      INTEGER                                    , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
1220      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   tabres
1221      LOGICAL                                    , INTENT(in   ) ::   before
1222      !!
1223      INTEGER :: ji,jj,jk
1224      REAL(wp) :: ztemp
1225      !!----------------------------------------------------------------------
1226
1227      IF (before) THEN
1228         DO jk=k1,k2
1229            DO jj=j1,j2
1230               DO ji=i1,i2
1231                  tabres(ji,jj,jk,1) = e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk)
1232                  tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk)
1233                  tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk)
1234               END DO
1235            END DO
1236         END DO
1237         tabres(:,:,:,1) = tabres(:,:,:,1)*Agrif_Rhox()*Agrif_Rhoy()
1238         tabres(:,:,:,2) = tabres(:,:,:,2)*Agrif_Rhox()
1239         tabres(:,:,:,3) = tabres(:,:,:,3)*Agrif_Rhoy()
1240      ELSE
1241         DO jk=k1,k2
1242            DO jj=j1,j2
1243               DO ji=i1,i2
1244                  IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN
1245                     print *,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk)
1246                     print *,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)*tmask(ji,jj,jk)
1247                     print *,'VAL3 = ',ji,jj,jk,tabres(ji,jj,jk,3),e2t(ji,jj)*tmask(ji,jj,jk)
1248                     ztemp = SQRT( tabres(ji,jj,jk,1)/(tabres(ji,jj,jk,2)*tabres(ji,jj,jk,3)) )
1249                     print *,'CORR = ',ztemp-1.
1250                     print *,'NEW VALS = ',tabres(ji,jj,jk,2)*ztemp,tabres(ji,jj,jk,3)*ztemp, &
1251                           tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp
1252                     e1t(ji,jj) = tabres(ji,jj,jk,2) * ztemp
1253                     e2t(ji,jj) = tabres(ji,jj,jk,3) * ztemp
1254                  END IF
1255               END DO
1256            END DO
1257         END DO
1258      ENDIF
1259      !
1260   END SUBROUTINE update_scales
1261
1262
1263   SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before )
1264      !!----------------------------------------------------------------------
1265      !!                      *** ROUTINE updateen ***
1266      !!----------------------------------------------------------------------
1267      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
1268      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
1269      LOGICAL                               , INTENT(in   ) ::   before
1270      !!----------------------------------------------------------------------
1271      !
1272      IF( before ) THEN
1273         ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2)
1274      ELSE
1275         en(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
1276      ENDIF
1277      !
1278   END SUBROUTINE updateEN
1279
1280
1281   SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before )
1282      !!----------------------------------------------------------------------
1283      !!                      *** ROUTINE updateavt ***
1284      !!----------------------------------------------------------------------
1285      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
1286      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
1287      LOGICAL                               , INTENT(in   ) ::   before
1288      !!----------------------------------------------------------------------
1289      !
1290      IF( before ) THEN   ;   ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2)
1291      ELSE                ;   avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
1292      ENDIF
1293      !
1294   END SUBROUTINE updateAVT
1295
1296
1297   SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before )
1298      !!---------------------------------------------
1299      !!           *** ROUTINE updateavm ***
1300      !!----------------------------------------------------------------------
1301      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
1302      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
1303      LOGICAL                               , INTENT(in   ) ::   before
1304      !!----------------------------------------------------------------------
1305      !
1306      IF( before ) THEN   ;   ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2)
1307      ELSE                ;   avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
1308      ENDIF
1309      !
1310   END SUBROUTINE updateAVM
1311
1312   SUBROUTINE updatee3t(ptab_dum, i1, i2, j1, j2, k1, k2, before )
1313      !!---------------------------------------------
1314      !!           *** ROUTINE updatee3t ***
1315      !!---------------------------------------------
1316      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ptab_dum
1317      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
1318      LOGICAL, INTENT(in) :: before
1319      !
1320      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ptab
1321      INTEGER :: ji,jj,jk
1322      REAL(wp) :: zcoef
1323      !!---------------------------------------------
1324      !
1325      IF (.NOT.before) THEN
1326         !
1327         ALLOCATE(ptab(i1:i2,j1:j2,1:jpk)) 
1328         !
1329         ! Update e3t from ssh (z* case only)
1330         DO jk = 1, jpkm1
1331            DO jj=j1,j2
1332               DO ji=i1,i2
1333                  ptab(ji,jj,jk) =   e3t_0(ji,jj,jk)                                    &
1334                    &                * ( 1._wp + ssh(ji,jj,Kmm_a)                       &
1335                    &                          * ssmask(ji,jj)                          &
1336                    &                          / ( ht_0(ji,jj)-1._wp + ssmask(ji,jj) ) )
1337               END DO
1338            END DO
1339         END DO
1340         !
1341         ! 1) Updates at BEFORE time step:
1342         ! -------------------------------
1343         !
1344         ! Save "old" scale factor (prior update) for subsequent asselin correction
1345         ! of prognostic variables
1346         e3t(i1:i2,j1:j2,1:jpkm1,Krhs_a) = e3t(i1:i2,j1:j2,1:jpkm1,Kmm_a)
1347
1348         ! One should also save e3t(:,:,:,Kbb_a), but lacking of workspace...
1349!         hdiv(i1:i2,j1:j2,1:jpkm1)   = e3t(i1:i2,j1:j2,1:jpkm1,Kbb_a)
1350
1351         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0) )) THEN
1352            DO jk = 1, jpkm1
1353               DO jj=j1,j2
1354                  DO ji=i1,i2
1355                     e3t(ji,jj,jk,Kbb_a) =             e3t(ji,jj,jk,Kbb_a)                  &
1356                       &                   + atfp * ( ptab(ji,jj,jk) - e3t(ji,jj,jk,Kmm_a) )
1357                  END DO
1358               END DO
1359            END DO
1360            !
1361            e3w  (i1:i2,j1:j2,1,Kbb_a) = e3w_0(i1:i2,j1:j2,1) + e3t(i1:i2,j1:j2,1,Kbb_a) - e3t_0(i1:i2,j1:j2,1)
1362            gdepw(i1:i2,j1:j2,1,Kbb_a) = 0.0_wp
1363            gdept(i1:i2,j1:j2,1,Kbb_a) = 0.5_wp * e3w(i1:i2,j1:j2,1,Kbb_a)
1364            !
1365            DO jk = 2, jpk
1366               DO jj = j1,j2
1367                  DO ji = i1,i2           
1368                     zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk))
1369                     e3w(ji,jj,jk,Kbb_a)  = e3w_0(ji,jj,jk) + ( 1.0_wp - 0.5_wp * tmask(ji,jj,jk) )          & 
1370                       &                                    * ( e3t(ji,jj,jk-1,Kbb_a) - e3t_0(ji,jj,jk-1) )  &
1371                       &                                    + 0.5_wp * tmask(ji,jj,jk)                       &
1372                       &                                    * ( e3t(ji,jj,jk  ,Kbb_a) - e3t_0(ji,jj,jk  ) )
1373                     gdepw(ji,jj,jk,Kbb_a) =                       gdepw(ji,jj,jk-1,Kbb_a) +       e3t(ji,jj,jk-1,Kbb_a)
1374                     gdept(ji,jj,jk,Kbb_a) =            zcoef  * ( gdepw(ji,jj,jk  ,Kbb_a) + 0.5 * e3w(ji,jj,jk  ,Kbb_a) )  &
1375                       &                     + (1._wp - zcoef) * ( gdept(ji,jj,jk-1,Kbb_a) +       e3w(ji,jj,jk  ,Kbb_a) ) 
1376                  END DO
1377               END DO
1378            END DO
1379            !
1380         ENDIF       
1381         !
1382         ! 2) Updates at NOW time step:
1383         ! ----------------------------
1384         !
1385         ! Update vertical scale factor at T-points:
1386         e3t(i1:i2,j1:j2,1:jpkm1,Kmm_a) = ptab(i1:i2,j1:j2,1:jpkm1)
1387         !
1388         ! Update total depth:
1389         ht(i1:i2,j1:j2) = 0._wp
1390         DO jk = 1, jpkm1
1391            ht(i1:i2,j1:j2) = ht(i1:i2,j1:j2) + e3t(i1:i2,j1:j2,jk,Kmm_a) * tmask(i1:i2,j1:j2,jk)
1392         END DO
1393         !
1394         ! Update vertical scale factor at W-points and depths:
1395           e3w(i1:i2,j1:j2,1,Kmm_a) = e3w_0(i1:i2,j1:j2,1) + e3t(i1:i2,j1:j2,1,Kmm_a) - e3t_0(i1:i2,j1:j2,1)
1396         gdept(i1:i2,j1:j2,1,Kmm_a) = 0.5_wp * e3w(i1:i2,j1:j2,1,Kmm_a)
1397         gdepw(i1:i2,j1:j2,1,Kmm_a) = 0.0_wp
1398         gde3w(i1:i2,j1:j2,1      ) = gdept(i1:i2,j1:j2,1,Kmm_a) - ( ht(i1:i2,j1:j2) - ht_0(i1:i2,j1:j2) ) ! Last term in the rhs is ssh
1399         !
1400         DO jk = 2, jpk
1401            DO jj = j1,j2
1402               DO ji = i1,i2           
1403               zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk))
1404                e3w(ji,jj,jk,Kmm_a)  = e3w_0(ji,jj,jk) + ( 1.0_wp - 0.5_wp * tmask(ji,jj,jk) )          &
1405                 &                                     * ( e3t(ji,jj,jk-1,Kmm_a) - e3t_0(ji,jj,jk-1) )  &
1406                 &                                     + 0.5_wp * tmask(ji,jj,jk)                       &
1407                 &                                     * ( e3t(ji,jj,jk  ,Kmm_a) - e3t_0(ji,jj,jk  ) )
1408               gdepw(ji,jj,jk,Kmm_a) =                         gdepw(ji,jj,jk-1,Kmm_a) +       e3t(ji,jj,jk-1,Kmm_a)
1409               gdept(ji,jj,jk,Kmm_a) =             zcoef   * ( gdepw(ji,jj,jk  ,Kmm_a) + 0.5 * e3w(ji,jj,jk  ,Kmm_a) )  &
1410                 &                     + ( 1._wp - zcoef ) * ( gdept(ji,jj,jk-1,Kmm_a) +       e3w(ji,jj,jk  ,Kmm_a) ) 
1411               gde3w(ji,jj,jk      ) =                         gdept(ji,jj,jk  ,Kmm_a) - ( ht(ji,jj)-ht_0(ji,jj) )    ! Last term in the rhs is ssh
1412               END DO
1413            END DO
1414         END DO
1415         !
1416         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
1417              e3t(i1:i2,j1:j2,1:jpk,Kbb_a) =   e3t(i1:i2,j1:j2,1:jpk,Kmm_a)
1418              e3w(i1:i2,j1:j2,1:jpk,Kbb_a) =   e3w(i1:i2,j1:j2,1:jpk,Kmm_a)
1419            gdepw(i1:i2,j1:j2,1:jpk,Kbb_a) = gdepw(i1:i2,j1:j2,1:jpk,Kmm_a)
1420            gdept(i1:i2,j1:j2,1:jpk,Kbb_a) = gdept(i1:i2,j1:j2,1:jpk,Kmm_a)
1421         ENDIF
1422         !
1423         DEALLOCATE(ptab)
1424      ENDIF
1425      !
1426   END SUBROUTINE updatee3t
1427
1428#else
1429   !!----------------------------------------------------------------------
1430   !!   Empty module                                          no AGRIF zoom
1431   !!----------------------------------------------------------------------
1432CONTAINS
1433   SUBROUTINE agrif_oce_update_empty
1434      WRITE(*,*)  'agrif_oce_update : You should not have seen this print! error?'
1435   END SUBROUTINE agrif_oce_update_empty
1436#endif
1437
1438   !!======================================================================
1439END MODULE agrif_oce_update
1440
Note: See TracBrowser for help on using the repository browser.