New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

agrif_oce_update.F90 in NEMO/branches/2018/dev_r9838_ENHANCE04_MLF/src/NST – NEMO

Context Navigation

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, 6 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
5	MODULE 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	!!----------------------------------------------------------------------
66	CONTAINS
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)thicke2u(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)thicke2u(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)ztemptabres(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	!!----------------------------------------------------------------------
1450	CONTAINS
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	!!======================================================================
1457	END MODULE agrif_oce_update
1458

Note: See TracBrowser for help on using the repository browser.

Download in other formats: