Context Navigation

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

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_update.F90 @ 7881

Download in other formats: