Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

agrif_opa_update.F90 @ 2243

Last change on this file since 2243 was 2240, checked in by cetlod, 14 years ago
Suppression of key_zco everywhere in the code
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 11.7 KB

Rev	Line
[390]	1	#define TWO_WAY
	2
[636]	3	MODULE agrif_opa_update
[1300]	4	#if defined key_agrif && ! defined key_off_tra
[636]	5	USE par_oce
	6	USE oce
	7	USE dom_oce
[782]	8	USE agrif_oce
[390]	9
[636]	10	IMPLICIT NONE
	11	PRIVATE
[390]	12
[636]	13	PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn
[390]	14
[1300]	15	INTEGER, PUBLIC :: nbcline = 0
[390]	16
[1156]	17	!!----------------------------------------------------------------------
	18	!! OPA 9.0 , LOCEAN-IPSL (2006)
	19	!! $Id$
	20	!! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
	21	!!----------------------------------------------------------------------
	22
[636]	23	CONTAINS
	24
	25	SUBROUTINE Agrif_Update_Tra( kt )
	26	!!---------------------------------------------
	27	!! * ROUTINE Agrif_Update_Tra *
	28	!!---------------------------------------------
	29	INTEGER, INTENT(in) :: kt
	30
	31	REAL :: ztab(jpi,jpj,jpk)
	32
	33	IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN
[390]	34	#if defined TWO_WAY
	35	Agrif_UseSpecialValueInUpdate = .TRUE.
	36	Agrif_SpecialValueFineGrid = 0.
[636]	37
	38	IF (MOD(nbcline,nbclineupdate) == 0) THEN
	39	CALL Agrif_Update_Variable(ztab,tn, procname=updateT)
	40	CALL Agrif_Update_Variable(ztab,sn, procname=updateS)
[390]	41	ELSE
[636]	42	CALL Agrif_Update_Variable(ztab,tn,locupdate=(/0,2/), procname=updateT)
	43	CALL Agrif_Update_Variable(ztab,sn,locupdate=(/0,2/), procname=updateS)
[390]	44	ENDIF
	45
	46	Agrif_UseSpecialValueInUpdate = .FALSE.
	47	#endif
	48
[636]	49	END SUBROUTINE Agrif_Update_Tra
[390]	50
[636]	51	SUBROUTINE Agrif_Update_Dyn( kt )
	52	!!---------------------------------------------
	53	!! * ROUTINE Agrif_Update_Dyn *
	54	!!---------------------------------------------
	55	INTEGER, INTENT(in) :: kt
	56
	57	REAL(wp), DIMENSION(jpi,jpj) :: ztab2d
	58	REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztab
	59
[390]	60	IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return
	61	#if defined TWO_WAY
	62
	63	IF (mod(nbcline,nbclineupdate) == 0) THEN
[636]	64	CALL Agrif_Update_Variable(ztab,un,procname = updateU)
	65	CALL Agrif_Update_Variable(ztab,vn,procname = updateV)
[390]	66	ELSE
[636]	67	CALL Agrif_Update_Variable(ztab,un,locupdate=(/0,1/),procname = updateU)
	68	CALL Agrif_Update_Variable(ztab,vn,locupdate=(/0,1/),procname = updateV)
[390]	69	ENDIF
	70
[636]	71	CALL Agrif_Update_Variable(ztab2d,e1u,procname = updateU2d)
	72	CALL Agrif_Update_Variable(ztab2d,e2v,procname = updateV2d)
	73
[390]	74	nbcline = nbcline + 1
	75
[782]	76	Agrif_UseSpecialValueInUpdate = ln_spc_dyn
[636]	77	Agrif_SpecialValueFineGrid = 0.
	78	CALL Agrif_Update_Variable(ztab2d,sshn,procname = updateSSH)
	79	Agrif_UseSpecialValueInUpdate = .FALSE.
[390]	80
	81
[1438]	82	!Done in step
	83	! CALL Agrif_ChildGrid_To_ParentGrid()
	84	! CALL recompute_diags( kt )
	85	! CALL Agrif_ParentGrid_To_ChildGrid()
[390]	86
	87	#endif
	88
[636]	89	END SUBROUTINE Agrif_Update_Dyn
	90
	91	SUBROUTINE recompute_diags( kt )
	92	!!---------------------------------------------
	93	!! * ROUTINE recompute_diags *
	94	!!---------------------------------------------
	95	USE divcur
[1587]	96	USE sshwzv
[636]	97	USE cla_div
	98
	99	INTEGER, INTENT(in) :: kt
	100
[390]	101	ta = hdivb
	102	sa = rotb
	103	Call div_cur(kt)
	104
	105	hdivb = ta
	106	rotb = sa
	107
	108	IF( n_cla == 1 ) CALL div_cla( kt )
[1441]	109	! CALL wzv( kt )
[390]	110
[636]	111	END SUBROUTINE recompute_diags
	112
	113	SUBROUTINE updateT( tabres, i1, i2, j1, j2, k1, k2, before )
	114	!!---------------------------------------------
	115	!! * ROUTINE updateT *
	116	!!---------------------------------------------
[390]	117	# include "domzgr_substitute.h90"
	118
[636]	119	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
	120	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
	121	LOGICAL, iNTENT(in) :: before
[390]	122
[636]	123	INTEGER :: ji,jj,jk
	124
	125	IF (before) THEN
[390]	126	DO jk=k1,k2
[636]	127	DO jj=j1,j2
	128	DO ji=i1,i2
	129	tabres(ji,jj,jk) = tn(ji,jj,jk)
	130	END DO
	131	END DO
	132	END DO
	133	ELSE
	134	DO jk=k1,k2
	135	DO jj=j1,j2
	136	DO ji=i1,i2
	137	IF( tabres(ji,jj,jk) .NE. 0. ) THEN
	138	tn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk)
	139	ENDIF
	140	END DO
	141	END DO
	142	END DO
	143	ENDIF
[390]	144
[636]	145	END SUBROUTINE updateT
[390]	146
[636]	147	SUBROUTINE updateS( tabres, i1, i2, j1, j2, k1, k2, before )
	148	!!---------------------------------------------
	149	!! * ROUTINE updateS *
	150	!!---------------------------------------------
[390]	151	# include "domzgr_substitute.h90"
	152
[636]	153	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
	154	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
	155	LOGICAL, iNTENT(in) :: before
[390]	156
[636]	157	INTEGER :: ji,jj,jk
[390]	158
[636]	159	IF (before) THEN
[390]	160	DO jk=k1,k2
[636]	161	DO jj=j1,j2
	162	DO ji=i1,i2
	163	tabres(ji,jj,jk) = sn(ji,jj,jk)
	164	END DO
	165	END DO
	166	END DO
	167	ELSE
	168	DO jk=k1,k2
	169	DO jj=j1,j2
	170	DO ji=i1,i2
	171	IF (tabres(ji,jj,jk).NE.0.) THEN
	172	sn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk)
	173	ENDIF
	174	END DO
	175	END DO
	176	END DO
	177	ENDIF
[390]	178
[636]	179	END SUBROUTINE updateS
[390]	180
[636]	181	SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before )
	182	!!---------------------------------------------
	183	!! * ROUTINE updateu *
	184	!!---------------------------------------------
[390]	185	# include "domzgr_substitute.h90"
	186
[636]	187	INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
	188	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
	189	LOGICAL, INTENT(in) :: before
[390]	190
[636]	191	INTEGER :: ji, jj, jk
	192	REAL(wp) :: zrhoy
	193
	194	IF (before) THEN
	195	zrhoy = Agrif_Rhoy()
[390]	196	DO jk=k1,k2
[636]	197	DO jj=j1,j2
	198	DO ji=i1,i2
	199	tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk)
	200	END DO
	201	END DO
	202	END DO
	203	tabres = zrhoy * tabres
	204	ELSE
[390]	205	DO jk=k1,k2
[636]	206	DO jj=j1,j2
	207	DO ji=i1,i2
	208	un(ji,jj,jk) = tabres(ji,jj,jk) / (e2u(ji,jj))
	209	un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)
	210	un(ji,jj,jk) = un(ji,jj,jk) / fse3u(ji,jj,jk)
	211	END DO
	212	END DO
	213	END DO
	214	ENDIF
[390]	215
[636]	216	END SUBROUTINE updateu
[390]	217
[636]	218	SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before )
	219	!!---------------------------------------------
	220	!! * ROUTINE updatev *
	221	!!---------------------------------------------
[390]	222	# include "domzgr_substitute.h90"
	223
[636]	224	INTEGER :: i1,i2,j1,j2,k1,k2
	225	INTEGER :: ji,jj,jk
	226	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres
	227	LOGICAL :: before
[390]	228
[636]	229	REAL(wp) :: zrhox
	230
	231	IF (before) THEN
	232	zrhox = Agrif_Rhox()
[390]	233	DO jk=k1,k2
[636]	234	DO jj=j1,j2
	235	DO ji=i1,i2
	236	tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk)
	237	tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v(ji,jj,jk)
	238	END DO
	239	END DO
	240	END DO
	241	tabres = zrhox * tabres
	242	ELSE
[390]	243	DO jk=k1,k2
[636]	244	DO jj=j1,j2
	245	DO ji=i1,i2
	246	vn(ji,jj,jk) = tabres(ji,jj,jk) / (e1v(ji,jj))
	247	vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk)
	248	vn(ji,jj,jk) = vn(ji,jj,jk) / fse3v(ji,jj,jk)
	249	END DO
	250	END DO
	251	END DO
	252	ENDIF
[390]	253
[636]	254	END SUBROUTINE updatev
[390]	255
[636]	256	SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before )
	257	!!---------------------------------------------
	258	!! * ROUTINE updateu2d *
	259	!!---------------------------------------------
[390]	260	# include "domzgr_substitute.h90"
	261
[636]	262	INTEGER, INTENT(in) :: i1, i2, j1, j2
	263	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
	264	LOGICAL, INTENT(in) :: before
[390]	265
[636]	266	INTEGER :: ji, jj, jk
	267	REAL(wp) :: zrhoy
	268	REAL(wp) :: zhinv
[390]	269
[636]	270	IF (before) THEN
	271	zrhoy = Agrif_Rhoy()
	272	DO jk = 1,jpkm1
	273	DO jj=j1,j2
	274	DO ji=i1,i2
	275	tabres(ji,jj) = tabres(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk)
	276	END DO
	277	END DO
	278	END DO
	279	DO jj=j1,j2
	280	DO ji=i1,i2
	281	tabres(ji,jj) = tabres(ji,jj) * e2u(ji,jj)
	282	END DO
	283	END DO
	284	tabres = zrhoy * tabres
	285	ELSE
	286	DO jj=j1,j2
	287	DO ji=i1,i2
	288	IF(umask(ji,jj,1) .NE. 0.) THEN
	289	spgu(ji,jj) = 0.e0
	290	DO jk=1,jpk
	291	spgu(ji,jj) = spgu(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk)
	292	END DO
	293	spgu(ji,jj) = spgu(ji,jj) * e2u(ji,jj)
	294	zhinv = (tabres(ji,jj)-spgu(ji,jj))/(hu(ji,jj)*e2u(ji,jj))
	295	Do jk=1,jpk
	296	un(ji,jj,jk) = un(ji,jj,jk) + zhinv
	297	un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)
	298	END DO
[390]	299	ENDIF
[636]	300	END DO
	301	END DO
	302	ENDIF
[390]	303
[636]	304	END SUBROUTINE updateu2d
[390]	305
[636]	306	SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before )
	307	!!---------------------------------------------
	308	!! * ROUTINE updatev2d *
	309	!!---------------------------------------------
[390]	310
[636]	311	INTEGER, INTENT(in) :: i1, i2, j1, j2
	312	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
	313	LOGICAL, INTENT(in) :: before
[390]	314
[636]	315	INTEGER :: ji, jj, jk
	316	REAL(wp) :: zrhox
	317	REAL(wp) :: zhinv
[390]	318
[636]	319	IF (before) THEN
	320	zrhox = Agrif_Rhox()
	321	tabres = 0.e0
	322	DO jk = 1,jpkm1
	323	DO jj=j1,j2
	324	DO ji=i1,i2
	325	tabres(ji,jj) = tabres(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk)
	326	END DO
	327	END DO
	328	END DO
	329	DO jj=j1,j2
	330	DO ji=i1,i2
	331	tabres(ji,jj) = tabres(ji,jj) * e1v(ji,jj)
	332	END DO
	333	END DO
	334	tabres = zrhox * tabres
	335	ELSE
	336	DO jj=j1,j2
	337	DO ji=i1,i2
	338	IF(vmask(ji,jj,1) .NE. 0.) THEN
	339	spgv(ji,jj) = 0.
	340	DO jk=1,jpk
	341	spgv(ji,jj) = spgv(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk)
	342	END DO
	343	spgv(ji,jj) = spgv(ji,jj) * e1v(ji,jj)
	344	zhinv = (tabres(ji,jj)-spgv(ji,jj))/(hv(ji,jj)*e1v(ji,jj))
	345	DO jk=1,jpk
	346	vn(ji,jj,jk) = vn(ji,jj,jk) + zhinv
	347	vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk)
	348	END DO
[390]	349	ENDIF
[636]	350	END DO
	351	END DO
	352	ENDIF
[390]	353
[636]	354	END SUBROUTINE updatev2d
[390]	355
[636]	356	SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before )
	357	!!---------------------------------------------
	358	!! * ROUTINE updateSSH *
	359	!!---------------------------------------------
[390]	360	# include "domzgr_substitute.h90"
	361
[636]	362	INTEGER, INTENT(in) :: i1, i2, j1, j2
	363	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
	364	LOGICAL, INTENT(in) :: before
[390]	365
[636]	366	INTEGER :: ji, jj
	367	REAL(wp) :: zrhox, zrhoy
	368
	369	IF (before) THEN
	370	zrhox = Agrif_Rhox()
	371	zrhoy = Agrif_Rhoy()
	372	DO jj=j1,j2
	373	DO ji=i1,i2
[390]	374	tabres(ji,jj) = e1t(ji,jj) * e2t(ji,jj) * sshn(ji,jj)
[636]	375	END DO
	376	END DO
	377	tabres = zrhox * zrhoy * tabres
	378	ELSE
	379	DO jj=j1,j2
	380	DO ji=i1,i2
[390]	381	sshn(ji,jj) = tabres(ji,jj) / (e1t(ji,jj) * e2t(ji,jj))
	382	sshn(ji,jj) = sshn(ji,jj) * tmask(ji,jj,1)
[636]	383	END DO
	384	END DO
	385	ENDIF
[390]	386
[636]	387	END SUBROUTINE updateSSH
	388
[390]	389	#else
[636]	390	CONTAINS
	391	SUBROUTINE agrif_opa_update_empty
	392	!!---------------------------------------------
	393	!! * ROUTINE agrif_opa_update_empty *
	394	!!---------------------------------------------
	395	WRITE(,) 'agrif_opa_update : You should not have seen this print! error?'
	396	END SUBROUTINE agrif_opa_update_empty
[390]	397	#endif
[636]	398	END MODULE agrif_opa_update

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

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

Context Navigation

source: branches/DEV_r2106_LOCEAN2010/NEMO/NST_SRC/agrif_opa_update.F90 @ 2243

Download in other formats: