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

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

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

Download in other formats: