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 utils/tools_dev_r12970_AGRIF_CMEMS/DOMAINcfg/src – NEMO

Context Navigation

source: utils/tools_dev_r12970_AGRIF_CMEMS/DOMAINcfg/src/agrif_user.F90 @ 13056

Last change on this file since 13056 was 13056, checked in by rblod, 4 years ago
ticket #2129 : cleaning domcfg
File size: 44.7 KB

Line
1	#if defined key_agrif
2	SUBROUTINE agrif_user()
3	!!----------------------------------------------------------------------
4	!! * ROUTINE agrif_user *
5	!!----------------------------------------------------------------------
6	END SUBROUTINE agrif_user
7
8	SUBROUTINE agrif_initworkspace()
9	!!----------------------------------------------------------------------
10	!! * ROUTINE Agrif_InitWorkspace *
11	!!----------------------------------------------------------------------
12	END SUBROUTINE agrif_initworkspace
13
14	SUBROUTINE Agrif_InitValues
15	!!----------------------------------------------------------------------
16	!! * ROUTINE Agrif_InitValues *
17	!!
18	!! ** Purpose :: Declaration of variables to be interpolated
19	!!----------------------------------------------------------------------
20	USE Agrif_Util
21	USE dom_oce
22	USE nemogcm
23	USE domain
24	!!
25	IMPLICIT NONE
26
27	! No temporal refinement
28	CALL Agrif_Set_coeffreft(1)
29
30	CALL nemo_init !* Initializations of each fine grid
31
32	CALL dom_nam
33
34	END SUBROUTINE Agrif_InitValues
35
36	SUBROUTINE Agrif_InitValues_cont
37	!!----------------------------------------------------------------------
38	!! * ROUTINE Agrif_InitValues_cont *
39	!!
40	!! ** Purpose :: Initialisation of variables to be interpolated
41	!!----------------------------------------------------------------------
42	USE dom_oce
43	USE lbclnk
44	!!
45	IMPLICIT NONE
46	!
47	INTEGER :: nx, ny
48	INTEGER :: irafx, irafy
49	LOGICAL :: ln_perio
50	!
51	irafx = agrif_irhox()
52	irafy = agrif_irhoy()
53
54	nx = nlci ; ny = nlcj
55
56	! IF(jperio /=1 .AND. jperio/=4 .AND. jperio/=6 ) THEN
57	! nx = (nbcellsx)+2*nbghostcellsfine+2
58	! ny = (nbcellsy)+2*nbghostcellsfine+2
59	! nbghostcellsfine_tot_x= nbghostcellsfine_x +1
60	! nbghostcellsfine_tot_y= nbghostcellsfine_y +1
61	! ELSE
62	! nx = (nbcellsx)+2*nbghostcellsfine_x
63	! ny = (nbcellsy)+2*nbghostcellsfine+2
64	! nbghostcellsfine_tot_x= 1
65	! nbghostcellsfine_tot_y= nbghostcellsfine_y +1
66	! ENDIF
67	! ELSE
68	! nbghostcellsfine = 0
69	! nx = nbcellsx+irafx
70	! ny = nbcellsy+irafy
71
72	WRITE(,) ' '
73	WRITE(,)'Size of the High resolution grid: ',nx,' x ',ny
74	WRITE(,) ' '
75
76	CALL agrif_init_lonlat()
77	ln_perio = .FALSE.
78	IF( jperio == 1 .OR. jperio == 2 .OR. jperio == 4 ) ln_perio=.TRUE.
79
80	WHERE (glamt < -180) glamt = glamt +360.
81	WHERE (glamt > +180) glamt = glamt -360.
82
83	CALL lbc_lnk( 'glamt', glamt, 'T', 1._wp)
84	CALL lbc_lnk( 'gphit', gphit, 'T', 1._wp)
85
86	WHERE (glamu < -180) glamu = glamu +360.
87	WHERE (glamu > +180) glamu = glamu -360.
88	CALL lbc_lnk( 'glamu', glamu, 'U', 1._wp)
89	CALL lbc_lnk( 'gphiu', gphiu, 'U', 1._wp)
90
91	WHERE (glamv < -180) glamv = glamv +360.
92	WHERE (glamv > +180) glamv = glamv -360.
93	CALL lbc_lnk( 'glamv', glamv, 'V', 1._wp)
94	CALL lbc_lnk( 'gphiv', gphiv, 'V', 1._wp)
95
96	WHERE (glamf < -180) glamf = glamf +360.
97	WHERE (glamf > +180) glamf = glamf -360.
98	CALL lbc_lnk( 'glamf', glamf, 'F', 1._wp)
99	CALL lbc_lnk( 'gphif', gphif, 'F', 1._wp)
100
101	! Correct South and North
102	IF ((nbondj == -1).OR.(nbondj == 2)) THEN
103	glamt(:,1) = glamt(:,2)
104	gphit(:,1) = gphit(:,2)
105	glamu(:,1) = glamu(:,2)
106	gphiu(:,1) = gphiu(:,2)
107	glamv(:,1) = glamv(:,2)
108	gphiv(:,1) = gphiv(:,2)
109	ENDIF
110	IF ((nbondj == 1).OR.(nbondj == 2)) THEN
111	glamt(:,jpj) = glamt(:,jpj-1)
112	gphit(:,jpj) = gphit(:,jpj-1)
113	glamu(:,jpj) = glamu(:,jpj-1)
114	gphiu(:,jpj) = gphiu(:,jpj-1)
115	glamv(:,jpj) = glamv(:,jpj-1)
116	gphiv(:,jpj) = gphiv(:,jpj-1)
117	glamf(:,jpj) = glamf(:,jpj-1)
118	gphif(:,jpj) = gphif(:,jpj-1)
119	ENDIF
120
121	! Correct West and East
122	IF( jperio /= 1 ) THEN
123	IF((nbondi == -1) .OR. (nbondi == 2) ) THEN
124	glamt(1,:) = glamt(2,:)
125	gphit(1,:) = gphit(2,:)
126	glamu(1,:) = glamu(2,:)
127	gphiu(1,:) = gphiu(2,:)
128	glamv(1,:) = glamv(2,:)
129	gphiv(1,:) = gphiv(2,:)
130	ENDIF
131	IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN
132	glamt(jpi,:) = glamt(jpi-1,:)
133	gphit(jpi,:) = gphit(jpi-1,:)
134	glamu(jpi,:) = glamu(jpi-1,:)
135	gphiu(jpi,:) = gphiu(jpi-1,:)
136	glamv(jpi,:) = glamv(jpi-1,:)
137	gphiv(jpi,:) = gphiv(jpi-1,:)
138	glamf(jpi,:) = glamf(jpi-1,:)
139	gphif(jpi,:) = gphif(jpi-1,:)
140	ENDIF
141	ENDIF
142
143	CALL agrif_init_scales()
144
145	! Correct South and North
146	IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN
147	e1t(:,1) = e1t(:,2)
148	e2t(:,1) = e2t(:,2)
149	e1u(:,1) = e1u(:,2)
150	e2u(:,1) = e2u(:,2)
151	e1v(:,1) = e1v(:,2)
152	e2v(:,1) = e2v(:,2)
153	ENDIF
154	IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN
155	e1t(:,jpj) = e1t(:,jpj-1)
156	e2t(:,jpj) = e2t(:,jpj-1)
157	e1u(:,jpj) = e1u(:,jpj-1)
158	e2u(:,jpj) = e2u(:,jpj-1)
159	e1v(:,jpj) = e1v(:,jpj-1)
160	e2v(:,jpj) = e2v(:,jpj-1)
161	e1f(:,jpj) = e1f(:,jpj-1)
162	e2f(:,jpj) = e2f(:,jpj-1)
163	ENDIF
164
165	! Correct West and East
166	IF( jperio /= 1 ) THEN
167	IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN
168	e1t(1,:) = e1t(2,:)
169	e2t(1,:) = e2t(2,:)
170	e1u(1,:) = e1u(2,:)
171	e2u(1,:) = e2u(2,:)
172	e1v(1,:) = e1v(2,:)
173	e2v(1,:) = e2v(2,:)
174	ENDIF
175	IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN
176	e1t(jpi,:) = e1t(jpi-1,:)
177	e2t(jpi,:) = e2t(jpi-1,:)
178	e1u(jpi,:) = e1u(jpi-1,:)
179	e2u(jpi,:) = e2u(jpi-1,:)
180	e1v(jpi,:) = e1v(jpi-1,:)
181	e2v(jpi,:) = e2v(jpi-1,:)
182	e1f(jpi,:) = e1f(jpi-1,:)
183	e2f(jpi,:) = e2f(jpi-1,:)
184	ENDIF
185	ENDIF
186
187	END SUBROUTINE Agrif_InitValues_cont
188
189
190	SUBROUTINE agrif_declare_var()
191	!!----------------------------------------------------------------------
192	!! * ROUTINE Agrif_InitValues_cont *
193	!!
194	!! ** Purpose :: Declaration of variables to be interpolated
195	!!----------------------------------------------------------------------
196	USE par_oce
197	USE dom_oce
198	USE agrif_profiles
199	USE agrif_parameters
200
201	IMPLICIT NONE
202
203	INTEGER :: ind1, ind2, ind3
204	INTEGER :: nx, ny
205	INTEGER ::nbghostcellsfine_tot_x, nbghostcellsfine_tot_y
206	INTEGER :: irafx
207
208	EXTERNAL :: nemo_mapping
209
210	! 1. Declaration of the type of variable which have to be interpolated
211	!---------------------------------------------------------------------
212
213	nx=nlci ; ny=nlcj
214
215	ind2 = 2 + nbghostcells_x
216	ind3 = 2 + nbghostcells_y_s
217	nbghostcellsfine_tot_x=nbghostcells_x+1
218	nbghostcellsfine_tot_y=max(nbghostcells_y_s,nbghostcells_y_n)+1
219
220	irafx = Agrif_irhox()
221
222	! In case of East-West periodicity, prevent AGRIF interpolation at east and west boundaries
223	! The procnames will not be CALLed at these boundaries
224	if (jperio == 1) THEN
225	CALL Agrif_Set_NearCommonBorderX(.TRUE.)
226	CALL Agrif_Set_DistantCommonBorderX(.TRUE.)
227	endif
228	if (.not.ln_bry_south) THEN
229	CALL Agrif_Set_NearCommonBorderY(.TRUE.)
230	endif
231
232	CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),glamt_id)
233	CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),glamu_id)
234	CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),glamv_id)
235	CALL agrif_declare_variable((/1,1/),(/ind2-1,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),glamf_id)
236
237	CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),gphit_id)
238	CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),gphiu_id)
239	CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),gphiv_id)
240	CALL agrif_declare_variable((/1,1/),(/ind2-1,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),gphif_id)
241
242	! Horizontal scale factors
243
244	CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),e1t_id)
245	CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),e1u_id)
246	CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),e1v_id)
247	CALL agrif_declare_variable((/1,1/),(/ind2-1,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),e1f_id)
248
249	CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),e2t_id)
250	CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),e2u_id)
251	CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),e2v_id)
252	CALL agrif_declare_variable((/1,1/),(/ind2-1,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),e2f_id)
253
254	! Bathymetry
255
256	CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),bathy_id)
257
258	! Vertical scale factors
259	CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nx,ny,jpk/),e3t_id)
260	CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nx,ny,jpk/),e3t_copy_id)
261	CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nx,ny,jpk+1/),e3t_connect_id)
262
263	CALL agrif_declare_variable((/1,2,0/),(/ind2-1,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nx,ny,jpk/),e3u_id)
264	CALL agrif_declare_variable((/2,1,0/),(/ind2,ind3-1,0/),(/'x','y','N'/),(/1,1,1/),(/nx,ny,jpk/),e3v_id)
265
266	! Bottom level
267
268	CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),bottom_level_id)
269
270	CALL Agrif_Set_bcinterp(glamt_id,interp=AGRIF_linear)
271	CALL Agrif_Set_interp(glamt_id,interp=AGRIF_linear)
272	CALL Agrif_Set_bc( glamt_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) )
273
274	CALL Agrif_Set_bcinterp(glamu_id,interp=AGRIF_linear)
275	CALL Agrif_Set_interp(glamu_id,interp=AGRIF_linear)
276	CALL Agrif_Set_bc( glamu_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) )
277
278	CALL Agrif_Set_bcinterp(glamv_id,interp=AGRIF_linear)
279	CALL Agrif_Set_interp(glamv_id,interp=AGRIF_linear)
280	CALL Agrif_Set_bc( glamv_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) )
281
282	CALL Agrif_Set_bcinterp(glamf_id,interp=AGRIF_linear)
283	CALL Agrif_Set_interp(glamf_id,interp=AGRIF_linear)
284	CALL Agrif_Set_bc( glamf_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) )
285
286	CALL Agrif_Set_bcinterp(gphit_id,interp=AGRIF_linear)
287	CALL Agrif_Set_interp(gphit_id,interp=AGRIF_linear)
288	CALL Agrif_Set_bc( gphit_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) )
289
290	CALL Agrif_Set_bcinterp(gphiu_id,interp=AGRIF_linear)
291	CALL Agrif_Set_interp(gphiu_id,interp=AGRIF_linear)
292	CALL Agrif_Set_bc( gphiu_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) )
293
294	CALL Agrif_Set_bcinterp(gphiv_id,interp=AGRIF_linear)
295	CALL Agrif_Set_interp(gphiv_id,interp=AGRIF_linear)
296	CALL Agrif_Set_bc( gphiv_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) )
297
298	CALL Agrif_Set_bcinterp(gphif_id,interp=AGRIF_linear)
299	CALL Agrif_Set_interp(gphif_id,interp=AGRIF_linear)
300	CALL Agrif_Set_bc( gphif_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) )
301
302	!
303
304	CALL Agrif_Set_bcinterp(e1t_id,interp=AGRIF_ppm)
305	CALL Agrif_Set_interp(e1t_id,interp=AGRIF_ppm)
306	CALL Agrif_Set_bc( e1t_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) )
307
308	CALL Agrif_Set_bcinterp(e1u_id, interp1=Agrif_linear, interp2=AGRIF_ppm)
309	CALL Agrif_Set_interp(e1u_id, interp1=Agrif_linear, interp2=AGRIF_ppm)
310	CALL Agrif_Set_bc( e1u_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) )
311
312	CALL Agrif_Set_bcinterp(e1v_id,interp1=AGRIF_ppm, interp2=Agrif_linear)
313	CALL Agrif_Set_interp(e1v_id, interp1=AGRIF_ppm, interp2=Agrif_linear)
314	CALL Agrif_Set_bc( e1v_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) )
315
316	CALL Agrif_Set_bcinterp(e1f_id,interp=AGRIF_linear)
317	CALL Agrif_Set_interp(e1f_id,interp=AGRIF_linear)
318	CALL Agrif_Set_bc( e1f_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) )
319
320	CALL Agrif_Set_bcinterp(e2t_id,interp=AGRIF_ppm)
321	CALL Agrif_Set_interp(e2t_id,interp=AGRIF_ppm)
322	CALL Agrif_Set_bc( e2t_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) )
323
324	CALL Agrif_Set_bcinterp(e2u_id,interp1=Agrif_linear, interp2=AGRIF_ppm)
325	CALL Agrif_Set_interp(e2u_id,interp1=Agrif_linear, interp2=AGRIF_ppm)
326	CALL Agrif_Set_bc( e2u_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) )
327
328	CALL Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm, interp2=Agrif_linear)
329	CALL Agrif_Set_interp(e2v_id,interp1=AGRIF_ppm, interp2=Agrif_linear)
330	CALL Agrif_Set_bc( e2v_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) )
331
332	CALL Agrif_Set_bcinterp(e2f_id,interp=AGRIF_linear)
333	CALL Agrif_Set_interp(e2f_id,interp=AGRIF_linear)
334	CALL Agrif_Set_bc( e2f_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) )
335
336	CALL Agrif_Set_bcinterp(bathy_id,interp=AGRIF_linear)
337	CALL Agrif_Set_interp(bathy_id,interp=AGRIF_linear)
338	CALL Agrif_Set_bc( bathy_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) )
339
340	! Vertical scale factors
341	CALL Agrif_Set_bcinterp(e3t_id,interp=AGRIF_ppm)
342	CALL Agrif_Set_interp(e3t_id,interp=AGRIF_ppm)
343	CALL Agrif_Set_bc( e3t_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) )
344	CALL Agrif_Set_Updatetype( e3t_id, update = AGRIF_Update_Average)
345
346	CALL Agrif_Set_bcinterp(e3t_copy_id,interp=AGRIF_constant)
347	CALL Agrif_Set_interp(e3t_copy_id,interp=AGRIF_constant)
348	CALL Agrif_Set_bc( e3t_copy_id, (/-npt_copy*irafx,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/))
349
350	CALL Agrif_Set_bcinterp(e3t_connect_id,interp=AGRIF_ppm)
351	CALL Agrif_Set_interp(e3t_connect_id,interp=AGRIF_ppm)
352	CALL Agrif_Set_bc( e3t_connect_id, (/-(npt_copy+npt_connect)irafx-1,-npt_copyirafx/))
353
354	CALL Agrif_Set_bcinterp(e3u_id, interp1=Agrif_linear, interp2=AGRIF_ppm)
355	CALL Agrif_Set_interp(e3u_id, interp1=Agrif_linear, interp2=AGRIF_ppm)
356	CALL Agrif_Set_bc( e3u_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) )
357	CALL Agrif_Set_Updatetype(e3u_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average)
358
359	CALL Agrif_Set_bcinterp(e3v_id,interp1=AGRIF_ppm, interp2=Agrif_linear)
360	CALL Agrif_Set_interp(e3v_id, interp1=AGRIF_ppm, interp2=Agrif_linear)
361	CALL Agrif_Set_bc( e3v_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) )
362	CALL Agrif_Set_Updatetype(e3v_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy)
363
364	! Bottom level
365	CALL Agrif_Set_bcinterp(bottom_level_id,interp=AGRIF_constant)
366	CALL Agrif_Set_interp(bottom_level_id,interp=AGRIF_constant)
367	CALL Agrif_Set_bc( bottom_level_id, (/-npt_copy*irafx,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/))
368	CALL Agrif_Set_Updatetype( bottom_level_id, update = AGRIF_Update_Max)
369
370	CALL Agrif_Set_ExternalMapping(nemo_mapping)
371
372	END SUBROUTINE agrif_declare_var
373
374	SUBROUTINE nemo_mapping(ndim,ptx,pty,bounds,bounds_chunks,correction_required,nb_chunks)
375	USE dom_oce
376	INTEGER :: ndim
377	INTEGER :: ptx, pty
378	INTEGER,DIMENSION(ndim,2,2) :: bounds
379	INTEGER,DIMENSION(:,:,:,:),allocatable :: bounds_chunks
380	LOGICAL,DIMENSION(:),allocatable :: correction_required
381	INTEGER :: nb_chunks
382	INTEGER :: i
383
384	IF (agrif_debug_interp) THEN
385	DO i = 1, ndim
386	print *,'direction = ',i,bounds(i,1,2),bounds(i,2,2)
387	END DO
388	ENDIF
389
390	IF( bounds(2,2,2) > jpjglo ) THEN
391	IF( bounds(2,1,2) <= jpjglo ) THEN
392	nb_chunks = 2
393	ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
394	ALLOCATE(correction_required(nb_chunks))
395	DO i = 1, nb_chunks
396	bounds_chunks(i,:,:,:) = bounds
397	END DO
398
399	! FIRST CHUNCK (for j<=jpjglo)
400
401	! Original indices
402	bounds_chunks(1,1,1,1) = bounds(1,1,2)
403	bounds_chunks(1,1,2,1) = bounds(1,2,2)
404	bounds_chunks(1,2,1,1) = bounds(2,1,2)
405	bounds_chunks(1,2,2,1) = jpjglo
406
407	bounds_chunks(1,1,1,2) = bounds(1,1,2)
408	bounds_chunks(1,1,2,2) = bounds(1,2,2)
409	bounds_chunks(1,2,1,2) = bounds(2,1,2)
410	bounds_chunks(1,2,2,2) = jpjglo
411
412	! Correction required or not
413	correction_required(1)=.FALSE.
414
415	! SECOND CHUNCK (for j>jpjglo)
416
417	!Original indices
418	bounds_chunks(2,1,1,1) = bounds(1,1,2)
419	bounds_chunks(2,1,2,1) = bounds(1,2,2)
420	bounds_chunks(2,2,1,1) = jpjglo-2
421	bounds_chunks(2,2,2,1) = bounds(2,2,2)
422
423	! Where to find them
424	! We use the relation TAB(ji,jj)=TAB(jpiglo-ji+2,jpjglo-2-(jj-jpjglo))
425
426	IF (ptx == 2) THEN ! T, V points
427	bounds_chunks(2,1,1,2) = jpiglo-bounds(1,2,2)+2
428	bounds_chunks(2,1,2,2) = jpiglo-bounds(1,1,2)+2
429	ELSE ! U, F points
430	bounds_chunks(2,1,1,2) = jpiglo-bounds(1,2,2)+1
431	bounds_chunks(2,1,2,2) = jpiglo-bounds(1,1,2)+1
432	ENDIF
433
434	IF (pty == 2) THEN ! T, U points
435	bounds_chunks(2,2,1,2) = jpjglo-2-(bounds(2,2,2) -jpjglo)
436	bounds_chunks(2,2,2,2) = jpjglo-2-(jpjglo-2 -jpjglo)
437	ELSE ! V, F points
438	bounds_chunks(2,2,1,2) = jpjglo-3-(bounds(2,2,2) -jpjglo)
439	bounds_chunks(2,2,2,2) = jpjglo-3-(jpjglo-2 -jpjglo)
440	ENDIF
441
442	! Correction required or not
443	correction_required(2)=.TRUE.
444
445	ELSE
446
447	nb_chunks = 1
448	ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
449	ALLOCATE(correction_required(nb_chunks))
450	DO i=1,nb_chunks
451	bounds_chunks(i,:,:,:) = bounds
452	END DO
453
454	bounds_chunks(1,1,1,1) = bounds(1,1,2)
455	bounds_chunks(1,1,2,1) = bounds(1,2,2)
456	bounds_chunks(1,2,1,1) = bounds(2,1,2)
457	bounds_chunks(1,2,2,1) = bounds(2,2,2)
458
459	bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+2
460	bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+2
461
462	bounds_chunks(1,2,1,2) = jpjglo-2-(bounds(2,2,2)-jpjglo)
463	bounds_chunks(1,2,2,2) = jpjglo-2-(bounds(2,1,2)-jpjglo)
464
465	IF (ptx == 2) THEN ! T, V points
466	bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+2
467	bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+2
468	ELSE ! U, F points
469	bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+1
470	bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+1
471	ENDIF
472
473	IF (pty == 2) THEN ! T, U points
474	bounds_chunks(1,2,1,2) = jpjglo-2-(bounds(2,2,2) -jpjglo)
475	bounds_chunks(1,2,2,2) = jpjglo-2-(bounds(2,1,2) -jpjglo)
476	ELSE ! V, F points
477	bounds_chunks(1,2,1,2) = jpjglo-3-(bounds(2,2,2) -jpjglo)
478	bounds_chunks(1,2,2,2) = jpjglo-3-(bounds(2,1,2) -jpjglo)
479	ENDIF
480
481	correction_required(1)=.TRUE.
482
483	ENDIF ! bounds(2,1,2) <= jpjglo
484
485	ELSE IF (bounds(1,1,2) < 1) THEN
486
487	IF (bounds(1,2,2) > 0) THEN
488	nb_chunks = 2
489	ALLOCATE(correction_required(nb_chunks))
490	correction_required=.FALSE.
491	ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
492	DO i=1,nb_chunks
493	bounds_chunks(i,:,:,:) = bounds
494	END DO
495
496	bounds_chunks(1,1,1,2) = bounds(1,1,2)+jpiglo-2
497	bounds_chunks(1,1,2,2) = 1+jpiglo-2
498
499	bounds_chunks(1,1,1,1) = bounds(1,1,2)
500	bounds_chunks(1,1,2,1) = 1
501
502	bounds_chunks(2,1,1,2) = 2
503	bounds_chunks(2,1,2,2) = bounds(1,2,2)
504
505	bounds_chunks(2,1,1,1) = 2
506	bounds_chunks(2,1,2,1) = bounds(1,2,2)
507	ELSE
508	nb_chunks = 1
509	ALLOCATE(correction_required(nb_chunks))
510	correction_required=.FALSE.
511	ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
512	DO i=1,nb_chunks
513	bounds_chunks(i,:,:,:) = bounds
514	END DO
515	bounds_chunks(1,1,1,2) = bounds(1,1,2)+jpiglo-2
516	bounds_chunks(1,1,2,2) = bounds(1,2,2)+jpiglo-2
517
518	bounds_chunks(1,1,1,1) = bounds(1,1,2)
519	bounds_chunks(1,1,2,1) = bounds(1,2,2)
520	ENDIF
521
522	ELSE
523
524	nb_chunks=1
525	ALLOCATE(correction_required(nb_chunks))
526	correction_required=.FALSE.
527	ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
528	DO i=1,nb_chunks
529	bounds_chunks(i,:,:,:) = bounds
530	END DO
531	bounds_chunks(1,1,1,2) = bounds(1,1,2)
532	bounds_chunks(1,1,2,2) = bounds(1,2,2)
533	bounds_chunks(1,2,1,2) = bounds(2,1,2)
534	bounds_chunks(1,2,2,2) = bounds(2,2,2)
535
536	bounds_chunks(1,1,1,1) = bounds(1,1,2)
537	bounds_chunks(1,1,2,1) = bounds(1,2,2)
538	bounds_chunks(1,2,1,1) = bounds(2,1,2)
539	bounds_chunks(1,2,2,1) = bounds(2,2,2)
540
541	ENDIF
542
543	END SUBROUTINE nemo_mapping
544
545	FUNCTION agrif_external_switch_index(ptx,pty,i1,isens)
546	USE dom_oce
547	INTEGER :: ptx, pty, i1, isens
548	INTEGER :: agrif_external_switch_index
549
550	IF( isens == 1 ) THEN
551	IF( ptx == 2 ) THEN ! T, V points
552	agrif_external_switch_index = jpiglo-i1+2
553	ELSE ! U, F points
554	agrif_external_switch_index = jpiglo-i1+1
555	ENDIF
556	ELSE IF (isens ==2) THEN
557	IF (pty == 2) THEN ! T, U points
558	agrif_external_switch_index = jpjglo-2-(i1 -jpjglo)
559	ELSE ! V, F points
560	agrif_external_switch_index = jpjglo-3-(i1 -jpjglo)
561	ENDIF
562	ENDIF
563
564	END FUNCTION agrif_external_switch_index
565
566	SUBROUTINE correct_field(tab2d,i1,i2,j1,j2)
567	USE dom_oce
568	INTEGER :: i1,i2,j1,j2
569	REAL,DIMENSION(i1:i2,j1:j2) :: tab2d
570
571	INTEGER :: i,j
572	REAL,DIMENSION(i1:i2,j1:j2) :: tab2dtemp
573
574	tab2dtemp = tab2d
575
576	DO j=j1,j2
577	DO i=i1,i2
578	tab2d(i,j)=tab2dtemp(i2-(i-i1),j2-(j-j1))
579	END DO
580	ENDDO
581
582	END SUBROUTINE correct_field
583
584	SUBROUTINE agrif_init_lonlat()
585	USE agrif_profiles
586	USE agrif_util
587	USE dom_oce
588
589	EXTERNAL :: init_glamt, init_glamu, init_glamv, init_glamf
590	EXTERNAL :: init_gphit, init_gphiu, init_gphiv, init_gphif
591	EXTERNAL :: longitude_linear_interp
592
593	INTEGER :: ji,jj,i1,i2,j1,j2
594	REAL, DIMENSION(jpi,jpj) :: tab2dtemp
595	INTEGER :: ind2,ind3
596	INTEGER :: irhox, irhoy
597
598	irhox = agrif_irhox()
599	irhoy = agrif_irhoy()
600	CALL Agrif_Set_external_linear_interp(longitude_linear_interp)
601
602	CALL Agrif_Init_variable(glamt_id, procname = init_glamt)
603	CALL Agrif_Init_variable(glamu_id, procname = init_glamu)
604	CALL Agrif_Init_variable(glamv_id, procname = init_glamv)
605	CALL Agrif_Init_variable(glamf_id, procname = init_glamf)
606	CALL Agrif_UnSet_external_linear_interp()
607
608	CALL Agrif_Init_variable(gphit_id, procname = init_gphit)
609	CALL Agrif_Init_variable(gphiu_id, procname = init_gphiu)
610	CALL Agrif_Init_variable(gphiv_id, procname = init_gphiv)
611	CALL Agrif_Init_variable(gphif_id, procname = init_gphif)
612
613	END SUBROUTINE agrif_init_lonlat
614
615	REAL FUNCTION longitude_linear_interp(x1,x2,coeff)
616	REAL :: x1, x2, coeff
617	REAL :: val_interp
618
619	IF( (x1x2 <= -5050) ) THEN
620	IF( x1 < 0 ) THEN
621	val_interp = coeff (x1+360.) + (1.-coeff) x2
622	ELSE
623	val_interp = coeff x1 + (1.-coeff) (x2+360.)
624	ENDIF
625	IF ((val_interp) >=180.) val_interp = val_interp - 360.
626	ELSE
627	val_interp = coeff * x1 + (1.-coeff) * x2
628	ENDIF
629	longitude_linear_interp = val_interp
630
631	END FUNCTION longitude_linear_interp
632
633	SUBROUTINE agrif_init_scales()
634	USE agrif_profiles
635	USE agrif_util
636	USE dom_oce
637	USE lbclnk
638	LOGICAL :: ln_perio
639	INTEGER nx,ny
640
641	EXTERNAL :: init_e1t, init_e1u, init_e1v, init_e1f
642	EXTERNAL :: init_e2t, init_e2u, init_e2v, init_e2f
643
644	nx = nlci ; ny = nlcj
645
646	ln_perio=.FALSE.
647	if( jperio ==1 .OR. jperio==2 .OR. jperio==4) ln_perio=.TRUE.
648
649	CALL Agrif_Init_variable(e1t_id, procname = init_e1t)
650	CALL Agrif_Init_variable(e1u_id, procname = init_e1u)
651	CALL Agrif_Init_variable(e1v_id, procname = init_e1v)
652	CALL Agrif_Init_variable(e1f_id, procname = init_e1f)
653
654	CALL Agrif_Init_variable(e2t_id, procname = init_e2t)
655	CALL Agrif_Init_variable(e2u_id, procname = init_e2u)
656	CALL Agrif_Init_variable(e2v_id, procname = init_e2v)
657	CALL Agrif_Init_variable(e2f_id, procname = init_e2f)
658
659	CALL lbc_lnk( 'e1t', e1t, 'T', 1._wp)
660	CALL lbc_lnk( 'e2t', e2t, 'T', 1._wp)
661	CALL lbc_lnk( 'e1u', e1u, 'U', 1._wp)
662	CALL lbc_lnk( 'e2u', e2u, 'U', 1._wp)
663	CALL lbc_lnk( 'e1v', e1v, 'V', 1._wp)
664	CALL lbc_lnk( 'e2v', e2v, 'V', 1._wp)
665	CALL lbc_lnk( 'e1f', e1f, 'F', 1._wp)
666	CALL lbc_lnk( 'e2f', e2f, 'F', 1._wp)
667
668	END SUBROUTINE agrif_init_scales
669
670	SUBROUTINE init_glamt( ptab, i1, i2, j1, j2, before, nb,ndir)
671	USE dom_oce
672	!!----------------------------------------------------------------------
673	!! * ROUTINE interpsshn *
674	!!----------------------------------------------------------------------
675	INTEGER , INTENT(in ) :: i1, i2, j1, j2
676	REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
677	LOGICAL , INTENT(in ) :: before
678	INTEGER , INTENT(in ) :: nb , ndir
679
680	!
681	!!----------------------------------------------------------------------
682	!
683	IF( before) THEN
684	ptab(i1:i2,j1:j2) = glamt(i1:i2,j1:j2)
685	ELSE
686	glamt(i1:i2,j1:j2) = ptab(i1:i2,j1:j2)
687	ENDIF
688	!
689	END SUBROUTINE init_glamt
690
691	SUBROUTINE init_glamu( ptab, i1, i2, j1, j2, before, nb,ndir)
692	USE dom_oce
693	!!----------------------------------------------------------------------
694	!! * ROUTINE interpsshn *
695	!!----------------------------------------------------------------------
696	INTEGER , INTENT(in ) :: i1, i2, j1, j2
697	REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
698	LOGICAL , INTENT(in ) :: before
699	INTEGER , INTENT(in ) :: nb , ndir
700	LOGICAL :: western_side, eastern_side,northern_side,southern_side
701	!
702	!!----------------------------------------------------------------------
703	!
704	IF( before) THEN
705	ptab(i1:i2,j1:j2) = glamu(i1:i2,j1:j2)
706	ELSE
707	glamu(i1:i2,j1:j2) = ptab(i1:i2,j1:j2)
708	ENDIF
709	!
710	END SUBROUTINE init_glamu
711
712	SUBROUTINE init_glamv( ptab, i1, i2, j1, j2, before, nb,ndir)
713	USE dom_oce
714	!!----------------------------------------------------------------------
715	!! * ROUTINE interpsshn *
716	!!----------------------------------------------------------------------
717	INTEGER , INTENT(in ) :: i1, i2, j1, j2
718	REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
719	LOGICAL , INTENT(in ) :: before
720	INTEGER , INTENT(in ) :: nb , ndir
721	!
722	!!----------------------------------------------------------------------
723	!
724	IF( before) THEN
725	ptab(i1:i2,j1:j2) = glamv(i1:i2,j1:j2)
726	ELSE
727	glamv(i1:i2,j1:j2) = ptab(i1:i2,j1:j2)
728	ENDIF
729	!
730	END SUBROUTINE init_glamv
731
732	SUBROUTINE init_glamf( ptab, i1, i2, j1, j2, before, nb,ndir)
733	USE dom_oce
734	!!----------------------------------------------------------------------
735	!! * ROUTINE init_glamf *
736	!!----------------------------------------------------------------------
737	INTEGER , INTENT(in ) :: i1, i2, j1, j2
738	REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
739	LOGICAL , INTENT(in ) :: before
740	INTEGER , INTENT(in ) :: nb , ndir
741	!
742	!!----------------------------------------------------------------------
743	!
744	IF( before) THEN
745	ptab(i1:i2,j1:j2) = glamf(i1:i2,j1:j2)
746	ELSE
747	glamf(i1:i2,j1:j2) = ptab(i1:i2,j1:j2)
748	ENDIF
749	!
750	END SUBROUTINE init_glamf
751
752	SUBROUTINE init_gphit( ptab, i1, i2, j1, j2, before, nb,ndir)
753	USE dom_oce
754	!!----------------------------------------------------------------------
755	!! * ROUTINE init_gphit *
756	!!----------------------------------------------------------------------
757	INTEGER , INTENT(in ) :: i1, i2, j1, j2
758	REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
759	LOGICAL , INTENT(in ) :: before
760	INTEGER , INTENT(in ) :: nb , ndir
761	!
762	!!----------------------------------------------------------------------
763	!
764	IF( before) THEN
765	ptab(i1:i2,j1:j2) = gphit(i1:i2,j1:j2)
766	ELSE
767	gphit(i1:i2,j1:j2)=ptab
768	ENDIF
769	!
770	END SUBROUTINE init_gphit
771
772	SUBROUTINE init_gphiu( ptab, i1, i2, j1, j2, before, nb,ndir)
773	USE dom_oce
774	!!----------------------------------------------------------------------
775	!! * ROUTINE init_gphiu *
776	!!----------------------------------------------------------------------
777	INTEGER , INTENT(in ) :: i1, i2, j1, j2
778	REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
779	LOGICAL , INTENT(in ) :: before
780	INTEGER , INTENT(in ) :: nb , ndir
781	!
782	!!----------------------------------------------------------------------
783	!
784	IF( before) THEN
785	ptab(i1:i2,j1:j2) = gphiu(i1:i2,j1:j2)
786	ELSE
787	gphiu(i1:i2,j1:j2)=ptab
788	ENDIF
789	!
790	END SUBROUTINE init_gphiu
791
792	SUBROUTINE init_gphiv( ptab, i1, i2, j1, j2, before, nb,ndir)
793	USE dom_oce
794	!!----------------------------------------------------------------------
795	!! * ROUTINE init_gphiv *
796	!!----------------------------------------------------------------------
797	INTEGER , INTENT(in ) :: i1, i2, j1, j2
798	REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
799	LOGICAL , INTENT(in ) :: before
800	INTEGER , INTENT(in ) :: nb , ndir
801	!
802	!!----------------------------------------------------------------------
803
804	IF( before) THEN
805	ptab(i1:i2,j1:j2) = gphiv(i1:i2,j1:j2)
806	ELSE
807	gphiv(i1:i2,j1:j2)=ptab
808	ENDIF
809	!
810	END SUBROUTINE init_gphiv
811
812
813	SUBROUTINE init_gphif( ptab, i1, i2, j1, j2, before, nb,ndir)
814	USE dom_oce
815	!!----------------------------------------------------------------------
816	!! * ROUTINE init_gphif *
817	!!----------------------------------------------------------------------
818	INTEGER , INTENT(in ) :: i1, i2, j1, j2
819	REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
820	LOGICAL , INTENT(in ) :: before
821	INTEGER , INTENT(in ) :: nb , ndir
822	!
823	!!----------------------------------------------------------------------
824	!
825	IF( before) THEN
826	ptab(i1:i2,j1:j2) = gphif(i1:i2,j1:j2)
827	ELSE
828	gphif(i1:i2,j1:j2)=ptab
829	ENDIF
830	!
831	END SUBROUTINE init_gphif
832
833
834	SUBROUTINE init_e1t( ptab, i1, i2, j1, j2, before, nb,ndir)
835	USE dom_oce
836	USE agrif_parameters
837	!!----------------------------------------------------------------------
838	!! * ROUTINE init_e1t *
839	!!----------------------------------------------------------------------
840	INTEGER , INTENT(in ) :: i1, i2, j1, j2
841	REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
842	LOGICAL , INTENT(in ) :: before
843	INTEGER , INTENT(in ) :: nb , ndir
844	!
845	!!----------------------------------------------------------------------
846	!
847	INTEGER :: jj
848
849	IF( before) THEN
850	! May need to extend at south boundary
851	IF (j1<1) THEN
852	IF (.NOT.agrif_child(ln_bry_south)) THEN
853	IF ((nbondj == -1).OR.(nbondj == 2)) THEN
854	DO jj=1,j2
855	ptab(i1:i2,jj)=e1t(i1:i2,jj)
856	ENDDO
857	DO jj=j1,0
858	ptab(i1:i2,jj)=e1t(i1:i2,1)
859	ENDDO
860	ENDIF
861	ELSE
862	stop "OUT OF BOUNDS"
863	ENDIF
864	ELSE
865	ptab(i1:i2,j1:j2) = e1t(i1:i2,j1:j2)
866	ENDIF
867	ELSE
868	e1t(i1:i2,j1:j2)=ptab/Agrif_rhoy()
869	ENDIF
870	!
871	END SUBROUTINE init_e1t
872
873	SUBROUTINE init_e1u( ptab, i1, i2, j1, j2, before, nb,ndir)
874	USE dom_oce
875	USE agrif_parameters
876	!!----------------------------------------------------------------------
877	!! * ROUTINE init_e1u *
878	!!----------------------------------------------------------------------
879	INTEGER , INTENT(in ) :: i1, i2, j1, j2
880	REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
881	LOGICAL , INTENT(in ) :: before
882	INTEGER , INTENT(in ) :: nb , ndir
883	!
884	!!----------------------------------------------------------------------
885	!
886	INTEGER :: jj
887
888	IF( before) THEN
889	IF (j1<1) THEN
890	IF (.NOT.agrif_child(ln_bry_south)) THEN
891	IF ((nbondj == -1).OR.(nbondj == 2)) THEN
892	DO jj=1,j2
893	ptab(i1:i2,jj)=e1u(i1:i2,jj)
894	ENDDO
895	DO jj=j1,0
896	ptab(i1:i2,jj)=e1u(i1:i2,1)
897	ENDDO
898	ENDIF
899	ELSE
900	stop "OUT OF BOUNDS"
901	ENDIF
902	ELSE
903	ptab(i1:i2,j1:j2) = e1u(i1:i2,j1:j2)
904	ENDIF
905	ELSE
906	e1u(i1:i2,j1:j2)=ptab/Agrif_rhoy()
907	ENDIF
908	!
909	END SUBROUTINE init_e1u
910
911	SUBROUTINE init_e1v( ptab, i1, i2, j1, j2, before, nb,ndir)
912	USE dom_oce
913	!!----------------------------------------------------------------------
914	!! * ROUTINE init_e1v *
915	!!----------------------------------------------------------------------
916	INTEGER , INTENT(in ) :: i1, i2, j1, j2
917	REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
918	LOGICAL , INTENT(in ) :: before
919	INTEGER , INTENT(in ) :: nb , ndir
920	!
921	!!----------------------------------------------------------------------
922	!
923	IF( before) THEN
924	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2)
925	ELSE
926	e1v(i1:i2,j1:j2)=ptab/Agrif_rhoy()
927	ENDIF
928	!
929	END SUBROUTINE init_e1v
930
931	SUBROUTINE init_e1f( ptab, i1, i2, j1, j2, before, nb,ndir)
932	USE dom_oce
933	!!----------------------------------------------------------------------
934	!! * ROUTINE init_e1f *
935	!!----------------------------------------------------------------------
936	INTEGER , INTENT(in ) :: i1, i2, j1, j2
937	REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
938	LOGICAL , INTENT(in ) :: before
939	INTEGER , INTENT(in ) :: nb , ndir
940	!
941	!!----------------------------------------------------------------------
942	!
943	IF( before) THEN
944	ptab(i1:i2,j1:j2) = e1f(i1:i2,j1:j2)
945	ELSE
946	e1f(i1:i2,j1:j2)=ptab/Agrif_rhoy()
947	ENDIF
948	!
949	END SUBROUTINE init_e1f
950
951	SUBROUTINE init_e2t( ptab, i1, i2, j1, j2, before, nb,ndir)
952	USE dom_oce
953	USE agrif_parameters
954	!!----------------------------------------------------------------------
955	!! * ROUTINE init_e2t *
956	!!----------------------------------------------------------------------
957	INTEGER , INTENT(in ) :: i1, i2, j1, j2
958	REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
959	LOGICAL , INTENT(in ) :: before
960	INTEGER , INTENT(in ) :: nb , ndir
961	!
962	!!----------------------------------------------------------------------
963	!
964	INTEGER :: jj
965
966	IF( before) THEN
967	IF (j1<1) THEN
968	IF (.NOT.agrif_child(ln_bry_south)) THEN
969	IF ((nbondj == -1).OR.(nbondj == 2)) THEN
970	DO jj=1,j2
971	ptab(i1:i2,jj)=e2t(i1:i2,jj)
972	ENDDO
973	DO jj=j1,0
974	ptab(i1:i2,jj)=e2t(i1:i2,1)
975	ENDDO
976	ENDIF
977	ELSE
978	stop "OUT OF BOUNDS"
979	ENDIF
980	ELSE
981	ptab(i1:i2,j1:j2) = e2t(i1:i2,j1:j2)
982	ENDIF
983	ELSE
984	e2t(i1:i2,j1:j2)=ptab/Agrif_rhoy()
985	ENDIF
986	!
987	END SUBROUTINE init_e2t
988
989	SUBROUTINE init_e2u( ptab, i1, i2, j1, j2, before, nb,ndir)
990	USE dom_oce
991	USE agrif_parameters
992	!!----------------------------------------------------------------------
993	!! * ROUTINE interpsshn *
994	!!----------------------------------------------------------------------
995	INTEGER , INTENT(in ) :: i1, i2, j1, j2
996	REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
997	LOGICAL , INTENT(in ) :: before
998	INTEGER , INTENT(in ) :: nb , ndir
999	!
1000	!!----------------------------------------------------------------------
1001	!
1002	INTEGER :: jj
1003
1004	IF( before) THEN
1005	IF (j1<1) THEN
1006	IF (.NOT.agrif_child(ln_bry_south)) THEN
1007	IF ((nbondj == -1).OR.(nbondj == 2)) THEN
1008	DO jj=1,j2
1009	ptab(i1:i2,jj)=e2u(i1:i2,jj)
1010	ENDDO
1011	DO jj=j1,0
1012	ptab(i1:i2,jj)=e2u(i1:i2,1)
1013	ENDDO
1014	ENDIF
1015	ELSE
1016	stop "OUT OF BOUNDS"
1017	ENDIF
1018	ELSE
1019	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2)
1020	ENDIF
1021	ELSE
1022	e2u(i1:i2,j1:j2)=ptab/Agrif_rhoy()
1023	ENDIF
1024	!
1025	END SUBROUTINE init_e2u
1026
1027	SUBROUTINE init_e2v( ptab, i1, i2, j1, j2, before, nb,ndir)
1028	USE dom_oce
1029	!!----------------------------------------------------------------------
1030	!! * ROUTINE interpsshn *
1031	!!----------------------------------------------------------------------
1032	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1033	REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1034	LOGICAL , INTENT(in ) :: before
1035	INTEGER , INTENT(in ) :: nb , ndir
1036	!
1037	!!----------------------------------------------------------------------
1038	IF( before) THEN
1039	ptab(i1:i2,j1:j2) = e2v(i1:i2,j1:j2)
1040	ELSE
1041	e2v(i1:i2,j1:j2)=ptab/Agrif_rhoy()
1042	ENDIF
1043	!
1044	END SUBROUTINE init_e2v
1045
1046	SUBROUTINE init_e2f( ptab, i1, i2, j1, j2, before, nb,ndir)
1047	USE dom_oce
1048	!!----------------------------------------------------------------------
1049	!! * ROUTINE interpsshn *
1050	!!----------------------------------------------------------------------
1051	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1052	REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1053	LOGICAL , INTENT(in ) :: before
1054	INTEGER , INTENT(in ) :: nb , ndir
1055	!
1056	!!----------------------------------------------------------------------
1057	!
1058	IF( before) THEN
1059	ptab(i1:i2,j1:j2) = e2f(i1:i2,j1:j2)
1060	ELSE
1061	e2f(i1:i2,j1:j2)=ptab/Agrif_rhoy()
1062	ENDIF
1063	!
1064	END SUBROUTINE init_e2f
1065
1066
1067	SUBROUTINE agrif_nemo_init
1068	USE agrif_parameters
1069	USE dom_oce
1070	USE in_out_manager
1071	USE lib_mpp
1072	!!
1073	IMPLICIT NONE
1074
1075	INTEGER :: ios
1076
1077	NAMELIST/namagrif/ nn_cln_update,ln_spc_dyn,rn_sponge_tra,rn_sponge_dyn,ln_chk_bathy,npt_connect, &
1078	& npt_copy, ln_bry_south
1079
1080	REWIND( numnam_ref ) ! Namelist namagrif in reference namelist : nesting parameters
1081	READ ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901 )
1082	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist', lwp )
1083
1084	REWIND( numnam_cfg ) ! Namelist namzgr in configuration namelist : nesting parameters
1085	READ ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 )
1086	902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist', lwp )
1087	IF(lwm) WRITE ( numond, namagrif )
1088
1089	IF(lwp) THEN ! Control print
1090	WRITE(numout,*)
1091	WRITE(numout,*) 'agrif_nemo_init : nesting'
1092	WRITE(numout,*) '~~~~~~~'
1093	WRITE(numout,*) ' Namelist namagrif : set nesting parameters'
1094	WRITE(numout,*) ' npt_copy = ', npt_copy
1095	WRITE(numout,*) ' npt_connect = ', npt_connect
1096	WRITE(numout,*) ' ln_bry_south = ', ln_bry_south
1097	ENDIF
1098
1099	! Set the number of ghost cells according to periodicity
1100
1101	nbghostcells_x = nbghostcells
1102	nbghostcells_y_s = nbghostcells
1103	nbghostcells_y_n = nbghostcells
1104
1105	IF (.not.agrif_root()) THEN
1106	IF (jperio == 1) THEN
1107	nbghostcells_x = 0
1108	ENDIF
1109	IF (.NOT.ln_bry_south) THEN
1110	nbghostcells_y_s = 0
1111	ENDIF
1112	ENDIF
1113
1114	END SUBROUTINE agrif_nemo_init
1115
1116	SUBROUTINE Agrif_detect( kg, ksizex )
1117	!!----------------------------------------------------------------------
1118	!! * ROUTINE Agrif_detect *
1119	!!----------------------------------------------------------------------
1120	INTEGER, DIMENSION(2) :: ksizex
1121	INTEGER, DIMENSION(ksizex(1),ksizex(2)) :: kg
1122	!!----------------------------------------------------------------------
1123	!
1124	RETURN
1125	!
1126	END SUBROUTINE Agrif_detect
1127
1128	SUBROUTINE agrif_before_regridding
1129	END SUBROUTINE agrif_before_regridding
1130
1131	# if defined key_mpp_mpi
1132	SUBROUTINE Agrif_InvLoc( indloc, nprocloc, i, indglob )
1133	!!----------------------------------------------------------------------
1134	!! * ROUTINE Agrif_InvLoc *
1135	!!----------------------------------------------------------------------
1136	USE dom_oce
1137	!!
1138	IMPLICIT NONE
1139	!
1140	INTEGER :: indglob, indloc, nprocloc, i
1141	!!----------------------------------------------------------------------
1142	!
1143	SELECT CASE( i )
1144	CASE(1) ; indglob = indloc + nimppt(nprocloc+1) - 1
1145	CASE(2) ; indglob = indloc + njmppt(nprocloc+1) - 1
1146	CASE DEFAULT
1147	indglob = indloc
1148	END SELECT
1149	!
1150	END SUBROUTINE Agrif_InvLoc
1151
1152	SUBROUTINE Agrif_get_proc_info( imin, imax, jmin, jmax )
1153	!!----------------------------------------------------------------------
1154	!! * ROUTINE Agrif_get_proc_info *
1155	!!----------------------------------------------------------------------
1156	USE par_oce
1157	USE dom_oce
1158	!!
1159	IMPLICIT NONE
1160	!
1161	INTEGER, INTENT(out) :: imin, imax
1162	INTEGER, INTENT(out) :: jmin, jmax
1163	!!----------------------------------------------------------------------
1164	!
1165	imin = nimppt(Agrif_Procrank+1) ! ?????
1166	jmin = njmppt(Agrif_Procrank+1) ! ?????
1167	imax = imin + jpi - 1
1168	jmax = jmin + jpj - 1
1169	!
1170	END SUBROUTINE Agrif_get_proc_info
1171
1172	SUBROUTINE Agrif_estimate_parallel_cost(imin, imax,jmin, jmax, nbprocs, grid_cost)
1173	!!----------------------------------------------------------------------
1174	!! * ROUTINE Agrif_estimate_parallel_cost *
1175	!!----------------------------------------------------------------------
1176	USE par_oce
1177	!!
1178	IMPLICIT NONE
1179	!
1180	INTEGER, INTENT(in) :: imin, imax
1181	INTEGER, INTENT(in) :: jmin, jmax
1182	INTEGER, INTENT(in) :: nbprocs
1183	REAL(wp), INTENT(out) :: grid_cost
1184	!!----------------------------------------------------------------------
1185	!
1186	grid_cost = REAL(imax-imin+1,wp)*REAL(jmax-jmin+1,wp) / REAL(nbprocs,wp)
1187	!
1188	END SUBROUTINE Agrif_estimate_parallel_cost
1189	# endif
1190	#endif

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

Download in other formats: