Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

agrif_opa_update.F90 @ 2677

Last change on this file since 2677 was 2677, checked in by rblod, 13 years ago
Commit in NST_SRC for agrif and dynamic memory
Property svn:keywords set to `Id`
File size: 12.6 KB

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

Download in other formats: