Context Navigation

agrif_opa_interp.F90 @ 8866

Last change on this file since 8866 was 8866, checked in by gm, 6 years ago
#1911 (ENHANCE-09): Agrif: remove Agrif_update_tke + style cleaning
Property svn:keywords set to `Id`
File size: 49.3 KB

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

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

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

Context Navigation

source: branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90 @ 8866

Download in other formats: