Context Navigation

vlspltqs.F @ 2597

Last change on this file since 2597 was 2597, checked in by Ehouarn Millour, 9 years ago
Cleanup in the dynamics: get rid of comconst.h, make it a module comconst_mod. EM
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: 25.1 KB

Rev	Line
[1520]	1	c
	2	c $Id: vlspltqs.F 2597 2016-07-22 06:44:47Z emillour $
	3	c
[524]	4	SUBROUTINE vlspltqs ( q,pente_max,masse,w,pbaru,pbarv,pdt,
[2270]	5	, p,pk,teta,iq )
	6	USE infotrac, ONLY: nqtot,nqdesc,iqfils
[524]	7	c
	8	c Auteurs: P.Le Van, F.Hourdin, F.Forget, F.Codron
	9	c
	10	c ********************************************************************
	11	c Shema d'advection " pseudo amont " .
	12	c + test sur humidite specifique: Q advecte< Qsat aval
	13	c (F. Codron, 10/99)
	14	c ********************************************************************
	15	c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg ....
	16	c
	17	c pente_max facteur de limitation des pentes: 2 en general
	18	c 0 pour un schema amont
	19	c pbaru,pbarv,w flux de masse en u ,v ,w
	20	c pdt pas de temps
	21	c
	22	c teta temperature potentielle, p pression aux interfaces,
	23	c pk exner au milieu des couches necessaire pour calculer Qsat
	24	c --------------------------------------------------------------------
[2597]	25
	26	USE comconst_mod, ONLY: cpp
	27
[524]	28	IMPLICIT NONE
	29	c
[2597]	30	include "dimensions.h"
	31	include "paramet.h"
	32	include "logic.h"
	33	include "comvert.h"
[524]	34
	35	c
	36	c Arguments:
	37	c ----------
	38	REAL masse(ip1jmp1,llm),pente_max
	39	REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
[2270]	40	REAL q(ip1jmp1,llm,nqtot)
[524]	41	REAL w(ip1jmp1,llm),pdt
	42	REAL p(ip1jmp1,llmp1),teta(ip1jmp1,llm),pk(ip1jmp1,llm)
[2270]	43	INTEGER iq ! CRisi
[524]	44	c
	45	c Local
	46	c ---------
	47	c
	48	INTEGER i,ij,l,j,ii
[2270]	49	INTEGER ifils,iq2 ! CRisi
[524]	50	c
	51	REAL qsat(ip1jmp1,llm)
[2270]	52	REAL zm(ip1jmp1,llm,nqtot)
[524]	53	REAL mu(ip1jmp1,llm)
	54	REAL mv(ip1jm,llm)
	55	REAL mw(ip1jmp1,llm+1)
[2270]	56	REAL zq(ip1jmp1,llm,nqtot)
[524]	57	REAL temps1,temps2,temps3
	58	REAL zzpbar, zzw
	59	LOGICAL testcpu
	60	SAVE testcpu
	61	SAVE temps1,temps2,temps3
	62
	63	REAL qmin,qmax
	64	DATA qmin,qmax/0.,1.e33/
	65	DATA testcpu/.false./
	66	DATA temps1,temps2,temps3/0.,0.,0./
	67
	68	c--pour rapport de melange saturant--
	69
	70	REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play
	71	REAL ptarg,pdelarg,foeew,zdelta
	72	REAL tempe(ip1jmp1)
	73
	74	c fonction psat(T)
	75
	76	FOEEW ( PTARG,PDELARG ) = EXP (
	77	* (R3LES(1.-PDELARG)+R3IESPDELARG) * (PTARG-RTT)
	78	* / (PTARG-(R4LES(1.-PDELARG)+R4IESPDELARG)) )
	79
	80	r2es = 380.11733
	81	r3les = 17.269
	82	r3ies = 21.875
	83	r4les = 35.86
	84	r4ies = 7.66
	85	retv = 0.6077667
	86	rtt = 273.16
	87
	88	c-- Calcul de Qsat en chaque point
	89	c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2
	90	c pour eviter une exponentielle.
	91	DO l = 1, llm
	92	DO ij = 1, ip1jmp1
	93	tempe(ij) = teta(ij,l) * pk(ij,l) /cpp
	94	ENDDO
	95	DO ij = 1, ip1jmp1
	96	zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) )
	97	play = 0.5*(p(ij,l)+p(ij,l+1))
	98	qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play )
	99	qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) )
	100	ENDDO
	101	ENDDO
	102
	103	c PRINT*,'Debut vlsplt version debug sans vlyqs'
	104
	105	zzpbar = 0.5 * pdt
	106	zzw = pdt
	107	DO l=1,llm
	108	DO ij = iip2,ip1jm
	109	mu(ij,l)=pbaru(ij,l) * zzpbar
	110	ENDDO
	111	DO ij=1,ip1jm
	112	mv(ij,l)=pbarv(ij,l) * zzpbar
	113	ENDDO
	114	DO ij=1,ip1jmp1
	115	mw(ij,l)=w(ij,l) * zzw
	116	ENDDO
	117	ENDDO
	118
	119	DO ij=1,ip1jmp1
	120	mw(ij,llm+1)=0.
	121	ENDDO
	122
[2270]	123	CALL SCOPY(ijp1llm,q(1,1,iq),1,zq(1,1,iq),1)
	124	CALL SCOPY(ijp1llm,masse,1,zm(1,1,iq),1)
	125	if (nqdesc(iq).gt.0) then
	126	do ifils=1,nqdesc(iq)
	127	iq2=iqfils(ifils,iq)
	128	CALL SCOPY(ijp1llm,q(1,1,iq2),1,zq(1,1,iq2),1)
	129	enddo
	130	endif !if (nqfils(iq).gt.0) then
[524]	131
	132	c call minmaxq(zq,qmin,qmax,'avant vlxqs ')
[2270]	133	call vlxqs(zq,pente_max,zm,mu,qsat,iq)
[524]	134
	135	c call minmaxq(zq,qmin,qmax,'avant vlyqs ')
	136
[2270]	137	call vlyqs(zq,pente_max,zm,mv,qsat,iq)
[524]	138
	139	c call minmaxq(zq,qmin,qmax,'avant vlz ')
	140
[2270]	141	call vlz(zq,pente_max,zm,mw,iq)
[524]	142
	143	c call minmaxq(zq,qmin,qmax,'avant vlyqs ')
	144	c call minmaxq(zm,qmin,qmax,'M avant vlyqs ')
	145
[2270]	146	call vlyqs(zq,pente_max,zm,mv,qsat,iq)
[524]	147
	148	c call minmaxq(zq,qmin,qmax,'avant vlxqs ')
	149	c call minmaxq(zm,qmin,qmax,'M avant vlxqs ')
	150
[2270]	151	call vlxqs(zq,pente_max,zm,mu,qsat,iq)
[524]	152
	153	c call minmaxq(zq,qmin,qmax,'apres vlxqs ')
	154	c call minmaxq(zm,qmin,qmax,'M apres vlxqs ')
	155
	156
	157	DO l=1,llm
	158	DO ij=1,ip1jmp1
[2270]	159	q(ij,l,iq)=zq(ij,l,iq)
[524]	160	ENDDO
	161	DO ij=1,ip1jm+1,iip1
[2270]	162	q(ij+iim,l,iq)=q(ij,l,iq)
[524]	163	ENDDO
	164	ENDDO
[2270]	165	! CRisi: aussi pour les fils
	166	if (nqdesc(iq).gt.0) then
	167	do ifils=1,nqdesc(iq)
	168	iq2=iqfils(ifils,iq)
	169	DO l=1,llm
	170	DO ij=1,ip1jmp1
	171	q(ij,l,iq2)=zq(ij,l,iq2)
	172	ENDDO
	173	DO ij=1,ip1jm+1,iip1
	174	q(ij+iim,l,iq2)=q(ij,l,iq2)
	175	ENDDO
	176	ENDDO
	177	enddo !do ifils=1,nqdesc(iq)
	178	endif ! if (nqfils(iq).gt.0) then
[2286]	179	!write(,) 'vlspltqs 183: fin de la routine'
[524]	180
	181	RETURN
	182	END
[2270]	183	SUBROUTINE vlxqs(q,pente_max,masse,u_m,qsat,iq)
	184	USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi
	185
[524]	186	c
	187	c Auteurs: P.Le Van, F.Hourdin, F.Forget
	188	c
	189	c ********************************************************************
	190	c Shema d'advection " pseudo amont " .
	191	c ********************************************************************
	192	c
	193	c --------------------------------------------------------------------
	194	IMPLICIT NONE
	195	c
[2597]	196	include "dimensions.h"
	197	include "paramet.h"
	198	include "logic.h"
	199	include "comvert.h"
[524]	200	c
	201	c
	202	c Arguments:
	203	c ----------
[2270]	204	REAL masse(ip1jmp1,llm,nqtot),pente_max
[524]	205	REAL u_m( ip1jmp1,llm )
[2270]	206	REAL q(ip1jmp1,llm,nqtot)
[524]	207	REAL qsat(ip1jmp1,llm)
[2270]	208	INTEGER iq ! CRisi
[524]	209	c
	210	c Local
	211	c ---------
	212	c
	213	INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
	214	INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm)
	215	c
	216	REAL new_m,zu_m,zdum(ip1jmp1,llm)
	217	REAL dxq(ip1jmp1,llm),dxqu(ip1jmp1)
	218	REAL zz(ip1jmp1)
	219	REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
	220	REAL u_mq(ip1jmp1,llm)
	221
[2270]	222	! CRisi
	223	REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot)
	224	INTEGER ifils,iq2 ! CRisi
	225
[524]	226	Logical first,testcpu
	227	SAVE first,testcpu
	228
	229	REAL SSUM
	230	REAL temps0,temps1,temps2,temps3,temps4,temps5
	231	SAVE temps0,temps1,temps2,temps3,temps4,temps5
	232
	233
	234	DATA first,testcpu/.true.,.false./
	235
	236	IF(first) THEN
	237	temps1=0.
	238	temps2=0.
	239	temps3=0.
	240	temps4=0.
	241	temps5=0.
	242	first=.false.
	243	ENDIF
	244
	245	c calcul de la pente a droite et a gauche de la maille
	246
	247
	248	IF (pente_max.gt.-1.e-5) THEN
	249	c IF (pente_max.gt.10) THEN
	250
	251	c calcul des pentes avec limitation, Van Leer scheme I:
	252	c -----------------------------------------------------
	253
	254	c calcul de la pente aux points u
	255	DO l = 1, llm
	256	DO ij=iip2,ip1jm-1
[2270]	257	dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
[524]	258	c IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'
[2270]	259	c sigu(ij)=u_m(ij,l)/masse(ij,l,iq)
[524]	260	ENDDO
	261	DO ij=iip1+iip1,ip1jm,iip1
	262	dxqu(ij)=dxqu(ij-iim)
	263	c sigu(ij)=sigu(ij-iim)
	264	ENDDO
	265
	266	DO ij=iip2,ip1jm
	267	adxqu(ij)=abs(dxqu(ij))
	268	ENDDO
	269
	270	c calcul de la pente maximum dans la maille en valeur absolue
	271
	272	DO ij=iip2+1,ip1jm
	273	dxqmax(ij,l)=pente_max*
	274	, min(adxqu(ij-1),adxqu(ij))
	275	c limitation subtile
	276	c , min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
	277
	278
	279	ENDDO
	280
	281	DO ij=iip1+iip1,ip1jm,iip1
	282	dxqmax(ij-iim,l)=dxqmax(ij,l)
	283	ENDDO
	284
	285	DO ij=iip2+1,ip1jm
	286	#ifdef CRAY
	287	dxq(ij,l)=
	288	, cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))
	289	#else
	290	IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN
	291	dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
	292	ELSE
	293	c extremum local
	294	dxq(ij,l)=0.
	295	ENDIF
	296	#endif
	297	dxq(ij,l)=0.5*dxq(ij,l)
	298	dxq(ij,l)=
	299	, sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
	300	ENDDO
	301
	302	ENDDO ! l=1,llm
	303
	304	ELSE ! (pente_max.lt.-1.e-5)
	305
	306	c Pentes produits:
	307	c ----------------
	308
	309	DO l = 1, llm
	310	DO ij=iip2,ip1jm-1
[2270]	311	dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
[524]	312	ENDDO
	313	DO ij=iip1+iip1,ip1jm,iip1
	314	dxqu(ij)=dxqu(ij-iim)
	315	ENDDO
	316
	317	DO ij=iip2+1,ip1jm
	318	zz(ij)=dxqu(ij-1)*dxqu(ij)
	319	zz(ij)=zz(ij)+zz(ij)
	320	IF(zz(ij).gt.0) THEN
	321	dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
	322	ELSE
	323	c extremum local
	324	dxq(ij,l)=0.
	325	ENDIF
	326	ENDDO
	327
	328	ENDDO
	329
	330	ENDIF ! (pente_max.lt.-1.e-5)
	331
	332	c bouclage de la pente en iip1:
	333	c -----------------------------
	334
	335	DO l=1,llm
	336	DO ij=iip1+iip1,ip1jm,iip1
	337	dxq(ij-iim,l)=dxq(ij,l)
	338	ENDDO
	339
	340	DO ij=1,ip1jmp1
	341	iadvplus(ij,l)=0
	342	ENDDO
	343
	344	ENDDO
	345
	346
	347	c calcul des flux a gauche et a droite
	348
	349	#ifdef CRAY
	350	c--pas encore modification sur Qsat
	351	DO l=1,llm
	352	DO ij=iip2,ip1jm-1
[2270]	353	zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l,iq),
	354	, 1.+u_m(ij,l)/masse(ij+1,l,iq),
[524]	355	, u_m(ij,l))
	356	zdum(ij,l)=0.5*zdum(ij,l)
	357	u_mq(ij,l)=cvmgp(
[2270]	358	, q(ij,l,iq)+zdum(ij,l)*dxq(ij,l),
	359	, q(ij+1,l,iq)-zdum(ij,l)*dxq(ij+1,l),
[524]	360	, u_m(ij,l))
	361	u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
	362	ENDDO
	363	ENDDO
	364	#else
	365	c on cumule le flux correspondant a toutes les mailles dont la masse
	366	c au travers de la paroi pENDant le pas de temps.
	367	c le rapport de melange de l'air advecte est min(q_vanleer, Qsat_downwind)
	368	DO l=1,llm
	369	DO ij=iip2,ip1jm-1
	370	IF (u_m(ij,l).gt.0.) THEN
[2270]	371	zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
[524]	372	u_mq(ij,l)=u_m(ij,l)*
[2270]	373	$ min(q(ij,l,iq)+0.5zdum(ij,l)dxq(ij,l),qsat(ij+1,l))
[524]	374	ELSE
[2270]	375	zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
[524]	376	u_mq(ij,l)=u_m(ij,l)*
[2270]	377	$ min(q(ij+1,l,iq)-0.5zdum(ij,l)dxq(ij+1,l),qsat(ij,l))
[524]	378	ENDIF
	379	ENDDO
	380	ENDDO
	381	#endif
	382
	383
	384	c detection des points ou on advecte plus que la masse de la
	385	c maille
	386	DO l=1,llm
	387	DO ij=iip2,ip1jm-1
	388	IF(zdum(ij,l).lt.0) THEN
	389	iadvplus(ij,l)=1
	390	u_mq(ij,l)=0.
	391	ENDIF
	392	ENDDO
	393	ENDDO
	394	DO l=1,llm
	395	DO ij=iip1+iip1,ip1jm,iip1
	396	iadvplus(ij,l)=iadvplus(ij-iim,l)
	397	ENDDO
	398	ENDDO
	399
	400
	401
	402	c traitement special pour le cas ou on advecte en longitude plus que le
	403	c contenu de la maille.
	404	c cette partie est mal vectorisee.
	405
	406	c pas d'influence de la pression saturante (pour l'instant)
	407
	408	c calcul du nombre de maille sur lequel on advecte plus que la maille.
	409
	410	n0=0
	411	DO l=1,llm
	412	nl(l)=0
	413	DO ij=iip2,ip1jm
	414	nl(l)=nl(l)+iadvplus(ij,l)
	415	ENDDO
	416	n0=n0+nl(l)
	417	ENDDO
	418
[595]	419	IF(n0.gt.0) THEN
[524]	420	ccc PRINT*,'Nombre de points pour lesquels on advect plus que le'
	421	ccc & ,'contenu de la maille : ',n0
	422
	423	DO l=1,llm
	424	IF(nl(l).gt.0) THEN
	425	iju=0
	426	c indicage des mailles concernees par le traitement special
	427	DO ij=iip2,ip1jm
	428	IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN
	429	iju=iju+1
	430	indu(iju)=ij
	431	ENDIF
	432	ENDDO
	433	niju=iju
	434	c PRINT*,'niju,nl',niju,nl(l)
	435
	436	c traitement des mailles
	437	DO iju=1,niju
	438	ij=indu(iju)
	439	j=(ij-1)/iip1+1
	440	zu_m=u_m(ij,l)
	441	u_mq(ij,l)=0.
	442	IF(zu_m.gt.0.) THEN
	443	ijq=ij
	444	i=ijq-(j-1)*iip1
	445	c accumulation pour les mailles completements advectees
[2270]	446	do while(zu_m.gt.masse(ijq,l,iq))
	447	u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq)
	448	& *masse(ijq,l,iq)
	449	zu_m=zu_m-masse(ijq,l,iq)
[524]	450	i=mod(i-2+iim,iim)+1
	451	ijq=(j-1)*iip1+i
	452	ENDDO
	453	c ajout de la maille non completement advectee
	454	u_mq(ij,l)=u_mq(ij,l)+zu_m*
[2270]	455	& (q(ijq,l,iq)+0.5*(1.-zu_m/masse(ijq,l,iq))
	456	& *dxq(ijq,l))
[524]	457	ELSE
	458	ijq=ij+1
	459	i=ijq-(j-1)*iip1
	460	c accumulation pour les mailles completements advectees
[2270]	461	do while(-zu_m.gt.masse(ijq,l,iq))
	462	u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq)
	463	& *masse(ijq,l,iq)
	464	zu_m=zu_m+masse(ijq,l,iq)
[524]	465	i=mod(i,iim)+1
	466	ijq=(j-1)*iip1+i
	467	ENDDO
	468	c ajout de la maille non completement advectee
[2270]	469	u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)-
	470	& 0.5(1.+zu_m/masse(ijq,l,iq))dxq(ijq,l))
[524]	471	ENDIF
	472	ENDDO
	473	ENDIF
	474	ENDDO
	475	ENDIF ! n0.gt.0
	476
	477
	478
	479	c bouclage en latitude
	480
	481	DO l=1,llm
	482	DO ij=iip1+iip1,ip1jm,iip1
	483	u_mq(ij,l)=u_mq(ij-iim,l)
	484	ENDDO
	485	ENDDO
	486
[2270]	487	! CRisi: appel récursif de l'advection sur les fils.
	488	! Il faut faire ça avant d'avoir mis à jour q et masse
[2286]	489	!write(,) 'vlspltqs 326: iq,nqfils(iq)=',iq,nqfils(iq)
[2270]	490
	491	if (nqfils(iq).gt.0) then
	492	do ifils=1,nqdesc(iq)
	493	iq2=iqfils(ifils,iq)
	494	DO l=1,llm
	495	DO ij=iip2,ip1jm
	496	! On a besoin de q et masse seulement entre iip2 et ip1jm
	497	masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
	498	Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
	499	enddo
	500	enddo
	501	enddo !do ifils=1,nqdesc(iq)
	502	do ifils=1,nqfils(iq)
	503	iq2=iqfils(ifils,iq)
	504	call vlx(Ratio,pente_max,masseq,u_mq,iq2)
	505	enddo !do ifils=1,nqfils(iq)
	506	endif !if (nqfils(iq).gt.0) then
	507	! end CRisi
[524]	508
	509	c calcul des tendances
	510
	511	DO l=1,llm
	512	DO ij=iip2+1,ip1jm
[2270]	513	new_m=masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l)
	514	q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+
[524]	515	& u_mq(ij-1,l)-u_mq(ij,l))
	516	& /new_m
[2270]	517	masse(ij,l,iq)=new_m
[524]	518	ENDDO
	519	c Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
	520	DO ij=iip1+iip1,ip1jm,iip1
[2270]	521	q(ij-iim,l,iq)=q(ij,l,iq)
	522	masse(ij-iim,l,iq)=masse(ij,l,iq)
[524]	523	ENDDO
	524	ENDDO
	525
[2270]	526	! retablir les fils en rapport de melange par rapport a l'air:
	527	! On calcule q entre iip2+1,ip1jm -> on fait pareil pour ratio
	528	! puis on boucle en longitude
	529	if (nqdesc(iq).gt.0) then
	530	do ifils=1,nqdesc(iq)
	531	iq2=iqfils(ifils,iq)
	532	DO l=1,llm
	533	DO ij=iip2+1,ip1jm
	534	q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
	535	enddo
	536	DO ij=iip1+iip1,ip1jm,iip1
	537	q(ij-iim,l,iq2)=q(ij,l,iq2)
	538	enddo ! DO ij=ijb+iip1-1,ije,iip1
	539	enddo !DO l=1,llm
	540	enddo !do ifils=1,nqdesc(iq)
	541	endif !if (nqfils(iq).gt.0) then
	542
[524]	543	c CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
	544	c CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
	545
	546
	547	RETURN
	548	END
[2270]	549	SUBROUTINE vlyqs(q,pente_max,masse,masse_adv_v,qsat,iq)
	550	USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi
[524]	551	c
	552	c Auteurs: P.Le Van, F.Hourdin, F.Forget
	553	c
	554	c ********************************************************************
	555	c Shema d'advection " pseudo amont " .
	556	c ********************************************************************
	557	c q,masse_adv_v,w sont des arguments d'entree pour le s-pg ....
	558	c qsat est un argument de sortie pour le s-pg ....
	559	c
	560	c
	561	c --------------------------------------------------------------------
[2597]	562
	563	USE comconst_mod, ONLY: pi
	564
[524]	565	IMPLICIT NONE
	566	c
[2597]	567	include "dimensions.h"
	568	include "paramet.h"
	569	include "logic.h"
	570	include "comvert.h"
	571	include "comgeom.h"
[524]	572	c
	573	c
	574	c Arguments:
	575	c ----------
[2270]	576	REAL masse(ip1jmp1,llm,nqtot),pente_max
[524]	577	REAL masse_adv_v( ip1jm,llm)
[2270]	578	REAL q(ip1jmp1,llm,nqtot)
[524]	579	REAL qsat(ip1jmp1,llm)
[2270]	580	INTEGER iq ! CRisi
[524]	581	c
	582	c Local
	583	c ---------
	584	c
	585	INTEGER i,ij,l
	586	c
	587	REAL airej2,airejjm,airescb(iim),airesch(iim)
	588	REAL dyq(ip1jmp1,llm),dyqv(ip1jm)
	589	REAL adyqv(ip1jm),dyqmax(ip1jmp1)
	590	REAL qbyv(ip1jm,llm)
	591
	592	REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
	593	c REAL newq,oldmasse
	594	Logical first,testcpu
	595	REAL temps0,temps1,temps2,temps3,temps4,temps5
	596	SAVE temps0,temps1,temps2,temps3,temps4,temps5
	597	SAVE first,testcpu
	598
	599	REAL convpn,convps,convmpn,convmps
	600	REAL sinlon(iip1),sinlondlon(iip1)
	601	REAL coslon(iip1),coslondlon(iip1)
	602	SAVE sinlon,coslon,sinlondlon,coslondlon
	603	SAVE airej2,airejjm
[2270]	604
	605	REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
	606	INTEGER ifils,iq2 ! CRisi
[524]	607	c
	608	c
	609	REAL SSUM
	610
	611	DATA first,testcpu/.true.,.false./
	612	DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
	613
	614	IF(first) THEN
	615	PRINT*,'Shema Amont nouveau appele dans Vanleer '
	616	first=.false.
	617	do i=2,iip1
	618	coslon(i)=cos(rlonv(i))
	619	sinlon(i)=sin(rlonv(i))
	620	coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
	621	sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
	622	ENDDO
	623	coslon(1)=coslon(iip1)
	624	coslondlon(1)=coslondlon(iip1)
	625	sinlon(1)=sinlon(iip1)
	626	sinlondlon(1)=sinlondlon(iip1)
	627	airej2 = SSUM( iim, aire(iip2), 1 )
	628	airejjm= SSUM( iim, aire(ip1jm -iim), 1 )
	629	ENDIF
	630
	631	c
	632
	633
	634	DO l = 1, llm
	635	c
	636	c --------------------------------
	637	c CALCUL EN LATITUDE
	638	c --------------------------------
	639
	640	c On commence par calculer la valeur du traceur moyenne sur le premier cercle
	641	c de latitude autour du pole (qpns pour le pole nord et qpsn pour
	642	c le pole nord) qui sera utilisee pour evaluer les pentes au pole.
	643
	644	DO i = 1, iim
[2270]	645	airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
	646	airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
[524]	647	ENDDO
	648	qpns = SSUM( iim, airescb ,1 ) / airej2
	649	qpsn = SSUM( iim, airesch ,1 ) / airejjm
	650
	651	c calcul des pentes aux points v
	652
	653	DO ij=1,ip1jm
[2270]	654	dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
[524]	655	adyqv(ij)=abs(dyqv(ij))
	656	ENDDO
	657
	658	c calcul des pentes aux points scalaires
	659
	660	DO ij=iip2,ip1jm
	661	dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
	662	dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
	663	dyqmax(ij)=pente_max*dyqmax(ij)
	664	ENDDO
	665
	666	c calcul des pentes aux poles
	667
	668	DO ij=1,iip1
[2270]	669	dyq(ij,l)=qpns-q(ij+iip1,l,iq)
	670	dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
[524]	671	ENDDO
	672
	673	c filtrage de la derivee
	674	dyn1=0.
	675	dys1=0.
	676	dyn2=0.
	677	dys2=0.
	678	DO ij=1,iim
	679	dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
	680	dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
	681	dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
	682	dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
	683	ENDDO
	684	DO ij=1,iip1
	685	dyq(ij,l)=dyn1sinlon(ij)+dyn2coslon(ij)
	686	dyq(ip1jm+ij,l)=dys1sinlon(ij)+dys2coslon(ij)
	687	ENDDO
	688
	689	c calcul des pentes limites aux poles
	690
	691	fn=1.
	692	fs=1.
	693	DO ij=1,iim
	694	IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN
	695	fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
	696	ENDIF
	697	IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN
	698	fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
	699	ENDIF
	700	ENDDO
	701	DO ij=1,iip1
	702	dyq(ij,l)=fn*dyq(ij,l)
	703	dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
	704	ENDDO
	705
	706	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	707	C En memoire de dIFferents tests sur la
	708	C limitation des pentes aux poles.
	709	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	710	C PRINT*,dyq(1)
	711	C PRINT*,dyqv(iip1+1)
[1520]	712	C appn=abs(dyq(1)/dyqv(iip1+1))
[524]	713	C PRINT*,dyq(ip1jm+1)
	714	C PRINT*,dyqv(ip1jm-iip1+1)
[1520]	715	C apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
[524]	716	C DO ij=2,iim
[1520]	717	C appn=amax1(abs(dyq(ij)/dyqv(ij)),appn)
	718	C apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps)
[524]	719	C ENDDO
[1520]	720	C appn=min(pente_max/appn,1.)
	721	C apps=min(pente_max/apps,1.)
[524]	722	C
	723	C
	724	C cas ou on a un extremum au pole
	725	C
	726	C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
[1520]	727	C & appn=0.
[524]	728	C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
	729	C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
[1520]	730	C & apps=0.
[524]	731	C
	732	C limitation des pentes aux poles
	733	C DO ij=1,iip1
[1520]	734	C dyq(ij)=appn*dyq(ij)
	735	C dyq(ip1jm+ij)=apps*dyq(ip1jm+ij)
[524]	736	C ENDDO
	737	C
	738	C test
	739	C DO ij=1,iip1
	740	C dyq(iip1+ij)=0.
	741	C dyq(ip1jm+ij-iip1)=0.
	742	C ENDDO
	743	C DO ij=1,ip1jmp1
	744	C dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
	745	C ENDDO
	746	C
	747	C changement 10 07 96
	748	C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
	749	C & THEN
	750	C DO ij=1,iip1
	751	C dyqmax(ij)=0.
	752	C ENDDO
	753	C ELSE
	754	C DO ij=1,iip1
	755	C dyqmax(ij)=pente_max*abs(dyqv(ij))
	756	C ENDDO
	757	C ENDIF
	758	C
	759	C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
	760	C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
	761	C &THEN
	762	C DO ij=ip1jm+1,ip1jmp1
	763	C dyqmax(ij)=0.
	764	C ENDDO
	765	C ELSE
	766	C DO ij=ip1jm+1,ip1jmp1
	767	C dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
	768	C ENDDO
	769	C ENDIF
	770	C fin changement 10 07 96
	771	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	772
	773	c calcul des pentes limitees
	774
	775	DO ij=iip2,ip1jm
	776	IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN
	777	dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
	778	ELSE
	779	dyq(ij,l)=0.
	780	ENDIF
	781	ENDDO
	782
	783	ENDDO
	784
	785	DO l=1,llm
	786	DO ij=1,ip1jm
	787	IF( masse_adv_v(ij,l).GT.0. ) THEN
[2270]	788	qbyv(ij,l)= MIN( qsat(ij+iip1,l), q(ij+iip1,l,iq ) +
	789	, dyq(ij+iip1,l)0.5(1.-masse_adv_v(ij,l)
	790	, /masse(ij+iip1,l,iq)))
[524]	791	ELSE
[2270]	792	qbyv(ij,l)= MIN( qsat(ij,l), q(ij,l,iq) - dyq(ij,l) *
	793	, 0.5*(1.+masse_adv_v(ij,l)/masse(ij,l,iq)) )
[524]	794	ENDIF
	795	qbyv(ij,l) = masse_adv_v(ij,l)*qbyv(ij,l)
	796	ENDDO
	797	ENDDO
	798
	799
[2270]	800	! CRisi: appel récursif de l'advection sur les fils.
	801	! Il faut faire ça avant d'avoir mis à jour q et masse
[2286]	802	!write(,) 'vlyqs 689: iq,nqfils(iq)=',iq,nqfils(iq)
[2270]	803
	804	if (nqfils(iq).gt.0) then
	805	do ifils=1,nqdesc(iq)
	806	iq2=iqfils(ifils,iq)
	807	DO l=1,llm
	808	DO ij=1,ip1jmp1
	809	masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
	810	Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
	811	enddo
	812	enddo
	813	enddo !do ifils=1,nqdesc(iq)
	814
	815	do ifils=1,nqfils(iq)
	816	iq2=iqfils(ifils,iq)
[2286]	817	!write(,) 'vlyqs 783: appel rec de vly, iq2=',iq2
[2270]	818	call vly(Ratio,pente_max,masseq,qbyv,iq2)
	819	enddo !do ifils=1,nqfils(iq)
	820	endif !if (nqfils(iq).gt.0) then
	821
[524]	822	DO l=1,llm
	823	DO ij=iip2,ip1jm
[2270]	824	newmasse=masse(ij,l,iq)
[524]	825	& +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
[2270]	826	q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l)
	827	& -qbyv(ij-iip1,l))/newmasse
	828	masse(ij,l,iq)=newmasse
[524]	829	ENDDO
	830	c.-. ancienne version
	831	convpn=SSUM(iim,qbyv(1,l),1)/apoln
	832	convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
	833	DO ij = 1,iip1
[2270]	834	newmasse=masse(ij,l,iq)+convmpn*aire(ij)
	835	q(ij,l,iq)=(q(ij,l,iq)masse(ij,l,iq)+convpnaire(ij))/
[524]	836	& newmasse
[2270]	837	masse(ij,l,iq)=newmasse
[524]	838	ENDDO
	839	convps = -SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
	840	convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols
	841	DO ij = ip1jm+1,ip1jmp1
[2270]	842	newmasse=masse(ij,l,iq)+convmps*aire(ij)
	843	q(ij,l,iq)=(q(ij,l,iq)masse(ij,l,iq)+convpsaire(ij))/
[524]	844	& newmasse
[2270]	845	masse(ij,l,iq)=newmasse
[524]	846	ENDDO
	847	c.-. fin ancienne version
	848
	849	c._. nouvelle version
	850	c convpn=SSUM(iim,qbyv(1,l),1)
	851	c convmpn=ssum(iim,masse_adv_v(1,l),1)
	852	c oldmasse=ssum(iim,masse(1,l),1)
	853	c newmasse=oldmasse+convmpn
	854	c newq=(q(1,l)*oldmasse+convpn)/newmasse
	855	c newmasse=newmasse/apoln
	856	c DO ij = 1,iip1
	857	c q(ij,l)=newq
[2270]	858	c masse(ij,l,iq)=newmasse*aire(ij)
[524]	859	c ENDDO
	860	c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
	861	c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
	862	c oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
	863	c newmasse=oldmasse+convmps
	864	c newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse
	865	c newmasse=newmasse/apols
	866	c DO ij = ip1jm+1,ip1jmp1
	867	c q(ij,l)=newq
[2270]	868	c masse(ij,l,iq)=newmasse*aire(ij)
[524]	869	c ENDDO
	870	c._. fin nouvelle version
	871	ENDDO
	872
[2286]	873	!write(,) 'vly 866'
[2270]	874
	875	! retablir les fils en rapport de melange par rapport a l'air:
	876	if (nqdesc(iq).gt.0) then
	877	do ifils=1,nqdesc(iq)
	878	iq2=iqfils(ifils,iq)
	879	DO l=1,llm
	880	DO ij=1,ip1jmp1
	881	q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)
	882	enddo
	883	enddo
	884	enddo !do ifils=1,nqdesc(iq)
	885	endif !if (nqfils(iq).gt.0) then
[2286]	886	!write(,) 'vly 879'
[2270]	887
[524]	888	RETURN
	889	END

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

Download in other formats:

Original Format