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

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

agrif_oce_interp.F90 in NEMO/trunk/src/NST – NEMO

Context Navigation

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

Last change on this file since 9725 was 9598, checked in by nicolasmartin, 6 years ago
Reorganisation plan for NEMO repository: changes to make compilation succeed with new structure Juste one issue left with AGRIF_NORDIC with AGRIF preprocessing Standardisation of routines header with version 4.0 and year 2018 Fix for some broken symlinks
Property svn:keywords set to `Id`
File size: 57.5 KB

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

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

Download in other formats: