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/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/NST_SRC – NEMO

Context Navigation

source: branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 @ 5974

Last change on this file since 5974 was 5974, checked in by timgraham, 8 years ago
Upgrade to head of trunk (r5936)
Property svn:keywords set to `Id`
File size: 23.1 KB

Rev	Line
[5682]	1	#define TWO_WAY /* TWO WAY NESTING */
	2	#undef DECAL_FEEDBACK /* SEPARATION of INTERFACES*/
	3
[636]	4	MODULE agrif_opa_update
[2528]	5	#if defined key_agrif && ! defined key_offline
[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
[5682]	13	USE zdf_oce ! vertical physics: ocean variables
[3294]	14
[636]	15	IMPLICIT NONE
	16	PRIVATE
[390]	17
[5682]	18	PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn,Update_Scales
	19	# if defined key_zdftke
	20	PUBLIC Agrif_Update_Tke
	21	# endif
[1156]	22	!!----------------------------------------------------------------------
[5682]	23	!! NEMO/NST 3.6 , NEMO Consortium (2010)
[1156]	24	!! $Id$
[2528]	25	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[1156]	26	!!----------------------------------------------------------------------
	27
[636]	28	CONTAINS
	29
[5682]	30	RECURSIVE SUBROUTINE Agrif_Update_Tra( )
[636]	31	!!---------------------------------------------
	32	!! * ROUTINE Agrif_Update_Tra *
	33	!!---------------------------------------------
[5682]	34	!
	35	IF (Agrif_Root()) RETURN
	36	!
	37	#if defined TWO_WAY
	38	IF (lwp.AND.lk_agrif_debug) Write(,) 'Update tracers from grid Number',Agrif_Fixed(), 'nbcline', nbcline
[636]	39
[390]	40	Agrif_UseSpecialValueInUpdate = .TRUE.
	41	Agrif_SpecialValueFineGrid = 0.
[5682]	42	!
[636]	43	IF (MOD(nbcline,nbclineupdate) == 0) THEN
[5682]	44	# if ! defined DECAL_FEEDBACK
	45	CALL Agrif_Update_Variable(tsn_id, procname=updateTS)
	46	# else
	47	CALL Agrif_Update_Variable(tsn_id, locupdate=(/1,0/),procname=updateTS)
	48	# endif
[390]	49	ELSE
[5682]	50	# if ! defined DECAL_FEEDBACK
	51	CALL Agrif_Update_Variable(tsn_id,locupdate=(/0,2/), procname=updateTS)
	52	# else
	53	CALL Agrif_Update_Variable(tsn_id,locupdate=(/1,2/), procname=updateTS)
	54	# endif
[390]	55	ENDIF
[5682]	56	!
[390]	57	Agrif_UseSpecialValueInUpdate = .FALSE.
[5682]	58	!
	59	IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update:
	60	CALL Agrif_ChildGrid_To_ParentGrid()
	61	CALL Agrif_Update_Tra()
	62	CALL Agrif_ParentGrid_To_ChildGrid()
	63	ENDIF
	64	!
[390]	65	#endif
[5682]	66	!
[636]	67	END SUBROUTINE Agrif_Update_Tra
[390]	68
[5682]	69	RECURSIVE SUBROUTINE Agrif_Update_Dyn( )
[636]	70	!!---------------------------------------------
	71	!! * ROUTINE Agrif_Update_Dyn *
	72	!!---------------------------------------------
[5682]	73	!
	74	IF (Agrif_Root()) RETURN
	75	!
[390]	76	#if defined TWO_WAY
[5682]	77	IF (lwp.AND.lk_agrif_debug) Write(,) 'Update momentum from grid Number',Agrif_Fixed(), 'nbcline', nbcline
[390]	78
[5682]	79	Agrif_UseSpecialValueInUpdate = .FALSE.
	80	Agrif_SpecialValueFineGrid = 0.
	81	!
[390]	82	IF (mod(nbcline,nbclineupdate) == 0) THEN
[5682]	83	# if ! defined DECAL_FEEDBACK
	84	CALL Agrif_Update_Variable(un_update_id,procname = updateU)
	85	CALL Agrif_Update_Variable(vn_update_id,procname = updateV)
	86	# else
	87	CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU)
	88	CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV)
	89	# endif
[390]	90	ELSE
[5682]	91	# if ! defined DECAL_FEEDBACK
	92	CALL Agrif_Update_Variable(un_update_id,locupdate=(/0,1/),procname = updateU)
	93	CALL Agrif_Update_Variable(vn_update_id,locupdate=(/0,1/),procname = updateV)
	94	# else
	95	CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateU)
	96	CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updateV)
	97	# endif
[390]	98	ENDIF
	99
[5682]	100	# if ! defined DECAL_FEEDBACK
	101	CALL Agrif_Update_Variable(e1u_id,procname = updateU2d)
	102	CALL Agrif_Update_Variable(e2v_id,procname = updateV2d)
	103	# else
	104	CALL Agrif_Update_Variable(e1u_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU2d)
	105	CALL Agrif_Update_Variable(e2v_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV2d)
	106	# endif
[636]	107
[5974]	108	IF ( ln_dynspg_ts.AND.ln_bt_fw ) THEN
[4486]	109	! Update time integrated transports
	110	IF (mod(nbcline,nbclineupdate) == 0) THEN
[5682]	111	# if ! defined DECAL_FEEDBACK
	112	CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b)
	113	CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b)
	114	# else
	115	CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateub2b)
	116	CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updatevb2b)
	117	# endif
[4486]	118	ELSE
[5682]	119	# if ! defined DECAL_FEEDBACK
	120	CALL Agrif_Update_Variable(ub2b_update_id,locupdate=(/0,1/),procname = updateub2b)
	121	CALL Agrif_Update_Variable(vb2b_update_id,locupdate=(/0,1/),procname = updatevb2b)
	122	# else
	123	CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateub2b)
	124	CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updatevb2b)
	125	# endif
[4486]	126	ENDIF
[5682]	127	END IF
	128	!
[390]	129	nbcline = nbcline + 1
[5682]	130	!
	131	Agrif_UseSpecialValueInUpdate = .TRUE.
[636]	132	Agrif_SpecialValueFineGrid = 0.
[5682]	133	# if ! defined DECAL_FEEDBACK
	134	CALL Agrif_Update_Variable(sshn_id,procname = updateSSH)
	135	# else
	136	CALL Agrif_Update_Variable(sshn_id,locupdate=(/1,0/),procname = updateSSH)
	137	# endif
[636]	138	Agrif_UseSpecialValueInUpdate = .FALSE.
[5682]	139	!
[390]	140	#endif
[5682]	141	!
	142	! Do recursive update:
	143	IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update:
	144	CALL Agrif_ChildGrid_To_ParentGrid()
	145	CALL Agrif_Update_Dyn()
	146	CALL Agrif_ParentGrid_To_ChildGrid()
	147	ENDIF
	148	!
[636]	149	END SUBROUTINE Agrif_Update_Dyn
	150
[5682]	151	# if defined key_zdftke
	152	SUBROUTINE Agrif_Update_Tke( kt )
[636]	153	!!---------------------------------------------
[5682]	154	!! * ROUTINE Agrif_Update_Tke *
[636]	155	!!---------------------------------------------
[5682]	156	!!
[636]	157	INTEGER, INTENT(in) :: kt
[5682]	158	!
	159	IF( ( Agrif_NbStepint() .NE. 0 ) .AND. (kt /= 0) ) RETURN
	160	# if defined TWO_WAY
[636]	161
[5682]	162	Agrif_UseSpecialValueInUpdate = .TRUE.
	163	Agrif_SpecialValueFineGrid = 0.
[636]	164
[5682]	165	CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN )
	166	CALL Agrif_Update_Variable(avt_id, locupdate=(/0,0/), procname=updateAVT )
	167	CALL Agrif_Update_Variable(avm_id, locupdate=(/0,0/), procname=updateAVM )
	168
	169	Agrif_UseSpecialValueInUpdate = .FALSE.
	170
	171	# endif
	172
	173	END SUBROUTINE Agrif_Update_Tke
	174	# endif /* key_zdftke */
	175
[3294]	176	SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
[636]	177	!!---------------------------------------------
	178	!! * ROUTINE updateT *
	179	!!---------------------------------------------
[390]	180	# include "domzgr_substitute.h90"
[3294]	181	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
	182	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
[5682]	183	LOGICAL, INTENT(in) :: before
	184	!!
[3294]	185	INTEGER :: ji,jj,jk,jn
[5682]	186	!!---------------------------------------------
	187	!
[636]	188	IF (before) THEN
[3294]	189	DO jn = n1,n2
	190	DO jk=k1,k2
	191	DO jj=j1,j2
	192	DO ji=i1,i2
	193	tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn)
	194	END DO
[636]	195	END DO
	196	END DO
	197	END DO
	198	ELSE
[4491]	199	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
[5682]	200	! Add asselin part
[4491]	201	DO jn = n1,n2
	202	DO jk=k1,k2
	203	DO jj=j1,j2
	204	DO ji=i1,i2
	205	IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN
	206	tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) &
[5682]	207	& + atfp * ( tabres(ji,jj,jk,jn) &
	208	& - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk)
[4491]	209	ENDIF
	210	ENDDO
	211	ENDDO
	212	ENDDO
	213	ENDDO
	214	ENDIF
[3294]	215	DO jn = n1,n2
	216	DO jk=k1,k2
	217	DO jj=j1,j2
	218	DO ji=i1,i2
	219	IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN
[4491]	220	tsn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk)
[3294]	221	END IF
	222	END DO
[636]	223	END DO
	224	END DO
	225	END DO
	226	ENDIF
[5682]	227	!
[3294]	228	END SUBROUTINE updateTS
[390]	229
[636]	230	SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before )
	231	!!---------------------------------------------
	232	!! * ROUTINE updateu *
	233	!!---------------------------------------------
[390]	234	# include "domzgr_substitute.h90"
[5682]	235	!!
[636]	236	INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
	237	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
	238	LOGICAL, INTENT(in) :: before
[5682]	239	!!
[636]	240	INTEGER :: ji, jj, jk
	241	REAL(wp) :: zrhoy
[5682]	242	!!---------------------------------------------
	243	!
[636]	244	IF (before) THEN
	245	zrhoy = Agrif_Rhoy()
[390]	246	DO jk=k1,k2
[636]	247	DO jj=j1,j2
	248	DO ji=i1,i2
	249	tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk)
[4491]	250	tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u_n(ji,jj,jk)
[636]	251	END DO
	252	END DO
	253	END DO
	254	tabres = zrhoy * tabres
	255	ELSE
[390]	256	DO jk=k1,k2
[636]	257	DO jj=j1,j2
	258	DO ji=i1,i2
[4491]	259	tabres(ji,jj,jk) = tabres(ji,jj,jk) / e2u(ji,jj) / fse3u_n(ji,jj,jk)
	260	!
	261	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
	262	ub(ji,jj,jk) = ub(ji,jj,jk) &
[5682]	263	& + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk)
[4491]	264	ENDIF
	265	!
	266	un(ji,jj,jk) = tabres(ji,jj,jk) * umask(ji,jj,jk)
[636]	267	END DO
	268	END DO
	269	END DO
	270	ENDIF
[5682]	271	!
[636]	272	END SUBROUTINE updateu
[390]	273
[636]	274	SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before )
	275	!!---------------------------------------------
	276	!! * ROUTINE updatev *
	277	!!---------------------------------------------
[390]	278	# include "domzgr_substitute.h90"
[5682]	279	!!
[636]	280	INTEGER :: i1,i2,j1,j2,k1,k2
	281	INTEGER :: ji,jj,jk
	282	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres
	283	LOGICAL :: before
[5682]	284	!!
[636]	285	REAL(wp) :: zrhox
[5682]	286	!!---------------------------------------------
	287	!
[636]	288	IF (before) THEN
	289	zrhox = Agrif_Rhox()
[390]	290	DO jk=k1,k2
[636]	291	DO jj=j1,j2
	292	DO ji=i1,i2
	293	tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk)
[4491]	294	tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v_n(ji,jj,jk)
[636]	295	END DO
	296	END DO
	297	END DO
	298	tabres = zrhox * tabres
	299	ELSE
[390]	300	DO jk=k1,k2
[636]	301	DO jj=j1,j2
	302	DO ji=i1,i2
[4491]	303	tabres(ji,jj,jk) = tabres(ji,jj,jk) / e1v(ji,jj) / fse3v_n(ji,jj,jk)
	304	!
	305	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
	306	vb(ji,jj,jk) = vb(ji,jj,jk) &
[5682]	307	& + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk)
[4491]	308	ENDIF
	309	!
	310	vn(ji,jj,jk) = tabres(ji,jj,jk) * vmask(ji,jj,jk)
[636]	311	END DO
	312	END DO
	313	END DO
	314	ENDIF
[5682]	315	!
[636]	316	END SUBROUTINE updatev
[390]	317
[636]	318	SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before )
	319	!!---------------------------------------------
	320	!! * ROUTINE updateu2d *
	321	!!---------------------------------------------
[390]	322	# include "domzgr_substitute.h90"
[5682]	323	!!
[636]	324	INTEGER, INTENT(in) :: i1, i2, j1, j2
	325	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
	326	LOGICAL, INTENT(in) :: before
[5682]	327	!!
[636]	328	INTEGER :: ji, jj, jk
	329	REAL(wp) :: zrhoy
[4491]	330	REAL(wp) :: zcorr
[5682]	331	!!---------------------------------------------
	332	!
[636]	333	IF (before) THEN
	334	zrhoy = Agrif_Rhoy()
	335	DO jj=j1,j2
	336	DO ji=i1,i2
[4486]	337	tabres(ji,jj) = un_b(ji,jj) * hu(ji,jj) * e2u(ji,jj)
[636]	338	END DO
	339	END DO
	340	tabres = zrhoy * tabres
	341	ELSE
	342	DO jj=j1,j2
	343	DO ji=i1,i2
[4491]	344	tabres(ji,jj) = tabres(ji,jj) * hur(ji,jj) / e2u(ji,jj)
	345	!
	346	! Update "now" 3d velocities:
	347	spgu(ji,jj) = 0.e0
	348	DO jk=1,jpkm1
	349	spgu(ji,jj) = spgu(ji,jj) + fse3u_n(ji,jj,jk) * un(ji,jj,jk)
	350	END DO
	351	spgu(ji,jj) = spgu(ji,jj) * hur(ji,jj)
	352	!
	353	zcorr = tabres(ji,jj) - spgu(ji,jj)
	354	DO jk=1,jpkm1
	355	un(ji,jj,jk) = un(ji,jj,jk) + zcorr * umask(ji,jj,jk)
	356	END DO
	357	!
[4486]	358	! Update barotropic velocities:
[5974]	359	IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN
	360	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
	361	zcorr = tabres(ji,jj) - un_b(ji,jj)
	362	ub_b(ji,jj) = ub_b(ji,jj) + atfp * zcorr * umask(ji,jj,1)
	363	END IF
	364	ENDIF
[4491]	365	un_b(ji,jj) = tabres(ji,jj) * umask(ji,jj,1)
	366	!
	367	! Correct "before" velocities to hold correct bt component:
	368	spgu(ji,jj) = 0.e0
	369	DO jk=1,jpkm1
	370	spgu(ji,jj) = spgu(ji,jj) + fse3u_b(ji,jj,jk) * ub(ji,jj,jk)
	371	END DO
	372	spgu(ji,jj) = spgu(ji,jj) * hur_b(ji,jj)
	373	!
	374	zcorr = ub_b(ji,jj) - spgu(ji,jj)
	375	DO jk=1,jpkm1
	376	ub(ji,jj,jk) = ub(ji,jj,jk) + zcorr * umask(ji,jj,jk)
	377	END DO
	378	!
[636]	379	END DO
	380	END DO
	381	ENDIF
[5682]	382	!
[636]	383	END SUBROUTINE updateu2d
[390]	384
[636]	385	SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before )
	386	!!---------------------------------------------
	387	!! * ROUTINE updatev2d *
	388	!!---------------------------------------------
	389	INTEGER, INTENT(in) :: i1, i2, j1, j2
	390	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
	391	LOGICAL, INTENT(in) :: before
[5682]	392	!!
[636]	393	INTEGER :: ji, jj, jk
	394	REAL(wp) :: zrhox
[4491]	395	REAL(wp) :: zcorr
[5682]	396	!!---------------------------------------------
	397	!
[636]	398	IF (before) THEN
	399	zrhox = Agrif_Rhox()
	400	DO jj=j1,j2
	401	DO ji=i1,i2
[4486]	402	tabres(ji,jj) = vn_b(ji,jj) * hv(ji,jj) * e1v(ji,jj)
[636]	403	END DO
	404	END DO
	405	tabres = zrhox * tabres
	406	ELSE
	407	DO jj=j1,j2
	408	DO ji=i1,i2
[4491]	409	tabres(ji,jj) = tabres(ji,jj) * hvr(ji,jj) / e1v(ji,jj)
	410	!
	411	! Update "now" 3d velocities:
	412	spgv(ji,jj) = 0.e0
	413	DO jk=1,jpkm1
	414	spgv(ji,jj) = spgv(ji,jj) + fse3v_n(ji,jj,jk) * vn(ji,jj,jk)
	415	END DO
	416	spgv(ji,jj) = spgv(ji,jj) * hvr(ji,jj)
	417	!
	418	zcorr = tabres(ji,jj) - spgv(ji,jj)
	419	DO jk=1,jpkm1
	420	vn(ji,jj,jk) = vn(ji,jj,jk) + zcorr * vmask(ji,jj,jk)
	421	END DO
	422	!
[4486]	423	! Update barotropic velocities:
[5974]	424	IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN
	425	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
	426	zcorr = tabres(ji,jj) - vn_b(ji,jj)
	427	vb_b(ji,jj) = vb_b(ji,jj) + atfp * zcorr * vmask(ji,jj,1)
	428	END IF
	429	ENDIF
[4491]	430	vn_b(ji,jj) = tabres(ji,jj) * vmask(ji,jj,1)
	431	!
	432	! Correct "before" velocities to hold correct bt component:
	433	spgv(ji,jj) = 0.e0
	434	DO jk=1,jpkm1
	435	spgv(ji,jj) = spgv(ji,jj) + fse3v_b(ji,jj,jk) * vb(ji,jj,jk)
	436	END DO
	437	spgv(ji,jj) = spgv(ji,jj) * hvr_b(ji,jj)
	438	!
	439	zcorr = vb_b(ji,jj) - spgv(ji,jj)
	440	DO jk=1,jpkm1
	441	vb(ji,jj,jk) = vb(ji,jj,jk) + zcorr * vmask(ji,jj,jk)
	442	END DO
	443	!
[636]	444	END DO
	445	END DO
	446	ENDIF
[5682]	447	!
[636]	448	END SUBROUTINE updatev2d
[390]	449
[5682]	450
[636]	451	SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before )
	452	!!---------------------------------------------
	453	!! * ROUTINE updateSSH *
	454	!!---------------------------------------------
	455	INTEGER, INTENT(in) :: i1, i2, j1, j2
	456	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
	457	LOGICAL, INTENT(in) :: before
[5682]	458	!!
[636]	459	INTEGER :: ji, jj
[5682]	460	!!---------------------------------------------
	461	!
[636]	462	IF (before) THEN
	463	DO jj=j1,j2
	464	DO ji=i1,i2
[4486]	465	tabres(ji,jj) = sshn(ji,jj)
[636]	466	END DO
	467	END DO
	468	ELSE
[5974]	469	IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN
	470	IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
	471	DO jj=j1,j2
	472	DO ji=i1,i2
	473	sshb(ji,jj) = sshb(ji,jj) &
	474	& + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1)
	475	END DO
[4491]	476	END DO
[5974]	477	ENDIF
[4491]	478	ENDIF
[5974]	479
[636]	480	DO jj=j1,j2
	481	DO ji=i1,i2
[4486]	482	sshn(ji,jj) = tabres(ji,jj) * tmask(ji,jj,1)
[636]	483	END DO
	484	END DO
	485	ENDIF
[5682]	486	!
[636]	487	END SUBROUTINE updateSSH
	488
[4486]	489	SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before )
	490	!!---------------------------------------------
	491	!! * ROUTINE updateub2b *
	492	!!---------------------------------------------
	493	INTEGER, INTENT(in) :: i1, i2, j1, j2
	494	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
	495	LOGICAL, INTENT(in) :: before
[5682]	496	!!
[4486]	497	INTEGER :: ji, jj
	498	REAL(wp) :: zrhoy
[5682]	499	!!---------------------------------------------
	500	!
[4486]	501	IF (before) THEN
	502	zrhoy = Agrif_Rhoy()
	503	DO jj=j1,j2
	504	DO ji=i1,i2
	505	tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj)
	506	END DO
	507	END DO
	508	tabres = zrhoy * tabres
	509	ELSE
	510	DO jj=j1,j2
	511	DO ji=i1,i2
	512	ub2_b(ji,jj) = tabres(ji,jj) / e2u(ji,jj)
	513	END DO
	514	END DO
	515	ENDIF
[5682]	516	!
[4486]	517	END SUBROUTINE updateub2b
	518
	519	SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before )
	520	!!---------------------------------------------
	521	!! * ROUTINE updatevb2b *
	522	!!---------------------------------------------
	523	INTEGER, INTENT(in) :: i1, i2, j1, j2
	524	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
	525	LOGICAL, INTENT(in) :: before
[5682]	526	!!
[4486]	527	INTEGER :: ji, jj
	528	REAL(wp) :: zrhox
[5682]	529	!!---------------------------------------------
	530	!
[4486]	531	IF (before) THEN
	532	zrhox = Agrif_Rhox()
	533	DO jj=j1,j2
	534	DO ji=i1,i2
	535	tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj)
	536	END DO
	537	END DO
	538	tabres = zrhox * tabres
	539	ELSE
	540	DO jj=j1,j2
	541	DO ji=i1,i2
	542	vb2_b(ji,jj) = tabres(ji,jj) / e1v(ji,jj)
	543	END DO
	544	END DO
	545	ENDIF
[5682]	546	!
[4486]	547	END SUBROUTINE updatevb2b
	548
[5682]	549
	550	SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before )
	551	! currently not used
	552	!!---------------------------------------------
	553	!! * ROUTINE updateT *
	554	!!---------------------------------------------
	555	# include "domzgr_substitute.h90"
	556
	557	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
	558	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
	559	LOGICAL, iNTENT(in) :: before
	560
	561	INTEGER :: ji,jj,jk
	562	REAL(wp) :: ztemp
	563
	564	IF (before) THEN
	565	DO jk=k1,k2
	566	DO jj=j1,j2
	567	DO ji=i1,i2
	568	tabres(ji,jj,jk,1) = e1t(ji,jj)e2t(ji,jj)tmask(ji,jj,jk)
	569	tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk)
	570	tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk)
	571	END DO
	572	END DO
	573	END DO
	574	tabres(:,:,:,1)=tabres(:,:,:,1)Agrif_Rhox()Agrif_Rhoy()
	575	tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox()
	576	tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy()
	577	ELSE
	578	DO jk=k1,k2
	579	DO jj=j1,j2
	580	DO ji=i1,i2
	581	IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN
	582	print ,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)e2t(ji,jj)*tmask(ji,jj,jk)
	583	print ,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)tmask(ji,jj,jk)
	584	print ,'VAL3 = ',ji,jj,jk,tabres(ji,jj,jk,3),e2t(ji,jj)tmask(ji,jj,jk)
	585	ztemp = sqrt(tabres(ji,jj,jk,1)/(tabres(ji,jj,jk,2)*tabres(ji,jj,jk,3)))
	586	print *,'CORR = ',ztemp-1.
	587	print ,'NEW VALS = ',tabres(ji,jj,jk,2)ztemp,tabres(ji,jj,jk,3)*ztemp, &
	588	tabres(ji,jj,jk,2)ztemptabres(ji,jj,jk,3)*ztemp
	589	e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp
	590	e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp
	591	END IF
	592	END DO
	593	END DO
	594	END DO
	595	ENDIF
	596	!
	597	END SUBROUTINE update_scales
	598
	599	# if defined key_zdftke
	600	SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before )
	601	!!---------------------------------------------
	602	!! * ROUTINE updateen *
	603	!!---------------------------------------------
	604	INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
	605	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
	606	LOGICAL, INTENT(in) :: before
	607	!!---------------------------------------------
	608	!
	609	IF (before) THEN
	610	ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2)
	611	ELSE
	612	en(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)
	613	ENDIF
	614	!
	615	END SUBROUTINE updateEN
	616
	617
	618	SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before )
	619	!!---------------------------------------------
	620	!! * ROUTINE updateavt *
	621	!!---------------------------------------------
	622	INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
	623	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
	624	LOGICAL, INTENT(in) :: before
	625	!!---------------------------------------------
	626	!
	627	IF (before) THEN
	628	ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2)
	629	ELSE
	630	avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)
	631	ENDIF
	632	!
	633	END SUBROUTINE updateAVT
	634
	635
	636	SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before )
	637	!!---------------------------------------------
	638	!! * ROUTINE updateavm *
	639	!!---------------------------------------------
	640	INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
	641	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
	642	LOGICAL, INTENT(in) :: before
	643	!!---------------------------------------------
	644	!
	645	IF (before) THEN
	646	ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2)
	647	ELSE
	648	avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)
	649	ENDIF
	650	!
	651	END SUBROUTINE updateAVM
	652
	653	# endif /* key_zdftke */
	654
[390]	655	#else
[636]	656	CONTAINS
	657	SUBROUTINE agrif_opa_update_empty
	658	!!---------------------------------------------
	659	!! * ROUTINE agrif_opa_update_empty *
	660	!!---------------------------------------------
	661	WRITE(,) 'agrif_opa_update : You should not have seen this print! error?'
	662	END SUBROUTINE agrif_opa_update_empty
[390]	663	#endif
[636]	664	END MODULE agrif_opa_update
[4486]	665

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

Download in other formats: