Context Navigation

agrif_oce_interp.F90 @ 12489

Last change on this file since 12489 was 12377, checked in by acc, 4 years ago

The big one. Merging all 2019 developments from the option 1 branch back onto the trunk.

This changeset reproduces 2019/dev_r11943_MERGE_2019 on the trunk using a 2-URL merge
onto a working copy of the trunk. I.e.:

svn merge --ignore-ancestry \

svn+ssh://acc@forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/NEMO/trunk \
svn+ssh://acc@forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/NEMO/branches/2019/dev_r11943_MERGE_2019 ./

The --ignore-ancestry flag avoids problems that may otherwise arise from the fact that
the merge history been trunk and branch may have been applied in a different order but
care has been taken before this step to ensure that all applicable fixes and updates
are present in the merge branch.

The trunk state just before this step has been branched to releases/release-4.0-HEAD
and that branch has been immediately tagged as releases/release-4.0.2. Any fixes
or additions in response to tickets on 4.0, 4.0.1 or 4.0.2 should be done on
releases/release-4.0-HEAD. From now on future 'point' releases (e.g. 4.0.2) will
remain unchanged with periodic releases as needs demand. Note release-4.0-HEAD is a
transitional naming convention. Future full releases, say 4.2, will have a release-4.2
branch which fulfills this role and the first point release (e.g. 4.2.0) will be made
immediately following the release branch creation.

2020 developments can be started from any trunk revision later than this one.

Property svn:keywords set to Id

File size: 45.4 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
[5656]	36
[636]	37	IMPLICIT NONE
	38	PRIVATE
[4292]	39
[12377]	40	PUBLIC Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_dyn_ts_flux, Agrif_ssh_ts, Agrif_dta_ts
[9057]	41	PUBLIC Agrif_tra, Agrif_avm
[9019]	42	PUBLIC interpun , interpvn
[9057]	43	PUBLIC interptsn, interpsshn, interpavm
[9019]	44	PUBLIC interpunb, interpvnb , interpub2b, interpvb2b
[12377]	45	PUBLIC interpe3t
	46	#if defined key_vertical
	47	PUBLIC interpht0, interpmbkt
	48	# endif
[6140]	49	INTEGER :: bdy_tinterp = 0
	50
[1156]	51	!!----------------------------------------------------------------------
[9598]	52	!! NEMO/NST 4.0 , NEMO Consortium (2018)
[1156]	53	!! $Id$
[10068]	54	!! Software governed by the CeCILL license (see ./LICENSE)
[1156]	55	!!----------------------------------------------------------------------
[5656]	56	CONTAINS
	57
[782]	58	SUBROUTINE Agrif_tra
[1605]	59	!!----------------------------------------------------------------------
[5656]	60	!! * ROUTINE Agrif_tra *
[1605]	61	!!----------------------------------------------------------------------
[636]	62	!
[1605]	63	IF( Agrif_Root() ) RETURN
[6140]	64	!
	65	Agrif_SpecialValue = 0._wp
[636]	66	Agrif_UseSpecialValue = .TRUE.
[6140]	67	!
[5656]	68	CALL Agrif_Bc_variable( tsn_id, procname=interptsn )
[6140]	69	!
[636]	70	Agrif_UseSpecialValue = .FALSE.
[1605]	71	!
[636]	72	END SUBROUTINE Agrif_tra
	73
[1605]	74
[636]	75	SUBROUTINE Agrif_dyn( kt )
[1605]	76	!!----------------------------------------------------------------------
	77	!! * ROUTINE Agrif_DYN *
	78	!!----------------------------------------------------------------------
	79	INTEGER, INTENT(in) :: kt
[6140]	80	!
	81	INTEGER :: ji, jj, jk ! dummy loop indices
[9057]	82	INTEGER :: ibdy1, jbdy1, ibdy2, jbdy2
[9019]	83	REAL(wp), DIMENSION(jpi,jpj) :: zub, zvb
[1605]	84	!!----------------------------------------------------------------------
[6140]	85	!
[1605]	86	IF( Agrif_Root() ) RETURN
[6140]	87	!
	88	Agrif_SpecialValue = 0._wp
[5656]	89	Agrif_UseSpecialValue = ln_spc_dyn
[6140]	90	!
	91	CALL Agrif_Bc_variable( un_interp_id, procname=interpun )
	92	CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn )
	93	!
[5656]	94	Agrif_UseSpecialValue = .FALSE.
[6140]	95	!
[12377]	96	! --- West --- !
	97	ibdy1 = 2
	98	ibdy2 = 1+nbghostcells
	99	!
	100	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
	101	DO ji = mi0(ibdy1), mi1(ibdy2)
	102	uu_b(ji,:,Krhs_a) = 0._wp
[782]	103
[6140]	104	DO jk = 1, jpkm1
	105	DO jj = 1, jpj
[12377]	106	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)
[5930]	107	END DO
[636]	108	END DO
[12377]	109
[6140]	110	DO jj = 1, jpj
[12377]	111	uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a)
[636]	112	END DO
[12377]	113	END DO
	114	ENDIF
	115	!
	116	DO ji = mi0(ibdy1), mi1(ibdy2)
	117	zub(ji,:) = 0._wp ! Correct transport
[9057]	118	DO jk = 1, jpkm1
	119	DO jj = 1, jpj
[12377]	120	zub(ji,jj) = zub(ji,jj) &
	121	& + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a)*umask(ji,jj,jk)
[9057]	122	END DO
	123	END DO
	124	DO jj=1,jpj
[12377]	125	zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
[9057]	126	END DO
	127
	128	DO jk = 1, jpkm1
	129	DO jj = 1, jpj
[12377]	130	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)
[9057]	131	END DO
	132	END DO
[12377]	133	END DO
[9057]	134
[12377]	135	IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate
	136	DO ji = mi0(ibdy1), mi1(ibdy2)
	137	zvb(ji,:) = 0._wp
[9019]	138	DO jk = 1, jpkm1
	139	DO jj = 1, jpj
[12377]	140	zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
[9019]	141	END DO
[636]	142	END DO
[9057]	143	DO jj = 1, jpj
[12377]	144	zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
[636]	145	END DO
[6140]	146	DO jk = 1, jpkm1
	147	DO jj = 1, jpj
[12377]	148	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]	149	END DO
	150	END DO
[12377]	151	END DO
[636]	152	ENDIF
[390]	153
[9019]	154	! --- East --- !
[12377]	155	ibdy1 = jpiglo-1-nbghostcells
	156	ibdy2 = jpiglo-2
	157	!
	158	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
	159	DO ji = mi0(ibdy1), mi1(ibdy2)
	160	uu_b(ji,:,Krhs_a) = 0._wp
[9057]	161	DO jk = 1, jpkm1
	162	DO jj = 1, jpj
[12377]	163	uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) &
	164	& + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
[5930]	165	END DO
[636]	166	END DO
[9057]	167	DO jj = 1, jpj
[12377]	168	uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a)
[5930]	169	END DO
[12377]	170	END DO
	171	ENDIF
	172	!
	173	DO ji = mi0(ibdy1), mi1(ibdy2)
	174	zub(ji,:) = 0._wp ! Correct transport
[9031]	175	DO jk = 1, jpkm1
	176	DO jj = 1, jpj
[12377]	177	zub(ji,jj) = zub(ji,jj) &
	178	& + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
[9031]	179	END DO
	180	END DO
[9057]	181	DO jj=1,jpj
[12377]	182	zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
[9031]	183	END DO
[9057]	184
[9031]	185	DO jk = 1, jpkm1
	186	DO jj = 1, jpj
[12377]	187	uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) &
	188	& + uu_b(ji,jj,Krhs_a)-zub(ji,jj))*umask(ji,jj,jk)
[9031]	189	END DO
	190	END DO
[12377]	191	END DO
[9057]	192
[12377]	193	IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate
	194	ibdy1 = jpiglo-nbghostcells
	195	ibdy2 = jpiglo-1
	196	DO ji = mi0(ibdy1), mi1(ibdy2)
	197	zvb(ji,:) = 0._wp
[6140]	198	DO jk = 1, jpkm1
	199	DO jj = 1, jpj
[12377]	200	zvb(ji,jj) = zvb(ji,jj) &
	201	& + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
[5930]	202	END DO
	203	END DO
[9019]	204	DO jj = 1, jpj
[12377]	205	zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
[4486]	206	END DO
[6140]	207	DO jk = 1, jpkm1
	208	DO jj = 1, jpj
[12377]	209	vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) &
	210	& + vv_b(ji,jj,Krhs_a)-zvb(ji,jj)) * vmask(ji,jj,jk)
[5930]	211	END DO
	212	END DO
[12377]	213	END DO
[636]	214	ENDIF
[390]	215
[9019]	216	! --- South --- !
[12377]	217	jbdy1 = 2
	218	jbdy2 = 1+nbghostcells
	219	!
	220	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
	221	DO jj = mj0(jbdy1), mj1(jbdy2)
	222	vv_b(:,jj,Krhs_a) = 0._wp
[6140]	223	DO jk = 1, jpkm1
	224	DO ji = 1, jpi
[12377]	225	vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) &
	226	& + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
[5930]	227	END DO
[636]	228	END DO
	229	DO ji=1,jpi
[12377]	230	vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a)
[636]	231	END DO
[12377]	232	END DO
	233	ENDIF
	234	!
	235	DO jj = mj0(jbdy1), mj1(jbdy2)
	236	zvb(:,jj) = 0._wp ! Correct transport
[9031]	237	DO jk=1,jpkm1
	238	DO ji=1,jpi
[12377]	239	zvb(ji,jj) = zvb(ji,jj) &
	240	& + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
[636]	241	END DO
[9057]	242	END DO
	243	DO ji = 1, jpi
[12377]	244	zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
[9057]	245	END DO
[9134]	246
[9057]	247	DO jk = 1, jpkm1
[6140]	248	DO ji = 1, jpi
[12377]	249	vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) &
	250	& + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk)
[636]	251	END DO
[9057]	252	END DO
[12377]	253	END DO
[9057]	254
[12377]	255	IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate
	256	DO jj = mj0(jbdy1), mj1(jbdy2)
	257	zub(:,jj) = 0._wp
[6140]	258	DO jk = 1, jpkm1
	259	DO ji = 1, jpi
[12377]	260	zub(ji,jj) = zub(ji,jj) &
	261	& + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
[5930]	262	END DO
	263	END DO
[9057]	264	DO ji = 1, jpi
[12377]	265	zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
[9057]	266	END DO
	267
	268	DO jk = 1, jpkm1
[6140]	269	DO ji = 1, jpi
[12377]	270	uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) &
	271	& + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
[5930]	272	END DO
[9057]	273	END DO
[12377]	274	END DO
[636]	275	ENDIF
[390]	276
[9019]	277	! --- North --- !
[12377]	278	jbdy1 = jpjglo-1-nbghostcells
	279	jbdy2 = jpjglo-2
	280	!
	281	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
	282	DO jj = mj0(jbdy1), mj1(jbdy2)
	283	vv_b(:,jj,Krhs_a) = 0._wp
[6140]	284	DO jk = 1, jpkm1
	285	DO ji = 1, jpi
[12377]	286	vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) &
	287	& + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
[5930]	288	END DO
[636]	289	END DO
[9057]	290	DO ji=1,jpi
[12377]	291	vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a)
[636]	292	END DO
[12377]	293	END DO
	294	ENDIF
	295	!
	296	DO jj = mj0(jbdy1), mj1(jbdy2)
	297	zvb(:,jj) = 0._wp ! Correct transport
[9057]	298	DO jk=1,jpkm1
	299	DO ji=1,jpi
[12377]	300	zvb(ji,jj) = zvb(ji,jj) &
	301	& + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
[9057]	302	END DO
	303	END DO
	304	DO ji = 1, jpi
[12377]	305	zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
[9057]	306	END DO
[9134]	307
[9031]	308	DO jk = 1, jpkm1
	309	DO ji = 1, jpi
[12377]	310	vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) &
	311	& + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk)
[636]	312	END DO
[9057]	313	END DO
[12377]	314	END DO
[9057]	315
[12377]	316	IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate
	317	jbdy1 = jpjglo-nbghostcells
	318	jbdy2 = jpjglo-1
	319	DO jj = mj0(jbdy1), mj1(jbdy2)
	320	zub(:,jj) = 0._wp
[9057]	321	DO jk = 1, jpkm1
	322	DO ji = 1, jpi
[12377]	323	zub(ji,jj) = zub(ji,jj) &
	324	& + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
[9057]	325	END DO
	326	END DO
[6140]	327	DO ji = 1, jpi
[12377]	328	zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
[636]	329	END DO
[9057]	330
[6140]	331	DO jk = 1, jpkm1
	332	DO ji = 1, jpi
[12377]	333	uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) &
	334	& + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
[5930]	335	END DO
	336	END DO
[12377]	337	END DO
[636]	338	ENDIF
[2715]	339	!
[636]	340	END SUBROUTINE Agrif_dyn
[390]	341
[6140]	342
[4486]	343	SUBROUTINE Agrif_dyn_ts( jn )
[4292]	344	!!----------------------------------------------------------------------
	345	!! * ROUTINE Agrif_dyn_ts *
	346	!!----------------------------------------------------------------------
[4486]	347	INTEGER, INTENT(in) :: jn
[4292]	348	!!
	349	INTEGER :: ji, jj
[12377]	350	INTEGER :: istart, iend, jstart, jend
[4486]	351	!!----------------------------------------------------------------------
[6140]	352	!
[4486]	353	IF( Agrif_Root() ) RETURN
[9057]	354	!
[12377]	355	!--- West ---!
	356	istart = 2
	357	iend = nbghostcells+1
	358	DO ji = mi0(istart), mi1(iend)
[4486]	359	DO jj=1,jpj
[12377]	360	va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
	361	ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
[4486]	362	END DO
[12377]	363	END DO
[6140]	364	!
[12377]	365	!--- East ---!
	366	istart = jpiglo-nbghostcells
	367	iend = jpiglo-1
	368	DO ji = mi0(istart), mi1(iend)
[4486]	369	DO jj=1,jpj
[12377]	370	va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
[4486]	371	END DO
[12377]	372	END DO
	373	istart = jpiglo-nbghostcells-1
	374	iend = jpiglo-2
	375	DO ji = mi0(istart), mi1(iend)
	376	DO jj=1,jpj
	377	ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
	378	END DO
	379	END DO
[6140]	380	!
[12377]	381	!--- South ---!
	382	jstart = 2
	383	jend = nbghostcells+1
	384	DO jj = mj0(jstart), mj1(jend)
[4486]	385	DO ji=1,jpi
[12377]	386	ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
	387	va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
[4486]	388	END DO
[12377]	389	END DO
[6140]	390	!
[12377]	391	!--- North ---!
	392	jstart = jpjglo-nbghostcells
	393	jend = jpjglo-1
	394	DO jj = mj0(jstart), mj1(jend)
[4486]	395	DO ji=1,jpi
[12377]	396	ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
[4486]	397	END DO
[12377]	398	END DO
	399	jstart = jpjglo-nbghostcells-1
	400	jend = jpjglo-2
	401	DO jj = mj0(jstart), mj1(jend)
	402	DO ji=1,jpi
	403	va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
	404	END DO
	405	END DO
[4486]	406	!
	407	END SUBROUTINE Agrif_dyn_ts
	408
[12377]	409	SUBROUTINE Agrif_dyn_ts_flux( jn, zu, zv )
	410	!!----------------------------------------------------------------------
	411	!! * ROUTINE Agrif_dyn_ts_flux *
	412	!!----------------------------------------------------------------------
	413	INTEGER, INTENT(in) :: jn
	414	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zu, zv
	415	!!
	416	INTEGER :: ji, jj
	417	INTEGER :: istart, iend, jstart, jend
	418	!!----------------------------------------------------------------------
	419	!
	420	IF( Agrif_Root() ) RETURN
	421	!
	422	!--- West ---!
	423	istart = 2
	424	iend = nbghostcells+1
	425	DO ji = mi0(istart), mi1(iend)
	426	DO jj=1,jpj
	427	zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
	428	zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
	429	END DO
	430	END DO
	431	!
	432	!--- East ---!
	433	istart = jpiglo-nbghostcells
	434	iend = jpiglo-1
	435	DO ji = mi0(istart), mi1(iend)
	436	DO jj=1,jpj
	437	zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
	438	END DO
	439	END DO
	440	istart = jpiglo-nbghostcells-1
	441	iend = jpiglo-2
	442	DO ji = mi0(istart), mi1(iend)
	443	DO jj=1,jpj
	444	zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
	445	END DO
	446	END DO
	447	!
	448	!--- South ---!
	449	jstart = 2
	450	jend = nbghostcells+1
	451	DO jj = mj0(jstart), mj1(jend)
	452	DO ji=1,jpi
	453	zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
	454	zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
	455	END DO
	456	END DO
	457	!
	458	!--- North ---!
	459	jstart = jpjglo-nbghostcells
	460	jend = jpjglo-1
	461	DO jj = mj0(jstart), mj1(jend)
	462	DO ji=1,jpi
	463	zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
	464	END DO
	465	END DO
	466	jstart = jpjglo-nbghostcells-1
	467	jend = jpjglo-2
	468	DO jj = mj0(jstart), mj1(jend)
	469	DO ji=1,jpi
	470	zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
	471	END DO
	472	END DO
	473	!
	474	END SUBROUTINE Agrif_dyn_ts_flux
[6140]	475
[4486]	476	SUBROUTINE Agrif_dta_ts( kt )
	477	!!----------------------------------------------------------------------
	478	!! * ROUTINE Agrif_dta_ts *
	479	!!----------------------------------------------------------------------
	480	INTEGER, INTENT(in) :: kt
	481	!!
	482	INTEGER :: ji, jj
	483	LOGICAL :: ll_int_cons
[4292]	484	!!----------------------------------------------------------------------
[6140]	485	!
[4292]	486	IF( Agrif_Root() ) RETURN
[6140]	487	!
	488	ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only
	489	!
[9031]	490	! Enforce volume conservation if no time refinement:
	491	IF ( Agrif_rhot()==1 ) ll_int_cons=.TRUE.
[6140]	492	!
[4486]	493	! Interpolate barotropic fluxes
[12377]	494	Agrif_SpecialValue = 0._wp
[4486]	495	Agrif_UseSpecialValue = ln_spc_dyn
[6140]	496	!
[12377]	497	! Set bdy time interpolation stage to 0 (latter incremented locally do deal with corners)
	498	utint_stage(:,:) = 0
	499	vtint_stage(:,:) = 0
	500	!
[6140]	501	IF( ll_int_cons ) THEN ! Conservative interpolation
[9019]	502	! order matters here !!!!!!
[6140]	503	CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated
[12377]	504	CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b )
	505	!
[5656]	506	bdy_tinterp = 1
[6140]	507	CALL Agrif_Bc_variable( unb_id , calledweight=1._wp, procname=interpunb ) ! After
[12377]	508	CALL Agrif_Bc_variable( vnb_id , calledweight=1._wp, procname=interpvnb )
	509	!
[5656]	510	bdy_tinterp = 2
[6140]	511	CALL Agrif_Bc_variable( unb_id , calledweight=0._wp, procname=interpunb ) ! Before
[12377]	512	CALL Agrif_Bc_variable( vnb_id , calledweight=0._wp, procname=interpvnb )
[4486]	513	ELSE ! Linear interpolation
[12377]	514	!
	515	ubdy(:,:) = 0._wp ; vbdy(:,:) = 0._wp
[9031]	516	CALL Agrif_Bc_variable( unb_id, procname=interpunb )
	517	CALL Agrif_Bc_variable( vnb_id, procname=interpvnb )
[4486]	518	ENDIF
	519	Agrif_UseSpecialValue = .FALSE.
[5656]	520	!
[4486]	521	END SUBROUTINE Agrif_dta_ts
	522
[6140]	523
[2486]	524	SUBROUTINE Agrif_ssh( kt )
	525	!!----------------------------------------------------------------------
[9031]	526	!! * ROUTINE Agrif_ssh *
[2486]	527	!!----------------------------------------------------------------------
	528	INTEGER, INTENT(in) :: kt
[9019]	529	!
[12377]	530	INTEGER :: ji, jj
	531	INTEGER :: istart, iend, jstart, jend
[2486]	532	!!----------------------------------------------------------------------
[6140]	533	!
[2486]	534	IF( Agrif_Root() ) RETURN
[9031]	535	!
[9116]	536	! Linear time interpolation of sea level
[9031]	537	!
	538	Agrif_SpecialValue = 0._wp
	539	Agrif_UseSpecialValue = .TRUE.
	540	CALL Agrif_Bc_variable(sshn_id, procname=interpsshn )
	541	Agrif_UseSpecialValue = .FALSE.
	542	!
[9116]	543	! --- West --- !
[12377]	544	istart = 2
	545	iend = 1 + nbghostcells
	546	DO ji = mi0(istart), mi1(iend)
[9019]	547	DO jj = 1, jpj
[12377]	548	ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
[9019]	549	ENDDO
[12377]	550	ENDDO
[6140]	551	!
[9019]	552	! --- East --- !
[12377]	553	istart = jpiglo - nbghostcells
	554	iend = jpiglo - 1
	555	DO ji = mi0(istart), mi1(iend)
[9019]	556	DO jj = 1, jpj
[12377]	557	ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
[9019]	558	ENDDO
[12377]	559	ENDDO
[6140]	560	!
[9019]	561	! --- South --- !
[12377]	562	jstart = 2
	563	jend = 1 + nbghostcells
	564	DO jj = mj0(jstart), mj1(jend)
	565	DO ji = 1, jpi
	566	ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
[9019]	567	ENDDO
[12377]	568	ENDDO
[6140]	569	!
[9019]	570	! --- North --- !
[12377]	571	jstart = jpjglo - nbghostcells
	572	jend = jpjglo - 1
	573	DO jj = mj0(jstart), mj1(jend)
	574	DO ji = 1, jpi
	575	ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
[9019]	576	ENDDO
[12377]	577	ENDDO
[6140]	578	!
[2486]	579	END SUBROUTINE Agrif_ssh
	580
[6140]	581
[4486]	582	SUBROUTINE Agrif_ssh_ts( jn )
[4292]	583	!!----------------------------------------------------------------------
	584	!! * ROUTINE Agrif_ssh_ts *
	585	!!----------------------------------------------------------------------
[4486]	586	INTEGER, INTENT(in) :: jn
[4292]	587	!!
[12377]	588	INTEGER :: ji, jj
	589	INTEGER :: istart, iend, jstart, jend
[4292]	590	!!----------------------------------------------------------------------
[9031]	591	!
	592	IF( Agrif_Root() ) RETURN
	593	!
[9116]	594	! --- West --- !
[12377]	595	istart = 2
	596	iend = 1+nbghostcells
	597	DO ji = mi0(istart), mi1(iend)
[6140]	598	DO jj = 1, jpj
[12377]	599	ssha_e(ji,jj) = hbdy(ji,jj)
[9116]	600	ENDDO
[12377]	601	ENDDO
[6140]	602	!
[9116]	603	! --- East --- !
[12377]	604	istart = jpiglo - nbghostcells
	605	iend = jpiglo - 1
	606	DO ji = mi0(istart), mi1(iend)
[6140]	607	DO jj = 1, jpj
[12377]	608	ssha_e(ji,jj) = hbdy(ji,jj)
[9116]	609	ENDDO
[12377]	610	ENDDO
[6140]	611	!
[9116]	612	! --- South --- !
[12377]	613	jstart = 2
	614	jend = 1+nbghostcells
	615	DO jj = mj0(jstart), mj1(jend)
	616	DO ji = 1, jpi
	617	ssha_e(ji,jj) = hbdy(ji,jj)
[9116]	618	ENDDO
[12377]	619	ENDDO
[6140]	620	!
[9116]	621	! --- North --- !
[12377]	622	jstart = jpjglo - nbghostcells
	623	jend = jpjglo - 1
	624	DO jj = mj0(jstart), mj1(jend)
	625	DO ji = 1, jpi
	626	ssha_e(ji,jj) = hbdy(ji,jj)
[9116]	627	ENDDO
[12377]	628	ENDDO
[6140]	629	!
[4292]	630	END SUBROUTINE Agrif_ssh_ts
	631
[9019]	632	SUBROUTINE Agrif_avm
[4292]	633	!!----------------------------------------------------------------------
[9019]	634	!! * ROUTINE Agrif_avm *
[5656]	635	!!----------------------------------------------------------------------
	636	REAL(wp) :: zalpha
[6140]	637	!!----------------------------------------------------------------------
[5656]	638	!
[9031]	639	IF( Agrif_Root() ) RETURN
[6140]	640	!
[9031]	641	zalpha = 1._wp ! JC: proper time interpolation impossible
	642	! => use last available value from parent
	643	!
	644	Agrif_SpecialValue = 0.e0
[5656]	645	Agrif_UseSpecialValue = .TRUE.
[6140]	646	!
[9019]	647	CALL Agrif_Bc_variable( avm_id, calledweight=zalpha, procname=interpavm )
[6140]	648	!
[5656]	649	Agrif_UseSpecialValue = .FALSE.
	650	!
[9019]	651	END SUBROUTINE Agrif_avm
[6140]	652
[5656]	653
[12377]	654	SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before )
[6140]	655	!!----------------------------------------------------------------------
[9019]	656	!! * ROUTINE interptsn *
[6140]	657	!!----------------------------------------------------------------------
	658	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab
	659	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2
	660	LOGICAL , INTENT(in ) :: before
[5656]	661	!
[12377]	662	INTEGER :: ji, jj, jk, jn ! dummy loop indices
	663	INTEGER :: N_in, N_out
[9031]	664	! vertical interpolation:
[12377]	665	REAL(wp) :: zhtot
	666	REAL(wp), DIMENSION(k1:k2,1:jpts) :: tabin
[9031]	667	REAL(wp), DIMENSION(k1:k2) :: h_in
[9116]	668	REAL(wp), DIMENSION(1:jpk) :: h_out
[12377]	669	!!----------------------------------------------------------------------
[9031]	670
[9019]	671	IF( before ) THEN
[9031]	672	DO jn = 1,jpts
	673	DO jk=k1,k2
	674	DO jj=j1,j2
	675	DO ji=i1,i2
[12377]	676	ptab(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a)
[9031]	677	END DO
	678	END DO
	679	END DO
	680	END DO
	681
	682	# if defined key_vertical
[12377]	683	! Interpolate thicknesses
	684	! Warning: these are masked, hence extrapolated prior interpolation.
[9031]	685	DO jk=k1,k2
	686	DO jj=j1,j2
	687	DO ji=i1,i2
[12377]	688	ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a)
[9031]	689	END DO
	690	END DO
	691	END DO
[12377]	692
	693	! Extrapolate thicknesses in partial bottom cells:
	694	! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
	695	IF (ln_zps) THEN
	696	DO jj=j1,j2
	697	DO ji=i1,i2
	698	jk = mbkt(ji,jj)
	699	ptab(ji,jj,jk,jpts+1) = 0._wp
	700	END DO
	701	END DO
	702	END IF
	703
	704	! Save ssh at last level:
	705	IF (.NOT.ln_linssh) THEN
	706	ptab(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1)
	707	ELSE
	708	ptab(i1:i2,j1:j2,k2,jpts+1) = 0._wp
	709	END IF
[9031]	710	# endif
	711	ELSE
	712
[12377]	713	# if defined key_vertical
	714	IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp
	715
[9031]	716	DO jj=j1,j2
	717	DO ji=i1,i2
[12377]	718	ts(ji,jj,:,:,Krhs_a) = 0._wp
	719	N_in = mbkt_parent(ji,jj)
	720	zhtot = 0._wp
	721	DO jk=1,N_in !k2 = jpk of parent grid
	722	IF (jk==N_in) THEN
	723	h_in(jk) = ht0_parent(ji,jj) + ptab(ji,jj,k2,n2) - zhtot
	724	ELSE
	725	h_in(jk) = ptab(ji,jj,jk,n2)
	726	ENDIF
	727	zhtot = zhtot + h_in(jk)
[9031]	728	tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1)
	729	END DO
	730	N_out = 0
	731	DO jk=1,jpk ! jpk of child grid
[12377]	732	IF (tmask(ji,jj,jk) == 0._wp) EXIT
[9031]	733	N_out = N_out + 1
[12377]	734	h_out(jk) = e3t(ji,jj,jk,Krhs_a)
[9031]	735	ENDDO
[12377]	736	IF (N_in*N_out > 0) THEN
	737	CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a),h_out(1:N_out),N_in,N_out,jpts)
[9031]	738	ENDIF
	739	ENDDO
	740	ENDDO
	741	# else
[5656]	742	!
[9759]	743	DO jn=1, jpts
[12377]	744	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)
[9759]	745	END DO
[12377]	746	# endif
[9116]	747
[5656]	748	ENDIF
	749	!
	750	END SUBROUTINE interptsn
	751
[12377]	752	SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before )
[5656]	753	!!----------------------------------------------------------------------
[4292]	754	!! * ROUTINE interpsshn *
	755	!!----------------------------------------------------------------------
[6140]	756	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	757	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	758	LOGICAL , INTENT(in ) :: before
	759	!
[5656]	760	!!----------------------------------------------------------------------
	761	!
	762	IF( before) THEN
[12377]	763	ptab(i1:i2,j1:j2) = ssh(i1:i2,j1:j2,Kmm_a)
[5656]	764	ELSE
[12377]	765	hbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
[5656]	766	ENDIF
	767	!
	768	END SUBROUTINE interpsshn
	769
[12377]	770	SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
[6140]	771	!!----------------------------------------------------------------------
[9019]	772	!! * ROUTINE interpun *
[9031]	773	!!---------------------------------------------
	774	!!
	775	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
	776	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
	777	LOGICAL, INTENT(in) :: before
	778	!!
	779	INTEGER :: ji,jj,jk
[12377]	780	REAL(wp) :: zrhoy, zhtot
[9031]	781	! vertical interpolation:
	782	REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
	783	REAL(wp), DIMENSION(1:jpk) :: h_out
[12377]	784	INTEGER :: N_in, N_out
[9031]	785	REAL(wp) :: h_diff
	786	!!---------------------------------------------
[5656]	787	!
[9031]	788	IF (before) THEN
	789	DO jk=1,jpk
	790	DO jj=j1,j2
	791	DO ji=i1,i2
[12377]	792	ptab(ji,jj,jk,1) = (e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * uu(ji,jj,jk,Kmm_a)*umask(ji,jj,jk))
[9031]	793	# if defined key_vertical
[12377]	794	! Interpolate thicknesses (masked for subsequent extrapolation)
	795	ptab(ji,jj,jk,2) = umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a)
[9031]	796	# endif
	797	END DO
	798	END DO
[5656]	799	END DO
[12377]	800	# if defined key_vertical
	801	! Extrapolate thicknesses in partial bottom cells:
	802	! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
	803	IF (ln_zps) THEN
	804	DO jj=j1,j2
	805	DO ji=i1,i2
	806	jk = mbku(ji,jj)
	807	ptab(ji,jj,jk,2) = 0._wp
	808	END DO
	809	END DO
	810	END IF
	811	! Save ssh at last level:
	812	ptab(i1:i2,j1:j2,k2,2) = 0._wp
	813	IF (.NOT.ln_linssh) THEN
	814	! This vertical sum below should be replaced by the sea-level at U-points (optimization):
	815	DO jk=1,jpk
	816	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)
	817	END DO
	818	ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hu_0(i1:i2,j1:j2)
	819	END IF
	820	# endif
	821	!
[5656]	822	ELSE
[9031]	823	zrhoy = Agrif_rhoy()
	824	# if defined key_vertical
	825	! VERTICAL REFINEMENT BEGIN
	826
[12377]	827	IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
	828
[9031]	829	DO ji=i1,i2
	830	DO jj=j1,j2
[12377]	831	uu(ji,jj,:,Krhs_a) = 0._wp
	832	N_in = mbku_parent(ji,jj)
	833	zhtot = 0._wp
	834	DO jk=1,N_in
	835	IF (jk==N_in) THEN
	836	h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
	837	ELSE
	838	h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy)
	839	ENDIF
	840	zhtot = zhtot + h_in(jk)
	841	tabin(jk) = ptab(ji,jj,jk,1)/(e2u(ji,jj)zrhoyh_in(jk))
[9031]	842	ENDDO
[12377]	843
[9031]	844	N_out = 0
	845	DO jk=1,jpk
[12377]	846	if (umask(ji,jj,jk) == 0) EXIT
[9031]	847	N_out = N_out + 1
[12377]	848	h_out(N_out) = e3u(ji,jj,jk,Krhs_a)
[9031]	849	ENDDO
[12377]	850	IF (N_in*N_out > 0) THEN
	851	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)
[9031]	852	ENDIF
	853	ENDDO
	854	ENDDO
	855
	856	# else
[6140]	857	DO jk = 1, jpkm1
[5656]	858	DO jj=j1,j2
[12377]	859	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) )
[5656]	860	END DO
	861	END DO
[9031]	862	# endif
	863
[5656]	864	ENDIF
	865	!
	866	END SUBROUTINE interpun
	867
[12377]	868	SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
[6140]	869	!!----------------------------------------------------------------------
[9019]	870	!! * ROUTINE interpvn *
[6140]	871	!!----------------------------------------------------------------------
[5656]	872	!
[9031]	873	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
	874	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
	875	LOGICAL, INTENT(in) :: before
	876	!
	877	INTEGER :: ji,jj,jk
	878	REAL(wp) :: zrhox
	879	! vertical interpolation:
	880	REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
	881	REAL(wp), DIMENSION(1:jpk) :: h_out
[12377]	882	INTEGER :: N_in, N_out
	883	REAL(wp) :: h_diff, zhtot
[9031]	884	!!---------------------------------------------
[5656]	885	!
[9031]	886	IF (before) THEN
	887	DO jk=k1,k2
	888	DO jj=j1,j2
	889	DO ji=i1,i2
[12377]	890	ptab(ji,jj,jk,1) = (e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vv(ji,jj,jk,Kmm_a)*vmask(ji,jj,jk))
[9031]	891	# if defined key_vertical
[12377]	892	! Interpolate thicknesses (masked for subsequent extrapolation)
	893	ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a)
[9031]	894	# endif
	895	END DO
	896	END DO
[5656]	897	END DO
[12377]	898	# if defined key_vertical
	899	! Extrapolate thicknesses in partial bottom cells:
	900	! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
	901	IF (ln_zps) THEN
	902	DO jj=j1,j2
	903	DO ji=i1,i2
	904	jk = mbkv(ji,jj)
	905	ptab(ji,jj,jk,2) = 0._wp
	906	END DO
	907	END DO
	908	END IF
	909	! Save ssh at last level:
	910	ptab(i1:i2,j1:j2,k2,2) = 0._wp
	911	IF (.NOT.ln_linssh) THEN
	912	! This vertical sum below should be replaced by the sea-level at V-points (optimization):
	913	DO jk=1,jpk
	914	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)
	915	END DO
	916	ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hv_0(i1:i2,j1:j2)
	917	END IF
	918	# endif
[9031]	919	ELSE
	920	zrhox = Agrif_rhox()
	921	# if defined key_vertical
	922
[12377]	923	IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
[9031]	924
	925	DO jj=j1,j2
	926	DO ji=i1,i2
[12377]	927	vv(ji,jj,:,Krhs_a) = 0._wp
	928	N_in = mbkv_parent(ji,jj)
	929	zhtot = 0._wp
	930	DO jk=1,N_in
	931	IF (jk==N_in) THEN
	932	h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
	933	ELSE
	934	h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox)
	935	ENDIF
	936	zhtot = zhtot + h_in(jk)
	937	tabin(jk) = ptab(ji,jj,jk,1)/(e1v(ji,jj)zrhoxh_in(jk))
	938	ENDDO
[9031]	939
	940	N_out = 0
	941	DO jk=1,jpk
[12377]	942	if (vmask(ji,jj,jk) == 0) EXIT
[9031]	943	N_out = N_out + 1
[12377]	944	h_out(N_out) = e3v(ji,jj,jk,Krhs_a)
[9031]	945	END DO
[12377]	946	IF (N_in*N_out > 0) THEN
	947	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)
[9031]	948	ENDIF
	949	END DO
	950	END DO
	951	# else
[6140]	952	DO jk = 1, jpkm1
[12377]	953	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) )
[5656]	954	END DO
[9031]	955	# endif
[5656]	956	ENDIF
	957	!
	958	END SUBROUTINE interpvn
[636]	959
[12377]	960	SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before)
[1605]	961	!!----------------------------------------------------------------------
[5656]	962	!! * ROUTINE interpunb *
[1605]	963	!!----------------------------------------------------------------------
[6140]	964	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	965	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	966	LOGICAL , INTENT(in ) :: before
	967	!
	968	INTEGER :: ji, jj
	969	REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff
[1605]	970	!!----------------------------------------------------------------------
[5656]	971	!
[6140]	972	IF( before ) THEN
[12377]	973	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]	974	ELSE
	975	zrhoy = Agrif_Rhoy()
	976	zrhot = Agrif_rhot()
	977	! Time indexes bounds for integration
	978	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
	979	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
[12377]	980	!
	981	DO ji = i1, i2
	982	DO jj = j1, j2
	983	IF ( utint_stage(ji,jj) < (bdy_tinterp + 1) ) THEN
	984	IF ( utint_stage(ji,jj) == 1 ) THEN
	985	ztcoeff = zrhot * ( zt1*2._wp ( zt1 - 1._wp) &
	986	& - zt0*2._wp ( zt0 - 1._wp) )
	987	ELSEIF( utint_stage(ji,jj) == 2 ) THEN
	988	ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &
	989	& - zt0 * ( zt0 - 1._wp)**2._wp )
	990	ELSEIF( utint_stage(ji,jj) == 0 ) THEN
	991	ztcoeff = 1._wp
	992	ELSE
	993	ztcoeff = 0._wp
	994	ENDIF
	995	!
	996	ubdy(ji,jj) = ubdy(ji,jj) + ztcoeff * ptab(ji,jj)
	997	!
	998	IF (( utint_stage(ji,jj) == 2 ).OR.( utint_stage(ji,jj) == 0 )) THEN
	999	ubdy(ji,jj) = ubdy(ji,jj) / (zrhoye2u(ji,jj)) umask(ji,jj,1)
	1000	ENDIF
	1001	!
	1002	utint_stage(ji,jj) = utint_stage(ji,jj) + 1
	1003	ENDIF
	1004	END DO
	1005	END DO
	1006	END IF
[5656]	1007	!
	1008	END SUBROUTINE interpunb
[636]	1009
[6140]	1010
[12377]	1011	SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before )
[1605]	1012	!!----------------------------------------------------------------------
[5656]	1013	!! * ROUTINE interpvnb *
[1605]	1014	!!----------------------------------------------------------------------
[6140]	1015	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1016	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1017	LOGICAL , INTENT(in ) :: before
	1018	!
[12377]	1019	INTEGER :: ji, jj
[6140]	1020	REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff
[1605]	1021	!!----------------------------------------------------------------------
[5656]	1022	!
[6140]	1023	IF( before ) THEN
[12377]	1024	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]	1025	ELSE
	1026	zrhox = Agrif_Rhox()
	1027	zrhot = Agrif_rhot()
	1028	! Time indexes bounds for integration
	1029	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
[12377]	1030	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
	1031	!
	1032	DO ji = i1, i2
	1033	DO jj = j1, j2
	1034	IF ( vtint_stage(ji,jj) < (bdy_tinterp + 1) ) THEN
	1035	IF ( vtint_stage(ji,jj) == 1 ) THEN
	1036	ztcoeff = zrhot * ( zt1*2._wp ( zt1 - 1._wp) &
	1037	& - zt0*2._wp ( zt0 - 1._wp) )
	1038	ELSEIF( vtint_stage(ji,jj) == 2 ) THEN
	1039	ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &
	1040	& - zt0 * ( zt0 - 1._wp)**2._wp )
	1041	ELSEIF( vtint_stage(ji,jj) == 0 ) THEN
	1042	ztcoeff = 1._wp
	1043	ELSE
	1044	ztcoeff = 0._wp
	1045	ENDIF
	1046	!
	1047	vbdy(ji,jj) = vbdy(ji,jj) + ztcoeff * ptab(ji,jj)
	1048	!
	1049	IF (( vtint_stage(ji,jj) == 2 ).OR.( vtint_stage(ji,jj) == 0 )) THEN
	1050	vbdy(ji,jj) = vbdy(ji,jj) / (zrhoxe1v(ji,jj)) vmask(ji,jj,1)
	1051	ENDIF
	1052	!
	1053	vtint_stage(ji,jj) = vtint_stage(ji,jj) + 1
	1054	ENDIF
	1055	END DO
	1056	END DO
[5656]	1057	ENDIF
	1058	!
	1059	END SUBROUTINE interpvnb
[390]	1060
[6140]	1061
[12377]	1062	SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before )
[1605]	1063	!!----------------------------------------------------------------------
[5656]	1064	!! * ROUTINE interpub2b *
[1605]	1065	!!----------------------------------------------------------------------
[6140]	1066	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1067	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1068	LOGICAL , INTENT(in ) :: before
	1069	!
	1070	INTEGER :: ji,jj
[12377]	1071	REAL(wp) :: zrhot, zt0, zt1, zat
[1605]	1072	!!----------------------------------------------------------------------
[5656]	1073	IF( before ) THEN
[9031]	1074	IF ( ln_bt_fw ) THEN
	1075	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
	1076	ELSE
	1077	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2)
	1078	ENDIF
[5656]	1079	ELSE
	1080	zrhot = Agrif_rhot()
	1081	! Time indexes bounds for integration
	1082	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
	1083	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
	1084	! Polynomial interpolation coefficients:
[6140]	1085	zat = zrhot * ( zt1*2._wp (-2._wp*zt1 + 3._wp) &
	1086	& - zt0*2._wp (-2._wp*zt0 + 3._wp) )
[12377]	1087	!
	1088	ubdy(i1:i2,j1:j2) = zat * ptab(i1:i2,j1:j2)
	1089	!
	1090	! Update interpolation stage:
	1091	utint_stage(i1:i2,j1:j2) = 1
[5656]	1092	ENDIF
	1093	!
	1094	END SUBROUTINE interpub2b
[6140]	1095
[636]	1096
[12377]	1097	SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before )
[4292]	1098	!!----------------------------------------------------------------------
[5656]	1099	!! * ROUTINE interpvb2b *
[4292]	1100	!!----------------------------------------------------------------------
[6140]	1101	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1102	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1103	LOGICAL , INTENT(in ) :: before
	1104	!
	1105	INTEGER :: ji,jj
[12377]	1106	REAL(wp) :: zrhot, zt0, zt1, zat
[4292]	1107	!!----------------------------------------------------------------------
[5656]	1108	!
	1109	IF( before ) THEN
[9031]	1110	IF ( ln_bt_fw ) THEN
	1111	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
	1112	ELSE
	1113	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2)
	1114	ENDIF
[5656]	1115	ELSE
	1116	zrhot = Agrif_rhot()
	1117	! Time indexes bounds for integration
	1118	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
	1119	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
	1120	! Polynomial interpolation coefficients:
[6140]	1121	zat = zrhot * ( zt1*2._wp (-2._wp*zt1 + 3._wp) &
	1122	& - zt0*2._wp (-2._wp*zt0 + 3._wp) )
[5656]	1123	!
[12377]	1124	vbdy(i1:i2,j1:j2) = zat * ptab(i1:i2,j1:j2)
	1125	!
	1126	! update interpolation stage:
	1127	vtint_stage(i1:i2,j1:j2) = 1
[5656]	1128	ENDIF
	1129	!
	1130	END SUBROUTINE interpvb2b
[4292]	1131
[6140]	1132
[12377]	1133	SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before )
[5656]	1134	!!----------------------------------------------------------------------
	1135	!! * ROUTINE interpe3t *
	1136	!!----------------------------------------------------------------------
[6140]	1137	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
[5656]	1138	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
[6140]	1139	LOGICAL , INTENT(in ) :: before
[5656]	1140	!
	1141	INTEGER :: ji, jj, jk
	1142	!!----------------------------------------------------------------------
	1143	!
[6140]	1144	IF( before ) THEN
	1145	ptab(i1:i2,j1:j2,k1:k2) = tmask(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2)
[5656]	1146	ELSE
[9019]	1147	!
[6140]	1148	DO jk = k1, k2
	1149	DO jj = j1, j2
	1150	DO ji = i1, i2
[9019]	1151	IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) ) > 1.D-2) THEN
[12377]	1152	WRITE(numout,*) ' Agrif error for e3t_0: parent , child, i, j, k ', &
	1153	& ptab(ji,jj,jk), tmask(ji,jj,jk) * e3t_0(ji,jj,jk), &
	1154	& ji+nimpp-1, jj+njmpp-1, jk
	1155	kindic_agr = kindic_agr + 1
[5656]	1156	ENDIF
	1157	END DO
	1158	END DO
	1159	END DO
[6140]	1160	!
[5656]	1161	ENDIF
	1162	!
	1163	END SUBROUTINE interpe3t
	1164
[6140]	1165
[9031]	1166	SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
[4486]	1167	!!----------------------------------------------------------------------
[5656]	1168	!! * ROUTINE interavm *
[4486]	1169	!!----------------------------------------------------------------------
[9116]	1170	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, m1, m2
[9031]	1171	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
[9116]	1172	LOGICAL , INTENT(in ) :: before
[12377]	1173	!
	1174	INTEGER :: ji, jj, jk
	1175	INTEGER :: N_in, N_out
	1176	REAL(wp), DIMENSION(k1:k2) :: tabin, z_in
	1177	REAL(wp), DIMENSION(1:jpk) :: z_out
[4486]	1178	!!----------------------------------------------------------------------
[5656]	1179	!
[9031]	1180	IF (before) THEN
	1181	DO jk=k1,k2
	1182	DO jj=j1,j2
	1183	DO ji=i1,i2
	1184	ptab(ji,jj,jk,1) = avm_k(ji,jj,jk)
	1185	END DO
	1186	END DO
	1187	END DO
[12377]	1188
	1189	# if defined key_vertical
	1190	! Interpolate thicknesses
	1191	! Warning: these are masked, hence extrapolated prior interpolation.
[9031]	1192	DO jk=k1,k2
	1193	DO jj=j1,j2
	1194	DO ji=i1,i2
[12377]	1195	ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a)
[9031]	1196	END DO
	1197	END DO
	1198	END DO
[12377]	1199
	1200	! Extrapolate thicknesses in partial bottom cells:
	1201	! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
	1202	IF (ln_zps) THEN
	1203	DO jj=j1,j2
	1204	DO ji=i1,i2
	1205	jk = mbkt(ji,jj)
	1206	ptab(ji,jj,jk,2) = 0._wp
	1207	END DO
	1208	END DO
	1209	END IF
	1210
	1211	! Save ssh at last level:
	1212	IF (.NOT.ln_linssh) THEN
	1213	ptab(i1:i2,j1:j2,k2,2) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1)
	1214	ELSE
	1215	ptab(i1:i2,j1:j2,k2,2) = 0._wp
	1216	END IF
	1217	# endif
[9031]	1218	ELSE
	1219	#ifdef key_vertical
[12377]	1220	IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
	1221	avm_k(i1:i2,j1:j2,k1:k2) = 0._wp
	1222
	1223	DO jj = j1, j2
	1224	DO ji =i1, i2
	1225	N_in = mbkt_parent(ji,jj)
	1226	IF ( tmask(ji,jj,1) == 0._wp) N_in = 0
	1227	z_in(N_in+1) = ht0_parent(ji,jj) + ptab(ji,jj,k2,2)
	1228	DO jk = N_in, 1, -1 ! Parent vertical grid
	1229	z_in(jk) = z_in(jk+1) - ptab(ji,jj,jk,2)
	1230	tabin(jk) = ptab(ji,jj,jk,1)
[9031]	1231	END DO
[12377]	1232	N_out = mbkt(ji,jj)
	1233	DO jk = 1, N_out ! Child vertical grid
	1234	z_out(jk) = gdepw(ji,jj,jk,Kmm_a)
[9031]	1235	ENDDO
[12377]	1236	IF (N_in*N_out > 0) THEN
	1237	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)
[9031]	1238	ENDIF
	1239	ENDDO
	1240	ENDDO
	1241	#else
	1242	avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1)
	1243	#endif
[5656]	1244	ENDIF
	1245	!
	1246	END SUBROUTINE interpavm
[4486]	1247
[12377]	1248	# if defined key_vertical
	1249	SUBROUTINE interpmbkt( ptab, i1, i2, j1, j2, before )
	1250	!!----------------------------------------------------------------------
	1251	!! * ROUTINE interpsshn *
	1252	!!----------------------------------------------------------------------
	1253	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1254	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1255	LOGICAL , INTENT(in ) :: before
	1256	!
	1257	!!----------------------------------------------------------------------
	1258	!
	1259	IF( before) THEN
	1260	ptab(i1:i2,j1:j2) = REAL(mbkt(i1:i2,j1:j2),wp)
	1261	ELSE
	1262	mbkt_parent(i1:i2,j1:j2) = NINT(ptab(i1:i2,j1:j2))
	1263	ENDIF
	1264	!
	1265	END SUBROUTINE interpmbkt
	1266
	1267	SUBROUTINE interpht0( ptab, i1, i2, j1, j2, before )
	1268	!!----------------------------------------------------------------------
	1269	!! * ROUTINE interpsshn *
	1270	!!----------------------------------------------------------------------
	1271	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1272	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1273	LOGICAL , INTENT(in ) :: before
	1274	!
	1275	!!----------------------------------------------------------------------
	1276	!
	1277	IF( before) THEN
	1278	ptab(i1:i2,j1:j2) = ht_0(i1:i2,j1:j2)
	1279	ELSE
	1280	ht0_parent(i1:i2,j1:j2) = ptab(i1:i2,j1:j2)
	1281	ENDIF
	1282	!
	1283	END SUBROUTINE interpht0
	1284	#endif
	1285
[390]	1286	#else
[1605]	1287	!!----------------------------------------------------------------------
	1288	!! Empty module no AGRIF zoom
	1289	!!----------------------------------------------------------------------
[636]	1290	CONTAINS
[9570]	1291	SUBROUTINE Agrif_OCE_Interp_empty
	1292	WRITE(,) 'agrif_oce_interp : You should not have seen this print! error?'
	1293	END SUBROUTINE Agrif_OCE_Interp_empty
[390]	1294	#endif
[1605]	1295
	1296	!!======================================================================
[9570]	1297	END MODULE agrif_oce_interp

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

New URL for NEMO forge! http://forge.nemo-ocean.eu

Context Navigation

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

Download in other formats: