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_oce_interp.F90 in NEMO/branches/2019/dev_r10973_AGRIF-01_jchanut_small_jpi_jpj/src/NST – NEMO

Context Navigation

source: NEMO/branches/2019/dev_r10973_AGRIF-01_jchanut_small_jpi_jpj/src/NST/agrif_oce_interp.F90 @ 11205

Last change on this file since 11205 was 11205, checked in by jchanut, 5 years ago
#2199 1) Make sponge independent of sub-domain size. Partially masked open boundary segments are not taken into account anymore. To do so, sponge coefficients should be read in a file for realistic applications (then nesting tools need to be modified accordingly). 2) Replace East-West-North-South barotropic data arrays by a global 2d array. Then apply barotropic open boundary conditions thanks to mi0/mi1, mj0/mj1 indexes. 3) Call AGRIF bdy update one more time in dynspg_ts during extrapolation phase. This removes a dozen lines of code in dynspg_ts routine.
Property svn:keywords set to `Id`
File size: 55.0 KB

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

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

Download in other formats: