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_opa_update.F90 in branches/2017/dev_r8624_AGRIF3_VVL/NEMOGCM/NEMO/NST_SRC – NEMO

Context Navigation

source: branches/2017/dev_r8624_AGRIF3_VVL/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 @ 8762

Last change on this file since 8762 was 8762, checked in by jchanut, 6 years ago
AGRIF + vvl: Final changes, update SETTE tests (these are ok except SAS) - #1965
Property svn:keywords set to `Id`
File size: 35.8 KB

Rev	Line
[5656]	1	#define TWO_WAY /* TWO WAY NESTING */
	2	#undef DECAL_FEEDBACK /* SEPARATION of INTERFACES*/
	3
[636]	4	MODULE agrif_opa_update
[7646]	5	#if defined key_agrif
[636]	6	USE par_oce
	7	USE oce
	8	USE dom_oce
[782]	9	USE agrif_oce
[2715]	10	USE in_out_manager ! I/O manager
	11	USE lib_mpp
[3294]	12	USE wrk_nemo
[5656]	13	USE zdf_oce ! vertical physics: ocean variables
[8741]	14	USE domvvl ! Need interpolation routines
[3294]	15
[636]	16	IMPLICIT NONE
	17	PRIVATE
[390]	18
[8741]	19	PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn, Update_Scales, Agrif_Update_vvl
	20
[5656]	21	# if defined key_zdftke
	22	PUBLIC Agrif_Update_Tke
	23	# endif
[1156]	24	!!----------------------------------------------------------------------
[5656]	25	!! NEMO/NST 3.6 , NEMO Consortium (2010)
[1156]	26	!! $Id$
[2528]	27	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[1156]	28	!!----------------------------------------------------------------------
[636]	29	CONTAINS
	30
[8741]	31	SUBROUTINE Agrif_Update_Tra( )
[636]	32	!!---------------------------------------------
	33	!! * ROUTINE Agrif_Update_Tra *
	34	!!---------------------------------------------
[5656]	35	!
	36	IF (Agrif_Root()) RETURN
	37	!
	38	#if defined TWO_WAY
	39	IF (lwp.AND.lk_agrif_debug) Write(,) 'Update tracers from grid Number',Agrif_Fixed(), 'nbcline', nbcline
[636]	40
[390]	41	Agrif_UseSpecialValueInUpdate = .TRUE.
	42	Agrif_SpecialValueFineGrid = 0.
[5656]	43	!
[636]	44	IF (MOD(nbcline,nbclineupdate) == 0) THEN
[5656]	45	# if ! defined DECAL_FEEDBACK
	46	CALL Agrif_Update_Variable(tsn_id, procname=updateTS)
	47	# else
	48	CALL Agrif_Update_Variable(tsn_id, locupdate=(/1,0/),procname=updateTS)
	49	# endif
[390]	50	ELSE
[5656]	51	# if ! defined DECAL_FEEDBACK
	52	CALL Agrif_Update_Variable(tsn_id,locupdate=(/0,2/), procname=updateTS)
	53	# else
	54	CALL Agrif_Update_Variable(tsn_id,locupdate=(/1,2/), procname=updateTS)
	55	# endif
[390]	56	ENDIF
[5656]	57	!
[390]	58	Agrif_UseSpecialValueInUpdate = .FALSE.
[5656]	59	!
[390]	60	#endif
[5656]	61	!
[636]	62	END SUBROUTINE Agrif_Update_Tra
[390]	63
[8741]	64	SUBROUTINE Agrif_Update_Dyn( )
[636]	65	!!---------------------------------------------
	66	!! * ROUTINE Agrif_Update_Dyn *
	67	!!---------------------------------------------
[5656]	68	!
	69	IF (Agrif_Root()) RETURN
	70	!
[390]	71	#if defined TWO_WAY
[5656]	72	IF (lwp.AND.lk_agrif_debug) Write(,) 'Update momentum from grid Number',Agrif_Fixed(), 'nbcline', nbcline
[390]	73
[5656]	74	Agrif_UseSpecialValueInUpdate = .FALSE.
	75	Agrif_SpecialValueFineGrid = 0.
	76	!
[390]	77	IF (mod(nbcline,nbclineupdate) == 0) THEN
[5656]	78	# if ! defined DECAL_FEEDBACK
	79	CALL Agrif_Update_Variable(un_update_id,procname = updateU)
	80	CALL Agrif_Update_Variable(vn_update_id,procname = updateV)
	81	# else
	82	CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU)
	83	CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV)
	84	# endif
[390]	85	ELSE
[5656]	86	# if ! defined DECAL_FEEDBACK
	87	CALL Agrif_Update_Variable(un_update_id,locupdate=(/0,1/),procname = updateU)
	88	CALL Agrif_Update_Variable(vn_update_id,locupdate=(/0,1/),procname = updateV)
	89	# else
	90	CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateU)
	91	CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updateV)
	92	# endif
[390]	93	ENDIF
	94
[5656]	95	# if ! defined DECAL_FEEDBACK
	96	CALL Agrif_Update_Variable(e1u_id,procname = updateU2d)
	97	CALL Agrif_Update_Variable(e2v_id,procname = updateV2d)
	98	# else
	99	CALL Agrif_Update_Variable(e1u_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU2d)
	100	CALL Agrif_Update_Variable(e2v_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV2d)
	101	# endif
[636]	102
[5930]	103	IF ( ln_dynspg_ts.AND.ln_bt_fw ) THEN
[4486]	104	! Update time integrated transports
	105	IF (mod(nbcline,nbclineupdate) == 0) THEN
[5656]	106	# if ! defined DECAL_FEEDBACK
	107	CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b)
	108	CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b)
	109	# else
	110	CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateub2b)
	111	CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updatevb2b)
	112	# endif
[4486]	113	ELSE
[5656]	114	# if ! defined DECAL_FEEDBACK
	115	CALL Agrif_Update_Variable(ub2b_update_id,locupdate=(/0,1/),procname = updateub2b)
	116	CALL Agrif_Update_Variable(vb2b_update_id,locupdate=(/0,1/),procname = updatevb2b)
	117	# else
	118	CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateub2b)
	119	CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updatevb2b)
	120	# endif
[4486]	121	ENDIF
[5656]	122	END IF
	123	!
[390]	124	nbcline = nbcline + 1
[5656]	125	!
	126	Agrif_UseSpecialValueInUpdate = .TRUE.
[636]	127	Agrif_SpecialValueFineGrid = 0.
[5656]	128	# if ! defined DECAL_FEEDBACK
	129	CALL Agrif_Update_Variable(sshn_id,procname = updateSSH)
	130	# else
	131	CALL Agrif_Update_Variable(sshn_id,locupdate=(/1,0/),procname = updateSSH)
	132	# endif
[636]	133	Agrif_UseSpecialValueInUpdate = .FALSE.
[5656]	134	!
[390]	135	#endif
[5656]	136	!
[636]	137	END SUBROUTINE Agrif_Update_Dyn
	138
[5656]	139	# if defined key_zdftke
[6140]	140
[8762]	141	SUBROUTINE Agrif_Update_Tke( kt )
[636]	142	!!---------------------------------------------
[5656]	143	!! * ROUTINE Agrif_Update_Tke *
[636]	144	!!---------------------------------------------
[5656]	145	!!
[8762]	146	INTEGER, INTENT(in) :: kt
[8741]	147	!
	148	IF (Agrif_Root()) RETURN
[5656]	149	!
	150	IF( ( Agrif_NbStepint() .NE. 0 ) .AND. (kt /= 0) ) RETURN
	151	# if defined TWO_WAY
[636]	152
[5656]	153	Agrif_UseSpecialValueInUpdate = .TRUE.
	154	Agrif_SpecialValueFineGrid = 0.
[636]	155
[5656]	156	CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN )
	157	CALL Agrif_Update_Variable(avt_id, locupdate=(/0,0/), procname=updateAVT )
	158	CALL Agrif_Update_Variable(avm_id, locupdate=(/0,0/), procname=updateAVM )
	159
	160	Agrif_UseSpecialValueInUpdate = .FALSE.
	161
	162	# endif
	163
	164	END SUBROUTINE Agrif_Update_Tke
[6140]	165
[5656]	166	# endif /* key_zdftke */
	167
[8741]	168	SUBROUTINE Agrif_Update_vvl( )
[636]	169	!!---------------------------------------------
[8741]	170	!! * ROUTINE Agrif_Update_vvl *
	171	!!---------------------------------------------
	172	!
	173	IF (Agrif_Root()) RETURN
	174	!
	175	#if defined TWO_WAY
	176	!
	177	IF (lwp.AND.lk_agrif_debug) Write(,) 'Update e3 from grid Number',Agrif_Fixed(), 'Step', Agrif_Nb_Step()
	178	!
	179	Agrif_UseSpecialValueInUpdate = .TRUE.
	180	Agrif_SpecialValueFineGrid = 0.
	181	!
	182	# if ! defined DECAL_FEEDBACK
	183	CALL Agrif_Update_Variable(e3t_id, procname=updatee3t)
	184	# else
	185	CALL Agrif_Update_Variable(e3t_id, locupdate=(/1,0/), procname=updatee3t)
	186	# endif
	187	!
	188	Agrif_UseSpecialValueInUpdate = .FALSE.
	189	!
	190	CALL Agrif_ChildGrid_To_ParentGrid()
	191	CALL dom_vvl_update_UVF
	192	CALL Agrif_ParentGrid_To_ChildGrid()
	193	!
	194	#endif
	195	!
	196	END SUBROUTINE Agrif_Update_vvl
	197
	198	SUBROUTINE dom_vvl_update_UVF
	199	!!---------------------------------------------
	200	!! * ROUTINE dom_vvl_update_UVF *
	201	!!---------------------------------------------
	202	!!
	203	INTEGER :: jk
	204	REAL(wp):: zcoef
	205	!!---------------------------------------------
	206
	207	IF (lwp.AND.lk_agrif_debug) Write(,) 'Finalize e3 on grid Number', &
	208	& Agrif_Fixed(), 'Step', Agrif_Nb_Step()
	209
	210	! Save "old" scale factor (prior update) for subsequent asselin correction
	211	! of prognostic variables (needed to update initial state only)
	212	! -------------------------------------------------------------
	213	!
	214	e3u_a(:,:,:) = e3u_n(:,:,:)
	215	e3v_a(:,:,:) = e3v_n(:,:,:)
	216	! ua(:,:,:) = e3u_b(:,:,:)
	217	! va(:,:,:) = e3v_b(:,:,:)
	218	hu_a(:,:) = hu_n(:,:)
	219	hv_a(:,:) = hv_n(:,:)
	220
	221	! 1) NOW fields
	222	!--------------
	223
	224	! Vertical scale factor interpolations
	225	! ------------------------------------
	226	CALL dom_vvl_interpol( e3t_n(:,:,:), e3u_n(:,:,:) , 'U' )
	227	CALL dom_vvl_interpol( e3t_n(:,:,:), e3v_n(:,:,:) , 'V' )
	228	CALL dom_vvl_interpol( e3u_n(:,:,:), e3f_n(:,:,:) , 'F' )
	229
	230	CALL dom_vvl_interpol( e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' )
	231	CALL dom_vvl_interpol( e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' )
	232
	233	! Update total depths:
	234	! --------------------
	235	hu_n(:,:) = 0._wp ! Ocean depth at U-points
	236	hv_n(:,:) = 0._wp ! Ocean depth at V-points
	237	DO jk = 1, jpkm1
	238	hu_n(:,:) = hu_n(:,:) + e3u_n(:,:,jk) * umask(:,:,jk)
	239	hv_n(:,:) = hv_n(:,:) + e3v_n(:,:,jk) * vmask(:,:,jk)
	240	END DO
	241	! ! Inverse of the local depth
	242	r1_hu_n(:,:) = ssumask(:,:) / ( hu_n(:,:) + 1._wp - ssumask(:,:) )
	243	r1_hv_n(:,:) = ssvmask(:,:) / ( hv_n(:,:) + 1._wp - ssvmask(:,:) )
	244
	245
	246	! 2) BEFORE fields:
	247	!------------------
	248	IF ( (.NOT.(lk_agrif_fstep.AND.(neuler==0)).AND.(ln_dynspg_exp)) &
	249	& .OR.(.NOT.(lk_agrif_fstep.AND.(neuler==0)).AND.(ln_dynspg_ts &
	250	& .AND.(.NOT.ln_bt_fw)))) THEN
	251	!
	252	! Vertical scale factor interpolations
	253	! ------------------------------------
	254	CALL dom_vvl_interpol( e3t_b(:,:,:), e3u_b(:,:,:), 'U' )
	255	CALL dom_vvl_interpol( e3t_b(:,:,:), e3v_b(:,:,:), 'V' )
	256
	257	CALL dom_vvl_interpol( e3u_b(:,:,:), e3uw_b(:,:,:), 'UW' )
	258	CALL dom_vvl_interpol( e3v_b(:,:,:), e3vw_b(:,:,:), 'VW' )
	259
	260	! Update total depths:
	261	! --------------------
	262	hu_b(:,:) = 0._wp ! Ocean depth at U-points
	263	hv_b(:,:) = 0._wp ! Ocean depth at V-points
	264	DO jk = 1, jpkm1
	265	hu_b(:,:) = hu_b(:,:) + e3u_b(:,:,jk) * umask(:,:,jk)
	266	hv_b(:,:) = hv_b(:,:) + e3v_b(:,:,jk) * vmask(:,:,jk)
	267	END DO
	268	! ! Inverse of the local depth
	269	r1_hu_b(:,:) = ssumask(:,:) / ( hu_b(:,:) + 1._wp - ssumask(:,:) )
	270	r1_hv_b(:,:) = ssvmask(:,:) / ( hv_b(:,:) + 1._wp - ssvmask(:,:) )
	271	ENDIF
	272	!
	273	END SUBROUTINE dom_vvl_update_UVF
	274
[8762]	275	SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
[8741]	276	!!---------------------------------------------
[636]	277	!! * ROUTINE updateT *
	278	!!---------------------------------------------
[3294]	279	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
	280	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
[5656]	281	LOGICAL, INTENT(in) :: before
	282	!!
[3294]	283	INTEGER :: ji,jj,jk,jn
[8741]	284	REAL(wp) :: ztb, ztnu, ztno
[5656]	285	!!---------------------------------------------
	286	!
[636]	287	IF (before) THEN
[3294]	288	DO jn = n1,n2
	289	DO jk=k1,k2
	290	DO jj=j1,j2
	291	DO ji=i1,i2
[8741]	292	!> jc tmp
	293	tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn) * e3t_n(ji,jj,jk) / e3t_0(ji,jj,jk)
	294	! tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn) * e3t_n(ji,jj,jk)
	295	!< jc tmp
[3294]	296	END DO
[636]	297	END DO
	298	END DO
	299	END DO
	300	ELSE
[8741]	301	!> jc tmp
	302	DO jn = n1,n2
	303	tabres(i1:i2,j1:j2,k1:k2,jn) = tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) &
	304	& * tmask(i1:i2,j1:j2,k1:k2)
	305	ENDDO
	306	!< jc tmp
[4491]	307	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
[5656]	308	! Add asselin part
[4491]	309	DO jn = n1,n2
	310	DO jk=k1,k2
	311	DO jj=j1,j2
	312	DO ji=i1,i2
	313	IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN
[8741]	314	ztb = tsb(ji,jj,jk,jn) * e3t_b(ji,jj,jk) ! fse3t_b prior update should be used
	315	ztnu = tabres(ji,jj,jk,jn)
	316	ztno = tsn(ji,jj,jk,jn) * e3t_a(ji,jj,jk)
	317	tsb(ji,jj,jk,jn) = ( ztb + atfp * ( ztnu - ztno) ) &
	318	& * tmask(ji,jj,jk) / e3t_b(ji,jj,jk)
[4491]	319	ENDIF
	320	ENDDO
	321	ENDDO
	322	ENDDO
	323	ENDDO
	324	ENDIF
[3294]	325	DO jn = n1,n2
	326	DO jk=k1,k2
	327	DO jj=j1,j2
	328	DO ji=i1,i2
	329	IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN
[8741]	330	tsn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) / e3t_n(ji,jj,jk)
[3294]	331	END IF
	332	END DO
[636]	333	END DO
	334	END DO
	335	END DO
[8741]	336	!
	337	IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
	338	tsb(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2)
	339	ENDIF
	340	!
[636]	341	ENDIF
[5656]	342	!
[3294]	343	END SUBROUTINE updateTS
[390]	344
[6140]	345
[636]	346	SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before )
	347	!!---------------------------------------------
	348	!! * ROUTINE updateu *
	349	!!---------------------------------------------
[6140]	350	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
[636]	351	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
[6140]	352	LOGICAL , INTENT(in ) :: before
	353	!
[8741]	354	INTEGER :: ji, jj, jk
	355	REAL(wp) :: zrhoy, zub, zunu, zuno
[5656]	356	!!---------------------------------------------
	357	!
[6140]	358	IF( before ) THEN
[636]	359	zrhoy = Agrif_Rhoy()
[6140]	360	DO jk = k1, k2
	361	tabres(i1:i2,j1:j2,jk) = zrhoy * e2u(i1:i2,j1:j2) * e3u_n(i1:i2,j1:j2,jk) * un(i1:i2,j1:j2,jk)
[636]	362	END DO
	363	ELSE
[390]	364	DO jk=k1,k2
[636]	365	DO jj=j1,j2
	366	DO ji=i1,i2
[8741]	367	tabres(ji,jj,jk) = tabres(ji,jj,jk) * r1_e2u(ji,jj)
[4491]	368	!
	369	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
[8741]	370	zub = ub(ji,jj,jk) * e3u_b(ji,jj,jk)
	371	zuno = un(ji,jj,jk) * e3u_a(ji,jj,jk)
	372	zunu = tabres(ji,jj,jk)
	373	ub(ji,jj,jk) = ( zub + atfp * ( zunu - zuno) ) &
	374	& * umask(ji,jj,jk) / e3u_b(ji,jj,jk)
[4491]	375	ENDIF
	376	!
[8741]	377	un(ji,jj,jk) = tabres(ji,jj,jk) * umask(ji,jj,jk) / e3u_n(ji,jj,jk)
[636]	378	END DO
	379	END DO
	380	END DO
[8741]	381	!
	382	IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
	383	ub(i1:i2,j1:j2,k1:k2) = un(i1:i2,j1:j2,k1:k2)
	384	ENDIF
	385	!
[636]	386	ENDIF
[5656]	387	!
[636]	388	END SUBROUTINE updateu
[390]	389
[6140]	390
[8741]	391	SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before)
[636]	392	!!---------------------------------------------
	393	!! * ROUTINE updatev *
	394	!!---------------------------------------------
[8741]	395	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
	396	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
	397	LOGICAL , INTENT(in ) :: before
	398	!
	399	INTEGER :: ji, jj, jk
	400	REAL(wp) :: zrhox, zvb, zvnu, zvno
[5656]	401	!!---------------------------------------------
	402	!
[636]	403	IF (before) THEN
	404	zrhox = Agrif_Rhox()
[390]	405	DO jk=k1,k2
[636]	406	DO jj=j1,j2
	407	DO ji=i1,i2
[6140]	408	tabres(ji,jj,jk) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk)
[636]	409	END DO
	410	END DO
	411	END DO
	412	ELSE
[390]	413	DO jk=k1,k2
[636]	414	DO jj=j1,j2
	415	DO ji=i1,i2
[8741]	416	tabres(ji,jj,jk) = tabres(ji,jj,jk) * r1_e1v(ji,jj)
[4491]	417	!
	418	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
[8741]	419	zvb = vb(ji,jj,jk) * e3v_b(ji,jj,jk)
	420	zvno = vn(ji,jj,jk) * e3v_a(ji,jj,jk)
	421	zvnu = tabres(ji,jj,jk)
	422	vb(ji,jj,jk) = ( zvb + atfp * ( zvnu - zvno) ) &
	423	& * vmask(ji,jj,jk) / e3v_b(ji,jj,jk)
[4491]	424	ENDIF
	425	!
[8741]	426	vn(ji,jj,jk) = tabres(ji,jj,jk) * vmask(ji,jj,jk) / e3v_n(ji,jj,jk)
[636]	427	END DO
	428	END DO
	429	END DO
[8741]	430	!
	431	IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
	432	vb(i1:i2,j1:j2,k1:k2) = vn(i1:i2,j1:j2,k1:k2)
	433	ENDIF
	434	!
[636]	435	ENDIF
[5656]	436	!
[636]	437	END SUBROUTINE updatev
[390]	438
[6140]	439
[636]	440	SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before )
	441	!!---------------------------------------------
	442	!! * ROUTINE updateu2d *
	443	!!---------------------------------------------
	444	INTEGER, INTENT(in) :: i1, i2, j1, j2
	445	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
	446	LOGICAL, INTENT(in) :: before
[5656]	447	!!
[8741]	448	INTEGER :: ji, jj, jk
[636]	449	REAL(wp) :: zrhoy
[4491]	450	REAL(wp) :: zcorr
[5656]	451	!!---------------------------------------------
	452	!
[636]	453	IF (before) THEN
	454	zrhoy = Agrif_Rhoy()
	455	DO jj=j1,j2
	456	DO ji=i1,i2
[6140]	457	tabres(ji,jj) = zrhoy * un_b(ji,jj) * hu_n(ji,jj) * e2u(ji,jj)
[636]	458	END DO
	459	END DO
	460	ELSE
	461	DO jj=j1,j2
	462	DO ji=i1,i2
[8741]	463	tabres(ji,jj) = tabres(ji,jj) * r1_e2u(ji,jj)
[4491]	464	!
	465	! Update "now" 3d velocities:
[6140]	466	spgu(ji,jj) = 0._wp
[4491]	467	DO jk=1,jpkm1
[6140]	468	spgu(ji,jj) = spgu(ji,jj) + e3u_n(ji,jj,jk) * un(ji,jj,jk)
[4491]	469	END DO
	470	!
[8741]	471	zcorr = (tabres(ji,jj) - spgu(ji,jj)) * r1_hu_n(ji,jj)
[4491]	472	DO jk=1,jpkm1
	473	un(ji,jj,jk) = un(ji,jj,jk) + zcorr * umask(ji,jj,jk)
	474	END DO
	475	!
[4486]	476	! Update barotropic velocities:
[5930]	477	IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN
	478	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
[8741]	479	zcorr = (tabres(ji,jj) - un_b(ji,jj) * hu_a(ji,jj)) * r1_hu_b(ji,jj)
[5930]	480	ub_b(ji,jj) = ub_b(ji,jj) + atfp * zcorr * umask(ji,jj,1)
	481	END IF
[8741]	482	ENDIF
	483	un_b(ji,jj) = tabres(ji,jj) * r1_hu_n(ji,jj) * umask(ji,jj,1)
[4491]	484	!
	485	! Correct "before" velocities to hold correct bt component:
	486	spgu(ji,jj) = 0.e0
	487	DO jk=1,jpkm1
[6140]	488	spgu(ji,jj) = spgu(ji,jj) + e3u_b(ji,jj,jk) * ub(ji,jj,jk)
[4491]	489	END DO
	490	!
[8741]	491	zcorr = ub_b(ji,jj) - spgu(ji,jj) * r1_hu_b(ji,jj)
[4491]	492	DO jk=1,jpkm1
	493	ub(ji,jj,jk) = ub(ji,jj,jk) + zcorr * umask(ji,jj,jk)
	494	END DO
	495	!
[636]	496	END DO
	497	END DO
[8741]	498	!
	499	IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
	500	ub_b(i1:i2,j1:j2) = un_b(i1:i2,j1:j2)
	501	ENDIF
[636]	502	ENDIF
[5656]	503	!
[636]	504	END SUBROUTINE updateu2d
[390]	505
[6140]	506
[636]	507	SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before )
	508	!!---------------------------------------------
	509	!! * ROUTINE updatev2d *
	510	!!---------------------------------------------
	511	INTEGER, INTENT(in) :: i1, i2, j1, j2
	512	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
	513	LOGICAL, INTENT(in) :: before
[5656]	514	!!
[8741]	515	INTEGER :: ji, jj, jk
[636]	516	REAL(wp) :: zrhox
[4491]	517	REAL(wp) :: zcorr
[5656]	518	!!---------------------------------------------
	519	!
[636]	520	IF (before) THEN
	521	zrhox = Agrif_Rhox()
	522	DO jj=j1,j2
	523	DO ji=i1,i2
[6140]	524	tabres(ji,jj) = zrhox * vn_b(ji,jj) * hv_n(ji,jj) * e1v(ji,jj)
[636]	525	END DO
	526	END DO
	527	ELSE
	528	DO jj=j1,j2
	529	DO ji=i1,i2
[8741]	530	tabres(ji,jj) = tabres(ji,jj) * r1_e1v(ji,jj)
[4491]	531	!
	532	! Update "now" 3d velocities:
	533	spgv(ji,jj) = 0.e0
	534	DO jk=1,jpkm1
[6140]	535	spgv(ji,jj) = spgv(ji,jj) + e3v_n(ji,jj,jk) * vn(ji,jj,jk)
[4491]	536	END DO
	537	!
[8741]	538	zcorr = (tabres(ji,jj) - spgv(ji,jj)) * r1_hv_n(ji,jj)
[4491]	539	DO jk=1,jpkm1
	540	vn(ji,jj,jk) = vn(ji,jj,jk) + zcorr * vmask(ji,jj,jk)
	541	END DO
	542	!
[4486]	543	! Update barotropic velocities:
[5930]	544	IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN
	545	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
[8741]	546	zcorr = (tabres(ji,jj) - vn_b(ji,jj) * hv_a(ji,jj)) * r1_hv_b(ji,jj)
[5930]	547	vb_b(ji,jj) = vb_b(ji,jj) + atfp * zcorr * vmask(ji,jj,1)
	548	END IF
	549	ENDIF
[8741]	550	vn_b(ji,jj) = tabres(ji,jj) * r1_hv_n(ji,jj) * vmask(ji,jj,1)
[4491]	551	!
	552	! Correct "before" velocities to hold correct bt component:
	553	spgv(ji,jj) = 0.e0
	554	DO jk=1,jpkm1
[6140]	555	spgv(ji,jj) = spgv(ji,jj) + e3v_b(ji,jj,jk) * vb(ji,jj,jk)
[4491]	556	END DO
	557	!
[8741]	558	zcorr = vb_b(ji,jj) - spgv(ji,jj) * r1_hv_b(ji,jj)
[4491]	559	DO jk=1,jpkm1
	560	vb(ji,jj,jk) = vb(ji,jj,jk) + zcorr * vmask(ji,jj,jk)
	561	END DO
	562	!
[636]	563	END DO
	564	END DO
[8741]	565	!
	566	IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
	567	vb_b(i1:i2,j1:j2) = vn_b(i1:i2,j1:j2)
	568	ENDIF
	569	!
[636]	570	ENDIF
[5656]	571	!
[636]	572	END SUBROUTINE updatev2d
[390]	573
[5656]	574
[8762]	575	SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before )
[636]	576	!!---------------------------------------------
	577	!! * ROUTINE updateSSH *
	578	!!---------------------------------------------
	579	INTEGER, INTENT(in) :: i1, i2, j1, j2
	580	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
	581	LOGICAL, INTENT(in) :: before
[5656]	582	!!
[636]	583	INTEGER :: ji, jj
[5656]	584	!!---------------------------------------------
	585	!
[636]	586	IF (before) THEN
	587	DO jj=j1,j2
	588	DO ji=i1,i2
[4486]	589	tabres(ji,jj) = sshn(ji,jj)
[636]	590	END DO
	591	END DO
	592	ELSE
[6140]	593	IF( .NOT.ln_dynspg_ts .OR. ( ln_dynspg_ts .AND. .NOT.ln_bt_fw ) ) THEN
[5930]	594	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
	595	DO jj=j1,j2
	596	DO ji=i1,i2
	597	sshb(ji,jj) = sshb(ji,jj) &
	598	& + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1)
	599	END DO
[4491]	600	END DO
[5930]	601	ENDIF
[4491]	602	ENDIF
[6140]	603	!
[636]	604	DO jj=j1,j2
	605	DO ji=i1,i2
[4486]	606	sshn(ji,jj) = tabres(ji,jj) * tmask(ji,jj,1)
[636]	607	END DO
	608	END DO
[8741]	609	!
	610	IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
	611	sshb(i1:i2,j1:j2) = sshn(i1:i2,j1:j2)
	612	ENDIF
	613	!
[8762]	614
[636]	615	ENDIF
[5656]	616	!
[636]	617	END SUBROUTINE updateSSH
	618
[6140]	619
[8762]	620	SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before, nb, ndir )
[4486]	621	!!---------------------------------------------
	622	!! * ROUTINE updateub2b *
	623	!!---------------------------------------------
	624	INTEGER, INTENT(in) :: i1, i2, j1, j2
	625	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
	626	LOGICAL, INTENT(in) :: before
[8762]	627	INTEGER, INTENT(in) :: nb, ndir
[5656]	628	!!
[8762]	629	LOGICAL :: western_side, eastern_side
[4486]	630	INTEGER :: ji, jj
[8741]	631	REAL(wp) :: zrhoy, za1
[5656]	632	!!---------------------------------------------
	633	!
[4486]	634	IF (before) THEN
	635	zrhoy = Agrif_Rhoy()
	636	DO jj=j1,j2
	637	DO ji=i1,i2
	638	tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj)
	639	END DO
	640	END DO
	641	tabres = zrhoy * tabres
	642	ELSE
[8762]	643	!
	644	tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e2u(i1:i2,j1:j2)
	645	!
	646	! Refluxing here:
	647	#if defined DECAL_FEEDBACK
	648	western_side = (nb == 1).AND.(ndir == 1)
	649	eastern_side = (nb == 1).AND.(ndir == 2)
	650	!
	651	IF (western_side) THEN
	652	DO jj=j1,j2
	653	sshn(i1 ,jj) = sshn(i1 ,jj) + rdt * r1_e1e2t(i1 ,jj) &
	654	& * e2u(i1,jj) * (ub2_b(i1,jj)-tabres(i1,jj))
	655	END DO
	656	ENDIF
	657	IF (eastern_side) THEN
	658	DO jj=j1,j2
	659	sshn(i2+1,jj) = sshn(i2+1,jj) - rdt * r1_e1e2t(i2+1,jj) &
	660	& * e2u(i2,jj) * (ub2_b(i2,jj)-tabres(i2,jj))
	661	END DO
	662	ENDIF
	663	!
	664	#endif
[8741]	665	za1 = 1._wp / REAL(Agrif_rhot(), wp)
[8762]	666	!
[4486]	667	DO jj=j1,j2
	668	DO ji=i1,i2
[8762]	669	! Update time integrated fluxes also in case of multiply nested grids:
[8741]	670	ub2_i_b(ji,jj) = ub2_i_b(ji,jj) &
	671	& + za1 * (tabres(ji,jj) - ub2_b(ji,jj))
[8762]	672	! Update half step back fluxes:
[8741]	673	ub2_b(ji,jj) = tabres(ji,jj)
[4486]	674	END DO
	675	END DO
	676	ENDIF
[5656]	677	!
[4486]	678	END SUBROUTINE updateub2b
	679
[6140]	680
[8762]	681	SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before, nb, ndir )
[4486]	682	!!---------------------------------------------
	683	!! * ROUTINE updatevb2b *
	684	!!---------------------------------------------
	685	INTEGER, INTENT(in) :: i1, i2, j1, j2
	686	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
	687	LOGICAL, INTENT(in) :: before
[8762]	688	INTEGER, INTENT(in) :: nb, ndir
[5656]	689	!!
[8762]	690	LOGICAL :: southern_side, northern_side
[4486]	691	INTEGER :: ji, jj
[8741]	692	REAL(wp) :: zrhox, za1
[5656]	693	!!---------------------------------------------
	694	!
[4486]	695	IF (before) THEN
	696	zrhox = Agrif_Rhox()
	697	DO jj=j1,j2
	698	DO ji=i1,i2
	699	tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj)
	700	END DO
	701	END DO
	702	tabres = zrhox * tabres
	703	ELSE
[8762]	704	!
	705	tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e1v(i1:i2,j1:j2)
	706	!
	707	! Refluxing here:
	708	#if defined DECAL_FEEDBACK
	709	southern_side = (nb == 2).AND.(ndir == 1)
	710	northern_side = (nb == 2).AND.(ndir == 2)
	711	!
	712	IF (southern_side) THEN
	713	DO ji=i1,i2
	714	sshn(ji,j1 ) = sshn(ji,j1 ) + rdt * r1_e1e2t(ji,j1 ) &
	715	& * e1v(ji,j1 ) * (vb2_b(ji,j1)-tabres(ji,j1))
	716	END DO
	717	ENDIF
	718	IF (northern_side) THEN
	719	DO ji=i1,i2
	720	sshn(ji,j2+1) = sshn(ji,j2+1) - rdt * r1_e1e2t(ji,j2+1) &
	721	& * e1v(ji,j2 ) * (vb2_b(ji,j2)-tabres(ji,j2))
	722	END DO
	723	ENDIF
	724	!
	725	#endif
[8741]	726	za1 = 1._wp / REAL(Agrif_rhot(), wp)
[4486]	727	DO jj=j1,j2
	728	DO ji=i1,i2
[8762]	729	! Update time integrated fluxes also in case of multiply nested grids:
[8741]	730	vb2_i_b(ji,jj) = vb2_i_b(ji,jj) &
	731	& + za1 * (tabres(ji,jj) - vb2_b(ji,jj))
[8762]	732	! Update half step back fluxes:
[8741]	733	vb2_b(ji,jj) = tabres(ji,jj)
[4486]	734	END DO
	735	END DO
	736	ENDIF
[5656]	737	!
[4486]	738	END SUBROUTINE updatevb2b
	739
[5656]	740
	741	SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before )
	742	! currently not used
	743	!!---------------------------------------------
	744	!! * ROUTINE updateT *
	745	!!---------------------------------------------
	746	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
	747	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
	748	LOGICAL, iNTENT(in) :: before
[6140]	749	!
[5656]	750	INTEGER :: ji,jj,jk
	751	REAL(wp) :: ztemp
[6140]	752	!!---------------------------------------------
[5656]	753
	754	IF (before) THEN
	755	DO jk=k1,k2
	756	DO jj=j1,j2
	757	DO ji=i1,i2
	758	tabres(ji,jj,jk,1) = e1t(ji,jj)e2t(ji,jj)tmask(ji,jj,jk)
	759	tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk)
	760	tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk)
	761	END DO
	762	END DO
	763	END DO
	764	tabres(:,:,:,1)=tabres(:,:,:,1)Agrif_Rhox()Agrif_Rhoy()
	765	tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox()
	766	tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy()
	767	ELSE
	768	DO jk=k1,k2
	769	DO jj=j1,j2
	770	DO ji=i1,i2
	771	IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN
	772	print ,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)e2t(ji,jj)*tmask(ji,jj,jk)
	773	print ,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)tmask(ji,jj,jk)
	774	print ,'VAL3 = ',ji,jj,jk,tabres(ji,jj,jk,3),e2t(ji,jj)tmask(ji,jj,jk)
	775	ztemp = sqrt(tabres(ji,jj,jk,1)/(tabres(ji,jj,jk,2)*tabres(ji,jj,jk,3)))
	776	print *,'CORR = ',ztemp-1.
	777	print ,'NEW VALS = ',tabres(ji,jj,jk,2)ztemp,tabres(ji,jj,jk,3)*ztemp, &
	778	tabres(ji,jj,jk,2)ztemptabres(ji,jj,jk,3)*ztemp
	779	e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp
	780	e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp
	781	END IF
	782	END DO
	783	END DO
	784	END DO
	785	ENDIF
	786	!
	787	END SUBROUTINE update_scales
	788
	789	# if defined key_zdftke
[6140]	790
[5656]	791	SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before )
	792	!!---------------------------------------------
	793	!! * ROUTINE updateen *
	794	!!---------------------------------------------
	795	INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
	796	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
	797	LOGICAL, INTENT(in) :: before
	798	!!---------------------------------------------
	799	!
	800	IF (before) THEN
	801	ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2)
	802	ELSE
	803	en(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)
	804	ENDIF
	805	!
	806	END SUBROUTINE updateEN
	807
	808
	809	SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before )
	810	!!---------------------------------------------
	811	!! * ROUTINE updateavt *
	812	!!---------------------------------------------
	813	INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
	814	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
	815	LOGICAL, INTENT(in) :: before
	816	!!---------------------------------------------
	817	!
	818	IF (before) THEN
	819	ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2)
	820	ELSE
	821	avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)
	822	ENDIF
	823	!
	824	END SUBROUTINE updateAVT
	825
	826
	827	SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before )
	828	!!---------------------------------------------
	829	!! * ROUTINE updateavm *
	830	!!---------------------------------------------
	831	INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
	832	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
	833	LOGICAL, INTENT(in) :: before
	834	!!---------------------------------------------
	835	!
	836	IF (before) THEN
	837	ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2)
	838	ELSE
	839	avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)
	840	ENDIF
	841	!
	842	END SUBROUTINE updateAVM
	843
	844	# endif /* key_zdftke */
	845
[8741]	846	SUBROUTINE updatee3t( ptab, i1, i2, j1, j2, k1, k2, before )
	847	!!---------------------------------------------
	848	!! * ROUTINE updatee3t *
	849	!!---------------------------------------------
	850	INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
	851	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
	852	LOGICAL, INTENT(in) :: before
	853	INTEGER :: ji,jj,jk
	854	REAL(wp) :: zcoef
	855	!!---------------------------------------------
	856	!
	857	IF (before) THEN
	858	!> jc tmp:
	859	! ptab(i1:i2,j1:j2,k1:k2) = e3t_n(i1:i2,j1:j2,k1:k2)
	860	ptab(i1:i2,j1:j2,k1:k2) = e3t_n(i1:i2,j1:j2,k1:k2) / e3t_0(i1:i2,j1:j2,k1:k2) * tmask(i1:i2,j1:j2,k1:k2)
	861	!< jc tmp:
	862	ELSE
	863	!
	864	! 1) Updates at BEFORE time step:
	865	! -------------------------------
	866	!
	867	!> jc tmp:
[8762]	868	DO jk = 1, jpkm1
	869	DO jj=j1,j2
	870	DO ji=i1,i2
	871	IF (tmask(ji,jj,jk)==1) THEN
	872	ptab(ji,jj,jk) = ptab(ji,jj,jk) * e3t_0(ji,jj,jk)
	873	ELSE
	874	ptab(ji,jj,jk) = e3t_0(ji,jj,jk)
	875	ENDIF
	876	END DO
	877	END DO
	878	END DO
	879	! ptab(i1:i2,j1:j2,k1:k2) = ptab(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2)
[8741]	880	!< jc tmp:
	881
	882	! Save "old" scale factor (prior update) for subsequent asselin correction
	883	! of prognostic variables (needed to update initial state only)
	884	e3t_a(i1:i2,j1:j2,k1:k2) = e3t_n(i1:i2,j1:j2,k1:k2)
[8762]	885	! hdivn(i1:i2,j1:j2,k1:k2) = e3t_b(i1:i2,j1:j2,k1:k2)
[8741]	886
	887	IF ( (.NOT.(lk_agrif_fstep.AND.(neuler==0)).AND.(ln_dynspg_exp)) &
	888	& .OR.(.NOT.(lk_agrif_fstep.AND.(neuler==0)).AND.(ln_dynspg_ts &
	889	& .AND.(.NOT.ln_bt_fw)))) THEN
	890
	891	DO jk = 1, jpkm1
	892	DO jj=j1,j2
	893	DO ji=i1,i2
	894	e3t_b(ji,jj,jk) = e3t_b(ji,jj,jk) &
	895	& + atfp * ( ptab(ji,jj,jk) - e3t_n(ji,jj,jk) )
	896	END DO
	897	END DO
	898	END DO
	899	!
	900	e3w_b (i1:i2,j1:j2,1) = e3w_0(i1:i2,j1:j2,1) + e3t_b(i1:i2,j1:j2,1) - e3t_0(i1:i2,j1:j2,1)
	901	gdepw_b(i1:i2,j1:j2,1) = 0.0_wp
	902	gdept_b(i1:i2,j1:j2,1) = 0.5_wp * e3w_b(i1:i2,j1:j2,1)
	903	!
	904	DO jk = 2, jpk
	905	DO jj = j1,j2
	906	DO ji = i1,i2
	907	zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk))
	908	e3w_b(ji,jj,jk) = e3w_0(ji,jj,jk) + ( 1.0_wp - 0.5_wp * tmask(ji,jj,jk) ) * &
	909	& ( e3t_b(ji,jj,jk-1) - e3t_0(ji,jj,jk-1) ) &
	910	& + 0.5_wp * tmask(ji,jj,jk) * &
	911	& ( e3t_b(ji,jj,jk ) - e3t_0(ji,jj,jk ) )
	912	gdepw_b(ji,jj,jk) = gdepw_b(ji,jj,jk-1) + e3t_b(ji,jj,jk-1)
	913	gdept_b(ji,jj,jk) = zcoef * ( gdepw_b(ji,jj,jk ) + 0.5 * e3w_b(ji,jj,jk)) &
	914	& + (1-zcoef) * ( gdept_b(ji,jj,jk-1) + e3w_b(ji,jj,jk))
	915	END DO
	916	END DO
	917	END DO
	918	!
	919	ENDIF
	920	!
	921	! 2) Updates at NOW time step:
	922	! ----------------------------
	923	!
	924	! Update vertical scale factor at T-points:
	925	e3t_n(i1:i2,j1:j2,k1:k2) = ptab(i1:i2,j1:j2,k1:k2)
	926	!
	927	! Update total depth:
	928	ht_n(i1:i2,j1:j2) = 0._wp
	929	DO jk = 1, jpkm1
	930	ht_n(i1:i2,j1:j2) = ht_n(i1:i2,j1:j2) + e3t_n(i1:i2,j1:j2,jk) * tmask(i1:i2,j1:j2,jk)
	931	END DO
	932	!
	933	! Update vertical scale factor at W-points and depths:
	934	e3w_n (i1:i2,j1:j2,1) = e3w_0(i1:i2,j1:j2,1) + e3t_n(i1:i2,j1:j2,1) - e3t_0(i1:i2,j1:j2,1)
	935	gdept_n(i1:i2,j1:j2,1) = 0.5_wp * e3w_n(i1:i2,j1:j2,1)
	936	gdepw_n(i1:i2,j1:j2,1) = 0.0_wp
	937	gde3w_n(i1:i2,j1:j2,1) = gdept_n(i1:i2,j1:j2,1) - (ht_n(i1:i2,j1:j2)-ht_0(i1:i2,j1:j2)) ! Last term in the rhs is ssh
	938	!
	939	DO jk = 2, jpk
	940	DO jj = j1,j2
	941	DO ji = i1,i2
	942	zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk))
	943	e3w_n(ji,jj,jk) = e3w_0(ji,jj,jk) + ( 1.0_wp - 0.5_wp * tmask(ji,jj,jk) ) * ( e3t_n(ji,jj,jk-1) - e3t_0(ji,jj,jk-1) ) &
	944	& + 0.5_wp * tmask(ji,jj,jk) * ( e3t_n(ji,jj,jk ) - e3t_0(ji,jj,jk ) )
	945	gdepw_n(ji,jj,jk) = gdepw_n(ji,jj,jk-1) + e3t_n(ji,jj,jk-1)
	946	gdept_n(ji,jj,jk) = zcoef * ( gdepw_n(ji,jj,jk ) + 0.5 * e3w_n(ji,jj,jk)) &
	947	& + (1-zcoef) * ( gdept_n(ji,jj,jk-1) + e3w_n(ji,jj,jk))
	948	gde3w_n(ji,jj,jk) = gdept_n(ji,jj,jk) - (ht_n(ji,jj)-ht_0(ji,jj)) ! Last term in the rhs is ssh
	949	END DO
	950	END DO
	951	END DO
	952	!
	953	IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
	954	e3t_b (i1:i2,j1:j2,1:jpk) = e3t_n (i1:i2,j1:j2,1:jpk)
	955	e3w_b (i1:i2,j1:j2,1:jpk) = e3w_n (i1:i2,j1:j2,1:jpk)
	956	gdepw_b(i1:i2,j1:j2,1:jpk) = gdepw_n(i1:i2,j1:j2,1:jpk)
	957	gdept_b(i1:i2,j1:j2,1:jpk) = gdept_n(i1:i2,j1:j2,1:jpk)
	958	ENDIF
	959	!
	960	ENDIF
	961	!
	962	END SUBROUTINE updatee3t
	963
[390]	964	#else
[636]	965	CONTAINS
	966	SUBROUTINE agrif_opa_update_empty
	967	!!---------------------------------------------
	968	!! * ROUTINE agrif_opa_update_empty *
	969	!!---------------------------------------------
	970	WRITE(,) 'agrif_opa_update : You should not have seen this print! error?'
	971	END SUBROUTINE agrif_opa_update_empty
[390]	972	#endif
[636]	973	END MODULE agrif_opa_update
[4486]	974

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

Download in other formats: