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/trunk/src/NST – NEMO

Context Navigation

source: NEMO/trunk/src/NST/agrif_user.F90 @ 14201

Last change on this file since 14201 was 14170, checked in by jchanut, 3 years ago
#2222, 2129: 1) Corrected ssh initialization from parent in line with what has been introduced by Sibylle 2) Fixed bug in dyn interp with expliciit free surface 3) Added check on number of levels in child grid without vertical remapping (must be < jpk_parent) 4) Removed the constrain on initialization from parent only when starting from climatology (requires Euler first step though).
Property svn:keywords set to `Id`
File size: 52.2 KB

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

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

Download in other formats: