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_interp.F90 in branches/2011/dev_LOCEAN_2011/NEMOGCM/NEMO/NST_SRC – NEMO

Context Navigation

source: branches/2011/dev_LOCEAN_2011/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90 @ 8452

Last change on this file since 8452 was 2977, checked in by cetlod, 13 years ago
Add in branch 2011/dev_LOCEAN_2011 changes from 2011/dev_r2787_PISCES_improvment, 2011/dev_r2787_LOCEAN_offline_fldread and 2011/dev_r2787_LOCEAN3_TRA_TRP branches, see ticket #877
Property svn:keywords set to `Id`
File size: 20.2 KB

Rev	Line
[636]	1	MODULE agrif_opa_interp
[1605]	2	!!======================================================================
	3	!! * MODULE agrif_opa_interp *
	4	!! AGRIF: interpolation package
	5	!!======================================================================
	6	!! History : 2.0 ! 2002-06 (XXX) Original cade
	7	!! - ! 2005-11 (XXX)
	8	!! 3.2 ! 2009-04 (R. Benshila)
	9	!!----------------------------------------------------------------------
[2528]	10	#if defined key_agrif && ! defined key_offline
[1605]	11	!!----------------------------------------------------------------------
	12	!! 'key_agrif' AGRIF zoom
[2528]	13	!! NOT 'key_offline' NO off-line tracers
[1605]	14	!!----------------------------------------------------------------------
	15	!! Agrif_tra :
	16	!! Agrif_dyn :
	17	!! interpu :
	18	!! interpv :
	19	!!----------------------------------------------------------------------
[636]	20	USE par_oce
	21	USE oce
	22	USE dom_oce
	23	USE sol_oce
[782]	24	USE agrif_oce
[1605]	25	USE phycst
	26	USE in_out_manager
[2715]	27	USE agrif_opa_sponge
	28	USE lib_mpp
[390]	29
[636]	30	IMPLICIT NONE
	31	PRIVATE
	32
[2486]	33	PUBLIC Agrif_tra, Agrif_dyn, Agrif_ssh, interpu, interpv
[390]	34
[1605]	35	# include "domzgr_substitute.h90"
	36	# include "vectopt_loop_substitute.h90"
[1156]	37	!!----------------------------------------------------------------------
[2528]	38	!! NEMO/NST 3.3 , NEMO Consortium (2010)
[1156]	39	!! $Id$
[2528]	40	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[1156]	41	!!----------------------------------------------------------------------
	42
[636]	43	CONTAINS
	44
[782]	45	SUBROUTINE Agrif_tra
[1605]	46	!!----------------------------------------------------------------------
	47	!! * ROUTINE Agrif_Tra *
	48	!!----------------------------------------------------------------------
[2715]	49	USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released
[2977]	50	USE wrk_nemo, ONLY: wrk_4d_1
[2715]	51	!!
[2977]	52	INTEGER :: ji, jj, jk, jn ! dummy loop indices
[1605]	53	REAL(wp) :: zrhox , alpha1, alpha2, alpha3
	54	REAL(wp) :: alpha4, alpha5, alpha6, alpha7
[2977]	55	REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztsa
[1605]	56	!!----------------------------------------------------------------------
[636]	57	!
[1605]	58	IF( Agrif_Root() ) RETURN
[390]	59
[2977]	60	ztsa => wrk_4d_1
	61	IF( wrk_in_use(4, 1) )THEN
[2715]	62	CALL ctl_stop('agrif_tra: requested workspace arrays unavailable.')
	63	RETURN
	64	END IF
	65
[1605]	66	Agrif_SpecialValue = 0.e0
[636]	67	Agrif_UseSpecialValue = .TRUE.
[2977]	68	ztsa(:,:,:,:) = 0.e0
[390]	69
[2977]	70	CALL Agrif_Bc_variable( ztsa, tsn_id, procname=interptsn )
[636]	71	Agrif_UseSpecialValue = .FALSE.
[390]	72
[636]	73	zrhox = Agrif_Rhox()
	74
[1605]	75	alpha1 = ( zrhox - 1. ) * 0.5
	76	alpha2 = 1. - alpha1
[636]	77
[1605]	78	alpha3 = ( zrhox - 1. ) / ( zrhox + 1. )
	79	alpha4 = 1. - alpha3
[636]	80
[1605]	81	alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )
	82	alpha7 = - ( zrhox - 1. ) / ( zrhox + 3. )
[636]	83	alpha5 = 1. - alpha6 - alpha7
	84
[1605]	85	IF( nbondi == 1 .OR. nbondi == 2 ) THEN
[636]	86
[2977]	87	DO jn = 1, jpts
	88	tsa(nlci,:,:,jn) = alpha1 * ztsa(nlci,:,:,jn) + alpha2 * ztsa(nlci-1,:,:,jn)
	89	DO jk = 1, jpkm1
	90	DO jj = 1, jpj
	91	IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN
	92	tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk)
	93	ELSE
	94	tsa(nlci-1,jj,jk,jn)=(alpha4tsa(nlci,jj,jk,jn)+alpha3tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk)
	95	IF( un(nlci-2,jj,jk) > 0.e0 ) THEN
	96	tsa(nlci-1,jj,jk,jn)=( alpha6tsa(nlci-2,jj,jk,jn)+alpha5tsa(nlci,jj,jk,jn) &
	97	& + alpha7tsa(nlci-3,jj,jk,jn) ) tmask(nlci-1,jj,jk)
	98	ENDIF
[636]	99	ENDIF
[2977]	100	END DO
[636]	101	END DO
[2977]	102	ENDDO
[390]	103	ENDIF
	104
[1605]	105	IF( nbondj == 1 .OR. nbondj == 2 ) THEN
[636]	106
[2977]	107	DO jn = 1, jpts
	108	tsa(:,nlcj,:,jn) = alpha1 * ztsa(:,nlcj,:,jn) + alpha2 * ztsa(:,nlcj-1,:,jn)
	109	DO jk = 1, jpkm1
	110	DO ji = 1, jpi
	111	IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN
	112	tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk)
	113	ELSE
	114	tsa(ji,nlcj-1,jk,jn)=(alpha4tsa(ji,nlcj,jk,jn)+alpha3tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)
	115	IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN
	116	tsa(ji,nlcj-1,jk,jn)=( alpha6tsa(ji,nlcj-2,jk,jn)+alpha5tsa(ji,nlcj,jk,jn) &
	117	& + alpha7tsa(ji,nlcj-3,jk,jn) ) tmask(ji,nlcj-1,jk)
	118	ENDIF
[636]	119	ENDIF
[2977]	120	END DO
[636]	121	END DO
[2977]	122	ENDDO
[390]	123	ENDIF
	124
[1605]	125	IF( nbondi == -1 .OR. nbondi == 2 ) THEN
[2977]	126	DO jn = 1, jpts
	127	tsa(1,:,:,jn) = alpha1 * ztsa(1,:,:,jn) + alpha2 * ztsa(2,:,:,jn)
	128	DO jk = 1, jpkm1
	129	DO jj = 1, jpj
	130	IF( umask(2,jj,jk) == 0.e0 ) THEN
	131	tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk)
	132	ELSE
	133	tsa(2,jj,jk,jn)=(alpha4tsa(1,jj,jk,jn)+alpha3tsa(3,jj,jk,jn))*tmask(2,jj,jk)
	134	IF( un(2,jj,jk) < 0.e0 ) THEN
	135	tsa(2,jj,jk,jn)=(alpha6tsa(3,jj,jk,jn)+alpha5tsa(1,jj,jk,jn)+alpha7tsa(4,jj,jk,jn))tmask(2,jj,jk)
	136	ENDIF
[636]	137	ENDIF
[2977]	138	END DO
[636]	139	END DO
	140	END DO
[390]	141	ENDIF
	142
[1605]	143	IF( nbondj == -1 .OR. nbondj == 2 ) THEN
[2977]	144	DO jn = 1, jpts
	145	tsa(:,1,:,jn) = alpha1 * ztsa(:,1,:,jn) + alpha2 * ztsa(:,2,:,jn)
	146	DO jk=1,jpk
	147	DO ji=1,jpi
	148	IF( vmask(ji,2,jk) == 0.e0 ) THEN
	149	tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk)
	150	ELSE
	151	tsa(ji,2,jk,jn)=(alpha4tsa(ji,1,jk,jn)+alpha3tsa(ji,3,jk,jn))*tmask(ji,2,jk)
	152	IF( vn(ji,2,jk) < 0.e0 ) THEN
	153	tsa(ji,2,jk,jn)=(alpha6tsa(ji,3,jk,jn)+alpha5tsa(ji,1,jk,jn)+alpha7tsa(ji,4,jk,jn))tmask(ji,2,jk)
	154	ENDIF
[636]	155	ENDIF
[2977]	156	END DO
[636]	157	END DO
[2977]	158	ENDDO
[636]	159	ENDIF
[1605]	160	!
[2977]	161	IF( wrk_not_released(4, 1) ) THEN
[2715]	162	CALL ctl_stop('agrif_tra: failed to release workspace arrays.')
	163	ENDIF
	164	!
[636]	165	END SUBROUTINE Agrif_tra
	166
[1605]	167
[636]	168	SUBROUTINE Agrif_dyn( kt )
[1605]	169	!!----------------------------------------------------------------------
	170	!! * ROUTINE Agrif_DYN *
	171	!!----------------------------------------------------------------------
[2715]	172	USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released
	173	USE wrk_nemo, ONLY: wrk_2d_4, wrk_2d_5
	174	USE wrk_nemo, ONLY: wrk_2d_6, wrk_2d_7
	175	USE wrk_nemo, ONLY: wrk_3d_1, wrk_3d_2
	176	!!
[1605]	177	INTEGER, INTENT(in) :: kt
	178	!!
	179	INTEGER :: ji,jj,jk
[636]	180	REAL(wp) :: timeref
[390]	181	REAL(wp) :: z2dt, znugdt
[636]	182	REAL(wp) :: zrhox, rhoy
[2715]	183	REAL(wp), POINTER, DIMENSION(:,:,:) :: zua, zva
	184	REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1, zua2d, zva2d
[1605]	185	!!----------------------------------------------------------------------
[390]	186
[1605]	187	IF( Agrif_Root() ) RETURN
[390]	188
[2715]	189	spgu1 => wrk_2d_4 ; spgv1 => wrk_2d_5
	190	zua2d => wrk_2d_6 ; zva2d => wrk_2d_7
	191	zua => wrk_3d_1 ; zva => wrk_3d_2
	192	IF( wrk_in_use(2, 4,5,6,7) .OR. wrk_in_use(3, 1,2) )THEN
	193	CALL ctl_stop('agrif_dyn: requested workspace arrays unavailable.')
	194	RETURN
	195	END IF
	196
[636]	197	zrhox = Agrif_Rhox()
[390]	198	rhoy = Agrif_Rhoy()
	199
	200	timeref = 1.
	201
	202	! time step: leap-frog
	203	z2dt = 2. * rdt
	204	! time step: Euler if restart from rest
	205	IF( neuler == 0 .AND. kt == nit000 ) z2dt = rdt
	206	! coefficients
[1605]	207	znugdt = grav * z2dt
[390]	208
[636]	209	Agrif_SpecialValue=0.
[782]	210	Agrif_UseSpecialValue = ln_spc_dyn
	211
[636]	212	zua = 0.
	213	zva = 0.
[2715]	214	CALL Agrif_Bc_variable(zua,un_id,procname=interpu)
	215	CALL Agrif_Bc_variable(zva,vn_id,procname=interpv)
[636]	216	zua2d = 0.
	217	zva2d = 0.
[390]	218
[636]	219	Agrif_SpecialValue=0.
[782]	220	Agrif_UseSpecialValue = ln_spc_dyn
[2715]	221	CALL Agrif_Bc_variable(zua2d,e1u_id,calledweight=1.,procname=interpu2d)
	222	CALL Agrif_Bc_variable(zva2d,e2v_id,calledweight=1.,procname=interpv2d)
[636]	223	Agrif_UseSpecialValue = .FALSE.
[390]	224
	225
[636]	226	IF((nbondi == -1).OR.(nbondi == 2)) THEN
[390]	227
[636]	228	DO jj=1,jpj
	229	laplacu(2,jj) = timeref * (zua2d(2,jj)/(rhoye2u(2,jj)))umask(2,jj,1)
	230	END DO
	231
	232	DO jk=1,jpkm1
	233	DO jj=1,jpj
	234	ua(1:2,jj,jk) = (zua(1:2,jj,jk)/(rhoy*e2u(1:2,jj)))
	235	ua(1:2,jj,jk) = ua(1:2,jj,jk) / fse3u(1:2,jj,jk)
	236	END DO
	237	END DO
[390]	238
[636]	239	DO jk=1,jpkm1
	240	DO jj=1,jpj
	241	ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk)
	242	END DO
	243	END DO
[390]	244
[636]	245	spgu(2,:)=0.
[390]	246
[636]	247	DO jk=1,jpkm1
	248	DO jj=1,jpj
	249	spgu(2,jj)=spgu(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk)
	250	END DO
	251	END DO
[390]	252
[636]	253	DO jj=1,jpj
	254	IF (umask(2,jj,1).NE.0.) THEN
	255	spgu(2,jj)=spgu(2,jj)/hu(2,jj)
	256	ENDIF
	257	END DO
[390]	258
[636]	259	DO jk=1,jpkm1
	260	DO jj=1,jpj
	261	ua(2,jj,jk) = 0.25(ua(1,jj,jk)+2.ua(2,jj,jk)+ua(3,jj,jk))
	262	ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk)
	263	END DO
	264	END DO
[390]	265
[636]	266	spgu1(2,:)=0.
[390]	267
[636]	268	DO jk=1,jpkm1
	269	DO jj=1,jpj
	270	spgu1(2,jj)=spgu1(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk)
	271	END DO
	272	END DO
[390]	273
[636]	274	DO jj=1,jpj
	275	IF (umask(2,jj,1).NE.0.) THEN
	276	spgu1(2,jj)=spgu1(2,jj)/hu(2,jj)
	277	ENDIF
	278	END DO
[390]	279
[636]	280	DO jk=1,jpkm1
	281	DO jj=1,jpj
	282	ua(2,jj,jk) = (ua(2,jj,jk)+spgu(2,jj)-spgu1(2,jj))*umask(2,jj,jk)
	283	END DO
	284	END DO
[390]	285
[636]	286	DO jk=1,jpkm1
	287	DO jj=1,jpj
	288	va(2,jj,jk) = (zva(2,jj,jk)/(zrhoxe1v(2,jj)))vmask(2,jj,jk)
	289	va(2,jj,jk) = va(2,jj,jk) / fse3v(2,jj,jk)
	290	END DO
	291	END DO
[390]	292
[636]	293	ENDIF
[390]	294
[636]	295	IF((nbondi == 1).OR.(nbondi == 2)) THEN
[390]	296
[636]	297	DO jj=1,jpj
	298	laplacu(nlci-2,jj) = timeref * (zua2d(nlci-2,jj)/(rhoy*e2u(nlci-2,jj)))
	299	END DO
[390]	300
[636]	301	DO jk=1,jpkm1
	302	DO jj=1,jpj
	303	ua(nlci-2:nlci-1,jj,jk) = (zua(nlci-2:nlci-1,jj,jk)/(rhoy*e2u(nlci-2:nlci-1,jj)))
	304
	305	ua(nlci-2:nlci-1,jj,jk) = ua(nlci-2:nlci-1,jj,jk) / fse3u(nlci-2:nlci-1,jj,jk)
[390]	306
[636]	307	END DO
	308	END DO
[390]	309
[636]	310	DO jk=1,jpkm1
	311	DO jj=1,jpj
	312	ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)- z2dt * znugdt * laplacu(nlci-2,jj))*umask(nlci-2,jj,jk)
	313	END DO
	314	END DO
[390]	315
	316
[636]	317	spgu(nlci-2,:)=0.
[390]	318
[636]	319	do jk=1,jpkm1
	320	do jj=1,jpj
	321	spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk)
	322	enddo
	323	enddo
[390]	324
[636]	325	DO jj=1,jpj
	326	IF (umask(nlci-2,jj,1).NE.0.) THEN
	327	spgu(nlci-2,jj)=spgu(nlci-2,jj)/hu(nlci-2,jj)
	328	ENDIF
	329	END DO
[390]	330
[636]	331	DO jk=1,jpkm1
	332	DO jj=1,jpj
	333	ua(nlci-2,jj,jk) = 0.25(ua(nlci-3,jj,jk)+2.ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk))
[390]	334
[636]	335	ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk)
[390]	336
[636]	337	END DO
	338	END DO
[390]	339
[636]	340	spgu1(nlci-2,:)=0.
[390]	341
[636]	342	DO jk=1,jpkm1
	343	DO jj=1,jpj
	344	spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u(nlci-2,jj,jk)ua(nlci-2,jj,jk)umask(nlci-2,jj,jk)
	345	END DO
	346	END DO
[390]	347
[636]	348	DO jj=1,jpj
	349	IF (umask(nlci-2,jj,1).NE.0.) THEN
	350	spgu1(nlci-2,jj)=spgu1(nlci-2,jj)/hu(nlci-2,jj)
	351	ENDIF
	352	END DO
[390]	353
[636]	354	DO jk=1,jpkm1
	355	DO jj=1,jpj
	356	ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)+spgu(nlci-2,jj)-spgu1(nlci-2,jj))*umask(nlci-2,jj,jk)
	357	END DO
	358	END DO
[390]	359
[636]	360	DO jk=1,jpkm1
	361	DO jj=1,jpj-1
	362	va(nlci-1,jj,jk) = (zva(nlci-1,jj,jk)/(zrhoxe1v(nlci-1,jj)))vmask(nlci-1,jj,jk)
	363	va(nlci-1,jj,jk) = va(nlci-1,jj,jk) / fse3v(nlci-1,jj,jk)
	364	END DO
	365	END DO
[390]	366
[636]	367	ENDIF
[390]	368
[636]	369	IF((nbondj == -1).OR.(nbondj == 2)) THEN
[390]	370
[636]	371	DO ji=1,jpi
	372	laplacv(ji,2) = timeref * (zva2d(ji,2)/(zrhox*e1v(ji,2)))
	373	END DO
[390]	374
[636]	375	DO jk=1,jpkm1
	376	DO ji=1,jpi
	377	va(ji,1:2,jk) = (zva(ji,1:2,jk)/(zrhox*e1v(ji,1:2)))
	378	va(ji,1:2,jk) = va(ji,1:2,jk) / fse3v(ji,1:2,jk)
	379	END DO
	380	END DO
[390]	381
[636]	382	DO jk=1,jpkm1
	383	DO ji=1,jpi
	384	va(ji,2,jk) = (va(ji,2,jk) - z2dt * znugdt * laplacv(ji,2))*vmask(ji,2,jk)
	385	END DO
	386	END DO
[390]	387
[636]	388	spgv(:,2)=0.
[390]	389
[636]	390	DO jk=1,jpkm1
	391	DO ji=1,jpi
	392	spgv(ji,2)=spgv(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk)
	393	END DO
	394	END DO
[390]	395
[636]	396	DO ji=1,jpi
	397	IF (vmask(ji,2,1).NE.0.) THEN
	398	spgv(ji,2)=spgv(ji,2)/hv(ji,2)
	399	ENDIF
	400	END DO
[390]	401
[636]	402	DO jk=1,jpkm1
	403	DO ji=1,jpi
	404	va(ji,2,jk)=0.25(va(ji,1,jk)+2.va(ji,2,jk)+va(ji,3,jk))
	405	va(ji,2,jk)=va(ji,2,jk)*vmask(ji,2,jk)
	406	END DO
	407	END DO
[390]	408
[636]	409	spgv1(:,2)=0.
[390]	410
[636]	411	DO jk=1,jpkm1
	412	DO ji=1,jpi
	413	spgv1(ji,2)=spgv1(ji,2)+fse3v(ji,2,jk)va(ji,2,jk)vmask(ji,2,jk)
	414	END DO
	415	END DO
[390]	416
[636]	417	DO ji=1,jpi
	418	IF (vmask(ji,2,1).NE.0.) THEN
	419	spgv1(ji,2)=spgv1(ji,2)/hv(ji,2)
	420	ENDIF
	421	END DO
[390]	422
[636]	423	DO jk=1,jpkm1
	424	DO ji=1,jpi
	425	va(ji,2,jk) = (va(ji,2,jk)+spgv(ji,2)-spgv1(ji,2))*vmask(ji,2,jk)
	426	END DO
	427	END DO
[390]	428
[636]	429	DO jk=1,jpkm1
	430	DO ji=1,jpi
	431	ua(ji,2,jk) = (zua(ji,2,jk)/(rhoye2u(ji,2)))umask(ji,2,jk)
	432	ua(ji,2,jk) = ua(ji,2,jk) / fse3u(ji,2,jk)
	433	END DO
	434	END DO
[390]	435
[636]	436	ENDIF
[390]	437
[636]	438	IF((nbondj == 1).OR.(nbondj == 2)) THEN
[390]	439
[636]	440	DO ji=1,jpi
	441	laplacv(ji,nlcj-2) = timeref * (zva2d(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2)))
	442	END DO
[390]	443
[636]	444	DO jk=1,jpkm1
	445	DO ji=1,jpi
	446	va(ji,nlcj-2:nlcj-1,jk) = (zva(ji,nlcj-2:nlcj-1,jk)/(zrhox*e1v(ji,nlcj-2:nlcj-1)))
	447	va(ji,nlcj-2:nlcj-1,jk) = va(ji,nlcj-2:nlcj-1,jk) / fse3v(ji,nlcj-2:nlcj-1,jk)
	448	END DO
	449	END DO
[390]	450
[636]	451	DO jk=1,jpkm1
	452	DO ji=1,jpi
	453	va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)-z2dt * znugdt * laplacv(ji,nlcj-2))*vmask(ji,nlcj-2,jk)
	454	END DO
	455	END DO
[390]	456
	457
[636]	458	spgv(:,nlcj-2)=0.
[390]	459
[636]	460	DO jk=1,jpkm1
	461	DO ji=1,jpi
	462	spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk)
	463	END DO
	464	END DO
[390]	465
[636]	466	DO ji=1,jpi
	467	IF (vmask(ji,nlcj-2,1).NE.0.) THEN
	468	spgv(ji,nlcj-2)=spgv(ji,nlcj-2)/hv(ji,nlcj-2)
	469	ENDIF
	470	END DO
[390]	471
[636]	472	DO jk=1,jpkm1
	473	DO ji=1,jpi
	474	va(ji,nlcj-2,jk)=0.25(va(ji,nlcj-3,jk)+2.va(ji,nlcj-2,jk)+va(ji,nlcj-1,jk))
	475	va(ji,nlcj-2,jk) = va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk)
	476	END DO
	477	END DO
[390]	478
[636]	479	spgv1(:,nlcj-2)=0.
[390]	480
[636]	481	DO jk=1,jpkm1
	482	DO ji=1,jpi
	483	spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk)
	484	END DO
	485	END DO
[390]	486
[636]	487	DO ji=1,jpi
	488	IF (vmask(ji,nlcj-2,1).NE.0.) THEN
	489	spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)/hv(ji,nlcj-2)
	490	ENDIF
	491	END DO
[390]	492
[636]	493	DO jk=1,jpkm1
	494	DO ji=1,jpi
	495	va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)+spgv(ji,nlcj-2)-spgv1(ji,nlcj-2))*vmask(ji,nlcj-2,jk)
	496	END DO
	497	END DO
[390]	498
[636]	499	DO jk=1,jpkm1
	500	DO ji=1,jpi
	501	ua(ji,nlcj-1,jk) = (zua(ji,nlcj-1,jk)/(rhoye2u(ji,nlcj-1)))umask(ji,nlcj-1,jk)
	502	ua(ji,nlcj-1,jk) = ua(ji,nlcj-1,jk) / fse3u(ji,nlcj-1,jk)
	503	END DO
	504	END DO
[390]	505
[636]	506	ENDIF
[2715]	507	!
	508	IF( wrk_not_released(3, 1,2) .OR. wrk_not_released(2, 4,5,6,7)) THEN
	509	CALL ctl_stop('agrif_dyn: failed to release workspace arrays.')
	510	ENDIF
	511	!
[636]	512	END SUBROUTINE Agrif_dyn
[390]	513
[1605]	514
[2486]	515	SUBROUTINE Agrif_ssh( kt )
	516	!!----------------------------------------------------------------------
[2528]	517	!! * ROUTINE Agrif_DYN *
[2486]	518	!!----------------------------------------------------------------------
	519	INTEGER, INTENT(in) :: kt
	520	!!
	521	!!----------------------------------------------------------------------
	522
	523	IF( Agrif_Root() ) RETURN
	524
[2528]	525
[2486]	526	IF((nbondi == -1).OR.(nbondi == 2)) THEN
	527	ssha(2,:)=ssha(3,:)
	528	sshn(2,:)=sshn(3,:)
	529	ENDIF
	530
	531	IF((nbondi == 1).OR.(nbondi == 2)) THEN
	532	ssha(nlci-1,:)=ssha(nlci-2,:)
	533	sshn(nlci-1,:)=sshn(nlci-2,:)
	534	ENDIF
	535
	536	IF((nbondj == -1).OR.(nbondj == 2)) THEN
	537	ssha(:,2)=sshn(:,3)
	538	sshn(:,2)=sshb(:,3)
	539	ENDIF
	540
	541	IF((nbondj == 1).OR.(nbondj == 2)) THEN
	542	ssha(:,nlcj-1)=ssha(:,nlcj-2)
	543	ssha(:,nlcj-1)=sshn(:,nlcj-2)
	544	ENDIF
	545
	546	END SUBROUTINE Agrif_ssh
	547
	548
[636]	549	SUBROUTINE interpu(tabres,i1,i2,j1,j2,k1,k2)
[1605]	550	!!----------------------------------------------------------------------
	551	!! * ROUTINE interpu *
	552	!!----------------------------------------------------------------------
[636]	553	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
	554	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
[1605]	555	!!
[636]	556	INTEGER :: ji,jj,jk
[1605]	557	!!----------------------------------------------------------------------
[636]	558
	559	DO jk=k1,k2
	560	DO jj=j1,j2
	561	DO ji=i1,i2
	562	tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk)
	563	tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u(ji,jj,jk)
	564	END DO
	565	END DO
	566	END DO
	567	END SUBROUTINE interpu
[390]	568
[1605]	569
[636]	570	SUBROUTINE interpu2d(tabres,i1,i2,j1,j2)
[1605]	571	!!----------------------------------------------------------------------
	572	!! * ROUTINE interpu2d *
	573	!!----------------------------------------------------------------------
[636]	574	INTEGER, INTENT(in) :: i1,i2,j1,j2
	575	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
[1605]	576	!!
[636]	577	INTEGER :: ji,jj
[1605]	578	!!----------------------------------------------------------------------
[390]	579
[636]	580	DO jj=j1,j2
	581	DO ji=i1,i2
	582	tabres(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj)) &
	583	* umask(ji,jj,1)
	584	END DO
	585	END DO
	586
	587	END SUBROUTINE interpu2d
	588
[1605]	589
[636]	590	SUBROUTINE interpv(tabres,i1,i2,j1,j2,k1,k2)
[1605]	591	!!----------------------------------------------------------------------
	592	!! * ROUTINE interpv *
	593	!!----------------------------------------------------------------------
[636]	594	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
	595	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
[1605]	596	!!
[636]	597	INTEGER :: ji, jj, jk
[1605]	598	!!----------------------------------------------------------------------
[636]	599
	600	DO jk=k1,k2
	601	DO jj=j1,j2
	602	DO ji=i1,i2
	603	tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk)
	604	tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v(ji,jj,jk)
	605	END DO
	606	END DO
	607	END DO
[390]	608
[636]	609	END SUBROUTINE interpv
[390]	610
[1605]	611
[636]	612	SUBROUTINE interpv2d(tabres,i1,i2,j1,j2)
[1605]	613	!!----------------------------------------------------------------------
	614	!! * ROUTINE interpu2d *
	615	!!----------------------------------------------------------------------
[636]	616	INTEGER, INTENT(in) :: i1,i2,j1,j2
	617	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
[1605]	618	!!
[636]	619	INTEGER :: ji,jj
[1605]	620	!!----------------------------------------------------------------------
[636]	621
	622	DO jj=j1,j2
	623	DO ji=i1,i2
	624	tabres(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) &
	625	* vmask(ji,jj,1)
	626	END DO
	627	END DO
	628
	629	END SUBROUTINE interpv2d
	630
[390]	631	#else
[1605]	632	!!----------------------------------------------------------------------
	633	!! Empty module no AGRIF zoom
	634	!!----------------------------------------------------------------------
[636]	635	CONTAINS
	636	SUBROUTINE Agrif_OPA_Interp_empty
	637	WRITE(,) 'agrif_opa_interp : You should not have seen this print! error?'
	638	END SUBROUTINE Agrif_OPA_Interp_empty
[390]	639	#endif
[1605]	640
	641	!!======================================================================
[636]	642	END MODULE agrif_opa_interp

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

Download in other formats: