Context Navigation

agrif_opa_interp.F90 @ 7881

Last change on this file since 7881 was 7646, checked in by timgraham, 7 years ago

Merge of dev_merge_2016 into trunk. UPDATE TO ARCHFILES NEEDED for XIOS2.
LIM_SRC_s/limrhg.F90 to follow in next commit due to change of kind (I'm unable to do it in this commit).
Merged using the following steps:

1) svn merge --reintegrate svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/trunk .
2) Resolve minor conflicts in sette.sh and namelist_cfg for ORCA2LIM3 (due to a change in trunk after branch was created)
3) svn commit
4) svn switch svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/trunk
5) svn merge svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/branches/2016/dev_merge_2016 .
6) At this stage I checked out a clean copy of the branch to compare against what is about to be committed to the trunk.
6) svn commit #Commit code to the trunk

In this commit I have also reverted a change to Fcheck_archfile.sh which was causing problems on the Paris machine.

Property svn:keywords set to Id

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

Download in other formats: