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_update.F90 in branches/2017/dev_r8126_UKMO_AGRIF_vert_interp/NEMOGCM/NEMO/NST_SRC – NEMO

Context Navigation

source: branches/2017/dev_r8126_UKMO_AGRIF_vert_interp/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 @ 8135

Last change on this file since 8135 was 8135, checked in by timgraham, 7 years ago
Added changes to code in NST_SRC from dev_r5803_UKMO_AGRIF_Vert_interp
Property svn:keywords set to `Id`
File size: 28.8 KB

Line
1	#define TWO_WAY /* TWO WAY NESTING */
2	#undef DECAL_FEEDBACK /* SEPARATION of INTERFACES*/
3
4	MODULE agrif_opa_update
5	#if defined key_agrif
6	USE par_oce
7	USE oce
8	USE dom_oce
9	USE agrif_oce
10	USE in_out_manager ! I/O manager
11	USE lib_mpp
12	USE wrk_nemo
13	USE zdf_oce ! vertical physics: ocean variables
14
15	IMPLICIT NONE
16	PRIVATE
17
18	PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn,Update_Scales
19	# if defined key_zdftke
20	PUBLIC Agrif_Update_Tke
21	# endif
22	!!----------------------------------------------------------------------
23	!! NEMO/NST 3.6 , NEMO Consortium (2010)
24	!! $Id$
25	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
26	!!----------------------------------------------------------------------
27	CONTAINS
28
29	RECURSIVE SUBROUTINE Agrif_Update_Tra( )
30	!!---------------------------------------------
31	!! * ROUTINE Agrif_Update_Tra *
32	!!---------------------------------------------
33	!
34	IF (Agrif_Root()) RETURN
35	!
36	#if defined TWO_WAY
37	IF (lwp.AND.lk_agrif_debug) Write(,) 'Update tracers from grid Number',Agrif_Fixed(), 'nbcline', nbcline
38
39	Agrif_UseSpecialValueInUpdate = .TRUE.
40	Agrif_SpecialValueFineGrid = 0.
41	!
42	IF (MOD(nbcline,nbclineupdate) == 0) THEN
43	# if ! defined DECAL_FEEDBACK
44	CALL Agrif_Update_Variable(tsn_id, procname=updateTS)
45	# else
46	CALL Agrif_Update_Variable(tsn_id, locupdate=(/1,0/),procname=updateTS)
47	# endif
48	ELSE
49	# if ! defined DECAL_FEEDBACK
50	CALL Agrif_Update_Variable(tsn_id,locupdate=(/0,2/), procname=updateTS)
51	# else
52	CALL Agrif_Update_Variable(tsn_id,locupdate=(/1,2/), procname=updateTS)
53	# endif
54	ENDIF
55	!
56	Agrif_UseSpecialValueInUpdate = .FALSE.
57	!
58	IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update:
59	CALL Agrif_ChildGrid_To_ParentGrid()
60	CALL Agrif_Update_Tra()
61	CALL Agrif_ParentGrid_To_ChildGrid()
62	ENDIF
63	!
64	#endif
65	!
66	END SUBROUTINE Agrif_Update_Tra
67
68
69	RECURSIVE SUBROUTINE Agrif_Update_Dyn( )
70	!!---------------------------------------------
71	!! * ROUTINE Agrif_Update_Dyn *
72	!!---------------------------------------------
73	!
74	IF (Agrif_Root()) RETURN
75	!
76	#if defined TWO_WAY
77	IF (lwp.AND.lk_agrif_debug) Write(,) 'Update momentum from grid Number',Agrif_Fixed(), 'nbcline', nbcline
78
79	Agrif_UseSpecialValueInUpdate = .FALSE.
80	Agrif_SpecialValueFineGrid = 0.
81	!
82	IF (mod(nbcline,nbclineupdate) == 0) THEN
83	# if ! defined DECAL_FEEDBACK
84	CALL Agrif_Update_Variable(un_update_id,procname = updateU)
85	CALL Agrif_Update_Variable(vn_update_id,procname = updateV)
86	# else
87	CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU)
88	CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV)
89	# endif
90	ELSE
91	# if ! defined DECAL_FEEDBACK
92	CALL Agrif_Update_Variable(un_update_id,locupdate=(/0,1/),procname = updateU)
93	CALL Agrif_Update_Variable(vn_update_id,locupdate=(/0,1/),procname = updateV)
94	# else
95	CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateU)
96	CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updateV)
97	# endif
98	ENDIF
99
100	# if ! defined DECAL_FEEDBACK
101	CALL Agrif_Update_Variable(e1u_id,procname = updateU2d)
102	CALL Agrif_Update_Variable(e2v_id,procname = updateV2d)
103	# else
104	CALL Agrif_Update_Variable(e1u_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU2d)
105	CALL Agrif_Update_Variable(e2v_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV2d)
106	# endif
107
108	IF ( ln_dynspg_ts.AND.ln_bt_fw ) THEN
109	! Update time integrated transports
110	IF (mod(nbcline,nbclineupdate) == 0) THEN
111	# if ! defined DECAL_FEEDBACK
112	CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b)
113	CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b)
114	# else
115	CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateub2b)
116	CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updatevb2b)
117	# endif
118	ELSE
119	# if ! defined DECAL_FEEDBACK
120	CALL Agrif_Update_Variable(ub2b_update_id,locupdate=(/0,1/),procname = updateub2b)
121	CALL Agrif_Update_Variable(vb2b_update_id,locupdate=(/0,1/),procname = updatevb2b)
122	# else
123	CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateub2b)
124	CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updatevb2b)
125	# endif
126	ENDIF
127	END IF
128	!
129	nbcline = nbcline + 1
130	!
131	Agrif_UseSpecialValueInUpdate = .TRUE.
132	Agrif_SpecialValueFineGrid = 0.
133	# if ! defined DECAL_FEEDBACK
134	CALL Agrif_Update_Variable(sshn_id,procname = updateSSH)
135	# else
136	CALL Agrif_Update_Variable(sshn_id,locupdate=(/1,0/),procname = updateSSH)
137	# endif
138	Agrif_UseSpecialValueInUpdate = .FALSE.
139	!
140	#endif
141	!
142	! Do recursive update:
143	IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update:
144	CALL Agrif_ChildGrid_To_ParentGrid()
145	CALL Agrif_Update_Dyn()
146	CALL Agrif_ParentGrid_To_ChildGrid()
147	ENDIF
148	!
149	END SUBROUTINE Agrif_Update_Dyn
150
151	# if defined key_zdftke
152
153	SUBROUTINE Agrif_Update_Tke( kt )
154	!!---------------------------------------------
155	!! * ROUTINE Agrif_Update_Tke *
156	!!---------------------------------------------
157	!!
158	INTEGER, INTENT(in) :: kt
159	!
160	return
161
162	IF( ( Agrif_NbStepint() .NE. 0 ) .AND. (kt /= 0) ) RETURN
163	# if defined TWO_WAY
164
165	Agrif_UseSpecialValueInUpdate = .TRUE.
166	Agrif_SpecialValueFineGrid = 0.
167
168	CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN )
169	CALL Agrif_Update_Variable(avt_id, locupdate=(/0,0/), procname=updateAVT )
170	CALL Agrif_Update_Variable(avm_id, locupdate=(/0,0/), procname=updateAVM )
171
172	Agrif_UseSpecialValueInUpdate = .FALSE.
173
174	# endif
175
176	END SUBROUTINE Agrif_Update_Tke
177
178	# endif /* key_zdftke */
179
180	SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
181	!!---------------------------------------------
182	!! * ROUTINE updateT *
183	!!---------------------------------------------
184	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
185	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
186	LOGICAL, INTENT(in) :: before
187	!!
188	INTEGER :: ji,jj,jk,jn
189	! VERTICAL REFINEMENT BEGIN
190	REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: tabres_child
191	REAL(wp) :: h_in(k1:k2)
192	REAL(wp) :: h_out(1:jpk)
193	INTEGER :: N_in, N_out
194	REAL(wp) :: h_diff
195	REAL(wp) :: zrho_xy
196	REAL(wp) :: tabin(k1:k2,n1:n2)
197	! VERTICAL REFINEMENT END
198	!!---------------------------------------------
199	!
200	IF (before) THEN
201	zrho_xy = Agrif_rhox() * Agrif_rhoy()
202	DO jn = n1,n2-1
203	DO jk=k1,k2
204	DO jj=j1,j2
205	DO ji=i1,i2
206	tabres(ji,jj,jk,jn) = zrho_xy * tsn(ji,jj,jk,jn) * e1e2t(ji,jj) * e3t_n(ji,jj,jk)
207	END DO
208	END DO
209	END DO
210	END DO
211	DO jk=k1,k2
212	DO jj=j1,j2
213	DO ji=i1,i2
214	tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * zrho_xy * e1e2t(ji,jj) * e3t_n(ji,jj,jk)
215	END DO
216	END DO
217	END DO
218
219	ELSE
220	! VERTICAL REFINEMENT BEGIN
221	tabres_child(:,:,:,:) = 0.
222
223	DO jj=j1,j2
224	DO ji=i1,i2
225	N_in = 0
226	DO jk=k1,k2 !k2 = jpk of child grid
227	IF (tabres(ji,jj,jk,n2) == 0) EXIT
228	N_in = N_in + 1
229	tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2)
230	h_in(N_in) = tabres(ji,jj,jk,n2)/e1e2t(ji,jj)
231	ENDDO
232	N_out = 0
233	DO jk=1,jpk ! jpk of parent grid
234	IF (tmask(ji,jj,jk) == 0) EXIT ! TODO: Will not work with ISF
235	N_out = N_out + 1
236	h_out(N_out) = e3t_n(ji,jj,jk) !Parent grid scale factors. Could multiply by e1e2t here instead of division above
237	ENDDO
238	IF (N_in > 0) THEN
239	h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
240	! Should be able to remove the next IF/ELSEIF statement once scale factors are dealt with properly
241	! IF abs(h_diff > 1.e-8) THEN
242	! N_in = N_in + 1
243	! h_in(N_in) = h_diff
244	! tabin(N_in,:) = tabin(N_in-1,:)
245	IF (h_diff < 0) THEN
246	print *,'CHECK YOUR bathy T points ...',ji,jj,h_diff,sum(h_in(1:N_in)),sum(h_out(1:N_out))
247	print *,'Nval = ',N_out,mbathy(ji,jj)
248	print *,'BATHY = ',gdepw_0(ji,jj,mbathy(ji,jj)+1),sum(e3t_0(ji,jj,1:mbathy(ji,jj)))
249	STOP
250	! N_out = N_out + 1
251	! h_out(N_out) = - h_diff
252	ENDIF
253	DO jn=n1,n2-1
254	CALL reconstructandremap(tabin(1:N_in,jn),h_in(1:N_in),tabres_child(ji,jj,1:N_out,jn),h_out(1:N_out),N_in,N_out)
255	ENDDO
256	ENDIF
257	ENDDO
258	ENDDO
259
260	! WARNING :
261	! tabres replaced by tabres_child in the following
262	! k1 k2 replaced by 1 jpk
263	! VERTICAL REFINEMENT END
264
265	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
266	! Add asselin part
267	DO jn = n1,n2-1
268	DO jk=1,jpk
269	DO jj=j1,j2
270	DO ji=i1,i2
271	IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN
272	tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) &
273	& + atfp * ( tabres_child(ji,jj,jk,jn) &
274	& - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk)
275	ENDIF
276	ENDDO
277	ENDDO
278	ENDDO
279	ENDDO
280	ENDIF
281	DO jn = n1,n2-1
282	DO jk=1,jpk
283	DO jj=j1,j2
284	DO ji=i1,i2
285	IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN
286	tsn(ji,jj,jk,jn) = tabres_child(ji,jj,jk,jn) * tmask(ji,jj,jk)
287	END IF
288	END DO
289	END DO
290	END DO
291	END DO
292	ENDIF
293	!
294	END SUBROUTINE updateTS
295
296
297	SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
298	!!---------------------------------------------
299	!! * ROUTINE updateu *
300	!!---------------------------------------------
301	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2
302	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,2), INTENT(inout) :: tabres
303	LOGICAL , INTENT(in ) :: before
304	!
305	INTEGER :: ji, jj, jk
306	REAL(wp) :: zrhoy
307	! VERTICAL REFINEMENT BEGIN
308	REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child
309	REAL(wp) :: h_in(k1:k2)
310	REAL(wp) :: h_out(1:jpk)
311	INTEGER :: N_in, N_out
312	REAL(wp) :: h_diff
313	REAL(wp) :: tabin(k1:k2)
314	! VERTICAL REFINEMENT END
315	!!---------------------------------------------
316	!
317	IF( before ) THEN
318	zrhoy = Agrif_Rhoy()
319	DO jk=k1,k2
320	DO jj=j1,j2
321	DO ji=i1,i2
322	tabres(ji,jj,jk,1) = zrhoy * e2u(ji,jj) * e3u_n(ji,jj,jk) * umask(ji,jj,jk) * un(ji,jj,jk)
323	tabres(ji,jj,jk,2) = umask(ji,jj,jk) * zrhoy * e2u(ji,jj) * e3u_n(ji,jj,jk)
324	END DO
325	END DO
326	END DO
327	ELSE
328	! VERTICAL REFINEMENT BEGIN
329	tabres_child(:,:,:) = 0.
330
331	DO jj=j1,j2
332	DO ji=i1,i2
333	N_in = 0
334	DO jk=k1,k2 !k2=jpk of child grid
335	IF (tabres(ji,jj,jk,2) == 0) EXIT
336	N_in = N_in + 1
337	tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2)
338	h_in(N_in) = tabres(ji,jj,jk,2)/e2u(ji,jj)
339	ENDDO
340	N_out = 0
341	DO jk=1,jpk
342	IF (umask(ji,jj,jk) == 0) EXIT
343	N_out = N_out + 1
344	h_out(N_out) = e3u_n(ji,jj,jk)
345	ENDDO
346	IF (N_in * N_out > 0) THEN
347	h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
348	! Should be able to remove the next IF/ELSEIF statement once scale factors are dealt with properly
349	if (h_diff < 0.) then
350	print *,'CHECK YOUR BATHY ...'
351	stop
352	! else ! Extends with 0
353	! N_in = N_in + 1
354	! tabin(N_in) = 0.
355	! h_in(N_in) = h_diff
356	endif
357	CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
358	ENDIF
359	ENDDO
360	ENDDO
361
362	! WARNING :
363	! tabres replaced by tabres_child in the following
364	! k1 k2 replaced by 1 jpk
365	! remove division by fs e3u (already done)
366	! VERTICAL REFINEMENT END
367
368	DO jk=1,jpk
369	DO jj=j1,j2
370	DO ji=i1,i2
371	!Following line now replaced by division higher up in vertical refinement case
372	! tabres(ji,jj,jk) = tabres(ji,jj,jk) * r1_e2u(ji,jj) / e3u_n(ji,jj,jk)
373	!
374	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
375	ub(ji,jj,jk) = ub(ji,jj,jk) &
376	& + atfp * ( tabres_child(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk)
377	ENDIF
378	!
379	un(ji,jj,jk) = tabres_child(ji,jj,jk) * umask(ji,jj,jk)
380	END DO
381	END DO
382	END DO
383	ENDIF
384	!
385	END SUBROUTINE updateu
386
387
388	SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before )
389	!!---------------------------------------------
390	!! * ROUTINE updatev *
391	!!---------------------------------------------
392	INTEGER :: i1,i2,j1,j2,k1,k2,n1,n2
393	INTEGER :: ji,jj,jk
394	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,2) :: tabres
395	LOGICAL :: before
396	!!
397	REAL(wp) :: zrhox
398	! VERTICAL REFINEMENT BEGIN
399	REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child
400	REAL(wp) :: h_in(k1:k2)
401	REAL(wp) :: h_out(1:jpk)
402	INTEGER :: N_in, N_out
403	REAL(wp) :: h_diff
404	REAL(wp) :: tabin(k1:k2)
405	! VERTICAL REFINEMENT END
406	!!---------------------------------------------
407	!
408	IF (before) THEN
409	zrhox = Agrif_Rhox()
410	DO jk=k1,k2
411	DO jj=j1,j2
412	DO ji=i1,i2
413	tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk) * vn(ji,jj,jk)
414	tabres(ji,jj,jk,2) = vmask(ji,jj,jk) * zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk)
415	END DO
416	END DO
417	END DO
418	ELSE
419	! VERTICAL REFINEMENT BEGIN
420	tabres_child(:,:,:) = 0.
421
422	DO jj=j1,j2
423	DO ji=i1,i2
424	N_in = 0
425	DO jk=k1,k2
426	IF (tabres(ji,jj,jk,2) == 0) EXIT
427	N_in = N_in + 1
428	tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2)
429	h_in(N_in) = tabres(ji,jj,jk,2)/e1v(ji,jj)
430	ENDDO
431	N_out = 0
432	DO jk=1,jpk
433	IF (vmask(ji,jj,jk) == 0) EXIT
434	N_out = N_out + 1
435	h_out(N_out) = e3v_n(ji,jj,jk)
436	ENDDO
437	IF (N_in * N_out > 0) THEN
438	h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
439	! Should be able to remove the next IF/ELSEIF statement once scale factors are dealt with properly
440	if (h_diff < 0.) then
441	print *,'CHECK YOUR BATHY ...'
442	stop
443	! else ! Extends with 0
444	! N_in = N_in + 1
445	! tabin(N_in) = 0.
446	! h_in(N_in) = h_diff
447	endif
448	CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
449	ENDIF
450	ENDDO
451	ENDDO
452
453	! WARNING :
454	! tabres replaced by tabres_child in the following
455	! k1 k2 replaced by 1 jpk
456	! remove division by fs e3v (already done)
457	! VERTICAL REFINEMENT END
458
459	DO jk=k1,jpk
460	DO jj=j1,j2
461	DO ji=i1,i2
462	!Following line now replaced by division higher up in vertical refinement case
463	! tabres(ji,jj,jk) = tabres(ji,jj,jk) * r1_e1v(ji,jj) / e3v_n(ji,jj,jk)
464	!
465	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
466	vb(ji,jj,jk) = vb(ji,jj,jk) &
467	& + atfp * ( tabres_child(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk)
468	ENDIF
469	!
470	vn(ji,jj,jk) = tabres_child(ji,jj,jk) * vmask(ji,jj,jk)
471	END DO
472	END DO
473	END DO
474	ENDIF
475	!
476	END SUBROUTINE updatev
477
478
479	SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before )
480	!!---------------------------------------------
481	!! * ROUTINE updateu2d *
482	!!---------------------------------------------
483	INTEGER, INTENT(in) :: i1, i2, j1, j2
484	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
485	LOGICAL, INTENT(in) :: before
486	!!
487	INTEGER :: ji, jj, jk
488	REAL(wp) :: zrhoy
489	REAL(wp) :: zcorr
490	!!---------------------------------------------
491	!
492	IF (before) THEN
493	zrhoy = Agrif_Rhoy()
494	DO jj=j1,j2
495	DO ji=i1,i2
496	tabres(ji,jj) = zrhoy * un_b(ji,jj) * hu_n(ji,jj) * e2u(ji,jj)
497	END DO
498	END DO
499	ELSE
500	DO jj=j1,j2
501	DO ji=i1,i2
502	tabres(ji,jj) = tabres(ji,jj) * r1_hu_n(ji,jj) * r1_e2u(ji,jj)
503	!
504	! Update "now" 3d velocities:
505	spgu(ji,jj) = 0._wp
506	DO jk=1,jpkm1
507	spgu(ji,jj) = spgu(ji,jj) + e3u_n(ji,jj,jk) * un(ji,jj,jk)
508	END DO
509	spgu(ji,jj) = spgu(ji,jj) * r1_hu_n(ji,jj)
510	!
511	zcorr = tabres(ji,jj) - spgu(ji,jj)
512	DO jk=1,jpkm1
513	un(ji,jj,jk) = un(ji,jj,jk) + zcorr * umask(ji,jj,jk)
514	END DO
515	!
516	! Update barotropic velocities:
517	IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN
518	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
519	zcorr = tabres(ji,jj) - un_b(ji,jj)
520	ub_b(ji,jj) = ub_b(ji,jj) + atfp * zcorr * umask(ji,jj,1)
521	END IF
522	ENDIF
523	un_b(ji,jj) = tabres(ji,jj) * umask(ji,jj,1)
524	!
525	! Correct "before" velocities to hold correct bt component:
526	spgu(ji,jj) = 0.e0
527	DO jk=1,jpkm1
528	spgu(ji,jj) = spgu(ji,jj) + e3u_b(ji,jj,jk) * ub(ji,jj,jk)
529	END DO
530	spgu(ji,jj) = spgu(ji,jj) * r1_hu_b(ji,jj)
531	!
532	zcorr = ub_b(ji,jj) - spgu(ji,jj)
533	DO jk=1,jpkm1
534	ub(ji,jj,jk) = ub(ji,jj,jk) + zcorr * umask(ji,jj,jk)
535	END DO
536	!
537	END DO
538	END DO
539	ENDIF
540	!
541	END SUBROUTINE updateu2d
542
543
544	SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before )
545	!!---------------------------------------------
546	!! * ROUTINE updatev2d *
547	!!---------------------------------------------
548	INTEGER, INTENT(in) :: i1, i2, j1, j2
549	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
550	LOGICAL, INTENT(in) :: before
551	!!
552	INTEGER :: ji, jj, jk
553	REAL(wp) :: zrhox
554	REAL(wp) :: zcorr
555	!!---------------------------------------------
556	!
557	IF (before) THEN
558	zrhox = Agrif_Rhox()
559	DO jj=j1,j2
560	DO ji=i1,i2
561	tabres(ji,jj) = zrhox * vn_b(ji,jj) * hv_n(ji,jj) * e1v(ji,jj)
562	END DO
563	END DO
564	ELSE
565	DO jj=j1,j2
566	DO ji=i1,i2
567	tabres(ji,jj) = tabres(ji,jj) * r1_hv_n(ji,jj) * r1_e1v(ji,jj)
568	!
569	! Update "now" 3d velocities:
570	spgv(ji,jj) = 0.e0
571	DO jk=1,jpkm1
572	spgv(ji,jj) = spgv(ji,jj) + e3v_n(ji,jj,jk) * vn(ji,jj,jk)
573	END DO
574	spgv(ji,jj) = spgv(ji,jj) * r1_hv_n(ji,jj)
575	!
576	zcorr = tabres(ji,jj) - spgv(ji,jj)
577	DO jk=1,jpkm1
578	vn(ji,jj,jk) = vn(ji,jj,jk) + zcorr * vmask(ji,jj,jk)
579	END DO
580	!
581	! Update barotropic velocities:
582	IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN
583	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
584	zcorr = tabres(ji,jj) - vn_b(ji,jj)
585	vb_b(ji,jj) = vb_b(ji,jj) + atfp * zcorr * vmask(ji,jj,1)
586	END IF
587	ENDIF
588	vn_b(ji,jj) = tabres(ji,jj) * vmask(ji,jj,1)
589	!
590	! Correct "before" velocities to hold correct bt component:
591	spgv(ji,jj) = 0.e0
592	DO jk=1,jpkm1
593	spgv(ji,jj) = spgv(ji,jj) + e3v_b(ji,jj,jk) * vb(ji,jj,jk)
594	END DO
595	spgv(ji,jj) = spgv(ji,jj) * r1_hv_b(ji,jj)
596	!
597	zcorr = vb_b(ji,jj) - spgv(ji,jj)
598	DO jk=1,jpkm1
599	vb(ji,jj,jk) = vb(ji,jj,jk) + zcorr * vmask(ji,jj,jk)
600	END DO
601	!
602	END DO
603	END DO
604	ENDIF
605	!
606	END SUBROUTINE updatev2d
607
608
609	SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before )
610	!!---------------------------------------------
611	!! * ROUTINE updateSSH *
612	!!---------------------------------------------
613	INTEGER, INTENT(in) :: i1, i2, j1, j2
614	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
615	LOGICAL, INTENT(in) :: before
616	!!
617	INTEGER :: ji, jj
618	!!---------------------------------------------
619	!
620	IF (before) THEN
621	DO jj=j1,j2
622	DO ji=i1,i2
623	tabres(ji,jj) = sshn(ji,jj)
624	END DO
625	END DO
626	ELSE
627	IF( .NOT.ln_dynspg_ts .OR. ( ln_dynspg_ts .AND. .NOT.ln_bt_fw ) ) THEN
628	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
629	DO jj=j1,j2
630	DO ji=i1,i2
631	sshb(ji,jj) = sshb(ji,jj) &
632	& + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1)
633	END DO
634	END DO
635	ENDIF
636	ENDIF
637	!
638	DO jj=j1,j2
639	DO ji=i1,i2
640	sshn(ji,jj) = tabres(ji,jj) * tmask(ji,jj,1)
641	END DO
642	END DO
643	ENDIF
644	!
645	END SUBROUTINE updateSSH
646
647
648	SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before )
649	!!---------------------------------------------
650	!! * ROUTINE updateub2b *
651	!!---------------------------------------------
652	INTEGER, INTENT(in) :: i1, i2, j1, j2
653	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
654	LOGICAL, INTENT(in) :: before
655	!!
656	INTEGER :: ji, jj
657	REAL(wp) :: zrhoy
658	!!---------------------------------------------
659	!
660	IF (before) THEN
661	zrhoy = Agrif_Rhoy()
662	DO jj=j1,j2
663	DO ji=i1,i2
664	tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj)
665	END DO
666	END DO
667	tabres = zrhoy * tabres
668	ELSE
669	DO jj=j1,j2
670	DO ji=i1,i2
671	ub2_b(ji,jj) = tabres(ji,jj) / e2u(ji,jj)
672	END DO
673	END DO
674	ENDIF
675	!
676	END SUBROUTINE updateub2b
677
678
679	SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before )
680	!!---------------------------------------------
681	!! * ROUTINE updatevb2b *
682	!!---------------------------------------------
683	INTEGER, INTENT(in) :: i1, i2, j1, j2
684	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
685	LOGICAL, INTENT(in) :: before
686	!!
687	INTEGER :: ji, jj
688	REAL(wp) :: zrhox
689	!!---------------------------------------------
690	!
691	IF (before) THEN
692	zrhox = Agrif_Rhox()
693	DO jj=j1,j2
694	DO ji=i1,i2
695	tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj)
696	END DO
697	END DO
698	tabres = zrhox * tabres
699	ELSE
700	DO jj=j1,j2
701	DO ji=i1,i2
702	vb2_b(ji,jj) = tabres(ji,jj) / e1v(ji,jj)
703	END DO
704	END DO
705	ENDIF
706	!
707	END SUBROUTINE updatevb2b
708
709
710	SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before )
711	! currently not used
712	!!---------------------------------------------
713	!! * ROUTINE updateT *
714	!!---------------------------------------------
715	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
716	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
717	LOGICAL, iNTENT(in) :: before
718	!
719	INTEGER :: ji,jj,jk
720	REAL(wp) :: ztemp
721	!!---------------------------------------------
722
723	IF (before) THEN
724	DO jk=k1,k2
725	DO jj=j1,j2
726	DO ji=i1,i2
727	tabres(ji,jj,jk,1) = e1t(ji,jj)e2t(ji,jj)tmask(ji,jj,jk)
728	tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk)
729	tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk)
730	END DO
731	END DO
732	END DO
733	tabres(:,:,:,1)=tabres(:,:,:,1)Agrif_Rhox()Agrif_Rhoy()
734	tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox()
735	tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy()
736	ELSE
737	DO jk=k1,k2
738	DO jj=j1,j2
739	DO ji=i1,i2
740	IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN
741	print ,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)e2t(ji,jj)*tmask(ji,jj,jk)
742	print ,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)tmask(ji,jj,jk)
743	print ,'VAL3 = ',ji,jj,jk,tabres(ji,jj,jk,3),e2t(ji,jj)tmask(ji,jj,jk)
744	ztemp = sqrt(tabres(ji,jj,jk,1)/(tabres(ji,jj,jk,2)*tabres(ji,jj,jk,3)))
745	print *,'CORR = ',ztemp-1.
746	print ,'NEW VALS = ',tabres(ji,jj,jk,2)ztemp,tabres(ji,jj,jk,3)*ztemp, &
747	tabres(ji,jj,jk,2)ztemptabres(ji,jj,jk,3)*ztemp
748	e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp
749	e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp
750	END IF
751	END DO
752	END DO
753	END DO
754	ENDIF
755	!
756	END SUBROUTINE update_scales
757
758	# if defined key_zdftke
759
760	SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before )
761	!!---------------------------------------------
762	!! * ROUTINE updateen *
763	!!---------------------------------------------
764	INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
765	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
766	LOGICAL, INTENT(in) :: before
767	!!---------------------------------------------
768	!
769	IF (before) THEN
770	ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2)
771	ELSE
772	en(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)
773	ENDIF
774	!
775	END SUBROUTINE updateEN
776
777
778	SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before )
779	!!---------------------------------------------
780	!! * ROUTINE updateavt *
781	!!---------------------------------------------
782	INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
783	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
784	LOGICAL, INTENT(in) :: before
785	!!---------------------------------------------
786	!
787	IF (before) THEN
788	ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2)
789	ELSE
790	avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)
791	ENDIF
792	!
793	END SUBROUTINE updateAVT
794
795
796	SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before )
797	!!---------------------------------------------
798	!! * ROUTINE updateavm *
799	!!---------------------------------------------
800	INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
801	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
802	LOGICAL, INTENT(in) :: before
803	!!---------------------------------------------
804	!
805	IF (before) THEN
806	ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2)
807	ELSE
808	avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)
809	ENDIF
810	!
811	END SUBROUTINE updateAVM
812
813	# endif /* key_zdftke */
814
815	#else
816	CONTAINS
817	SUBROUTINE agrif_opa_update_empty
818	!!---------------------------------------------
819	!! * ROUTINE agrif_opa_update_empty *
820	!!---------------------------------------------
821	WRITE(,) 'agrif_opa_update : You should not have seen this print! error?'
822	END SUBROUTINE agrif_opa_update_empty
823	#endif
824	END MODULE agrif_opa_update
825

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

Download in other formats: