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

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

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

Download in other formats: