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_r12558_HPC-08_epico_Extra_Halo/src/NST – NEMO

Context Navigation

source: NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/NST/agrif_user.F90 @ 13229

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

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

Download in other formats: