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_opa_interp.F90 in branches/2017/dev_r8624_AGRIF3_VVL/NEMOGCM/NEMO/NST_SRC – NEMO

Context Navigation

source: branches/2017/dev_r8624_AGRIF3_VVL/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90 @ 8741

Last change on this file since 8741 was 8741, checked in by jchanut, 6 years ago
AGRIF + vvl Main changes - #1965
Property svn:keywords set to `Id`
File size: 47.8 KB

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

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

Download in other formats: