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/2016/dev_INGV_UKMO_2016/NEMOGCM/NEMO/NST_SRC – NEMO

Context Navigation

source: branches/2016/dev_INGV_UKMO_2016/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90 @ 7351

Last change on this file since 7351 was 7351, checked in by emanuelaclementi, 7 years ago
ticket #1805 step 3: /2016/dev_INGV_UKMO_2016 aligned to the trunk at revision 7161
Property svn:keywords set to `Id`
File size: 47.5 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	!!----------------------------------------------------------------------
[2528]	11	#if defined key_agrif && ! defined key_offline
[1605]	12	!!----------------------------------------------------------------------
	13	!! 'key_agrif' AGRIF zoom
[2528]	14	!! NOT 'key_offline' NO off-line tracers
[1605]	15	!!----------------------------------------------------------------------
	16	!! Agrif_tra :
	17	!! Agrif_dyn :
	18	!! interpu :
	19	!! interpv :
	20	!!----------------------------------------------------------------------
[636]	21	USE par_oce
	22	USE oce
	23	USE dom_oce
[7351]	24	USE zdf_oce
[782]	25	USE agrif_oce
[1605]	26	USE phycst
[7351]	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
	41	# if defined key_zdftke
	42	PUBLIC Agrif_tke, interpavm
	43	# endif
[390]	44
[7351]	45	INTEGER :: bdy_tinterp = 0
	46
[1605]	47	# include "vectopt_loop_substitute.h90"
[1156]	48	!!----------------------------------------------------------------------
[7351]	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
[7351]	61	!
	62	Agrif_SpecialValue = 0._wp
[636]	63	Agrif_UseSpecialValue = .TRUE.
[7351]	64	!
[5656]	65	CALL Agrif_Bc_variable( tsn_id, procname=interptsn )
[7351]	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
[7351]	77	!
	78	INTEGER :: ji, jj, jk ! dummy loop indices
	79	INTEGER :: j1, j2, i1, i2
	80	REAL(wp), POINTER, DIMENSION(:,:) :: zub, zvb
[1605]	81	!!----------------------------------------------------------------------
[7351]	82	!
[1605]	83	IF( Agrif_Root() ) RETURN
[7351]	84	!
	85	CALL wrk_alloc( jpi,jpj, zub, zvb )
	86	!
	87	Agrif_SpecialValue = 0._wp
[5656]	88	Agrif_UseSpecialValue = ln_spc_dyn
[7351]	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.
[7351]	94	!
[5656]	95	! prevent smoothing in ghost cells
[7351]	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
[7351]	103	IF( nbondi == -1 .OR. nbondi == 2 ) THEN
	104	!
[5930]	105	! Smoothing
	106	! ---------
[7351]	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
[7351]	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
[7351]	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
[7351]	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
[7351]	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	!-----------------------------------------------------
[7351]	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
[7351]	151	DO jj = 1, jpj
	152	zvb(2,jj) = zvb(2,jj) * r1_hv_a(2,jj)
[4486]	153	END DO
[7351]	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
[7351]	160	!
[5930]	161	! Mask domain edges:
	162	!-------------------
[7351]	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
[7351]	169	!
[636]	170	ENDIF
[390]	171
[7351]	172	IF( nbondi == 1 .OR. nbondi == 2 ) THEN
[5930]	173
	174	! Smoothing
	175	! ---------
[7351]	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
[7351]	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
[7351]	184	ua_b(nlci-2,jj) = ua_b(nlci-2,jj) * r1_hu_a(nlci-2,jj)
[5930]	185	END DO
	186	ENDIF
	187
[7351]	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
[7351]	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
[7351]	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
[7351]	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
[7351]	210	!
[4486]	211	! Set tangential velocities to time splitting estimate
[5930]	212	!-----------------------------------------------------
[7351]	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
[7351]	221	zvb(nlci-1,jj) = zvb(nlci-1,jj) * r1_hv_a(nlci-1,jj)
[4486]	222	END DO
[7351]	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
[7351]	229	!
[5930]	230	! Mask domain edges:
	231	!-------------------
[7351]	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
[7351]	238	!
[636]	239	ENDIF
[390]	240
[7351]	241	IF( nbondj == -1 .OR. nbondj == 2 ) THEN
[390]	242
[5930]	243	! Smoothing
	244	! ---------
[7351]	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
[7351]	253	va_b(ji,2) = va_b(ji,2) * r1_hv_a(ji,2)
[636]	254	END DO
[5930]	255	ENDIF
[7351]	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
[7351]	263	!
	264	zvb(:,2) = 0._wp ! Correct transport
[636]	265	DO jk=1,jpkm1
	266	DO ji=1,jpi
[7351]	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
[7351]	270	DO ji = 1, jpi
	271	zvb(ji,2) = zvb(ji,2) * r1_hv_a(ji,2)
[636]	272	END DO
[7351]	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	!-----------------------------------------------------
[7351]	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
[7351]	288	DO ji = 1, jpi
	289	zub(ji,2) = zub(ji,2) * r1_hu_a(ji,2)
[4486]	290	END DO
	291
[7351]	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	!-------------------
[7351]	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
[7351]	310	IF( nbondj == 1 .OR. nbondj == 2 ) THEN
	311	!
[5930]	312	! Smoothing
	313	! ---------
[7351]	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
[7351]	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
[7351]	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
[7351]	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
[7351]	339	DO ji = 1, jpi
	340	zvb(ji,nlcj-2) = zvb(ji,nlcj-2) * r1_hv_a(ji,nlcj-2)
[636]	341	END DO
[7351]	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
[7351]	347	!
[4486]	348	! Set tangential velocities to time splitting estimate
[5930]	349	!-----------------------------------------------------
[7351]	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
[7351]	357	DO ji = 1, jpi
	358	zub(ji,nlcj-1) = zub(ji,nlcj-1) * r1_hu_a(ji,nlcj-1)
[4486]	359	END DO
[7351]	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
[7351]	367	!
[5930]	368	! Mask domain edges:
	369	!-------------------
[7351]	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
[7351]	376	!
[636]	377	ENDIF
[2715]	378	!
[7351]	379	CALL wrk_dealloc( jpi,jpj, zub, zvb )
[2715]	380	!
[636]	381	END SUBROUTINE Agrif_dyn
[390]	382
[7351]	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	!!----------------------------------------------------------------------
[7351]	393	!
[4486]	394	IF( Agrif_Root() ) RETURN
[7351]	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
[7351]	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
[7351]	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
[7351]	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
[7351]	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
[5656]	452	REAL(wp) :: zrhot, zt
[4292]	453	!!----------------------------------------------------------------------
[7351]	454	!
[4292]	455	IF( Agrif_Root() ) RETURN
[7351]	456	!
	457	ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only
	458	!
[4486]	459	zrhot = Agrif_rhot()
[7351]	460	!
[4486]	461	! "Central" time index for interpolation:
[7351]	462	IF( ln_bt_fw ) THEN
	463	zt = REAL( Agrif_NbStepint()+0.5_wp, wp ) / zrhot
[4486]	464	ELSE
[7351]	465	zt = REAL( Agrif_NbStepint() , wp ) / zrhot
[4486]	466	ENDIF
[7351]	467	!
[4486]	468	! Linear interpolation of sea level
[7351]	469	Agrif_SpecialValue = 0._wp
[4486]	470	Agrif_UseSpecialValue = .TRUE.
[7351]	471	CALL Agrif_Bc_variable( sshn_id, calledweight=zt, procname=interpsshn )
[4486]	472	Agrif_UseSpecialValue = .FALSE.
[7351]	473	!
[4486]	474	! Interpolate barotropic fluxes
	475	Agrif_SpecialValue=0.
	476	Agrif_UseSpecialValue = ln_spc_dyn
[7351]	477	!
	478	IF( ll_int_cons ) THEN ! Conservative interpolation
[5656]	479	! orders matters here !!!!!!
[7351]	480	CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated
	481	CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b )
[5656]	482	bdy_tinterp = 1
[7351]	483	CALL Agrif_Bc_variable( unb_id , calledweight=1._wp, procname=interpunb ) ! After
	484	CALL Agrif_Bc_variable( vnb_id , calledweight=1._wp, procname=interpvnb )
[5656]	485	bdy_tinterp = 2
[7351]	486	CALL Agrif_Bc_variable( unb_id , calledweight=0._wp, procname=interpunb ) ! Before
	487	CALL Agrif_Bc_variable( vnb_id , calledweight=0._wp, procname=interpvnb )
[4486]	488	ELSE ! Linear interpolation
[5656]	489	bdy_tinterp = 0
[7351]	490	ubdy_w(:) = 0._wp ; vbdy_w(:) = 0._wp
	491	ubdy_e(:) = 0._wp ; vbdy_e(:) = 0._wp
	492	ubdy_n(:) = 0._wp ; vbdy_n(:) = 0._wp
	493	ubdy_s(:) = 0._wp ; vbdy_s(:) = 0._wp
	494	CALL Agrif_Bc_variable( unb_id, calledweight=zt, procname=interpunb )
	495	CALL Agrif_Bc_variable( vnb_id, calledweight=zt, procname=interpvnb )
[4486]	496	ENDIF
	497	Agrif_UseSpecialValue = .FALSE.
[5656]	498	!
[4486]	499	END SUBROUTINE Agrif_dta_ts
	500
[7351]	501
[2486]	502	SUBROUTINE Agrif_ssh( kt )
	503	!!----------------------------------------------------------------------
[2528]	504	!! * ROUTINE Agrif_DYN *
[2486]	505	!!----------------------------------------------------------------------
	506	INTEGER, INTENT(in) :: kt
	507	!!
	508	!!----------------------------------------------------------------------
[7351]	509	!
[2486]	510	IF( Agrif_Root() ) RETURN
[7351]	511	!
[2486]	512	IF((nbondi == -1).OR.(nbondi == 2)) THEN
	513	ssha(2,:)=ssha(3,:)
	514	sshn(2,:)=sshn(3,:)
	515	ENDIF
[7351]	516	!
[2486]	517	IF((nbondi == 1).OR.(nbondi == 2)) THEN
	518	ssha(nlci-1,:)=ssha(nlci-2,:)
[5656]	519	sshn(nlci-1,:)=sshn(nlci-2,:)
[2486]	520	ENDIF
[7351]	521	!
[2486]	522	IF((nbondj == -1).OR.(nbondj == 2)) THEN
[4292]	523	ssha(:,2)=ssha(:,3)
	524	sshn(:,2)=sshn(:,3)
[2486]	525	ENDIF
[7351]	526	!
[2486]	527	IF((nbondj == 1).OR.(nbondj == 2)) THEN
	528	ssha(:,nlcj-1)=ssha(:,nlcj-2)
[5656]	529	sshn(:,nlcj-1)=sshn(:,nlcj-2)
[2486]	530	ENDIF
[7351]	531	!
[2486]	532	END SUBROUTINE Agrif_ssh
	533
[7351]	534
[4486]	535	SUBROUTINE Agrif_ssh_ts( jn )
[4292]	536	!!----------------------------------------------------------------------
	537	!! * ROUTINE Agrif_ssh_ts *
	538	!!----------------------------------------------------------------------
[4486]	539	INTEGER, INTENT(in) :: jn
[4292]	540	!!
[4486]	541	INTEGER :: ji,jj
[4292]	542	!!----------------------------------------------------------------------
[7351]	543	!
[4292]	544	IF((nbondi == -1).OR.(nbondi == 2)) THEN
[7351]	545	DO jj = 1, jpj
[4486]	546	ssha_e(2,jj) = hbdy_w(jj)
	547	END DO
[4292]	548	ENDIF
[7351]	549	!
[4292]	550	IF((nbondi == 1).OR.(nbondi == 2)) THEN
[7351]	551	DO jj = 1, jpj
[4486]	552	ssha_e(nlci-1,jj) = hbdy_e(jj)
	553	END DO
[4292]	554	ENDIF
[7351]	555	!
[4292]	556	IF((nbondj == -1).OR.(nbondj == 2)) THEN
[7351]	557	DO ji = 1, jpi
[4486]	558	ssha_e(ji,2) = hbdy_s(ji)
	559	END DO
[4292]	560	ENDIF
[7351]	561	!
[4292]	562	IF((nbondj == 1).OR.(nbondj == 2)) THEN
[7351]	563	DO ji = 1, jpi
[4486]	564	ssha_e(ji,nlcj-1) = hbdy_n(ji)
	565	END DO
[4292]	566	ENDIF
[7351]	567	!
[4292]	568	END SUBROUTINE Agrif_ssh_ts
	569
[5656]	570	# if defined key_zdftke
[7351]	571
[5656]	572	SUBROUTINE Agrif_tke
[4292]	573	!!----------------------------------------------------------------------
[5656]	574	!! * ROUTINE Agrif_tke *
	575	!!----------------------------------------------------------------------
	576	REAL(wp) :: zalpha
[7351]	577	!!----------------------------------------------------------------------
[5656]	578	!
	579	zalpha = REAL( Agrif_NbStepint() + Agrif_IRhot() - 1, wp ) / REAL( Agrif_IRhot(), wp )
	580	IF( zalpha > 1. ) zalpha = 1.
[7351]	581	!
[5656]	582	Agrif_SpecialValue = 0.e0
	583	Agrif_UseSpecialValue = .TRUE.
[7351]	584	!
[5656]	585	CALL Agrif_Bc_variable(avm_id ,calledweight=zalpha, procname=interpavm)
[7351]	586	!
[5656]	587	Agrif_UseSpecialValue = .FALSE.
	588	!
	589	END SUBROUTINE Agrif_tke
[7351]	590
[5656]	591	# endif
	592
[7351]	593	SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )
	594	!!----------------------------------------------------------------------
[5656]	595	!! * ROUTINE interptsn *
[7351]	596	!!----------------------------------------------------------------------
	597	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab
	598	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2
	599	LOGICAL , INTENT(in ) :: before
	600	INTEGER , INTENT(in ) :: nb , ndir
[5656]	601	!
	602	INTEGER :: ji, jj, jk, jn ! dummy loop indices
[7351]	603	INTEGER :: imin, imax, jmin, jmax
[5656]	604	REAL(wp) :: zrhox , zalpha1, zalpha2, zalpha3
	605	REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha7
[7351]	606	LOGICAL :: western_side, eastern_side,northern_side,southern_side
	607	!!----------------------------------------------------------------------
	608	!
[5656]	609	IF (before) THEN
	610	ptab(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2)
	611	ELSE
	612	!
	613	western_side = (nb == 1).AND.(ndir == 1)
	614	eastern_side = (nb == 1).AND.(ndir == 2)
	615	southern_side = (nb == 2).AND.(ndir == 1)
	616	northern_side = (nb == 2).AND.(ndir == 2)
	617	!
	618	zrhox = Agrif_Rhox()
	619	!
	620	zalpha1 = ( zrhox - 1. ) * 0.5
	621	zalpha2 = 1. - zalpha1
	622	!
	623	zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. )
	624	zalpha4 = 1. - zalpha3
	625	!
	626	zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )
	627	zalpha7 = - ( zrhox - 1. ) / ( zrhox + 3. )
	628	zalpha5 = 1. - zalpha6 - zalpha7
	629	!
	630	imin = i1
	631	imax = i2
	632	jmin = j1
	633	jmax = j2
	634	!
	635	! Remove CORNERS
	636	IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3
	637	IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2
	638	IF((nbondi == -1).OR.(nbondi == 2)) imin = 3
	639	IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2
	640	!
[7351]	641	IF( eastern_side ) THEN
[5656]	642	DO jn = 1, jpts
	643	tsa(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn)
	644	DO jk = 1, jpkm1
	645	DO jj = jmin,jmax
[7351]	646	IF( umask(nlci-2,jj,jk) == 0._wp ) THEN
[5656]	647	tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk)
	648	ELSE
	649	tsa(nlci-1,jj,jk,jn)=(zalpha4tsa(nlci,jj,jk,jn)+zalpha3tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk)
[7351]	650	IF( un(nlci-2,jj,jk) > 0._wp ) THEN
[5656]	651	tsa(nlci-1,jj,jk,jn)=( zalpha6tsa(nlci-2,jj,jk,jn)+zalpha5tsa(nlci,jj,jk,jn) &
	652	+ zalpha7tsa(nlci-3,jj,jk,jn) ) tmask(nlci-1,jj,jk)
	653	ENDIF
	654	ENDIF
	655	END DO
	656	END DO
[5930]	657	tsa(nlci,j1:j2,k1:k2,jn) = 0._wp
[7351]	658	END DO
[5656]	659	ENDIF
	660	!
	661	IF( northern_side ) THEN
	662	DO jn = 1, jpts
	663	tsa(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn)
	664	DO jk = 1, jpkm1
	665	DO ji = imin,imax
[7351]	666	IF( vmask(ji,nlcj-2,jk) == 0._wp ) THEN
[5656]	667	tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk)
	668	ELSE
	669	tsa(ji,nlcj-1,jk,jn)=(zalpha4tsa(ji,nlcj,jk,jn)+zalpha3tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)
[7351]	670	IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN
[5656]	671	tsa(ji,nlcj-1,jk,jn)=( zalpha6tsa(ji,nlcj-2,jk,jn)+zalpha5tsa(ji,nlcj,jk,jn) &
	672	+ zalpha7tsa(ji,nlcj-3,jk,jn) ) tmask(ji,nlcj-1,jk)
	673	ENDIF
	674	ENDIF
	675	END DO
	676	END DO
[5930]	677	tsa(i1:i2,nlcj,k1:k2,jn) = 0._wp
[7351]	678	END DO
[5656]	679	ENDIF
	680	!
[7351]	681	IF( western_side ) THEN
[5656]	682	DO jn = 1, jpts
	683	tsa(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn)
	684	DO jk = 1, jpkm1
	685	DO jj = jmin,jmax
[7351]	686	IF( umask(2,jj,jk) == 0._wp ) THEN
[5656]	687	tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk)
	688	ELSE
	689	tsa(2,jj,jk,jn)=(zalpha4tsa(1,jj,jk,jn)+zalpha3tsa(3,jj,jk,jn))*tmask(2,jj,jk)
[7351]	690	IF( un(2,jj,jk) < 0._wp ) THEN
[5656]	691	tsa(2,jj,jk,jn)=(zalpha6tsa(3,jj,jk,jn)+zalpha5tsa(1,jj,jk,jn)+zalpha7tsa(4,jj,jk,jn))tmask(2,jj,jk)
	692	ENDIF
	693	ENDIF
	694	END DO
	695	END DO
[5930]	696	tsa(1,j1:j2,k1:k2,jn) = 0._wp
[5656]	697	END DO
	698	ENDIF
	699	!
	700	IF( southern_side ) THEN
	701	DO jn = 1, jpts
	702	tsa(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn)
[7351]	703	DO jk = 1, jpk
[5656]	704	DO ji=imin,imax
[7351]	705	IF( vmask(ji,2,jk) == 0._wp ) THEN
[5656]	706	tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk)
	707	ELSE
	708	tsa(ji,2,jk,jn)=(zalpha4tsa(ji,1,jk,jn)+zalpha3tsa(ji,3,jk,jn))*tmask(ji,2,jk)
[7351]	709	IF( vn(ji,2,jk) < 0._wp ) THEN
[5656]	710	tsa(ji,2,jk,jn)=(zalpha6tsa(ji,3,jk,jn)+zalpha5tsa(ji,1,jk,jn)+zalpha7tsa(ji,4,jk,jn))tmask(ji,2,jk)
	711	ENDIF
	712	ENDIF
	713	END DO
	714	END DO
[5930]	715	tsa(i1:i2,1,k1:k2,jn) = 0._wp
[7351]	716	END DO
[5656]	717	ENDIF
	718	!
	719	! Treatment of corners
	720	!
	721	! East south
	722	IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN
	723	tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:)
	724	ENDIF
	725	! East north
	726	IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN
	727	tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:)
	728	ENDIF
	729	! West south
	730	IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN
	731	tsa(2,2,:,:) = ptab(2,2,:,:)
	732	ENDIF
	733	! West north
	734	IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN
	735	tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:)
	736	ENDIF
	737	!
	738	ENDIF
	739	!
	740	END SUBROUTINE interptsn
	741
[7351]	742
	743	SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before, nb, ndir )
[5656]	744	!!----------------------------------------------------------------------
[4292]	745	!! * ROUTINE interpsshn *
	746	!!----------------------------------------------------------------------
[7351]	747	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	748	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	749	LOGICAL , INTENT(in ) :: before
	750	INTEGER , INTENT(in ) :: nb , ndir
	751	!
[5656]	752	LOGICAL :: western_side, eastern_side,northern_side,southern_side
	753	!!----------------------------------------------------------------------
	754	!
	755	IF( before) THEN
	756	ptab(i1:i2,j1:j2) = sshn(i1:i2,j1:j2)
	757	ELSE
	758	western_side = (nb == 1).AND.(ndir == 1)
	759	eastern_side = (nb == 1).AND.(ndir == 2)
	760	southern_side = (nb == 2).AND.(ndir == 1)
	761	northern_side = (nb == 2).AND.(ndir == 2)
	762	IF(western_side) hbdy_w(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1)
	763	IF(eastern_side) hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1)
	764	IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1)
	765	IF(northern_side) hbdy_n(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1)
	766	ENDIF
	767	!
	768	END SUBROUTINE interpsshn
	769
[7351]	770
	771	SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, before )
	772	!!----------------------------------------------------------------------
[5656]	773	!! * ROUTINE interpun *
[7351]	774	!!----------------------------------------------------------------------
	775	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
	776	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
	777	LOGICAL , INTENT(in ) :: before
[5656]	778	!
[7351]	779	INTEGER :: ji, jj, jk
	780	REAL(wp) :: zrhoy
	781	!!----------------------------------------------------------------------
	782	!
	783	IF( before ) THEN
	784	DO jk = k1, jpk
	785	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]	786	END DO
	787	ELSE
	788	zrhoy = Agrif_Rhoy()
[7351]	789	DO jk = 1, jpkm1
[5656]	790	DO jj=j1,j2
[7351]	791	ua(i1:i2,jj,jk) = ptab(i1:i2,jj,jk) / ( zrhoy * e2u(i1:i2,jj) * e3u_n(i1:i2,jj,jk) )
[5656]	792	END DO
	793	END DO
	794	ENDIF
	795	!
	796	END SUBROUTINE interpun
	797
[7351]	798
	799	SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, before )
	800	!!----------------------------------------------------------------------
[5656]	801	!! * ROUTINE interpvn *
[7351]	802	!!----------------------------------------------------------------------
	803	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
	804	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
	805	LOGICAL , INTENT(in ) :: before
[5656]	806	!
[7351]	807	INTEGER :: ji, jj, jk
	808	REAL(wp) :: zrhox
	809	!!----------------------------------------------------------------------
[5656]	810	!
[7351]	811	IF( before ) THEN !interpv entre 1 et k2 et interpv2d en jpkp1
	812	DO jk = k1, jpk
	813	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]	814	END DO
	815	ELSE
	816	zrhox= Agrif_Rhox()
[7351]	817	DO jk = 1, jpkm1
	818	va(i1:i2,j1:j2,jk) = ptab(i1:i2,j1:j2,jk) / ( zrhox * e1v(i1:i2,j1:j2) * e3v_n(i1:i2,j1:j2,jk) )
[5656]	819	END DO
	820	ENDIF
	821	!
	822	END SUBROUTINE interpvn
[7351]	823
[636]	824
[7351]	825	SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before, nb, ndir )
[1605]	826	!!----------------------------------------------------------------------
[5656]	827	!! * ROUTINE interpunb *
[1605]	828	!!----------------------------------------------------------------------
[7351]	829	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	830	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	831	LOGICAL , INTENT(in ) :: before
	832	INTEGER , INTENT(in ) :: nb , ndir
	833	!
	834	INTEGER :: ji, jj
	835	REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff
	836	LOGICAL :: western_side, eastern_side,northern_side,southern_side
[1605]	837	!!----------------------------------------------------------------------
[5656]	838	!
[7351]	839	IF( before ) THEN
	840	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * hu_n(i1:i2,j1:j2) * un_b(i1:i2,j1:j2)
[5656]	841	ELSE
	842	western_side = (nb == 1).AND.(ndir == 1)
	843	eastern_side = (nb == 1).AND.(ndir == 2)
	844	southern_side = (nb == 2).AND.(ndir == 1)
	845	northern_side = (nb == 2).AND.(ndir == 2)
	846	zrhoy = Agrif_Rhoy()
	847	zrhot = Agrif_rhot()
	848	! Time indexes bounds for integration
	849	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
	850	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
	851	! Polynomial interpolation coefficients:
	852	IF( bdy_tinterp == 1 ) THEN
	853	ztcoeff = zrhot * ( zt1*2._wp ( zt1 - 1._wp) &
[7351]	854	& - zt0*2._wp ( zt0 - 1._wp) )
[5656]	855	ELSEIF( bdy_tinterp == 2 ) THEN
	856	ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &
[7351]	857	& - zt0 * ( zt0 - 1._wp)**2._wp )
[636]	858
[5656]	859	ELSE
	860	ztcoeff = 1
	861	ENDIF
	862	!
	863	IF(western_side) THEN
	864	ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)
	865	ENDIF
	866	IF(eastern_side) THEN
	867	ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)
	868	ENDIF
	869	IF(southern_side) THEN
	870	ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1)
	871	ENDIF
	872	IF(northern_side) THEN
	873	ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)
	874	ENDIF
	875	!
	876	IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN
	877	IF(western_side) THEN
[7351]	878	ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoye2u(i1,j1:j2)) umask(i1,j1:j2,1)
[5656]	879	ENDIF
	880	IF(eastern_side) THEN
[7351]	881	ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoye2u(i1,j1:j2)) umask(i1,j1:j2,1)
[5656]	882	ENDIF
	883	IF(southern_side) THEN
[7351]	884	ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoye2u(i1:i2,j1)) umask(i1:i2,j1,1)
[5656]	885	ENDIF
	886	IF(northern_side) THEN
[7351]	887	ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoye2u(i1:i2,j1)) umask(i1:i2,j1,1)
[5656]	888	ENDIF
	889	ENDIF
	890	ENDIF
	891	!
	892	END SUBROUTINE interpunb
[636]	893
[7351]	894
	895	SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before, nb, ndir )
[1605]	896	!!----------------------------------------------------------------------
[5656]	897	!! * ROUTINE interpvnb *
[1605]	898	!!----------------------------------------------------------------------
[7351]	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	INTEGER , INTENT(in ) :: nb , ndir
	903	!
	904	INTEGER :: ji,jj
	905	REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff
	906	LOGICAL :: western_side, eastern_side,northern_side,southern_side
[1605]	907	!!----------------------------------------------------------------------
[5656]	908	!
[7351]	909	IF( before ) THEN
	910	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * hv_n(i1:i2,j1:j2) * vn_b(i1:i2,j1:j2)
[5656]	911	ELSE
	912	western_side = (nb == 1).AND.(ndir == 1)
	913	eastern_side = (nb == 1).AND.(ndir == 2)
	914	southern_side = (nb == 2).AND.(ndir == 1)
	915	northern_side = (nb == 2).AND.(ndir == 2)
	916	zrhox = Agrif_Rhox()
	917	zrhot = Agrif_rhot()
	918	! Time indexes bounds for integration
	919	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
	920	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
	921	IF( bdy_tinterp == 1 ) THEN
	922	ztcoeff = zrhot * ( zt1*2._wp ( zt1 - 1._wp) &
[7351]	923	& - zt0*2._wp ( zt0 - 1._wp) )
[5656]	924	ELSEIF( bdy_tinterp == 2 ) THEN
	925	ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &
[7351]	926	& - zt0 * ( zt0 - 1._wp)**2._wp )
[5656]	927	ELSE
	928	ztcoeff = 1
	929	ENDIF
	930	!
	931	IF(western_side) THEN
	932	vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)
	933	ENDIF
	934	IF(eastern_side) THEN
	935	vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)
	936	ENDIF
	937	IF(southern_side) THEN
	938	vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1)
	939	ENDIF
	940	IF(northern_side) THEN
	941	vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)
	942	ENDIF
	943	!
	944	IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN
	945	IF(western_side) THEN
	946	vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2)) &
	947	& * vmask(i1,j1:j2,1)
	948	ENDIF
	949	IF(eastern_side) THEN
	950	vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2)) &
	951	& * vmask(i1,j1:j2,1)
	952	ENDIF
	953	IF(southern_side) THEN
	954	vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1)) &
	955	& * vmask(i1:i2,j1,1)
	956	ENDIF
	957	IF(northern_side) THEN
	958	vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1)) &
	959	& * vmask(i1:i2,j1,1)
	960	ENDIF
	961	ENDIF
	962	ENDIF
	963	!
	964	END SUBROUTINE interpvnb
[390]	965
[7351]	966
	967	SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before, nb, ndir )
[1605]	968	!!----------------------------------------------------------------------
[5656]	969	!! * ROUTINE interpub2b *
[1605]	970	!!----------------------------------------------------------------------
[7351]	971	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	972	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	973	LOGICAL , INTENT(in ) :: before
	974	INTEGER , INTENT(in ) :: nb , ndir
	975	!
	976	INTEGER :: ji,jj
	977	REAL(wp) :: zrhot, zt0, zt1,zat
	978	LOGICAL :: western_side, eastern_side,northern_side,southern_side
[1605]	979	!!----------------------------------------------------------------------
[5656]	980	IF( before ) THEN
[7351]	981	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
[5656]	982	ELSE
	983	western_side = (nb == 1).AND.(ndir == 1)
	984	eastern_side = (nb == 1).AND.(ndir == 2)
	985	southern_side = (nb == 2).AND.(ndir == 1)
	986	northern_side = (nb == 2).AND.(ndir == 2)
	987	zrhot = Agrif_rhot()
	988	! Time indexes bounds for integration
	989	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
	990	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
	991	! Polynomial interpolation coefficients:
[7351]	992	zat = zrhot * ( zt1*2._wp (-2._wp*zt1 + 3._wp) &
	993	& - zt0*2._wp (-2._wp*zt0 + 3._wp) )
[5656]	994	!
	995	IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i1,j1:j2)
	996	IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2)
	997	IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j1)
	998	IF(northern_side) ubdy_n(i1:i2) = zat * ptab(i1:i2,j1)
	999	ENDIF
	1000	!
	1001	END SUBROUTINE interpub2b
[7351]	1002
[636]	1003
[7351]	1004	SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before, nb, ndir )
[4292]	1005	!!----------------------------------------------------------------------
[5656]	1006	!! * ROUTINE interpvb2b *
[4292]	1007	!!----------------------------------------------------------------------
[7351]	1008	INTEGER , INTENT(in ) :: i1, i2, j1, j2
	1009	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
	1010	LOGICAL , INTENT(in ) :: before
	1011	INTEGER , INTENT(in ) :: nb , ndir
	1012	!
	1013	INTEGER :: ji,jj
	1014	REAL(wp) :: zrhot, zt0, zt1,zat
	1015	LOGICAL :: western_side, eastern_side,northern_side,southern_side
[4292]	1016	!!----------------------------------------------------------------------
[5656]	1017	!
	1018	IF( before ) THEN
[7351]	1019	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
[5656]	1020	ELSE
	1021	western_side = (nb == 1).AND.(ndir == 1)
	1022	eastern_side = (nb == 1).AND.(ndir == 2)
	1023	southern_side = (nb == 2).AND.(ndir == 1)
	1024	northern_side = (nb == 2).AND.(ndir == 2)
	1025	zrhot = Agrif_rhot()
	1026	! Time indexes bounds for integration
	1027	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
	1028	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
	1029	! Polynomial interpolation coefficients:
[7351]	1030	zat = zrhot * ( zt1*2._wp (-2._wp*zt1 + 3._wp) &
	1031	& - zt0*2._wp (-2._wp*zt0 + 3._wp) )
[5656]	1032	!
[7351]	1033	IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2)
	1034	IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2)
	1035	IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j1)
	1036	IF(northern_side) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1)
[5656]	1037	ENDIF
	1038	!
	1039	END SUBROUTINE interpvb2b
[4292]	1040
[7351]	1041
	1042	SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
[5656]	1043	!!----------------------------------------------------------------------
	1044	!! * ROUTINE interpe3t *
	1045	!!----------------------------------------------------------------------
[7351]	1046	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
[5656]	1047	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
[7351]	1048	LOGICAL , INTENT(in ) :: before
	1049	INTEGER , INTENT(in ) :: nb , ndir
[5656]	1050	!
	1051	INTEGER :: ji, jj, jk
	1052	LOGICAL :: western_side, eastern_side, northern_side, southern_side
	1053	REAL(wp) :: ztmpmsk
	1054	!!----------------------------------------------------------------------
	1055	!
[7351]	1056	IF( before ) THEN
	1057	ptab(i1:i2,j1:j2,k1:k2) = tmask(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2)
[5656]	1058	ELSE
	1059	western_side = (nb == 1).AND.(ndir == 1)
	1060	eastern_side = (nb == 1).AND.(ndir == 2)
	1061	southern_side = (nb == 2).AND.(ndir == 1)
	1062	northern_side = (nb == 2).AND.(ndir == 2)
[4292]	1063
[7351]	1064	DO jk = k1, k2
	1065	DO jj = j1, j2
	1066	DO ji = i1, i2
[5656]	1067	! Get velocity mask at boundary edge points:
[7351]	1068	IF( western_side ) ztmpmsk = umask(ji ,jj ,1)
	1069	IF( eastern_side ) ztmpmsk = umask(nlci-2,jj ,1)
	1070	IF( northern_side) ztmpmsk = vmask(ji ,nlcj-2,1)
	1071	IF( southern_side) ztmpmsk = vmask(ji ,2 ,1)
	1072	!
	1073	IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) )*ztmpmsk > 1.D-2) THEN
[5656]	1074	IF (western_side) THEN
	1075	WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
	1076	ELSEIF (eastern_side) THEN
	1077	WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
	1078	ELSEIF (southern_side) THEN
	1079	WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk
	1080	ELSEIF (northern_side) THEN
	1081	WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk
	1082	ENDIF
[7351]	1083	WRITE(numout,*) ' ptab(ji,jj,jk), e3t(ji,jj,jk) ', ptab(ji,jj,jk), e3t_0(ji,jj,jk)
[5656]	1084	kindic_agr = kindic_agr + 1
	1085	ENDIF
	1086	END DO
	1087	END DO
	1088	END DO
[7351]	1089	!
[5656]	1090	ENDIF
	1091	!
	1092	END SUBROUTINE interpe3t
	1093
[7351]	1094
	1095	SUBROUTINE interpumsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
[4292]	1096	!!----------------------------------------------------------------------
[5656]	1097	!! * ROUTINE interpumsk *
[4292]	1098	!!----------------------------------------------------------------------
[7351]	1099	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
	1100	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
	1101	LOGICAL , INTENT(in ) :: before
	1102	INTEGER , INTENT(in ) :: nb , ndir
[5656]	1103	!
[7351]	1104	INTEGER :: ji, jj, jk
	1105	LOGICAL :: western_side, eastern_side
[4292]	1106	!!----------------------------------------------------------------------
[5656]	1107	!
[7351]	1108	IF( before ) THEN
	1109	ptab(i1:i2,j1:j2,k1:k2) = umask(i1:i2,j1:j2,k1:k2)
[5656]	1110	ELSE
[7351]	1111	western_side = (nb == 1).AND.(ndir == 1)
	1112	eastern_side = (nb == 1).AND.(ndir == 2)
	1113	DO jk = k1, k2
	1114	DO jj = j1, j2
	1115	DO ji = i1, i2
[5656]	1116	! Velocity mask at boundary edge points:
	1117	IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN
	1118	IF (western_side) THEN
	1119	WRITE(numout,*) 'ERROR with umask at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
	1120	WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk)
	1121	kindic_agr = kindic_agr + 1
	1122	ELSEIF (eastern_side) THEN
	1123	WRITE(numout,*) 'ERROR with umask at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
	1124	WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk)
	1125	kindic_agr = kindic_agr + 1
	1126	ENDIF
	1127	ENDIF
	1128	END DO
	1129	END DO
[4292]	1130	END DO
[7351]	1131	!
[5656]	1132	ENDIF
	1133	!
	1134	END SUBROUTINE interpumsk
[4292]	1135
[7351]	1136
	1137	SUBROUTINE interpvmsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
[4486]	1138	!!----------------------------------------------------------------------
[5656]	1139	!! * ROUTINE interpvmsk *
[4486]	1140	!!----------------------------------------------------------------------
[7351]	1141	INTEGER , INTENT(in ) :: i1,i2,j1,j2,k1,k2
	1142	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
	1143	LOGICAL , INTENT(in ) :: before
	1144	INTEGER , INTENT(in ) :: nb , ndir
[5656]	1145	!
[7351]	1146	INTEGER :: ji, jj, jk
	1147	LOGICAL :: northern_side, southern_side
[4486]	1148	!!----------------------------------------------------------------------
[5656]	1149	!
[7351]	1150	IF( before ) THEN
	1151	ptab(i1:i2,j1:j2,k1:k2) = vmask(i1:i2,j1:j2,k1:k2)
[5656]	1152	ELSE
	1153	southern_side = (nb == 2).AND.(ndir == 1)
	1154	northern_side = (nb == 2).AND.(ndir == 2)
[7351]	1155	DO jk = k1, k2
	1156	DO jj = j1, j2
	1157	DO ji = i1, i2
[5656]	1158	! Velocity mask at boundary edge points:
	1159	IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN
	1160	IF (southern_side) THEN
	1161	WRITE(numout,*) 'ERROR with vmask at the southern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
	1162	WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk)
	1163	kindic_agr = kindic_agr + 1
	1164	ELSEIF (northern_side) THEN
	1165	WRITE(numout,*) 'ERROR with vmask at the northern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
	1166	WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk)
	1167	kindic_agr = kindic_agr + 1
	1168	ENDIF
	1169	ENDIF
	1170	END DO
	1171	END DO
[4486]	1172	END DO
[7351]	1173	!
[5656]	1174	ENDIF
	1175	!
	1176	END SUBROUTINE interpvmsk
[4486]	1177
[5656]	1178	# if defined key_zdftke
	1179
[7351]	1180	SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, before )
[4486]	1181	!!----------------------------------------------------------------------
[5656]	1182	!! * ROUTINE interavm *
[4486]	1183	!!----------------------------------------------------------------------
[7351]	1184	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
	1185	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
	1186	LOGICAL , INTENT(in ) :: before
[4486]	1187	!!----------------------------------------------------------------------
[5656]	1188	!
[7351]	1189	IF( before ) THEN
[5656]	1190	ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2)
	1191	ELSE
	1192	avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)
	1193	ENDIF
	1194	!
	1195	END SUBROUTINE interpavm
[4486]	1196
[5656]	1197	# endif /* key_zdftke */
[4486]	1198
[390]	1199	#else
[1605]	1200	!!----------------------------------------------------------------------
	1201	!! Empty module no AGRIF zoom
	1202	!!----------------------------------------------------------------------
[636]	1203	CONTAINS
	1204	SUBROUTINE Agrif_OPA_Interp_empty
	1205	WRITE(,) 'agrif_opa_interp : You should not have seen this print! error?'
	1206	END SUBROUTINE Agrif_OPA_Interp_empty
[390]	1207	#endif
[1605]	1208
	1209	!!======================================================================
[636]	1210	END MODULE agrif_opa_interp

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

Download in other formats: