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_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/NST – NEMO

Context Navigation

source: NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/NST/agrif_user.F90 @ 13351

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

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

Download in other formats: