source: NEMO/branches/2018/dev_r9838_ENHANCE04_MLF/src/NST/agrif_oce_update.F90 @ 9923

Last change on this file since 9923 was 9923, checked in by gm, 3 years ago

#1911 (ENHANCE-04): step I.2: dev_r9838_ENHANCE04_MLF

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