Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

advyp.F @ 5304

Last change on this file since 5304 was 524, checked in by lmdzadmin, 20 years ago
Initial revision
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 18.9 KB

Rev	Line
[524]	1	!
	2	! $Header$
	3	!
	4	SUBROUTINE ADVYP(LIMIT,DTY,PBARV,SM,S0,SSX,SY,SZ
	5	. ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra )
	6	IMPLICIT NONE
	7	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	8	C C
	9	C second-order moments (SOM) advection of tracer in Y direction C
	10	C C
	11	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	12	C C
	13	C Source : Pascal Simon ( Meteo, CNRM ) C
	14	C Adaptation : A.A. (LGGE) C
	15	C Derniere Modif : 19/10/95 LAST
	16	C C
	17	C sont les arguments d'entree pour le s-pg C
	18	C C
	19	C argument de sortie du s-pg C
	20	C C
	21	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	22	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	23	C
	24	C Rem : Probleme aux poles il faut reecrire ce cas specifique
	25	C Attention au sens de l'indexation
	26	C
	27	C parametres principaux du modele
	28	C
	29	C
	30	#include "dimensions.h"
	31	#include "paramet.h"
	32	#include "comconst.h"
	33	#include "comvert.h"
	34	#include "comgeom.h"
	35
	36	C Arguments :
	37	C ----------
	38	C dty : frequence fictive d'appel du transport
	39	C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
	40
	41	INTEGER lon,lat,niv
	42	INTEGER i,j,jv,k,kp,l
	43	INTEGER ntra
	44	C PARAMETER (ntra = 1)
	45
	46	REAL dty
	47	REAL pbarv ( iip1,jjm, llm )
	48
	49	C moments: SM total mass in each grid box
	50	C S0 mass of tracer in each grid box
	51	C Si 1rst order moment in i direction
	52	C
	53	REAL SM(iip1,jjp1,llm)
	54	+ ,S0(iip1,jjp1,llm,ntra)
	55	REAL SSX(iip1,jjp1,llm,ntra)
	56	+ ,SY(iip1,jjp1,llm,ntra)
	57	+ ,SZ(iip1,jjp1,llm,ntra)
	58	+ ,SSXX(iip1,jjp1,llm,ntra)
	59	+ ,SSXY(iip1,jjp1,llm,ntra)
	60	+ ,SSXZ(iip1,jjp1,llm,ntra)
	61	+ ,SYY(iip1,jjp1,llm,ntra)
	62	+ ,SYZ(iip1,jjp1,llm,ntra)
	63	+ ,SZZ(iip1,jjp1,llm,ntra)
	64	C
	65	C Local :
	66	C -------
	67
	68	C mass fluxes across the boundaries (UGRI,VGRI,WGRI)
	69	C mass fluxes in kg
	70	C declaration :
	71
	72	REAL VGRI(iip1,0:jjp1,llm)
	73
	74	C Rem : UGRI et WGRI ne sont pas utilises dans
	75	C cette subroutine ( advection en y uniquement )
	76	C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
	77	C
	78	C the moments F are similarly defined and used as temporary
	79	C storage for portions of the grid boxes in transit
	80	C
	81	C the moments Fij are used as temporary storage for
	82	C portions of the grid boxes in transit at the current level
	83	C
	84	C work arrays
	85	C
	86	C
	87	REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1)
	88	REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra)
	89	REAL FZ(iim,jjm,ntra)
	90	REAL FXX(iim,jjm,ntra),FXY(iim,jjm,ntra)
	91	REAL FXZ(iim,jjm,ntra),FYY(iim,jjm,ntra)
	92	REAL FYZ(iim,jjm,ntra),FZZ(iim,jjm,ntra)
	93	REAL S00(ntra)
	94	REAL SM0 ! Just temporal variable
	95	C
	96	C work arrays
	97	C
	98	REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1)
	99	REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1)
	100	REAL ALF2(iim,0:jjp1),ALF3(iim,0:jjp1)
	101	REAL ALF4(iim,0:jjp1)
	102	REAL TEMPTM ! Just temporal variable
	103	REAL SLPMAX,S1MAX,S1NEW,S2NEW
	104	c
	105	C Special pour poles
	106	c
	107	REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn
	108	REAL sns0(ntra),snsz(ntra),snsm
	109	REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra)
	110	REAL cx1(llm,ntra), cxLAT(llm,ntra)
	111	REAL cy1(llm,ntra), cyLAT(llm,ntra)
	112	REAL z1(iim), zcos(iim), zsin(iim)
	113	REAL SSUM
	114	EXTERNAL SSUM
	115	C
	116	REAL sqi,sqf
	117	LOGICAL LIMIT
	118
	119	lon = iim ! rem : Il est possible qu'un pbl. arrive ici
	120	lat = jjp1 ! a cause des dim. differentes entre les
	121	niv = llm ! tab. S et VGRI
	122
	123	c-----------------------------------------------------------------
	124	C initialisations
	125
	126	sbms = 0.
	127	sfms = 0.
	128	sfzs = 0.
	129	sbmn = 0.
	130	sfmn = 0.
	131	sfzn = 0.
	132
	133	c-----------------------------------------------------------------
	134	C *** Test : diag de la qtite totale de traceur dans
	135	C l'atmosphere avant l'advection en Y
	136	c
	137	sqi = 0.
	138	sqf = 0.
	139
	140	DO l = 1,llm
	141	DO j = 1,jjp1
	142	DO i = 1,iim
	143	sqi = sqi + S0(i,j,l,ntra)
	144	END DO
	145	END DO
	146	END DO
	147	PRINT*,'---------- DIAG DANS ADVY - ENTREE --------'
	148	PRINT*,'sqi=',sqi
	149
	150	c-----------------------------------------------------------------
	151	C Interface : adaptation nouveau modele
	152	C -------------------------------------
	153	C
	154	C Conversion des flux de masses en kg
	155	C-AA 20/10/94 le signe -1 est necessaire car indexation opposee
	156
	157	DO 500 l = 1,llm
	158	DO 500 j = 1,jjm
	159	DO 500 i = 1,iip1
	160	vgri (i,j,llm+1-l)=-1.*pbarv (i,j,l)
	161	500 CONTINUE
	162
	163	CAA Initialisation de flux fictifs aux bords sup. des boites pol.
	164
	165	DO l = 1,llm
	166	DO i = 1,iip1
	167	vgri(i,0,l) = 0.
	168	vgri(i,jjp1,l) = 0.
	169	ENDDO
	170	ENDDO
	171	c
	172	c----------------- START HERE -----------------------
	173	C boucle sur les niveaux
	174	C
	175	DO 1 L=1,NIV
	176	C
	177	C place limits on appropriate moments before transport
	178	C (if flux-limiting is to be applied)
	179	C
	180	IF(.NOT.LIMIT) GO TO 11
	181	C
	182	DO 10 JV=1,NTRA
	183	DO 10 K=1,LAT
	184	DO 100 I=1,LON
	185	IF(S0(I,K,L,JV).GT.0.) THEN
	186	SLPMAX=AMAX1(S0(I,K,L,JV),0.)
	187	S1MAX=1.5*SLPMAX
	188	S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,SY(I,K,L,JV)))
	189	S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. ,
	190	+ AMAX1(ABS(S1NEW)-SLPMAX,SYY(I,K,L,JV)) )
	191	SY (I,K,L,JV)=S1NEW
	192	SYY(I,K,L,JV)=S2NEW
	193	SSXY(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXY(I,K,L,JV)))
	194	SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV)))
	195	ELSE
	196	SY (I,K,L,JV)=0.
	197	SYY(I,K,L,JV)=0.
	198	SSXY(I,K,L,JV)=0.
	199	SYZ(I,K,L,JV)=0.
	200	ENDIF
	201	100 CONTINUE
	202	10 CONTINUE
	203	C
	204	11 CONTINUE
	205	C
	206	C le flux a travers le pole Nord est traite separement
	207	C
	208	SM0=0.
	209	DO 20 JV=1,NTRA
	210	S00(JV)=0.
	211	20 CONTINUE
	212	C
	213	DO 21 I=1,LON
	214	C
	215	IF(VGRI(I,0,L).LE.0.) THEN
	216	FM(I,0)=-VGRI(I,0,L)*DTY
	217	ALF(I,0)=FM(I,0)/SM(I,1,L)
	218	SM(I,1,L)=SM(I,1,L)-FM(I,0)
	219	SM0=SM0+FM(I,0)
	220	ENDIF
	221	C
	222	ALFQ(I,0)=ALF(I,0)*ALF(I,0)
	223	ALF1(I,0)=1.-ALF(I,0)
	224	ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
	225	ALF2(I,0)=ALF1(I,0)-ALF(I,0)
	226	ALF3(I,0)=ALF(I,0)*ALFQ(I,0)
	227	ALF4(I,0)=ALF1(I,0)*ALF1Q(I,0)
	228	C
	229	21 CONTINUE
	230	c print*,'ADVYP 21'
	231	C
	232	DO 22 JV=1,NTRA
	233	DO 220 I=1,LON
	234	C
	235	IF(VGRI(I,0,L).LE.0.) THEN
	236	C
	237	F0(I,0,JV)=ALF(I,0)* ( S0(I,1,L,JV)-ALF1(I,0)*
	238	+ ( SY(I,1,L,JV)-ALF2(I,0)*SYY(I,1,L,JV) ) )
	239	C
	240	S00(JV)=S00(JV)+F0(I,0,JV)
	241	S0 (I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)
	242	SY (I,1,L,JV)=ALF1Q(I,0)*
	243	+ (SY(I,1,L,JV)+3.ALF(I,0)SYY(I,1,L,JV))
	244	SYY(I,1,L,JV)=ALF4 (I,0)*SYY(I,1,L,JV)
	245	SSX (I,1,L,JV)=ALF1 (I,0)*
	246	+ (SSX(I,1,L,JV)+ALF(I,0)*SSXY(I,1,L,JV) )
	247	SZ (I,1,L,JV)=ALF1 (I,0)*
	248	+ (SZ(I,1,L,JV)+ALF(I,0)*SSXZ(I,1,L,JV) )
	249	SSXX(I,1,L,JV)=ALF1 (I,0)*SSXX(I,1,L,JV)
	250	SSXZ(I,1,L,JV)=ALF1 (I,0)*SSXZ(I,1,L,JV)
	251	SZZ(I,1,L,JV)=ALF1 (I,0)*SZZ(I,1,L,JV)
	252	SSXY(I,1,L,JV)=ALF1Q(I,0)*SSXY(I,1,L,JV)
	253	SYZ(I,1,L,JV)=ALF1Q(I,0)*SYZ(I,1,L,JV)
	254	C
	255	ENDIF
	256	C
	257	220 CONTINUE
	258	22 CONTINUE
	259	C
	260	DO 23 I=1,LON
	261	IF(VGRI(I,0,L).GT.0.) THEN
	262	FM(I,0)=VGRI(I,0,L)*DTY
	263	ALF(I,0)=FM(I,0)/SM0
	264	ENDIF
	265	23 CONTINUE
	266	C
	267	DO 24 JV=1,NTRA
	268	DO 240 I=1,LON
	269	IF(VGRI(I,0,L).GT.0.) THEN
	270	F0(I,0,JV)=ALF(I,0)*S00(JV)
	271	ENDIF
	272	240 CONTINUE
	273	24 CONTINUE
	274	C
	275	C puts the temporary moments Fi into appropriate neighboring boxes
	276	C
	277	c print*,'av ADVYP 25'
	278	DO 25 I=1,LON
	279	C
	280	IF(VGRI(I,0,L).GT.0.) THEN
	281	SM(I,1,L)=SM(I,1,L)+FM(I,0)
	282	ALF(I,0)=FM(I,0)/SM(I,1,L)
	283	ENDIF
	284	C
	285	ALFQ(I,0)=ALF(I,0)*ALF(I,0)
	286	ALF1(I,0)=1.-ALF(I,0)
	287	ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
	288	ALF2(I,0)=ALF1(I,0)-ALF(I,0)
	289	ALF3(I,0)=ALF1(I,0)*ALF(I,0)
	290	C
	291	25 CONTINUE
	292	c print*,'av ADVYP 25'
	293	C
	294	DO 26 JV=1,NTRA
	295	DO 260 I=1,LON
	296	C
	297	IF(VGRI(I,0,L).GT.0.) THEN
	298	C
	299	TEMPTM=ALF(I,0)S0(I,1,L,JV)-ALF1(I,0)F0(I,0,JV)
	300	S0 (I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)
	301	SYY(I,1,L,JV)=ALF1Q(I,0)*SYY(I,1,L,JV)
	302	+ +5.( ALF3 (I,0)SY (I,1,L,JV)-ALF2(I,0)*TEMPTM )
	303	SY (I,1,L,JV)=ALF1 (I,0)SY (I,1,L,JV)+3.TEMPTM
	304	SSXY(I,1,L,JV)=ALF1 (I,0)SSXY(I,1,L,JV)+3.ALF(I,0)*SSX(I,1,L,JV)
	305	SYZ(I,1,L,JV)=ALF1 (I,0)SYZ(I,1,L,JV)+3.ALF(I,0)*SZ(I,1,L,JV)
	306	C
	307	ENDIF
	308	C
	309	260 CONTINUE
	310	26 CONTINUE
	311	C
	312	C calculate flux and moments between adjacent boxes
	313	C 1- create temporary moments/masses for partial boxes in transit
	314	C 2- reajusts moments remaining in the box
	315	C
	316	C flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
	317	C
	318	c print*,'av ADVYP 30'
	319	DO 30 K=1,LAT-1
	320	KP=K+1
	321	DO 300 I=1,LON
	322	C
	323	IF(VGRI(I,K,L).LT.0.) THEN
	324	FM(I,K)=-VGRI(I,K,L)*DTY
	325	ALF(I,K)=FM(I,K)/SM(I,KP,L)
	326	SM(I,KP,L)=SM(I,KP,L)-FM(I,K)
	327	ELSE
	328	FM(I,K)=VGRI(I,K,L)*DTY
	329	ALF(I,K)=FM(I,K)/SM(I,K,L)
	330	SM(I,K,L)=SM(I,K,L)-FM(I,K)
	331	ENDIF
	332	C
	333	ALFQ(I,K)=ALF(I,K)*ALF(I,K)
	334	ALF1(I,K)=1.-ALF(I,K)
	335	ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
	336	ALF2(I,K)=ALF1(I,K)-ALF(I,K)
	337	ALF3(I,K)=ALF(I,K)*ALFQ(I,K)
	338	ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K)
	339	C
	340	300 CONTINUE
	341	30 CONTINUE
	342	c print*,'ap ADVYP 30'
	343	C
	344	DO 31 JV=1,NTRA
	345	DO 31 K=1,LAT-1
	346	KP=K+1
	347	DO 310 I=1,LON
	348	C
	349	IF(VGRI(I,K,L).LT.0.) THEN
	350	C
	351	F0 (I,K,JV)=ALF (I,K)* ( S0(I,KP,L,JV)-ALF1(I,K)*
	352	+ ( SY(I,KP,L,JV)-ALF2(I,K)*SYY(I,KP,L,JV) ) )
	353	FY (I,K,JV)=ALFQ(I,K)*
	354	+ (SY(I,KP,L,JV)-3.ALF1(I,K)SYY(I,KP,L,JV))
	355	FYY(I,K,JV)=ALF3(I,K)*SYY(I,KP,L,JV)
	356	FX (I,K,JV)=ALF (I,K)*
	357	+ (SSX(I,KP,L,JV)-ALF1(I,K)*SSXY(I,KP,L,JV))
	358	FZ (I,K,JV)=ALF (I,K)*
	359	+ (SZ(I,KP,L,JV)-ALF1(I,K)*SYZ(I,KP,L,JV))
	360	FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,KP,L,JV)
	361	FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,KP,L,JV)
	362	FXX(I,K,JV)=ALF (I,K)*SSXX(I,KP,L,JV)
	363	FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,KP,L,JV)
	364	FZZ(I,K,JV)=ALF (I,K)*SZZ(I,KP,L,JV)
	365	C
	366	S0 (I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)
	367	SY (I,KP,L,JV)=ALF1Q(I,K)*
	368	+ (SY(I,KP,L,JV)+3.ALF(I,K)SYY(I,KP,L,JV))
	369	SYY(I,KP,L,JV)=ALF4(I,K)*SYY(I,KP,L,JV)
	370	SSX (I,KP,L,JV)=SSX (I,KP,L,JV)-FX (I,K,JV)
	371	SZ (I,KP,L,JV)=SZ (I,KP,L,JV)-FZ (I,K,JV)
	372	SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)-FXX(I,K,JV)
	373	SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)-FXZ(I,K,JV)
	374	SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)-FZZ(I,K,JV)
	375	SSXY(I,KP,L,JV)=ALF1Q(I,K)*SSXY(I,KP,L,JV)
	376	SYZ(I,KP,L,JV)=ALF1Q(I,K)*SYZ(I,KP,L,JV)
	377	C
	378	ELSE
	379	C
	380	F0 (I,K,JV)=ALF (I,K)* ( S0(I,K,L,JV)+ALF1(I,K)*
	381	+ ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) )
	382	FY (I,K,JV)=ALFQ(I,K)*
	383	+ (SY(I,K,L,JV)+3.ALF1(I,K)SYY(I,K,L,JV))
	384	FYY(I,K,JV)=ALF3(I,K)*SYY(I,K,L,JV)
	385	FX (I,K,JV)=ALF (I,K)(SSX(I,K,L,JV)+ALF1(I,K)SSXY(I,K,L,JV))
	386	FZ (I,K,JV)=ALF (I,K)(SZ(I,K,L,JV)+ALF1(I,K)SYZ(I,K,L,JV))
	387	FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,K,L,JV)
	388	FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,K,L,JV)
	389	FXX(I,K,JV)=ALF (I,K)*SSXX(I,K,L,JV)
	390	FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,K,L,JV)
	391	FZZ(I,K,JV)=ALF (I,K)*SZZ(I,K,L,JV)
	392	C
	393	S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
	394	SY (I,K,L,JV)=ALF1Q(I,K)*
	395	+ (SY(I,K,L,JV)-3.ALF(I,K)SYY(I,K,L,JV))
	396	SYY(I,K,L,JV)=ALF4(I,K)*SYY(I,K,L,JV)
	397	SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,K,JV)
	398	SZ (I,K,L,JV)=SZ (I,K,L,JV)-FZ (I,K,JV)
	399	SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,K,JV)
	400	SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)-FXZ(I,K,JV)
	401	SZZ(I,K,L,JV)=SZZ(I,K,L,JV)-FZZ(I,K,JV)
	402	SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV)
	403	SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV)
	404	C
	405	ENDIF
	406	C
	407	310 CONTINUE
	408	31 CONTINUE
	409	c print*,'ap ADVYP 31'
	410	C
	411	C puts the temporary moments Fi into appropriate neighboring boxes
	412	C
	413	DO 32 K=1,LAT-1
	414	KP=K+1
	415	DO 320 I=1,LON
	416	C
	417	IF(VGRI(I,K,L).LT.0.) THEN
	418	SM(I,K,L)=SM(I,K,L)+FM(I,K)
	419	ALF(I,K)=FM(I,K)/SM(I,K,L)
	420	ELSE
	421	SM(I,KP,L)=SM(I,KP,L)+FM(I,K)
	422	ALF(I,K)=FM(I,K)/SM(I,KP,L)
	423	ENDIF
	424	C
	425	ALFQ(I,K)=ALF(I,K)*ALF(I,K)
	426	ALF1(I,K)=1.-ALF(I,K)
	427	ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
	428	ALF2(I,K)=ALF1(I,K)-ALF(I,K)
	429	ALF3(I,K)=ALF1(I,K)*ALF(I,K)
	430	C
	431	320 CONTINUE
	432	32 CONTINUE
	433	c print*,'ap ADVYP 32'
	434	C
	435	DO 33 JV=1,NTRA
	436	DO 33 K=1,LAT-1
	437	KP=K+1
	438	DO 330 I=1,LON
	439	C
	440	IF(VGRI(I,K,L).LT.0.) THEN
	441	C
	442	TEMPTM=-ALF(I,K)S0(I,K,L,JV)+ALF1(I,K)F0(I,K,JV)
	443	S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
	444	SYY(I,K,L,JV)=ALFQ(I,K)FYY(I,K,JV)+ALF1Q(I,K)SYY(I,K,L,JV)
	445	+ +5.( ALF3(I,K)(FY(I,K,JV)-SY(I,K,L,JV))+ALF2(I,K)*TEMPTM )
	446	SY (I,K,L,JV)=ALF(I,K)FY(I,K,JV)+ALF1(I,K)SY(I,K,L,JV)
	447	+ +3.*TEMPTM
	448	SSXY(I,K,L,JV)=ALF (I,K)FXY(I,K,JV)+ALF1(I,K)SSXY(I,K,L,JV)
	449	+ +3.(ALF1(I,K)FX (I,K,JV)-ALF (I,K)*SSX (I,K,L,JV))
	450	SYZ(I,K,L,JV)=ALF (I,K)FYZ(I,K,JV)+ALF1(I,K)SYZ(I,K,L,JV)
	451	+ +3.(ALF1(I,K)FZ (I,K,JV)-ALF (I,K)*SZ (I,K,L,JV))
	452	SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,K,JV)
	453	SZ (I,K,L,JV)=SZ (I,K,L,JV)+FZ (I,K,JV)
	454	SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,K,JV)
	455	SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)+FXZ(I,K,JV)
	456	SZZ(I,K,L,JV)=SZZ(I,K,L,JV)+FZZ(I,K,JV)
	457	C
	458	ELSE
	459	C
	460	TEMPTM=ALF(I,K)S0(I,KP,L,JV)-ALF1(I,K)F0(I,K,JV)
	461	S0 (I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV)
	462	SYY(I,KP,L,JV)=ALFQ(I,K)FYY(I,K,JV)+ALF1Q(I,K)SYY(I,KP,L,JV)
	463	+ +5.( ALF3(I,K)(SY(I,KP,L,JV)-FY(I,K,JV))-ALF2(I,K)*TEMPTM )
	464	SY (I,KP,L,JV)=ALF(I,K)FY(I,K,JV)+ALF1(I,K)SY(I,KP,L,JV)
	465	+ +3.*TEMPTM
	466	SSXY(I,KP,L,JV)=ALF(I,K)FXY(I,K,JV)+ALF1(I,K)SSXY(I,KP,L,JV)
	467	+ +3.(ALF(I,K)SSX(I,KP,L,JV)-ALF1(I,K)*FX(I,K,JV))
	468	SYZ(I,KP,L,JV)=ALF(I,K)FYZ(I,K,JV)+ALF1(I,K)SYZ(I,KP,L,JV)
	469	+ +3.(ALF(I,K)SZ(I,KP,L,JV)-ALF1(I,K)*FZ(I,K,JV))
	470	SSX (I,KP,L,JV)=SSX (I,KP,L,JV)+FX (I,K,JV)
	471	SZ (I,KP,L,JV)=SZ (I,KP,L,JV)+FZ (I,K,JV)
	472	SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)+FXX(I,K,JV)
	473	SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)+FXZ(I,K,JV)
	474	SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)+FZZ(I,K,JV)
	475	C
	476	ENDIF
	477	C
	478	330 CONTINUE
	479	33 CONTINUE
	480	c print*,'ap ADVYP 33'
	481	C
	482	C traitement special pour le pole Sud (idem pole Nord)
	483	C
	484	K=LAT
	485	C
	486	SM0=0.
	487	DO 40 JV=1,NTRA
	488	S00(JV)=0.
	489	40 CONTINUE
	490	C
	491	DO 41 I=1,LON
	492	C
	493	IF(VGRI(I,K,L).GE.0.) THEN
	494	FM(I,K)=VGRI(I,K,L)*DTY
	495	ALF(I,K)=FM(I,K)/SM(I,K,L)
	496	SM(I,K,L)=SM(I,K,L)-FM(I,K)
	497	SM0=SM0+FM(I,K)
	498	ENDIF
	499	C
	500	ALFQ(I,K)=ALF(I,K)*ALF(I,K)
	501	ALF1(I,K)=1.-ALF(I,K)
	502	ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
	503	ALF2(I,K)=ALF1(I,K)-ALF(I,K)
	504	ALF3(I,K)=ALF(I,K)*ALFQ(I,K)
	505	ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K)
	506	C
	507	41 CONTINUE
	508	c print*,'ap ADVYP 41'
	509	C
	510	DO 42 JV=1,NTRA
	511	DO 420 I=1,LON
	512	C
	513	IF(VGRI(I,K,L).GE.0.) THEN
	514	F0 (I,K,JV)=ALF(I,K)* ( S0(I,K,L,JV)+ALF1(I,K)*
	515	+ ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) )
	516	S00(JV)=S00(JV)+F0(I,K,JV)
	517	C
	518	S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
	519	SY (I,K,L,JV)=ALF1Q(I,K)*
	520	+ (SY(I,K,L,JV)-3.ALF(I,K)SYY(I,K,L,JV))
	521	SYY(I,K,L,JV)=ALF4 (I,K)*SYY(I,K,L,JV)
	522	SSX (I,K,L,JV)=ALF1(I,K)(SSX(I,K,L,JV)-ALF(I,K)SSXY(I,K,L,JV))
	523	SZ (I,K,L,JV)=ALF1(I,K)(SZ(I,K,L,JV)-ALF(I,K)SYZ(I,K,L,JV))
	524	SSXX(I,K,L,JV)=ALF1 (I,K)*SSXX(I,K,L,JV)
	525	SSXZ(I,K,L,JV)=ALF1 (I,K)*SSXZ(I,K,L,JV)
	526	SZZ(I,K,L,JV)=ALF1 (I,K)*SZZ(I,K,L,JV)
	527	SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV)
	528	SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV)
	529	ENDIF
	530	C
	531	420 CONTINUE
	532	42 CONTINUE
	533	c print*,'ap ADVYP 42'
	534	C
	535	DO 43 I=1,LON
	536	IF(VGRI(I,K,L).LT.0.) THEN
	537	FM(I,K)=-VGRI(I,K,L)*DTY
	538	ALF(I,K)=FM(I,K)/SM0
	539	ENDIF
	540	43 CONTINUE
	541	c print*,'ap ADVYP 43'
	542	C
	543	DO 44 JV=1,NTRA
	544	DO 440 I=1,LON
	545	IF(VGRI(I,K,L).LT.0.) THEN
	546	F0(I,K,JV)=ALF(I,K)*S00(JV)
	547	ENDIF
	548	440 CONTINUE
	549	44 CONTINUE
	550	C
	551	C puts the temporary moments Fi into appropriate neighboring boxes
	552	C
	553	DO 45 I=1,LON
	554	C
	555	IF(VGRI(I,K,L).LT.0.) THEN
	556	SM(I,K,L)=SM(I,K,L)+FM(I,K)
	557	ALF(I,K)=FM(I,K)/SM(I,K,L)
	558	ENDIF
	559	C
	560	ALFQ(I,K)=ALF(I,K)*ALF(I,K)
	561	ALF1(I,K)=1.-ALF(I,K)
	562	ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
	563	ALF2(I,K)=ALF1(I,K)-ALF(I,K)
	564	ALF3(I,K)=ALF1(I,K)*ALF(I,K)
	565	C
	566	45 CONTINUE
	567	c print*,'ap ADVYP 45'
	568	C
	569	DO 46 JV=1,NTRA
	570	DO 460 I=1,LON
	571	C
	572	IF(VGRI(I,K,L).LT.0.) THEN
	573	C
	574	TEMPTM=-ALF(I,K)S0(I,K,L,JV)+ALF1(I,K)F0(I,K,JV)
	575	S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
	576	SYY(I,K,L,JV)=ALF1Q(I,K)*SYY(I,K,L,JV)
	577	+ +5.(-ALF3 (I,K)SY (I,K,L,JV)+ALF2(I,K)*TEMPTM )
	578	SY (I,K,L,JV)=ALF1(I,K)SY (I,K,L,JV)+3.TEMPTM
	579	SSXY(I,K,L,JV)=ALF1(I,K)SSXY(I,K,L,JV)-3.ALF(I,K)*SSX(I,K,L,JV)
	580	SYZ(I,K,L,JV)=ALF1(I,K)SYZ(I,K,L,JV)-3.ALF(I,K)*SZ(I,K,L,JV)
	581	C
	582	ENDIF
	583	C
	584	460 CONTINUE
	585	46 CONTINUE
	586	c print*,'ap ADVYP 46'
	587	C
	588	1 CONTINUE
	589
	590	c--------------------------------------------------
	591	C bouclage cyclique horizontal .
	592
	593	DO l = 1,llm
	594	DO jv = 1,ntra
	595	DO j = 1,jjp1
	596	SM(iip1,j,l) = SM(1,j,l)
	597	S0(iip1,j,l,jv) = S0(1,j,l,jv)
	598	SSX(iip1,j,l,jv) = SSX(1,j,l,jv)
	599	SY(iip1,j,l,jv) = SY(1,j,l,jv)
	600	SZ(iip1,j,l,jv) = SZ(1,j,l,jv)
	601	END DO
	602	END DO
	603	END DO
	604
	605	c -------------------------------------------------------------------
	606	C *** Test negativite:
	607
	608	c DO jv = 1,ntra
	609	c DO l = 1,llm
	610	c DO j = 1,jjp1
	611	c DO i = 1,iip1
	612	c IF (s0( i,j,l,jv ).lt.0.) THEN
	613	c PRINT*, '------ S0 < 0 en FIN ADVYP ---'
	614	c PRINT*, 'S0(',i,j,l,jv,')=', S0(i,j,l,jv)
	615	cc STOP
	616	c ENDIF
	617	c ENDDO
	618	c ENDDO
	619	c ENDDO
	620	c ENDDO
	621
	622
	623	c -------------------------------------------------------------------
	624	C *** Test : diag de la qtite totale de traceur dans
	625	C l'atmosphere avant l'advection en Y
	626
	627	DO l = 1,llm
	628	DO j = 1,jjp1
	629	DO i = 1,iim
	630	sqf = sqf + S0(i,j,l,ntra)
	631	END DO
	632	END DO
	633	END DO
	634	PRINT*,'---------- DIAG DANS ADVY - SORTIE --------'
	635	PRINT*,'sqf=',sqf
	636	c print*,'ap ADVYP fin'
	637
	638	c-----------------------------------------------------------------
	639	C
	640	RETURN
	641	END
	642
	643
	644
	645
	646
	647
	648
	649
	650
	651
	652
	653

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

Download in other formats:

Original Format