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/trunk/src/NST – NEMO

Context Navigation

source: NEMO/trunk/src/NST/agrif_oce_interp.F90 @ 14555

Last change on this file since 14555 was 14433, checked in by smasson, 3 years ago
trunk: merge dev_r14312_MPI_Interface into the trunk, #2598
Property svn:keywords set to `Id`
File size: 72.4 KB

Rev	Line
[9570]	1	MODULE agrif_oce_interp
[1605]	2	!!======================================================================
[9570]	3	!! * MODULE agrif_oce_interp *
[14227]	4	!! AGRIF: interpolation package for the ocean dynamics (OCE)
[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
[14053]	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
[12377]	35	USE vremap
[13216]	36	USE lbclnk
[5656]	37
[636]	38	IMPLICIT NONE
	39	PRIVATE
[4292]	40
[12377]	41	PUBLIC Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_dyn_ts_flux, Agrif_ssh_ts, Agrif_dta_ts
[9057]	42	PUBLIC Agrif_tra, Agrif_avm
[9019]	43	PUBLIC interpun , interpvn
[9057]	44	PUBLIC interptsn, interpsshn, interpavm
[9019]	45	PUBLIC interpunb, interpvnb , interpub2b, interpvb2b
[13286]	46	PUBLIC interpe3t, interpglamt, interpgphit
[14086]	47	PUBLIC interpht0, interpmbkt, interpe3t0_vremap
	48	PUBLIC agrif_istate_oce, agrif_istate_ssh ! called by icestate.F90 and domvvl.F90
	49	PUBLIC agrif_check_bat
[13216]	50
[6140]	51	INTEGER :: bdy_tinterp = 0
	52
[14053]	53	!! * Substitutions
	54	# include "domzgr_substitute.h90"
[9598]	55	!! NEMO/NST 4.0 , NEMO Consortium (2018)
[1156]	56	!! $Id$
[10068]	57	!! Software governed by the CeCILL license (see ./LICENSE)
[1156]	58	!!----------------------------------------------------------------------
[5656]	59	CONTAINS
	60
[14086]	61	SUBROUTINE Agrif_istate_oce( Kbb, Kmm, Kaa )
	62	!!----------------------------------------------------------------------
	63	!! * ROUTINE agrif_istate_oce *
	64	!!
	65	!! set initial t, s, u, v, ssh from parent
	66	!!----------------------------------------------------------------------
	67	!
	68	IMPLICIT NONE
	69	!
	70	INTEGER, INTENT(in) :: Kbb, Kmm, Kaa
	71	INTEGER :: jn
	72	!!----------------------------------------------------------------------
	73	IF(lwp) WRITE(numout,*) ' '
	74	IF(lwp) WRITE(numout,*) 'Agrif_istate_oce : interp child initial state from parent'
	75	IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~'
	76	IF(lwp) WRITE(numout,*) ' '
	77
	78	IF ( .NOT.Agrif_Parent(l_1st_euler) ) &
	79	& CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent')
	80
	81	l_ini_child = .TRUE.
	82	Agrif_SpecialValue = 0.0_wp
	83	Agrif_UseSpecialValue = .TRUE.
	84
[14170]	85	ts(:,:,:,:,Kbb) = 0.0_wp
	86	uu(:,:,:,Kbb) = 0.0_wp
	87	vv(:,:,:,Kbb) = 0.0_wp
[14086]	88
	89	Krhs_a = Kbb ; Kmm_a = Kbb
	90
	91	CALL Agrif_Init_Variable(tsini_id, procname=interptsn)
	92
	93	Agrif_UseSpecialValue = ln_spc_dyn
	94	use_sign_north = .TRUE.
	95	sign_north = -1._wp
	96	CALL Agrif_Init_Variable(uini_id , procname=interpun )
	97	CALL Agrif_Init_Variable(vini_id , procname=interpvn )
	98	use_sign_north = .FALSE.
	99
	100	Agrif_UseSpecialValue = .FALSE.
	101	l_ini_child = .FALSE.
	102
	103	Krhs_a = Kaa ; Kmm_a = Kmm
	104
	105	DO jn = 1, jpts
	106	ts(:,:,:,jn,Kbb) = ts(:,:,:,jn,Kbb) * tmask(:,:,:)
	107	END DO
	108	uu(:,:,:,Kbb) = uu(:,:,:,Kbb) * umask(:,:,:)
	109	vv(:,:,:,Kbb) = vv(:,:,:,Kbb) * vmask(:,:,:)
	110
[14433]	111	CALL lbc_lnk( 'agrif_istate_oce', uu(:,:,: ,Kbb), 'U', -1.0_wp , vv(:,:,:,Kbb), 'V', -1.0_wp )
[14086]	112	CALL lbc_lnk( 'agrif_istate_oce', ts(:,:,:,:,Kbb), 'T', 1.0_wp )
	113
	114	END SUBROUTINE Agrif_istate_oce
	115
	116
[14170]	117	SUBROUTINE Agrif_istate_ssh( Kbb, Kmm, Kaa )
[14086]	118	!!----------------------------------------------------------------------
	119	!! * ROUTINE agrif_istate_ssh *
	120	!!
	121	!! set initial ssh from parent
	122	!!----------------------------------------------------------------------
	123	!
	124	IMPLICIT NONE
	125	!
[14170]	126	INTEGER, INTENT(in) :: Kbb, Kmm, Kaa
[14086]	127	!!----------------------------------------------------------------------
	128	IF(lwp) WRITE(numout,*) ' '
	129	IF(lwp) WRITE(numout,*) 'Agrif_istate_ssh : interp child ssh from parent'
	130	IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~'
	131	IF(lwp) WRITE(numout,*) ' '
	132
	133	IF ( .NOT.Agrif_Parent(l_1st_euler) ) &
	134	& CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent')
	135
[14170]	136	Krhs_a = Kbb ; Kmm_a = Kbb
	137	!
[14086]	138	Agrif_SpecialValue = 0._wp
	139	Agrif_UseSpecialValue = .TRUE.
	140	l_ini_child = .TRUE.
	141	!
[14170]	142	ssh(:,:,Kbb) = 0._wp
[14086]	143	CALL Agrif_Init_Variable(sshini_id, procname=interpsshn)
	144	!
	145	Agrif_UseSpecialValue = .FALSE.
	146	l_ini_child = .FALSE.
[14170]	147	!
	148	Krhs_a = Kaa ; Kmm_a = Kmm
	149	!
	150	CALL lbc_lnk( 'Agrif_istate_ssh', ssh(:,:,Kbb), 'T', 1._wp )
	151	!
	152	ssh(:,:,Kmm) = ssh(:,:,Kbb)
	153	ssh(:,:,Kaa) = 0._wp
[14086]	154
	155	END SUBROUTINE Agrif_istate_ssh
	156
	157
[782]	158	SUBROUTINE Agrif_tra
[1605]	159	!!----------------------------------------------------------------------
[5656]	160	!! * ROUTINE Agrif_tra *
[1605]	161	!!----------------------------------------------------------------------
[636]	162	!
[1605]	163	IF( Agrif_Root() ) RETURN
[6140]	164	!
	165	Agrif_SpecialValue = 0._wp
[636]	166	Agrif_UseSpecialValue = .TRUE.
[14086]	167	l_vremap = ln_vert_remap
[6140]	168	!
[14086]	169	CALL Agrif_Bc_variable( ts_interp_id, procname=interptsn )
[6140]	170	!
[636]	171	Agrif_UseSpecialValue = .FALSE.
[14086]	172	l_vremap = .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
[6140]	182	!
	183	INTEGER :: ji, jj, jk ! dummy loop indices
[9057]	184	INTEGER :: ibdy1, jbdy1, ibdy2, jbdy2
[9019]	185	REAL(wp), DIMENSION(jpi,jpj) :: zub, zvb
[1605]	186	!!----------------------------------------------------------------------
[6140]	187	!
[1605]	188	IF( Agrif_Root() ) RETURN
[6140]	189	!
[13286]	190	Agrif_SpecialValue = 0.0_wp
[5656]	191	Agrif_UseSpecialValue = ln_spc_dyn
[14086]	192	l_vremap = ln_vert_remap
[6140]	193	!
[13216]	194	use_sign_north = .TRUE.
[13286]	195	sign_north = -1.0_wp
[6140]	196	CALL Agrif_Bc_variable( un_interp_id, procname=interpun )
	197	CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn )
[14086]	198
	199	IF( .NOT.ln_dynspg_ts ) THEN ! Get transports
[14170]	200	ubdy(:,:) = 0._wp ; vbdy(:,:) = 0._wp
	201	utint_stage(:,:) = 0 ; vtint_stage(:,:) = 0
[14086]	202	CALL Agrif_Bc_variable( unb_interp_id, procname=interpunb )
	203	CALL Agrif_Bc_variable( vnb_interp_id, procname=interpvnb )
	204	ENDIF
	205
[13216]	206	use_sign_north = .FALSE.
[6140]	207	!
[5656]	208	Agrif_UseSpecialValue = .FALSE.
[14086]	209	l_vremap = .FALSE.
[6140]	210	!
[14086]	211	! Ensure below that vertically integrated transports match
	212	! either transports out of time splitting procedure (ln_dynspg_ts=.TRUE.)
	213	! or parent grid transports (ln_dynspg_ts=.FALSE.)
	214	!
[12377]	215	! --- West --- !
[13216]	216	IF( lk_west ) THEN
[13286]	217	ibdy1 = nn_hls + 2 ! halo + land + 1
[14086]	218	ibdy2 = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells
[13216]	219	!
	220	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
	221	DO ji = mi0(ibdy1), mi1(ibdy2)
[6140]	222	DO jj = 1, jpj
[14086]	223	uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
	224	vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
[5930]	225	END DO
[636]	226	END DO
[13216]	227	ENDIF
	228	!
[12377]	229	DO ji = mi0(ibdy1), mi1(ibdy2)
[14086]	230	zub(ji,:) = 0._wp
[9019]	231	DO jk = 1, jpkm1
	232	DO jj = 1, jpj
[13286]	233	zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
[9019]	234	END DO
[636]	235	END DO
[13216]	236	DO jj=1,jpj
	237	zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
[13286]	238	END DO
[6140]	239	DO jk = 1, jpkm1
	240	DO jj = 1, jpj
[13286]	241	uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
[5930]	242	END DO
	243	END DO
[12377]	244	END DO
[13286]	245	!
[14086]	246	DO ji = mi0(ibdy1), mi1(ibdy2)
	247	zvb(ji,:) = 0._wp
	248	DO jk = 1, jpkm1
	249	DO jj = 1, jpj
	250	zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
[13216]	251	END DO
[14086]	252	END DO
	253	DO jj = 1, jpj
	254	zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
	255	END DO
	256	DO jk = 1, jpkm1
[13216]	257	DO jj = 1, jpj
[14086]	258	vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) )*vmask(ji,jj,jk)
[13216]	259	END DO
	260	END DO
[14086]	261	END DO
[13286]	262	!
[636]	263	ENDIF
[390]	264
[9019]	265	! --- East --- !
[13216]	266	IF( lk_east) THEN
[14086]	267	ibdy1 = jpiglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhox()
	268	ibdy2 = jpiglo - ( nn_hls + 2 )
[13216]	269	!
[14086]	270	IF( .NOT.ln_dynspg_ts ) THEN
[13216]	271	DO ji = mi0(ibdy1), mi1(ibdy2)
[9057]	272	DO jj = 1, jpj
[14086]	273	uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
[5930]	274	END DO
[636]	275	END DO
[13216]	276	ENDIF
	277	!
[12377]	278	DO ji = mi0(ibdy1), mi1(ibdy2)
[14086]	279	zub(ji,:) = 0._wp
[6140]	280	DO jk = 1, jpkm1
	281	DO jj = 1, jpj
[13286]	282	zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
[5930]	283	END DO
	284	END DO
[13216]	285	DO jj=1,jpj
	286	zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
[4486]	287	END DO
[6140]	288	DO jk = 1, jpkm1
	289	DO jj = 1, jpj
[13286]	290	uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
[5930]	291	END DO
	292	END DO
[12377]	293	END DO
[13286]	294	!
[14086]	295	ibdy1 = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox()
[14170]	296	ibdy2 = jpiglo - ( nn_hls + 1 )
	297	!
[14086]	298	IF( .NOT.ln_dynspg_ts ) THEN
[13216]	299	DO ji = mi0(ibdy1), mi1(ibdy2)
	300	DO jj = 1, jpj
[14086]	301	vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
[13216]	302	END DO
[14086]	303	END DO
	304	ENDIF
[14170]	305	!
[14086]	306	DO ji = mi0(ibdy1), mi1(ibdy2)
	307	zvb(ji,:) = 0._wp
	308	DO jk = 1, jpkm1
	309	DO jj = 1, jpj
	310	zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
	311	END DO
	312	END DO
	313	DO jj = 1, jpj
	314	zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
	315	END DO
	316	DO jk = 1, jpkm1
	317	DO jj = 1, jpj
[13286]	318	vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk)
[13216]	319	END DO
	320	END DO
[14086]	321	END DO
[13286]	322	!
[636]	323	ENDIF
[390]	324
[9019]	325	! --- South --- !
[13216]	326	IF( lk_south ) THEN
[14086]	327	jbdy1 = nn_hls + 2
	328	jbdy2 = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhoy()
[13216]	329	!
[14086]	330	IF( .NOT.ln_dynspg_ts ) THEN
[13216]	331	DO jj = mj0(jbdy1), mj1(jbdy2)
[14170]	332	DO ji = 1, jpi
	333	uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
	334	vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
[13216]	335	END DO
	336	END DO
	337	ENDIF
	338	!
[12377]	339	DO jj = mj0(jbdy1), mj1(jbdy2)
[14086]	340	zvb(:,jj) = 0._wp
[13216]	341	DO jk=1,jpkm1
	342	DO ji=1,jpi
[13286]	343	zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
[5930]	344	END DO
[636]	345	END DO
[13216]	346	DO ji = 1, jpi
	347	zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
[636]	348	END DO
[6140]	349	DO jk = 1, jpkm1
	350	DO ji = 1, jpi
[13286]	351	vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk)
[5930]	352	END DO
	353	END DO
[13216]	354	END DO
[13286]	355	!
[14086]	356	DO jj = mj0(jbdy1), mj1(jbdy2)
	357	zub(:,jj) = 0._wp
	358	DO jk = 1, jpkm1
	359	DO ji = 1, jpi
	360	zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
[13216]	361	END DO
[14086]	362	END DO
	363	DO ji = 1, jpi
	364	zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
	365	END DO
	366	DO jk = 1, jpkm1
[6140]	367	DO ji = 1, jpi
[14086]	368	uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
[5930]	369	END DO
[9057]	370	END DO
[14086]	371	END DO
[13286]	372	!
[636]	373	ENDIF
[390]	374
[9019]	375	! --- North --- !
[13216]	376	IF( lk_north ) THEN
[14086]	377	jbdy1 = jpjglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhoy()
	378	jbdy2 = jpjglo - ( nn_hls + 2 )
[13216]	379	!
[14086]	380	IF( .NOT.ln_dynspg_ts ) THEN
[13216]	381	DO jj = mj0(jbdy1), mj1(jbdy2)
[14170]	382	DO ji = 1, jpi
[14086]	383	vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
[13216]	384	END DO
	385	END DO
	386	ENDIF
	387	!
[12377]	388	DO jj = mj0(jbdy1), mj1(jbdy2)
[14086]	389	zvb(:,jj) = 0._wp
[13216]	390	DO jk=1,jpkm1
	391	DO ji=1,jpi
[13286]	392	zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
[5930]	393	END DO
[636]	394	END DO
[13216]	395	DO ji = 1, jpi
	396	zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
[636]	397	END DO
[9057]	398	DO jk = 1, jpkm1
	399	DO ji = 1, jpi
[13286]	400	vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk)
[9057]	401	END DO
	402	END DO
[13216]	403	END DO
[13286]	404	!
[14086]	405	jbdy1 = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy()
	406	jbdy2 = jpjglo - ( nn_hls + 1 )
[14170]	407	!
[14086]	408	IF( .NOT.ln_dynspg_ts ) THEN
[13216]	409	DO jj = mj0(jbdy1), mj1(jbdy2)
[14170]	410	DO ji = 1, jpi
[14086]	411	uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
	412	END DO
	413	END DO
	414	ENDIF
[14170]	415	!
[14086]	416	DO jj = mj0(jbdy1), mj1(jbdy2)
	417	zub(:,jj) = 0._wp
	418	DO jk = 1, jpkm1
[6140]	419	DO ji = 1, jpi
[14086]	420	zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
[5930]	421	END DO
[14086]	422	END DO
	423	DO ji = 1, jpi
	424	zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
	425	END DO
	426	DO jk = 1, jpkm1
	427	DO ji = 1, jpi
[13286]	428	uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
[13216]	429	END DO
[5930]	430	END DO
[14086]	431	END DO
[13286]	432	!
[636]	433	ENDIF
[2715]	434	!
[636]	435	END SUBROUTINE Agrif_dyn
[390]	436
[6140]	437
[4486]	438	SUBROUTINE Agrif_dyn_ts( jn )
[4292]	439	!!----------------------------------------------------------------------
	440	!! * ROUTINE Agrif_dyn_ts *
	441	!!----------------------------------------------------------------------
[4486]	442	INTEGER, INTENT(in) :: jn
[4292]	443	!!
	444	INTEGER :: ji, jj
[12377]	445	INTEGER :: istart, iend, jstart, jend
[4486]	446	!!----------------------------------------------------------------------
[6140]	447	!
[4486]	448	IF( Agrif_Root() ) RETURN
[9057]	449	!
[12377]	450	!--- West ---!
[13216]	451	IF( lk_west ) THEN
[13286]	452	istart = nn_hls + 2 ! halo + land + 1
[14086]	453	iend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells
[13216]	454	DO ji = mi0(istart), mi1(iend)
	455	DO jj=1,jpj
	456	va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
	457	ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
	458	END DO
[4486]	459	END DO
[13216]	460	ENDIF
[6140]	461	!
[12377]	462	!--- East ---!
[13216]	463	IF( lk_east ) THEN
[14086]	464	istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox()
	465	iend = jpiglo - ( nn_hls + 1 )
[13216]	466	DO ji = mi0(istart), mi1(iend)
	467
	468	DO jj=1,jpj
	469	va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
	470	END DO
[4486]	471	END DO
[14086]	472	istart = jpiglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhox()
	473	iend = jpiglo - ( nn_hls + 2 )
[13216]	474	DO ji = mi0(istart), mi1(iend)
	475	DO jj=1,jpj
	476	ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
	477	END DO
[12377]	478	END DO
[13216]	479	ENDIF
[6140]	480	!
[12377]	481	!--- South ---!
[13216]	482	IF( lk_south ) THEN
[14086]	483	jstart = nn_hls + 2
	484	jend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhoy()
[13216]	485	DO jj = mj0(jstart), mj1(jend)
	486
	487	DO ji=1,jpi
	488	ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
	489	va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
	490	END DO
[4486]	491	END DO
[13216]	492	ENDIF
[6140]	493	!
[12377]	494	!--- North ---!
[13216]	495	IF( lk_north ) THEN
[14086]	496	jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy()
	497	jend = jpjglo - ( nn_hls + 1 )
[13216]	498	DO jj = mj0(jstart), mj1(jend)
	499	DO ji=1,jpi
	500	ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
	501	END DO
[4486]	502	END DO
[14086]	503	jstart = jpjglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhoy()
	504	jend = jpjglo - ( nn_hls + 2 )
[13216]	505	DO jj = mj0(jstart), mj1(jend)
	506	DO ji=1,jpi
	507	va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
	508	END DO
[12377]	509	END DO
[13216]	510	ENDIF
[4486]	511	!
	512	END SUBROUTINE Agrif_dyn_ts
	513
[13286]	514
[12377]	515	SUBROUTINE Agrif_dyn_ts_flux( jn, zu, zv )
	516	!!----------------------------------------------------------------------
	517	!! * ROUTINE Agrif_dyn_ts_flux *
	518	!!----------------------------------------------------------------------
	519	INTEGER, INTENT(in) :: jn
	520	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zu, zv
	521	!!
	522	INTEGER :: ji, jj
	523	INTEGER :: istart, iend, jstart, jend
	524	!!----------------------------------------------------------------------
	525	!
	526	IF( Agrif_Root() ) RETURN
	527	!
	528	!--- West ---!
[13216]	529	IF( lk_west ) THEN
[14086]	530	istart = nn_hls + 2
	531	iend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhox()
[13216]	532	DO ji = mi0(istart), mi1(iend)
	533	DO jj=1,jpj
	534	zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
	535	zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
	536	END DO
[12377]	537	END DO
[13216]	538	ENDIF
[12377]	539	!
	540	!--- East ---!
[13216]	541	IF( lk_east ) THEN
[14086]	542	istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox()
	543	iend = jpiglo - ( nn_hls + 1 )
[13216]	544	DO ji = mi0(istart), mi1(iend)
	545	DO jj=1,jpj
	546	zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
	547	END DO
[12377]	548	END DO
[14086]	549	istart = jpiglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhox()
	550	iend = jpiglo - ( nn_hls + 2 )
[13216]	551	DO ji = mi0(istart), mi1(iend)
	552	DO jj=1,jpj
	553	zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
	554	END DO
[12377]	555	END DO
[13216]	556	ENDIF
[12377]	557	!
	558	!--- South ---!
[13216]	559	IF( lk_south ) THEN
[14086]	560	jstart = nn_hls + 2
	561	jend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhoy()
[13216]	562	DO jj = mj0(jstart), mj1(jend)
	563	DO ji=1,jpi
	564	zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
	565	zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
	566	END DO
[12377]	567	END DO
[13216]	568	ENDIF
[12377]	569	!
	570	!--- North ---!
[13216]	571	IF( lk_north ) THEN
[14086]	572	jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy()
	573	jend = jpjglo - ( nn_hls + 1 )
[13216]	574	DO jj = mj0(jstart), mj1(jend)
	575	DO ji=1,jpi
	576	zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
	577	END DO
[12377]	578	END DO
[14086]	579	jstart = jpjglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhoy()
	580	jend = jpjglo - ( nn_hls + 2 )
[13216]	581	DO jj = mj0(jstart), mj1(jend)
	582	DO ji=1,jpi
	583	zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
	584	END DO
[12377]	585	END DO
[13216]	586	ENDIF
[12377]	587	!
	588	END SUBROUTINE Agrif_dyn_ts_flux
[6140]	589
[13286]	590
[4486]	591	SUBROUTINE Agrif_dta_ts( kt )
	592	!!----------------------------------------------------------------------
	593	!! * ROUTINE Agrif_dta_ts *
	594	!!----------------------------------------------------------------------
	595	INTEGER, INTENT(in) :: kt
	596	!!
	597	LOGICAL :: ll_int_cons
[4292]	598	!!----------------------------------------------------------------------
[6140]	599	!
[4292]	600	IF( Agrif_Root() ) RETURN
[6140]	601	!
	602	ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only
	603	!
[9031]	604	! Enforce volume conservation if no time refinement:
	605	IF ( Agrif_rhot()==1 ) ll_int_cons=.TRUE.
[6140]	606	!
[4486]	607	! Interpolate barotropic fluxes
[12377]	608	Agrif_SpecialValue = 0._wp
[4486]	609	Agrif_UseSpecialValue = ln_spc_dyn
[13216]	610
	611	use_sign_north = .TRUE.
	612	sign_north = -1.
	613
[6140]	614	!
[12377]	615	! Set bdy time interpolation stage to 0 (latter incremented locally do deal with corners)
	616	utint_stage(:,:) = 0
	617	vtint_stage(:,:) = 0
	618	!
[6140]	619	IF( ll_int_cons ) THEN ! Conservative interpolation
[14086]	620	IF ( lk_tint2d_notinterp ) THEN
[14122]	621	Agrif_UseSpecialValue = .FALSE.
[14086]	622	CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b_const )
	623	CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b_const )
	624	! Divergence conserving correction terms:
[14122]	625	IF ( Agrif_Rhox()>1 ) CALL Agrif_Bc_variable( ub2b_cor_id, calledweight=1._wp, procname=ub2b_cor )
	626	IF ( Agrif_Rhoy()>1 ) CALL Agrif_Bc_variable( vb2b_cor_id, calledweight=1._wp, procname=vb2b_cor )
[14086]	627	ELSE
	628	! order matters here !!!!!!
	629	CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated
	630	CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b )
	631	!
	632	bdy_tinterp = 1
	633	CALL Agrif_Bc_variable( unb_interp_id , calledweight=1._wp, procname=interpunb ) ! After
	634	CALL Agrif_Bc_variable( vnb_interp_id , calledweight=1._wp, procname=interpvnb )
	635	!
	636	bdy_tinterp = 2
	637	CALL Agrif_Bc_variable( unb_interp_id , calledweight=0._wp, procname=interpunb ) ! Before
	638	CALL Agrif_Bc_variable( vnb_interp_id , calledweight=0._wp, procname=interpvnb )
	639	ENDIF
[4486]	640	ELSE ! Linear interpolation
[12377]	641	!
	642	ubdy(:,:) = 0._wp ; vbdy(:,:) = 0._wp
[14086]	643	CALL Agrif_Bc_variable( unb_interp_id, procname=interpunb )
	644	CALL Agrif_Bc_variable( vnb_interp_id, procname=interpvnb )
[4486]	645	ENDIF
	646	Agrif_UseSpecialValue = .FALSE.
[13216]	647	use_sign_north = .FALSE.
[5656]	648	!
[4486]	649	END SUBROUTINE Agrif_dta_ts
	650
[6140]	651
[2486]	652	SUBROUTINE Agrif_ssh( kt )
	653	!!----------------------------------------------------------------------
[9031]	654	!! * ROUTINE Agrif_ssh *
[2486]	655	!!----------------------------------------------------------------------
	656	INTEGER, INTENT(in) :: kt
[9019]	657	!
[12377]	658	INTEGER :: ji, jj
	659	INTEGER :: istart, iend, jstart, jend
[2486]	660	!!----------------------------------------------------------------------
[6140]	661	!
[2486]	662	IF( Agrif_Root() ) RETURN
[9031]	663	!
[9116]	664	! Linear time interpolation of sea level
[9031]	665	!
	666	Agrif_SpecialValue = 0._wp
	667	Agrif_UseSpecialValue = .TRUE.
	668	CALL Agrif_Bc_variable(sshn_id, procname=interpsshn )
	669	Agrif_UseSpecialValue = .FALSE.
	670	!
[9116]	671	! --- West --- !
[13216]	672	IF(lk_west) THEN
[14086]	673	istart = nn_hls + 2 ! halo + land + 1
	674	iend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells
[13216]	675	DO ji = mi0(istart), mi1(iend)
	676	DO jj = 1, jpj
	677	ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
[13286]	678	END DO
	679	END DO
[13216]	680	ENDIF
[6140]	681	!
[9019]	682	! --- East --- !
[13216]	683	IF(lk_east) THEN
[14086]	684	istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells - 1
	685	iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
[13216]	686	DO ji = mi0(istart), mi1(iend)
	687	DO jj = 1, jpj
	688	ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
[13286]	689	END DO
	690	END DO
[13216]	691	ENDIF
[6140]	692	!
[9019]	693	! --- South --- !
[13216]	694	IF(lk_south) THEN
[14086]	695	jstart = nn_hls + 2 ! halo + land + 1
	696	jend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells
[13216]	697	DO jj = mj0(jstart), mj1(jend)
	698	DO ji = 1, jpi
	699	ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
[13286]	700	END DO
	701	END DO
[13216]	702	ENDIF
[6140]	703	!
[9019]	704	! --- North --- !
[13216]	705	IF(lk_north) THEN
[14086]	706	jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells - 1
	707	jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
[13216]	708	DO jj = mj0(jstart), mj1(jend)
	709	DO ji = 1, jpi
	710	ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
[13286]	711	END DO
	712	END DO
[13216]	713	ENDIF
[6140]	714	!
[2486]	715	END SUBROUTINE Agrif_ssh
	716
[6140]	717
[4486]	718	SUBROUTINE Agrif_ssh_ts( jn )
[4292]	719	!!----------------------------------------------------------------------
	720	!! * ROUTINE Agrif_ssh_ts *
	721	!!----------------------------------------------------------------------
[4486]	722	INTEGER, INTENT(in) :: jn
[4292]	723	!!
[12377]	724	INTEGER :: ji, jj
	725	INTEGER :: istart, iend, jstart, jend
[4292]	726	!!----------------------------------------------------------------------
[9031]	727	!
	728	IF( Agrif_Root() ) RETURN
	729	!
[9116]	730	! --- West --- !
[13216]	731	IF(lk_west) THEN
[14086]	732	istart = nn_hls + 2 ! halo + land + 1
	733	iend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells
[13216]	734	DO ji = mi0(istart), mi1(iend)
	735	DO jj = 1, jpj
	736	ssha_e(ji,jj) = hbdy(ji,jj)
[13286]	737	END DO
	738	END DO
[13216]	739	ENDIF
[6140]	740	!
[9116]	741	! --- East --- !
[13216]	742	IF(lk_east) THEN
[14086]	743	istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells - 1
	744	iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
[13216]	745	DO ji = mi0(istart), mi1(iend)
	746	DO jj = 1, jpj
	747	ssha_e(ji,jj) = hbdy(ji,jj)
[13286]	748	END DO
	749	END DO
[13216]	750	ENDIF
[6140]	751	!
[9116]	752	! --- South --- !
[13216]	753	IF(lk_south) THEN
[14086]	754	jstart = nn_hls + 2 ! halo + land + 1
	755	jend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells
[13216]	756	DO jj = mj0(jstart), mj1(jend)
	757	DO ji = 1, jpi
	758	ssha_e(ji,jj) = hbdy(ji,jj)
[13286]	759	END DO
	760	END DO
[13216]	761	ENDIF
[6140]	762	!
[9116]	763	! --- North --- !
[13216]	764	IF(lk_north) THEN
[14086]	765	jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells - 1
	766	jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
[13216]	767	DO jj = mj0(jstart), mj1(jend)
	768	DO ji = 1, jpi
	769	ssha_e(ji,jj) = hbdy(ji,jj)
[13286]	770	END DO
	771	END DO
[13216]	772	ENDIF
[6140]	773	!
[4292]	774	END SUBROUTINE Agrif_ssh_ts
	775
[13286]	776
[9019]	777	SUBROUTINE Agrif_avm
[4292]	778	!!----------------------------------------------------------------------
[9019]	779	!! * ROUTINE Agrif_avm *
[5656]	780	!!----------------------------------------------------------------------
	781	REAL(wp) :: zalpha
[6140]	782	!!----------------------------------------------------------------------
[5656]	783	!
[9031]	784	IF( Agrif_Root() ) RETURN
[6140]	785	!
[9031]	786	zalpha = 1._wp ! JC: proper time interpolation impossible
	787	! => use last available value from parent
	788	!
	789	Agrif_SpecialValue = 0.e0
[5656]	790	Agrif_UseSpecialValue = .TRUE.
[14086]	791	l_vremap = ln_vert_remap
[6140]	792	!
[9019]	793	CALL Agrif_Bc_variable( avm_id, calledweight=zalpha, procname=interpavm )
[6140]	794	!
[5656]	795	Agrif_UseSpecialValue = .FALSE.
[14086]	796	l_vremap = .FALSE.
[5656]	797	!
[9019]	798	END SUBROUTINE Agrif_avm
[5656]	799
[13286]	800
[12377]	801	SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before )
[6140]	802	!!----------------------------------------------------------------------
	803	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab
	804	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2
	805	LOGICAL , INTENT(in ) :: before
[5656]	806	!
[12377]	807	INTEGER :: ji, jj, jk, jn ! dummy loop indices
	808	INTEGER :: N_in, N_out
[13216]	809	INTEGER :: item
[9031]	810	! vertical interpolation:
[14086]	811	REAL(wp) :: zhtot, zwgt
	812	REAL(wp), DIMENSION(k1:k2,1:jpts) :: tabin, tabin_i
	813	REAL(wp), DIMENSION(k1:k2) :: z_in, h_in_i, z_in_i
[13216]	814	REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
[12377]	815	!!----------------------------------------------------------------------
[9031]	816
[13216]	817	IF( before ) THEN
	818
	819	item = Kmm_a
	820	IF( l_ini_child ) Kmm_a = Kbb_a
	821
[9031]	822	DO jn = 1,jpts
	823	DO jk=k1,k2
	824	DO jj=j1,j2
	825	DO ji=i1,i2
[12377]	826	ptab(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a)
[9031]	827	END DO
	828	END DO
	829	END DO
[13216]	830	END DO
[9031]	831
[14086]	832	IF( l_vremap .OR. l_ini_child .OR. ln_zps ) THEN
	833
	834	! Fill cell depths (i.e. gdept) to be interpolated
[13216]	835	! Warning: these are masked, hence extrapolated prior interpolation.
[14086]	836	DO jj=j1,j2
	837	DO ji=i1,i2
	838	ptab(ji,jj,k1,jpts+1) = 0.5_wp * tmask(ji,jj,k1) * e3t(ji,jj,k1,Kmm_a)
	839	DO jk=k1+1,k2
	840	ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * &
	841	& ( ptab(ji,jj,jk-1,jpts+1) + 0.5_wp * (e3t(ji,jj,jk-1,Kmm_a)+e3t(ji,jj,jk,Kmm_a)) )
[13216]	842	END DO
	843	END DO
	844	END DO
[14086]	845
[13216]	846	! Save ssh at last level:
	847	IF (.NOT.ln_linssh) THEN
	848	ptab(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1)
	849	END IF
	850	ENDIF
	851	Kmm_a = item
	852
[9031]	853	ELSE
[13216]	854	item = Krhs_a
	855	IF( l_ini_child ) Krhs_a = Kbb_a
[9031]	856
[13216]	857	IF( l_vremap .OR. l_ini_child ) THEN
	858	IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp
	859	DO jj=j1,j2
	860	DO ji=i1,i2
[14086]	861	ts(ji,jj,:,:,Krhs_a) = 0.
	862	!
	863	! Build vertical grids:
[13216]	864	N_in = mbkt_parent(ji,jj)
[14218]	865	N_out = mbkt(ji,jj)
	866	IF (N_in*N_out > 0) THEN
	867	! Input grid (account for partial cells if any):
	868	DO jk=1,N_in
	869	z_in(jk) = ptab(ji,jj,jk,n2) - ptab(ji,jj,k2,n2)
	870	tabin(jk,1:jpts) = ptab(ji,jj,jk,1:jpts)
	871	END DO
[14086]	872
[14218]	873	! Intermediate grid:
	874	IF ( l_vremap ) THEN
	875	DO jk = 1, N_in
	876	h_in_i(jk) = e3t0_parent(ji,jj,jk) * &
	877	& (1._wp + ptab(ji,jj,k2,n2)/(ht0_parent(ji,jj)*ssmask(ji,jj) + 1._wp - ssmask(ji,jj)))
	878	END DO
	879	z_in_i(1) = 0.5_wp * h_in_i(1)
	880	DO jk=2,N_in
	881	z_in_i(jk) = z_in_i(jk-1) + 0.5_wp * ( h_in_i(jk) + h_in_i(jk-1) )
	882	END DO
	883	z_in_i(1:N_in) = z_in_i(1:N_in) - ptab(ji,jj,k2,n2)
	884	ENDIF
	885
	886	! Output (Child) grid:
	887	DO jk=1,N_out
	888	h_out(jk) = e3t(ji,jj,jk,Krhs_a)
[14086]	889	END DO
[14218]	890	z_out(1) = 0.5_wp * h_out(1)
	891	DO jk=2,N_out
	892	z_out(jk) = z_out(jk-1) + 0.5_wp * ( h_out(jk)+h_out(jk-1) )
[14086]	893	END DO
[14218]	894	IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Krhs_a)
[13216]	895
	896	IF( l_ini_child ) THEN
[14086]	897	CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), &
[13216]	898	& z_out(1:N_out),N_in,N_out,jpts)
	899	ELSE
[14086]	900	CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),tabin_i(1:N_in,1:jpts), &
	901	& z_in_i(1:N_in),N_in,N_in,jpts)
	902	CALL reconstructandremap(tabin_i(1:N_in,1:jpts),h_in_i(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), &
[13216]	903	& h_out(1:N_out),N_in,N_out,jpts)
	904	ENDIF
[12377]	905	ENDIF
[13286]	906	END DO
	907	END DO
[13216]	908	Krhs_a = item
	909
	910	ELSE
	911
[14086]	912	IF ( Agrif_Parent(ln_zps) ) THEN ! Account for partial cells
	913	! linear vertical interpolation
	914	DO jj=j1,j2
	915	DO ji=i1,i2
	916	!
	917	N_in = mbkt(ji,jj)
	918	N_out = mbkt(ji,jj)
	919	z_in(1) = ptab(ji,jj,1,n2)
	920	tabin(1,1:jpts) = ptab(ji,jj,1,1:jpts)
	921	DO jk=2, N_in
	922	z_in(jk) = ptab(ji,jj,jk,n2)
	923	tabin(jk,1:jpts) = ptab(ji,jj,jk,1:jpts)
	924	END DO
	925	IF (.NOT.ln_linssh) z_in(1:N_in) = z_in(1:N_in) - ptab(ji,jj,k2,n2)
	926	z_out(1) = 0.5_wp * e3t(ji,jj,1,Krhs_a)
	927	DO jk=2, N_out
	928	z_out(jk) = z_out(jk-1) + 0.5_wp * (e3t(ji,jj,jk-1,Krhs_a) + e3t(ji,jj,jk,Krhs_a))
	929	END DO
	930	IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Krhs_a)
	931	CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ptab(ji,jj,1:N_out,1:jpts), &
	932	& z_out(1:N_out),N_in,N_out,jpts)
	933	END DO
	934	END DO
	935	ENDIF
	936
	937	DO jn =1, jpts
	938	ts(i1:i2,j1:j2,1:jpk,jn,Krhs_a) = ptab(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk)
[13216]	939	END DO
	940	ENDIF
[9116]	941
[5656]	942	ENDIF
	943	!
	944	END SUBROUTINE interptsn
	945
[13286]	946
[12377]	947	SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before )
[5656]	948	!!----------------------------------------------------------------------
[4292]	949	!! * ROUTINE interpsshn *
	950	!!----------------------------------------------------------------------
[6140]	951	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	952	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	953	LOGICAL , INTENT(in ) :: before
	954	!
[5656]	955	!!----------------------------------------------------------------------
	956	!
	957	IF( before) THEN
[12377]	958	ptab(i1:i2,j1:j2) = ssh(i1:i2,j1:j2,Kmm_a)
[5656]	959	ELSE
[14086]	960	IF( l_ini_child ) THEN
[14170]	961	ssh(i1:i2,j1:j2,Krhs_a) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
[14086]	962	ELSE
	963	hbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
	964	ENDIF
[5656]	965	ENDIF
	966	!
	967	END SUBROUTINE interpsshn
	968
[13286]	969
[12377]	970	SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
[6140]	971	!!----------------------------------------------------------------------
[9019]	972	!! * ROUTINE interpun *
[9031]	973	!!---------------------------------------------
	974	!!
	975	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
	976	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
	977	LOGICAL, INTENT(in) :: before
	978	!!
	979	INTEGER :: ji,jj,jk
[12377]	980	REAL(wp) :: zrhoy, zhtot
[9031]	981	! vertical interpolation:
[13216]	982	REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in
	983	REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
	984	INTEGER :: N_in, N_out,item
[9031]	985	REAL(wp) :: h_diff
	986	!!---------------------------------------------
[5656]	987	!
[9031]	988	IF (before) THEN
[13216]	989
	990	item = Kmm_a
	991	IF( l_ini_child ) Kmm_a = Kbb_a
	992
[9031]	993	DO jk=1,jpk
	994	DO jj=j1,j2
	995	DO ji=i1,i2
[12377]	996	ptab(ji,jj,jk,1) = (e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * uu(ji,jj,jk,Kmm_a)*umask(ji,jj,jk))
[13216]	997	IF( l_vremap .OR. l_ini_child) THEN
	998	! Interpolate thicknesses (masked for subsequent extrapolation)
	999	ptab(ji,jj,jk,2) = umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a)
	1000	ENDIF
[9031]	1001	END DO
	1002	END DO
[5656]	1003	END DO
[13216]	1004
[14086]	1005	IF( l_vremap .OR. l_ini_child ) THEN
[12377]	1006	! Extrapolate thicknesses in partial bottom cells:
	1007	! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
[13216]	1008	IF (ln_zps) THEN
	1009	DO jj=j1,j2
	1010	DO ji=i1,i2
	1011	jk = mbku(ji,jj)
	1012	ptab(ji,jj,jk,2) = 0._wp
	1013	END DO
	1014	END DO
	1015	END IF
	1016
	1017	! Save ssh at last level:
	1018	ptab(i1:i2,j1:j2,k2,2) = 0._wp
	1019	IF (.NOT.ln_linssh) THEN
	1020	! This vertical sum below should be replaced by the sea-level at U-points (optimization):
	1021	DO jk=1,jpk
	1022	ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) + e3u(i1:i2,j1:j2,jk,Kmm_a) * umask(i1:i2,j1:j2,jk)
	1023	END DO
	1024	ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hu_0(i1:i2,j1:j2)
	1025	END IF
	1026	ENDIF
	1027
	1028	Kmm_a = item
[12377]	1029	!
[5656]	1030	ELSE
[9031]	1031	zrhoy = Agrif_rhoy()
[13216]	1032
	1033	IF( l_vremap .OR. l_ini_child) THEN
[9031]	1034	! VERTICAL REFINEMENT BEGIN
	1035
[13216]	1036	IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
[12377]	1037
[13216]	1038	DO ji=i1,i2
	1039	DO jj=j1,j2
	1040	uu(ji,jj,:,Krhs_a) = 0._wp
	1041	N_in = mbku_parent(ji,jj)
[14218]	1042	N_out = mbku(ji,jj)
	1043	IF (N_in*N_out > 0) THEN
	1044	zhtot = 0._wp
	1045	DO jk=1,N_in
	1046	!IF (jk==N_in) THEN
	1047	! h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
	1048	!ELSE
	1049	! h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy)
	1050	!ENDIF
	1051	IF ( l_vremap ) THEN
	1052	h_in(jk) = e3u0_parent(ji,jj,jk)
[14086]	1053	ELSE
[14218]	1054	IF (jk==N_in) THEN
	1055	h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
	1056	ELSE
	1057	h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy)
	1058	ENDIF
[14086]	1059	ENDIF
[14218]	1060	zhtot = zhtot + h_in(jk)
	1061	IF( h_in(jk) .GT. 0. ) THEN
	1062	tabin(jk) = ptab(ji,jj,jk,1)/(e2u(ji,jj)zrhoyh_in(jk))
	1063	ELSE
	1064	tabin(jk) = 0.
	1065	ENDIF
	1066	END DO
	1067	z_in(1) = 0.5_wp * h_in(1) - zhtot + hu0_parent(ji,jj)
	1068	DO jk=2,N_in
	1069	z_in(jk) = z_in(jk-1) + 0.5_wp * (h_in(jk)+h_in(jk-1))
	1070	END DO
[13216]	1071
[14218]	1072	DO jk=1, N_out
	1073	h_out(jk) = e3u(ji,jj,jk,Krhs_a)
	1074	END DO
[13216]	1075
[14218]	1076	z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hu_0(ji,jj)
	1077	DO jk=2,N_out
	1078	z_out(jk) = z_out(jk-1) + 0.5_wp * (h_out(jk-1) + h_out(jk))
	1079	END DO
[13216]	1080
[14218]	1081	IF( l_ini_child ) THEN
	1082	CALL remap_linear (tabin(1:N_in),z_in(1:N_in),uu(ji,jj,1:N_out,Krhs_a),z_out(1:N_out),N_in,N_out,1)
	1083	ELSE
	1084	CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),uu(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1)
	1085	ENDIF
[13216]	1086	ENDIF
[13286]	1087	END DO
	1088	END DO
[13216]	1089	ELSE
	1090	DO jk = 1, jpkm1
	1091	DO jj=j1,j2
	1092	uu(i1:i2,jj,jk,Krhs_a) = ptab(i1:i2,jj,jk,1) / ( zrhoy * e2u(i1:i2,jj) * e3u(i1:i2,jj,jk,Krhs_a) )
	1093	END DO
[5656]	1094	END DO
[13216]	1095	ENDIF
[9031]	1096
[5656]	1097	ENDIF
	1098	!
	1099	END SUBROUTINE interpun
	1100
[13286]	1101
[12377]	1102	SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
[6140]	1103	!!----------------------------------------------------------------------
[9019]	1104	!! * ROUTINE interpvn *
[6140]	1105	!!----------------------------------------------------------------------
[5656]	1106	!
[9031]	1107	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
	1108	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
	1109	LOGICAL, INTENT(in) :: before
	1110	!
	1111	INTEGER :: ji,jj,jk
	1112	REAL(wp) :: zrhox
	1113	! vertical interpolation:
[13216]	1114	REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in
	1115	REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
	1116	INTEGER :: N_in, N_out, item
[12377]	1117	REAL(wp) :: h_diff, zhtot
[9031]	1118	!!---------------------------------------------
[5656]	1119	!
[13216]	1120	IF (before) THEN
	1121
	1122	item = Kmm_a
	1123	IF( l_ini_child ) Kmm_a = Kbb_a
	1124
[9031]	1125	DO jk=k1,k2
	1126	DO jj=j1,j2
	1127	DO ji=i1,i2
[12377]	1128	ptab(ji,jj,jk,1) = (e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vv(ji,jj,jk,Kmm_a)*vmask(ji,jj,jk))
[13216]	1129	IF( l_vremap .OR. l_ini_child) THEN
	1130	! Interpolate thicknesses (masked for subsequent extrapolation)
	1131	ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a)
	1132	ENDIF
[9031]	1133	END DO
	1134	END DO
[5656]	1135	END DO
[13216]	1136
	1137	IF( l_vremap .OR. l_ini_child) THEN
[12377]	1138	! Extrapolate thicknesses in partial bottom cells:
	1139	! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
[13216]	1140	IF (ln_zps) THEN
	1141	DO jj=j1,j2
	1142	DO ji=i1,i2
	1143	jk = mbkv(ji,jj)
	1144	ptab(ji,jj,jk,2) = 0._wp
	1145	END DO
	1146	END DO
	1147	END IF
	1148	! Save ssh at last level:
	1149	ptab(i1:i2,j1:j2,k2,2) = 0._wp
	1150	IF (.NOT.ln_linssh) THEN
	1151	! This vertical sum below should be replaced by the sea-level at V-points (optimization):
	1152	DO jk=1,jpk
	1153	ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) + e3v(i1:i2,j1:j2,jk,Kmm_a) * vmask(i1:i2,j1:j2,jk)
[12377]	1154	END DO
[13216]	1155	ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hv_0(i1:i2,j1:j2)
	1156	END IF
	1157	ENDIF
	1158	item = Kmm_a
	1159
[9031]	1160	ELSE
	1161	zrhox = Agrif_rhox()
	1162
[13216]	1163	IF( l_vremap .OR. l_ini_child ) THEN
[9031]	1164
[13216]	1165	IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
	1166
	1167	DO jj=j1,j2
	1168	DO ji=i1,i2
	1169	vv(ji,jj,:,Krhs_a) = 0._wp
	1170	N_in = mbkv_parent(ji,jj)
[14218]	1171	N_out = mbkv(ji,jj)
	1172
	1173	IF (N_in*N_out > 0) THEN
	1174	zhtot = 0._wp
	1175	DO jk=1,N_in
	1176	!IF (jk==N_in) THEN
	1177	! h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
	1178	!ELSE
	1179	! h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox)
	1180	!ENDIF
	1181	IF (l_vremap) THEN
	1182	h_in(jk) = e3v0_parent(ji,jj,jk)
[14086]	1183	ELSE
[14218]	1184	IF (jk==N_in) THEN
	1185	h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
	1186	ELSE
	1187	h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox)
	1188	ENDIF
[14086]	1189	ENDIF
[14218]	1190	zhtot = zhtot + h_in(jk)
	1191	IF( h_in(jk) .GT. 0. ) THEN
	1192	tabin(jk) = ptab(ji,jj,jk,1)/(e1v(ji,jj)zrhoxh_in(jk))
	1193	ELSE
	1194	tabin(jk) = 0.
	1195	ENDIF
	1196	END DO
[13216]	1197
[14218]	1198	z_in(1) = 0.5_wp * h_in(1) - zhtot + hv0_parent(ji,jj)
	1199	DO jk=2,N_in
	1200	z_in(jk) = z_in(jk-1) + 0.5_wp * (h_in(jk-1)+h_in(jk))
	1201	END DO
[13216]	1202
[14218]	1203	DO jk=1,N_out
	1204	h_out(jk) = e3v(ji,jj,jk,Krhs_a)
	1205	END DO
[13216]	1206
[14218]	1207	z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hv_0(ji,jj)
	1208	DO jk=2,N_out
	1209	z_out(jk) = z_out(jk-1) + 0.5_wp * (h_out(jk-1)+h_out(jk))
	1210	END DO
[13216]	1211
	1212	IF( l_ini_child ) THEN
	1213	CALL remap_linear (tabin(1:N_in),z_in(1:N_in),vv(ji,jj,1:N_out,Krhs_a),z_out(1:N_out),N_in,N_out,1)
	1214	ELSE
	1215	CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),vv(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1)
	1216	ENDIF
[12377]	1217	ENDIF
[9031]	1218	END DO
	1219	END DO
[13216]	1220	ELSE
	1221	DO jk = 1, jpkm1
	1222	vv(i1:i2,j1:j2,jk,Krhs_a) = ptab(i1:i2,j1:j2,jk,1) / ( zrhox * e1v(i1:i2,j1:j2) * e3v(i1:i2,j1:j2,jk,Krhs_a) )
	1223	END DO
	1224	ENDIF
[5656]	1225	ENDIF
	1226	!
	1227	END SUBROUTINE interpvn
[636]	1228
[12377]	1229	SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before)
[1605]	1230	!!----------------------------------------------------------------------
[5656]	1231	!! * ROUTINE interpunb *
[1605]	1232	!!----------------------------------------------------------------------
[6140]	1233	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1234	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1235	LOGICAL , INTENT(in ) :: before
	1236	!
	1237	INTEGER :: ji, jj
	1238	REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff
[1605]	1239	!!----------------------------------------------------------------------
[5656]	1240	!
[6140]	1241	IF( before ) THEN
[12377]	1242	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * hu(i1:i2,j1:j2,Kmm_a) * uu_b(i1:i2,j1:j2,Kmm_a)
[5656]	1243	ELSE
	1244	zrhoy = Agrif_Rhoy()
	1245	zrhot = Agrif_rhot()
	1246	! Time indexes bounds for integration
	1247	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
	1248	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
[12377]	1249	!
	1250	DO ji = i1, i2
	1251	DO jj = j1, j2
	1252	IF ( utint_stage(ji,jj) < (bdy_tinterp + 1) ) THEN
	1253	IF ( utint_stage(ji,jj) == 1 ) THEN
	1254	ztcoeff = zrhot * ( zt1*2._wp ( zt1 - 1._wp) &
	1255	& - zt0*2._wp ( zt0 - 1._wp) )
	1256	ELSEIF( utint_stage(ji,jj) == 2 ) THEN
	1257	ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &
	1258	& - zt0 * ( zt0 - 1._wp)**2._wp )
	1259	ELSEIF( utint_stage(ji,jj) == 0 ) THEN
	1260	ztcoeff = 1._wp
	1261	ELSE
	1262	ztcoeff = 0._wp
	1263	ENDIF
	1264	!
	1265	ubdy(ji,jj) = ubdy(ji,jj) + ztcoeff * ptab(ji,jj)
	1266	!
	1267	IF (( utint_stage(ji,jj) == 2 ).OR.( utint_stage(ji,jj) == 0 )) THEN
	1268	ubdy(ji,jj) = ubdy(ji,jj) / (zrhoye2u(ji,jj)) umask(ji,jj,1)
	1269	ENDIF
	1270	!
	1271	utint_stage(ji,jj) = utint_stage(ji,jj) + 1
	1272	ENDIF
	1273	END DO
	1274	END DO
	1275	END IF
[5656]	1276	!
	1277	END SUBROUTINE interpunb
[636]	1278
[6140]	1279
[12377]	1280	SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before )
[1605]	1281	!!----------------------------------------------------------------------
[5656]	1282	!! * ROUTINE interpvnb *
[1605]	1283	!!----------------------------------------------------------------------
[6140]	1284	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1285	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1286	LOGICAL , INTENT(in ) :: before
	1287	!
[12377]	1288	INTEGER :: ji, jj
[6140]	1289	REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff
[1605]	1290	!!----------------------------------------------------------------------
[5656]	1291	!
[6140]	1292	IF( before ) THEN
[12377]	1293	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * hv(i1:i2,j1:j2,Kmm_a) * vv_b(i1:i2,j1:j2,Kmm_a)
[5656]	1294	ELSE
	1295	zrhox = Agrif_Rhox()
	1296	zrhot = Agrif_rhot()
	1297	! Time indexes bounds for integration
	1298	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
[12377]	1299	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
	1300	!
	1301	DO ji = i1, i2
	1302	DO jj = j1, j2
	1303	IF ( vtint_stage(ji,jj) < (bdy_tinterp + 1) ) THEN
	1304	IF ( vtint_stage(ji,jj) == 1 ) THEN
	1305	ztcoeff = zrhot * ( zt1*2._wp ( zt1 - 1._wp) &
	1306	& - zt0*2._wp ( zt0 - 1._wp) )
	1307	ELSEIF( vtint_stage(ji,jj) == 2 ) THEN
	1308	ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &
	1309	& - zt0 * ( zt0 - 1._wp)**2._wp )
	1310	ELSEIF( vtint_stage(ji,jj) == 0 ) THEN
	1311	ztcoeff = 1._wp
	1312	ELSE
	1313	ztcoeff = 0._wp
	1314	ENDIF
	1315	!
	1316	vbdy(ji,jj) = vbdy(ji,jj) + ztcoeff * ptab(ji,jj)
	1317	!
	1318	IF (( vtint_stage(ji,jj) == 2 ).OR.( vtint_stage(ji,jj) == 0 )) THEN
	1319	vbdy(ji,jj) = vbdy(ji,jj) / (zrhoxe1v(ji,jj)) vmask(ji,jj,1)
	1320	ENDIF
	1321	!
	1322	vtint_stage(ji,jj) = vtint_stage(ji,jj) + 1
	1323	ENDIF
	1324	END DO
	1325	END DO
[5656]	1326	ENDIF
	1327	!
	1328	END SUBROUTINE interpvnb
[390]	1329
[6140]	1330
[12377]	1331	SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before )
[1605]	1332	!!----------------------------------------------------------------------
[5656]	1333	!! * ROUTINE interpub2b *
[1605]	1334	!!----------------------------------------------------------------------
[6140]	1335	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1336	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1337	LOGICAL , INTENT(in ) :: before
	1338	!
	1339	INTEGER :: ji,jj
[12377]	1340	REAL(wp) :: zrhot, zt0, zt1, zat
[1605]	1341	!!----------------------------------------------------------------------
[5656]	1342	IF( before ) THEN
[14053]	1343	! IF ( ln_bt_fw ) THEN
[9031]	1344	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
[14053]	1345	! ELSE
	1346	! ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2)
	1347	! ENDIF
[5656]	1348	ELSE
	1349	zrhot = Agrif_rhot()
	1350	! Time indexes bounds for integration
	1351	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
	1352	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
	1353	! Polynomial interpolation coefficients:
[6140]	1354	zat = zrhot * ( zt1*2._wp (-2._wp*zt1 + 3._wp) &
	1355	& - zt0*2._wp (-2._wp*zt0 + 3._wp) )
[12377]	1356	!
	1357	ubdy(i1:i2,j1:j2) = zat * ptab(i1:i2,j1:j2)
	1358	!
	1359	! Update interpolation stage:
	1360	utint_stage(i1:i2,j1:j2) = 1
[5656]	1361	ENDIF
	1362	!
	1363	END SUBROUTINE interpub2b
[6140]	1364
[14086]	1365	SUBROUTINE interpub2b_const( ptab, i1, i2, j1, j2, before )
	1366	!!----------------------------------------------------------------------
	1367	!! * ROUTINE interpub2b_const *
	1368	!!----------------------------------------------------------------------
	1369	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1370	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1371	LOGICAL , INTENT(in ) :: before
	1372	!
	1373	REAL(wp) :: zrhoy
	1374	!!----------------------------------------------------------------------
	1375	IF( before ) THEN
	1376	! IF ( ln_bt_fw ) THEN
	1377	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
	1378	! ELSE
	1379	! ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2)
	1380	! ENDIF
	1381	ELSE
	1382	zrhoy = Agrif_Rhoy()
	1383	!
	1384	ubdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) &
	1385	& / (zrhoye2u(i1:i2,j1:j2)) umask(i1:i2,j1:j2,1)
	1386	!
	1387	ENDIF
	1388	!
	1389	END SUBROUTINE interpub2b_const
[636]	1390
[14086]	1391
	1392	SUBROUTINE ub2b_cor( ptab, i1, i2, j1, j2, before )
	1393	!!----------------------------------------------------------------------
	1394	!! * ROUTINE ub2b_cor *
	1395	!!----------------------------------------------------------------------
	1396	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1397	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1398	LOGICAL , INTENT(in ) :: before
	1399	!
	1400	INTEGER :: ji, jj
	1401	REAL(wp) :: zrhox, zrhoy, zx
	1402	!!----------------------------------------------------------------------
	1403	IF( before ) THEN
	1404	ptab(:,:) = 0._wp
	1405	DO ji=i1+1,i2-1
[14122]	1406	DO jj=j1+1,j2-1
[14086]	1407	ptab(ji,jj) = 0.25_wp( ( vb2_b(ji+1,jj )e1v(ji+1,jj ) &
	1408	& -vb2_b(ji-1,jj )*e1v(ji-1,jj ) ) &
	1409	& -( vb2_b(ji+1,jj-1)*e1v(ji+1,jj-1) &
	1410	& -vb2_b(ji-1,jj-1)*e1v(ji-1,jj-1) ) )
	1411	END DO
	1412	END DO
	1413	ELSE
	1414	!
	1415	zrhox = Agrif_Rhox()
	1416	zrhoy = Agrif_Rhoy()
	1417	DO ji=i1,i2
	1418	DO jj=j1,j2
	1419	IF (utint_stage(ji,jj)==0) THEN
	1420	zx = 2._wp*MOD(ABS(mig0(ji)-nbghostcells-1), INT(Agrif_Rhox()))/zrhox - 1._wp
	1421	ubdy(ji,jj) = ubdy(ji,jj) + 0.25_wp(1._wp-zxzx) * ptab(ji,jj) &
	1422	& / zrhoy r1_e2u(ji,jj) umask(ji,jj,1)
	1423	utint_stage(ji,jj) = 1
	1424	ENDIF
	1425	END DO
	1426	END DO
	1427	!
	1428	ENDIF
	1429	!
	1430	END SUBROUTINE ub2b_cor
	1431
	1432
[12377]	1433	SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before )
[4292]	1434	!!----------------------------------------------------------------------
[5656]	1435	!! * ROUTINE interpvb2b *
[4292]	1436	!!----------------------------------------------------------------------
[6140]	1437	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1438	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1439	LOGICAL , INTENT(in ) :: before
	1440	!
	1441	INTEGER :: ji,jj
[12377]	1442	REAL(wp) :: zrhot, zt0, zt1, zat
[4292]	1443	!!----------------------------------------------------------------------
[5656]	1444	!
	1445	IF( before ) THEN
[14053]	1446	! IF ( ln_bt_fw ) THEN
[9031]	1447	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
[14053]	1448	! ELSE
	1449	! ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2)
	1450	! ENDIF
[5656]	1451	ELSE
	1452	zrhot = Agrif_rhot()
	1453	! Time indexes bounds for integration
	1454	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
	1455	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
	1456	! Polynomial interpolation coefficients:
[6140]	1457	zat = zrhot * ( zt1*2._wp (-2._wp*zt1 + 3._wp) &
	1458	& - zt0*2._wp (-2._wp*zt0 + 3._wp) )
[5656]	1459	!
[12377]	1460	vbdy(i1:i2,j1:j2) = zat * ptab(i1:i2,j1:j2)
	1461	!
	1462	! update interpolation stage:
	1463	vtint_stage(i1:i2,j1:j2) = 1
[5656]	1464	ENDIF
	1465	!
	1466	END SUBROUTINE interpvb2b
[4292]	1467
[6140]	1468
[14086]	1469	SUBROUTINE interpvb2b_const( ptab, i1, i2, j1, j2, before )
	1470	!!----------------------------------------------------------------------
	1471	!! * ROUTINE interpub2b_const *
	1472	!!----------------------------------------------------------------------
	1473	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1474	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1475	LOGICAL , INTENT(in ) :: before
	1476	!
	1477	REAL(wp) :: zrhox
	1478	!!----------------------------------------------------------------------
	1479	IF( before ) THEN
	1480	! IF ( ln_bt_fw ) THEN
	1481	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
	1482	! ELSE
	1483	! ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2)
	1484	! ENDIF
	1485	ELSE
	1486	zrhox = Agrif_Rhox()
	1487	!
	1488	vbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) &
	1489	& / (zrhoxe1v(i1:i2,j1:j2)) vmask(i1:i2,j1:j2,1)
	1490	!
	1491	ENDIF
	1492	!
	1493	END SUBROUTINE interpvb2b_const
	1494
	1495
	1496	SUBROUTINE vb2b_cor( ptab, i1, i2, j1, j2, before )
	1497	!!----------------------------------------------------------------------
	1498	!! * ROUTINE vb2b_cor *
	1499	!!----------------------------------------------------------------------
	1500	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1501	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1502	LOGICAL , INTENT(in ) :: before
	1503	!
	1504	INTEGER :: ji, jj
	1505	REAL(wp) :: zrhox, zrhoy, zy
	1506	!!----------------------------------------------------------------------
	1507	IF( before ) THEN
	1508	ptab(:,:) = 0._wp
	1509	DO ji=i1+1,i2-1
[14122]	1510	DO jj=j1+1,j2-1
[14086]	1511	ptab(ji,jj) = 0.25_wp( ( ub2_b(ji ,jj+1)e2u(ji ,jj+1) &
	1512	& -ub2_b(ji ,jj-1)*e2u(ji ,jj-1) ) &
	1513	& -( ub2_b(ji-1,jj+1)*e2u(ji-1,jj+1) &
	1514	& -ub2_b(ji-1,jj-1)*e2u(ji-1,jj-1) ) )
	1515	END DO
	1516	END DO
	1517	ELSE
	1518	!
	1519	zrhox = Agrif_Rhox()
	1520	zrhoy = Agrif_Rhoy()
	1521	DO ji=i1,i2
	1522	DO jj=j1,j2
	1523	IF (vtint_stage(ji,jj)==0) THEN
	1524	zy = 2._wp*MOD(ABS(mjg0(jj)-nbghostcells-1), INT(Agrif_Rhoy()))/zrhoy - 1._wp
	1525	vbdy(ji,jj) = vbdy(ji,jj) + 0.25_wp(1._wp-zyzy) * ptab(ji,jj) &
	1526	& / zrhox * r1_e1v(ji,jj) * vmask(ji,jj,1)
	1527	vtint_stage(ji,jj) = 1
	1528	ENDIF
	1529	END DO
	1530	END DO
	1531	!
	1532	ENDIF
	1533	!
	1534	END SUBROUTINE vb2b_cor
	1535
	1536
[12377]	1537	SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before )
[5656]	1538	!!----------------------------------------------------------------------
	1539	!! * ROUTINE interpe3t *
	1540	!!----------------------------------------------------------------------
[6140]	1541	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
[5656]	1542	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
[6140]	1543	LOGICAL , INTENT(in ) :: before
[5656]	1544	!
	1545	INTEGER :: ji, jj, jk
	1546	!!----------------------------------------------------------------------
	1547	!
[6140]	1548	IF( before ) THEN
	1549	ptab(i1:i2,j1:j2,k1:k2) = tmask(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2)
[5656]	1550	ELSE
[9019]	1551	!
[6140]	1552	DO jk = k1, k2
	1553	DO jj = j1, j2
	1554	DO ji = i1, i2
[9019]	1555	IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) ) > 1.D-2) THEN
[12377]	1556	WRITE(numout,*) ' Agrif error for e3t_0: parent , child, i, j, k ', &
	1557	& ptab(ji,jj,jk), tmask(ji,jj,jk) * e3t_0(ji,jj,jk), &
[14086]	1558	& mig0(ji), mjg0(jj), jk
[14218]	1559	kindic_agr = kindic_agr + 1
[5656]	1560	ENDIF
	1561	END DO
	1562	END DO
	1563	END DO
[6140]	1564	!
[5656]	1565	ENDIF
	1566	!
	1567	END SUBROUTINE interpe3t
	1568
[14086]	1569
	1570	SUBROUTINE interpe3t0_vremap( ptab, i1, i2, j1, j2, k1, k2, before )
	1571	!!----------------------------------------------------------------------
	1572	!! * ROUTINE interpe3t0_vremap *
	1573	!!----------------------------------------------------------------------
	1574	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
	1575	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
	1576	LOGICAL , INTENT(in ) :: before
	1577	!
	1578	INTEGER :: ji, jj, jk
	1579	REAL(wp) :: zh
	1580	!!----------------------------------------------------------------------
	1581	!
	1582	IF( before ) THEN
	1583	IF ( ln_zps ) THEN
	1584	DO jk = k1, k2
	1585	DO jj = j1, j2
	1586	DO ji = i1, i2
	1587	ptab(ji, jj, jk) = e3t_1d(jk)
	1588	END DO
	1589	END DO
	1590	END DO
	1591	ELSE
	1592	ptab(i1:i2,j1:j2,k1:k2) = e3t_0(i1:i2,j1:j2,k1:k2)
	1593	ENDIF
	1594	ELSE
	1595	!
	1596	DO jk = k1, k2
	1597	DO jj = j1, j2
	1598	DO ji = i1, i2
	1599	e3t0_parent(ji,jj,jk) = ptab(ji,jj,jk)
	1600	END DO
	1601	END DO
	1602	END DO
	1603
	1604	! Retrieve correct scale factor at the bottom:
	1605	DO jj = j1, j2
	1606	DO ji = i1, i2
	1607	zh = 0._wp
	1608	DO jk = 1, mbkt_parent(ji, jj)-1
	1609	zh = zh + e3t0_parent(ji,jj,jk)
	1610	END DO
	1611	e3t0_parent(ji,jj,mbkt_parent(ji,jj)) = ht0_parent(ji, jj) - zh
	1612	END DO
	1613	END DO
	1614
	1615	ENDIF
	1616	!
	1617	END SUBROUTINE interpe3t0_vremap
	1618
	1619
[13286]	1620	SUBROUTINE interpglamt( ptab, i1, i2, j1, j2, before )
	1621	!!----------------------------------------------------------------------
	1622	!! * ROUTINE interpglamt *
	1623	!!----------------------------------------------------------------------
	1624	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1625	REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1626	LOGICAL , INTENT(in ) :: before
	1627	!
	1628	INTEGER :: ji, jj, jk
	1629	REAL(wp):: ztst
	1630	!!----------------------------------------------------------------------
	1631	!
	1632	IF( before ) THEN
	1633	ptab(i1:i2,j1:j2) = glamt(i1:i2,j1:j2)
	1634	ELSE
	1635	ztst = MAXVAL(ABS(glamt(i1:i2,j1:j2)))*1.e-4
	1636	DO jj = j1, j2
	1637	DO ji = i1, i2
	1638	IF( ABS( ptab(ji,jj) - glamt(ji,jj) ) > ztst ) THEN
	1639	WRITE(numout,*) ' Agrif error for glamt: parent, child, i, j ', ptab(ji,jj), glamt(ji,jj), mig0(ji), mig0(jj)
	1640	! kindic_agr = kindic_agr + 1
	1641	ENDIF
	1642	END DO
	1643	END DO
	1644	ENDIF
	1645	!
	1646	END SUBROUTINE interpglamt
	1647
	1648
	1649	SUBROUTINE interpgphit( ptab, i1, i2, j1, j2, before )
	1650	!!----------------------------------------------------------------------
	1651	!! * ROUTINE interpgphit *
	1652	!!----------------------------------------------------------------------
	1653	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1654	REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1655	LOGICAL , INTENT(in ) :: before
	1656	!
	1657	INTEGER :: ji, jj, jk
	1658	REAL(wp):: ztst
	1659	!!----------------------------------------------------------------------
	1660	!
	1661	IF( before ) THEN
	1662	ptab(i1:i2,j1:j2) = gphit(i1:i2,j1:j2)
	1663	ELSE
	1664	ztst = MAXVAL(ABS(gphit(i1:i2,j1:j2)))*1.e-4
	1665	DO jj = j1, j2
	1666	DO ji = i1, i2
	1667	IF( ABS( ptab(ji,jj) - gphit(ji,jj) ) > ztst ) THEN
	1668	WRITE(numout,*) ' Agrif error for gphit: parent, child, i, j ', ptab(ji,jj), gphit(ji,jj), mig0(ji), mig0(jj)
	1669	! kindic_agr = kindic_agr + 1
	1670	ENDIF
	1671	END DO
	1672	END DO
	1673	ENDIF
	1674	!
	1675	END SUBROUTINE interpgphit
	1676
	1677
[9031]	1678	SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
[4486]	1679	!!----------------------------------------------------------------------
[5656]	1680	!! * ROUTINE interavm *
[4486]	1681	!!----------------------------------------------------------------------
[9116]	1682	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, m1, m2
[9031]	1683	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
[9116]	1684	LOGICAL , INTENT(in ) :: before
[12377]	1685	!
	1686	INTEGER :: ji, jj, jk
	1687	INTEGER :: N_in, N_out
	1688	REAL(wp), DIMENSION(k1:k2) :: tabin, z_in
	1689	REAL(wp), DIMENSION(1:jpk) :: z_out
[4486]	1690	!!----------------------------------------------------------------------
[5656]	1691	!
[9031]	1692	IF (before) THEN
	1693	DO jk=k1,k2
	1694	DO jj=j1,j2
	1695	DO ji=i1,i2
	1696	ptab(ji,jj,jk,1) = avm_k(ji,jj,jk)
	1697	END DO
	1698	END DO
[13216]	1699	END DO
[12377]	1700
[13216]	1701	IF( l_vremap ) THEN
[14218]	1702	! Interpolate interfaces
[13216]	1703	! Warning: these are masked, hence extrapolated prior interpolation.
	1704	DO jk=k1,k2
	1705	DO jj=j1,j2
	1706	DO ji=i1,i2
[14218]	1707	ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * gdepw(ji,jj,jk,Kmm_a)
[13216]	1708	END DO
	1709	END DO
	1710	END DO
	1711
	1712	! Save ssh at last level:
	1713	IF (.NOT.ln_linssh) THEN
	1714	ptab(i1:i2,j1:j2,k2,2) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1)
	1715	ELSE
	1716	ptab(i1:i2,j1:j2,k2,2) = 0._wp
	1717	END IF
	1718	ENDIF
	1719
[9031]	1720	ELSE
[13216]	1721
	1722	IF( l_vremap ) THEN
	1723	IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
[14218]	1724	avm_k(i1:i2,j1:j2,1:jpkm1) = 0._wp
[13216]	1725
	1726	DO jj = j1, j2
	1727	DO ji =i1, i2
	1728	N_in = mbkt_parent(ji,jj)
[14218]	1729	N_out = mbkt(ji,jj)
[13216]	1730	IF (N_in*N_out > 0) THEN
[14218]	1731	DO jk = 1, N_in ! Parent vertical grid
	1732	z_in(jk) = ptab(ji,jj,jk,2) - ptab(ji,jj,k2,2)
	1733	tabin(jk) = ptab(ji,jj,jk,1)
	1734	END DO
	1735	DO jk = 1, N_out ! Child vertical grid
	1736	z_out(jk) = gdepw(ji,jj,jk,Kmm_a) - ssh(ji,jj,Kmm_a)
	1737	END DO
	1738	IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Kmm_a)
	1739
[13216]	1740	CALL remap_linear(tabin(1:N_in),z_in(1:N_in),avm_k(ji,jj,1:N_out),z_out(1:N_out),N_in,N_out,1)
	1741	ENDIF
[13286]	1742	END DO
	1743	END DO
[13216]	1744	ELSE
[14218]	1745	avm_k(i1:i2,j1:j2,1:jpkm1) = ptab (i1:i2,j1:j2,1:jpkm1,1)
[13216]	1746	ENDIF
[5656]	1747	ENDIF
	1748	!
	1749	END SUBROUTINE interpavm
[4486]	1750
[13286]	1751
[12377]	1752	SUBROUTINE interpmbkt( ptab, i1, i2, j1, j2, before )
	1753	!!----------------------------------------------------------------------
[14086]	1754	!! * ROUTINE interpmbkt *
[12377]	1755	!!----------------------------------------------------------------------
	1756	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1757	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1758	LOGICAL , INTENT(in ) :: before
	1759	!
	1760	!!----------------------------------------------------------------------
	1761	!
	1762	IF( before) THEN
	1763	ptab(i1:i2,j1:j2) = REAL(mbkt(i1:i2,j1:j2),wp)
	1764	ELSE
	1765	mbkt_parent(i1:i2,j1:j2) = NINT(ptab(i1:i2,j1:j2))
	1766	ENDIF
	1767	!
	1768	END SUBROUTINE interpmbkt
	1769
[13286]	1770
[12377]	1771	SUBROUTINE interpht0( ptab, i1, i2, j1, j2, before )
	1772	!!----------------------------------------------------------------------
[14086]	1773	!! * ROUTINE interpht0 *
[12377]	1774	!!----------------------------------------------------------------------
	1775	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1776	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1777	LOGICAL , INTENT(in ) :: before
	1778	!
	1779	!!----------------------------------------------------------------------
	1780	!
	1781	IF( before) THEN
	1782	ptab(i1:i2,j1:j2) = ht_0(i1:i2,j1:j2)
	1783	ELSE
	1784	ht0_parent(i1:i2,j1:j2) = ptab(i1:i2,j1:j2)
	1785	ENDIF
	1786	!
	1787	END SUBROUTINE interpht0
	1788
[14086]	1789	SUBROUTINE Agrif_check_bat( iindic )
[13216]	1790	!!----------------------------------------------------------------------
[14086]	1791	!! * ROUTINE Agrif_check_bat *
[13216]	1792	!!----------------------------------------------------------------------
[14086]	1793	INTEGER, INTENT(inout) :: iindic
	1794	!!
	1795	INTEGER :: ji, jj
	1796	INTEGER :: istart, iend, jstart, jend, ispon
[13216]	1797	!!----------------------------------------------------------------------
	1798	!
[14086]	1799	!
	1800	! --- West --- !
	1801	IF(lk_west) THEN
	1802	ispon = nn_sponge_len * Agrif_irhox()
	1803	istart = nn_hls + 2 ! halo + land + 1
	1804	iend = nn_hls + 1 + nbghostcells + ispon ! halo + land + nbghostcells + sponge
	1805	jstart = nn_hls + 2
	1806	jend = jpjglo - nn_hls - 1
	1807	DO ji = mi0(istart), mi1(iend)
	1808	DO jj = mj0(jstart), mj1(jend)
	1809	IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
	1810	END DO
	1811	DO jj = mj0(jstart), mj1(jend-1)
	1812	IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
	1813	END DO
	1814	END DO
	1815	DO ji = mi0(istart), mi1(iend-1)
	1816	DO jj = mj0(jstart), mj1(jend)
	1817	IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
	1818	END DO
	1819	END DO
[13216]	1820	ENDIF
	1821	!
[14086]	1822	! --- East --- !
	1823	IF(lk_east) THEN
	1824	ispon = nn_sponge_len * Agrif_irhox()
	1825	istart = jpiglo - ( nn_hls + nbghostcells + ispon ) ! halo + land + nbghostcells + sponge - 1
	1826	iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
	1827	jstart = nn_hls + 2
	1828	jend = jpjglo - nn_hls - 1
	1829	DO ji = mi0(istart), mi1(iend)
	1830	DO jj = mj0(jstart), mj1(jend)
	1831	IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
	1832	END DO
	1833	DO jj = mj0(jstart), mj1(jend-1)
	1834	IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
	1835	END DO
	1836	END DO
	1837	DO ji = mi0(istart+1), mi1(iend-1)
	1838	DO jj = mj0(jstart), mj1(jend)
	1839	IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
	1840	END DO
	1841	END DO
	1842	ENDIF
	1843	!
	1844	! --- South --- !
	1845	IF(lk_south) THEN
	1846	ispon = nn_sponge_len * Agrif_irhoy()
	1847	jstart = nn_hls + 2 ! halo + land + 1
	1848	jend = nn_hls + 1 + nbghostcells + ispon ! halo + land + nbghostcells + sponge
	1849	istart = nn_hls + 2
	1850	iend = jpiglo - nn_hls - 1
	1851	DO jj = mj0(jstart), mj1(jend)
	1852	DO ji = mi0(istart), mi1(iend)
	1853	IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
	1854	END DO
	1855	DO ji = mi0(istart), mi1(iend-1)
	1856	IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
	1857	END DO
	1858	END DO
	1859	DO jj = mj0(jstart), mj1(jend-1)
	1860	DO ji = mi0(istart), mi1(iend)
	1861	IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
	1862	END DO
	1863	END DO
	1864	ENDIF
	1865	!
	1866	! --- North --- !
	1867	IF(lk_north) THEN
	1868	ispon = nn_sponge_len * Agrif_irhoy()
	1869	jstart = jpjglo - ( nn_hls + nbghostcells + ispon) ! halo + land + nbghostcells +sponge - 1
	1870	jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
	1871	istart = nn_hls + 2
	1872	iend = jpiglo - nn_hls - 1
	1873	DO jj = mj0(jstart), mj1(jend)
	1874	DO ji = mi0(istart), mi1(iend)
	1875	IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
	1876	END DO
	1877	DO ji = mi0(istart), mi1(iend-1)
	1878	IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
	1879	END DO
	1880	END DO
	1881	DO jj = mj0(jstart+1), mj1(jend-1)
	1882	DO ji = mi0(istart), mi1(iend)
	1883	IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
	1884	END DO
	1885	END DO
	1886	ENDIF
	1887	!
	1888	END SUBROUTINE Agrif_check_bat
[13216]	1889
[390]	1890	#else
[1605]	1891	!!----------------------------------------------------------------------
	1892	!! Empty module no AGRIF zoom
	1893	!!----------------------------------------------------------------------
[636]	1894	CONTAINS
[9570]	1895	SUBROUTINE Agrif_OCE_Interp_empty
	1896	WRITE(,) 'agrif_oce_interp : You should not have seen this print! error?'
	1897	END SUBROUTINE Agrif_OCE_Interp_empty
[390]	1898	#endif
[1605]	1899
	1900	!!======================================================================
[9570]	1901	END MODULE agrif_oce_interp

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

Download in other formats: