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

Context Navigation

source: NEMO/branches/2020/dev_r12973_AGRIF_CMEMS/src/NST/agrif_user.F90 @ 13133

Last change on this file since 13133 was 13133, checked in by jchanut, 4 years ago
Remove useless restriction on sponge width, #2129
Property svn:keywords set to `Id`
File size: 50.5 KB

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

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

Download in other formats: