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_opa_interp.F90 in branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/NST_SRC – NEMO

Context Navigation

source: branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90 @ 4317

Last change on this file since 4317 was 4292, checked in by cetlod, 10 years ago
dev_MERGE_2013 : 1st step of the merge, see ticket #1185
Property svn:keywords set to `Id`
File size: 28.0 KB

Line
1	MODULE agrif_opa_interp
2	!!======================================================================
3	!! * MODULE agrif_opa_interp *
4	!! AGRIF: interpolation package
5	!!======================================================================
6	!! History : 2.0 ! 2002-06 (XXX) Original cade
7	!! - ! 2005-11 (XXX)
8	!! 3.2 ! 2009-04 (R. Benshila)
9	!!----------------------------------------------------------------------
10	#if defined key_agrif && ! defined key_offline
11	!!----------------------------------------------------------------------
12	!! 'key_agrif' AGRIF zoom
13	!! NOT 'key_offline' NO off-line tracers
14	!!----------------------------------------------------------------------
15	!! Agrif_tra :
16	!! Agrif_dyn :
17	!! interpu :
18	!! interpv :
19	!!----------------------------------------------------------------------
20	USE par_oce
21	USE oce
22	USE dom_oce
23	USE sol_oce
24	USE agrif_oce
25	USE phycst
26	USE in_out_manager
27	USE agrif_opa_sponge
28	USE lib_mpp
29	USE wrk_nemo
30	USE dynspg_oce
31
32	IMPLICIT NONE
33	PRIVATE
34
35	! Barotropic arrays used to store open boundary data during
36	! time-splitting loop:
37	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_w, vbdy_w, hbdy_w
38	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_e, vbdy_e, hbdy_e
39	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_n, vbdy_n, hbdy_n
40	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_s, vbdy_s, hbdy_s
41
42	PUBLIC Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts
43	PUBLIC interpu, interpv, interpunb, interpvnb, interpsshn
44
45	# include "domzgr_substitute.h90"
46	# include "vectopt_loop_substitute.h90"
47	!!----------------------------------------------------------------------
48	!! NEMO/NST 3.3 , NEMO Consortium (2010)
49	!! $Id$
50	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
51	!!----------------------------------------------------------------------
52
53	CONTAINS
54
55	SUBROUTINE Agrif_tra
56	!!----------------------------------------------------------------------
57	!! * ROUTINE Agrif_Tra *
58	!!----------------------------------------------------------------------
59	!!
60	INTEGER :: ji, jj, jk, jn ! dummy loop indices
61	REAL(wp) :: zrhox , alpha1, alpha2, alpha3
62	REAL(wp) :: alpha4, alpha5, alpha6, alpha7
63	REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztsa
64	!!----------------------------------------------------------------------
65	!
66	IF( Agrif_Root() ) RETURN
67
68	CALL wrk_alloc( jpi, jpj, jpk, jpts, ztsa )
69
70	Agrif_SpecialValue = 0.e0
71	Agrif_UseSpecialValue = .TRUE.
72	ztsa(:,:,:,:) = 0.e0
73
74	CALL Agrif_Bc_variable( ztsa, tsn_id, procname=interptsn )
75	Agrif_UseSpecialValue = .FALSE.
76
77	zrhox = Agrif_Rhox()
78
79	alpha1 = ( zrhox - 1. ) * 0.5
80	alpha2 = 1. - alpha1
81
82	alpha3 = ( zrhox - 1. ) / ( zrhox + 1. )
83	alpha4 = 1. - alpha3
84
85	alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )
86	alpha7 = - ( zrhox - 1. ) / ( zrhox + 3. )
87	alpha5 = 1. - alpha6 - alpha7
88
89	IF( nbondi == 1 .OR. nbondi == 2 ) THEN
90
91	DO jn = 1, jpts
92	tsa(nlci,:,:,jn) = alpha1 * ztsa(nlci,:,:,jn) + alpha2 * ztsa(nlci-1,:,:,jn)
93	DO jk = 1, jpkm1
94	DO jj = 1, jpj
95	IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN
96	tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk)
97	ELSE
98	tsa(nlci-1,jj,jk,jn)=(alpha4tsa(nlci,jj,jk,jn)+alpha3tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk)
99	IF( un(nlci-2,jj,jk) > 0.e0 ) THEN
100	tsa(nlci-1,jj,jk,jn)=( alpha6tsa(nlci-2,jj,jk,jn)+alpha5tsa(nlci,jj,jk,jn) &
101	& + alpha7tsa(nlci-3,jj,jk,jn) ) tmask(nlci-1,jj,jk)
102	ENDIF
103	ENDIF
104	END DO
105	END DO
106	ENDDO
107	ENDIF
108
109	IF( nbondj == 1 .OR. nbondj == 2 ) THEN
110
111	DO jn = 1, jpts
112	tsa(:,nlcj,:,jn) = alpha1 * ztsa(:,nlcj,:,jn) + alpha2 * ztsa(:,nlcj-1,:,jn)
113	DO jk = 1, jpkm1
114	DO ji = 1, jpi
115	IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN
116	tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk)
117	ELSE
118	tsa(ji,nlcj-1,jk,jn)=(alpha4tsa(ji,nlcj,jk,jn)+alpha3tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)
119	IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN
120	tsa(ji,nlcj-1,jk,jn)=( alpha6tsa(ji,nlcj-2,jk,jn)+alpha5tsa(ji,nlcj,jk,jn) &
121	& + alpha7tsa(ji,nlcj-3,jk,jn) ) tmask(ji,nlcj-1,jk)
122	ENDIF
123	ENDIF
124	END DO
125	END DO
126	ENDDO
127	ENDIF
128
129	IF( nbondi == -1 .OR. nbondi == 2 ) THEN
130	DO jn = 1, jpts
131	tsa(1,:,:,jn) = alpha1 * ztsa(1,:,:,jn) + alpha2 * ztsa(2,:,:,jn)
132	DO jk = 1, jpkm1
133	DO jj = 1, jpj
134	IF( umask(2,jj,jk) == 0.e0 ) THEN
135	tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk)
136	ELSE
137	tsa(2,jj,jk,jn)=(alpha4tsa(1,jj,jk,jn)+alpha3tsa(3,jj,jk,jn))*tmask(2,jj,jk)
138	IF( un(2,jj,jk) < 0.e0 ) THEN
139	tsa(2,jj,jk,jn)=(alpha6tsa(3,jj,jk,jn)+alpha5tsa(1,jj,jk,jn)+alpha7tsa(4,jj,jk,jn))tmask(2,jj,jk)
140	ENDIF
141	ENDIF
142	END DO
143	END DO
144	END DO
145	ENDIF
146
147	IF( nbondj == -1 .OR. nbondj == 2 ) THEN
148	DO jn = 1, jpts
149	tsa(:,1,:,jn) = alpha1 * ztsa(:,1,:,jn) + alpha2 * ztsa(:,2,:,jn)
150	DO jk=1,jpk
151	DO ji=1,jpi
152	IF( vmask(ji,2,jk) == 0.e0 ) THEN
153	tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk)
154	ELSE
155	tsa(ji,2,jk,jn)=(alpha4tsa(ji,1,jk,jn)+alpha3tsa(ji,3,jk,jn))*tmask(ji,2,jk)
156	IF( vn(ji,2,jk) < 0.e0 ) THEN
157	tsa(ji,2,jk,jn)=(alpha6tsa(ji,3,jk,jn)+alpha5tsa(ji,1,jk,jn)+alpha7tsa(ji,4,jk,jn))tmask(ji,2,jk)
158	ENDIF
159	ENDIF
160	END DO
161	END DO
162	ENDDO
163	ENDIF
164	!
165	CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztsa )
166	!
167	END SUBROUTINE Agrif_tra
168
169
170	SUBROUTINE Agrif_dyn( kt )
171	!!----------------------------------------------------------------------
172	!! * ROUTINE Agrif_DYN *
173	!!----------------------------------------------------------------------
174	!!
175	INTEGER, INTENT(in) :: kt
176	!!
177	INTEGER :: ji,jj,jk
178	REAL(wp) :: timeref
179	REAL(wp) :: z2dt, znugdt
180	REAL(wp) :: zrhox, zrhoy
181	REAL(wp), POINTER, DIMENSION(:,:,:) :: zua, zva
182	REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1, zua2d, zva2d
183	!!----------------------------------------------------------------------
184
185	IF( Agrif_Root() ) RETURN
186
187	CALL wrk_alloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d )
188	CALL wrk_alloc( jpi, jpj, jpk, zua, zva )
189
190	zrhox = Agrif_Rhox()
191	zrhoy = Agrif_Rhoy()
192
193	timeref = 1.
194
195	! time step: leap-frog
196	z2dt = 2. * rdt
197	! time step: Euler if restart from rest
198	IF( neuler == 0 .AND. kt == nit000 ) z2dt = rdt
199	! coefficients
200	znugdt = grav * z2dt
201
202	Agrif_SpecialValue=0.
203	Agrif_UseSpecialValue = ln_spc_dyn
204
205	zua = 0.
206	zva = 0.
207	CALL Agrif_Bc_variable(zua,un_id,procname=interpu)
208	CALL Agrif_Bc_variable(zva,vn_id,procname=interpv)
209	zua2d = 0.
210	zva2d = 0.
211
212	#if defined key_dynspg_flt
213	Agrif_SpecialValue=0.
214	Agrif_UseSpecialValue = ln_spc_dyn
215	CALL Agrif_Bc_variable(zua2d,e1u_id,calledweight=1.,procname=interpu2d)
216	CALL Agrif_Bc_variable(zva2d,e2v_id,calledweight=1.,procname=interpv2d)
217	#endif
218	Agrif_UseSpecialValue = .FALSE.
219
220
221	IF((nbondi == -1).OR.(nbondi == 2)) THEN
222
223	#if defined key_dynspg_flt
224	DO jj=1,jpj
225	laplacu(2,jj) = timeref * (zua2d(2,jj)/(zrhoye2u(2,jj)))umask(2,jj,1)
226	END DO
227	#endif
228
229	DO jk=1,jpkm1
230	DO jj=1,jpj
231	ua(1:2,jj,jk) = (zua(1:2,jj,jk)/(zrhoy*e2u(1:2,jj)))
232	ua(1:2,jj,jk) = ua(1:2,jj,jk) / fse3u(1:2,jj,jk)
233	END DO
234	END DO
235
236	#if defined key_dynspg_flt
237	DO jk=1,jpkm1
238	DO jj=1,jpj
239	ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk)
240	END DO
241	END DO
242
243	spgu(2,:)=0.
244
245	DO jk=1,jpkm1
246	DO jj=1,jpj
247	spgu(2,jj)=spgu(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk)
248	END DO
249	END DO
250
251	DO jj=1,jpj
252	IF (umask(2,jj,1).NE.0.) THEN
253	spgu(2,jj)=spgu(2,jj)/hu(2,jj)
254	ENDIF
255	END DO
256	#else
257	spgu(2,:) = ua_b(2,:)
258	#endif
259
260	DO jk=1,jpkm1
261	DO jj=1,jpj
262	ua(2,jj,jk) = 0.25(ua(1,jj,jk)+2.ua(2,jj,jk)+ua(3,jj,jk))
263	ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk)
264	END DO
265	END DO
266
267	spgu1(2,:)=0.
268
269	DO jk=1,jpkm1
270	DO jj=1,jpj
271	spgu1(2,jj)=spgu1(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk)
272	END DO
273	END DO
274
275	DO jj=1,jpj
276	IF (umask(2,jj,1).NE.0.) THEN
277	spgu1(2,jj)=spgu1(2,jj)/hu(2,jj)
278	ENDIF
279	END DO
280
281	DO jk=1,jpkm1
282	DO jj=1,jpj
283	ua(2,jj,jk) = (ua(2,jj,jk)+spgu(2,jj)-spgu1(2,jj))*umask(2,jj,jk)
284	END DO
285	END DO
286
287	DO jk=1,jpkm1
288	DO jj=1,jpj
289	va(2,jj,jk) = (zva(2,jj,jk)/(zrhoxe1v(2,jj)))vmask(2,jj,jk)
290	va(2,jj,jk) = va(2,jj,jk) / fse3v(2,jj,jk)
291	END DO
292	END DO
293
294	ENDIF
295
296	IF((nbondi == 1).OR.(nbondi == 2)) THEN
297	#if defined key_dynspg_flt
298	DO jj=1,jpj
299	laplacu(nlci-2,jj) = timeref * (zua2d(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj)))
300	END DO
301	#endif
302
303	DO jk=1,jpkm1
304	DO jj=1,jpj
305	ua(nlci-2:nlci-1,jj,jk) = (zua(nlci-2:nlci-1,jj,jk)/(zrhoy*e2u(nlci-2:nlci-1,jj)))
306
307	ua(nlci-2:nlci-1,jj,jk) = ua(nlci-2:nlci-1,jj,jk) / fse3u(nlci-2:nlci-1,jj,jk)
308
309	END DO
310	END DO
311
312	#if defined key_dynspg_flt
313	DO jk=1,jpkm1
314	DO jj=1,jpj
315	ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)- z2dt * znugdt * laplacu(nlci-2,jj))*umask(nlci-2,jj,jk)
316	END DO
317	END DO
318
319
320	spgu(nlci-2,:)=0.
321
322	do jk=1,jpkm1
323	do jj=1,jpj
324	spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk)
325	enddo
326	enddo
327
328	DO jj=1,jpj
329	IF (umask(nlci-2,jj,1).NE.0.) THEN
330	spgu(nlci-2,jj)=spgu(nlci-2,jj)/hu(nlci-2,jj)
331	ENDIF
332	END DO
333	#else
334	spgu(nlci-2,:) = ua_b(nlci-2,:)
335	#endif
336
337	DO jk=1,jpkm1
338	DO jj=1,jpj
339	ua(nlci-2,jj,jk) = 0.25(ua(nlci-3,jj,jk)+2.ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk))
340
341	ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk)
342
343	END DO
344	END DO
345
346	spgu1(nlci-2,:)=0.
347
348	DO jk=1,jpkm1
349	DO jj=1,jpj
350	spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u(nlci-2,jj,jk)ua(nlci-2,jj,jk)umask(nlci-2,jj,jk)
351	END DO
352	END DO
353
354	DO jj=1,jpj
355	IF (umask(nlci-2,jj,1).NE.0.) THEN
356	spgu1(nlci-2,jj)=spgu1(nlci-2,jj)/hu(nlci-2,jj)
357	ENDIF
358	END DO
359
360	DO jk=1,jpkm1
361	DO jj=1,jpj
362	ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)+spgu(nlci-2,jj)-spgu1(nlci-2,jj))*umask(nlci-2,jj,jk)
363	END DO
364	END DO
365
366	DO jk=1,jpkm1
367	DO jj=1,jpj-1
368	va(nlci-1,jj,jk) = (zva(nlci-1,jj,jk)/(zrhoxe1v(nlci-1,jj)))vmask(nlci-1,jj,jk)
369	va(nlci-1,jj,jk) = va(nlci-1,jj,jk) / fse3v(nlci-1,jj,jk)
370	END DO
371	END DO
372
373	ENDIF
374
375	IF((nbondj == -1).OR.(nbondj == 2)) THEN
376
377	#if defined key_dynspg_flt
378	DO ji=1,jpi
379	laplacv(ji,2) = timeref * (zva2d(ji,2)/(zrhox*e1v(ji,2)))
380	END DO
381	#endif
382
383	DO jk=1,jpkm1
384	DO ji=1,jpi
385	va(ji,1:2,jk) = (zva(ji,1:2,jk)/(zrhox*e1v(ji,1:2)))
386	va(ji,1:2,jk) = va(ji,1:2,jk) / fse3v(ji,1:2,jk)
387	END DO
388	END DO
389
390	#if defined key_dynspg_flt
391	DO jk=1,jpkm1
392	DO ji=1,jpi
393	va(ji,2,jk) = (va(ji,2,jk) - z2dt * znugdt * laplacv(ji,2))*vmask(ji,2,jk)
394	END DO
395	END DO
396
397	spgv(:,2)=0.
398
399	DO jk=1,jpkm1
400	DO ji=1,jpi
401	spgv(ji,2)=spgv(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk)
402	END DO
403	END DO
404
405	DO ji=1,jpi
406	IF (vmask(ji,2,1).NE.0.) THEN
407	spgv(ji,2)=spgv(ji,2)/hv(ji,2)
408	ENDIF
409	END DO
410	#else
411	spgv(:,2)=va_b(:,2)
412	#endif
413
414	DO jk=1,jpkm1
415	DO ji=1,jpi
416	va(ji,2,jk)=0.25(va(ji,1,jk)+2.va(ji,2,jk)+va(ji,3,jk))
417	va(ji,2,jk)=va(ji,2,jk)*vmask(ji,2,jk)
418	END DO
419	END DO
420
421	spgv1(:,2)=0.
422
423	DO jk=1,jpkm1
424	DO ji=1,jpi
425	spgv1(ji,2)=spgv1(ji,2)+fse3v(ji,2,jk)va(ji,2,jk)vmask(ji,2,jk)
426	END DO
427	END DO
428
429	DO ji=1,jpi
430	IF (vmask(ji,2,1).NE.0.) THEN
431	spgv1(ji,2)=spgv1(ji,2)/hv(ji,2)
432	ENDIF
433	END DO
434
435	DO jk=1,jpkm1
436	DO ji=1,jpi
437	va(ji,2,jk) = (va(ji,2,jk)+spgv(ji,2)-spgv1(ji,2))*vmask(ji,2,jk)
438	END DO
439	END DO
440
441	DO jk=1,jpkm1
442	DO ji=1,jpi
443	ua(ji,2,jk) = (zua(ji,2,jk)/(zrhoye2u(ji,2)))umask(ji,2,jk)
444	ua(ji,2,jk) = ua(ji,2,jk) / fse3u(ji,2,jk)
445	END DO
446	END DO
447
448	ENDIF
449
450	IF((nbondj == 1).OR.(nbondj == 2)) THEN
451
452	#if defined key_dynspg_flt
453	DO ji=1,jpi
454	laplacv(ji,nlcj-2) = timeref * (zva2d(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2)))
455	END DO
456	#endif
457
458	DO jk=1,jpkm1
459	DO ji=1,jpi
460	va(ji,nlcj-2:nlcj-1,jk) = (zva(ji,nlcj-2:nlcj-1,jk)/(zrhox*e1v(ji,nlcj-2:nlcj-1)))
461	va(ji,nlcj-2:nlcj-1,jk) = va(ji,nlcj-2:nlcj-1,jk) / fse3v(ji,nlcj-2:nlcj-1,jk)
462	END DO
463	END DO
464
465	#if defined key_dynspg_flt
466	DO jk=1,jpkm1
467	DO ji=1,jpi
468	va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)-z2dt * znugdt * laplacv(ji,nlcj-2))*vmask(ji,nlcj-2,jk)
469	END DO
470	END DO
471
472	spgv(:,nlcj-2)=0.
473
474	DO jk=1,jpkm1
475	DO ji=1,jpi
476	spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk)
477	END DO
478	END DO
479
480	DO ji=1,jpi
481	IF (vmask(ji,nlcj-2,1).NE.0.) THEN
482	spgv(ji,nlcj-2)=spgv(ji,nlcj-2)/hv(ji,nlcj-2)
483	ENDIF
484	END DO
485	#else
486	spgv(:,nlcj-2)=va_b(:,nlcj-2)
487	#endif
488
489	DO jk=1,jpkm1
490	DO ji=1,jpi
491	va(ji,nlcj-2,jk)=0.25(va(ji,nlcj-3,jk)+2.va(ji,nlcj-2,jk)+va(ji,nlcj-1,jk))
492	va(ji,nlcj-2,jk) = va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk)
493	END DO
494	END DO
495
496	spgv1(:,nlcj-2)=0.
497
498	DO jk=1,jpkm1
499	DO ji=1,jpi
500	spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk)
501	END DO
502	END DO
503
504	DO ji=1,jpi
505	IF (vmask(ji,nlcj-2,1).NE.0.) THEN
506	spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)/hv(ji,nlcj-2)
507	ENDIF
508	END DO
509
510	DO jk=1,jpkm1
511	DO ji=1,jpi
512	va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)+spgv(ji,nlcj-2)-spgv1(ji,nlcj-2))*vmask(ji,nlcj-2,jk)
513	END DO
514	END DO
515
516	DO jk=1,jpkm1
517	DO ji=1,jpi
518	ua(ji,nlcj-1,jk) = (zua(ji,nlcj-1,jk)/(zrhoye2u(ji,nlcj-1)))umask(ji,nlcj-1,jk)
519	ua(ji,nlcj-1,jk) = ua(ji,nlcj-1,jk) / fse3u(ji,nlcj-1,jk)
520	END DO
521	END DO
522
523	ENDIF
524	!
525	CALL wrk_dealloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d )
526	CALL wrk_dealloc( jpi, jpj, jpk, zua, zva )
527	!
528	END SUBROUTINE Agrif_dyn
529
530	SUBROUTINE Agrif_dyn_ts( kt, jn )
531	!!----------------------------------------------------------------------
532	!! * ROUTINE Agrif_dyn_ts *
533	!!----------------------------------------------------------------------
534	!!
535	INTEGER, INTENT(in) :: kt, jn
536	!!
537	INTEGER :: ji, jj
538	REAL(wp) :: zrhox, zrhoy
539	REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1
540	REAL(wp), POINTER, DIMENSION(:,:) :: zunb, zvnb, zsshn
541	!!----------------------------------------------------------------------
542
543	IF( Agrif_Root() ) RETURN
544
545	IF ((kt==nit000).AND.(jn==1)) THEN
546	ALLOCATE( ubdy_w(jpj), vbdy_w(jpj), hbdy_w(jpj))
547	ALLOCATE( ubdy_e(jpj), vbdy_e(jpj), hbdy_e(jpj))
548	ALLOCATE( ubdy_n(jpi), vbdy_n(jpi), hbdy_n(jpi))
549	ALLOCATE( ubdy_s(jpi), vbdy_s(jpi), hbdy_s(jpi))
550	ENDIF
551
552	IF (jn==1) THEN
553	! Fill boundary arrays at each baroclinic step
554	! with Parent grid barotropic fluxes and sea level
555	!
556	CALL wrk_alloc( jpi, jpj, zunb, zvnb, zsshn )
557
558	zrhox = Agrif_Rhox()
559	zrhoy = Agrif_Rhoy()
560
561	!alt Agrif_SpecialValue = 0.e0
562	!alt Agrif_UseSpecialValue = .TRUE.
563	!alt CALL Agrif_Bc_variable(zsshn, sshn_id, procname=interpsshn )
564	!alt Agrif_UseSpecialValue = .FALSE.
565
566	Agrif_SpecialValue=0.
567	Agrif_UseSpecialValue = ln_spc_dyn
568	zunb(:,:) = 0._wp ; zvnb(:,:) = 0._wp
569	CALL Agrif_Bc_variable(zunb,unb_id,procname=interpunb)
570	CALL Agrif_Bc_variable(zvnb,vnb_id,procname=interpvnb)
571	Agrif_UseSpecialValue = .FALSE.
572
573	IF((nbondi == -1).OR.(nbondi == 2)) THEN
574	DO jj=1,jpj
575	ubdy_w(jj) = (zunb(2,jj)/(zrhoy*e2u(2,jj)))
576	vbdy_w(jj) = (zvnb(2,jj)/(zrhox*e1v(2,jj)))
577	hbdy_w(jj) = zsshn(2,jj)
578	END DO
579	ENDIF
580
581	IF((nbondi == 1).OR.(nbondi == 2)) THEN
582	DO jj=1,jpj
583	ubdy_e(jj) = zunb(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj))
584	vbdy_e(jj) = zvnb(nlci-1,jj)/(zrhox*e1v(nlci-1,jj))
585	hbdy_e(jj) = zsshn(nlci-1,jj)
586	END DO
587	ENDIF
588
589	IF((nbondj == -1).OR.(nbondj == 2)) THEN
590	DO ji=1,jpi
591	ubdy_s(ji) = zunb(ji,2)/(zrhoy*e2u(ji,2))
592	vbdy_s(ji) = zvnb(ji,2)/(zrhox*e1v(ji,2))
593	hbdy_s(ji) = zsshn(ji,2)
594	END DO
595	ENDIF
596
597	IF((nbondj == 1).OR.(nbondj == 2)) THEN
598	DO ji=1,jpi
599	ubdy_n(ji) = zunb(ji,nlcj-1)/(zrhoy*e2u(ji,nlcj-1))
600	vbdy_n(ji) = zvnb(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2))
601	hbdy_n(ji) = zsshn(ji,nlcj-1)
602	END DO
603	ENDIF
604
605	CALL wrk_dealloc( jpi, jpj, zunb, zvnb, zsshn )
606	ENDIF ! jn==1
607
608	! Then update velocities at each barotropic time step
609	IF((nbondi == -1).OR.(nbondi == 2)) THEN
610	DO jj=1,jpj
611	va_e(2,jj) = vbdy_w(jj) * hvr_e(2,jj)
612	! Specified fluxes:
613	ua_e(2,jj) = ubdy_w(jj) * hur_e(2,jj)
614	! Characteristics method:
615	!alt ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) &
616	!alt & - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) )
617	END DO
618	ENDIF
619
620	IF((nbondi == 1).OR.(nbondi == 2)) THEN
621	DO jj=1,jpj
622	va_e(nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj)
623	! Specified fluxes:
624	ua_e(nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj)
625	! Characteristics method:
626	!alt ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) &
627	!alt & + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) )
628	END DO
629	ENDIF
630
631	IF((nbondj == -1).OR.(nbondj == 2)) THEN
632	DO ji=1,jpi
633	ua_e(ji,2) = ubdy_s(ji) * hur_e(ji,2)
634	! Specified fluxes:
635	va_e(ji,2) = vbdy_s(ji) * hvr_e(ji,2)
636	! Characteristics method:
637	!alt va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) &
638	!alt & - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) )
639	END DO
640	ENDIF
641
642	IF((nbondj == 1).OR.(nbondj == 2)) THEN
643	DO ji=1,jpi
644	ua_e(ji,nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-1)
645	! Specified fluxes:
646	va_e(ji,nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-2)
647	! Characteristics method:
648	!alt va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2) + va_e(ji,nlcj-3) &
649	!alt & + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) )
650	END DO
651	ENDIF
652	!
653	END SUBROUTINE Agrif_dyn_ts
654
655	SUBROUTINE Agrif_ssh( kt )
656	!!----------------------------------------------------------------------
657	!! * ROUTINE Agrif_DYN *
658	!!----------------------------------------------------------------------
659	INTEGER, INTENT(in) :: kt
660	!!
661	!!----------------------------------------------------------------------
662
663	IF( Agrif_Root() ) RETURN
664
665
666	IF((nbondi == -1).OR.(nbondi == 2)) THEN
667	ssha(2,:)=ssha(3,:)
668	sshn(2,:)=sshn(3,:)
669	ENDIF
670
671	IF((nbondi == 1).OR.(nbondi == 2)) THEN
672	ssha(nlci-1,:)=ssha(nlci-2,:)
673	sshn(nlci-1,:)=sshn(nlci-2,:)
674	ENDIF
675
676	IF((nbondj == -1).OR.(nbondj == 2)) THEN
677	ssha(:,2)=ssha(:,3)
678	sshn(:,2)=sshn(:,3)
679	ENDIF
680
681	IF((nbondj == 1).OR.(nbondj == 2)) THEN
682	ssha(:,nlcj-1)=ssha(:,nlcj-2)
683	sshn(:,nlcj-1)=sshn(:,nlcj-2)
684	ENDIF
685
686	END SUBROUTINE Agrif_ssh
687
688	SUBROUTINE Agrif_ssh_ts( kt )
689	!!----------------------------------------------------------------------
690	!! * ROUTINE Agrif_ssh_ts *
691	!!----------------------------------------------------------------------
692	INTEGER, INTENT(in) :: kt
693	!!
694	!!----------------------------------------------------------------------
695
696	IF((nbondi == -1).OR.(nbondi == 2)) THEN
697	ssha_e(2,:) = ssha_e(3,:)
698	ENDIF
699
700	IF((nbondi == 1).OR.(nbondi == 2)) THEN
701	ssha_e(nlci-1,:) = ssha_e(nlci-2,:)
702	ENDIF
703
704	IF((nbondj == -1).OR.(nbondj == 2)) THEN
705	ssha_e(:,2) = ssha_e(:,3)
706	ENDIF
707
708	IF((nbondj == 1).OR.(nbondj == 2)) THEN
709	ssha_e(:,nlcj-1) = ssha_e(:,nlcj-2)
710	ENDIF
711
712	END SUBROUTINE Agrif_ssh_ts
713
714	SUBROUTINE interpsshn(tabres,i1,i2,j1,j2)
715	!!----------------------------------------------------------------------
716	!! * ROUTINE interpsshn *
717	!!----------------------------------------------------------------------
718	INTEGER, INTENT(in) :: i1,i2,j1,j2
719	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
720	!!
721	INTEGER :: ji,jj
722	!!----------------------------------------------------------------------
723
724	tabres(i1:i2,j1:j2) = sshn(i1:i2,j1:j2)
725
726	END SUBROUTINE interpsshn
727
728	SUBROUTINE interpu(tabres,i1,i2,j1,j2,k1,k2)
729	!!----------------------------------------------------------------------
730	!! * ROUTINE interpu *
731	!!----------------------------------------------------------------------
732	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
733	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
734	!!
735	INTEGER :: ji,jj,jk
736	!!----------------------------------------------------------------------
737
738	DO jk=k1,k2
739	DO jj=j1,j2
740	DO ji=i1,i2
741	tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk)
742	tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u(ji,jj,jk)
743	END DO
744	END DO
745	END DO
746	END SUBROUTINE interpu
747
748
749	SUBROUTINE interpu2d(tabres,i1,i2,j1,j2)
750	!!----------------------------------------------------------------------
751	!! * ROUTINE interpu2d *
752	!!----------------------------------------------------------------------
753	INTEGER, INTENT(in) :: i1,i2,j1,j2
754	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
755	!!
756	INTEGER :: ji,jj
757	!!----------------------------------------------------------------------
758
759	DO jj=j1,j2
760	DO ji=i1,i2
761	tabres(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj)) &
762	* umask(ji,jj,1)
763	END DO
764	END DO
765
766	END SUBROUTINE interpu2d
767
768
769	SUBROUTINE interpv(tabres,i1,i2,j1,j2,k1,k2)
770	!!----------------------------------------------------------------------
771	!! * ROUTINE interpv *
772	!!----------------------------------------------------------------------
773	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
774	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
775	!!
776	INTEGER :: ji, jj, jk
777	!!----------------------------------------------------------------------
778
779	DO jk=k1,k2
780	DO jj=j1,j2
781	DO ji=i1,i2
782	tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk)
783	tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v(ji,jj,jk)
784	END DO
785	END DO
786	END DO
787
788	END SUBROUTINE interpv
789
790
791	SUBROUTINE interpv2d(tabres,i1,i2,j1,j2)
792	!!----------------------------------------------------------------------
793	!! * ROUTINE interpu2d *
794	!!----------------------------------------------------------------------
795	INTEGER, INTENT(in) :: i1,i2,j1,j2
796	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
797	!!
798	INTEGER :: ji,jj
799	!!----------------------------------------------------------------------
800
801	DO jj=j1,j2
802	DO ji=i1,i2
803	tabres(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) &
804	* vmask(ji,jj,1)
805	END DO
806	END DO
807
808	END SUBROUTINE interpv2d
809
810	SUBROUTINE interpunb(tabres,i1,i2,j1,j2)
811	!!----------------------------------------------------------------------
812	!! * ROUTINE interpunb *
813	!!----------------------------------------------------------------------
814	INTEGER, INTENT(in) :: i1,i2,j1,j2
815	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
816	!!
817	INTEGER :: ji,jj,jk
818	!!----------------------------------------------------------------------
819
820	tabres(:,:) = 0.e0
821	DO jk=1,jpkm1
822	DO jj=j1,j2
823	DO ji=i1,i2
824	tabres(ji,jj) = tabres(ji,jj) + e2u(ji,jj) * un(ji,jj,jk) &
825	* umask(ji,jj,jk) * fse3u(ji,jj,jk)
826	END DO
827	END DO
828	END DO
829
830	END SUBROUTINE interpunb
831
832	SUBROUTINE interpvnb(tabres,i1,i2,j1,j2)
833	!!----------------------------------------------------------------------
834	!! * ROUTINE interpvnb *
835	!!----------------------------------------------------------------------
836	INTEGER, INTENT(in) :: i1,i2,j1,j2
837	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
838	!!
839	INTEGER :: ji,jj,jk
840	!!----------------------------------------------------------------------
841
842	tabres(:,:) = 0.e0
843	DO jk=1,jpkm1
844	DO jj=j1,j2
845	DO ji=i1,i2
846	tabres(ji,jj) = tabres(ji,jj) + e1v(ji,jj) * vn(ji,jj,jk) &
847	* vmask(ji,jj,jk) * fse3v(ji,jj,jk)
848	END DO
849	END DO
850	END DO
851
852	END SUBROUTINE interpvnb
853
854	#else
855	!!----------------------------------------------------------------------
856	!! Empty module no AGRIF zoom
857	!!----------------------------------------------------------------------
858	CONTAINS
859	SUBROUTINE Agrif_OPA_Interp_empty
860	WRITE(,) 'agrif_opa_interp : You should not have seen this print! error?'
861	END SUBROUTINE Agrif_OPA_Interp_empty
862	#endif
863
864	!!======================================================================
865	END MODULE agrif_opa_interp

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

Download in other formats: