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 @ 8596

Last change on this file since 8596 was 8596, checked in by timgraham, 7 years ago
Vertical refinement code working but protected by "key_vertical"
Property svn:keywords set to `Id`
File size: 30.2 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	# if defined key_vertical
202	zrho_xy = Agrif_rhox() * Agrif_rhoy()
203	DO jn = n1,n2-1
204	DO jk=k1,k2
205	DO jj=j1,j2
206	DO ji=i1,i2
207	tabres(ji,jj,jk,jn) = zrho_xy * tsn(ji,jj,jk,jn) * e1e2t(ji,jj) * e3t_n(ji,jj,jk)
208	END DO
209	END DO
210	END DO
211	END DO
212	DO jk=k1,k2
213	DO jj=j1,j2
214	DO ji=i1,i2
215	tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * zrho_xy * e1e2t(ji,jj) * e3t_n(ji,jj,jk)
216	END DO
217	END DO
218	END DO
219	#else
220	DO jn = n1,n2-1
221	DO jk=k1,k2
222	DO jj=j1,j2
223	DO ji=i1,i2
224	tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn)
225	END DO
226	END DO
227	END DO
228	END DO
229	#endif
230	ELSE
231	! VERTICAL REFINEMENT BEGIN
232	tabres_child(:,:,:,:) = 0.
233	# if defined key_vertical
234	DO jj=j1,j2
235	DO ji=i1,i2
236	N_in = 0
237	DO jk=k1,k2 !k2 = jpk of child grid
238	IF (tabres(ji,jj,jk,n2) == 0) EXIT
239	N_in = N_in + 1
240	tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2)
241	h_in(N_in) = tabres(ji,jj,jk,n2)/e1e2t(ji,jj)
242	ENDDO
243	N_out = 0
244	DO jk=1,jpk ! jpk of parent grid
245	IF (tmask(ji,jj,jk) == 0) EXIT ! TODO: Will not work with ISF
246	N_out = N_out + 1
247	h_out(N_out) = e3t_n(ji,jj,jk) !Parent grid scale factors. Could multiply by e1e2t here instead of division above
248	ENDDO
249	IF (N_in > 0) THEN
250	h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
251	! Should be able to remove the next IF/ELSEIF statement once scale factors are dealt with properly
252	! IF abs(h_diff > 1.e-8) THEN
253	! N_in = N_in + 1
254	! h_in(N_in) = h_diff
255	! tabin(N_in,:) = tabin(N_in-1,:)
256	IF (h_diff < -1.e-4) THEN
257	print *,'CHECK YOUR bathy T points ...',ji,jj,h_diff,sum(h_in(1:N_in)),sum(h_out(1:N_out))
258	print *, tabres(ji,j1:j2,1,n2)
259	STOP
260	! N_out = N_out + 1
261	! h_out(N_out) = - h_diff
262	ENDIF
263	DO jn=n1,n2-1
264	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)
265	ENDDO
266	ENDIF
267	ENDDO
268	ENDDO
269	#else
270	tabres_child(:,:,:,:) = tabres(:,:,:,1:jpts)
271	#endif
272
273	! WARNING :
274	! tabres replaced by tabres_child in the following
275	! k1 k2 replaced by 1 jpk
276	! VERTICAL REFINEMENT END
277
278	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
279	! Add asselin part
280	DO jn = n1,n2-1
281	DO jk=1,jpk
282	DO jj=j1,j2
283	DO ji=i1,i2
284	IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN
285	tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) &
286	& + atfp * ( tabres_child(ji,jj,jk,jn) &
287	& - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk)
288	ENDIF
289	ENDDO
290	ENDDO
291	ENDDO
292	ENDDO
293	ENDIF
294	DO jn = n1,n2-1
295	DO jk=1,jpk
296	DO jj=j1,j2
297	DO ji=i1,i2
298	IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN
299	tsn(ji,jj,jk,jn) = tabres_child(ji,jj,jk,jn) * tmask(ji,jj,jk)
300	END IF
301	END DO
302	END DO
303	END DO
304	END DO
305	ENDIF
306	!
307	END SUBROUTINE updateTS
308
309
310	SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
311	!!---------------------------------------------
312	!! * ROUTINE updateu *
313	!!---------------------------------------------
314	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2
315	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,2), INTENT(inout) :: tabres
316	LOGICAL , INTENT(in ) :: before
317	!
318	INTEGER :: ji, jj, jk
319	REAL(wp) :: zrhoy
320	! VERTICAL REFINEMENT BEGIN
321	REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child
322	REAL(wp) :: h_in(k1:k2)
323	REAL(wp) :: h_out(1:jpk)
324	INTEGER :: N_in, N_out
325	REAL(wp) :: h_diff
326	REAL(wp) :: tabin(k1:k2)
327	! VERTICAL REFINEMENT END
328	!!---------------------------------------------
329	!
330	IF( before ) THEN
331	zrhoy = Agrif_Rhoy()
332	# if defined key_vertical
333	DO jk=k1,k2
334	DO jj=j1,j2
335	DO ji=i1,i2
336	tabres(ji,jj,jk,1) = zrhoy * e2u(ji,jj) * e3u_n(ji,jj,jk) * umask(ji,jj,jk) * un(ji,jj,jk)
337	tabres(ji,jj,jk,2) = umask(ji,jj,jk) * zrhoy * e2u(ji,jj) * e3u_n(ji,jj,jk)
338	END DO
339	END DO
340	END DO
341	#else
342	DO jk = k1,k2
343	tabres(i1:i2,j1:j2,jk,1) = zrhoy * e2u(i1:i2,j1:j2) * e3u_n(i1:i2,j1:j2,jk) * un(i1:i2,j1:j2,jk)
344	END DO
345	#endif
346	ELSE
347	tabres_child(:,:,:) = 0.
348	# if defined key_vertical
349	! VERTICAL REFINEMENT BEGIN
350	DO jj=j1,j2
351	DO ji=i1,i2
352	N_in = 0
353	DO jk=k1,k2 !k2=jpk of child grid
354	IF (tabres(ji,jj,jk,2) == 0) EXIT
355	N_in = N_in + 1
356	tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2)
357	h_in(N_in) = tabres(ji,jj,jk,2)/e2u(ji,jj)
358	ENDDO
359	N_out = 0
360	DO jk=1,jpk
361	IF (umask(ji,jj,jk) == 0) EXIT
362	N_out = N_out + 1
363	h_out(N_out) = e3u_n(ji,jj,jk)
364	ENDDO
365	IF (N_in * N_out > 0) THEN
366	h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
367	! Should be able to remove the next IF/ELSEIF statement once scale factors are dealt with properly
368	if (h_diff < -1.e-4) then
369	print *,'CHECK YOUR BATHY ...'
370	stop
371	! else ! Extends with 0
372	! N_in = N_in + 1
373	! tabin(N_in) = 0.
374	! h_in(N_in) = h_diff
375	endif
376	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)
377	ENDIF
378	ENDDO
379	ENDDO
380	#else
381	DO jk=1,jpk
382	DO jj=j1,j2
383	DO ji=i1,i2
384	tabres_child(:,:,:) = tabres(:,:,:,1)* r1_e2u(ji,jj) / e3u_n(ji,jj,jk)
385	END DO
386	END DO
387	END DO
388	#endif
389
390	! WARNING :
391	! tabres replaced by tabres_child in the following
392	! k1 k2 replaced by 1 jpk
393	! remove division by fs e3u (already done)
394	! VERTICAL REFINEMENT END
395
396	DO jk=1,jpk
397	DO jj=j1,j2
398	DO ji=i1,i2
399	!Following line now replaced by division higher up in vertical refinement case
400	! tabres(ji,jj,jk) = tabres(ji,jj,jk) * r1_e2u(ji,jj) / e3u_n(ji,jj,jk)
401	!
402	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
403	ub(ji,jj,jk) = ub(ji,jj,jk) &
404	& + atfp * ( tabres_child(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk)
405	ENDIF
406	!
407	un(ji,jj,jk) = tabres_child(ji,jj,jk) * umask(ji,jj,jk)
408	END DO
409	END DO
410	END DO
411	ENDIF
412	!
413	END SUBROUTINE updateu
414
415
416	SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before )
417	!!---------------------------------------------
418	!! * ROUTINE updatev *
419	!!---------------------------------------------
420	INTEGER :: i1,i2,j1,j2,k1,k2,n1,n2
421	INTEGER :: ji,jj,jk
422	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,2) :: tabres
423	LOGICAL :: before
424	!!
425	REAL(wp) :: zrhox
426	! VERTICAL REFINEMENT BEGIN
427	REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child
428	REAL(wp) :: h_in(k1:k2)
429	REAL(wp) :: h_out(1:jpk)
430	INTEGER :: N_in, N_out
431	REAL(wp) :: h_diff
432	REAL(wp) :: tabin(k1:k2)
433	! VERTICAL REFINEMENT END
434	!!---------------------------------------------
435	!
436	IF (before) THEN
437	zrhox = Agrif_Rhox()
438	#if defined key_vertical
439	DO jk=k1,k2
440	DO jj=j1,j2
441	DO ji=i1,i2
442	tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk) * vn(ji,jj,jk)
443	tabres(ji,jj,jk,2) = vmask(ji,jj,jk) * zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk)
444	END DO
445	END DO
446	END DO
447	#else
448	DO jk=k1,k2
449	DO jj=j1,j2
450	DO ji=i1,i2
451	tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk)
452	END DO
453	END DO
454	END DO
455	#endif
456	ELSE
457	tabres_child(:,:,:) = 0.
458	! VERTICAL REFINEMENT BEGIN
459	#if defined key_vertical
460	DO jj=j1,j2
461	DO ji=i1,i2
462	N_in = 0
463	DO jk=k1,k2
464	IF (tabres(ji,jj,jk,2) == 0) EXIT
465	N_in = N_in + 1
466	tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2)
467	h_in(N_in) = tabres(ji,jj,jk,2)/e1v(ji,jj)
468	ENDDO
469	N_out = 0
470	DO jk=1,jpk
471	IF (vmask(ji,jj,jk) == 0) EXIT
472	N_out = N_out + 1
473	h_out(N_out) = e3v_n(ji,jj,jk)
474	ENDDO
475	IF (N_in * N_out > 0) THEN
476	h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
477	! Should be able to remove the next IF/ELSEIF statement once scale factors are dealt with properly
478	if (h_diff < -1.e-4) then
479	print *,'CHECK YOUR BATHY ...'
480	stop
481	! else ! Extends with 0
482	! N_in = N_in + 1
483	! tabin(N_in) = 0.
484	! h_in(N_in) = h_diff
485	endif
486	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)
487	ENDIF
488	ENDDO
489	ENDDO
490	#else
491	DO jk=k1,k2
492	DO jj=j1,j2
493	DO ji=i1,i2
494	tabres(ji,jj,jk,1) = e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk)
495	END DO
496	END DO
497	END DO
498	#endif
499
500	! WARNING :
501	! tabres replaced by tabres_child in the following
502	! k1 k2 replaced by 1 jpk
503	! remove division by fs e3v (already done)
504	! VERTICAL REFINEMENT END
505
506	DO jk=k1,jpk
507	DO jj=j1,j2
508	DO ji=i1,i2
509	!Following line now replaced by division higher up in vertical refinement case
510	! tabres(ji,jj,jk) = tabres(ji,jj,jk) * r1_e1v(ji,jj) / e3v_n(ji,jj,jk)
511	!
512	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
513	vb(ji,jj,jk) = vb(ji,jj,jk) &
514	& + atfp * ( tabres_child(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk)
515	ENDIF
516	!
517	vn(ji,jj,jk) = tabres_child(ji,jj,jk) * vmask(ji,jj,jk)
518	END DO
519	END DO
520	END DO
521	ENDIF
522	!
523	END SUBROUTINE updatev
524
525
526	SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before )
527	!!---------------------------------------------
528	!! * ROUTINE updateu2d *
529	!!---------------------------------------------
530	INTEGER, INTENT(in) :: i1, i2, j1, j2
531	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
532	LOGICAL, INTENT(in) :: before
533	!!
534	INTEGER :: ji, jj, jk
535	REAL(wp) :: zrhoy
536	REAL(wp) :: zcorr
537	!!---------------------------------------------
538	!
539	IF (before) THEN
540	zrhoy = Agrif_Rhoy()
541	DO jj=j1,j2
542	DO ji=i1,i2
543	tabres(ji,jj) = zrhoy * un_b(ji,jj) * hu_n(ji,jj) * e2u(ji,jj)
544	END DO
545	END DO
546	ELSE
547	DO jj=j1,j2
548	DO ji=i1,i2
549	tabres(ji,jj) = tabres(ji,jj) * r1_hu_n(ji,jj) * r1_e2u(ji,jj)
550	!
551	! Update "now" 3d velocities:
552	spgu(ji,jj) = 0._wp
553	DO jk=1,jpkm1
554	spgu(ji,jj) = spgu(ji,jj) + e3u_n(ji,jj,jk) * un(ji,jj,jk)
555	END DO
556	spgu(ji,jj) = spgu(ji,jj) * r1_hu_n(ji,jj)
557	!
558	zcorr = tabres(ji,jj) - spgu(ji,jj)
559	DO jk=1,jpkm1
560	un(ji,jj,jk) = un(ji,jj,jk) + zcorr * umask(ji,jj,jk)
561	END DO
562	!
563	! Update barotropic velocities:
564	IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN
565	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
566	zcorr = tabres(ji,jj) - un_b(ji,jj)
567	ub_b(ji,jj) = ub_b(ji,jj) + atfp * zcorr * umask(ji,jj,1)
568	END IF
569	ENDIF
570	un_b(ji,jj) = tabres(ji,jj) * umask(ji,jj,1)
571	!
572	! Correct "before" velocities to hold correct bt component:
573	spgu(ji,jj) = 0.e0
574	DO jk=1,jpkm1
575	spgu(ji,jj) = spgu(ji,jj) + e3u_b(ji,jj,jk) * ub(ji,jj,jk)
576	END DO
577	spgu(ji,jj) = spgu(ji,jj) * r1_hu_b(ji,jj)
578	!
579	zcorr = ub_b(ji,jj) - spgu(ji,jj)
580	DO jk=1,jpkm1
581	ub(ji,jj,jk) = ub(ji,jj,jk) + zcorr * umask(ji,jj,jk)
582	END DO
583	!
584	END DO
585	END DO
586	ENDIF
587	!
588	END SUBROUTINE updateu2d
589
590
591	SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before )
592	!!---------------------------------------------
593	!! * ROUTINE updatev2d *
594	!!---------------------------------------------
595	INTEGER, INTENT(in) :: i1, i2, j1, j2
596	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
597	LOGICAL, INTENT(in) :: before
598	!!
599	INTEGER :: ji, jj, jk
600	REAL(wp) :: zrhox
601	REAL(wp) :: zcorr
602	!!---------------------------------------------
603	!
604	IF (before) THEN
605	zrhox = Agrif_Rhox()
606	DO jj=j1,j2
607	DO ji=i1,i2
608	tabres(ji,jj) = zrhox * vn_b(ji,jj) * hv_n(ji,jj) * e1v(ji,jj)
609	END DO
610	END DO
611	ELSE
612	DO jj=j1,j2
613	DO ji=i1,i2
614	tabres(ji,jj) = tabres(ji,jj) * r1_hv_n(ji,jj) * r1_e1v(ji,jj)
615	!
616	! Update "now" 3d velocities:
617	spgv(ji,jj) = 0.e0
618	DO jk=1,jpkm1
619	spgv(ji,jj) = spgv(ji,jj) + e3v_n(ji,jj,jk) * vn(ji,jj,jk)
620	END DO
621	spgv(ji,jj) = spgv(ji,jj) * r1_hv_n(ji,jj)
622	!
623	zcorr = tabres(ji,jj) - spgv(ji,jj)
624	DO jk=1,jpkm1
625	vn(ji,jj,jk) = vn(ji,jj,jk) + zcorr * vmask(ji,jj,jk)
626	END DO
627	!
628	! Update barotropic velocities:
629	IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN
630	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
631	zcorr = tabres(ji,jj) - vn_b(ji,jj)
632	vb_b(ji,jj) = vb_b(ji,jj) + atfp * zcorr * vmask(ji,jj,1)
633	END IF
634	ENDIF
635	vn_b(ji,jj) = tabres(ji,jj) * vmask(ji,jj,1)
636	!
637	! Correct "before" velocities to hold correct bt component:
638	spgv(ji,jj) = 0.e0
639	DO jk=1,jpkm1
640	spgv(ji,jj) = spgv(ji,jj) + e3v_b(ji,jj,jk) * vb(ji,jj,jk)
641	END DO
642	spgv(ji,jj) = spgv(ji,jj) * r1_hv_b(ji,jj)
643	!
644	zcorr = vb_b(ji,jj) - spgv(ji,jj)
645	DO jk=1,jpkm1
646	vb(ji,jj,jk) = vb(ji,jj,jk) + zcorr * vmask(ji,jj,jk)
647	END DO
648	!
649	END DO
650	END DO
651	ENDIF
652	!
653	END SUBROUTINE updatev2d
654
655
656	SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before )
657	!!---------------------------------------------
658	!! * ROUTINE updateSSH *
659	!!---------------------------------------------
660	INTEGER, INTENT(in) :: i1, i2, j1, j2
661	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
662	LOGICAL, INTENT(in) :: before
663	!!
664	INTEGER :: ji, jj
665	!!---------------------------------------------
666	!
667	IF (before) THEN
668	DO jj=j1,j2
669	DO ji=i1,i2
670	tabres(ji,jj) = sshn(ji,jj)
671	END DO
672	END DO
673	ELSE
674	IF( .NOT.ln_dynspg_ts .OR. ( ln_dynspg_ts .AND. .NOT.ln_bt_fw ) ) THEN
675	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
676	DO jj=j1,j2
677	DO ji=i1,i2
678	sshb(ji,jj) = sshb(ji,jj) &
679	& + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1)
680	END DO
681	END DO
682	ENDIF
683	ENDIF
684	!
685	DO jj=j1,j2
686	DO ji=i1,i2
687	sshn(ji,jj) = tabres(ji,jj) * tmask(ji,jj,1)
688	END DO
689	END DO
690	ENDIF
691	!
692	END SUBROUTINE updateSSH
693
694
695	SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before )
696	!!---------------------------------------------
697	!! * ROUTINE updateub2b *
698	!!---------------------------------------------
699	INTEGER, INTENT(in) :: i1, i2, j1, j2
700	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
701	LOGICAL, INTENT(in) :: before
702	!!
703	INTEGER :: ji, jj
704	REAL(wp) :: zrhoy
705	!!---------------------------------------------
706	!
707	IF (before) THEN
708	zrhoy = Agrif_Rhoy()
709	DO jj=j1,j2
710	DO ji=i1,i2
711	tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj)
712	END DO
713	END DO
714	tabres = zrhoy * tabres
715	ELSE
716	DO jj=j1,j2
717	DO ji=i1,i2
718	ub2_b(ji,jj) = tabres(ji,jj) / e2u(ji,jj)
719	END DO
720	END DO
721	ENDIF
722	!
723	END SUBROUTINE updateub2b
724
725
726	SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before )
727	!!---------------------------------------------
728	!! * ROUTINE updatevb2b *
729	!!---------------------------------------------
730	INTEGER, INTENT(in) :: i1, i2, j1, j2
731	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
732	LOGICAL, INTENT(in) :: before
733	!!
734	INTEGER :: ji, jj
735	REAL(wp) :: zrhox
736	!!---------------------------------------------
737	!
738	IF (before) THEN
739	zrhox = Agrif_Rhox()
740	DO jj=j1,j2
741	DO ji=i1,i2
742	tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj)
743	END DO
744	END DO
745	tabres = zrhox * tabres
746	ELSE
747	DO jj=j1,j2
748	DO ji=i1,i2
749	vb2_b(ji,jj) = tabres(ji,jj) / e1v(ji,jj)
750	END DO
751	END DO
752	ENDIF
753	!
754	END SUBROUTINE updatevb2b
755
756
757	SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before )
758	! currently not used
759	!!---------------------------------------------
760	!! * ROUTINE updateT *
761	!!---------------------------------------------
762	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
763	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
764	LOGICAL, iNTENT(in) :: before
765	!
766	INTEGER :: ji,jj,jk
767	REAL(wp) :: ztemp
768	!!---------------------------------------------
769
770	IF (before) THEN
771	DO jk=k1,k2
772	DO jj=j1,j2
773	DO ji=i1,i2
774	tabres(ji,jj,jk,1) = e1t(ji,jj)e2t(ji,jj)tmask(ji,jj,jk)
775	tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk)
776	tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk)
777	END DO
778	END DO
779	END DO
780	tabres(:,:,:,1)=tabres(:,:,:,1)Agrif_Rhox()Agrif_Rhoy()
781	tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox()
782	tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy()
783	ELSE
784	DO jk=k1,k2
785	DO jj=j1,j2
786	DO ji=i1,i2
787	IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN
788	print ,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)e2t(ji,jj)*tmask(ji,jj,jk)
789	print ,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)tmask(ji,jj,jk)
790	print ,'VAL3 = ',ji,jj,jk,tabres(ji,jj,jk,3),e2t(ji,jj)tmask(ji,jj,jk)
791	ztemp = sqrt(tabres(ji,jj,jk,1)/(tabres(ji,jj,jk,2)*tabres(ji,jj,jk,3)))
792	print *,'CORR = ',ztemp-1.
793	print ,'NEW VALS = ',tabres(ji,jj,jk,2)ztemp,tabres(ji,jj,jk,3)*ztemp, &
794	tabres(ji,jj,jk,2)ztemptabres(ji,jj,jk,3)*ztemp
795	e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp
796	e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp
797	END IF
798	END DO
799	END DO
800	END DO
801	ENDIF
802	!
803	END SUBROUTINE update_scales
804
805	# if defined key_zdftke
806
807	SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before )
808	!!---------------------------------------------
809	!! * ROUTINE updateen *
810	!!---------------------------------------------
811	INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
812	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
813	LOGICAL, INTENT(in) :: before
814	!!---------------------------------------------
815	!
816	IF (before) THEN
817	ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2)
818	ELSE
819	en(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)
820	ENDIF
821	!
822	END SUBROUTINE updateEN
823
824
825	SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before )
826	!!---------------------------------------------
827	!! * ROUTINE updateavt *
828	!!---------------------------------------------
829	INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
830	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
831	LOGICAL, INTENT(in) :: before
832	!!---------------------------------------------
833	!
834	IF (before) THEN
835	ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2)
836	ELSE
837	avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)
838	ENDIF
839	!
840	END SUBROUTINE updateAVT
841
842
843	SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before )
844	!!---------------------------------------------
845	!! * ROUTINE updateavm *
846	!!---------------------------------------------
847	INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
848	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
849	LOGICAL, INTENT(in) :: before
850	!!---------------------------------------------
851	!
852	IF (before) THEN
853	ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2)
854	ELSE
855	avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)
856	ENDIF
857	!
858	END SUBROUTINE updateAVM
859
860	# endif /* key_zdftke */
861
862	#else
863	CONTAINS
864	SUBROUTINE agrif_opa_update_empty
865	!!---------------------------------------------
866	!! * ROUTINE agrif_opa_update_empty *
867	!!---------------------------------------------
868	WRITE(,) 'agrif_opa_update : You should not have seen this print! error?'
869	END SUBROUTINE agrif_opa_update_empty
870	#endif
871	END MODULE agrif_opa_update
872

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

Download in other formats: