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/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_interp.F90 @ 7824

Last change on this file since 7824 was 7824, checked in by timgraham, 7 years ago
Commit changes to interp & update routines for U, V, T&S. This version now works correctly for simple GYRE test case with 41 levels on the child grid.
Property svn:keywords set to `Id`
File size: 57.2 KB

Rev	Line
[636]	1	MODULE agrif_opa_interp
[1605]	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)
[5656]	9	!! 3.6 ! 2014-09 (R. Benshila)
[1605]	10	!!----------------------------------------------------------------------
[2528]	11	#if defined key_agrif && ! defined key_offline
[1605]	12	!!----------------------------------------------------------------------
	13	!! 'key_agrif' AGRIF zoom
[2528]	14	!! NOT 'key_offline' NO off-line tracers
[1605]	15	!!----------------------------------------------------------------------
	16	!! Agrif_tra :
	17	!! Agrif_dyn :
	18	!! interpu :
	19	!! interpv :
	20	!!----------------------------------------------------------------------
[636]	21	USE par_oce
	22	USE oce
	23	USE dom_oce
[6404]	24	USE zdf_oce
[782]	25	USE agrif_oce
[1605]	26	USE phycst
[6404]	27	!
[1605]	28	USE in_out_manager
[2715]	29	USE agrif_opa_sponge
	30	USE lib_mpp
[4292]	31	USE wrk_nemo
[5656]	32
[636]	33	IMPLICIT NONE
	34	PRIVATE
[4292]	35
[4486]	36	PUBLIC Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts
[6258]	37	! VERTICAL REFINEMENT BEGIN
	38	PUBLIC Agrif_Init_InterpScales
	39	! VERTICAL REFINEMENT END
[6445]	40	PUBLIC interpun, interpvn
[5656]	41	PUBLIC interptsn, interpsshn
	42	PUBLIC interpunb, interpvnb, interpub2b, interpvb2b
	43	PUBLIC interpe3t, interpumsk, interpvmsk
	44	# if defined key_zdftke
	45	PUBLIC Agrif_tke, interpavm
	46	# endif
[390]	47
[6404]	48	INTEGER :: bdy_tinterp = 0
	49
[1605]	50	# include "vectopt_loop_substitute.h90"
[1156]	51	!!----------------------------------------------------------------------
[6404]	52	!! NEMO/NST 3.7 , NEMO Consortium (2015)
[6401]	53	!! $Id$
[2528]	54	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[1156]	55	!!----------------------------------------------------------------------
[6258]	56	! VERTICAL REFINEMENT BEGIN
	57	REAL, DIMENSION(:,:,:), ALLOCATABLE :: interp_scales_t, interp_scales_u, interp_scales_v
	58	!$AGRIF_DO_NOT_TREAT
	59	LOGICAL :: scaleT, scaleU, scaleV = .FALSE.
	60	!$AGRIF_END_DO_NOT_TREAT
	61	! VERTICAL REFINEMENT END
	62
[5656]	63	CONTAINS
	64
[6258]	65	! VERTICAL REFINEMENT BEGIN
	66
	67	SUBROUTINE Agrif_Init_InterpScales
	68
	69	scaleT = .TRUE.
	70	Call Agrif_Bc_Variable(scales_t_id,calledweight=1.,procname=interpscales)
	71	scaleT = .FALSE.
	72
	73	scaleU = .TRUE.
	74	Call Agrif_Bc_Variable(scales_u_id,calledweight=1.,procname=interpscales)
	75	scaleU = .FALSE.
	76
	77	scaleV = .TRUE.
	78	Call Agrif_Bc_Variable(scales_v_id,calledweight=1.,procname=interpscales)
	79	scaleV = .FALSE.
	80
	81	END SUBROUTINE Agrif_Init_InterpScales
	82
	83	SUBROUTINE interpscales(ptab,i1,i2,j1,j2,k1,k2,before)
	84	!!---------------------------------------------
	85	!! * ROUTINE interpscales *
	86	!!---------------------------------------------
	87
	88	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
	89	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
	90
	91	INTEGER :: ji, jj, jk
	92	LOGICAL :: before
	93
	94	IF (before) THEN
	95	IF (scaleT ) THEN
	96	DO jk=k1,k2
	97	DO jj=j1,j2
	98	DO ji=i1,i2
[6404]	99	! ptab(ji,jj,jk) = e3t_n(ji,jj,jk) * tmask(ji,jj,jk)
	100	ptab(ji,jj,jk) = e3t_n(ji,jj,jk)
[6258]	101	END DO
	102	END DO
	103	END DO
	104	ELSEIF (scaleU) THEN
	105	DO jk=k1,k2
	106	DO jj=j1,j2
	107	DO ji=i1,i2
[6404]	108	! ptab(ji,jj,jk) = e3u_n(ji,jj,jk) * umask(ji,jj,jk)
	109	! ptab(ji,jj,jk) = e3u_n(ji,jj,jk)
[6258]	110	ptab(ji,jj,jk) = umask(ji,jj,jk)
	111	END DO
	112	END DO
	113	END DO
	114	ELSEIF (scaleV) THEN
	115	DO jk=k1,k2
	116	DO jj=j1,j2
	117	DO ji=i1,i2
[6404]	118	! ptab(ji,jj,jk) = e3v_n(ji,jj,jk) * vmask(ji,jj,jk)
	119	! ptab(ji,jj,jk) = e3v_n(ji,jj,jk)
[6258]	120	ptab(ji,jj,jk) = vmask(ji,jj,jk)
	121	END DO
	122	END DO
	123	END DO
	124	ENDIF
	125	ELSE
	126	IF (scaleT ) THEN
	127	IF (.not.allocated(interp_scales_t)) allocate(interp_scales_t(jpi,jpj,k1:k2))
	128	DO jk=k1,k2
	129	DO jj=j1,j2
	130	DO ji=i1,i2
	131	interp_scales_t(ji,jj,jk) = ptab(ji,jj,jk)
	132	END DO
	133	END DO
	134	END DO
	135	ELSEIF (scaleU) THEN
	136	IF (.not.allocated(interp_scales_u)) allocate(interp_scales_u(jpi,jpj,k1:k2))
	137	DO jk=k1,k2
	138	DO jj=j1,j2
	139	DO ji=i1,i2
	140	interp_scales_u(ji,jj,jk) = ptab(ji,jj,jk)
	141	END DO
	142	END DO
	143	END DO
	144	ELSEIF (scaleV) THEN
	145	IF (.not.allocated(interp_scales_v)) allocate(interp_scales_v(jpi,jpj,k1:k2))
	146	DO jk=k1,k2
	147	DO jj=j1,j2
	148	DO ji=i1,i2
	149	interp_scales_v(ji,jj,jk) = ptab(ji,jj,jk)
	150	END DO
	151	END DO
	152	END DO
	153	ENDIF
	154	ENDIF
	155
	156	END SUBROUTINE interpscales
	157
	158	! VERTICAL REFINEMENT END
	159
[782]	160	SUBROUTINE Agrif_tra
[1605]	161	!!----------------------------------------------------------------------
[5656]	162	!! * ROUTINE Agrif_tra *
[1605]	163	!!----------------------------------------------------------------------
[636]	164	!
[1605]	165	IF( Agrif_Root() ) RETURN
[6404]	166	!
	167	Agrif_SpecialValue = 0._wp
[636]	168	Agrif_UseSpecialValue = .TRUE.
[6404]	169	!
[5656]	170	CALL Agrif_Bc_variable( tsn_id, procname=interptsn )
[6404]	171	!
[636]	172	Agrif_UseSpecialValue = .FALSE.
[1605]	173	!
[636]	174	END SUBROUTINE Agrif_tra
	175
[1605]	176
[636]	177	SUBROUTINE Agrif_dyn( kt )
[1605]	178	!!----------------------------------------------------------------------
	179	!! * ROUTINE Agrif_DYN *
	180	!!----------------------------------------------------------------------
	181	INTEGER, INTENT(in) :: kt
[6404]	182	!
	183	INTEGER :: ji, jj, jk ! dummy loop indices
	184	INTEGER :: j1, j2, i1, i2
	185	REAL(wp), POINTER, DIMENSION(:,:) :: zub, zvb
[1605]	186	!!----------------------------------------------------------------------
[6404]	187	!
[1605]	188	IF( Agrif_Root() ) RETURN
[6404]	189	!
	190	CALL wrk_alloc( jpi,jpj, zub, zvb )
	191	!
	192	Agrif_SpecialValue = 0._wp
[5656]	193	Agrif_UseSpecialValue = ln_spc_dyn
[6404]	194	!
	195	CALL Agrif_Bc_variable( un_interp_id, procname=interpun )
	196	CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn )
	197	!
[5656]	198	Agrif_UseSpecialValue = .FALSE.
[6404]	199	!
[5656]	200	! prevent smoothing in ghost cells
[6404]	201	i1 = 1 ; i2 = jpi
	202	j1 = 1 ; j2 = jpj
	203	IF( nbondj == -1 .OR. nbondj == 2 ) j1 = 3
	204	IF( nbondj == +1 .OR. nbondj == 2 ) j2 = nlcj-2
	205	IF( nbondi == -1 .OR. nbondi == 2 ) i1 = 3
	206	IF( nbondi == +1 .OR. nbondi == 2 ) i2 = nlci-2
[782]	207
[6404]	208	IF( nbondi == -1 .OR. nbondi == 2 ) THEN
	209	!
	210	! Smoothing
	211	! ---------
	212	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
	213	ua_b(2,:) = 0._wp
	214	DO jk = 1, jpkm1
	215	DO jj = 1, jpj
	216	ua_b(2,jj) = ua_b(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk)
	217	END DO
[636]	218	END DO
[6404]	219	DO jj = 1, jpj
	220	ua_b(2,jj) = ua_b(2,jj) * r1_hu_a(2,jj)
[636]	221	END DO
[6404]	222	ENDIF
	223	!
	224	DO jk=1,jpkm1 ! Smooth
[5656]	225	DO jj=j1,j2
[6404]	226	ua(2,jj,jk) = 0.25_wp(ua(1,jj,jk)+2._wpua(2,jj,jk)+ua(3,jj,jk))
[636]	227	ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk)
	228	END DO
	229	END DO
[6404]	230	!
	231	zub(2,:) = 0._wp ! Correct transport
	232	DO jk = 1, jpkm1
	233	DO jj = 1, jpj
	234	zub(2,jj) = zub(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk)
[636]	235	END DO
	236	END DO
	237	DO jj=1,jpj
[6404]	238	zub(2,jj) = zub(2,jj) * r1_hu_a(2,jj)
[636]	239	END DO
[390]	240
[636]	241	DO jk=1,jpkm1
[6404]	242	DO jj=1,jpj
	243	ua(2,jj,jk) = (ua(2,jj,jk)+ua_b(2,jj)-zub(2,jj))*umask(2,jj,jk)
[636]	244	END DO
	245	END DO
[390]	246
[4486]	247	! Set tangential velocities to time splitting estimate
[6404]	248	!-----------------------------------------------------
	249	IF( ln_dynspg_ts ) THEN
	250	zvb(2,:) = 0._wp
	251	DO jk = 1, jpkm1
	252	DO jj = 1, jpj
	253	zvb(2,jj) = zvb(2,jj) + e3v_a(2,jj,jk) * va(2,jj,jk)
	254	END DO
[4486]	255	END DO
[6404]	256	DO jj = 1, jpj
	257	zvb(2,jj) = zvb(2,jj) * r1_hv_a(2,jj)
[4486]	258	END DO
[6404]	259	DO jk = 1, jpkm1
	260	DO jj = 1, jpj
	261	va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-zvb(2,jj)) * vmask(2,jj,jk)
	262	END DO
	263	END DO
	264	ENDIF
	265	!
	266	! Mask domain edges:
	267	!-------------------
	268	DO jk = 1, jpkm1
	269	DO jj = 1, jpj
	270	ua(1,jj,jk) = 0._wp
	271	va(1,jj,jk) = 0._wp
	272	END DO
	273	END DO
	274	!
[636]	275	ENDIF
[390]	276
[6404]	277	IF( nbondi == 1 .OR. nbondi == 2 ) THEN
	278
	279	! Smoothing
	280	! ---------
	281	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
	282	ua_b(nlci-2,:) = 0._wp
	283	DO jk=1,jpkm1
	284	DO jj=1,jpj
	285	ua_b(nlci-2,jj) = ua_b(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk)
	286	END DO
[636]	287	END DO
	288	DO jj=1,jpj
[6404]	289	ua_b(nlci-2,jj) = ua_b(nlci-2,jj) * r1_hu_a(nlci-2,jj)
	290	END DO
	291	ENDIF
[390]	292
[6404]	293	DO jk = 1, jpkm1 ! Smooth
	294	DO jj = j1, j2
	295	ua(nlci-2,jj,jk) = 0.25_wp * umask(nlci-2,jj,jk) &
	296	& * ( ua(nlci-3,jj,jk) + 2._wp*ua(nlci-2,jj,jk) + ua(nlci-1,jj,jk) )
[636]	297	END DO
	298	END DO
[6404]	299
	300	zub(nlci-2,:) = 0._wp ! Correct transport
	301	DO jk = 1, jpkm1
	302	DO jj = 1, jpj
	303	zub(nlci-2,jj) = zub(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk)
[636]	304	END DO
	305	END DO
[6404]	306	DO jj = 1, jpj
	307	zub(nlci-2,jj) = zub(nlci-2,jj) * r1_hu_a(nlci-2,jj)
[636]	308	END DO
[6404]	309
	310	DO jk = 1, jpkm1
	311	DO jj = 1, jpj
	312	ua(nlci-2,jj,jk) = ( ua(nlci-2,jj,jk) + ua_b(nlci-2,jj) - zub(nlci-2,jj) ) * umask(nlci-2,jj,jk)
[636]	313	END DO
	314	END DO
[6404]	315	!
[4486]	316	! Set tangential velocities to time splitting estimate
[6404]	317	!-----------------------------------------------------
	318	IF( ln_dynspg_ts ) THEN
	319	zvb(nlci-1,:) = 0._wp
	320	DO jk = 1, jpkm1
	321	DO jj = 1, jpj
	322	zvb(nlci-1,jj) = zvb(nlci-1,jj) + e3v_a(nlci-1,jj,jk) * va(nlci-1,jj,jk)
	323	END DO
[4486]	324	END DO
	325	DO jj=1,jpj
[6404]	326	zvb(nlci-1,jj) = zvb(nlci-1,jj) * r1_hv_a(nlci-1,jj)
[4486]	327	END DO
[6404]	328	DO jk = 1, jpkm1
	329	DO jj = 1, jpj
	330	va(nlci-1,jj,jk) = ( va(nlci-1,jj,jk) + va_b(nlci-1,jj) - zvb(nlci-1,jj) ) * vmask(nlci-1,jj,jk)
	331	END DO
	332	END DO
	333	ENDIF
	334	!
	335	! Mask domain edges:
	336	!-------------------
	337	DO jk = 1, jpkm1
	338	DO jj = 1, jpj
	339	ua(nlci-1,jj,jk) = 0._wp
	340	va(nlci ,jj,jk) = 0._wp
	341	END DO
	342	END DO
	343	!
[636]	344	ENDIF
[390]	345
[6404]	346	IF( nbondj == -1 .OR. nbondj == 2 ) THEN
[390]	347
[6404]	348	! Smoothing
	349	! ---------
	350	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
	351	va_b(:,2) = 0._wp
	352	DO jk = 1, jpkm1
	353	DO ji = 1, jpi
	354	va_b(ji,2) = va_b(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk)
	355	END DO
[636]	356	END DO
	357	DO ji=1,jpi
[6404]	358	va_b(ji,2) = va_b(ji,2) * r1_hv_a(ji,2)
[636]	359	END DO
[6404]	360	ENDIF
	361	!
	362	DO jk = 1, jpkm1 ! Smooth
	363	DO ji = i1, i2
	364	va(ji,2,jk) = 0.25_wp * vmask(ji,2,jk) &
	365	& * ( va(ji,1,jk) + 2._wp*va(ji,2,jk) + va(ji,3,jk) )
[636]	366	END DO
	367	END DO
[6404]	368	!
	369	zvb(:,2) = 0._wp ! Correct transport
[636]	370	DO jk=1,jpkm1
	371	DO ji=1,jpi
[6404]	372	zvb(ji,2) = zvb(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk) * vmask(ji,2,jk)
[636]	373	END DO
	374	END DO
[6404]	375	DO ji = 1, jpi
	376	zvb(ji,2) = zvb(ji,2) * r1_hv_a(ji,2)
[636]	377	END DO
[6404]	378	DO jk = 1, jpkm1
	379	DO ji = 1, jpi
	380	va(ji,2,jk) = ( va(ji,2,jk) + va_b(ji,2) - zvb(ji,2) ) * vmask(ji,2,jk)
[636]	381	END DO
	382	END DO
[390]	383
[4486]	384	! Set tangential velocities to time splitting estimate
[6404]	385	!-----------------------------------------------------
	386	IF( ln_dynspg_ts ) THEN
	387	zub(:,2) = 0._wp
	388	DO jk = 1, jpkm1
	389	DO ji = 1, jpi
	390	zub(ji,2) = zub(ji,2) + e3u_a(ji,2,jk) * ua(ji,2,jk) * umask(ji,2,jk)
	391	END DO
[4486]	392	END DO
[6404]	393	DO ji = 1, jpi
	394	zub(ji,2) = zub(ji,2) * r1_hu_a(ji,2)
[4486]	395	END DO
[390]	396
[6404]	397	DO jk = 1, jpkm1
	398	DO ji = 1, jpi
	399	ua(ji,2,jk) = ( ua(ji,2,jk) + ua_b(ji,2) - zub(ji,2) ) * umask(ji,2,jk)
	400	END DO
[636]	401	END DO
[6404]	402	ENDIF
[390]	403
[6404]	404	! Mask domain edges:
	405	!-------------------
	406	DO jk = 1, jpkm1
	407	DO ji = 1, jpi
	408	ua(ji,1,jk) = 0._wp
	409	va(ji,1,jk) = 0._wp
[636]	410	END DO
[6404]	411	END DO
[390]	412
[6404]	413	ENDIF
[5656]	414
[6404]	415	IF( nbondj == 1 .OR. nbondj == 2 ) THEN
	416	!
	417	! Smoothing
	418	! ---------
	419	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
	420	va_b(:,nlcj-2) = 0._wp
	421	DO jk = 1, jpkm1
	422	DO ji = 1, jpi
	423	va_b(ji,nlcj-2) = va_b(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk)
	424	END DO
[636]	425	END DO
[6404]	426	DO ji = 1, jpi
	427	va_b(ji,nlcj-2) = va_b(ji,nlcj-2) * r1_hv_a(ji,nlcj-2)
	428	END DO
	429	ENDIF
	430	!
	431	DO jk = 1, jpkm1 ! Smooth
	432	DO ji = i1, i2
	433	va(ji,nlcj-2,jk) = 0.25_wp * vmask(ji,nlcj-2,jk) &
	434	& * ( va(ji,nlcj-3,jk) + 2._wp * va(ji,nlcj-2,jk) + va(ji,nlcj-1,jk) )
	435	END DO
[636]	436	END DO
[6404]	437	!
	438	zvb(:,nlcj-2) = 0._wp ! Correct transport
	439	DO jk = 1, jpkm1
	440	DO ji = 1, jpi
	441	zvb(ji,nlcj-2) = zvb(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk)
[636]	442	END DO
	443	END DO
[6404]	444	DO ji = 1, jpi
	445	zvb(ji,nlcj-2) = zvb(ji,nlcj-2) * r1_hv_a(ji,nlcj-2)
[636]	446	END DO
[6404]	447	DO jk = 1, jpkm1
	448	DO ji = 1, jpi
	449	va(ji,nlcj-2,jk) = ( va(ji,nlcj-2,jk) + va_b(ji,nlcj-2) - zvb(ji,nlcj-2) ) * vmask(ji,nlcj-2,jk)
[636]	450	END DO
	451	END DO
[6404]	452	!
[4486]	453	! Set tangential velocities to time splitting estimate
[6404]	454	!-----------------------------------------------------
	455	IF( ln_dynspg_ts ) THEN
	456	zub(:,nlcj-1) = 0._wp
	457	DO jk = 1, jpkm1
	458	DO ji = 1, jpi
	459	zub(ji,nlcj-1) = zub(ji,nlcj-1) + e3u_a(ji,nlcj-1,jk) * ua(ji,nlcj-1,jk) * umask(ji,nlcj-1,jk)
	460	END DO
[4486]	461	END DO
[6404]	462	DO ji = 1, jpi
	463	zub(ji,nlcj-1) = zub(ji,nlcj-1) * r1_hu_a(ji,nlcj-1)
[4486]	464	END DO
[6404]	465	!
	466	DO jk = 1, jpkm1
	467	DO ji = 1, jpi
	468	ua(ji,nlcj-1,jk) = ( ua(ji,nlcj-1,jk) + ua_b(ji,nlcj-1) - zub(ji,nlcj-1) ) * umask(ji,nlcj-1,jk)
	469	END DO
	470	END DO
	471	ENDIF
	472	!
	473	! Mask domain edges:
	474	!-------------------
	475	DO jk = 1, jpkm1
	476	DO ji = 1, jpi
	477	ua(ji,nlcj ,jk) = 0._wp
	478	va(ji,nlcj-1,jk) = 0._wp
	479	END DO
	480	END DO
	481	!
[636]	482	ENDIF
[2715]	483	!
[6404]	484	CALL wrk_dealloc( jpi,jpj, zub, zvb )
[2715]	485	!
[636]	486	END SUBROUTINE Agrif_dyn
[390]	487
[6404]	488
[4486]	489	SUBROUTINE Agrif_dyn_ts( jn )
[4292]	490	!!----------------------------------------------------------------------
	491	!! * ROUTINE Agrif_dyn_ts *
	492	!!----------------------------------------------------------------------
	493	!!
[4486]	494	INTEGER, INTENT(in) :: jn
[4292]	495	!!
	496	INTEGER :: ji, jj
[4486]	497	!!----------------------------------------------------------------------
[6404]	498	!
[4486]	499	IF( Agrif_Root() ) RETURN
[6404]	500	!
[4486]	501	IF((nbondi == -1).OR.(nbondi == 2)) THEN
	502	DO jj=1,jpj
	503	va_e(2,jj) = vbdy_w(jj) * hvr_e(2,jj)
[5656]	504	! Specified fluxes:
[4486]	505	ua_e(2,jj) = ubdy_w(jj) * hur_e(2,jj)
[5656]	506	! Characteristics method:
	507	!alt ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) &
	508	!alt & - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) )
[4486]	509	END DO
	510	ENDIF
[6404]	511	!
[4486]	512	IF((nbondi == 1).OR.(nbondi == 2)) THEN
	513	DO jj=1,jpj
	514	va_e(nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj)
[5656]	515	! Specified fluxes:
[4486]	516	ua_e(nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj)
[5656]	517	! Characteristics method:
	518	!alt ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) &
	519	!alt & + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) )
[4486]	520	END DO
	521	ENDIF
[6404]	522	!
[4486]	523	IF((nbondj == -1).OR.(nbondj == 2)) THEN
	524	DO ji=1,jpi
	525	ua_e(ji,2) = ubdy_s(ji) * hur_e(ji,2)
[5656]	526	! Specified fluxes:
[4486]	527	va_e(ji,2) = vbdy_s(ji) * hvr_e(ji,2)
[5656]	528	! Characteristics method:
	529	!alt va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) &
	530	!alt & - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) )
[4486]	531	END DO
	532	ENDIF
[6404]	533	!
[4486]	534	IF((nbondj == 1).OR.(nbondj == 2)) THEN
	535	DO ji=1,jpi
	536	ua_e(ji,nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-1)
[5656]	537	! Specified fluxes:
[4486]	538	va_e(ji,nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-2)
[5656]	539	! Characteristics method:
	540	!alt va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2) + va_e(ji,nlcj-3) &
	541	!alt & + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) )
[4486]	542	END DO
	543	ENDIF
	544	!
	545	END SUBROUTINE Agrif_dyn_ts
	546
[6404]	547
[4486]	548	SUBROUTINE Agrif_dta_ts( kt )
	549	!!----------------------------------------------------------------------
	550	!! * ROUTINE Agrif_dta_ts *
	551	!!----------------------------------------------------------------------
	552	!!
	553	INTEGER, INTENT(in) :: kt
	554	!!
	555	INTEGER :: ji, jj
	556	LOGICAL :: ll_int_cons
[5656]	557	REAL(wp) :: zrhot, zt
[4292]	558	!!----------------------------------------------------------------------
[6404]	559	!
[4292]	560	IF( Agrif_Root() ) RETURN
[6404]	561	!
	562	ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only
	563	!
[4486]	564	zrhot = Agrif_rhot()
[6404]	565	!
[4486]	566	! "Central" time index for interpolation:
[6404]	567	IF( ln_bt_fw ) THEN
	568	zt = REAL( Agrif_NbStepint()+0.5_wp, wp ) / zrhot
[4486]	569	ELSE
[6404]	570	zt = REAL( Agrif_NbStepint() , wp ) / zrhot
[4486]	571	ENDIF
[6404]	572	!
[4486]	573	! Linear interpolation of sea level
[6404]	574	Agrif_SpecialValue = 0._wp
[4486]	575	Agrif_UseSpecialValue = .TRUE.
[6404]	576	CALL Agrif_Bc_variable( sshn_id, calledweight=zt, procname=interpsshn )
[4486]	577	Agrif_UseSpecialValue = .FALSE.
[6404]	578	!
[4486]	579	! Interpolate barotropic fluxes
	580	Agrif_SpecialValue=0.
	581	Agrif_UseSpecialValue = ln_spc_dyn
[6404]	582	!
	583	IF( ll_int_cons ) THEN ! Conservative interpolation
[5656]	584	! orders matters here !!!!!!
[6404]	585	CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated
	586	CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b )
[5656]	587	bdy_tinterp = 1
[6404]	588	CALL Agrif_Bc_variable( unb_id , calledweight=1._wp, procname=interpunb ) ! After
	589	CALL Agrif_Bc_variable( vnb_id , calledweight=1._wp, procname=interpvnb )
[5656]	590	bdy_tinterp = 2
[6404]	591	CALL Agrif_Bc_variable( unb_id , calledweight=0._wp, procname=interpunb ) ! Before
	592	CALL Agrif_Bc_variable( vnb_id , calledweight=0._wp, procname=interpvnb )
[4486]	593	ELSE ! Linear interpolation
[5656]	594	bdy_tinterp = 0
[6404]	595	ubdy_w(:) = 0._wp ; vbdy_w(:) = 0._wp
	596	ubdy_e(:) = 0._wp ; vbdy_e(:) = 0._wp
	597	ubdy_n(:) = 0._wp ; vbdy_n(:) = 0._wp
	598	ubdy_s(:) = 0._wp ; vbdy_s(:) = 0._wp
	599	CALL Agrif_Bc_variable( unb_id, calledweight=zt, procname=interpunb )
	600	CALL Agrif_Bc_variable( vnb_id, calledweight=zt, procname=interpvnb )
[4486]	601	ENDIF
	602	Agrif_UseSpecialValue = .FALSE.
[5656]	603	!
[4486]	604	END SUBROUTINE Agrif_dta_ts
	605
[6404]	606
[2486]	607	SUBROUTINE Agrif_ssh( kt )
	608	!!----------------------------------------------------------------------
[2528]	609	!! * ROUTINE Agrif_DYN *
[2486]	610	!!----------------------------------------------------------------------
	611	INTEGER, INTENT(in) :: kt
	612	!!
	613	!!----------------------------------------------------------------------
[6404]	614	!
[2486]	615	IF( Agrif_Root() ) RETURN
[6404]	616	!
[2486]	617	IF((nbondi == -1).OR.(nbondi == 2)) THEN
	618	ssha(2,:)=ssha(3,:)
	619	sshn(2,:)=sshn(3,:)
	620	ENDIF
[6404]	621	!
[2486]	622	IF((nbondi == 1).OR.(nbondi == 2)) THEN
	623	ssha(nlci-1,:)=ssha(nlci-2,:)
[5656]	624	sshn(nlci-1,:)=sshn(nlci-2,:)
[2486]	625	ENDIF
[6404]	626	!
[2486]	627	IF((nbondj == -1).OR.(nbondj == 2)) THEN
[4292]	628	ssha(:,2)=ssha(:,3)
	629	sshn(:,2)=sshn(:,3)
[2486]	630	ENDIF
[6404]	631	!
[2486]	632	IF((nbondj == 1).OR.(nbondj == 2)) THEN
	633	ssha(:,nlcj-1)=ssha(:,nlcj-2)
[5656]	634	sshn(:,nlcj-1)=sshn(:,nlcj-2)
[2486]	635	ENDIF
[6404]	636	!
[2486]	637	END SUBROUTINE Agrif_ssh
	638
[6404]	639
[4486]	640	SUBROUTINE Agrif_ssh_ts( jn )
[4292]	641	!!----------------------------------------------------------------------
	642	!! * ROUTINE Agrif_ssh_ts *
	643	!!----------------------------------------------------------------------
[4486]	644	INTEGER, INTENT(in) :: jn
[4292]	645	!!
[4486]	646	INTEGER :: ji,jj
[4292]	647	!!----------------------------------------------------------------------
[6404]	648	!
[4292]	649	IF((nbondi == -1).OR.(nbondi == 2)) THEN
[6404]	650	DO jj = 1, jpj
[4486]	651	ssha_e(2,jj) = hbdy_w(jj)
	652	END DO
[4292]	653	ENDIF
[6404]	654	!
[4292]	655	IF((nbondi == 1).OR.(nbondi == 2)) THEN
[6404]	656	DO jj = 1, jpj
[4486]	657	ssha_e(nlci-1,jj) = hbdy_e(jj)
	658	END DO
[4292]	659	ENDIF
[6404]	660	!
[4292]	661	IF((nbondj == -1).OR.(nbondj == 2)) THEN
[6404]	662	DO ji = 1, jpi
[4486]	663	ssha_e(ji,2) = hbdy_s(ji)
	664	END DO
[4292]	665	ENDIF
[6404]	666	!
[4292]	667	IF((nbondj == 1).OR.(nbondj == 2)) THEN
[6404]	668	DO ji = 1, jpi
[4486]	669	ssha_e(ji,nlcj-1) = hbdy_n(ji)
	670	END DO
[4292]	671	ENDIF
[6404]	672	!
[4292]	673	END SUBROUTINE Agrif_ssh_ts
	674
[5656]	675	# if defined key_zdftke
[6404]	676
[5656]	677	SUBROUTINE Agrif_tke
[4292]	678	!!----------------------------------------------------------------------
[5656]	679	!! * ROUTINE Agrif_tke *
	680	!!----------------------------------------------------------------------
	681	REAL(wp) :: zalpha
[6404]	682	!!----------------------------------------------------------------------
[5656]	683	!
[6258]	684	return
	685
[5656]	686	zalpha = REAL( Agrif_NbStepint() + Agrif_IRhot() - 1, wp ) / REAL( Agrif_IRhot(), wp )
	687	IF( zalpha > 1. ) zalpha = 1.
[6404]	688	!
[5656]	689	Agrif_SpecialValue = 0.e0
	690	Agrif_UseSpecialValue = .TRUE.
[6404]	691	!
[5656]	692	CALL Agrif_Bc_variable(avm_id ,calledweight=zalpha, procname=interpavm)
[6404]	693	!
[5656]	694	Agrif_UseSpecialValue = .FALSE.
	695	!
	696	END SUBROUTINE Agrif_tke
[6404]	697
[5656]	698	# endif
	699
[6404]	700	SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )
	701	!!----------------------------------------------------------------------
[5656]	702	!! * ROUTINE interptsn *
[6404]	703	!!----------------------------------------------------------------------
	704	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab
	705	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2
	706	LOGICAL , INTENT(in ) :: before
	707	INTEGER , INTENT(in ) :: nb , ndir
[5656]	708	!
	709	INTEGER :: ji, jj, jk, jn ! dummy loop indices
[6404]	710	INTEGER :: imin, imax, jmin, jmax
[5656]	711	REAL(wp) :: zrhox , zalpha1, zalpha2, zalpha3
	712	REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha7
	713	LOGICAL :: western_side, eastern_side,northern_side,southern_side
[6258]	714	! VERTICAL REFINEMENT BEGIN
	715	REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: ptab_child
[7824]	716	REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin
[6258]	717	REAL(wp) :: h_in(k1:k2)
	718	REAL(wp) :: h_out(1:jpk)
	719	INTEGER :: N_in, N_out
	720	REAL(wp) :: h_diff
[7824]	721	REAL(wp) :: zrhoxy
[6258]	722	! VERTICAL REFINEMENT END
[5656]	723
[7824]	724	zrhoxy = Agrif_rhox()*Agrif_rhoy()
[5656]	725	IF (before) THEN
[7824]	726	DO jn = n1,n2-1
	727	DO jk=k1,k2
	728	DO jj=j1,j2
	729	DO ji=i1,i2
	730	ptab(ji,jj,jk,jn) = tsn(ji,jj,jk,jn) * e1e2t(ji,jj) * e3t_n(ji,jj,jk)
	731	END DO
	732	END DO
	733	END DO
	734	END DO
	735	DO jk=k1,k2
	736	DO jj=j1,j2
	737	DO ji=i1,i2
	738	ptab(ji,jj,jk,n2) = tmask(ji,jj,jk) * e1e2t(ji,jj) * e3t_n(ji,jj,jk)
	739	END DO
	740	END DO
	741	END DO
	742
[6258]	743	ELSE
	744	! VERTICAL REFINEMENT BEGIN
	745
	746	ptab_child(:,:,:,:) = 0.
	747	do jj=j1,j2
	748	do ji=i1,i2
[7824]	749	N_in = 0
	750	DO jk=k1,k2 !k2 = jpk of parent grid
	751	IF (ptab(ji,jj,jk,n2) == 0) EXIT
	752	N_in = N_in + 1
	753	tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1)/ptab(ji,jj,jk,n2)
	754	h_in(N_in) = ptab(ji,jj,jk,n2)/(e1e2t(ji,jj)*zrhoxy)
	755	END DO
[6258]	756	N_out = jpk-1
[7824]	757	DO jk=1,jpk ! jpk of child grid
	758	! IF (tmask(ji,jj,jk) == 0) EXIT ! TODO: Will not work with ISF. !This doesn't seem to work at the moment. Is it just a GYRE issue???????
	759	! N_out = N_out + 1
	760	h_out(jk) = e3t_n(ji,jj,jk) !Child grid scale factors. Could multiply by e1e2t here instead of division above
	761	ENDDO
	762	IF (N_in > 0) THEN
	763	h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
	764	! if (h_diff > 0) then
	765	! h_in(N_in+1) = h_diff
	766	! N_in = N_in + 1
	767	! else
	768	! h_out(N_out+1) = -h_diff
	769	! N_out = N_out + 1
	770	! endif
	771	ptab(ji,jj,k2,:) = ptab(ji,jj,k2-1,:) !what is this line for?????
[6258]	772	do jn=1,jpts
[7824]	773	call reconstructandremap(tabin(1:N_in,jn),h_in,ptab_child(ji,jj,1:N_out,jn),h_out,N_in,N_out)
[6258]	774	enddo
	775	! if (abs(h_diff) > 1000.) then
	776	! do jn=1,jpts
	777	! do jk=1,N_out
	778	! print *,'AVANT APRES = ',ji,jj,jk,N_out,ptab(ji,jj,jk,jn),ptab_child(ji,jj,jk,jn)
	779	! enddo
	780	! enddo
	781	! endif
[7824]	782	ENDIF
[6258]	783	enddo
	784	enddo
[7824]	785
[6258]	786
	787	! VERTICAL REFINEMENT END
	788
[5656]	789	!
	790	western_side = (nb == 1).AND.(ndir == 1)
	791	eastern_side = (nb == 1).AND.(ndir == 2)
	792	southern_side = (nb == 2).AND.(ndir == 1)
	793	northern_side = (nb == 2).AND.(ndir == 2)
	794	!
	795	zrhox = Agrif_Rhox()
	796	!
	797	zalpha1 = ( zrhox - 1. ) * 0.5
	798	zalpha2 = 1. - zalpha1
	799	!
	800	zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. )
	801	zalpha4 = 1. - zalpha3
	802	!
	803	zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )
	804	zalpha7 = - ( zrhox - 1. ) / ( zrhox + 3. )
	805	zalpha5 = 1. - zalpha6 - zalpha7
	806	!
	807	imin = i1
	808	imax = i2
	809	jmin = j1
	810	jmax = j2
	811	!
	812	! Remove CORNERS
	813	IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3
	814	IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2
	815	IF((nbondi == -1).OR.(nbondi == 2)) imin = 3
	816	IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2
	817	!
[6258]	818	! VERTICAL REFINEMENT BEGIN
	819
	820	! WARNING :
	821	! ptab replaced by ptab_child in the following
	822	! k1 k2 replaced by 1 jpk
	823	! VERTICAL REFINEMENT END
[5656]	824	IF( eastern_side) THEN
	825	DO jn = 1, jpts
[6258]	826	tsa(nlci,j1:j2,1:jpk,jn) = zalpha1 * ptab_child(nlci,j1:j2,1:jpk,jn) + zalpha2 * ptab_child(nlci-1,j1:j2,1:jpk,jn)
[5656]	827	DO jk = 1, jpkm1
	828	DO jj = jmin,jmax
[6404]	829	IF( umask(nlci-2,jj,jk) == 0._wp ) THEN
[5656]	830	tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk)
	831	ELSE
	832	tsa(nlci-1,jj,jk,jn)=(zalpha4tsa(nlci,jj,jk,jn)+zalpha3tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk)
[6404]	833	IF( un(nlci-2,jj,jk) > 0._wp ) THEN
[5656]	834	tsa(nlci-1,jj,jk,jn)=( zalpha6tsa(nlci-2,jj,jk,jn)+zalpha5tsa(nlci,jj,jk,jn) &
	835	+ zalpha7tsa(nlci-3,jj,jk,jn) ) tmask(nlci-1,jj,jk)
	836	ENDIF
	837	ENDIF
	838	END DO
	839	END DO
[6404]	840	tsa(nlci,j1:j2,k1:k2,jn) = 0._wp
	841	END DO
[5656]	842	ENDIF
	843	!
	844	IF( northern_side ) THEN
	845	DO jn = 1, jpts
[6258]	846	tsa(i1:i2,nlcj,1:jpk,jn) = zalpha1 * ptab_child(i1:i2,nlcj,1:jpk,jn) + zalpha2 * ptab_child(i1:i2,nlcj-1,1:jpk,jn)
[5656]	847	DO jk = 1, jpkm1
	848	DO ji = imin,imax
[6404]	849	IF( vmask(ji,nlcj-2,jk) == 0._wp ) THEN
[5656]	850	tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk)
	851	ELSE
	852	tsa(ji,nlcj-1,jk,jn)=(zalpha4tsa(ji,nlcj,jk,jn)+zalpha3tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)
[6404]	853	IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN
[5656]	854	tsa(ji,nlcj-1,jk,jn)=( zalpha6tsa(ji,nlcj-2,jk,jn)+zalpha5tsa(ji,nlcj,jk,jn) &
	855	+ zalpha7tsa(ji,nlcj-3,jk,jn) ) tmask(ji,nlcj-1,jk)
	856	ENDIF
	857	ENDIF
	858	END DO
	859	END DO
[6404]	860	tsa(i1:i2,nlcj,k1:k2,jn) = 0._wp
	861	END DO
[5656]	862	ENDIF
	863	!
[6404]	864	IF( western_side ) THEN
[5656]	865	DO jn = 1, jpts
[6258]	866	tsa(1,j1:j2,1:jpk,jn) = zalpha1 * ptab_child(1,j1:j2,1:jpk,jn) + zalpha2 * ptab_child(2,j1:j2,1:jpk,jn)
[5656]	867	DO jk = 1, jpkm1
	868	DO jj = jmin,jmax
[6404]	869	IF( umask(2,jj,jk) == 0._wp ) THEN
[5656]	870	tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk)
	871	ELSE
	872	tsa(2,jj,jk,jn)=(zalpha4tsa(1,jj,jk,jn)+zalpha3tsa(3,jj,jk,jn))*tmask(2,jj,jk)
[6404]	873	IF( un(2,jj,jk) < 0._wp ) THEN
[5656]	874	tsa(2,jj,jk,jn)=(zalpha6tsa(3,jj,jk,jn)+zalpha5tsa(1,jj,jk,jn)+zalpha7tsa(4,jj,jk,jn))tmask(2,jj,jk)
	875	ENDIF
	876	ENDIF
	877	END DO
	878	END DO
[6404]	879	tsa(1,j1:j2,k1:k2,jn) = 0._wp
[5656]	880	END DO
	881	ENDIF
	882	!
	883	IF( southern_side ) THEN
	884	DO jn = 1, jpts
[6258]	885	tsa(i1:i2,1,1:jpk,jn) = zalpha1 * ptab_child(i1:i2,1,1:jpk,jn) + zalpha2 * ptab_child(i1:i2,2,1:jpk,jn)
[6404]	886	DO jk = 1, jpk
[5656]	887	DO ji=imin,imax
[6404]	888	IF( vmask(ji,2,jk) == 0._wp ) THEN
[5656]	889	tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk)
	890	ELSE
	891	tsa(ji,2,jk,jn)=(zalpha4tsa(ji,1,jk,jn)+zalpha3tsa(ji,3,jk,jn))*tmask(ji,2,jk)
[6404]	892	IF( vn(ji,2,jk) < 0._wp ) THEN
[5656]	893	tsa(ji,2,jk,jn)=(zalpha6tsa(ji,3,jk,jn)+zalpha5tsa(ji,1,jk,jn)+zalpha7tsa(ji,4,jk,jn))tmask(ji,2,jk)
	894	ENDIF
	895	ENDIF
	896	END DO
	897	END DO
[6404]	898	tsa(i1:i2,1,k1:k2,jn) = 0._wp
	899	END DO
[5656]	900	ENDIF
	901	!
	902	! Treatment of corners
	903	!
	904	! East south
	905	IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN
[6258]	906	tsa(nlci-1,2,:,:) = ptab_child(nlci-1,2,:,:)
[5656]	907	ENDIF
	908	! East north
	909	IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN
[6258]	910	tsa(nlci-1,nlcj-1,:,:) = ptab_child(nlci-1,nlcj-1,:,:)
[5656]	911	ENDIF
	912	! West south
	913	IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN
[6258]	914	tsa(2,2,:,:) = ptab_child(2,2,:,:)
[5656]	915	ENDIF
	916	! West north
	917	IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN
[6258]	918	tsa(2,nlcj-1,:,:) = ptab_child(2,nlcj-1,:,:)
[5656]	919	ENDIF
	920	!
	921	ENDIF
	922	!
	923	END SUBROUTINE interptsn
	924
[6404]	925
	926	SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before, nb, ndir )
[5656]	927	!!----------------------------------------------------------------------
[4292]	928	!! * ROUTINE interpsshn *
	929	!!----------------------------------------------------------------------
[6404]	930	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	931	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	932	LOGICAL , INTENT(in ) :: before
	933	INTEGER , INTENT(in ) :: nb , ndir
	934	!
[5656]	935	LOGICAL :: western_side, eastern_side,northern_side,southern_side
	936	!!----------------------------------------------------------------------
	937	!
	938	IF( before) THEN
	939	ptab(i1:i2,j1:j2) = sshn(i1:i2,j1:j2)
	940	ELSE
	941	western_side = (nb == 1).AND.(ndir == 1)
	942	eastern_side = (nb == 1).AND.(ndir == 2)
	943	southern_side = (nb == 2).AND.(ndir == 1)
	944	northern_side = (nb == 2).AND.(ndir == 2)
	945	IF(western_side) hbdy_w(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1)
	946	IF(eastern_side) hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1)
	947	IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1)
	948	IF(northern_side) hbdy_n(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1)
	949	ENDIF
	950	!
	951	END SUBROUTINE interpsshn
	952
[6258]	953	SUBROUTINE interpun(ptab,i1,i2,j1,j2,k1,k2,m1,m2,before,nb,ndir)
[5656]	954	!!---------------------------------------------
	955	!! * ROUTINE interpun *
	956	!!---------------------------------------------
[4292]	957	!!
[6258]	958	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
	959	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
[5656]	960	LOGICAL, INTENT(in) :: before
[6258]	961	INTEGER, INTENT(in) :: nb , ndir
[5656]	962	!!
	963	INTEGER :: ji,jj,jk
[6258]	964	REAL(wp) :: zrhoy
	965	! VERTICAL REFINEMENT BEGIN
	966	REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: ptab_child
	967	REAL(wp), DIMENSION(k1:k2) :: tabin
	968	REAL(wp) :: h_in(k1:k2)
	969	REAL(wp) :: h_out(1:jpk)
	970	INTEGER :: N_in, N_out
	971	REAL(wp) :: h_diff
	972	LOGICAL :: western_side, eastern_side
	973	INTEGER :: iref
	974
	975	! VERTICAL REFINEMENT END
[5656]	976	!!---------------------------------------------
	977	!
[6930]	978	zrhoy = Agrif_rhoy()
[5656]	979	IF (before) THEN
	980	DO jk=1,jpk
	981	DO jj=j1,j2
	982	DO ji=i1,i2
[7824]	983	ptab(ji,jj,jk,1) = e2u(ji,jj) * e3u_n(ji,jj,jk) * un(ji,jj,jk)
	984	ptab(ji,jj,jk,2) = umask(ji,jj,jk) * e2u(ji,jj) * e3u_n(ji,jj,jk)
[5656]	985	END DO
	986	END DO
	987	END DO
	988	ELSE
[6258]	989	! VERTICAL REFINEMENT BEGIN
	990	western_side = (nb == 1).AND.(ndir == 1)
	991	eastern_side = (nb == 1).AND.(ndir == 2)
	992
	993	ptab_child(:,:,:) = 0.
[6930]	994	DO jj=j1,j2
	995	DO ji=i1,i2
	996	iref = ji
	997	IF (western_side) iref = 2
	998	IF (eastern_side) iref = nlci-2
[6258]	999
[6930]	1000	N_in = 0
	1001	DO jk=k1,k2
	1002	IF (ptab(ji,jj,jk,2) == 0) EXIT
	1003	N_in = N_in + 1
	1004	tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2)
[7824]	1005	h_in(N_in) = ptab(ji,jj,jk,2)/(e2u(ji,jj) * zrhoy)
[6930]	1006	ENDDO
[6258]	1007
[6930]	1008	IF (N_in == 0) THEN
	1009	ptab_child(ji,jj,:) = 0.
	1010	CYCLE
	1011	ENDIF
[6258]	1012
[6930]	1013	N_out = 0
	1014	DO jk=1,jpk
	1015	if (umask(iref,jj,jk) == 0) EXIT
	1016	N_out = N_out + 1
	1017	h_out(N_out) = e3u_n(ji,jj,jk)
	1018	ENDDO
[6258]	1019
[6930]	1020	IF (N_out == 0) THEN
	1021	ptab_child(ji,jj,:) = 0.
	1022	CYCLE
	1023	ENDIF
[6258]	1024
[7824]	1025	! IF (N_in * N_out > 0) THEN
	1026	! h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
	1027	! Should be able to remove the next IF/ELSEIF statement once scale factors are dealt with properly
	1028	! if (h_diff < 0.) then
	1029	! print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in))
	1030	! stop
	1031	! endif
	1032	! ENDIF
[6930]	1033	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)
[6258]	1034
[6930]	1035	ENDDO
[6258]	1036	ENDDO
	1037
	1038	! in the following
[6930]	1039	! remove division of ua by fs e3u (already done) and also zrhoy and e2u
[6258]	1040	! VERTICAL REFINEMENT END
	1041
[6404]	1042	DO jk = 1, jpkm1
[5656]	1043	DO jj=j1,j2
[6930]	1044	ua(i1:i2,jj,jk) = ptab_child(i1:i2,jj,jk)
	1045	!/(zrhoy*e2u(i1:i2,jj)))
[5656]	1046	END DO
	1047	END DO
	1048	ENDIF
	1049	!
	1050	END SUBROUTINE interpun
	1051
	1052
[4292]	1053
[6258]	1054	SUBROUTINE interpvn(ptab,i1,i2,j1,j2,k1,k2,m1,m2,before,nb,ndir)
[5656]	1055	!!---------------------------------------------
	1056	!! * ROUTINE interpvn *
[6404]	1057	!!----------------------------------------------------------------------
[5656]	1058	!
[6258]	1059	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
	1060	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
[5656]	1061	LOGICAL, INTENT(in) :: before
[6258]	1062	INTEGER, INTENT(in) :: nb , ndir
[5656]	1063	!
[636]	1064	INTEGER :: ji,jj,jk
[6258]	1065	REAL(wp) :: zrhox
	1066	! VERTICAL REFINEMENT BEGIN
	1067	REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: ptab_child
	1068	REAL(wp), DIMENSION(k1:k2) :: tabin
	1069	REAL(wp) :: h_in(k1:k2)
	1070	REAL(wp) :: h_out(1:jpk)
	1071	INTEGER :: N_in, N_out
	1072	REAL(wp) :: h_diff
	1073	LOGICAL :: northern_side,southern_side
	1074	INTEGER :: jref
	1075
	1076	! VERTICAL REFINEMENT END
[5656]	1077	!!---------------------------------------------
	1078	!
[7824]	1079	zrhox = Agrif_rhox()
[5656]	1080	IF (before) THEN
[7824]	1081	DO jk=k1,k2
[5656]	1082	DO jj=j1,j2
	1083	DO ji=i1,i2
[7824]	1084	ptab(ji,jj,jk,1) = e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk)
	1085	ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v_n(ji,jj,jk)
[5656]	1086	END DO
	1087	END DO
	1088	END DO
[6258]	1089	ELSE
	1090	! VERTICAL REFINEMENT BEGIN
	1091	ptab_child(:,:,:) = 0.
	1092	southern_side = (nb == 2).AND.(ndir == 1)
	1093	northern_side = (nb == 2).AND.(ndir == 2)
	1094	do jj=j1,j2
[7824]	1095	jref = jj
	1096	IF (southern_side) jref = 2
	1097	IF (northern_side) jref = nlcj-2
	1098	do ji=i1,i2
[6258]	1099
[7824]	1100	N_in = 0
	1101	do jk=k1,k2
	1102	if (ptab(ji,jj,jk,2) == 0) EXIT
	1103	N_in = N_in + 1
	1104	tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2)
	1105	h_in(N_in) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox)
	1106	enddo
	1107	IF (N_in == 0) THEN
	1108	ptab_child(ji,jj,:) = 0.
	1109	CYCLE
	1110	ENDIF
[6258]	1111
[7824]	1112	N_out = 0
	1113	do jk=1,jpk
	1114	if (vmask(ji,jref,jk) == 0) EXIT
	1115	N_out = N_out + 1
	1116	h_out(N_out) = e3v_n(ji,jj,jk)
	1117	enddo
	1118	IF (N_out == 0) THEN
	1119	ptab_child(ji,jj,:) = 0.
	1120	CYCLE
	1121	ENDIF
	1122
	1123	! IF (N_in * N_out > 0) THEN
	1124	! h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
	1125	! Should be able to remove the next IF/ELSEIF statement once scale factors are dealt with properly
	1126	! if (h_diff < 0.) then
	1127	! print *,'CHECK YOUR BATHY interpvn...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in))
	1128	! stop
	1129	! endif
	1130	! ENDIF
	1131	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)
[6258]	1132
[7824]	1133	enddo
[6258]	1134	enddo
	1135	! in the following
[7824]	1136	! remove division of va by fs e3v, zrhox and e1v (already done)
[6258]	1137	! VERTICAL REFINEMENT END
[5656]	1138	DO jk=1,jpkm1
	1139	DO jj=j1,j2
[7824]	1140	va(i1:i2,jj,jk) = ptab_child(i1:i2,jj,jk)
[5656]	1141	END DO
	1142	END DO
	1143	ENDIF
	1144	!
	1145	END SUBROUTINE interpvn
[6404]	1146
[636]	1147
[6404]	1148	SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before, nb, ndir )
[1605]	1149	!!----------------------------------------------------------------------
[5656]	1150	!! * ROUTINE interpunb *
[1605]	1151	!!----------------------------------------------------------------------
[6404]	1152	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1153	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1154	LOGICAL , INTENT(in ) :: before
	1155	INTEGER , INTENT(in ) :: nb , ndir
	1156	!
	1157	INTEGER :: ji, jj
	1158	REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff
	1159	LOGICAL :: western_side, eastern_side,northern_side,southern_side
[1605]	1160	!!----------------------------------------------------------------------
[5656]	1161	!
[6404]	1162	IF( before ) THEN
	1163	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * hu_n(i1:i2,j1:j2) * un_b(i1:i2,j1:j2)
[5656]	1164	ELSE
	1165	western_side = (nb == 1).AND.(ndir == 1)
	1166	eastern_side = (nb == 1).AND.(ndir == 2)
	1167	southern_side = (nb == 2).AND.(ndir == 1)
	1168	northern_side = (nb == 2).AND.(ndir == 2)
	1169	zrhoy = Agrif_Rhoy()
	1170	zrhot = Agrif_rhot()
	1171	! Time indexes bounds for integration
	1172	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
	1173	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
	1174	! Polynomial interpolation coefficients:
	1175	IF( bdy_tinterp == 1 ) THEN
	1176	ztcoeff = zrhot * ( zt1*2._wp ( zt1 - 1._wp) &
[6404]	1177	& - zt0*2._wp ( zt0 - 1._wp) )
[5656]	1178	ELSEIF( bdy_tinterp == 2 ) THEN
	1179	ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &
[6404]	1180	& - zt0 * ( zt0 - 1._wp)**2._wp )
[636]	1181
[5656]	1182	ELSE
	1183	ztcoeff = 1
	1184	ENDIF
	1185	!
	1186	IF(western_side) THEN
	1187	ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)
	1188	ENDIF
	1189	IF(eastern_side) THEN
	1190	ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)
	1191	ENDIF
	1192	IF(southern_side) THEN
	1193	ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1)
	1194	ENDIF
	1195	IF(northern_side) THEN
	1196	ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)
	1197	ENDIF
	1198	!
	1199	IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN
	1200	IF(western_side) THEN
[6404]	1201	ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoye2u(i1,j1:j2)) umask(i1,j1:j2,1)
[5656]	1202	ENDIF
	1203	IF(eastern_side) THEN
[6404]	1204	ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoye2u(i1,j1:j2)) umask(i1,j1:j2,1)
[5656]	1205	ENDIF
	1206	IF(southern_side) THEN
[6404]	1207	ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoye2u(i1:i2,j1)) umask(i1:i2,j1,1)
[5656]	1208	ENDIF
	1209	IF(northern_side) THEN
[6404]	1210	ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoye2u(i1:i2,j1)) umask(i1:i2,j1,1)
[5656]	1211	ENDIF
	1212	ENDIF
	1213	ENDIF
	1214	!
	1215	END SUBROUTINE interpunb
[636]	1216
[6404]	1217
	1218	SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before, nb, ndir )
[1605]	1219	!!----------------------------------------------------------------------
[5656]	1220	!! * ROUTINE interpvnb *
[1605]	1221	!!----------------------------------------------------------------------
[6404]	1222	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1223	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1224	LOGICAL , INTENT(in ) :: before
	1225	INTEGER , INTENT(in ) :: nb , ndir
	1226	!
	1227	INTEGER :: ji,jj
	1228	REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff
	1229	LOGICAL :: western_side, eastern_side,northern_side,southern_side
[1605]	1230	!!----------------------------------------------------------------------
[5656]	1231	!
[6404]	1232	IF( before ) THEN
	1233	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * hv_n(i1:i2,j1:j2) * vn_b(i1:i2,j1:j2)
[5656]	1234	ELSE
	1235	western_side = (nb == 1).AND.(ndir == 1)
	1236	eastern_side = (nb == 1).AND.(ndir == 2)
	1237	southern_side = (nb == 2).AND.(ndir == 1)
	1238	northern_side = (nb == 2).AND.(ndir == 2)
	1239	zrhox = Agrif_Rhox()
	1240	zrhot = Agrif_rhot()
	1241	! Time indexes bounds for integration
	1242	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
	1243	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
	1244	IF( bdy_tinterp == 1 ) THEN
	1245	ztcoeff = zrhot * ( zt1*2._wp ( zt1 - 1._wp) &
[6404]	1246	& - zt0*2._wp ( zt0 - 1._wp) )
[5656]	1247	ELSEIF( bdy_tinterp == 2 ) THEN
	1248	ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &
[6404]	1249	& - zt0 * ( zt0 - 1._wp)**2._wp )
[5656]	1250	ELSE
	1251	ztcoeff = 1
	1252	ENDIF
	1253	!
	1254	IF(western_side) THEN
	1255	vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)
	1256	ENDIF
	1257	IF(eastern_side) THEN
	1258	vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)
	1259	ENDIF
	1260	IF(southern_side) THEN
	1261	vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1)
	1262	ENDIF
	1263	IF(northern_side) THEN
	1264	vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)
	1265	ENDIF
	1266	!
	1267	IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN
	1268	IF(western_side) THEN
	1269	vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2)) &
	1270	& * vmask(i1,j1:j2,1)
	1271	ENDIF
	1272	IF(eastern_side) THEN
	1273	vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2)) &
	1274	& * vmask(i1,j1:j2,1)
	1275	ENDIF
	1276	IF(southern_side) THEN
	1277	vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1)) &
	1278	& * vmask(i1:i2,j1,1)
	1279	ENDIF
	1280	IF(northern_side) THEN
	1281	vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1)) &
	1282	& * vmask(i1:i2,j1,1)
	1283	ENDIF
	1284	ENDIF
	1285	ENDIF
	1286	!
	1287	END SUBROUTINE interpvnb
[390]	1288
[6404]	1289
	1290	SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before, nb, ndir )
[1605]	1291	!!----------------------------------------------------------------------
[5656]	1292	!! * ROUTINE interpub2b *
[1605]	1293	!!----------------------------------------------------------------------
[6404]	1294	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1295	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1296	LOGICAL , INTENT(in ) :: before
	1297	INTEGER , INTENT(in ) :: nb , ndir
	1298	!
	1299	INTEGER :: ji,jj
	1300	REAL(wp) :: zrhot, zt0, zt1,zat
	1301	LOGICAL :: western_side, eastern_side,northern_side,southern_side
[1605]	1302	!!----------------------------------------------------------------------
[5656]	1303	IF( before ) THEN
[6404]	1304	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
[5656]	1305	ELSE
	1306	western_side = (nb == 1).AND.(ndir == 1)
	1307	eastern_side = (nb == 1).AND.(ndir == 2)
	1308	southern_side = (nb == 2).AND.(ndir == 1)
	1309	northern_side = (nb == 2).AND.(ndir == 2)
	1310	zrhot = Agrif_rhot()
	1311	! Time indexes bounds for integration
	1312	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
	1313	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
	1314	! Polynomial interpolation coefficients:
[6404]	1315	zat = zrhot * ( zt1*2._wp (-2._wp*zt1 + 3._wp) &
	1316	& - zt0*2._wp (-2._wp*zt0 + 3._wp) )
[5656]	1317	!
	1318	IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i1,j1:j2)
	1319	IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2)
	1320	IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j1)
	1321	IF(northern_side) ubdy_n(i1:i2) = zat * ptab(i1:i2,j1)
	1322	ENDIF
	1323	!
	1324	END SUBROUTINE interpub2b
[6404]	1325
[636]	1326
[6404]	1327	SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before, nb, ndir )
[4292]	1328	!!----------------------------------------------------------------------
[5656]	1329	!! * ROUTINE interpvb2b *
[4292]	1330	!!----------------------------------------------------------------------
[6404]	1331	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1332	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1333	LOGICAL , INTENT(in ) :: before
	1334	INTEGER , INTENT(in ) :: nb , ndir
	1335	!
	1336	INTEGER :: ji,jj
	1337	REAL(wp) :: zrhot, zt0, zt1,zat
	1338	LOGICAL :: western_side, eastern_side,northern_side,southern_side
[4292]	1339	!!----------------------------------------------------------------------
[5656]	1340	!
	1341	IF( before ) THEN
[6404]	1342	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
[5656]	1343	ELSE
	1344	western_side = (nb == 1).AND.(ndir == 1)
	1345	eastern_side = (nb == 1).AND.(ndir == 2)
	1346	southern_side = (nb == 2).AND.(ndir == 1)
	1347	northern_side = (nb == 2).AND.(ndir == 2)
	1348	zrhot = Agrif_rhot()
	1349	! Time indexes bounds for integration
	1350	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
	1351	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
	1352	! Polynomial interpolation coefficients:
[6404]	1353	zat = zrhot * ( zt1*2._wp (-2._wp*zt1 + 3._wp) &
	1354	& - zt0*2._wp (-2._wp*zt0 + 3._wp) )
[5656]	1355	!
[6404]	1356	IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2)
	1357	IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2)
	1358	IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j1)
	1359	IF(northern_side) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1)
[5656]	1360	ENDIF
	1361	!
	1362	END SUBROUTINE interpvb2b
[4292]	1363
[6404]	1364
	1365	SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
[5656]	1366	!!----------------------------------------------------------------------
	1367	!! * ROUTINE interpe3t *
	1368	!!----------------------------------------------------------------------
[6404]	1369	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
[5656]	1370	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
[6404]	1371	LOGICAL , INTENT(in ) :: before
	1372	INTEGER , INTENT(in ) :: nb , ndir
[5656]	1373	!
	1374	INTEGER :: ji, jj, jk
	1375	LOGICAL :: western_side, eastern_side, northern_side, southern_side
	1376	REAL(wp) :: ztmpmsk
	1377	!!----------------------------------------------------------------------
	1378	!
[6404]	1379	IF( before ) THEN
	1380	ptab(i1:i2,j1:j2,k1:k2) = tmask(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2)
[5656]	1381	ELSE
	1382	western_side = (nb == 1).AND.(ndir == 1)
	1383	eastern_side = (nb == 1).AND.(ndir == 2)
	1384	southern_side = (nb == 2).AND.(ndir == 1)
	1385	northern_side = (nb == 2).AND.(ndir == 2)
[4292]	1386
[6404]	1387	DO jk = k1, k2
	1388	DO jj = j1, j2
	1389	DO ji = i1, i2
[5656]	1390	! Get velocity mask at boundary edge points:
[6404]	1391	IF( western_side ) ztmpmsk = umask(ji ,jj ,1)
	1392	IF( eastern_side ) ztmpmsk = umask(nlci-2,jj ,1)
	1393	IF( northern_side) ztmpmsk = vmask(ji ,nlcj-2,1)
	1394	IF( southern_side) ztmpmsk = vmask(ji ,2 ,1)
	1395	!
	1396	IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) )*ztmpmsk > 1.D-2) THEN
[5656]	1397	IF (western_side) THEN
	1398	WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
	1399	ELSEIF (eastern_side) THEN
	1400	WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
	1401	ELSEIF (southern_side) THEN
	1402	WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk
	1403	ELSEIF (northern_side) THEN
	1404	WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk
	1405	ENDIF
[6404]	1406	WRITE(numout,*) ' ptab(ji,jj,jk), e3t(ji,jj,jk) ', ptab(ji,jj,jk), e3t_0(ji,jj,jk)
[5656]	1407	kindic_agr = kindic_agr + 1
	1408	ENDIF
	1409	END DO
	1410	END DO
	1411	END DO
[6404]	1412	!
[5656]	1413	ENDIF
	1414	!
	1415	END SUBROUTINE interpe3t
	1416
[6404]	1417
	1418	SUBROUTINE interpumsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
[4292]	1419	!!----------------------------------------------------------------------
[5656]	1420	!! * ROUTINE interpumsk *
[4292]	1421	!!----------------------------------------------------------------------
[6404]	1422	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
	1423	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
	1424	LOGICAL , INTENT(in ) :: before
	1425	INTEGER , INTENT(in ) :: nb , ndir
[5656]	1426	!
[6404]	1427	INTEGER :: ji, jj, jk
	1428	LOGICAL :: western_side, eastern_side
[4292]	1429	!!----------------------------------------------------------------------
[5656]	1430	!
[6404]	1431	IF( before ) THEN
	1432	ptab(i1:i2,j1:j2,k1:k2) = umask(i1:i2,j1:j2,k1:k2)
[5656]	1433	ELSE
[6404]	1434	western_side = (nb == 1).AND.(ndir == 1)
	1435	eastern_side = (nb == 1).AND.(ndir == 2)
	1436	DO jk = k1, k2
	1437	DO jj = j1, j2
	1438	DO ji = i1, i2
[5656]	1439	! Velocity mask at boundary edge points:
	1440	IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN
	1441	IF (western_side) THEN
	1442	WRITE(numout,*) 'ERROR with umask at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
	1443	WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk)
	1444	kindic_agr = kindic_agr + 1
	1445	ELSEIF (eastern_side) THEN
	1446	WRITE(numout,*) 'ERROR with umask at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
	1447	WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk)
	1448	kindic_agr = kindic_agr + 1
	1449	ENDIF
	1450	ENDIF
	1451	END DO
	1452	END DO
[4292]	1453	END DO
[6404]	1454	!
[5656]	1455	ENDIF
	1456	!
	1457	END SUBROUTINE interpumsk
[4292]	1458
[6404]	1459
	1460	SUBROUTINE interpvmsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
[4486]	1461	!!----------------------------------------------------------------------
[5656]	1462	!! * ROUTINE interpvmsk *
[4486]	1463	!!----------------------------------------------------------------------
[6404]	1464	INTEGER , INTENT(in ) :: i1,i2,j1,j2,k1,k2
	1465	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
	1466	LOGICAL , INTENT(in ) :: before
	1467	INTEGER , INTENT(in ) :: nb , ndir
[5656]	1468	!
[6404]	1469	INTEGER :: ji, jj, jk
	1470	LOGICAL :: northern_side, southern_side
[4486]	1471	!!----------------------------------------------------------------------
[5656]	1472	!
[6404]	1473	IF( before ) THEN
	1474	ptab(i1:i2,j1:j2,k1:k2) = vmask(i1:i2,j1:j2,k1:k2)
[5656]	1475	ELSE
	1476	southern_side = (nb == 2).AND.(ndir == 1)
	1477	northern_side = (nb == 2).AND.(ndir == 2)
[6404]	1478	DO jk = k1, k2
	1479	DO jj = j1, j2
	1480	DO ji = i1, i2
[5656]	1481	! Velocity mask at boundary edge points:
	1482	IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN
	1483	IF (southern_side) THEN
	1484	WRITE(numout,*) 'ERROR with vmask at the southern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
	1485	WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk)
	1486	kindic_agr = kindic_agr + 1
	1487	ELSEIF (northern_side) THEN
	1488	WRITE(numout,*) 'ERROR with vmask at the northern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
	1489	WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk)
	1490	kindic_agr = kindic_agr + 1
	1491	ENDIF
	1492	ENDIF
	1493	END DO
	1494	END DO
[4486]	1495	END DO
[6404]	1496	!
[5656]	1497	ENDIF
	1498	!
	1499	END SUBROUTINE interpvmsk
[4486]	1500
[5656]	1501	# if defined key_zdftke
	1502
[6404]	1503	SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, before )
[4486]	1504	!!----------------------------------------------------------------------
[5656]	1505	!! * ROUTINE interavm *
[4486]	1506	!!----------------------------------------------------------------------
[6404]	1507	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
	1508	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
	1509	LOGICAL , INTENT(in ) :: before
[4486]	1510	!!----------------------------------------------------------------------
[5656]	1511	!
[6404]	1512	IF( before ) THEN
[5656]	1513	ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2)
	1514	ELSE
	1515	avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)
	1516	ENDIF
	1517	!
	1518	END SUBROUTINE interpavm
[4486]	1519
[5656]	1520	# endif /* key_zdftke */
[4486]	1521
[390]	1522	#else
[1605]	1523	!!----------------------------------------------------------------------
	1524	!! Empty module no AGRIF zoom
	1525	!!----------------------------------------------------------------------
[636]	1526	CONTAINS
	1527	SUBROUTINE Agrif_OPA_Interp_empty
	1528	WRITE(,) 'agrif_opa_interp : You should not have seen this print! error?'
	1529	END SUBROUTINE Agrif_OPA_Interp_empty
[390]	1530	#endif
[1605]	1531
	1532	!!======================================================================
[636]	1533	END MODULE agrif_opa_interp

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

Download in other formats: