Context Navigation

agrif_oce_update.F90 @ 11480

Last change on this file since 11480 was 11480, checked in by davestorkey, 5 years ago

2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps : Merge in changes from branch of branch.
Main changes:

"nxt" modules renamed as "atf" and now just do Asselin time filtering. The time level swapping is achieved by swapping indices.
Some additional prognostic grid variables changed to use a time dimension.

Notes:

This merged branch passes SETTE tests but does not identical results to the SETTE tests with the trunk@10721 unless minor bugs to do with Euler timestepping and the OFF timestepping are fixed in the trunk (NEMO tickets #2310 and #2311).
The nn_dttrc > 1 option for TOP (TOP has a different timestep to OCE) doesn't work. But it doesn't work in the trunk or NEMO 4.0 release either.

Property svn:keywords set to Id

File size: 57.9 KB

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

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

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

Context Navigation

source: NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/NST/agrif_oce_update.F90 @ 11480

Download in other formats: