Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_cu_tiedtke.F @ 1419

Last change on this file since 1419 was 1, checked in by lfita, 10 years ago

-- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 116.1 KB

Line
1	!-----------------------------------------------------------------------
2	!
3	!WRF:MODEL_LAYER:PHYSICS
4	!
5	!####################TIEDTKE SCHEME#########################
6	! Taken from the IPRC iRAM - Yuqing Wang, University of Hawaii
7	! Added by Chunxi Zhang and Yuqing Wang to WRF3.2, May, 2010
8	! refenrence: Tiedtke (1989, MWR, 117, 1779-1800)
9	! Nordeng, T.E., (1995), CAPE closure and organized entrainment/detrainment
10	! Yuqing Wang et al. (2003,J. Climate, 16, 1721-1738) for improvements
11	! for cloud top detrainment
12	! (2004, Mon. Wea. Rev., 132, 274-296), improvements for PBL clouds
13	! (2007,Mon. Wea. Rev., 135, 567-585), diurnal cycle of precipitation
14	! This scheme is on testing
15	!###########################################################
16	MODULE module_cu_tiedtke
17	!
18	!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
19	! epsl--- allowed minimum value for floating calculation
20	!---------------------------------------------------------------
21	real,parameter :: epsl = 1.0e-20
22	real,parameter :: t000 = 273.15
23	real,parameter :: hgfr = 233.15 ! defined in param.f in explct
24	!-------------------------------------------------------------
25	! Ends the parameters set
26	!++++++++++++++++++++++++++++
27	REAL,PRIVATE :: G,CPV
28	REAL :: API,A,EOMEGA,RD,RV,CPD,RCPD,VTMPC1,VTMPC2, &
29	RHOH2O,ALV,ALS,ALF,CLW,TMELT,SOLC,STBO,DAYL,YEARL, &
30	C1ES,C2ES,C3LES,C3IES,C4LES,C4IES,C5LES,C5IES,ZRG
31
32	REAL :: ENTRPEN,ENTRSCV,ENTRMID,ENTRDD,CMFCTOP,RHM,RHC, &
33	CMFCMAX,CMFCMIN,CMFDEPS,RHCDD,CPRCON,CRIRH,ZBUO0, &
34	fdbk,ZTAU
35
36	INTEGER :: nentr
37
38	REAL :: CVDIFTS, CEVAPCU1, CEVAPCU2,ZDNOPRC
39
40
41	PARAMETER(A=6371.22E03, &
42	ALV=2.5008E6, &
43	ALS=2.8345E6, &
44	ALF=ALS-ALV, &
45	CPD=1005.46, &
46	CPV=1869.46, & ! CPV in module is 1846.4
47	RCPD=1.0/CPD, &
48	RHOH2O=1.0E03, &
49	TMELT=273.16, &
50	G=9.806, & ! G=9.806
51	ZRG=1.0/G, &
52	RD=287.05, &
53	RV=461.51, &
54	C1ES=610.78, &
55	C2ES=C1ES*RD/RV, &
56	C3LES=17.269, &
57	C4LES=35.86, &
58	C5LES=C3LES*(TMELT-C4LES), &
59	C3IES=21.875, &
60	C4IES=7.66, &
61	C5IES=C3IES*(TMELT-C4IES), &
62	API=3.141593, & ! API=2.0*ASIN(1.)
63	VTMPC1=RV/RD-1.0, &
64	VTMPC2=CPV/CPD-1.0, &
65	CVDIFTS=1.0, &
66	CEVAPCU1=1.93E-6*261., &
67	CEVAPCU2=1.E3/(38.3*0.293) )
68
69
70	! SPECIFY PARAMETERS FOR MASSFLUX-SCHEME
71	! --------------------------------------
72	! These are tunable parameters
73	!
74	! ENTRPEN: AVERAGE ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
75	! -------
76	!
77	PARAMETER(ENTRPEN=1.0E-4)
78	!
79	! ENTRSCV: AVERAGE ENTRAINMENT RATE FOR SHALLOW CONVECTION
80	! -------
81	!
82	PARAMETER(ENTRSCV=1.2E-3)
83	!
84	! ENTRMID: AVERAGE ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
85	! -------
86	!
87	PARAMETER(ENTRMID=1.0E-4)
88	!
89	! ENTRDD: AVERAGE ENTRAINMENT RATE FOR DOWNDRAFTS
90	! ------
91	!
92	PARAMETER(ENTRDD =2.0E-4)
93	!
94	! CMFCTOP: RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANCY LEVEL
95	! -------
96	!
97	PARAMETER(CMFCTOP=0.26)
98	!
99	! CMFCMAX: MAXIMUM MASSFLUX VALUE ALLOWED FOR UPDRAFTS ETC
100	! -------
101	!
102	PARAMETER(CMFCMAX=1.0)
103	!
104	! CMFCMIN: MINIMUM MASSFLUX VALUE (FOR SAFETY)
105	! -------
106	!
107	PARAMETER(CMFCMIN=1.E-10)
108	!
109	! CMFDEPS: FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
110	! -------
111	!
112	PARAMETER(CMFDEPS=0.30)
113	!
114	! CPRCON: COEFFICIENTS FOR DETERMINING CONVERSION FROM CLOUD WATER
115	!
116	PARAMETER(CPRCON = 2.0E-3/G)
117	!
118	! ZDNOPRC: The pressure depth below which no precipitation
119	!
120	PARAMETER(ZDNOPRC = 1.5E4)
121	!--------------------
122	PARAMETER(nentr=1) ! Old entrainment rate parameterization ! chn1,2,4
123	! PARAMETER(nentr=2) ! New entrainment rate parameterization ! chn3
124	!
125	!--------------------
126	PARAMETER(RHC=0.80,RHM=1.0,ZBUO0=0.50)
127	!--------------------
128	PARAMETER(CRIRH=0.80,fdbk = 1.0,ZTAU = 3600.0)
129	!--------------------
130	LOGICAL :: LMFPEN,LMFMID,LMFSCV,LMFDD,LMFDUDV
131	PARAMETER(LMFPEN=.TRUE.,LMFMID=.TRUE.,LMFSCV=.TRUE.,LMFDD=.TRUE.,LMFDUDV=.TRUE.)
132	!--------------------
133	!#################### END of Variables definition##########################
134	!-----------------------------------------------------------------------
135	!
136	CONTAINS
137	!-----------------------------------------------------------------------
138	SUBROUTINE CU_TIEDTKE( &
139	DT,ITIMESTEP,STEPCU &
140	,RAINCV,PRATEC,QFX,ZNU &
141	,U3D,V3D,W,T3D,QV3D,QC3D,QI3D,PI3D,RHO3D &
142	,QVFTEN,QVPBLTEN &
143	,DZ8W,PCPS,P8W,XLAND,CU_ACT_FLAG &
144	,CUDT, CURR_SECS, ADAPT_STEP_FLAG &
145	,ids,ide, jds,jde, kds,kde &
146	,ims,ime, jms,jme, kms,kme &
147	,its,ite, jts,jte, kts,kte &
148	,RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN &
149	,RUCUTEN, RVCUTEN &
150	,F_QV ,F_QC ,F_QR ,F_QI ,F_QS &
151	)
152
153	!-------------------------------------------------------------------
154	IMPLICIT NONE
155	!-------------------------------------------------------------------
156	!-- U3D 3D u-velocity interpolated to theta points (m/s)
157	!-- V3D 3D v-velocity interpolated to theta points (m/s)
158	!-- TH3D 3D potential temperature (K)
159	!-- T3D temperature (K)
160	!-- QV3D 3D water vapor mixing ratio (Kg/Kg)
161	!-- QC3D 3D cloud mixing ratio (Kg/Kg)
162	!-- QI3D 3D ice mixing ratio (Kg/Kg)
163	!-- RHO3D 3D air density (kg/m^3)
164	!-- P8w 3D hydrostatic pressure at full levels (Pa)
165	!-- Pcps 3D hydrostatic pressure at half levels (Pa)
166	!-- PI3D 3D exner function (dimensionless)
167	!-- RTHCUTEN Theta tendency due to
168	! cumulus scheme precipitation (K/s)
169	!-- RUCUTEN U wind tendency due to
170	! cumulus scheme precipitation (K/s)
171	!-- RVCUTEN V wind tendency due to
172	! cumulus scheme precipitation (K/s)
173	!-- RQVCUTEN Qv tendency due to
174	! cumulus scheme precipitation (kg/kg/s)
175	!-- RQRCUTEN Qr tendency due to
176	! cumulus scheme precipitation (kg/kg/s)
177	!-- RQCCUTEN Qc tendency due to
178	! cumulus scheme precipitation (kg/kg/s)
179	!-- RQSCUTEN Qs tendency due to
180	! cumulus scheme precipitation (kg/kg/s)
181	!-- RQICUTEN Qi tendency due to
182	! cumulus scheme precipitation (kg/kg/s)
183	!-- RAINC accumulated total cumulus scheme precipitation (mm)
184	!-- RAINCV cumulus scheme precipitation (mm)
185	!-- PRATEC precipitiation rate from cumulus scheme (mm/s)
186	!-- dz8w dz between full levels (m)
187	!-- QFX upward moisture flux at the surface (kg/m^2/s)
188	!-- DT time step (s)
189	!-- ids start index for i in domain
190	!-- ide end index for i in domain
191	!-- jds start index for j in domain
192	!-- jde end index for j in domain
193	!-- kds start index for k in domain
194	!-- kde end index for k in domain
195	!-- ims start index for i in memory
196	!-- ime end index for i in memory
197	!-- jms start index for j in memory
198	!-- jme end index for j in memory
199	!-- kms start index for k in memory
200	!-- kme end index for k in memory
201	!-- its start index for i in tile
202	!-- ite end index for i in tile
203	!-- jts start index for j in tile
204	!-- jte end index for j in tile
205	!-- kts start index for k in tile
206	!-- kte end index for k in tile
207	!-------------------------------------------------------------------
208	INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, &
209	ims,ime, jms,jme, kms,kme, &
210	its,ite, jts,jte, kts,kte, &
211	ITIMESTEP, &
212	STEPCU
213
214	REAL, INTENT(IN) :: &
215	DT
216
217
218	REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: &
219	XLAND
220
221	REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: &
222	RAINCV, PRATEC
223
224	LOGICAL, DIMENSION(IMS:IME,JMS:JME), INTENT(INOUT) :: &
225	CU_ACT_FLAG
226
227
228	REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: &
229	DZ8W, &
230	P8w, &
231	Pcps, &
232	PI3D, &
233	QC3D, &
234	QVFTEN, &
235	QVPBLTEN, &
236	QI3D, &
237	QV3D, &
238	RHO3D, &
239	T3D, &
240	U3D, &
241	V3D, &
242	W
243
244	!--------------------------- OPTIONAL VARS ----------------------------
245
246	REAL, DIMENSION(ims:ime, kms:kme, jms:jme), &
247	OPTIONAL, INTENT(INOUT) :: &
248	RQCCUTEN, &
249	RQICUTEN, &
250	RQVCUTEN, &
251	RTHCUTEN, &
252	RUCUTEN, &
253	RVCUTEN
254
255	!
256	! Flags relating to the optional tendency arrays declared above
257	! Models that carry the optional tendencies will provdide the
258	! optional arguments at compile time; these flags all the model
259	! to determine at run-time whether a particular tracer is in
260	! use or not.
261	!
262	LOGICAL, OPTIONAL :: &
263	F_QV &
264	,F_QC &
265	,F_QR &
266	,F_QI &
267	,F_QS
268
269	! Adaptive time-step variables
270	REAL, INTENT(IN ) :: CUDT
271	REAL, INTENT(IN ) :: CURR_SECS
272	LOGICAL,INTENT(IN ) :: ADAPT_STEP_FLAG
273
274	!--------------------------- LOCAL VARS ------------------------------
275
276	REAL, DIMENSION(ims:ime, jms:jme) :: &
277	QFX
278
279	REAL :: &
280	DELT, &
281	RDELT
282
283	REAL , DIMENSION(its:ite) :: &
284	RCS, &
285	RN, &
286	EVAP
287	INTEGER , DIMENSION(its:ite) :: SLIMSK
288
289
290	REAL , DIMENSION(its:ite, kts:kte+1) :: &
291	PRSI
292
293	REAL , DIMENSION(its:ite, kts:kte) :: &
294	DEL, &
295	DOT, &
296	PHIL, &
297	PRSL, &
298	Q1, &
299	Q2, &
300	Q3, &
301	Q1B, &
302	Q1BL, &
303	Q11, &
304	Q12, &
305	T1, &
306	U1, &
307	V1, &
308	ZI, &
309	ZL, &
310	OMG, &
311	GHT
312
313	INTEGER, DIMENSION(its:ite) :: &
314	KBOT, &
315	KTOP
316
317	INTEGER :: &
318	I, &
319	IM, &
320	J, &
321	K, &
322	KM, &
323	KP, &
324	KX
325
326
327	LOGICAL :: run_param
328
329	!-------other local variables----
330	INTEGER,DIMENSION( its:ite ) :: KTYPE
331	REAL, DIMENSION( kts:kte ) :: sig1 ! half sigma levels
332	REAL, DIMENSION( kms:kme ) :: ZNU
333	INTEGER :: zz
334	!-----------------------------------------------------------------------
335	!
336	!*** CHECK TO SEE IF THIS IS A CONVECTION TIMESTEP
337	!
338	if (adapt_step_flag) then
339	if ( (ITIMESTEP .eq. 1) .or. (cudt .eq. 0) .or. &
340	( CURR_SECS + dt >= ( int( CURR_SECS / ( cudt * 60 ) ) + 1 ) * cudt * 60 ) ) then
341	run_param = .TRUE.
342	else
343	run_param = .FALSE.
344	endif
345	else
346	if (MOD(ITIMESTEP,STEPCU) .EQ. 0 .or. ITIMESTEP .eq. 1) then
347	run_param = .TRUE.
348	else
349	run_param = .FALSE.
350	endif
351	endif
352
353	!-----------------------------------------------------------------------
354	IF(run_param) THEN
355
356	DO J=JTS,JTE
357	DO I=ITS,ITE
358	CU_ACT_FLAG(I,J)=.TRUE.
359	ENDDO
360	ENDDO
361
362	IM=ITE-ITS+1
363	KX=KTE-KTS+1
364	DELT=DT*STEPCU
365	RDELT=1./DELT
366
367	!------------- J LOOP (OUTER) --------------------------------------------------
368
369	DO J=jts,jte
370
371	! --------------- compute zi and zl -----------------------------------------
372	DO i=its,ite
373	ZI(I,KTS)=0.0
374	ENDDO
375
376	DO k=kts+1,kte
377	KM=k-1
378	DO i=its,ite
379	ZI(I,K)=ZI(I,KM)+dz8w(i,km,j)
380	ENDDO
381	ENDDO
382
383	DO k=kts+1,kte
384	KM=k-1
385	DO i=its,ite
386	ZL(I,KM)=(ZI(I,K)+ZI(I,KM))*0.5
387	ENDDO
388	ENDDO
389
390	DO i=its,ite
391	ZL(I,KTE)=2.*ZI(I,KTE)-ZL(I,KTE-1)
392	ENDDO
393
394	! --------------- end compute zi and zl -------------------------------------
395	DO i=its,ite
396	SLIMSK(i)=int(ABS(XLAND(i,j)-2.))
397	ENDDO
398
399	DO k=kts,kte
400	kp=k+1
401	DO i=its,ite
402	DOT(i,k)=-0.5grho3d(i,k,j)*(w(i,k,j)+w(i,kp,j))
403	ENDDO
404	ENDDO
405
406	DO k=kts,kte
407	zz = kte+1-k
408	DO i=its,ite
409	U1(i,zz)=U3D(i,k,j)
410	V1(i,zz)=V3D(i,k,j)
411	T1(i,zz)=T3D(i,k,j)
412	Q1(i,zz)= QV3D(i,k,j)
413	if(itimestep == 1) then
414	Q1B(i,zz)=0.
415	Q1BL(i,zz)=0.
416	else
417	Q1B(i,zz)=QVFTEN(i,k,j)
418	Q1BL(i,zz)=QVPBLTEN(i,k,j)
419	endif
420	Q2(i,zz)=QC3D(i,k,j)
421	Q3(i,zz)=QI3D(i,k,j)
422	OMG(i,zz)=DOT(i,k)
423	GHT(i,zz)=ZL(i,k)
424	PRSL(i,zz) = Pcps(i,k,j)
425	ENDDO
426	ENDDO
427
428	DO k=kts,kte+1
429	zz = kte+2-k
430	DO i=its,ite
431	PRSI(i,zz) = P8w(i,k,j)
432	ENDDO
433	ENDDO
434
435	DO k=kts,kte
436	zz = kte+1-k
437	sig1(zz) = ZNU(k)
438	ENDDO
439
440	!###############before call TIECNV, we need EVAP########################
441	! EVAP is the vapor flux at the surface
442	!########################################################################
443	!
444	DO i=its,ite
445	EVAP(i) = QFX(i,j)
446	ENDDO
447	!########################################################################
448	CALL TIECNV(U1,V1,T1,Q1,Q2,Q3,Q1B,Q1BL,GHT,OMG,PRSL,PRSI,EVAP, &
449	RN,SLIMSK,KTYPE,IM,KX,KX+1,sig1,DELT)
450
451	DO I=ITS,ITE
452	RAINCV(I,J)=RN(I)/STEPCU
453	PRATEC(I,J)=RN(I)/(STEPCU * DT)
454	ENDDO
455
456	DO K=KTS,KTE
457	zz = kte+1-k
458	DO I=ITS,ITE
459	RTHCUTEN(I,K,J)=(T1(I,zz)-T3D(I,K,J))/PI3D(I,K,J)*RDELT
460	RQVCUTEN(I,K,J)=(Q1(I,zz)-QV3D(I,K,J))*RDELT
461	RUCUTEN(I,K,J) =(U1(I,zz)-U3D(I,K,J))*RDELT
462	RVCUTEN(I,K,J) =(V1(I,zz)-V3D(I,K,J))*RDELT
463	ENDDO
464	ENDDO
465
466	IF(PRESENT(RQCCUTEN))THEN
467	IF ( F_QC ) THEN
468	DO K=KTS,KTE
469	zz = kte+1-k
470	DO I=ITS,ITE
471	RQCCUTEN(I,K,J)=(Q2(I,zz)-QC3D(I,K,J))*RDELT
472	ENDDO
473	ENDDO
474	ENDIF
475	ENDIF
476
477	IF(PRESENT(RQICUTEN))THEN
478	IF ( F_QI ) THEN
479	DO K=KTS,KTE
480	zz = kte+1-k
481	DO I=ITS,ITE
482	RQICUTEN(I,K,J)=(Q3(I,zz)-QI3D(I,K,J))*RDELT
483	ENDDO
484	ENDDO
485	ENDIF
486	ENDIF
487
488
489	ENDDO
490
491	ENDIF
492
493	END SUBROUTINE CU_TIEDTKE
494
495	!====================================================================
496	SUBROUTINE tiedtkeinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, &
497	RUCUTEN,RVCUTEN, &
498	RESTART,P_QC,P_QI,P_FIRST_SCALAR, &
499	allowed_to_read, &
500	ids, ide, jds, jde, kds, kde, &
501	ims, ime, jms, jme, kms, kme, &
502	its, ite, jts, jte, kts, kte)
503	!--------------------------------------------------------------------
504	IMPLICIT NONE
505	!--------------------------------------------------------------------
506	LOGICAL , INTENT(IN) :: allowed_to_read,restart
507	INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
508	ims, ime, jms, jme, kms, kme, &
509	its, ite, jts, jte, kts, kte
510	INTEGER , INTENT(IN) :: P_FIRST_SCALAR, P_QI, P_QC
511
512	REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: &
513	RTHCUTEN, &
514	RQVCUTEN, &
515	RQCCUTEN, &
516	RQICUTEN, &
517	RUCUTEN,RVCUTEN
518
519	INTEGER :: i, j, k, itf, jtf, ktf
520
521	jtf=min0(jte,jde-1)
522	ktf=min0(kte,kde-1)
523	itf=min0(ite,ide-1)
524
525	IF(.not.restart)THEN
526	DO j=jts,jtf
527	DO k=kts,ktf
528	DO i=its,itf
529	RTHCUTEN(i,k,j)=0.
530	RQVCUTEN(i,k,j)=0.
531	RUCUTEN(i,k,j)=0.
532	RVCUTEN(i,k,j)=0.
533	ENDDO
534	ENDDO
535	ENDDO
536
537	IF (P_QC .ge. P_FIRST_SCALAR) THEN
538	DO j=jts,jtf
539	DO k=kts,ktf
540	DO i=its,itf
541	RQCCUTEN(i,k,j)=0.
542	ENDDO
543	ENDDO
544	ENDDO
545	ENDIF
546
547	IF (P_QI .ge. P_FIRST_SCALAR) THEN
548	DO j=jts,jtf
549	DO k=kts,ktf
550	DO i=its,itf
551	RQICUTEN(i,k,j)=0.
552	ENDDO
553	ENDDO
554	ENDDO
555	ENDIF
556	ENDIF
557
558	END SUBROUTINE tiedtkeinit
559
560	! ------------------------------------------------------------------------
561
562	!------------This is the combined version for tiedtke---------------
563	!----------------------------------------------------------------
564	! In this module only the mass flux convection scheme of the ECMWF is included
565	!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
566	!#############################################################
567	!
568	! LEVEL 1 SUBROUTINEs
569	!
570	!#############################################################
571	!********************************************************
572	! subroutine TIECNV
573	!********************************************************
574	SUBROUTINE TIECNV(pu,pv,pt,pqv,pqc,pqi,pqvf,pqvbl,poz,pomg, &
575	pap,paph,evap,zprecc,lndj,KTYPE,lq,km,km1,sig1,dt)
576	!-----------------------------------------------------------------
577	! This is the interface between the meso-scale model and the mass
578	! flux convection module
579	!-----------------------------------------------------------------
580	implicit none
581
582	real pu(lq,km),pv(lq,km),pt(lq,km),pqv(lq,km),pqvf(lq,km)
583	real poz(lq,km),pomg(lq,km),evap(lq),zprecc(lq),pqvbl(lq,km)
584
585	REAL PUM1(lq,km), PVM1(lq,km), &
586	PTTE(lq,km), PQTE(lq,km), PVOM(lq,km), PVOL(lq,km), &
587	PVERV(lq,km), PGEO(lq,km), PAP(lq,km), PAPH(lq,km1)
588	REAL PQHFL(lq), ZQQ(lq,km), PAPRC(lq), PAPRS(lq), &
589	PRSFC(lq), PSSFC(lq), PAPRSM(lq), PCTE(lq,km)
590	REAL ZTP1(lq,km), ZQP1(lq,km), ZTU(lq,km), ZQU(lq,km), &
591	ZLU(lq,km), ZLUDE(lq,km), ZMFU(lq,km), ZMFD(lq,km), &
592	ZQSAT(lq,km), pqc(lq,km), pqi(lq,km), ZRAIN(lq)
593
594	REAL sig(km1),sig1(km)
595	INTEGER ICBOT(lq), ICTOP(lq), KTYPE(lq), lndj(lq)
596	REAL dt
597	LOGICAL LOCUM(lq)
598
599	real PSHEAT,PSRAIN,PSEVAP,PSMELT,PSDISS,TT
600	real ZTMST,ZTPP1,fliq,fice,ZTC,ZALF
601	integer i,j,k,lq,lp,km,km1
602	! real TLUCUA
603	! external TLUCUA
604
605	ZTMST=dt
606	! Masv flux diagnostics.
607
608	PSHEAT=0.0
609	PSRAIN=0.0
610	PSEVAP=0.0
611	PSMELT=0.0
612	PSDISS=0.0
613	DO 8 j=1,lq
614	ZRAIN(j)=0.0
615	LOCUM(j)=.FALSE.
616	PRSFC(j)=0.0
617	PSSFC(j)=0.0
618	PAPRC(j)=0.0
619	PAPRS(j)=0.0
620	PAPRSM(j)=0.0
621	PQHFL(j)=evap(j)
622	8 CONTINUE
623
624	! CONVERT MODEL VARIABLES FOR MFLUX SCHEME
625
626	DO 10 k=1,km
627	DO 10 j=1,lq
628	PTTE(j,k)=0.0
629	PCTE(j,k)=0.0
630	PVOM(j,k)=0.0
631	PVOL(j,k)=0.0
632	ZTP1(j,k)=pt(j,k)
633	ZQP1(j,k)=pqv(j,k)/(1.0+pqv(j,k))
634	PUM1(j,k)=pu(j,k)
635	PVM1(j,k)=pv(j,k)
636	PVERV(j,k)=pomg(j,k)
637	PGEO(j,k)=G*poz(j,k)
638	TT=ZTP1(j,k)
639	ZQSAT(j,k)=TLUCUA(TT)/PAP(j,k)
640	ZQSAT(j,k)=MIN(0.5,ZQSAT(j,k))
641	ZQSAT(j,k)=ZQSAT(j,k)/(1.-VTMPC1*ZQSAT(j,k))
642	PQTE(j,k)=pqvf(j,k)+pqvbl(j,k)
643	ZQQ(j,k)=PQTE(j,k)
644	10 CONTINUE
645	!
646	!-----------------------------------------------------------------------
647	!* 2. CALL 'CUMASTR'(MASTER-ROUTINE FOR CUMULUS PARAMETERIZATION)
648	!
649	CALL CUMASTR_NEW &
650	(lq, km, km1, km-1, ZTP1, &
651	ZQP1, PUM1, PVM1, PVERV, ZQSAT, &
652	PQHFL, ZTMST, PAP, PAPH, PGEO, &
653	PTTE, PQTE, PVOM, PVOL, PRSFC, &
654	PSSFC, PAPRC, PAPRSM, PAPRS, LOCUM, &
655	KTYPE, ICBOT, ICTOP, ZTU, ZQU, &
656	ZLU, ZLUDE, ZMFU, ZMFD, ZRAIN, &
657	PSRAIN, PSEVAP, PSHEAT, PSDISS, PSMELT, &
658	PCTE, sig1, lndj)
659	!
660	! TO INCLUDE THE CLOUD WATER AND CLOUD ICE DETRAINED FROM CONVECTION
661	!
662	IF(fdbk.ge.1.0e-9) THEN
663	DO 20 K=1,km
664	DO 20 j=1,lq
665	If(PCTE(j,k).GT.0.0) then
666	ZTPP1=pt(j,k)+PTTE(j,k)*ZTMST
667	if(ZTPP1.ge.t000) then
668	fliq=1.0
669	ZALF=0.0
670	else if(ZTPP1.le.hgfr) then
671	fliq=0.0
672	ZALF=ALF
673	else
674	ZTC=ZTPP1-t000
675	fliq=0.0059+0.9941exp(-0.003102ZTC*ZTC)
676	ZALF=ALF
677	endif
678	fice=1.0-fliq
679	pqc(j,k)=pqc(j,k)+fliqPCTE(j,k)ZTMST
680	pqi(j,k)=pqi(j,k)+ficePCTE(j,k)ZTMST
681	PTTE(j,k)=PTTE(j,k)-ZALFRCPDfliq*PCTE(j,k)
682	Endif
683	20 CONTINUE
684	ENDIF
685	!
686	DO 75 k=1,km
687	DO 75 j=1,lq
688	pt(j,k)=ZTP1(j,k)+PTTE(j,k)*ZTMST
689	ZQP1(j,k)=ZQP1(j,k)+(PQTE(j,k)-ZQQ(j,k))*ZTMST
690	pqv(j,k)=ZQP1(j,k)/(1.0-ZQP1(j,k))
691	75 CONTINUE
692	DO 85 j=1,lq
693	zprecc(j)=amax1(0.0,(PRSFC(j)+PSSFC(j))*ZTMST)
694	85 CONTINUE
695	IF (LMFDUDV) THEN
696	DO 100 k=1,km
697	DO 100 j=1,lq
698	pu(j,k)=pu(j,k)+PVOM(j,k)*ZTMST
699	pv(j,k)=pv(j,k)+PVOL(j,k)*ZTMST
700	100 CONTINUE
701	ENDIF
702	!
703	RETURN
704	END SUBROUTINE TIECNV
705
706	!#############################################################
707	!
708	! LEVEL 2 SUBROUTINEs
709	!
710	!#############################################################
711	!***********************************************************
712	! SUBROUTINE CUMASTR_NEW
713	!***********************************************************
714	SUBROUTINE CUMASTR_NEW &
715	(KLON, KLEV, KLEVP1, KLEVM1, PTEN, &
716	PQEN, PUEN, PVEN, PVERV, PQSEN, &
717	PQHFL, ZTMST, PAP, PAPH, PGEO, &
718	PTTE, PQTE, PVOM, PVOL, PRSFC, &
719	PSSFC, PAPRC, PAPRSM, PAPRS, LDCUM, &
720	KTYPE, KCBOT, KCTOP, PTU, PQU, &
721	PLU, PLUDE, PMFU, PMFD, PRAIN, &
722	PSRAIN, PSEVAP, PSHEAT, PSDISS, PSMELT,&
723	PCTE, sig1, lndj)
724	!
725	!**CUMASTR MASTER ROUTINE FOR CUMULUS MASSFLUX-SCHEME
726	! M.TIEDTKE E.C.M.W.F. 1986/1987/1989
727	!***PURPOSE
728	! -------
729	! THIS ROUTINE COMPUTES THE PHYSICAL TENDENCIES OF THE
730	! PROGNOSTIC VARIABLES T,Q,U AND V DUE TO CONVECTIVE PROCESSES.
731	! PROCESSES CONSIDERED ARE: CONVECTIVE FLUXES, FORMATION OF
732	! PRECIPITATION, EVAPORATION OF FALLING RAIN BELOW CLOUD BASE,
733	! SATURATED CUMULUS DOWNDRAFTS.
734	!***INTERFACE.
735	! ----------
736	! CUMASTR IS CALLED FROM MSSFLX
737	! THE ROUTINE TAKES ITS INPUT FROM THE LONG-TERM STORAGE
738	! T,Q,U,V,PHI AND P AND MOISTURE TENDENCIES.
739	! IT RETURNS ITS OUTPUT TO THE SAME SPACE
740	! 1.MODIFIED TENDENCIES OF MODEL VARIABLES
741	! 2.RATES OF CONVECTIVE PRECIPITATION
742	! (USED IN SUBROUTINE SURF)
743	! 3.CLOUD BASE, CLOUD TOP AND PRECIP FOR RADIATION
744	! (USED IN SUBROUTINE CLOUD)
745	!***METHOD
746	! ------
747	! PARAMETERIZATION IS DONE USING A MASSFLUX-SCHEME.
748	! (1) DEFINE CONSTANTS AND PARAMETERS
749	! (2) SPECIFY VALUES (T,Q,QS...) AT HALF LEVELS AND
750	! INITIALIZE UPDRAFT- AND DOWNDRAFT-VALUES IN 'CUINI'
751	! (3) CALCULATE CLOUD BASE IN 'CUBASE'
752	! AND SPECIFY CLOUD BASE MASSFLUX FROM PBL MOISTURE BUDGET
753	! (4) DO CLOUD ASCENT IN 'CUASC' IN ABSENCE OF DOWNDRAFTS
754	! (5) DO DOWNDRAFT CALCULATIONS:
755	! (A) DETERMINE VALUES AT LFS IN 'CUDLFS'
756	! (B) DETERMINE MOIST DESCENT IN 'CUDDRAF'
757	! (C) RECALCULATE CLOUD BASE MASSFLUX CONSIDERING THE
758	! EFFECT OF CU-DOWNDRAFTS
759	! (6) DO FINAL CLOUD ASCENT IN 'CUASC'
760	! (7) DO FINAL ADJUSMENTS TO CONVECTIVE FLUXES IN 'CUFLX',
761	! DO EVAPORATION IN SUBCLOUD LAYER
762	! (8) CALCULATE INCREMENTS OF T AND Q IN 'CUDTDQ'
763	! (9) CALCULATE INCREMENTS OF U AND V IN 'CUDUDV'
764	!***EXTERNALS.
765	! ----------
766	! CUINI: INITIALIZES VALUES AT VERTICAL GRID USED IN CU-PARAMETR.
767	! CUBASE: CLOUD BASE CALCULATION FOR PENETR.AND SHALLOW CONVECTION
768	! CUASC: CLOUD ASCENT FOR ENTRAINING PLUME
769	! CUDLFS: DETERMINES VALUES AT LFS FOR DOWNDRAFTS
770	! CUDDRAF:DOES MOIST DESCENT FOR CUMULUS DOWNDRAFTS
771	! CUFLX: FINAL ADJUSTMENTS TO CONVECTIVE FLUXES (ALSO IN PBL)
772	! CUDQDT: UPDATES TENDENCIES FOR T AND Q
773	! CUDUDV: UPDATES TENDENCIES FOR U AND V
774	!***SWITCHES.
775	! --------
776	! LMFPEN=.T. PENETRATIVE CONVECTION IS SWITCHED ON
777	! LMFSCV=.T. SHALLOW CONVECTION IS SWITCHED ON
778	! LMFMID=.T. MIDLEVEL CONVECTION IS SWITCHED ON
779	! LMFDD=.T. CUMULUS DOWNDRAFTS SWITCHED ON
780	! LMFDUDV=.T. CUMULUS FRICTION SWITCHED ON
781	!***
782	! MODEL PARAMETERS (DEFINED IN SUBROUTINE CUPARAM)
783	! ------------------------------------------------
784	! ENTRPEN ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
785	! ENTRSCV ENTRAINMENT RATE FOR SHALLOW CONVECTION
786	! ENTRMID ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
787	! ENTRDD ENTRAINMENT RATE FOR CUMULUS DOWNDRAFTS
788	! CMFCTOP RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANCY
789	! LEVEL
790	! CMFCMAX MAXIMUM MASSFLUX VALUE ALLOWED FOR
791	! CMFCMIN MINIMUM MASSFLUX VALUE (FOR SAFETY)
792	! CMFDEPS FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
793	! CPRCON COEFFICIENT FOR CONVERSION FROM CLOUD WATER TO RAIN
794	!***REFERENCE.
795	! ----------
796	! PAPER ON MASSFLUX SCHEME (TIEDTKE,1989)
797	!-----------------------------------------------------------------
798	!-------------------------------------------------------------------
799	IMPLICIT NONE
800	!-------------------------------------------------------------------
801	INTEGER KLON, KLEV, KLEVP1
802	INTEGER KLEVM1
803	REAL ZTMST
804	REAL PSRAIN, PSEVAP, PSHEAT, PSDISS, PSMELT, ZCONS2
805	INTEGER JK,JL,IKB
806	REAL ZQUMQE, ZDQMIN, ZMFMAX, ZALVDCP, ZQALV
807	REAL ZHSAT, ZGAM, ZZZ, ZHHAT, ZBI, ZRO, ZDZ, ZDHDZ, ZDEPTH
808	REAL ZFAC, ZRH, ZPBMPT, DEPT, ZHT, ZEPS
809	INTEGER ICUM, ITOPM2
810	REAL PTEN(KLON,KLEV), PQEN(KLON,KLEV), &
811	PUEN(KLON,KLEV), PVEN(KLON,KLEV), &
812	PTTE(KLON,KLEV), PQTE(KLON,KLEV), &
813	PVOM(KLON,KLEV), PVOL(KLON,KLEV), &
814	PQSEN(KLON,KLEV), PGEO(KLON,KLEV), &
815	PAP(KLON,KLEV), PAPH(KLON,KLEVP1),&
816	PVERV(KLON,KLEV), PQHFL(KLON)
817	REAL PTU(KLON,KLEV), PQU(KLON,KLEV), &
818	PLU(KLON,KLEV), PLUDE(KLON,KLEV), &
819	PMFU(KLON,KLEV), PMFD(KLON,KLEV), &
820	PAPRC(KLON), PAPRS(KLON), &
821	PAPRSM(KLON), PRAIN(KLON), &
822	PRSFC(KLON), PSSFC(KLON)
823	REAL ZTENH(KLON,KLEV), ZQENH(KLON,KLEV),&
824	ZGEOH(KLON,KLEV), ZQSENH(KLON,KLEV),&
825	ZTD(KLON,KLEV), ZQD(KLON,KLEV), &
826	ZMFUS(KLON,KLEV), ZMFDS(KLON,KLEV), &
827	ZMFUQ(KLON,KLEV), ZMFDQ(KLON,KLEV), &
828	ZDMFUP(KLON,KLEV), ZDMFDP(KLON,KLEV),&
829	ZMFUL(KLON,KLEV), ZRFL(KLON), &
830	ZUU(KLON,KLEV), ZVU(KLON,KLEV), &
831	ZUD(KLON,KLEV), ZVD(KLON,KLEV)
832	REAL ZENTR(KLON), ZHCBASE(KLON), &
833	ZMFUB(KLON), ZMFUB1(KLON), &
834	ZDQPBL(KLON), ZDQCV(KLON)
835	REAL ZSFL(KLON), ZDPMEL(KLON,KLEV), &
836	PCTE(KLON,KLEV), ZCAPE(KLON), &
837	ZHEAT(KLON), ZHHATT(KLON,KLEV), &
838	ZHMIN(KLON), ZRELH(KLON)
839	REAL sig1(KLEV)
840	INTEGER ILAB(KLON,KLEV), IDTOP(KLON), &
841	ICTOP0(KLON), ILWMIN(KLON)
842	INTEGER KCBOT(KLON), KCTOP(KLON), &
843	KTYPE(KLON), IHMIN(KLON), &
844	KTOP0, lndj(KLON)
845	LOGICAL LDCUM(KLON)
846	LOGICAL LODDRAF(KLON), LLO1
847	!-------------------------------------------
848	! 1. SPECIFY CONSTANTS AND PARAMETERS
849	!-------------------------------------------
850	100 CONTINUE
851	ZCONS2=1./(G*ZTMST)
852	!--------------------------------------------------------------
853	!* 2. INITIALIZE VALUES AT VERTICAL GRID POINTS IN 'CUINI'
854	!--------------------------------------------------------------
855	200 CONTINUE
856	CALL CUINI &
857	(KLON, KLEV, KLEVP1, KLEVM1, PTEN, &
858	PQEN, PQSEN, PUEN, PVEN, PVERV, &
859	PGEO, PAPH, ZGEOH, ZTENH, ZQENH, &
860	ZQSENH, ILWMIN, PTU, PQU, ZTD, &
861	ZQD, ZUU, ZVU, ZUD, ZVD, &
862	PMFU, PMFD, ZMFUS, ZMFDS, ZMFUQ, &
863	ZMFDQ, ZDMFUP, ZDMFDP, ZDPMEL, PLU, &
864	PLUDE, ILAB)
865	!----------------------------------
866	!* 3.0 CLOUD BASE CALCULATIONS
867	!----------------------------------
868	300 CONTINUE
869	!* (A) DETERMINE CLOUD BASE VALUES IN 'CUBASE'
870	! -------------------------------------------
871	CALL CUBASE &
872	(KLON, KLEV, KLEVP1, KLEVM1, ZTENH, &
873	ZQENH, ZGEOH, PAPH, PTU, PQU, &
874	PLU, PUEN, PVEN, ZUU, ZVU, &
875	LDCUM, KCBOT, ILAB)
876	!* (B) DETERMINE TOTAL MOISTURE CONVERGENCE AND
877	!* THEN DECIDE ON TYPE OF CUMULUS CONVECTION
878	! -----------------------------------------
879	JK=1
880	DO 310 JL=1,KLON
881	ZDQCV(JL) =PQTE(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK))
882	ZDQPBL(JL)=0.0
883	IDTOP(JL)=0
884	310 CONTINUE
885	DO 320 JK=2,KLEV
886	DO 315 JL=1,KLON
887	ZDQCV(JL)=ZDQCV(JL)+PQTE(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK))
888	IF(JK.GE.KCBOT(JL)) ZDQPBL(JL)=ZDQPBL(JL)+PQTE(JL,JK) &
889	*(PAPH(JL,JK+1)-PAPH(JL,JK))
890	315 CONTINUE
891	320 CONTINUE
892	DO 340 JL=1,KLON
893	KTYPE(JL)=0
894	IF(ZDQCV(JL).GT.MAX(0.,1.1PQHFL(JL)G)) THEN
895	KTYPE(JL)=1
896	ELSE
897	KTYPE(JL)=2
898	ENDIF
899	!* (C) DETERMINE MOISTURE SUPPLY FOR BOUNDARY LAYER
900	!* AND DETERMINE CLOUD BASE MASSFLUX IGNORING
901	!* THE EFFECTS OF DOWNDRAFTS AT THIS STAGE
902	! ------------------------------------------
903	IKB=KCBOT(JL)
904	ZQUMQE=PQU(JL,IKB)+PLU(JL,IKB)-ZQENH(JL,IKB)
905	ZDQMIN=MAX(0.01*ZQENH(JL,IKB),1.E-10)
906	IF(ZDQPBL(JL).GT.0..AND.ZQUMQE.GT.ZDQMIN.AND.LDCUM(JL)) THEN
907	ZMFUB(JL)=ZDQPBL(JL)/(G*MAX(ZQUMQE,ZDQMIN))
908	ELSE
909	ZMFUB(JL)=0.01
910	LDCUM(JL)=.FALSE.
911	ENDIF
912	ZMFMAX=(PAPH(JL,IKB)-PAPH(JL,IKB-1))*ZCONS2
913	ZMFUB(JL)=MIN(ZMFUB(JL),ZMFMAX)
914	!------------------------------------------------------
915	!* 4.0 DETERMINE CLOUD ASCENT FOR ENTRAINING PLUME
916	!------------------------------------------------------
917	400 CONTINUE
918	!* (A) ESTIMATE CLOUD HEIGHT FOR ENTRAINMENT/DETRAINMENT
919	!* CALCULATIONS IN CUASC (MAX.POSSIBLE CLOUD HEIGHT
920	!* FOR NON-ENTRAINING PLUME, FOLLOWING A.-S.,1974)
921	! -------------------------------------------------------------
922	IKB=KCBOT(JL)
923	ZHCBASE(JL)=CPDPTU(JL,IKB)+ZGEOH(JL,IKB)+ALVPQU(JL,IKB)
924	ICTOP0(JL)=KCBOT(JL)-1
925	340 CONTINUE
926	ZALVDCP=ALV/CPD
927	ZQALV=1./ALV
928	DO 420 JK=KLEVM1,3,-1
929	DO 420 JL=1,KLON
930	ZHSAT=CPDZTENH(JL,JK)+ZGEOH(JL,JK)+ALVZQSENH(JL,JK)
931	ZGAM=C5LESZALVDCPZQSENH(JL,JK)/ &
932	((1.-VTMPC1ZQSENH(JL,JK))(ZTENH(JL,JK)-C4LES)**2)
933	ZZZ=CPDZTENH(JL,JK)0.608
934	ZHHAT=ZHSAT-(ZZZ+ZGAMZZZ)/(1.+ZGAMZZZZQALV) &
935	MAX(ZQSENH(JL,JK)-ZQENH(JL,JK),0.)
936	ZHHATT(JL,JK)=ZHHAT
937	IF(JK.LT.ICTOP0(JL).AND.ZHCBASE(JL).GT.ZHHAT) ICTOP0(JL)=JK
938	420 CONTINUE
939	DO 430 JL=1,KLON
940	JK=KCBOT(JL)
941	ZHSAT=CPDZTENH(JL,JK)+ZGEOH(JL,JK)+ALVZQSENH(JL,JK)
942	ZGAM=C5LESZALVDCPZQSENH(JL,JK)/ &
943	((1.-VTMPC1ZQSENH(JL,JK))(ZTENH(JL,JK)-C4LES)**2)
944	ZZZ=CPDZTENH(JL,JK)0.608
945	ZHHAT=ZHSAT-(ZZZ+ZGAMZZZ)/(1.+ZGAMZZZZQALV) &
946	MAX(ZQSENH(JL,JK)-ZQENH(JL,JK),0.)
947	ZHHATT(JL,JK)=ZHHAT
948	430 CONTINUE
949	!
950	! Find lowest possible org. detrainment level
951	!
952	DO 440 JL = 1, KLON
953	ZHMIN(JL) = 0.
954	IF( LDCUM(JL).AND.KTYPE(JL).EQ.1 ) THEN
955	IHMIN(JL) = KCBOT(JL)
956	ELSE
957	IHMIN(JL) = -1
958	END IF
959	440 CONTINUE
960	!
961	ZBI = 1./(25.*G)
962	DO 450 JK = KLEV, 1, -1
963	DO 450 JL = 1, KLON
964	LLO1 = LDCUM(JL).AND.KTYPE(JL).EQ.1.AND.IHMIN(JL).EQ.KCBOT(JL)
965	IF (LLO1.AND.JK.LT.KCBOT(JL).AND.JK.GE.ICTOP0(JL)) THEN
966	IKB = KCBOT(JL)
967	ZRO = RDZTENH(JL,JK)/(GPAPH(JL,JK))
968	ZDZ = (PAPH(JL,JK)-PAPH(JL,JK-1))*ZRO
969	ZDHDZ=(CPD(PTEN(JL,JK-1)-PTEN(JL,JK))+ALV(PQEN(JL,JK-1)- &
970	PQEN(JL,JK))+(PGEO(JL,JK-1)-PGEO(JL,JK)))*G/(PGEO(JL, &
971	JK-1)-PGEO(JL,JK))
972	ZDEPTH = ZGEOH(JL,JK) - ZGEOH(JL,IKB)
973	ZFAC = SQRT(1.+ZDEPTH*ZBI)
974	ZHMIN(JL) = ZHMIN(JL) + ZDHDZZFACZDZ
975	ZRH = -ALV(ZQSENH(JL,JK)-ZQENH(JL,JK))ZFAC
976	IF (ZHMIN(JL).GT.ZRH) IHMIN(JL) = JK
977	END IF
978	450 CONTINUE
979	DO 460 JL = 1, KLON
980	IF (LDCUM(JL).AND.KTYPE(JL).EQ.1) THEN
981	IF (IHMIN(JL).LT.ICTOP0(JL)) IHMIN(JL) = ICTOP0(JL)
982	END IF
983	if(nentr.eq.1) then
984	IF(KTYPE(JL).EQ.1) THEN
985	ZENTR(JL)=ENTRPEN
986	ELSE
987	ZENTR(JL)=ENTRSCV
988	ENDIF
989	if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.1
990	else
991	ZDEPTH=ZRG*(ZGEOH(JL,ICTOP0(JL))-ZGEOH(JL,KCBOT(JL)))
992	ZENTR(JL)=MAX(ENTRPEN,1.5/MAX(500.0,ZDEPTH))
993	if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.1
994	endif
995	460 CONTINUE
996	!* (B) DO ASCENT IN 'CUASC'IN ABSENCE OF DOWNDRAFTS
997	!----------------------------------------------------------
998	CALL CUASC_NEW &
999	(KLON, KLEV, KLEVP1, KLEVM1, ZTENH, &
1000	ZQENH, PUEN, PVEN, PTEN, PQEN, &
1001	PQSEN, PGEO, ZGEOH, PAP, PAPH, &
1002	PQTE, PVERV, ILWMIN, LDCUM, ZHCBASE, &
1003	KTYPE, ILAB, PTU, PQU, PLU, &
1004	ZUU, ZVU, PMFU, ZMFUB, ZENTR, &
1005	ZMFUS, ZMFUQ, ZMFUL, PLUDE, ZDMFUP, &
1006	KCBOT, KCTOP, ICTOP0, ICUM, ZTMST, &
1007	IHMIN, ZHHATT, ZQSENH)
1008	IF(ICUM.EQ.0) GO TO 1000
1009	!* (C) CHECK CLOUD DEPTH AND CHANGE ENTRAINMENT RATE ACCORDINGLY
1010	! CALCULATE PRECIPITATION RATE (FOR DOWNDRAFT CALCULATION)
1011	!------------------------------------------------------------------
1012	DO 480 JL=1,KLON
1013	ZPBMPT=PAPH(JL,KCBOT(JL))-PAPH(JL,KCTOP(JL))
1014	IF(LDCUM(JL)) ICTOP0(JL)=KCTOP(JL)
1015	IF(LDCUM(JL).AND.KTYPE(JL).EQ.1.AND.ZPBMPT.LT.ZDNOPRC) KTYPE(JL)=2
1016	IF(KTYPE(JL).EQ.2.and.nentr.eq.1) then
1017	ZENTR(JL)=ENTRSCV
1018	if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.1
1019	endif
1020	if(nentr.eq.2) then
1021	ZDEPTH=ZRG*(ZGEOH(JL,KCTOP(JL))-ZGEOH(JL,KCBOT(JL)))
1022	ZENTR(JL)=MAX(ENTRPEN,1.5/MAX(500.0,ZDEPTH))
1023	if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.1
1024	endif
1025	ZRFL(JL)=ZDMFUP(JL,1)
1026	480 CONTINUE
1027	DO 490 JK=2,KLEV
1028	DO 490 JL=1,KLON
1029	ZRFL(JL)=ZRFL(JL)+ZDMFUP(JL,JK)
1030	490 CONTINUE
1031	!-----------------------------------------
1032	!* 5.0 CUMULUS DOWNDRAFT CALCULATIONS
1033	!-----------------------------------------
1034	500 CONTINUE
1035	IF(LMFDD) THEN
1036	!* (A) DETERMINE LFS IN 'CUDLFS'
1037	!--------------------------------------
1038	CALL CUDLFS &
1039	(KLON, KLEV, KLEVP1, ZTENH, ZQENH, &
1040	PUEN, PVEN, ZGEOH, PAPH, PTU, &
1041	PQU, ZUU, ZVU, LDCUM, KCBOT, &
1042	KCTOP, ZMFUB, ZRFL, ZTD, ZQD, &
1043	ZUD, ZVD, PMFD, ZMFDS, ZMFDQ, &
1044	ZDMFDP, IDTOP, LODDRAF)
1045	!* (B) DETERMINE DOWNDRAFT T,Q AND FLUXES IN 'CUDDRAF'
1046	!------------------------------------------------------------
1047	CALL CUDDRAF &
1048	(KLON, KLEV, KLEVP1, ZTENH, ZQENH, &
1049	PUEN, PVEN, ZGEOH, PAPH, ZRFL, &
1050	LODDRAF, ZTD, ZQD, ZUD, ZVD, &
1051	PMFD, ZMFDS, ZMFDQ, ZDMFDP)
1052	!* (C) RECALCULATE CONVECTIVE FLUXES DUE TO EFFECT OF
1053	! DOWNDRAFTS ON BOUNDARY LAYER MOISTURE BUDGET
1054	!-----------------------------------------------------------
1055	END IF
1056	!
1057	!-- 5.1 Recalculate cloud base massflux from a cape closure
1058	! for deep convection (ktype=1) and by PBL equilibrium
1059	! taking downdrafts into account for shallow convection
1060	! (ktype=2)
1061	! implemented by Y. WANG based on ECHAM4 in Nov. 2001.
1062	!
1063	DO 510 JL=1,KLON
1064	ZHEAT(JL)=0.0
1065	ZCAPE(JL)=0.0
1066	ZRELH(JL)=0.0
1067	ZMFUB1(JL)=ZMFUB(JL)
1068	510 CONTINUE
1069	!
1070	DO 511 JL=1,KLON
1071	IF(LDCUM(JL).AND.KTYPE(JL).EQ.1) THEN
1072	KTOP0=MAX(12,KCTOP(JL))
1073	DO JK=2,KLEV
1074	IF(JK.LE.KCBOT(JL).AND.JK.GT.KCTOP(JL)) THEN
1075	ZRO=PAPH(JL,JK)/(RD*ZTENH(JL,JK))
1076	ZDZ=(PAPH(JL,JK)-PAPH(JL,JK-1))/(G*ZRO)
1077	ZHEAT(JL)=ZHEAT(JL)+((PTEN(JL,JK-1)-PTEN(JL,JK) &
1078	+GZDZ/CPD)/ZTENH(JL,JK)+0.608(PQEN(JL,JK-1)- &
1079	PQEN(JL,JK)))(PMFU(JL,JK)+PMFD(JL,JK))G/ZRO
1080	ZCAPE(JL)=ZCAPE(JL)+G((PTU(JL,JK)(1.+.608*PQU(JL,JK) &
1081	-PLU(JL,JK)))/(ZTENH(JL,JK)(1.+.608ZQENH(JL,JK))) &
1082	-1.0)*ZDZ
1083	ENDIF
1084	IF(JK.LE.KCBOT(JL).AND.JK.GT.KTOP0) THEN
1085	dept=(PAPH(JL,JK)-PAPH(JL,JK-1))/(PAPH(JL,KCBOT(JL))- &
1086	PAPH(JL,KTOP0))
1087	ZRELH(JL)=ZRELH(JL)+dept*PQEN(JL,JK)/PQSEN(JL,JK)
1088	ENDIF
1089	ENDDO
1090	!
1091	IF(ZRELH(JL).GE.CRIRH) THEN
1092	IKB=KCBOT(JL)
1093	! ZHT=MAX(0.0,(ZCAPE(JL)-300.0))/(ZTAU*ZHEAT(JL))
1094	ZHT=MAX(0.0,(ZCAPE(JL)-0.0))/(ZTAU*ZHEAT(JL))
1095	ZMFUB1(JL)=MAX(ZMFUB(JL)*ZHT,0.01)
1096	ZMFMAX=(PAPH(JL,IKB)-PAPH(JL,IKB-1))*ZCONS2
1097	ZMFUB1(JL)=MIN(ZMFUB1(JL),ZMFMAX)
1098	ELSE
1099	ZMFUB1(JL)=0.01
1100	ZMFUB(JL)=0.01
1101	LDCUM(JL)=.FALSE.
1102	ENDIF
1103	ENDIF
1104	511 CONTINUE
1105	!
1106	!* 5.2 RECALCULATE CONVECTIVE FLUXES DUE TO EFFECT OF
1107	! DOWNDRAFTS ON BOUNDARY LAYER MOISTURE BUDGET
1108	!--------------------------------------------------------
1109	DO 512 JL=1,KLON
1110	IF(KTYPE(JL).NE.1) THEN
1111	IKB=KCBOT(JL)
1112	IF(PMFD(JL,IKB).LT.0.0.AND.LODDRAF(JL)) THEN
1113	ZEPS=CMFDEPS
1114	ELSE
1115	ZEPS=0.
1116	ENDIF
1117	ZQUMQE=PQU(JL,IKB)+PLU(JL,IKB)- &
1118	ZEPSZQD(JL,IKB)-(1.-ZEPS)ZQENH(JL,IKB)
1119	ZDQMIN=MAX(0.01*ZQENH(JL,IKB),1.E-10)
1120	ZMFMAX=(PAPH(JL,IKB)-PAPH(JL,IKB-1))*ZCONS2
1121	IF(ZDQPBL(JL).GT.0..AND.ZQUMQE.GT.ZDQMIN.AND.LDCUM(JL) &
1122	.AND.ZMFUB(JL).LT.ZMFMAX) THEN
1123	ZMFUB1(JL)=ZDQPBL(JL)/(G*MAX(ZQUMQE,ZDQMIN))
1124	ELSE
1125	ZMFUB1(JL)=ZMFUB(JL)
1126	ENDIF
1127	LLO1=(KTYPE(JL).EQ.2).AND.ABS(ZMFUB1(JL) &
1128	-ZMFUB(JL)).LT.0.2*ZMFUB(JL)
1129	IF(.NOT.LLO1) ZMFUB1(JL)=ZMFUB(JL)
1130	ZMFUB1(JL)=MIN(ZMFUB1(JL),ZMFMAX)
1131	END IF
1132	512 CONTINUE
1133	DO 530 JK=1,KLEV
1134	DO 530 JL=1,KLON
1135	IF(LDCUM(JL)) THEN
1136	ZFAC=ZMFUB1(JL)/MAX(ZMFUB(JL),1.E-10)
1137	PMFD(JL,JK)=PMFD(JL,JK)*ZFAC
1138	ZMFDS(JL,JK)=ZMFDS(JL,JK)*ZFAC
1139	ZMFDQ(JL,JK)=ZMFDQ(JL,JK)*ZFAC
1140	ZDMFDP(JL,JK)=ZDMFDP(JL,JK)*ZFAC
1141	ELSE
1142	PMFD(JL,JK)=0.0
1143	ZMFDS(JL,JK)=0.0
1144	ZMFDQ(JL,JK)=0.0
1145	ZDMFDP(JL,JK)=0.0
1146	ENDIF
1147	530 CONTINUE
1148	DO 538 JL=1,KLON
1149	IF(LDCUM(JL)) THEN
1150	ZMFUB(JL)=ZMFUB1(JL)
1151	ELSE
1152	ZMFUB(JL)=0.0
1153	ENDIF
1154	538 CONTINUE
1155	!
1156	!---------------------------------------------------------------
1157	!* 6.0 DETERMINE FINAL CLOUD ASCENT FOR ENTRAINING PLUME
1158	!* FOR PENETRATIVE CONVECTION (TYPE=1),
1159	!* FOR SHALLOW TO MEDIUM CONVECTION (TYPE=2)
1160	!* AND FOR MID-LEVEL CONVECTION (TYPE=3).
1161	!---------------------------------------------------------------
1162	600 CONTINUE
1163	CALL CUASC_NEW &
1164	(KLON, KLEV, KLEVP1, KLEVM1, ZTENH, &
1165	ZQENH, PUEN, PVEN, PTEN, PQEN, &
1166	PQSEN, PGEO, ZGEOH, PAP, PAPH, &
1167	PQTE, PVERV, ILWMIN, LDCUM, ZHCBASE,&
1168	KTYPE, ILAB, PTU, PQU, PLU, &
1169	ZUU, ZVU, PMFU, ZMFUB, ZENTR, &
1170	ZMFUS, ZMFUQ, ZMFUL, PLUDE, ZDMFUP, &
1171	KCBOT, KCTOP, ICTOP0, ICUM, ZTMST, &
1172	IHMIN, ZHHATT, ZQSENH)
1173	!----------------------------------------------------------
1174	!* 7.0 DETERMINE FINAL CONVECTIVE FLUXES IN 'CUFLX'
1175	!----------------------------------------------------------
1176	700 CONTINUE
1177	CALL CUFLX &
1178	(KLON, KLEV, KLEVP1, PQEN, PQSEN, &
1179	ZTENH, ZQENH, PAPH, ZGEOH, KCBOT, &
1180	KCTOP, IDTOP, KTYPE, LODDRAF, LDCUM, &
1181	PMFU, PMFD, ZMFUS, ZMFDS, ZMFUQ, &
1182	ZMFDQ, ZMFUL, PLUDE, ZDMFUP, ZDMFDP, &
1183	ZRFL, PRAIN, PTEN, ZSFL, ZDPMEL, &
1184	ITOPM2, ZTMST, sig1)
1185	!----------------------------------------------------------------
1186	!* 8.0 UPDATE TENDENCIES FOR T AND Q IN SUBROUTINE CUDTDQ
1187	!----------------------------------------------------------------
1188	800 CONTINUE
1189	CALL CUDTDQ &
1190	(KLON, KLEV, KLEVP1, ITOPM2, PAPH, &
1191	LDCUM, PTEN, PTTE, PQTE, ZMFUS, &
1192	ZMFDS, ZMFUQ, ZMFDQ, ZMFUL, ZDMFUP, &
1193	ZDMFDP, ZTMST, ZDPMEL, PRAIN, ZRFL, &
1194	ZSFL, PSRAIN, PSEVAP, PSHEAT, PSMELT, &
1195	PRSFC, PSSFC, PAPRC, PAPRSM, PAPRS, &
1196	PQEN, PQSEN, PLUDE, PCTE)
1197	!----------------------------------------------------------------
1198	!* 9.0 UPDATE TENDENCIES FOR U AND U IN SUBROUTINE CUDUDV
1199	!----------------------------------------------------------------
1200	900 CONTINUE
1201	IF(LMFDUDV) THEN
1202	CALL CUDUDV &
1203	(KLON, KLEV, KLEVP1, ITOPM2, KTYPE, &
1204	KCBOT, PAPH, LDCUM, PUEN, PVEN, &
1205	PVOM, PVOL, ZUU, ZUD, ZVU, &
1206	ZVD, PMFU, PMFD, PSDISS)
1207	END IF
1208	1000 CONTINUE
1209	RETURN
1210	END SUBROUTINE CUMASTR_NEW
1211	!
1212
1213	!#############################################################
1214	!
1215	! LEVEL 3 SUBROUTINEs
1216	!
1217	!#############################################################
1218	!**********************************************
1219	! SUBROUTINE CUINI
1220	!**********************************************
1221	!
1222	SUBROUTINE CUINI &
1223	(KLON, KLEV, KLEVP1, KLEVM1, PTEN, &
1224	PQEN, PQSEN, PUEN, PVEN, PVERV, &
1225	PGEO, PAPH, PGEOH, PTENH, PQENH, &
1226	PQSENH, KLWMIN, PTU, PQU, PTD, &
1227	PQD, PUU, PVU, PUD, PVD, &
1228	PMFU, PMFD, PMFUS, PMFDS, PMFUQ, &
1229	PMFDQ, PDMFUP, PDMFDP, PDPMEL, PLU, &
1230	PLUDE, KLAB)
1231	! M.TIEDTKE E.C.M.W.F. 12/89
1232	!***PURPOSE
1233	! -------
1234	! THIS ROUTINE INTERPOLATES LARGE-SCALE FIELDS OF T,Q ETC.
1235	! TO HALF LEVELS (I.E. GRID FOR MASSFLUX SCHEME),
1236	! AND INITIALIZES VALUES FOR UPDRAFTS AND DOWNDRAFTS
1237	!***INTERFACE
1238	! ---------
1239	! THIS ROUTINE IS CALLED FROM CUMASTR.
1240	!***METHOD.
1241	! --------
1242	! FOR EXTRAPOLATION TO HALF LEVELS SEE TIEDTKE(1989)
1243	!***EXTERNALS
1244	! ---------
1245	! CUADJTQ TO SPECIFY QS AT HALF LEVELS
1246	! ----------------------------------------------------------------
1247	!-------------------------------------------------------------------
1248	IMPLICIT NONE
1249	!-------------------------------------------------------------------
1250	INTEGER KLON, KLEV, KLEVP1
1251	INTEGER klevm1
1252	INTEGER JK,JL,IK, ICALL
1253	REAL ZDP, ZZS
1254	REAL PTEN(KLON,KLEV), PQEN(KLON,KLEV), &
1255	PUEN(KLON,KLEV), PVEN(KLON,KLEV), &
1256	PQSEN(KLON,KLEV), PVERV(KLON,KLEV), &
1257	PGEO(KLON,KLEV), PGEOH(KLON,KLEV), &
1258	PAPH(KLON,KLEVP1), PTENH(KLON,KLEV), &
1259	PQENH(KLON,KLEV), PQSENH(KLON,KLEV)
1260	REAL PTU(KLON,KLEV), PQU(KLON,KLEV), &
1261	PTD(KLON,KLEV), PQD(KLON,KLEV), &
1262	PUU(KLON,KLEV), PUD(KLON,KLEV), &
1263	PVU(KLON,KLEV), PVD(KLON,KLEV), &
1264	PMFU(KLON,KLEV), PMFD(KLON,KLEV), &
1265	PMFUS(KLON,KLEV), PMFDS(KLON,KLEV), &
1266	PMFUQ(KLON,KLEV), PMFDQ(KLON,KLEV), &
1267	PDMFUP(KLON,KLEV), PDMFDP(KLON,KLEV), &
1268	PLU(KLON,KLEV), PLUDE(KLON,KLEV)
1269	REAL ZWMAX(KLON), ZPH(KLON), &
1270	PDPMEL(KLON,KLEV)
1271	INTEGER KLAB(KLON,KLEV), KLWMIN(KLON)
1272	LOGICAL LOFLAG(KLON)
1273	!------------------------------------------------------------
1274	!* 1. SPECIFY LARGE SCALE PARAMETERS AT HALF LEVELS
1275	!* ADJUST TEMPERATURE FIELDS IF STATICLY UNSTABLE
1276	!* FIND LEVEL OF MAXIMUM VERTICAL VELOCITY
1277	! -----------------------------------------------------------
1278	100 CONTINUE
1279	ZDP=0.5
1280	DO 130 JK=2,KLEV
1281	DO 110 JL=1,KLON
1282	PGEOH(JL,JK)=PGEO(JL,JK)+(PGEO(JL,JK-1)-PGEO(JL,JK))*ZDP
1283	PTENH(JL,JK)=(MAX(CPD*PTEN(JL,JK-1)+PGEO(JL,JK-1), &
1284	CPDPTEN(JL,JK)+PGEO(JL,JK))-PGEOH(JL,JK))RCPD
1285	PQSENH(JL,JK)=PQSEN(JL,JK-1)
1286	ZPH(JL)=PAPH(JL,JK)
1287	LOFLAG(JL)=.TRUE.
1288	110 CONTINUE
1289	IK=JK
1290	ICALL=0
1291	CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTENH,PQSENH,LOFLAG,ICALL)
1292	DO 120 JL=1,KLON
1293	PQENH(JL,JK)=MIN(PQEN(JL,JK-1),PQSEN(JL,JK-1)) &
1294	+(PQSENH(JL,JK)-PQSEN(JL,JK-1))
1295	PQENH(JL,JK)=MAX(PQENH(JL,JK),0.)
1296	120 CONTINUE
1297	130 CONTINUE
1298	DO 140 JL=1,KLON
1299	PTENH(JL,KLEV)=(CPD*PTEN(JL,KLEV)+PGEO(JL,KLEV)- &
1300	PGEOH(JL,KLEV))*RCPD
1301	PQENH(JL,KLEV)=PQEN(JL,KLEV)
1302	PTENH(JL,1)=PTEN(JL,1)
1303	PQENH(JL,1)=PQEN(JL,1)
1304	PGEOH(JL,1)=PGEO(JL,1)
1305	KLWMIN(JL)=KLEV
1306	ZWMAX(JL)=0.
1307	140 CONTINUE
1308	DO 160 JK=KLEVM1,2,-1
1309	DO 150 JL=1,KLON
1310	ZZS=MAX(CPD*PTENH(JL,JK)+PGEOH(JL,JK), &
1311	CPD*PTENH(JL,JK+1)+PGEOH(JL,JK+1))
1312	PTENH(JL,JK)=(ZZS-PGEOH(JL,JK))*RCPD
1313	150 CONTINUE
1314	160 CONTINUE
1315	DO 190 JK=KLEV,3,-1
1316	DO 180 JL=1,KLON
1317	IF(PVERV(JL,JK).LT.ZWMAX(JL)) THEN
1318	ZWMAX(JL)=PVERV(JL,JK)
1319	KLWMIN(JL)=JK
1320	END IF
1321	180 CONTINUE
1322	190 CONTINUE
1323	!-----------------------------------------------------------
1324	!* 2.0 INITIALIZE VALUES FOR UPDRAFTS AND DOWNDRAFTS
1325	!-----------------------------------------------------------
1326	200 CONTINUE
1327	DO 230 JK=1,KLEV
1328	IK=JK-1
1329	IF(JK.EQ.1) IK=1
1330	DO 220 JL=1,KLON
1331	PTU(JL,JK)=PTENH(JL,JK)
1332	PTD(JL,JK)=PTENH(JL,JK)
1333	PQU(JL,JK)=PQENH(JL,JK)
1334	PQD(JL,JK)=PQENH(JL,JK)
1335	PLU(JL,JK)=0.
1336	PUU(JL,JK)=PUEN(JL,IK)
1337	PUD(JL,JK)=PUEN(JL,IK)
1338	PVU(JL,JK)=PVEN(JL,IK)
1339	PVD(JL,JK)=PVEN(JL,IK)
1340	PMFU(JL,JK)=0.
1341	PMFD(JL,JK)=0.
1342	PMFUS(JL,JK)=0.
1343	PMFDS(JL,JK)=0.
1344	PMFUQ(JL,JK)=0.
1345	PMFDQ(JL,JK)=0.
1346	PDMFUP(JL,JK)=0.
1347	PDMFDP(JL,JK)=0.
1348	PDPMEL(JL,JK)=0.
1349	PLUDE(JL,JK)=0.
1350	KLAB(JL,JK)=0
1351	220 CONTINUE
1352	230 CONTINUE
1353	RETURN
1354	END SUBROUTINE CUINI
1355
1356	!**********************************************
1357	! SUBROUTINE CUBASE
1358	!**********************************************
1359	SUBROUTINE CUBASE &
1360	(KLON, KLEV, KLEVP1, KLEVM1, PTENH, &
1361	PQENH, PGEOH, PAPH, PTU, PQU, &
1362	PLU, PUEN, PVEN, PUU, PVU, &
1363	LDCUM, KCBOT, KLAB)
1364	! THIS ROUTINE CALCULATES CLOUD BASE VALUES (T AND Q)
1365	! FOR CUMULUS PARAMETERIZATION
1366	! M.TIEDTKE E.C.M.W.F. 7/86 MODIF. 12/89
1367	!***PURPOSE.
1368	! --------
1369	! TO PRODUCE CLOUD BASE VALUES FOR CU-PARAMETRIZATION
1370	!***INTERFACE
1371	! ---------
1372	! THIS ROUTINE IS CALLED FROM CUMASTR.
1373	! INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS.
1374	! IT RETURNS CLOUD BASE VALUES AND FLAGS AS FOLLOWS;
1375	! KLAB=1 FOR SUBCLOUD LEVELS
1376	! KLAB=2 FOR CONDENSATION LEVEL
1377	!***METHOD.
1378	! --------
1379	! LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE
1380	! (NON ENTRAINING PLUME,I.E.CONSTANT MASSFLUX)
1381	!***EXTERNALS
1382	! ---------
1383	! CUADJTQ FOR ADJUSTING T AND Q DUE TO CONDENSATION IN ASCENT
1384	! ----------------------------------------------------------------
1385	!-------------------------------------------------------------------
1386	IMPLICIT NONE
1387	!-------------------------------------------------------------------
1388	INTEGER KLON, KLEV, KLEVP1
1389	INTEGER klevm1
1390	INTEGER JL,JK,IS,IK,ICALL,IKB
1391	REAL ZBUO,ZZ
1392	REAL PTENH(KLON,KLEV), PQENH(KLON,KLEV), &
1393	PGEOH(KLON,KLEV), PAPH(KLON,KLEVP1)
1394	REAL PTU(KLON,KLEV), PQU(KLON,KLEV), &
1395	PLU(KLON,KLEV)
1396	REAL PUEN(KLON,KLEV), PVEN(KLON,KLEV), &
1397	PUU(KLON,KLEV), PVU(KLON,KLEV)
1398	REAL ZQOLD(KLON,KLEV), ZPH(KLON)
1399	INTEGER KLAB(KLON,KLEV), KCBOT(KLON)
1400	LOGICAL LDCUM(KLON), LOFLAG(KLON)
1401	!***INPUT VARIABLES:
1402	! PTENH [ZTENH] - Environment Temperature on half levels. (CUINI)
1403	! PQENH [ZQENH] - Env. specific humidity on half levels. (CUINI)
1404	! PGEOH [ZGEOH] - Geopotential on half levels, (MSSFLX)
1405	! PAPH - Pressure of half levels. (MSSFLX)
1406	!***VARIABLES MODIFIED BY CUBASE:
1407	! LDCUM - Logical denoting profiles. (CUBASE)
1408	! KTYPE - Convection type - 1: Penetrative (CUMASTR)
1409	! 2: Stratocumulus (CUMASTR)
1410	! 3: Mid-level (CUASC)
1411	! PTU - Cloud Temperature.
1412	! PQU - Cloud specific Humidity.
1413	! PLU - Cloud Liquid Water (Moisture condensed out)
1414	! KCBOT - Cloud Base Level. (CUBASE)
1415	! KLAB [ILAB] - Level Label - 1: Sub-cloud layer (CUBASE)
1416	!------------------------------------------------
1417	! 1. INITIALIZE VALUES AT LIFTING LEVEL
1418	!------------------------------------------------
1419	100 CONTINUE
1420	DO 110 JL=1,KLON
1421	KLAB(JL,KLEV)=1
1422	KCBOT(JL)=KLEVM1
1423	LDCUM(JL)=.FALSE.
1424	PUU(JL,KLEV)=PUEN(JL,KLEV)*(PAPH(JL,KLEVP1)-PAPH(JL,KLEV))
1425	PVU(JL,KLEV)=PVEN(JL,KLEV)*(PAPH(JL,KLEVP1)-PAPH(JL,KLEV))
1426	110 CONTINUE
1427	!-------------------------------------------------------
1428	! 2.0 DO ASCENT IN SUBCLOUD LAYER,
1429	! CHECK FOR EXISTENCE OF CONDENSATION LEVEL,
1430	! ADJUST T,Q AND L ACCORDINGLY IN CUADJTQ,
1431	! CHECK FOR BUOYANCY AND SET FLAGS
1432	!-------------------------------------------------------
1433	DO 200 JK=1,KLEV
1434	DO 200 JL=1,KLON
1435	ZQOLD(JL,JK)=0.0
1436	200 CONTINUE
1437	DO 290 JK=KLEVM1,2,-1
1438	IS=0
1439	DO 210 JL=1,KLON
1440	IF(KLAB(JL,JK+1).EQ.1) THEN
1441	IS=IS+1
1442	LOFLAG(JL)=.TRUE.
1443	ELSE
1444	LOFLAG(JL)=.FALSE.
1445	ENDIF
1446	ZPH(JL)=PAPH(JL,JK)
1447	210 CONTINUE
1448	IF(IS.EQ.0) GO TO 290
1449	DO 220 JL=1,KLON
1450	IF(LOFLAG(JL)) THEN
1451	PQU(JL,JK)=PQU(JL,JK+1)
1452	PTU(JL,JK)=(CPD*PTU(JL,JK+1)+PGEOH(JL,JK+1) &
1453	-PGEOH(JL,JK))*RCPD
1454	ZBUO=PTU(JL,JK)(1.+VTMPC1PQU(JL,JK))- &
1455	PTENH(JL,JK)(1.+VTMPC1PQENH(JL,JK))+ZBUO0
1456	IF(ZBUO.GT.0.) KLAB(JL,JK)=1
1457	ZQOLD(JL,JK)=PQU(JL,JK)
1458	END IF
1459	220 CONTINUE
1460	IK=JK
1461	ICALL=1
1462	CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTU,PQU,LOFLAG,ICALL)
1463	DO 240 JL=1,KLON
1464	IF(LOFLAG(JL).AND.PQU(JL,JK).NE.ZQOLD(JL,JK)) THEN
1465	KLAB(JL,JK)=2
1466	PLU(JL,JK)=PLU(JL,JK)+ZQOLD(JL,JK)-PQU(JL,JK)
1467	ZBUO=PTU(JL,JK)(1.+VTMPC1PQU(JL,JK))- &
1468	PTENH(JL,JK)(1.+VTMPC1PQENH(JL,JK))+ZBUO0
1469	IF(ZBUO.GT.0.) THEN
1470	KCBOT(JL)=JK
1471	LDCUM(JL)=.TRUE.
1472	END IF
1473	END IF
1474	240 CONTINUE
1475	! CALCULATE AVERAGES OF U AND V FOR SUBCLOUD ARA,.
1476	! THE VALUES WILL BE USED TO DEFINE CLOUD BASE VALUES.
1477	IF(LMFDUDV) THEN
1478	DO 250 JL=1,KLON
1479	IF(JK.GE.KCBOT(JL)) THEN
1480	PUU(JL,KLEV)=PUU(JL,KLEV)+ &
1481	PUEN(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK))
1482	PVU(JL,KLEV)=PVU(JL,KLEV)+ &
1483	PVEN(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK))
1484	END IF
1485	250 CONTINUE
1486	END IF
1487	290 CONTINUE
1488	IF(LMFDUDV) THEN
1489	DO 310 JL=1,KLON
1490	IF(LDCUM(JL)) THEN
1491	IKB=KCBOT(JL)
1492	ZZ=1./(PAPH(JL,KLEVP1)-PAPH(JL,IKB))
1493	PUU(JL,KLEV)=PUU(JL,KLEV)*ZZ
1494	PVU(JL,KLEV)=PVU(JL,KLEV)*ZZ
1495	ELSE
1496	PUU(JL,KLEV)=PUEN(JL,KLEVM1)
1497	PVU(JL,KLEV)=PVEN(JL,KLEVM1)
1498	END IF
1499	310 CONTINUE
1500	END IF
1501	RETURN
1502	END SUBROUTINE CUBASE
1503
1504	!
1505	!**********************************************
1506	! SUBROUTINE CUASC_NEW
1507	!**********************************************
1508	SUBROUTINE CUASC_NEW &
1509	(KLON, KLEV, KLEVP1, KLEVM1, PTENH, &
1510	PQENH, PUEN, PVEN, PTEN, PQEN, &
1511	PQSEN, PGEO, PGEOH, PAP, PAPH, &
1512	PQTE, PVERV, KLWMIN, LDCUM, PHCBASE,&
1513	KTYPE, KLAB, PTU, PQU, PLU, &
1514	PUU, PVU, PMFU, PMFUB, PENTR, &
1515	PMFUS, PMFUQ, PMFUL, PLUDE, PDMFUP, &
1516	KCBOT, KCTOP, KCTOP0, KCUM, ZTMST, &
1517	KHMIN, PHHATT, PQSENH)
1518	! THIS ROUTINE DOES THE CALCULATIONS FOR CLOUD ASCENTS
1519	! FOR CUMULUS PARAMETERIZATION
1520	! M.TIEDTKE E.C.M.W.F. 7/86 MODIF. 12/89
1521	! Y.WANG IPRC 11/01 MODIF.
1522	!***PURPOSE.
1523	! --------
1524	! TO PRODUCE CLOUD ASCENTS FOR CU-PARAMETRIZATION
1525	! (VERTICAL PROFILES OF T,Q,L,U AND V AND CORRESPONDING
1526	! FLUXES AS WELL AS PRECIPITATION RATES)
1527	!***INTERFACE
1528	! ---------
1529	! THIS ROUTINE IS CALLED FROM CUMASTR.
1530	!***METHOD.
1531	! --------
1532	! LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE
1533	! AND THEN CALCULATE MOIST ASCENT FOR
1534	! ENTRAINING/DETRAINING PLUME.
1535	! ENTRAINMENT AND DETRAINMENT RATES DIFFER FOR
1536	! SHALLOW AND DEEP CUMULUS CONVECTION.
1537	! IN CASE THERE IS NO PENETRATIVE OR SHALLOW CONVECTION
1538	! CHECK FOR POSSIBILITY OF MID LEVEL CONVECTION
1539	! (CLOUD BASE VALUES CALCULATED IN CUBASMC)
1540	!***EXTERNALS
1541	! ---------
1542	! CUADJTQ ADJUST T AND Q DUE TO CONDENSATION IN ASCENT
1543	! CUENTR_NEW CALCULATE ENTRAINMENT/DETRAINMENT RATES
1544	! CUBASMC CALCULATE CLOUD BASE VALUES FOR MIDLEVEL CONVECTION
1545	!***REFERENCE
1546	! ---------
1547	! (TIEDTKE,1989)
1548	!***INPUT VARIABLES:
1549	! PTENH [ZTENH] - Environ Temperature on half levels. (CUINI)
1550	! PQENH [ZQENH] - Env. specific humidity on half levels. (CUINI)
1551	! PUEN - Environment wind u-component. (MSSFLX)
1552	! PVEN - Environment wind v-component. (MSSFLX)
1553	! PTEN - Environment Temperature. (MSSFLX)
1554	! PQEN - Environment Specific Humidity. (MSSFLX)
1555	! PQSEN - Environment Saturation Specific Humidity. (MSSFLX)
1556	! PGEO - Geopotential. (MSSFLX)
1557	! PGEOH [ZGEOH] - Geopotential on half levels, (MSSFLX)
1558	! PAP - Pressure in Pa. (MSSFLX)
1559	! PAPH - Pressure of half levels. (MSSFLX)
1560	! PQTE - Moisture convergence (Delta q/Delta t). (MSSFLX)
1561	! PVERV - Large Scale Vertical Velocity (Omega). (MSSFLX)
1562	! KLWMIN [ILWMIN] - Level of Minimum Omega. (CUINI)
1563	! KLAB [ILAB] - Level Label - 1: Sub-cloud layer.
1564	! 2: Condensation Level (Cloud Base)
1565	! PMFUB [ZMFUB] - Updraft Mass Flux at Cloud Base. (CUMASTR)
1566	!***VARIABLES MODIFIED BY CUASC:
1567	! LDCUM - Logical denoting profiles. (CUBASE)
1568	! KTYPE - Convection type - 1: Penetrative (CUMASTR)
1569	! 2: Stratocumulus (CUMASTR)
1570	! 3: Mid-level (CUASC)
1571	! PTU - Cloud Temperature.
1572	! PQU - Cloud specific Humidity.
1573	! PLU - Cloud Liquid Water (Moisture condensed out)
1574	! PUU [ZUU] - Cloud Momentum U-Component.
1575	! PVU [ZVU] - Cloud Momentum V-Component.
1576	! PMFU - Updraft Mass Flux.
1577	! PENTR [ZENTR] - Entrainment Rate. (CUMASTR ) (CUBASMC)
1578	! PMFUS [ZMFUS] - Updraft Flux of Dry Static Energy. (CUBASMC)
1579	! PMFUQ [ZMFUQ] - Updraft Flux of Specific Humidity.
1580	! PMFUL [ZMFUL] - Updraft Flux of Cloud Liquid Water.
1581	! PLUDE - Liquid Water Returned to Environment by Detrainment.
1582	! PDMFUP [ZMFUP] -
1583	! KCBOT - Cloud Base Level. (CUBASE)
1584	! KCTOP -
1585	! KCTOP0 [ICTOP0] - Estimate of Cloud Top. (CUMASTR)
1586	! KCUM [ICUM] -
1587	!-------------------------------------------------------------------
1588	IMPLICIT NONE
1589	!-------------------------------------------------------------------
1590	INTEGER KLON, KLEV, KLEVP1
1591	INTEGER klevm1,kcum
1592	REAL ZTMST,ZCONS2,ZDZ,ZDRODZ
1593	INTEGER JL,JK,IKB,IK,IS,IKT,ICALL
1594	REAL ZMFMAX,ZFAC,ZMFTEST,ZDPRHO,ZMSE,ZNEVN,ZODMAX
1595	REAL ZQEEN,ZSEEN,ZSCDE,ZGA,ZDT,ZSCOD
1596	REAL ZQUDE,ZQCOD, ZMFUSK, ZMFUQK,ZMFULK
1597	REAL ZBUO, ZPRCON, ZLNEW, ZZ, ZDMFEU, ZDMFDU
1598	REAL ZBUOYZ,ZZDMF
1599	REAL PTENH(KLON,KLEV), PQENH(KLON,KLEV), &
1600	PUEN(KLON,KLEV), PVEN(KLON,KLEV), &
1601	PTEN(KLON,KLEV), PQEN(KLON,KLEV), &
1602	PGEO(KLON,KLEV), PGEOH(KLON,KLEV), &
1603	PAP(KLON,KLEV), PAPH(KLON,KLEVP1), &
1604	PQSEN(KLON,KLEV), PQTE(KLON,KLEV), &
1605	PVERV(KLON,KLEV), PQSENH(KLON,KLEV)
1606	REAL PTU(KLON,KLEV), PQU(KLON,KLEV), &
1607	PUU(KLON,KLEV), PVU(KLON,KLEV), &
1608	PMFU(KLON,KLEV), ZPH(KLON), &
1609	PMFUB(KLON), PENTR(KLON), &
1610	PMFUS(KLON,KLEV), PMFUQ(KLON,KLEV), &
1611	PLU(KLON,KLEV), PLUDE(KLON,KLEV), &
1612	PMFUL(KLON,KLEV), PDMFUP(KLON,KLEV)
1613	REAL ZDMFEN(KLON), ZDMFDE(KLON), &
1614	ZMFUU(KLON), ZMFUV(KLON), &
1615	ZPBASE(KLON), ZQOLD(KLON), &
1616	PHHATT(KLON,KLEV), ZODETR(KLON,KLEV), &
1617	ZOENTR(KLON,KLEV), ZBUOY(KLON)
1618	REAL PHCBASE(KLON)
1619	INTEGER KLWMIN(KLON), KTYPE(KLON), &
1620	KLAB(KLON,KLEV), KCBOT(KLON), &
1621	KCTOP(KLON), KCTOP0(KLON), &
1622	KHMIN(KLON)
1623	LOGICAL LDCUM(KLON), LOFLAG(KLON)
1624	!--------------------------------
1625	!* 1. SPECIFY PARAMETERS
1626	!--------------------------------
1627	100 CONTINUE
1628	ZCONS2=1./(G*ZTMST)
1629	!---------------------------------
1630	! 2. SET DEFAULT VALUES
1631	!---------------------------------
1632	200 CONTINUE
1633	DO 210 JL=1,KLON
1634	ZMFUU(JL)=0.
1635	ZMFUV(JL)=0.
1636	ZBUOY(JL)=0.
1637	IF(.NOT.LDCUM(JL)) KTYPE(JL)=0
1638	210 CONTINUE
1639	DO 230 JK=1,KLEV
1640	DO 230 JL=1,KLON
1641	PLU(JL,JK)=0.
1642	PMFU(JL,JK)=0.
1643	PMFUS(JL,JK)=0.
1644	PMFUQ(JL,JK)=0.
1645	PMFUL(JL,JK)=0.
1646	PLUDE(JL,JK)=0.
1647	PDMFUP(JL,JK)=0.
1648	ZOENTR(JL,JK)=0.
1649	ZODETR(JL,JK)=0.
1650	IF(.NOT.LDCUM(JL).OR.KTYPE(JL).EQ.3) KLAB(JL,JK)=0
1651	IF(.NOT.LDCUM(JL).AND.PAPH(JL,JK).LT.4.E4) KCTOP0(JL)=JK
1652	230 CONTINUE
1653	!------------------------------------------------
1654	! 3.0 INITIALIZE VALUES AT LIFTING LEVEL
1655	!------------------------------------------------
1656	DO 310 JL=1,KLON
1657	KCTOP(JL)=KLEVM1
1658	IF(.NOT.LDCUM(JL)) THEN
1659	KCBOT(JL)=KLEVM1
1660	PMFUB(JL)=0.
1661	PQU(JL,KLEV)=0.
1662	END IF
1663	PMFU(JL,KLEV)=PMFUB(JL)
1664	PMFUS(JL,KLEV)=PMFUB(JL)(CPDPTU(JL,KLEV)+PGEOH(JL,KLEV))
1665	PMFUQ(JL,KLEV)=PMFUB(JL)*PQU(JL,KLEV)
1666	IF(LMFDUDV) THEN
1667	ZMFUU(JL)=PMFUB(JL)*PUU(JL,KLEV)
1668	ZMFUV(JL)=PMFUB(JL)*PVU(JL,KLEV)
1669	END IF
1670	310 CONTINUE
1671	!
1672	!-- 3.1 Find organized entrainment at cloud base
1673	!
1674	DO 322 JL=1,KLON
1675	LDCUM(JL)=.FALSE.
1676	IF (KTYPE(JL).EQ.1) THEN
1677	IKB = KCBOT(JL)
1678	ZBUOY(JL)=G*((PTU(JL,IKB)-PTENH(JL,IKB))/PTENH(JL,IKB)+ &
1679	0.608*(PQU(JL,IKB)-PQENH(JL,IKB)))
1680	IF (ZBUOY(JL).GT.0.) THEN
1681	ZDZ = (PGEO(JL,IKB-1)-PGEO(JL,IKB))*ZRG
1682	ZDRODZ = -LOG(PTEN(JL,IKB-1)/PTEN(JL,IKB))/ZDZ - &
1683	G/(RD*PTENH(JL,IKB))
1684	ZOENTR(JL,IKB-1)=ZBUOY(JL)0.5/(1.+ZBUOY(JL)ZDZ) &
1685	+ZDRODZ
1686	ZOENTR(JL,IKB-1) = MIN(ZOENTR(JL,IKB-1),1.E-3)
1687	ZOENTR(JL,IKB-1) = MAX(ZOENTR(JL,IKB-1),0.)
1688	END IF
1689	END IF
1690	322 CONTINUE
1691	!
1692	!-----------------------------------------------------------------
1693	! 4. DO ASCENT: SUBCLOUD LAYER (KLAB=1) ,CLOUDS (KLAB=2)
1694	! BY DOING FIRST DRY-ADIABATIC ASCENT AND THEN
1695	! BY ADJUSTING T,Q AND L ACCORDINGLY IN CUADJTQ,
1696	! THEN CHECK FOR BUOYANCY AND SET FLAGS ACCORDINGLY
1697	!-----------------------------------------------------------------
1698	400 CONTINUE
1699	DO 480 JK=KLEVM1,2,-1
1700	! SPECIFY CLOUD BASE VALUES FOR MIDLEVEL CONVECTION
1701	! IN CUBASMC IN CASE THERE IS NOT ALREADY CONVECTION
1702	! ---------------------------------------------------------------------
1703	IK=JK
1704	IF(LMFMID.AND.IK.LT.KLEVM1.AND.IK.GT.KLEV-13) THEN
1705	CALL CUBASMC &
1706	(KLON, KLEV, KLEVM1, IK, PTEN, &
1707	PQEN, PQSEN, PUEN, PVEN, PVERV, &
1708	PGEO, PGEOH, LDCUM, KTYPE, KLAB, &
1709	PMFU, PMFUB, PENTR, KCBOT, PTU, &
1710	PQU, PLU, PUU, PVU, PMFUS, &
1711	PMFUQ, PMFUL, PDMFUP, ZMFUU, ZMFUV)
1712	ENDIF
1713	IS=0
1714	DO 410 JL=1,KLON
1715	ZQOLD(JL)=0.0
1716	IS=IS+KLAB(JL,JK+1)
1717	IF(KLAB(JL,JK+1).EQ.0) KLAB(JL,JK)=0
1718	LOFLAG(JL)=KLAB(JL,JK+1).GT.0
1719	ZPH(JL)=PAPH(JL,JK)
1720	IF(KTYPE(JL).EQ.3.AND.JK.EQ.KCBOT(JL)) THEN
1721	ZMFMAX=(PAPH(JL,JK)-PAPH(JL,JK-1))*ZCONS2
1722	IF(PMFUB(JL).GT.ZMFMAX) THEN
1723	ZFAC=ZMFMAX/PMFUB(JL)
1724	PMFU(JL,JK+1)=PMFU(JL,JK+1)*ZFAC
1725	PMFUS(JL,JK+1)=PMFUS(JL,JK+1)*ZFAC
1726	PMFUQ(JL,JK+1)=PMFUQ(JL,JK+1)*ZFAC
1727	ZMFUU(JL)=ZMFUU(JL)*ZFAC
1728	ZMFUV(JL)=ZMFUV(JL)*ZFAC
1729	PMFUB(JL)=ZMFMAX
1730	END IF
1731	END IF
1732	410 CONTINUE
1733	IF(IS.EQ.0) GO TO 480
1734	!
1735	!* SPECIFY ENTRAINMENT RATES IN CUENTR_NEW
1736	! -------------------------------------
1737	IK=JK
1738	CALL CUENTR_NEW &
1739	(KLON, KLEV, KLEVP1, IK, PTENH,&
1740	PAPH, PAP, PGEOH, KLWMIN, LDCUM,&
1741	KTYPE, KCBOT, KCTOP0, ZPBASE, PMFU, &
1742	PENTR, ZDMFEN, ZDMFDE, ZODETR, KHMIN)
1743	!
1744	! DO ADIABATIC ASCENT FOR ENTRAINING/DETRAINING PLUME
1745	! -------------------------------------------------------
1746	! Do adiabatic ascent for entraining/detraining plume
1747	! the cloud ensemble entrains environmental values
1748	! in turbulent detrainment cloud ensemble values are detrained
1749	! in organized detrainment the dry static energy and
1750	! moisture that are neutral compared to the
1751	! environmental air are detrained
1752	!
1753	DO 420 JL=1,KLON
1754	IF(LOFLAG(JL)) THEN
1755	IF(JK.LT.KCBOT(JL)) THEN
1756	ZMFTEST=PMFU(JL,JK+1)+ZDMFEN(JL)-ZDMFDE(JL)
1757	ZMFMAX=MIN(ZMFTEST,(PAPH(JL,JK)-PAPH(JL,JK-1))*ZCONS2)
1758	ZDMFEN(JL)=MAX(ZDMFEN(JL)-MAX(ZMFTEST-ZMFMAX,0.),0.)
1759	END IF
1760	ZDMFDE(JL)=MIN(ZDMFDE(JL),0.75*PMFU(JL,JK+1))
1761	PMFU(JL,JK)=PMFU(JL,JK+1)+ZDMFEN(JL)-ZDMFDE(JL)
1762	IF (JK.LT.kcbot(jl)) THEN
1763	zdprho = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg
1764	zoentr(jl,jk) = zoentr(jl,jk)zdprhopmfu(jl,jk+1)
1765	zmftest = pmfu(jl,jk) + zoentr(jl,jk)-zodetr(jl,jk)
1766	zmfmax = MIN(zmftest,(paph(jl,jk)-paph(jl,jk-1))*zcons2)
1767	zoentr(jl,jk) = MAX(zoentr(jl,jk)-MAX(zmftest-zmfmax,0.),0.)
1768	END IF
1769	!
1770	! limit organized detrainment to not allowing for too deep clouds
1771	!
1772	IF (ktype(jl).EQ.1.AND.jk.LT.kcbot(jl).AND.jk.LE.khmin(jl)) THEN
1773	zmse = cpdptu(jl,jk+1) + alvpqu(jl,jk+1) + pgeoh(jl,jk+1)
1774	ikt = kctop0(jl)
1775	znevn=(pgeoh(jl,ikt)-pgeoh(jl,jk+1))*(zmse-phhatt(jl, &
1776	jk+1))*zrg
1777	IF (znevn.LE.0.) znevn = 1.
1778	zdprho = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg
1779	zodmax = ((phcbase(jl)-zmse)/znevn)zdprhopmfu(jl,jk+1)
1780	zodmax = MAX(zodmax,0.)
1781	zodetr(jl,jk) = MIN(zodetr(jl,jk),zodmax)
1782	END IF
1783	zodetr(jl,jk) = MIN(zodetr(jl,jk),0.75*pmfu(jl,jk))
1784	pmfu(jl,jk) = pmfu(jl,jk) + zoentr(jl,jk) - zodetr(jl,jk)
1785	ZQEEN=PQENH(JL,JK+1)*ZDMFEN(JL)
1786	zqeen=zqeen + pqenh(jl,jk+1)*zoentr(jl,jk)
1787	ZSEEN=(CPDPTENH(JL,JK+1)+PGEOH(JL,JK+1))ZDMFEN(JL)
1788	zseen=zseen+(cpdptenh(jl,jk+1)+pgeoh(jl,jk+1)) &
1789	zoentr(jl,jk)
1790	ZSCDE=(CPDPTU(JL,JK+1)+PGEOH(JL,JK+1))ZDMFDE(JL)
1791	! find moist static energy that give nonbuoyant air
1792	zga = alvpqsenh(jl,jk+1)/(rv(ptenh(jl,jk+1)**2))
1793	zdt = (plu(jl,jk+1)-0.608*(pqsenh(jl,jk+1)-pqenh(jl, &
1794	jk+1)))/(1./ptenh(jl,jk+1)+0.608*zga)
1795	zscod = cpdptenh(jl,jk+1) + pgeoh(jl,jk+1) + cpdzdt
1796	zscde = zscde + zodetr(jl,jk)*zscod
1797	zqude = pqu(jl,jk+1)*zdmfde(jl)
1798	zqcod = pqsenh(jl,jk+1) + zga*zdt
1799	zqude = zqude + zodetr(jl,jk)*zqcod
1800	plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl)
1801	plude(jl,jk) = plude(jl,jk)+plu(jl,jk+1)*zodetr(jl,jk)
1802	zmfusk = pmfus(jl,jk+1) + zseen - zscde
1803	zmfuqk = pmfuq(jl,jk+1) + zqeen - zqude
1804	zmfulk = pmful(jl,jk+1) - plude(jl,jk)
1805	plu(jl,jk) = zmfulk*(1./MAX(cmfcmin,pmfu(jl,jk)))
1806	pqu(jl,jk) = zmfuqk*(1./MAX(cmfcmin,pmfu(jl,jk)))
1807	ptu(jl,jk)=(zmfusk*(1./MAX(cmfcmin,pmfu(jl,jk)))- &
1808	pgeoh(jl,jk))*rcpd
1809	ptu(jl,jk) = MAX(100.,ptu(jl,jk))
1810	ptu(jl,jk) = MIN(400.,ptu(jl,jk))
1811	zqold(jl) = pqu(jl,jk)
1812	END IF
1813	420 CONTINUE
1814	!* DO CORRECTIONS FOR MOIST ASCENT
1815	!* BY ADJUSTING T,Q AND L IN CUADJTQ
1816	!------------------------------------------------
1817	IK=JK
1818	ICALL=1
1819	!
1820	CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTU,PQU,LOFLAG,ICALL)
1821	!
1822	DO 440 JL=1,KLON
1823	IF(LOFLAG(JL).AND.PQU(JL,JK).NE.ZQOLD(JL)) THEN
1824	KLAB(JL,JK)=2
1825	PLU(JL,JK)=PLU(JL,JK)+ZQOLD(JL)-PQU(JL,JK)
1826	ZBUO=PTU(JL,JK)(1.+VTMPC1PQU(JL,JK)-PLU(JL,JK))- &
1827	PTENH(JL,JK)(1.+VTMPC1PQENH(JL,JK))
1828	IF(KLAB(JL,JK+1).EQ.1) ZBUO=ZBUO+ZBUO0
1829	IF(ZBUO.GT.0..AND.PMFU(JL,JK).GT.0.01*PMFUB(JL).AND. &
1830	JK.GE.KCTOP0(JL)) THEN
1831	KCTOP(JL)=JK
1832	LDCUM(JL)=.TRUE.
1833	IF(ZPBASE(JL)-PAPH(JL,JK).GE.ZDNOPRC) THEN
1834	ZPRCON=CPRCON
1835	ELSE
1836	ZPRCON=0.
1837	ENDIF
1838	ZLNEW=PLU(JL,JK)/(1.+ZPRCON*(PGEOH(JL,JK)-PGEOH(JL,JK+1)))
1839	PDMFUP(JL,JK)=MAX(0.,(PLU(JL,JK)-ZLNEW)*PMFU(JL,JK))
1840	PLU(JL,JK)=ZLNEW
1841	ELSE
1842	KLAB(JL,JK)=0
1843	PMFU(JL,JK)=0.
1844	END IF
1845	END IF
1846	IF(LOFLAG(JL)) THEN
1847	PMFUL(JL,JK)=PLU(JL,JK)*PMFU(JL,JK)
1848	PMFUS(JL,JK)=(CPDPTU(JL,JK)+PGEOH(JL,JK))PMFU(JL,JK)
1849	PMFUQ(JL,JK)=PQU(JL,JK)*PMFU(JL,JK)
1850	END IF
1851	440 CONTINUE
1852	!
1853	IF(LMFDUDV) THEN
1854	!
1855	DO 460 JL=1,KLON
1856	zdmfen(jl) = zdmfen(jl) + zoentr(jl,jk)
1857	zdmfde(jl) = zdmfde(jl) + zodetr(jl,jk)
1858	IF(LOFLAG(JL)) THEN
1859	IF(KTYPE(JL).EQ.1.OR.KTYPE(JL).EQ.3) THEN
1860	IF(ZDMFEN(JL).LE.1.E-20) THEN
1861	ZZ=3.
1862	ELSE
1863	ZZ=2.
1864	ENDIF
1865	ELSE
1866	IF(ZDMFEN(JL).LE.1.0E-20) THEN
1867	ZZ=1.
1868	ELSE
1869	ZZ=0.
1870	ENDIF
1871	END IF
1872	ZDMFEU=ZDMFEN(JL)+ZZ*ZDMFDE(JL)
1873	ZDMFDU=ZDMFDE(JL)+ZZ*ZDMFDE(JL)
1874	ZDMFDU=MIN(ZDMFDU,0.75*PMFU(JL,JK+1))
1875	ZMFUU(JL)=ZMFUU(JL)+ &
1876	ZDMFEUPUEN(JL,JK)-ZDMFDUPUU(JL,JK+1)
1877	ZMFUV(JL)=ZMFUV(JL)+ &
1878	ZDMFEUPVEN(JL,JK)-ZDMFDUPVU(JL,JK+1)
1879	IF(PMFU(JL,JK).GT.0.) THEN
1880	PUU(JL,JK)=ZMFUU(JL)*(1./PMFU(JL,JK))
1881	PVU(JL,JK)=ZMFUV(JL)*(1./PMFU(JL,JK))
1882	END IF
1883	END IF
1884	460 CONTINUE
1885	!
1886	END IF
1887	!
1888	! Compute organized entrainment
1889	! for use at next level
1890	!
1891	DO 470 jl = 1, klon
1892	IF (loflag(jl).AND.ktype(jl).EQ.1) THEN
1893	zbuoyz=g*((ptu(jl,jk)-ptenh(jl,jk))/ptenh(jl,jk)+ &
1894	0.608*(pqu(jl,jk)-pqenh(jl,jk))-plu(jl,jk))
1895	zbuoyz = MAX(zbuoyz,0.0)
1896	zdz = (pgeo(jl,jk-1)-pgeo(jl,jk))*zrg
1897	zdrodz = -LOG(pten(jl,jk-1)/pten(jl,jk))/zdz - &
1898	g/(rd*ptenh(jl,jk))
1899	zbuoy(jl) = zbuoy(jl) + zbuoyz*zdz
1900	zoentr(jl,jk-1) = zbuoyz*0.5/(1.+zbuoy(jl))+zdrodz
1901	zoentr(jl,jk-1) = MIN(zoentr(jl,jk-1),1.E-3)
1902	zoentr(jl,jk-1) = MAX(zoentr(jl,jk-1),0.)
1903	END IF
1904	470 CONTINUE
1905	!
1906	480 CONTINUE
1907	! -----------------------------------------------------------------
1908	! 5. DETERMINE CONVECTIVE FLUXES ABOVE NON-BUOYANCY LEVEL
1909	! -----------------------------------------------------------------
1910	! (NOTE: CLOUD VARIABLES LIKE T,Q AND L ARE NOT
1911	! AFFECTED BY DETRAINMENT AND ARE ALREADY KNOWN
1912	! FROM PREVIOUS CALCULATIONS ABOVE)
1913	500 CONTINUE
1914	DO 510 JL=1,KLON
1915	IF(KCTOP(JL).EQ.KLEVM1) LDCUM(JL)=.FALSE.
1916	KCBOT(JL)=MAX(KCBOT(JL),KCTOP(JL))
1917	510 CONTINUE
1918	IS=0
1919	DO 520 JL=1,KLON
1920	IF(LDCUM(JL)) THEN
1921	IS=IS+1
1922	ENDIF
1923	520 CONTINUE
1924	KCUM=IS
1925	IF(IS.EQ.0) GO TO 800
1926	DO 530 JL=1,KLON
1927	IF(LDCUM(JL)) THEN
1928	JK=KCTOP(JL)-1
1929	ZZDMF=CMFCTOP
1930	ZDMFDE(JL)=(1.-ZZDMF)*PMFU(JL,JK+1)
1931	PLUDE(JL,JK)=ZDMFDE(JL)*PLU(JL,JK+1)
1932	PMFU(JL,JK)=PMFU(JL,JK+1)-ZDMFDE(JL)
1933	PMFUS(JL,JK)=(CPDPTU(JL,JK)+PGEOH(JL,JK))PMFU(JL,JK)
1934	PMFUQ(JL,JK)=PQU(JL,JK)*PMFU(JL,JK)
1935	PMFUL(JL,JK)=PLU(JL,JK)*PMFU(JL,JK)
1936	PLUDE(JL,JK-1)=PMFUL(JL,JK)
1937	PDMFUP(JL,JK)=0.
1938	END IF
1939	530 CONTINUE
1940	IF(LMFDUDV) THEN
1941	DO 540 JL=1,KLON
1942	IF(LDCUM(JL)) THEN
1943	JK=KCTOP(JL)-1
1944	PUU(JL,JK)=PUU(JL,JK+1)
1945	PVU(JL,JK)=PVU(JL,JK+1)
1946	END IF
1947	540 CONTINUE
1948	END IF
1949	800 CONTINUE
1950	RETURN
1951	END SUBROUTINE CUASC_NEW
1952	!
1953
1954	!**********************************************
1955	! SUBROUTINE CUDLFS
1956	!**********************************************
1957	SUBROUTINE CUDLFS &
1958	(KLON, KLEV, KLEVP1, PTENH, PQENH, &
1959	PUEN, PVEN, PGEOH, PAPH, PTU, &
1960	PQU, PUU, PVU, LDCUM, KCBOT, &
1961	KCTOP, PMFUB, PRFL, PTD, PQD, &
1962	PUD, PVD, PMFD, PMFDS, PMFDQ, &
1963	PDMFDP, KDTOP, LDDRAF)
1964	! THIS ROUTINE CALCULATES LEVEL OF FREE SINKING FOR
1965	! CUMULUS DOWNDRAFTS AND SPECIFIES T,Q,U AND V VALUES
1966	! M.TIEDTKE E.C.M.W.F. 12/86 MODIF. 12/89
1967	!***PURPOSE.
1968	! --------
1969	! TO PRODUCE LFS-VALUES FOR CUMULUS DOWNDRAFTS
1970	! FOR MASSFLUX CUMULUS PARAMETERIZATION
1971	!***INTERFACE
1972	! ---------
1973	! THIS ROUTINE IS CALLED FROM CUMASTR.
1974	! INPUT ARE ENVIRONMENTAL VALUES OF T,Q,U,V,P,PHI
1975	! AND UPDRAFT VALUES T,Q,U AND V AND ALSO
1976	! CLOUD BASE MASSFLUX AND CU-PRECIPITATION RATE.
1977	! IT RETURNS T,Q,U AND V VALUES AND MASSFLUX AT LFS.
1978	!***METHOD.
1979	! --------
1980	! CHECK FOR NEGATIVE BUOYANCY OF AIR OF EQUAL PARTS OF
1981	! MOIST ENVIRONMENTAL AIR AND CLOUD AIR.
1982	!***EXTERNALS
1983	! ---------
1984	! CUADJTQ FOR CALCULATING WET BULB T AND Q AT LFS
1985	! ----------------------------------------------------------------
1986	!-------------------------------------------------------------------
1987	IMPLICIT NONE
1988	!-------------------------------------------------------------------
1989	INTEGER KLON, KLEV, KLEVP1
1990	INTEGER JL,KE,JK,IS,IK,ICALL
1991	REAL ZTTEST, ZQTEST, ZBUO, ZMFTOP
1992	REAL PTENH(KLON,KLEV), PQENH(KLON,KLEV), &
1993	PUEN(KLON,KLEV), PVEN(KLON,KLEV), &
1994	PGEOH(KLON,KLEV), PAPH(KLON,KLEVP1), &
1995	PTU(KLON,KLEV), PQU(KLON,KLEV), &
1996	PUU(KLON,KLEV), PVU(KLON,KLEV), &
1997	PMFUB(KLON), PRFL(KLON)
1998	REAL PTD(KLON,KLEV), PQD(KLON,KLEV), &
1999	PUD(KLON,KLEV), PVD(KLON,KLEV), &
2000	PMFD(KLON,KLEV), PMFDS(KLON,KLEV), &
2001	PMFDQ(KLON,KLEV), PDMFDP(KLON,KLEV)
2002	REAL ZTENWB(KLON,KLEV), ZQENWB(KLON,KLEV), &
2003	ZCOND(KLON), ZPH(KLON)
2004	INTEGER KCBOT(KLON), KCTOP(KLON), &
2005	KDTOP(KLON)
2006	LOGICAL LDCUM(KLON), LLo2(KLON), &
2007	LDDRAF(KLON)
2008	!-----------------------------------------------
2009	! 1. SET DEFAULT VALUES FOR DOWNDRAFTS
2010	!-----------------------------------------------
2011	100 CONTINUE
2012	DO 110 JL=1,KLON
2013	LDDRAF(JL)=.FALSE.
2014	KDTOP(JL)=KLEVP1
2015	110 CONTINUE
2016	IF(.NOT.LMFDD) GO TO 300
2017	!------------------------------------------------------------
2018	! 2. DETERMINE LEVEL OF FREE SINKING BY
2019	! DOING A SCAN FROM TOP TO BASE OF CUMULUS CLOUDS
2020	! FOR EVERY POINT AND PROCEED AS FOLLOWS:
2021	! (1) DETEMINE WET BULB ENVIRONMENTAL T AND Q
2022	! (2) DO MIXING WITH CUMULUS CLOUD AIR
2023	! (3) CHECK FOR NEGATIVE BUOYANCY
2024	! THE ASSUMPTION IS THAT AIR OF DOWNDRAFTS IS MIXTURE
2025	! OF 50% CLOUD AIR + 50% ENVIRONMENTAL AIR AT WET BULB
2026	! TEMPERATURE (I.E. WHICH BECAME SATURATED DUE TO
2027	! EVAPORATION OF RAIN AND CLOUD WATER)
2028	!------------------------------------------------------------------
2029	200 CONTINUE
2030	KE=KLEV-3
2031	DO 290 JK=3,KE
2032	! 2.1 CALCULATE WET-BULB TEMPERATURE AND MOISTURE
2033	! FOR ENVIRONMENTAL AIR IN CUADJTQ
2034	! -----------------------------------------------------
2035	210 CONTINUE
2036	IS=0
2037	DO 212 JL=1,KLON
2038	ZTENWB(JL,JK)=PTENH(JL,JK)
2039	ZQENWB(JL,JK)=PQENH(JL,JK)
2040	ZPH(JL)=PAPH(JL,JK)
2041	LLO2(JL)=LDCUM(JL).AND.PRFL(JL).GT.0..AND..NOT.LDDRAF(JL).AND. &
2042	(JK.LT.KCBOT(JL).AND.JK.GT.KCTOP(JL))
2043	IF(LLO2(JL))THEN
2044	IS=IS+1
2045	ENDIF
2046	212 CONTINUE
2047	IF(IS.EQ.0) GO TO 290
2048	IK=JK
2049	ICALL=2
2050	CALL CUADJTQ(KLON,KLEV,IK,ZPH,ZTENWB,ZQENWB,LLO2,ICALL)
2051	! 2.2 DO MIXING OF CUMULUS AND ENVIRONMENTAL AIR
2052	! AND CHECK FOR NEGATIVE BUOYANCY.
2053	! THEN SET VALUES FOR DOWNDRAFT AT LFS.
2054	! -----------------------------------------------------
2055	220 CONTINUE
2056	DO 222 JL=1,KLON
2057	IF(LLO2(JL)) THEN
2058	ZTTEST=0.5*(PTU(JL,JK)+ZTENWB(JL,JK))
2059	ZQTEST=0.5*(PQU(JL,JK)+ZQENWB(JL,JK))
2060	ZBUO=ZTTEST(1.+VTMPC1ZQTEST)- &
2061	PTENH(JL,JK)(1.+VTMPC1PQENH(JL,JK))
2062	ZCOND(JL)=PQENH(JL,JK)-ZQENWB(JL,JK)
2063	ZMFTOP=-CMFDEPS*PMFUB(JL)
2064	IF(ZBUO.LT.0..AND.PRFL(JL).GT.10.ZMFTOPZCOND(JL)) THEN
2065	KDTOP(JL)=JK
2066	LDDRAF(JL)=.TRUE.
2067	PTD(JL,JK)=ZTTEST
2068	PQD(JL,JK)=ZQTEST
2069	PMFD(JL,JK)=ZMFTOP
2070	PMFDS(JL,JK)=PMFD(JL,JK)(CPDPTD(JL,JK)+PGEOH(JL,JK))
2071	PMFDQ(JL,JK)=PMFD(JL,JK)*PQD(JL,JK)
2072	PDMFDP(JL,JK-1)=-0.5PMFD(JL,JK)ZCOND(JL)
2073	PRFL(JL)=PRFL(JL)+PDMFDP(JL,JK-1)
2074	END IF
2075	END IF
2076	222 CONTINUE
2077	IF(LMFDUDV) THEN
2078	DO 224 JL=1,KLON
2079	IF(PMFD(JL,JK).LT.0.) THEN
2080	PUD(JL,JK)=0.5*(PUU(JL,JK)+PUEN(JL,JK-1))
2081	PVD(JL,JK)=0.5*(PVU(JL,JK)+PVEN(JL,JK-1))
2082	END IF
2083	224 CONTINUE
2084	END IF
2085	290 CONTINUE
2086	300 CONTINUE
2087	RETURN
2088	END SUBROUTINE CUDLFS
2089	!
2090
2091	!**********************************************
2092	! SUBROUTINE CUDDRAF
2093	!**********************************************
2094	SUBROUTINE CUDDRAF &
2095	(KLON, KLEV, KLEVP1, PTENH, PQENH, &
2096	PUEN, PVEN, PGEOH, PAPH, PRFL, &
2097	LDDRAF, PTD, PQD, PUD, PVD, &
2098	PMFD, PMFDS, PMFDQ, PDMFDP)
2099	! THIS ROUTINE CALCULATES CUMULUS DOWNDRAFT DESCENT
2100	! M.TIEDTKE E.C.M.W.F. 12/86 MODIF. 12/89
2101	!***PURPOSE.
2102	! --------
2103	! TO PRODUCE THE VERTICAL PROFILES FOR CUMULUS DOWNDRAFTS
2104	! (I.E. T,Q,U AND V AND FLUXES)
2105	!***INTERFACE
2106	! ---------
2107	! THIS ROUTINE IS CALLED FROM CUMASTR.
2108	! INPUT IS T,Q,P,PHI,U,V AT HALF LEVELS.
2109	! IT RETURNS FLUXES OF S,Q AND EVAPORATION RATE
2110	! AND U,V AT LEVELS WHERE DOWNDRAFT OCCURS
2111	!***METHOD.
2112	! --------
2113	! CALCULATE MOIST DESCENT FOR ENTRAINING/DETRAINING PLUME BY
2114	! A) MOVING AIR DRY-ADIABATICALLY TO NEXT LEVEL BELOW AND
2115	! B) CORRECTING FOR EVAPORATION TO OBTAIN SATURATED STATE.
2116	!***EXTERNALS
2117	! ---------
2118	! CUADJTQ FOR ADJUSTING T AND Q DUE TO EVAPORATION IN
2119	! SATURATED DESCENT
2120	!***REFERENCE
2121	! ---------
2122	! (TIEDTKE,1989)
2123	! ----------------------------------------------------------------
2124	!-------------------------------------------------------------------
2125	IMPLICIT NONE
2126	!-------------------------------------------------------------------
2127	INTEGER KLON, KLEV, KLEVP1
2128	INTEGER JK,IS,JL,ITOPDE, IK, ICALL
2129	REAL ZENTR,ZSEEN, ZQEEN, ZSDDE, ZQDDE,ZMFDSK, ZMFDQK
2130	REAL ZBUO, ZDMFDP, ZMFDUK, ZMFDVK
2131	REAL PTENH(KLON,KLEV), PQENH(KLON,KLEV), &
2132	PUEN(KLON,KLEV), PVEN(KLON,KLEV), &
2133	PGEOH(KLON,KLEV), PAPH(KLON,KLEVP1)
2134	REAL PTD(KLON,KLEV), PQD(KLON,KLEV), &
2135	PUD(KLON,KLEV), PVD(KLON,KLEV), &
2136	PMFD(KLON,KLEV), PMFDS(KLON,KLEV), &
2137	PMFDQ(KLON,KLEV), PDMFDP(KLON,KLEV), &
2138	PRFL(KLON)
2139	REAL ZDMFEN(KLON), ZDMFDE(KLON), &
2140	ZCOND(KLON), ZPH(KLON)
2141	LOGICAL LDDRAF(KLON), LLO2(KLON)
2142	!--------------------------------------------------------------
2143	! 1. CALCULATE MOIST DESCENT FOR CUMULUS DOWNDRAFT BY
2144	! (A) CALCULATING ENTRAINMENT RATES, ASSUMING
2145	! LINEAR DECREASE OF MASSFLUX IN PBL
2146	! (B) DOING MOIST DESCENT - EVAPORATIVE COOLING
2147	! AND MOISTENING IS CALCULATED IN CUADJTQ
2148	! (C) CHECKING FOR NEGATIVE BUOYANCY AND
2149	! SPECIFYING FINAL T,Q,U,V AND DOWNWARD FLUXES
2150	! ----------------------------------------------------------------
2151	100 CONTINUE
2152	DO 180 JK=3,KLEV
2153	IS=0
2154	DO 110 JL=1,KLON
2155	ZPH(JL)=PAPH(JL,JK)
2156	LLO2(JL)=LDDRAF(JL).AND.PMFD(JL,JK-1).LT.0.
2157	IF(LLO2(JL)) THEN
2158	IS=IS+1
2159	ENDIF
2160	110 CONTINUE
2161	IF(IS.EQ.0) GO TO 180
2162	DO 122 JL=1,KLON
2163	IF(LLO2(JL)) THEN
2164	ZENTR=ENTRDDPMFD(JL,JK-1)RD*PTENH(JL,JK-1)/ &
2165	(GPAPH(JL,JK-1))(PAPH(JL,JK)-PAPH(JL,JK-1))
2166	ZDMFEN(JL)=ZENTR
2167	ZDMFDE(JL)=ZENTR
2168	END IF
2169	122 CONTINUE
2170	ITOPDE=KLEV-2
2171	IF(JK.GT.ITOPDE) THEN
2172	DO 124 JL=1,KLON
2173	IF(LLO2(JL)) THEN
2174	ZDMFEN(JL)=0.
2175	ZDMFDE(JL)=PMFD(JL,ITOPDE)* &
2176	(PAPH(JL,JK)-PAPH(JL,JK-1))/ &
2177	(PAPH(JL,KLEVP1)-PAPH(JL,ITOPDE))
2178	END IF
2179	124 CONTINUE
2180	END IF
2181	DO 126 JL=1,KLON
2182	IF(LLO2(JL)) THEN
2183	PMFD(JL,JK)=PMFD(JL,JK-1)+ZDMFEN(JL)-ZDMFDE(JL)
2184	ZSEEN=(CPDPTENH(JL,JK-1)+PGEOH(JL,JK-1))ZDMFEN(JL)
2185	ZQEEN=PQENH(JL,JK-1)*ZDMFEN(JL)
2186	ZSDDE=(CPDPTD(JL,JK-1)+PGEOH(JL,JK-1))ZDMFDE(JL)
2187	ZQDDE=PQD(JL,JK-1)*ZDMFDE(JL)
2188	ZMFDSK=PMFDS(JL,JK-1)+ZSEEN-ZSDDE
2189	ZMFDQK=PMFDQ(JL,JK-1)+ZQEEN-ZQDDE
2190	PQD(JL,JK)=ZMFDQK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))
2191	PTD(JL,JK)=(ZMFDSK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))- &
2192	PGEOH(JL,JK))*RCPD
2193	PTD(JL,JK)=MIN(400.,PTD(JL,JK))
2194	PTD(JL,JK)=MAX(100.,PTD(JL,JK))
2195	ZCOND(JL)=PQD(JL,JK)
2196	END IF
2197	126 CONTINUE
2198	IK=JK
2199	ICALL=2
2200	CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTD,PQD,LLO2,ICALL)
2201	DO 150 JL=1,KLON
2202	IF(LLO2(JL)) THEN
2203	ZCOND(JL)=ZCOND(JL)-PQD(JL,JK)
2204	ZBUO=PTD(JL,JK)(1.+VTMPC1PQD(JL,JK))- &
2205	PTENH(JL,JK)(1.+VTMPC1PQENH(JL,JK))
2206	IF(ZBUO.GE.0..OR.PRFL(JL).LE.(PMFD(JL,JK)*ZCOND(JL))) THEN
2207	PMFD(JL,JK)=0.
2208	ENDIF
2209	PMFDS(JL,JK)=(CPDPTD(JL,JK)+PGEOH(JL,JK))PMFD(JL,JK)
2210	PMFDQ(JL,JK)=PQD(JL,JK)*PMFD(JL,JK)
2211	ZDMFDP=-PMFD(JL,JK)*ZCOND(JL)
2212	PDMFDP(JL,JK-1)=ZDMFDP
2213	PRFL(JL)=PRFL(JL)+ZDMFDP
2214	END IF
2215	150 CONTINUE
2216	IF(LMFDUDV) THEN
2217	DO 160 JL=1,KLON
2218	IF(LLO2(JL).AND.PMFD(JL,JK).LT.0.) THEN
2219	ZMFDUK=PMFD(JL,JK-1)*PUD(JL,JK-1)+ &
2220	ZDMFEN(JL)PUEN(JL,JK-1)-ZDMFDE(JL)PUD(JL,JK-1)
2221	ZMFDVK=PMFD(JL,JK-1)*PVD(JL,JK-1)+ &
2222	ZDMFEN(JL)PVEN(JL,JK-1)-ZDMFDE(JL)PVD(JL,JK-1)
2223	PUD(JL,JK)=ZMFDUK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))
2224	PVD(JL,JK)=ZMFDVK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))
2225	END IF
2226	160 CONTINUE
2227	END IF
2228	180 CONTINUE
2229	RETURN
2230	END SUBROUTINE CUDDRAF
2231	!
2232
2233	!**********************************************
2234	! SUBROUTINE CUFLX
2235	!**********************************************
2236	SUBROUTINE CUFLX &
2237	(KLON, KLEV, KLEVP1, PQEN, PQSEN, &
2238	PTENH, PQENH, PAPH, PGEOH, KCBOT, &
2239	KCTOP, KDTOP, KTYPE, LDDRAF, LDCUM, &
2240	PMFU, PMFD, PMFUS, PMFDS, PMFUQ, &
2241	PMFDQ, PMFUL, PLUDE, PDMFUP, PDMFDP, &
2242	PRFL, PRAIN, PTEN, PSFL, PDPMEL, &
2243	KTOPM2, ZTMST, sig1)
2244	! M.TIEDTKE E.C.M.W.F. 7/86 MODIF. 12/89
2245	!***PURPOSE
2246	! -------
2247	! THIS ROUTINE DOES THE FINAL CALCULATION OF CONVECTIVE
2248	! FLUXES IN THE CLOUD LAYER AND IN THE SUBCLOUD LAYER
2249	!***INTERFACE
2250	! ---------
2251	! THIS ROUTINE IS CALLED FROM CUMASTR.
2252	!***EXTERNALS
2253	! ---------
2254	! NONE
2255	! ----------------------------------------------------------------
2256	!-------------------------------------------------------------------
2257	IMPLICIT NONE
2258	!-------------------------------------------------------------------
2259	INTEGER KLON, KLEV, KLEVP1
2260	INTEGER KTOPM2, ITOP, JL, JK, IKB
2261	REAL ZTMST, ZCONS1, ZCONS2, ZCUCOV, ZTMELP2
2262	REAL ZZP, ZFAC, ZSNMLT, ZRFL, CEVAPCU, ZRNEW
2263	REAL ZRMIN, ZRFLN, ZDRFL, ZDPEVAP
2264	REAL PQEN(KLON,KLEV), PQSEN(KLON,KLEV), &
2265	PTENH(KLON,KLEV), PQENH(KLON,KLEV), &
2266	PAPH(KLON,KLEVP1), PGEOH(KLON,KLEV)
2267	REAL PMFU(KLON,KLEV), PMFD(KLON,KLEV), &
2268	PMFUS(KLON,KLEV), PMFDS(KLON,KLEV), &
2269	PMFUQ(KLON,KLEV), PMFDQ(KLON,KLEV), &
2270	PDMFUP(KLON,KLEV), PDMFDP(KLON,KLEV), &
2271	PMFUL(KLON,KLEV), PLUDE(KLON,KLEV), &
2272	PRFL(KLON), PRAIN(KLON)
2273	REAL PTEN(KLON,KLEV), PDPMEL(KLON,KLEV), &
2274	PSFL(KLON), ZPSUBCL(KLON)
2275	REAL sig1(KLEV)
2276	INTEGER KCBOT(KLON), KCTOP(KLON), &
2277	KDTOP(KLON), KTYPE(KLON)
2278	LOGICAL LDDRAF(KLON), LDCUM(KLON)
2279	!* SPECIFY CONSTANTS
2280	ZCONS1=CPD/(ALFGZTMST)
2281	ZCONS2=1./(G*ZTMST)
2282	ZCUCOV=0.05
2283	ZTMELP2=TMELT+2.
2284	!* 1.0 DETERMINE FINAL CONVECTIVE FLUXES
2285	!---------------------------------------------
2286	100 CONTINUE
2287	ITOP=KLEV
2288	DO 110 JL=1,KLON
2289	PRFL(JL)=0.
2290	PSFL(JL)=0.
2291	PRAIN(JL)=0.
2292	! SWITCH OFF SHALLOW CONVECTION
2293	IF(.NOT.LMFSCV.AND.KTYPE(JL).EQ.2)THEN
2294	LDCUM(JL)=.FALSE.
2295	LDDRAF(JL)=.FALSE.
2296	ENDIF
2297	ITOP=MIN(ITOP,KCTOP(JL))
2298	IF(.NOT.LDCUM(JL).OR.KDTOP(JL).LT.KCTOP(JL)) LDDRAF(JL)=.FALSE.
2299	IF(.NOT.LDCUM(JL)) KTYPE(JL)=0
2300	110 CONTINUE
2301	KTOPM2=ITOP-2
2302	DO 120 JK=KTOPM2,KLEV
2303	DO 115 JL=1,KLON
2304	IF(LDCUM(JL).AND.JK.GE.KCTOP(JL)-1) THEN
2305	PMFUS(JL,JK)=PMFUS(JL,JK)-PMFU(JL,JK)* &
2306	(CPD*PTENH(JL,JK)+PGEOH(JL,JK))
2307	PMFUQ(JL,JK)=PMFUQ(JL,JK)-PMFU(JL,JK)*PQENH(JL,JK)
2308	IF(LDDRAF(JL).AND.JK.GE.KDTOP(JL)) THEN
2309	PMFDS(JL,JK)=PMFDS(JL,JK)-PMFD(JL,JK)* &
2310	(CPD*PTENH(JL,JK)+PGEOH(JL,JK))
2311	PMFDQ(JL,JK)=PMFDQ(JL,JK)-PMFD(JL,JK)*PQENH(JL,JK)
2312	ELSE
2313	PMFD(JL,JK)=0.
2314	PMFDS(JL,JK)=0.
2315	PMFDQ(JL,JK)=0.
2316	PDMFDP(JL,JK-1)=0.
2317	END IF
2318	ELSE
2319	PMFU(JL,JK)=0.
2320	PMFD(JL,JK)=0.
2321	PMFUS(JL,JK)=0.
2322	PMFDS(JL,JK)=0.
2323	PMFUQ(JL,JK)=0.
2324	PMFDQ(JL,JK)=0.
2325	PMFUL(JL,JK)=0.
2326	PDMFUP(JL,JK-1)=0.
2327	PDMFDP(JL,JK-1)=0.
2328	PLUDE(JL,JK-1)=0.
2329	END IF
2330	115 CONTINUE
2331	120 CONTINUE
2332	DO 130 JK=KTOPM2,KLEV
2333	DO 125 JL=1,KLON
2334	IF(LDCUM(JL).AND.JK.GT.KCBOT(JL)) THEN
2335	IKB=KCBOT(JL)
2336	ZZP=((PAPH(JL,KLEVP1)-PAPH(JL,JK))/ &
2337	(PAPH(JL,KLEVP1)-PAPH(JL,IKB)))
2338	IF(KTYPE(JL).EQ.3) THEN
2339	ZZP=ZZP**2
2340	ENDIF
2341	PMFU(JL,JK)=PMFU(JL,IKB)*ZZP
2342	PMFUS(JL,JK)=PMFUS(JL,IKB)*ZZP
2343	PMFUQ(JL,JK)=PMFUQ(JL,IKB)*ZZP
2344	PMFUL(JL,JK)=PMFUL(JL,IKB)*ZZP
2345	END IF
2346	!* 2. CALCULATE RAIN/SNOW FALL RATES
2347	!* CALCULATE MELTING OF SNOW
2348	!* CALCULATE EVAPORATION OF PRECIP
2349	!----------------------------------------------
2350	IF(LDCUM(JL)) THEN
2351	PRAIN(JL)=PRAIN(JL)+PDMFUP(JL,JK)
2352	IF(PTEN(JL,JK).GT.TMELT) THEN
2353	PRFL(JL)=PRFL(JL)+PDMFUP(JL,JK)+PDMFDP(JL,JK)
2354	IF(PSFL(JL).GT.0..AND.PTEN(JL,JK).GT.ZTMELP2) THEN
2355	ZFAC=ZCONS1*(PAPH(JL,JK+1)-PAPH(JL,JK))
2356	ZSNMLT=MIN(PSFL(JL),ZFAC*(PTEN(JL,JK)-ZTMELP2))
2357	PDPMEL(JL,JK)=ZSNMLT
2358	PSFL(JL)=PSFL(JL)-ZSNMLT
2359	PRFL(JL)=PRFL(JL)+ZSNMLT
2360	END IF
2361	ELSE
2362	PSFL(JL)=PSFL(JL)+PDMFUP(JL,JK)+PDMFDP(JL,JK)
2363	END IF
2364	END IF
2365	125 CONTINUE
2366	130 CONTINUE
2367	DO 230 JL=1,KLON
2368	PRFL(JL)=MAX(PRFL(JL),0.)
2369	PSFL(JL)=MAX(PSFL(JL),0.)
2370	ZPSUBCL(JL)=PRFL(JL)+PSFL(JL)
2371	230 CONTINUE
2372	DO 240 JK=KTOPM2,KLEV
2373	DO 235 JL=1,KLON
2374	IF(LDCUM(JL).AND.JK.GE.KCBOT(JL).AND. &
2375	ZPSUBCL(JL).GT.1.E-20) THEN
2376	ZRFL=ZPSUBCL(JL)
2377	CEVAPCU=CEVAPCU1SQRT(CEVAPCU2SQRT(sig1(JK)))
2378	ZRNEW=(MAX(0.,SQRT(ZRFL/ZCUCOV)- &
2379	CEVAPCU(PAPH(JL,JK+1)-PAPH(JL,JK)) &
2380	MAX(0.,PQSEN(JL,JK)-PQEN(JL,JK))))*2ZCUCOV
2381	ZRMIN=ZRFL-ZCUCOVMAX(0.,0.8PQSEN(JL,JK)-PQEN(JL,JK)) &
2382	ZCONS2(PAPH(JL,JK+1)-PAPH(JL,JK))
2383	ZRNEW=MAX(ZRNEW,ZRMIN)
2384	ZRFLN=MAX(ZRNEW,0.)
2385	ZDRFL=MIN(0.,ZRFLN-ZRFL)
2386	PDMFUP(JL,JK)=PDMFUP(JL,JK)+ZDRFL
2387	ZPSUBCL(JL)=ZRFLN
2388	END IF
2389	235 CONTINUE
2390	240 CONTINUE
2391	DO 250 JL=1,KLON
2392	ZDPEVAP=ZPSUBCL(JL)-(PRFL(JL)+PSFL(JL))
2393	PRFL(JL)=PRFL(JL)+ZDPEVAPPRFL(JL) &
2394	(1./MAX(1.E-20,PRFL(JL)+PSFL(JL)))
2395	PSFL(JL)=PSFL(JL)+ZDPEVAPPSFL(JL) &
2396	(1./MAX(1.E-20,PRFL(JL)+PSFL(JL)))
2397	250 CONTINUE
2398	RETURN
2399	END SUBROUTINE CUFLX
2400	!
2401
2402	!**********************************************
2403	! SUBROUTINE CUDTDQ
2404	!**********************************************
2405	SUBROUTINE CUDTDQ &
2406	(KLON, KLEV, KLEVP1, KTOPM2, PAPH, &
2407	LDCUM, PTEN, PTTE, PQTE, PMFUS, &
2408	PMFDS, PMFUQ, PMFDQ, PMFUL, PDMFUP, &
2409	PDMFDP, ZTMST, PDPMEL, PRAIN, PRFL, &
2410	PSFL, PSRAIN, PSEVAP, PSHEAT, PSMELT, &
2411	PRSFC, PSSFC, PAPRC, PAPRSM, PAPRS, &
2412	PQEN, PQSEN, PLUDE, PCTE)
2413	!**** CUDTDQ - UPDATES T AND Q TENDENCIES, PRECIPITATION RATES
2414	! DOES GLOBAL DIAGNOSTICS
2415	! M.TIEDTKE E.C.M.W.F. 7/86 MODIF. 12/89
2416	!***INTERFACE.
2417	! ----------
2418	! CUDTDQ IS CALLED FROM CUMASTR
2419	! ----------------------------------------------------------------
2420	!-------------------------------------------------------------------
2421	IMPLICIT NONE
2422	!-------------------------------------------------------------------
2423	INTEGER KLON, KLEV, KLEVP1
2424	INTEGER KTOPM2,JL, JK
2425	REAL ZTMST, PSRAIN, PSEVAP, PSHEAT, PSMELT, ZDIAGT, ZDIAGW
2426	REAL ZALV, RHK, RHCOE, PLDFD, ZDTDT, ZDQDT
2427	REAL PTTE(KLON,KLEV), PQTE(KLON,KLEV), &
2428	PTEN(KLON,KLEV), PLUDE(KLON,KLEV), &
2429	PGEO(KLON,KLEV), PAPH(KLON,KLEVP1), &
2430	PAPRC(KLON), PAPRS(KLON), &
2431	PAPRSM(KLON), PCTE(KLON,KLEV), &
2432	PRSFC(KLON), PSSFC(KLON)
2433	REAL PMFUS(KLON,KLEV), PMFDS(KLON,KLEV), &
2434	PMFUQ(KLON,KLEV), PMFDQ(KLON,KLEV), &
2435	PMFUL(KLON,KLEV), PQSEN(KLON,KLEV), &
2436	PDMFUP(KLON,KLEV), PDMFDP(KLON,KLEV),&
2437	PRFL(KLON), PRAIN(KLON), &
2438	PQEN(KLON,KLEV)
2439	REAL PDPMEL(KLON,KLEV), PSFL(KLON)
2440	REAL ZSHEAT(KLON), ZMELT(KLON)
2441	LOGICAL LDCUM(KLON)
2442	!--------------------------------
2443	!* 1.0 SPECIFY PARAMETERS
2444	!--------------------------------
2445	100 CONTINUE
2446	ZDIAGT=ZTMST
2447	ZDIAGW=ZDIAGT/RHOH2O
2448	!--------------------------------------------------
2449	!* 2.0 INCREMENTATION OF T AND Q TENDENCIES
2450	!--------------------------------------------------
2451	200 CONTINUE
2452	DO 210 JL=1,KLON
2453	ZMELT(JL)=0.
2454	ZSHEAT(JL)=0.
2455	210 CONTINUE
2456	DO 250 JK=KTOPM2,KLEV
2457	IF(JK.LT.KLEV) THEN
2458	DO 220 JL=1,KLON
2459	IF(LDCUM(JL)) THEN
2460	IF(PTEN(JL,JK).GT.TMELT) THEN
2461	ZALV=ALV
2462	ELSE
2463	ZALV=ALS
2464	ENDIF
2465	RHK=MIN(1.0,PQEN(JL,JK)/PQSEN(JL,JK))
2466	RHCOE=MAX(0.0,(RHK-RHC)/(RHM-RHC))
2467	pldfd=MAX(0.0,RHCOEfdbkPLUDE(JL,JK))
2468	ZDTDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))RCPD &
2469	(PMFUS(JL,JK+1)-PMFUS(JL,JK)+ &
2470	PMFDS(JL,JK+1)-PMFDS(JL,JK)-ALF*PDPMEL(JL,JK) &
2471	-ZALV*(PMFUL(JL,JK+1)-PMFUL(JL,JK)-pldfd- &
2472	(PDMFUP(JL,JK)+PDMFDP(JL,JK))))
2473	PTTE(JL,JK)=PTTE(JL,JK)+ZDTDT
2474	ZDQDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*&
2475	(PMFUQ(JL,JK+1)-PMFUQ(JL,JK)+ &
2476	PMFDQ(JL,JK+1)-PMFDQ(JL,JK)+ &
2477	PMFUL(JL,JK+1)-PMFUL(JL,JK)-pldfd- &
2478	(PDMFUP(JL,JK)+PDMFDP(JL,JK)))
2479	PQTE(JL,JK)=PQTE(JL,JK)+ZDQDT
2480	PCTE(JL,JK)=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*pldfd
2481	ZSHEAT(JL)=ZSHEAT(JL)+ZALV*(PDMFUP(JL,JK)+PDMFDP(JL,JK))
2482	ZMELT(JL)=ZMELT(JL)+PDPMEL(JL,JK)
2483	END IF
2484	220 CONTINUE
2485	ELSE
2486	DO 230 JL=1,KLON
2487	IF(LDCUM(JL)) THEN
2488	IF(PTEN(JL,JK).GT.TMELT) THEN
2489	ZALV=ALV
2490	ELSE
2491	ZALV=ALS
2492	ENDIF
2493	RHK=MIN(1.0,PQEN(JL,JK)/PQSEN(JL,JK))
2494	RHCOE=MAX(0.0,(RHK-RHC)/(RHM-RHC))
2495	pldfd=MAX(0.0,RHCOEfdbkPLUDE(JL,JK))
2496	ZDTDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))RCPD &
2497	(PMFUS(JL,JK)+PMFDS(JL,JK)+ALFPDPMEL(JL,JK)-ZALV &
2498	(PMFUL(JL,JK)+PDMFUP(JL,JK)+PDMFDP(JL,JK)+pldfd))
2499	PTTE(JL,JK)=PTTE(JL,JK)+ZDTDT
2500	ZDQDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
2501	(PMFUQ(JL,JK)+PMFDQ(JL,JK)+pldfd+ &
2502	(PMFUL(JL,JK)+PDMFUP(JL,JK)+PDMFDP(JL,JK)))
2503	PQTE(JL,JK)=PQTE(JL,JK)+ZDQDT
2504	PCTE(JL,JK)=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*pldfd
2505	ZSHEAT(JL)=ZSHEAT(JL)+ZALV*(PDMFUP(JL,JK)+PDMFDP(JL,JK))
2506	ZMELT(JL)=ZMELT(JL)+PDPMEL(JL,JK)
2507	END IF
2508	230 CONTINUE
2509	END IF
2510	250 CONTINUE
2511	!---------------------------------------------------------
2512	! 3. UPDATE SURFACE FIELDS AND DO GLOBAL BUDGETS
2513	!---------------------------------------------------------
2514	300 CONTINUE
2515	DO 310 JL=1,KLON
2516	PRSFC(JL)=PRFL(JL)
2517	PSSFC(JL)=PSFL(JL)
2518	PAPRC(JL)=PAPRC(JL)+ZDIAGW*(PRFL(JL)+PSFL(JL))
2519	PAPRS(JL)=PAPRSM(JL)+ZDIAGW*PSFL(JL)
2520	PSHEAT=PSHEAT+ZSHEAT(JL)
2521	PSRAIN=PSRAIN+PRAIN(JL)
2522	PSEVAP=PSEVAP-(PRFL(JL)+PSFL(JL))
2523	PSMELT=PSMELT+ZMELT(JL)
2524	310 CONTINUE
2525	PSEVAP=PSEVAP+PSRAIN
2526	RETURN
2527	END SUBROUTINE CUDTDQ
2528
2529	!
2530	!**********************************************
2531	! SUBROUTINE CUDUDV
2532	!**********************************************
2533	SUBROUTINE CUDUDV &
2534	(KLON, KLEV, KLEVP1, KTOPM2, KTYPE, &
2535	KCBOT, PAPH, LDCUM, PUEN, PVEN, &
2536	PVOM, PVOL, PUU, PUD, PVU, &
2537	PVD, PMFU, PMFD, PSDISS)
2538	!**** CUDUDV - UPDATES U AND V TENDENCIES,
2539	! DOES GLOBAL DIAGNOSTIC OF DISSIPATION
2540	! M.TIEDTKE E.C.M.W.F. 7/86 MODIF. 12/89
2541	!***INTERFACE.
2542	! ----------
2543	! CUDUDV IS CALLED FROM CUMASTR
2544	! ----------------------------------------------------------------
2545	!-------------------------------------------------------------------
2546	IMPLICIT NONE
2547	!-------------------------------------------------------------------
2548	INTEGER KLON, KLEV, KLEVP1
2549	INTEGER KTOPM2, JK, IK, JL, IKB
2550	REAL PSDISS,ZZP, ZDUDT ,ZDVDT, ZSUM
2551	REAL PUEN(KLON,KLEV), PVEN(KLON,KLEV), &
2552	PVOL(KLON,KLEV), PVOM(KLON,KLEV), &
2553	PAPH(KLON,KLEVP1)
2554	REAL PUU(KLON,KLEV), PUD(KLON,KLEV), &
2555	PVU(KLON,KLEV), PVD(KLON,KLEV), &
2556	PMFU(KLON,KLEV), PMFD(KLON,KLEV)
2557	REAL ZMFUU(KLON,KLEV), ZMFDU(KLON,KLEV), &
2558	ZMFUV(KLON,KLEV), ZMFDV(KLON,KLEV), &
2559	ZDISS(KLON)
2560	INTEGER KTYPE(KLON), KCBOT(KLON)
2561	LOGICAL LDCUM(KLON)
2562	!------------------------------------------------------------
2563	!* 1.0 CALCULATE FLUXES AND UPDATE U AND V TENDENCIES
2564	! -----------------------------------------------------------
2565	100 CONTINUE
2566	DO 120 JK=KTOPM2,KLEV
2567	IK=JK-1
2568	DO 110 JL=1,KLON
2569	IF(LDCUM(JL)) THEN
2570	ZMFUU(JL,JK)=PMFU(JL,JK)*(PUU(JL,JK)-PUEN(JL,IK))
2571	ZMFUV(JL,JK)=PMFU(JL,JK)*(PVU(JL,JK)-PVEN(JL,IK))
2572	ZMFDU(JL,JK)=PMFD(JL,JK)*(PUD(JL,JK)-PUEN(JL,IK))
2573	ZMFDV(JL,JK)=PMFD(JL,JK)*(PVD(JL,JK)-PVEN(JL,IK))
2574	END IF
2575	110 CONTINUE
2576	120 CONTINUE
2577	DO 140 JK=KTOPM2,KLEV
2578	DO 130 JL=1,KLON
2579	IF(LDCUM(JL).AND.JK.GT.KCBOT(JL)) THEN
2580	IKB=KCBOT(JL)
2581	ZZP=((PAPH(JL,KLEVP1)-PAPH(JL,JK))/ &
2582	(PAPH(JL,KLEVP1)-PAPH(JL,IKB)))
2583	IF(KTYPE(JL).EQ.3) THEN
2584	ZZP=ZZP**2
2585	ENDIF
2586	ZMFUU(JL,JK)=ZMFUU(JL,IKB)*ZZP
2587	ZMFUV(JL,JK)=ZMFUV(JL,IKB)*ZZP
2588	ZMFDU(JL,JK)=ZMFDU(JL,IKB)*ZZP
2589	ZMFDV(JL,JK)=ZMFDV(JL,IKB)*ZZP
2590	END IF
2591	130 CONTINUE
2592	140 CONTINUE
2593	DO 150 JL=1,KLON
2594	ZDISS(JL)=0.
2595	150 CONTINUE
2596	DO 190 JK=KTOPM2,KLEV
2597	IF(JK.LT.KLEV) THEN
2598	DO 160 JL=1,KLON
2599	IF(LDCUM(JL)) THEN
2600	ZDUDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
2601	(ZMFUU(JL,JK+1)-ZMFUU(JL,JK)+ &
2602	ZMFDU(JL,JK+1)-ZMFDU(JL,JK))
2603	ZDVDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
2604	(ZMFUV(JL,JK+1)-ZMFUV(JL,JK)+ &
2605	ZMFDV(JL,JK+1)-ZMFDV(JL,JK))
2606	ZDISS(JL)=ZDISS(JL)+ &
2607	PUEN(JL,JK)*(ZMFUU(JL,JK+1)-ZMFUU(JL,JK)+ &
2608	ZMFDU(JL,JK+1)-ZMFDU(JL,JK))+ &
2609	PVEN(JL,JK)*(ZMFUV(JL,JK+1)-ZMFUV(JL,JK)+ &
2610	ZMFDV(JL,JK+1)-ZMFDV(JL,JK))
2611	PVOM(JL,JK)=PVOM(JL,JK)+ZDUDT
2612	PVOL(JL,JK)=PVOL(JL,JK)+ZDVDT
2613	END IF
2614	160 CONTINUE
2615	ELSE
2616	DO 170 JL=1,KLON
2617	IF(LDCUM(JL)) THEN
2618	ZDUDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
2619	(ZMFUU(JL,JK)+ZMFDU(JL,JK))
2620	ZDVDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
2621	(ZMFUV(JL,JK)+ZMFDV(JL,JK))
2622	ZDISS(JL)=ZDISS(JL)- &
2623	(PUEN(JL,JK)*(ZMFUU(JL,JK)+ZMFDU(JL,JK))+ &
2624	PVEN(JL,JK)*(ZMFUV(JL,JK)+ZMFDV(JL,JK)))
2625	PVOM(JL,JK)=PVOM(JL,JK)+ZDUDT
2626	PVOL(JL,JK)=PVOL(JL,JK)+ZDVDT
2627	END IF
2628	170 CONTINUE
2629	END IF
2630	190 CONTINUE
2631	ZSUM=SSUM(KLON,ZDISS(1),1)
2632	PSDISS=PSDISS+ZSUM
2633	RETURN
2634	END SUBROUTINE CUDUDV
2635	!
2636
2637	!#################################################################
2638	!
2639	! LEVEL 4 SUBROUTINES
2640	!
2641	!#################################################################
2642	!**************************************************************
2643	! SUBROUTINE CUBASMC
2644	!**************************************************************
2645	SUBROUTINE CUBASMC &
2646	(KLON, KLEV, KLEVM1, KK, PTEN, &
2647	PQEN, PQSEN, PUEN, PVEN, PVERV, &
2648	PGEO, PGEOH, LDCUM, KTYPE, KLAB, &
2649	PMFU, PMFUB, PENTR, KCBOT, PTU, &
2650	PQU, PLU, PUU, PVU, PMFUS, &
2651	PMFUQ, PMFUL, PDMFUP, PMFUU, PMFUV)
2652	! M.TIEDTKE E.C.M.W.F. 12/89
2653	!***PURPOSE.
2654	! --------
2655	! THIS ROUTINE CALCULATES CLOUD BASE VALUES
2656	! FOR MIDLEVEL CONVECTION
2657	!***INTERFACE
2658	! ---------
2659	! THIS ROUTINE IS CALLED FROM CUASC.
2660	! INPUT ARE ENVIRONMENTAL VALUES T,Q ETC
2661	! IT RETURNS CLOUDBASE VALUES FOR MIDLEVEL CONVECTION
2662	!***METHOD.
2663	! -------
2664	! S. TIEDTKE (1989)
2665	!***EXTERNALS
2666	! ---------
2667	! NONE
2668	! ----------------------------------------------------------------
2669	!-------------------------------------------------------------------
2670	IMPLICIT NONE
2671	!-------------------------------------------------------------------
2672	INTEGER KLON, KLEV, KLEVP1
2673	INTEGER KLEVM1,KK, JL
2674	REAL zzzmb
2675	REAL PTEN(KLON,KLEV), PQEN(KLON,KLEV), &
2676	PUEN(KLON,KLEV), PVEN(KLON,KLEV), &
2677	PQSEN(KLON,KLEV), PVERV(KLON,KLEV), &
2678	PGEO(KLON,KLEV), PGEOH(KLON,KLEV)
2679	REAL PTU(KLON,KLEV), PQU(KLON,KLEV), &
2680	PUU(KLON,KLEV), PVU(KLON,KLEV), &
2681	PLU(KLON,KLEV), PMFU(KLON,KLEV), &
2682	PMFUB(KLON), PENTR(KLON), &
2683	PMFUS(KLON,KLEV), PMFUQ(KLON,KLEV), &
2684	PMFUL(KLON,KLEV), PDMFUP(KLON,KLEV), &
2685	PMFUU(KLON), PMFUV(KLON)
2686	INTEGER KTYPE(KLON), KCBOT(KLON), &
2687	KLAB(KLON,KLEV)
2688	LOGICAL LDCUM(KLON)
2689	!--------------------------------------------------------
2690	!* 1. CALCULATE ENTRAINMENT AND DETRAINMENT RATES
2691	! -------------------------------------------------------
2692	100 CONTINUE
2693	DO 150 JL=1,KLON
2694	IF( .NOT. LDCUM(JL).AND.KLAB(JL,KK+1).EQ.0.0.AND. &
2695	PQEN(JL,KK).GT.0.90*PQSEN(JL,KK)) THEN
2696	PTU(JL,KK+1)=(CPD*PTEN(JL,KK)+PGEO(JL,KK)-PGEOH(JL,KK+1)) &
2697	*RCPD
2698	PQU(JL,KK+1)=PQEN(JL,KK)
2699	PLU(JL,KK+1)=0.
2700	ZZZMB=MAX(CMFCMIN,-PVERV(JL,KK)/G)
2701	ZZZMB=MIN(ZZZMB,CMFCMAX)
2702	PMFUB(JL)=ZZZMB
2703	PMFU(JL,KK+1)=PMFUB(JL)
2704	PMFUS(JL,KK+1)=PMFUB(JL)(CPDPTU(JL,KK+1)+PGEOH(JL,KK+1))
2705	PMFUQ(JL,KK+1)=PMFUB(JL)*PQU(JL,KK+1)
2706	PMFUL(JL,KK+1)=0.
2707	PDMFUP(JL,KK+1)=0.
2708	KCBOT(JL)=KK
2709	KLAB(JL,KK+1)=1
2710	KTYPE(JL)=3
2711	PENTR(JL)=ENTRMID
2712	IF(LMFDUDV) THEN
2713	PUU(JL,KK+1)=PUEN(JL,KK)
2714	PVU(JL,KK+1)=PVEN(JL,KK)
2715	PMFUU(JL)=PMFUB(JL)*PUU(JL,KK+1)
2716	PMFUV(JL)=PMFUB(JL)*PVU(JL,KK+1)
2717	END IF
2718	END IF
2719	150 CONTINUE
2720	RETURN
2721	END SUBROUTINE CUBASMC
2722
2723	!
2724	!**************************************************************
2725	! SUBROUTINE CUADJTQ
2726	!**************************************************************
2727	SUBROUTINE CUADJTQ(KLON,KLEV,KK,PP,PT,PQ,LDFLAG,KCALL)
2728	! M.TIEDTKE E.C.M.W.F. 12/89
2729	! D.SALMOND CRAY(UK)) 12/8/91
2730	!***PURPOSE.
2731	! --------
2732	! TO PRODUCE T,Q AND L VALUES FOR CLOUD ASCENT
2733	!***INTERFACE
2734	! ---------
2735	! THIS ROUTINE IS CALLED FROM SUBROUTINES:
2736	! CUBASE (T AND Q AT CONDENSTION LEVEL)
2737	! CUASC (T AND Q AT CLOUD LEVELS)
2738	! CUINI (ENVIRONMENTAL T AND QS VALUES AT HALF LEVELS)
2739	! INPUT ARE UNADJUSTED T AND Q VALUES,
2740	! IT RETURNS ADJUSTED VALUES OF T AND Q
2741	! NOTE: INPUT PARAMETER KCALL DEFINES CALCULATION AS
2742	! KCALL=0 ENV. T AND QS INCUINI
2743	! KCALL=1 CONDENSATION IN UPDRAFTS (E.G. CUBASE, CUASC)
2744	! KCALL=2 EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF
2745	!***EXTERNALS
2746	! ---------
2747	! 3 LOOKUP TABLES ( TLUCUA, TLUCUB, TLUCUC )
2748	! FOR CONDENSATION CALCULATIONS.
2749	! THE TABLES ARE INITIALISED IN SETPHYS.
2750	! ----------------------------------------------------------------
2751	!-------------------------------------------------------------------
2752	IMPLICIT NONE
2753	!-------------------------------------------------------------------
2754	INTEGER KLON, KLEV
2755	INTEGER KK, KCALL, ISUM, JL
2756	REAL ZQSAT, ZCOR, ZCOND1, TT
2757	REAL PT(KLON,KLEV), PQ(KLON,KLEV), &
2758	ZCOND(KLON), ZQP(KLON), &
2759	PP(KLON)
2760	LOGICAL LDFLAG(KLON)
2761	!------------------------------------------------------------------
2762	! 2. CALCULATE CONDENSATION AND ADJUST T AND Q ACCORDINGLY
2763	!------------------------------------------------------------------
2764	200 CONTINUE
2765	IF (KCALL.EQ.1 ) THEN
2766	ISUM=0
2767	DO 210 JL=1,KLON
2768	ZCOND(JL)=0.
2769	IF(LDFLAG(JL)) THEN
2770	ZQP(JL)=1./PP(JL)
2771	TT=PT(JL,KK)
2772	ZQSAT=TLUCUA(TT)*ZQP(JL)
2773	ZQSAT=MIN(0.5,ZQSAT)
2774	ZCOR=1./(1.-VTMPC1*ZQSAT)
2775	ZQSAT=ZQSAT*ZCOR
2776	ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSATZCORTLUCUB(TT))
2777	ZCOND(JL)=MAX(ZCOND(JL),0.)
2778	PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL)
2779	PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL)
2780	IF(ZCOND(JL).NE.0.0) ISUM=ISUM+1
2781	END IF
2782	210 CONTINUE
2783	IF(ISUM.EQ.0) GO TO 230
2784	DO 220 JL=1,KLON
2785	IF(LDFLAG(JL).AND.ZCOND(JL).NE.0.) THEN
2786	TT=PT(JL,KK)
2787	ZQSAT=TLUCUA(TT)*ZQP(JL)
2788	ZQSAT=MIN(0.5,ZQSAT)
2789	ZCOR=1./(1.-VTMPC1*ZQSAT)
2790	ZQSAT=ZQSAT*ZCOR
2791	ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSATZCORTLUCUB(TT))
2792	PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1
2793	PQ(JL,KK)=PQ(JL,KK)-ZCOND1
2794	END IF
2795	220 CONTINUE
2796	230 CONTINUE
2797	END IF
2798	IF(KCALL.EQ.2) THEN
2799	ISUM=0
2800	DO 310 JL=1,KLON
2801	ZCOND(JL)=0.
2802	IF(LDFLAG(JL)) THEN
2803	TT=PT(JL,KK)
2804	ZQP(JL)=1./PP(JL)
2805	ZQSAT=TLUCUA(TT)*ZQP(JL)
2806	ZQSAT=MIN(0.5,ZQSAT)
2807	ZCOR=1./(1.-VTMPC1*ZQSAT)
2808	ZQSAT=ZQSAT*ZCOR
2809	ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSATZCORTLUCUB(TT))
2810	ZCOND(JL)=MIN(ZCOND(JL),0.)
2811	PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL)
2812	PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL)
2813	IF(ZCOND(JL).NE.0.0) ISUM=ISUM+1
2814	END IF
2815	310 CONTINUE
2816	IF(ISUM.EQ.0) GO TO 330
2817	DO 320 JL=1,KLON
2818	IF(LDFLAG(JL).AND.ZCOND(JL).NE.0.) THEN
2819	TT=PT(JL,KK)
2820	ZQSAT=TLUCUA(TT)*ZQP(JL)
2821	ZQSAT=MIN(0.5,ZQSAT)
2822	ZCOR=1./(1.-VTMPC1*ZQSAT)
2823	ZQSAT=ZQSAT*ZCOR
2824	ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSATZCORTLUCUB(TT))
2825	PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1
2826	PQ(JL,KK)=PQ(JL,KK)-ZCOND1
2827	END IF
2828	320 CONTINUE
2829	330 CONTINUE
2830	END IF
2831	IF(KCALL.EQ.0) THEN
2832	ISUM=0
2833	DO 410 JL=1,KLON
2834	TT=PT(JL,KK)
2835	ZQP(JL)=1./PP(JL)
2836	ZQSAT=TLUCUA(TT)*ZQP(JL)
2837	ZQSAT=MIN(0.5,ZQSAT)
2838	ZCOR=1./(1.-VTMPC1*ZQSAT)
2839	ZQSAT=ZQSAT*ZCOR
2840	ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSATZCORTLUCUB(TT))
2841	PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL)
2842	PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL)
2843	IF(ZCOND(JL).NE.0.0) ISUM=ISUM+1
2844	410 CONTINUE
2845	IF(ISUM.EQ.0) GO TO 430
2846	DO 420 JL=1,KLON
2847	TT=PT(JL,KK)
2848	ZQSAT=TLUCUA(TT)*ZQP(JL)
2849	ZQSAT=MIN(0.5,ZQSAT)
2850	ZCOR=1./(1.-VTMPC1*ZQSAT)
2851	ZQSAT=ZQSAT*ZCOR
2852	ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSATZCORTLUCUB(TT))
2853	PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1
2854	PQ(JL,KK)=PQ(JL,KK)-ZCOND1
2855	420 CONTINUE
2856	430 CONTINUE
2857	END IF
2858	IF(KCALL.EQ.4) THEN
2859	DO 510 JL=1,KLON
2860	TT=PT(JL,KK)
2861	ZQP(JL)=1./PP(JL)
2862	ZQSAT=TLUCUA(TT)*ZQP(JL)
2863	ZQSAT=MIN(0.5,ZQSAT)
2864	ZCOR=1./(1.-VTMPC1*ZQSAT)
2865	ZQSAT=ZQSAT*ZCOR
2866	ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSATZCORTLUCUB(TT))
2867	PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL)
2868	PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL)
2869	510 CONTINUE
2870	DO 520 JL=1,KLON
2871	TT=PT(JL,KK)
2872	ZQSAT=TLUCUA(TT)*ZQP(JL)
2873	ZQSAT=MIN(0.5,ZQSAT)
2874	ZCOR=1./(1.-VTMPC1*ZQSAT)
2875	ZQSAT=ZQSAT*ZCOR
2876	ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSATZCORTLUCUB(TT))
2877	PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1
2878	PQ(JL,KK)=PQ(JL,KK)-ZCOND1
2879	520 CONTINUE
2880	END IF
2881	RETURN
2882	END SUBROUTINE CUADJTQ
2883
2884	!
2885	!**********************************************************
2886	! SUBROUTINE CUENTR_NEW
2887	!**********************************************************
2888	SUBROUTINE CUENTR_NEW &
2889	(KLON, KLEV, KLEVP1, KK, PTENH, &
2890	PAPH, PAP, PGEOH, KLWMIN, LDCUM, &
2891	KTYPE, KCBOT, KCTOP0, ZPBASE, PMFU, &
2892	PENTR, ZDMFEN, ZDMFDE, ZODETR, KHMIN)
2893	! M.TIEDTKE E.C.M.W.F. 12/89
2894	! Y.WANG IPRC 11/01
2895	!***PURPOSE.
2896	! --------
2897	! THIS ROUTINE CALCULATES ENTRAINMENT/DETRAINMENT RATES
2898	! FOR UPDRAFTS IN CUMULUS PARAMETERIZATION
2899	!***INTERFACE
2900	! ---------
2901	! THIS ROUTINE IS CALLED FROM CUASC.
2902	! INPUT ARE ENVIRONMENTAL VALUES T,Q ETC
2903	! AND UPDRAFT VALUES T,Q ETC
2904	! IT RETURNS ENTRAINMENT/DETRAINMENT RATES
2905	!***METHOD.
2906	! --------
2907	! S. TIEDTKE (1989), NORDENG(1996)
2908	!***EXTERNALS
2909	! ---------
2910	! NONE
2911	! ----------------------------------------------------------------
2912	!-------------------------------------------------------------------
2913	IMPLICIT NONE
2914	!-------------------------------------------------------------------
2915	INTEGER KLON, KLEV, KLEVP1
2916	INTEGER KK, JL, IKLWMIN,IKB, IKT, IKH
2917	REAL ZRRHO, ZDPRHO, ZPMID, ZENTR, ZZMZK, ZTMZK, ARG, ZORGDE
2918	REAL PTENH(KLON,KLEV), &
2919	PAP(KLON,KLEV), PAPH(KLON,KLEVP1), &
2920	PMFU(KLON,KLEV), PGEOH(KLON,KLEV), &
2921	PENTR(KLON), ZPBASE(KLON), &
2922	ZDMFEN(KLON), ZDMFDE(KLON), &
2923	ZODETR(KLON,KLEV)
2924	INTEGER KLWMIN(KLON), KTYPE(KLON), &
2925	KCBOT(KLON), KCTOP0(KLON), &
2926	KHMIN(KLON)
2927	LOGICAL LDCUM(KLON),LLO1,LLO2
2928	!---------------------------------------------------------
2929	!* 1. CALCULATE ENTRAINMENT AND DETRAINMENT RATES
2930	!---------------------------------------------------------
2931	!* 1.1 SPECIFY ENTRAINMENT RATES FOR SHALLOW CLOUDS
2932	!----------------------------------------------------------
2933	!* 1.2 SPECIFY ENTRAINMENT RATES FOR DEEP CLOUDS
2934	!-------------------------------------------------------
2935	DO jl = 1, klon
2936	zpbase(jl) = paph(jl,kcbot(jl))
2937	zrrho = (rd*ptenh(jl,kk+1))/paph(jl,kk+1)
2938	zdprho = (paph(jl,kk+1)-paph(jl,kk))*zrg
2939	zpmid = 0.5*(zpbase(jl)+paph(jl,kctop0(jl)))
2940	zentr = pentr(jl)pmfu(jl,kk+1)zdprho*zrrho
2941	llo1 = kk.LT.kcbot(jl).AND.ldcum(jl)
2942	if(llo1) then
2943	zdmfde(jl) = zentr
2944	else
2945	zdmfde(jl) = 0.0
2946	endif
2947	llo2 = llo1.AND.ktype(jl).EQ.2.AND.((zpbase(jl)-paph(jl,kk)) &
2948	.LT.ZDNOPRC.OR.paph(jl,kk).GT.zpmid)
2949	if(llo2) then
2950	zdmfen(jl) = zentr
2951	else
2952	zdmfen(jl) = 0.0
2953	endif
2954	iklwmin = MAX(klwmin(jl),kctop0(jl)+2)
2955	llo2 = llo1.AND.ktype(jl).EQ.3.AND.(kk.GE.iklwmin.OR.pap(jl,kk) &
2956	.GT.zpmid)
2957	IF (llo2) zdmfen(jl) = zentr
2958	llo2 = llo1.AND.ktype(jl).EQ.1
2959	! Turbulent entrainment
2960	IF (llo2) zdmfen(jl) = zentr
2961	! Organized detrainment, detrainment starts at khmin
2962	ikb = kcbot(jl)
2963	zodetr(jl,kk) = 0.
2964	IF (llo2.AND.kk.LE.khmin(jl).AND.kk.GE.kctop0(jl)) THEN
2965	ikt = kctop0(jl)
2966	ikh = khmin(jl)
2967	IF (ikh.GT.ikt) THEN
2968	zzmzk = -(pgeoh(jl,ikh)-pgeoh(jl,kk))*zrg
2969	ztmzk = -(pgeoh(jl,ikh)-pgeoh(jl,ikt))*zrg
2970	arg = 3.1415(zzmzk/ztmzk)0.5
2971	zorgde = TAN(arg)3.14150.5/ztmzk
2972	zdprho = (paph(jl,kk+1)-paph(jl,kk))(zrgzrrho)
2973	zodetr(jl,kk) = MIN(zorgde,1.E-3)pmfu(jl,kk+1)zdprho
2974	END IF
2975	END IF
2976	ENDDO
2977	!
2978	RETURN
2979	END SUBROUTINE CUENTR_NEW
2980	!
2981
2982	!**********************************************************
2983	! FUNCTION SSUM, TLUCUA, TLUCUB, TLUCUC
2984	!**********************************************************
2985	REAL FUNCTION SSUM ( N, X, IX )
2986	!
2987	! COMPUTES SSUM = SUM OF [X(I)]
2988	! FOR N ELEMENTS OF X WITH SKIP INCREMENT IX FOR VECTOR X
2989	!
2990	IMPLICIT NONE
2991	REAL X(*)
2992	REAL ZSUM
2993	INTEGER N, IX, JX, JL
2994	!
2995	JX = 1
2996	ZSUM = 0.0
2997	DO JL = 1, N
2998	ZSUM = ZSUM + X(JX)
2999	JX = JX + IX
3000	enddo
3001	!
3002	SSUM=ZSUM
3003	!
3004	RETURN
3005	END FUNCTION SSUM
3006
3007	REAL FUNCTION TLUCUA(TT)
3008	!
3009	! Set up lookup tables for cloud ascent calculations.
3010	!
3011	IMPLICIT NONE
3012	REAL ZCVM3,ZCVM4,TT !,TLUCUA
3013	!
3014	IF(TT-TMELT.GT.0.) THEN
3015	ZCVM3=C3LES
3016	ZCVM4=C4LES
3017	ELSE
3018	ZCVM3=C3IES
3019	ZCVM4=C4IES
3020	END IF
3021	TLUCUA=C2ESEXP(ZCVM3(TT-TMELT)*(1./(TT-ZCVM4)))
3022	!
3023	RETURN
3024	END FUNCTION TLUCUA
3025	!
3026	REAL FUNCTION TLUCUB(TT)
3027	!
3028	! Set up lookup tables for cloud ascent calculations.
3029	!
3030	IMPLICIT NONE
3031	REAL Z5ALVCP,Z5ALSCP,ZCVM4,ZCVM5,TT !,TLUCUB
3032	!
3033	Z5ALVCP=C5LES*ALV/CPD
3034	Z5ALSCP=C5IES*ALS/CPD
3035	IF(TT-TMELT.GT.0.) THEN
3036	ZCVM4=C4LES
3037	ZCVM5=Z5ALVCP
3038	ELSE
3039	ZCVM4=C4IES
3040	ZCVM5=Z5ALSCP
3041	END IF
3042	TLUCUB=ZCVM5(1./(TT-ZCVM4))*2
3043	!
3044	RETURN
3045	END FUNCTION TLUCUB
3046	!
3047	REAL FUNCTION TLUCUC(TT)
3048	!
3049	! Set up lookup tables for cloud ascent calculations.
3050	!
3051	IMPLICIT NONE
3052	REAL ZALVDCP,ZALSDCP,TT,ZLDCP !,TLUCUC
3053	!
3054	ZALVDCP=ALV/CPD
3055	ZALSDCP=ALS/CPD
3056	IF(TT-TMELT.GT.0.) THEN
3057	ZLDCP=ZALVDCP
3058	ELSE
3059	ZLDCP=ZALSDCP
3060	END IF
3061	TLUCUC=ZLDCP
3062	!
3063	RETURN
3064	END FUNCTION TLUCUC
3065	!
3066
3067	END MODULE module_cu_tiedtke

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

Download in other formats:

Original Format