5 SUBROUTINE newmicro(ok_cdnc, bl95_b0, bl95_b1, paprs, pplay, t, pqlwp, pclc, &
6 pcltau, pclemi, pch, pcl, pcm, pct, pctlwp, xflwp, xfiwp, xflwc, xfiwc, &
7 mass_solu_aero, mass_solu_aero_pi, pcldtaupi, re, fl, reliq, reice, &
56 LOGICAL random, maximum_random, maximum
59 LOGICAL,
SAVE :: first = .
true.
64 REAL thres_tau, thres_neb
95 parameter(prmhc=440.*100., prlmc=680.*100.)
103 REAL coef_froi, coef_chau
104 parameter(coef_chau=0.13, coef_froi=0.09)
114 REAL,
PARAMETER :: t_glace_min_old = 258.
115 REAL,
PARAMETER :: t_glace_max_old = 273.13
118 REAL k_ice0, k_ice, df
136 REAL bl95_b0, bl95_b1
151 REAL zflwp_var, zfiwp_var
171 IF (abs(d_rei_dt-0.71)<1.e-4) d_rei_dt = 0.71
191 rhodz(i, k) = (paprs(i,k)-paprs(i,k+1))/
rg
192 zrho(i, k) = pplay(i, k)/t(i, k)/rd
193 dh(i, k) = rhodz(i, k)/zrho(i, k)
195 zfice(i, k) = 1.0 - (t(i,k)-t_glace_min_old)/(t_glace_max_old-t_glace_min_old)
196 zfice(i, k) = min(max(zfice(i,k),0.0), 1.0)
198 xflwc(i, k) = (1.-zfice(i,k))*pqlwp(i, k)
199 xfiwc(i, k) = zfice(i, k)*pqlwp(i, k)
212 rhodz(i, k) = (paprs(i,k)-paprs(i,k+1))/
rg
213 zrho(i, k) = pplay(i, k)/t(i, k)/rd
214 dh(i, k) = rhodz(i, k)/zrho(i, k)
216 xflwc(i, k) = (1.-zfice(i,k))*pqlwp(i, k)
217 xfiwc(i, k) = zfice(i, k)*pqlwp(i, k)
234 cdnc(i, k) = 10.**(bl95_b0+bl95_b1*log(max(mass_solu_aero(i,k), &
235 1.e-4))/log(10.))*1.e6
236 cdnc(i, k) = min(1000.e6, max(20.e6,cdnc(i,k)))
239 cdnc_pi(i, k) = 10.**(bl95_b0+bl95_b1*log(max(mass_solu_aero_pi(i,k), &
240 1.e-4))/log(10.))*1.e6
241 cdnc_pi(i, k) = min(1000.e6, max(20.e6,cdnc_pi(i,k)))
244 rad_chaud(i, k) = 1.1*((pqlwp(i,k)*pplay(i, &
245 k)/(rd*t(i,k)))/(4./3*rpi*1000.*cdnc(i,k)))**(1./3.)
246 rad_chaud(i, k) = max(rad_chaud(i,k)*1.e6, 5.)
249 rad_chaud_pi(i, k) = 1.1*((pqlwp(i,k)*pplay(i, &
250 k)/(rd*t(i,k)))/(4./3.*rpi*1000.*cdnc_pi(i,k)))**(1./3.)
251 rad_chaud_pi(i, k) = max(rad_chaud_pi(i,k)*1.e6, 5.)
255 IF (pclc(i,k)<=seuil_neb)
THEN
257 pcldtaupi(i, k) = 0.0
261 zflwp_var = 1000.*(1.-zfice(i,k))*pqlwp(i, k)/pclc(i, k)* &
263 zfiwp_var = 1000.*zfice(i, k)*pqlwp(i, k)/pclc(i, k)*rhodz(i, k)
264 tc = t(i, k) - 273.15
272 IF (zfiwp_var==0. .OR. rei<=0.) rei = 1.
273 pcldtaupi(i, k) = 3.0/2.0*zflwp_var/rad_chaud_pi(i, k) + &
274 zfiwp_var*(3.448e-03+2.431/rei)
285 DO k = 1, min(3,
klev)
306 IF (pclc(i,k)<=seuil_neb)
THEN
316 fl(i, k) = seuil_neb*(1.-zfice(i,k))
317 re(i, k) = rad_chaud(i, k)*fl(i, k)
328 zflwp_var = 1000.*(1.-zfice(i,k))*pqlwp(i, k)/pclc(i, k)*rhodz(i, k)
329 zfiwp_var = 1000.*zfice(i, k)*pqlwp(i, k)/pclc(i, k)*rhodz(i, k)
339 fl(i, k) = pclc(i, k)*(1.-zfice(i,k))
340 re(i, k) = rad_chaud(i, k)*fl(i, k)
342 rel = rad_chaud(i, k)
351 tc = t(i, k) - 273.15
359 IF (zflwp_var==0.) rel = 1.
360 IF (zfiwp_var==0. .OR. rei<=0.) rei = 1.
361 pcltau(i, k) = 3.0/2.0*(zflwp_var/rel) + zfiwp_var*(3.448e-03+2.431/ &
369 k_ice = k_ice0 + 1.0/rei
371 pclemi(i, k) = 1.0 - exp(-coef_chau*zflwp_var-df*k_ice*zfiwp_var)
377 xflwp(i) = xflwp(i) + xflwc(i, k)*rhodz(i, k)
378 xfiwp(i) = xfiwp(i) + xfiwc(i, k)*rhodz(i, k)
385 IF (.NOT. ok_cdnc)
THEN
388 pcldtaupi(i, k) = pcltau(i, k)
389 reice_pi(i, k) = reice(i, k)
396 reliq(i, k) = rad_chaud(i, k)
397 reliq_pi(i, k) = rad_chaud_pi(i, k)
398 reice_pi(i, k) = reice(i, k)
422 pctlwp(i) = pctlwp(i) + pqlwp(i, k)*rhodz(i, k)
431 zclear(i) = zclear(i)*(1.-max(pclc(i,k),zcloud(i)))/(1.-min(
real( &
zcloud(i),kind=8),1.-zepsec))
432 pct(i) = 1. - zclear(i)
433 IF (paprs(i,k)<prmhc)
THEN
434 pch(i) = pch(i)*(1.-max(pclc(i,k),zcloudh(i)))/(1.-min(
real(zcloudh &
(i),kind=8),1.-zepsec))
435 zcloudh(i) = pclc(i, k)
436 ELSE IF (paprs(i,k)>=prmhc .AND. paprs(i,k)<prlmc)
THEN
437 pcm(i) = pcm(i)*(1.-max(pclc(i,k),zcloudm(i)))/(1.-min(
real(zcloudm &
(i),kind=8),1.-zepsec))
438 zcloudm(i) = pclc(i, k)
439 ELSE IF (paprs(i,k)>=prlmc)
THEN
440 pcl(i) = pcl(i)*(1.-max(pclc(i,k),zcloudl(i)))/(1.-min(
real(zcloudl &
(i),kind=8),1.-zepsec))
441 zcloudl(i) = pclc(i, k)
443 zcloud(i) = pclc(i, k)
446 ELSE IF (novlp==2)
THEN
449 zcloud(i) = max(pclc(i,k), zcloud(i))
451 IF (paprs(i,k)<prmhc)
THEN
452 pch(i) = min(pclc(i,k), pch(i))
453 ELSE IF (paprs(i,k)>=prmhc .AND. paprs(i,k)<prlmc)
THEN
454 pcm(i) = min(pclc(i,k), pcm(i))
455 ELSE IF (paprs(i,k)>=prlmc)
THEN
456 pcl(i) = min(pclc(i,k), pcl(i))
460 ELSE IF (novlp==3)
THEN
463 zclear(i) = zclear(i)*(1.-pclc(i,k))
464 pct(i) = 1 - zclear(i)
465 IF (paprs(i,k)<prmhc)
THEN
466 pch(i) = pch(i)*(1.0-pclc(i,k))
467 ELSE IF (paprs(i,k)>=prmhc .AND. paprs(i,k)<prlmc)
THEN
468 pcm(i) = pcm(i)*(1.0-pclc(i,k))
469 ELSE IF (paprs(i,k)>=prlmc)
THEN
470 pcl(i) = pcl(i)*(1.0-pclc(i,k))
496 phase3d(i, k) = 1 - zfice(i, k)
497 IF (pclc(i,k)<=seuil_neb)
THEN
498 lcc3d(i, k) = seuil_neb*phase3d(i, k)
500 lcc3d(i, k) = pclc(i, k)*phase3d(i, k)
510 IF (random .OR. maximum_random) tcc(i) = 1.
511 IF (maximum) tcc(i) = 0.
515 DO k =
klev - 1, 1, -1
520 IF (pcltau(i,k)>thres_tau .AND. pclc(i,k)>thres_neb)
THEN
524 WRITE (*, *)
'Hypothese de recouvrement: MAXIMUM'
528 ftmp(i) = max(tcc(i), pclc(i,k))
533 WRITE (*, *)
'Hypothese de recouvrement: RANDOM'
537 ftmp(i) = tcc(i)*(1-pclc(i,k))
540 IF (maximum_random)
THEN
542 WRITE (*, *)
'Hypothese de recouvrement: MAXIMUM_ &
548 ftmp(i) = tcc(i)*(1.-max(pclc(i,k),pclc(i,k+1)))/(1.-min(pclc(i, &
553 k)*(tcc(i)-ftmp(i))*flag_max
555 cldncl(i) =
cldncl(i) + cdnc(i, k)*phase3d(i, k)*(tcc(i)-ftmp(i))* &
558 lcc(i) =
lcc(i) + phase3d(i, k)*(tcc(i)-ftmp(i))*flag_max
565 IF (random .OR. maximum_random) tcc(i) = 1. - tcc(i)
575 lcc3dstra(i, k) = pclc(i, k)*pqlwp(i, k)*phase3d(i, k)
579 radius = 1.1*((pqlwp(i,k)*pplay(i,k)/(rd*t(i,k)))/(4./3*rpi*1000.* &
581 radius = max(radius, 5.e-6)
599 lcc_integrat(i) = lcc_integrat(i) +
lcc3d(i, k)*dh(i, k)
600 height(i) = height(i) + dh(i, k)
602 lcc_integrat(i) = lcc_integrat(i)/height(i)
603 IF (lcc_integrat(i)<=1.0e-03)
THEN
622 IF (
lcc(i)<=0.0)
lcc(i) = 0.0
630
real, dimension(:,:), allocatable, save clwcon
subroutine icefrac_lsc(np, temp, sig, icefrac)
real, dimension(:,:), allocatable, save lcc3dstra
!$Id t_glace_min REAL exposant_glace REAL rei_max REAL coefw_cld_cv REAL tmax_fonte_cv INTEGER iflag_cld_cv common nuagecom rei_max
real, dimension(:), allocatable, save cldnvi
!$Id t_glace_min REAL exposant_glace REAL rei_max REAL coefw_cld_cv REAL tmax_fonte_cv INTEGER iflag_t_glace
real, dimension(:,:), allocatable, save rnebcon
real, dimension(:,:), allocatable, save scdnc
!$Id itapm1 ENDIF!IM on interpole les champs sur les niveaux STD de pression!IM a chaque pas de temps de la physique c!positionnement de l argument logique a false c!pour ne pas recalculer deux fois la meme chose!c!a cet effet un appel a plevel_new a ete deplace c!a la fin de la serie d appels c!la boucle DO nlevSTD a ete internalisee c!dans d ou la creation de cette routine c c!CALL false
real, dimension(:,:), allocatable, save lcc3dcon
real, dimension(:,:), allocatable, save lcc3d
real, dimension(:), allocatable, save lcc
real, dimension(:,:), allocatable, save reffclws
!$Id t_glace_min REAL exposant_glace REAL rei_min
!$Header!integer nvarmx parameter(nfmx=10, imx=200, jmx=150, lmx=200, nvarmx=1000) real xd(imx
real, dimension(:), allocatable, save cldncl
!$Id itapm1 ENDIF!IM on interpole les champs sur les niveaux STD de pression!IM a chaque pas de temps de la physique c!positionnement de l argument logique a false c!pour ne pas recalculer deux fois la meme chose!c!a cet effet un appel a plevel_new a ete deplace c!a la fin de la serie d appels c!la boucle DO nlevSTD a ete internalisee c!dans d ou la creation de cette routine c c!CALL ulevSTD CALL &zphi philevSTD CALL &zx_rh rhlevSTD!DO klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon du jour ou toutes les read_climoz CALL true
real, dimension(:), allocatable, save reffclwtop
real, dimension(:,:), allocatable, save reffclwc
subroutine newmicro(ok_cdnc, bl95_b0, bl95_b1, paprs, pplay, t, pqlwp, pclc, pcltau, pclemi, pch, pcl, pcm, pct, pctlwp, xflwp, xfiwp, xflwc, xfiwc, mass_solu_aero, mass_solu_aero_pi, pcldtaupi, re, fl, reliq, reice, reliq_pi, reice_pi)