Context Navigation

conlmd.F @ 1

Last change on this file since 1 was 1, checked in by emillour, 14 years ago
Import initial LMDZ5
File size: 70.0 KB

Rev	Line
[1]	1	!
	2	! $Header$
	3	!
	4	SUBROUTINE conlmd (dtime, paprs, pplay, t, q, conv_q,
	5	s d_t, d_q, rain, snow, ibas, itop)
	6	USE dimphy
	7	IMPLICIT none
	8	c======================================================================
	9	c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
	10	c Objet: Schema de convection utilis'e dans le modele du LMD
	11	c Ajustement humide (Manabe) + Ajustement convectif (Kuo)
	12	c======================================================================
	13	cym#include "dimensions.h"
	14	cym#include "dimphy.h"
	15	#include "YOMCST.h"
	16	#include "YOETHF.h"
	17	c
	18	c Arguments:
	19	c
	20	REAL dtime ! pas d'integration (s)
	21	REAL paprs(klon,klev+1) ! pression inter-couche (Pa)
	22	REAL pplay(klon,klev) ! pression au milieu de couche (Pa)
	23	REAL t(klon,klev) ! temperature (K)
	24	REAL q(klon,klev) ! humidite specifique (kg/kg)
	25	REAL conv_q(klon,klev) ! taux de convergence humidite (g/g/s)
	26	c
	27	REAL d_t(klon,klev) ! incrementation temperature
	28	REAL d_q(klon,klev) ! incrementation humidite
	29	REAL rain(klon) ! pluies (mm/s)
	30	REAL snow(klon) ! neige (mm/s)
	31	INTEGER ibas(klon) ! niveau du bas
	32	INTEGER itop(klon) ! niveau du haut
	33	c
	34	LOGICAL usekuo ! utiliser convection profonde (schema Kuo)
	35	PARAMETER (usekuo=.TRUE.)
	36	c
	37	REAL d_t_bis(klon,klev)
	38	REAL d_q_bis(klon,klev)
	39	REAL rain_bis(klon)
	40	REAL snow_bis(klon)
	41	INTEGER ibas_bis(klon)
	42	INTEGER itop_bis(klon)
	43	REAL d_ql(klon,klev), d_ql_bis(klon,klev)
	44	REAL rneb(klon,klev), rneb_bis(klon,klev)
	45	c
	46	INTEGER i, k
	47	REAL zlvdcp, zlsdcp, zdelta, zz, za, zb
	48	c
	49	ccc CALL fiajh ! ancienne version de Convection Manabe
	50	CALL conman ! nouvelle version de Convection Manabe
	51	e (dtime, paprs, pplay, t, q,
	52	s d_t, d_q, d_ql, rneb,
	53	s rain, snow, ibas, itop)
	54	c
	55	IF (usekuo) THEN
	56	ccc CALL fiajc ! ancienne version de Convection Kuo
	57	CALL conkuo ! nouvelle version de Convection Kuo
	58	e (dtime, paprs, pplay, t, q, conv_q,
	59	s d_t_bis, d_q_bis, d_ql_bis, rneb_bis,
	60	s rain_bis, snow_bis, ibas_bis, itop_bis)
	61	DO k = 1, klev
	62	DO i = 1, klon
	63	d_t(i,k) = d_t(i,k) + d_t_bis(i,k)
	64	d_q(i,k) = d_q(i,k) + d_q_bis(i,k)
	65	d_ql(i,k) = d_ql(i,k) + d_ql_bis(i,k)
	66	ENDDO
	67	ENDDO
	68	DO i = 1, klon
	69	rain(i) = rain(i) + rain_bis(i)
	70	snow(i) = snow(i) + snow_bis(i)
	71	ibas(i) = MIN(ibas(i),ibas_bis(i))
	72	itop(i) = MAX(itop(i),itop_bis(i))
	73	ENDDO
	74	ENDIF
	75	c
	76	c L'eau liquide convective est dispersee dans l'air:
	77	c
	78	DO k = 1, klev
	79	DO i = 1, klon
	80	zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q(i,k))
	81	zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q(i,k))
	82	zdelta = MAX(0.,SIGN(1.,RTT-t(i,k)))
	83	zz = d_ql(i,k) ! re-evap. de l'eau liquide
	84	zb = MAX(0.0,zz)
	85	za = - MAX(0.0,zz) * (zlvdcp(1.-zdelta)+zlsdcpzdelta)
	86	d_t(i,k) = d_t(i,k) + za
	87	d_q(i,k) = d_q(i,k) + zb
	88	ENDDO
	89	ENDDO
	90	c
	91	RETURN
	92	END
	93	SUBROUTINE conman (dtime, paprs, pplay, t, q,
	94	s d_t, d_q, d_ql, rneb,
	95	s rain, snow, ibas, itop)
	96	USE dimphy
	97	IMPLICIT none
	98	c======================================================================
	99	c Auteur(s): Z.X. Li (LMD/CNRS) date: 19970324
	100	c Objet: ajustement humide convectif avec la possibilite de faire
	101	c l'ajustement sur une fraction de la maille.
	102	c Methode: On impose une distribution uniforme pour la vapeur d'eau
	103	c au sein d'une maille. On applique la procedure d'ajustement
	104	c successivement a la totalite, 75%, 50%, 25% et 5% de la maille
	105	c jusqu'a ce que l'ajustement a lieu. J'espere que ceci augmente
	106	c les activites convectives et corrige le biais "trop froid et sec"
	107	c du modele.
	108	c======================================================================
	109	cym#include "dimensions.h"
	110	cym#include "dimphy.h"
	111	#include "YOMCST.h"
	112	c
	113	REAL dtime ! pas d'integration (s)
	114	REAL t(klon,klev) ! temperature (K)
	115	REAL q(klon,klev) ! humidite specifique (kg/kg)
	116	REAL paprs(klon,klev+1) ! pression inter-couche (Pa)
	117	REAL pplay(klon,klev) ! pression au milieu de couche (Pa)
	118	c
	119	REAL d_t(klon,klev) ! incrementation temperature
	120	REAL d_q(klon,klev) ! incrementation humidite
	121	REAL d_ql(klon,klev) ! incrementation eau liquide
	122	REAL rneb(klon,klev) ! nebulosite
	123	REAL rain(klon) ! pluies (mm/s)
	124	REAL snow(klon) ! neige (mm/s)
	125	INTEGER ibas(klon) ! niveau du bas
	126	INTEGER itop(klon) ! niveau du haut
	127	c
	128	LOGICAL afaire(klon) ! .TRUE. implique l'ajustement
	129	LOGICAL accompli(klon) ! .TRUE. si l'ajustement est effectif
	130	c
	131	INTEGER nb ! nombre de sous-fractions a considere
	132	PARAMETER (nb=1)
	133	ccc PARAMETER (nb=3)
	134	c
	135	REAL ratqs ! largeur de la distribution pour vapeur d'eau
	136	PARAMETER (ratqs=0.05)
	137	c
	138	REAL w_q(klon,klev)
	139	REAL w_d_t(klon,klev), w_d_q(klon,klev), w_d_ql(klon,klev)
	140	REAL w_rneb(klon,klev)
	141	REAL w_rain(klon), w_snow(klon)
	142	INTEGER w_ibas(klon), w_itop(klon)
	143	REAL zq1, zq2
	144	INTEGER i, k, n
	145	c
	146	REAL t_coup
	147	PARAMETER (t_coup=234.0)
	148	REAL zdp1, zdp2
	149	REAL zqs1, zqs2, zdqs1, zdqs2
	150	REAL zgamdz
	151	REAL zflo ! flotabilite
	152	REAL zsat ! sur-saturation
	153	REAL zdelta, zcor, zcvm5
	154	LOGICAL imprim
	155	c
	156	INTEGER ncpt
	157	SAVE ncpt
	158	c$OMP THREADPRIVATE(ncpt)
	159	REAL frac(nb) ! valeur de la maille fractionnelle
	160	SAVE frac
	161	c$OMP THREADPRIVATE(frac)
	162	INTEGER opt_cld(nb) ! option pour le modele nuageux
	163	SAVE opt_cld
	164	c$OMP THREADPRIVATE(opt_cld)
	165	LOGICAL appel1er
	166	SAVE appel1er
	167	c$OMP THREADPRIVATE(appel1er)
	168	c
	169	c Fonctions thermodynamiques:
	170	c
	171	#include "YOETHF.h"
	172	#include "FCTTRE.h"
	173	c
	174	DATA frac / 1.0 /
	175	DATA opt_cld / 4 /
	176	ccc DATA frac / 1.0, 0.50, 0.25/
	177	ccc DATA opt_cld / 4, 4, 4/
	178	c
	179	DATA appel1er /.TRUE./
	180	DATA ncpt /0/
	181	c
	182	IF (appel1er) THEN
	183	PRINT*, 'conman, nb:', nb
	184	PRINT*, 'conman, frac:', frac
	185	PRINT*, 'conman, opt_cld:', opt_cld
	186	appel1er = .FALSE.
	187	ENDIF
	188	c
	189	c Initialiser les sorties a zero:
	190	c
	191	DO k = 1, klev
	192	DO i = 1, klon
	193	d_t(i,k) = 0.0
	194	d_q(i,k) = 0.0
	195	d_ql(i,k) = 0.0
	196	rneb(i,k) = 0.0
	197	ENDDO
	198	ENDDO
	199	DO i = 1, klon
	200	ibas(i) = klev
	201	itop(i) = 1
	202	rain(i) = 0.0
	203	snow(i) = 0.0
	204	ENDDO
	205	c
	206	c S'il n'y a pas d'instabilite conditionnelle,
	207	c pas la penne de se fatiguer:
	208	c
	209	DO i = 1, klon
	210	afaire(i) = .FALSE.
	211	ENDDO
	212	DO k = 1, klev-1
	213	DO i = 1, klon
	214	IF (thermcep) THEN
	215	zdelta=MAX(0.,SIGN(1.,RTT-t(i,k)))
	216	zcvm5=R5LESRLVTT(1.-zdelta) + zdeltaR5IESRLSTT
	217	zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k))
	218	zqs1= R2ES*FOEEW(t(i,k),zdelta)/pplay(i,k)
	219	zqs1=MIN(0.5,zqs1)
	220	zcor=1./(1.-RETV*zqs1)
	221	zqs1=zqs1*zcor
	222	zdqs1 =FOEDE(t(i,k),zdelta,zcvm5,zqs1,zcor)
	223	c
	224	zdelta=MAX(0.,SIGN(1.,RTT-t(i,k+1)))
	225	zcvm5=R5LESRLVTT(1.-zdelta) + zdeltaR5IESRLSTT
	226	zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k+1))
	227	zqs2= R2ES*FOEEW(t(i,k+1),zdelta)/pplay(i,k+1)
	228	zqs2=MIN(0.5,zqs2)
	229	zcor=1./(1.-RETV*zqs2)
	230	zqs2=zqs2*zcor
	231	zdqs2 =FOEDE(t(i,k+1),zdelta,zcvm5,zqs2,zcor)
	232	ELSE
	233	IF (t(i,k) .LT. t_coup) THEN
	234	zqs1= qsats(t(i,k)) / pplay(i,k)
	235	zdqs1= dqsats(t(i,k),zqs1)
	236	c
	237	zqs2= qsats(t(i,k+1)) / pplay(i,k+1)
	238	zdqs2= dqsats(t(i,k+1),zqs2)
	239	ELSE
	240	zqs1= qsatl(t(i,k)) / pplay(i,k)
	241	zdqs1= dqsatl(t(i,k),zqs1)
	242	c
	243	zqs2= qsatl(t(i,k+1)) / pplay(i,k+1)
	244	zdqs2= dqsatl(t(i,k+1),zqs2)
	245	ENDIF
	246	ENDIF
	247	zdp1 = paprs(i,k) - paprs(i,k+1)
	248	zdp2 = paprs(i,k+1) - paprs(i,k+2)
	249	zgamdz = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD
	250	. ( RD(t(i,k)zdp1+t(i,k+1)zdp2)/(zdp1+zdp2)
	251	. +RLVTT(zqs1zdp1+zqs2*zdp2)/(zdp1+zdp2)
	252	. ) / (1.0+(zdqs1zdp1+zdqs2zdp2)/(zdp1+zdp2) )
	253	zflo = t(i,k) + zgamdz - t(i,k+1)
	254	zsat = (q(i,k)-zqs1)zdp1 + (q(i,k+1)-zqs2)zdp2
	255	IF (zflo.GT.0.0) afaire(i) = .TRUE.
	256	c erreur IF (zflo.GT.0.0 .AND. zsat.GT.0.0) afaire(i) = .TRUE.
	257	ENDDO
	258	ENDDO
	259	c
	260	imprim = MOD(ncpt,48).EQ.0
	261	DO 99999 n = 1, nb
	262	c
	263	DO k = 1, klev
	264	DO i = 1, klon
	265	IF (afaire(i)) THEN
	266	zq1 = q(i,k) * (1.0-ratqs)
	267	zq2 = q(i,k) * (1.0+ratqs)
	268	w_q(i,k) = zq2 - frac(n)/2.0 * (zq2-zq1)
	269	ENDIF
	270	ENDDO
	271	ENDDO
	272	c
	273	CALL conmanv (dtime, paprs, pplay, t, w_q,
	274	e afaire, opt_cld(n),
	275	s w_d_t, w_d_q, w_d_ql, w_rneb,
	276	s w_rain, w_snow, w_ibas, w_itop,accompli,imprim)
	277	DO k = 1, klev
	278	DO i = 1, klon
	279	IF (afaire(i) .AND. accompli(i)) THEN
	280	d_t(i,k) = w_d_t(i,k) * frac(n)
	281	d_q(i,k) = w_d_q(i,k) * frac(n)
	282	d_ql(i,k) = w_d_ql(i,k) * frac(n)
	283	IF (NINT(w_rneb(i,k)).EQ.1) rneb(i,k) = frac(n)
	284	ENDIF
	285	ENDDO
	286	ENDDO
	287	DO i = 1, klon
	288	IF (afaire(i) .AND. accompli(i)) THEN
	289	rain(i) = w_rain(i) * frac(n)
	290	snow(i) = w_snow(i) * frac(n)
	291	ibas(i) = MIN(ibas(i),w_ibas(i))
	292	itop(i) = MAX(itop(i),w_itop(i))
	293	ENDIF
	294	ENDDO
	295	DO i = 1, klon
	296	IF(afaire(i) .AND. accompli(i)) afaire(i) = .FALSE.
	297	ENDDO
	298	c
	299	99999 CONTINUE
	300	c
	301	ncpt = ncpt + 1
	302	c
	303	RETURN
	304	END
	305	SUBROUTINE conmanv (dtime, paprs, pplay, t, q,
	306	e afaire, opt_cld,
	307	s d_t, d_q, d_ql, rneb,
	308	s rain, snow, ibas, itop,accompli,imprim)
	309	USE dimphy
	310	IMPLICIT none
	311	c======================================================================
	312	c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
	313	c Objet: ajustement humide (convection proposee par Manabe).
	314	c Pour une colonne verticale, il peut avoir plusieurs blocs
	315	c necessitant l'ajustement. ibas est le bas du plus bas bloc
	316	c et itop est le haut du plus haut bloc
	317	c======================================================================
	318	cym#include "dimensions.h"
	319	cym#include "dimphy.h"
	320	#include "YOMCST.h"
	321	c
	322	c Arguments:
	323	c
	324	REAL dtime ! pas d'integration (s)
	325	REAL t(klon,klev) ! temperature (K)
	326	REAL q(klon,klev) ! humidite specifique (kg/kg)
	327	REAL paprs(klon,klev+1) ! pression inter-couche (Pa)
	328	REAL pplay(klon,klev) ! pression au milieu de couche (Pa)
	329	INTEGER opt_cld ! comment traiter l'eau liquide
	330	LOGICAL afaire(klon) ! .TRUE. si le point est a faire (Input)
	331	LOGICAL imprim ! .T. pour imprimer quelques diagnostiques
	332	c
	333	REAL d_t(klon,klev) ! incrementation temperature
	334	REAL d_q(klon,klev) ! incrementation humidite
	335	REAL d_ql(klon,klev) ! incrementation eau liquide
	336	REAL rneb(klon,klev) ! nebulosite
	337	REAL rain(klon) ! pluies (mm/s)
	338	REAL snow(klon) ! neige (mm/s)
	339	INTEGER ibas(klon) ! niveau du bas
	340	INTEGER itop(klon) ! niveau du haut
	341	LOGICAL accompli(klon) ! .TRUE. si l'ajustement a eu lieu (Output)
	342	c
	343	c Quelques options:
	344	c
	345	LOGICAL new_top ! re-calculer sommet quand re-ajustement est fait
	346	PARAMETER (new_top=.FALSE.)
	347	LOGICAL evap_prec ! evaporation de pluie au-dessous de convection
	348	PARAMETER (evap_prec=.TRUE.)
	349	REAL coef_eva
	350	PARAMETER (coef_eva=1.0E-05)
	351	REAL t_coup
	352	PARAMETER (t_coup=234.0)
	353	REAL seuil_vap
	354	PARAMETER (seuil_vap=1.0E-10)
	355	LOGICAL old_tau ! implique precip nulle, si vrai.
	356	PARAMETER (old_tau=.FALSE.)
	357	REAL toliq(klon) ! rapport entre l'eau nuageuse et l'eau precipitante
	358	REAL dpmin, tomax !Epaisseur faible, rapport eau liquide plus grande
	359	PARAMETER (dpmin=0.15, tomax=0.97)
	360	REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible
	361	PARAMETER (dpmax=0.30, tomin=0.05)
	362	REAL deep_sig, deep_to ! au dela de deep_sig, utiliser deep_to
	363	PARAMETER (deep_sig=0.50, deep_to=0.05)
	364	LOGICAL exigent ! implique un calcul supplementaire pour Qs
	365	PARAMETER (exigent=.FALSE.)
	366	c
	367	INTEGER kbase
	368	PARAMETER (kbase=0)
	369	c
	370	c Variables locales:
	371	c
	372	INTEGER nexpo
	373	INTEGER i, k, k1min, k1max, k2min, k2max, is
	374	REAL zgamdz(klon,klev-1)
	375	REAL zt(klon,klev), zq(klon,klev)
	376	REAL zqs(klon,klev), zdqs(klon,klev)
	377	REAL zqmqsdp(klon,klev)
	378	REAL ztnew(klon,klev), zqnew(klon,klev)
	379	REAL zcond(klon), zvapo(klon), zrapp(klon)
	380	REAL zrfl(klon), zrfln, zqev, zqevt
	381	REAL zsat(klon) ! sur-saturation
	382	REAL zflo(klon) ! flotabilite
	383	REAL za(klon), zb(klon), zc(klon)
	384	INTEGER k1(klon), k2(klon)
	385	REAL zdelta, zcor, zcvm5
	386	REAL delp(klon,klev)
	387	LOGICAL possible(klon), todo(klon), etendre(klon)
	388	LOGICAL aller(klon), todobis(klon)
	389	REAL zalfa
	390	INTEGER nbtodo, nbdone
	391	c
	392	c Fonctions thermodynamiques:
	393	c
	394	#include "YOETHF.h"
	395	#include "FCTTRE.h"
	396	c
	397	DO k = 1, klev
	398	DO i = 1, klon
	399	delp(i,k) = paprs(i,k) - paprs(i,k+1)
	400	ENDDO
	401	ENDDO
	402	c
	403	c Initialiser les sorties a zero
	404	c
	405	DO k = 1, klev
	406	DO i = 1, klon
	407	d_t(i,k) = 0.0
	408	d_q(i,k) = 0.0
	409	d_ql(i,k) = 0.0
	410	rneb(i,k) = 0.0
	411	ENDDO
	412	ENDDO
	413	DO i = 1, klon
	414	ibas(i) = klev
	415	itop(i) = 1
	416	rain(i) = 0.0
	417	snow(i) = 0.0
	418	accompli(i) = .FALSE.
	419	ENDDO
	420	c
	421	c Preparations
	422	c
	423	DO k = 1, klev
	424	DO i = 1, klon
	425	IF (afaire(i)) THEN
	426	zt(i,k) = t(i,k)
	427	zq(i,k) = q(i,k)
	428	c
	429	c Calculer Qs et L/Cp*dQs/dT
	430	c
	431	IF (thermcep) THEN
	432	zdelta=MAX(0.,SIGN(1.,RTT-zt(i,k)))
	433	zcvm5=R5LESRLVTT(1.-zdelta) + zdeltaR5IESRLSTT
	434	zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i,k))
	435	zqs(i,k)= R2ES*FOEEW(zt(i,k),zdelta)/pplay(i,k)
	436	zqs(i,k)=MIN(0.5,zqs(i,k))
	437	zcor=1./(1.-RETV*zqs(i,k))
	438	zqs(i,k)=zqs(i,k)*zcor
	439	zdqs(i,k) =FOEDE(zt(i,k),zdelta,zcvm5,zqs(i,k),zcor)
	440	ELSE
	441	IF (zt(i,k) .LT. t_coup) THEN
	442	zqs(i,k)= qsats(zt(i,k)) / pplay(i,k)
	443	zdqs(i,k)= dqsats(zt(i,k),zqs(i,k))
	444	ELSE
	445	zqs(i,k)= qsatl(zt(i,k)) / pplay(i,k)
	446	zdqs(i,k)= dqsatl(zt(i,k),zqs(i,k))
	447	ENDIF
	448	ENDIF
	449	c
	450	c Calculer (q-qs)*dp
	451	zqmqsdp(i,k) = (zq(i,k)-zqs(i,k)) * delp(i,k)
	452	ENDIF
	453	ENDDO
	454	ENDDO
	455	c
	456	c-----zgama is the moist convective lapse rate (-dT/dz).
	457	c-----zgamdz(*,k) est la difference minimale autorisee des temperatures
	458	c-----entre deux couches (k et k+1), c.a.d. si T(k+1)-T(k) est inferieur
	459	c-----a zgamdz(*,k), alors ces 2 couches sont instables conditionnellement
	460	c
	461	DO k = 1, klev-1
	462	DO i = 1, klon
	463	IF (afaire(i)) THEN
	464	zgamdz(i,k) = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD
	465	. ( RD(zt(i,k)delp(i,k)+zt(i,k+1)delp(i,k+1))
	466	. /(delp(i,k)+delp(i,k+1))
	467	. +RLVTT(zqs(i,k)delp(i,k)+zqs(i,k+1)*delp(i,k+1))
	468	. /(delp(i,k)+delp(i,k+1))
	469	. ) / (1.0+(zdqs(i,k)delp(i,k)+zdqs(i,k+1)delp(i,k+1))
	470	. /(delp(i,k)+delp(i,k+1)) )
	471	ENDIF
	472	ENDDO
	473	ENDDO
	474	c
	475	c On cherche la presence simultanee d'instabilite conditionnelle
	476	c et de sur-saturation. Sinon, pas la penne de se fatiguer:
	477	c
	478	DO i = 1, klon
	479	possible(i) = .FALSE.
	480	ENDDO
	481	DO k = 2, klev
	482	DO i = 1, klon
	483	IF (afaire(i)) THEN
	484	zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
	485	zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1)
	486	IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) possible(i) = .TRUE.
	487	ENDIF
	488	ENDDO
	489	ENDDO
	490	c
	491	DO i = 1, klon
	492	IF (possible(i)) THEN
	493	k1(i) = kbase
	494	k2(i) = k1(i) + 1
	495	ENDIF
	496	ENDDO
	497	c
	498	810 CONTINUE ! chercher le bas de la colonne a ajuster
	499	c
	500	k2min = klev
	501	DO i = 1, klon
	502	todo(i) = .FALSE.
	503	aller(i) = .TRUE.
	504	IF (possible(i)) k2min = MIN(k2min,k2(i))
	505	ENDDO
	506	IF (k2min.EQ.klev) GOTO 860
	507	DO k = k2min, klev-1
	508	DO i = 1, klon
	509	IF (possible(i) .AND. k.GE.k2(i) .AND. aller(i)) THEN
	510	zflo(i) = zt(i,k) + zgamdz(i,k) - zt(i,k+1)
	511	zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k+1)
	512	IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN
	513	k1(i) = k
	514	k2(i) = k+1
	515	todo(i) = .TRUE.
	516	aller(i) = .FALSE.
	517	ENDIF
	518	ENDIF
	519	ENDDO
	520	ENDDO
	521	DO i = 1, klon
	522	IF (possible(i).AND.aller(i)) THEN
	523	todo(i) = .FALSE.
	524	k1(i) = klev
	525	k2(i) = klev
	526	ENDIF
	527	ENDDO
	528	c
	529	CCC DO i = 1, klon
	530	CCC IF (possible(i)) THEN
	531	CCC 811 k2(i) = k2(i) + 1
	532	CCC IF (k2(i) .GT. klev) THEN
	533	CCC todo(i) = .FALSE.
	534	CCC GOTO 812
	535	CCC ENDIF
	536	CCC k = k2(i)
	537	CCC zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
	538	CCC zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1)
	539	CCC IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) GOTO 811
	540	CCC k1(i) = k2(i) - 1
	541	CCC todo(i) = .TRUE.
	542	CCC ENDIF
	543	CCC 812 CONTINUE
	544	CCC ENDDO
	545	c
	546	820 CONTINUE ! chercher le haut de la colonne
	547	c
	548	k2min = klev
	549	DO i = 1, klon
	550	aller(i) = .TRUE.
	551	IF (todo(i)) k2min = MIN(k2min,k2(i))
	552	ENDDO
	553	IF (k2min.LT.klev) THEN
	554	DO k = k2min, klev
	555	DO i = 1, klon
	556	IF (todo(i) .AND. k.GT.k2(i) .AND. aller(i)) THEN
	557	zsat(i) = zsat(i) + zqmqsdp(i,k)
	558	zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
	559	IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) THEN
	560	aller(i) = .FALSE.
	561	ELSE
	562	k2(i) = k
	563	ENDIF
	564	ENDIF
	565	ENDDO
	566	ENDDO
	567	c error is = 0
	568	c error DO i = 1, klon
	569	c error IF(todo(i).AND.aller(i)) THEN
	570	c error is = is + 1
	571	c error todo(i) = .FALSE.
	572	c error k2(i) = klev
	573	c error ENDIF
	574	c error ENDDO
	575	c error IF (is.GT.0) THEN
	576	c error PRINT*, "Bizard. je pourrais continuer mais j arrete"
	577	c error CALL abort
	578	c error ENDIF
	579	ENDIF
	580	c
	581	CCC DO i = 1, klon
	582	CCC IF (todo(i)) THEN
	583	CCC 821 CONTINUE
	584	CCC IF (k2(i) .EQ. klev) GOTO 822
	585	CCC k = k2(i) + 1
	586	CCC zsat(i) = zsat(i) + zqmqsdp(i,k)
	587	CCC zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
	588	CCC IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) GOTO 822
	589	CCC k2(i) = k
	590	CCC GOTO 821
	591	CCC ENDIF
	592	CCC 822 CONTINUE
	593	CCC ENDDO
	594	c
	595	830 CONTINUE ! faire l'ajustement en sachant k1 et k2
	596	c
	597	is = 0
	598	DO i = 1, klon
	599	IF (todo(i)) THEN
	600	IF (k2(i).LE.k1(i)) is = is + 1
	601	ENDIF
	602	ENDDO
	603	IF (is.GT.0) THEN
	604	PRINT*, "Impossible: k1 trop grand ou k2 trop petit"
	605	PRINT*, "is=", is
	606	CALL abort
	607	ENDIF
	608	c
	609	k1min = klev
	610	k1max = 1
	611	k2max = 1
	612	DO i = 1, klon
	613	IF (todo(i)) THEN
	614	k1min = MIN(k1min,k1(i))
	615	k1max = MAX(k1max,k1(i))
	616	k2max = MAX(k2max,k2(i))
	617	ENDIF
	618	ENDDO
	619	c
	620	DO i = 1, klon
	621	IF (todo(i)) THEN
	622	k = k1(i)
	623	za(i) = 0.
	624	zb(i) = ( RCPD(1.+zdqs(i,k))(zt(i,k)-za(i))
	625	. -RLVTT(zqs(i,k)-zq(i,k)) )delp(i,k)
	626	zc(i) = delp(i,k) * RCPD*(1.+zdqs(i,k))
	627	ENDIF
	628	ENDDO
	629	c
	630	DO k = k1min, k2max
	631	DO i = 1, klon
	632	IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i)) THEN
	633	za(i) = za(i) + zgamdz(i,k-1)
	634	zb(i) = zb(i)+(RCPD(1.+zdqs(i,k))(zt(i,k)-za(i))
	635	. -RLVTT(zqs(i,k)-zq(i,k)) ) delp(i,k)
	636	zc(i) = zc(i) + delp(i,k)RCPD(1.+zdqs(i,k))
	637	ENDIF
	638	ENDDO
	639	ENDDO
	640	c
	641	DO i = 1, klon
	642	IF (todo(i)) THEN
	643	k = k1(i)
	644	ztnew(i,k) = zb(i)/zc(i)
	645	zqnew(i,k) = zqs(i,k) + (ztnew(i,k)-zt(i,k))
	646	. RCPD/RLVTTzdqs(i,k)
	647	ENDIF
	648	ENDDO
	649	c
	650	DO k = k1min, k2max
	651	DO i = 1, klon
	652	IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i)) THEN
	653	ztnew(i,k) = ztnew(i,k-1) + zgamdz(i,k-1)
	654	zqnew(i,k) = zqs(i,k) + (ztnew(i,k)-zt(i,k))
	655	. RCPD/RLVTTzdqs(i,k)
	656	ENDIF
	657	ENDDO
	658	ENDDO
	659	c
	660	c Quantite de condensation produite pendant l'ajustement:
	661	c
	662	DO i = 1, klon
	663	zcond(i) = 0.0
	664	ENDDO
	665	DO k = k1min, k2max
	666	DO i = 1, klon
	667	IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN
	668	rneb(i,k) = 1.0
	669	zcond(i) = zcond(i) + (zq(i,k)-zqnew(i,k)) *delp(i,k)/RG
	670	ENDIF
	671	ENDDO
	672	ENDDO
	673	c
	674	c Si condensation negative, effort completement perdu:
	675	c
	676	DO i = 1, klon
	677	IF (todo(i).AND.zcond(i).LE.0.) todo(i) = .FALSE.
	678	ENDDO
	679	c
	680	c L'ajustement a ete accompli, meme les calculs accessoires
	681	c ne sont pas encore faits:
	682	c
	683	DO i = 1, klon
	684	IF (todo(i)) accompli(i) = .TRUE.
	685	ENDDO
	686	c
	687	c=====
	688	c Une fois que la condensation a lieu, on doit construire un
	689	c "modele nuageux" pour partager la condensation entre l'eau
	690	c liquide nuageuse et la precipitation (leur rapport toliq
	691	c est calcule selon l'epaisseur nuageuse). Je suppose que
	692	c toliq=tomax quand l'epaisseur nuageuse est inferieure a dpmin,
	693	c et que toliq=tomin quand l'epaisseur depasse dpmax (interpolation
	694	c lineaire entre dpmin et dpmax).
	695	c=====
	696	DO i = 1, klon
	697	IF (todo(i)) THEN
	698	toliq(i) = tomax-((paprs(i,k1(i))-paprs(i,k2(i)+1))
	699	. /paprs(i,1)-dpmin)
	700	. *(tomax-tomin)/(dpmax-dpmin)
	701	toliq(i) = MAX(tomin,MIN(tomax,toliq(i)))
	702	IF (pplay(i,k2(i))/paprs(i,1) .LE. deep_sig) toliq(i) = deep_to
	703	IF (old_tau) toliq(i) = 1.0
	704	ENDIF
	705	ENDDO
	706	c=====
	707	c On doit aussi determiner la distribution verticale de
	708	c l'eau nuageuse. Plusieurs options sont proposees:
	709	c
	710	c (0) La condensation precipite integralement (toliq ne sera
	711	c pas utilise).
	712	c (1) L'eau liquide est distribuee entre k1 et k2 et proportionnelle
	713	c a la vapeur d'eau locale.
	714	c (2) Elle est distribuee entre k1 et k2 avec une valeur constante.
	715	c (3) Elle est seulement distribuee aux couches ou la vapeur d'eau
	716	c est effectivement diminuee pendant le processus d'ajustement.
	717	c (4) Elle est en fonction (lineaire ou exponentielle) de la
	718	c distance (epaisseur en pression) avec le niveau k1 (la couche
	719	c k1 n'aura donc pas d'eau liquide).
	720	c=====
	721	c
	722	IF (opt_cld.EQ.0) THEN
	723	c
	724	DO i = 1, klon
	725	IF (todo(i)) zrfl(i) = zcond(i) / dtime
	726	ENDDO
	727	c
	728	ELSE IF (opt_cld.EQ.1) THEN
	729	c
	730	DO i = 1, klon
	731	IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de vapeur d'eau
	732	ENDDO
	733	DO k = k1min, k2max
	734	DO i = 1, klon
	735	IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i))
	736	. zvapo(i) = zvapo(i) + zqnew(i,k)*delp(i,k)/RG
	737	ENDDO
	738	ENDDO
	739	DO i = 1, klon
	740	IF (todo(i)) THEN
	741	zrapp(i) = toliq(i) * zcond(i) / zvapo(i)
	742	zrapp(i) = MAX(0.,MIN(1.,zrapp(i)))
	743	zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
	744	ENDIF
	745	ENDDO
	746	DO k = k1min, k2max
	747	DO i = 1, klon
	748	IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN
	749	d_ql(i,k) = d_ql(i,k) + zrapp(i) * zqnew(i,k)
	750	ENDIF
	751	ENDDO
	752	ENDDO
	753	c
	754	ELSE IF (opt_cld.EQ.2) THEN
	755	c
	756	DO i = 1, klon
	757	IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse
	758	ENDDO
	759	DO k = k1min, k2max
	760	DO i = 1, klon
	761	IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i))
	762	. zvapo(i) = zvapo(i) + delp(i,k)/RG
	763	ENDDO
	764	ENDDO
	765	DO k = k1min, k2max
	766	DO i = 1, klon
	767	IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN
	768	d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
	769	ENDIF
	770	ENDDO
	771	ENDDO
	772	DO i = 1, klon
	773	IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
	774	ENDDO
	775	c
	776	ELSE IF (opt_cld.EQ.3) THEN
	777	c
	778	DO i = 1, klon
	779	IF (todo(i)) zvapo(i) = 0.0 ! quantite de l'eau strictement condensee
	780	ENDDO
	781	DO k = k1min, k2max
	782	DO i = 1, klon
	783	IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i))
	784	. zvapo(i) = zvapo(i) + MAX(0.0,zq(i,k)-zqnew(i,k))
	785	. * delp(i,k)/RG
	786	ENDDO
	787	ENDDO
	788	DO k = k1min, k2max
	789	DO i = 1, klon
	790	IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i) .AND.
	791	. zvapo(i).GT.0.0)
	792	. d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
	793	. * MAX(0.0,zq(i,k)-zqnew(i,k))
	794	ENDDO
	795	ENDDO
	796	DO i = 1, klon
	797	IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
	798	ENDDO
	799	c
	800	ELSE IF (opt_cld.EQ.4) THEN
	801	c
	802	nexpo = 3
	803	ccc nexpo = 1 ! distribution lineaire
	804	c
	805	DO i = 1, klon
	806	IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse
	807	ENDDO ! (avec ponderation)
	808	DO k = k1min, k2max
	809	DO i = 1, klon
	810	IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i))
	811	. zvapo(i) = zvapo(i) + delp(i,k) / RG
	812	. * (pplay(i,k1(i))-pplay(i,k))**nexpo
	813	ENDDO
	814	ENDDO
	815	DO k = k1min, k2max
	816	DO i = 1, klon
	817	IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i))
	818	. d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
	819	. * (pplay(i,k1(i))-pplay(i,k))**nexpo
	820	ENDDO
	821	ENDDO
	822	DO i = 1, klon
	823	IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
	824	ENDDO
	825	c
	826	ELSE ! valeur non-prevue pour opt_cld
	827	c
	828	PRINT*, "opt_cld est faux:", opt_cld
	829	CALL abort
	830	c
	831	ENDIF ! fin de opt_cld
	832	c
	833	c L'eau precipitante peut etre evaporee:
	834	c
	835	zalfa = 0.05
	836	IF (evap_prec .AND. (k1max.GE.2)) THEN
	837	DO k = k1max-1, 1, -1
	838	DO i = 1, klon
	839	IF (todo(i) .AND. k.LT.k1(i) .AND. zrfl(i).GT.0.0) THEN
	840	zqev = MAX (0.0, (zqs(i,k)-zq(i,k))*zalfa )
	841	zqevt = coef_eva * (1.0-zq(i,k)/zqs(i,k))*SQRT(zrfl(i))
	842	. * delp(i,k)/pplay(i,k)zt(i,k)RD/RG
	843	zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) * RG*dtime/delp(i,k)
	844	zqev = MIN (zqev, zqevt)
	845	zrfln = zrfl(i) - zqev*(delp(i,k))/RG/dtime
	846	zq(i,k) = zq(i,k) - (zrfln-zrfl(i))
	847	. * (RG/(delp(i,k)))*dtime
	848	zt(i,k) = zt(i,k) + (zrfln-zrfl(i))
	849	. * (RG/(delp(i,k)))*dtime
	850	. * RLVTT/RCPD/(1.0+RVTMP2*zq(i,k))
	851	zrfl(i) = zrfln
	852	ENDIF
	853	ENDDO
	854	ENDDO
	855	ENDIF
	856	c
	857	c La temperature de la premiere couche determine la pluie ou la neige:
	858	c
	859	DO i = 1, klon
	860	IF (todo(i)) THEN
	861	IF (zt(i,1) .GT. RTT) THEN
	862	rain(i) = rain(i) + zrfl(i)
	863	ELSE
	864	snow(i) = snow(i) + zrfl(i)
	865	ENDIF
	866	ENDIF
	867	ENDDO
	868	c
	869	c Mise a jour de la temperature et de l'humidite
	870	c
	871	DO k = k1min, k2max
	872	DO i = 1, klon
	873	IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN
	874	zt(i,k) = ztnew(i,k)
	875	zq(i,k) = zqnew(i,k)
	876	ENDIF
	877	ENDDO
	878	ENDDO
	879	c
	880	c Re-calculer certaines variables pour etendre et re-ajuster la colonne
	881	c
	882	IF (exigent) THEN
	883	DO k = 1, klev
	884	DO i = 1, klon
	885	IF (todo(i)) THEN
	886	IF (thermcep) THEN
	887	zdelta=MAX(0.,SIGN(1.,RTT-zt(i,k)))
	888	zcvm5=R5LESRLVTT(1.-zdelta) + zdeltaR5IESRLSTT
	889	zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i,k))
	890	zqs(i,k)= R2ES*FOEEW(zt(i,k),zdelta)/pplay(i,k)
	891	zqs(i,k)=MIN(0.5,zqs(i,k))
	892	zcor=1./(1.-RETV*zqs(i,k))
	893	zqs(i,k)=zqs(i,k)*zcor
	894	zdqs(i,k) =FOEDE(zt(i,k),zdelta,zcvm5,zqs(i,k),zcor)
	895	ELSE
	896	IF (zt(i,k) .LT. t_coup) THEN
	897	zqs(i,k)= qsats(zt(i,k)) / pplay(i,k)
	898	zdqs(i,k)= dqsats(zt(i,k),zqs(i,k))
	899	ELSE
	900	zqs(i,k)= qsatl(zt(i,k)) / pplay(i,k)
	901	zdqs(i,k)= dqsatl(zt(i,k),zqs(i,k))
	902	ENDIF
	903	ENDIF
	904	ENDIF
	905	ENDDO
	906	ENDDO
	907	ENDIF
	908	c
	909	IF (exigent) THEN
	910	DO k = 1, klev-1
	911	DO i = 1, klon
	912	IF (todo(i)) THEN
	913	zgamdz(i,k) = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD
	914	. ( RD(zt(i,k)delp(i,k)+zt(i,k+1)delp(i,k+1))
	915	. /(delp(i,k)+delp(i,k+1))
	916	. +RLVTT(zqs(i,k)delp(i,k)+zqs(i,k+1)*delp(i,k+1))
	917	. /(delp(i,k)+delp(i,k+1))
	918	. ) / (1.0+(zdqs(i,k)delp(i,k)+zdqs(i,k+1)delp(i,k+1))
	919	. /(delp(i,k)+delp(i,k+1)) )
	920	ENDIF
	921	ENDDO
	922	ENDDO
	923	ENDIF
	924	c
	925	c Puisque l'humidite a ete modifiee, on re-fait (q-qs)*dp
	926	c
	927	DO k = 1, klev
	928	DO i = 1, klon
	929	IF (todo(i)) THEN
	930	zqmqsdp(i,k) = (zq(i,k)-zqs(i,k))*delp(i,k)
	931	ENDIF
	932	ENDDO
	933	ENDDO
	934	c
	935	c Verifier si l'on peut etendre le bas de la colonne
	936	c
	937	DO i = 1, klon
	938	etendre(i) = .FALSE.
	939	ENDDO
	940	c
	941	k1max = 1
	942	DO i = 1, klon
	943	IF (todo(i) .AND. k1(i).GT.(kbase+1)) THEN
	944	k = k1(i)
	945	zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
	946	zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1)
	947	csc voici l'ancienne ligne:
	948	csc IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) THEN
	949	csc sylvain: il faut RESPECTER les 2 criteres:
	950	IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN
	951	etendre(i) = .TRUE.
	952	k1(i) = k1(i) - 1
	953	k1max = MAX(k1max,k1(i))
	954	aller(i) = .TRUE.
	955	ENDIF
	956	ENDIF
	957	ENDDO
	958	c
	959	IF (k1max.GT.(kbase+1)) THEN
	960	DO k = k1max, kbase+1, -1
	961	DO i = 1, klon
	962	IF (etendre(i) .AND. k.LT.k1(i) .AND. aller(i)) THEN
	963	zsat(i) = zsat(i) + zqmqsdp(i,k)
	964	zflo(i) = zt(i,k) + zgamdz(i,k) - zt(i,k+1)
	965	IF (zsat(i).LE.0.0 .OR. zflo(i).LE.0.0) THEN
	966	aller(i) = .FALSE.
	967	ELSE
	968	k1(i) = k
	969	ENDIF
	970	ENDIF
	971	ENDDO
	972	ENDDO
	973	DO i = 1, klon
	974	IF (etendre(i).AND.aller(i)) THEN
	975	k1(i) = 1
	976	ENDIF
	977	ENDDO
	978	ENDIF
	979	c
	980	CCC DO i = 1, klon
	981	CCC IF (etendre(i)) THEN
	982	CCC 840 k = k1(i)
	983	CCC IF (k.GT.1) THEN
	984	CCC zsat(i) = zsat(i) + zqmqsdp(i,k-1)
	985	CCC zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
	986	CCC IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN
	987	CCC k1(i) = k - 1
	988	CCC GOTO 840
	989	CCC ENDIF
	990	CCC ENDIF
	991	CCC ENDIF
	992	CCC ENDDO
	993	c
	994	DO i = 1, klon
	995	todobis(i) = todo(i)
	996	todo(i) = .FALSE.
	997	ENDDO
	998	is = 0
	999	DO i = 1, klon
	1000	IF (etendre(i)) THEN
	1001	todo(i) = .TRUE.
	1002	is = is + 1
	1003	ENDIF
	1004	ENDDO
	1005	IF (is.GT.0) THEN
	1006	IF (new_top) THEN
	1007	GOTO 820 ! chercher de nouveau le sommet k2
	1008	ELSE
	1009	GOTO 830 ! supposer que le sommet est celui deja trouve
	1010	ENDIF
	1011	ENDIF
	1012	c
	1013	DO i = 1, klon
	1014	possible(i) = .FALSE.
	1015	ENDDO
	1016	is = 0
	1017	DO i = 1, klon
	1018	IF (todobis(i) .AND. k2(i).LT.klev) THEN
	1019	is = is + 1
	1020	possible(i) = .TRUE.
	1021	ENDIF
	1022	ENDDO
	1023	IF (is.GT.0) GOTO 810 !on cherche en haut d'autres blocks
	1024	c a ajuster a partir du sommet de la colonne precedente
	1025	c
	1026	860 CONTINUE ! Calculer les tendances et diagnostiques
	1027	ccc print*, "Apres 860"
	1028	c
	1029	DO k = 1, klev
	1030	DO i = 1, klon
	1031	IF (accompli(i)) THEN
	1032	d_t(i,k) = zt(i,k) - t(i,k)
	1033	zq(i,k) = MAX(zq(i,k),seuil_vap)
	1034	d_q(i,k) = zq(i,k) - q(i,k)
	1035	ENDIF
	1036	ENDDO
	1037	ENDDO
	1038	c
	1039	DO 888 i = 1, klon
	1040	IF (accompli(i)) THEN
	1041	DO k = 1, klev
	1042	IF (rneb(i,k).GT.0.0) THEN
	1043	ibas(i) = k
	1044	GOTO 807
	1045	ENDIF
	1046	ENDDO
	1047	807 CONTINUE
	1048	DO k = klev, 1, -1
	1049	IF (rneb(i,k).GT.0.0) THEN
	1050	itop(i) = k
	1051	GOTO 808
	1052	ENDIF
	1053	ENDDO
	1054	808 CONTINUE
	1055	ENDIF
	1056	888 CONTINUE
	1057	c
	1058	IF (imprim) THEN
	1059	nbtodo = 0
	1060	nbdone = 0
	1061	DO i = 1, klon
	1062	IF (afaire(i)) nbtodo = nbtodo + 1
	1063	IF (accompli(i)) nbdone = nbdone + 1
	1064	ENDDO
	1065	PRINT*, "nbTodo, nbDone=", nbtodo, nbdone
	1066	ENDIF
	1067	c
	1068	RETURN
	1069	END
	1070	SUBROUTINE conkuo(dtime, paprs, pplay, t, q, conv_q,
	1071	s d_t, d_q, d_ql, rneb,
	1072	s rain, snow, ibas, itop)
	1073	USE dimphy
	1074	IMPLICIT none
	1075	c======================================================================
	1076	c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
	1077	c Objet: Schema de convection de type Kuo (1965).
	1078	c Cette version du code peut calculer le niveau de depart
	1079	c N.B. version vectorielle (le 6 oct. 1997)
	1080	c======================================================================
	1081	cym#include "dimensions.h"
	1082	cym#include "dimphy.h"
	1083	#include "YOMCST.h"
	1084	c
	1085	c Arguments:
	1086	c
	1087	REAL dtime ! intervalle du temps (s)
	1088	REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
	1089	REAL pplay(klon,klev) ! pression au milieu de couche (Pa)
	1090	REAL t(klon,klev) ! temperature (K)
	1091	REAL q(klon,klev) ! humidite specifique
	1092	REAL conv_q(klon,klev) ! taux de convergence humidite (g/g/s)
	1093	c
	1094	REAL d_t(klon,klev) ! incrementation temperature
	1095	REAL d_q(klon,klev) ! incrementation humidite
	1096	REAL d_ql(klon,klev) ! incrementation eau liquide
	1097	REAL rneb(klon,klev) ! nebulosite
	1098	REAL rain(klon) ! pluies (mm/s)
	1099	REAL snow(klon) ! neige (mm/s)
	1100	INTEGER itop(klon) ! niveau du sommet
	1101	INTEGER ibas(klon) ! niveau du bas
	1102	c
	1103	LOGICAL ldcum(klon) ! convection existe
	1104	LOGICAL todo(klon)
	1105	c
	1106	c Quelsques options:
	1107	c
	1108	LOGICAL calcfcl ! calculer le niveau de convection libre
	1109	PARAMETER (calcfcl=.TRUE.)
	1110	INTEGER ldepar ! niveau fixe de convection libre
	1111	PARAMETER (ldepar=4)
	1112	INTEGER opt_cld ! comment traiter l'eau liquide
	1113	PARAMETER (opt_cld=4) ! valeur possible: 0, 1, 2, 3 ou 4
	1114	LOGICAL evap_prec ! evaporation de pluie au-dessous de convection
	1115	PARAMETER (evap_prec=.TRUE.)
	1116	REAL coef_eva
	1117	PARAMETER (coef_eva=1.0E-05)
	1118	LOGICAL new_deh ! nouvelle facon de calculer dH
	1119	PARAMETER (new_deh=.FALSE.)
	1120	REAL t_coup
	1121	PARAMETER (t_coup=234.0)
	1122	LOGICAL old_tau ! implique precipitation nulle
	1123	PARAMETER (old_tau=.FALSE.)
	1124	REAL toliq(klon) ! rapport entre l'eau nuageuse et l'eau precipitante
	1125	REAL dpmin, tomax !Epaisseur faible, rapport eau liquide plus grande
	1126	PARAMETER (dpmin=0.15, tomax=0.97)
	1127	REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible
	1128	PARAMETER (dpmax=0.30, tomin=0.05)
	1129	REAL deep_sig, deep_to ! au dela de deep_sig, utiliser deep_to
	1130	PARAMETER (deep_sig=0.50, deep_to=0.05)
	1131	c
	1132	c Variables locales:
	1133	c
	1134	INTEGER nexpo
	1135	LOGICAL nuage(klon)
	1136	INTEGER i, k, kbmin, kbmax, khmax
	1137	REAL ztotal(klon,klev), zdeh(klon,klev)
	1138	REAL zgz(klon,klev)
	1139	REAL zqs(klon,klev)
	1140	REAL zdqs(klon,klev)
	1141	REAL ztemp(klon,klev)
	1142	REAL zpres(klon,klev)
	1143	REAL zconv(klon) ! convergence d'humidite
	1144	REAL zvirt(klon) ! convergence virtuelle d'humidite
	1145	REAL zfrac(klon) ! fraction convective
	1146	INTEGER kb(klon), kh(klon)
	1147	c
	1148	REAL zcond(klon), zvapo(klon), zrapp(klon)
	1149	REAL zrfl(klon), zrfln, zqev, zqevt
	1150	REAL zdelta, zcvm5, zcor
	1151	REAL zvar
	1152	c
	1153	LOGICAL appel1er
	1154	SAVE appel1er
	1155	c$OMP THREADPRIVATE(appel1er)
	1156	c
	1157	c Fonctions thermodynamiques
	1158	c
	1159	#include "YOETHF.h"
	1160	#include "FCTTRE.h"
	1161	c
	1162	DATA appel1er /.TRUE./
	1163	c
	1164	IF (appel1er) THEN
	1165	PRINT*, 'conkuo, calcfcl:', calcfcl
	1166	IF (.NOT.calcfcl) PRINT*, 'conkuo, ldepar:', ldepar
	1167	PRINT*, 'conkuo, opt_cld:', opt_cld
	1168	PRINT*, 'conkuo, evap_prec:', evap_prec
	1169	PRINT*, 'conkuo, new_deh:', new_deh
	1170	appel1er = .FALSE.
	1171	ENDIF
	1172	c
	1173	c Initialiser les sorties a zero
	1174	c
	1175	DO k = 1, klev
	1176	DO i = 1, klon
	1177	d_q(i,k) = 0.0
	1178	d_t(i,k) = 0.0
	1179	d_ql(i,k) = 0.0
	1180	rneb(i,k) = 0.0
	1181	ENDDO
	1182	ENDDO
	1183	DO i = 1, klon
	1184	rain(i) = 0.0
	1185	snow(i) = 0.0
	1186	ibas(i) = 0
	1187	itop(i) = 0
	1188	ENDDO
	1189	c
	1190	c Calculer la vapeur d'eau saturante Qs et sa derive L/Cp * dQs/dT
	1191	c
	1192	DO k = 1, klev
	1193	DO i = 1, klon
	1194	IF (thermcep) THEN
	1195	zdelta=MAX(0.,SIGN(1.,RTT-t(i,k)))
	1196	zcvm5=R5LESRLVTT(1.-zdelta) + zdeltaR5IESRLSTT
	1197	zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k))
	1198	zqs(i,k)=R2ES*FOEEW(t(i,k),zdelta)/pplay(i,k)
	1199	zqs(i,k)=MIN(0.5,zqs(i,k))
	1200	zcor=1./(1.-RETV*zqs(i,k))
	1201	zqs(i,k)=zqs(i,k)*zcor
	1202	zdqs(i,k) =FOEDE(t(i,k),zdelta,zcvm5,zqs(i,k),zcor)
	1203	ELSE
	1204	IF (t(i,k).LT.t_coup) THEN
	1205	zqs(i,k) = qsats(t(i,k))/pplay(i,k)
	1206	zdqs(i,k) = dqsats(t(i,k),zqs(i,k))
	1207	ELSE
	1208	zqs(i,k) = qsatl(t(i,k))/pplay(i,k)
	1209	zdqs(i,k) = dqsatl(t(i,k),zqs(i,k))
	1210	ENDIF
	1211	ENDIF
	1212	ENDDO
	1213	ENDDO
	1214	c
	1215	c Calculer gz (energie potentielle)
	1216	c
	1217	DO i = 1, klon
	1218	zgz(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
	1219	. * (paprs(i,1)-pplay(i,1))
	1220	ENDDO
	1221	DO k = 2, klev
	1222	DO i = 1, klon
	1223	zgz(i,k) = zgz(i,k-1)
	1224	. + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
	1225	. * (pplay(i,k-1)-pplay(i,k))
	1226	ENDDO
	1227	ENDDO
	1228	c
	1229	c Calculer l'energie statique humide saturee (CpT + gz + LQs)
	1230	c
	1231	DO k = 1, klev
	1232	DO i = 1, klon
	1233	ztotal(i,k) = RCPDt(i,k) + RLVTTzqs(i,k) + zgz(i,k)
	1234	ENDDO
	1235	ENDDO
	1236	c
	1237	c Determiner le niveau de depart et calculer la difference de
	1238	c l'energie statique humide saturee (ztotal) entre la couche
	1239	c de depart et chaque couche au-dessus.
	1240	c
	1241	IF (calcfcl) THEN
	1242	DO k = 1, klev
	1243	DO i = 1, klon
	1244	zpres(i,k) = pplay(i,k)
	1245	ztemp(i,k) = t(i,k)
	1246	ENDDO
	1247	ENDDO
	1248	CALL kuofcl(ztemp, q, zgz, zpres, ldcum, kb)
	1249	DO i = 1, klon
	1250	IF (ldcum(i)) THEN
	1251	k = kb(i)
	1252	IF (new_deh) THEN
	1253	zdeh(i,k) = ztotal(i,k-1) - ztotal(i,k)
	1254	ELSE
	1255	zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k))
	1256	. - RD 0.5(t(i,k-1)+t(i,k))/paprs(i,k)
	1257	. *(pplay(i,k-1)-pplay(i,k))
	1258	. + RLVTT*(zqs(i,k-1)-zqs(i,k))
	1259	ENDIF
	1260	zdeh(i,k) = zdeh(i,k) * 0.5
	1261	ENDIF
	1262	ENDDO
	1263	DO k = 1, klev
	1264	DO i = 1, klon
	1265	IF (ldcum(i) .AND. k.GE.(kb(i)+1)) THEN
	1266	IF (new_deh) THEN
	1267	zdeh(i,k) = zdeh(i,k-1) + (ztotal(i,k-1)-ztotal(i,k))
	1268	ELSE
	1269	zdeh(i,k) = zdeh(i,k-1)
	1270	. + RCPD * (t(i,k-1)-t(i,k))
	1271	. - RD 0.5(t(i,k-1)+t(i,k))/paprs(i,k)
	1272	. *(pplay(i,k-1)-pplay(i,k))
	1273	. + RLVTT*(zqs(i,k-1)-zqs(i,k))
	1274	ENDIF
	1275	ENDIF
	1276	ENDDO
	1277	ENDDO
	1278	ELSE
	1279	DO i = 1, klon
	1280	k = ldepar
	1281	kb(i) = ldepar
	1282	ldcum(i) = .TRUE.
	1283	IF (new_deh) THEN
	1284	zdeh(i,k) = ztotal(i,k-1) - ztotal(i,k)
	1285	ELSE
	1286	zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k))
	1287	. - RD 0.5(t(i,k-1)+t(i,k))/paprs(i,k)
	1288	. *(pplay(i,k-1)-pplay(i,k))
	1289	. + RLVTT*(zqs(i,k-1)-zqs(i,k))
	1290	ENDIF
	1291	zdeh(i,k) = zdeh(i,k) * 0.5
	1292	ENDDO
	1293	DO k = ldepar+1, klev
	1294	DO i = 1, klon
	1295	IF (new_deh) THEN
	1296	zdeh(i,k) = zdeh(i,k-1) + (ztotal(i,k-1)-ztotal(i,k))
	1297	ELSE
	1298	zdeh(i,k) = zdeh(i,k-1)
	1299	. + RCPD * (t(i,k-1)-t(i,k))
	1300	. - RD 0.5(t(i,k-1)+t(i,k))/paprs(i,k)
	1301	. *(pplay(i,k-1)-pplay(i,k))
	1302	. + RLVTT*(zqs(i,k-1)-zqs(i,k))
	1303	ENDIF
	1304	ENDDO
	1305	ENDDO
	1306	ENDIF
	1307	c
	1308	c-----Chercher le sommet du nuage
	1309	c-----Calculer la convergence de l'humidite (en kg/m**2 a un facteur
	1310	c-----psolpa/RG pres) du bas jusqu'au sommet du nuage.
	1311	c-----Calculer la convergence virtuelle pour que toute la maille
	1312	c-----deviennt nuageuse (du bas jusqu'au sommet du nuage)
	1313	c
	1314	DO i = 1, klon
	1315	nuage(i) = .TRUE.
	1316	zconv(i) = 0.0
	1317	zvirt(i) = 0.0
	1318	kh(i) = -999
	1319	ENDDO
	1320	DO k = 1, klev
	1321	DO i = 1, klon
	1322	IF (k.GE.kb(i) .AND. ldcum(i)) THEN
	1323	nuage(i) = nuage(i) .AND. zdeh(i,k).GT.0.0
	1324	IF (nuage(i)) THEN
	1325	kh(i) = k
	1326	zconv(i)=zconv(i)+conv_q(i,k)*dtime
	1327	. *(paprs(i,k)-paprs(i,k+1))
	1328	zvirt(i)=zvirt(i)+(zdeh(i,k)/RLVTT+zqs(i,k)-q(i,k))
	1329	. *(paprs(i,k)-paprs(i,k+1))
	1330	ENDIF
	1331	ENDIF
	1332	ENDDO
	1333	ENDDO
	1334	c
	1335	DO i = 1, klon
	1336	todo(i) = ldcum(i) .AND. kh(i).GT.kb(i) .AND. zconv(i).GT.0.0
	1337	ENDDO
	1338	c
	1339	kbmin = klev
	1340	kbmax = 0
	1341	khmax = 0
	1342	DO i = 1, klon
	1343	IF (todo(i)) THEN
	1344	kbmin = MIN(kbmin,kb(i))
	1345	kbmax = MAX(kbmax,kb(i))
	1346	khmax = MAX(khmax,kh(i))
	1347	ENDIF
	1348	ENDDO
	1349	c
	1350	c-----Calculer la surface couverte par le nuage
	1351	c
	1352	DO i = 1, klon
	1353	IF (todo(i)) THEN
	1354	zfrac(i) = MAX(0.0,MIN(zconv(i)/zvirt(i), 1.0))
	1355	ENDIF
	1356	ENDDO
	1357	c
	1358	c-----Calculs essentiels:
	1359	c
	1360	DO i = 1, klon
	1361	IF (todo(i)) THEN
	1362	zcond(i) = 0.0
	1363	ENDIF
	1364	ENDDO
	1365	DO k = kbmin, khmax
	1366	DO i = 1, klon
	1367	IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
	1368	zvar = zdeh(i,k)/(1.+zdqs(i,k))
	1369	d_t(i,k) = zvar * zfrac(i) / RCPD
	1370	d_q(i,k) = (zvarzdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))zfrac(i)
	1371	. - conv_q(i,k)*dtime
	1372	zcond(i) = zcond(i) - d_q(i,k) *(paprs(i,k)-paprs(i,k+1))/RG
	1373	rneb(i,k) = zfrac(i)
	1374	ENDIF
	1375	ENDDO
	1376	ENDDO
	1377	c
	1378	DO i = 1, klon
	1379	IF (todo(i) .AND. zcond(i).LT.0.0) THEN
	1380	PRINT*, 'WARNING: cond. negative (Kuo) ',
	1381	. i,kb(i),kh(i), zcond(i)
	1382	zcond(i) = 0.0
	1383	DO k = kb(i), kh(i)
	1384	d_t(i,k) = 0.0
	1385	d_q(i,k) = 0.0
	1386	ENDDO
	1387	todo(i) = .FALSE. ! effort totalement perdu
	1388	ENDIF
	1389	ENDDO
	1390	c
	1391	c=====
	1392	c Une fois que la condensation a lieu, on doit construire un
	1393	c "modele nuageux" pour partager la condensation entre l'eau
	1394	c liquide nuageuse et la precipitation (leur rapport toliq
	1395	c est calcule selon l'epaisseur nuageuse). Je suppose que
	1396	c toliq=tomax quand l'epaisseur nuageuse est inferieure a dpmin,
	1397	c et que toliq=tomin quand l'epaisseur depasse dpmax (interpolation
	1398	c lineaire entre dpmin et dpmax).
	1399	c=====
	1400	DO i = 1, klon
	1401	IF (todo(i)) THEN
	1402	toliq(i) = tomax-((paprs(i,kb(i))-paprs(i,kh(i)+1))
	1403	. /paprs(i,1)-dpmin)
	1404	. *(tomax-tomin)/(dpmax-dpmin)
	1405	toliq(i) = MAX(tomin,MIN(tomax,toliq(i)))
	1406	IF (pplay(i,kh(i))/paprs(i,1) .LE. deep_sig) toliq(i) = deep_to
	1407	IF (old_tau) toliq(i) = 1.0
	1408	ENDIF
	1409	ENDDO
	1410	c=====
	1411	c On doit aussi determiner la distribution verticale de
	1412	c l'eau nuageuse. Plusieurs options sont proposees:
	1413	c
	1414	c (0) La condensation precipite integralement (toliq ne sera
	1415	c pas utilise).
	1416	c (1) L'eau liquide est distribuee entre k1 et k2 et proportionnelle
	1417	c a la vapeur d'eau locale.
	1418	c (2) Elle est distribuee entre k1 et k2 avec une valeur constante.
	1419	c (3) Elle est seulement distribuee aux couches ou la vapeur d'eau
	1420	c est effectivement diminuee pendant le processus d'ajustement.
	1421	c (4) Elle est en fonction (lineaire ou exponentielle) de la
	1422	c distance (epaisseur en pression) avec le niveau k1 (la couche
	1423	c k1 n'aura donc pas d'eau liquide).
	1424	c=====
	1425	c
	1426	IF (opt_cld.EQ.0) THEN
	1427	c
	1428	DO i = 1, klon
	1429	IF (todo(i)) zrfl(i) = zcond(i) / dtime
	1430	ENDDO
	1431	c
	1432	ELSE IF (opt_cld.EQ.1) THEN
	1433	c
	1434	DO i = 1, klon
	1435	IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de vapeur d'eau
	1436	ENDDO
	1437	DO k = kbmin, khmax
	1438	DO i = 1, klon
	1439	IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
	1440	zvapo(i) = zvapo(i) + (q(i,k)+d_q(i,k))
	1441	. *(paprs(i,k)-paprs(i,k+1))/RG
	1442	ENDIF
	1443	ENDDO
	1444	ENDDO
	1445	DO i = 1, klon
	1446	IF (todo(i)) THEN
	1447	zrapp(i) = toliq(i) * zcond(i) / zvapo(i)
	1448	zrapp(i) = MAX(0.,MIN(1.,zrapp(i)))
	1449	ENDIF
	1450	ENDDO
	1451	DO k = kbmin, khmax
	1452	DO i = 1, klon
	1453	IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
	1454	d_ql(i,k) = zrapp(i) * (q(i,k)+d_q(i,k))
	1455	ENDIF
	1456	ENDDO
	1457	ENDDO
	1458	DO i = 1, klon
	1459	IF (todo(i)) THEN
	1460	zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
	1461	ENDIF
	1462	ENDDO
	1463	c
	1464	ELSE IF (opt_cld.EQ.2) THEN
	1465	c
	1466	DO i = 1, klon
	1467	IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse
	1468	ENDDO
	1469	DO k = kbmin, khmax
	1470	DO i = 1, klon
	1471	IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
	1472	zvapo(i) = zvapo(i) + (paprs(i,k)-paprs(i,k+1))/RG
	1473	ENDIF
	1474	ENDDO
	1475	ENDDO
	1476	DO k = kbmin, khmax
	1477	DO i = 1, klon
	1478	IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
	1479	d_ql(i,k) = toliq(i) * zcond(i) / zvapo(i)
	1480	ENDIF
	1481	ENDDO
	1482	ENDDO
	1483	DO i = 1, klon
	1484	IF (todo(i)) THEN
	1485	zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
	1486	ENDIF
	1487	ENDDO
	1488	c
	1489	ELSE IF (opt_cld.EQ.3) THEN
	1490	c
	1491	DO i = 1, klon
	1492	IF (todo(i)) THEN
	1493	zvapo(i) = 0.0 ! quantite de l'eau strictement condensee
	1494	ENDIF
	1495	ENDDO
	1496	DO k = kbmin, khmax
	1497	DO i = 1, klon
	1498	IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
	1499	zvapo(i) = zvapo(i) + MAX(0.0,-d_q(i,k))
	1500	. * (paprs(i,k)-paprs(i,k+1))/RG
	1501	ENDIF
	1502	ENDDO
	1503	ENDDO
	1504	DO k = kbmin, khmax
	1505	DO i = 1, klon
	1506	IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i) .AND.
	1507	. zvapo(i).GT.0.0) THEN
	1508	d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
	1509	. * MAX(0.0,-d_q(i,k))
	1510	ENDIF
	1511	ENDDO
	1512	ENDDO
	1513	DO i = 1, klon
	1514	IF (todo(i)) THEN
	1515	zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
	1516	ENDIF
	1517	ENDDO
	1518	c
	1519	ELSE IF (opt_cld.EQ.4) THEN
	1520	c
	1521	nexpo = 3
	1522	ccc nexpo = 1 ! distribution lineaire
	1523	c
	1524	DO i = 1, klon
	1525	IF (todo(i)) THEN
	1526	zvapo(i) = 0.0 ! quantite integrale de masse (avec ponderation)
	1527	ENDIF
	1528	ENDDO
	1529	DO k = kbmin, khmax
	1530	DO i = 1, klon
	1531	IF (todo(i) .AND. k.GE.(kb(i)+1) .AND. k.LE.kh(i)) THEN
	1532	zvapo(i) = zvapo(i) + (paprs(i,k)-paprs(i,k+1)) / RG
	1533	. * (pplay(i,kb(i))-pplay(i,k))**nexpo
	1534	ENDIF
	1535	ENDDO
	1536	ENDDO
	1537	DO k = kbmin, khmax
	1538	DO i = 1, klon
	1539	IF (todo(i) .AND. k.GE.(kb(i)+1) .AND. k.LE.kh(i)) THEN
	1540	d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
	1541	. * (pplay(i,kb(i))-pplay(i,k))**nexpo
	1542	ENDIF
	1543	ENDDO
	1544	ENDDO
	1545	DO i = 1, klon
	1546	IF (todo(i)) THEN
	1547	zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
	1548	ENDIF
	1549	ENDDO
	1550	c
	1551	ELSE ! valeur non-prevue pour opt_cld
	1552	c
	1553	PRINT*, "opt_cld est faux:", opt_cld
	1554	CALL abort
	1555	c
	1556	ENDIF ! fin de opt_cld
	1557	c
	1558	c L'eau precipitante peut etre re-evaporee:
	1559	c
	1560	IF (evap_prec .AND. kbmax.GE.2) THEN
	1561	DO k = kbmax, 1, -1
	1562	DO i = 1, klon
	1563	IF (todo(i) .AND. k.LE.(kb(i)-1) .AND. zrfl(i).GT.0.0) THEN
	1564	zqev = MAX (0.0, (zqs(i,k)-q(i,k))*zfrac(i) )
	1565	zqevt = coef_eva * (1.0-q(i,k)/zqs(i,k))*SQRT(zrfl(i))
	1566	. * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)t(i,k)RD/RG
	1567	zqevt = MAX(0.0,MIN(zqevt,zrfl(i)))
	1568	. * RG*dtime/(paprs(i,k)-paprs(i,k+1))
	1569	zqev = MIN (zqev, zqevt)
	1570	zrfln = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1))
	1571	. /RG/dtime
	1572	d_q(i,k) = - (zrfln-zrfl(i))
	1573	. * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
	1574	d_t(i,k) = (zrfln-zrfl(i))
	1575	. * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
	1576	. * RLVTT/RCPD
	1577	zrfl(i) = zrfln
	1578	ENDIF
	1579	ENDDO
	1580	ENDDO
	1581	ENDIF
	1582	c
	1583	c La temperature de la premiere couche determine la pluie ou la neige:
	1584	c
	1585	DO i = 1, klon
	1586	IF (todo(i)) THEN
	1587	IF (t(i,1) .GT. RTT) THEN
	1588	rain(i) = rain(i) + zrfl(i)
	1589	ELSE
	1590	snow(i) = snow(i) + zrfl(i)
	1591	ENDIF
	1592	ENDIF
	1593	ENDDO
	1594	c
	1595	RETURN
	1596	END
	1597	SUBROUTINE kuofcl(pt, pq, pg, pp, LDCUM, kcbot)
	1598	USE dimphy
	1599	IMPLICIT none
	1600	c======================================================================
	1601	c Auteur(s): Z.X. Li (LMD/CNRS) date: 19940927
	1602	c adaptation du code de Tiedtke du ECMWF
	1603	c Objet: calculer le niveau de convection libre
	1604	c (FCL: Free Convection Level)
	1605	c======================================================================
	1606	c Arguments:
	1607	c pt---input-R- temperature (K)
	1608	c pq---input-R- vapeur d'eau (kg/kg)
	1609	c pg---input-R- geopotentiel (g*z ou z est en metre)
	1610	c pp---input-R- pression (Pa)
	1611	c
	1612	c LDCUM---output-L- Y-t-il la convection
	1613	c kcbot---output-I- Niveau du bas de la convection
	1614	c======================================================================
	1615	cym#include "dimensions.h"
	1616	cym#include "dimphy.h"
	1617	#include "YOMCST.h"
	1618	#include "YOETHF.h"
	1619	C
	1620	REAL pt(klon,klev), pq(klon,klev), pg(klon,klev), pp(klon,klev)
	1621	INTEGER kcbot(klon)
	1622	LOGICAL LDCUM(klon)
	1623	C
	1624	REAL ztu(klon,klev), zqu(klon,klev), zlu(klon,klev)
	1625	REAL zqold(klon), zbuo
	1626	INTEGER is, i, k
	1627	c
	1628	c klab=1: on est sous le nuage convectif
	1629	c klab=2: le bas du nuage convectif
	1630	c klab=0: autres couches
	1631	INTEGER klab(klon,klev)
	1632	c
	1633	c quand lflag=.true., on est sous le nuage, il faut donc appliquer
	1634	c le processus d'elevation.
	1635	LOGICAL lflag(klon)
	1636	C
	1637	DO k = 1, klev
	1638	DO i = 1, klon
	1639	ztu(i,k) = pt(i,k)
	1640	zqu(i,k) = pq(i,k)
	1641	zlu(i,k) = 0.0
	1642	klab(i,k) = 0
	1643	ENDDO
	1644	ENDDO
	1645	C----------------------------------------------------------------------
	1646	DO i = 1, klon
	1647	klab(i,1)=1
	1648	kcbot(i)=2
	1649	LDCUM(i)=.FALSE.
	1650	ENDDO
	1651	C
	1652	DO 290 k = 2, klev-1
	1653	c
	1654	is=0
	1655	DO i = 1, klon
	1656	if (klab(i,k-1).EQ.1) is = is + 1
	1657	lflag(i) = .FALSE.
	1658	if (klab(i,k-1).EQ.1) lflag(i) = .TRUE.
	1659	ENDDO
	1660	IF (is.EQ.0) GOTO 290
	1661	c
	1662	c on eleve le parcel d'air selon l'adiabatique sec
	1663	c
	1664	DO i = 1, klon
	1665	IF (lflag(i)) THEN
	1666	zqu(i,k) = zqu(i,k-1)
	1667	ztu(i,k) = ztu(i,k-1) + (pg(i,k-1)-pg(i,k))/RCPD
	1668	zbuo = ztu(i,k)(1.+RETVzqu(i,k))-
	1669	. pt(i,k)(1.+RETVpq(i,k))+0.5
	1670	IF (zbuo.GT.0.) klab(i,k)=1
	1671	zqold(i) = zqu(i,k)
	1672	ENDIF
	1673	ENDDO
	1674	c
	1675	c on calcule la condensation eventuelle
	1676	c
	1677	CALL adjtq(pp(1,k), ztu(1,k), zqu(1,k), lflag, 1)
	1678	c
	1679	c s'il y a la condensation et la "buoyancy" force est positive
	1680	c c'est bien le bas de la tour de convection
	1681	c
	1682	DO i=1, klon
	1683	IF(lflag(i).AND.zqu(i,k).NE.zqold(i)) THEN
	1684	klab(i,k) = 2
	1685	zlu(i,k) = zlu(i,k)+zqold(i)-zqu(i,k)
	1686	zbuo = ztu(i,k)(1.+RETVzqu(i,k))-
	1687	. pt(i,k)(1.+RETVpq(i,k))+0.5
	1688	IF (zbuo.GT.0.) THEN
	1689	kcbot(i) = k
	1690	LDCUM(i) = .TRUE.
	1691	ENDIF
	1692	ENDIF
	1693	ENDDO
	1694	C
	1695	290 CONTINUE
	1696	C
	1697	RETURN
	1698	END
	1699	SUBROUTINE adjtq(pp, pt, pq, LDFLAG, KCALL)
	1700	USE dimphy
	1701	IMPLICIT none
	1702	c======================================================================
	1703	c Auteur(s): Z.X. Li (LMD/CNRS) date: 19940927
	1704	c adaptation du code de Tiedtke du ECMWF
	1705	c Objet: ajustement entre T et Q
	1706	c======================================================================
	1707	c Arguments:
	1708	c pp---input-R- pression (Pa)
	1709	c pt---input/output-R- temperature (K)
	1710	c pq---input/output-R- vapeur d'eau (kg/kg)
	1711	c======================================================================
	1712	C TO PRODUCE T,Q AND L VALUES FOR CLOUD ASCENT
	1713	C
	1714	C NOTE: INPUT PARAMETER KCALL DEFINES CALCULATION AS
	1715	C KCALL=0 ENV. T AND QS INCUINI
	1716	C KCALL=1 CONDENSATION IN UPDRAFTS (E.G. CUBASE, CUASC)
	1717	C KCALL=2 EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF)
	1718	C
	1719	cym#include "dimensions.h"
	1720	cym#include "dimphy.h"
	1721	#include "YOMCST.h"
	1722	C
	1723	REAL pt(klon), pq(klon), pp(klon)
	1724	LOGICAL ldflag(klon)
	1725	INTEGER KCALL
	1726	c
	1727	REAL t_coup
	1728	PARAMETER (t_coup=234.0)
	1729	c
	1730	REAL zcond(klon), zcond1
	1731	REAL zdelta, zcvm5, zldcp, zqsat, zcor, zdqsat
	1732	INTEGER is, i
	1733	#include "YOETHF.h"
	1734	#include "FCTTRE.h"
	1735	c
	1736	DO i = 1, klon
	1737	zcond(i) = 0.0
	1738	ENDDO
	1739	C
	1740	DO 210 i=1, klon
	1741	IF (LDFLAG(i)) THEN
	1742	zdelta=MAX(0.,SIGN(1.,RTT-pt(i)))
	1743	zldcp = RLVTT(1.-zdelta) + zdeltaRLSTT
	1744	zldcp = zldcp / RCPD/(1.0+RVTMP2*pq(i))
	1745	IF (thermcep) THEN
	1746	zcvm5=R5LESRLVTT(1.-zdelta) + zdeltaR5IESRLSTT
	1747	zcvm5 = zcvm5 / RCPD/(1.0+RVTMP2*pq(i))
	1748	zqsat=R2ES*FOEEW (pt(i), zdelta) / pp(i)
	1749	zqsat=MIN(0.5,zqsat)
	1750	zcor=1./(1.-RETV *zqsat)
	1751	zqsat=zqsat*zcor
	1752	zdqsat = FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor)
	1753	ELSE
	1754	IF (pt(i).LT.t_coup) THEN
	1755	zqsat = qsats(pt(i))/pp(i)
	1756	zdqsat = dqsats(pt(i),zqsat)
	1757	ELSE
	1758	zqsat = qsatl(pt(i))/pp(i)
	1759	zdqsat = dqsatl(pt(i),zqsat)
	1760	ENDIF
	1761	ENDIF
	1762	zcond(i)=(pq(i)-zqsat) / (1. + zdqsat)
	1763	IF(KCALL.EQ.1) zcond(i)=MAX(zcond(i),0.)
	1764	IF(KCALL.EQ.2) zcond(i)=MIN(zcond(i),0.)
	1765	pt(i)=pt(i)+zldcp*zcond(i)
	1766	pq(i)=pq(i)-zcond(i)
	1767	ENDIF
	1768	210 CONTINUE
	1769	C
	1770	is = 0
	1771	DO i=1, klon
	1772	if (zcond(i).NE.0.) is = is + 1
	1773	ENDDO
	1774	IF(is.EQ.0) GOTO 230
	1775	C
	1776	DO 220 i = 1, klon
	1777	IF(LDFLAG(i).AND.zcond(i).NE.0.) THEN
	1778	zdelta=MAX(0.,SIGN(1.,RTT-pt(i)))
	1779	zldcp = RLVTT(1.-zdelta) + zdeltaRLSTT
	1780	zldcp = zldcp / RCPD/(1.0+RVTMP2*pq(i))
	1781	IF (thermcep) THEN
	1782	zcvm5=R5LESRLVTT(1.-zdelta) + zdeltaR5IESRLSTT
	1783	zcvm5 = zcvm5 / RCPD/(1.0+RVTMP2*pq(i))
	1784	zqsat=R2ES*FOEEW (pt(i), zdelta) / pp(i)
	1785	zqsat=MIN(0.5,zqsat)
	1786	zcor=1./(1.-RETV *zqsat)
	1787	zqsat=zqsat*zcor
	1788	zdqsat = FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor)
	1789	ELSE
	1790	IF (pt(i).LT.t_coup) THEN
	1791	zqsat = qsats(pt(i))/pp(i)
	1792	zdqsat = dqsats(pt(i),zqsat)
	1793	ELSE
	1794	zqsat = qsatl(pt(i))/pp(i)
	1795	zdqsat = dqsatl(pt(i),zqsat)
	1796	ENDIF
	1797	ENDIF
	1798	zcond1=(pq(i)-zqsat) / (1.+zdqsat)
	1799	pt(i)=pt(i)+zldcp*zcond1
	1800	pq(i)=pq(i)-zcond1
	1801	END IF
	1802	220 CONTINUE
	1803	C
	1804	230 CONTINUE
	1805	RETURN
	1806	END
	1807	SUBROUTINE fiajh(dtime, paprs, pplay, t, q,
	1808	. d_t, d_q, d_ql, rneb,
	1809	. rain, snow, ibas, itop)
	1810	USE dimphy
	1811	IMPLICIT NONE
	1812	c
	1813	c Ajustement humide (Schema de convection de Manabe)
	1814	C.
	1815	cym#include "dimensions.h"
	1816	cym#include "dimphy.h"
	1817	#include "YOMCST.h"
	1818	c
	1819	c Arguments:
	1820	c
	1821	REAL dtime ! intervalle du temps (s)
	1822	REAL t(klon,klev) ! temperature (K)
	1823	REAL q(klon,klev) ! humidite specifique (kg/kg)
	1824	REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
	1825	REAL pplay(klon,klev) ! pression au milieu de couche (Pa)
	1826	c
	1827	REAL d_t(klon,klev) ! incrementation pour la temperature
	1828	REAL d_q(klon,klev) ! incrementation pour vapeur d'eau
	1829	REAL d_ql(klon,klev) ! incrementation pour l'eau liquide
	1830	REAL rneb(klon,klev) ! fraction nuageuse
	1831	c
	1832	REAL rain(klon) ! variable non utilisee
	1833	REAL snow(klon) ! variable non utilisee
	1834	INTEGER ibas(klon) ! variable non utilisee
	1835	INTEGER itop(klon) ! variable non utilisee
	1836
	1837	REAL t_coup
	1838	PARAMETER (t_coup=234.0)
	1839	REAL seuil_vap
	1840	PARAMETER (seuil_vap=1.0E-10)
	1841	c
	1842	c Variables locales:
	1843	c
	1844	INTEGER i, k
	1845	INTEGER k1, k1p, k2, k2p
	1846	LOGICAL itest(klon)
	1847	REAL delta_q(klon, klev)
	1848	REAL cp_new_t(klev)
	1849	REAL cp_delta_t(klev)
	1850	REAL new_qb(klev)
	1851	REAL v_cptj(klev), v_cptjk1, v_ssig
	1852	REAL v_cptt(klon,klev), v_p, v_t
	1853	REAL v_qs(klon,klev), v_qsd(klon,klev)
	1854	REAL zq1(klon), zq2(klon)
	1855	REAL gamcpdz(klon,2:klev)
	1856	REAL zdp, zdpm
	1857	c
	1858	REAL zsat ! sur-saturation
	1859	REAL zflo ! flotabilite
	1860	c
	1861	REAL local_q(klon,klev),local_t(klon,klev)
	1862	c
	1863	REAL zdelta, zcor, zcvm5
	1864	C
	1865	#include "YOETHF.h"
	1866	#include "FCTTRE.h"
	1867	C
	1868	DO k = 1, klev
	1869	DO i = 1, klon
	1870	local_q(i,k) = q(i,k)
	1871	local_t(i,k) = t(i,k)
	1872	rneb(i,k) = 0.0
	1873	d_ql(i,k) = 0.0
	1874	d_t(i,k) = 0.0
	1875	d_q(i,k) = 0.0
	1876	ENDDO
	1877	ENDDO
	1878	DO i = 1, klon
	1879	rain(i) = 0.0
	1880	snow(i) = 0.0
	1881	ibas(i) = 0
	1882	itop(i) = 0
	1883	ENDDO
	1884	c
	1885	c Calculer v_qs et v_qsd:
	1886	c
	1887	DO k = 1, klev
	1888	DO i = 1, klon
	1889	v_cptt(i,k) = RCPD * local_t(i,k)
	1890	v_t = local_t(i,k)
	1891	v_p = pplay(i,k)
	1892	c
	1893	IF (thermcep) THEN
	1894	zdelta=MAX(0.,SIGN(1.,RTT-v_t))
	1895	zcvm5=R5LESRLVTT(1.-zdelta) + zdeltaR5IESRLSTT
	1896	zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*local_q(i,k))
	1897	v_qs(i,k)= R2ES * FOEEW(v_t,zdelta)/v_p
	1898	v_qs(i,k)=MIN(0.5,v_qs(i,k))
	1899	zcor=1./(1.-RETV*v_qs(i,k))
	1900	v_qs(i,k)=v_qs(i,k)*zcor
	1901	v_qsd(i,k) =FOEDE(v_t,zdelta,zcvm5,v_qs(i,k),zcor)
	1902	ELSE
	1903	IF (v_t.LT.t_coup) THEN
	1904	v_qs(i,k) = qsats(v_t) / v_p
	1905	v_qsd(i,k) = dqsats(v_t,v_qs(i,k))
	1906	ELSE
	1907	v_qs(i,k) = qsatl(v_t) / v_p
	1908	v_qsd(i,k) = dqsatl(v_t,v_qs(i,k))
	1909	ENDIF
	1910	ENDIF
	1911	ENDDO
	1912	ENDDO
	1913	c
	1914	c Calculer Gamma * Cp * dz: (gamm est le gradient critique)
	1915	c
	1916	DO k = 2, klev
	1917	DO i = 1, klon
	1918	zdp = paprs(i,k)-paprs(i,k+1)
	1919	zdpm = paprs(i,k-1)-paprs(i,k)
	1920	gamcpdz(i,k) = ( ( RD/RCPD /(zdpm+zdp) *
	1921	. (v_cptt(i,k-1)zdpm + v_cptt(i,k)zdp)
	1922	. +RLVTT /(zdpm+zdp) *
	1923	. (v_qs(i,k-1)zdpm + v_qs(i,k)zdp)
	1924	. )* (pplay(i,k-1)-pplay(i,k)) / paprs(i,k) )
	1925	. / (1.0+(v_qsd(i,k-1)*zdpm+
	1926	. v_qsd(i,k)*zdp)/(zdpm+zdp) )
	1927	ENDDO
	1928	ENDDO
	1929	C
	1930	C------------------------------------ modification des profils instables
	1931	DO 9999 i = 1, klon
	1932	itest(i) = .FALSE.
	1933	C
	1934	k1 = 0
	1935	k2 = 1
	1936	C
	1937	810 CONTINUE ! chercher k1, le bas de la colonne
	1938	k2 = k2 + 1
	1939	IF (k2 .GT. klev) GOTO 9999
	1940	zflo = v_cptt(i,k2-1) - v_cptt(i,k2) - gamcpdz(i,k2)
	1941	zsat=(local_q(i,k2-1)-v_qs(i,k2-1))*(paprs(i,k2-1)-paprs(i,k2))
	1942	. +(local_q(i,k2)-v_qs(i,k2))*(paprs(i,k2)-paprs(i,k2+1))
	1943	IF ( zflo.LE.0.0 .OR. zsat.LE.0.0 ) GOTO 810
	1944	k1 = k2 - 1
	1945	itest(i) = .TRUE.
	1946	C
	1947	820 CONTINUE ! chercher k2, le haut de la colonne
	1948	IF (k2 .EQ. klev) GOTO 821
	1949	k2p = k2 + 1
	1950	zsat=zsat +(paprs(i,k2p)-paprs(i,k2p+1))
	1951	. *(local_q(i,k2p)-v_qs(i,k2p))
	1952	zflo = v_cptt(i,k2p-1) - v_cptt(i,k2p) - gamcpdz(i,k2p)
	1953	IF (zflo.LE.0.0 .OR. zsat.LE.0.0) GOTO 821
	1954	k2 = k2p
	1955	GOTO 820
	1956	821 CONTINUE
	1957	C
	1958	C------------------------------------------------------ ajustement local
	1959	830 CONTINUE ! ajustement proprement dit
	1960	v_cptj(k1) = 0.0
	1961	zdp = paprs(i,k1)-paprs(i,k1+1)
	1962	v_cptjk1 = ( (1.0+v_qsd(i,k1))*(v_cptt(i,k1)+v_cptj(k1))
	1963	. + RLVTT(local_q(i,k1)-v_qs(i,k1)) ) zdp
	1964	v_ssig = zdp * (1.0+v_qsd(i,k1))
	1965	C
	1966	k1p = k1 + 1
	1967	DO k = k1p, k2
	1968	zdp = paprs(i,k)-paprs(i,k+1)
	1969	v_cptj(k) = v_cptj(k-1) + gamcpdz(i,k)
	1970	v_cptjk1 = v_cptjk1 + zdp
	1971	. * ( (1.0+v_qsd(i, k))*(v_cptt(i,k)+v_cptj(k))
	1972	. + RLVTT*(local_q(i,k)-v_qs(i,k)) )
	1973	v_ssig = v_ssig + zdp *(1.0+v_qsd(i,k))
	1974	ENDDO
	1975	C
	1976	DO k = k1, k2
	1977	cp_new_t(k) = v_cptjk1/v_ssig - v_cptj(k)
	1978	cp_delta_t(k) = cp_new_t(k) - v_cptt(i,k)
	1979	new_qb(k) = v_qs(i,k) + v_qsd(i,k)*cp_delta_t(k)/RLVTT
	1980	local_q(i,k) = new_qb(k)
	1981	local_t(i,k) = cp_new_t(k) / RCPD
	1982	ENDDO
	1983	C
	1984	C--------------------------------------------------- sondage vers le bas
	1985	C -- on redefinit les variables prognostiques dans
	1986	C -- la colonne qui vient d'etre ajustee
	1987	C
	1988	DO k = k1, k2
	1989	v_cptt(i,k) = RCPD * local_t(i,k)
	1990	v_t = local_t(i,k)
	1991	v_p = pplay(i,k)
	1992	C
	1993	IF (thermcep) THEN
	1994	zdelta=MAX(0.,SIGN(1.,RTT-v_t))
	1995	zcvm5=R5LESRLVTT(1.-zdelta) + zdeltaR5IESRLSTT
	1996	zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*local_q(i,k))
	1997	v_qs(i,k)= R2ES * FOEEW(v_t,zdelta)/v_p
	1998	v_qs(i,k)=MIN(0.5,v_qs(i,k))
	1999	zcor=1./(1.-RETV*v_qs(i,k))
	2000	v_qs(i,k)=v_qs(i,k)*zcor
	2001	v_qsd(i,k) =FOEDE(v_t,zdelta,zcvm5,v_qs(i,k),zcor)
	2002	ELSE
	2003	IF (v_t.LT.t_coup) THEN
	2004	v_qs(i,k) = qsats(v_t) / v_p
	2005	v_qsd(i,k) = dqsats(v_t,v_qs(i,k))
	2006	ELSE
	2007	v_qs(i,k) = qsatl(v_t) / v_p
	2008	v_qsd(i,k) = dqsatl(v_t,v_qs(i,k))
	2009	ENDIF
	2010	ENDIF
	2011	ENDDO
	2012	DO k = 2, klev
	2013	zdpm = paprs(i,k-1) - paprs(i,k)
	2014	zdp = paprs(i,k) - paprs(i,k+1)
	2015	gamcpdz(i,k) = ( ( RD/RCPD /(zdpm+zdp) *
	2016	. (v_cptt(i,k-1)zdpm+v_cptt(i,k)zdp)
	2017	. +RLVTT /(zdpm+zdp) *
	2018	. (v_qs(i,k-1)zdpm+v_qs(i,k)zdp)
	2019	. )* (pplay(i,k-1)-pplay(i,k)) / paprs(i,k) )
	2020	. / (1.0+(v_qsd(i,k-1)zdpm+v_qsd(i,k)zdp)
	2021	. /(zdpm+zdp) )
	2022	ENDDO
	2023	C
	2024	C Verifier si l'on peut etendre la colonne vers le bas
	2025	C
	2026	IF (k1 .EQ. 1) GOTO 841 ! extension echouee
	2027	zflo = v_cptt(i,k1-1) - v_cptt(i,k1) - gamcpdz(i,k1)
	2028	zsat=(local_q(i,k1-1)-v_qs(i,k1-1))*(paprs(i,k1-1)-paprs(i,k1))
	2029	. + (local_q(i,k1)-v_qs(i,k1))*(paprs(i,k1)-paprs(i,k1+1))
	2030	IF (zflo.LE.0.0 .OR. zsat.LE.0.0) GOTO 841 ! extension echouee
	2031	C
	2032	840 CONTINUE
	2033	k1 = k1 - 1
	2034	IF (k1 .EQ. 1) GOTO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995)
	2035	zsat = zsat + (local_q(i,k1-1)-v_qs(i,k1-1))
	2036	. *(paprs(i,k1-1)-paprs(i,k1))
	2037	zflo = v_cptt(i,k1-1) - v_cptt(i,k1) - gamcpdz(i,k1)
	2038	IF (zflo.GT.0.0 .AND. zsat.GT.0.0) THEN
	2039	GOTO 840
	2040	ELSE
	2041	GOTO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995)
	2042	ENDIF
	2043	841 CONTINUE
	2044	C
	2045	GOTO 810 ! chercher d'autres blocks en haut
	2046	C
	2047	9999 CONTINUE ! boucle sur tous les points
	2048	C-----------------------------------------------------------------------
	2049	c
	2050	c Determiner la fraction nuageuse (hypothese: la nebulosite a lieu
	2051	c a l'endroit ou la vapeur d'eau est diminuee par l'ajustement):
	2052	c
	2053	DO k = 1, klev
	2054	DO i = 1, klon
	2055	IF (itest(i)) THEN
	2056	delta_q(i,k) = local_q(i,k) - q(i,k)
	2057	IF (delta_q(i,k).LT.0.) rneb(i,k) = 1.0
	2058	ENDIF
	2059	ENDDO
	2060	ENDDO
	2061	c
	2062	c Distribuer l'eau condensee en eau liquide nuageuse (hypothese:
	2063	c l'eau liquide est distribuee aux endroits ou la vapeur d'eau
	2064	c diminue et d'une maniere proportionnelle a cet diminution):
	2065	c
	2066	DO i = 1, klon
	2067	IF (itest(i)) THEN
	2068	zq1(i) = 0.0
	2069	zq2(i) = 0.0
	2070	ENDIF
	2071	ENDDO
	2072	DO k = 1, klev
	2073	DO i = 1, klon
	2074	IF (itest(i)) THEN
	2075	zdp = paprs(i,k)-paprs(i,k+1)
	2076	zq1(i) = zq1(i) - delta_q(i,k) * zdp
	2077	zq2(i) = zq2(i) - MIN(0.0, delta_q(i,k)) * zdp
	2078	ENDIF
	2079	ENDDO
	2080	ENDDO
	2081	DO k = 1, klev
	2082	DO i = 1, klon
	2083	IF (itest(i)) THEN
	2084	IF (zq2(i).NE.0.0)
	2085	. d_ql(i,k) = - MIN(0.0,delta_q(i,k))*zq1(i)/zq2(i)
	2086	ENDIF
	2087	ENDDO
	2088	ENDDO
	2089	C
	2090	DO k = 1, klev
	2091	DO i = 1, klon
	2092	local_q(i, k) = MAX(local_q(i, k), seuil_vap)
	2093	ENDDO
	2094	ENDDO
	2095	C
	2096	DO k = 1, klev
	2097	DO i = 1, klon
	2098	d_t(i,k) = local_t(i,k) - t(i,k)
	2099	d_q(i,k) = local_q(i,k) - q(i,k)
	2100	ENDDO
	2101	ENDDO
	2102	c
	2103	RETURN
	2104	END
	2105	SUBROUTINE fiajc(dtime,paprs,pplay,
	2106	. t, q,conv_q,
	2107	. d_t, d_q, d_ql,rneb,
	2108	. rain, snow, ibas, itop)
	2109	USE dimphy
	2110	IMPLICIT NONE
	2111	c
	2112	cym#include "dimensions.h"
	2113	cym#include "dimphy.h"
	2114	#include "YOMCST.h"
	2115	c
	2116	c Options:
	2117	c
	2118	INTEGER plb ! niveau de depart pour la convection
	2119	PARAMETER (plb=4)
	2120	c
	2121	c Mystere: cette option n'est pas innocente pour les resultats !
	2122	c Qui peut resoudre ce mystere ? (Z.X.Li mars 1995)
	2123	LOGICAL vector ! calcul vectorise
	2124	PARAMETER (vector=.FALSE.)
	2125	c
	2126	REAL t_coup
	2127	PARAMETER (t_coup=234.0)
	2128	c
	2129	c Arguments:
	2130	c
	2131	REAL q(klon,klev) ! humidite specifique (kg/kg)
	2132	REAL t(klon,klev) ! temperature (K)
	2133	REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
	2134	REAL pplay(klon,klev) ! pression au milieu de couche (Pa)
	2135	REAL dtime ! intervalle du temps (s)
	2136	REAL conv_q(klon,klev) ! taux de convergence de l'humidite
	2137	REAL rneb(klon,klev) ! fraction nuageuse
	2138	REAL d_q(klon,klev) ! incrementaion pour la vapeur d'eau
	2139	REAL d_ql(klon,klev) ! incrementation pour l'eau liquide
	2140	REAL d_t(klon,klev) ! incrementation pour la temperature
	2141	REAL rain(klon) ! variable non-utilisee
	2142	REAL snow(klon) ! variable non-utilisee
	2143	INTEGER itop(klon) ! variable non-utilisee
	2144	INTEGER ibas(klon) ! variable non-utilisee
	2145	c
	2146	INTEGER kh(klon), i, k
	2147	LOGICAL nuage(klon), test(klon,klev)
	2148	REAL zconv(klon), zdeh(klon,klev), zvirt(klon)
	2149	REAL zdqs(klon,klev), zqs(klon,klev)
	2150	REAL ztt, zvar, zfrac(klon)
	2151	REAL zq1(klon), zq2(klon)
	2152	REAL zdelta, zcor, zcvm5
	2153	C
	2154	#include "YOETHF.h"
	2155	#include "FCTTRE.h"
	2156	c
	2157	c Initialiser les sorties:
	2158	c
	2159	DO k = 1, klev
	2160	DO i = 1, klon
	2161	rneb(i,k) = 0.0
	2162	d_ql(i,k) = 0.0
	2163	d_t(i,k) = 0.0
	2164	d_q(i,k) = 0.0
	2165	ENDDO
	2166	ENDDO
	2167	DO i = 1, klon
	2168	itop(i) = 0
	2169	ibas(i) = 0
	2170	rain(i) = 0.0
	2171	snow(i) = 0.0
	2172	ENDDO
	2173	c
	2174	c Calculer Qs et L/Cp * dQs/dT:
	2175	c
	2176	DO k = 1, klev
	2177	DO i = 1, klon
	2178	ztt = t(i,k)
	2179	IF (thermcep) THEN
	2180	zdelta=MAX(0.,SIGN(1.,RTT-ztt))
	2181	zcvm5=R5LESRLVTT(1.-zdelta) + zdeltaR5IESRLSTT
	2182	zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k))
	2183	zqs(i,k)= R2ES*FOEEW(ztt,zdelta)/pplay(i,k)
	2184	zqs(i,k)=MIN(0.5,zqs(i,k))
	2185	zcor=1./(1.-RETV*zqs(i,k))
	2186	zqs(i,k)=zqs(i,k)*zcor
	2187	zdqs(i,k) =FOEDE(ztt,zdelta,zcvm5,zqs(i,k),zcor)
	2188	ELSE
	2189	IF (ztt .LT. t_coup) THEN
	2190	zqs(i,k) = qsats(ztt) / pplay(i,k)
	2191	zdqs(i,k) = dqsats(ztt,zqs(i,k))
	2192	ELSE
	2193	zqs(i,k) = qsatl(ztt) / pplay(i,k)
	2194	zdqs(i,k) = dqsatl(ztt,zqs(i,k))
	2195	ENDIF
	2196	ENDIF
	2197	ENDDO
	2198	ENDDO
	2199	c
	2200	c Determiner la difference de l'energie totale saturee:
	2201	c
	2202	DO i = 1, klon
	2203	k = plb
	2204	zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k))
	2205	. - RD 0.5(t(i,k-1)+t(i,k))/paprs(i,k)
	2206	. *(pplay(i,k-1)-pplay(i,k))
	2207	. + RLVTT*(zqs(i,k-1)-zqs(i,k))
	2208	zdeh(i,k) = zdeh(i,k) * 0.5 ! on prend la moitie
	2209	ENDDO
	2210	DO k = plb+1, klev
	2211	DO i = 1, klon
	2212	zdeh(i,k) = zdeh(i,k-1)
	2213	. + RCPD * (t(i,k-1)-t(i,k))
	2214	. - RD 0.5(t(i,k-1)+t(i,k))/paprs(i,k)
	2215	. *(pplay(i,k-1)-pplay(i,k))
	2216	. + RLVTT*(zqs(i,k-1)-zqs(i,k))
	2217	ENDDO
	2218	ENDDO
	2219	c
	2220	c Determiner le sommet du nuage selon l'instabilite
	2221	c Calculer les convergences d'humidite (reelle et virtuelle)
	2222	c
	2223	DO i = 1, klon
	2224	nuage(i) = .TRUE.
	2225	zconv(i) = 0.0
	2226	zvirt(i) = 0.0
	2227	kh(i) = -999
	2228	ENDDO
	2229	DO k = plb, klev
	2230	DO i = 1, klon
	2231	nuage(i) = nuage(i) .AND. zdeh(i,k).GT.0.0
	2232	IF (nuage(i)) THEN
	2233	kh(i) = k
	2234	zconv(i) = zconv(i)+conv_q(i,k)*dtime
	2235	. *(paprs(i,k)-paprs(i,k+1))
	2236	zvirt(i)=zvirt(i)+(zdeh(i,k)/RLVTT+zqs(i,k)-q(i,k))
	2237	. *(paprs(i,k)-paprs(i,k+1))
	2238	ENDIF
	2239	ENDDO
	2240	ENDDO
	2241	c
	2242	IF (vector) THEN
	2243	c
	2244	c
	2245	DO k = plb, klev
	2246	DO i = 1, klon
	2247	IF (k.LE.kh(i) .AND. kh(i).GT.plb .AND. zconv(i).GT.0.0) THEN
	2248	test(i,k) = .TRUE.
	2249	zfrac(i) = MAX(0.0,MIN(zconv(i)/zvirt(i),1.0))
	2250	ELSE
	2251	test(i,k) = .FALSE.
	2252	ENDIF
	2253	ENDDO
	2254	ENDDO
	2255	c
	2256	DO k = plb, klev
	2257	DO i = 1, klon
	2258	IF (test(i,k)) THEN
	2259	zvar = zdeh(i,k)/(1.0+zdqs(i,k))
	2260	d_q(i,k) = (zvarzdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))zfrac(i)
	2261	. - conv_q(i,k)*dtime
	2262	d_t(i,k) = zvar * zfrac(i) / RCPD
	2263	ENDIF
	2264	ENDDO
	2265	ENDDO
	2266	c
	2267	DO i = 1, klon
	2268	zq1(i) = 0.0
	2269	zq2(i) = 0.0
	2270	ENDDO
	2271	DO k = plb, klev
	2272	DO i = 1, klon
	2273	IF (test(i,k)) THEN
	2274	IF (d_q(i,k).LT.0.0) rneb(i,k) = zfrac(i)
	2275	zq1(i) = zq1(i) - d_q(i,k) * (paprs(i,k)-paprs(i,k+1))
	2276	zq2(i) = zq2(i) - MIN(0.0, d_q(i,k))
	2277	. * (paprs(i,k)-paprs(i,k+1))
	2278	ENDIF
	2279	ENDDO
	2280	ENDDO
	2281	c
	2282	DO k = plb, klev
	2283	DO i = 1, klon
	2284	IF (test(i,k)) THEN
	2285	IF(zq2(i).NE.0.)d_ql(i,k)=-MIN(0.0,d_q(i,k))*zq1(i)/zq2(i)
	2286	ENDIF
	2287	ENDDO
	2288	ENDDO
	2289	c
	2290	ELSE ! (.NOT. vector)
	2291	c
	2292	DO 999 i = 1, klon
	2293	IF (kh(i).GT.plb .AND. zconv(i).GT.0.0) THEN
	2294	ccc IF (kh(i).LE.plb) GOTO 999 ! il n'y a pas d'instabilite
	2295	ccc IF (zconv(i).LE.0.0) GOTO 999 ! convergence insuffisante
	2296	zfrac(i) = MAX(0.0,MIN(zconv(i)/zvirt(i),1.0))
	2297	DO k = plb, kh(i)
	2298	zvar = zdeh(i,k)/(1.0+zdqs(i,k))
	2299	d_q(i,k) = (zvarzdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))zfrac(i)
	2300	. - conv_q(i,k)*dtime
	2301	d_t(i,k) = zvar * zfrac(i) / RCPD
	2302	ENDDO
	2303	c
	2304	zq1(i) = 0.0
	2305	zq2(i) = 0.0
	2306	DO k = plb, kh(i)
	2307	IF (d_q(i,k).LT.0.0) rneb(i,k) = zfrac(i)
	2308	zq1(i) = zq1(i) - d_q(i,k) * (paprs(i,k)-paprs(i,k+1))
	2309	zq2(i) = zq2(i) - MIN(0.0, d_q(i,k))
	2310	. * (paprs(i,k)-paprs(i,k+1))
	2311	ENDDO
	2312	DO k = plb, kh(i)
	2313	IF(zq2(i).NE.0.)d_ql(i,k)=-MIN(0.0,d_q(i,k))*zq1(i)/zq2(i)
	2314	ENDDO
	2315	ENDIF
	2316	999 CONTINUE
	2317	c
	2318	ENDIF ! fin de teste sur vector
	2319	c
	2320	RETURN
	2321	END

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

Download in other formats:

Original Format