Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

agrif_opa_interp.F90 @ 7910

Last change on this file since 7910 was 7910, checked in by timgraham, 7 years ago
All wrk_alloc removed
Property svn:keywords set to `Id`
File size: 47.3 KB

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

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

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

Context Navigation

source: branches/2017/dev_r7881_no_wrk_alloc/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90 @ 7910

Download in other formats: