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

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

agrif_oce_interp.F90 in NEMO/branches/2019/dev_r11233_AGRIF-05_jchanut_vert_coord_interp/src/NST – NEMO

Context Navigation

source: NEMO/branches/2019/dev_r11233_AGRIF-05_jchanut_vert_coord_interp/src/NST/agrif_oce_interp.F90 @ 11590

Last change on this file since 11590 was 11590, checked in by jchanut, 5 years ago
#2222: 1) create remapping module (vremap) and integration of D. Engwirda piecewise polynomial recontruction package (PPR_LIB cpp key). 2) Various bug corrections with key_vertical activated.
Property svn:keywords set to `Id`
File size: 45.0 KB

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

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

Download in other formats: