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_r13296_HPC-07_mocavero_mpi3/src/NST – NEMO

Context Navigation

source: NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/NST/agrif_user.F90 @ 13630

Last change on this file since 13630 was 13630, checked in by mocavero, 4 years ago
Add neighborhood collectives calls in the NEMO src - ticket #2496
Property svn:keywords set to `Id`
File size: 52.8 KB

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

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

Download in other formats: