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)