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 @ 14117

Last change on this file since 14117 was 14086, checked in by cetlod, 3 years ago
Adding AGRIF branches into the trunk
Property svn:keywords set to `Id`
File size: 51.9 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( unb_interp_id,calledweight=1.,procname=interpunb )
368	CALL Agrif_Bc_variable( vnb_interp_id,calledweight=1.,procname=interpvnb )
369	CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b) ! must be called before unb_id to define ubdy
370	CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b) ! must be called before vnb_id to define vbdy
371	use_sign_north = .FALSE.
372	ubdy(:,:) = 0._wp
373	vbdy(:,:) = 0._wp
374	ELSE
375	Agrif_UseSpecialValue = ln_spc_dyn
376	use_sign_north = .TRUE.
377	sign_north = -1.
378	CALL Agrif_Bc_variable( unb_interp_id,calledweight=1.,procname=interpunb )
379	CALL Agrif_Bc_variable( vnb_interp_id,calledweight=1.,procname=interpvnb )
380	use_sign_north = .FALSE.
381	ubdy(:,:) = 0._wp
382	vbdy(:,:) = 0._wp
383	ENDIF
384	Agrif_UseSpecialValue = .FALSE.
385	l_vremap = .FALSE.
386
387	!-----------------
388	check_namelist = .TRUE.
389
390	IF( check_namelist ) THEN
391	! Check free surface scheme
392	IF ( ( Agrif_Parent(ln_dynspg_ts ).AND.ln_dynspg_exp ).OR.&
393	& ( Agrif_Parent(ln_dynspg_exp).AND.ln_dynspg_ts ) ) THEN
394	WRITE(cl_check1,*) Agrif_Parent( ln_dynspg_ts )
395	WRITE(cl_check2,*) ln_dynspg_ts
396	WRITE(cl_check3,*) Agrif_Parent( ln_dynspg_exp )
397	WRITE(cl_check4,*) ln_dynspg_exp
398	CALL ctl_stop( 'Incompatible free surface scheme between grids' , &
399	& 'parent grid ln_dynspg_ts :'//cl_check1 , &
400	& 'child grid ln_dynspg_ts :'//cl_check2 , &
401	& 'parent grid ln_dynspg_exp :'//cl_check3 , &
402	& 'child grid ln_dynspg_exp :'//cl_check4 , &
403	& 'those logicals should be identical' )
404	STOP
405	ENDIF
406
407	! Check if identical linear free surface option
408	IF ( ( Agrif_Parent(ln_linssh ).AND.(.NOT.ln_linssh )).OR.&
409	& ( (.NOT.Agrif_Parent(ln_linssh)).AND.ln_linssh ) ) THEN
410	WRITE(cl_check1,*) Agrif_Parent(ln_linssh )
411	WRITE(cl_check2,*) ln_linssh
412	CALL ctl_stop( 'Incompatible linearized fs option between grids', &
413	& 'parent grid ln_linssh :'//cl_check1 , &
414	& 'child grid ln_linssh :'//cl_check2 , &
415	& 'those logicals should be identical' )
416	STOP
417	ENDIF
418	ENDIF
419
420	END SUBROUTINE Agrif_InitValues_cont
421
422	SUBROUTINE agrif_declare_var
423	!!----------------------------------------------------------------------
424	!! * ROUTINE agrif_declare_var *
425	!!----------------------------------------------------------------------
426	USE agrif_util
427	USE agrif_oce
428	USE par_oce
429	USE zdf_oce
430	USE oce
431	!
432	IMPLICIT NONE
433	!
434	INTEGER :: ind1, ind2, ind3, imaxrho
435	!!----------------------------------------------------------------------
436
437	! 1. Declaration of the type of variable which have to be interpolated
438	!---------------------------------------------------------------------
439	ind1 = nbghostcells
440	ind2 = nn_hls + 2 + nbghostcells_x
441	ind3 = nn_hls + 2 + nbghostcells_y_s
442	imaxrho = MAX(Agrif_irhox(), Agrif_irhoy())
443
444	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)
445	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)
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_sponge_id)
447	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)
448	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)
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_update_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_update_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_sponge_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_sponge_id)
453
454	CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/) ,sshn_id)
455	CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/), unb_interp_id)
456	CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/), vnb_interp_id)
457	CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_interp_id)
458	CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_interp_id)
459	CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/), unb_sponge_id)
460	CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/), vnb_sponge_id)
461	CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_update_id)
462	CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_update_id)
463	CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/), unb_update_id)
464	CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/), vnb_update_id)
465	CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/) ,ub2b_cor_id)
466	CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/) ,vb2b_cor_id)
467	! CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),glamt_id)
468	! CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gphit_id)
469
470
471	IF( ln_zdftke.OR.ln_zdfgls ) THEN ! logical not known at this point
472	! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id)
473	! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id)
474	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)
475	ENDIF
476
477	! 2. Type of interpolation
478	!-------------------------
479	CALL Agrif_Set_bcinterp( ts_interp_id,interp =AGRIF_linear)
480	CALL Agrif_Set_bcinterp( ts_sponge_id,interp =AGRIF_linear)
481
482	#if defined DIV_CONS
483	lk_tint2d_notinterp = .TRUE.
484	CALL Agrif_Set_bcinterp(sshn_id,interp=AGRIF_constant)
485	CALL Agrif_Set_bcinterp(ub2b_cor_id,interp=AGRIF_constant)
486	CALL Agrif_Set_bcinterp(vb2b_cor_id,interp=AGRIF_constant)
487	CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_linearconserv)
488	CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_linearconserv,interp2=Agrif_linear)
489	#else
490	lk_tint2d_notinterp = .FALSE.
491	CALL Agrif_Set_bcinterp(sshn_id,interp =AGRIF_linear)
492	CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm)
493	CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear)
494	#endif
495
496	CALL Agrif_Set_bcinterp(unb_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm )
497	CALL Agrif_Set_bcinterp(vnb_interp_id,interp1=AGRIF_ppm ,interp2=Agrif_linear)
498	CALL Agrif_Set_bcinterp(unb_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm )
499	CALL Agrif_Set_bcinterp(vnb_sponge_id,interp1=AGRIF_ppm ,interp2=Agrif_linear)
500
501	CALL Agrif_Set_bcinterp(un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm )
502	CALL Agrif_Set_bcinterp(vn_interp_id,interp1=AGRIF_ppm ,interp2=Agrif_linear)
503
504	CALL Agrif_Set_bcinterp(un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm )
505	CALL Agrif_Set_bcinterp(vn_sponge_id,interp1=AGRIF_ppm ,interp2=Agrif_linear)
506
507	IF( ln_zdftke.OR.ln_zdfgls ) CALL Agrif_Set_bcinterp( avm_id, interp=AGRIF_linear )
508
509
510	! CALL Agrif_Set_bcinterp(gphit_id,interp=AGRIF_constant)
511	! CALL Agrif_Set_bcinterp(glamt_id,interp=AGRIF_constant)
512
513	! 3. Location of interpolation
514	!-----------------------------
515	CALL Agrif_Set_bc( ts_interp_id, (/0,ind1-1/) ) ! if west, rhox=3 and nbghost=3: columns 2 to 4
516	CALL Agrif_Set_bc( un_interp_id, (/0,ind1-1/) )
517	CALL Agrif_Set_bc( vn_interp_id, (/0,ind1-1/) )
518
519	CALL Agrif_Set_bc( ts_sponge_id, (/-nn_sponge_len*imaxrho-1,0/) ) ! if west, rhox=3, nn_sponge_len=2
520	CALL Agrif_Set_bc( un_sponge_id, (/-nn_sponge_len*imaxrho-1,0/) ) ! and nbghost=3:
521	CALL Agrif_Set_bc( vn_sponge_id, (/-nn_sponge_len*imaxrho-1,0/) ) ! columns 4 to 11
522
523	CALL Agrif_Set_bc( sshn_id, (/-imaxrho*nn_shift_bar,ind1-1/) )
524	CALL Agrif_Set_bc( unb_interp_id, (/-imaxrho*nn_shift_bar,ind1-1/) )
525	CALL Agrif_Set_bc( vnb_interp_id, (/-imaxrho*nn_shift_bar,ind1-1/) )
526	CALL Agrif_Set_bc(ub2b_interp_id, (/-imaxrho*nn_shift_bar,ind1-1/) )
527	CALL Agrif_Set_bc(vb2b_interp_id, (/-imaxrho*nn_shift_bar,ind1-1/) )
528	CALL Agrif_Set_bc( unb_sponge_id, (/-(nn_sponge_len+nn_shift_bar)imaxrho,-imaxrhonn_shift_bar/) )
529	CALL Agrif_Set_bc( vnb_sponge_id, (/-(nn_sponge_len+nn_shift_bar)imaxrho,-imaxrhonn_shift_bar/) )
530	CALL Agrif_Set_bc( ub2b_cor_id, (/-imaxrho*nn_shift_bar,ind1/) )
531	CALL Agrif_Set_bc( vb2b_cor_id, (/-imaxrho*nn_shift_bar,ind1/) )
532	IF( ln_zdftke.OR.ln_zdfgls ) CALL Agrif_Set_bc( avm_id, (/0,ind1/) )
533	!!$ CALL Agrif_Set_bc(glamt_id, (/0,ind1-1/) )
534	!!$ CALL Agrif_Set_bc(gphit_id, (/0,ind1-1/) )
535
536	! 4. Update type
537	!---------------
538
539	# if defined UPD_HIGH
540	CALL Agrif_Set_Updatetype( ts_interp_id,update = Agrif_Update_Full_Weighting)
541	CALL Agrif_Set_Updatetype( un_update_id,update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting)
542	CALL Agrif_Set_Updatetype( vn_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average )
543
544	CALL Agrif_Set_Updatetype( unb_update_id,update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting)
545	CALL Agrif_Set_Updatetype( vnb_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average )
546	CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting)
547	CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average )
548	CALL Agrif_Set_Updatetype( sshn_id,update = Agrif_Update_Full_Weighting)
549	CALL Agrif_Set_Updatetype( e3t_id,update = Agrif_Update_Full_Weighting)
550
551	! IF( ln_zdftke.OR.ln_zdfgls ) THEN
552	! CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Full_Weighting)
553	! CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Full_Weighting)
554	! CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Full_Weighting)
555	! ENDIF
556
557	#else
558	CALL Agrif_Set_Updatetype( ts_update_id,update = AGRIF_Update_Average)
559	CALL Agrif_Set_Updatetype( un_update_id,update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average)
560	CALL Agrif_Set_Updatetype( vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy )
561
562	CALL Agrif_Set_Updatetype( unb_update_id,update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average)
563	CALL Agrif_Set_Updatetype( vnb_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy )
564	CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average)
565	CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy )
566	CALL Agrif_Set_Updatetype( sshn_id,update = AGRIF_Update_Average)
567	CALL Agrif_Set_Updatetype( e3t_id,update = AGRIF_Update_Average)
568
569	! IF( ln_zdftke.OR.ln_zdfgls ) THEN
570	! CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Average)
571	! CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average)
572	! CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average)
573	! ENDIF
574
575	#endif
576	!
577	END SUBROUTINE agrif_declare_var
578
579	#if defined key_si3
580	SUBROUTINE Agrif_InitValues_cont_ice
581	!!----------------------------------------------------------------------
582	!! * ROUTINE Agrif_InitValues_cont_ice *
583	!!----------------------------------------------------------------------
584	USE Agrif_Util
585	USE sbc_oce, ONLY : nn_fsbc ! clem: necessary otherwise Agrif_Parent(nn_fsbc) = nn_fsbc
586	USE ice
587	USE agrif_ice
588	USE in_out_manager
589	USE agrif_ice_interp
590	USE lib_mpp
591	!
592	IMPLICIT NONE
593	!
594	!!----------------------------------------------------------------------
595	! Controls
596
597	! clem: For some reason, nn_fsbc(child)/=1 does not work properly (signal can be largely degraded by the agrif zoom)
598	! the run must satisfy CFL=Uice/(dx/dt) < 0.6/nn_fsbc(child)
599	! therefore, if nn_fsbc(child)>1 one must reduce the time-step in proportion to nn_fsbc(child), which is not acceptable
600	! If a solution is found, the following stop could be removed because the rest of the code take nn_fsbc(child) into account
601	IF( nn_fsbc > 1 ) CALL ctl_stop('nn_fsbc(child) must be set to 1 otherwise agrif and sea-ice may not work properly')
602
603	! stop if rhot * nn_fsbc(parent) /= N * nn_fsbc(child) with N being integer
604	IF( MOD( Agrif_irhot() * Agrif_Parent(nn_fsbc), nn_fsbc ) /= 0 ) THEN
605	CALL ctl_stop('rhot * nn_fsbc(parent) /= N * nn_fsbc(child), therefore nn_fsbc(child) should be set to 1 or nn_fsbc(parent)')
606	ENDIF
607	! First Interpolations (using "after" ice subtime step => nbstep_ice=1)
608	!----------------------------------------------------------------------
609	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)
610	CALL agrif_interp_ice('U') ! interpolation of ice velocities
611	CALL agrif_interp_ice('V') ! interpolation of ice velocities
612	CALL agrif_interp_ice('T') ! interpolation of ice tracers
613	nbstep_ice = 0
614	!
615	END SUBROUTINE Agrif_InitValues_cont_ice
616
617
618	SUBROUTINE agrif_declare_var_ice
619	!!----------------------------------------------------------------------
620	!! * ROUTINE agrif_declare_var_ice *
621	!!----------------------------------------------------------------------
622	USE Agrif_Util
623	USE ice
624	USE par_oce, ONLY : nbghostcells, nbghostcells_x, nbghostcells_y_s
625	!
626	IMPLICIT NONE
627	!
628	INTEGER :: ind1, ind2, ind3
629	INTEGER :: ipl
630	!!----------------------------------------------------------------------
631	!
632	! 1. Declaration of the type of variable which have to be interpolated (parent=>child)
633	! agrif_declare_variable(position,1st point index,--,--,dimensions,name)
634	! ex.: position=> 1,1 = not-centered (in i and j)
635	! 2,2 = centered ( - )
636	! index => 1,1 = one ghost line
637	! 2,2 = two ghost lines
638	!-------------------------------------------------------------------------------------
639	ind1 = nbghostcells
640	ind2 = nn_hls + 2 + nbghostcells_x
641	ind3 = nn_hls + 2 + nbghostcells_y_s
642	ipl = jpl*(9+nlay_s+nlay_i)
643	CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,ipl/),tra_ice_id)
644	CALL agrif_declare_variable((/1,2/) ,(/ind2-1,ind3/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), u_ice_id)
645	CALL agrif_declare_variable((/2,1/) ,(/ind2,ind3-1/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), v_ice_id)
646
647	CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,ipl/),tra_iceini_id)
648	CALL agrif_declare_variable((/1,2/) ,(/ind2-1,ind3/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), u_iceini_id)
649	CALL agrif_declare_variable((/2,1/) ,(/ind2,ind3-1/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), v_iceini_id)
650
651	! 2. Set interpolations (normal & tangent to the grid cell for velocities)
652	!-----------------------------------
653	CALL Agrif_Set_bcinterp(tra_ice_id, interp = AGRIF_linear)
654	CALL Agrif_Set_bcinterp(u_ice_id , interp1 = Agrif_linear,interp2 = AGRIF_ppm )
655	CALL Agrif_Set_bcinterp(v_ice_id , interp1 = AGRIF_ppm ,interp2 = Agrif_linear)
656
657	CALL Agrif_Set_bcinterp(tra_iceini_id, interp = AGRIF_linear)
658	CALL Agrif_Set_interp (tra_iceini_id, interp = AGRIF_linear)
659	CALL Agrif_Set_bcinterp(u_iceini_id , interp = AGRIF_linear)
660	CALL Agrif_Set_interp (u_iceini_id , interp = AGRIF_linear)
661	CALL Agrif_Set_bcinterp(v_iceini_id , interp = AGRIF_linear)
662	CALL Agrif_Set_interp (v_iceini_id , interp = AGRIF_linear)
663
664	! 3. Set location of interpolations
665	!----------------------------------
666	CALL Agrif_Set_bc(tra_ice_id,(/0,ind1/))
667	CALL Agrif_Set_bc(u_ice_id ,(/0,ind1/))
668	CALL Agrif_Set_bc(v_ice_id ,(/0,ind1/))
669
670	CALL Agrif_Set_bc(tra_iceini_id,(/0,ind1/))
671	CALL Agrif_Set_bc(u_iceini_id ,(/0,ind1/))
672	CALL Agrif_Set_bc(v_iceini_id ,(/0,ind1/))
673
674	! 4. Set update type in case 2 ways (child=>parent) (normal & tangent to the grid cell for velocities)
675	!--------------------------------------------------
676	# if defined UPD_HIGH
677	CALL Agrif_Set_Updatetype(tra_ice_id, update = Agrif_Update_Full_Weighting)
678	CALL Agrif_Set_Updatetype(u_ice_id , update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting)
679	CALL Agrif_Set_Updatetype(v_ice_id , update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average )
680	# else
681	CALL Agrif_Set_Updatetype(tra_ice_id, update = AGRIF_Update_Average)
682	CALL Agrif_Set_Updatetype(u_ice_id , update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average)
683	CALL Agrif_Set_Updatetype(v_ice_id , update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy )
684	# endif
685
686	END SUBROUTINE agrif_declare_var_ice
687	#endif
688
689
690	# if defined key_top
691	SUBROUTINE Agrif_InitValues_cont_top
692	!!----------------------------------------------------------------------
693	!! * ROUTINE Agrif_InitValues_cont_top *
694	!!----------------------------------------------------------------------
695	USE Agrif_Util
696	USE oce
697	USE dom_oce
698	USE nemogcm
699	USE par_trc
700	USE lib_mpp
701	USE trc
702	USE in_out_manager
703	USE agrif_oce_sponge
704	USE agrif_top_update
705	USE agrif_top_interp
706	USE agrif_top_sponge
707	!
708	IMPLICIT NONE
709	!
710	CHARACTER(len=10) :: cl_check1, cl_check2, cl_check3
711	LOGICAL :: check_namelist
712	!!----------------------------------------------------------------------
713
714	! 1. Declaration of the type of variable which have to be interpolated
715	!---------------------------------------------------------------------
716	CALL agrif_declare_var_top
717
718	! 2. First interpolations of potentially non zero fields
719	!-------------------------------------------------------
720	Agrif_SpecialValue=0._wp
721	Agrif_UseSpecialValue = .TRUE.
722	CALL Agrif_Bc_variable(trn_id,calledweight=1.,procname=interptrn)
723	Agrif_UseSpecialValue = .FALSE.
724	CALL Agrif_Sponge
725	tabspongedone_trn = .FALSE.
726	CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge)
727	! reset tsa to zero
728	tr(:,:,:,:,Krhs_a) = 0._wp
729
730	! 3. Some controls
731	!-----------------
732	check_namelist = .TRUE.
733
734	IF( check_namelist ) THEN
735	! Check time steps
736	IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN
737	WRITE(cl_check1,*) Agrif_Parent(rdt)
738	WRITE(cl_check2,*) rdt
739	WRITE(cl_check3,) rdtAgrif_Rhot()
740	CALL ctl_stop( 'incompatible time step between grids', &
741	& 'parent grid value : '//cl_check1 , &
742	& 'child grid value : '//cl_check2 , &
743	& 'value on child grid should be changed to &
744	& :'//cl_check3 )
745	ENDIF
746
747	! Check run length
748	IF( Agrif_IRhot() * (Agrif_Parent(nitend)- &
749	Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN
750	WRITE(cl_check1,) (Agrif_Parent(nit000)-1)Agrif_IRhot() + 1
751	WRITE(cl_check2,) Agrif_Parent(nitend) Agrif_IRhot()
752	CALL ctl_warn( 'incompatible run length between grids' , &
753	& ' nit000 on fine grid will be change to : '//cl_check1, &
754	& ' nitend on fine grid will be change to : '//cl_check2 )
755	nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1
756	nitend = Agrif_Parent(nitend) *Agrif_IRhot()
757	ENDIF
758	ENDIF
759	!
760	END SUBROUTINE Agrif_InitValues_cont_top
761
762
763	SUBROUTINE agrif_declare_var_top
764	!!----------------------------------------------------------------------
765	!! * ROUTINE agrif_declare_var_top *
766	!!----------------------------------------------------------------------
767	USE agrif_util
768	USE agrif_oce
769	USE dom_oce
770	USE trc
771	!!
772	IMPLICIT NONE
773	!
774	INTEGER :: ind1, ind2, ind3, imaxrho
775	!!----------------------------------------------------------------------
776	!RB_CMEMS : declare here init for top
777	! 1. Declaration of the type of variable which have to be interpolated
778	!---------------------------------------------------------------------
779	ind1 = nbghostcells
780	ind2 = nn_hls + 2 + nbghostcells_x
781	ind3 = nn_hls + 2 + nbghostcells_y_s
782	imaxrho = MAX(Agrif_irhox(), Agrif_irhoy())
783
784	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)
785	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)
786
787	! 2. Type of interpolation
788	!-------------------------
789	CALL Agrif_Set_bcinterp(trn_id,interp=AGRIF_linear)
790	CALL Agrif_Set_bcinterp(trn_sponge_id,interp=AGRIF_linear)
791
792	! 3. Location of interpolation
793	!-----------------------------
794	CALL Agrif_Set_bc(trn_id,(/0,ind1-1/))
795	CALL Agrif_Set_bc(trn_sponge_id,(/-nn_sponge_len*imaxrho-1,0/))
796
797	! 4. Update type
798	!---------------
799	# if defined UPD_HIGH
800	CALL Agrif_Set_Updatetype(trn_id, update = Agrif_Update_Full_Weighting)
801	#else
802	CALL Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average)
803	#endif
804	!
805	END SUBROUTINE agrif_declare_var_top
806	# endif
807
808
809	SUBROUTINE Agrif_detect( kg, ksizex )
810	!!----------------------------------------------------------------------
811	!! * ROUTINE Agrif_detect *
812	!!----------------------------------------------------------------------
813	INTEGER, DIMENSION(2) :: ksizex
814	INTEGER, DIMENSION(ksizex(1),ksizex(2)) :: kg
815	!!----------------------------------------------------------------------
816	!
817	RETURN
818	!
819	END SUBROUTINE Agrif_detect
820
821
822	SUBROUTINE agrif_nemo_init
823	!!----------------------------------------------------------------------
824	!! * ROUTINE agrif_init *
825	!!----------------------------------------------------------------------
826	USE agrif_oce
827	USE agrif_ice
828	USE dom_oce
829	USE in_out_manager
830	USE lib_mpp
831	!
832	IMPLICIT NONE
833	!
834	INTEGER :: ios ! Local integer output status for namelist read
835	NAMELIST/namagrif/ ln_agrif_2way, ln_init_chfrpar, rn_sponge_tra, rn_sponge_dyn, rn_trelax_tra, rn_trelax_dyn, &
836	& ln_spc_dyn, ln_vert_remap, ln_chk_bathy
837	!!--------------------------------------------------------------------------------------
838	!
839	READ ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901)
840	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist' )
841	READ ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 )
842	902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist' )
843	IF(lwm) WRITE ( numond, namagrif )
844	!
845	IF(lwp) THEN ! control print
846	WRITE(numout,*)
847	WRITE(numout,*) 'agrif_nemo_init : AGRIF parameters'
848	WRITE(numout,*) '~~~~~~~~~~~~~~~'
849	WRITE(numout,*) ' Namelist namagrif : set AGRIF parameters'
850	WRITE(numout,*) ' Two way nesting activated ln_agrif_2way = ', ln_agrif_2way
851	WRITE(numout,*) ' child initial state from parent ln_init_chfrpar = ', ln_init_chfrpar
852	WRITE(numout,*) ' ad. sponge coeft for tracers rn_sponge_tra = ', rn_sponge_tra
853	WRITE(numout,*) ' ad. sponge coeft for dynamics rn_sponge_tra = ', rn_sponge_dyn
854	WRITE(numout,*) ' ad. time relaxation for tracers rn_trelax_tra = ', rn_trelax_tra
855	WRITE(numout,*) ' ad. time relaxation for dynamics rn_trelax_dyn = ', rn_trelax_dyn
856	WRITE(numout,*) ' use special values for dynamics ln_spc_dyn = ', ln_spc_dyn
857	WRITE(numout,*) ' vertical remapping ln_vert_remap = ', ln_vert_remap
858	WRITE(numout,*) ' check bathymetry ln_chk_bathy = ', ln_chk_bathy
859	ENDIF
860
861	! JC => side effects of lines below to be checked:
862	lk_west = .NOT. ( Agrif_Ix() == 1 )
863	lk_east = .NOT. ( Agrif_Ix() + nbcellsx/AGRIF_Irhox() == Agrif_Parent(Ni0glo) -1 )
864	lk_south = .NOT. ( Agrif_Iy() == 1 )
865	lk_north = .NOT. ( Agrif_Iy() + nbcellsy/AGRIF_Irhoy() == Agrif_Parent(Nj0glo) -1 )
866	!
867	! Set the number of ghost cells according to periodicity
868	nbghostcells_x = nbghostcells
869	nbghostcells_y_s = nbghostcells
870	nbghostcells_y_n = nbghostcells
871	!
872	IF( jperio == 1 ) nbghostcells_x = 0
873	IF( .NOT. lk_south ) nbghostcells_y_s = 0
874	IF( .NOT. lk_north ) nbghostcells_y_n = 0
875	!
876	! Some checks
877	IF( jpiglo /= nbcellsx + 2 + 2*nn_hls + nbghostcells_x + nbghostcells_x ) CALL ctl_stop( 'STOP', &
878	& 'agrif_nemo_init: Agrif children requires jpiglo == nbcellsx + 2 + 2nn_hls + 2nbghostcells_x' )
879	IF( jpjglo /= nbcellsy + 2 + 2*nn_hls + nbghostcells_y_s + nbghostcells_y_n ) CALL ctl_stop( 'STOP', &
880	& 'agrif_nemo_init: Agrif children requires jpjglo == nbcellsy + 2 + 2*nn_hls + nbghostcells_y_s + nbghostcells_y_n' )
881	IF( ln_use_jattr ) CALL ctl_stop( 'STOP', 'agrif_nemo_init:Agrif children requires ln_use_jattr = .false. ' )
882	!
883	!
884	END SUBROUTINE agrif_nemo_init
885
886
887	# if defined key_mpp_mpi
888	SUBROUTINE Agrif_InvLoc( indloc, nprocloc, i, indglob )
889	!!----------------------------------------------------------------------
890	!! * ROUTINE Agrif_InvLoc *
891	!!----------------------------------------------------------------------
892	USE dom_oce
893	!!
894	IMPLICIT NONE
895	!
896	INTEGER :: indglob, indloc, nprocloc, i
897	!!----------------------------------------------------------------------
898	!
899	SELECT CASE( i )
900	CASE(1) ; indglob = mig(indloc)
901	CASE(2) ; indglob = mjg(indloc)
902	CASE DEFAULT ; indglob = indloc
903	END SELECT
904	!
905	END SUBROUTINE Agrif_InvLoc
906
907
908	SUBROUTINE Agrif_get_proc_info( imin, imax, jmin, jmax )
909	!!----------------------------------------------------------------------
910	!! * ROUTINE Agrif_get_proc_info *
911	!!----------------------------------------------------------------------
912	USE par_oce
913	!!
914	IMPLICIT NONE
915	!
916	INTEGER, INTENT(out) :: imin, imax
917	INTEGER, INTENT(out) :: jmin, jmax
918	!!----------------------------------------------------------------------
919	!
920	imin = mig( 1 )
921	jmin = mjg( 1 )
922	imax = mig(jpi)
923	jmax = mjg(jpj)
924	!
925	END SUBROUTINE Agrif_get_proc_info
926
927
928	SUBROUTINE Agrif_estimate_parallel_cost(imin, imax,jmin, jmax, nbprocs, grid_cost)
929	!!----------------------------------------------------------------------
930	!! * ROUTINE Agrif_estimate_parallel_cost *
931	!!----------------------------------------------------------------------
932	USE par_oce
933	!!
934	IMPLICIT NONE
935	!
936	INTEGER, INTENT(in) :: imin, imax
937	INTEGER, INTENT(in) :: jmin, jmax
938	INTEGER, INTENT(in) :: nbprocs
939	REAL(wp), INTENT(out) :: grid_cost
940	!!----------------------------------------------------------------------
941	!
942	grid_cost = REAL(imax-imin+1,wp)*REAL(jmax-jmin+1,wp) / REAL(nbprocs,wp)
943	!
944	END SUBROUTINE Agrif_estimate_parallel_cost
945
946	# endif
947
948	SUBROUTINE nemo_mapping(ndim,ptx,pty,bounds,bounds_chunks,correction_required,nb_chunks)
949	!!----------------------------------------------------------------------
950	!! * ROUTINE Nemo_mapping *
951	!!----------------------------------------------------------------------
952	USE dom_oce
953	!!
954	IMPLICIT NONE
955	!
956	INTEGER :: ndim
957	INTEGER :: ptx, pty
958	INTEGER, DIMENSION(ndim,2,2) :: bounds
959	INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: bounds_chunks
960	LOGICAL, DIMENSION(:), ALLOCATABLE :: correction_required
961	INTEGER :: nb_chunks
962	!
963	INTEGER :: i
964
965	IF (agrif_debug_interp) THEN
966	DO i=1,ndim
967	WRITE(,) 'direction = ',i,bounds(i,1,2),bounds(i,2,2)
968	ENDDO
969	ENDIF
970
971	IF( bounds(2,2,2) > jpjglo) THEN
972	IF( bounds(2,1,2) <=jpjglo) THEN
973	nb_chunks = 2
974	ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
975	ALLOCATE(correction_required(nb_chunks))
976	DO i = 1,nb_chunks
977	bounds_chunks(i,:,:,:) = bounds
978	END DO
979
980	! FIRST CHUNCK (for j<=jpjglo)
981
982	! Original indices
983	bounds_chunks(1,1,1,1) = bounds(1,1,2)
984	bounds_chunks(1,1,2,1) = bounds(1,2,2)
985	bounds_chunks(1,2,1,1) = bounds(2,1,2)
986	bounds_chunks(1,2,2,1) = jpjglo
987
988	bounds_chunks(1,1,1,2) = bounds(1,1,2)
989	bounds_chunks(1,1,2,2) = bounds(1,2,2)
990	bounds_chunks(1,2,1,2) = bounds(2,1,2)
991	bounds_chunks(1,2,2,2) = jpjglo
992
993	! Correction required or not
994	correction_required(1)=.FALSE.
995
996	! SECOND CHUNCK (for j>jpjglo)
997
998	! Original indices
999	bounds_chunks(2,1,1,1) = bounds(1,1,2)
1000	bounds_chunks(2,1,2,1) = bounds(1,2,2)
1001	bounds_chunks(2,2,1,1) = jpjglo-2
1002	bounds_chunks(2,2,2,1) = bounds(2,2,2)
1003
1004	! Where to find them
1005	! We use the relation TAB(ji,jj)=TAB(jpiglo-ji+2,jpjglo-2-(jj-jpjglo))
1006
1007	IF( ptx == 2) THEN ! T, V points
1008	bounds_chunks(2,1,1,2) = jpiglo-bounds(1,2,2)+2
1009	bounds_chunks(2,1,2,2) = jpiglo-bounds(1,1,2)+2
1010	ELSE ! U, F points
1011	bounds_chunks(2,1,1,2) = jpiglo-bounds(1,2,2)+1
1012	bounds_chunks(2,1,2,2) = jpiglo-bounds(1,1,2)+1
1013	ENDIF
1014
1015	IF( pty == 2) THEN ! T, U points
1016	bounds_chunks(2,2,1,2) = jpjglo-2-(bounds(2,2,2) -jpjglo)
1017	bounds_chunks(2,2,2,2) = jpjglo-2-(jpjglo-2 -jpjglo)
1018	ELSE ! V, F points
1019	bounds_chunks(2,2,1,2) = jpjglo-3-(bounds(2,2,2) -jpjglo)
1020	bounds_chunks(2,2,2,2) = jpjglo-3-(jpjglo-2 -jpjglo)
1021	ENDIF
1022	! Correction required or not
1023	correction_required(2)=.TRUE.
1024
1025	ELSE
1026	nb_chunks = 1
1027	ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
1028	ALLOCATE(correction_required(nb_chunks))
1029	DO i=1,nb_chunks
1030	bounds_chunks(i,:,:,:) = bounds
1031	END DO
1032
1033	bounds_chunks(1,1,1,1) = bounds(1,1,2)
1034	bounds_chunks(1,1,2,1) = bounds(1,2,2)
1035	bounds_chunks(1,2,1,1) = bounds(2,1,2)
1036	bounds_chunks(1,2,2,1) = bounds(2,2,2)
1037
1038	bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+2
1039	bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+2
1040
1041	bounds_chunks(1,2,1,2) = jpjglo-2-(bounds(2,2,2)-jpjglo)
1042	bounds_chunks(1,2,2,2) = jpjglo-2-(bounds(2,1,2)-jpjglo)
1043
1044	IF( ptx == 2) THEN ! T, V points
1045	bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+2
1046	bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+2
1047	ELSE ! U, F points
1048	bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+1
1049	bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+1
1050	ENDIF
1051
1052	IF (pty == 2) THEN ! T, U points
1053	bounds_chunks(1,2,1,2) = jpjglo-2-(bounds(2,2,2) -jpjglo)
1054	bounds_chunks(1,2,2,2) = jpjglo-2-(bounds(2,1,2) -jpjglo)
1055	ELSE ! V, F points
1056	bounds_chunks(1,2,1,2) = jpjglo-3-(bounds(2,2,2) -jpjglo)
1057	bounds_chunks(1,2,2,2) = jpjglo-3-(bounds(2,1,2) -jpjglo)
1058	ENDIF
1059
1060	correction_required(1)=.TRUE.
1061	ENDIF
1062
1063	ELSE IF (bounds(1,1,2) < 1) THEN
1064	IF (bounds(1,2,2) > 0) THEN
1065	nb_chunks = 2
1066	ALLOCATE(correction_required(nb_chunks))
1067	correction_required=.FALSE.
1068	ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
1069	DO i=1,nb_chunks
1070	bounds_chunks(i,:,:,:) = bounds
1071	END DO
1072
1073	bounds_chunks(1,1,1,2) = bounds(1,1,2)+jpiglo-2
1074	bounds_chunks(1,1,2,2) = 1+jpiglo-2
1075
1076	bounds_chunks(1,1,1,1) = bounds(1,1,2)
1077	bounds_chunks(1,1,2,1) = 1
1078
1079	bounds_chunks(2,1,1,2) = 2
1080	bounds_chunks(2,1,2,2) = bounds(1,2,2)
1081
1082	bounds_chunks(2,1,1,1) = 2
1083	bounds_chunks(2,1,2,1) = bounds(1,2,2)
1084
1085	ELSE
1086	nb_chunks = 1
1087	ALLOCATE(correction_required(nb_chunks))
1088	correction_required=.FALSE.
1089	ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
1090	DO i=1,nb_chunks
1091	bounds_chunks(i,:,:,:) = bounds
1092	END DO
1093	bounds_chunks(1,1,1,2) = bounds(1,1,2)+jpiglo-2
1094	bounds_chunks(1,1,2,2) = bounds(1,2,2)+jpiglo-2
1095
1096	bounds_chunks(1,1,1,1) = bounds(1,1,2)
1097	bounds_chunks(1,1,2,1) = bounds(1,2,2)
1098	ENDIF
1099	ELSE
1100	nb_chunks=1
1101	ALLOCATE(correction_required(nb_chunks))
1102	correction_required=.FALSE.
1103	ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
1104	DO i=1,nb_chunks
1105	bounds_chunks(i,:,:,:) = bounds
1106	END DO
1107	bounds_chunks(1,1,1,2) = bounds(1,1,2)
1108	bounds_chunks(1,1,2,2) = bounds(1,2,2)
1109	bounds_chunks(1,2,1,2) = bounds(2,1,2)
1110	bounds_chunks(1,2,2,2) = bounds(2,2,2)
1111
1112	bounds_chunks(1,1,1,1) = bounds(1,1,2)
1113	bounds_chunks(1,1,2,1) = bounds(1,2,2)
1114	bounds_chunks(1,2,1,1) = bounds(2,1,2)
1115	bounds_chunks(1,2,2,1) = bounds(2,2,2)
1116	ENDIF
1117
1118	END SUBROUTINE nemo_mapping
1119
1120	FUNCTION agrif_external_switch_index(ptx,pty,i1,isens)
1121
1122	USE dom_oce
1123	!
1124	IMPLICIT NONE
1125
1126	INTEGER :: ptx, pty, i1, isens
1127	INTEGER :: agrif_external_switch_index
1128	!!----------------------------------------------------------------------
1129
1130	IF( isens == 1 ) THEN
1131	IF( ptx == 2 ) THEN ! T, V points
1132	agrif_external_switch_index = jpiglo-i1+2
1133	ELSE ! U, F points
1134	agrif_external_switch_index = jpiglo-i1+1
1135	ENDIF
1136	ELSE IF( isens ==2 ) THEN
1137	IF ( pty == 2 ) THEN ! T, U points
1138	agrif_external_switch_index = jpjglo-2-(i1 -jpjglo)
1139	ELSE ! V, F points
1140	agrif_external_switch_index = jpjglo-3-(i1 -jpjglo)
1141	ENDIF
1142	ENDIF
1143
1144	END FUNCTION agrif_external_switch_index
1145
1146	SUBROUTINE Correct_field(tab2d,i1,i2,j1,j2)
1147	!!----------------------------------------------------------------------
1148	!! * ROUTINE Correct_field *
1149	!!----------------------------------------------------------------------
1150	USE dom_oce
1151	USE agrif_oce
1152	!
1153	IMPLICIT NONE
1154	!
1155	INTEGER :: i1,i2,j1,j2
1156	REAL(wp), DIMENSION(i1:i2,j1:j2) :: tab2d
1157	!
1158	INTEGER :: i,j
1159	REAL(wp), DIMENSION(i1:i2,j1:j2) :: tab2dtemp
1160	!!----------------------------------------------------------------------
1161
1162	tab2dtemp = tab2d
1163
1164	IF( .NOT. use_sign_north ) THEN
1165	DO j=j1,j2
1166	DO i=i1,i2
1167	tab2d(i,j)=tab2dtemp(i2-(i-i1),j2-(j-j1))
1168	END DO
1169	END DO
1170	ELSE
1171	DO j=j1,j2
1172	DO i=i1,i2
1173	tab2d(i,j)=sign_north * tab2dtemp(i2-(i-i1),j2-(j-j1))
1174	END DO
1175	END DO
1176	ENDIF
1177
1178	END SUBROUTINE Correct_field
1179
1180	#else
1181	SUBROUTINE Subcalledbyagrif
1182	!!----------------------------------------------------------------------
1183	!! * ROUTINE Subcalledbyagrif *
1184	!!----------------------------------------------------------------------
1185	WRITE(,) 'Impossible to be here'
1186	END SUBROUTINE Subcalledbyagrif
1187	#endif

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

Download in other formats: