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_user.F90 in NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/NST – NEMO

Context Navigation

source: NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/NST/agrif_user.F90 @ 13998

Last change on this file since 13998 was 13998, checked in by techene, 3 years ago
branch updated with trunk 13787
Property svn:keywords set to `Id`
File size: 52.1 KB

Line
1	#undef UPD_HIGH /* MIX HIGH UPDATE */
2	#if defined key_agrif
3	!! * Substitutions
4	# include "do_loop_substitute.h90"
5	!!----------------------------------------------------------------------
6	!! NEMO/NST 4.0 , NEMO Consortium (2018)
7	!! $Id$
8	!! Software governed by the CeCILL license (see ./LICENSE)
9	!!----------------------------------------------------------------------
10	SUBROUTINE agrif_user
11	END SUBROUTINE agrif_user
12
13
14	SUBROUTINE agrif_before_regridding
15	END SUBROUTINE agrif_before_regridding
16
17
18	SUBROUTINE Agrif_InitWorkspace
19	END SUBROUTINE Agrif_InitWorkspace
20
21
22	SUBROUTINE Agrif_InitValues
23	!!----------------------------------------------------------------------
24	!! * ROUTINE Agrif_InitValues *
25	!!----------------------------------------------------------------------
26	USE nemogcm
27	!!----------------------------------------------------------------------
28	!
29	CALL nemo_init !* Initializations of each fine grid
30	Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices
31	!
32	! !* Agrif initialization
33	CALL Agrif_InitValues_cont
34	# if defined key_top
35	CALL Agrif_InitValues_cont_top
36	# endif
37	# if defined key_si3
38	CALL Agrif_InitValues_cont_ice
39	# endif
40	!
41	END SUBROUTINE Agrif_initvalues
42
43
44	SUBROUTINE Agrif_Istate( Kbb, Kmm, Kaa )
45	!!----------------------------------------------------------------------
46	!! * ROUTINE agrif_istate *
47	!!----------------------------------------------------------------------
48	USE domvvl
49	USE domain
50	USE par_oce
51	USE agrif_oce
52	USE agrif_oce_interp
53	USE oce
54	USE lib_mpp
55	USE lbclnk
56	!
57	IMPLICIT NONE
58	!
59	INTEGER, INTENT(in) :: Kbb, Kmm, Kaa
60	INTEGER :: jn
61	!!----------------------------------------------------------------------
62	IF(lwp) WRITE(numout,*) ' '
63	IF(lwp) WRITE(numout,*) 'AGRIF: interp child initial state from parent'
64	IF(lwp) WRITE(numout,*) ' '
65
66	l_ini_child = .TRUE.
67	Agrif_SpecialValue = 0.0_wp
68	Agrif_UseSpecialValue = .TRUE.
69	uu(:,:,:,:) = 0.0_wp ; vv(:,:,:,:) = 0.0_wp ; ts(:,:,:,:,:) = 0.0_wp
70
71	Krhs_a = Kbb ; Kmm_a = Kbb
72
73	! Brutal fix to pas 1x1 refinment.
74	! IF(Agrif_Irhox() == 1) THEN
75	! CALL Agrif_Init_Variable(tsini_id, procname=agrif_initts)
76	! ELSE
77	CALL Agrif_Init_Variable(tsini_id, procname=interptsn)
78
79	! ENDIF
80	! just for VORTEX because Parent velocities can actually be exactly zero
81	! Agrif_UseSpecialValue = .FALSE.
82	Agrif_UseSpecialValue = ln_spc_dyn
83	use_sign_north = .TRUE.
84	sign_north = -1.
85	CALL Agrif_Init_Variable(uini_id , procname=interpun )
86	CALL Agrif_Init_Variable(vini_id , procname=interpvn )
87	use_sign_north = .FALSE.
88
89	Agrif_UseSpecialValue = .FALSE.
90	l_ini_child = .FALSE.
91
92	Krhs_a = Kaa ; Kmm_a = Kmm
93
94	DO jn = 1, jpts
95	ts(:,:,:,jn,Kbb) = ts(:,:,:,jn,Kbb)*tmask(:,:,:)
96	END DO
97	uu(:,:,:,Kbb) = uu(:,:,:,Kbb) * umask(:,:,:)
98	vv(:,:,:,Kbb) = vv(:,:,:,Kbb) * vmask(:,:,:)
99
100
101	CALL lbc_lnk_multi( 'agrif_istate', uu(:,:,: ,Kbb), 'U', -1.0_wp , vv(:,:,:,Kbb), 'V', -1.0_wp )
102	CALL lbc_lnk( 'agrif_istate', ts(:,:,:,:,Kbb), 'T', 1.0_wp )
103
104	END SUBROUTINE Agrif_Istate
105
106
107	SUBROUTINE agrif_declare_var_ini
108	!!----------------------------------------------------------------------
109	!! * ROUTINE agrif_declare_var_ini *
110	!!----------------------------------------------------------------------
111	USE agrif_util
112	USE agrif_oce
113	USE par_oce
114	USE zdf_oce
115	USE oce
116	USE dom_oce
117	!
118	IMPLICIT NONE
119	!
120	INTEGER :: ind1, ind2, ind3
121	INTEGER :: its
122	External :: nemo_mapping
123	!!----------------------------------------------------------------------
124
125	! In case of East-West periodicity, prevent AGRIF interpolation at east and west boundaries
126	! The procnames will not be called at these boundaries
127	IF (jperio == 1) THEN
128	CALL Agrif_Set_NearCommonBorderX(.TRUE.)
129	CALL Agrif_Set_DistantCommonBorderX(.TRUE.)
130	ENDIF
131
132	IF ( .NOT. lk_south ) THEN
133	CALL Agrif_Set_NearCommonBorderY(.TRUE.)
134	ENDIF
135
136	! 1. Declaration of the type of variable which have to be interpolated
137	!---------------------------------------------------------------------
138	ind1 = nbghostcells
139	ind2 = nn_hls + 2 + nbghostcells_x
140	ind3 = nn_hls + 2 + nbghostcells_y_s
141
142	CALL agrif_declare_variable((/2,2,0 /),(/ind2 ,ind3,0 /),(/'x','y','N' /),(/1,1,1 /),(/jpi,jpj,jpk /), e3t_id)
143	CALL agrif_declare_variable((/2,2 /),(/ind2 ,ind3 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /), mbkt_id)
144	CALL agrif_declare_variable((/2,2 /),(/ind2 ,ind3 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /), ht0_id)
145
146	CALL agrif_declare_variable((/1,2 /),(/ind2-1,ind3 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /), e1u_id)
147	CALL agrif_declare_variable((/2,1 /),(/ind2 ,ind3-1 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /), e2v_id)
148
149	! Initial or restart velues
150	its = jpts+1
151	CALL agrif_declare_variable((/2,2,0,0/),(/ind2 ,ind3 ,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,its/), tsini_id)
152	CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3 ,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2 /), uini_id)
153	CALL agrif_declare_variable((/2,1,0,0/),(/ind2 ,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2 /), vini_id)
154	CALL agrif_declare_variable((/2,2 /),(/ind2 ,ind3 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /),sshini_id)
155	!
156
157	! 2. Type of interpolation
158	!-------------------------
159	CALL Agrif_Set_bcinterp( e3t_id,interp =AGRIF_constant)
160
161	CALL Agrif_Set_bcinterp( mbkt_id,interp =AGRIF_constant)
162	CALL Agrif_Set_interp ( mbkt_id,interp =AGRIF_constant)
163	CALL Agrif_Set_bcinterp( ht0_id,interp =AGRIF_constant)
164	CALL Agrif_Set_interp ( ht0_id,interp =AGRIF_constant)
165
166	CALL Agrif_Set_bcinterp( e1u_id,interp1=Agrif_linear, interp2=AGRIF_ppm )
167	CALL Agrif_Set_bcinterp( e2v_id,interp1=AGRIF_ppm , interp2=Agrif_linear )
168
169	! Initial fields
170	CALL Agrif_Set_bcinterp( tsini_id,interp =AGRIF_linear )
171	CALL Agrif_Set_interp ( tsini_id,interp =AGRIF_linear )
172	CALL Agrif_Set_bcinterp( uini_id,interp =AGRIF_linear )
173	CALL Agrif_Set_interp ( uini_id,interp =AGRIF_linear )
174	CALL Agrif_Set_bcinterp( vini_id,interp =AGRIF_linear )
175	CALL Agrif_Set_interp ( vini_id,interp =AGRIF_linear )
176	CALL Agrif_Set_bcinterp(sshini_id,interp =AGRIF_linear )
177	CALL Agrif_Set_interp (sshini_id,interp =AGRIF_linear )
178
179	! 3. Location of interpolation
180	!-----------------------------
181	! CALL Agrif_Set_bc( e3t_id, (/-nn_sponge_len*Agrif_irhox(),ind1-1/) )
182	! JC: check near the boundary only until matching in sponge has been sorted out:
183	CALL Agrif_Set_bc( e3t_id, (/0,ind1-1/) )
184
185	! extend the interpolation zone by 1 more point than necessary:
186	! RB check here
187	CALL Agrif_Set_bc( mbkt_id, (/-nn_sponge_len*Agrif_irhox()-2,ind1/) )
188	CALL Agrif_Set_bc( ht0_id, (/-nn_sponge_len*Agrif_irhox()-2,ind1/) )
189
190	CALL Agrif_Set_bc( e1u_id, (/0,ind1-1/) )
191	CALL Agrif_Set_bc( e2v_id, (/0,ind1-1/) )
192
193	CALL Agrif_Set_bc( tsini_id, (/0,ind1-1/) ) ! if west, rhox=3 and nbghost=3: columns 2 to 4
194	CALL Agrif_Set_bc( uini_id, (/0,ind1-1/) )
195	CALL Agrif_Set_bc( vini_id, (/0,ind1-1/) )
196	CALL Agrif_Set_bc( sshini_id, (/0,ind1-1/) )
197
198	! 4. Update type
199	!---------------
200	# if defined UPD_HIGH
201	CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Average , update2=Agrif_Update_Full_Weighting)
202	CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Full_Weighting, update2=Agrif_Update_Average )
203	#else
204	CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy , update2=Agrif_Update_Average )
205	CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average , update2=Agrif_Update_Copy )
206	#endif
207
208	! CALL Agrif_Set_ExternalMapping(nemo_mapping)
209	!
210	END SUBROUTINE agrif_declare_var_ini
211
212
213	SUBROUTINE Agrif_Init_Domain( Kbb, Kmm, Kaa )
214	!!----------------------------------------------------------------------
215	!! * ROUTINE Agrif_Init_Domain *
216	!!----------------------------------------------------------------------
217	USE agrif_oce_update
218	USE agrif_oce_interp
219	USE agrif_oce_sponge
220	USE Agrif_Util
221	USE oce
222	USE dom_oce
223	USE zdf_oce
224	USE nemogcm
225	USE agrif_oce
226	!
227	USE lbclnk
228	USE lib_mpp
229	USE in_out_manager
230	!
231	IMPLICIT NONE
232	!
233	INTEGER, INTENT(in) :: Kbb, Kmm, Kaa
234	!
235	LOGICAL :: check_namelist
236	CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3, cl_check4
237	REAL(wp), DIMENSION(jpi,jpj) :: zk ! workspace
238	INTEGER :: ji, jj, jk
239	!!----------------------------------------------------------------------
240
241	! CALL Agrif_Declare_Var_ini
242
243	IF( agrif_oce_alloc() > 0 ) CALL ctl_warn('agrif agrif_oce_alloc: allocation of arrays failed')
244
245	! Build consistent parent bathymetry and number of levels
246	! on the child grid
247	Agrif_UseSpecialValue = .FALSE.
248	ht0_parent( :,:) = 0._wp
249	mbkt_parent(:,:) = 0
250	!
251	! CALL Agrif_Bc_variable(ht0_id ,calledweight=1.,procname=interpht0 )
252	! CALL Agrif_Bc_variable(mbkt_id,calledweight=1.,procname=interpmbkt)
253	CALL Agrif_Init_Variable(ht0_id , procname=interpht0 )
254	CALL Agrif_Init_Variable(mbkt_id, procname=interpmbkt)
255	!
256	! Assume step wise change of bathymetry near interface
257	! TODO: Switch to linear interpolation of bathymetry in the s-coordinate case
258	! and no refinement
259	DO_2D( 1, 0, 1, 0 )
260	mbku_parent(ji,jj) = MIN( mbkt_parent(ji+1,jj ), mbkt_parent(ji,jj) )
261	mbkv_parent(ji,jj) = MIN( mbkt_parent(ji ,jj+1), mbkt_parent(ji,jj) )
262	END_2D
263	IF ( ln_sco.AND.Agrif_Parent(ln_sco) ) THEN
264	DO_2D( 1, 0, 1, 0 )
265	hu0_parent(ji,jj) = 0.5_wp * ( ht0_parent(ji,jj)+ht0_parent(ji+1,jj) )
266	hv0_parent(ji,jj) = 0.5_wp * ( ht0_parent(ji,jj)+ht0_parent(ji,jj+1) )
267	END_2D
268	ELSE
269	DO_2D( 1, 0, 1, 0 )
270	hu0_parent(ji,jj) = MIN( ht0_parent(ji,jj), ht0_parent(ji+1,jj) )
271	hv0_parent(ji,jj) = MIN( ht0_parent(ji,jj), ht0_parent(ji,jj+1) )
272	END_2D
273	ENDIF
274	!
275	CALL lbc_lnk_multi( 'Agrif_Init_Domain', hu0_parent, 'U', 1.0_wp, hv0_parent, 'V', 1.0_wp )
276	DO_2D( 0, 0, 0, 0 )
277	zk(ji,jj) = REAL( mbku_parent(ji,jj), wp )
278	END_2D
279	CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'U', 1.0_wp )
280	mbku_parent(:,:) = MAX( NINT( zk(:,:) ), 1 )
281	DO_2D( 0, 0, 0, 0 )
282	zk(ji,jj) = REAL( mbkv_parent(ji,jj), wp )
283	END_2D
284	CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'V', 1.0_wp )
285	mbkv_parent(:,:) = MAX( NINT( zk(:,:) ), 1 )
286
287	IF ( ln_init_chfrpar ) THEN
288	CALL Agrif_Init_Variable(sshini_id, procname=agrif_initssh)
289	CALL lbc_lnk( 'Agrif_Init_Domain', ssh(:,:,Kbb), 'T', 1. )
290	#if ! defined key_qco
291	DO jk = 1, jpk
292	e3t(:,:,jk,Kbb) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kbb) ) &
293	& / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) &
294	& + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) )
295	END DO
296	#endif
297	ENDIF
298
299	! check if masks and bathymetries match
300	IF(ln_chk_bathy) THEN
301	Agrif_UseSpecialValue = .FALSE.
302	!
303	IF(lwp) WRITE(numout,*) ' '
304	IF(lwp) WRITE(numout,*) 'AGRIF: Check Bathymetry and masks near bdys. Level: ', Agrif_Level()
305	!
306	kindic_agr = 0
307	IF( .NOT. l_vremap ) THEN
308	!
309	! check if tmask and vertical scale factors agree with parent in sponge area:
310	CALL Agrif_Bc_variable(e3t_id,calledweight=1.,procname=interpe3t)
311	!
312	ELSE
313	!
314	! In case of vertical interpolation, check only that total depths agree between child and parent:
315	DO ji = 1, jpi
316	DO jj = 1, jpj
317	IF ((mbkt_parent(ji,jj)/=0).AND.(ABS(ht0_parent(ji,jj)-ht_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1
318	IF ((mbku_parent(ji,jj)/=0).AND.(ABS(hu0_parent(ji,jj)-hu_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1
319	IF ((mbkv_parent(ji,jj)/=0).AND.(ABS(hv0_parent(ji,jj)-hv_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1
320	END DO
321	END DO
322
323	CALL mpp_sum( 'agrif_user', kindic_agr )
324	IF( kindic_agr /= 0 ) THEN
325	CALL ctl_stop('==> Child Bathymetry is NOT correct near boundaries.')
326	ELSE
327	IF(lwp) WRITE(numout,*) '==> Child Bathymetry is ok near boundaries.'
328	IF(lwp) WRITE(numout,*) ' '
329	ENDIF
330	ENDIF
331	ENDIF
332
333	IF( l_vremap ) THEN
334	! Additional constrain that should be removed someday:
335	IF ( Agrif_Parent(jpk).GT.jpk ) THEN
336	CALL ctl_stop( ' With l_vremap, child grids must have jpk greater or equal to the parent value' )
337	ENDIF
338	ENDIF
339	!
340	END SUBROUTINE Agrif_Init_Domain
341
342
343	SUBROUTINE Agrif_InitValues_cont
344	!!----------------------------------------------------------------------
345	!! * ROUTINE Agrif_InitValues_cont *
346	!!
347	!! ** Purpose :: Declaration of variables to be interpolated
348	!!----------------------------------------------------------------------
349	USE agrif_oce_update
350	USE agrif_oce_interp
351	USE agrif_oce_sponge
352	USE Agrif_Util
353	USE oce
354	USE dom_oce
355	USE zdf_oce
356	USE nemogcm
357	USE agrif_oce
358	!
359	USE lbclnk
360	USE lib_mpp
361	USE in_out_manager
362	!
363	IMPLICIT NONE
364	!
365	LOGICAL :: check_namelist
366	CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3, cl_check4
367	REAL(wp), DIMENSION(jpi,jpj) :: zk ! workspace
368	INTEGER :: ji, jj
369
370	! 1. Declaration of the type of variable which have to be interpolated
371	!---------------------------------------------------------------------
372	CALL agrif_declare_var
373
374	! 2. First interpolations of potentially non zero fields
375	!-------------------------------------------------------
376	Agrif_SpecialValue = 0._wp
377	Agrif_UseSpecialValue = .TRUE.
378	CALL Agrif_Bc_variable( tsn_id,calledweight=1.,procname=interptsn)
379	CALL Agrif_Sponge
380	tabspongedone_tsn = .FALSE.
381	CALL Agrif_Bc_variable(tsn_sponge_id,calledweight=1.,procname=interptsn_sponge)
382	! reset tsa to zero
383	ts(:,:,:,:,Krhs_a) = 0._wp
384
385	Agrif_UseSpecialValue = ln_spc_dyn
386	use_sign_north = .TRUE.
387	sign_north = -1.
388	CALL Agrif_Bc_variable(un_interp_id,calledweight=1.,procname=interpun)
389	CALL Agrif_Bc_variable(vn_interp_id,calledweight=1.,procname=interpvn)
390	tabspongedone_u = .FALSE.
391	tabspongedone_v = .FALSE.
392	CALL Agrif_Bc_variable(un_sponge_id,calledweight=1.,procname=interpun_sponge)
393	tabspongedone_u = .FALSE.
394	tabspongedone_v = .FALSE.
395	CALL Agrif_Bc_variable(vn_sponge_id,calledweight=1.,procname=interpvn_sponge)
396	use_sign_north = .FALSE.
397	uu(:,:,:,Krhs_a) = 0._wp
398	vv(:,:,:,Krhs_a) = 0._wp
399
400	Agrif_UseSpecialValue = .TRUE.
401	CALL Agrif_Bc_variable(sshn_id,calledweight=1., procname=interpsshn )
402	hbdy(:,:) = 0._wp
403	ssh(:,:,Krhs_a) = 0._wp
404
405	IF ( ln_dynspg_ts ) THEN
406	Agrif_UseSpecialValue = ln_spc_dyn
407	use_sign_north = .TRUE.
408	sign_north = -1.
409	CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b) ! must be called before unb_id to define ubdy
410	CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b) ! must be called before vnb_id to define vbdy
411	CALL Agrif_Bc_variable( unb_id,calledweight=1.,procname=interpunb )
412	CALL Agrif_Bc_variable( vnb_id,calledweight=1.,procname=interpvnb )
413	use_sign_north = .FALSE.
414	ubdy(:,:) = 0._wp
415	vbdy(:,:) = 0._wp
416	ENDIF
417	Agrif_UseSpecialValue = .FALSE.
418
419	!-----------------
420	check_namelist = .TRUE.
421
422	IF( check_namelist ) THEN
423	! Check free surface scheme
424	IF ( ( Agrif_Parent(ln_dynspg_ts ).AND.ln_dynspg_exp ).OR.&
425	& ( Agrif_Parent(ln_dynspg_exp).AND.ln_dynspg_ts ) ) THEN
426	WRITE(cl_check1,*) Agrif_Parent( ln_dynspg_ts )
427	WRITE(cl_check2,*) ln_dynspg_ts
428	WRITE(cl_check3,*) Agrif_Parent( ln_dynspg_exp )
429	WRITE(cl_check4,*) ln_dynspg_exp
430	CALL ctl_stop( 'Incompatible free surface scheme between grids' , &
431	& 'parent grid ln_dynspg_ts :'//cl_check1 , &
432	& 'child grid ln_dynspg_ts :'//cl_check2 , &
433	& 'parent grid ln_dynspg_exp :'//cl_check3 , &
434	& 'child grid ln_dynspg_exp :'//cl_check4 , &
435	& 'those logicals should be identical' )
436	STOP
437	ENDIF
438
439	! Check if identical linear free surface option
440	IF ( ( Agrif_Parent(ln_linssh ).AND.(.NOT.ln_linssh )).OR.&
441	& ( (.NOT.Agrif_Parent(ln_linssh)).AND.ln_linssh ) ) THEN
442	WRITE(cl_check1,*) Agrif_Parent(ln_linssh )
443	WRITE(cl_check2,*) ln_linssh
444	CALL ctl_stop( 'Incompatible linearized fs option between grids', &
445	& 'parent grid ln_linssh :'//cl_check1 , &
446	& 'child grid ln_linssh :'//cl_check2 , &
447	& 'those logicals should be identical' )
448	STOP
449	ENDIF
450	ENDIF
451
452	END SUBROUTINE Agrif_InitValues_cont
453
454	SUBROUTINE agrif_declare_var
455	!!----------------------------------------------------------------------
456	!! * ROUTINE agrif_declare_var *
457	!!----------------------------------------------------------------------
458	USE agrif_util
459	USE agrif_oce
460	USE par_oce
461	USE zdf_oce
462	USE oce
463	!
464	IMPLICIT NONE
465	!
466	INTEGER :: ind1, ind2, ind3
467	!!----------------------------------------------------------------------
468
469	! 1. Declaration of the type of variable which have to be interpolated
470	!---------------------------------------------------------------------
471	ind1 = nbghostcells
472	ind2 = nn_hls + 2 + nbghostcells_x
473	ind3 = nn_hls + 2 + nbghostcells_y_s
474	# if defined key_vertical
475	CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts+1/),tsn_id)
476	CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts+1/),tsn_sponge_id)
477	CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),un_interp_id)
478	CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),vn_interp_id)
479	CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),un_update_id)
480	CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),vn_update_id)
481	CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),un_sponge_id)
482	CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),vn_sponge_id)
483	# else
484	CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsn_id)
485	CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsn_sponge_id)
486	CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),un_interp_id)
487	CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),vn_interp_id)
488	CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),un_update_id)
489	CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),vn_update_id)
490	CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),un_sponge_id)
491	CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),vn_sponge_id)
492	# endif
493	CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),unb_id)
494	CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vnb_id)
495	CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_interp_id)
496	CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_interp_id)
497	CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_update_id)
498	CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_update_id)
499
500	! CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),glamt_id)
501	! CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gphit_id)
502	CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),sshn_id)
503
504
505	IF( ln_zdftke.OR.ln_zdfgls ) THEN ! logical not known at this point
506	! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id)
507	! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id)
508	# if defined key_vertical
509	CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),avm_id)
510	# else
511	CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),avm_id)
512	# endif
513	ENDIF
514
515	! 2. Type of interpolation
516	!-------------------------
517	CALL Agrif_Set_bcinterp( tsn_id,interp =AGRIF_linear)
518	CALL Agrif_Set_bcinterp( un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm )
519	CALL Agrif_Set_bcinterp( vn_interp_id,interp1=AGRIF_ppm ,interp2=Agrif_linear)
520
521	CALL Agrif_Set_bcinterp( tsn_sponge_id,interp =AGRIF_linear)
522	CALL Agrif_Set_bcinterp( un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm )
523	CALL Agrif_Set_bcinterp( vn_sponge_id,interp1=AGRIF_ppm ,interp2=Agrif_linear)
524
525	CALL Agrif_Set_bcinterp( sshn_id,interp =AGRIF_linear)
526	CALL Agrif_Set_bcinterp( unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm )
527	CALL Agrif_Set_bcinterp( vnb_id,interp1=AGRIF_ppm ,interp2=Agrif_linear)
528	CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm )
529	CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm ,interp2=Agrif_linear)
530	!
531	! > Divergence conserving alternative:
532	! CALL Agrif_Set_bcinterp(sshn_id,interp=AGRIF_constant)
533	! CALL Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_constant)
534	! CALL Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_constant,interp2=Agrif_linear)
535	! CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_constant)
536	! CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_constant,interp2=Agrif_linear)
537	!<
538
539	IF( ln_zdftke.OR.ln_zdfgls ) CALL Agrif_Set_bcinterp( avm_id, interp=AGRIF_linear )
540
541
542	! CALL Agrif_Set_bcinterp(gphit_id,interp=AGRIF_constant)
543	! CALL Agrif_Set_bcinterp(glamt_id,interp=AGRIF_constant)
544
545	! 3. Location of interpolation
546	!-----------------------------
547	CALL Agrif_Set_bc( tsn_id, (/0,ind1-1/) ) ! if west, rhox=3 and nbghost=3: columns 2 to 4
548	CALL Agrif_Set_bc( un_interp_id, (/0,ind1-1/) )
549	CALL Agrif_Set_bc( vn_interp_id, (/0,ind1-1/) )
550
551	CALL Agrif_Set_bc( tsn_sponge_id, (/-nn_sponge_len*Agrif_irhox()-1,0/) ) ! if west, rhox=3, nn_sponge_len=2
552	CALL Agrif_Set_bc( un_sponge_id, (/-nn_sponge_len*Agrif_irhox()-1,0/) ) ! and nbghost=3:
553	CALL Agrif_Set_bc( vn_sponge_id, (/-nn_sponge_len*Agrif_irhox()-1,0/) ) ! columns 4 to 11
554
555	CALL Agrif_Set_bc( sshn_id, (/0,ind1-1/) )
556	CALL Agrif_Set_bc( unb_id, (/0,ind1-1/) )
557	CALL Agrif_Set_bc( vnb_id, (/0,ind1-1/) )
558	CALL Agrif_Set_bc( ub2b_interp_id, (/0,ind1-1/) )
559	CALL Agrif_Set_bc( vb2b_interp_id, (/0,ind1-1/) )
560
561	IF( ln_zdftke.OR.ln_zdfgls ) CALL Agrif_Set_bc( avm_id, (/0,ind1/) )
562	!!$ CALL Agrif_Set_bc(glamt_id, (/0,ind1-1/) )
563	!!$ CALL Agrif_Set_bc(gphit_id, (/0,ind1-1/) )
564
565	! 4. Update type
566	!---------------
567
568	# if defined UPD_HIGH
569	CALL Agrif_Set_Updatetype( tsn_id,update = Agrif_Update_Full_Weighting)
570	CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting)
571	CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average )
572
573	CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting)
574	CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average )
575	CALL Agrif_Set_Updatetype( sshn_id,update = Agrif_Update_Full_Weighting)
576	CALL Agrif_Set_Updatetype( e3t_id,update = Agrif_Update_Full_Weighting)
577
578	! IF( ln_zdftke.OR.ln_zdfgls ) THEN
579	! CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Full_Weighting)
580	! CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Full_Weighting)
581	! CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Full_Weighting)
582	! ENDIF
583
584	#else
585	CALL Agrif_Set_Updatetype( tsn_id, update = AGRIF_Update_Average)
586	CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average)
587	CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy )
588
589	CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average)
590	CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy )
591	CALL Agrif_Set_Updatetype( sshn_id,update = AGRIF_Update_Average)
592	CALL Agrif_Set_Updatetype( e3t_id,update = AGRIF_Update_Average)
593
594	! IF( ln_zdftke.OR.ln_zdfgls ) THEN
595	! CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Average)
596	! CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average)
597	! CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average)
598	! ENDIF
599
600	#endif
601	!
602	END SUBROUTINE agrif_declare_var
603
604	#if defined key_si3
605	SUBROUTINE Agrif_InitValues_cont_ice
606	!!----------------------------------------------------------------------
607	!! * ROUTINE Agrif_InitValues_cont_ice *
608	!!----------------------------------------------------------------------
609	USE Agrif_Util
610	USE sbc_oce, ONLY : nn_fsbc ! clem: necessary otherwise Agrif_Parent(nn_fsbc) = nn_fsbc
611	USE ice
612	USE agrif_ice
613	USE in_out_manager
614	USE agrif_ice_interp
615	USE lib_mpp
616	!
617	IMPLICIT NONE
618	!
619	!!----------------------------------------------------------------------
620	! Controls
621
622	! clem: For some reason, nn_fsbc(child)/=1 does not work properly (signal can be largely degraded by the agrif zoom)
623	! the run must satisfy CFL=Uice/(dx/dt) < 0.6/nn_fsbc(child)
624	! therefore, if nn_fsbc(child)>1 one must reduce the time-step in proportion to nn_fsbc(child), which is not acceptable
625	! If a solution is found, the following stop could be removed because the rest of the code take nn_fsbc(child) into account
626	IF( nn_fsbc > 1 ) CALL ctl_stop('nn_fsbc(child) must be set to 1 otherwise agrif and sea-ice may not work properly')
627
628	! stop if rhot * nn_fsbc(parent) /= N * nn_fsbc(child) with N being integer
629	IF( MOD( Agrif_irhot() * Agrif_Parent(nn_fsbc), nn_fsbc ) /= 0 ) THEN
630	CALL ctl_stop('rhot * nn_fsbc(parent) /= N * nn_fsbc(child), therefore nn_fsbc(child) should be set to 1 or nn_fsbc(parent)')
631	ENDIF
632	! First Interpolations (using "after" ice subtime step => nbstep_ice=1)
633	!----------------------------------------------------------------------
634	nbstep_ice = ( Agrif_irhot() * Agrif_Parent(nn_fsbc) / nn_fsbc ) ! clem: to have calledweight=1 in interp (otherwise the western border of the zoom is wrong)
635	CALL agrif_interp_ice('U') ! interpolation of ice velocities
636	CALL agrif_interp_ice('V') ! interpolation of ice velocities
637	CALL agrif_interp_ice('T') ! interpolation of ice tracers
638	nbstep_ice = 0
639	!
640	END SUBROUTINE Agrif_InitValues_cont_ice
641
642
643	SUBROUTINE agrif_declare_var_ice
644	!!----------------------------------------------------------------------
645	!! * ROUTINE agrif_declare_var_ice *
646	!!----------------------------------------------------------------------
647	USE Agrif_Util
648	USE ice
649	USE par_oce, ONLY : nbghostcells, nbghostcells_x, nbghostcells_y_s
650	!
651	IMPLICIT NONE
652	!
653	INTEGER :: ind1, ind2, ind3
654	INTEGER :: ipl
655	!!----------------------------------------------------------------------
656	!
657	! 1. Declaration of the type of variable which have to be interpolated (parent=>child)
658	! agrif_declare_variable(position,1st point index,--,--,dimensions,name)
659	! ex.: position=> 1,1 = not-centered (in i and j)
660	! 2,2 = centered ( - )
661	! index => 1,1 = one ghost line
662	! 2,2 = two ghost lines
663	!-------------------------------------------------------------------------------------
664	ind1 = nbghostcells
665	ind2 = nn_hls + 2 + nbghostcells_x
666	ind3 = nn_hls + 2 + nbghostcells_y_s
667	ipl = jpl*(9+nlay_s+nlay_i)
668	CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,ipl/),tra_ice_id)
669	CALL agrif_declare_variable((/1,2/) ,(/ind2-1,ind3/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), u_ice_id)
670	CALL agrif_declare_variable((/2,1/) ,(/ind2,ind3-1/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), v_ice_id)
671
672	CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,ipl/),tra_iceini_id)
673	CALL agrif_declare_variable((/1,2/) ,(/ind2-1,ind3/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), u_iceini_id)
674	CALL agrif_declare_variable((/2,1/) ,(/ind2,ind3-1/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), v_iceini_id)
675
676	! 2. Set interpolations (normal & tangent to the grid cell for velocities)
677	!-----------------------------------
678	CALL Agrif_Set_bcinterp(tra_ice_id, interp = AGRIF_linear)
679	CALL Agrif_Set_bcinterp(u_ice_id , interp1 = Agrif_linear,interp2 = AGRIF_ppm )
680	CALL Agrif_Set_bcinterp(v_ice_id , interp1 = AGRIF_ppm ,interp2 = Agrif_linear)
681
682	CALL Agrif_Set_bcinterp(tra_iceini_id, interp = AGRIF_linear)
683	CALL Agrif_Set_interp (tra_iceini_id, interp = AGRIF_linear)
684	CALL Agrif_Set_bcinterp(u_iceini_id , interp = AGRIF_linear )
685	CALL Agrif_Set_interp (u_iceini_id , interp = AGRIF_linear )
686	CALL Agrif_Set_bcinterp(v_iceini_id , interp = AGRIF_linear)
687	CALL Agrif_Set_interp (v_iceini_id , interp = AGRIF_linear)
688
689	! 3. Set location of interpolations
690	!----------------------------------
691	CALL Agrif_Set_bc(tra_ice_id,(/0,ind1/))
692	CALL Agrif_Set_bc(u_ice_id ,(/0,ind1/))
693	CALL Agrif_Set_bc(v_ice_id ,(/0,ind1/))
694
695	CALL Agrif_Set_bc(tra_iceini_id,(/0,ind1/))
696	CALL Agrif_Set_bc(u_iceini_id ,(/0,ind1/))
697	CALL Agrif_Set_bc(v_iceini_id ,(/0,ind1/))
698
699	! 4. Set update type in case 2 ways (child=>parent) (normal & tangent to the grid cell for velocities)
700	!--------------------------------------------------
701	# if defined UPD_HIGH
702	CALL Agrif_Set_Updatetype(tra_ice_id, update = Agrif_Update_Full_Weighting)
703	CALL Agrif_Set_Updatetype(u_ice_id , update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting)
704	CALL Agrif_Set_Updatetype(v_ice_id , update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average )
705	# else
706	CALL Agrif_Set_Updatetype(tra_ice_id, update = AGRIF_Update_Average)
707	CALL Agrif_Set_Updatetype(u_ice_id , update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average)
708	CALL Agrif_Set_Updatetype(v_ice_id , update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy )
709	# endif
710
711	END SUBROUTINE agrif_declare_var_ice
712	#endif
713
714
715	# if defined key_top
716	SUBROUTINE Agrif_InitValues_cont_top
717	!!----------------------------------------------------------------------
718	!! * ROUTINE Agrif_InitValues_cont_top *
719	!!----------------------------------------------------------------------
720	USE Agrif_Util
721	USE oce
722	USE dom_oce
723	USE nemogcm
724	USE par_trc
725	USE lib_mpp
726	USE trc
727	USE in_out_manager
728	USE agrif_oce_sponge
729	USE agrif_top_update
730	USE agrif_top_interp
731	USE agrif_top_sponge
732	!
733	IMPLICIT NONE
734	!
735	CHARACTER(len=10) :: cl_check1, cl_check2, cl_check3
736	LOGICAL :: check_namelist
737	!!----------------------------------------------------------------------
738
739	! 1. Declaration of the type of variable which have to be interpolated
740	!---------------------------------------------------------------------
741	CALL agrif_declare_var_top
742
743	! 2. First interpolations of potentially non zero fields
744	!-------------------------------------------------------
745	Agrif_SpecialValue=0._wp
746	Agrif_UseSpecialValue = .TRUE.
747	CALL Agrif_Bc_variable(trn_id,calledweight=1.,procname=interptrn)
748	Agrif_UseSpecialValue = .FALSE.
749	CALL Agrif_Sponge
750	tabspongedone_trn = .FALSE.
751	CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge)
752	! reset tsa to zero
753	tra(:,:,:,:) = 0._wp
754
755	! 3. Some controls
756	!-----------------
757	check_namelist = .TRUE.
758
759	IF( check_namelist ) THEN
760	! Check time steps
761	IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN
762	WRITE(cl_check1,*) Agrif_Parent(rdt)
763	WRITE(cl_check2,*) rdt
764	WRITE(cl_check3,) rdtAgrif_Rhot()
765	CALL ctl_stop( 'incompatible time step between grids', &
766	& 'parent grid value : '//cl_check1 , &
767	& 'child grid value : '//cl_check2 , &
768	& 'value on child grid should be changed to &
769	& :'//cl_check3 )
770	ENDIF
771
772	! Check run length
773	IF( Agrif_IRhot() * (Agrif_Parent(nitend)- &
774	Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN
775	WRITE(cl_check1,) (Agrif_Parent(nit000)-1)Agrif_IRhot() + 1
776	WRITE(cl_check2,) Agrif_Parent(nitend) Agrif_IRhot()
777	CALL ctl_warn( 'incompatible run length between grids' , &
778	& ' nit000 on fine grid will be change to : '//cl_check1, &
779	& ' nitend on fine grid will be change to : '//cl_check2 )
780	nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1
781	nitend = Agrif_Parent(nitend) *Agrif_IRhot()
782	ENDIF
783	ENDIF
784	!
785	END SUBROUTINE Agrif_InitValues_cont_top
786
787
788	SUBROUTINE agrif_declare_var_top
789	!!----------------------------------------------------------------------
790	!! * ROUTINE agrif_declare_var_top *
791	!!----------------------------------------------------------------------
792	USE agrif_util
793	USE agrif_oce
794	USE dom_oce
795	USE trc
796	!!
797	IMPLICIT NONE
798	!
799	INTEGER :: ind1, ind2, ind3
800	!!----------------------------------------------------------------------
801	!RB_CMEMS : declare here init for top
802	! 1. Declaration of the type of variable which have to be interpolated
803	!---------------------------------------------------------------------
804	ind1 = nbghostcells
805	ind2 = nn_hls + 2 + nbghostcells_x
806	ind3 = nn_hls + 2 + nbghostcells_y_s
807	# if defined key_vertical
808	CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra+1/),trn_id)
809	CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra+1/),trn_sponge_id)
810	# else
811	! LAURENT: STRANGE why (3,3) here ?
812	CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trn_id)
813	CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trn_sponge_id)
814	# endif
815
816	! 2. Type of interpolation
817	!-------------------------
818	CALL Agrif_Set_bcinterp(trn_id,interp=AGRIF_linear)
819	CALL Agrif_Set_bcinterp(trn_sponge_id,interp=AGRIF_linear)
820
821	! 3. Location of interpolation
822	!-----------------------------
823	CALL Agrif_Set_bc(trn_id,(/0,ind1-1/))
824	CALL Agrif_Set_bc(trn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/))
825
826	! 4. Update type
827	!---------------
828	# if defined UPD_HIGH
829	CALL Agrif_Set_Updatetype(trn_id, update = Agrif_Update_Full_Weighting)
830	#else
831	CALL Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average)
832	#endif
833	!
834	END SUBROUTINE agrif_declare_var_top
835	# endif
836
837
838	SUBROUTINE Agrif_detect( kg, ksizex )
839	!!----------------------------------------------------------------------
840	!! * ROUTINE Agrif_detect *
841	!!----------------------------------------------------------------------
842	INTEGER, DIMENSION(2) :: ksizex
843	INTEGER, DIMENSION(ksizex(1),ksizex(2)) :: kg
844	!!----------------------------------------------------------------------
845	!
846	RETURN
847	!
848	END SUBROUTINE Agrif_detect
849
850
851	SUBROUTINE agrif_nemo_init
852	!!----------------------------------------------------------------------
853	!! * ROUTINE agrif_init *
854	!!----------------------------------------------------------------------
855	USE agrif_oce
856	USE agrif_ice
857	USE dom_oce
858	USE in_out_manager
859	USE lib_mpp
860	!
861	IMPLICIT NONE
862	!
863	INTEGER :: ios ! Local integer output status for namelist read
864	NAMELIST/namagrif/ ln_agrif_2way, ln_init_chfrpar, rn_sponge_tra, rn_sponge_dyn, rn_trelax_tra, rn_trelax_dyn, &
865	& ln_spc_dyn, ln_chk_bathy
866	!!--------------------------------------------------------------------------------------
867	!
868	READ ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901)
869	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist' )
870	READ ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 )
871	902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist' )
872	IF(lwm) WRITE ( numond, namagrif )
873	!
874	IF(lwp) THEN ! control print
875	WRITE(numout,*)
876	WRITE(numout,*) 'agrif_nemo_init : AGRIF parameters'
877	WRITE(numout,*) '~~~~~~~~~~~~~~~'
878	WRITE(numout,*) ' Namelist namagrif : set AGRIF parameters'
879	WRITE(numout,*) ' Two way nesting activated ln_agrif_2way = ', ln_agrif_2way
880	WRITE(numout,*) ' child initial state from parent ln_init_chfrpar = ', ln_init_chfrpar
881	WRITE(numout,*) ' ad. sponge coeft for tracers rn_sponge_tra = ', rn_sponge_tra
882	WRITE(numout,*) ' ad. sponge coeft for dynamics rn_sponge_tra = ', rn_sponge_dyn
883	WRITE(numout,*) ' ad. time relaxation for tracers rn_trelax_tra = ', rn_trelax_tra
884	WRITE(numout,*) ' ad. time relaxation for dynamics rn_trelax_dyn = ', rn_trelax_dyn
885	WRITE(numout,*) ' use special values for dynamics ln_spc_dyn = ', ln_spc_dyn
886	WRITE(numout,*) ' check bathymetry ln_chk_bathy = ', ln_chk_bathy
887	ENDIF
888
889	lk_west = .NOT. ( Agrif_Ix() == 1 )
890	lk_east = .NOT. ( Agrif_Ix() + nbcellsx/AGRIF_Irhox() == Agrif_Parent(jpiglo) -1 )
891	lk_south = .NOT. ( Agrif_Iy() == 1 )
892	lk_north = .NOT. ( Agrif_Iy() + nbcellsy/AGRIF_Irhoy() == Agrif_Parent(jpjglo) -1 )
893
894	!
895	! Set the number of ghost cells according to periodicity
896	nbghostcells_x = nbghostcells
897	nbghostcells_y_s = nbghostcells
898	nbghostcells_y_n = nbghostcells
899	!
900	IF( jperio == 1 ) nbghostcells_x = 0
901	IF( .NOT. lk_south ) nbghostcells_y_s = 0
902	! Some checks
903	IF( jpiglo /= nbcellsx + 2 + 2*nn_hls + nbghostcells_x + nbghostcells_x ) CALL ctl_stop( 'STOP', &
904	& 'agrif_nemo_init: Agrif children requires jpiglo == nbcellsx + 2 + 2nn_hls + 2nbghostcells_x' )
905	IF( jpjglo /= nbcellsy + 2 + 2*nn_hls + nbghostcells_y_s + nbghostcells_y_n ) CALL ctl_stop( 'STOP', &
906	& 'agrif_nemo_init: Agrif children requires jpjglo == nbcellsy + 2 + 2*nn_hls + nbghostcells_y_s + nbghostcells_y_n' )
907	IF( ln_use_jattr ) CALL ctl_stop( 'STOP', 'agrif_nemo_init:Agrif children requires ln_use_jattr = .false. ' )
908	!
909	END SUBROUTINE agrif_nemo_init
910
911
912	# if defined key_mpp_mpi
913	SUBROUTINE Agrif_InvLoc( indloc, nprocloc, i, indglob )
914	!!----------------------------------------------------------------------
915	!! * ROUTINE Agrif_InvLoc *
916	!!----------------------------------------------------------------------
917	USE dom_oce
918	!!
919	IMPLICIT NONE
920	!
921	INTEGER :: indglob, indloc, nprocloc, i
922	!!----------------------------------------------------------------------
923	!
924	SELECT CASE( i )
925	CASE(1) ; indglob = mig(indloc)
926	CASE(2) ; indglob = mjg(indloc)
927	CASE DEFAULT ; indglob = indloc
928	END SELECT
929	!
930	END SUBROUTINE Agrif_InvLoc
931
932
933	SUBROUTINE Agrif_get_proc_info( imin, imax, jmin, jmax )
934	!!----------------------------------------------------------------------
935	!! * ROUTINE Agrif_get_proc_info *
936	!!----------------------------------------------------------------------
937	USE par_oce
938	!!
939	IMPLICIT NONE
940	!
941	INTEGER, INTENT(out) :: imin, imax
942	INTEGER, INTENT(out) :: jmin, jmax
943	!!----------------------------------------------------------------------
944	!
945	imin = mig( 1 )
946	jmin = mjg( 1 )
947	imax = mig(jpi)
948	jmax = mjg(jpj)
949	!
950	END SUBROUTINE Agrif_get_proc_info
951
952
953	SUBROUTINE Agrif_estimate_parallel_cost(imin, imax,jmin, jmax, nbprocs, grid_cost)
954	!!----------------------------------------------------------------------
955	!! * ROUTINE Agrif_estimate_parallel_cost *
956	!!----------------------------------------------------------------------
957	USE par_oce
958	!!
959	IMPLICIT NONE
960	!
961	INTEGER, INTENT(in) :: imin, imax
962	INTEGER, INTENT(in) :: jmin, jmax
963	INTEGER, INTENT(in) :: nbprocs
964	REAL(wp), INTENT(out) :: grid_cost
965	!!----------------------------------------------------------------------
966	!
967	grid_cost = REAL(imax-imin+1,wp)*REAL(jmax-jmin+1,wp) / REAL(nbprocs,wp)
968	!
969	END SUBROUTINE Agrif_estimate_parallel_cost
970
971	# endif
972
973	SUBROUTINE nemo_mapping(ndim,ptx,pty,bounds,bounds_chunks,correction_required,nb_chunks)
974	!!----------------------------------------------------------------------
975	!! * ROUTINE Nemo_mapping *
976	!!----------------------------------------------------------------------
977	USE dom_oce
978	!!
979	IMPLICIT NONE
980	!
981	INTEGER :: ndim
982	INTEGER :: ptx, pty
983	INTEGER, DIMENSION(ndim,2,2) :: bounds
984	INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: bounds_chunks
985	LOGICAL, DIMENSION(:), ALLOCATABLE :: correction_required
986	INTEGER :: nb_chunks
987	!
988	INTEGER :: i
989
990	IF (agrif_debug_interp) THEN
991	DO i=1,ndim
992	WRITE(,) 'direction = ',i,bounds(i,1,2),bounds(i,2,2)
993	ENDDO
994	ENDIF
995
996	IF( bounds(2,2,2) > jpjglo) THEN
997	IF( bounds(2,1,2) <=jpjglo) THEN
998	nb_chunks = 2
999	ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
1000	ALLOCATE(correction_required(nb_chunks))
1001	DO i = 1,nb_chunks
1002	bounds_chunks(i,:,:,:) = bounds
1003	END DO
1004
1005	! FIRST CHUNCK (for j<=jpjglo)
1006
1007	! Original indices
1008	bounds_chunks(1,1,1,1) = bounds(1,1,2)
1009	bounds_chunks(1,1,2,1) = bounds(1,2,2)
1010	bounds_chunks(1,2,1,1) = bounds(2,1,2)
1011	bounds_chunks(1,2,2,1) = jpjglo
1012
1013	bounds_chunks(1,1,1,2) = bounds(1,1,2)
1014	bounds_chunks(1,1,2,2) = bounds(1,2,2)
1015	bounds_chunks(1,2,1,2) = bounds(2,1,2)
1016	bounds_chunks(1,2,2,2) = jpjglo
1017
1018	! Correction required or not
1019	correction_required(1)=.FALSE.
1020
1021	! SECOND CHUNCK (for j>jpjglo)
1022
1023	! Original indices
1024	bounds_chunks(2,1,1,1) = bounds(1,1,2)
1025	bounds_chunks(2,1,2,1) = bounds(1,2,2)
1026	bounds_chunks(2,2,1,1) = jpjglo-2
1027	bounds_chunks(2,2,2,1) = bounds(2,2,2)
1028
1029	! Where to find them
1030	! We use the relation TAB(ji,jj)=TAB(jpiglo-ji+2,jpjglo-2-(jj-jpjglo))
1031
1032	IF( ptx == 2) THEN ! T, V points
1033	bounds_chunks(2,1,1,2) = jpiglo-bounds(1,2,2)+2
1034	bounds_chunks(2,1,2,2) = jpiglo-bounds(1,1,2)+2
1035	ELSE ! U, F points
1036	bounds_chunks(2,1,1,2) = jpiglo-bounds(1,2,2)+1
1037	bounds_chunks(2,1,2,2) = jpiglo-bounds(1,1,2)+1
1038	ENDIF
1039
1040	IF( pty == 2) THEN ! T, U points
1041	bounds_chunks(2,2,1,2) = jpjglo-2-(bounds(2,2,2) -jpjglo)
1042	bounds_chunks(2,2,2,2) = jpjglo-2-(jpjglo-2 -jpjglo)
1043	ELSE ! V, F points
1044	bounds_chunks(2,2,1,2) = jpjglo-3-(bounds(2,2,2) -jpjglo)
1045	bounds_chunks(2,2,2,2) = jpjglo-3-(jpjglo-2 -jpjglo)
1046	ENDIF
1047	! Correction required or not
1048	correction_required(2)=.TRUE.
1049
1050	ELSE
1051	nb_chunks = 1
1052	ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
1053	ALLOCATE(correction_required(nb_chunks))
1054	DO i=1,nb_chunks
1055	bounds_chunks(i,:,:,:) = bounds
1056	END DO
1057
1058	bounds_chunks(1,1,1,1) = bounds(1,1,2)
1059	bounds_chunks(1,1,2,1) = bounds(1,2,2)
1060	bounds_chunks(1,2,1,1) = bounds(2,1,2)
1061	bounds_chunks(1,2,2,1) = bounds(2,2,2)
1062
1063	bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+2
1064	bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+2
1065
1066	bounds_chunks(1,2,1,2) = jpjglo-2-(bounds(2,2,2)-jpjglo)
1067	bounds_chunks(1,2,2,2) = jpjglo-2-(bounds(2,1,2)-jpjglo)
1068
1069	IF( ptx == 2) THEN ! T, V points
1070	bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+2
1071	bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+2
1072	ELSE ! U, F points
1073	bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+1
1074	bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+1
1075	ENDIF
1076
1077	IF (pty == 2) THEN ! T, U points
1078	bounds_chunks(1,2,1,2) = jpjglo-2-(bounds(2,2,2) -jpjglo)
1079	bounds_chunks(1,2,2,2) = jpjglo-2-(bounds(2,1,2) -jpjglo)
1080	ELSE ! V, F points
1081	bounds_chunks(1,2,1,2) = jpjglo-3-(bounds(2,2,2) -jpjglo)
1082	bounds_chunks(1,2,2,2) = jpjglo-3-(bounds(2,1,2) -jpjglo)
1083	ENDIF
1084
1085	correction_required(1)=.TRUE.
1086	ENDIF
1087
1088	ELSE IF (bounds(1,1,2) < 1) THEN
1089	IF (bounds(1,2,2) > 0) THEN
1090	nb_chunks = 2
1091	ALLOCATE(correction_required(nb_chunks))
1092	correction_required=.FALSE.
1093	ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
1094	DO i=1,nb_chunks
1095	bounds_chunks(i,:,:,:) = bounds
1096	END DO
1097
1098	bounds_chunks(1,1,1,2) = bounds(1,1,2)+jpiglo-2
1099	bounds_chunks(1,1,2,2) = 1+jpiglo-2
1100
1101	bounds_chunks(1,1,1,1) = bounds(1,1,2)
1102	bounds_chunks(1,1,2,1) = 1
1103
1104	bounds_chunks(2,1,1,2) = 2
1105	bounds_chunks(2,1,2,2) = bounds(1,2,2)
1106
1107	bounds_chunks(2,1,1,1) = 2
1108	bounds_chunks(2,1,2,1) = bounds(1,2,2)
1109
1110	ELSE
1111	nb_chunks = 1
1112	ALLOCATE(correction_required(nb_chunks))
1113	correction_required=.FALSE.
1114	ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
1115	DO i=1,nb_chunks
1116	bounds_chunks(i,:,:,:) = bounds
1117	END DO
1118	bounds_chunks(1,1,1,2) = bounds(1,1,2)+jpiglo-2
1119	bounds_chunks(1,1,2,2) = bounds(1,2,2)+jpiglo-2
1120
1121	bounds_chunks(1,1,1,1) = bounds(1,1,2)
1122	bounds_chunks(1,1,2,1) = bounds(1,2,2)
1123	ENDIF
1124	ELSE
1125	nb_chunks=1
1126	ALLOCATE(correction_required(nb_chunks))
1127	correction_required=.FALSE.
1128	ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
1129	DO i=1,nb_chunks
1130	bounds_chunks(i,:,:,:) = bounds
1131	END DO
1132	bounds_chunks(1,1,1,2) = bounds(1,1,2)
1133	bounds_chunks(1,1,2,2) = bounds(1,2,2)
1134	bounds_chunks(1,2,1,2) = bounds(2,1,2)
1135	bounds_chunks(1,2,2,2) = bounds(2,2,2)
1136
1137	bounds_chunks(1,1,1,1) = bounds(1,1,2)
1138	bounds_chunks(1,1,2,1) = bounds(1,2,2)
1139	bounds_chunks(1,2,1,1) = bounds(2,1,2)
1140	bounds_chunks(1,2,2,1) = bounds(2,2,2)
1141	ENDIF
1142
1143	END SUBROUTINE nemo_mapping
1144
1145	FUNCTION agrif_external_switch_index(ptx,pty,i1,isens)
1146
1147	USE dom_oce
1148	!
1149	IMPLICIT NONE
1150
1151	INTEGER :: ptx, pty, i1, isens
1152	INTEGER :: agrif_external_switch_index
1153	!!----------------------------------------------------------------------
1154
1155	IF( isens == 1 ) THEN
1156	IF( ptx == 2 ) THEN ! T, V points
1157	agrif_external_switch_index = jpiglo-i1+2
1158	ELSE ! U, F points
1159	agrif_external_switch_index = jpiglo-i1+1
1160	ENDIF
1161	ELSE IF( isens ==2 ) THEN
1162	IF ( pty == 2 ) THEN ! T, U points
1163	agrif_external_switch_index = jpjglo-2-(i1 -jpjglo)
1164	ELSE ! V, F points
1165	agrif_external_switch_index = jpjglo-3-(i1 -jpjglo)
1166	ENDIF
1167	ENDIF
1168
1169	END FUNCTION agrif_external_switch_index
1170
1171	SUBROUTINE Correct_field(tab2d,i1,i2,j1,j2)
1172	!!----------------------------------------------------------------------
1173	!! * ROUTINE Correct_field *
1174	!!----------------------------------------------------------------------
1175	USE dom_oce
1176	USE agrif_oce
1177	!
1178	IMPLICIT NONE
1179	!
1180	INTEGER :: i1,i2,j1,j2
1181	REAL(wp), DIMENSION(i1:i2,j1:j2) :: tab2d
1182	!
1183	INTEGER :: i,j
1184	REAL(wp), DIMENSION(i1:i2,j1:j2) :: tab2dtemp
1185	!!----------------------------------------------------------------------
1186
1187	tab2dtemp = tab2d
1188
1189	IF( .NOT. use_sign_north ) THEN
1190	DO j=j1,j2
1191	DO i=i1,i2
1192	tab2d(i,j)=tab2dtemp(i2-(i-i1),j2-(j-j1))
1193	END DO
1194	END DO
1195	ELSE
1196	DO j=j1,j2
1197	DO i=i1,i2
1198	tab2d(i,j)=sign_north * tab2dtemp(i2-(i-i1),j2-(j-j1))
1199	END DO
1200	END DO
1201	ENDIF
1202
1203	END SUBROUTINE Correct_field
1204
1205	#else
1206	SUBROUTINE Subcalledbyagrif
1207	!!----------------------------------------------------------------------
1208	!! * ROUTINE Subcalledbyagrif *
1209	!!----------------------------------------------------------------------
1210	WRITE(,) 'Impossible to be here'
1211	END SUBROUTINE Subcalledbyagrif
1212	#endif

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

Download in other formats: