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/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/NST – NEMO

Context Navigation

source: NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/NST/agrif_oce_interp.F90 @ 13337

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

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

Download in other formats: