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

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

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

Context Navigation

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

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

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

Download in other formats: