New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

agrif_user.F90 in NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/NST – NEMO

Context Navigation

source: NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/NST/agrif_user.F90 @ 13371

Last change on this file since 13371 was 13371, checked in by jchanut, 4 years ago
#2222, remove constrain on jpk_parent <= jpk_child with last library change
Property svn:keywords set to `Id`
File size: 47.5 KB

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

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

Download in other formats: