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

Last change on this file since 13103 was 13076, checked in by rblod, 4 years ago
ticket #2129 : correct indexes in declaration in agrif_user
Property svn:keywords set to `Id`
File size: 50.8 KB

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

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

Download in other formats: