Context Navigation

advxp.F @ 5231

Last change on this file since 5231 was 5084, checked in by Laurent Fairhead, 3 months ago
Reverting to r4065. Updating fortran standard broke too much stuff. Will do it by smaller chunks AB, LF
Property copyright set to Name of program: LMDZ Creation date: 1984 Version: LMDZ5 License: CeCILL version 2 Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539 See the license file in the root directory Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 18.1 KB

Rev	Line
[524]	1	!
	2	! $Header$
	3	!
	4	SUBROUTINE ADVXP(LIMIT,DTX,PBARU,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 X direction C
	10	C C
	11	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	12	C
	13	C parametres principaux du modele
	14	C
[2600]	15	include "dimensions.h"
	16	include "paramet.h"
[524]	17
	18	INTEGER ntra
	19	c PARAMETER (ntra = 1)
	20	C
	21	C definition de la grille du modele
	22	C
	23	REAL dtx
	24	REAL pbaru ( iip1,jjp1,llm )
	25	C
	26	C moments: SM total mass in each grid box
	27	C S0 mass of tracer in each grid box
	28	C Si 1rst order moment in i direction
	29	C Sij 2nd order moment in i and j directions
	30	C
	31	REAL SM(iip1,jjp1,llm)
	32	+ ,S0(iip1,jjp1,llm,ntra)
	33	REAL SSX(iip1,jjp1,llm,ntra)
	34	+ ,SY(iip1,jjp1,llm,ntra)
	35	+ ,SZ(iip1,jjp1,llm,ntra)
	36	REAL SSXX(iip1,jjp1,llm,ntra)
	37	+ ,SSXY(iip1,jjp1,llm,ntra)
	38	+ ,SSXZ(iip1,jjp1,llm,ntra)
	39	+ ,SYY(iip1,jjp1,llm,ntra)
	40	+ ,SYZ(iip1,jjp1,llm,ntra)
	41	+ ,SZZ(iip1,jjp1,llm,ntra)
	42
	43	C Local :
	44	C -------
	45
	46	C mass fluxes across the boundaries (UGRI,VGRI,WGRI)
	47	C mass fluxes in kg
	48	C declaration :
	49
	50	REAL UGRI(iip1,jjp1,llm)
	51
	52	C Rem : VGRI et WGRI ne sont pas utilises dans
	53	C cette subroutine ( advection en x uniquement )
	54	C
	55	C
	56	C Tij are the moments for the current latitude and level
	57	C
	58	REAL TM (iim)
	59	REAL T0 (iim,NTRA),TX (iim,NTRA)
	60	REAL TY (iim,NTRA),TZ (iim,NTRA)
	61	REAL TXX(iim,NTRA),TXY(iim,NTRA)
	62	REAL TXZ(iim,NTRA),TYY(iim,NTRA)
	63	REAL TYZ(iim,NTRA),TZZ(iim,NTRA)
	64	C
	65	C the moments F are similarly defined and used as temporary
	66	C storage for portions of the grid boxes in transit
	67	C
	68	REAL FM (iim)
	69	REAL F0 (iim,NTRA),FX (iim,NTRA)
	70	REAL FY (iim,NTRA),FZ (iim,NTRA)
	71	REAL FXX(iim,NTRA),FXY(iim,NTRA)
	72	REAL FXZ(iim,NTRA),FYY(iim,NTRA)
	73	REAL FYZ(iim,NTRA),FZZ(iim,NTRA)
	74	C
	75	C work arrays
	76	C
	77	REAL ALF (iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)
	78	REAL ALF2(iim),ALF3(iim),ALF4(iim)
	79	C
	80	REAL SMNEW(iim),UEXT(iim)
	81	REAL sqi,sqf
	82	REAL TEMPTM
	83	REAL SLPMAX
	84	REAL S1MAX,S1NEW,S2NEW
	85
	86	LOGICAL LIMIT
	87	INTEGER NUM(jjp1),LONK,NUMK
	88	INTEGER lon,lati,latf,niv
	89	INTEGER i,i2,i3,j,jv,l,k,iter
	90
	91	lon = iim
	92	lati=2
	93	latf = jjm
	94	niv = llm
	95
	96	C * Test de passage d'arguments ****
	97
	98	c DO 399 l = 1, llm
	99	c DO 399 j = 1, jjp1
	100	c DO 399 i = 1, iip1
	101	c IF (S0(i,j,l,ntra) .lt. 0. ) THEN
	102	c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
[2600]	103	c print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra)
[524]	104	c print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra)
	105	c print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra)
	106	c PRINT*, 'AIE !! debut ADVXP - pbl arg. passage dans ADVXP'
	107	cc STOP
	108	c ENDIF
	109	c 399 CONTINUE
	110
	111	C *** Test : diagnostique de la qtite totale de traceur
	112	C dans l'atmosphere avant l'advection
	113	c
	114	sqi =0.
	115	sqf =0.
	116	c
	117	DO l = 1, llm
	118	DO j = 1, jjp1
	119	DO i = 1, iim
[2600]	120	sqi = sqi + S0(i,j,l,ntra)
[524]	121	END DO
	122	END DO
	123	END DO
	124	PRINT*,'------ DIAG DANS ADVX2 - ENTREE -----'
	125	PRINT*,'sqi=',sqi
	126	c test
	127	c -------------------------------------
[5084]	128	DO 300 j =1,jjp1
[524]	129	NUM(j) =1
[5084]	130	300 CONTINUE
[524]	131	c DO l=1,llm
	132	c NUM(2,l)=6
	133	c NUM(3,l)=6
	134	c NUM(jjm-1,l)=6
	135	c NUM(jjm,l)=6
	136	c ENDDO
	137	c DO j=2,6
	138	c NUM(j)=12
	139	c ENDDO
	140	c DO j=jjm-5,jjm-1
	141	c NUM(j)=12
	142	c ENDDO
	143
	144	C Interface : adaptation nouveau modele
	145	C -------------------------------------
	146	C
	147	C ---------------------------------------------------------
	148	C Conversion des flux de masses en kg/s
	149	C pbaru est en N/s d'ou :
	150	C ugri est en kg/s
	151
[5084]	152	DO 500 l = 1,llm
	153	DO 500 j = 1,jjp1
	154	DO 500 i = 1,iip1
[524]	155	ugri (i,j,llm+1-l) =pbaru (i,j,l)
[5084]	156	500 CONTINUE
[524]	157
	158	C ---------------------------------------------------------
	159	C start here
	160	C
	161	C boucle principale sur les niveaux et les latitudes
	162	C
[5084]	163	DO 1 L=1,NIV
	164	DO 1 K=lati,latf
[524]	165
	166	C
	167	C initialisation
	168	C
	169	C program assumes periodic boundaries in X
	170	C
[5084]	171	DO 10 I=2,LON
[524]	172	SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX
[5084]	173	10 CONTINUE
[524]	174	SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX
	175	C
	176	C modifications for extended polar zones
	177	C
	178	NUMK=NUM(K)
	179	LONK=LON/NUMK
	180	C
[5084]	181	IF(NUMK.GT.1) THEN
[524]	182	C
[5084]	183	DO 111 I=1,LON
[524]	184	TM(I)=0.
[5084]	185	111 CONTINUE
	186	DO 112 JV=1,NTRA
	187	DO 1120 I=1,LON
[524]	188	T0 (I,JV)=0.
	189	TX (I,JV)=0.
	190	TY (I,JV)=0.
	191	TZ (I,JV)=0.
	192	TXX(I,JV)=0.
	193	TXY(I,JV)=0.
	194	TXZ(I,JV)=0.
	195	TYY(I,JV)=0.
	196	TYZ(I,JV)=0.
	197	TZZ(I,JV)=0.
[5084]	198	1120 CONTINUE
	199	112 CONTINUE
[524]	200	C
[5084]	201	DO 11 I2=1,NUMK
[524]	202	C
[5084]	203	DO 113 I=1,LONK
[524]	204	I3=(I-1)*NUMK+I2
	205	TM(I)=TM(I)+SM(I3,K,L)
	206	ALF(I)=SM(I3,K,L)/TM(I)
	207	ALF1(I)=1.-ALF(I)
	208	ALFQ(I)=ALF(I)*ALF(I)
	209	ALF1Q(I)=ALF1(I)*ALF1(I)
	210	ALF2(I)=ALF1(I)-ALF(I)
	211	ALF3(I)=ALF(I)*ALF1(I)
[5084]	212	113 CONTINUE
[524]	213	C
[5084]	214	DO 114 JV=1,NTRA
	215	DO 1140 I=1,LONK
[524]	216	I3=(I-1)*NUMK+I2
	217	TEMPTM=-ALF(I)T0(I,JV)+ALF1(I)S0(I3,K,L,JV)
	218	T0 (I,JV)=T0(I,JV)+S0(I3,K,L,JV)
	219	TXX(I,JV)=ALFQ(I)SSXX(I3,K,L,JV)+ALF1Q(I)TXX(I,JV)
	220	+ +5.( ALF3(I)(SSX(I3,K,L,JV)-TX(I,JV))+ALF2(I)*TEMPTM )
	221	TX (I,JV)=ALF(I)SSX(I3,K,L,JV)+ALF1(I)TX(I,JV)+3.*TEMPTM
	222	TXY(I,JV)=ALF (I)SSXY(I3,K,L,JV)+ALF1(I)TXY(I,JV)
	223	+ +3.(ALF1(I)SY (I3,K,L,JV)-ALF (I)*TY (I,JV))
	224	TXZ(I,JV)=ALF (I)SSXZ(I3,K,L,JV)+ALF1(I)TXZ(I,JV)
	225	+ +3.(ALF1(I)SZ (I3,K,L,JV)-ALF (I)*TZ (I,JV))
	226	TY (I,JV)=TY (I,JV)+SY (I3,K,L,JV)
	227	TZ (I,JV)=TZ (I,JV)+SZ (I3,K,L,JV)
	228	TYY(I,JV)=TYY(I,JV)+SYY(I3,K,L,JV)
	229	TYZ(I,JV)=TYZ(I,JV)+SYZ(I3,K,L,JV)
	230	TZZ(I,JV)=TZZ(I,JV)+SZZ(I3,K,L,JV)
[5084]	231	1140 CONTINUE
	232	114 CONTINUE
[524]	233	C
[5084]	234	11 CONTINUE
[524]	235	C
	236	ELSE
	237	C
[5084]	238	DO 115 I=1,LON
[524]	239	TM(I)=SM(I,K,L)
[5084]	240	115 CONTINUE
	241	DO 116 JV=1,NTRA
	242	DO 1160 I=1,LON
[524]	243	T0 (I,JV)=S0 (I,K,L,JV)
	244	TX (I,JV)=SSX (I,K,L,JV)
	245	TY (I,JV)=SY (I,K,L,JV)
	246	TZ (I,JV)=SZ (I,K,L,JV)
	247	TXX(I,JV)=SSXX(I,K,L,JV)
	248	TXY(I,JV)=SSXY(I,K,L,JV)
	249	TXZ(I,JV)=SSXZ(I,K,L,JV)
	250	TYY(I,JV)=SYY(I,K,L,JV)
	251	TYZ(I,JV)=SYZ(I,K,L,JV)
	252	TZZ(I,JV)=SZZ(I,K,L,JV)
[5084]	253	1160 CONTINUE
	254	116 CONTINUE
[524]	255	C
	256	ENDIF
	257	C
[5084]	258	DO 117 I=1,LONK
[524]	259	UEXT(I)=UGRI(I*NUMK,K,L)
[5084]	260	117 CONTINUE
[524]	261	C
	262	C place limits on appropriate moments before transport
	263	C (if flux-limiting is to be applied)
	264	C
	265	IF(.NOT.LIMIT) GO TO 13
	266	C
[5084]	267	DO 12 JV=1,NTRA
	268	DO 120 I=1,LONK
	269	IF(T0(I,JV).GT.0.) THEN
[524]	270	SLPMAX=T0(I,JV)
	271	S1MAX=1.5*SLPMAX
	272	S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,TX(I,JV)))
	273	S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. ,
	274	+ AMAX1(ABS(S1NEW)-SLPMAX,TXX(I,JV)) )
	275	TX (I,JV)=S1NEW
	276	TXX(I,JV)=S2NEW
	277	TXY(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXY(I,JV)))
	278	TXZ(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXZ(I,JV)))
	279	ELSE
	280	TX (I,JV)=0.
	281	TXX(I,JV)=0.
	282	TXY(I,JV)=0.
	283	TXZ(I,JV)=0.
	284	ENDIF
[5084]	285	120 CONTINUE
	286	12 CONTINUE
[524]	287	C
	288	13 CONTINUE
	289	C
	290	C calculate flux and moments between adjacent boxes
	291	C 1- create temporary moments/masses for partial boxes in transit
	292	C 2- reajusts moments remaining in the box
	293	C
	294	C flux from IP to I if U(I).lt.0
	295	C
[5084]	296	DO 140 I=1,LONK-1
	297	IF(UEXT(I).LT.0.) THEN
[524]	298	FM(I)=-UEXT(I)*DTX
	299	ALF(I)=FM(I)/TM(I+1)
	300	TM(I+1)=TM(I+1)-FM(I)
	301	ENDIF
[5084]	302	140 CONTINUE
[524]	303	C
	304	I=LONK
[5084]	305	IF(UEXT(I).LT.0.) THEN
[524]	306	FM(I)=-UEXT(I)*DTX
	307	ALF(I)=FM(I)/TM(1)
	308	TM(1)=TM(1)-FM(I)
	309	ENDIF
	310	C
	311	C flux from I to IP if U(I).gt.0
	312	C
[5084]	313	DO 141 I=1,LONK
	314	IF(UEXT(I).GE.0.) THEN
[524]	315	FM(I)=UEXT(I)*DTX
	316	ALF(I)=FM(I)/TM(I)
	317	TM(I)=TM(I)-FM(I)
	318	ENDIF
[5084]	319	141 CONTINUE
[524]	320	C
[5084]	321	DO 142 I=1,LONK
[524]	322	ALFQ(I)=ALF(I)*ALF(I)
	323	ALF1(I)=1.-ALF(I)
	324	ALF1Q(I)=ALF1(I)*ALF1(I)
	325	ALF2(I)=ALF1(I)-ALF(I)
	326	ALF3(I)=ALF(I)*ALFQ(I)
	327	ALF4(I)=ALF1(I)*ALF1Q(I)
[5084]	328	142 CONTINUE
[524]	329	C
[5084]	330	DO 150 JV=1,NTRA
	331	DO 1500 I=1,LONK-1
[524]	332	C
[5084]	333	IF(UEXT(I).LT.0.) THEN
[524]	334	C
	335	F0 (I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)*
	336	+ ( TX(I+1,JV)-ALF2(I)*TXX(I+1,JV) ) )
	337	FX (I,JV)=ALFQ(I)(TX(I+1,JV)-3.ALF1(I)*TXX(I+1,JV))
	338	FXX(I,JV)=ALF3(I)*TXX(I+1,JV)
	339	FY (I,JV)=ALF (I)(TY(I+1,JV)-ALF1(I)TXY(I+1,JV))
	340	FZ (I,JV)=ALF (I)(TZ(I+1,JV)-ALF1(I)TXZ(I+1,JV))
	341	FXY(I,JV)=ALFQ(I)*TXY(I+1,JV)
	342	FXZ(I,JV)=ALFQ(I)*TXZ(I+1,JV)
	343	FYY(I,JV)=ALF (I)*TYY(I+1,JV)
	344	FYZ(I,JV)=ALF (I)*TYZ(I+1,JV)
	345	FZZ(I,JV)=ALF (I)*TZZ(I+1,JV)
	346	C
	347	T0 (I+1,JV)=T0(I+1,JV)-F0(I,JV)
	348	TX (I+1,JV)=ALF1Q(I)(TX(I+1,JV)+3.ALF(I)*TXX(I+1,JV))
	349	TXX(I+1,JV)=ALF4(I)*TXX(I+1,JV)
	350	TY (I+1,JV)=TY (I+1,JV)-FY (I,JV)
	351	TZ (I+1,JV)=TZ (I+1,JV)-FZ (I,JV)
	352	TYY(I+1,JV)=TYY(I+1,JV)-FYY(I,JV)
	353	TYZ(I+1,JV)=TYZ(I+1,JV)-FYZ(I,JV)
	354	TZZ(I+1,JV)=TZZ(I+1,JV)-FZZ(I,JV)
	355	TXY(I+1,JV)=ALF1Q(I)*TXY(I+1,JV)
	356	TXZ(I+1,JV)=ALF1Q(I)*TXZ(I+1,JV)
	357	C
	358	ENDIF
	359	C
[5084]	360	1500 CONTINUE
	361	150 CONTINUE
[524]	362	C
	363	I=LONK
[5084]	364	IF(UEXT(I).LT.0.) THEN
[524]	365	C
[5084]	366	DO 151 JV=1,NTRA
[524]	367	C
	368	F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)*
	369	+ ( TX(1,JV)-ALF2(I)*TXX(1,JV) ) )
	370	FX (I,JV)=ALFQ(I)(TX(1,JV)-3.ALF1(I)*TXX(1,JV))
	371	FXX(I,JV)=ALF3(I)*TXX(1,JV)
	372	FY (I,JV)=ALF (I)(TY(1,JV)-ALF1(I)TXY(1,JV))
	373	FZ (I,JV)=ALF (I)(TZ(1,JV)-ALF1(I)TXZ(1,JV))
	374	FXY(I,JV)=ALFQ(I)*TXY(1,JV)
	375	FXZ(I,JV)=ALFQ(I)*TXZ(1,JV)
	376	FYY(I,JV)=ALF (I)*TYY(1,JV)
	377	FYZ(I,JV)=ALF (I)*TYZ(1,JV)
	378	FZZ(I,JV)=ALF (I)*TZZ(1,JV)
	379	C
	380	T0 (1,JV)=T0(1,JV)-F0(I,JV)
	381	TX (1,JV)=ALF1Q(I)(TX(1,JV)+3.ALF(I)*TXX(1,JV))
	382	TXX(1,JV)=ALF4(I)*TXX(1,JV)
	383	TY (1,JV)=TY (1,JV)-FY (I,JV)
	384	TZ (1,JV)=TZ (1,JV)-FZ (I,JV)
	385	TYY(1,JV)=TYY(1,JV)-FYY(I,JV)
	386	TYZ(1,JV)=TYZ(1,JV)-FYZ(I,JV)
	387	TZZ(1,JV)=TZZ(1,JV)-FZZ(I,JV)
	388	TXY(1,JV)=ALF1Q(I)*TXY(1,JV)
	389	TXZ(1,JV)=ALF1Q(I)*TXZ(1,JV)
	390	C
[5084]	391	151 CONTINUE
[524]	392	C
	393	ENDIF
	394	C
[5084]	395	DO 152 JV=1,NTRA
	396	DO 1520 I=1,LONK
[524]	397	C
[5084]	398	IF(UEXT(I).GE.0.) THEN
[524]	399	C
	400	F0 (I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)*
	401	+ ( TX(I,JV)+ALF2(I)*TXX(I,JV) ) )
	402	FX (I,JV)=ALFQ(I)(TX(I,JV)+3.ALF1(I)*TXX(I,JV))
	403	FXX(I,JV)=ALF3(I)*TXX(I,JV)
	404	FY (I,JV)=ALF (I)(TY(I,JV)+ALF1(I)TXY(I,JV))
	405	FZ (I,JV)=ALF (I)(TZ(I,JV)+ALF1(I)TXZ(I,JV))
	406	FXY(I,JV)=ALFQ(I)*TXY(I,JV)
	407	FXZ(I,JV)=ALFQ(I)*TXZ(I,JV)
	408	FYY(I,JV)=ALF (I)*TYY(I,JV)
	409	FYZ(I,JV)=ALF (I)*TYZ(I,JV)
	410	FZZ(I,JV)=ALF (I)*TZZ(I,JV)
	411	C
	412	T0 (I,JV)=T0(I,JV)-F0(I,JV)
	413	TX (I,JV)=ALF1Q(I)(TX(I,JV)-3.ALF(I)*TXX(I,JV))
	414	TXX(I,JV)=ALF4(I)*TXX(I,JV)
	415	TY (I,JV)=TY (I,JV)-FY (I,JV)
	416	TZ (I,JV)=TZ (I,JV)-FZ (I,JV)
	417	TYY(I,JV)=TYY(I,JV)-FYY(I,JV)
	418	TYZ(I,JV)=TYZ(I,JV)-FYZ(I,JV)
	419	TZZ(I,JV)=TZZ(I,JV)-FZZ(I,JV)
	420	TXY(I,JV)=ALF1Q(I)*TXY(I,JV)
	421	TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV)
	422	C
	423	ENDIF
	424	C
[5084]	425	1520 CONTINUE
	426	152 CONTINUE
[524]	427	C
	428	C puts the temporary moments Fi into appropriate neighboring boxes
	429	C
[5084]	430	DO 160 I=1,LONK
	431	IF(UEXT(I).LT.0.) THEN
[524]	432	TM(I)=TM(I)+FM(I)
	433	ALF(I)=FM(I)/TM(I)
	434	ENDIF
[5084]	435	160 CONTINUE
[524]	436	C
[5084]	437	DO 161 I=1,LONK-1
	438	IF(UEXT(I).GE.0.) THEN
[524]	439	TM(I+1)=TM(I+1)+FM(I)
	440	ALF(I)=FM(I)/TM(I+1)
	441	ENDIF
[5084]	442	161 CONTINUE
[524]	443	C
	444	I=LONK
[5084]	445	IF(UEXT(I).GE.0.) THEN
[524]	446	TM(1)=TM(1)+FM(I)
	447	ALF(I)=FM(I)/TM(1)
	448	ENDIF
	449	C
[5084]	450	DO 162 I=1,LONK
[524]	451	ALF1(I)=1.-ALF(I)
	452	ALFQ(I)=ALF(I)*ALF(I)
	453	ALF1Q(I)=ALF1(I)*ALF1(I)
	454	ALF2(I)=ALF1(I)-ALF(I)
	455	ALF3(I)=ALF(I)*ALF1(I)
[5084]	456	162 CONTINUE
[524]	457	C
[5084]	458	DO 170 JV=1,NTRA
	459	DO 1700 I=1,LONK
[524]	460	C
[5084]	461	IF(UEXT(I).LT.0.) THEN
[524]	462	C
	463	TEMPTM=-ALF(I)T0(I,JV)+ALF1(I)F0(I,JV)
	464	T0 (I,JV)=T0(I,JV)+F0(I,JV)
	465	TXX(I,JV)=ALFQ(I)FXX(I,JV)+ALF1Q(I)TXX(I,JV)
	466	+ +5.( ALF3(I)(FX(I,JV)-TX(I,JV))+ALF2(I)*TEMPTM )
	467	TX (I,JV)=ALF (I)FX (I,JV)+ALF1(I)TX (I,JV)+3.*TEMPTM
	468	TXY(I,JV)=ALF (I)FXY(I,JV)+ALF1(I)TXY(I,JV)
	469	+ +3.(ALF1(I)FY (I,JV)-ALF (I)*TY (I,JV))
	470	TXZ(I,JV)=ALF (I)FXZ(I,JV)+ALF1(I)TXZ(I,JV)
	471	+ +3.(ALF1(I)FZ (I,JV)-ALF (I)*TZ (I,JV))
	472	TY (I,JV)=TY (I,JV)+FY (I,JV)
	473	TZ (I,JV)=TZ (I,JV)+FZ (I,JV)
	474	TYY(I,JV)=TYY(I,JV)+FYY(I,JV)
	475	TYZ(I,JV)=TYZ(I,JV)+FYZ(I,JV)
	476	TZZ(I,JV)=TZZ(I,JV)+FZZ(I,JV)
	477	C
	478	ENDIF
	479	C
[5084]	480	1700 CONTINUE
	481	170 CONTINUE
[524]	482	C
[5084]	483	DO 171 JV=1,NTRA
	484	DO 1710 I=1,LONK-1
[524]	485	C
[5084]	486	IF(UEXT(I).GE.0.) THEN
[524]	487	C
	488	TEMPTM=ALF(I)T0(I+1,JV)-ALF1(I)F0(I,JV)
	489	T0 (I+1,JV)=T0(I+1,JV)+F0(I,JV)
	490	TXX(I+1,JV)=ALFQ(I)FXX(I,JV)+ALF1Q(I)TXX(I+1,JV)
	491	+ +5.( ALF3(I)(TX(I+1,JV)-FX(I,JV))-ALF2(I)*TEMPTM )
	492	TX (I+1,JV)=ALF(I)FX (I ,JV)+ALF1(I)TX (I+1,JV)+3.*TEMPTM
	493	TXY(I+1,JV)=ALF(I)FXY(I ,JV)+ALF1(I)TXY(I+1,JV)
	494	+ +3.(ALF(I)TY (I+1,JV)-ALF1(I)*FY (I ,JV))
	495	TXZ(I+1,JV)=ALF(I)FXZ(I ,JV)+ALF1(I)TXZ(I+1,JV)
	496	+ +3.(ALF(I)TZ (I+1,JV)-ALF1(I)*FZ (I ,JV))
	497	TY (I+1,JV)=TY (I+1,JV)+FY (I,JV)
	498	TZ (I+1,JV)=TZ (I+1,JV)+FZ (I,JV)
	499	TYY(I+1,JV)=TYY(I+1,JV)+FYY(I,JV)
	500	TYZ(I+1,JV)=TYZ(I+1,JV)+FYZ(I,JV)
	501	TZZ(I+1,JV)=TZZ(I+1,JV)+FZZ(I,JV)
	502	C
	503	ENDIF
	504	C
[5084]	505	1710 CONTINUE
	506	171 CONTINUE
[524]	507	C
	508	I=LONK
[5084]	509	IF(UEXT(I).GE.0.) THEN
	510	DO 172 JV=1,NTRA
[524]	511	TEMPTM=ALF(I)T0(1,JV)-ALF1(I)F0(I,JV)
	512	T0 (1,JV)=T0(1,JV)+F0(I,JV)
	513	TXX(1,JV)=ALFQ(I)FXX(I,JV)+ALF1Q(I)TXX(1,JV)
	514	+ +5.( ALF3(I)(TX(1,JV)-FX(I,JV))-ALF2(I)*TEMPTM )
	515	TX (1,JV)=ALF(I)FX(I,JV)+ALF1(I)TX(1,JV)+3.*TEMPTM
	516	TXY(1,JV)=ALF(I)FXY(I,JV)+ALF1(I)TXY(1,JV)
	517	+ +3.(ALF(I)TY (1,JV)-ALF1(I)*FY (I,JV))
	518	TXZ(1,JV)=ALF(I)FXZ(I,JV)+ALF1(I)TXZ(1,JV)
	519	+ +3.(ALF(I)TZ (1,JV)-ALF1(I)*FZ (I,JV))
	520	TY (1,JV)=TY (1,JV)+FY (I,JV)
	521	TZ (1,JV)=TZ (1,JV)+FZ (I,JV)
	522	TYY(1,JV)=TYY(1,JV)+FYY(I,JV)
	523	TYZ(1,JV)=TYZ(1,JV)+FYZ(I,JV)
	524	TZZ(1,JV)=TZZ(1,JV)+FZZ(I,JV)
[5084]	525	172 CONTINUE
[524]	526	ENDIF
	527	C
	528	C retour aux mailles d'origine (passage des Tij aux Sij)
	529	C
[5084]	530	IF(NUMK.GT.1) THEN
[524]	531	C
[5084]	532	DO 18 I2=1,NUMK
[524]	533	C
[5084]	534	DO 180 I=1,LONK
[524]	535	C
	536	I3=I2+(I-1)*NUMK
	537	SM(I3,K,L)=SMNEW(I3)
	538	ALF(I)=SMNEW(I3)/TM(I)
	539	TM(I)=TM(I)-SMNEW(I3)
	540	C
	541	ALFQ(I)=ALF(I)*ALF(I)
	542	ALF1(I)=1.-ALF(I)
	543	ALF1Q(I)=ALF1(I)*ALF1(I)
	544	ALF2(I)=ALF1(I)-ALF(I)
	545	ALF3(I)=ALF(I)*ALFQ(I)
	546	ALF4(I)=ALF1(I)*ALF1Q(I)
	547	C
[5084]	548	180 CONTINUE
[524]	549	C
[5084]	550	DO 181 JV=1,NTRA
	551	DO 181 I=1,LONK
[524]	552	C
	553	I3=I2+(I-1)*NUMK
	554	S0 (I3,K,L,JV)=ALF (I)* ( T0(I,JV)-ALF1(I)*
	555	+ ( TX(I,JV)-ALF2(I)*TXX(I,JV) ) )
	556	SSX (I3,K,L,JV)=ALFQ(I)(TX(I,JV)-3.ALF1(I)*TXX(I,JV))
	557	SSXX(I3,K,L,JV)=ALF3(I)*TXX(I,JV)
	558	SY (I3,K,L,JV)=ALF (I)(TY(I,JV)-ALF1(I)TXY(I,JV))
	559	SZ (I3,K,L,JV)=ALF (I)(TZ(I,JV)-ALF1(I)TXZ(I,JV))
	560	SSXY(I3,K,L,JV)=ALFQ(I)*TXY(I,JV)
	561	SSXZ(I3,K,L,JV)=ALFQ(I)*TXZ(I,JV)
	562	SYY(I3,K,L,JV)=ALF (I)*TYY(I,JV)
	563	SYZ(I3,K,L,JV)=ALF (I)*TYZ(I,JV)
	564	SZZ(I3,K,L,JV)=ALF (I)*TZZ(I,JV)
	565	C
	566	C reajusts moments remaining in the box
	567	C
	568	T0 (I,JV)=T0(I,JV)-S0(I3,K,L,JV)
	569	TX (I,JV)=ALF1Q(I)(TX(I,JV)+3.ALF(I)*TXX(I,JV))
	570	TXX(I,JV)=ALF4 (I)*TXX(I,JV)
	571	TY (I,JV)=TY (I,JV)-SY (I3,K,L,JV)
	572	TZ (I,JV)=TZ (I,JV)-SZ (I3,K,L,JV)
	573	TYY(I,JV)=TYY(I,JV)-SYY(I3,K,L,JV)
	574	TYZ(I,JV)=TYZ(I,JV)-SYZ(I3,K,L,JV)
	575	TZZ(I,JV)=TZZ(I,JV)-SZZ(I3,K,L,JV)
	576	TXY(I,JV)=ALF1Q(I)*TXY(I,JV)
	577	TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV)
	578	C
[5084]	579	181 CONTINUE
[524]	580	C
[5084]	581	18 CONTINUE
[524]	582	C
	583	ELSE
	584	C
[5084]	585	DO 190 I=1,LON
[524]	586	SM(I,K,L)=TM(I)
[5084]	587	190 CONTINUE
	588	DO 191 JV=1,NTRA
	589	DO 1910 I=1,LON
[524]	590	S0 (I,K,L,JV)=T0 (I,JV)
	591	SSX (I,K,L,JV)=TX (I,JV)
	592	SY (I,K,L,JV)=TY (I,JV)
	593	SZ (I,K,L,JV)=TZ (I,JV)
	594	SSXX(I,K,L,JV)=TXX(I,JV)
	595	SSXY(I,K,L,JV)=TXY(I,JV)
	596	SSXZ(I,K,L,JV)=TXZ(I,JV)
	597	SYY(I,K,L,JV)=TYY(I,JV)
	598	SYZ(I,K,L,JV)=TYZ(I,JV)
	599	SZZ(I,K,L,JV)=TZZ(I,JV)
[5084]	600	1910 CONTINUE
	601	191 CONTINUE
[524]	602	C
	603	ENDIF
	604	C
[5084]	605	1 CONTINUE
[524]	606	C
	607	C ----------- AA Test en fin de ADVX ------ Controle des S*
	608
	609	c DO 9999 l = 1, llm
	610	c DO 9999 j = 1, jjp1
	611	c DO 9999 i = 1, iip1
[2600]	612	c IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN
[524]	613	c PRINT*, '-------------------'
[2600]	614	c PRINT*, 'En fin de ADVXP'
[524]	615	c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
[2600]	616	c print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra)
[524]	617	c print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra)
[2600]	618	c print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra)
[524]	619	c WRITE (,) 'On arrete !! - pbl en fin de ADVXP'
	620	c STOP
	621	c ENDIF
	622	c 9999 CONTINUE
	623	c ---------- bouclage cyclique
	624
	625	DO l = 1,llm
	626	DO j = 1,jjp1
	627	SM(iip1,j,l) = SM(1,j,l)
	628	S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
[2600]	629	SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra)
	630	SY(iip1,j,l,ntra) = SY(1,j,l,ntra)
	631	SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra)
[524]	632	END DO
	633	END DO
	634
	635	C ----------- qqtite totale de traceur dans tte l'atmosphere
	636	DO l = 1, llm
	637	DO j = 1, jjp1
	638	DO i = 1, iim
	639	sqf = sqf + S0(i,j,l,ntra)
	640	END DO
	641	END DO
	642	END DO
	643
	644	PRINT*,'------ DIAG DANS ADVX2 - SORTIE -----'
	645	PRINT*,'sqf=',sqf
	646	c-------------------------------------------------------------
	647	RETURN
	648	END

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

Download in other formats:

Original Format