Context Navigation

newmicro.F @ 1522

Last change on this file since 1522 was 1522, checked in by idelkadi, 14 years ago
Correction du diagnostique utilise pour le calcul des fractions de nuages bas, moyens et haut
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 25.8 KB

Rev	Line
[1279]	1	! $Id: newmicro.F 1522 2011-05-24 14:50:59Z idelkadi $
[1522]	2
	3
	4
[1279]	5	!
[524]	6	SUBROUTINE newmicro (paprs, pplay,ok_newmicro,
	7	. t, pqlwp, pclc, pcltau, pclemi,
	8	. pch, pcl, pcm, pct, pctlwp,
	9	s xflwp, xfiwp, xflwc, xfiwc,
	10	e ok_aie,
[1279]	11	e mass_solu_aero, mass_solu_aero_pi,
[524]	12	e bl95_b0, bl95_b1,
[1279]	13	s cldtaupi, re, fl, reliq, reice)
	14
[766]	15	USE dimphy
[1337]	16	USE phys_local_var_mod, only: scdnc,cldncl,reffclwtop,lcc,
	17	. reffclws,reffclwc,cldnvi,lcc3d,
	18	. lcc3dcon,lcc3dstra
	19	USE phys_state_var_mod, only: rnebcon,clwcon
[524]	20	IMPLICIT none
	21	c======================================================================
	22	c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910
	23	c Objet: Calculer epaisseur optique et emmissivite des nuages
	24	c======================================================================
	25	c Arguments:
	26	c t-------input-R-temperature
	27	c pqlwp---input-R-eau liquide nuageuse dans l'atmosphere (kg/kg)
	28	c pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1)
	29	c
	30	c ok_aie--input-L-apply aerosol indirect effect or not
[1279]	31	c mass_solu_aero-----input-R-total mass concentration for all soluble aerosols[ug/m^3]
	32	c mass_solu_aero_pi--input-R-dito, pre-industrial value
[524]	33	c bl95_b0-input-R-a parameter, may be varied for tests (s-sea, l-land)
	34	c bl95_b1-input-R-a parameter, may be varied for tests ( -"- )
	35	c
	36	c cldtaupi-output-R-pre-industrial value of cloud optical thickness,
	37	c needed for the diagnostics of the aerosol indirect
	38	c radiative forcing (see radlwsw)
	39	c re------output-R-Cloud droplet effective radius multiplied by fl [um]
	40	c fl------output-R-Denominator to re, introduced to avoid problems in
	41	c the averaging of the output. fl is the fraction of liquid
	42	c water clouds within a grid cell
	43	c pcltau--output-R-epaisseur optique des nuages
	44	c pclemi--output-R-emissivite des nuages (0 a 1)
	45	c======================================================================
	46	C
	47	#include "YOMCST.h"
	48	c
[766]	49	cym#include "dimensions.h"
	50	cym#include "dimphy.h"
[524]	51	#include "nuage.h"
[685]	52	cIM cf. CR: include pour NOVLP et ZEPSEC
	53	#include "radepsi.h"
	54	#include "radopt.h"
[1337]	55	c choix de l'hypothese de recouvrememnt nuageuse
[1522]	56	LOGICAL RANDOM,MAXIMUM_RANDOM,MAXIMUM
[1337]	57	parameter (RANDOM=.FALSE., MAXIMUM_RANDOM=.TRUE., MAXIMUM=.FALSE.)
[1522]	58	LOGICAL, SAVE :: FIRST=.TRUE.
	59	!$OMP THREADPRIVATE(FIRST)
[1337]	60	c Hypoyhese de recouvrement : MAXIMUM_RANDOM
	61	INTEGER flag_max
	62	REAL phase3d(klon, klev),dh(klon, klev),pdel(klon, klev),
	63	. zrho(klon, klev)
	64	REAL tcc(klon), ftmp(klon), lcc_integrat(klon), height(klon)
	65	REAL thres_tau,thres_neb
	66	PARAMETER (thres_tau=0.3, thres_neb=0.001)
	67	REAL t_tmp
	68	REAL gravit
	69	PARAMETER (gravit=9.80616) !m/s2
	70	REAL pqlwpcon(klon, klev), pqlwpstra(klon, klev)
	71	c
[524]	72	REAL paprs(klon,klev+1), pplay(klon,klev)
	73	REAL t(klon,klev)
	74	c
	75	REAL pclc(klon,klev)
	76	REAL pqlwp(klon,klev)
	77	REAL pcltau(klon,klev), pclemi(klon,klev)
	78	c
	79	REAL pct(klon), pctlwp(klon), pch(klon), pcl(klon), pcm(klon)
	80	c
	81	LOGICAL lo
	82	c
[1522]	83	!!Abderr modif JL mail du 19.01.2011 18:31
	84	! REAL cetahb, cetamb
	85	! PARAMETER (cetahb = 0.45, cetamb = 0.80)
	86	! Remplacer
	87	!cetahb*paprs(i,1) par prmhc
	88	!cetamb*paprs(i,1) par prlmc
	89	REAL prmhc ! Pressure between medium and high level cloud
	90	REAL prlmc ! Pressure between low and medium level cloud
	91	PARAMETER (prmhc = 440.100., prlmc = 680.100.)
	92
[524]	93	C
	94	INTEGER i, k
	95	cIM: 091003 REAL zflwp, zradef, zfice, zmsac
	96	REAL zflwp(klon), zradef, zfice, zmsac
	97	cIM: 091003 rajout
	98	REAL xflwp(klon), xfiwp(klon)
	99	REAL xflwc(klon,klev), xfiwc(klon,klev)
	100	c
	101	REAL radius, rad_chaud
	102	cc PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0)
	103	ccc PARAMETER (rad_chaud=15.0, rad_froid=35.0)
	104	c sintex initial PARAMETER (rad_chaud=10.0, rad_froid=30.0)
	105	REAL coef, coef_froi, coef_chau
	106	PARAMETER (coef_chau=0.13, coef_froi=0.09)
[1286]	107	REAL seuil_neb
	108	PARAMETER (seuil_neb=0.001)
[524]	109	INTEGER nexpo ! exponentiel pour glace/eau
	110	PARAMETER (nexpo=6)
	111	ccc PARAMETER (nexpo=1)
	112
	113	c -- sb:
	114	logical ok_newmicro
	115	c parameter (ok_newmicro=.FALSE.)
	116	cIM: 091003 real rel, tc, rei, zfiwp
	117	real rel, tc, rei, zfiwp(klon)
	118	real k_liq, k_ice0, k_ice, DF
	119	parameter (k_liq=0.0903, k_ice0=0.005) ! units=m2/g
	120	parameter (DF=1.66) ! diffusivity factor
	121	c sb --
	122	cjq for the aerosol indirect effect
	123	cjq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003
	124	cjq
	125	LOGICAL ok_aie ! Apply AIE or not?
	126	LOGICAL ok_a1lwpdep ! a1 LWP dependent?
	127
[1279]	128	REAL mass_solu_aero(klon, klev) ! total mass concentration for all soluble aerosols [ug m-3]
	129	REAL mass_solu_aero_pi(klon, klev) ! - " - (pre-industrial value)
[524]	130	REAL cdnc(klon, klev) ! cloud droplet number concentration [m-3]
	131	REAL re(klon, klev) ! cloud droplet effective radius [um]
	132	REAL cdnc_pi(klon, klev) ! cloud droplet number concentration [m-3] (pi value)
	133	REAL re_pi(klon, klev) ! cloud droplet effective radius [um] (pi value)
	134
	135	REAL fl(klon, klev) ! xliq * rneb (denominator to re; fraction of liquid water clouds within the grid cell)
	136
	137	REAL bl95_b0, bl95_b1 ! Parameter in B&L 95-Formula
	138
	139	REAL cldtaupi(klon, klev) ! pre-industrial cloud opt thickness for diag
	140	cjq-end
[685]	141	cIM cf. CR:parametres supplementaires
	142	REAL zclear(klon)
	143	REAL zcloud(klon)
[1522]	144	REAL zcloudh(klon)
	145	REAL zcloudm(klon)
	146	REAL zcloudl(klon)
[1146]	147
[1522]	148
[1146]	149	c **************************
	150	c * *
	151	c * DEBUT PARTIE OPTIMISEE *
	152	c * *
	153	c **************************
	154
	155	REAL diff_paprs(klon, klev), zfice1, zfice2(klon, klev)
	156	REAL rad_chaud_tab(klon, klev), zflwp_var, zfiwp_var
	157
[1279]	158	! Abderrahmane oct 2009
	159	Real reliq(klon, klev), reice(klon, klev)
	160
[524]	161	c
	162	c Calculer l'epaisseur optique et l'emmissivite des nuages
	163	c
[1146]	164	c IM inversion des DO
	165	xflwp = 0.d0
	166	xfiwp = 0.d0
	167	xflwc = 0.d0
	168	xfiwc = 0.d0
	169
[1334]	170	! Initialisation
	171	reliq=0.
	172	reice=0.
	173
[524]	174	DO k = 1, klev
[1146]	175	DO i = 1, klon
	176	diff_paprs(i,k) = (paprs(i,k)-paprs(i,k+1))/RG
	177	ENDDO
	178	ENDDO
[524]	179
[1146]	180	IF (ok_newmicro) THEN
[524]	181
	182
[1146]	183	DO k = 1, klev
	184	DO i = 1, klon
[1286]	185	c zfice2(i,k) = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace)
	186	zfice2(i,k) = 1.0 - (t(i,k)-t_glace_min) /
	187	& (t_glace_max-t_glace_min)
[1146]	188	zfice2(i,k) = MIN(MAX(zfice2(i,k),0.0),1.0)
	189	c IM Total Liquid/Ice water content
	190	xflwc(i,k) = (1.-zfice2(i,k))*pqlwp(i,k)
	191	xfiwc(i,k) = zfice2(i,k)*pqlwp(i,k)
	192	c IM In-Cloud Liquid/Ice water content
	193	c xflwc(i,k) = xflwc(i,k)+(1.-zfice)*pqlwp(i,k)/pclc(i,k)
	194	c xfiwc(i,k) = xfiwc(i,k)+zfice*pqlwp(i,k)/pclc(i,k)
	195	ENDDO
	196	ENDDO
[524]	197
[1146]	198	IF (ok_aie) THEN
	199	DO k = 1, klev
	200	DO i = 1, klon
	201	! Formula "D" of Boucher and Lohmann, Tellus, 1995
	202	!
	203	cdnc(i,k) = 10.*(bl95_b0+bl95_b1
[1279]	204	& log(MAX(mass_solu_aero(i,k),1.e-4))/log(10.))*1.e6 !-m-3
[1146]	205	! Cloud droplet number concentration (CDNC) is restricted
	206	! to be within [20, 1000 cm^3]
	207	!
	208	cdnc(i,k)=MIN(1000.e6,MAX(20.e6,cdnc(i,k)))
	209	!
	210	!
	211	cdnc_pi(i,k) = 10.*(bl95_b0+bl95_b1
[1305]	212	& log(MAX(mass_solu_aero_pi(i,k),1.e-4))/log(10.))
	213	& *1.e6 !-m-3
[1146]	214	cdnc_pi(i,k)=MIN(1000.e6,MAX(20.e6,cdnc_pi(i,k)))
	215	ENDDO
	216	ENDDO
	217	DO k = 1, klev
	218	DO i = 1, klon
	219	! rad_chaud_tab(i,k) =
	220	! & MAX(1.1e6
	221	! & ((pqlwp(i,k)pplay(i,k)/(RD * T(i,k)))
	222	! & /(4./3RPI1000.cdnc(i,k)) )*(1./3.),5.)
	223	rad_chaud_tab(i,k) =
	224	& 1.1
	225	& ((pqlwp(i,k)pplay(i,k)/(RD * T(i,k)))
	226	& /(4./3RPI1000.cdnc(i,k)) )*(1./3.)
	227	rad_chaud_tab(i,k) = MAX(rad_chaud_tab(i,k) * 1e6, 5.)
	228	ENDDO
	229	ENDDO
	230	ELSE
	231	DO k = 1, MIN(3,klev)
	232	DO i = 1, klon
	233	rad_chaud_tab(i,k) = rad_chau2
	234	ENDDO
	235	ENDDO
	236	DO k = MIN(3,klev)+1, klev
	237	DO i = 1, klon
	238	rad_chaud_tab(i,k) = rad_chau1
	239	ENDDO
	240	ENDDO
[524]	241
[1146]	242	ENDIF
	243
	244	DO k = 1, klev
	245	! IF(.not.ok_aie) THEN
	246	rad_chaud = rad_chau1
	247	IF (k.LE.3) rad_chaud = rad_chau2
	248	! ENDIF
	249	DO i = 1, klon
	250	IF (pclc(i,k) .LE. seuil_neb) THEN
	251
	252	c -- effective cloud droplet radius (microns):
	253
	254	c for liquid water clouds:
	255	! For output diagnostics
	256	!
	257	! Cloud droplet effective radius [um]
	258	!
	259	! we multiply here with f * xl (fraction of liquid water
	260	! clouds in the grid cell) to avoid problems in the
	261	! averaging of the output.
	262	! In the output of IOIPSL, derive the real cloud droplet
	263	! effective radius as re/fl
	264	!
	265
	266	fl(i,k) = seuil_neb*(1.-zfice2(i,k))
	267	re(i,k) = rad_chaud_tab(i,k)*fl(i,k)
	268
[1279]	269	rel = 0.
	270	rei = 0.
[1146]	271	pclc(i,k) = 0.0
	272	pcltau(i,k) = 0.0
	273	pclemi(i,k) = 0.0
	274	cldtaupi(i,k) = 0.0
	275	ELSE
[524]	276
[1146]	277	c -- liquid/ice cloud water paths:
	278
	279	zflwp_var= 1000.(1.-zfice2(i,k))pqlwp(i,k)/pclc(i,k)
	280	& *diff_paprs(i,k)
	281	zfiwp_var= 1000.zfice2(i,k)pqlwp(i,k)/pclc(i,k)
	282	& *diff_paprs(i,k)
	283
	284	c -- effective cloud droplet radius (microns):
	285
	286	c for liquid water clouds:
	287
	288	IF (ok_aie) THEN
	289	radius =
	290	& 1.1
	291	& ((pqlwp(i,k)pplay(i,k)/(RD * T(i,k)))
	292	& /(4./3.RPI1000.cdnc_pi(i,k)))*(1./3.)
	293	radius = MAX(radius*1e6, 5.)
	294
	295	tc = t(i,k)-273.15
	296	rei = 0.71*tc + 61.29
	297	if (tc.le.-81.4) rei = 3.5
	298	if (zflwp_var.eq.0.) radius = 1.
	299	if (zfiwp_var.eq.0. .or. rei.le.0.) rei = 1.
	300	cldtaupi(i,k) = 3.0/2.0 * zflwp_var / radius
	301	& + zfiwp_var * (3.448e-03 + 2.431/rei)
[1279]	302
[1146]	303	ENDIF ! ok_aie
	304	! For output diagnostics
	305	!
	306	! Cloud droplet effective radius [um]
	307	!
	308	! we multiply here with f * xl (fraction of liquid water
	309	! clouds in the grid cell) to avoid problems in the
	310	! averaging of the output.
	311	! In the output of IOIPSL, derive the real cloud droplet
	312	! effective radius as re/fl
	313	!
	314
	315	fl(i,k) = pclc(i,k)*(1.-zfice2(i,k))
	316	re(i,k) = rad_chaud_tab(i,k)*fl(i,k)
	317
	318	rel = rad_chaud_tab(i,k)
	319	c for ice clouds: as a function of the ambiant temperature
	320	c [formula used by Iacobellis and Somerville (2000), with an
	321	c asymptotical value of 3.5 microns at T<-81.4 C added to be
	322	c consistent with observations of Heymsfield et al. 1986]:
	323	tc = t(i,k)-273.15
	324	rei = 0.71*tc + 61.29
	325	if (tc.le.-81.4) rei = 3.5
	326	c -- cloud optical thickness :
	327
	328	c [for liquid clouds, traditional formula,
	329	c for ice clouds, Ebert & Curry (1992)]
	330
[1279]	331	if (zflwp_var.eq.0.) rel = 1.
	332	if (zfiwp_var.eq.0. .or. rei.le.0.) rei = 1.
	333	pcltau(i,k) = 3.0/2.0 * ( zflwp_var/rel )
[1146]	334	& + zfiwp_var * (3.448e-03 + 2.431/rei)
	335	c -- cloud infrared emissivity:
	336
	337	c [the broadband infrared absorption coefficient is parameterized
	338	c as a function of the effective cld droplet radius]
	339
	340	c Ebert and Curry (1992) formula as used by Kiehl & Zender (1995):
	341	k_ice = k_ice0 + 1.0/rei
	342
	343	pclemi(i,k) = 1.0
	344	& - EXP( -coef_chauzflwp_var - DFk_ice*zfiwp_var)
[524]	345
[1146]	346	ENDIF
[1279]	347	reliq(i,k)=rel
	348	reice(i,k)=rei
	349	! if (i.eq.1) then
	350	! print*,'Dans newmicro rel, rei :',rel, rei
	351	! print*,'Dans newmicro reliq, reice :',
	352	! $ reliq(i,k),reice(i,k)
	353	! endif
	354
[1146]	355	ENDDO
	356	ENDDO
[524]	357
[1146]	358	DO k = 1, klev
	359	DO i = 1, klon
	360	xflwp(i) = xflwp(i)+ xflwc(i,k) * diff_paprs(i,k)
	361	xfiwp(i) = xfiwp(i)+ xfiwc(i,k) * diff_paprs(i,k)
	362	ENDDO
	363	ENDDO
[524]	364
[1146]	365	ELSE
	366	DO k = 1, klev
	367	rad_chaud = rad_chau1
	368	IF (k.LE.3) rad_chaud = rad_chau2
	369	DO i = 1, klon
	370
	371	IF (pclc(i,k) .LE. seuil_neb) THEN
[524]	372
[1146]	373	pclc(i,k) = 0.0
	374	pcltau(i,k) = 0.0
	375	pclemi(i,k) = 0.0
	376	cldtaupi(i,k) = 0.0
[524]	377
[1146]	378	ELSE
[524]	379
[1146]	380	zflwp_var = 1000.pqlwp(i,k)diff_paprs(i,k)
	381	& /pclc(i,k)
	382
	383	zfice1 = MIN(
[1286]	384	& MAX( 1.0 - (t(i,k)-t_glace_min) /
	385	& (t_glace_max-t_glace_min),0.0),1.0)**nexpo
[1146]	386
	387	radius = rad_chaud * (1.-zfice1) + rad_froid * zfice1
	388	coef = coef_chau * (1.-zfice1) + coef_froi * zfice1
[524]	389
[1146]	390	pcltau(i,k) = 3.0 * zflwp_var / (2.0 * radius)
	391	pclemi(i,k) = 1.0 - EXP( - coef * zflwp_var)
[524]	392
[1146]	393	ENDIF
	394
	395	ENDDO
	396	ENDDO
	397	ENDIF
	398
	399	IF (.NOT.ok_aie) THEN
	400	DO k = 1, klev
	401	DO i = 1, klon
	402	cldtaupi(i,k)=pcltau(i,k)
	403	ENDDO
	404	ENDDO
	405	ENDIF
[524]	406
[1146]	407	ccc DO k = 1, klev
	408	ccc DO i = 1, klon
	409	ccc t(i,k) = t(i,k)
	410	ccc pclc(i,k) = MAX( 1.e-5 , pclc(i,k) )
	411	ccc lo = pclc(i,k) .GT. (2.*1.e-5)
	412	ccc zflwp = pqlwp(i,k)1000.(paprs(i,k)-paprs(i,k+1))
	413	ccc . /(rg*pclc(i,k))
	414	ccc zradef = 10.0 + (1.-sigs(k))*45.0
	415	ccc pcltau(i,k) = 1.5 * zflwp / zradef
	416	ccc zfice=1.0-MIN(MAX((t(i,k)-263.)/(273.-263.),0.0),1.0)
	417	ccc zmsac = 0.13(1.0-zfice) + 0.08zfice
	418	ccc pclemi(i,k) = 1.-EXP(-zmsac*zflwp)
	419	ccc if (.NOT.lo) pclc(i,k) = 0.0
	420	ccc if (.NOT.lo) pcltau(i,k) = 0.0
	421	ccc if (.NOT.lo) pclemi(i,k) = 0.0
	422	ccc ENDDO
	423	ccc ENDDO
	424	ccccc print*, 'pas de nuage dans le rayonnement'
	425	ccccc DO k = 1, klev
	426	ccccc DO i = 1, klon
	427	ccccc pclc(i,k) = 0.0
	428	ccccc pcltau(i,k) = 0.0
	429	ccccc pclemi(i,k) = 0.0
	430	ccccc ENDDO
	431	ccccc ENDDO
	432	C
	433	C COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS
	434	C
	435	c IM cf. CR:test: calcul prenant ou non en compte le recouvrement
	436	c initialisations
[685]	437	DO i=1,klon
	438	zclear(i)=1.
	439	zcloud(i)=0.
[1522]	440	zcloudh(i)=0.
	441	zcloudm(i)=0.
	442	zcloudl(i)=0.
[524]	443	pch(i)=1.0
	444	pcm(i) = 1.0
	445	pcl(i) = 1.0
	446	pctlwp(i) = 0.0
	447	ENDDO
	448	C
[685]	449	cIM cf CR DO k=1,klev
[524]	450	DO k = klev, 1, -1
[1146]	451	DO i = 1, klon
	452	pctlwp(i) = pctlwp(i)
	453	& + pqlwp(i,k)*diff_paprs(i,k)
	454	ENDDO
	455	ENDDO
	456	c IM cf. CR
	457	IF (NOVLP.EQ.1) THEN
	458	DO k = klev, 1, -1
	459	DO i = 1, klon
[685]	460	zclear(i)=zclear(i)*(1.-MAX(pclc(i,k),zcloud(i)))
[1279]	461	& /(1.-MIN(real(zcloud(i), kind=8),1.-ZEPSEC))
[685]	462	pct(i)=1.-zclear(i)
[1522]	463	IF (paprs(i,k).LT.prmhc) THEN
	464	pch(i) = pch(i)*(1.-MAX(pclc(i,k),zcloudh(i)))
	465	& /(1.-MIN(real(zcloudh(i), kind=8),1.-ZEPSEC))
	466	zcloudh(i)=pclc(i,k)
	467	ELSE IF (paprs(i,k).GE.prmhc .AND.
	468	& paprs(i,k).LT.prlmc) THEN
	469	pcm(i) = pcm(i)*(1.-MAX(pclc(i,k),zcloudm(i)))
	470	& /(1.-MIN(real(zcloudm(i), kind=8),1.-ZEPSEC))
	471	zcloudm(i)=pclc(i,k)
	472	ELSE IF (paprs(i,k).GE.prlmc) THEN
	473	pcl(i) = pcl(i)*(1.-MAX(pclc(i,k),zcloudl(i)))
	474	& /(1.-MIN(real(zcloudl(i), kind=8),1.-ZEPSEC))
	475	zcloudl(i)=pclc(i,k)
[685]	476	endif
	477	zcloud(i)=pclc(i,k)
[1146]	478	ENDDO
	479	ENDDO
	480	ELSE IF (NOVLP.EQ.2) THEN
	481	DO k = klev, 1, -1
	482	DO i = 1, klon
[685]	483	zcloud(i)=MAX(pclc(i,k),zcloud(i))
	484	pct(i)=zcloud(i)
[1522]	485	IF (paprs(i,k).LT.prmhc) THEN
[685]	486	pch(i) = MIN(pclc(i,k),pch(i))
[1522]	487	ELSE IF (paprs(i,k).GE.prmhc .AND.
	488	& paprs(i,k).LT.prlmc) THEN
[685]	489	pcm(i) = MIN(pclc(i,k),pcm(i))
[1522]	490	ELSE IF (paprs(i,k).GE.prlmc) THEN
[685]	491	pcl(i) = MIN(pclc(i,k),pcl(i))
	492	endif
[1146]	493	ENDDO
	494	ENDDO
	495	ELSE IF (NOVLP.EQ.3) THEN
	496	DO k = klev, 1, -1
	497	DO i = 1, klon
[685]	498	zclear(i)=zclear(i)*(1.-pclc(i,k))
	499	pct(i)=1-zclear(i)
[1522]	500	IF (paprs(i,k).LT.prmhc) THEN
[1146]	501	pch(i) = pch(i)*(1.0-pclc(i,k))
[1522]	502	ELSE IF (paprs(i,k).GE.prmhc .AND.
	503	& paprs(i,k).LT.prlmc) THEN
[1146]	504	pcm(i) = pcm(i)*(1.0-pclc(i,k))
[1522]	505	ELSE IF (paprs(i,k).GE.prlmc) THEN
[1146]	506	pcl(i) = pcl(i)*(1.0-pclc(i,k))
[685]	507	endif
[1146]	508	ENDDO
[685]	509	ENDDO
[1146]	510	ENDIF
	511
	512	C
[524]	513	DO i = 1, klon
[1146]	514	c IM cf. CR pct(i)=1.-pct(i)
[524]	515	pch(i)=1.-pch(i)
	516	pcm(i)=1.-pcm(i)
	517	pcl(i)=1.-pcl(i)
	518	ENDDO
[1337]	519
	520	c ========================================================
	521	! DIAGNOSTICS CALCULATION FOR CMIP5 PROTOCOL
	522	c ========================================================
	523	!! change by Nicolas Yan (LSCE)
	524	!! Cloud Droplet Number Concentration (CDNC) : 3D variable
	525	!! Fractionnal cover by liquid water cloud (LCC3D) : 3D variable
	526	!! Cloud Droplet Number Concentration at top of cloud (CLDNCL) : 2D variable
	527	!! Droplet effective radius at top of cloud (REFFCLWTOP) : 2D variable
	528	!! Fractionnal cover by liquid water at top of clouds (LCC) : 2D variable
	529	IF (ok_newmicro) THEN
	530	IF (ok_aie) THEN
	531	DO k = 1, klev
	532	DO i = 1, klon
	533	phase3d(i,k)=1-zfice2(i,k)
	534	IF (pclc(i,k) .LE. seuil_neb) THEN
	535	lcc3d(i,k)=seuil_neb*phase3d(i,k)
	536	ELSE
	537	lcc3d(i,k)=pclc(i,k)*phase3d(i,k)
	538	ENDIF
	539	scdnc(i,k)=lcc3d(i,k)*cdnc(i,k) ! m-3
	540	ENDDO
	541	ENDDO
	542
	543	DO i=1,klon
	544	lcc(i)=0.
	545	reffclwtop(i)=0.
	546	cldncl(i)=0.
	547	IF(RANDOM .OR. MAXIMUM_RANDOM) tcc(i) = 1.
	548	IF(MAXIMUM) tcc(i) = 0.
	549	ENDDO
	550
	551
	552	DO i=1,klon
	553	DO k=klev-1,1,-1 !From TOA down
	554
	555
	556	! Test, if the cloud optical depth exceeds the necessary
	557	! threshold:
	558
	559	IF (pcltau(i,k).GT.thres_tau .AND. pclc(i,k).GT.thres_neb)
	560	. THEN
	561	! To calculate the right Temperature at cloud top,
	562	! interpolate it between layers:
	563	t_tmp = t(i,k) +
	564	. (paprs(i,k+1)-pplay(i,k))/(pplay(i,k+1)-pplay(i,k))
	565	. * ( t(i,k+1) - t(i,k) )
	566
	567	IF(MAXIMUM) THEN
	568	IF(FIRST) THEN
	569	write(,)'Hypothese de recouvrement: MAXIMUM'
	570	FIRST=.FALSE.
	571	ENDIF
	572	flag_max= -1.
	573	ftmp(i) = MAX(tcc(i),pclc(i,k))
	574	ENDIF
	575
	576	IF(RANDOM) THEN
	577	IF(FIRST) THEN
	578	write(,)'Hypothese de recouvrement: RANDOM'
	579	FIRST=.FALSE.
	580	ENDIF
	581	flag_max= 1.
	582	ftmp(i) = tcc(i) * (1-pclc(i,k))
	583	ENDIF
	584
	585	IF(MAXIMUM_RANDOM) THEN
	586	IF(FIRST) THEN
	587	write(,)'Hypothese de recouvrement: MAXIMUM_
	588	. RANDOM'
	589	FIRST=.FALSE.
	590	ENDIF
	591	flag_max= 1.
	592	ftmp(i) = tcc(i) *
	593	. (1. - MAX(pclc(i,k),pclc(i,k+1))) /
	594	. (1. - MIN(pclc(i,k+1),1.-thres_neb))
	595	ENDIF
	596	c Effective radius of cloud droplet at top of cloud (m)
	597	reffclwtop(i) = reffclwtop(i) + rad_chaud_tab(i,k) *
	598	. 1.0E-06 * phase3d(i,k) * ( tcc(i) - ftmp(i))*flag_max
	599	c CDNC at top of cloud (m-3)
	600	cldncl(i) = cldncl(i) + cdnc(i,k) * phase3d(i,k) *
	601	. (tcc(i) - ftmp(i))*flag_max
	602	c Liquid Cloud Content at top of cloud
	603	lcc(i) = lcc(i) + phase3d(i,k) * (tcc(i)-ftmp(i))*
	604	. flag_max
	605	c Total Cloud Content at top of cloud
	606	tcc(i)=ftmp(i)
	607
	608	ENDIF ! is there a visible, not-too-small cloud?
	609	ENDDO ! loop over k
	610
	611	IF(RANDOM .OR. MAXIMUM_RANDOM) tcc(i)=1.-tcc(i)
	612	ENDDO ! loop over i
	613
	614	!! Convective and Stratiform Cloud Droplet Effective Radius (REFFCLWC REFFCLWS)
	615	DO i = 1, klon
	616	DO k = 1, klev
	617	pqlwpcon(i,k)=rnebcon(i,k)*clwcon(i,k) ! fraction eau liquide convective
	618	pqlwpstra(i,k)=pclc(i,k)*phase3d(i,k)-pqlwpcon(i,k) ! fraction eau liquide stratiforme
	619	IF (pqlwpstra(i,k) .LE. 0.0) pqlwpstra(i,k)=0.0
	620	! Convective Cloud Droplet Effective Radius (REFFCLWC) : variable 3D
	621	reffclwc(i,k)=1.1
	622	& ((pqlwpcon(i,k)pplay(i,k)/(RD * T(i,k)))
	623	& /(4./3RPI1000.cdnc(i,k)) )*(1./3.)
	624	reffclwc(i,k) = MAX(reffclwc(i,k) * 1e6, 5.)
	625
	626	! Stratiform Cloud Droplet Effective Radius (REFFCLWS) : variable 3D
	627	IF ((pclc(i,k)-rnebcon(i,k)) .LE. seuil_neb) THEN ! tout sous la forme convective
	628	reffclws(i,k)=0.0
	629	lcc3dstra(i,k)= 0.0
	630	ELSE
	631	reffclws(i,k) = (pclc(i,k)phase3d(i,k)
	632	& rad_chaud_tab(i,k)-
	633	& pqlwpcon(i,k)*reffclwc(i,k))
	634	IF(reffclws(i,k) .LE. 0.0) reffclws(i,k)=0.0
	635	lcc3dstra(i,k)=pqlwpstra(i,k)
	636	ENDIF
	637	!Convertion from um to m
	638	IF(rnebcon(i,k). LE. seuil_neb) THEN
	639	reffclwc(i,k) = reffclwc(i,k)seuil_nebclwcon(i,k)
	640	& *1.0E-06
	641	lcc3dcon(i,k)= seuil_neb*clwcon(i,k)
	642	ELSE
	643	reffclwc(i,k) = reffclwc(i,k)*pqlwpcon(i,k)
	644	& *1.0E-06
	645	lcc3dcon(i,k) = pqlwpcon(i,k)
	646	ENDIF
	647
	648	reffclws(i,k) = reffclws(i,k)*1.0E-06
	649
	650	ENDDO !klev
	651	ENDDO !klon
	652
	653	!! Column Integrated Cloud Droplet Number (CLDNVI) : variable 2D
	654	DO k = 1, klev
	655	DO i = 1, klon
	656	pdel(i,k) = paprs(i,k)-paprs(i,k+1)
	657	zrho(i,k)=pplay(i,k)/t(i,k)/RD ! kg/m3
	658	dh(i,k)=pdel(i,k)/(gravit*zrho(i,k)) ! hauteur de chaque boite (m)
	659	ENDDO
	660	ENDDO
	661	c
	662	DO i = 1, klon
	663	cldnvi(i)=0.
	664	lcc_integrat(i)=0.
	665	height(i)=0.
	666	DO k = 1, klev
	667	cldnvi(i)=cldnvi(i)+cdnc(i,k)lcc3d(i,k)dh(i,k)
	668	lcc_integrat(i)=lcc_integrat(i)+lcc3d(i,k)*dh(i,k)
	669	height(i)=height(i)+dh(i,k)
	670	ENDDO ! klev
	671	lcc_integrat(i)=lcc_integrat(i)/height(i)
	672	IF (lcc_integrat(i) .LE. 1.0E-03) THEN
	673	cldnvi(i)=cldnvi(i)*lcc(i)/seuil_neb
	674	ELSE
	675	cldnvi(i)=cldnvi(i)*lcc(i)/lcc_integrat(i)
	676	ENDIF
	677	ENDDO ! klon
	678
	679	DO i = 1, klon
	680	DO k = 1, klev
	681	IF (scdnc(i,k) .LE. 0.0) scdnc(i,k)=0.0
	682	IF (reffclws(i,k) .LE. 0.0) reffclws(i,k)=0.0
	683	IF (reffclwc(i,k) .LE. 0.0) reffclwc(i,k)=0.0
	684	IF (lcc3d(i,k) .LE. 0.0) lcc3d(i,k)=0.0
	685	IF (lcc3dcon(i,k) .LE. 0.0) lcc3dcon(i,k)=0.0
	686	IF (lcc3dstra(i,k) .LE. 0.0) lcc3dstra(i,k)=0.0
	687	ENDDO
	688	IF (reffclwtop(i) .LE. 0.0) reffclwtop(i)=0.0
	689	IF (cldncl(i) .LE. 0.0) cldncl(i)=0.0
	690	IF (cldnvi(i) .LE. 0.0) cldnvi(i)=0.0
	691	IF (lcc(i) .LE. 0.0) lcc(i)=0.0
	692	ENDDO
	693
	694	ENDIF !ok_aie
	695	ENDIF !ok newmicro
	696	c
[524]	697	C
	698	RETURN
	699	END

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

Download in other formats:

Original Format