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/2015/dev_r5803_UKMO_AGRIF_Vert_interp/NEMOGCM/NEMO/NST_SRC – NEMO

Context Navigation

source: branches/2015/dev_r5803_UKMO_AGRIF_Vert_interp/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 @ 6454

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

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

Download in other formats: