Index: LMDZ6/trunk/libf/phylmd/calltherm.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/calltherm.F90 (revision 4589) +++ LMDZ6/trunk/libf/phylmd/calltherm.F90 (revision 4590) @@ -29,4 +29,7 @@ USE indice_sol_mod USE print_control_mod, ONLY: prt_level,lunout + USE lmdz_thermcell_alp, ONLY: thermcell_alp + USE lmdz_thermcell_main, ONLY: thermcell_main + USE lmdz_thermcell_old, ONLY: thermcell, thermcell_2002, thermcell_eau, calcul_sec, thermcell_sec #ifdef ISO use infotrac_phy, ONLY: ntiso Index: LMDZ6/trunk/libf/phylmd/lmdz_thermcell_alim.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/lmdz_thermcell_alim.F90 (revision 4590) +++ LMDZ6/trunk/libf/phylmd/lmdz_thermcell_alim.F90 (revision 4590) @@ -0,0 +1,127 @@ +MODULE lmdz_thermcell_alim +! +! $Id: thermcell_plume.F90 2311 2015-06-25 07:45:24Z emillour $ +! +CONTAINS + + SUBROUTINE thermcell_alim(flag,ngrid,klev,ztv,d_temp,zlev,alim_star,lalim) +IMPLICIT NONE + +!-------------------------------------------------------------------------- +! FH : 2015/11/06 +! thermcell_alim: calcule la distribution verticale de l'alimentation +! laterale a la base des panaches thermiques +!-------------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: ngrid,klev + REAL, INTENT(IN) :: ztv(ngrid,klev) + REAL, INTENT(IN) :: d_temp(ngrid) + REAL, INTENT(IN) :: zlev(ngrid,klev+1) + REAL, INTENT(OUT) :: alim_star(ngrid,klev) + INTEGER, INTENT(OUT) :: lalim(ngrid) + INTEGER, INTENT(IN) :: flag + + REAL :: alim_star_tot(ngrid),zi(ngrid),zh(ngrid) + REAL :: zlay(ngrid,klev) + REAL ztv_parcel + + INTEGER ig,l + + REAL h,z,falim + falim(h,z)=0.2*((z-h)**5+h**5) + + +!=================================================================== + + lalim(:)=1 + alim_star_tot(:)=0. + +!------------------------------------------------------------------------- +! Definition de l'alimentation +!------------------------------------------------------------------------- + IF (flag==0) THEN ! CMIP5 version + do l=1,klev-1 + do ig=1,ngrid + if (ztv(ig,l)> ztv(ig,l+1) .and. ztv(ig,1)>=ztv(ig,l) ) then + alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.) & + & *sqrt(zlev(ig,l+1)) + lalim(ig)=l+1 + alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l) + endif + enddo + enddo + do l=1,klev + do ig=1,ngrid + if (alim_star_tot(ig) > 1.e-10 ) then + alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig) + endif + enddo + enddo + alim_star_tot(:)=1. + +!------------------------------------------------------------------------- +! Nouvelle definition avec possibilite d'introduire un DT en surface +! On suppose que la forme du profile d'alimentation scale avec la hauteur +! d'inversion calculée avec une particule partant de la premieere couche + +! Fonction f(z) = z ( h - z ) , avec h = zi/3 +! On utilise l'integralle +! Int_0^z f(z') dz' = z^2 ( h/2 - z/3 ) = falim(h,z) +! Pour calculer l'alimentation des couches +!------------------------------------------------------------------------- + ELSE +! Computing inversion height zi and zh=zi/3. + zi(:)=0. +! Il faut recalculer zlay qui n'est pas dispo dans thermcell_plume +! A changer eventuellement. + do l=1,klev + zlay(:,l)=0.5*(zlev(:,l)+zlev(:,l+1)) + enddo + + do l=klev-1,1,-1 + do ig=1,ngrid + ztv_parcel=ztv(ig,1)+d_temp(ig) + if (ztv_parcel zmax alors on pose zlcl = zmax + else + rhobarz0(ig)=0. + zlcl(ig)=zmax(ig) + endif + enddo +!!jyg fin + +!------------Calcul des propriétés du thermique au LCL + IF ( (iflag_trig_bl.ge.1) .or. (iflag_clos_bl.ge.1) ) THEN + + !-----Initialisation de la TKE moyenne + do l=1,nlay + do ig=1,ngrid + pbl_tke_max(ig,l)=0. + enddo + enddo + +!-----Calcul de la TKE moyenne + do nsrf=1,nbsrf + do l=1,nlay + do ig=1,ngrid + pbl_tke_max(ig,l)=pctsrf(ig,nsrf)*pbl_tke(ig,l,nsrf)+pbl_tke_max(ig,l) + enddo + enddo + enddo + +!-----Initialisations des TKE dans et hors des thermiques + do l=1,nlay + do ig=1,ngrid + therm_tke_max(ig,l)=pbl_tke_max(ig,l) + env_tke_max(ig,l)=pbl_tke_max(ig,l) + enddo + enddo + +!-----Calcul de la TKE transportée par les thermiques : therm_tke_max + call thermcell_tke_transport(ngrid,nlay,ptimestep,fm0,entr0, & ! in + & rg,pplev,therm_tke_max) ! out +! print *,' thermcell_tke_transport -> ' !!jyg + +!-----Calcul des profils verticaux de TKE hors thermiques : env_tke_max, et de la vitesse verticale grande échelle : W_ls + do l=1,nlay + do ig=1,ngrid + pbl_tke_max(ig,l)=fraca(ig,l)*therm_tke_max(ig,l)+(1.-fraca(ig,l))*env_tke_max(ig,l) ! Recalcul de TKE moyenne aprés transport de TKE_TH + env_tke_max(ig,l)=(pbl_tke_max(ig,l)-fraca(ig,l)*therm_tke_max(ig,l))/(1.-fraca(ig,l)) ! Recalcul de TKE dans l'environnement aprés transport de TKE_TH + w_ls(ig,l)=-1.*omega(ig,l)/(RG*rhobarz(ig,l)) ! Vitesse verticale de grande échelle + enddo + enddo +! print *,' apres w_ls = ' !!jyg + + do ig=1,ngrid + if (ok_lcl(ig)) then + fraca0(ig)=fraca(ig,klcl(ig))+(fraca(ig,klcl(ig)+1) & + & -fraca(ig,klcl(ig)))*interp(ig) + w0(ig)=zw2(ig,klcl(ig))+(zw2(ig,klcl(ig)+1) & + & -zw2(ig,klcl(ig)))*interp(ig) + w_conv(ig)=w_ls(ig,klcl(ig))+(w_ls(ig,klcl(ig)+1) & + & -w_ls(ig,klcl(ig)))*interp(ig) + therm_tke_max0(ig)=therm_tke_max(ig,klcl(ig)) & + & +(therm_tke_max(ig,klcl(ig)+1)-therm_tke_max(ig,klcl(ig)))*interp(ig) + env_tke_max0(ig)=env_tke_max(ig,klcl(ig))+(env_tke_max(ig,klcl(ig)+1) & + & -env_tke_max(ig,klcl(ig)))*interp(ig) + pbl_tke_max0(ig)=pbl_tke_max(ig,klcl(ig))+(pbl_tke_max(ig,klcl(ig)+1) & + & -pbl_tke_max(ig,klcl(ig)))*interp(ig) + if (therm_tke_max0(ig).ge.20.) therm_tke_max0(ig)=20. + if (env_tke_max0(ig).ge.20.) env_tke_max0(ig)=20. + if (pbl_tke_max0(ig).ge.20.) pbl_tke_max0(ig)=20. + else + fraca0(ig)=0. + w0(ig)=0. +!!jyg le 27/04/2012 +!! zlcl(ig)=0. +!! + endif + enddo + + ENDIF ! IF ( (iflag_trig_bl.ge.1) .or. (iflag_clos_bl.ge.1) ) +! print *,'ENDIF ( (iflag_trig_bl.ge.1) .or. (iflag_clos_bl.ge.1) ) ' !!jyg + +!------------Triggering------------------ + IF (iflag_trig_bl.ge.1) THEN + +!-----Initialisations + depth(:)=0. + n2(:)=0. + s2(:)=100. ! some low value, arbitrary + s_max(:)=0. + +!-----Epaisseur du nuage (depth) et détermination de la queue du spectre de panaches (n2,s2) et du panache le plus gros (s_max) + do ig=1,ngrid + zmax_moy(ig)=zlcl(ig)+zmax_moy_coef*(zmax(ig)-zlcl(ig)) + depth(ig)=zmax_moy(ig)-zlcl(ig) + hmin(ig)=hmincoef*zlcl(ig) + if (depth(ig).ge.10.) then + s2(ig)=(hcoef*depth(ig)+hmin(ig))**2 + n2(ig)=(1.-eps1)*fraca0(ig)*airephy(ig)/s2(ig) +!! +!!jyg le 27/04/2012 +!! s_max(ig)=s2(ig)*log(n2(ig)) +!! if (n2(ig) .lt. 1) s_max(ig)=0. + s_max(ig)=s2(ig)*log(max(n2(ig),1.)) +!!fin jyg + else + n2(ig)=0. + s_max(ig)=0. + endif + enddo +! print *,'avant Calcul de Wmax ' !!jyg + + susqr2pi=su_cst*sqrt(2.*Rpi) + reuler=exp(1.) + do ig=1,ngrid + if ( (depth(ig).ge.10.) .and. (s_max(ig).gt.susqr2pi*reuler) ) then + w_max(ig)=w0(ig)*(1.+sqrt(2.*log(s_max(ig)/susqr2pi)-log(2.*log(s_max(ig)/susqr2pi)))) + ale_bl_stat(ig)=0.5*w_max(ig)**2 + else + w_max(ig)=0. + ale_bl_stat(ig)=0. + endif + enddo + + ENDIF ! iflag_trig_bl +! print *,'ENDIF iflag_trig_bl' !!jyg + +!------------Closure------------------ + + IF (iflag_clos_bl.ge.2) THEN + +!-----Calcul de ALP_BL_STAT + do ig=1,ngrid + alp_bl_det(ig)=0.5*coef_m*rhobarz0(ig)*(w0(ig)**3)*fraca0(ig)*(1.-2.*fraca0(ig))/((1.-fraca0(ig))**2) + alp_bl_fluct_m(ig)=1.5*rhobarz0(ig)*fraca0(ig)*(w_conv(ig)+coef_m*w0(ig))* & + & (w0(ig)**2) + alp_bl_fluct_tke(ig)=3.*coef_m*rhobarz0(ig)*w0(ig)*fraca0(ig)*(therm_tke_max0(ig)-env_tke_max0(ig)) & + & +3.*rhobarz0(ig)*w_conv(ig)*pbl_tke_max0(ig) + if (iflag_clos_bl.ge.2) then + alp_bl_conv(ig)=1.5*coef_m*rhobarz0(ig)*fraca0(ig)*(fraca0(ig)/(1.-fraca0(ig)))*w_conv(ig)* & + & (w0(ig)**2) + else + alp_bl_conv(ig)=0. + endif + alp_bl_stat(ig)=alp_bl_det(ig)+alp_bl_fluct_m(ig)+alp_bl_fluct_tke(ig)+alp_bl_conv(ig) + enddo + +!-----Sécurité ALP infinie + do ig=1,ngrid + if (fraca0(ig).gt.0.98) alp_bl_stat(ig)=2. + enddo + + ENDIF ! (iflag_clos_bl.ge.2) + +!!! fin nrlmd le 10/04/2012 + +! print*,'avant calcul ale et alp' +!calcul de ALE et ALP pour la convection + alp_bl(:)=0. + ale_bl(:)=0. +! print*,'ALE,ALP ,l,zw2(ig,l),ale_bl(ig),alp_bl(ig)' + do l=1,nlay + do ig=1,ngrid + alp_bl(ig)=max(alp_bl(ig),0.5*rhobarz(ig,l)*wth3(ig,l) ) + ale_bl(ig)=max(ale_bl(ig),0.5*zw2(ig,l)**2) +! print*,'ALE,ALP',l,zw2(ig,l),ale_bl(ig),alp_bl(ig) + enddo + enddo + +! ale sec (max de wmax/2 sous la zone d'inhibition) dans +! le cas iflag_trig_bl=3 + IF (iflag_trig_bl==3) ale_bl(:)=0.5*wmax_sec(:)**2 + +!test:calcul de la ponderation des couches pour KE +!initialisations + + fm_tot(:)=0. + wght_th(:,:)=1. + lalim_conv(:)=lalim(:) + + do k=1,nlay + do ig=1,ngrid + if (k<=lalim_conv(ig)) fm_tot(ig)=fm_tot(ig)+fm(ig,k) + enddo + enddo + +! assez bizarre car, si on est dans la couche d'alim et que alim_star et +! plus petit que 1.e-10, on prend wght_th=1. + do k=1,nlay + do ig=1,ngrid + if (k<=lalim_conv(ig).and.alim_star(ig,k)>1.e-10) then + wght_th(ig,k)=alim_star(ig,k) + endif + enddo + enddo + +! print*,'apres wght_th' +!test pour prolonger la convection + do ig=1,ngrid +!v1d if ((alim_star(ig,1).lt.1.e-10).and.(therm)) then + if ((alim_star(ig,1).lt.1.e-10)) then + lalim_conv(ig)=1 + wght_th(ig,1)=1. +! print*,'lalim_conv ok',lalim_conv(ig),wght_th(ig,1) + endif + enddo + +!------------------------------------------------------------------------ +! Modif CR/FH 20110310 : alp integree sur la verticale. +! Integrale verticale de ALP. +! wth3 etant aux niveaux inter-couches, on utilise d play comme masse des +! couches +!------------------------------------------------------------------------ + + alp_int(:)=0. + dp_int(:)=0. + do l=2,nlay + do ig=1,ngrid + if(l.LE.lmax(ig)) THEN + zdp=pplay(ig,l-1)-pplay(ig,l) + alp_int(ig)=alp_int(ig)+0.5*rhobarz(ig,l)*wth3(ig,l)*zdp + dp_int(ig)=dp_int(ig)+zdp + endif + enddo + enddo + + if (iflag_coupl>=3 .and. iflag_coupl<=5) then + do ig=1,ngrid +!valeur integree de alp_bl * 0.5: + if (dp_int(ig)>0.) then + alp_bl(ig)=alp_int(ig)/dp_int(ig) + endif + enddo! + endif + + +! Facteur multiplicatif sur alp_bl + alp_bl(:)=alp_bl_k*alp_bl(:) + +!------------------------------------------------------------------------ + + + + return + end +END MODULE lmdz_thermcell_alp Index: LMDZ6/trunk/libf/phylmd/lmdz_thermcell_closure.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/lmdz_thermcell_closure.F90 (revision 4590) +++ LMDZ6/trunk/libf/phylmd/lmdz_thermcell_closure.F90 (revision 4590) @@ -0,0 +1,75 @@ +MODULE lmdz_thermcell_closure +! +! $Header$ +! +CONTAINS + + SUBROUTINE thermcell_closure(ngrid,nlay,r_aspect,ptimestep,rho, & + & zlev,lalim,alim_star,zmax,wmax,f) + +!------------------------------------------------------------------------- +!thermcell_closure: fermeture, determination de f +! +! Modification 7 septembre 2009 +! 1. On enleve alim_star_tot des arguments pour le recalculer et etre ainis +! coherent avec l'integrale au numerateur. +! 2. On ne garde qu'une version des couples wmax,zmax et wmax_sec,zmax_sec +! l'idee etant que le choix se fasse a l'appel de thermcell_closure +! 3. Vectorisation en mettant les boucles en l l'exterieur avec des if +!------------------------------------------------------------------------- + IMPLICIT NONE + +! --- arguments ------------------------------------------ +integer, intent(in) :: ngrid,nlay +real, intent(in) :: r_aspect,ptimestep +real, intent(in), dimension(ngrid,nlay) :: alim_star,rho,zlev +integer, intent(in), dimension(ngrid) :: lalim +real, intent(in), dimension(ngrid) :: zmax,wmax + +real, intent(out), dimension(ngrid) :: f + + +! --- local ------------------------------------------ +real, dimension(ngrid) :: zdenom,alim_star2,alim_star_tot +INTEGER llmax +INTEGER ig,k + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!print*,'THERMCELL CLOSURE 26E' + +alim_star2(:)=0. +alim_star_tot(:)=0. +f(:)=0. + +! Indice vertical max (max de lalim) atteint par les thermiques sur le domaine +llmax=1 +do ig=1,ngrid + if (lalim(ig)>llmax) llmax=lalim(ig) +enddo + + +! Calcul des integrales sur la verticale de alim_star et de +! alim_star^2/(rho dz) +do k=1,llmax-1 + do ig=1,ngrid + if (k1.e-10) then + f(ig)=wmax(ig)*alim_star_tot(ig)/ & +& (max(500.,zmax(ig))*r_aspect*alim_star2(ig)) + endif +enddo + + + + RETURN + end +END MODULE lmdz_thermcell_closure Index: LMDZ6/trunk/libf/phylmd/lmdz_thermcell_down.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/lmdz_thermcell_down.F90 (revision 4590) +++ LMDZ6/trunk/libf/phylmd/lmdz_thermcell_down.F90 (revision 4590) @@ -0,0 +1,304 @@ +MODULE lmdz_thermcell_down +CONTAINS + +SUBROUTINE thermcell_updown_dq(ngrid,nlay,ptimestep,lmax,eup,dup,edn,ddn,masse,trac,dtrac) + +USE lmdz_thermcell_ini, ONLY: iflag_thermals_down + + +!----------------------------------------------------------------- +! thermcell_updown_dq: computes the tendency of tracers associated +! with the presence of convective up/down drafts +! This routine that has been collectively written during the +! "ateliers downdrafts" in 2022/2023 +! Maelle, Frédéric, Catherine, Fleur, Florent, Etienne +!------------------------------------------------------------------ + + + IMPLICIT NONE + +! declarations +!============================================================== + +! input/output + + integer,intent(in) :: ngrid ! number of horizontal grid points + integer, intent(in) :: nlay ! number of vertical layers + real,intent(in) :: ptimestep ! time step of the physics [s] + real,intent(in), dimension(ngrid,nlay) :: eup ! entrainment to updrafts * dz [same unit as flux] + real,intent(in), dimension(ngrid,nlay) :: dup ! detrainment from updrafts * dz [same unit as flux] + real,intent(in), dimension(ngrid,nlay) :: edn ! entrainment to downdrafts * dz [same unit as flux] + real,intent(in), dimension(ngrid,nlay) :: ddn ! detrainment from downdrafts * dz [same unit as flux] + real,intent(in), dimension(ngrid,nlay) :: masse ! mass of layers = rho dz + real,intent(in), dimension(ngrid,nlay) :: trac ! tracer + integer, intent(in), dimension(ngrid) :: lmax ! max level index at which downdraft are present + real,intent(out),dimension(ngrid,nlay) ::dtrac ! tendance du traceur + + +! Local + + real, dimension(ngrid,nlay+1) :: fup,fdn,fc,fthu,fthd,fthe,fthtot + real, dimension(ngrid,nlay) :: tracu,tracd,traci,tracold + real :: www, mstar_inv + integer ig,ilay + real, dimension(ngrid,nlay):: s1,s2,num !coefficients pour la resolution implicite + integer :: iflag_impl=1 ! 0 pour explicite, 1 pour implicite "classique", 2 pour implicite avec entrainement et detrainement + + fdn(:,:)=0. + fup(:,:)=0. + fc(:,:)=0. + fthu(:,:)=0. + fthd(:,:)=0. + fthe(:,:)=0. + fthtot(:,:)=0. + tracd(:,:)=0. + tracu(:,:)=0. + traci(:,:)=trac(:,:) + tracold(:,:)=trac(:,:) + s1(:,:)=0. + s2(:,:)=0. + num(:,:)=1. + + if ( iflag_thermals_down < 10 ) then + call abort_physic("thermcell_updown_dq", & + 'thermcell_down_dq = 0 or >= 10', 1) + else + iflag_impl=iflag_thermals_down-10 + endif + + + ! lmax : indice tel que fu(kmax+1)=0 + ! Dans ce cas, pas besoin d'initialiser tracd(lmax) ( =trac(lmax) ) + ! Boucle pour le downdraft + do ilay=nlay,1,-1 + do ig=1,ngrid + !if ( lmax(ig) > nlay - 2 ) stop "les thermiques montent trop haut" + if (ilay.le.lmax(ig) .and. lmax(ig)>1 ) then + fdn(ig,ilay)=fdn(ig,ilay+1)+edn(ig,ilay)-ddn(ig,ilay) + if ( fdn(ig,ilay)+ddn(ig,ilay) > 0. ) then + www=fdn(ig,ilay+1)/ (fdn(ig,ilay)+ddn(ig,ilay)) + else + www=0. + endif + tracd(ig,ilay)=www*tracd(ig,ilay+1) + (1.-www)*trac(ig,ilay) + endif + enddo + enddo !Fin boucle sur l'updraft + fdn(:,1)=0. + + !Boucle pour l'updraft + do ilay=1,nlay,1 + do ig=1,ngrid + if (ilay.lt.lmax(ig) .and. lmax(ig)>1) then + fup(ig,ilay+1)=fup(ig,ilay)+eup(ig,ilay)-dup(ig,ilay) + if (fup(ig,ilay+1)+dup(ig,ilay) > 0.) then + www=fup(ig,ilay)/(fup(ig,ilay+1)+dup(ig,ilay)) + else + www=0. + endif + if (ilay == 1 ) then + tracu(ig,ilay)=trac(ig,ilay) + else + tracu(ig,ilay)=www*tracu(ig,ilay-1)+(1.-www)*trac(ig,ilay) + endif + endif + enddo + enddo !fin boucle sur le downdraft + + ! Calcul des flux des traceurs dans les updraft et les downdrfat + ! et du flux de masse compensateur + ! en ilay=1 et nlay+1, fthu=0 et fthd=0 + fthu(:,1)=0. + fthu(:,nlay+1)=0. + fthd(:,1)=0. + fthd(:,nlay+1)=0. + fc(:,1)=0. + fc(:,nlay+1)=0. + do ilay=2,nlay,1 !boucle sur les interfaces + do ig=1,ngrid + fthu(ig,ilay)=fup(ig,ilay)*tracu(ig,ilay-1) + fthd(ig,ilay)=-fdn(ig,ilay)*tracd(ig,ilay) + fc(ig,ilay)=fup(ig,ilay)-fdn(ig,ilay) + enddo + enddo + + + !Boucle pour calculer le flux du traceur flux updraft, flux downdraft, flux compensatoire + !Methode explicite : + if(iflag_impl==0) then + do ilay=2,nlay,1 + do ig=1,ngrid + !!!!ATTENTION HYPOTHESE de FLUX COMPENSATOIRE DESCENDANT ET DONC comme schema amont on va chercher trac au dessus!!!!! + !!!! tentative de prise en compte d'un flux compensatoire montant !!!! + if (fup(ig,ilay)-fdn(ig,ilay) .lt. 0.) then + call abort_physic("thermcell_updown_dq", 'flux compensatoire '& + // 'montant, cas non traite par thermcell_updown_dq', 1) + !fthe(ig,ilay)=(fup(ig,ilay)-fdn(ig,ilay))*trac(ig,ilay-1) + else + fthe(ig,ilay)=-(fup(ig,ilay)-fdn(ig,ilay))*trac(ig,ilay) + endif + !! si on voulait le prendre en compte on + !fthe(ig,ilay)=-(fup(ig,ilay)-fdn(ig,ilay))*trac(ig,ilay-1) + fthtot(ig,ilay)=fthu(ig,ilay)+fthd(ig,ilay)+fthe(ig,ilay) + enddo + enddo + !Boucle pour calculer trac + do ilay=1,nlay + do ig=1,ngrid + dtrac(ig,ilay)=(fthtot(ig,ilay)-fthtot(ig,ilay+1))/masse(ig,ilay) +! trac(ig,ilay)=trac(ig,ilay) + (fthtot(ig,ilay)-fthtot(ig,ilay+1))*(ptimestep/masse(ig,ilay)) + enddo + enddo !fin du calculer de la tendance du traceur avec la methode explicite + + !!! Reecriture du schéma explicite avec les notations du schéma implicite + else if(iflag_impl==-1) then + write(*,*) 'nouveau schéma explicite !!!' + !!! Calcul de s1 + do ilay=1,nlay + do ig=1,ngrid + s1(ig,ilay)=fthu(ig,ilay)-fthu(ig,ilay+1)+fthd(ig,ilay)-fthd(ig,ilay+1) + s2(ig,ilay)=s1(ig,ilay)+fthe(ig,ilay)-fthe(ig,ilay+1) + enddo + enddo + + do ilay=2,nlay,1 + do ig=1,ngrid + if (fup(ig,ilay)-fdn(ig,ilay) .lt. 0.) then + call abort_physic("thermcell_updown_dq", 'flux compensatoire ' & + // 'montant, cas non traite par thermcell_updown_dq', 1) + else + fthe(ig,ilay)=-(fup(ig,ilay)-fdn(ig,ilay))*trac(ig,ilay) + endif + fthtot(ig,ilay)=fthu(ig,ilay)+fthd(ig,ilay)+fthe(ig,ilay) + enddo + enddo + !Boucle pour calculer trac + do ilay=1,nlay + do ig=1,ngrid + ! dtrac(ig,ilay)=(fthtot(ig,ilay)-fthtot(ig,ilay+1))/masse(ig,ilay) + dtrac(ig,ilay)=(s1(ig,ilay)+fthe(ig,ilay)-fthe(ig,ilay+1))/masse(ig,ilay) +! trac(ig,ilay)=trac(ig,ilay) + (fthtot(ig,ilay)-fthtot(ig,ilay+1))*(ptimestep/masse(ig,ilay)) +! trac(ig,ilay)=trac(ig,ilay) + (s1(ig,ilay)+fthe(ig,ilay)-fthe(ig,ilay+1))*(ptimestep/masse(ig,ilay)) + enddo + enddo !fin du calculer de la tendance du traceur avec la methode explicite + + else if (iflag_impl==1) then + do ilay=1,nlay + do ig=1,ngrid + s1(ig,ilay)=fthu(ig,ilay)-fthu(ig,ilay+1)+fthd(ig,ilay)-fthd(ig,ilay+1) + enddo + enddo + + !Boucle pour calculer traci = trac((t+dt) + do ilay=nlay-1,1,-1 + do ig=1,ngrid + if((fup(ig,ilay)-fdn(ig,ilay)) .lt. 0) then + write(*,*) 'flux compensatoire montant, cas non traite par thermcell_updown_dq dans le cas d une resolution implicite, ilay : ', ilay + call abort_physic("thermcell_updown_dq", "", 1) + else + mstar_inv=ptimestep/masse(ig,ilay) + traci(ig,ilay)=((traci(ig,ilay+1)*fc(ig,ilay+1)+s1(ig,ilay))*mstar_inv+tracold(ig,ilay))/(1.+fc(ig,ilay)*mstar_inv) + endif + enddo + enddo + do ilay=1,nlay + do ig=1,ngrid + dtrac(ig,ilay)=(traci(ig,ilay)-tracold(ig,ilay))/ptimestep + enddo + enddo + + else + call abort_physic("thermcell_updown_dq", & + 'valeur de iflag_impl non prevue', 1) + endif + + RETURN + END + +!========================================================================= + + SUBROUTINE thermcell_down(ngrid,nlay,po,pt,pu,pv,pplay,pplev, & + & lmax,fup,eup,dup,theta) + +!-------------------------------------------------------------- +!thermcell_down: calcul des propri??t??s du panache descendant. +!-------------------------------------------------------------- + + + USE lmdz_thermcell_ini, ONLY : prt_level,RLvCp,RKAPPA,RETV,fact_thermals_down + IMPLICIT NONE + +! arguments + + integer,intent(in) :: ngrid,nlay + real,intent(in), dimension(ngrid,nlay) :: po,pt,pu,pv,pplay,eup,dup + real,intent(in), dimension(ngrid,nlay) :: theta + real,intent(in), dimension(ngrid,nlay+1) :: pplev,fup + integer, intent(in), dimension(ngrid) :: lmax + + + +! Local + + real, dimension(ngrid,nlay) :: edn,ddn,thetad + real, dimension(ngrid,nlay+1) :: fdn + + integer ig,ilay + real dqsat_dT + logical mask(ngrid,nlay) + + edn(:,:)=0. + ddn(:,:)=0. + fdn(:,:)=0. + thetad(:,:)=0. + + ! lmax : indice tel que fu(kmax+1)=0 + + ! Dans ce cas, pas besoin d'initialiser thetad(lmax) ( =theta(lmax) ) + +! FH MODIFS APRES REUNIONS POUR COMMISSIONS +! quelques erreurs de declaration +! probleme si lmax=1 ce qui a l'air d'??tre le cas en d??but de simu. Devrait ??tre 0 ? +! Remarques : +! on pourrait ??crire la formule de thetad +! www=fdn(ig,ilay+1)/ (fdn(ig,ilay)+ddn(ig,ilay)) +! thetad(ig,ilay)= www * thetad(ig,ilay+1) + (1.-www) * theta(ig,ilay) +! Elle a l'avantage de bien montr?? la conservation, l'id??e fondamentale dans le +! transport qu'on ne fait que sommer des "sources" au travers d'un "propagateur" +! (Green) +! Elle montre aussi beaucoup plus clairement pourquoi on n'a pas ?? se souccier (trop) +! de la possible nulit?? du d??nominateur + + + do ilay=nlay,1,-1 + do ig=1,ngrid + if (ilay.le.lmax(ig).and.lmax(ig)>1) then + edn(ig,ilay)=fact_thermals_down*dup(ig,ilay) + ddn(ig,ilay)=fact_thermals_down*eup(ig,ilay) + fdn(ig,ilay)=fdn(ig,ilay+1)+edn(ig,ilay)-ddn(ig,ilay) + thetad(ig,ilay)=( fdn(ig,ilay+1)*thetad(ig,ilay+1) + edn(ig,ilay)*theta(ig,ilay) ) / (fdn(ig,ilay)+ddn(ig,ilay)) + endif + enddo + enddo + + ! Suite du travail : + ! Ecrire la conservervation de theta_l dans le panache descendant + ! Eventuellement faire la transformation theta_l -> theta_v + ! Si l'air est sec (et qu'on oublie le c??t?? theta_v) on peut + ! se contenter de conserver theta. + ! + ! Connaissant thetadn, on peut calculer la flotabilit??. + ! Connaissant la flotabilit??, on peut calculer w de proche en proche + ! On peut calculer le detrainement de facon ?? garder alpha*rho = cste + ! On en d??duit l'entrainement lat??ral + ! C'est le mod??le des mini-projets. + +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! Initialisations : +!------------------ + + +! + RETURN + END +END MODULE lmdz_thermcell_down Index: LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dq.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dq.F90 (revision 4590) +++ LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dq.F90 (revision 4590) @@ -0,0 +1,331 @@ +MODULE lmdz_thermcell_dq +CONTAINS + + subroutine thermcell_dq(ngrid,nlay,impl,ptimestep,fm,entr, & + & masse,q,dq,qa,lev_out) + USE print_control_mod, ONLY: prt_level + + implicit none + +!======================================================================= +! +! Calcul du transport verticale dans la couche limite en presence +! de "thermiques" explicitement representes +! calcul du dq/dt une fois qu'on connait les ascendances +! +! Modif 2013/01/04 (FH hourdin@lmd.jussieu.fr) +! Introduction of an implicit computation of vertical advection in +! the environment of thermal plumes in thermcell_dq +! impl = 0 : explicit, 1 : implicit, -1 : old version +! +!======================================================================= + +! arguments + integer, intent(in) :: ngrid,nlay,impl + real, intent(in) :: ptimestep + real, intent(in), dimension(ngrid,nlay) :: masse + real, intent(inout), dimension(ngrid,nlay) :: entr,q + real, intent(in), dimension(ngrid,nlay+1) :: fm + real, intent(out), dimension(ngrid,nlay) :: dq,qa + integer, intent(in) :: lev_out ! niveau pour les print + +! Local + real, dimension(ngrid,nlay) :: detr,qold + real, dimension(ngrid,nlay+1) :: wqd,fqa + real zzm + integer ig,k + real cfl + + integer niter,iter + CHARACTER (LEN=20) :: modname='thermcell_dq' + CHARACTER (LEN=80) :: abort_message + + +! Old explicite scheme +if (impl<=-1) then + + call thermcell_dq_o(ngrid,nlay,impl,ptimestep,fm,entr, & + & masse,q,dq,qa,lev_out) + +else + + +! Calcul du critere CFL pour l'advection dans la subsidence + cfl = 0. + do k=1,nlay + do ig=1,ngrid + zzm=masse(ig,k)/ptimestep + cfl=max(cfl,fm(ig,k)/zzm) + if (entr(ig,k).gt.zzm) then + print*,'entr*dt>m,1',k,entr(ig,k)*ptimestep,masse(ig,k) + abort_message = 'entr dt > m, 1st' + CALL abort_physic (modname,abort_message,1) + endif + enddo + enddo + + qold=q + + + if (prt_level.ge.1) print*,'Q2 THERMCEL_DQ 0' + +! calcul du detrainement + do k=1,nlay + do ig=1,ngrid + detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k) +! print*,'Q2 DQ ',detr(ig,k),fm(ig,k),entr(ig,k) +!test + if (detr(ig,k).lt.0.) then + entr(ig,k)=entr(ig,k)-detr(ig,k) + detr(ig,k)=0. +! print*,'detr2<0!!!','ig=',ig,'k=',k,'f=',fm(ig,k), +! s 'f+1=',fm(ig,k+1),'e=',entr(ig,k),'d=',detr(ig,k) + endif + if (fm(ig,k+1).lt.0.) then +! print*,'fm2<0!!!' + endif + if (entr(ig,k).lt.0.) then +! print*,'entr2<0!!!' + endif + enddo + enddo + +! Computation of tracer concentrations in the ascending plume + do ig=1,ngrid + qa(ig,1)=q(ig,1) + enddo + + do k=2,nlay + do ig=1,ngrid + if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt. & + & 1.e-5*masse(ig,k)) then + qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k)) & + & /(fm(ig,k+1)+detr(ig,k)) + else + qa(ig,k)=q(ig,k) + endif + if (qa(ig,k).lt.0.) then +! print*,'qa<0!!!' + endif + if (q(ig,k).lt.0.) then +! print*,'q<0!!!' + endif + enddo + enddo + +! Plume vertical flux + do k=2,nlay-1 + fqa(:,k)=fm(:,k)*qa(:,k-1) + enddo + fqa(:,1)=0. ; fqa(:,nlay)=0. + + +! Trace species evolution + if (impl==0) then + do k=1,nlay-1 + q(:,k)=q(:,k)+(fqa(:,k)-fqa(:,k+1)-fm(:,k)*q(:,k)+fm(:,k+1)*q(:,k+1)) & + & *ptimestep/masse(:,k) + enddo + else + do k=nlay-1,1,-1 +! FH debut de modif : le calcul ci dessous modifiait numériquement +! la concentration quand le flux de masse etait nul car on divisait +! puis multipliait par masse/ptimestep. +! q(:,k)=(masse(:,k)*q(:,k)/ptimestep+fqa(:,k)-fqa(:,k+1)+fm(:,k+1)*q(:,k+1)) & +! & /(fm(:,k)+masse(:,k)/ptimestep) + q(:,k)=(q(:,k)+ptimestep/masse(:,k)*(fqa(:,k)-fqa(:,k+1)+fm(:,k+1)*q(:,k+1))) & + & /(1.+fm(:,k)*ptimestep/masse(:,k)) +! FH fin de modif. + enddo + endif + +! Tendencies + do k=1,nlay + do ig=1,ngrid + dq(ig,k)=(q(ig,k)-qold(ig,k))/ptimestep + q(ig,k)=qold(ig,k) + enddo + enddo + +endif ! impl=-1 +RETURN +end + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Obsolete version kept for convergence with Cmip5 NPv3.1 simulations +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine thermcell_dq_o(ngrid,nlay,impl,ptimestep,fm,entr, & + & masse,q,dq,qa,lev_out) + USE print_control_mod, ONLY: prt_level + implicit none + +!======================================================================= +! +! Calcul du transport verticale dans la couche limite en presence +! de "thermiques" explicitement representes +! calcul du dq/dt une fois qu'on connait les ascendances +! +!======================================================================= + + integer ngrid,nlay,impl + + real ptimestep + real masse(ngrid,nlay),fm(ngrid,nlay+1) + real entr(ngrid,nlay) + real q(ngrid,nlay) + real dq(ngrid,nlay) + integer lev_out ! niveau pour les print + + real qa(ngrid,nlay),detr(ngrid,nlay),wqd(ngrid,nlay+1) + + real zzm + + integer ig,k + real cfl + + real qold(ngrid,nlay) + real ztimestep + integer niter,iter + CHARACTER (LEN=20) :: modname='thermcell_dq' + CHARACTER (LEN=80) :: abort_message + + + +! Calcul du critere CFL pour l'advection dans la subsidence + cfl = 0. + do k=1,nlay + do ig=1,ngrid + zzm=masse(ig,k)/ptimestep + cfl=max(cfl,fm(ig,k)/zzm) + if (entr(ig,k).gt.zzm) then + print*,'entr*dt>m,2',k,entr(ig,k)*ptimestep,masse(ig,k) + abort_message = 'entr dt > m, 2nd' + CALL abort_physic (modname,abort_message,1) + endif + enddo + enddo + +!IM 090508 print*,'CFL CFL CFL CFL ',cfl + +#undef CFL +#ifdef CFL +! On subdivise le calcul en niter pas de temps. + niter=int(cfl)+1 +#else + niter=1 +#endif + + ztimestep=ptimestep/niter + qold=q + + +do iter=1,niter + if (prt_level.ge.1) print*,'Q2 THERMCEL_DQ 0' + +! calcul du detrainement + do k=1,nlay + do ig=1,ngrid + detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k) +! print*,'Q2 DQ ',detr(ig,k),fm(ig,k),entr(ig,k) +!test + if (detr(ig,k).lt.0.) then + entr(ig,k)=entr(ig,k)-detr(ig,k) + detr(ig,k)=0. +! print*,'detr2<0!!!','ig=',ig,'k=',k,'f=',fm(ig,k), +! s 'f+1=',fm(ig,k+1),'e=',entr(ig,k),'d=',detr(ig,k) + endif + if (fm(ig,k+1).lt.0.) then +! print*,'fm2<0!!!' + endif + if (entr(ig,k).lt.0.) then +! print*,'entr2<0!!!' + endif + enddo + enddo + +! calcul de la valeur dans les ascendances + do ig=1,ngrid + qa(ig,1)=q(ig,1) + enddo + + do k=2,nlay + do ig=1,ngrid + if ((fm(ig,k+1)+detr(ig,k))*ztimestep.gt. & + & 1.e-5*masse(ig,k)) then + qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k)) & + & /(fm(ig,k+1)+detr(ig,k)) + else + qa(ig,k)=q(ig,k) + endif + if (qa(ig,k).lt.0.) then +! print*,'qa<0!!!' + endif + if (q(ig,k).lt.0.) then +! print*,'q<0!!!' + endif + enddo + enddo + +! Calcul du flux subsident + + do k=2,nlay + do ig=1,ngrid +#undef centre +#ifdef centre + wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k)) +#else + +#define plusqueun +#ifdef plusqueun +! Schema avec advection sur plus qu'une maille. + zzm=masse(ig,k)/ztimestep + if (fm(ig,k)>zzm) then + wqd(ig,k)=zzm*q(ig,k)+(fm(ig,k)-zzm)*q(ig,k+1) + else + wqd(ig,k)=fm(ig,k)*q(ig,k) + endif +#else + wqd(ig,k)=fm(ig,k)*q(ig,k) +#endif +#endif + + if (wqd(ig,k).lt.0.) then +! print*,'wqd<0!!!' + endif + enddo + enddo + do ig=1,ngrid + wqd(ig,1)=0. + wqd(ig,nlay+1)=0. + enddo + + +! Calcul des tendances + do k=1,nlay + do ig=1,ngrid + q(ig,k)=q(ig,k)+(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k) & + & -wqd(ig,k)+wqd(ig,k+1)) & + & *ztimestep/masse(ig,k) +! if (dq(ig,k).lt.0.) then +! print*,'dq<0!!!' +! endif + enddo + enddo + + +enddo + + +! Calcul des tendances + do k=1,nlay + do ig=1,ngrid + dq(ig,k)=(q(ig,k)-qold(ig,k))/ptimestep + q(ig,k)=qold(ig,k) + enddo + enddo + + return + end +END MODULE lmdz_thermcell_dq Index: LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dry.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dry.F90 (revision 4590) +++ LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dry.F90 (revision 4590) @@ -0,0 +1,169 @@ +MODULE lmdz_thermcell_dry +! +! $Id$ +! +CONTAINS + + SUBROUTINE thermcell_dry(ngrid,nlay,zlev,pphi,ztv,alim_star, & + & lalim,lmin,zmax,wmax) + +!-------------------------------------------------------------------------- +!thermcell_dry: calcul de zmax et wmax du thermique sec +! Calcul de la vitesse maximum et de la hauteur maximum pour un panache +! ascendant avec une fonction d'alimentation alim_star et sans changement +! de phase. +! Le calcul pourrait etre sans doute simplifier. +! La temperature potentielle virtuelle dans la panache ascendant est +! la temperature potentielle virtuelle pondérée par alim_star. +!-------------------------------------------------------------------------- + USE lmdz_thermcell_ini, ONLY: prt_level, RG + IMPLICIT NONE + + integer, intent(in) :: ngrid,nlay + real, intent(in), dimension(ngrid,nlay+1) :: zlev,pphi,ztv,alim_star + integer, intent(in), dimension(ngrid) :: lalim + real, intent(out), dimension(ngrid) :: zmax,wmax + +!variables locales + REAL zw2(ngrid,nlay+1) + REAL f_star(ngrid,nlay+1) + REAL ztva(ngrid,nlay+1) + REAL wmaxa(ngrid) + REAL wa_moy(ngrid,nlay+1) + REAL linter(ngrid),zlevinter(ngrid) + INTEGER lmix(ngrid),lmax(ngrid),lmin(ngrid) + CHARACTER (LEN=20) :: modname='thermcell_dry' + CHARACTER (LEN=80) :: abort_message + INTEGER l,ig + +!initialisations + do ig=1,ngrid + do l=1,nlay+1 + zw2(ig,l)=0. + wa_moy(ig,l)=0. + enddo + enddo + do ig=1,ngrid + do l=1,nlay + ztva(ig,l)=ztv(ig,l) + enddo + enddo + do ig=1,ngrid + wmax(ig)=0. + wmaxa(ig)=0. + enddo +!calcul de la vitesse a partir de la CAPE en melangeant thetav + + +! Calcul des F^*, integrale verticale de E^* + f_star(:,1)=0. + do l=1,nlay + f_star(:,l+1)=f_star(:,l)+alim_star(:,l) + enddo + +! niveau (reel) auquel zw2 s'annule FH :n'etait pas initialise + linter(:)=0. + +! couche la plus haute concernee par le thermique. + lmax(:)=1 + +! Le niveau linter est une variable continue qui se trouve dans la couche +! lmax + + do l=1,nlay-2 + do ig=1,ngrid + if (l.eq.lmin(ig).and.lalim(ig).gt.1) then + +!------------------------------------------------------------------------ +! Calcul de la vitesse en haut de la premiere couche instable. +! Premiere couche du panache thermique +!------------------------------------------------------------------------ + + zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) & + & *(zlev(ig,l+1)-zlev(ig,l)) & + & *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l)) + +!------------------------------------------------------------------------ +! Tant que la vitesse en bas de la couche et la somme du flux de masse +! et de l'entrainement (c'est a dire le flux de masse en haut) sont +! positifs, on calcul +! 1. le flux de masse en haut f_star(ig,l+1) +! 2. la temperature potentielle virtuelle dans la couche ztva(ig,l) +! 3. la vitesse au carré en haut zw2(ig,l+1) +!------------------------------------------------------------------------ + + else if (zw2(ig,l).ge.1e-10) then + + ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+alim_star(ig,l) & + & *ztv(ig,l))/f_star(ig,l+1) + zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+ & + & 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) & + & *(zlev(ig,l+1)-zlev(ig,l)) + endif +! determination de zmax continu par interpolation lineaire +!------------------------------------------------------------------------ + + if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then +! stop'On tombe sur le cas particulier de thermcell_dry' +! print*,'On tombe sur le cas particulier de thermcell_dry' + zw2(ig,l+1)=0. + linter(ig)=l+1 + lmax(ig)=l + endif + + if (zw2(ig,l+1).lt.0.) then + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) & + & -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. + lmax(ig)=l +! endif +!CR:zmax continu 06/05/12: calcul de linter quand le thermique est stoppe par le detrainement + elseif (f_star(ig,l+1).lt.0.) then + linter(ig)=(l*(f_star(ig,l+1)-f_star(ig,l)) & + & -f_star(ig,l))/(f_star(ig,l+1)-f_star(ig,l)) + zw2(ig,l+1)=0. + lmax(ig)=l + endif +!CRfin + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +! lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + enddo + if (prt_level.ge.1) print*,'fin calcul zw2' +! +! Determination de zw2 max + do ig=1,ngrid + wmax(ig)=0. + enddo + + do l=1,nlay + do ig=1,ngrid + if (l.le.lmax(ig)) then + zw2(ig,l)=sqrt(zw2(ig,l)) + wmax(ig)=max(wmax(ig),zw2(ig,l)) + else + zw2(ig,l)=0. + endif + enddo + enddo + +! Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=0. + zlevinter(ig)=zlev(ig,1) + enddo + do ig=1,ngrid +! calcul de zlevinter + zlevinter(ig)=zlev(ig,lmax(ig)) + & + & (linter(ig)-lmax(ig))*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig))) + zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + enddo + + RETURN + END +END MODULE lmdz_thermcell_dry Index: LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dtke.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dtke.F90 (revision 4590) +++ LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dtke.F90 (revision 4590) @@ -0,0 +1,127 @@ +MODULE lmdz_thermcell_dtke +CONTAINS + + subroutine thermcell_dtke(ngrid,nlay,nsrf,ptimestep,fm0,entr0, & + & rg,pplev,tke) + USE print_control_mod, ONLY: prt_level + implicit none + +!======================================================================= +! +! Calcul du transport verticale dans la couche limite en presence +! de "thermiques" explicitement representes +! calcul du dq/dt une fois qu'on connait les ascendances +! +!======================================================================= + + integer ngrid,nlay,nsrf + + real ptimestep + real masse0(ngrid,nlay),fm0(ngrid,nlay+1),pplev(ngrid,nlay+1) + real entr0(ngrid,nlay),rg + real tke(ngrid,nlay,nsrf) + real detr0(ngrid,nlay) + + + real masse(ngrid,nlay),fm(ngrid,nlay+1) + real entr(ngrid,nlay) + real q(ngrid,nlay) + integer lev_out ! niveau pour les print + + real qa(ngrid,nlay),detr(ngrid,nlay),wqd(ngrid,nlay+1) + + real zzm + + integer ig,k + integer isrf + + + lev_out=0 + + + if (prt_level.ge.1) print*,'Q2 THERMCEL_DQ 0' + +! calcul du detrainement + do k=1,nlay + detr0(:,k)=fm0(:,k)-fm0(:,k+1)+entr0(:,k) + masse0(:,k)=(pplev(:,k)-pplev(:,k+1))/RG + enddo + + +! Decalage vertical des entrainements et detrainements. + masse(:,1)=0.5*masse0(:,1) + entr(:,1)=0.5*entr0(:,1) + detr(:,1)=0.5*detr0(:,1) + fm(:,1)=0. + do k=1,nlay-1 + masse(:,k+1)=0.5*(masse0(:,k)+masse0(:,k+1)) + entr(:,k+1)=0.5*(entr0(:,k)+entr0(:,k+1)) + detr(:,k+1)=0.5*(detr0(:,k)+detr0(:,k+1)) + fm(:,k+1)=fm(:,k)+entr(:,k)-detr(:,k) + enddo + fm(:,nlay+1)=0. + +! calcul de la valeur dans les ascendances + do ig=1,ngrid + qa(ig,1)=q(ig,1) + enddo + + + +do isrf=1,nsrf + + q(:,:)=tke(:,:,isrf) + + if (1==1) then + do k=2,nlay + do ig=1,ngrid + if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt. & + & 1.e-5*masse(ig,k)) then + qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k)) & + & /(fm(ig,k+1)+detr(ig,k)) + else + qa(ig,k)=q(ig,k) + endif + if (qa(ig,k).lt.0.) then +! print*,'qa<0!!!' + endif + if (q(ig,k).lt.0.) then +! print*,'q<0!!!' + endif + enddo + enddo + +! Calcul du flux subsident + + do k=2,nlay + do ig=1,ngrid + wqd(ig,k)=fm(ig,k)*q(ig,k) + if (wqd(ig,k).lt.0.) then +! print*,'wqd<0!!!' + endif + enddo + enddo + do ig=1,ngrid + wqd(ig,1)=0. + wqd(ig,nlay+1)=0. + enddo + + +! Calcul des tendances + do k=1,nlay + do ig=1,ngrid + q(ig,k)=q(ig,k)+(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k) & + & -wqd(ig,k)+wqd(ig,k+1)) & + & *ptimestep/masse(ig,k) + enddo + enddo + + endif + + tke(:,:,isrf)=q(:,:) + +enddo + + return + end +END MODULE lmdz_thermcell_dtke Index: LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dv2.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dv2.F90 (revision 4590) +++ LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dv2.F90 (revision 4590) @@ -0,0 +1,197 @@ +MODULE lmdz_thermcell_dv2 +CONTAINS + + subroutine thermcell_dv2(ngrid,nlay,ptimestep,fm,entr,masse & + & ,fraca,larga & + & ,u,v,du,dv,ua,va,lev_out) + USE print_control_mod, ONLY: prt_level,lunout + implicit none + +!======================================================================= +! +! Calcul du transport verticale dans la couche limite en presence +! de "thermiques" explicitement representes +! calcul du dq/dt une fois qu'on connait les ascendances +! +! Vectorisation, FH : 2010/03/08 +! +!======================================================================= + + + integer ngrid,nlay + + real ptimestep + real masse(ngrid,nlay),fm(ngrid,nlay+1) + real fraca(ngrid,nlay+1) + real larga(ngrid) + real entr(ngrid,nlay) + real u(ngrid,nlay) + real ua(ngrid,nlay) + real du(ngrid,nlay) + real v(ngrid,nlay) + real va(ngrid,nlay) + real dv(ngrid,nlay) + integer lev_out ! niveau pour les print + + real qa(ngrid,nlay),detr(ngrid,nlay),zf,zf2 + real wvd(ngrid,nlay+1),wud(ngrid,nlay+1) + real gamma0(ngrid,nlay+1),gamma(ngrid,nlay+1) + real ue(ngrid,nlay),ve(ngrid,nlay) + LOGICAL ltherm(ngrid,nlay) + real dua(ngrid,nlay),dva(ngrid,nlay) + integer iter + + integer ig,k,nlarga0 + +!------------------------------------------------------------------------- + +! calcul du detrainement +!--------------------------- + +! print*,'THERMCELL DV2 OPTIMISE 3' + + nlarga0=0. + + do k=1,nlay + do ig=1,ngrid + detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k) + enddo + enddo + +! calcul de la valeur dans les ascendances + do ig=1,ngrid + ua(ig,1)=u(ig,1) + va(ig,1)=v(ig,1) + ue(ig,1)=u(ig,1) + ve(ig,1)=v(ig,1) + enddo + + IF(prt_level>9)WRITE(lunout,*) & + & 'WARNING on initialise gamma(1:ngrid,1)=0.' + gamma(1:ngrid,1)=0. + do k=2,nlay + do ig=1,ngrid + ltherm(ig,k)=(fm(ig,k+1)+detr(ig,k))*ptimestep > 1.e-5*masse(ig,k) + if(ltherm(ig,k).and.larga(ig)>0.) then + gamma0(ig,k)=masse(ig,k) & + & *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) ) & + & *0.5/larga(ig) & + & *1. + else + gamma0(ig,k)=0. + endif + if (ltherm(ig,k).and.larga(ig)<=0.) nlarga0=nlarga0+1 + enddo + enddo + + gamma(:,:)=0. + + do k=2,nlay + + do ig=1,ngrid + if (ltherm(ig,k)) then + dua(ig,k)=ua(ig,k-1)-u(ig,k-1) + dva(ig,k)=va(ig,k-1)-v(ig,k-1) + else + ua(ig,k)=u(ig,k) + va(ig,k)=v(ig,k) + ue(ig,k)=u(ig,k) + ve(ig,k)=v(ig,k) + endif + enddo + + +! Debut des iterations +!---------------------- +do iter=1,5 + do ig=1,ngrid +! Pour memoire : calcul prenant en compte la fraction reelle +! zf=0.5*(fraca(ig,k)+fraca(ig,k+1)) +! zf2=1./(1.-zf) +! Calcul avec fraction infiniement petite + zf=0. + zf2=1. + +! la première fois on multiplie le coefficient de freinage +! par le module du vent dans la couche en dessous. +! Mais pourquoi donc ??? + if (ltherm(ig,k)) then +! On choisit une relaxation lineaire. +! gamma(ig,k)=gamma0(ig,k) +! On choisit une relaxation quadratique. + gamma(ig,k)=gamma0(ig,k)*sqrt(dua(ig,k)**2+dva(ig,k)**2) + ua(ig,k)=(fm(ig,k)*ua(ig,k-1) & + & +(zf2*entr(ig,k)+gamma(ig,k))*u(ig,k)) & + & /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2 & + & +gamma(ig,k)) + va(ig,k)=(fm(ig,k)*va(ig,k-1) & + & +(zf2*entr(ig,k)+gamma(ig,k))*v(ig,k)) & + & /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2 & + & +gamma(ig,k)) +! print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua(ig,k),dva(ig,k) + dua(ig,k)=ua(ig,k)-u(ig,k) + dva(ig,k)=va(ig,k)-v(ig,k) + ue(ig,k)=(u(ig,k)-zf*ua(ig,k))*zf2 + ve(ig,k)=(v(ig,k)-zf*va(ig,k))*zf2 + endif + enddo +! Fin des iterations +!-------------------- +enddo + + enddo ! k=2,nlay + + +! Calcul du flux vertical de moment dans l'environnement. +!--------------------------------------------------------- + do k=2,nlay + do ig=1,ngrid + wud(ig,k)=fm(ig,k)*ue(ig,k) + wvd(ig,k)=fm(ig,k)*ve(ig,k) + enddo + enddo + do ig=1,ngrid + wud(ig,1)=0. + wud(ig,nlay+1)=0. + wvd(ig,1)=0. + wvd(ig,nlay+1)=0. + enddo + +! calcul des tendances. +!----------------------- + do k=1,nlay + do ig=1,ngrid + du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k) & + & -(entr(ig,k)+gamma(ig,k))*ue(ig,k) & + & -wud(ig,k)+wud(ig,k+1)) & + & /masse(ig,k) + dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k) & + & -(entr(ig,k)+gamma(ig,k))*ve(ig,k) & + & -wvd(ig,k)+wvd(ig,k+1)) & + & /masse(ig,k) + enddo + enddo + + +! Sorties eventuelles. +!---------------------- + + if(prt_level.GE.10) then + do k=1,nlay + do ig=1,ngrid + print*,'th_dv2 ig k gamma entr detr ua ue va ve wud wvd masse',ig,k,gamma(ig,k), & + & entr(ig,k),detr(ig,k),ua(ig,k),ue(ig,k),va(ig,k),ve(ig,k),wud(ig,k),wvd(ig,k),wud(ig,k+1),wvd(ig,k+1), & + & masse(ig,k) + enddo + enddo + endif +! + if (nlarga0>0) then + print*,'WARNING !!!!!! DANS THERMCELL_DV2 ' + print*,nlarga0,' points pour lesquels laraga=0. dans un thermique' + print*,'Il faudrait decortiquer ces points' + endif + + return + end +END MODULE lmdz_thermcell_dv2 Index: LMDZ6/trunk/libf/phylmd/lmdz_thermcell_env.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/lmdz_thermcell_env.F90 (revision 4590) +++ LMDZ6/trunk/libf/phylmd/lmdz_thermcell_env.F90 (revision 4590) @@ -0,0 +1,83 @@ +MODULE lmdz_thermcell_env +CONTAINS + + SUBROUTINE thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay, & + & pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,pqsat,lev_out) + +!-------------------------------------------------------------- +!thermcell_env: calcule les caracteristiques de l environnement +!necessaires au calcul des proprietes dans le thermique +!-------------------------------------------------------------- + + + USE lmdz_thermcell_ini, ONLY : prt_level,RLvCp,RKAPPA,RETV + USE lmdz_thermcell_qsat, ONLY : thermcell_qsat + IMPLICIT NONE + +! arguments + + integer,intent(in) :: ngrid,nlay,lev_out + real,intent(in), dimension(ngrid,nlay) :: po,pt,pu,pv,pplay + real,intent(in), dimension(ngrid,nlay+1) :: pplev + real,intent(out), dimension(ngrid,nlay) :: zo,zl,zh,ztv,zthl + real,intent(out), dimension(ngrid,nlay) :: zpspsk,zu,zv,pqsat + +! Local + + integer ig,ll + real dqsat_dT + logical mask(ngrid,nlay) + + +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! Initialisations : +!------------------ + + mask(:,:)=.true. + +! +! calcul des caracteristiques de l environnement + DO ll=1,nlay + DO ig=1,ngrid + zo(ig,ll)=po(ig,ll) + zl(ig,ll)=0. + zh(ig,ll)=pt(ig,ll) + enddo + enddo + +! Condensation : +!--------------- +! Calcul de l'humidite a saturation et de la condensation + + call thermcell_qsat(ngrid*nlay,mask,pplev,pt,po,pqsat) + do ll=1,nlay + do ig=1,ngrid + zl(ig,ll) = max(0.,po(ig,ll)-pqsat(ig,ll)) + zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll) ! T = Tl + Lv/Cp ql + zo(ig,ll) = po(ig,ll)-zl(ig,ll) + enddo + enddo + +!----------------------------------------------------------------------- + if (prt_level.ge.1) print*,'0 OK convect8' + + do ll=1,nlay + do ig=1,ngrid + zpspsk(ig,ll)=(pplay(ig,ll)/100000.)**RKAPPA + zu(ig,ll)=pu(ig,ll) + zv(ig,ll)=pv(ig,ll) +!attention zh est maintenant le profil de T et plus le profil de theta ! +! Quelle horreur ! A eviter. +! T-> Theta + ztv(ig,ll)=zh(ig,ll)/zpspsk(ig,ll) +!Theta_v + ztv(ig,ll)=ztv(ig,ll)*(1.+RETV*(zo(ig,ll))-zl(ig,ll)) +!Thetal + zthl(ig,ll)=pt(ig,ll)/zpspsk(ig,ll) +! + enddo + enddo + + RETURN + END +END MODULE lmdz_thermcell_env Index: LMDZ6/trunk/libf/phylmd/lmdz_thermcell_flux2.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/lmdz_thermcell_flux2.F90 (revision 4590) +++ LMDZ6/trunk/libf/phylmd/lmdz_thermcell_flux2.F90 (revision 4590) @@ -0,0 +1,515 @@ +MODULE lmdz_thermcell_flux2 +! +! $Id$ +! +CONTAINS + + SUBROUTINE thermcell_flux2(ngrid,nlay,ptimestep,masse, & + & lalim,lmax,alim_star, & + & entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr, & + & detr,zqla,lev_out,lunout1,igout) +!IM 060508 & detr,zqla,zmax,lev_out,lunout,igout) + + +!--------------------------------------------------------------------------- +!thermcell_flux: deduction des flux +!--------------------------------------------------------------------------- + + USE lmdz_thermcell_ini, ONLY : prt_level,iflag_thermals_optflux + IMPLICIT NONE + +! arguments + INTEGER, intent(in) :: ngrid,nlay + REAL, intent(in) :: ptimestep + REAL, intent(in), dimension(ngrid,nlay) :: masse + INTEGER, intent(in), dimension(ngrid) :: lalim,lmax + REAL, intent(in), dimension(ngrid,nlay) :: alim_star,entr_star,detr_star + REAL, intent(in), dimension(ngrid) :: f + REAL, intent(in), dimension(ngrid,nlay) :: rhobarz + REAL, intent(in), dimension(ngrid,nlay+1) :: zw2,zlev +! FH : laisser ca le temps de verifier qu'on a bien fait de commenter les +! lignes faisant apparaitre zqla, zmax ... +! REAL, intent(in), dimension(ngrid) :: zmax(ngrid) +! enlever aussi zqla + REAL, intent(in), dimension(ngrid,nlay) :: zqla ! not used + integer, intent(in) :: lev_out, lunout1 + + REAL,intent(out), dimension(ngrid,nlay) :: entr,detr + REAL,intent(out), dimension(ngrid,nlay+1) :: fm + +! local + INTEGER ig,l + integer igout,lout + REAL zfm + integer ncorecfm1,ncorecfm2,ncorecfm3,ncorecalpha + integer ncorecfm4,ncorecfm5,ncorecfm6,ncorecfm7,ncorecfm8 + + + REAL f_old,ddd0,eee0,ddd,eee,zzz + + REAL,SAVE :: fomass_max=0.5 + REAL,SAVE :: alphamax=0.7 +!$OMP THREADPRIVATE(fomass_max,alphamax) + + logical check_debug,labort_physic + + character (len=20) :: modname='thermcell_flux2' + character (len=80) :: abort_message + + + ncorecfm1=0 + ncorecfm2=0 + ncorecfm3=0 + ncorecfm4=0 + ncorecfm5=0 + ncorecfm6=0 + ncorecfm7=0 + ncorecfm8=0 + ncorecalpha=0 + +!initialisation + fm(:,:)=0. + + if (prt_level.ge.10) then + write(lunout1,*) 'Dans thermcell_flux 0' + write(lunout1,*) 'flux base ',f(igout) + write(lunout1,*) 'lmax ',lmax(igout) + write(lunout1,*) 'lalim ',lalim(igout) + write(lunout1,*) 'ig= ',igout + write(lunout1,*) ' l E* A* D* ' + write(lunout1,'(i4,3e15.5)') (l,entr_star(igout,l),alim_star(igout,l),detr_star(igout,l) & + & ,l=1,lmax(igout)) + endif + + +!------------------------------------------------------------------------- +! Verification de la nullite des entrainement et detrainement au dessus +! de lmax(ig) +! Active uniquement si check_debug=.true. ou prt_level>=10 +!------------------------------------------------------------------------- + + check_debug=.false..or.prt_level>=10 + + if (check_debug) then + do l=1,nlay + do ig=1,ngrid + if (l.le.lmax(ig)) then + if (entr_star(ig,l).gt.1.) then + print*,'WARNING thermcell_flux 1 ig,l,lmax(ig)',ig,l,lmax(ig) + print*,'entr_star(ig,l)',entr_star(ig,l) + print*,'alim_star(ig,l)',alim_star(ig,l) + print*,'detr_star(ig,l)',detr_star(ig,l) + endif + else + if (abs(entr_star(ig,l))+abs(alim_star(ig,l))+abs(detr_star(ig,l)).gt.0.) then + print*,'cas 1 : ig,l,lmax(ig)',ig,l,lmax(ig) + print*,'entr_star(ig,l)',entr_star(ig,l) + print*,'alim_star(ig,l)',alim_star(ig,l) + print*,'detr_star(ig,l)',detr_star(ig,l) + abort_message = '' + labort_physic=.true. + CALL abort_physic (modname,abort_message,1) + endif + endif + enddo + enddo + endif + +!------------------------------------------------------------------------- +! Multiplication par le flux de masse issu de la femreture +!------------------------------------------------------------------------- + + do l=1,nlay + entr(:,l)=f(:)*(entr_star(:,l)+alim_star(:,l)) + detr(:,l)=f(:)*detr_star(:,l) + enddo + + if (prt_level.ge.10) then + write(lunout1,*) 'Dans thermcell_flux 1' + write(lunout1,*) 'flux base ',f(igout) + write(lunout1,*) 'lmax ',lmax(igout) + write(lunout1,*) 'lalim ',lalim(igout) + write(lunout1,*) 'ig= ',igout + write(lunout1,*) ' l E D W2' + write(lunout1,'(i4,3e15.5)') (l,entr(igout,l),detr(igout,l) & + & ,zw2(igout,l+1),l=1,lmax(igout)) + endif + + fm(:,1)=0. + do l=1,nlay + do ig=1,ngrid + if (l.lt.lmax(ig)) then + fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l) + elseif(l.eq.lmax(ig)) then + fm(ig,l+1)=0. + detr(ig,l)=fm(ig,l)+entr(ig,l) + else + fm(ig,l+1)=0. + endif + enddo + enddo + + + +! Test provisoire : pour comprendre pourquoi on corrige plein de fois +! le cas fm6, on commence par regarder une premiere fois avant les +! autres corrections. + + do l=1,nlay + do ig=1,ngrid + if (detr(ig,l).gt.fm(ig,l)) then + ncorecfm8=ncorecfm8+1 +! igout=ig + endif + enddo + enddo + +! if (prt_level.ge.10) & +! & call printflux(ngrid,nlay,lunout1,igout,f,lmax,lalim, & +! & ptimestep,masse,entr,detr,fm,'2 ') + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH Version en cours de test; +! par rapport a thermcell_flux, on fait une grande boucle sur "l" +! et on modifie le flux avec tous les contr�les appliques d'affilee +! pour la meme couche +! Momentanement, on duplique le calcule du flux pour pouvoir comparer +! les flux avant et apres modif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do l=1,nlay + + do ig=1,ngrid + if (l.lt.lmax(ig)) then + fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l) + elseif(l.eq.lmax(ig)) then + fm(ig,l+1)=0. + detr(ig,l)=fm(ig,l)+entr(ig,l) + else + fm(ig,l+1)=0. + endif + enddo + + +!------------------------------------------------------------------------- +! Verification de la positivite des flux de masse +!------------------------------------------------------------------------- + +! do l=1,nlay + do ig=1,ngrid + if (fm(ig,l+1).lt.0.) then +! print*,'fm1<0',l+1,lmax(ig),fm(ig,l+1) + ncorecfm1=ncorecfm1+1 + fm(ig,l+1)=fm(ig,l) + detr(ig,l)=entr(ig,l) + endif + enddo +! enddo + + if (prt_level.ge.10) & + & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +!------------------------------------------------------------------------- +!Test sur fraca croissant +!------------------------------------------------------------------------- + if (iflag_thermals_optflux==0) then +! do l=1,nlay + do ig=1,ngrid + if (l.ge.lalim(ig).and.l.le.lmax(ig) & + & .and.(zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10) ) then +! zzz est le flux en l+1 a frac constant + zzz=fm(ig,l)*rhobarz(ig,l+1)*zw2(ig,l+1) & + & /(rhobarz(ig,l)*zw2(ig,l)) + if (fm(ig,l+1).gt.zzz) then + detr(ig,l)=detr(ig,l)+fm(ig,l+1)-zzz + fm(ig,l+1)=zzz + ncorecfm4=ncorecfm4+1 + endif + endif + enddo +! enddo + endif + + if (prt_level.ge.10) & + & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + + +!------------------------------------------------------------------------- +!test sur flux de masse croissant +!------------------------------------------------------------------------- + if (iflag_thermals_optflux==0) then +! do l=1,nlay + do ig=1,ngrid + if ((fm(ig,l+1).gt.fm(ig,l)).and.(l.gt.lalim(ig))) then + f_old=fm(ig,l+1) + fm(ig,l+1)=fm(ig,l) + detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1) + ncorecfm5=ncorecfm5+1 + endif + enddo +! enddo + endif + + if (prt_level.ge.10) & + & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +!fin 1.eq.0 +!------------------------------------------------------------------------- +!detr ne peut pas etre superieur a fm +!------------------------------------------------------------------------- + + if(1.eq.1) then + +! do l=1,nlay + + + + labort_physic=.false. + do ig=1,ngrid + if (entr(ig,l)<0.) then + labort_physic=.true. + igout=ig + lout=l + endif + enddo + + if (labort_physic) then + print*,'N1 ig,l,entr',igout,lout,entr(igout,lout) + abort_message = 'entr negatif' + CALL abort_physic (modname,abort_message,1) + endif + + do ig=1,ngrid + if (detr(ig,l).gt.fm(ig,l)) then + ncorecfm6=ncorecfm6+1 + detr(ig,l)=fm(ig,l) + entr(ig,l)=fm(ig,l+1) + +! Dans le cas ou on est au dessus de la couche d'alimentation et que le +! detrainement est plus fort que le flux de masse, on stope le thermique. +!test:on commente +! if (l.gt.lalim(ig)) then +! lmax(ig)=l +! fm(ig,l+1)=0. +! entr(ig,l)=0. +! else +! ncorecfm7=ncorecfm7+1 +! endif + endif + + if(l.gt.lmax(ig)) then + detr(ig,l)=0. + fm(ig,l+1)=0. + entr(ig,l)=0. + endif + enddo + + labort_physic=.false. + do ig=1,ngrid + if (entr(ig,l).lt.0.) then + labort_physic=.true. + igout=ig + endif + enddo + if (labort_physic) then + ig=igout + print*,'ig,l,lmax(ig)',ig,l,lmax(ig) + print*,'entr(ig,l)',entr(ig,l) + print*,'fm(ig,l)',fm(ig,l) + abort_message = 'probleme dans thermcell flux' + CALL abort_physic (modname,abort_message,1) + endif + + +! enddo + endif + + + if (prt_level.ge.10) & + & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +!------------------------------------------------------------------------- +!fm ne peut pas etre negatif +!------------------------------------------------------------------------- + +! do l=1,nlay + do ig=1,ngrid + if (fm(ig,l+1).lt.0.) then + detr(ig,l)=detr(ig,l)+fm(ig,l+1) + fm(ig,l+1)=0. + ncorecfm2=ncorecfm2+1 + endif + enddo + + labort_physic=.false. + do ig=1,ngrid + if (detr(ig,l).lt.0.) then + labort_physic=.true. + igout=ig + endif + enddo + if (labort_physic) then + ig=igout + print*,'cas 2 : ig,l,lmax(ig)',ig,l,lmax(ig) + print*,'detr(ig,l)',detr(ig,l) + print*,'fm(ig,l)',fm(ig,l) + abort_message = 'probleme dans thermcell flux' + CALL abort_physic (modname,abort_message,1) + endif +! enddo + + if (prt_level.ge.10) & + & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +!----------------------------------------------------------------------- +!la fraction couverte ne peut pas etre superieure a 1 +!----------------------------------------------------------------------- + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH Partie a revisiter. +! Il semble qu'etaient codees ici deux optiques dans le cas +! F/ (rho *w) > 1 +! soit limiter la hauteur du thermique en considerant que c'est +! la derniere chouche, soit limiter F a rho w. +! Dans le second cas, il faut en fait limiter a un peu moins +! que ca parce qu'on a des 1 / ( 1 -alpha) un peu plus loin +! dans thermcell_main et qu'il semble de toutes facons deraisonable +! d'avoir des fractions de 1.. +! Ci dessous, et dans l'etat actuel, le premier des deux if est +! sans doute inutile. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! do l=1,nlay + do ig=1,ngrid + if (zw2(ig,l+1).gt.1.e-10) then + zfm=rhobarz(ig,l+1)*zw2(ig,l+1)*alphamax + if ( fm(ig,l+1) .gt. zfm) then + f_old=fm(ig,l+1) + fm(ig,l+1)=zfm + detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1) +! lmax(ig)=l+1 +! zmax(ig)=zlev(ig,lmax(ig)) +! print*,'alpha>1',l+1,lmax(ig) + ncorecalpha=ncorecalpha+1 + endif + endif + enddo +! enddo +! + + + if (prt_level.ge.10) & + & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +! Fin de la grande boucle sur les niveaux verticaux + enddo + +! if (prt_level.ge.10) & +! & call printflux(ngrid,nlay,lunout1,igout,f,lmax,lalim, & +! & ptimestep,masse,entr,detr,fm,'8 ') + + +!----------------------------------------------------------------------- +! On fait en sorte que la quantite totale d'air entraine dans le +! panache ne soit pas trop grande comparee a la masse de la maille +!----------------------------------------------------------------------- + + if (1.eq.1) then + labort_physic=.false. + do l=1,nlay-1 + do ig=1,ngrid + eee0=entr(ig,l) + ddd0=detr(ig,l) + eee=entr(ig,l)-masse(ig,l)*fomass_max/ptimestep + ddd=detr(ig,l)-eee + if (eee.gt.0.) then + ncorecfm3=ncorecfm3+1 + entr(ig,l)=entr(ig,l)-eee + if ( ddd.gt.0.) then +! l'entrainement est trop fort mais l'exces peut etre compense par une +! diminution du detrainement) + detr(ig,l)=ddd + else +! l'entrainement est trop fort mais l'exces doit etre compense en partie +! par un entrainement plus fort dans la couche superieure + if(l.eq.lmax(ig)) then + detr(ig,l)=fm(ig,l)+entr(ig,l) + else + if(l.ge.lmax(ig).and.0.eq.1) then + igout=ig + lout=l + labort_physic=.true. + endif + entr(ig,l+1)=entr(ig,l+1)-ddd + detr(ig,l)=0. + fm(ig,l+1)=fm(ig,l)+entr(ig,l) + detr(ig,l)=0. + endif + endif + endif + enddo + enddo + if (labort_physic) then + ig=igout + l=lout + print*,'ig,l',ig,l + print*,'eee0',eee0 + print*,'ddd0',ddd0 + print*,'eee',eee + print*,'ddd',ddd + print*,'entr',entr(ig,l) + print*,'detr',detr(ig,l) + print*,'masse',masse(ig,l) + print*,'fomass_max',fomass_max + print*,'masse(ig,l)*fomass_max/ptimestep',masse(ig,l)*fomass_max/ptimestep + print*,'ptimestep',ptimestep + print*,'lmax(ig)',lmax(ig) + print*,'fm(ig,l+1)',fm(ig,l+1) + print*,'fm(ig,l)',fm(ig,l) + abort_message = 'probleme dans thermcell_flux' + CALL abort_physic (modname,abort_message,1) + endif + endif +! +! ddd=detr(ig)-entre +!on s assure que tout s annule bien en zmax + do ig=1,ngrid + fm(ig,lmax(ig)+1)=0. + entr(ig,lmax(ig))=0. + detr(ig,lmax(ig))=fm(ig,lmax(ig))+entr(ig,lmax(ig)) + enddo + +!----------------------------------------------------------------------- +! Impression du nombre de bidouilles qui ont ete necessaires +!----------------------------------------------------------------------- + +!IM 090508 beg +! if (ncorecfm1+ncorecfm2+ncorecfm3+ncorecfm4+ncorecfm5+ncorecalpha > 0 ) then +! +! print*,'PB thermcell : on a du coriger ',ncorecfm1,'x fm1',& +! & ncorecfm2,'x fm2',ncorecfm3,'x fm3 et', & +! & ncorecfm4,'x fm4',ncorecfm5,'x fm5 et', & +! & ncorecfm6,'x fm6', & +! & ncorecfm7,'x fm7', & +! & ncorecfm8,'x fm8', & +! & ncorecalpha,'x alpha' +! endif +!IM 090508 end + +! if (prt_level.ge.10) & +! & call printflux(ngrid,nlay,lunout1,igout,f,lmax,lalim, & +! & ptimestep,masse,entr,detr,fm,'fin') + + + RETURN + end +END MODULE lmdz_thermcell_flux2 Index: LMDZ6/trunk/libf/phylmd/lmdz_thermcell_height.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/lmdz_thermcell_height.F90 (revision 4590) +++ LMDZ6/trunk/libf/phylmd/lmdz_thermcell_height.F90 (revision 4590) @@ -0,0 +1,163 @@ +MODULE lmdz_thermcell_height +CONTAINS + + SUBROUTINE thermcell_height(ngrid,nlay,lalim,lmin,linter,lmix, & + & zw2,zlev,lmax,zmax,zmax0,zmix,wmax) + IMPLICIT NONE + +!----------------------------------------------------------------------------- +!thermcell_height: calcul des caracteristiques du thermique: zmax,wmax,zmix +!----------------------------------------------------------------------------- + +! arguments + +! Entree + integer, intent(in) :: ngrid,nlay + real, intent(in), dimension(ngrid) :: linter + real, intent(in), dimension(ngrid,nlay+1) :: zlev +! Sortie + real, intent(out), dimension(ngrid) :: wmax,zmax,zmax0,zmix + integer, intent(out), dimension(ngrid) :: lmax +! Les deux + integer, intent(inout), dimension(ngrid) :: lmix,lalim,lmin + real, intent(inout), dimension(ngrid,nlay+1) :: zw2 + +! local + real, dimension(ngrid) :: num,denom,zlevinter + integer ig,l + +!calcul de la hauteur max du thermique + do ig=1,ngrid + lmax(ig)=lalim(ig) + enddo + do ig=1,ngrid + do l=nlay,lalim(ig)+1,-1 + if (zw2(ig,l).le.1.e-10) then + lmax(ig)=l-1 + endif + enddo + enddo + +! On traite le cas particulier qu'il faudrait éviter ou le thermique +! atteind le haut du modele ... + do ig=1,ngrid + if ( zw2(ig,nlay) > 1.e-10 ) then + print*,'WARNING !!!!! W2 thermiques non nul derniere couche ' + lmax(ig)=nlay + endif + enddo + +! pas de thermique si couche 1 stable + do ig=1,ngrid + if (lmin(ig).gt.1) then + lmax(ig)=1 + lmin(ig)=1 + lalim(ig)=1 + endif + enddo +! +! Determination de zw2 max + do ig=1,ngrid + wmax(ig)=0. + enddo + + do l=1,nlay + do ig=1,ngrid + if (l.le.lmax(ig)) then + if (zw2(ig,l).lt.0.)then + print*,'pb2 zw2<0' + endif + zw2(ig,l)=sqrt(zw2(ig,l)) + wmax(ig)=max(wmax(ig),zw2(ig,l)) + else + zw2(ig,l)=0. + endif + enddo + enddo + +! Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=0. + zlevinter(ig)=zlev(ig,1) + enddo + +! if (iflag_thermals_ed.ge.1) then + if (1==0) then +!CR:date de quand le calcul du zmax continu etait buggue + num(:)=0. + denom(:)=0. + do ig=1,ngrid + do l=1,nlay + num(ig)=num(ig)+zw2(ig,l)*zlev(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + denom(ig)=denom(ig)+zw2(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + enddo + enddo + do ig=1,ngrid + if (denom(ig).gt.1.e-10) then + zmax(ig)=2.*num(ig)/denom(ig) + zmax0(ig)=zmax(ig) + endif + enddo + + else +!CR:Calcul de zmax continu via le linter + do ig=1,ngrid +! calcul de zlevinter + zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))* & + & linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1) & + & -zlev(ig,lmax(ig))) +!pour le cas ou on prend tjs lmin=1 +! zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1)) + zmax0(ig)=zmax(ig) + enddo + + + endif +!endif iflag_thermals_ed +! +! def de zmix continu (profil parabolique des vitesses) + do ig=1,ngrid + if (lmix(ig).gt.1) then +! test + if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) & + & *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) & + & -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) & + & *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10) & + & then +! + zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) & + & *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2) & + & -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) & + & *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2)) & + & /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) & + & *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) & + & -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) & + & *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) + else + zmix(ig)=zlev(ig,lmix(ig)) + print*,'pb zmix' + endif + else + zmix(ig)=0. + endif +!test + if ((zmax(ig)-zmix(ig)).le.0.) then + zmix(ig)=0.9*zmax(ig) +! print*,'pb zmix>zmax' + endif + enddo +! +! calcul du nouveau lmix correspondant + do ig=1,ngrid + do l=1,nlay + if (zmix(ig).ge.zlev(ig,l).and. & + & zmix(ig).lt.zlev(ig,l+1)) then + lmix(ig)=l + endif + enddo + enddo +! + RETURN + end +END MODULE lmdz_thermcell_height Index: LMDZ6/trunk/libf/phylmd/lmdz_thermcell_ini.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/lmdz_thermcell_ini.F90 (revision 4590) +++ LMDZ6/trunk/libf/phylmd/lmdz_thermcell_ini.F90 (revision 4590) @@ -0,0 +1,114 @@ +MODULE lmdz_thermcell_ini + +IMPLICIT NONE + +save + + integer :: dvdq=1,dqimpl=-1,prt_level=0,lunout + real RG,RD,RCPD,RKAPPA,RLVTT,RLvCp,RETV + real :: r_aspect_thermals,tau_thermals,fact_thermals_ed_dz + integer :: iflag_thermals_ed,iflag_thermals_optflux,iflag_thermals_closure + integer :: iflag_thermals_down + real :: fact_thermals_down + +!$OMP THREADPRIVATE(dvdq,dqimpl,prt_level,lunout) +!$OMP THREADPRIVATE(RG,RD,RCPD,RKAPPA,RLVTT,RLvCp) +!$OMP THREADPRIVATE(r_aspect_thermals,tau_thermals,fact_thermals_ed_dz) +!$OMP THREADPRIVATE(iflag_thermals_ed,iflag_thermals_optflux,iflag_thermals_closure) +!$OMP THREADPRIVATE(iflag_thermals_down) +!$OMP THREADPRIVATE(fact_thermals_down) + + + REAL, SAVE :: fact_epsilon=0.002 + REAL, SAVE :: betalpha=0.9 + REAL, SAVE :: afact=2./3. + REAL, SAVE :: fact_shell=1. + REAL,SAVE :: detr_min=1.e-5 + REAL,SAVE :: entr_min=1.e-5 + REAL,SAVE :: detr_q_coef=0.012 + REAL,SAVE :: detr_q_power=0.5 + REAL,SAVE :: mix0=0. + INTEGER,SAVE :: thermals_flag_alim=0 + +!$OMP THREADPRIVATE(fact_epsilon, betalpha, afact, fact_shell) +!$OMP THREADPRIVATE(detr_min, entr_min, detr_q_coef, detr_q_power) +!$OMP THREADPRIVATE( mix0, thermals_flag_alim) + + +CONTAINS + +SUBROUTINE thermcell_ini(iflag_thermals,prt_level_in,tau_thermals_in,lunout_in, & + & RG_in,RD_in,RCPD_in,RKAPPA_in,RLVTT_in,RETV_in) + + USE ioipsl_getin_p_mod, ONLY : getin_p + +integer, intent(in) :: iflag_thermals,prt_level_in,lunout_in +real, intent(in) :: RG_in,RD_in,RCPD_in,RKAPPA_in,RLVTT_in,RETV_in,tau_thermals_in + +print*,'thermcell_ini' + if (iflag_thermals==15.or.iflag_thermals==16) then + dvdq=0 + dqimpl=-1 + else + dvdq=1 + dqimpl=1 + endif + prt_level=prt_level_in + RG=RG_in + RD=RD_in + RCPD=RCPD_in + RKAPPA=RKAPPA_in + RLVTT=RLVTT_in + RLvCp = RLVTT/RCPD + RETV=RETV_in + tau_thermals=tau_thermals_in + lunout=lunout_in + + +!===================================================================== +! a la fois les vieilles param et thermcell_main : +!===================================================================== + + r_aspect_thermals=2. + CALL getin_p('r_aspect_thermals',r_aspect_thermals) + + tau_thermals = 0. + CALL getin_p('tau_thermals',tau_thermals) + + fact_thermals_ed_dz = 0.1 + CALL getin_p('fact_thermals_ed_dz',fact_thermals_ed_dz) + + fact_thermals_ed_dz = 0.1 + CALL getin_p('fact_thermals_ed_dz',fact_thermals_ed_dz) + + iflag_thermals_ed = 0 + CALL getin_p('iflag_thermals_ed',iflag_thermals_ed) + + iflag_thermals_optflux = 0 + CALL getin_p('iflag_thermals_optflux',iflag_thermals_optflux) + + iflag_thermals_closure = 1 + CALL getin_p('iflag_thermals_closure',iflag_thermals_closure) + + iflag_thermals_down = 0 + CALL getin_p('iflag_thermals_down',iflag_thermals_down) + + fact_thermals_down = 0.5 + CALL getin_p('fact_thermals_down',fact_thermals_down) + + CALL getin_p('thermals_fact_epsilon',fact_epsilon) + CALL getin_p('thermals_betalpha',betalpha) + CALL getin_p('thermals_afact',afact) + CALL getin_p('thermals_fact_shell',fact_shell) + CALL getin_p('thermals_detr_min',detr_min) + CALL getin_p('thermals_entr_min',entr_min) + CALL getin_p('thermals_detr_q_coef',detr_q_coef) + CALL getin_p('thermals_detr_q_power',detr_q_power) + CALL getin_p('thermals_mix0',mix0) + CALL getin_p('thermals_flag_alim',thermals_flag_alim) + + + RETURN + +END SUBROUTINE thermcell_ini +END MODULE lmdz_thermcell_ini Index: LMDZ6/trunk/libf/phylmd/lmdz_thermcell_main.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/lmdz_thermcell_main.F90 (revision 4590) +++ LMDZ6/trunk/libf/phylmd/lmdz_thermcell_main.F90 (revision 4590) @@ -0,0 +1,904 @@ +MODULE lmdz_thermcell_main +! $Id$ +! +CONTAINS + + subroutine thermcell_main(itap,ngrid,nlay,ptimestep & + & ,pplay,pplev,pphi,debut & + & ,pu,pv,pt,po & + & ,pduadj,pdvadj,pdtadj,pdoadj & + & ,fm0,entr0,detr0,zqta,zqla,lmax & + & ,ratqscth,ratqsdiff,zqsatth & + & ,zmax0, f0,zw2,fraca,ztv & + & ,zpspsk,ztla,zthl,ztva & + & ,pcon,rhobarz,wth3,wmax_sec,lalim,fm,alim_star,zmax & +#ifdef ISO + & ,xtpo,xtpdoadj & +#endif + & ) + + + USE lmdz_thermcell_ini, ONLY: thermcell_ini,dqimpl,dvdq,prt_level,lunout,prt_level + USE lmdz_thermcell_ini, ONLY: iflag_thermals_closure,iflag_thermals_ed,tau_thermals,r_aspect_thermals + USE lmdz_thermcell_ini, ONLY: iflag_thermals_down,fact_thermals_down + USE lmdz_thermcell_ini, ONLY: RD,RG + + USE lmdz_thermcell_down, ONLY: thermcell_updown_dq + USE lmdz_thermcell_closure, ONLY: thermcell_closure + USE lmdz_thermcell_dq, ONLY: thermcell_dq + USE lmdz_thermcell_dry, ONLY: thermcell_dry + USE lmdz_thermcell_dv2, ONLY: thermcell_dv2 + USE lmdz_thermcell_env, ONLY: thermcell_env + USE lmdz_thermcell_flux2, ONLY: thermcell_flux2 + USE lmdz_thermcell_height, ONLY: thermcell_height + USE lmdz_thermcell_plume, ONLY: thermcell_plume + USE lmdz_thermcell_plume_6A, ONLY: thermcell_plume_6A,thermcell_plume_5B + +#ifdef ISO + USE infotrac_phy, ONLY : ntiso +#ifdef ISOVERIF + USE isotopes_mod, ONLY : iso_eau,iso_HDO + USE isotopes_verif_mod, ONLY: iso_verif_egalite, & + iso_verif_aberrant_encadre +#endif +#endif + + + IMPLICIT NONE + +!======================================================================= +! Auteurs: Frederic Hourdin, Catherine Rio, Anne Mathieu +! Version du 09.02.07 +! Calcul du transport vertical dans la couche limite en presence +! de "thermiques" explicitement representes avec processus nuageux +! +! Reecriture a partir d'un listing papier a Habas, le 14/02/00 +! +! le thermique est suppose homogene et dissipe par melange avec +! son environnement. la longueur l_mix controle l'efficacite du +! melange +! +! Le calcul du transport des differentes especes se fait en prenant +! en compte: +! 1. un flux de masse montant +! 2. un flux de masse descendant +! 3. un entrainement +! 4. un detrainement +! +! Modif 2013/01/04 (FH hourdin@lmd.jussieu.fr) +! Introduction of an implicit computation of vertical advection in +! the environment of thermal plumes in thermcell_dq +! impl = 0 : explicit, 1 : implicit, -1 : old version +! controled by iflag_thermals = +! 15, 16 run with impl=-1 : numerical convergence with NPv3 +! 17, 18 run with impl=1 : more stable +! 15 and 17 correspond to the activation of the stratocumulus "bidouille" +! +! Using +! abort_physic +! iso_verif_aberrant_encadre +! iso_verif_egalite +! test_ltherm +! thermcell_closure +! thermcell_dq +! thermcell_dry +! thermcell_dv2 +! thermcell_env +! thermcell_flux2 +! thermcell_height +! thermcell_plume +! thermcell_plume_5B +! thermcell_plume_6A +! +!======================================================================= + + +!----------------------------------------------------------------------- +! declarations: +! ------------- + + +! arguments: +! ---------- + integer, intent(in) :: itap,ngrid,nlay + real, intent(in) :: ptimestep + real, intent(in), dimension(ngrid,nlay) :: pt,pu,pv,pplay,pphi +! ATTENTION : po et zpspsk sont inout et out mais c'est pas forcement pour de bonnes raisons (FH, 2023) + real, intent(inout), dimension(ngrid,nlay) :: po + real, intent(out), dimension(ngrid,nlay) :: zpspsk + real, intent(in), dimension(ngrid,nlay+1) :: pplev + integer, intent(out), dimension(ngrid) :: lmax + real, intent(out), dimension(ngrid,nlay) :: pdtadj,pduadj,pdvadj,pdoadj,entr0,detr0 + real, intent(out), dimension(ngrid,nlay) :: ztla,zqla,zqta,zqsatth,zthl + real, intent(out), dimension(ngrid,nlay+1) :: fm0,zw2,fraca + real, intent(inout), dimension(ngrid) :: zmax0,f0 + real, intent(out), dimension(ngrid,nlay) :: ztva,ztv + logical, intent(in) :: debut + real,intent(out), dimension(ngrid,nlay) :: ratqscth,ratqsdiff + + real, intent(out), dimension(ngrid) :: pcon + real, intent(out), dimension(ngrid,nlay) :: rhobarz,wth3 + real, intent(out), dimension(ngrid) :: wmax_sec + integer,intent(out), dimension(ngrid) :: lalim + real, intent(out), dimension(ngrid,nlay+1) :: fm + real, intent(out), dimension(ngrid,nlay) :: alim_star + real, intent(out), dimension(ngrid) :: zmax + +! local: +! ------ + + + integer,save :: igout=1 +!$OMP THREADPRIVATE(igout) + integer,save :: lunout1=6 +!$OMP THREADPRIVATE(lunout1) + integer,save :: lev_out=10 +!$OMP THREADPRIVATE(lev_out) + + real lambda, zf,zf2,var,vardiff,CHI + integer ig,k,l,ierr,ll + logical sorties + real, dimension(ngrid) :: linter,zmix, zmax_sec + integer,dimension(ngrid) :: lmin,lmix,lmix_bis,nivcon + real, dimension(ngrid,nlay) :: ztva_est + real, dimension(ngrid,nlay) :: deltaz,zlay,zh,zdthladj,zu,zv,zo,zl,zva,zua,zoa + real, dimension(ngrid,nlay) :: zta,zha,q2,wq,wthl,wthv,thetath2,wth2 + real, dimension(ngrid,nlay) :: rho,masse + real, dimension(ngrid,nlay+1) :: zw_est,zlev + real, dimension(ngrid) :: wmax,wmax_tmp + real, dimension(ngrid,nlay+1) :: f_star + real, dimension(ngrid,nlay) :: entr,detr,entr_star,detr_star,alim_star_clos + real, dimension(ngrid,nlay) :: zqsat,csc + real, dimension(ngrid) :: zcon,zcon2,alim_star_tot,f + real, dimension(ngrid,nlay) :: entrdn,detrdn + + character (len=20) :: modname='thermcell_main' + character (len=80) :: abort_message + + +#ifdef ISO + REAL xtpo(ntiso,ngrid,nlay),xtpdoadj(ntiso,ngrid,nlay) + REAL xtzo(ntiso,ngrid,nlay) + REAL xtpdoadj_tmp(ngrid,nlay) + REAL xtpo_tmp(ngrid,nlay) + REAL xtzo_tmp(ngrid,nlay) + integer ixt +#endif + +! + +!----------------------------------------------------------------------- +! initialisation: +! --------------- +! + fm=0. ; entr=0. ; detr=0. + + if (prt_level.ge.1) print*,'thermcell_main V4' + + sorties=.true. + IF(ngrid.NE.ngrid) THEN + PRINT* + PRINT*,'STOP dans convadj' + PRINT*,'ngrid =',ngrid + PRINT*,'ngrid =',ngrid + ENDIF +! +! write(lunout,*)'WARNING thermcell_main f0=max(f0,1.e-2)' + do ig=1,ngrid + f0(ig)=max(f0(ig),1.e-2) + zmax0(ig)=max(zmax0(ig),40.) +!IMmarche pas ?! if (f0(ig)<1.e-2) f0(ig)=1.e-2 + enddo + + if (prt_level.ge.20) then + do ig=1,ngrid + print*,'th_main ig f0',ig,f0(ig) + enddo + endif +!----------------------------------------------------------------------- +! Calcul de T,q,ql a partir de Tl et qT dans l environnement +! -------------------------------------------------------------------- +! + CALL thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay, & + & pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,zqsat,lev_out) + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_env' + +!------------------------------------------------------------------------ +! -------------------- +! +! +! + + + + + + + + + + + +! +! +! wa, fraca, wd, fracd -------------------- zlev(2), rhobarz +! wh,wt,wo ... +! +! + + + + + + + + + + + zh,zu,zv,zo,rho +! +! +! -------------------- zlev(1) +! \\\\\\\\\\\\\\\\\\\\ +! +! + +!----------------------------------------------------------------------- +! Calcul des altitudes des couches +!----------------------------------------------------------------------- + + do l=2,nlay + zlev(:,l)=0.5*(pphi(:,l)+pphi(:,l-1))/RG + enddo + zlev(:,1)=0. + zlev(:,nlay+1)=(2.*pphi(:,nlay)-pphi(:,nlay-1))/RG + do l=1,nlay + zlay(:,l)=pphi(:,l)/RG + enddo + do l=1,nlay + deltaz(:,l)=zlev(:,l+1)-zlev(:,l) + enddo + +!----------------------------------------------------------------------- +! Calcul des densites et masses +!----------------------------------------------------------------------- + + rho(:,:)=pplay(:,:)/(zpspsk(:,:)*RD*ztv(:,:)) + if (prt_level.ge.10) write(lunout,*) 'WARNING thermcell_main rhobarz(:,1)=rho(:,1)' + rhobarz(:,1)=rho(:,1) + do l=2,nlay + rhobarz(:,l)=0.5*(rho(:,l)+rho(:,l-1)) + enddo + do l=1,nlay + masse(:,l)=(pplev(:,l)-pplev(:,l+1))/RG + enddo + if (prt_level.ge.1) print*,'thermcell_main apres initialisation' + +!------------------------------------------------------------------ +! +! /|\ +! -------- | F_k+1 ------- +! ----> D_k +! /|\ <---- E_k , A_k +! -------- | F_k --------- +! ----> D_k-1 +! <---- E_k-1 , A_k-1 +! +! +! +! +! +! --------------------------- +! +! ----- F_lmax+1=0 ---------- \ +! lmax (zmax) | +! --------------------------- | +! | +! --------------------------- | +! | +! --------------------------- | +! | +! --------------------------- | +! | +! --------------------------- | +! | E +! --------------------------- | D +! | +! --------------------------- | +! | +! --------------------------- \ | +! lalim | | +! --------------------------- | | +! | | +! --------------------------- | | +! | A | +! --------------------------- | | +! | | +! --------------------------- | | +! lmin (=1 pour le moment) | | +! ----- F_lmin=0 ------------ / / +! +! --------------------------- +! ////////////////////////// +! +! +!============================================================================= +! Calculs initiaux ne faisant pas intervenir les changements de phase +!============================================================================= + +!------------------------------------------------------------------ +! 1. alim_star est le profil vertical de l'alimentation a la base du +! panache thermique, calcule a partir de la flotabilite de l'air sec +! 2. lmin et lalim sont les indices inferieurs et superieurs de alim_star +!------------------------------------------------------------------ +! + entr_star=0. ; detr_star=0. ; alim_star=0. ; alim_star_tot=0. + lmin=1 + +!----------------------------------------------------------------------------- +! 3. wmax_sec et zmax_sec sont les vitesses et altitudes maximum d'un +! panache sec conservatif (e=d=0) alimente selon alim_star +! Il s'agit d'un calcul de type CAPE +! zmax_sec est utilise pour determiner la geometrie du thermique. +!------------------------------------------------------------------------------ +!--------------------------------------------------------------------------------- +!calcul du melange et des variables dans le thermique +!-------------------------------------------------------------------------------- +! + if (prt_level.ge.1) print*,'avant thermcell_plume ',lev_out + +!===================================================================== +! Old version of thermcell_plume in thermcell_plume_6A.F90 +! It includes both thermcell_plume_6A and thermcell_plume_5B corresponding +! to the 5B and 6A versions used for CMIP5 and CMIP6. +! The latest was previously named thermcellV1_plume. +! The new thermcell_plume is a clean version (removing obsolete +! options) of thermcell_plume_6A. +! The 3 versions are controled by +! flag_thermals_ed <= 9 thermcell_plume_6A +! <= 19 thermcell_plume_5B +! else thermcell_plume (default 20 for convergence with 6A) +! Fredho +!===================================================================== + + if (iflag_thermals_ed<=9) then +! print*,'THERM NOUVELLE/NOUVELLE Arnaud' + CALL thermcell_plume_6A(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,& + & zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, & + & lalim,f0,detr_star,entr_star,f_star,csc,ztva, & + & ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter & + & ,lev_out,lunout1,igout) + + elseif (iflag_thermals_ed<=19) then +! print*,'THERM RIO et al 2010, version d Arnaud' + CALL thermcell_plume_5B(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,& + & zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, & + & lalim,f0,detr_star,entr_star,f_star,csc,ztva, & + & ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter & + & ,lev_out,lunout1,igout) + else + CALL thermcell_plume(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,& + & zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, & + & lalim,f0,detr_star,entr_star,f_star,csc,ztva, & + & ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter & + & ,lev_out,lunout1,igout) + endif + + if (prt_level.ge.1) print*,'apres thermcell_plume ',lev_out + + call test_ltherm(ngrid,nlay,pplay,lalim,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lalim ') + call test_ltherm(ngrid,nlay,pplay,lmix ,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lmix ') + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_plume' + if (prt_level.ge.10) then + write(lunout1,*) 'Dans thermcell_main 2' + write(lunout1,*) 'lmin ',lmin(igout) + write(lunout1,*) 'lalim ',lalim(igout) + write(lunout1,*) ' ig l alim_star entr_star detr_star f_star ' + write(lunout1,'(i6,i4,4e15.5)') (igout,l,alim_star(igout,l),entr_star(igout,l),detr_star(igout,l) & + & ,f_star(igout,l+1),l=1,nint(linter(igout))+5) + endif + +!------------------------------------------------------------------------------- +! Calcul des caracteristiques du thermique:zmax,zmix,wmax +!------------------------------------------------------------------------------- +! + CALL thermcell_height(ngrid,nlay,lalim,lmin,linter,lmix,zw2, & + & zlev,lmax,zmax,zmax0,zmix,wmax) +! Attention, w2 est transforme en sa racine carree dans cette routine +! Le probleme vient du fait que linter et lmix sont souvent egaux a 1. + wmax_tmp=0. + do l=1,nlay + wmax_tmp(:)=max(wmax_tmp(:),zw2(:,l)) + enddo +! print*,"ZMAX ",lalim,lmin,linter,lmix,lmax,zmax,zmax0,zmix,wmax + + + + call test_ltherm(ngrid,nlay,pplay,lalim,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lalim ') + call test_ltherm(ngrid,nlay,pplay,lmin ,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmin ') + call test_ltherm(ngrid,nlay,pplay,lmix ,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmix ') + call test_ltherm(ngrid,nlay,pplay,lmax ,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmax ') + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_height' + +!------------------------------------------------------------------------------- +! Fermeture,determination de f +!------------------------------------------------------------------------------- +! +! + CALL thermcell_dry(ngrid,nlay,zlev,pphi,ztv,alim_star, & + & lalim,lmin,zmax_sec,wmax_sec) + + +call test_ltherm(ngrid,nlay,pplay,lmin,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry lmin ') +call test_ltherm(ngrid,nlay,pplay,lalim,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry lalim ') + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_dry' + if (prt_level.ge.10) then + write(lunout1,*) 'Dans thermcell_main 1b' + write(lunout1,*) 'lmin ',lmin(igout) + write(lunout1,*) 'lalim ',lalim(igout) + write(lunout1,*) ' ig l alim_star entr_star detr_star f_star ' + write(lunout1,'(i6,i4,e15.5)') (igout,l,alim_star(igout,l) & + & ,l=1,lalim(igout)+4) + endif + + + + +! Choix de la fonction d'alimentation utilisee pour la fermeture. +! Apparemment sans importance + alim_star_clos(:,:)=alim_star(:,:) + alim_star_clos(:,:)=entr_star(:,:)+alim_star(:,:) +! +!CR Appel de la fermeture seche + if (iflag_thermals_closure.eq.1) then + + CALL thermcell_closure(ngrid,nlay,r_aspect_thermals,ptimestep,rho, & + & zlev,lalim,alim_star_clos,zmax_sec,wmax_sec,f) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Appel avec les zmax et wmax tenant compte de la condensation +! Semble moins bien marcher + else if (iflag_thermals_closure.eq.2) then + + CALL thermcell_closure(ngrid,nlay,r_aspect_thermals,ptimestep,rho, & + & zlev,lalim,alim_star,zmax,wmax,f) + + + endif + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if(prt_level.ge.1)print*,'thermcell_closure apres thermcell_closure' + + if (tau_thermals>1.) then + lambda=exp(-ptimestep/tau_thermals) + f0=(1.-lambda)*f+lambda*f0 + else + f0=f + endif + +! Test valable seulement en 1D mais pas genant + if (.not. (f0(1).ge.0.) ) then + abort_message = '.not. (f0(1).ge.0.)' + CALL abort_physic (modname,abort_message,1) + endif + +!------------------------------------------------------------------------------- +!deduction des flux + + CALL thermcell_flux2(ngrid,nlay,ptimestep,masse, & + & lalim,lmax,alim_star, & + & entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr, & + & detr,zqla,lev_out,lunout1,igout) + +!IM 060508 & detr,zqla,zmax,lev_out,lunout,igout) + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_flux' + call test_ltherm(ngrid,nlay,pplay,lalim,ztv,po,ztva,zqla,f_star,zw2,'thermcell_flux lalim ') + call test_ltherm(ngrid,nlay,pplay,lmax ,ztv,po,ztva,zqla,f_star,zw2,'thermcell_flux lmax ') + +!------------------------------------------------------------------ +! On ne prend pas directement les profils issus des calculs precedents +! mais on s'autorise genereusement une relaxation vers ceci avec +! une constante de temps tau_thermals (typiquement 1800s). +!------------------------------------------------------------------ + + if (tau_thermals>1.) then + lambda=exp(-ptimestep/tau_thermals) + fm0=(1.-lambda)*fm+lambda*fm0 + entr0=(1.-lambda)*entr+lambda*entr0 + detr0=(1.-lambda)*detr+lambda*detr0 + else + fm0=fm + entr0=entr + detr0=detr + endif + +!------------------------------------------------------------------ +! Calcul de la fraction de l'ascendance +!------------------------------------------------------------------ + do ig=1,ngrid + fraca(ig,1)=0. + fraca(ig,nlay+1)=0. + enddo + do l=2,nlay + do ig=1,ngrid + if (zw2(ig,l).gt.1.e-10) then + fraca(ig,l)=fm(ig,l)/(rhobarz(ig,l)*zw2(ig,l)) + else + fraca(ig,l)=0. + endif + enddo + enddo + +!c------------------------------------------------------------------ +! calcul du transport vertical +!------------------------------------------------------------------ + IF (iflag_thermals_down .GT. 0) THEN + if (debut) print*,'WARNING !!! routine thermcell_down en cours de developpement' + entrdn=fact_thermals_down*detr0 + detrdn=fact_thermals_down*entr0 + ! we want to transport potential temperature, total water and momentum + CALL thermcell_updown_dq(ngrid,nlay,ptimestep,lmax,entr0,detr0,entrdn,detrdn,masse,zthl,zdthladj) + CALL thermcell_updown_dq(ngrid,nlay,ptimestep,lmax,entr0,detr0,entrdn,detrdn,masse,po,pdoadj) + CALL thermcell_updown_dq(ngrid,nlay,ptimestep,lmax,entr0,detr0,entrdn,detrdn,masse,zu,pduadj) + CALL thermcell_updown_dq(ngrid,nlay,ptimestep,lmax,entr0,detr0,entrdn,detrdn,masse,zv,pdvadj) + ELSE + !-------------------------------------------------------------- + + call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse, & + & zthl,zdthladj,zta,lev_out) + call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse, & + & po,pdoadj,zoa,lev_out) + +#ifdef ISO + ! C Risi: on utilise directement la meme routine + do ixt=1,ntiso + do ll=1,nlay + DO ig=1,ngrid + xtpo_tmp(ig,ll)=xtpo(ixt,ig,ll) + xtzo_tmp(ig,ll)=xtzo(ixt,ig,ll) + enddo + enddo + call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse, & + & xtpo_tmp,xtpdoadj_tmp,xtzo_tmp,lev_out) + do ll=1,nlay + DO ig=1,ngrid + xtpdoadj(ixt,ig,ll)=xtpdoadj_tmp(ig,ll) + enddo + enddo + enddo +#endif + +#ifdef ISO +#ifdef ISOVERIF + DO ll=1,nlay + DO ig=1,ngrid + if (iso_eau.gt.0) then + call iso_verif_egalite(xtpo(iso_eau,ig,ll), & + & po(ig,ll),'thermcell_main 594') + call iso_verif_egalite(xtpdoadj(iso_eau,ig,ll), & + & pdoadj(ig,ll),'thermcell_main 596') + endif + if (iso_HDO.gt.0) then + call iso_verif_aberrant_encadre(xtpo(iso_hdo,ig,ll) & + & /po(ig,ll),'thermcell_main 610') + endif + enddo + enddo !DO ll=1,nlay + write(*,*) 'thermcell_main 600 tmp: apres thermcell_dq' +#endif +#endif + + +!------------------------------------------------------------------ +! calcul du transport vertical du moment horizontal +!------------------------------------------------------------------ + +!IM 090508 + if (dvdq == 0 ) then + +! Calcul du transport de V tenant compte d'echange par gradient +! de pression horizontal avec l'environnement + + call thermcell_dv2(ngrid,nlay,ptimestep,fm0,entr0,masse & +! & ,fraca*dvdq,zmax & + & ,fraca,zmax & + & ,zu,zv,pduadj,pdvadj,zua,zva,lev_out) + + else + +! calcul purement conservatif pour le transport de V + call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse & + & ,zu,pduadj,zua,lev_out) + call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse & + & ,zv,pdvadj,zva,lev_out) + + endif + ENDIF + +! print*,'13 OK convect8' + do l=1,nlay + do ig=1,ngrid + pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l) + enddo + enddo + + if (prt_level.ge.1) print*,'14 OK convect8' +!------------------------------------------------------------------ +! Calculs de diagnostiques pour les sorties +!------------------------------------------------------------------ +!calcul de fraca pour les sorties + + if (sorties) then + if (prt_level.ge.1) print*,'14a OK convect8' +! calcul du niveau de condensation +! initialisation + do ig=1,ngrid + nivcon(ig)=0 + zcon(ig)=0. + enddo +!nouveau calcul + do ig=1,ngrid + CHI=zh(ig,1)/(1669.0-122.0*zo(ig,1)/zqsat(ig,1)-zh(ig,1)) + pcon(ig)=pplay(ig,1)*(zo(ig,1)/zqsat(ig,1))**CHI + enddo +!IM do k=1,nlay + do k=1,nlay-1 + do ig=1,ngrid + if ((pcon(ig).le.pplay(ig,k)) & + & .and.(pcon(ig).gt.pplay(ig,k+1))) then + zcon2(ig)=zlay(ig,k)-(pcon(ig)-pplay(ig,k))/(RG*rho(ig,k))/100. + endif + enddo + enddo +!IM + ierr=0 + do ig=1,ngrid + if (pcon(ig).le.pplay(ig,nlay)) then + zcon2(ig)=zlay(ig,nlay)-(pcon(ig)-pplay(ig,nlay))/(RG*rho(ig,nlay))/100. + ierr=1 + endif + enddo + if (ierr==1) then + abort_message = 'thermcellV0_main: les thermiques vont trop haut ' + CALL abort_physic (modname,abort_message,1) + endif + + if (prt_level.ge.1) print*,'14b OK convect8' + do k=nlay,1,-1 + do ig=1,ngrid + if (zqla(ig,k).gt.1e-10) then + nivcon(ig)=k + zcon(ig)=zlev(ig,k) + endif + enddo + enddo + if (prt_level.ge.1) print*,'14c OK convect8' +!calcul des moments +!initialisation + do l=1,nlay + do ig=1,ngrid + q2(ig,l)=0. + wth2(ig,l)=0. + wth3(ig,l)=0. + ratqscth(ig,l)=0. + ratqsdiff(ig,l)=0. + enddo + enddo + if (prt_level.ge.1) print*,'14d OK convect8' + if (prt_level.ge.10)write(lunout,*) & + & 'WARNING thermcell_main wth2=0. si zw2 > 1.e-10' + do l=1,nlay + do ig=1,ngrid + zf=fraca(ig,l) + zf2=zf/(1.-zf) +! + thetath2(ig,l)=zf2*(ztla(ig,l)-zthl(ig,l))**2 + if(zw2(ig,l).gt.1.e-10) then + wth2(ig,l)=zf2*(zw2(ig,l))**2 + else + wth2(ig,l)=0. + endif + wth3(ig,l)=zf2*(1-2.*fraca(ig,l))/(1-fraca(ig,l)) & + & *zw2(ig,l)*zw2(ig,l)*zw2(ig,l) + q2(ig,l)=zf2*(zqta(ig,l)*1000.-po(ig,l)*1000.)**2 +!test: on calcul q2/po=ratqsc + ratqscth(ig,l)=sqrt(max(q2(ig,l),1.e-6)/(po(ig,l)*1000.)) + enddo + enddo +!calcul des flux: q, thetal et thetav + do l=1,nlay + do ig=1,ngrid + wq(ig,l)=fraca(ig,l)*zw2(ig,l)*(zqta(ig,l)*1000.-po(ig,l)*1000.) + wthl(ig,l)=fraca(ig,l)*zw2(ig,l)*(ztla(ig,l)-zthl(ig,l)) + wthv(ig,l)=fraca(ig,l)*zw2(ig,l)*(ztva(ig,l)-ztv(ig,l)) + enddo + enddo + +!calcul du ratqscdiff + if (prt_level.ge.1) print*,'14e OK convect8' + var=0. + vardiff=0. + ratqsdiff(:,:)=0. + + do l=1,nlay + do ig=1,ngrid + if (l<=lalim(ig)) then + var=var+alim_star(ig,l)*zqta(ig,l)*1000. + endif + enddo + enddo + + if (prt_level.ge.1) print*,'14f OK convect8' + + do l=1,nlay + do ig=1,ngrid + if (l<=lalim(ig)) then + zf=fraca(ig,l) + zf2=zf/(1.-zf) + vardiff=vardiff+alim_star(ig,l)*(zqta(ig,l)*1000.-var)**2 + endif + enddo + enddo + + if (prt_level.ge.1) print*,'14g OK convect8' + do l=1,nlay + do ig=1,ngrid + ratqsdiff(ig,l)=sqrt(vardiff)/(po(ig,l)*1000.) + enddo + enddo + endif + + if (prt_level.ge.1) print*,'thermcell_main FIN OK' + + RETURN + end subroutine thermcell_main + +!============================================================================= +!///////////////////////////////////////////////////////////////////////////// +!============================================================================= + subroutine test_ltherm(ngrid,nlay,pplay,long,ztv,po,ztva, & ! in + & zqla,f_star,zw2,comment) ! in +!============================================================================= + USE lmdz_thermcell_ini, ONLY: prt_level + IMPLICIT NONE + + integer i, k, ngrid,nlay + real, intent(in), dimension(ngrid,nlay) :: pplay,ztv,po,ztva,zqla + real, intent(in), dimension(ngrid,nlay) :: f_star,zw2 + integer, intent(in), dimension(ngrid) :: long + real seuil + character*21 comment + + seuil=0.25 + + if (prt_level.ge.1) THEN + print*,'WARNING !!! TEST ',comment + endif + return + +! test sur la hauteur des thermiques ... + do i=1,ngrid +!IMtemp if (pplay(i,long(i)).lt.seuil*pplev(i,1)) then + if (prt_level.ge.10) then + print*,'WARNING ',comment,' au point ',i,' K= ',long(i) + print*,' K P(MB) THV(K) Qenv(g/kg)THVA QLA(g/kg) F* W2' + do k=1,nlay + write(6,'(i3,7f10.3)') k,pplay(i,k),ztv(i,k),1000*po(i,k),ztva(i,k),1000*zqla(i,k),f_star(i,k),zw2(i,k) + enddo + endif + enddo + + + return + end + +! nrlmd le 10/04/2012 Transport de la TKE par le thermique moyen pour la fermeture en ALP +! On transporte pbl_tke pour donner therm_tke +! Copie conforme de la subroutine DTKE dans physiq.F ecrite par Frederic Hourdin + +!======================================================================= +!/////////////////////////////////////////////////////////////////////// +!======================================================================= + + subroutine thermcell_tke_transport( & + & ngrid,nlay,ptimestep,fm0,entr0,rg,pplev, & ! in + & therm_tke_max) ! out + USE lmdz_thermcell_ini, ONLY: prt_level + implicit none + +!======================================================================= +! +! Calcul du transport verticale dans la couche limite en presence +! de "thermiques" explicitement representes +! calcul du dq/dt une fois qu'on connait les ascendances +! +!======================================================================= + + integer ngrid,nlay + + real, intent(in) :: ptimestep + real, intent(in), dimension(ngrid,nlay+1) :: fm0,pplev + real, intent(in), dimension(ngrid,nlay) :: entr0 + real, intent(in) :: rg + real, intent(out), dimension(ngrid,nlay) :: therm_tke_max + + real detr0(ngrid,nlay) + real masse0(ngrid,nlay) + real masse(ngrid,nlay),fm(ngrid,nlay+1) + real entr(ngrid,nlay) + real q(ngrid,nlay) + integer lev_out ! niveau pour les print + + real qa(ngrid,nlay),detr(ngrid,nlay),wqd(ngrid,nlay+1) + integer ig,k + + + lev_out=0 + + + if (prt_level.ge.1) print*,'Q2 THERMCEL_DQ 0' + +! calcul du detrainement + do k=1,nlay + detr0(:,k)=fm0(:,k)-fm0(:,k+1)+entr0(:,k) + masse0(:,k)=(pplev(:,k)-pplev(:,k+1))/RG + enddo + + +! Decalage vertical des entrainements et detrainements. + masse(:,1)=0.5*masse0(:,1) + entr(:,1)=0.5*entr0(:,1) + detr(:,1)=0.5*detr0(:,1) + fm(:,1)=0. + do k=1,nlay-1 + masse(:,k+1)=0.5*(masse0(:,k)+masse0(:,k+1)) + entr(:,k+1)=0.5*(entr0(:,k)+entr0(:,k+1)) + detr(:,k+1)=0.5*(detr0(:,k)+detr0(:,k+1)) + fm(:,k+1)=fm(:,k)+entr(:,k)-detr(:,k) + enddo + fm(:,nlay+1)=0. + + + q(:,:)=therm_tke_max(:,:) +!!! nrlmd le 16/09/2010 + do ig=1,ngrid + qa(ig,1)=q(ig,1) + enddo +!!! + + if (1==1) then + do k=2,nlay + do ig=1,ngrid + if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt. & + & 1.e-5*masse(ig,k)) then + qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k)) & + & /(fm(ig,k+1)+detr(ig,k)) + else + qa(ig,k)=q(ig,k) + endif + if (qa(ig,k).lt.0.) then +! print*,'qa<0!!!' + endif + if (q(ig,k).lt.0.) then +! print*,'q<0!!!' + endif + enddo + enddo + +! Calcul du flux subsident + + do k=2,nlay + do ig=1,ngrid + wqd(ig,k)=fm(ig,k)*q(ig,k) + if (wqd(ig,k).lt.0.) then +! print*,'wqd<0!!!' + endif + enddo + enddo + do ig=1,ngrid + wqd(ig,1)=0. + wqd(ig,nlay+1)=0. + enddo + +! Calcul des tendances + do k=1,nlay + do ig=1,ngrid + q(ig,k)=q(ig,k)+(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k) & + & -wqd(ig,k)+wqd(ig,k+1)) & + & *ptimestep/masse(ig,k) + enddo + enddo + + endif + + therm_tke_max(:,:)=q(:,:) + + return +!!! fin nrlmd le 10/04/2012 + end + +END MODULE lmdz_thermcell_main Index: LMDZ6/trunk/libf/phylmd/lmdz_thermcell_old.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/lmdz_thermcell_old.F90 (revision 4590) +++ LMDZ6/trunk/libf/phylmd/lmdz_thermcell_old.F90 (revision 4590) @@ -0,0 +1,6513 @@ +MODULE lmdz_thermcell_old +CONTAINS + +SUBROUTINE thermcell_2002(ngrid, nlay, ptimestep, iflag_thermals, pplay, & + pplev, pphi, pu, pv, pt, po, pduadj, pdvadj, pdtadj, pdoadj, fm0, entr0, & + fraca, wa_moy, r_aspect, l_mix, w2di, tho) + + USE dimphy + USE write_field_phy + USE lmdz_thermcell_dv2, ONLY : thermcell_dv2 + USE lmdz_thermcell_dq, ONLY : thermcell_dq + IMPLICIT NONE + + ! ======================================================================= + + ! Calcul du transport verticale dans la couche limite en presence + ! de "thermiques" explicitement representes + + ! Réécriture à partir d'un listing papier à Habas, le 14/02/00 + + ! le thermique est supposé homogène et dissipé par mélange avec + ! son environnement. la longueur l_mix contrôle l'efficacité du + ! mélange + + ! Le calcul du transport des différentes espèces se fait en prenant + ! en compte: + ! 1. un flux de masse montant + ! 2. un flux de masse descendant + ! 3. un entrainement + ! 4. un detrainement + + ! ======================================================================= + + ! ----------------------------------------------------------------------- + ! declarations: + ! ------------- + + include "YOMCST.h" + + ! arguments: + ! ---------- + + INTEGER ngrid, nlay, w2di, iflag_thermals + REAL tho + REAL ptimestep, l_mix, r_aspect + REAL pt(ngrid, nlay), pdtadj(ngrid, nlay) + REAL pu(ngrid, nlay), pduadj(ngrid, nlay) + REAL pv(ngrid, nlay), pdvadj(ngrid, nlay) + REAL po(ngrid, nlay), pdoadj(ngrid, nlay) + REAL pplay(ngrid, nlay), pplev(ngrid, nlay+1) + REAL pphi(ngrid, nlay) + REAL fraca(ngrid, nlay+1), zw2(ngrid, nlay+1) + + INTEGER, SAVE :: idetr = 3, lev_out = 1 + !$OMP THREADPRIVATE(idetr,lev_out) + + ! local: + ! ------ + + INTEGER, SAVE :: dvdq = 0, flagdq = 0, dqimpl = 1 + LOGICAL, SAVE :: debut = .TRUE. + !$OMP THREADPRIVATE(dvdq,flagdq,debut,dqimpl) + + INTEGER ig, k, l, lmax(klon, klev+1), lmaxa(klon), lmix(klon) + REAL zmax(klon), zw, zz, ztva(klon, klev), zzz + + REAL zlev(klon, klev+1), zlay(klon, klev) + REAL zh(klon, klev), zdhadj(klon, klev) + REAL ztv(klon, klev) + REAL zu(klon, klev), zv(klon, klev), zo(klon, klev) + REAL wh(klon, klev+1) + REAL wu(klon, klev+1), wv(klon, klev+1), wo(klon, klev+1) + REAL zla(klon, klev+1) + REAL zwa(klon, klev+1) + REAL zld(klon, klev+1) + REAL zwd(klon, klev+1) + REAL zsortie(klon, klev) + REAL zva(klon, klev) + REAL zua(klon, klev) + REAL zoa(klon, klev) + + REAL zha(klon, klev) + REAL wa_moy(klon, klev+1) + REAL fracc(klon, klev+1) + REAL zf, zf2 + REAL thetath2(klon, klev), wth2(klon, klev) + ! common/comtherm/thetath2,wth2 + + REAL count_time + + LOGICAL sorties + REAL rho(klon, klev), rhobarz(klon, klev+1), masse(klon, klev) + REAL zpspsk(klon, klev) + + REAL wmax(klon, klev), wmaxa(klon) + + REAL wa(klon, klev, klev+1) + REAL wd(klon, klev+1) + REAL larg_part(klon, klev, klev+1) + REAL fracd(klon, klev+1) + REAL xxx(klon, klev+1) + REAL larg_cons(klon, klev+1) + REAL larg_detr(klon, klev+1) + REAL fm0(klon, klev+1), entr0(klon, klev), detr(klon, klev) + REAL pu_therm(klon, klev), pv_therm(klon, klev) + REAL fm(klon, klev+1), entr(klon, klev) + REAL fmc(klon, klev+1) + + CHARACTER (LEN=2) :: str2 + CHARACTER (LEN=10) :: str10 + + CHARACTER (LEN=20) :: modname = 'thermcell2002' + CHARACTER (LEN=80) :: abort_message + + LOGICAL vtest(klon), down + + EXTERNAL scopy + + INTEGER ncorrec, ll + SAVE ncorrec + DATA ncorrec/0/ + !$OMP THREADPRIVATE(ncorrec) + + + ! ----------------------------------------------------------------------- + ! initialisation: + ! --------------- + + sorties = .TRUE. + IF (ngrid/=klon) THEN + PRINT * + PRINT *, 'STOP dans convadj' + PRINT *, 'ngrid =', ngrid + PRINT *, 'klon =', klon + END IF + + ! ----------------------------------------------------------------------- + ! incrementation eventuelle de tendances precedentes: + ! --------------------------------------------------- + + ! print*,'0 OK convect8' + + DO l = 1, nlay + DO ig = 1, ngrid + zpspsk(ig, l) = (pplay(ig,l)/pplev(ig,1))**rkappa + zh(ig, l) = pt(ig, l)/zpspsk(ig, l) + zu(ig, l) = pu(ig, l) + zv(ig, l) = pv(ig, l) + zo(ig, l) = po(ig, l) + ztv(ig, l) = zh(ig, l)*(1.+0.61*zo(ig,l)) + END DO + END DO + + ! print*,'1 OK convect8' + ! -------------------- + + + ! + + + + + + + + + + + + + + ! wa, fraca, wd, fracd -------------------- zlev(2), rhobarz + ! wh,wt,wo ... + + ! + + + + + + + + + + + zh,zu,zv,zo,rho + + + ! -------------------- zlev(1) + ! \\\\\\\\\\\\\\\\\\\\ + + + + ! ----------------------------------------------------------------------- + ! Calcul des altitudes des couches + ! ----------------------------------------------------------------------- + + IF (debut) THEN + flagdq = (iflag_thermals-1000)/100 + dvdq = (iflag_thermals-(1000+flagdq*100))/10 + IF (flagdq==2) dqimpl = -1 + IF (flagdq==3) dqimpl = 1 + debut = .FALSE. + END IF + PRINT *, 'TH flag th ', iflag_thermals, flagdq, dvdq, dqimpl + + DO l = 2, nlay + DO ig = 1, ngrid + zlev(ig, l) = 0.5*(pphi(ig,l)+pphi(ig,l-1))/rg + END DO + END DO + DO ig = 1, ngrid + zlev(ig, 1) = 0. + zlev(ig, nlay+1) = (2.*pphi(ig,klev)-pphi(ig,klev-1))/rg + END DO + DO l = 1, nlay + DO ig = 1, ngrid + zlay(ig, l) = pphi(ig, l)/rg + END DO + END DO + + ! print*,'2 OK convect8' + ! ----------------------------------------------------------------------- + ! Calcul des densites + ! ----------------------------------------------------------------------- + + DO l = 1, nlay + DO ig = 1, ngrid + rho(ig, l) = pplay(ig, l)/(zpspsk(ig,l)*rd*zh(ig,l)) + END DO + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + rhobarz(ig, l) = 0.5*(rho(ig,l)+rho(ig,l-1)) + END DO + END DO + + DO k = 1, nlay + DO l = 1, nlay + 1 + DO ig = 1, ngrid + wa(ig, k, l) = 0. + END DO + END DO + END DO + + ! print*,'3 OK convect8' + ! ------------------------------------------------------------------ + ! Calcul de w2, quarre de w a partir de la cape + ! a partir de w2, on calcule wa, vitesse de l'ascendance + + ! ATTENTION: Dans cette version, pour cause d'economie de memoire, + ! w2 est stoke dans wa + + ! ATTENTION: dans convect8, on n'utilise le calcule des wa + ! independants par couches que pour calculer l'entrainement + ! a la base et la hauteur max de l'ascendance. + + ! Indicages: + ! l'ascendance provenant du niveau k traverse l'interface l avec + ! une vitesse wa(k,l). + + ! -------------------- + + ! + + + + + + + + + + + + ! wa(k,l) ---- -------------------- l + ! /\ + ! /||\ + + + + + + + + + + + ! || + ! || -------------------- + ! || + ! || + + + + + + + + + + + ! || + ! || -------------------- + ! ||__ + ! |___ + + + + + + + + + + k + + ! -------------------- + + + + ! ------------------------------------------------------------------ + + + DO k = 1, nlay - 1 + DO ig = 1, ngrid + wa(ig, k, k) = 0. + wa(ig, k, k+1) = 2.*rg*(ztv(ig,k)-ztv(ig,k+1))/ztv(ig, k+1)* & + (zlev(ig,k+1)-zlev(ig,k)) + END DO + DO l = k + 1, nlay - 1 + DO ig = 1, ngrid + wa(ig, k, l+1) = wa(ig, k, l) + 2.*rg*(ztv(ig,k)-ztv(ig,l))/ztv(ig, l & + )*(zlev(ig,l+1)-zlev(ig,l)) + END DO + END DO + DO ig = 1, ngrid + wa(ig, k, nlay+1) = 0. + END DO + END DO + + ! print*,'4 OK convect8' + ! Calcul de la couche correspondant a la hauteur du thermique + DO k = 1, nlay - 1 + DO ig = 1, ngrid + lmax(ig, k) = k + END DO + DO l = nlay, k + 1, -1 + DO ig = 1, ngrid + IF (wa(ig,k,l)<=1.E-10) lmax(ig, k) = l - 1 + END DO + END DO + END DO + + ! print*,'5 OK convect8' + ! Calcule du w max du thermique + DO k = 1, nlay + DO ig = 1, ngrid + wmax(ig, k) = 0. + END DO + END DO + + DO k = 1, nlay - 1 + DO l = k, nlay + DO ig = 1, ngrid + IF (l<=lmax(ig,k)) THEN + wa(ig, k, l) = sqrt(wa(ig,k,l)) + wmax(ig, k) = max(wmax(ig,k), wa(ig,k,l)) + ELSE + wa(ig, k, l) = 0. + END IF + END DO + END DO + END DO + + DO k = 1, nlay - 1 + DO ig = 1, ngrid + pu_therm(ig, k) = sqrt(wmax(ig,k)) + pv_therm(ig, k) = sqrt(wmax(ig,k)) + END DO + END DO + + ! print*,'6 OK convect8' + ! Longueur caracteristique correspondant a la hauteur des thermiques. + DO ig = 1, ngrid + zmax(ig) = 500. + END DO + ! print*,'LMAX LMAX LMAX ' + DO k = 1, nlay - 1 + DO ig = 1, ngrid + zmax(ig) = max(zmax(ig), zlev(ig,lmax(ig,k))-zlev(ig,k)) + END DO + ! print*,k,lmax(1,k) + END DO + ! print*,'ZMAX ZMAX ZMAX ',zmax + ! call dump2d(iim,jjm-1,zmax(2:ngrid-1),'ZMAX ') + + ! print*,'OKl336' + ! Calcul de l'entrainement. + ! Le rapport d'aspect relie la largeur de l'ascendance a l'epaisseur + ! de la couche d'alimentation en partant du principe que la vitesse + ! maximum dans l'ascendance est la vitesse d'entrainement horizontale. + DO k = 1, nlay + DO ig = 1, ngrid + zzz = rho(ig, k)*wmax(ig, k)*(zlev(ig,k+1)-zlev(ig,k))/ & + (zmax(ig)*r_aspect) + IF (w2di==2) THEN + entr(ig, k) = entr(ig, k) + ptimestep*(zzz-entr(ig,k))/tho + ELSE + entr(ig, k) = zzz + END IF + ztva(ig, k) = ztv(ig, k) + END DO + END DO + + + ! print*,'7 OK convect8' + DO k = 1, klev + 1 + DO ig = 1, ngrid + zw2(ig, k) = 0. + fmc(ig, k) = 0. + larg_cons(ig, k) = 0. + larg_detr(ig, k) = 0. + wa_moy(ig, k) = 0. + END DO + END DO + + ! print*,'8 OK convect8' + DO ig = 1, ngrid + lmaxa(ig) = 1 + lmix(ig) = 1 + wmaxa(ig) = 0. + END DO + + + ! print*,'OKl372' + DO l = 1, nlay - 2 + DO ig = 1, ngrid + ! if (zw2(ig,l).lt.1.e-10.and.ztv(ig,l).gt.ztv(ig,l+1)) then + ! print*,'COUCOU ',l,zw2(ig,l),ztv(ig,l),ztv(ig,l+1) + IF (zw2(ig,l)<1.E-10 .AND. ztv(ig,l)>ztv(ig,l+1) .AND. & + entr(ig,l)>1.E-10) THEN + ! print*,'COUCOU cas 1' + ! Initialisation de l'ascendance + ! lmix(ig)=1 + ztva(ig, l) = ztv(ig, l) + fmc(ig, l) = 0. + fmc(ig, l+1) = entr(ig, l) + zw2(ig, l) = 0. + ! if (.not.ztv(ig,l+1).gt.150.) then + ! print*,'ig,l+1,ztv(ig,l+1)' + ! print*, ig,l+1,ztv(ig,l+1) + ! endif + zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* & + (zlev(ig,l+1)-zlev(ig,l)) + larg_detr(ig, l) = 0. + ELSE IF (zw2(ig,l)>=1.E-10 .AND. fmc(ig,l)+entr(ig,l)>1.E-10) THEN + ! Incrementation... + fmc(ig, l+1) = fmc(ig, l) + entr(ig, l) + ! if (.not.fmc(ig,l+1).gt.1.e-15) then + ! print*,'ig,l+1,fmc(ig,l+1)' + ! print*, ig,l+1,fmc(ig,l+1) + ! print*,'Fmc ',(fmc(ig,ll),ll=1,klev+1) + ! print*,'W2 ',(zw2(ig,ll),ll=1,klev+1) + ! print*,'Tv ',(ztv(ig,ll),ll=1,klev) + ! print*,'Entr ',(entr(ig,ll),ll=1,klev) + ! endif + ztva(ig, l) = (fmc(ig,l)*ztva(ig,l-1)+entr(ig,l)*ztv(ig,l))/ & + fmc(ig, l+1) + ! mise a jour de la vitesse ascendante (l'air entraine de la couche + ! consideree commence avec une vitesse nulle). + zw2(ig, l+1) = zw2(ig, l)*(fmc(ig,l)/fmc(ig,l+1))**2 + & + 2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, l)*(zlev(ig,l+1)-zlev(ig,l)) + END IF + IF (zw2(ig,l+1)<0.) THEN + zw2(ig, l+1) = 0. + lmaxa(ig) = l + ELSE + wa_moy(ig, l+1) = sqrt(zw2(ig,l+1)) + END IF + IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN + ! lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig) = l + 1 + wmaxa(ig) = wa_moy(ig, l+1) + END IF + ! print*,'COUCOU cas 2 LMIX=',lmix(ig),wa_moy(ig,l+1),wmaxa(ig) + END DO + END DO + + ! print*,'9 OK convect8' + ! print*,'WA1 ',wa_moy + + ! determination de l'indice du debut de la mixed layer ou w decroit + + ! calcul de la largeur de chaque ascendance dans le cas conservatif. + ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant + ! d'une couche est égale à la hauteur de la couche alimentante. + ! La vitesse maximale dans l'ascendance est aussi prise comme estimation + ! de la vitesse d'entrainement horizontal dans la couche alimentante. + + ! print*,'OKl439' + DO l = 2, nlay + DO ig = 1, ngrid + IF (l<=lmaxa(ig)) THEN + zw = max(wa_moy(ig,l), 1.E-10) + larg_cons(ig, l) = zmax(ig)*r_aspect*fmc(ig, l)/(rhobarz(ig,l)*zw) + END IF + END DO + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + IF (l<=lmaxa(ig)) THEN + ! if (idetr.eq.0) then + ! cette option est finalement en dur. + larg_detr(ig, l) = sqrt(l_mix*zlev(ig,l)) + ! else if (idetr.eq.1) then + ! larg_detr(ig,l)=larg_cons(ig,l) + ! s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) + ! else if (idetr.eq.2) then + ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + ! s *sqrt(wa_moy(ig,l)) + ! else if (idetr.eq.4) then + ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + ! s *wa_moy(ig,l) + ! endif + END IF + END DO + END DO + + ! print*,'10 OK convect8' + ! print*,'WA2 ',wa_moy + ! calcul de la fraction de la maille concernée par l'ascendance en tenant + ! compte de l'epluchage du thermique. + + DO l = 2, nlay + DO ig = 1, ngrid + IF (larg_cons(ig,l)>1.) THEN + ! print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' + fraca(ig, l) = (larg_cons(ig,l)-larg_detr(ig,l))/(r_aspect*zmax(ig)) + IF (l>lmix(ig)) THEN + xxx(ig, l) = (lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig)) + IF (idetr==0) THEN + fraca(ig, l) = fraca(ig, lmix(ig)) + ELSE IF (idetr==1) THEN + fraca(ig, l) = fraca(ig, lmix(ig))*xxx(ig, l) + ELSE IF (idetr==2) THEN + fraca(ig, l) = fraca(ig, lmix(ig))*(1.-(1.-xxx(ig,l))**2) + ELSE + fraca(ig, l) = fraca(ig, lmix(ig))*xxx(ig, l)**2 + END IF + END IF + ! print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' + fraca(ig, l) = max(fraca(ig,l), 0.) + fraca(ig, l) = min(fraca(ig,l), 0.5) + fracd(ig, l) = 1. - fraca(ig, l) + fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) + ELSE + ! wa_moy(ig,l)=0. + fraca(ig, l) = 0. + fracc(ig, l) = 0. + fracd(ig, l) = 1. + END IF + END DO + END DO + + ! print*,'11 OK convect8' + ! print*,'Ea3 ',wa_moy + ! ------------------------------------------------------------------ + ! Calcul de fracd, wd + ! somme wa - wd = 0 + ! ------------------------------------------------------------------ + + + DO ig = 1, ngrid + fm(ig, 1) = 0. + fm(ig, nlay+1) = 0. + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + fm(ig, l) = fraca(ig, l)*wa_moy(ig, l)*rhobarz(ig, l) + END DO + DO ig = 1, ngrid + IF (fracd(ig,l)<0.1) THEN + abort_message = 'fracd trop petit' + CALL abort_physic(modname, abort_message, 1) + ELSE + ! vitesse descendante "diagnostique" + wd(ig, l) = fm(ig, l)/(fracd(ig,l)*rhobarz(ig,l)) + END IF + END DO + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg + END DO + END DO + + ! print*,'12 OK convect8' + ! print*,'WA4 ',wa_moy + ! c------------------------------------------------------------------ + ! calcul du transport vertical + ! ------------------------------------------------------------------ + + GO TO 4444 + ! print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep + DO l = 2, nlay - 1 + DO ig = 1, ngrid + IF (fm(ig,l+1)*ptimestep>masse(ig,l) .AND. fm(ig,l+1)*ptimestep>masse( & + ig,l+1)) THEN + ! print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' + ! s ,fm(ig,l+1)*ptimestep + ! s ,' M=',masse(ig,l),masse(ig,l+1) + END IF + END DO + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + IF (entr(ig,l)*ptimestep>masse(ig,l)) THEN + ! print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' + ! s ,entr(ig,l)*ptimestep + ! s ,' M=',masse(ig,l) + END IF + END DO + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + IF (.NOT. fm(ig,l)>=0. .OR. .NOT. fm(ig,l)<=10.) THEN + ! print*,'WARN!!! fm exagere ig=',ig,' l=',l + ! s ,' FM=',fm(ig,l) + END IF + IF (.NOT. masse(ig,l)>=1.E-10 .OR. .NOT. masse(ig,l)<=1.E4) THEN + ! print*,'WARN!!! masse exagere ig=',ig,' l=',l + ! s ,' M=',masse(ig,l) + ! print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', + ! s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) + ! print*,'zlev(ig,l+1),zlev(ig,l)' + ! s ,zlev(ig,l+1),zlev(ig,l) + ! print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' + ! s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) + END IF + IF (.NOT. entr(ig,l)>=0. .OR. .NOT. entr(ig,l)<=10.) THEN + ! print*,'WARN!!! entr exagere ig=',ig,' l=',l + ! s ,' E=',entr(ig,l) + END IF + END DO + END DO + +4444 CONTINUE + ! print*,'OK 444 ' + + IF (w2di==1) THEN + fm0 = fm0 + ptimestep*(fm-fm0)/tho + entr0 = entr0 + ptimestep*(entr-entr0)/tho + ELSE + fm0 = fm + entr0 = entr + END IF + + IF (flagdq==0) THEN + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zh, zdhadj, & + zha) + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zo, pdoadj, & + zoa) + PRINT *, 'THERMALS OPT 1' + ELSE IF (flagdq==1) THEN + CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, & + zdhadj, zha) + CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, & + pdoadj, zoa) + PRINT *, 'THERMALS OPT 2' + ELSE + CALL thermcell_dq(ngrid, nlay, dqimpl, ptimestep, fm0, entr0, masse, zh, & + zdhadj, zha, lev_out) + CALL thermcell_dq(ngrid, nlay, dqimpl, ptimestep, fm0, entr0, masse, zo, & + pdoadj, zoa, lev_out) + PRINT *, 'THERMALS OPT 3', dqimpl + END IF + + PRINT *, 'TH VENT ', dvdq + IF (dvdq==0) THEN + ! print*,'TH VENT OK ',dvdq + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, & + zua) + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, & + zva) + ELSE IF (dvdq==1) THEN + CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, & + zu, zv, pduadj, pdvadj, zua, zva) + ELSE IF (dvdq==2) THEN + CALL thermcell_dv2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, & + zmax, zu, zv, pduadj, pdvadj, zua, zva, lev_out) + ELSE IF (dvdq==3) THEN + CALL thermcell_dq(ngrid, nlay, dqimpl, ptimestep, fm0, entr0, masse, zu, & + pduadj, zua, lev_out) + CALL thermcell_dq(ngrid, nlay, dqimpl, ptimestep, fm0, entr0, masse, zv, & + pdvadj, zva, lev_out) + END IF + + ! CALL writefield_phy('duadj',pduadj,klev) + + DO l = 1, nlay + DO ig = 1, ngrid + zf = 0.5*(fracc(ig,l)+fracc(ig,l+1)) + zf2 = zf/(1.-zf) + thetath2(ig, l) = zf2*(zha(ig,l)-zh(ig,l))**2 + wth2(ig, l) = zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 + END DO + END DO + + + + ! print*,'13 OK convect8' + ! print*,'WA5 ',wa_moy + DO l = 1, nlay + DO ig = 1, ngrid + pdtadj(ig, l) = zdhadj(ig, l)*zpspsk(ig, l) + END DO + END DO + + + ! do l=1,nlay + ! do ig=1,ngrid + ! if(abs(pdtadj(ig,l))*86400..gt.500.) then + ! print*,'WARN!!! ig=',ig,' l=',l + ! s ,' pdtadj=',pdtadj(ig,l) + ! endif + ! if(abs(pdoadj(ig,l))*86400..gt.1.) then + ! print*,'WARN!!! ig=',ig,' l=',l + ! s ,' pdoadj=',pdoadj(ig,l) + ! endif + ! enddo + ! enddo + + ! print*,'14 OK convect8' + ! ------------------------------------------------------------------ + ! Calculs pour les sorties + ! ------------------------------------------------------------------ + + IF (sorties) THEN + DO l = 1, nlay + DO ig = 1, ngrid + zla(ig, l) = (1.-fracd(ig,l))*zmax(ig) + zld(ig, l) = fracd(ig, l)*zmax(ig) + IF (1.-fracd(ig,l)>1.E-10) zwa(ig, l) = wd(ig, l)*fracd(ig, l)/ & + (1.-fracd(ig,l)) + END DO + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + detr(ig, l) = fm(ig, l) + entr(ig, l) - fm(ig, l+1) + IF (detr(ig,l)<0.) THEN + entr(ig, l) = entr(ig, l) - detr(ig, l) + detr(ig, l) = 0. + ! print*,'WARNING !!! detrainement negatif ',ig,l + END IF + END DO + END DO + END IF + + ! print*,'15 OK convect8' + + + ! if(wa_moy(1,4).gt.1.e-10) stop + + ! print*,'19 OK convect8' + RETURN +END SUBROUTINE thermcell_2002 + +SUBROUTINE thermcell_cld(ngrid, nlay, ptimestep, pplay, pplev, pphi, zlev, & + debut, pu, pv, pt, po, pduadj, pdvadj, pdtadj, pdoadj, fm0, entr0, zqla, & + lmax, zmax_sec, wmax_sec, zw_sec, lmix_sec, ratqscth, ratqsdiff & ! s + ! ,pu_therm,pv_therm + , r_aspect, l_mix, w2di, tho) + + USE dimphy + IMPLICIT NONE + + ! ======================================================================= + + ! Calcul du transport verticale dans la couche limite en presence + ! de "thermiques" explicitement representes + + ! Réécriture à partir d'un listing papier à Habas, le 14/02/00 + + ! le thermique est supposé homogène et dissipé par mélange avec + ! son environnement. la longueur l_mix contrôle l'efficacité du + ! mélange + + ! Le calcul du transport des différentes espèces se fait en prenant + ! en compte: + ! 1. un flux de masse montant + ! 2. un flux de masse descendant + ! 3. un entrainement + ! 4. un detrainement + + ! ======================================================================= + + ! ----------------------------------------------------------------------- + ! declarations: + ! ------------- + + include "YOMCST.h" + include "YOETHF.h" + include "FCTTRE.h" + + ! arguments: + ! ---------- + + INTEGER ngrid, nlay, w2di + REAL tho + REAL ptimestep, l_mix, r_aspect + REAL pt(ngrid, nlay), pdtadj(ngrid, nlay) + REAL pu(ngrid, nlay), pduadj(ngrid, nlay) + REAL pv(ngrid, nlay), pdvadj(ngrid, nlay) + REAL po(ngrid, nlay), pdoadj(ngrid, nlay) + REAL pplay(ngrid, nlay), pplev(ngrid, nlay+1) + REAL pphi(ngrid, nlay) + + INTEGER idetr + SAVE idetr + DATA idetr/3/ + !$OMP THREADPRIVATE(idetr) + + ! local: + ! ------ + + INTEGER ig, k, l, lmaxa(klon), lmix(klon) + REAL zsortie1d(klon) + ! CR: on remplace lmax(klon,klev+1) + INTEGER lmax(klon), lmin(klon), lentr(klon) + REAL linter(klon) + REAL zmix(klon), fracazmix(klon) + REAL alpha + SAVE alpha + DATA alpha/1./ + !$OMP THREADPRIVATE(alpha) + + ! RC + REAL zmax(klon), zw, zz, zw2(klon, klev+1), ztva(klon, klev), zzz + REAL zmax_sec(klon) + REAL zmax_sec2(klon) + REAL zw_sec(klon, klev+1) + INTEGER lmix_sec(klon) + REAL w_est(klon, klev+1) + ! on garde le zmax du pas de temps precedent + ! real zmax0(klon) + ! save zmax0 + ! real zmix0(klon) + ! save zmix0 + REAL, SAVE, ALLOCATABLE :: zmax0(:), zmix0(:) + !$OMP THREADPRIVATE(zmax0, zmix0) + + REAL zlev(klon, klev+1), zlay(klon, klev) + REAL deltaz(klon, klev) + REAL zh(klon, klev), zdhadj(klon, klev) + REAL zthl(klon, klev), zdthladj(klon, klev) + REAL ztv(klon, klev) + REAL zu(klon, klev), zv(klon, klev), zo(klon, klev) + REAL zl(klon, klev) + REAL wh(klon, klev+1) + REAL wu(klon, klev+1), wv(klon, klev+1), wo(klon, klev+1) + REAL zla(klon, klev+1) + REAL zwa(klon, klev+1) + REAL zld(klon, klev+1) + REAL zwd(klon, klev+1) + REAL zsortie(klon, klev) + REAL zva(klon, klev) + REAL zua(klon, klev) + REAL zoa(klon, klev) + + REAL zta(klon, klev) + REAL zha(klon, klev) + REAL wa_moy(klon, klev+1) + REAL fraca(klon, klev+1) + REAL fracc(klon, klev+1) + REAL zf, zf2 + REAL thetath2(klon, klev), wth2(klon, klev), wth3(klon, klev) + REAL q2(klon, klev) + REAL dtheta(klon, klev) + ! common/comtherm/thetath2,wth2 + + REAL ratqscth(klon, klev) + REAL sum + REAL sumdiff + REAL ratqsdiff(klon, klev) + REAL count_time + INTEGER ialt + + LOGICAL sorties + REAL rho(klon, klev), rhobarz(klon, klev+1), masse(klon, klev) + REAL zpspsk(klon, klev) + + ! real wmax(klon,klev),wmaxa(klon) + REAL wmax(klon), wmaxa(klon) + REAL wmax_sec(klon) + REAL wmax_sec2(klon) + REAL wa(klon, klev, klev+1) + REAL wd(klon, klev+1) + REAL larg_part(klon, klev, klev+1) + REAL fracd(klon, klev+1) + REAL xxx(klon, klev+1) + REAL larg_cons(klon, klev+1) + REAL larg_detr(klon, klev+1) + REAL fm0(klon, klev+1), entr0(klon, klev), detr(klon, klev) + REAL massetot(klon, klev) + REAL detr0(klon, klev) + REAL alim0(klon, klev) + REAL pu_therm(klon, klev), pv_therm(klon, klev) + REAL fm(klon, klev+1), entr(klon, klev) + REAL fmc(klon, klev+1) + + REAL zcor, zdelta, zcvm5, qlbef + REAL tbef(klon), qsatbef(klon) + REAL dqsat_dt, dt, num, denom + REAL reps, rlvcp, ddt0 + REAL ztla(klon, klev), zqla(klon, klev), zqta(klon, klev) + ! CR niveau de condensation + REAL nivcon(klon) + REAL zcon(klon) + REAL zqsat(klon, klev) + REAL zqsatth(klon, klev) + PARAMETER (ddt0=.01) + + + ! CR:nouvelles variables + REAL f_star(klon, klev+1), entr_star(klon, klev) + REAL detr_star(klon, klev) + REAL alim_star_tot(klon), alim_star2(klon) + REAL entr_star_tot(klon) + REAL detr_star_tot(klon) + REAL alim_star(klon, klev) + REAL alim(klon, klev) + REAL nu(klon, klev) + REAL nu_e(klon, klev) + REAL nu_min + REAL nu_max + REAL nu_r + REAL f(klon) + ! real f(klon), f0(klon) + ! save f0 + REAL, SAVE, ALLOCATABLE :: f0(:) + !$OMP THREADPRIVATE(f0) + + REAL f_old + REAL zlevinter(klon) + LOGICAL, SAVE :: first = .TRUE. + !$OMP THREADPRIVATE(first) + ! data first /.false./ + ! save first + LOGICAL nuage + ! save nuage + LOGICAL boucle + LOGICAL therm + LOGICAL debut + LOGICAL rale + INTEGER test(klon) + INTEGER signe_zw2 + ! RC + + CHARACTER *2 str2 + CHARACTER *10 str10 + + CHARACTER (LEN=20) :: modname = 'thermcell_cld' + CHARACTER (LEN=80) :: abort_message + + LOGICAL vtest(klon), down + LOGICAL zsat(klon) + + EXTERNAL scopy + + INTEGER ncorrec, ll + SAVE ncorrec + DATA ncorrec/0/ + !$OMP THREADPRIVATE(ncorrec) + + + + ! ----------------------------------------------------------------------- + ! initialisation: + ! --------------- + + IF (first) THEN + ALLOCATE (zmix0(klon)) + ALLOCATE (zmax0(klon)) + ALLOCATE (f0(klon)) + first = .FALSE. + END IF + + sorties = .FALSE. + ! print*,'NOUVEAU DETR PLUIE ' + IF (ngrid/=klon) THEN + PRINT * + PRINT *, 'STOP dans convadj' + PRINT *, 'ngrid =', ngrid + PRINT *, 'klon =', klon + END IF + + ! Initialisation + rlvcp = rlvtt/rcpd + reps = rd/rv + ! initialisations de zqsat + DO ll = 1, nlay + DO ig = 1, ngrid + zqsat(ig, ll) = 0. + zqsatth(ig, ll) = 0. + END DO + END DO + + ! on met le first a true pour le premier passage de la journée + DO ig = 1, klon + test(ig) = 0 + END DO + IF (debut) THEN + DO ig = 1, klon + test(ig) = 1 + f0(ig) = 0. + zmax0(ig) = 0. + END DO + END IF + DO ig = 1, klon + IF ((.NOT. debut) .AND. (f0(ig)<1.E-10)) THEN + test(ig) = 1 + END IF + END DO + ! do ig=1,klon + ! print*,'test(ig)',test(ig),zmax0(ig) + ! enddo + nuage = .FALSE. + ! ----------------------------------------------------------------------- + ! AM Calcul de T,q,ql a partir de Tl et qT + ! --------------------------------------------------- + + ! Pr Tprec=Tl calcul de qsat + ! Si qsat>qT T=Tl, q=qT + ! Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt) + ! On cherche DDT < DDT0 + + ! defaut + DO ll = 1, nlay + DO ig = 1, ngrid + zo(ig, ll) = po(ig, ll) + zl(ig, ll) = 0. + zh(ig, ll) = pt(ig, ll) + END DO + END DO + DO ig = 1, ngrid + zsat(ig) = .FALSE. + END DO + + + DO ll = 1, nlay + ! les points insatures sont definitifs + DO ig = 1, ngrid + tbef(ig) = pt(ig, ll) + zdelta = max(0., sign(1.,rtt-tbef(ig))) + qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, ll) + qsatbef(ig) = min(0.5, qsatbef(ig)) + zcor = 1./(1.-retv*qsatbef(ig)) + qsatbef(ig) = qsatbef(ig)*zcor + zsat(ig) = (max(0.,po(ig,ll)-qsatbef(ig))>1.E-10) + END DO + + DO ig = 1, ngrid + IF (zsat(ig) .AND. (1==1)) THEN + qlbef = max(0., po(ig,ll)-qsatbef(ig)) + ! si sature: ql est surestime, d'ou la sous-relax + dt = 0.5*rlvcp*qlbef + ! write(18,*),'DT0=',DT + ! on pourra enchainer 2 ou 3 calculs sans Do while + DO WHILE (abs(dt)>ddt0) + ! il faut verifier si c,a conserve quand on repasse en insature ... + tbef(ig) = tbef(ig) + dt + zdelta = max(0., sign(1.,rtt-tbef(ig))) + qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, ll) + qsatbef(ig) = min(0.5, qsatbef(ig)) + zcor = 1./(1.-retv*qsatbef(ig)) + qsatbef(ig) = qsatbef(ig)*zcor + ! on veut le signe de qlbef + qlbef = po(ig, ll) - qsatbef(ig) + zdelta = max(0., sign(1.,rtt-tbef(ig))) + zcvm5 = r5les*(1.-zdelta) + r5ies*zdelta + zcor = 1./(1.-retv*qsatbef(ig)) + dqsat_dt = foede(tbef(ig), zdelta, zcvm5, qsatbef(ig), zcor) + num = -tbef(ig) + pt(ig, ll) + rlvcp*qlbef + denom = 1. + rlvcp*dqsat_dt + IF (denom<1.E-10) THEN + PRINT *, 'pb denom' + END IF + dt = num/denom + END DO + ! on ecrit de maniere conservative (sat ou non) + zl(ig, ll) = max(0., qlbef) + ! T = Tl +Lv/Cp ql + zh(ig, ll) = pt(ig, ll) + rlvcp*zl(ig, ll) + zo(ig, ll) = po(ig, ll) - zl(ig, ll) + END IF + ! on ecrit zqsat + zqsat(ig, ll) = qsatbef(ig) + END DO + END DO + ! AM fin + + ! ----------------------------------------------------------------------- + ! incrementation eventuelle de tendances precedentes: + ! --------------------------------------------------- + + ! print*,'0 OK convect8' + + DO l = 1, nlay + DO ig = 1, ngrid + zpspsk(ig, l) = (pplay(ig,l)/100000.)**rkappa + ! zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA + ! zh(ig,l)=pt(ig,l)/zpspsk(ig,l) + zu(ig, l) = pu(ig, l) + zv(ig, l) = pv(ig, l) + ! zo(ig,l)=po(ig,l) + ! ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l)) + ! AM attention zh est maintenant le profil de T et plus le profil de + ! theta ! + + ! T-> Theta + ztv(ig, l) = zh(ig, l)/zpspsk(ig, l) + ! AM Theta_v + ztv(ig, l) = ztv(ig, l)*(1.+retv*(zo(ig,l))-zl(ig,l)) + ! AM Thetal + zthl(ig, l) = pt(ig, l)/zpspsk(ig, l) + + END DO + END DO + + ! print*,'1 OK convect8' + ! -------------------- + + + ! + + + + + + + + + + + + + + ! wa, fraca, wd, fracd -------------------- zlev(2), rhobarz + ! wh,wt,wo ... + + ! + + + + + + + + + + + zh,zu,zv,zo,rho + + + ! -------------------- zlev(1) + ! \\\\\\\\\\\\\\\\\\\\ + + + + ! ----------------------------------------------------------------------- + ! Calcul des altitudes des couches + ! ----------------------------------------------------------------------- + + DO l = 2, nlay + DO ig = 1, ngrid + zlev(ig, l) = 0.5*(pphi(ig,l)+pphi(ig,l-1))/rg + END DO + END DO + DO ig = 1, ngrid + zlev(ig, 1) = 0. + zlev(ig, nlay+1) = (2.*pphi(ig,klev)-pphi(ig,klev-1))/rg + END DO + DO l = 1, nlay + DO ig = 1, ngrid + zlay(ig, l) = pphi(ig, l)/rg + END DO + END DO + ! calcul de deltaz + DO l = 1, nlay + DO ig = 1, ngrid + deltaz(ig, l) = zlev(ig, l+1) - zlev(ig, l) + END DO + END DO + + ! print*,'2 OK convect8' + ! ----------------------------------------------------------------------- + ! Calcul des densites + ! ----------------------------------------------------------------------- + + DO l = 1, nlay + DO ig = 1, ngrid + ! rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l)) + rho(ig, l) = pplay(ig, l)/(zpspsk(ig,l)*rd*ztv(ig,l)) + END DO + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + rhobarz(ig, l) = 0.5*(rho(ig,l)+rho(ig,l-1)) + END DO + END DO + + DO k = 1, nlay + DO l = 1, nlay + 1 + DO ig = 1, ngrid + wa(ig, k, l) = 0. + END DO + END DO + END DO + ! Cr:ajout:calcul de la masse + DO l = 1, nlay + DO ig = 1, ngrid + ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg + END DO + END DO + ! print*,'3 OK convect8' + ! ------------------------------------------------------------------ + ! Calcul de w2, quarre de w a partir de la cape + ! a partir de w2, on calcule wa, vitesse de l'ascendance + + ! ATTENTION: Dans cette version, pour cause d'economie de memoire, + ! w2 est stoke dans wa + + ! ATTENTION: dans convect8, on n'utilise le calcule des wa + ! independants par couches que pour calculer l'entrainement + ! a la base et la hauteur max de l'ascendance. + + ! Indicages: + ! l'ascendance provenant du niveau k traverse l'interface l avec + ! une vitesse wa(k,l). + + ! -------------------- + + ! + + + + + + + + + + + + ! wa(k,l) ---- -------------------- l + ! /\ + ! /||\ + + + + + + + + + + + ! || + ! || -------------------- + ! || + ! || + + + + + + + + + + + ! || + ! || -------------------- + ! ||__ + ! |___ + + + + + + + + + + k + + ! -------------------- + + + + ! ------------------------------------------------------------------ + + ! CR: ponderation entrainement des couches instables + ! def des alim_star tels que alim=f*alim_star + DO l = 1, klev + DO ig = 1, ngrid + alim_star(ig, l) = 0. + alim(ig, l) = 0. + END DO + END DO + ! determination de la longueur de la couche d entrainement + DO ig = 1, ngrid + lentr(ig) = 1 + END DO + + ! on ne considere que les premieres couches instables + therm = .FALSE. + DO k = nlay - 2, 1, -1 + DO ig = 1, ngrid + IF (ztv(ig,k)>ztv(ig,k+1) .AND. ztv(ig,k+1)<=ztv(ig,k+2)) THEN + lentr(ig) = k + 1 + therm = .TRUE. + END IF + END DO + END DO + + ! determination du lmin: couche d ou provient le thermique + DO ig = 1, ngrid + lmin(ig) = 1 + END DO + DO ig = 1, ngrid + DO l = nlay, 2, -1 + IF (ztv(ig,l-1)>ztv(ig,l)) THEN + lmin(ig) = l - 1 + END IF + END DO + END DO + + ! definition de l'entrainement des couches + DO l = 1, klev - 1 + DO ig = 1, ngrid + IF (ztv(ig,l)>ztv(ig,l+1) .AND. l>=lmin(ig) .AND. l1.E-10) THEN + ! do l=1,lentr(ig) + DO l = 1, klev + ! def possibles pour entr_star: zdthetadz, dthetadz, zdtheta + alim_star(ig, l) = alim_star(ig, l)/alim_star_tot(ig) + END DO + END IF + END DO + + ! print*,'fin calcul alim_star' + + ! AM:initialisations + DO k = 1, nlay + DO ig = 1, ngrid + ztva(ig, k) = ztv(ig, k) + ztla(ig, k) = zthl(ig, k) + zqla(ig, k) = 0. + zqta(ig, k) = po(ig, k) + zsat(ig) = .FALSE. + END DO + END DO + DO k = 1, klev + DO ig = 1, ngrid + detr_star(ig, k) = 0. + entr_star(ig, k) = 0. + detr(ig, k) = 0. + entr(ig, k) = 0. + END DO + END DO + ! print*,'7 OK convect8' + DO k = 1, klev + 1 + DO ig = 1, ngrid + zw2(ig, k) = 0. + fmc(ig, k) = 0. + ! CR + f_star(ig, k) = 0. + ! RC + larg_cons(ig, k) = 0. + larg_detr(ig, k) = 0. + wa_moy(ig, k) = 0. + END DO + END DO + + ! n print*,'8 OK convect8' + DO ig = 1, ngrid + linter(ig) = 1. + lmaxa(ig) = 1 + lmix(ig) = 1 + wmaxa(ig) = 0. + END DO + + nu_min = l_mix + nu_max = 1000. + ! do ig=1,ngrid + ! nu_max=wmax_sec(ig) + ! enddo + DO ig = 1, ngrid + DO k = 1, klev + nu(ig, k) = 0. + nu_e(ig, k) = 0. + END DO + END DO + ! Calcul de l'excès de température du à la diffusion turbulente + DO ig = 1, ngrid + DO l = 1, klev + dtheta(ig, l) = 0. + END DO + END DO + DO ig = 1, ngrid + DO l = 1, lentr(ig) - 1 + dtheta(ig, l) = sqrt(10.*0.4*zlev(ig,l+1)**2*1.*((ztv(ig,l+1)- & + ztv(ig,l))/(zlev(ig,l+1)-zlev(ig,l)))**2) + END DO + END DO + ! do l=1,nlay-2 + DO l = 1, klev - 1 + DO ig = 1, ngrid + IF (ztv(ig,l)>ztv(ig,l+1) .AND. alim_star(ig,l)>1.E-10 .AND. & + zw2(ig,l)<1E-10) THEN + ! AM + ! test:on rajoute un excès de T dans couche alim + ! ztla(ig,l)=zthl(ig,l)+dtheta(ig,l) + ztla(ig, l) = zthl(ig, l) + ! test: on rajoute un excès de q dans la couche alim + ! zqta(ig,l)=po(ig,l)+0.001 + zqta(ig, l) = po(ig, l) + zqla(ig, l) = zl(ig, l) + ! AM + f_star(ig, l+1) = alim_star(ig, l) + ! test:calcul de dteta + zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* & + (zlev(ig,l+1)-zlev(ig,l))*0.4*pphi(ig, l)/(pphi(ig,l+1)-pphi(ig,l)) + w_est(ig, l+1) = zw2(ig, l+1) + larg_detr(ig, l) = 0. + ! print*,'coucou boucle 1' + ELSE IF ((zw2(ig,l)>=1E-10) .AND. (f_star(ig,l)+alim_star(ig, & + l))>1.E-10) THEN + ! print*,'coucou boucle 2' + ! estimation du detrainement a partir de la geometrie du pas + ! precedent + IF ((test(ig)==1) .OR. ((.NOT. debut) .AND. (f0(ig)<1.E-10))) THEN + detr_star(ig, l) = 0. + entr_star(ig, l) = 0. + ! print*,'coucou test(ig)',test(ig),f0(ig),zmax0(ig) + ELSE + ! print*,'coucou debut detr' + ! tests sur la definition du detr + IF (zqla(ig,l-1)>1.E-10) THEN + nuage = .TRUE. + END IF + + w_est(ig, l+1) = zw2(ig, l)*((f_star(ig,l))**2)/(f_star(ig,l)+ & + alim_star(ig,l))**2 + 2.*rg*(ztva(ig,l-1)-ztv(ig,l))/ztv(ig, l)*( & + zlev(ig,l+1)-zlev(ig,l)) + IF (w_est(ig,l+1)<0.) THEN + w_est(ig, l+1) = zw2(ig, l) + END IF + IF (l>2) THEN + IF ((w_est(ig,l+1)>w_est(ig,l)) .AND. (zlev(ig, & + l+1)f_star(ig,l)) THEN + detr_star(ig, l) = f_star(ig, l) + ! entr_star(ig,l)=0. + END IF + + IF ((l1.E-10) THEN + ! then + ! test + ! if (((f_star(ig,l+1)+detr_star(ig,l)).gt.1.e-10)) then + ! AM on melange Tl et qt du thermique + ! on rajoute un excès de T dans la couche alim + ! if (l.lt.lentr(ig)) then + ! ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+ + ! s + ! (alim_star(ig,l)+entr_star(ig,l))*(zthl(ig,l)+dtheta(ig,l))) + ! s /(f_star(ig,l+1)+detr_star(ig,l)) + ! else + ztla(ig, l) = (f_star(ig,l)*ztla(ig,l-1)+(alim_star(ig, & + l)+entr_star(ig,l))*zthl(ig,l))/(f_star(ig,l+1)+detr_star(ig,l)) + ! s /(f_star(ig,l+1)) + ! endif + ! on rajoute un excès de q dans la couche alim + ! if (l.lt.lentr(ig)) then + ! zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+ + ! s (alim_star(ig,l)+entr_star(ig,l))*(po(ig,l)+0.001)) + ! s /(f_star(ig,l+1)+detr_star(ig,l)) + ! else + zqta(ig, l) = (f_star(ig,l)*zqta(ig,l-1)+(alim_star(ig, & + l)+entr_star(ig,l))*po(ig,l))/(f_star(ig,l+1)+detr_star(ig,l)) + ! s /(f_star(ig,l+1)) + ! endif + ! AM on en deduit thetav et ql du thermique + ! CR test + ! Tbef(ig)=ztla(ig,l)*zpspsk(ig,l) + tbef(ig) = ztla(ig, l)*zpspsk(ig, l) + zdelta = max(0., sign(1.,rtt-tbef(ig))) + qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, l) + qsatbef(ig) = min(0.5, qsatbef(ig)) + zcor = 1./(1.-retv*qsatbef(ig)) + qsatbef(ig) = qsatbef(ig)*zcor + zsat(ig) = (max(0.,zqta(ig,l)-qsatbef(ig))>1.E-10) + + IF (zsat(ig) .AND. (1==1)) THEN + qlbef = max(0., zqta(ig,l)-qsatbef(ig)) + dt = 0.5*rlvcp*qlbef + ! write(17,*)'DT0=',DT + DO WHILE (abs(dt)>ddt0) + ! print*,'aie' + tbef(ig) = tbef(ig) + dt + zdelta = max(0., sign(1.,rtt-tbef(ig))) + qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, l) + qsatbef(ig) = min(0.5, qsatbef(ig)) + zcor = 1./(1.-retv*qsatbef(ig)) + qsatbef(ig) = qsatbef(ig)*zcor + qlbef = zqta(ig, l) - qsatbef(ig) + + zdelta = max(0., sign(1.,rtt-tbef(ig))) + zcvm5 = r5les*(1.-zdelta) + r5ies*zdelta + zcor = 1./(1.-retv*qsatbef(ig)) + dqsat_dt = foede(tbef(ig), zdelta, zcvm5, qsatbef(ig), zcor) + num = -tbef(ig) + ztla(ig, l)*zpspsk(ig, l) + rlvcp*qlbef + denom = 1. + rlvcp*dqsat_dt + IF (denom<1.E-10) THEN + PRINT *, 'pb denom' + END IF + dt = num/denom + ! write(17,*)'DT=',DT + END DO + zqla(ig, l) = max(0., zqta(ig,l)-qsatbef(ig)) + zqla(ig, l) = max(0., qlbef) + ! zqla(ig,l)=0. + END IF + ! zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig)) + + ! on ecrit de maniere conservative (sat ou non) + ! T = Tl +Lv/Cp ql + ! CR rq utilisation de humidite specifique ou rapport de melange? + ztva(ig, l) = ztla(ig, l)*zpspsk(ig, l) + rlvcp*zqla(ig, l) + ztva(ig, l) = ztva(ig, l)/zpspsk(ig, l) + ! on rajoute le calcul de zha pour diagnostiques (temp potentielle) + zha(ig, l) = ztva(ig, l) + ! if (l.lt.lentr(ig)) then + ! ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) + ! s -zqla(ig,l))-zqla(ig,l)) + 0.1 + ! else + ztva(ig, l) = ztva(ig, l)*(1.+retv*(zqta(ig,l)-zqla(ig, & + l))-zqla(ig,l)) + ! endif + ! ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l) + ! s /(1.-retv*zqla(ig,l)) + ! ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l) + ! ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) + ! s /(1.-retv*zqta(ig,l)) + ! s -zqla(ig,l)/(1.-retv*zqla(ig,l))) + ! s -zqla(ig,l)/(1.-retv*zqla(ig,l))) + ! write(13,*)zqla(ig,l),zqla(ig,l)/(1.-retv*zqla(ig,l)) + ! on ecrit zqsat + zqsatth(ig, l) = qsatbef(ig) + ! enddo + ! DO ig=1,ngrid + ! if (zw2(ig,l).ge.1.e-10.and. + ! s f_star(ig,l)+entr_star(ig,l).gt.1.e-10) then + ! mise a jour de la vitesse ascendante (l'air entraine de la couche + ! consideree commence avec une vitesse nulle). + + ! if (f_star(ig,l+1).gt.1.e-10) then + zw2(ig, l+1) = zw2(ig, l)* & ! s + ! ((f_star(ig,l)-detr_star(ig,l))**2) + ! s /f_star(ig,l+1)**2+ + ((f_star(ig,l))**2)/(f_star(ig,l+1)+detr_star(ig,l))**2 + & ! s + ! /(f_star(ig,l+1))**2+ + 2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, l)*(zlev(ig,l+1)-zlev(ig,l)) + ! s *(f_star(ig,l)/f_star(ig,l+1))**2 + + END IF + END IF + + IF (zw2(ig,l+1)<0.) THEN + linter(ig) = (l*(zw2(ig,l+1)-zw2(ig,l))-zw2(ig,l))/(zw2(ig,l+1)-zw2( & + ig,l)) + zw2(ig, l+1) = 0. + ! print*,'linter=',linter(ig) + ! else if ((zw2(ig,l+1).lt.1.e-10).and.(zw2(ig,l+1).ge.0.)) then + ! linter(ig)=l+1 + ! print*,'linter=l',zw2(ig,l),zw2(ig,l+1) + ELSE + wa_moy(ig, l+1) = sqrt(zw2(ig,l+1)) + ! wa_moy(ig,l+1)=zw2(ig,l+1) + END IF + IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN + ! lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig) = l + 1 + wmaxa(ig) = wa_moy(ig, l+1) + END IF + END DO + END DO + PRINT *, 'fin calcul zw2' + + ! Calcul de la couche correspondant a la hauteur du thermique + DO ig = 1, ngrid + lmax(ig) = lentr(ig) + END DO + DO ig = 1, ngrid + DO l = nlay, lentr(ig) + 1, -1 + IF (zw2(ig,l)<=1.E-10) THEN + lmax(ig) = l - 1 + END IF + END DO + END DO + ! pas de thermique si couche 1 stable + DO ig = 1, ngrid + IF (lmin(ig)>1) THEN + lmax(ig) = 1 + lmin(ig) = 1 + lentr(ig) = 1 + END IF + END DO + + ! Determination de zw2 max + DO ig = 1, ngrid + wmax(ig) = 0. + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + IF (l<=lmax(ig)) THEN + IF (zw2(ig,l)<0.) THEN + PRINT *, 'pb2 zw2<0' + END IF + zw2(ig, l) = sqrt(zw2(ig,l)) + wmax(ig) = max(wmax(ig), zw2(ig,l)) + ELSE + zw2(ig, l) = 0. + END IF + END DO + END DO + + ! Longueur caracteristique correspondant a la hauteur des thermiques. + DO ig = 1, ngrid + zmax(ig) = 0. + zlevinter(ig) = zlev(ig, 1) + END DO + DO ig = 1, ngrid + ! calcul de zlevinter + zlevinter(ig) = (zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*linter(ig) + & + zlev(ig, lmax(ig)) - lmax(ig)*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig))) + ! pour le cas ou on prend tjs lmin=1 + ! zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + zmax(ig) = max(zmax(ig), zlevinter(ig)-zlev(ig,1)) + zmax0(ig) = zmax(ig) + WRITE (11, *) 'ig,lmax,linter', ig, lmax(ig), linter(ig) + WRITE (12, *) 'ig,zlevinter,zmax', ig, zmax(ig), zlevinter(ig) + END DO + + ! Calcul de zmax_sec et wmax_sec + CALL fermeture_seche(ngrid, nlay, pplay, pplev, pphi, zlev, rhobarz, f0, & + zpspsk, alim, zh, zo, lentr, lmin, nu_min, nu_max, r_aspect, zmax_sec2, & + wmax_sec2) + + PRINT *, 'avant fermeture' + ! Fermeture,determination de f + ! en lmax f=d-e + DO ig = 1, ngrid + ! entr_star(ig,lmax(ig))=0. + ! f_star(ig,lmax(ig)+1)=0. + ! detr_star(ig,lmax(ig))=f_star(ig,lmax(ig))+entr_star(ig,lmax(ig)) + ! s +alim_star(ig,lmax(ig)) + END DO + + DO ig = 1, ngrid + alim_star2(ig) = 0. + END DO + ! calcul de entr_star_tot + DO ig = 1, ngrid + DO k = 1, lmix(ig) + entr_star_tot(ig) = entr_star_tot(ig) & ! s + ! +entr_star(ig,k) + +alim_star(ig, k) + ! s -detr_star(ig,k) + detr_star_tot(ig) = detr_star_tot(ig) & ! s + ! +alim_star(ig,k) + -detr_star(ig, k) + entr_star(ig, k) + END DO + END DO + + DO ig = 1, ngrid + IF (alim_star_tot(ig)<1.E-10) THEN + f(ig) = 0. + ELSE + ! do k=lmin(ig),lentr(ig) + DO k = 1, lentr(ig) + alim_star2(ig) = alim_star2(ig) + alim_star(ig, k)**2/(rho(ig,k)*( & + zlev(ig,k+1)-zlev(ig,k))) + END DO + IF ((zmax_sec(ig)>1.E-10) .AND. (1==1)) THEN + f(ig) = wmax_sec(ig)/(max(500.,zmax_sec(ig))*r_aspect*alim_star2(ig)) + f(ig) = f(ig) + (f0(ig)-f(ig))*exp((-ptimestep/zmax_sec(ig))*wmax_sec & + (ig)) + ELSE + f(ig) = wmax(ig)/(max(500.,zmax(ig))*r_aspect*alim_star2(ig)) + f(ig) = f(ig) + (f0(ig)-f(ig))*exp((-ptimestep/zmax(ig))*wmax(ig)) + END IF + END IF + f0(ig) = f(ig) + END DO + PRINT *, 'apres fermeture' + ! Calcul de l'entrainement + DO ig = 1, ngrid + DO k = 1, klev + alim(ig, k) = f(ig)*alim_star(ig, k) + END DO + END DO + ! CR:test pour entrainer moins que la masse + ! do ig=1,ngrid + ! do l=1,lentr(ig) + ! if ((alim(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then + ! alim(ig,l+1)=alim(ig,l+1)+alim(ig,l) + ! s -0.9*masse(ig,l)/ptimestep + ! alim(ig,l)=0.9*masse(ig,l)/ptimestep + ! endif + ! enddo + ! enddo + ! calcul du détrainement + DO ig = 1, klon + DO k = 1, klev + detr(ig, k) = f(ig)*detr_star(ig, k) + IF (detr(ig,k)<0.) THEN + ! print*,'detr1<0!!!' + END IF + END DO + DO k = 1, klev + entr(ig, k) = f(ig)*entr_star(ig, k) + IF (entr(ig,k)<0.) THEN + ! print*,'entr1<0!!!' + END IF + END DO + END DO + + ! do ig=1,ngrid + ! do l=1,klev + ! if (((detr(ig,l)+entr(ig,l)+alim(ig,l))*ptimestep).gt. + ! s (masse(ig,l))) then + ! print*,'d2+e2+a2>m2','ig=',ig,'l=',l,'lmax(ig)=',lmax(ig),'d+e+a=' + ! s,(detr(ig,l)+entr(ig,l)+alim(ig,l))*ptimestep,'m=',masse(ig,l) + ! endif + ! enddo + ! enddo + ! Calcul des flux + + DO ig = 1, ngrid + DO l = 1, lmax(ig) + ! do l=1,klev + ! fmc(ig,l+1)=f(ig)*f_star(ig,l+1) + fmc(ig, l+1) = fmc(ig, l) + alim(ig, l) + entr(ig, l) - detr(ig, l) + ! print*,'??!!','ig=',ig,'l=',l,'lmax=',lmax(ig),'lmix=',lmix(ig), + ! s 'e=',entr(ig,l),'d=',detr(ig,l),'a=',alim(ig,l),'f=',fmc(ig,l), + ! s 'f+1=',fmc(ig,l+1) + IF (fmc(ig,l+1)<0.) THEN + PRINT *, 'fmc1<0', l + 1, lmax(ig), fmc(ig, l+1) + fmc(ig, l+1) = fmc(ig, l) + detr(ig, l) = alim(ig, l) + entr(ig, l) + ! fmc(ig,l+1)=0. + ! print*,'fmc1<0',l+1,lmax(ig),fmc(ig,l+1) + END IF + ! if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then + ! f_old=fmc(ig,l+1) + ! fmc(ig,l+1)=fmc(ig,l) + ! detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1) + ! endif + + ! if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then + ! f_old=fmc(ig,l+1) + ! fmc(ig,l+1)=fmc(ig,l) + ! detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l) + ! endif + ! rajout du test sur alpha croissant + ! if test + ! if (1.eq.0) then + + IF (l==klev) THEN + PRINT *, 'THERMCELL PB ig=', ig, ' l=', l + abort_message = 'THERMCELL PB' + CALL abort_physic(modname, abort_message, 1) + END IF + ! if ((zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10).and. + ! s (l.ge.lentr(ig)).and. + IF ((zw2(ig,l+1)>1.E-10) .AND. (zw2(ig,l)>1.E-10) .AND. (l>=lentr(ig))) & + THEN + IF (((fmc(ig,l+1)/(rhobarz(ig,l+1)*zw2(ig,l+1)))>(fmc(ig,l)/ & + (rhobarz(ig,l)*zw2(ig,l))))) THEN + f_old = fmc(ig, l+1) + fmc(ig, l+1) = fmc(ig, l)*rhobarz(ig, l+1)*zw2(ig, l+1)/ & + (rhobarz(ig,l)*zw2(ig,l)) + detr(ig, l) = detr(ig, l) + f_old - fmc(ig, l+1) + ! detr(ig,l)=(fmc(ig,l+1)-fmc(ig,l))/(0.4-1.) + ! entr(ig,l)=0.4*detr(ig,l) + ! entr(ig,l)=fmc(ig,l+1)-fmc(ig,l)+detr(ig,l) + END IF + END IF + IF ((fmc(ig,l+1)>fmc(ig,l)) .AND. (l>lentr(ig))) THEN + f_old = fmc(ig, l+1) + fmc(ig, l+1) = fmc(ig, l) + detr(ig, l) = detr(ig, l) + f_old - fmc(ig, l+1) + END IF + IF (detr(ig,l)>fmc(ig,l)) THEN + detr(ig, l) = fmc(ig, l) + entr(ig, l) = fmc(ig, l+1) - alim(ig, l) + END IF + IF (fmc(ig,l+1)<0.) THEN + detr(ig, l) = detr(ig, l) + fmc(ig, l+1) + fmc(ig, l+1) = 0. + PRINT *, 'fmc2<0', l + 1, lmax(ig) + END IF + + ! test pour ne pas avoir f=0 et d=e/=0 + ! if (fmc(ig,l+1).lt.1.e-10) then + ! detr(ig,l+1)=0. + ! entr(ig,l+1)=0. + ! zqla(ig,l+1)=0. + ! zw2(ig,l+1)=0. + ! lmax(ig)=l+1 + ! zmax(ig)=zlev(ig,lmax(ig)) + ! endif + IF (zw2(ig,l+1)>1.E-10) THEN + IF ((((fmc(ig,l+1))/(rhobarz(ig,l+1)*zw2(ig,l+1)))>1.)) THEN + f_old = fmc(ig, l+1) + fmc(ig, l+1) = rhobarz(ig, l+1)*zw2(ig, l+1) + zw2(ig, l+1) = 0. + zqla(ig, l+1) = 0. + detr(ig, l) = detr(ig, l) + f_old - fmc(ig, l+1) + lmax(ig) = l + 1 + zmax(ig) = zlev(ig, lmax(ig)) + PRINT *, 'alpha>1', l + 1, lmax(ig) + END IF + END IF + ! write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) + ! endif test + ! endif + END DO + END DO + DO ig = 1, ngrid + ! if (fmc(ig,lmax(ig)+1).ne.0.) then + fmc(ig, lmax(ig)+1) = 0. + entr(ig, lmax(ig)) = 0. + detr(ig, lmax(ig)) = fmc(ig, lmax(ig)) + entr(ig, lmax(ig)) + & + alim(ig, lmax(ig)) + ! endif + END DO + ! test sur le signe de fmc + DO ig = 1, ngrid + DO l = 1, klev + 1 + IF (fmc(ig,l)<0.) THEN + PRINT *, 'fm1<0!!!', 'ig=', ig, 'l=', l, 'a=', alim(ig, l-1), 'e=', & + entr(ig, l-1), 'f=', fmc(ig, l-1), 'd=', detr(ig, l-1), 'f+1=', & + fmc(ig, l) + END IF + END DO + END DO + ! test de verification + DO ig = 1, ngrid + DO l = 1, lmax(ig) + IF ((abs(fmc(ig,l+1)-fmc(ig,l)-alim(ig,l)-entr(ig,l)+ & + detr(ig,l)))>1.E-4) THEN + ! print*,'pbcm!!','ig=',ig,'l=',l,'lmax=',lmax(ig),'lmix=',lmix(ig), + ! s 'e=',entr(ig,l),'d=',detr(ig,l),'a=',alim(ig,l),'f=',fmc(ig,l), + ! s 'f+1=',fmc(ig,l+1) + END IF + IF (detr(ig,l)<0.) THEN + PRINT *, 'detrdemi<0!!!' + END IF + END DO + END DO + + ! RC + ! CR def de zmix continu (profil parabolique des vitesses) + DO ig = 1, ngrid + IF (lmix(ig)>1.) THEN + ! test + IF (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- & + (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- & + zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))- & + (zlev(ig,lmix(ig)))))>1E-10) THEN + + zmix(ig) = ((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)) & + )**2-(zlev(ig,lmix(ig)+1))**2)-(zw2(ig,lmix(ig))-zw2(ig, & + lmix(ig)+1))*((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))/ & + (2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- & + (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- & + zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) + ELSE + zmix(ig) = zlev(ig, lmix(ig)) + PRINT *, 'pb zmix' + END IF + ELSE + zmix(ig) = 0. + END IF + ! test + IF ((zmax(ig)-zmix(ig))<=0.) THEN + zmix(ig) = 0.9*zmax(ig) + ! print*,'pb zmix>zmax' + END IF + END DO + DO ig = 1, klon + zmix0(ig) = zmix(ig) + END DO + + ! calcul du nouveau lmix correspondant + DO ig = 1, ngrid + DO l = 1, klev + IF (zmix(ig)>=zlev(ig,l) .AND. zmix(ig)(fmc(ig,l)+alim(ig,l))+entr(ig,l)) THEN + PRINT *, 'detr2>fmc2!!!', 'ig=', ig, 'l=', l, 'd=', detr(ig, l), & + 'f=', fmc(ig, l), 'lmax=', lmax(ig) + ! detr(ig,l)=fmc(ig,l)+alim(ig,l)+entr(ig,l) + ! entr(ig,l)=0. + ! fmc(ig,l+1)=0. + ! zw2(ig,l+1)=0. + ! zqla(ig,l+1)=0. + PRINT *, 'pb!fm=0 et f_star>0', l, lmax(ig) + ! lmax(ig)=l + END IF + END DO + END DO + DO ig = 1, ngrid + DO l = lmax(ig) + 1, klev + 1 + ! fmc(ig,l)=0. + ! detr(ig,l)=0. + ! entr(ig,l)=0. + ! zw2(ig,l)=0. + ! zqla(ig,l)=0. + END DO + END DO + + ! Calcul du detrainement lors du premier passage + ! print*,'9 OK convect8' + ! print*,'WA1 ',wa_moy + + ! determination de l'indice du debut de la mixed layer ou w decroit + + ! calcul de la largeur de chaque ascendance dans le cas conservatif. + ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant + ! d'une couche est égale à la hauteur de la couche alimentante. + ! La vitesse maximale dans l'ascendance est aussi prise comme estimation + ! de la vitesse d'entrainement horizontal dans la couche alimentante. + + DO l = 2, nlay + DO ig = 1, ngrid + IF (l<=lmax(ig) .AND. (test(ig)==1)) THEN + zw = max(wa_moy(ig,l), 1.E-10) + larg_cons(ig, l) = zmax(ig)*r_aspect*fmc(ig, l)/(rhobarz(ig,l)*zw) + END IF + END DO + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + IF (l<=lmax(ig) .AND. (test(ig)==1)) THEN + ! if (idetr.eq.0) then + ! cette option est finalement en dur. + IF ((l_mix*zlev(ig,l))<0.) THEN + PRINT *, 'pb l_mix*zlev<0' + END IF + ! CR: test: nouvelle def de lambda + ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + IF (zw2(ig,l)>1.E-10) THEN + larg_detr(ig, l) = sqrt((l_mix/zw2(ig,l))*zlev(ig,l)) + ELSE + larg_detr(ig, l) = sqrt(l_mix*zlev(ig,l)) + END IF + ! else if (idetr.eq.1) then + ! larg_detr(ig,l)=larg_cons(ig,l) + ! s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) + ! else if (idetr.eq.2) then + ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + ! s *sqrt(wa_moy(ig,l)) + ! else if (idetr.eq.4) then + ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + ! s *wa_moy(ig,l) + ! endif + END IF + END DO + END DO + + ! print*,'10 OK convect8' + ! print*,'WA2 ',wa_moy + ! cal1cul de la fraction de la maille concernée par l'ascendance en tenant + ! compte de l'epluchage du thermique. + + + DO l = 2, nlay + DO ig = 1, ngrid + IF (larg_cons(ig,l)>1. .AND. (test(ig)==1)) THEN + ! print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' + fraca(ig, l) = (larg_cons(ig,l)-larg_detr(ig,l))/(r_aspect*zmax(ig)) + ! test + fraca(ig, l) = max(fraca(ig,l), 0.) + fraca(ig, l) = min(fraca(ig,l), 0.5) + fracd(ig, l) = 1. - fraca(ig, l) + fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) + ELSE + ! wa_moy(ig,l)=0. + fraca(ig, l) = 0. + fracc(ig, l) = 0. + fracd(ig, l) = 1. + END IF + END DO + END DO + ! CR: calcul de fracazmix + DO ig = 1, ngrid + IF (test(ig)==1) THEN + fracazmix(ig) = (fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ & + (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + & + fraca(ig, lmix(ig)) - zlev(ig, lmix(ig))*(fraca(ig,lmix(ig)+1)-fraca( & + ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig))) + END IF + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + IF (larg_cons(ig,l)>1. .AND. (test(ig)==1)) THEN + IF (l>lmix(ig)) THEN + ! test + IF (zmax(ig)-zmix(ig)<1.E-10) THEN + ! print*,'pb xxx' + xxx(ig, l) = (lmax(ig)+1.-l)/(lmax(ig)+1.-lmix(ig)) + ELSE + xxx(ig, l) = (zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig)) + END IF + IF (idetr==0) THEN + fraca(ig, l) = fracazmix(ig) + ELSE IF (idetr==1) THEN + fraca(ig, l) = fracazmix(ig)*xxx(ig, l) + ELSE IF (idetr==2) THEN + fraca(ig, l) = fracazmix(ig)*(1.-(1.-xxx(ig,l))**2) + ELSE + fraca(ig, l) = fracazmix(ig)*xxx(ig, l)**2 + END IF + ! print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' + fraca(ig, l) = max(fraca(ig,l), 0.) + fraca(ig, l) = min(fraca(ig,l), 0.5) + fracd(ig, l) = 1. - fraca(ig, l) + fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) + END IF + END IF + END DO + END DO + + PRINT *, 'fin calcul fraca' + ! print*,'11 OK convect8' + ! print*,'Ea3 ',wa_moy + ! ------------------------------------------------------------------ + ! Calcul de fracd, wd + ! somme wa - wd = 0 + ! ------------------------------------------------------------------ + + + DO ig = 1, ngrid + fm(ig, 1) = 0. + fm(ig, nlay+1) = 0. + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + IF (test(ig)==1) THEN + fm(ig, l) = fraca(ig, l)*wa_moy(ig, l)*rhobarz(ig, l) + ! CR:test + IF (alim(ig,l-1)<1E-10 .AND. fm(ig,l)>fm(ig,l-1) .AND. l>lmix(ig)) & + THEN + fm(ig, l) = fm(ig, l-1) + ! write(1,*)'ajustement fm, l',l + END IF + ! write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) + ! RC + END IF + END DO + DO ig = 1, ngrid + IF (fracd(ig,l)<0.1 .AND. (test(ig)==1)) THEN + abort_message = 'fracd trop petit' + CALL abort_physic(modname, abort_message, 1) + ELSE + ! vitesse descendante "diagnostique" + wd(ig, l) = fm(ig, l)/(fracd(ig,l)*rhobarz(ig,l)) + END IF + END DO + END DO + + DO l = 1, nlay + 1 + DO ig = 1, ngrid + IF (test(ig)==0) THEN + fm(ig, l) = fmc(ig, l) + END IF + END DO + END DO + + ! fin du first + DO l = 1, nlay + DO ig = 1, ngrid + ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg + END DO + END DO + + ! print*,'12 OK convect8' + ! print*,'WA4 ',wa_moy + ! c------------------------------------------------------------------ + ! calcul du transport vertical + ! ------------------------------------------------------------------ + + GO TO 4444 + ! print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep + DO l = 2, nlay - 1 + DO ig = 1, ngrid + IF (fm(ig,l+1)*ptimestep>masse(ig,l) .AND. fm(ig,l+1)*ptimestep>masse( & + ig,l+1)) THEN + PRINT *, 'WARN!!! FM>M ig=', ig, ' l=', l, ' FM=', & + fm(ig, l+1)*ptimestep, ' M=', masse(ig, l), masse(ig, l+1) + END IF + END DO + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + IF ((alim(ig,l)+entr(ig,l))*ptimestep>masse(ig,l)) THEN + PRINT *, 'WARN!!! E>M ig=', ig, ' l=', l, ' E==', & + (entr(ig,l)+alim(ig,l))*ptimestep, ' M=', masse(ig, l) + END IF + END DO + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + IF (.NOT. fm(ig,l)>=0. .OR. .NOT. fm(ig,l)<=10.) THEN + ! print*,'WARN!!! fm exagere ig=',ig,' l=',l + ! s ,' FM=',fm(ig,l) + END IF + IF (.NOT. masse(ig,l)>=1.E-10 .OR. .NOT. masse(ig,l)<=1.E4) THEN + ! print*,'WARN!!! masse exagere ig=',ig,' l=',l + ! s ,' M=',masse(ig,l) + ! print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', + ! s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) + ! print*,'zlev(ig,l+1),zlev(ig,l)' + ! s ,zlev(ig,l+1),zlev(ig,l) + ! print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' + ! s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) + END IF + IF (.NOT. alim(ig,l)>=0. .OR. .NOT. alim(ig,l)<=10.) THEN + ! print*,'WARN!!! entr exagere ig=',ig,' l=',l + ! s ,' E=',entr(ig,l) + END IF + END DO + END DO + +4444 CONTINUE + + ! CR:redefinition du entr + ! CR:test:on ne change pas la def du entr mais la def du fm + DO l = 1, nlay + DO ig = 1, ngrid + IF (test(ig)==1) THEN + detr(ig, l) = fm(ig, l) + alim(ig, l) - fm(ig, l+1) + IF (detr(ig,l)<0.) THEN + ! entr(ig,l)=entr(ig,l)-detr(ig,l) + fm(ig, l+1) = fm(ig, l) + alim(ig, l) + detr(ig, l) = 0. + ! write(11,*)'l,ig,entr',l,ig,entr(ig,l) + ! print*,'WARNING !!! detrainement negatif ',ig,l + END IF + END IF + END DO + END DO + ! RC + + IF (w2di==1) THEN + fm0 = fm0 + ptimestep*(fm-fm0)/tho + entr0 = entr0 + ptimestep*(alim+entr-entr0)/tho + ELSE + fm0 = fm + entr0 = alim + entr + detr0 = detr + alim0 = alim + ! zoa=zqta + ! entr0=alim + END IF + + IF (1==1) THEN + ! call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + ! . ,zh,zdhadj,zha) + ! call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + ! . ,zo,pdoadj,zoa) + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zthl, & + zdthladj, zta) + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, po, pdoadj, & + zoa) + ELSE + CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, & + zdhadj, zha) + CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, & + pdoadj, zoa) + END IF + + IF (1==0) THEN + CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, & + zu, zv, pduadj, pdvadj, zua, zva) + ELSE + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, & + zua) + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, & + zva) + END IF + + ! Calcul des moments + ! do l=1,nlay + ! do ig=1,ngrid + ! zf=0.5*(fracc(ig,l)+fracc(ig,l+1)) + ! zf2=zf/(1.-zf) + ! thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2 + ! wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 + ! enddo + ! enddo + + + + + + + ! print*,'13 OK convect8' + ! print*,'WA5 ',wa_moy + DO l = 1, nlay + DO ig = 1, ngrid + ! pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l) + pdtadj(ig, l) = zdthladj(ig, l)*zpspsk(ig, l) + END DO + END DO + + + ! do l=1,nlay + ! do ig=1,ngrid + ! if(abs(pdtadj(ig,l))*86400..gt.500.) then + ! print*,'WARN!!! ig=',ig,' l=',l + ! s ,' pdtadj=',pdtadj(ig,l) + ! endif + ! if(abs(pdoadj(ig,l))*86400..gt.1.) then + ! print*,'WARN!!! ig=',ig,' l=',l + ! s ,' pdoadj=',pdoadj(ig,l) + ! endif + ! enddo + ! enddo + + ! print*,'14 OK convect8' + ! ------------------------------------------------------------------ + ! Calculs pour les sorties + ! ------------------------------------------------------------------ + ! calcul de fraca pour les sorties + DO l = 2, klev + DO ig = 1, klon + IF (zw2(ig,l)>1.E-10) THEN + fraca(ig, l) = fm(ig, l)/(rhobarz(ig,l)*zw2(ig,l)) + ELSE + fraca(ig, l) = 0. + END IF + END DO + END DO + IF (sorties) THEN + DO l = 1, nlay + DO ig = 1, ngrid + zla(ig, l) = (1.-fracd(ig,l))*zmax(ig) + zld(ig, l) = fracd(ig, l)*zmax(ig) + IF (1.-fracd(ig,l)>1.E-10) zwa(ig, l) = wd(ig, l)*fracd(ig, l)/ & + (1.-fracd(ig,l)) + END DO + END DO + ! CR calcul du niveau de condensation + ! initialisation + DO ig = 1, ngrid + nivcon(ig) = 0. + zcon(ig) = 0. + END DO + DO k = nlay, 1, -1 + DO ig = 1, ngrid + IF (zqla(ig,k)>1E-10) THEN + nivcon(ig) = k + zcon(ig) = zlev(ig, k) + END IF + ! if (zcon(ig).gt.1.e-10) then + ! nuage=.true. + ! else + ! nuage=.false. + ! endif + END DO + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + zf = fraca(ig, l) + zf2 = zf/(1.-zf) + thetath2(ig, l) = zf2*(zha(ig,l)-zh(ig,l)/zpspsk(ig,l))**2 + wth2(ig, l) = zf2*(zw2(ig,l))**2 + ! print*,'wth2=',wth2(ig,l) + wth3(ig, l) = zf2*(1-2.*fraca(ig,l))/(1-fraca(ig,l))*zw2(ig, l)* & + zw2(ig, l)*zw2(ig, l) + q2(ig, l) = zf2*(zqta(ig,l)*1000.-po(ig,l)*1000.)**2 + ! test: on calcul q2/po=ratqsc + ! if (nuage) then + ratqscth(ig, l) = sqrt(q2(ig,l))/(po(ig,l)*1000.) + ! else + ! ratqscth(ig,l)=0. + ! endif + END DO + END DO + ! calcul du ratqscdiff + sum = 0. + sumdiff = 0. + ratqsdiff(:, :) = 0. + DO ig = 1, ngrid + DO l = 1, lentr(ig) + sum = sum + alim_star(ig, l)*zqta(ig, l)*1000. + END DO + END DO + DO ig = 1, ngrid + DO l = 1, lentr(ig) + zf = fraca(ig, l) + zf2 = zf/(1.-zf) + sumdiff = sumdiff + alim_star(ig, l)*(zqta(ig,l)*1000.-sum)**2 + ! ratqsdiff=ratqsdiff+alim_star(ig,l)* + ! s (zqta(ig,l)*1000.-po(ig,l)*1000.)**2 + END DO + END DO + DO l = 1, klev + DO ig = 1, ngrid + ratqsdiff(ig, l) = sqrt(sumdiff)/(po(ig,l)*1000.) + ! write(11,*)'ratqsdiff=',ratqsdiff(ig,l) + END DO + END DO + + END IF + + ! print*,'19 OK convect8' + RETURN +END SUBROUTINE thermcell_cld + +SUBROUTINE thermcell_eau(ngrid, nlay, ptimestep, pplay, pplev, pphi, pu, pv, & + pt, po, pduadj, pdvadj, pdtadj, pdoadj, fm0, entr0 & ! s + ! ,pu_therm,pv_therm + , r_aspect, l_mix, w2di, tho) + + USE dimphy + IMPLICIT NONE + + ! ======================================================================= + + ! Calcul du transport verticale dans la couche limite en presence + ! de "thermiques" explicitement representes + + ! Réécriture à partir d'un listing papier à Habas, le 14/02/00 + + ! le thermique est supposé homogène et dissipé par mélange avec + ! son environnement. la longueur l_mix contrôle l'efficacité du + ! mélange + + ! Le calcul du transport des différentes espèces se fait en prenant + ! en compte: + ! 1. un flux de masse montant + ! 2. un flux de masse descendant + ! 3. un entrainement + ! 4. un detrainement + + ! ======================================================================= + + ! ----------------------------------------------------------------------- + ! declarations: + ! ------------- + + include "YOMCST.h" + include "YOETHF.h" + include "FCTTRE.h" + + ! arguments: + ! ---------- + + INTEGER ngrid, nlay, w2di + REAL tho + REAL ptimestep, l_mix, r_aspect + REAL pt(ngrid, nlay), pdtadj(ngrid, nlay) + REAL pu(ngrid, nlay), pduadj(ngrid, nlay) + REAL pv(ngrid, nlay), pdvadj(ngrid, nlay) + REAL po(ngrid, nlay), pdoadj(ngrid, nlay) + REAL pplay(ngrid, nlay), pplev(ngrid, nlay+1) + REAL pphi(ngrid, nlay) + + INTEGER idetr + SAVE idetr + DATA idetr/3/ + !$OMP THREADPRIVATE(idetr) + + ! local: + ! ------ + + INTEGER ig, k, l, lmaxa(klon), lmix(klon) + REAL zsortie1d(klon) + ! CR: on remplace lmax(klon,klev+1) + INTEGER lmax(klon), lmin(klon), lentr(klon) + REAL linter(klon) + REAL zmix(klon), fracazmix(klon) + ! RC + REAL zmax(klon), zw, zz, zw2(klon, klev+1), ztva(klon, klev), zzz + + REAL zlev(klon, klev+1), zlay(klon, klev) + REAL zh(klon, klev), zdhadj(klon, klev) + REAL zthl(klon, klev), zdthladj(klon, klev) + REAL ztv(klon, klev) + REAL zu(klon, klev), zv(klon, klev), zo(klon, klev) + REAL zl(klon, klev) + REAL wh(klon, klev+1) + REAL wu(klon, klev+1), wv(klon, klev+1), wo(klon, klev+1) + REAL zla(klon, klev+1) + REAL zwa(klon, klev+1) + REAL zld(klon, klev+1) + REAL zwd(klon, klev+1) + REAL zsortie(klon, klev) + REAL zva(klon, klev) + REAL zua(klon, klev) + REAL zoa(klon, klev) + + REAL zta(klon, klev) + REAL zha(klon, klev) + REAL wa_moy(klon, klev+1) + REAL fraca(klon, klev+1) + REAL fracc(klon, klev+1) + REAL zf, zf2 + REAL thetath2(klon, klev), wth2(klon, klev) + ! common/comtherm/thetath2,wth2 + + REAL count_time + INTEGER ialt + + LOGICAL sorties + REAL rho(klon, klev), rhobarz(klon, klev+1), masse(klon, klev) + REAL zpspsk(klon, klev) + + ! real wmax(klon,klev),wmaxa(klon) + REAL wmax(klon), wmaxa(klon) + REAL wa(klon, klev, klev+1) + REAL wd(klon, klev+1) + REAL larg_part(klon, klev, klev+1) + REAL fracd(klon, klev+1) + REAL xxx(klon, klev+1) + REAL larg_cons(klon, klev+1) + REAL larg_detr(klon, klev+1) + REAL fm0(klon, klev+1), entr0(klon, klev), detr(klon, klev) + REAL pu_therm(klon, klev), pv_therm(klon, klev) + REAL fm(klon, klev+1), entr(klon, klev) + REAL fmc(klon, klev+1) + + REAL zcor, zdelta, zcvm5, qlbef + REAL tbef(klon), qsatbef(klon) + REAL dqsat_dt, dt, num, denom + REAL reps, rlvcp, ddt0 + REAL ztla(klon, klev), zqla(klon, klev), zqta(klon, klev) + + PARAMETER (ddt0=.01) + + ! CR:nouvelles variables + REAL f_star(klon, klev+1), entr_star(klon, klev) + REAL entr_star_tot(klon), entr_star2(klon) + REAL f(klon), f0(klon) + REAL zlevinter(klon) + LOGICAL first + DATA first/.FALSE./ + SAVE first + !$OMP THREADPRIVATE(first) + + ! RC + + CHARACTER *2 str2 + CHARACTER *10 str10 + + CHARACTER (LEN=20) :: modname = 'thermcell_eau' + CHARACTER (LEN=80) :: abort_message + + LOGICAL vtest(klon), down + LOGICAL zsat(klon) + + EXTERNAL scopy + + INTEGER ncorrec, ll + SAVE ncorrec + DATA ncorrec/0/ + !$OMP THREADPRIVATE(ncorrec) + + + + ! ----------------------------------------------------------------------- + ! initialisation: + ! --------------- + + sorties = .TRUE. + IF (ngrid/=klon) THEN + PRINT * + PRINT *, 'STOP dans convadj' + PRINT *, 'ngrid =', ngrid + PRINT *, 'klon =', klon + END IF + + ! Initialisation + rlvcp = rlvtt/rcpd + reps = rd/rv + + ! ----------------------------------------------------------------------- + ! AM Calcul de T,q,ql a partir de Tl et qT + ! --------------------------------------------------- + + ! Pr Tprec=Tl calcul de qsat + ! Si qsat>qT T=Tl, q=qT + ! Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt) + ! On cherche DDT < DDT0 + + ! defaut + DO ll = 1, nlay + DO ig = 1, ngrid + zo(ig, ll) = po(ig, ll) + zl(ig, ll) = 0. + zh(ig, ll) = pt(ig, ll) + END DO + END DO + DO ig = 1, ngrid + zsat(ig) = .FALSE. + END DO + + + DO ll = 1, nlay + ! les points insatures sont definitifs + DO ig = 1, ngrid + tbef(ig) = pt(ig, ll) + zdelta = max(0., sign(1.,rtt-tbef(ig))) + qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, ll) + qsatbef(ig) = min(0.5, qsatbef(ig)) + zcor = 1./(1.-retv*qsatbef(ig)) + qsatbef(ig) = qsatbef(ig)*zcor + zsat(ig) = (max(0.,po(ig,ll)-qsatbef(ig))>0.00001) + END DO + + DO ig = 1, ngrid + IF (zsat(ig)) THEN + qlbef = max(0., po(ig,ll)-qsatbef(ig)) + ! si sature: ql est surestime, d'ou la sous-relax + dt = 0.5*rlvcp*qlbef + ! on pourra enchainer 2 ou 3 calculs sans Do while + DO WHILE (dt>ddt0) + ! il faut verifier si c,a conserve quand on repasse en insature ... + tbef(ig) = tbef(ig) + dt + zdelta = max(0., sign(1.,rtt-tbef(ig))) + qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, ll) + qsatbef(ig) = min(0.5, qsatbef(ig)) + zcor = 1./(1.-retv*qsatbef(ig)) + qsatbef(ig) = qsatbef(ig)*zcor + ! on veut le signe de qlbef + qlbef = po(ig, ll) - qsatbef(ig) + ! dqsat_dT + zdelta = max(0., sign(1.,rtt-tbef(ig))) + zcvm5 = r5les*(1.-zdelta) + r5ies*zdelta + zcor = 1./(1.-retv*qsatbef(ig)) + dqsat_dt = foede(tbef(ig), zdelta, zcvm5, qsatbef(ig), zcor) + num = -tbef(ig) + pt(ig, ll) + rlvcp*qlbef + denom = 1. + rlvcp*dqsat_dt + dt = num/denom + END DO + ! on ecrit de maniere conservative (sat ou non) + zl(ig, ll) = max(0., qlbef) + ! T = Tl +Lv/Cp ql + zh(ig, ll) = pt(ig, ll) + rlvcp*zl(ig, ll) + zo(ig, ll) = po(ig, ll) - zl(ig, ll) + END IF + END DO + END DO + ! AM fin + + ! ----------------------------------------------------------------------- + ! incrementation eventuelle de tendances precedentes: + ! --------------------------------------------------- + + ! print*,'0 OK convect8' + + DO l = 1, nlay + DO ig = 1, ngrid + zpspsk(ig, l) = (pplay(ig,l)/pplev(ig,1))**rkappa + ! zh(ig,l)=pt(ig,l)/zpspsk(ig,l) + zu(ig, l) = pu(ig, l) + zv(ig, l) = pv(ig, l) + ! zo(ig,l)=po(ig,l) + ! ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l)) + ! AM attention zh est maintenant le profil de T et plus le profil de + ! theta ! + + ! T-> Theta + ztv(ig, l) = zh(ig, l)/zpspsk(ig, l) + ! AM Theta_v + ztv(ig, l) = ztv(ig, l)*(1.+retv*(zo(ig,l))-zl(ig,l)) + ! AM Thetal + zthl(ig, l) = pt(ig, l)/zpspsk(ig, l) + + END DO + END DO + + ! print*,'1 OK convect8' + ! -------------------- + + + ! + + + + + + + + + + + + + + ! wa, fraca, wd, fracd -------------------- zlev(2), rhobarz + ! wh,wt,wo ... + + ! + + + + + + + + + + + zh,zu,zv,zo,rho + + + ! -------------------- zlev(1) + ! \\\\\\\\\\\\\\\\\\\\ + + + + ! ----------------------------------------------------------------------- + ! Calcul des altitudes des couches + ! ----------------------------------------------------------------------- + + DO l = 2, nlay + DO ig = 1, ngrid + zlev(ig, l) = 0.5*(pphi(ig,l)+pphi(ig,l-1))/rg + END DO + END DO + DO ig = 1, ngrid + zlev(ig, 1) = 0. + zlev(ig, nlay+1) = (2.*pphi(ig,klev)-pphi(ig,klev-1))/rg + END DO + DO l = 1, nlay + DO ig = 1, ngrid + zlay(ig, l) = pphi(ig, l)/rg + END DO + END DO + + ! print*,'2 OK convect8' + ! ----------------------------------------------------------------------- + ! Calcul des densites + ! ----------------------------------------------------------------------- + + DO l = 1, nlay + DO ig = 1, ngrid + ! rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l)) + rho(ig, l) = pplay(ig, l)/(zpspsk(ig,l)*rd*ztv(ig,l)) + END DO + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + rhobarz(ig, l) = 0.5*(rho(ig,l)+rho(ig,l-1)) + END DO + END DO + + DO k = 1, nlay + DO l = 1, nlay + 1 + DO ig = 1, ngrid + wa(ig, k, l) = 0. + END DO + END DO + END DO + + ! print*,'3 OK convect8' + ! ------------------------------------------------------------------ + ! Calcul de w2, quarre de w a partir de la cape + ! a partir de w2, on calcule wa, vitesse de l'ascendance + + ! ATTENTION: Dans cette version, pour cause d'economie de memoire, + ! w2 est stoke dans wa + + ! ATTENTION: dans convect8, on n'utilise le calcule des wa + ! independants par couches que pour calculer l'entrainement + ! a la base et la hauteur max de l'ascendance. + + ! Indicages: + ! l'ascendance provenant du niveau k traverse l'interface l avec + ! une vitesse wa(k,l). + + ! -------------------- + + ! + + + + + + + + + + + + ! wa(k,l) ---- -------------------- l + ! /\ + ! /||\ + + + + + + + + + + + ! || + ! || -------------------- + ! || + ! || + + + + + + + + + + + ! || + ! || -------------------- + ! ||__ + ! |___ + + + + + + + + + + k + + ! -------------------- + + + + ! ------------------------------------------------------------------ + + ! CR: ponderation entrainement des couches instables + ! def des entr_star tels que entr=f*entr_star + DO l = 1, klev + DO ig = 1, ngrid + entr_star(ig, l) = 0. + END DO + END DO + ! determination de la longueur de la couche d entrainement + DO ig = 1, ngrid + lentr(ig) = 1 + END DO + + ! on ne considere que les premieres couches instables + DO k = nlay - 1, 1, -1 + DO ig = 1, ngrid + IF (ztv(ig,k)>ztv(ig,k+1) .AND. ztv(ig,k+1)ztv(ig,l)) THEN + lmin(ig) = l - 1 + END IF + END DO + END DO + + ! definition de l'entrainement des couches + DO l = 1, klev - 1 + DO ig = 1, ngrid + IF (ztv(ig,l)>ztv(ig,l+1) .AND. l>=lmin(ig) .AND. l<=lentr(ig)) THEN + entr_star(ig, l) = (ztv(ig,l)-ztv(ig,l+1))*(zlev(ig,l+1)-zlev(ig,l)) + END IF + END DO + END DO + ! pas de thermique si couche 1 stable + DO ig = 1, ngrid + IF (lmin(ig)>1) THEN + DO l = 1, klev + entr_star(ig, l) = 0. + END DO + END IF + END DO + ! calcul de l entrainement total + DO ig = 1, ngrid + entr_star_tot(ig) = 0. + END DO + DO ig = 1, ngrid + DO k = 1, klev + entr_star_tot(ig) = entr_star_tot(ig) + entr_star(ig, k) + END DO + END DO + + DO k = 1, klev + DO ig = 1, ngrid + ztva(ig, k) = ztv(ig, k) + END DO + END DO + ! RC + ! AM:initialisations + DO k = 1, nlay + DO ig = 1, ngrid + ztva(ig, k) = ztv(ig, k) + ztla(ig, k) = zthl(ig, k) + zqla(ig, k) = 0. + zqta(ig, k) = po(ig, k) + zsat(ig) = .FALSE. + END DO + END DO + + ! print*,'7 OK convect8' + DO k = 1, klev + 1 + DO ig = 1, ngrid + zw2(ig, k) = 0. + fmc(ig, k) = 0. + ! CR + f_star(ig, k) = 0. + ! RC + larg_cons(ig, k) = 0. + larg_detr(ig, k) = 0. + wa_moy(ig, k) = 0. + END DO + END DO + + ! print*,'8 OK convect8' + DO ig = 1, ngrid + linter(ig) = 1. + lmaxa(ig) = 1 + lmix(ig) = 1 + wmaxa(ig) = 0. + END DO + + ! CR: + DO l = 1, nlay - 2 + DO ig = 1, ngrid + IF (ztv(ig,l)>ztv(ig,l+1) .AND. entr_star(ig,l)>1.E-10 .AND. & + zw2(ig,l)<1E-10) THEN + ! AM + ztla(ig, l) = zthl(ig, l) + zqta(ig, l) = po(ig, l) + zqla(ig, l) = zl(ig, l) + ! AM + f_star(ig, l+1) = entr_star(ig, l) + ! test:calcul de dteta + zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* & + (zlev(ig,l+1)-zlev(ig,l))*0.4*pphi(ig, l)/(pphi(ig,l+1)-pphi(ig,l)) + larg_detr(ig, l) = 0. + ELSE IF ((zw2(ig,l)>=1E-10) .AND. (f_star(ig,l)+entr_star(ig, & + l)>1.E-10)) THEN + f_star(ig, l+1) = f_star(ig, l) + entr_star(ig, l) + + ! AM on melange Tl et qt du thermique + ztla(ig, l) = (f_star(ig,l)*ztla(ig,l-1)+entr_star(ig,l)*zthl(ig,l))/ & + f_star(ig, l+1) + zqta(ig, l) = (f_star(ig,l)*zqta(ig,l-1)+entr_star(ig,l)*po(ig,l))/ & + f_star(ig, l+1) + + ! ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l) + ! s *ztv(ig,l))/f_star(ig,l+1) + + ! AM on en deduit thetav et ql du thermique + tbef(ig) = ztla(ig, l)*zpspsk(ig, l) + zdelta = max(0., sign(1.,rtt-tbef(ig))) + qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, l) + qsatbef(ig) = min(0.5, qsatbef(ig)) + zcor = 1./(1.-retv*qsatbef(ig)) + qsatbef(ig) = qsatbef(ig)*zcor + zsat(ig) = (max(0.,zqta(ig,l)-qsatbef(ig))>0.00001) + END IF + END DO + DO ig = 1, ngrid + IF (zsat(ig)) THEN + qlbef = max(0., zqta(ig,l)-qsatbef(ig)) + dt = 0.5*rlvcp*qlbef + DO WHILE (dt>ddt0) + tbef(ig) = tbef(ig) + dt + zdelta = max(0., sign(1.,rtt-tbef(ig))) + qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, l) + qsatbef(ig) = min(0.5, qsatbef(ig)) + zcor = 1./(1.-retv*qsatbef(ig)) + qsatbef(ig) = qsatbef(ig)*zcor + qlbef = zqta(ig, l) - qsatbef(ig) + + zdelta = max(0., sign(1.,rtt-tbef(ig))) + zcvm5 = r5les*(1.-zdelta) + r5ies*zdelta + zcor = 1./(1.-retv*qsatbef(ig)) + dqsat_dt = foede(tbef(ig), zdelta, zcvm5, qsatbef(ig), zcor) + num = -tbef(ig) + ztla(ig, l)*zpspsk(ig, l) + rlvcp*qlbef + denom = 1. + rlvcp*dqsat_dt + dt = num/denom + END DO + zqla(ig, l) = max(0., zqta(ig,l)-qsatbef(ig)) + END IF + ! on ecrit de maniere conservative (sat ou non) + ! T = Tl +Lv/Cp ql + ztva(ig, l) = ztla(ig, l)*zpspsk(ig, l) + rlvcp*zqla(ig, l) + ztva(ig, l) = ztva(ig, l)/zpspsk(ig, l) + ztva(ig, l) = ztva(ig, l)*(1.+retv*(zqta(ig,l)-zqla(ig,l))-zqla(ig,l)) + + END DO + DO ig = 1, ngrid + IF (zw2(ig,l)>=1.E-10 .AND. f_star(ig,l)+entr_star(ig,l)>1.E-10) THEN + ! mise a jour de la vitesse ascendante (l'air entraine de la couche + ! consideree commence avec une vitesse nulle). + + zw2(ig, l+1) = zw2(ig, l)*(f_star(ig,l)/f_star(ig,l+1))**2 + & + 2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, l)*(zlev(ig,l+1)-zlev(ig,l)) + END IF + ! determination de zmax continu par interpolation lineaire + IF (zw2(ig,l+1)<0.) THEN + linter(ig) = (l*(zw2(ig,l+1)-zw2(ig,l))-zw2(ig,l))/(zw2(ig,l+1)-zw2( & + ig,l)) + zw2(ig, l+1) = 0. + lmaxa(ig) = l + ELSE + wa_moy(ig, l+1) = sqrt(zw2(ig,l+1)) + END IF + IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN + ! lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig) = l + 1 + wmaxa(ig) = wa_moy(ig, l+1) + END IF + END DO + END DO + + ! Calcul de la couche correspondant a la hauteur du thermique + DO ig = 1, ngrid + lmax(ig) = lentr(ig) + END DO + DO ig = 1, ngrid + DO l = nlay, lentr(ig) + 1, -1 + IF (zw2(ig,l)<=1.E-10) THEN + lmax(ig) = l - 1 + END IF + END DO + END DO + ! pas de thermique si couche 1 stable + DO ig = 1, ngrid + IF (lmin(ig)>1) THEN + lmax(ig) = 1 + lmin(ig) = 1 + END IF + END DO + + ! Determination de zw2 max + DO ig = 1, ngrid + wmax(ig) = 0. + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + IF (l<=lmax(ig)) THEN + zw2(ig, l) = sqrt(zw2(ig,l)) + wmax(ig) = max(wmax(ig), zw2(ig,l)) + ELSE + zw2(ig, l) = 0. + END IF + END DO + END DO + + ! Longueur caracteristique correspondant a la hauteur des thermiques. + DO ig = 1, ngrid + zmax(ig) = 500. + zlevinter(ig) = zlev(ig, 1) + END DO + DO ig = 1, ngrid + ! calcul de zlevinter + zlevinter(ig) = (zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*linter(ig) + & + zlev(ig, lmax(ig)) - lmax(ig)*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig))) + zmax(ig) = max(zmax(ig), zlevinter(ig)-zlev(ig,lmin(ig))) + END DO + + ! Fermeture,determination de f + DO ig = 1, ngrid + entr_star2(ig) = 0. + END DO + DO ig = 1, ngrid + IF (entr_star_tot(ig)<1.E-10) THEN + f(ig) = 0. + ELSE + DO k = lmin(ig), lentr(ig) + entr_star2(ig) = entr_star2(ig) + entr_star(ig, k)**2/(rho(ig,k)*( & + zlev(ig,k+1)-zlev(ig,k))) + END DO + ! Nouvelle fermeture + f(ig) = wmax(ig)/(zmax(ig)*r_aspect*entr_star2(ig))*entr_star_tot(ig) + ! test + IF (first) THEN + f(ig) = f(ig) + (f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)*wmax(ig)) + END IF + END IF + f0(ig) = f(ig) + first = .TRUE. + END DO + + ! Calcul de l'entrainement + DO k = 1, klev + DO ig = 1, ngrid + entr(ig, k) = f(ig)*entr_star(ig, k) + END DO + END DO + ! Calcul des flux + DO ig = 1, ngrid + DO l = 1, lmax(ig) - 1 + fmc(ig, l+1) = fmc(ig, l) + entr(ig, l) + END DO + END DO + + ! RC + + + ! print*,'9 OK convect8' + ! print*,'WA1 ',wa_moy + + ! determination de l'indice du debut de la mixed layer ou w decroit + + ! calcul de la largeur de chaque ascendance dans le cas conservatif. + ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant + ! d'une couche est égale à la hauteur de la couche alimentante. + ! La vitesse maximale dans l'ascendance est aussi prise comme estimation + ! de la vitesse d'entrainement horizontal dans la couche alimentante. + + DO l = 2, nlay + DO ig = 1, ngrid + IF (l<=lmaxa(ig)) THEN + zw = max(wa_moy(ig,l), 1.E-10) + larg_cons(ig, l) = zmax(ig)*r_aspect*fmc(ig, l)/(rhobarz(ig,l)*zw) + END IF + END DO + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + IF (l<=lmaxa(ig)) THEN + ! if (idetr.eq.0) then + ! cette option est finalement en dur. + larg_detr(ig, l) = sqrt(l_mix*zlev(ig,l)) + ! else if (idetr.eq.1) then + ! larg_detr(ig,l)=larg_cons(ig,l) + ! s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) + ! else if (idetr.eq.2) then + ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + ! s *sqrt(wa_moy(ig,l)) + ! else if (idetr.eq.4) then + ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + ! s *wa_moy(ig,l) + ! endif + END IF + END DO + END DO + + ! print*,'10 OK convect8' + ! print*,'WA2 ',wa_moy + ! calcul de la fraction de la maille concernée par l'ascendance en tenant + ! compte de l'epluchage du thermique. + + ! CR def de zmix continu (profil parabolique des vitesses) + DO ig = 1, ngrid + IF (lmix(ig)>1.) THEN + zmix(ig) = ((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig))) & + **2-(zlev(ig,lmix(ig)+1))**2)-(zw2(ig,lmix(ig))-zw2(ig, & + lmix(ig)+1))*((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))/ & + (2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- & + (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))*((zlev( & + ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) + ELSE + zmix(ig) = 0. + END IF + END DO + + ! calcul du nouveau lmix correspondant + DO ig = 1, ngrid + DO l = 1, klev + IF (zmix(ig)>=zlev(ig,l) .AND. zmix(ig)1.) THEN + ! print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' + fraca(ig, l) = (larg_cons(ig,l)-larg_detr(ig,l))/(r_aspect*zmax(ig)) + ! test + fraca(ig, l) = max(fraca(ig,l), 0.) + fraca(ig, l) = min(fraca(ig,l), 0.5) + fracd(ig, l) = 1. - fraca(ig, l) + fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) + ELSE + ! wa_moy(ig,l)=0. + fraca(ig, l) = 0. + fracc(ig, l) = 0. + fracd(ig, l) = 1. + END IF + END DO + END DO + ! CR: calcul de fracazmix + DO ig = 1, ngrid + fracazmix(ig) = (fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ & + (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + & + fraca(ig, lmix(ig)) - zlev(ig, lmix(ig))*(fraca(ig,lmix(ig)+1)-fraca(ig & + ,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig))) + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + IF (larg_cons(ig,l)>1.) THEN + IF (l>lmix(ig)) THEN + xxx(ig, l) = (zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig)) + IF (idetr==0) THEN + fraca(ig, l) = fracazmix(ig) + ELSE IF (idetr==1) THEN + fraca(ig, l) = fracazmix(ig)*xxx(ig, l) + ELSE IF (idetr==2) THEN + fraca(ig, l) = fracazmix(ig)*(1.-(1.-xxx(ig,l))**2) + ELSE + fraca(ig, l) = fracazmix(ig)*xxx(ig, l)**2 + END IF + ! print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' + fraca(ig, l) = max(fraca(ig,l), 0.) + fraca(ig, l) = min(fraca(ig,l), 0.5) + fracd(ig, l) = 1. - fraca(ig, l) + fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) + END IF + END IF + END DO + END DO + + ! print*,'11 OK convect8' + ! print*,'Ea3 ',wa_moy + ! ------------------------------------------------------------------ + ! Calcul de fracd, wd + ! somme wa - wd = 0 + ! ------------------------------------------------------------------ + + + DO ig = 1, ngrid + fm(ig, 1) = 0. + fm(ig, nlay+1) = 0. + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + fm(ig, l) = fraca(ig, l)*wa_moy(ig, l)*rhobarz(ig, l) + ! CR:test + IF (entr(ig,l-1)<1E-10 .AND. fm(ig,l)>fm(ig,l-1) .AND. l>lmix(ig)) THEN + fm(ig, l) = fm(ig, l-1) + ! write(1,*)'ajustement fm, l',l + END IF + ! write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) + ! RC + END DO + DO ig = 1, ngrid + IF (fracd(ig,l)<0.1) THEN + abort_message = 'fracd trop petit' + CALL abort_physic(modname, abort_message, 1) + ELSE + ! vitesse descendante "diagnostique" + wd(ig, l) = fm(ig, l)/(fracd(ig,l)*rhobarz(ig,l)) + END IF + END DO + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg + END DO + END DO + + ! print*,'12 OK convect8' + ! print*,'WA4 ',wa_moy + ! c------------------------------------------------------------------ + ! calcul du transport vertical + ! ------------------------------------------------------------------ + + GO TO 4444 + ! print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep + DO l = 2, nlay - 1 + DO ig = 1, ngrid + IF (fm(ig,l+1)*ptimestep>masse(ig,l) .AND. fm(ig,l+1)*ptimestep>masse( & + ig,l+1)) THEN + ! print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' + ! s ,fm(ig,l+1)*ptimestep + ! s ,' M=',masse(ig,l),masse(ig,l+1) + END IF + END DO + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + IF (entr(ig,l)*ptimestep>masse(ig,l)) THEN + ! print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' + ! s ,entr(ig,l)*ptimestep + ! s ,' M=',masse(ig,l) + END IF + END DO + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + IF (.NOT. fm(ig,l)>=0. .OR. .NOT. fm(ig,l)<=10.) THEN + ! print*,'WARN!!! fm exagere ig=',ig,' l=',l + ! s ,' FM=',fm(ig,l) + END IF + IF (.NOT. masse(ig,l)>=1.E-10 .OR. .NOT. masse(ig,l)<=1.E4) THEN + ! print*,'WARN!!! masse exagere ig=',ig,' l=',l + ! s ,' M=',masse(ig,l) + ! print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', + ! s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) + ! print*,'zlev(ig,l+1),zlev(ig,l)' + ! s ,zlev(ig,l+1),zlev(ig,l) + ! print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' + ! s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) + END IF + IF (.NOT. entr(ig,l)>=0. .OR. .NOT. entr(ig,l)<=10.) THEN + ! print*,'WARN!!! entr exagere ig=',ig,' l=',l + ! s ,' E=',entr(ig,l) + END IF + END DO + END DO + +4444 CONTINUE + + IF (w2di==1) THEN + fm0 = fm0 + ptimestep*(fm-fm0)/tho + entr0 = entr0 + ptimestep*(entr-entr0)/tho + ELSE + fm0 = fm + entr0 = entr + END IF + + IF (1==1) THEN + ! call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + ! . ,zh,zdhadj,zha) + ! call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + ! . ,zo,pdoadj,zoa) + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zthl, & + zdthladj, zta) + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, po, pdoadj, & + zoa) + ELSE + CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, & + zdhadj, zha) + CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, & + pdoadj, zoa) + END IF + + IF (1==0) THEN + CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, & + zu, zv, pduadj, pdvadj, zua, zva) + ELSE + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, & + zua) + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, & + zva) + END IF + + DO l = 1, nlay + DO ig = 1, ngrid + zf = 0.5*(fracc(ig,l)+fracc(ig,l+1)) + zf2 = zf/(1.-zf) + thetath2(ig, l) = zf2*(zha(ig,l)-zh(ig,l))**2 + wth2(ig, l) = zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 + END DO + END DO + + + + ! print*,'13 OK convect8' + ! print*,'WA5 ',wa_moy + DO l = 1, nlay + DO ig = 1, ngrid + ! pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l) + pdtadj(ig, l) = zdthladj(ig, l)*zpspsk(ig, l) + END DO + END DO + + + ! do l=1,nlay + ! do ig=1,ngrid + ! if(abs(pdtadj(ig,l))*86400..gt.500.) then + ! print*,'WARN!!! ig=',ig,' l=',l + ! s ,' pdtadj=',pdtadj(ig,l) + ! endif + ! if(abs(pdoadj(ig,l))*86400..gt.1.) then + ! print*,'WARN!!! ig=',ig,' l=',l + ! s ,' pdoadj=',pdoadj(ig,l) + ! endif + ! enddo + ! enddo + + ! print*,'14 OK convect8' + ! ------------------------------------------------------------------ + ! Calculs pour les sorties + ! ------------------------------------------------------------------ + + RETURN +END SUBROUTINE thermcell_eau + +SUBROUTINE thermcell(ngrid, nlay, ptimestep, pplay, pplev, pphi, pu, pv, pt, & + po, pduadj, pdvadj, pdtadj, pdoadj, fm0, entr0 & ! s + ! ,pu_therm,pv_therm + , r_aspect, l_mix, w2di, tho) + + USE dimphy + IMPLICIT NONE + + ! ======================================================================= + + ! Calcul du transport verticale dans la couche limite en presence + ! de "thermiques" explicitement representes + + ! Réécriture à partir d'un listing papier à Habas, le 14/02/00 + + ! le thermique est supposé homogène et dissipé par mélange avec + ! son environnement. la longueur l_mix contrôle l'efficacité du + ! mélange + + ! Le calcul du transport des différentes espèces se fait en prenant + ! en compte: + ! 1. un flux de masse montant + ! 2. un flux de masse descendant + ! 3. un entrainement + ! 4. un detrainement + + ! ======================================================================= + + ! ----------------------------------------------------------------------- + ! declarations: + ! ------------- + + include "YOMCST.h" + + ! arguments: + ! ---------- + + INTEGER ngrid, nlay, w2di + REAL tho + REAL ptimestep, l_mix, r_aspect + REAL pt(ngrid, nlay), pdtadj(ngrid, nlay) + REAL pu(ngrid, nlay), pduadj(ngrid, nlay) + REAL pv(ngrid, nlay), pdvadj(ngrid, nlay) + REAL po(ngrid, nlay), pdoadj(ngrid, nlay) + REAL pplay(ngrid, nlay), pplev(ngrid, nlay+1) + REAL pphi(ngrid, nlay) + + INTEGER idetr + SAVE idetr + DATA idetr/3/ + !$OMP THREADPRIVATE(idetr) + + ! local: + ! ------ + + INTEGER ig, k, l, lmaxa(klon), lmix(klon) + REAL zsortie1d(klon) + ! CR: on remplace lmax(klon,klev+1) + INTEGER lmax(klon), lmin(klon), lentr(klon) + REAL linter(klon) + REAL zmix(klon), fracazmix(klon) + ! RC + REAL zmax(klon), zw, zz, zw2(klon, klev+1), ztva(klon, klev), zzz + + REAL zlev(klon, klev+1), zlay(klon, klev) + REAL zh(klon, klev), zdhadj(klon, klev) + REAL ztv(klon, klev) + REAL zu(klon, klev), zv(klon, klev), zo(klon, klev) + REAL wh(klon, klev+1) + REAL wu(klon, klev+1), wv(klon, klev+1), wo(klon, klev+1) + REAL zla(klon, klev+1) + REAL zwa(klon, klev+1) + REAL zld(klon, klev+1) + REAL zwd(klon, klev+1) + REAL zsortie(klon, klev) + REAL zva(klon, klev) + REAL zua(klon, klev) + REAL zoa(klon, klev) + + REAL zha(klon, klev) + REAL wa_moy(klon, klev+1) + REAL fraca(klon, klev+1) + REAL fracc(klon, klev+1) + REAL zf, zf2 + REAL thetath2(klon, klev), wth2(klon, klev) + ! common/comtherm/thetath2,wth2 + + REAL count_time + INTEGER ialt + + LOGICAL sorties + REAL rho(klon, klev), rhobarz(klon, klev+1), masse(klon, klev) + REAL zpspsk(klon, klev) + + ! real wmax(klon,klev),wmaxa(klon) + REAL wmax(klon), wmaxa(klon) + REAL wa(klon, klev, klev+1) + REAL wd(klon, klev+1) + REAL larg_part(klon, klev, klev+1) + REAL fracd(klon, klev+1) + REAL xxx(klon, klev+1) + REAL larg_cons(klon, klev+1) + REAL larg_detr(klon, klev+1) + REAL fm0(klon, klev+1), entr0(klon, klev), detr(klon, klev) + REAL pu_therm(klon, klev), pv_therm(klon, klev) + REAL fm(klon, klev+1), entr(klon, klev) + REAL fmc(klon, klev+1) + + ! CR:nouvelles variables + REAL f_star(klon, klev+1), entr_star(klon, klev) + REAL entr_star_tot(klon), entr_star2(klon) + REAL f(klon), f0(klon) + REAL zlevinter(klon) + LOGICAL first + DATA first/.FALSE./ + SAVE first + !$OMP THREADPRIVATE(first) + ! RC + + CHARACTER *2 str2 + CHARACTER *10 str10 + + CHARACTER (LEN=20) :: modname = 'thermcell' + CHARACTER (LEN=80) :: abort_message + + LOGICAL vtest(klon), down + + EXTERNAL scopy + + INTEGER ncorrec, ll + SAVE ncorrec + DATA ncorrec/0/ + !$OMP THREADPRIVATE(ncorrec) + + + ! ----------------------------------------------------------------------- + ! initialisation: + ! --------------- + + sorties = .TRUE. + IF (ngrid/=klon) THEN + PRINT * + PRINT *, 'STOP dans convadj' + PRINT *, 'ngrid =', ngrid + PRINT *, 'klon =', klon + END IF + + ! ----------------------------------------------------------------------- + ! incrementation eventuelle de tendances precedentes: + ! --------------------------------------------------- + + ! print*,'0 OK convect8' + + DO l = 1, nlay + DO ig = 1, ngrid + zpspsk(ig, l) = (pplay(ig,l)/pplev(ig,1))**rkappa + zh(ig, l) = pt(ig, l)/zpspsk(ig, l) + zu(ig, l) = pu(ig, l) + zv(ig, l) = pv(ig, l) + zo(ig, l) = po(ig, l) + ztv(ig, l) = zh(ig, l)*(1.+0.61*zo(ig,l)) + END DO + END DO + + ! print*,'1 OK convect8' + ! -------------------- + + + ! + + + + + + + + + + + + + + ! wa, fraca, wd, fracd -------------------- zlev(2), rhobarz + ! wh,wt,wo ... + + ! + + + + + + + + + + + zh,zu,zv,zo,rho + + + ! -------------------- zlev(1) + ! \\\\\\\\\\\\\\\\\\\\ + + + + ! ----------------------------------------------------------------------- + ! Calcul des altitudes des couches + ! ----------------------------------------------------------------------- + + DO l = 2, nlay + DO ig = 1, ngrid + zlev(ig, l) = 0.5*(pphi(ig,l)+pphi(ig,l-1))/rg + END DO + END DO + DO ig = 1, ngrid + zlev(ig, 1) = 0. + zlev(ig, nlay+1) = (2.*pphi(ig,klev)-pphi(ig,klev-1))/rg + END DO + DO l = 1, nlay + DO ig = 1, ngrid + zlay(ig, l) = pphi(ig, l)/rg + END DO + END DO + + ! print*,'2 OK convect8' + ! ----------------------------------------------------------------------- + ! Calcul des densites + ! ----------------------------------------------------------------------- + + DO l = 1, nlay + DO ig = 1, ngrid + rho(ig, l) = pplay(ig, l)/(zpspsk(ig,l)*rd*zh(ig,l)) + END DO + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + rhobarz(ig, l) = 0.5*(rho(ig,l)+rho(ig,l-1)) + END DO + END DO + + DO k = 1, nlay + DO l = 1, nlay + 1 + DO ig = 1, ngrid + wa(ig, k, l) = 0. + END DO + END DO + END DO + + ! print*,'3 OK convect8' + ! ------------------------------------------------------------------ + ! Calcul de w2, quarre de w a partir de la cape + ! a partir de w2, on calcule wa, vitesse de l'ascendance + + ! ATTENTION: Dans cette version, pour cause d'economie de memoire, + ! w2 est stoke dans wa + + ! ATTENTION: dans convect8, on n'utilise le calcule des wa + ! independants par couches que pour calculer l'entrainement + ! a la base et la hauteur max de l'ascendance. + + ! Indicages: + ! l'ascendance provenant du niveau k traverse l'interface l avec + ! une vitesse wa(k,l). + + ! -------------------- + + ! + + + + + + + + + + + + ! wa(k,l) ---- -------------------- l + ! /\ + ! /||\ + + + + + + + + + + + ! || + ! || -------------------- + ! || + ! || + + + + + + + + + + + ! || + ! || -------------------- + ! ||__ + ! |___ + + + + + + + + + + k + + ! -------------------- + + + + ! ------------------------------------------------------------------ + + ! CR: ponderation entrainement des couches instables + ! def des entr_star tels que entr=f*entr_star + DO l = 1, klev + DO ig = 1, ngrid + entr_star(ig, l) = 0. + END DO + END DO + ! determination de la longueur de la couche d entrainement + DO ig = 1, ngrid + lentr(ig) = 1 + END DO + + ! on ne considere que les premieres couches instables + DO k = nlay - 2, 1, -1 + DO ig = 1, ngrid + IF (ztv(ig,k)>ztv(ig,k+1) .AND. ztv(ig,k+1)<=ztv(ig,k+2)) THEN + lentr(ig) = k + END IF + END DO + END DO + + ! determination du lmin: couche d ou provient le thermique + DO ig = 1, ngrid + lmin(ig) = 1 + END DO + DO ig = 1, ngrid + DO l = nlay, 2, -1 + IF (ztv(ig,l-1)>ztv(ig,l)) THEN + lmin(ig) = l - 1 + END IF + END DO + END DO + + ! definition de l'entrainement des couches + DO l = 1, klev - 1 + DO ig = 1, ngrid + IF (ztv(ig,l)>ztv(ig,l+1) .AND. l>=lmin(ig) .AND. l<=lentr(ig)) THEN + entr_star(ig, l) = (ztv(ig,l)-ztv(ig,l+1))*(zlev(ig,l+1)-zlev(ig,l)) + END IF + END DO + END DO + ! pas de thermique si couches 1->5 stables + DO ig = 1, ngrid + IF (lmin(ig)>5) THEN + DO l = 1, klev + entr_star(ig, l) = 0. + END DO + END IF + END DO + ! calcul de l entrainement total + DO ig = 1, ngrid + entr_star_tot(ig) = 0. + END DO + DO ig = 1, ngrid + DO k = 1, klev + entr_star_tot(ig) = entr_star_tot(ig) + entr_star(ig, k) + END DO + END DO + + PRINT *, 'fin calcul entr_star' + DO k = 1, klev + DO ig = 1, ngrid + ztva(ig, k) = ztv(ig, k) + END DO + END DO + ! RC + ! print*,'7 OK convect8' + DO k = 1, klev + 1 + DO ig = 1, ngrid + zw2(ig, k) = 0. + fmc(ig, k) = 0. + ! CR + f_star(ig, k) = 0. + ! RC + larg_cons(ig, k) = 0. + larg_detr(ig, k) = 0. + wa_moy(ig, k) = 0. + END DO + END DO + + ! print*,'8 OK convect8' + DO ig = 1, ngrid + linter(ig) = 1. + lmaxa(ig) = 1 + lmix(ig) = 1 + wmaxa(ig) = 0. + END DO + + ! CR: + DO l = 1, nlay - 2 + DO ig = 1, ngrid + IF (ztv(ig,l)>ztv(ig,l+1) .AND. entr_star(ig,l)>1.E-10 .AND. & + zw2(ig,l)<1E-10) THEN + f_star(ig, l+1) = entr_star(ig, l) + ! test:calcul de dteta + zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* & + (zlev(ig,l+1)-zlev(ig,l))*0.4*pphi(ig, l)/(pphi(ig,l+1)-pphi(ig,l)) + larg_detr(ig, l) = 0. + ELSE IF ((zw2(ig,l)>=1E-10) .AND. (f_star(ig,l)+entr_star(ig, & + l)>1.E-10)) THEN + f_star(ig, l+1) = f_star(ig, l) + entr_star(ig, l) + ztva(ig, l) = (f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)*ztv(ig,l))/ & + f_star(ig, l+1) + zw2(ig, l+1) = zw2(ig, l)*(f_star(ig,l)/f_star(ig,l+1))**2 + & + 2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, l)*(zlev(ig,l+1)-zlev(ig,l)) + END IF + ! determination de zmax continu par interpolation lineaire + IF (zw2(ig,l+1)<0.) THEN + ! test + IF (abs(zw2(ig,l+1)-zw2(ig,l))<1E-10) THEN + PRINT *, 'pb linter' + END IF + linter(ig) = (l*(zw2(ig,l+1)-zw2(ig,l))-zw2(ig,l))/(zw2(ig,l+1)-zw2( & + ig,l)) + zw2(ig, l+1) = 0. + lmaxa(ig) = l + ELSE + IF (zw2(ig,l+1)<0.) THEN + PRINT *, 'pb1 zw2<0' + END IF + wa_moy(ig, l+1) = sqrt(zw2(ig,l+1)) + END IF + IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN + ! lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig) = l + 1 + wmaxa(ig) = wa_moy(ig, l+1) + END IF + END DO + END DO + PRINT *, 'fin calcul zw2' + + ! Calcul de la couche correspondant a la hauteur du thermique + DO ig = 1, ngrid + lmax(ig) = lentr(ig) + END DO + DO ig = 1, ngrid + DO l = nlay, lentr(ig) + 1, -1 + IF (zw2(ig,l)<=1.E-10) THEN + lmax(ig) = l - 1 + END IF + END DO + END DO + ! pas de thermique si couches 1->5 stables + DO ig = 1, ngrid + IF (lmin(ig)>5) THEN + lmax(ig) = 1 + lmin(ig) = 1 + END IF + END DO + + ! Determination de zw2 max + DO ig = 1, ngrid + wmax(ig) = 0. + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + IF (l<=lmax(ig)) THEN + IF (zw2(ig,l)<0.) THEN + PRINT *, 'pb2 zw2<0' + END IF + zw2(ig, l) = sqrt(zw2(ig,l)) + wmax(ig) = max(wmax(ig), zw2(ig,l)) + ELSE + zw2(ig, l) = 0. + END IF + END DO + END DO + + ! Longueur caracteristique correspondant a la hauteur des thermiques. + DO ig = 1, ngrid + zmax(ig) = 0. + zlevinter(ig) = zlev(ig, 1) + END DO + DO ig = 1, ngrid + ! calcul de zlevinter + zlevinter(ig) = (zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*linter(ig) + & + zlev(ig, lmax(ig)) - lmax(ig)*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig))) + zmax(ig) = max(zmax(ig), zlevinter(ig)-zlev(ig,lmin(ig))) + END DO + + PRINT *, 'avant fermeture' + ! Fermeture,determination de f + DO ig = 1, ngrid + entr_star2(ig) = 0. + END DO + DO ig = 1, ngrid + IF (entr_star_tot(ig)<1.E-10) THEN + f(ig) = 0. + ELSE + DO k = lmin(ig), lentr(ig) + entr_star2(ig) = entr_star2(ig) + entr_star(ig, k)**2/(rho(ig,k)*( & + zlev(ig,k+1)-zlev(ig,k))) + END DO + ! Nouvelle fermeture + f(ig) = wmax(ig)/(max(500.,zmax(ig))*r_aspect*entr_star2(ig))* & + entr_star_tot(ig) + ! test + ! if (first) then + ! f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig) + ! s *wmax(ig)) + ! endif + END IF + ! f0(ig)=f(ig) + ! first=.true. + END DO + PRINT *, 'apres fermeture' + + ! Calcul de l'entrainement + DO k = 1, klev + DO ig = 1, ngrid + entr(ig, k) = f(ig)*entr_star(ig, k) + END DO + END DO + ! Calcul des flux + DO ig = 1, ngrid + DO l = 1, lmax(ig) - 1 + fmc(ig, l+1) = fmc(ig, l) + entr(ig, l) + END DO + END DO + + ! RC + + + ! print*,'9 OK convect8' + ! print*,'WA1 ',wa_moy + + ! determination de l'indice du debut de la mixed layer ou w decroit + + ! calcul de la largeur de chaque ascendance dans le cas conservatif. + ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant + ! d'une couche est égale à la hauteur de la couche alimentante. + ! La vitesse maximale dans l'ascendance est aussi prise comme estimation + ! de la vitesse d'entrainement horizontal dans la couche alimentante. + + DO l = 2, nlay + DO ig = 1, ngrid + IF (l<=lmaxa(ig)) THEN + zw = max(wa_moy(ig,l), 1.E-10) + larg_cons(ig, l) = zmax(ig)*r_aspect*fmc(ig, l)/(rhobarz(ig,l)*zw) + END IF + END DO + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + IF (l<=lmaxa(ig)) THEN + ! if (idetr.eq.0) then + ! cette option est finalement en dur. + IF ((l_mix*zlev(ig,l))<0.) THEN + PRINT *, 'pb l_mix*zlev<0' + END IF + larg_detr(ig, l) = sqrt(l_mix*zlev(ig,l)) + ! else if (idetr.eq.1) then + ! larg_detr(ig,l)=larg_cons(ig,l) + ! s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) + ! else if (idetr.eq.2) then + ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + ! s *sqrt(wa_moy(ig,l)) + ! else if (idetr.eq.4) then + ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + ! s *wa_moy(ig,l) + ! endif + END IF + END DO + END DO + + ! print*,'10 OK convect8' + ! print*,'WA2 ',wa_moy + ! calcul de la fraction de la maille concernée par l'ascendance en tenant + ! compte de l'epluchage du thermique. + + ! CR def de zmix continu (profil parabolique des vitesses) + DO ig = 1, ngrid + IF (lmix(ig)>1.) THEN + ! test + IF (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- & + (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- & + zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))- & + (zlev(ig,lmix(ig)))))>1E-10) THEN + + zmix(ig) = ((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)) & + )**2-(zlev(ig,lmix(ig)+1))**2)-(zw2(ig,lmix(ig))-zw2(ig, & + lmix(ig)+1))*((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))/ & + (2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- & + (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- & + zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) + ELSE + zmix(ig) = zlev(ig, lmix(ig)) + PRINT *, 'pb zmix' + END IF + ELSE + zmix(ig) = 0. + END IF + ! test + IF ((zmax(ig)-zmix(ig))<0.) THEN + zmix(ig) = 0.99*zmax(ig) + ! print*,'pb zmix>zmax' + END IF + END DO + + ! calcul du nouveau lmix correspondant + DO ig = 1, ngrid + DO l = 1, klev + IF (zmix(ig)>=zlev(ig,l) .AND. zmix(ig)1.) THEN + ! print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' + fraca(ig, l) = (larg_cons(ig,l)-larg_detr(ig,l))/(r_aspect*zmax(ig)) + ! test + fraca(ig, l) = max(fraca(ig,l), 0.) + fraca(ig, l) = min(fraca(ig,l), 0.5) + fracd(ig, l) = 1. - fraca(ig, l) + fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) + ELSE + ! wa_moy(ig,l)=0. + fraca(ig, l) = 0. + fracc(ig, l) = 0. + fracd(ig, l) = 1. + END IF + END DO + END DO + ! CR: calcul de fracazmix + DO ig = 1, ngrid + fracazmix(ig) = (fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ & + (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + & + fraca(ig, lmix(ig)) - zlev(ig, lmix(ig))*(fraca(ig,lmix(ig)+1)-fraca(ig & + ,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig))) + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + IF (larg_cons(ig,l)>1.) THEN + IF (l>lmix(ig)) THEN + ! test + IF (zmax(ig)-zmix(ig)<1.E-10) THEN + ! print*,'pb xxx' + xxx(ig, l) = (lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig)) + ELSE + xxx(ig, l) = (zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig)) + END IF + IF (idetr==0) THEN + fraca(ig, l) = fracazmix(ig) + ELSE IF (idetr==1) THEN + fraca(ig, l) = fracazmix(ig)*xxx(ig, l) + ELSE IF (idetr==2) THEN + fraca(ig, l) = fracazmix(ig)*(1.-(1.-xxx(ig,l))**2) + ELSE + fraca(ig, l) = fracazmix(ig)*xxx(ig, l)**2 + END IF + ! print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' + fraca(ig, l) = max(fraca(ig,l), 0.) + fraca(ig, l) = min(fraca(ig,l), 0.5) + fracd(ig, l) = 1. - fraca(ig, l) + fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) + END IF + END IF + END DO + END DO + + PRINT *, 'fin calcul fraca' + ! print*,'11 OK convect8' + ! print*,'Ea3 ',wa_moy + ! ------------------------------------------------------------------ + ! Calcul de fracd, wd + ! somme wa - wd = 0 + ! ------------------------------------------------------------------ + + + DO ig = 1, ngrid + fm(ig, 1) = 0. + fm(ig, nlay+1) = 0. + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + fm(ig, l) = fraca(ig, l)*wa_moy(ig, l)*rhobarz(ig, l) + ! CR:test + IF (entr(ig,l-1)<1E-10 .AND. fm(ig,l)>fm(ig,l-1) .AND. l>lmix(ig)) THEN + fm(ig, l) = fm(ig, l-1) + ! write(1,*)'ajustement fm, l',l + END IF + ! write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) + ! RC + END DO + DO ig = 1, ngrid + IF (fracd(ig,l)<0.1) THEN + abort_message = 'fracd trop petit' + CALL abort_physic(modname, abort_message, 1) + ELSE + ! vitesse descendante "diagnostique" + wd(ig, l) = fm(ig, l)/(fracd(ig,l)*rhobarz(ig,l)) + END IF + END DO + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg + END DO + END DO + + ! print*,'12 OK convect8' + ! print*,'WA4 ',wa_moy + ! c------------------------------------------------------------------ + ! calcul du transport vertical + ! ------------------------------------------------------------------ + + GO TO 4444 + ! print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep + DO l = 2, nlay - 1 + DO ig = 1, ngrid + IF (fm(ig,l+1)*ptimestep>masse(ig,l) .AND. fm(ig,l+1)*ptimestep>masse( & + ig,l+1)) THEN + ! print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' + ! s ,fm(ig,l+1)*ptimestep + ! s ,' M=',masse(ig,l),masse(ig,l+1) + END IF + END DO + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + IF (entr(ig,l)*ptimestep>masse(ig,l)) THEN + ! print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' + ! s ,entr(ig,l)*ptimestep + ! s ,' M=',masse(ig,l) + END IF + END DO + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + IF (.NOT. fm(ig,l)>=0. .OR. .NOT. fm(ig,l)<=10.) THEN + ! print*,'WARN!!! fm exagere ig=',ig,' l=',l + ! s ,' FM=',fm(ig,l) + END IF + IF (.NOT. masse(ig,l)>=1.E-10 .OR. .NOT. masse(ig,l)<=1.E4) THEN + ! print*,'WARN!!! masse exagere ig=',ig,' l=',l + ! s ,' M=',masse(ig,l) + ! print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', + ! s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) + ! print*,'zlev(ig,l+1),zlev(ig,l)' + ! s ,zlev(ig,l+1),zlev(ig,l) + ! print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' + ! s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) + END IF + IF (.NOT. entr(ig,l)>=0. .OR. .NOT. entr(ig,l)<=10.) THEN + ! print*,'WARN!!! entr exagere ig=',ig,' l=',l + ! s ,' E=',entr(ig,l) + END IF + END DO + END DO + +4444 CONTINUE + + ! CR:redefinition du entr + DO l = 1, nlay + DO ig = 1, ngrid + detr(ig, l) = fm(ig, l) + entr(ig, l) - fm(ig, l+1) + IF (detr(ig,l)<0.) THEN + entr(ig, l) = entr(ig, l) - detr(ig, l) + detr(ig, l) = 0. + ! print*,'WARNING !!! detrainement negatif ',ig,l + END IF + END DO + END DO + ! RC + IF (w2di==1) THEN + fm0 = fm0 + ptimestep*(fm-fm0)/tho + entr0 = entr0 + ptimestep*(entr-entr0)/tho + ELSE + fm0 = fm + entr0 = entr + END IF + + IF (1==1) THEN + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zh, zdhadj, & + zha) + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zo, pdoadj, & + zoa) + ELSE + CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, & + zdhadj, zha) + CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, & + pdoadj, zoa) + END IF + + IF (1==0) THEN + CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, & + zu, zv, pduadj, pdvadj, zua, zva) + ELSE + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, & + zua) + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, & + zva) + END IF + + DO l = 1, nlay + DO ig = 1, ngrid + zf = 0.5*(fracc(ig,l)+fracc(ig,l+1)) + zf2 = zf/(1.-zf) + thetath2(ig, l) = zf2*(zha(ig,l)-zh(ig,l))**2 + wth2(ig, l) = zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 + END DO + END DO + + + + ! print*,'13 OK convect8' + ! print*,'WA5 ',wa_moy + DO l = 1, nlay + DO ig = 1, ngrid + pdtadj(ig, l) = zdhadj(ig, l)*zpspsk(ig, l) + END DO + END DO + + + ! do l=1,nlay + ! do ig=1,ngrid + ! if(abs(pdtadj(ig,l))*86400..gt.500.) then + ! print*,'WARN!!! ig=',ig,' l=',l + ! s ,' pdtadj=',pdtadj(ig,l) + ! endif + ! if(abs(pdoadj(ig,l))*86400..gt.1.) then + ! print*,'WARN!!! ig=',ig,' l=',l + ! s ,' pdoadj=',pdoadj(ig,l) + ! endif + ! enddo + ! enddo + + ! print*,'14 OK convect8' + ! ------------------------------------------------------------------ + ! Calculs pour les sorties + ! ------------------------------------------------------------------ + + IF (sorties) THEN + DO l = 1, nlay + DO ig = 1, ngrid + zla(ig, l) = (1.-fracd(ig,l))*zmax(ig) + zld(ig, l) = fracd(ig, l)*zmax(ig) + IF (1.-fracd(ig,l)>1.E-10) zwa(ig, l) = wd(ig, l)*fracd(ig, l)/ & + (1.-fracd(ig,l)) + END DO + END DO + + ! deja fait + ! do l=1,nlay + ! do ig=1,ngrid + ! detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) + ! if (detr(ig,l).lt.0.) then + ! entr(ig,l)=entr(ig,l)-detr(ig,l) + ! detr(ig,l)=0. + ! print*,'WARNING !!! detrainement negatif ',ig,l + ! endif + ! enddo + ! enddo + + ! print*,'15 OK convect8' + + + ! #define und + GO TO 123 +#ifdef und + CALL writeg1d(1, nlay, wd, 'wd ', 'wd ') + CALL writeg1d(1, nlay, zwa, 'wa ', 'wa ') + CALL writeg1d(1, nlay, fracd, 'fracd ', 'fracd ') + CALL writeg1d(1, nlay, fraca, 'fraca ', 'fraca ') + CALL writeg1d(1, nlay, wa_moy, 'wam ', 'wam ') + CALL writeg1d(1, nlay, zla, 'la ', 'la ') + CALL writeg1d(1, nlay, zld, 'ld ', 'ld ') + CALL writeg1d(1, nlay, pt, 'pt ', 'pt ') + CALL writeg1d(1, nlay, zh, 'zh ', 'zh ') + CALL writeg1d(1, nlay, zha, 'zha ', 'zha ') + CALL writeg1d(1, nlay, zu, 'zu ', 'zu ') + CALL writeg1d(1, nlay, zv, 'zv ', 'zv ') + CALL writeg1d(1, nlay, zo, 'zo ', 'zo ') + CALL writeg1d(1, nlay, wh, 'wh ', 'wh ') + CALL writeg1d(1, nlay, wu, 'wu ', 'wu ') + CALL writeg1d(1, nlay, wv, 'wv ', 'wv ') + CALL writeg1d(1, nlay, wo, 'w15uo ', 'wXo ') + CALL writeg1d(1, nlay, zdhadj, 'zdhadj ', 'zdhadj ') + CALL writeg1d(1, nlay, pduadj, 'pduadj ', 'pduadj ') + CALL writeg1d(1, nlay, pdvadj, 'pdvadj ', 'pdvadj ') + CALL writeg1d(1, nlay, pdoadj, 'pdoadj ', 'pdoadj ') + CALL writeg1d(1, nlay, entr, 'entr ', 'entr ') + CALL writeg1d(1, nlay, detr, 'detr ', 'detr ') + CALL writeg1d(1, nlay, fm, 'fm ', 'fm ') + + CALL writeg1d(1, nlay, pdtadj, 'pdtadj ', 'pdtadj ') + CALL writeg1d(1, nlay, pplay, 'pplay ', 'pplay ') + CALL writeg1d(1, nlay, pplev, 'pplev ', 'pplev ') + + ! recalcul des flux en diagnostique... + ! print*,'PAS DE TEMPS ',ptimestep + CALL dt2f(pplev, pplay, pt, pdtadj, wh) + CALL writeg1d(1, nlay, wh, 'wh2 ', 'wh2 ') +#endif +123 CONTINUE + + END IF + + ! if(wa_moy(1,4).gt.1.e-10) stop + + ! print*,'19 OK convect8' + RETURN +END SUBROUTINE thermcell + +SUBROUTINE dqthermcell(ngrid, nlay, ptimestep, fm, entr, masse, q, dq, qa) + USE dimphy + IMPLICIT NONE + + ! ======================================================================= + + ! Calcul du transport verticale dans la couche limite en presence + ! de "thermiques" explicitement representes + ! calcul du dq/dt une fois qu'on connait les ascendances + + ! ======================================================================= + + INTEGER ngrid, nlay + + REAL ptimestep + REAL masse(ngrid, nlay), fm(ngrid, nlay+1) + REAL entr(ngrid, nlay) + REAL q(ngrid, nlay) + REAL dq(ngrid, nlay) + + REAL qa(klon, klev), detr(klon, klev), wqd(klon, klev+1) + + INTEGER ig, k + + ! calcul du detrainement + + DO k = 1, nlay + DO ig = 1, ngrid + detr(ig, k) = fm(ig, k) - fm(ig, k+1) + entr(ig, k) + ! test + IF (detr(ig,k)<0.) THEN + entr(ig, k) = entr(ig, k) - detr(ig, k) + detr(ig, k) = 0. + ! print*,'detr2<0!!!','ig=',ig,'k=',k,'f=',fm(ig,k), + ! s 'f+1=',fm(ig,k+1),'e=',entr(ig,k),'d=',detr(ig,k) + END IF + IF (fm(ig,k+1)<0.) THEN + ! print*,'fm2<0!!!' + END IF + IF (entr(ig,k)<0.) THEN + ! print*,'entr2<0!!!' + END IF + END DO + END DO + + ! calcul de la valeur dans les ascendances + DO ig = 1, ngrid + qa(ig, 1) = q(ig, 1) + END DO + + DO k = 2, nlay + DO ig = 1, ngrid + IF ((fm(ig,k+1)+detr(ig,k))*ptimestep>1.E-5*masse(ig,k)) THEN + qa(ig, k) = (fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k))/ & + (fm(ig,k+1)+detr(ig,k)) + ELSE + qa(ig, k) = q(ig, k) + END IF + IF (qa(ig,k)<0.) THEN + ! print*,'qa<0!!!' + END IF + IF (q(ig,k)<0.) THEN + ! print*,'q<0!!!' + END IF + END DO + END DO + + DO k = 2, nlay + DO ig = 1, ngrid + ! wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k)) + wqd(ig, k) = fm(ig, k)*q(ig, k) + IF (wqd(ig,k)<0.) THEN + ! print*,'wqd<0!!!' + END IF + END DO + END DO + DO ig = 1, ngrid + wqd(ig, 1) = 0. + wqd(ig, nlay+1) = 0. + END DO + + DO k = 1, nlay + DO ig = 1, ngrid + dq(ig, k) = (detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k)-wqd(ig,k)+wqd(ig,k+ & + 1))/masse(ig, k) + ! if (dq(ig,k).lt.0.) then + ! print*,'dq<0!!!' + ! endif + END DO + END DO + + RETURN +END SUBROUTINE dqthermcell +SUBROUTINE dvthermcell(ngrid, nlay, ptimestep, fm, entr, masse, fraca, larga, & + u, v, du, dv, ua, va) + USE dimphy + IMPLICIT NONE + + ! ======================================================================= + + ! Calcul du transport verticale dans la couche limite en presence + ! de "thermiques" explicitement representes + ! calcul du dq/dt une fois qu'on connait les ascendances + + ! ======================================================================= + + INTEGER ngrid, nlay + + REAL ptimestep + REAL masse(ngrid, nlay), fm(ngrid, nlay+1) + REAL fraca(ngrid, nlay+1) + REAL larga(ngrid) + REAL entr(ngrid, nlay) + REAL u(ngrid, nlay) + REAL ua(ngrid, nlay) + REAL du(ngrid, nlay) + REAL v(ngrid, nlay) + REAL va(ngrid, nlay) + REAL dv(ngrid, nlay) + + REAL qa(klon, klev), detr(klon, klev) + REAL wvd(klon, klev+1), wud(klon, klev+1) + REAL gamma0, gamma(klon, klev+1) + REAL dua, dva + INTEGER iter + + INTEGER ig, k + + ! calcul du detrainement + + DO k = 1, nlay + DO ig = 1, ngrid + detr(ig, k) = fm(ig, k) - fm(ig, k+1) + entr(ig, k) + END DO + END DO + + ! calcul de la valeur dans les ascendances + DO ig = 1, ngrid + ua(ig, 1) = u(ig, 1) + va(ig, 1) = v(ig, 1) + END DO + + DO k = 2, nlay + DO ig = 1, ngrid + IF ((fm(ig,k+1)+detr(ig,k))*ptimestep>1.E-5*masse(ig,k)) THEN + ! On itère sur la valeur du coeff de freinage. + ! gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)) + gamma0 = masse(ig, k)*sqrt(0.5*(fraca(ig,k+1)+fraca(ig, & + k)))*0.5/larga(ig) + ! gamma0=0. + ! la première fois on multiplie le coefficient de freinage + ! par le module du vent dans la couche en dessous. + dua = ua(ig, k-1) - u(ig, k-1) + dva = va(ig, k-1) - v(ig, k-1) + DO iter = 1, 5 + gamma(ig, k) = gamma0*sqrt(dua**2+dva**2) + ua(ig, k) = (fm(ig,k)*ua(ig,k-1)+(entr(ig,k)+gamma(ig, & + k))*u(ig,k))/(fm(ig,k+1)+detr(ig,k)+gamma(ig,k)) + va(ig, k) = (fm(ig,k)*va(ig,k-1)+(entr(ig,k)+gamma(ig, & + k))*v(ig,k))/(fm(ig,k+1)+detr(ig,k)+gamma(ig,k)) + ! print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva + dua = ua(ig, k) - u(ig, k) + dva = va(ig, k) - v(ig, k) + END DO + ELSE + ua(ig, k) = u(ig, k) + va(ig, k) = v(ig, k) + gamma(ig, k) = 0. + END IF + END DO + END DO + + DO k = 2, nlay + DO ig = 1, ngrid + wud(ig, k) = fm(ig, k)*u(ig, k) + wvd(ig, k) = fm(ig, k)*v(ig, k) + END DO + END DO + DO ig = 1, ngrid + wud(ig, 1) = 0. + wud(ig, nlay+1) = 0. + wvd(ig, 1) = 0. + wvd(ig, nlay+1) = 0. + END DO + + DO k = 1, nlay + DO ig = 1, ngrid + du(ig, k) = ((detr(ig,k)+gamma(ig,k))*ua(ig,k)-(entr(ig,k)+gamma(ig, & + k))*u(ig,k)-wud(ig,k)+wud(ig,k+1))/masse(ig, k) + dv(ig, k) = ((detr(ig,k)+gamma(ig,k))*va(ig,k)-(entr(ig,k)+gamma(ig, & + k))*v(ig,k)-wvd(ig,k)+wvd(ig,k+1))/masse(ig, k) + END DO + END DO + + RETURN +END SUBROUTINE dvthermcell +SUBROUTINE dqthermcell2(ngrid, nlay, ptimestep, fm, entr, masse, frac, q, dq, & + qa) + USE dimphy + IMPLICIT NONE + + ! ======================================================================= + + ! Calcul du transport verticale dans la couche limite en presence + ! de "thermiques" explicitement representes + ! calcul du dq/dt une fois qu'on connait les ascendances + + ! ======================================================================= + + INTEGER ngrid, nlay + + REAL ptimestep + REAL masse(ngrid, nlay), fm(ngrid, nlay+1) + REAL entr(ngrid, nlay), frac(ngrid, nlay) + REAL q(ngrid, nlay) + REAL dq(ngrid, nlay) + + REAL qa(klon, klev), detr(klon, klev), wqd(klon, klev+1) + REAL qe(klon, klev), zf, zf2 + + INTEGER ig, k + + ! calcul du detrainement + + DO k = 1, nlay + DO ig = 1, ngrid + detr(ig, k) = fm(ig, k) - fm(ig, k+1) + entr(ig, k) + END DO + END DO + + ! calcul de la valeur dans les ascendances + DO ig = 1, ngrid + qa(ig, 1) = q(ig, 1) + qe(ig, 1) = q(ig, 1) + END DO + + DO k = 2, nlay + DO ig = 1, ngrid + IF ((fm(ig,k+1)+detr(ig,k))*ptimestep>1.E-5*masse(ig,k)) THEN + zf = 0.5*(frac(ig,k)+frac(ig,k+1)) + zf2 = 1./(1.-zf) + qa(ig, k) = (fm(ig,k)*qa(ig,k-1)+zf2*entr(ig,k)*q(ig,k))/ & + (fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2) + qe(ig, k) = (q(ig,k)-zf*qa(ig,k))*zf2 + ELSE + qa(ig, k) = q(ig, k) + qe(ig, k) = q(ig, k) + END IF + END DO + END DO + + DO k = 2, nlay + DO ig = 1, ngrid + ! wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k)) + wqd(ig, k) = fm(ig, k)*qe(ig, k) + END DO + END DO + DO ig = 1, ngrid + wqd(ig, 1) = 0. + wqd(ig, nlay+1) = 0. + END DO + + DO k = 1, nlay + DO ig = 1, ngrid + dq(ig, k) = (detr(ig,k)*qa(ig,k)-entr(ig,k)*qe(ig,k)-wqd(ig,k)+wqd(ig,k & + +1))/masse(ig, k) + END DO + END DO + + RETURN +END SUBROUTINE dqthermcell2 +SUBROUTINE dvthermcell2(ngrid, nlay, ptimestep, fm, entr, masse, fraca, & + larga, u, v, du, dv, ua, va) + USE dimphy + IMPLICIT NONE + + ! ======================================================================= + + ! Calcul du transport verticale dans la couche limite en presence + ! de "thermiques" explicitement representes + ! calcul du dq/dt une fois qu'on connait les ascendances + + ! ======================================================================= + + INTEGER ngrid, nlay + + REAL ptimestep + REAL masse(ngrid, nlay), fm(ngrid, nlay+1) + REAL fraca(ngrid, nlay+1) + REAL larga(ngrid) + REAL entr(ngrid, nlay) + REAL u(ngrid, nlay) + REAL ua(ngrid, nlay) + REAL du(ngrid, nlay) + REAL v(ngrid, nlay) + REAL va(ngrid, nlay) + REAL dv(ngrid, nlay) + + REAL qa(klon, klev), detr(klon, klev), zf, zf2 + REAL wvd(klon, klev+1), wud(klon, klev+1) + REAL gamma0, gamma(klon, klev+1) + REAL ue(klon, klev), ve(klon, klev) + REAL dua, dva + INTEGER iter + + INTEGER ig, k + + ! calcul du detrainement + + DO k = 1, nlay + DO ig = 1, ngrid + detr(ig, k) = fm(ig, k) - fm(ig, k+1) + entr(ig, k) + END DO + END DO + + ! calcul de la valeur dans les ascendances + DO ig = 1, ngrid + ua(ig, 1) = u(ig, 1) + va(ig, 1) = v(ig, 1) + ue(ig, 1) = u(ig, 1) + ve(ig, 1) = v(ig, 1) + END DO + + DO k = 2, nlay + DO ig = 1, ngrid + IF ((fm(ig,k+1)+detr(ig,k))*ptimestep>1.E-5*masse(ig,k)) THEN + ! On itère sur la valeur du coeff de freinage. + ! gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)) + gamma0 = masse(ig, k)*sqrt(0.5*(fraca(ig,k+1)+fraca(ig, & + k)))*0.5/larga(ig)*1. + ! s *0.5 + ! gamma0=0. + zf = 0.5*(fraca(ig,k)+fraca(ig,k+1)) + zf = 0. + zf2 = 1./(1.-zf) + ! la première fois on multiplie le coefficient de freinage + ! par le module du vent dans la couche en dessous. + dua = ua(ig, k-1) - u(ig, k-1) + dva = va(ig, k-1) - v(ig, k-1) + DO iter = 1, 5 + ! On choisit une relaxation lineaire. + gamma(ig, k) = gamma0 + ! On choisit une relaxation quadratique. + gamma(ig, k) = gamma0*sqrt(dua**2+dva**2) + ua(ig, k) = (fm(ig,k)*ua(ig,k-1)+(zf2*entr(ig,k)+gamma(ig, & + k))*u(ig,k))/(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2+gamma(ig,k) & + ) + va(ig, k) = (fm(ig,k)*va(ig,k-1)+(zf2*entr(ig,k)+gamma(ig, & + k))*v(ig,k))/(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2+gamma(ig,k) & + ) + ! print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva + dua = ua(ig, k) - u(ig, k) + dva = va(ig, k) - v(ig, k) + ue(ig, k) = (u(ig,k)-zf*ua(ig,k))*zf2 + ve(ig, k) = (v(ig,k)-zf*va(ig,k))*zf2 + END DO + ELSE + ua(ig, k) = u(ig, k) + va(ig, k) = v(ig, k) + ue(ig, k) = u(ig, k) + ve(ig, k) = v(ig, k) + gamma(ig, k) = 0. + END IF + END DO + END DO + + DO k = 2, nlay + DO ig = 1, ngrid + wud(ig, k) = fm(ig, k)*ue(ig, k) + wvd(ig, k) = fm(ig, k)*ve(ig, k) + END DO + END DO + DO ig = 1, ngrid + wud(ig, 1) = 0. + wud(ig, nlay+1) = 0. + wvd(ig, 1) = 0. + wvd(ig, nlay+1) = 0. + END DO + + DO k = 1, nlay + DO ig = 1, ngrid + du(ig, k) = ((detr(ig,k)+gamma(ig,k))*ua(ig,k)-(entr(ig,k)+gamma(ig, & + k))*ue(ig,k)-wud(ig,k)+wud(ig,k+1))/masse(ig, k) + dv(ig, k) = ((detr(ig,k)+gamma(ig,k))*va(ig,k)-(entr(ig,k)+gamma(ig, & + k))*ve(ig,k)-wvd(ig,k)+wvd(ig,k+1))/masse(ig, k) + END DO + END DO + + RETURN +END SUBROUTINE dvthermcell2 +SUBROUTINE thermcell_sec(ngrid, nlay, ptimestep, pplay, pplev, pphi, zlev, & + pu, pv, pt, po, pduadj, pdvadj, pdtadj, pdoadj, fm0, entr0 & ! s + ! ,pu_therm,pv_therm + , r_aspect, l_mix, w2di, tho) + + USE dimphy + IMPLICIT NONE + + ! ======================================================================= + + ! Calcul du transport verticale dans la couche limite en presence + ! de "thermiques" explicitement representes + + ! Réécriture à partir d'un listing papier à Habas, le 14/02/00 + + ! le thermique est supposé homogène et dissipé par mélange avec + ! son environnement. la longueur l_mix contrôle l'efficacité du + ! mélange + + ! Le calcul du transport des différentes espèces se fait en prenant + ! en compte: + ! 1. un flux de masse montant + ! 2. un flux de masse descendant + ! 3. un entrainement + ! 4. un detrainement + + ! ======================================================================= + + ! ----------------------------------------------------------------------- + ! declarations: + ! ------------- + + include "YOMCST.h" + + ! arguments: + ! ---------- + + INTEGER ngrid, nlay, w2di + REAL tho + REAL ptimestep, l_mix, r_aspect + REAL pt(ngrid, nlay), pdtadj(ngrid, nlay) + REAL pu(ngrid, nlay), pduadj(ngrid, nlay) + REAL pv(ngrid, nlay), pdvadj(ngrid, nlay) + REAL po(ngrid, nlay), pdoadj(ngrid, nlay) + REAL pplay(ngrid, nlay), pplev(ngrid, nlay+1) + REAL pphi(ngrid, nlay) + + INTEGER idetr + SAVE idetr + DATA idetr/3/ + !$OMP THREADPRIVATE(idetr) + + ! local: + ! ------ + + INTEGER ig, k, l, lmaxa(klon), lmix(klon) + REAL zsortie1d(klon) + ! CR: on remplace lmax(klon,klev+1) + INTEGER lmax(klon), lmin(klon), lentr(klon) + REAL linter(klon) + REAL zmix(klon), fracazmix(klon) + ! RC + REAL zmax(klon), zw, zz, zw2(klon, klev+1), ztva(klon, klev), zzz + + REAL zlev(klon, klev+1), zlay(klon, klev) + REAL zh(klon, klev), zdhadj(klon, klev) + REAL ztv(klon, klev) + REAL zu(klon, klev), zv(klon, klev), zo(klon, klev) + REAL wh(klon, klev+1) + REAL wu(klon, klev+1), wv(klon, klev+1), wo(klon, klev+1) + REAL zla(klon, klev+1) + REAL zwa(klon, klev+1) + REAL zld(klon, klev+1) + REAL zwd(klon, klev+1) + REAL zsortie(klon, klev) + REAL zva(klon, klev) + REAL zua(klon, klev) + REAL zoa(klon, klev) + + REAL zha(klon, klev) + REAL wa_moy(klon, klev+1) + REAL fraca(klon, klev+1) + REAL fracc(klon, klev+1) + REAL zf, zf2 + REAL thetath2(klon, klev), wth2(klon, klev) + ! common/comtherm/thetath2,wth2 + + REAL count_time + INTEGER ialt + + LOGICAL sorties + REAL rho(klon, klev), rhobarz(klon, klev+1), masse(klon, klev) + REAL zpspsk(klon, klev) + + ! real wmax(klon,klev),wmaxa(klon) + REAL wmax(klon), wmaxa(klon) + REAL wa(klon, klev, klev+1) + REAL wd(klon, klev+1) + REAL larg_part(klon, klev, klev+1) + REAL fracd(klon, klev+1) + REAL xxx(klon, klev+1) + REAL larg_cons(klon, klev+1) + REAL larg_detr(klon, klev+1) + REAL fm0(klon, klev+1), entr0(klon, klev), detr(klon, klev) + REAL pu_therm(klon, klev), pv_therm(klon, klev) + REAL fm(klon, klev+1), entr(klon, klev) + REAL fmc(klon, klev+1) + + ! CR:nouvelles variables + REAL f_star(klon, klev+1), entr_star(klon, klev) + REAL entr_star_tot(klon), entr_star2(klon) + REAL f(klon), f0(klon) + REAL zlevinter(klon) + LOGICAL first + DATA first/.FALSE./ + SAVE first + !$OMP THREADPRIVATE(first) + ! RC + + CHARACTER *2 str2 + CHARACTER *10 str10 + + CHARACTER (LEN=20) :: modname = 'thermcell_sec' + CHARACTER (LEN=80) :: abort_message + + LOGICAL vtest(klon), down + + EXTERNAL scopy + + INTEGER ncorrec, ll + SAVE ncorrec + DATA ncorrec/0/ + !$OMP THREADPRIVATE(ncorrec) + + + ! ----------------------------------------------------------------------- + ! initialisation: + ! --------------- + + sorties = .TRUE. + IF (ngrid/=klon) THEN + PRINT * + PRINT *, 'STOP dans convadj' + PRINT *, 'ngrid =', ngrid + PRINT *, 'klon =', klon + END IF + + ! ----------------------------------------------------------------------- + ! incrementation eventuelle de tendances precedentes: + ! --------------------------------------------------- + + ! print*,'0 OK convect8' + + DO l = 1, nlay + DO ig = 1, ngrid + zpspsk(ig, l) = (pplay(ig,l)/pplev(ig,1))**rkappa + zh(ig, l) = pt(ig, l)/zpspsk(ig, l) + zu(ig, l) = pu(ig, l) + zv(ig, l) = pv(ig, l) + zo(ig, l) = po(ig, l) + ztv(ig, l) = zh(ig, l)*(1.+0.61*zo(ig,l)) + END DO + END DO + + ! print*,'1 OK convect8' + ! -------------------- + + + ! + + + + + + + + + + + + + + ! wa, fraca, wd, fracd -------------------- zlev(2), rhobarz + ! wh,wt,wo ... + + ! + + + + + + + + + + + zh,zu,zv,zo,rho + + + ! -------------------- zlev(1) + ! \\\\\\\\\\\\\\\\\\\\ + + + + ! ----------------------------------------------------------------------- + ! Calcul des altitudes des couches + ! ----------------------------------------------------------------------- + + DO l = 2, nlay + DO ig = 1, ngrid + zlev(ig, l) = 0.5*(pphi(ig,l)+pphi(ig,l-1))/rg + END DO + END DO + DO ig = 1, ngrid + zlev(ig, 1) = 0. + zlev(ig, nlay+1) = (2.*pphi(ig,klev)-pphi(ig,klev-1))/rg + END DO + DO l = 1, nlay + DO ig = 1, ngrid + zlay(ig, l) = pphi(ig, l)/rg + END DO + END DO + + ! print*,'2 OK convect8' + ! ----------------------------------------------------------------------- + ! Calcul des densites + ! ----------------------------------------------------------------------- + + DO l = 1, nlay + DO ig = 1, ngrid + rho(ig, l) = pplay(ig, l)/(zpspsk(ig,l)*rd*zh(ig,l)) + END DO + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + rhobarz(ig, l) = 0.5*(rho(ig,l)+rho(ig,l-1)) + END DO + END DO + + DO k = 1, nlay + DO l = 1, nlay + 1 + DO ig = 1, ngrid + wa(ig, k, l) = 0. + END DO + END DO + END DO + + ! print*,'3 OK convect8' + ! ------------------------------------------------------------------ + ! Calcul de w2, quarre de w a partir de la cape + ! a partir de w2, on calcule wa, vitesse de l'ascendance + + ! ATTENTION: Dans cette version, pour cause d'economie de memoire, + ! w2 est stoke dans wa + + ! ATTENTION: dans convect8, on n'utilise le calcule des wa + ! independants par couches que pour calculer l'entrainement + ! a la base et la hauteur max de l'ascendance. + + ! Indicages: + ! l'ascendance provenant du niveau k traverse l'interface l avec + ! une vitesse wa(k,l). + + ! -------------------- + + ! + + + + + + + + + + + + ! wa(k,l) ---- -------------------- l + ! /\ + ! /||\ + + + + + + + + + + + ! || + ! || -------------------- + ! || + ! || + + + + + + + + + + + ! || + ! || -------------------- + ! ||__ + ! |___ + + + + + + + + + + k + + ! -------------------- + + + + ! ------------------------------------------------------------------ + + ! CR: ponderation entrainement des couches instables + ! def des entr_star tels que entr=f*entr_star + DO l = 1, klev + DO ig = 1, ngrid + entr_star(ig, l) = 0. + END DO + END DO + ! determination de la longueur de la couche d entrainement + DO ig = 1, ngrid + lentr(ig) = 1 + END DO + + ! on ne considere que les premieres couches instables + DO k = nlay - 2, 1, -1 + DO ig = 1, ngrid + IF (ztv(ig,k)>ztv(ig,k+1) .AND. ztv(ig,k+1)<=ztv(ig,k+2)) THEN + lentr(ig) = k + END IF + END DO + END DO + + ! determination du lmin: couche d ou provient le thermique + DO ig = 1, ngrid + lmin(ig) = 1 + END DO + DO ig = 1, ngrid + DO l = nlay, 2, -1 + IF (ztv(ig,l-1)>ztv(ig,l)) THEN + lmin(ig) = l - 1 + END IF + END DO + END DO + + ! definition de l'entrainement des couches + DO l = 1, klev - 1 + DO ig = 1, ngrid + IF (ztv(ig,l)>ztv(ig,l+1) .AND. l>=lmin(ig) .AND. l<=lentr(ig)) THEN + entr_star(ig, l) = (ztv(ig,l)-ztv(ig,l+1))** & ! s + ! (zlev(ig,l+1)-zlev(ig,l)) + sqrt(zlev(ig,l+1)) + END IF + END DO + END DO + ! pas de thermique si couche 1 stable + DO ig = 1, ngrid + IF (lmin(ig)>1) THEN + DO l = 1, klev + entr_star(ig, l) = 0. + END DO + END IF + END DO + ! calcul de l entrainement total + DO ig = 1, ngrid + entr_star_tot(ig) = 0. + END DO + DO ig = 1, ngrid + DO k = 1, klev + entr_star_tot(ig) = entr_star_tot(ig) + entr_star(ig, k) + END DO + END DO + + ! print*,'fin calcul entr_star' + DO k = 1, klev + DO ig = 1, ngrid + ztva(ig, k) = ztv(ig, k) + END DO + END DO + ! RC + ! print*,'7 OK convect8' + DO k = 1, klev + 1 + DO ig = 1, ngrid + zw2(ig, k) = 0. + fmc(ig, k) = 0. + ! CR + f_star(ig, k) = 0. + ! RC + larg_cons(ig, k) = 0. + larg_detr(ig, k) = 0. + wa_moy(ig, k) = 0. + END DO + END DO + + ! print*,'8 OK convect8' + DO ig = 1, ngrid + linter(ig) = 1. + lmaxa(ig) = 1 + lmix(ig) = 1 + wmaxa(ig) = 0. + END DO + + ! CR: + DO l = 1, nlay - 2 + DO ig = 1, ngrid + IF (ztv(ig,l)>ztv(ig,l+1) .AND. entr_star(ig,l)>1.E-10 .AND. & + zw2(ig,l)<1E-10) THEN + f_star(ig, l+1) = entr_star(ig, l) + ! test:calcul de dteta + zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* & + (zlev(ig,l+1)-zlev(ig,l))*0.4*pphi(ig, l)/(pphi(ig,l+1)-pphi(ig,l)) + larg_detr(ig, l) = 0. + ELSE IF ((zw2(ig,l)>=1E-10) .AND. (f_star(ig,l)+entr_star(ig, & + l)>1.E-10)) THEN + f_star(ig, l+1) = f_star(ig, l) + entr_star(ig, l) + ztva(ig, l) = (f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)*ztv(ig,l))/ & + f_star(ig, l+1) + zw2(ig, l+1) = zw2(ig, l)*(f_star(ig,l)/f_star(ig,l+1))**2 + & + 2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, l)*(zlev(ig,l+1)-zlev(ig,l)) + END IF + ! determination de zmax continu par interpolation lineaire + IF (zw2(ig,l+1)<0.) THEN + ! test + IF (abs(zw2(ig,l+1)-zw2(ig,l))<1E-10) THEN + ! print*,'pb linter' + END IF + linter(ig) = (l*(zw2(ig,l+1)-zw2(ig,l))-zw2(ig,l))/(zw2(ig,l+1)-zw2( & + ig,l)) + zw2(ig, l+1) = 0. + lmaxa(ig) = l + ELSE + IF (zw2(ig,l+1)<0.) THEN + ! print*,'pb1 zw2<0' + END IF + wa_moy(ig, l+1) = sqrt(zw2(ig,l+1)) + END IF + IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN + ! lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig) = l + 1 + wmaxa(ig) = wa_moy(ig, l+1) + END IF + END DO + END DO + ! print*,'fin calcul zw2' + + ! Calcul de la couche correspondant a la hauteur du thermique + DO ig = 1, ngrid + lmax(ig) = lentr(ig) + END DO + DO ig = 1, ngrid + DO l = nlay, lentr(ig) + 1, -1 + IF (zw2(ig,l)<=1.E-10) THEN + lmax(ig) = l - 1 + END IF + END DO + END DO + ! pas de thermique si couche 1 stable + DO ig = 1, ngrid + IF (lmin(ig)>1) THEN + lmax(ig) = 1 + lmin(ig) = 1 + END IF + END DO + + ! Determination de zw2 max + DO ig = 1, ngrid + wmax(ig) = 0. + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + IF (l<=lmax(ig)) THEN + IF (zw2(ig,l)<0.) THEN + ! print*,'pb2 zw2<0' + END IF + zw2(ig, l) = sqrt(zw2(ig,l)) + wmax(ig) = max(wmax(ig), zw2(ig,l)) + ELSE + zw2(ig, l) = 0. + END IF + END DO + END DO + + ! Longueur caracteristique correspondant a la hauteur des thermiques. + DO ig = 1, ngrid + zmax(ig) = 0. + zlevinter(ig) = zlev(ig, 1) + END DO + DO ig = 1, ngrid + ! calcul de zlevinter + zlevinter(ig) = (zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*linter(ig) + & + zlev(ig, lmax(ig)) - lmax(ig)*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig))) + zmax(ig) = max(zmax(ig), zlevinter(ig)-zlev(ig,lmin(ig))) + END DO + + ! print*,'avant fermeture' + ! Fermeture,determination de f + DO ig = 1, ngrid + entr_star2(ig) = 0. + END DO + DO ig = 1, ngrid + IF (entr_star_tot(ig)<1.E-10) THEN + f(ig) = 0. + ELSE + DO k = lmin(ig), lentr(ig) + entr_star2(ig) = entr_star2(ig) + entr_star(ig, k)**2/(rho(ig,k)*( & + zlev(ig,k+1)-zlev(ig,k))) + END DO + ! Nouvelle fermeture + f(ig) = wmax(ig)/(max(500.,zmax(ig))*r_aspect*entr_star2(ig))* & + entr_star_tot(ig) + ! test + ! if (first) then + ! f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig) + ! s *wmax(ig)) + ! endif + END IF + ! f0(ig)=f(ig) + ! first=.true. + END DO + ! print*,'apres fermeture' + + ! Calcul de l'entrainement + DO k = 1, klev + DO ig = 1, ngrid + entr(ig, k) = f(ig)*entr_star(ig, k) + END DO + END DO + ! CR:test pour entrainer moins que la masse + DO ig = 1, ngrid + DO l = 1, lentr(ig) + IF ((entr(ig,l)*ptimestep)>(0.9*masse(ig,l))) THEN + entr(ig, l+1) = entr(ig, l+1) + entr(ig, l) - & + 0.9*masse(ig, l)/ptimestep + entr(ig, l) = 0.9*masse(ig, l)/ptimestep + END IF + END DO + END DO + ! CR: fin test + ! Calcul des flux + DO ig = 1, ngrid + DO l = 1, lmax(ig) - 1 + fmc(ig, l+1) = fmc(ig, l) + entr(ig, l) + END DO + END DO + + ! RC + + + ! print*,'9 OK convect8' + ! print*,'WA1 ',wa_moy + + ! determination de l'indice du debut de la mixed layer ou w decroit + + ! calcul de la largeur de chaque ascendance dans le cas conservatif. + ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant + ! d'une couche est égale à la hauteur de la couche alimentante. + ! La vitesse maximale dans l'ascendance est aussi prise comme estimation + ! de la vitesse d'entrainement horizontal dans la couche alimentante. + + DO l = 2, nlay + DO ig = 1, ngrid + IF (l<=lmaxa(ig)) THEN + zw = max(wa_moy(ig,l), 1.E-10) + larg_cons(ig, l) = zmax(ig)*r_aspect*fmc(ig, l)/(rhobarz(ig,l)*zw) + END IF + END DO + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + IF (l<=lmaxa(ig)) THEN + ! if (idetr.eq.0) then + ! cette option est finalement en dur. + IF ((l_mix*zlev(ig,l))<0.) THEN + ! print*,'pb l_mix*zlev<0' + END IF + ! CR: test: nouvelle def de lambda + ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + IF (zw2(ig,l)>1.E-10) THEN + larg_detr(ig, l) = sqrt((l_mix/zw2(ig,l))*zlev(ig,l)) + ELSE + larg_detr(ig, l) = sqrt(l_mix*zlev(ig,l)) + END IF + ! RC + ! else if (idetr.eq.1) then + ! larg_detr(ig,l)=larg_cons(ig,l) + ! s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) + ! else if (idetr.eq.2) then + ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + ! s *sqrt(wa_moy(ig,l)) + ! else if (idetr.eq.4) then + ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + ! s *wa_moy(ig,l) + ! endif + END IF + END DO + END DO + + ! print*,'10 OK convect8' + ! print*,'WA2 ',wa_moy + ! calcul de la fraction de la maille concernée par l'ascendance en tenant + ! compte de l'epluchage du thermique. + + ! CR def de zmix continu (profil parabolique des vitesses) + DO ig = 1, ngrid + IF (lmix(ig)>1.) THEN + ! test + IF (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- & + (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- & + zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))- & + (zlev(ig,lmix(ig)))))>1E-10) THEN + + zmix(ig) = ((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)) & + )**2-(zlev(ig,lmix(ig)+1))**2)-(zw2(ig,lmix(ig))-zw2(ig, & + lmix(ig)+1))*((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))/ & + (2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- & + (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- & + zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) + ELSE + zmix(ig) = zlev(ig, lmix(ig)) + ! print*,'pb zmix' + END IF + ELSE + zmix(ig) = 0. + END IF + ! test + IF ((zmax(ig)-zmix(ig))<0.) THEN + zmix(ig) = 0.99*zmax(ig) + ! print*,'pb zmix>zmax' + END IF + END DO + + ! calcul du nouveau lmix correspondant + DO ig = 1, ngrid + DO l = 1, klev + IF (zmix(ig)>=zlev(ig,l) .AND. zmix(ig)1.) THEN + ! print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' + fraca(ig, l) = (larg_cons(ig,l)-larg_detr(ig,l))/(r_aspect*zmax(ig)) + ! test + fraca(ig, l) = max(fraca(ig,l), 0.) + fraca(ig, l) = min(fraca(ig,l), 0.5) + fracd(ig, l) = 1. - fraca(ig, l) + fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) + ELSE + ! wa_moy(ig,l)=0. + fraca(ig, l) = 0. + fracc(ig, l) = 0. + fracd(ig, l) = 1. + END IF + END DO + END DO + ! CR: calcul de fracazmix + DO ig = 1, ngrid + fracazmix(ig) = (fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ & + (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + & + fraca(ig, lmix(ig)) - zlev(ig, lmix(ig))*(fraca(ig,lmix(ig)+1)-fraca(ig & + ,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig))) + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + IF (larg_cons(ig,l)>1.) THEN + IF (l>lmix(ig)) THEN + ! test + IF (zmax(ig)-zmix(ig)<1.E-10) THEN + ! print*,'pb xxx' + xxx(ig, l) = (lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig)) + ELSE + xxx(ig, l) = (zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig)) + END IF + IF (idetr==0) THEN + fraca(ig, l) = fracazmix(ig) + ELSE IF (idetr==1) THEN + fraca(ig, l) = fracazmix(ig)*xxx(ig, l) + ELSE IF (idetr==2) THEN + fraca(ig, l) = fracazmix(ig)*(1.-(1.-xxx(ig,l))**2) + ELSE + fraca(ig, l) = fracazmix(ig)*xxx(ig, l)**2 + END IF + ! print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' + fraca(ig, l) = max(fraca(ig,l), 0.) + fraca(ig, l) = min(fraca(ig,l), 0.5) + fracd(ig, l) = 1. - fraca(ig, l) + fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) + END IF + END IF + END DO + END DO + + ! print*,'fin calcul fraca' + ! print*,'11 OK convect8' + ! print*,'Ea3 ',wa_moy + ! ------------------------------------------------------------------ + ! Calcul de fracd, wd + ! somme wa - wd = 0 + ! ------------------------------------------------------------------ + + + DO ig = 1, ngrid + fm(ig, 1) = 0. + fm(ig, nlay+1) = 0. + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + fm(ig, l) = fraca(ig, l)*wa_moy(ig, l)*rhobarz(ig, l) + ! CR:test + IF (entr(ig,l-1)<1E-10 .AND. fm(ig,l)>fm(ig,l-1) .AND. l>lmix(ig)) THEN + fm(ig, l) = fm(ig, l-1) + ! write(1,*)'ajustement fm, l',l + END IF + ! write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) + ! RC + END DO + DO ig = 1, ngrid + IF (fracd(ig,l)<0.1) THEN + abort_message = 'fracd trop petit' + CALL abort_physic(modname, abort_message, 1) + ELSE + ! vitesse descendante "diagnostique" + wd(ig, l) = fm(ig, l)/(fracd(ig,l)*rhobarz(ig,l)) + END IF + END DO + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg + END DO + END DO + + ! print*,'12 OK convect8' + ! print*,'WA4 ',wa_moy + ! c------------------------------------------------------------------ + ! calcul du transport vertical + ! ------------------------------------------------------------------ + + GO TO 4444 + ! print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep + DO l = 2, nlay - 1 + DO ig = 1, ngrid + IF (fm(ig,l+1)*ptimestep>masse(ig,l) .AND. fm(ig,l+1)*ptimestep>masse( & + ig,l+1)) THEN + ! print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' + ! s ,fm(ig,l+1)*ptimestep + ! s ,' M=',masse(ig,l),masse(ig,l+1) + END IF + END DO + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + IF (entr(ig,l)*ptimestep>masse(ig,l)) THEN + ! print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' + ! s ,entr(ig,l)*ptimestep + ! s ,' M=',masse(ig,l) + END IF + END DO + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + IF (.NOT. fm(ig,l)>=0. .OR. .NOT. fm(ig,l)<=10.) THEN + ! print*,'WARN!!! fm exagere ig=',ig,' l=',l + ! s ,' FM=',fm(ig,l) + END IF + IF (.NOT. masse(ig,l)>=1.E-10 .OR. .NOT. masse(ig,l)<=1.E4) THEN + ! print*,'WARN!!! masse exagere ig=',ig,' l=',l + ! s ,' M=',masse(ig,l) + ! print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', + ! s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) + ! print*,'zlev(ig,l+1),zlev(ig,l)' + ! s ,zlev(ig,l+1),zlev(ig,l) + ! print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' + ! s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) + END IF + IF (.NOT. entr(ig,l)>=0. .OR. .NOT. entr(ig,l)<=10.) THEN + ! print*,'WARN!!! entr exagere ig=',ig,' l=',l + ! s ,' E=',entr(ig,l) + END IF + END DO + END DO + +4444 CONTINUE + + ! CR:redefinition du entr + DO l = 1, nlay + DO ig = 1, ngrid + detr(ig, l) = fm(ig, l) + entr(ig, l) - fm(ig, l+1) + IF (detr(ig,l)<0.) THEN + entr(ig, l) = entr(ig, l) - detr(ig, l) + detr(ig, l) = 0. + ! print*,'WARNING !!! detrainement negatif ',ig,l + END IF + END DO + END DO + ! RC + IF (w2di==1) THEN + fm0 = fm0 + ptimestep*(fm-fm0)/tho + entr0 = entr0 + ptimestep*(entr-entr0)/tho + ELSE + fm0 = fm + entr0 = entr + END IF + + IF (1==1) THEN + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zh, zdhadj, & + zha) + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zo, pdoadj, & + zoa) + ELSE + CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, & + zdhadj, zha) + CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, & + pdoadj, zoa) + END IF + + IF (1==0) THEN + CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, & + zu, zv, pduadj, pdvadj, zua, zva) + ELSE + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, & + zua) + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, & + zva) + END IF + + DO l = 1, nlay + DO ig = 1, ngrid + zf = 0.5*(fracc(ig,l)+fracc(ig,l+1)) + zf2 = zf/(1.-zf) + thetath2(ig, l) = zf2*(zha(ig,l)-zh(ig,l))**2 + wth2(ig, l) = zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 + END DO + END DO + + + + ! print*,'13 OK convect8' + ! print*,'WA5 ',wa_moy + DO l = 1, nlay + DO ig = 1, ngrid + pdtadj(ig, l) = zdhadj(ig, l)*zpspsk(ig, l) + END DO + END DO + + + ! do l=1,nlay + ! do ig=1,ngrid + ! if(abs(pdtadj(ig,l))*86400..gt.500.) then + ! print*,'WARN!!! ig=',ig,' l=',l + ! s ,' pdtadj=',pdtadj(ig,l) + ! endif + ! if(abs(pdoadj(ig,l))*86400..gt.1.) then + ! print*,'WARN!!! ig=',ig,' l=',l + ! s ,' pdoadj=',pdoadj(ig,l) + ! endif + ! enddo + ! enddo + + ! print*,'14 OK convect8' + ! ------------------------------------------------------------------ + ! Calculs pour les sorties + ! ------------------------------------------------------------------ + + RETURN +END SUBROUTINE thermcell_sec + +SUBROUTINE calcul_sec(ngrid, nlay, ptimestep, pplay, pplev, pphi, zlev, pu, & + pv, pt, po, zmax, wmax, zw2, lmix & ! s + ! ,pu_therm,pv_therm + , r_aspect, l_mix, w2di, tho) + + USE dimphy + IMPLICIT NONE + + ! ======================================================================= + + ! Calcul du transport verticale dans la couche limite en presence + ! de "thermiques" explicitement representes + + ! Réécriture à partir d'un listing papier à Habas, le 14/02/00 + + ! le thermique est supposé homogène et dissipé par mélange avec + ! son environnement. la longueur l_mix contrôle l'efficacité du + ! mélange + + ! Le calcul du transport des différentes espèces se fait en prenant + ! en compte: + ! 1. un flux de masse montant + ! 2. un flux de masse descendant + ! 3. un entrainement + ! 4. un detrainement + + ! ======================================================================= + + ! ----------------------------------------------------------------------- + ! declarations: + ! ------------- + + include "YOMCST.h" + + ! arguments: + ! ---------- + + INTEGER ngrid, nlay, w2di + REAL tho + REAL ptimestep, l_mix, r_aspect + REAL pt(ngrid, nlay), pdtadj(ngrid, nlay) + REAL pu(ngrid, nlay), pduadj(ngrid, nlay) + REAL pv(ngrid, nlay), pdvadj(ngrid, nlay) + REAL po(ngrid, nlay), pdoadj(ngrid, nlay) + REAL pplay(ngrid, nlay), pplev(ngrid, nlay+1) + REAL pphi(ngrid, nlay) + + INTEGER idetr + SAVE idetr + DATA idetr/3/ + !$OMP THREADPRIVATE(idetr) + ! local: + ! ------ + + INTEGER ig, k, l, lmaxa(klon), lmix(klon) + REAL zsortie1d(klon) + ! CR: on remplace lmax(klon,klev+1) + INTEGER lmax(klon), lmin(klon), lentr(klon) + REAL linter(klon) + REAL zmix(klon), fracazmix(klon) + ! RC + REAL zmax(klon), zw, zw2(klon, klev+1), ztva(klon, klev) + + REAL zlev(klon, klev+1), zlay(klon, klev) + REAL zh(klon, klev), zdhadj(klon, klev) + REAL ztv(klon, klev) + REAL zu(klon, klev), zv(klon, klev), zo(klon, klev) + REAL wh(klon, klev+1) + REAL wu(klon, klev+1), wv(klon, klev+1), wo(klon, klev+1) + REAL zla(klon, klev+1) + REAL zwa(klon, klev+1) + REAL zld(klon, klev+1) + ! real zwd(klon,klev+1) + REAL zsortie(klon, klev) + REAL zva(klon, klev) + REAL zua(klon, klev) + REAL zoa(klon, klev) + + REAL zha(klon, klev) + REAL wa_moy(klon, klev+1) + REAL fraca(klon, klev+1) + REAL fracc(klon, klev+1) + REAL zf, zf2 + REAL thetath2(klon, klev), wth2(klon, klev) + ! common/comtherm/thetath2,wth2 + + REAL count_time + ! integer isplit,nsplit + INTEGER isplit, nsplit, ialt + PARAMETER (nsplit=10) + DATA isplit/0/ + SAVE isplit + !$OMP THREADPRIVATE(isplit) + + LOGICAL sorties + REAL rho(klon, klev), rhobarz(klon, klev+1), masse(klon, klev) + REAL zpspsk(klon, klev) + + ! real wmax(klon,klev),wmaxa(klon) + REAL wmax(klon), wmaxa(klon) + REAL wa(klon, klev, klev+1) + REAL wd(klon, klev+1) + REAL larg_part(klon, klev, klev+1) + REAL fracd(klon, klev+1) + REAL xxx(klon, klev+1) + REAL larg_cons(klon, klev+1) + REAL larg_detr(klon, klev+1) + REAL fm0(klon, klev+1), entr0(klon, klev), detr(klon, klev) + REAL pu_therm(klon, klev), pv_therm(klon, klev) + REAL fm(klon, klev+1), entr(klon, klev) + REAL fmc(klon, klev+1) + + ! CR:nouvelles variables + REAL f_star(klon, klev+1), entr_star(klon, klev) + REAL entr_star_tot(klon), entr_star2(klon) + REAL zalim(klon) + INTEGER lalim(klon) + REAL norme(klon) + REAL f(klon), f0(klon) + REAL zlevinter(klon) + LOGICAL therm + LOGICAL first + DATA first/.FALSE./ + SAVE first + !$OMP THREADPRIVATE(first) + ! RC + + CHARACTER *2 str2 + CHARACTER *10 str10 + + CHARACTER (LEN=20) :: modname = 'calcul_sec' + CHARACTER (LEN=80) :: abort_message + + + ! LOGICAL vtest(klon),down + + EXTERNAL scopy + + INTEGER ncorrec + SAVE ncorrec + DATA ncorrec/0/ + !$OMP THREADPRIVATE(ncorrec) + + + ! ----------------------------------------------------------------------- + ! initialisation: + ! --------------- + + sorties = .TRUE. + IF (ngrid/=klon) THEN + PRINT * + PRINT *, 'STOP dans convadj' + PRINT *, 'ngrid =', ngrid + PRINT *, 'klon =', klon + END IF + + ! ----------------------------------------------------------------------- + ! incrementation eventuelle de tendances precedentes: + ! --------------------------------------------------- + + ! print*,'0 OK convect8' + + DO l = 1, nlay + DO ig = 1, ngrid + zpspsk(ig, l) = (pplay(ig,l)/pplev(ig,1))**rkappa + zh(ig, l) = pt(ig, l)/zpspsk(ig, l) + zu(ig, l) = pu(ig, l) + zv(ig, l) = pv(ig, l) + zo(ig, l) = po(ig, l) + ztv(ig, l) = zh(ig, l)*(1.+0.61*zo(ig,l)) + END DO + END DO + + ! print*,'1 OK convect8' + ! -------------------- + + + ! + + + + + + + + + + + + + + ! wa, fraca, wd, fracd -------------------- zlev(2), rhobarz + ! wh,wt,wo ... + + ! + + + + + + + + + + + zh,zu,zv,zo,rho + + + ! -------------------- zlev(1) + ! \\\\\\\\\\\\\\\\\\\\ + + + + ! ----------------------------------------------------------------------- + ! Calcul des altitudes des couches + ! ----------------------------------------------------------------------- + + DO l = 2, nlay + DO ig = 1, ngrid + zlev(ig, l) = 0.5*(pphi(ig,l)+pphi(ig,l-1))/rg + END DO + END DO + DO ig = 1, ngrid + zlev(ig, 1) = 0. + zlev(ig, nlay+1) = (2.*pphi(ig,klev)-pphi(ig,klev-1))/rg + END DO + DO l = 1, nlay + DO ig = 1, ngrid + zlay(ig, l) = pphi(ig, l)/rg + END DO + END DO + + ! print*,'2 OK convect8' + ! ----------------------------------------------------------------------- + ! Calcul des densites + ! ----------------------------------------------------------------------- + + DO l = 1, nlay + DO ig = 1, ngrid + rho(ig, l) = pplay(ig, l)/(zpspsk(ig,l)*rd*zh(ig,l)) + END DO + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + rhobarz(ig, l) = 0.5*(rho(ig,l)+rho(ig,l-1)) + END DO + END DO + + DO k = 1, nlay + DO l = 1, nlay + 1 + DO ig = 1, ngrid + wa(ig, k, l) = 0. + END DO + END DO + END DO + + ! print*,'3 OK convect8' + ! ------------------------------------------------------------------ + ! Calcul de w2, quarre de w a partir de la cape + ! a partir de w2, on calcule wa, vitesse de l'ascendance + + ! ATTENTION: Dans cette version, pour cause d'economie de memoire, + ! w2 est stoke dans wa + + ! ATTENTION: dans convect8, on n'utilise le calcule des wa + ! independants par couches que pour calculer l'entrainement + ! a la base et la hauteur max de l'ascendance. + + ! Indicages: + ! l'ascendance provenant du niveau k traverse l'interface l avec + ! une vitesse wa(k,l). + + ! -------------------- + + ! + + + + + + + + + + + + ! wa(k,l) ---- -------------------- l + ! /\ + ! /||\ + + + + + + + + + + + ! || + ! || -------------------- + ! || + ! || + + + + + + + + + + + ! || + ! || -------------------- + ! ||__ + ! |___ + + + + + + + + + + k + + ! -------------------- + + + + ! ------------------------------------------------------------------ + + ! CR: ponderation entrainement des couches instables + ! def des entr_star tels que entr=f*entr_star + DO l = 1, klev + DO ig = 1, ngrid + entr_star(ig, l) = 0. + END DO + END DO + ! determination de la longueur de la couche d entrainement + DO ig = 1, ngrid + lentr(ig) = 1 + END DO + + ! on ne considere que les premieres couches instables + therm = .FALSE. + DO k = nlay - 2, 1, -1 + DO ig = 1, ngrid + IF (ztv(ig,k)>ztv(ig,k+1) .AND. ztv(ig,k+1)<=ztv(ig,k+2)) THEN + lentr(ig) = k + 1 + therm = .TRUE. + END IF + END DO + END DO + ! limitation de la valeur du lentr + ! do ig=1,ngrid + ! lentr(ig)=min(5,lentr(ig)) + ! enddo + ! determination du lmin: couche d ou provient le thermique + DO ig = 1, ngrid + lmin(ig) = 1 + END DO + DO ig = 1, ngrid + DO l = nlay, 2, -1 + IF (ztv(ig,l-1)>ztv(ig,l)) THEN + lmin(ig) = l - 1 + END IF + END DO + END DO + ! initialisations + DO ig = 1, ngrid + zalim(ig) = 0. + norme(ig) = 0. + lalim(ig) = 1 + END DO + DO k = 1, klev - 1 + DO ig = 1, ngrid + zalim(ig) = zalim(ig) + zlev(ig, k)*max(0., (ztv(ig,k)-ztv(ig, & + k+1))/(zlev(ig,k+1)-zlev(ig,k))) + ! s *(zlev(ig,k+1)-zlev(ig,k)) + norme(ig) = norme(ig) + max(0., (ztv(ig,k)-ztv(ig,k+1))/(zlev(ig, & + k+1)-zlev(ig,k))) + ! s *(zlev(ig,k+1)-zlev(ig,k)) + END DO + END DO + DO ig = 1, ngrid + IF (norme(ig)>1.E-10) THEN + zalim(ig) = max(10.*zalim(ig)/norme(ig), zlev(ig,2)) + ! zalim(ig)=min(zalim(ig),zlev(ig,lentr(ig))) + END IF + END DO + ! détermination du lalim correspondant + DO k = 1, klev - 1 + DO ig = 1, ngrid + IF ((zalim(ig)>zlev(ig,k)) .AND. (zalim(ig)<=zlev(ig,k+1))) THEN + lalim(ig) = k + END IF + END DO + END DO + + ! definition de l'entrainement des couches + DO l = 1, klev - 1 + DO ig = 1, ngrid + IF (ztv(ig,l)>ztv(ig,l+1) .AND. l>=lmin(ig) .AND. lztv(ig,l+1) .AND. l>=lmin(ig) .AND. l<=lalim(ig) .AND. & + zalim(ig)>1.E-10) THEN + ! if (l.le.lentr(ig)) then + ! entr_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1) + ! s /zalim(ig)))**(3./2.) + ! write(10,*)zlev(ig,l),entr_star(ig,l) + END IF + END DO + END DO + ! endif + ! pas de thermique si couche 1 stable + DO ig = 1, ngrid + IF (lmin(ig)>5) THEN + DO l = 1, klev + entr_star(ig, l) = 0. + END DO + END IF + END DO + ! calcul de l entrainement total + DO ig = 1, ngrid + entr_star_tot(ig) = 0. + END DO + DO ig = 1, ngrid + DO k = 1, klev + entr_star_tot(ig) = entr_star_tot(ig) + entr_star(ig, k) + END DO + END DO + ! Calcul entrainement normalise + DO ig = 1, ngrid + IF (entr_star_tot(ig)>1.E-10) THEN + ! do l=1,lentr(ig) + DO l = 1, klev + ! def possibles pour entr_star: zdthetadz, dthetadz, zdtheta + entr_star(ig, l) = entr_star(ig, l)/entr_star_tot(ig) + END DO + END IF + END DO + + ! print*,'fin calcul entr_star' + DO k = 1, klev + DO ig = 1, ngrid + ztva(ig, k) = ztv(ig, k) + END DO + END DO + ! RC + ! print*,'7 OK convect8' + DO k = 1, klev + 1 + DO ig = 1, ngrid + zw2(ig, k) = 0. + fmc(ig, k) = 0. + ! CR + f_star(ig, k) = 0. + ! RC + larg_cons(ig, k) = 0. + larg_detr(ig, k) = 0. + wa_moy(ig, k) = 0. + END DO + END DO + + ! print*,'8 OK convect8' + DO ig = 1, ngrid + linter(ig) = 1. + lmaxa(ig) = 1 + lmix(ig) = 1 + wmaxa(ig) = 0. + END DO + + ! CR: + DO l = 1, nlay - 2 + DO ig = 1, ngrid + IF (ztv(ig,l)>ztv(ig,l+1) .AND. entr_star(ig,l)>1.E-10 .AND. & + zw2(ig,l)<1E-10) THEN + f_star(ig, l+1) = entr_star(ig, l) + ! test:calcul de dteta + zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* & + (zlev(ig,l+1)-zlev(ig,l))*0.4*pphi(ig, l)/(pphi(ig,l+1)-pphi(ig,l)) + larg_detr(ig, l) = 0. + ELSE IF ((zw2(ig,l)>=1E-10) .AND. (f_star(ig,l)+entr_star(ig, & + l)>1.E-10)) THEN + f_star(ig, l+1) = f_star(ig, l) + entr_star(ig, l) + ztva(ig, l) = (f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)*ztv(ig,l))/ & + f_star(ig, l+1) + zw2(ig, l+1) = zw2(ig, l)*(f_star(ig,l)/f_star(ig,l+1))**2 + & + 2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, l)*(zlev(ig,l+1)-zlev(ig,l)) + END IF + ! determination de zmax continu par interpolation lineaire + IF (zw2(ig,l+1)<0.) THEN + ! test + IF (abs(zw2(ig,l+1)-zw2(ig,l))<1E-10) THEN + ! print*,'pb linter' + END IF + linter(ig) = (l*(zw2(ig,l+1)-zw2(ig,l))-zw2(ig,l))/(zw2(ig,l+1)-zw2( & + ig,l)) + zw2(ig, l+1) = 0. + lmaxa(ig) = l + ELSE + IF (zw2(ig,l+1)<0.) THEN + ! print*,'pb1 zw2<0' + END IF + wa_moy(ig, l+1) = sqrt(zw2(ig,l+1)) + END IF + IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN + ! lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig) = l + 1 + wmaxa(ig) = wa_moy(ig, l+1) + END IF + END DO + END DO + ! print*,'fin calcul zw2' + + ! Calcul de la couche correspondant a la hauteur du thermique + DO ig = 1, ngrid + lmax(ig) = lentr(ig) + ! lmax(ig)=lalim(ig) + END DO + DO ig = 1, ngrid + DO l = nlay, lentr(ig) + 1, -1 + ! do l=nlay,lalim(ig)+1,-1 + IF (zw2(ig,l)<=1.E-10) THEN + lmax(ig) = l - 1 + END IF + END DO + END DO + ! pas de thermique si couche 1 stable + DO ig = 1, ngrid + IF (lmin(ig)>5) THEN + lmax(ig) = 1 + lmin(ig) = 1 + lentr(ig) = 1 + lalim(ig) = 1 + END IF + END DO + + ! Determination de zw2 max + DO ig = 1, ngrid + wmax(ig) = 0. + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + IF (l<=lmax(ig)) THEN + IF (zw2(ig,l)<0.) THEN + ! print*,'pb2 zw2<0' + END IF + zw2(ig, l) = sqrt(zw2(ig,l)) + wmax(ig) = max(wmax(ig), zw2(ig,l)) + ELSE + zw2(ig, l) = 0. + END IF + END DO + END DO + + ! Longueur caracteristique correspondant a la hauteur des thermiques. + DO ig = 1, ngrid + zmax(ig) = 0. + zlevinter(ig) = zlev(ig, 1) + END DO + DO ig = 1, ngrid + ! calcul de zlevinter + zlevinter(ig) = (zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*linter(ig) + & + zlev(ig, lmax(ig)) - lmax(ig)*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig))) + zmax(ig) = max(zmax(ig), zlevinter(ig)-zlev(ig,lmin(ig))) + END DO + DO ig = 1, ngrid + ! write(8,*)zmax(ig),lmax(ig),lentr(ig),lmin(ig) + END DO + ! on stope après les calculs de zmax et wmax + RETURN + + ! print*,'avant fermeture' + ! Fermeture,determination de f + ! Attention! entrainement normalisé ou pas? + DO ig = 1, ngrid + entr_star2(ig) = 0. + END DO + DO ig = 1, ngrid + IF (entr_star_tot(ig)<1.E-10) THEN + f(ig) = 0. + ELSE + DO k = lmin(ig), lentr(ig) + ! do k=lmin(ig),lalim(ig) + entr_star2(ig) = entr_star2(ig) + entr_star(ig, k)**2/(rho(ig,k)*( & + zlev(ig,k+1)-zlev(ig,k))) + END DO + ! Nouvelle fermeture + f(ig) = wmax(ig)/(max(500.,zmax(ig))*r_aspect*entr_star2(ig)) + ! s *entr_star_tot(ig) + ! test + ! if (first) then + f(ig) = f(ig) + (f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)*wmax(ig)) + ! endif + END IF + f0(ig) = f(ig) + ! first=.true. + END DO + ! print*,'apres fermeture' + ! on stoppe après la fermeture + RETURN + ! Calcul de l'entrainement + DO k = 1, klev + DO ig = 1, ngrid + entr(ig, k) = f(ig)*entr_star(ig, k) + END DO + END DO + ! on stoppe après le calcul de entr + ! RETURN + ! CR:test pour entrainer moins que la masse + ! do ig=1,ngrid + ! do l=1,lentr(ig) + ! if ((entr(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then + ! entr(ig,l+1)=entr(ig,l+1)+entr(ig,l) + ! s -0.9*masse(ig,l)/ptimestep + ! entr(ig,l)=0.9*masse(ig,l)/ptimestep + ! endif + ! enddo + ! enddo + ! CR: fin test + ! Calcul des flux + DO ig = 1, ngrid + DO l = 1, lmax(ig) - 1 + fmc(ig, l+1) = fmc(ig, l) + entr(ig, l) + END DO + END DO + + ! RC + + + ! print*,'9 OK convect8' + ! print*,'WA1 ',wa_moy + + ! determination de l'indice du debut de la mixed layer ou w decroit + + ! calcul de la largeur de chaque ascendance dans le cas conservatif. + ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant + ! d'une couche est égale à la hauteur de la couche alimentante. + ! La vitesse maximale dans l'ascendance est aussi prise comme estimation + ! de la vitesse d'entrainement horizontal dans la couche alimentante. + + DO l = 2, nlay + DO ig = 1, ngrid + IF (l<=lmaxa(ig)) THEN + zw = max(wa_moy(ig,l), 1.E-10) + larg_cons(ig, l) = zmax(ig)*r_aspect*fmc(ig, l)/(rhobarz(ig,l)*zw) + END IF + END DO + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + IF (l<=lmaxa(ig)) THEN + ! if (idetr.eq.0) then + ! cette option est finalement en dur. + IF ((l_mix*zlev(ig,l))<0.) THEN + ! print*,'pb l_mix*zlev<0' + END IF + ! CR: test: nouvelle def de lambda + ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + IF (zw2(ig,l)>1.E-10) THEN + larg_detr(ig, l) = sqrt((l_mix/zw2(ig,l))*zlev(ig,l)) + ELSE + larg_detr(ig, l) = sqrt(l_mix*zlev(ig,l)) + END IF + ! RC + ! else if (idetr.eq.1) then + ! larg_detr(ig,l)=larg_cons(ig,l) + ! s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) + ! else if (idetr.eq.2) then + ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + ! s *sqrt(wa_moy(ig,l)) + ! else if (idetr.eq.4) then + ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + ! s *wa_moy(ig,l) + ! endif + END IF + END DO + END DO + + ! print*,'10 OK convect8' + ! print*,'WA2 ',wa_moy + ! calcul de la fraction de la maille concernée par l'ascendance en tenant + ! compte de l'epluchage du thermique. + + ! CR def de zmix continu (profil parabolique des vitesses) + DO ig = 1, ngrid + IF (lmix(ig)>1.) THEN + ! test + IF (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- & + (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- & + zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))- & + (zlev(ig,lmix(ig)))))>1E-10) THEN + + zmix(ig) = ((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)) & + )**2-(zlev(ig,lmix(ig)+1))**2)-(zw2(ig,lmix(ig))-zw2(ig, & + lmix(ig)+1))*((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))/ & + (2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- & + (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- & + zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) + ELSE + zmix(ig) = zlev(ig, lmix(ig)) + ! print*,'pb zmix' + END IF + ELSE + zmix(ig) = 0. + END IF + ! test + IF ((zmax(ig)-zmix(ig))<0.) THEN + zmix(ig) = 0.99*zmax(ig) + ! print*,'pb zmix>zmax' + END IF + END DO + + ! calcul du nouveau lmix correspondant + DO ig = 1, ngrid + DO l = 1, klev + IF (zmix(ig)>=zlev(ig,l) .AND. zmix(ig)1.) THEN + ! print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' + fraca(ig, l) = (larg_cons(ig,l)-larg_detr(ig,l))/(r_aspect*zmax(ig)) + ! test + fraca(ig, l) = max(fraca(ig,l), 0.) + fraca(ig, l) = min(fraca(ig,l), 0.5) + fracd(ig, l) = 1. - fraca(ig, l) + fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) + ELSE + ! wa_moy(ig,l)=0. + fraca(ig, l) = 0. + fracc(ig, l) = 0. + fracd(ig, l) = 1. + END IF + END DO + END DO + ! CR: calcul de fracazmix + DO ig = 1, ngrid + fracazmix(ig) = (fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ & + (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + & + fraca(ig, lmix(ig)) - zlev(ig, lmix(ig))*(fraca(ig,lmix(ig)+1)-fraca(ig & + ,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig))) + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + IF (larg_cons(ig,l)>1.) THEN + IF (l>lmix(ig)) THEN + ! test + IF (zmax(ig)-zmix(ig)<1.E-10) THEN + ! print*,'pb xxx' + xxx(ig, l) = (lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig)) + ELSE + xxx(ig, l) = (zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig)) + END IF + IF (idetr==0) THEN + fraca(ig, l) = fracazmix(ig) + ELSE IF (idetr==1) THEN + fraca(ig, l) = fracazmix(ig)*xxx(ig, l) + ELSE IF (idetr==2) THEN + fraca(ig, l) = fracazmix(ig)*(1.-(1.-xxx(ig,l))**2) + ELSE + fraca(ig, l) = fracazmix(ig)*xxx(ig, l)**2 + END IF + ! print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' + fraca(ig, l) = max(fraca(ig,l), 0.) + fraca(ig, l) = min(fraca(ig,l), 0.5) + fracd(ig, l) = 1. - fraca(ig, l) + fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) + END IF + END IF + END DO + END DO + + ! print*,'fin calcul fraca' + ! print*,'11 OK convect8' + ! print*,'Ea3 ',wa_moy + ! ------------------------------------------------------------------ + ! Calcul de fracd, wd + ! somme wa - wd = 0 + ! ------------------------------------------------------------------ + + + DO ig = 1, ngrid + fm(ig, 1) = 0. + fm(ig, nlay+1) = 0. + END DO + + DO l = 2, nlay + DO ig = 1, ngrid + fm(ig, l) = fraca(ig, l)*wa_moy(ig, l)*rhobarz(ig, l) + ! CR:test + IF (entr(ig,l-1)<1E-10 .AND. fm(ig,l)>fm(ig,l-1) .AND. l>lmix(ig)) THEN + fm(ig, l) = fm(ig, l-1) + ! write(1,*)'ajustement fm, l',l + END IF + ! write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) + ! RC + END DO + DO ig = 1, ngrid + IF (fracd(ig,l)<0.1) THEN + abort_message = 'fracd trop petit' + CALL abort_physic(modname, abort_message, 1) + + ELSE + ! vitesse descendante "diagnostique" + wd(ig, l) = fm(ig, l)/(fracd(ig,l)*rhobarz(ig,l)) + END IF + END DO + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg + END DO + END DO + + ! print*,'12 OK convect8' + ! print*,'WA4 ',wa_moy + ! c------------------------------------------------------------------ + ! calcul du transport vertical + ! ------------------------------------------------------------------ + + GO TO 4444 + ! print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep + DO l = 2, nlay - 1 + DO ig = 1, ngrid + IF (fm(ig,l+1)*ptimestep>masse(ig,l) .AND. fm(ig,l+1)*ptimestep>masse( & + ig,l+1)) THEN + ! print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' + ! s ,fm(ig,l+1)*ptimestep + ! s ,' M=',masse(ig,l),masse(ig,l+1) + END IF + END DO + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + IF (entr(ig,l)*ptimestep>masse(ig,l)) THEN + ! print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' + ! s ,entr(ig,l)*ptimestep + ! s ,' M=',masse(ig,l) + END IF + END DO + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + IF (.NOT. fm(ig,l)>=0. .OR. .NOT. fm(ig,l)<=10.) THEN + ! print*,'WARN!!! fm exagere ig=',ig,' l=',l + ! s ,' FM=',fm(ig,l) + END IF + IF (.NOT. masse(ig,l)>=1.E-10 .OR. .NOT. masse(ig,l)<=1.E4) THEN + ! print*,'WARN!!! masse exagere ig=',ig,' l=',l + ! s ,' M=',masse(ig,l) + ! print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', + ! s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) + ! print*,'zlev(ig,l+1),zlev(ig,l)' + ! s ,zlev(ig,l+1),zlev(ig,l) + ! print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' + ! s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) + END IF + IF (.NOT. entr(ig,l)>=0. .OR. .NOT. entr(ig,l)<=10.) THEN + ! print*,'WARN!!! entr exagere ig=',ig,' l=',l + ! s ,' E=',entr(ig,l) + END IF + END DO + END DO + +4444 CONTINUE + + ! CR:redefinition du entr + DO l = 1, nlay + DO ig = 1, ngrid + detr(ig, l) = fm(ig, l) + entr(ig, l) - fm(ig, l+1) + IF (detr(ig,l)<0.) THEN + ! entr(ig,l)=entr(ig,l)-detr(ig,l) + fm(ig, l+1) = fm(ig, l) + entr(ig, l) + detr(ig, l) = 0. + ! print*,'WARNING !!! detrainement negatif ',ig,l + END IF + END DO + END DO + ! RC + IF (w2di==1) THEN + fm0 = fm0 + ptimestep*(fm-fm0)/tho + entr0 = entr0 + ptimestep*(entr-entr0)/tho + ELSE + fm0 = fm + entr0 = entr + END IF + + IF (1==1) THEN + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zh, zdhadj, & + zha) + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zo, pdoadj, & + zoa) + ELSE + CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, & + zdhadj, zha) + CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, & + pdoadj, zoa) + END IF + + IF (1==0) THEN + CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, & + zu, zv, pduadj, pdvadj, zua, zva) + ELSE + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, & + zua) + CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, & + zva) + END IF + + DO l = 1, nlay + DO ig = 1, ngrid + zf = 0.5*(fracc(ig,l)+fracc(ig,l+1)) + zf2 = zf/(1.-zf) + thetath2(ig, l) = zf2*(zha(ig,l)-zh(ig,l))**2 + wth2(ig, l) = zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 + END DO + END DO + + + + ! print*,'13 OK convect8' + ! print*,'WA5 ',wa_moy + DO l = 1, nlay + DO ig = 1, ngrid + pdtadj(ig, l) = zdhadj(ig, l)*zpspsk(ig, l) + END DO + END DO + + + ! do l=1,nlay + ! do ig=1,ngrid + ! if(abs(pdtadj(ig,l))*86400..gt.500.) then + ! print*,'WARN!!! ig=',ig,' l=',l + ! s ,' pdtadj=',pdtadj(ig,l) + ! endif + ! if(abs(pdoadj(ig,l))*86400..gt.1.) then + ! print*,'WARN!!! ig=',ig,' l=',l + ! s ,' pdoadj=',pdoadj(ig,l) + ! endif + ! enddo + ! enddo + + ! print*,'14 OK convect8' + ! ------------------------------------------------------------------ + ! Calculs pour les sorties + ! ------------------------------------------------------------------ + + IF (sorties) THEN + DO l = 1, nlay + DO ig = 1, ngrid + zla(ig, l) = (1.-fracd(ig,l))*zmax(ig) + zld(ig, l) = fracd(ig, l)*zmax(ig) + IF (1.-fracd(ig,l)>1.E-10) zwa(ig, l) = wd(ig, l)*fracd(ig, l)/ & + (1.-fracd(ig,l)) + END DO + END DO + + ! deja fait + ! do l=1,nlay + ! do ig=1,ngrid + ! detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) + ! if (detr(ig,l).lt.0.) then + ! entr(ig,l)=entr(ig,l)-detr(ig,l) + ! detr(ig,l)=0. + ! print*,'WARNING !!! detrainement negatif ',ig,l + ! endif + ! enddo + ! enddo + + ! print*,'15 OK convect8' + + isplit = isplit + 1 + + + ! #define und + GO TO 123 +#ifdef und + CALL writeg1d(1, nlay, wd, 'wd ', 'wd ') + CALL writeg1d(1, nlay, zwa, 'wa ', 'wa ') + CALL writeg1d(1, nlay, fracd, 'fracd ', 'fracd ') + CALL writeg1d(1, nlay, fraca, 'fraca ', 'fraca ') + CALL writeg1d(1, nlay, wa_moy, 'wam ', 'wam ') + CALL writeg1d(1, nlay, zla, 'la ', 'la ') + CALL writeg1d(1, nlay, zld, 'ld ', 'ld ') + CALL writeg1d(1, nlay, pt, 'pt ', 'pt ') + CALL writeg1d(1, nlay, zh, 'zh ', 'zh ') + CALL writeg1d(1, nlay, zha, 'zha ', 'zha ') + CALL writeg1d(1, nlay, zu, 'zu ', 'zu ') + CALL writeg1d(1, nlay, zv, 'zv ', 'zv ') + CALL writeg1d(1, nlay, zo, 'zo ', 'zo ') + CALL writeg1d(1, nlay, wh, 'wh ', 'wh ') + CALL writeg1d(1, nlay, wu, 'wu ', 'wu ') + CALL writeg1d(1, nlay, wv, 'wv ', 'wv ') + CALL writeg1d(1, nlay, wo, 'w15uo ', 'wXo ') + CALL writeg1d(1, nlay, zdhadj, 'zdhadj ', 'zdhadj ') + CALL writeg1d(1, nlay, pduadj, 'pduadj ', 'pduadj ') + CALL writeg1d(1, nlay, pdvadj, 'pdvadj ', 'pdvadj ') + CALL writeg1d(1, nlay, pdoadj, 'pdoadj ', 'pdoadj ') + CALL writeg1d(1, nlay, entr, 'entr ', 'entr ') + CALL writeg1d(1, nlay, detr, 'detr ', 'detr ') + CALL writeg1d(1, nlay, fm, 'fm ', 'fm ') + + CALL writeg1d(1, nlay, pdtadj, 'pdtadj ', 'pdtadj ') + CALL writeg1d(1, nlay, pplay, 'pplay ', 'pplay ') + CALL writeg1d(1, nlay, pplev, 'pplev ', 'pplev ') + + ! recalcul des flux en diagnostique... + ! print*,'PAS DE TEMPS ',ptimestep + CALL dt2f(pplev, pplay, pt, pdtadj, wh) + CALL writeg1d(1, nlay, wh, 'wh2 ', 'wh2 ') +#endif +123 CONTINUE + + END IF + + ! if(wa_moy(1,4).gt.1.e-10) stop + + ! print*,'19 OK convect8' + RETURN +END SUBROUTINE calcul_sec + +SUBROUTINE fermeture_seche(ngrid, nlay, pplay, pplev, pphi, zlev, rhobarz, & + f0, zpspsk, alim_star, zh, zo, lentr, lmin, nu_min, nu_max, r_aspect, & + zmax, wmax) + + USE dimphy + IMPLICIT NONE + + include "YOMCST.h" + + INTEGER ngrid, nlay + REAL pplay(ngrid, nlay), pplev(ngrid, nlay+1) + REAL pphi(ngrid, nlay) + REAL zlev(klon, klev+1) + REAL alim_star(klon, klev) + REAL f0(klon) + INTEGER lentr(klon) + INTEGER lmin(klon) + REAL zmax(klon) + REAL wmax(klon) + REAL nu_min + REAL nu_max + REAL r_aspect + REAL rhobarz(klon, klev+1) + REAL zh(klon, klev) + REAL zo(klon, klev) + REAL zpspsk(klon, klev) + + INTEGER ig, l + + REAL f_star(klon, klev+1) + REAL detr_star(klon, klev) + REAL entr_star(klon, klev) + REAL zw2(klon, klev+1) + REAL linter(klon) + INTEGER lmix(klon) + INTEGER lmax(klon) + REAL zlevinter(klon) + REAL wa_moy(klon, klev+1) + REAL wmaxa(klon) + REAL ztv(klon, klev) + REAL ztva(klon, klev) + REAL nu(klon, klev) + ! real zmax0_sec(klon) + ! save zmax0_sec + REAL, SAVE, ALLOCATABLE :: zmax0_sec(:) + !$OMP THREADPRIVATE(zmax0_sec) + LOGICAL, SAVE :: first = .TRUE. + !$OMP THREADPRIVATE(first) + + IF (first) THEN + ALLOCATE (zmax0_sec(klon)) + first = .FALSE. + END IF + + DO l = 1, nlay + DO ig = 1, ngrid + ztv(ig, l) = zh(ig, l)/zpspsk(ig, l) + ztv(ig, l) = ztv(ig, l)*(1.+retv*zo(ig,l)) + END DO + END DO + DO l = 1, nlay - 2 + DO ig = 1, ngrid + IF (ztv(ig,l)>ztv(ig,l+1) .AND. alim_star(ig,l)>1.E-10 .AND. & + zw2(ig,l)<1E-10) THEN + f_star(ig, l+1) = alim_star(ig, l) + ! test:calcul de dteta + zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* & + (zlev(ig,l+1)-zlev(ig,l))*0.4*pphi(ig, l)/(pphi(ig,l+1)-pphi(ig,l)) + ELSE IF ((zw2(ig,l)>=1E-10) .AND. (f_star(ig,l)+alim_star(ig, & + l))>1.E-10) THEN + ! estimation du detrainement a partir de la geometrie du pas + ! precedent + ! tests sur la definition du detr + nu(ig, l) = (nu_min+nu_max)/2.*(1.-(nu_max-nu_min)/(nu_max+nu_min)* & + tanh((((ztva(ig,l-1)-ztv(ig,l))/ztv(ig,l))/0.0005))) + + detr_star(ig, l) = rhobarz(ig, l)*sqrt(zw2(ig,l))/ & + (r_aspect*zmax0_sec(ig))* & ! s + ! /(r_aspect*zmax0(ig))* + (sqrt(nu(ig,l)*zlev(ig,l+1)/sqrt(zw2(ig,l)))-sqrt(nu(ig,l)*zlev(ig, & + l)/sqrt(zw2(ig,l)))) + detr_star(ig, l) = detr_star(ig, l)/f0(ig) + IF ((detr_star(ig,l))>f_star(ig,l)) THEN + detr_star(ig, l) = f_star(ig, l) + END IF + entr_star(ig, l) = 0.9*detr_star(ig, l) + IF ((l1.E-10) THEN + ! AM on melange Tl et qt du thermique + ztva(ig, l) = (f_star(ig,l)*ztva(ig,l-1)+(entr_star(ig, & + l)+alim_star(ig,l))*ztv(ig,l))/(f_star(ig,l+1)+detr_star(ig,l)) + zw2(ig, l+1) = zw2(ig, l)*(f_star(ig,l)/(f_star(ig, & + l+1)+detr_star(ig,l)))**2 + 2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, & + l)*(zlev(ig,l+1)-zlev(ig,l)) + END IF + END IF + + IF (zw2(ig,l+1)<0.) THEN + linter(ig) = (l*(zw2(ig,l+1)-zw2(ig,l))-zw2(ig,l))/(zw2(ig,l+1)-zw2( & + ig,l)) + zw2(ig, l+1) = 0. + ! print*,'linter=',linter(ig) + ELSE + wa_moy(ig, l+1) = sqrt(zw2(ig,l+1)) + END IF + IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN + ! lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig) = l + 1 + wmaxa(ig) = wa_moy(ig, l+1) + END IF + END DO + END DO + ! print*,'fin calcul zw2' + + ! Calcul de la couche correspondant a la hauteur du thermique + DO ig = 1, ngrid + lmax(ig) = lentr(ig) + END DO + DO ig = 1, ngrid + DO l = nlay, lentr(ig) + 1, -1 + IF (zw2(ig,l)<=1.E-10) THEN + lmax(ig) = l - 1 + END IF + END DO + END DO + ! pas de thermique si couche 1 stable + DO ig = 1, ngrid + IF (lmin(ig)>1) THEN + lmax(ig) = 1 + lmin(ig) = 1 + lentr(ig) = 1 + END IF + END DO + + ! Determination de zw2 max + DO ig = 1, ngrid + wmax(ig) = 0. + END DO + + DO l = 1, nlay + DO ig = 1, ngrid + IF (l<=lmax(ig)) THEN + IF (zw2(ig,l)<0.) THEN + ! print*,'pb2 zw2<0' + END IF + zw2(ig, l) = sqrt(zw2(ig,l)) + wmax(ig) = max(wmax(ig), zw2(ig,l)) + ELSE + zw2(ig, l) = 0. + END IF + END DO + END DO + + ! Longueur caracteristique correspondant a la hauteur des thermiques. + DO ig = 1, ngrid + zmax(ig) = 0. + zlevinter(ig) = zlev(ig, 1) + END DO + DO ig = 1, ngrid + ! calcul de zlevinter + zlevinter(ig) = (zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*linter(ig) + & + zlev(ig, lmax(ig)) - lmax(ig)*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig))) + ! pour le cas ou on prend tjs lmin=1 + ! zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + zmax(ig) = max(zmax(ig), zlevinter(ig)-zlev(ig,1)) + zmax0_sec(ig) = zmax(ig) + END DO + + RETURN +END SUBROUTINE fermeture_seche + +END MODULE lmdz_thermcell_old Index: LMDZ6/trunk/libf/phylmd/lmdz_thermcell_plume.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/lmdz_thermcell_plume.F90 (revision 4590) +++ LMDZ6/trunk/libf/phylmd/lmdz_thermcell_plume.F90 (revision 4590) @@ -0,0 +1,454 @@ +MODULE lmdz_thermcell_plume +! +! $Id: thermcell_plume.F90 3074 2017-11-15 13:31:44Z fhourdin $ +! +CONTAINS + + SUBROUTINE thermcell_plume(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz, & + & zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, & + & lalim,f0,detr_star,entr_star,f_star,csc,ztva, & + & ztla,zqla,zqta,zha,zw2,w_est,ztva_est,zqsatth,lmix,lmix_bis,linter & + & ,lev_out,lunout1,igout) +! & ,lev_out,lunout1,igout,zbuoy,zbuoyjam) +!-------------------------------------------------------------------------- +! Auhtors : Catherine Rio, Frédéric Hourdin, Arnaud Jam +! +!thermcell_plume: calcule les valeurs de qt, thetal et w dans l ascendance +! This versions starts from a cleaning of thermcell_plume_6A (2019/01/20) +! thermcell_plume_6A is activate for flag_thermas_ed < 10 +! thermcell_plume_5B for flag_thermas_ed < 20 +! thermcell_plume for flag_thermals_ed>= 20 +! Various options are controled by the flag_thermals_ed parameter +! = 20 : equivalent to thermcell_plume_6A with flag_thermals_ed=8 +! = 21 : the Jam strato-cumulus modif is not activated in detrainment +! = 29 : an other way to compute the modified buoyancy (to be tested) +!-------------------------------------------------------------------------- + + USE lmdz_thermcell_ini, ONLY: prt_level,fact_thermals_ed_dz,iflag_thermals_ed,RLvCP,RETV,RG + USE lmdz_thermcell_ini, ONLY: fact_epsilon, betalpha, afact, fact_shell + USE lmdz_thermcell_ini, ONLY: detr_min, entr_min, detr_q_coef, detr_q_power + USE lmdz_thermcell_ini, ONLY: mix0, thermals_flag_alim + USE lmdz_thermcell_alim, ONLY : thermcell_alim + USE lmdz_thermcell_qsat, ONLY : thermcell_qsat + + + IMPLICIT NONE + + integer,intent(in) :: itap,lev_out,lunout1,igout,ngrid,nlay + real,intent(in) :: ptimestep + real,intent(in),dimension(ngrid,nlay) :: ztv + real,intent(in),dimension(ngrid,nlay) :: zthl + real,intent(in),dimension(ngrid,nlay) :: po + real,intent(in),dimension(ngrid,nlay) :: zl + real,intent(in),dimension(ngrid,nlay) :: rhobarz + real,intent(in),dimension(ngrid,nlay+1) :: zlev + real,intent(in),dimension(ngrid,nlay+1) :: pplev + real,intent(in),dimension(ngrid,nlay) :: pphi + real,intent(in),dimension(ngrid,nlay) :: zpspsk + real,intent(in),dimension(ngrid) :: f0 + + integer,intent(out) :: lalim(ngrid) + real,intent(out),dimension(ngrid,nlay) :: alim_star + real,intent(out),dimension(ngrid) :: alim_star_tot + real,intent(out),dimension(ngrid,nlay) :: detr_star + real,intent(out),dimension(ngrid,nlay) :: entr_star + real,intent(out),dimension(ngrid,nlay+1) :: f_star + real,intent(out),dimension(ngrid,nlay) :: csc + real,intent(out),dimension(ngrid,nlay) :: ztva + real,intent(out),dimension(ngrid,nlay) :: ztla + real,intent(out),dimension(ngrid,nlay) :: zqla + real,intent(out),dimension(ngrid,nlay) :: zqta + real,intent(out),dimension(ngrid,nlay) :: zha + real,intent(out),dimension(ngrid,nlay+1) :: zw2 + real,intent(out),dimension(ngrid,nlay+1) :: w_est + real,intent(out),dimension(ngrid,nlay) :: ztva_est + real,intent(out),dimension(ngrid,nlay) :: zqsatth + integer,intent(out),dimension(ngrid) :: lmix(ngrid) + integer,intent(out),dimension(ngrid) :: lmix_bis(ngrid) + real,intent(out),dimension(ngrid) :: linter(ngrid) + + + REAL,dimension(ngrid,nlay+1) :: wa_moy + REAL,dimension(ngrid,nlay) :: entr,detr + REAL,dimension(ngrid,nlay) :: ztv_est + REAL,dimension(ngrid,nlay) :: zqla_est + REAL,dimension(ngrid,nlay) :: zta_est + REAL,dimension(ngrid) :: ztemp,zqsat + REAL zdw2,zdw2bis + REAL zw2modif + REAL zw2fact,zw2factbis + REAL,dimension(ngrid,nlay) :: zeps + + REAL,dimension(ngrid) :: wmaxa + + INTEGER ig,l,k,lt,it,lm,nbpb + + real,dimension(ngrid,nlay) :: zbuoy,gamma,zdqt + real zdz,zalpha,zw2m + real,dimension(ngrid,nlay) :: zbuoyjam,zdqtjam + real zdz2,zdz3,lmel,entrbis,zdzbis + real,dimension(ngrid) :: d_temp + real ztv1,ztv2,factinv,zinv,zlmel + real zlmelup,zlmeldwn,zlt,zltdwn,zltup + real atv1,atv2,btv1,btv2 + real ztv_est1,ztv_est2 + real zcor,zdelta,zcvm5,qlbef + real zbetalpha, coefzlmel + real eps + logical Zsat + LOGICAL,dimension(ngrid) :: active,activetmp + REAL fact_gamma,fact_gamma2,fact_epsilon2 + + + REAL,dimension(ngrid,nlay) :: c2 + + if (ngrid==1) print*,'THERMCELL PLUME MODIFIE 2014/07/11' + Zsat=.false. +! Initialisation + + + zbetalpha=betalpha/(1.+betalpha) + + +! Initialisations des variables r?elles +if (1==1) then + ztva(:,:)=ztv(:,:) + ztva_est(:,:)=ztva(:,:) + ztv_est(:,:)=ztv(:,:) + ztla(:,:)=zthl(:,:) + zqta(:,:)=po(:,:) + zqla(:,:)=0. + zha(:,:) = ztva(:,:) +else + ztva(:,:)=0. + ztv_est(:,:)=0. + ztva_est(:,:)=0. + ztla(:,:)=0. + zqta(:,:)=0. + zha(:,:) =0. +endif + + zqla_est(:,:)=0. + zqsatth(:,:)=0. + zqla(:,:)=0. + detr_star(:,:)=0. + entr_star(:,:)=0. + alim_star(:,:)=0. + alim_star_tot(:)=0. + csc(:,:)=0. + detr(:,:)=0. + entr(:,:)=0. + zw2(:,:)=0. + zbuoy(:,:)=0. + zbuoyjam(:,:)=0. + gamma(:,:)=0. + zeps(:,:)=0. + w_est(:,:)=0. + f_star(:,:)=0. + wa_moy(:,:)=0. + linter(:)=1. +! linter(:)=1. +! Initialisation des variables entieres + lmix(:)=1 + lmix_bis(:)=2 + wmaxa(:)=0. + + +!------------------------------------------------------------------------- +! On ne considere comme actif que les colonnes dont les deux premieres +! couches sont instables. +!------------------------------------------------------------------------- + + active(:)=ztv(:,1)>ztv(:,2) + d_temp(:)=0. ! Pour activer un contraste de temperature a la base + ! du panache +! Cet appel pourrait être fait avant thermcell_plume dans thermcell_main + CALL thermcell_alim(thermals_flag_alim,ngrid,nlay,ztv,d_temp,zlev,alim_star,lalim) + +!------------------------------------------------------------------------------ +! Calcul dans la premiere couche +! On decide dans cette version que le thermique n'est actif que si la premiere +! couche est instable. +! Pourrait etre change si on veut que le thermiques puisse se d??clencher +! dans une couche l>1 +!------------------------------------------------------------------------------ +do ig=1,ngrid +! Le panache va prendre au debut les caracteristiques de l'air contenu +! dans cette couche. + if (active(ig)) then + ztla(ig,1)=zthl(ig,1) + zqta(ig,1)=po(ig,1) + zqla(ig,1)=zl(ig,1) +!cr: attention, prise en compte de f*(1)=1 + f_star(ig,2)=alim_star(ig,1) + zw2(ig,2)=2.*RG*(ztv(ig,1)-ztv(ig,2))/ztv(ig,2) & +& *(zlev(ig,2)-zlev(ig,1)) & +& *0.4*pphi(ig,1)/(pphi(ig,2)-pphi(ig,1)) + w_est(ig,2)=zw2(ig,2) + endif +enddo +! + +!============================================================================== +!boucle de calcul de la vitesse verticale dans le thermique +!============================================================================== +do l=2,nlay-1 +!============================================================================== + + +! On decide si le thermique est encore actif ou non +! AFaire : Il faut sans doute ajouter entr_star a alim_star dans ce test + do ig=1,ngrid + active(ig)=active(ig) & +& .and. zw2(ig,l)>1.e-10 & +& .and. f_star(ig,l)+alim_star(ig,l)>1.e-10 + enddo + + + +!--------------------------------------------------------------------------- +! calcul des proprietes thermodynamiques et de la vitesse de la couche l +! sans tenir compte du detrainement et de l'entrainement dans cette +! couche +! C'est a dire qu'on suppose +! ztla(l)=ztla(l-1) et zqta(l)=zqta(l-1) +! Ici encore, on doit pouvoir ajouter entr_star (qui peut etre calculer +! avant) a l'alimentation pour avoir un calcul plus propre +!--------------------------------------------------------------------------- + + ztemp(:)=zpspsk(:,l)*ztla(:,l-1) + call thermcell_qsat(ngrid,active,pplev(:,l),ztemp,zqta(:,l-1),zqsat(:)) + do ig=1,ngrid +! print*,'active',active(ig),ig,l + if(active(ig)) then + zqla_est(ig,l)=max(0.,zqta(ig,l-1)-zqsat(ig)) + ztva_est(ig,l) = ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*zqla_est(ig,l) + zta_est(ig,l)=ztva_est(ig,l) + ztva_est(ig,l) = ztva_est(ig,l)/zpspsk(ig,l) + ztva_est(ig,l) = ztva_est(ig,l)*(1.+RETV*(zqta(ig,l-1) & + & -zqla_est(ig,l))-zqla_est(ig,l)) + + +!Modif AJAM + + zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) + zdz=zlev(ig,l+1)-zlev(ig,l) + lmel=fact_thermals_ed_dz*zlev(ig,l) +! lmel=0.09*zlev(ig,l) + zlmel=zlev(ig,l)+lmel + zlmelup=zlmel+(zdz/2) + zlmeldwn=zlmel-(zdz/2) + + lt=l+1 + zlt=zlev(ig,lt) + zdz3=zlev(ig,lt+1)-zlt + zltdwn=zlt-zdz3/2 + zltup=zlt+zdz3/2 + +!========================================================================= +! 3. Calcul de la flotabilite modifie par melange avec l'air au dessus +!========================================================================= + +!-------------------------------------------------- + lt=l+1 + zlt=zlev(ig,lt) + zdz2=zlev(ig,lt)-zlev(ig,l) + + do while (lmel.gt.zdz2) + lt=lt+1 + zlt=zlev(ig,lt) + zdz2=zlt-zlev(ig,l) + enddo + zdz3=zlev(ig,lt+1)-zlt + zltdwn=zlev(ig,lt)-zdz3/2 + zlmelup=zlmel+(zdz/2) + coefzlmel=Min(1.,(zlmelup-zltdwn)/zdz) + zbuoyjam(ig,l)=1.*RG*(coefzlmel*(ztva_est(ig,l)- & + & ztv(ig,lt))/ztv(ig,lt)+(1.-coefzlmel)*(ztva_est(ig,l)- & + & ztv(ig,lt-1))/ztv(ig,lt-1))+0.*zbuoy(ig,l) + +!------------------------------------------------ +!AJAM:nouveau calcul de w? +!------------------------------------------------ + zdz=zlev(ig,l+1)-zlev(ig,l) + zdzbis=zlev(ig,l)-zlev(ig,l-1) + zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) + zw2fact=fact_epsilon*2.*zdz/(1.+betalpha) + zw2factbis=fact_epsilon*2.*zdzbis/(1.+betalpha) + zdw2=afact*zbuoy(ig,l)/fact_epsilon + zdw2bis=afact*zbuoy(ig,l-1)/fact_epsilon + lm=Max(1,l-2) + w_est(ig,l+1)=Max(0.0001,exp(-zw2fact)*(w_est(ig,l)-zdw2)+zdw2) + endif + enddo + + +!------------------------------------------------- +!calcul des taux d'entrainement et de detrainement +!------------------------------------------------- + + do ig=1,ngrid + if (active(ig)) then + +! zw2m=max(0.5*(w_est(ig,l)+w_est(ig,l+1)),0.1) + zw2m=w_est(ig,l+1) + zdz=zlev(ig,l+1)-zlev(ig,l) + zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) + zalpha=f0(ig)*f_star(ig,l)/sqrt(w_est(ig,l+1))/rhobarz(ig,l) + zdqt(ig,l)=max(zqta(ig,l-1)-po(ig,l),0.)/po(ig,l) + +!========================================================================= +! 4. Calcul de l'entrainement et du detrainement +!========================================================================= + + detr_star(ig,l)=f_star(ig,l)*zdz & + & *( mix0 * 0.1 / (zalpha+0.001) & + & + MAX(detr_min, -afact*zbetalpha*zbuoyjam(ig,l)/zw2m & + & + detr_q_coef*(zdqt(ig,l)/zw2m)**detr_q_power)) + + if ( iflag_thermals_ed == 20 ) then + entr_star(ig,l)=f_star(ig,l)*zdz* ( & + & mix0 * 0.1 / (zalpha+0.001) & + & + zbetalpha*MAX(entr_min, & + & afact*zbuoyjam(ig,l)/zw2m - fact_epsilon)) + else + entr_star(ig,l)=f_star(ig,l)*zdz* ( & + & mix0 * 0.1 / (zalpha+0.001) & + & + zbetalpha*MAX(entr_min, & + & afact*zbuoy(ig,l)/zw2m - fact_epsilon)) + endif + +! En dessous de lalim, on prend le max de alim_star et entr_star pour +! alim_star et 0 sinon + if (l.lt.lalim(ig)) then + alim_star(ig,l)=max(alim_star(ig,l),entr_star(ig,l)) + entr_star(ig,l)=0. + endif + f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l) & + & -detr_star(ig,l) + + endif + enddo + + +!============================================================================ +! 5. calcul de la vitesse verticale en melangeant Tl et qt du thermique +!=========================================================================== + + activetmp(:)=active(:) .and. f_star(:,l+1)>1.e-10 + do ig=1,ngrid + if (activetmp(ig)) then + Zsat=.false. + ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+ & + & (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l)) & + & /(f_star(ig,l+1)+detr_star(ig,l)) + zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+ & + & (alim_star(ig,l)+entr_star(ig,l))*po(ig,l)) & + & /(f_star(ig,l+1)+detr_star(ig,l)) + + endif + enddo + + ztemp(:)=zpspsk(:,l)*ztla(:,l) + call thermcell_qsat(ngrid,activetmp,pplev(:,l),ztemp,zqta(:,l),zqsatth(:,l)) + do ig=1,ngrid + if (activetmp(ig)) then +! on ecrit de maniere conservative (sat ou non) +! T = Tl +Lv/Cp ql + zqla(ig,l)=max(0.,zqta(ig,l)-zqsatth(ig,l)) + ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l) + ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l) +!on rajoute le calcul de zha pour diagnostiques (temp potentielle) + zha(ig,l) = ztva(ig,l) + ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) & + & -zqla(ig,l))-zqla(ig,l)) + zbuoy(ig,l)=RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) + zdz=zlev(ig,l+1)-zlev(ig,l) + zdzbis=zlev(ig,l)-zlev(ig,l-1) + zeps(ig,l)=(entr_star(ig,l)+alim_star(ig,l))/(f_star(ig,l)*zdz) + zw2fact=fact_epsilon*2.*zdz/(1.+betalpha) + zw2factbis=fact_epsilon*2.*zdzbis/(1.+betalpha) + zdw2= afact*zbuoy(ig,l)/(fact_epsilon) + zdw2bis= afact*zbuoy(ig,l-1)/(fact_epsilon) + zw2(ig,l+1)=Max(0.0001,exp(-zw2fact)*(zw2(ig,l)-zdw2)+zdw2) + endif + enddo + + if (prt_level.ge.20) print*,'coucou calcul detr 460: ig, l',ig, l +! +!=========================================================================== +! 6. initialisations pour le calcul de la hauteur du thermique, de l'inversion et de la vitesse verticale max +!=========================================================================== + + nbpb=0 + do ig=1,ngrid + if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then +! stop'On tombe sur le cas particulier de thermcell_dry' +! print*,'On tombe sur le cas particulier de thermcell_plume' + nbpb=nbpb+1 + zw2(ig,l+1)=0. + linter(ig)=l+1 + endif + + if (zw2(ig,l+1).lt.0.) then + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) & + & -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. +!+CR:04/05/12:correction calcul linter pour calcul de zmax continu + elseif (f_star(ig,l+1).lt.0.) then + linter(ig)=(l*(f_star(ig,l+1)-f_star(ig,l)) & + & -f_star(ig,l))/(f_star(ig,l+1)-f_star(ig,l)) + zw2(ig,l+1)=0. +!fin CR:04/05/12 + endif + + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +! lmix est le niveau de la couche ou w (wa_moy) est maximum +!on rajoute le calcul de lmix_bis + if (zqla(ig,l).lt.1.e-10) then + lmix_bis(ig)=l+1 + endif + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + + if (nbpb>0) then + print*,'WARNING on tombe ',nbpb,' x sur un pb pour l=',l,' dans thermcell_plume' + endif + +!========================================================================= +! FIN DE LA BOUCLE VERTICALE + enddo +!========================================================================= + +!on recalcule alim_star_tot + do ig=1,ngrid + alim_star_tot(ig)=0. + enddo + do ig=1,ngrid + do l=1,lalim(ig)-1 + alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l) + enddo + enddo + + + if (prt_level.ge.20) print*,'coucou calcul detr 470: ig, l', ig, l + +#undef wrgrads_thermcell +#ifdef wrgrads_thermcell + call wrgradsfi(1,nlay,entr_star(igout,1:nlay),'esta ','esta ') + call wrgradsfi(1,nlay,detr_star(igout,1:nlay),'dsta ','dsta ') + call wrgradsfi(1,nlay,zbuoy(igout,1:nlay),'buoy ','buoy ') + call wrgradsfi(1,nlay,zdqt(igout,1:nlay),'dqt ','dqt ') + call wrgradsfi(1,nlay,w_est(igout,1:nlay),'w_est ','w_est ') + call wrgradsfi(1,nlay,w_est(igout,2:nlay+1),'w_es2 ','w_es2 ') + call wrgradsfi(1,nlay,zw2(igout,1:nlay),'zw2A ','zw2A ') +#endif + + + RETURN + end +END MODULE lmdz_thermcell_plume Index: LMDZ6/trunk/libf/phylmd/lmdz_thermcell_plume_6A.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/lmdz_thermcell_plume_6A.F90 (revision 4590) +++ LMDZ6/trunk/libf/phylmd/lmdz_thermcell_plume_6A.F90 (revision 4590) @@ -0,0 +1,1118 @@ +MODULE lmdz_thermcell_plume_6A +! +! $Id$ +! +CONTAINS + + SUBROUTINE thermcell_plume_6A(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz, & + & zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, & + & lalim,f0,detr_star,entr_star,f_star,csc,ztva, & + & ztla,zqla,zqta,zha,zw2,w_est,ztva_est,zqsatth,lmix,lmix_bis,linter & + & ,lev_out,lunout1,igout) +! & ,lev_out,lunout1,igout,zbuoy,zbuoyjam) +!-------------------------------------------------------------------------- +!thermcell_plume: calcule les valeurs de qt, thetal et w dans l ascendance +!-------------------------------------------------------------------------- + + USE lmdz_thermcell_ini, ONLY: prt_level,fact_thermals_ed_dz,iflag_thermals_ed,RLvCP,RETV,RG + USE lmdz_thermcell_ini, ONLY: fact_epsilon, betalpha, afact, fact_shell + USE lmdz_thermcell_ini, ONLY: detr_min, entr_min, detr_q_coef, detr_q_power + USE lmdz_thermcell_ini, ONLY: mix0, thermals_flag_alim + USE lmdz_thermcell_alim, ONLY : thermcell_alim + USE lmdz_thermcell_qsat, ONLY : thermcell_qsat + + + IMPLICIT NONE + + integer,intent(in) :: itap,lev_out,lunout1,igout,ngrid,nlay + real,intent(in) :: ptimestep + real,intent(in),dimension(ngrid,nlay) :: ztv + real,intent(in),dimension(ngrid,nlay) :: zthl + real,intent(in),dimension(ngrid,nlay) :: po + real,intent(in),dimension(ngrid,nlay) :: zl + real,intent(in),dimension(ngrid,nlay) :: rhobarz + real,intent(in),dimension(ngrid,nlay+1) :: zlev + real,intent(in),dimension(ngrid,nlay+1) :: pplev + real,intent(in),dimension(ngrid,nlay) :: pphi + real,intent(in),dimension(ngrid,nlay) :: zpspsk + real,intent(in),dimension(ngrid) :: f0 + + integer,intent(out) :: lalim(ngrid) + real,intent(out),dimension(ngrid,nlay) :: alim_star + real,intent(out),dimension(ngrid) :: alim_star_tot + real,intent(out),dimension(ngrid,nlay) :: detr_star + real,intent(out),dimension(ngrid,nlay) :: entr_star + real,intent(out),dimension(ngrid,nlay+1) :: f_star + real,intent(out),dimension(ngrid,nlay) :: csc + real,intent(out),dimension(ngrid,nlay) :: ztva + real,intent(out),dimension(ngrid,nlay) :: ztla + real,intent(out),dimension(ngrid,nlay) :: zqla + real,intent(out),dimension(ngrid,nlay) :: zqta + real,intent(out),dimension(ngrid,nlay) :: zha + real,intent(out),dimension(ngrid,nlay+1) :: zw2 + real,intent(out),dimension(ngrid,nlay+1) :: w_est + real,intent(out),dimension(ngrid,nlay) :: ztva_est + real,intent(out),dimension(ngrid,nlay) :: zqsatth + integer,intent(out),dimension(ngrid) :: lmix + integer,intent(out),dimension(ngrid) :: lmix_bis + real,intent(out),dimension(ngrid) :: linter + + REAL zdw2,zdw2bis + REAL zw2modif + REAL zw2fact,zw2factbis + REAL,dimension(ngrid,nlay) :: zeps + + REAL, dimension(ngrid) :: wmaxa(ngrid) + + INTEGER ig,l,k,lt,it,lm + integer nbpb + + real,dimension(ngrid,nlay) :: detr + real,dimension(ngrid,nlay) :: entr + real,dimension(ngrid,nlay+1) :: wa_moy + real,dimension(ngrid,nlay) :: ztv_est + real,dimension(ngrid) :: ztemp,zqsat + real,dimension(ngrid,nlay) :: zqla_est + real,dimension(ngrid,nlay) :: zta_est + + real,dimension(ngrid,nlay) :: zbuoy,gamma,zdqt + real zdz,zalpha,zw2m + real,dimension(ngrid,nlay) :: zbuoyjam,zdqtjam + real zbuoybis,zdz2,zdz3,lmel,entrbis,zdzbis + real, dimension(ngrid) :: d_temp + real ztv1,ztv2,factinv,zinv,zlmel + real zlmelup,zlmeldwn,zlt,zltdwn,zltup + real atv1,atv2,btv1,btv2 + real ztv_est1,ztv_est2 + real zcor,zdelta,zcvm5,qlbef + real zbetalpha, coefzlmel + real eps + logical Zsat + LOGICAL,dimension(ngrid) :: active,activetmp + REAL fact_gamma,fact_gamma2,fact_epsilon2 + REAL coefc + REAL,dimension(ngrid,nlay) :: c2 + + if (ngrid==1) print*,'THERMCELL PLUME MODIFIE 2014/07/11' + Zsat=.false. +! Initialisation + + + zbetalpha=betalpha/(1.+betalpha) + + +! Initialisations des variables r?elles +if (1==1) then + ztva(:,:)=ztv(:,:) + ztva_est(:,:)=ztva(:,:) + ztv_est(:,:)=ztv(:,:) + ztla(:,:)=zthl(:,:) + zqta(:,:)=po(:,:) + zqla(:,:)=0. + zha(:,:) = ztva(:,:) +else + ztva(:,:)=0. + ztv_est(:,:)=0. + ztva_est(:,:)=0. + ztla(:,:)=0. + zqta(:,:)=0. + zha(:,:) =0. +endif + + zqla_est(:,:)=0. + zqsatth(:,:)=0. + zqla(:,:)=0. + detr_star(:,:)=0. + entr_star(:,:)=0. + alim_star(:,:)=0. + alim_star_tot(:)=0. + csc(:,:)=0. + detr(:,:)=0. + entr(:,:)=0. + zw2(:,:)=0. + zbuoy(:,:)=0. + zbuoyjam(:,:)=0. + gamma(:,:)=0. + zeps(:,:)=0. + w_est(:,:)=0. + f_star(:,:)=0. + wa_moy(:,:)=0. + linter(:)=1. +! linter(:)=1. +! Initialisation des variables entieres + lmix(:)=1 + lmix_bis(:)=2 + wmaxa(:)=0. + +! Initialisation a 0 en cas de sortie dans replay + zqsat(:)=0. + zta_est(:,:)=0. + zdqt(:,:)=0. + zdqtjam(:,:)=0. + c2(:,:)=0. + + +!------------------------------------------------------------------------- +! On ne considere comme actif que les colonnes dont les deux premieres +! couches sont instables. +!------------------------------------------------------------------------- + + active(:)=ztv(:,1)>ztv(:,2) + d_temp(:)=0. ! Pour activer un contraste de temperature a la base + ! du panache +! Cet appel pourrait être fait avant thermcell_plume dans thermcell_main + CALL thermcell_alim(thermals_flag_alim,ngrid,nlay,ztv,d_temp,zlev,alim_star,lalim) + +!------------------------------------------------------------------------------ +! Calcul dans la premiere couche +! On decide dans cette version que le thermique n'est actif que si la premiere +! couche est instable. +! Pourrait etre change si on veut que le thermiques puisse se d??clencher +! dans une couche l>1 +!------------------------------------------------------------------------------ +do ig=1,ngrid +! Le panache va prendre au debut les caracteristiques de l'air contenu +! dans cette couche. + if (active(ig)) then + ztla(ig,1)=zthl(ig,1) + zqta(ig,1)=po(ig,1) + zqla(ig,1)=zl(ig,1) +!cr: attention, prise en compte de f*(1)=1 + f_star(ig,2)=alim_star(ig,1) + zw2(ig,2)=2.*RG*(ztv(ig,1)-ztv(ig,2))/ztv(ig,2) & +& *(zlev(ig,2)-zlev(ig,1)) & +& *0.4*pphi(ig,1)/(pphi(ig,2)-pphi(ig,1)) + w_est(ig,2)=zw2(ig,2) + endif +enddo +! + +!============================================================================== +!boucle de calcul de la vitesse verticale dans le thermique +!============================================================================== +do l=2,nlay-1 +!============================================================================== + + +! On decide si le thermique est encore actif ou non +! AFaire : Il faut sans doute ajouter entr_star a alim_star dans ce test + do ig=1,ngrid + active(ig)=active(ig) & +& .and. zw2(ig,l)>1.e-10 & +& .and. f_star(ig,l)+alim_star(ig,l)>1.e-10 + enddo + + + +!--------------------------------------------------------------------------- +! calcul des proprietes thermodynamiques et de la vitesse de la couche l +! sans tenir compte du detrainement et de l'entrainement dans cette +! couche +! C'est a dire qu'on suppose +! ztla(l)=ztla(l-1) et zqta(l)=zqta(l-1) +! Ici encore, on doit pouvoir ajouter entr_star (qui peut etre calculer +! avant) a l'alimentation pour avoir un calcul plus propre +!--------------------------------------------------------------------------- + + ztemp(:)=zpspsk(:,l)*ztla(:,l-1) + call thermcell_qsat(ngrid,active,pplev(:,l),ztemp,zqta(:,l-1),zqsat(:)) + do ig=1,ngrid +! print*,'active',active(ig),ig,l + if(active(ig)) then + zqla_est(ig,l)=max(0.,zqta(ig,l-1)-zqsat(ig)) + ztva_est(ig,l) = ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*zqla_est(ig,l) + zta_est(ig,l)=ztva_est(ig,l) + ztva_est(ig,l) = ztva_est(ig,l)/zpspsk(ig,l) + ztva_est(ig,l) = ztva_est(ig,l)*(1.+RETV*(zqta(ig,l-1) & + & -zqla_est(ig,l))-zqla_est(ig,l)) + + +!Modif AJAM + + zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) + zdz=zlev(ig,l+1)-zlev(ig,l) + lmel=fact_thermals_ed_dz*zlev(ig,l) +! lmel=0.09*zlev(ig,l) + zlmel=zlev(ig,l)+lmel + zlmelup=zlmel+(zdz/2) + zlmeldwn=zlmel-(zdz/2) + + lt=l+1 + zlt=zlev(ig,lt) + zdz3=zlev(ig,lt+1)-zlt + zltdwn=zlt-zdz3/2 + zltup=zlt+zdz3/2 + +!========================================================================= +! 3. Calcul de la flotabilite modifie par melange avec l'air au dessus +!========================================================================= + +!-------------------------------------------------- + if (iflag_thermals_ed.lt.8) then +!-------------------------------------------------- +!AJ052014: J'ai remplac?? la boucle do par un do while +! afin de faire moins de calcul dans la boucle +!-------------------------------------------------- + do while (zlmelup.gt.zltup) + lt=lt+1 + zlt=zlev(ig,lt) + zdz3=zlev(ig,lt+1)-zlt + zltdwn=zlt-zdz3/2 + zltup=zlt+zdz3/2 + enddo +!-------------------------------------------------- +!AJ052014: Si iflag_thermals_ed<8 (par ex 6), alors +! on cherche o?? se trouve l'altitude d'inversion +! en calculant ztv1 (interpolation de la valeur de +! theta au niveau lt en utilisant les niveaux lt-1 et +! lt-2) et ztv2 (interpolation avec les niveaux lt+1 +! et lt+2). Si theta r??ellement calcul??e au niveau lt +! comprise entre ztv1 et ztv2, alors il y a inversion +! et on calcule son altitude zinv en supposant que ztv(lt) +! est une combinaison lineaire de ztv1 et ztv2. +! Ensuite, on calcule la flottabilite en comparant +! la temperature de la couche l a celle de l'air situe +! l+lmel plus haut, ce qui necessite de savoir quel fraction +! de cet air est au-dessus ou en-dessous de l'inversion +!-------------------------------------------------- + atv1=(ztv(ig,lt-1)-ztv(ig,lt-2))/(zlev(ig,lt-1)-zlev(ig,lt-2)) + btv1=(ztv(ig,lt-2)*zlev(ig,lt-1)-ztv(ig,lt-1)*zlev(ig,lt-2)) & + & /(zlev(ig,lt-1)-zlev(ig,lt-2)) + atv2=(ztv(ig,lt+2)-ztv(ig,lt+1))/(zlev(ig,lt+2)-zlev(ig,lt+1)) + btv2=(ztv(ig,lt+1)*zlev(ig,lt+2)-ztv(ig,lt+2)*zlev(ig,lt+1)) & + & /(zlev(ig,lt+2)-zlev(ig,lt+1)) + + ztv1=atv1*zlt+btv1 + ztv2=atv2*zlt+btv2 + + if (ztv(ig,lt).gt.ztv1.and.ztv(ig,lt).lt.ztv2) then + +!-------------------------------------------------- +!AJ052014: D??calage de zinv qui est entre le haut +! et le bas de la couche lt +!-------------------------------------------------- + factinv=(ztv2-ztv(ig,lt))/(ztv2-ztv1) + zinv=zltdwn+zdz3*factinv + + + if (zlmeldwn.ge.zinv) then + ztv_est(ig,l)=atv2*zlmel+btv2 + zbuoyjam(ig,l)=fact_shell*RG*(ztva_est(ig,l)-ztv_est(ig,l))/ztv_est(ig,l) & + & +(1.-fact_shell)*zbuoy(ig,l) + elseif (zlmelup.ge.zinv) then + ztv_est2=atv2*0.5*(zlmelup+zinv)+btv2 + ztv_est1=atv1*0.5*(zinv+zlmeldwn)+btv1 + ztv_est(ig,l)=((zlmelup-zinv)/zdz)*ztv_est2+((zinv-zlmeldwn)/zdz)*ztv_est1 + + zbuoyjam(ig,l)=fact_shell*RG*(((zlmelup-zinv)/zdz)*(ztva_est(ig,l)- & + & ztv_est2)/ztv_est2+((zinv-zlmeldwn)/zdz)*(ztva_est(ig,l)- & + & ztv_est1)/ztv_est1)+(1.-fact_shell)*zbuoy(ig,l) + + else + ztv_est(ig,l)=atv1*zlmel+btv1 + zbuoyjam(ig,l)=fact_shell*RG*(ztva_est(ig,l)-ztv_est(ig,l))/ztv_est(ig,l) & + & +(1.-fact_shell)*zbuoy(ig,l) + endif + + else ! if (ztv(ig,lt).gt.ztv1.and.ztv(ig,lt).lt.ztv2) then + + if (zlmeldwn.gt.zltdwn) then + zbuoyjam(ig,l)=fact_shell*RG*((ztva_est(ig,l)- & + & ztv(ig,lt))/ztv(ig,lt))+(1.-fact_shell)*zbuoy(ig,l) + else + zbuoyjam(ig,l)=fact_shell*RG*(((zlmelup-zltdwn)/zdz)*(ztva_est(ig,l)- & + & ztv(ig,lt))/ztv(ig,lt)+((zltdwn-zlmeldwn)/zdz)*(ztva_est(ig,l)- & + & ztv(ig,lt-1))/ztv(ig,lt-1))+(1.-fact_shell)*zbuoy(ig,l) + + endif + +! zbuoyjam(ig,l)=fact_shell*RG*(((zlmelup-zltdwn)/zdz)*(ztva_est(ig,l)- & +! & ztv1)/ztv1+((zltdwn-zlmeldwn)/zdz)*(ztva_est(ig,l)- & +! & ztv(ig,lt-1))/ztv(ig,lt-1))+(1.-fact_shell)*zbuoy(ig,l) +! zdqt(ig,l)=Max(0.,((lmel+zdz3-zdz2)/zdz3)*(zqta(ig,l-1)- & +! & po(ig,lt))/po(ig,lt)+((zdz2-lmel)/zdz3)*(zqta(ig,l-1)- & +! & po(ig,lt-1))/po(ig,lt-1)) + endif ! if (ztv(ig,lt).gt.ztv1.and.ztv(ig,lt).lt.ztv2) then + + else ! if (iflag_thermals_ed.lt.8) then + lt=l+1 + zlt=zlev(ig,lt) + zdz2=zlev(ig,lt)-zlev(ig,l) + + do while (lmel.gt.zdz2) + lt=lt+1 + zlt=zlev(ig,lt) + zdz2=zlt-zlev(ig,l) + enddo + zdz3=zlev(ig,lt+1)-zlt + zltdwn=zlev(ig,lt)-zdz3/2 + zlmelup=zlmel+(zdz/2) + coefzlmel=Min(1.,(zlmelup-zltdwn)/zdz) + zbuoyjam(ig,l)=1.*RG*(coefzlmel*(ztva_est(ig,l)- & + & ztv(ig,lt))/ztv(ig,lt)+(1.-coefzlmel)*(ztva_est(ig,l)- & + & ztv(ig,lt-1))/ztv(ig,lt-1))+0.*zbuoy(ig,l) + endif ! if (iflag_thermals_ed.lt.8) then + +!------------------------------------------------ +!AJAM:nouveau calcul de w? +!------------------------------------------------ + zdz=zlev(ig,l+1)-zlev(ig,l) + zdzbis=zlev(ig,l)-zlev(ig,l-1) + zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) + + zw2fact=fact_epsilon*2.*zdz/(1.+betalpha) + zw2factbis=fact_epsilon*2.*zdzbis/(1.+betalpha) + zdw2=afact*zbuoy(ig,l)/fact_epsilon + zdw2bis=afact*zbuoy(ig,l-1)/fact_epsilon +! zdw2bis=0.5*(zdw2+zdw2bis) + lm=Max(1,l-2) +! zdw2=(afact/fact_epsilon)*((zdz/zdzbis)*zbuoy(ig,l) & +! & +((zdzbis-zdz)/zdzbis)*zbuoy(ig,l-1)) +! zdw2bis=(afact/fact_epsilon)*((zdz/zdzbis)*zbuoy(ig,l-1) & +! & +((zdzbis-zdz)/zdzbis)*zbuoy(ig,l-1)) +! w_est(ig,l+1)=Max(0.0001,exp(-zw2fact)*(w_est(ig,l)-zdw2)+zdw2) +! w_est(ig,l+1)=(zdz/zdzbis)*Max(0.0001,exp(-zw2fact)* & +! & (w_est(ig,l)-zdw2)+zdw2)+(zdzbis-zdz)/zdzbis* & +! & Max(0.0001,exp(-zw2factbis)*(w_est(ig,l-1)-zdw2bis)+zdw2) +! w_est(ig,l+1)=Max(0.0001,(1-exp(-zw2fact))*zdw2+w_est(ig,l)*exp(-zw2fact)) + +!-------------------------------------------------- +!AJ052014: J'ai remplac? w_est(ig,l) par zw2(ig,l) +!-------------------------------------------------- + if (iflag_thermals_ed==8) then +! Ancienne version +! w_est(ig,l+1)=Max(0.0001,(zdz/zdzbis)*(exp(-zw2fact)* & +! & (w_est(ig,l)-zdw2)+zdw2)+(zdzbis-zdz)/zdzbis* & +! & (exp(-zw2factbis)*(w_est(ig,l-1)-zdw2bis)+zdw2)) + + w_est(ig,l+1)=Max(0.0001,exp(-zw2fact)*(w_est(ig,l)-zdw2)+zdw2) + +! Nouvelle version Arnaud + else +! w_est(ig,l+1)=Max(0.0001,(zdz/zdzbis)*(exp(-zw2fact)* & +! & (w_est(ig,l)-zdw2)+zdw2)+(zdzbis-zdz)/zdzbis* & +! & (exp(-zw2factbis)*(w_est(ig,l-1)-zdw2bis)+zdw2)) + + w_est(ig,l+1)=Max(0.0001,exp(-zw2fact)*(w_est(ig,l)-zdw2bis)+zdw2) + +! w_est(ig,l+1)=Max(0.0001,(zdz/(zdzbis+zdz))*(exp(-zw2fact)* & +! & (w_est(ig,l)-zdw2bis)+zdw2)+(zdzbis/(zdzbis+zdz))* & +! & (exp(-zw2factbis)*(w_est(ig,l-1)-zdw2bis)+zdw2bis)) + + + +! w_est(ig,l+1)=Max(0.0001,(w_est(ig,l)+zdw2bis*zw2fact)*exp(-zw2fact)) + +! w_est(ig,l+1)=Max(0.0001,(zdz/zdzbis)*(zw2(ig,l)+zdw2*zw2fact)*exp(-zw2fact)+ & +! & (zdzbis-zdz)/zdzbis*(zw2(ig,l-1)+zdw2bis*zw2factbis)*exp(-zw2factbis)) + +! w_est(ig,l+1)=Max(0.0001,exp(-zw2factbis)*(w_est(ig,l-1)-zdw2bis)+zdw2) + + endif + + + if (iflag_thermals_ed<6) then + zalpha=f0(ig)*f_star(ig,l)/sqrt(w_est(ig,l+1))/rhobarz(ig,l) +! fact_epsilon=0.0005/(zalpha+0.025)**0.5 +! fact_epsilon=Min(0.003,0.0004/(zalpha)**0.5) + fact_epsilon=0.0002/(zalpha+0.1) + zw2fact=fact_epsilon*2.*zdz/(1.+betalpha) + zw2factbis=fact_epsilon*2.*zdzbis/(1.+betalpha) + zdw2=afact*zbuoy(ig,l)/fact_epsilon + zdw2bis=afact*zbuoy(ig,l-1)/fact_epsilon +! w_est(ig,l+1)=Max(0.0001,(zw2(ig,l)+zdw2*zw2fact)*exp(-zw2fact)) + +! w_est(ig,l+1)=Max(0.0001,(zdz/zdzbis)*(exp(-zw2fact)* & +! & (zw2(ig,l)-zdw2)+zdw2)+(zdzbis-zdz)/zdzbis* & +! & (exp(-zw2factbis)*(zw2(ig,l-1)-zdw2bis)+zdw2)) + + w_est(ig,l+1)=Max(0.0001,exp(-zw2fact)*(w_est(ig,l)-zdw2bis)+zdw2) + + + endif +!-------------------------------------------------- +!AJ052014: J'ai comment? ce if plus n?cessaire puisqu' +!on fait max(0.0001,.....) +!-------------------------------------------------- + +! if (w_est(ig,l+1).lt.0.) then +! w_est(ig,l+1)=zw2(ig,l) +! w_est(ig,l+1)=0.0001 +! endif + + endif + enddo + + +!------------------------------------------------- +!calcul des taux d'entrainement et de detrainement +!------------------------------------------------- + + do ig=1,ngrid + if (active(ig)) then + +! zw2m=max(0.5*(w_est(ig,l)+w_est(ig,l+1)),0.1) + zw2m=w_est(ig,l+1) +! zw2m=zw2(ig,l) + zdz=zlev(ig,l+1)-zlev(ig,l) + zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) +! zbuoybis=zbuoy(ig,l)+RG*0.1/300. + zbuoybis=zbuoy(ig,l) + zalpha=f0(ig)*f_star(ig,l)/sqrt(w_est(ig,l+1))/rhobarz(ig,l) + zdqt(ig,l)=max(zqta(ig,l-1)-po(ig,l),0.)/po(ig,l) + + +! entr_star(ig,l)=f_star(ig,l)*zdz*zbetalpha*MAX(0., & +! & afact*zbuoybis/zw2m - fact_epsilon ) + +! entr_star(ig,l)=MAX(0.,f_star(ig,l)*zdz*zbetalpha* & +! & afact*zbuoybis/zw2m - fact_epsilon ) + + + +! zbuoyjam(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) + +!========================================================================= +! 4. Calcul de l'entrainement et du detrainement +!========================================================================= + +! entr_star(ig,l)=f_star(ig,l)*zdz*zbetalpha*MAX(0., & +! & afact*zbuoyjam(ig,l)/zw2m - fact_epsilon ) +! entrbis=entr_star(ig,l) + + if (iflag_thermals_ed.lt.6) then + fact_epsilon=0.0002/(zalpha+0.1) + endif + + + + detr_star(ig,l)=f_star(ig,l)*zdz & + & *( mix0 * 0.1 / (zalpha+0.001) & + & + MAX(detr_min, -afact*zbetalpha*zbuoyjam(ig,l)/zw2m & + & + detr_q_coef*(zdqt(ig,l)/zw2m)**detr_q_power)) + +! detr_star(ig,l)=(zdz/zdzbis)*detr_star(ig,l)+ & +! & ((zdzbis-zdz)/zdzbis)*detr_star(ig,l-1) + + zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) + + entr_star(ig,l)=f_star(ig,l)*zdz* ( & + & mix0 * 0.1 / (zalpha+0.001) & + & + zbetalpha*MAX(entr_min, & + & afact*zbuoyjam(ig,l)/zw2m - fact_epsilon)) + + +! entr_star(ig,l)=f_star(ig,l)*zdz* ( & +! & mix0 * 0.1 / (zalpha+0.001) & +! & + MAX(entr_min, & +! & zbetalpha*afact*zbuoyjam(ig,l)/zw2m - fact_epsilon + & +! & detr_q_coef*(zdqt(ig,l)/zw2m)**detr_q_power)) + + +! entr_star(ig,l)=(zdz/zdzbis)*entr_star(ig,l)+ & +! & ((zdzbis-zdz)/zdzbis)*entr_star(ig,l-1) + +! entr_star(ig,l)=Max(0.,f_star(ig,l)*zdz*zbetalpha* & +! & afact*zbuoy(ig,l)/zw2m & +! & - 1.*fact_epsilon) + + +! En dessous de lalim, on prend le max de alim_star et entr_star pour +! alim_star et 0 sinon + if (l.lt.lalim(ig)) then + alim_star(ig,l)=max(alim_star(ig,l),entr_star(ig,l)) + entr_star(ig,l)=0. + endif +! if (l.lt.lalim(ig).and.alim_star(ig,l)>alim_star(ig,l-1)) then +! alim_star(ig,l)=entrbis +! endif + +! print*,'alim0',zlev(ig,l),entr_star(ig,l),detr_star(ig,l),zw2m,zbuoy(ig,l),f_star(ig,l) +! Calcul du flux montant normalise + f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l) & + & -detr_star(ig,l) + + endif + enddo + + +!============================================================================ +! 5. calcul de la vitesse verticale en melangeant Tl et qt du thermique +!=========================================================================== + + activetmp(:)=active(:) .and. f_star(:,l+1)>1.e-10 + do ig=1,ngrid + if (activetmp(ig)) then + Zsat=.false. + ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+ & + & (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l)) & + & /(f_star(ig,l+1)+detr_star(ig,l)) + zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+ & + & (alim_star(ig,l)+entr_star(ig,l))*po(ig,l)) & + & /(f_star(ig,l+1)+detr_star(ig,l)) + + endif + enddo + + ztemp(:)=zpspsk(:,l)*ztla(:,l) + call thermcell_qsat(ngrid,activetmp,pplev(:,l),ztemp,zqta(:,l),zqsatth(:,l)) + do ig=1,ngrid + if (activetmp(ig)) then +! on ecrit de maniere conservative (sat ou non) +! T = Tl +Lv/Cp ql + zqla(ig,l)=max(0.,zqta(ig,l)-zqsatth(ig,l)) + ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l) + ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l) +!on rajoute le calcul de zha pour diagnostiques (temp potentielle) + zha(ig,l) = ztva(ig,l) + ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) & + & -zqla(ig,l))-zqla(ig,l)) + zbuoy(ig,l)=RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) + zdz=zlev(ig,l+1)-zlev(ig,l) + zdzbis=zlev(ig,l)-zlev(ig,l-1) + zeps(ig,l)=(entr_star(ig,l)+alim_star(ig,l))/(f_star(ig,l)*zdz) +!!!!!!! fact_epsilon=0.002 + zw2fact=fact_epsilon*2.*zdz/(1.+betalpha) + zw2factbis=fact_epsilon*2.*zdzbis/(1.+betalpha) + zdw2= afact*zbuoy(ig,l)/(fact_epsilon) + zdw2bis= afact*zbuoy(ig,l-1)/(fact_epsilon) +! zdw2=(afact/fact_epsilon)*((zdz/zdzbis)*zbuoy(ig,l) & +! & +((zdzbis-zdz)/zdzbis)*zbuoy(ig,l-1)) +! lm=Max(1,l-2) +! zdw2bis=(afact/fact_epsilon)*((zdz/zdzbis)*zbuoy(ig,l-1) & +! & +((zdzbis-zdz)/zdzbis)*zbuoy(ig,l-1)) +! zw2(ig,l+1)=Max(0.0001,exp(-zw2fact)*(zw2(ig,l)-zdw2bis)+zdw2) +! zw2(ig,l+1)=Max(0.0001,(zdz/zdzbis)*(zw2(ig,l)+zdw2*zw2fact)*exp(-zw2fact)+ & +! & (zdzbis-zdz)/zdzbis*(zw2(ig,l-1)+zdw2bis*zw2factbis)*exp(-zw2factbis)) +! zw2(ig,l+1)=Max(0.0001,(zw2(ig,l)+zdw2*zw2fact)*exp(-zw2fact)) +! zw2(ig,l+1)=Max(0.0001,(zdz/zdzbis)*(exp(-zw2fact)* & +! & (zw2(ig,l)-zdw2)+zdw2)+(zdzbis-zdz)/zdzbis* & +! & (exp(-zw2factbis)*(zw2(ig,l-1)-zdw2bis)+zdw2)) + if (iflag_thermals_ed==8) then + zw2(ig,l+1)=Max(0.0001,exp(-zw2fact)*(zw2(ig,l)-zdw2)+zdw2) + else + zw2(ig,l+1)=Max(0.0001,exp(-zw2fact)*(zw2(ig,l)-zdw2bis)+zdw2) + endif +! zw2(ig,l+1)=Max(0.0001,(zdz/(zdz+zdzbis))*(exp(-zw2fact)* & +! & (zw2(ig,l)-zdw2)+zdw2bis)+(zdzbis/(zdz+zdzbis))* & +! & (exp(-zw2factbis)*(zw2(ig,l-1)-zdw2bis)+zdw2bis)) + + + if (iflag_thermals_ed.lt.6) then + zalpha=f0(ig)*f_star(ig,l)/sqrt(zw2(ig,l+1))/rhobarz(ig,l) +! fact_epsilon=0.0005/(zalpha+0.025)**0.5 +! fact_epsilon=Min(0.003,0.0004/(zalpha)**0.5) + fact_epsilon=0.0002/(zalpha+0.1)**1 + zw2fact=fact_epsilon*2.*zdz/(1.+betalpha) + zw2factbis=fact_epsilon*2.*zdzbis/(1.+betalpha) + zdw2= afact*zbuoy(ig,l)/(fact_epsilon) + zdw2bis= afact*zbuoy(ig,l-1)/(fact_epsilon) + +! zw2(ig,l+1)=Max(0.0001,(zdz/zdzbis)*(exp(-zw2fact)* & +! & (zw2(ig,l)-zdw2)+zdw2)+(zdzbis-zdz)/zdzbis* & +! & (exp(-zw2factbis)*(zw2(ig,l-1)-zdw2bis)+zdw2)) +! zw2(ig,l+1)=Max(0.0001,(zw2(ig,l)+zdw2*zw2fact)*exp(-zw2fact)) + zw2(ig,l+1)=Max(0.0001,exp(-zw2fact)*(zw2(ig,l)-zdw2bis)+zdw2) + + endif + + + endif + enddo + + if (prt_level.ge.20) print*,'coucou calcul detr 460: ig, l',ig, l +! +!=========================================================================== +! 6. initialisations pour le calcul de la hauteur du thermique, de l'inversion et de la vitesse verticale max +!=========================================================================== + + nbpb=0 + do ig=1,ngrid + if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then +! stop'On tombe sur le cas particulier de thermcell_dry' +! print*,'On tombe sur le cas particulier de thermcell_plume' + nbpb=nbpb+1 + zw2(ig,l+1)=0. + linter(ig)=l+1 + endif + + if (zw2(ig,l+1).lt.0.) then + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) & + & -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. +!+CR:04/05/12:correction calcul linter pour calcul de zmax continu + elseif (f_star(ig,l+1).lt.0.) then + linter(ig)=(l*(f_star(ig,l+1)-f_star(ig,l)) & + & -f_star(ig,l))/(f_star(ig,l+1)-f_star(ig,l)) + zw2(ig,l+1)=0. +!fin CR:04/05/12 + endif + + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +! lmix est le niveau de la couche ou w (wa_moy) est maximum +!on rajoute le calcul de lmix_bis + if (zqla(ig,l).lt.1.e-10) then + lmix_bis(ig)=l+1 + endif + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + + if (nbpb>0) then + print*,'WARNING on tombe ',nbpb,' x sur un pb pour l=',l,' dans thermcell_plume' + endif + +!========================================================================= +! FIN DE LA BOUCLE VERTICALE + enddo +!========================================================================= + +!on recalcule alim_star_tot + do ig=1,ngrid + alim_star_tot(ig)=0. + enddo + do ig=1,ngrid + do l=1,lalim(ig)-1 + alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l) + enddo + enddo + + + if (prt_level.ge.20) print*,'coucou calcul detr 470: ig, l', ig, l + +#undef wrgrads_thermcell +#ifdef wrgrads_thermcell + call wrgradsfi(1,nlay,entr_star(igout,1:nlay),'esta ','esta ') + call wrgradsfi(1,nlay,detr_star(igout,1:nlay),'dsta ','dsta ') + call wrgradsfi(1,nlay,zbuoy(igout,1:nlay),'buoy ','buoy ') + call wrgradsfi(1,nlay,zdqt(igout,1:nlay),'dqt ','dqt ') + call wrgradsfi(1,nlay,w_est(igout,1:nlay),'w_est ','w_est ') + call wrgradsfi(1,nlay,w_est(igout,2:nlay+1),'w_es2 ','w_es2 ') + call wrgradsfi(1,nlay,zw2(igout,1:nlay),'zw2A ','zw2A ') +#endif + + + RETURN + end + + + + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE thermcell_plume_5B(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz, & +& zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, & +& lalim,f0,detr_star,entr_star,f_star,csc,ztva, & +& ztla,zqla,zqta,zha,zw2,w_est,ztva_est,zqsatth,lmix,lmix_bis,linter & +& ,lev_out,lunout1,igout) +!& ,lev_out,lunout1,igout,zbuoy,zbuoyjam) + +!-------------------------------------------------------------------------- +!thermcell_plume: calcule les valeurs de qt, thetal et w dans l ascendance +! Version conforme a l'article de Rio et al. 2010. +! Code ecrit par Catherine Rio, Arnaud Jam et Frederic Hourdin +!-------------------------------------------------------------------------- + + USE lmdz_thermcell_ini, ONLY: prt_level,fact_thermals_ed_dz,iflag_thermals_ed,RLvCP,RETV,RG + USE lmdz_thermcell_qsat, ONLY : thermcell_qsat + IMPLICIT NONE + + INTEGER itap + INTEGER lunout1,igout + INTEGER ngrid,nlay + REAL ptimestep + REAL ztv(ngrid,nlay) + REAL zthl(ngrid,nlay) + REAL po(ngrid,nlay) + REAL zl(ngrid,nlay) + REAL rhobarz(ngrid,nlay) + REAL zlev(ngrid,nlay+1) + REAL pplev(ngrid,nlay+1) + REAL pphi(ngrid,nlay) + REAL zpspsk(ngrid,nlay) + REAL alim_star(ngrid,nlay) + REAL f0(ngrid) + INTEGER lalim(ngrid) + integer lev_out ! niveau pour les print + integer nbpb + + real alim_star_tot(ngrid) + + REAL ztva(ngrid,nlay) + REAL ztla(ngrid,nlay) + REAL zqla(ngrid,nlay) + REAL zqta(ngrid,nlay) + REAL zha(ngrid,nlay) + + REAL detr_star(ngrid,nlay) + REAL coefc + REAL entr_star(ngrid,nlay) + REAL detr(ngrid,nlay) + REAL entr(ngrid,nlay) + + REAL csc(ngrid,nlay) + + REAL zw2(ngrid,nlay+1) + REAL w_est(ngrid,nlay+1) + REAL f_star(ngrid,nlay+1) + REAL wa_moy(ngrid,nlay+1) + + REAL ztva_est(ngrid,nlay) + REAL zqla_est(ngrid,nlay) + REAL zqsatth(ngrid,nlay) + REAL zta_est(ngrid,nlay) + REAL zbuoyjam(ngrid,nlay) + REAL ztemp(ngrid),zqsat(ngrid) + REAL zdw2 + REAL zw2modif + REAL zw2fact + REAL zeps(ngrid,nlay) + + REAL linter(ngrid) + INTEGER lmix(ngrid) + INTEGER lmix_bis(ngrid) + REAL wmaxa(ngrid) + + INTEGER ig,l,k + + real zdz,zbuoy(ngrid,nlay),zalpha,gamma(ngrid,nlay),zdqt(ngrid,nlay),zw2m + real zbuoybis + real zcor,zdelta,zcvm5,qlbef,zdz2 + real betalpha,zbetalpha + real eps, afact + logical Zsat + LOGICAL active(ngrid),activetmp(ngrid) + REAL fact_gamma,fact_epsilon,fact_gamma2,fact_epsilon2 + REAL c2(ngrid,nlay) + Zsat=.false. +! Initialisation + + fact_epsilon=0.002 + betalpha=0.9 + afact=2./3. + + zbetalpha=betalpha/(1.+betalpha) + + +! Initialisations des variables reeles +if (1==1) then + ztva(:,:)=ztv(:,:) + ztva_est(:,:)=ztva(:,:) + ztla(:,:)=zthl(:,:) + zqta(:,:)=po(:,:) + zha(:,:) = ztva(:,:) +else + ztva(:,:)=0. + ztva_est(:,:)=0. + ztla(:,:)=0. + zqta(:,:)=0. + zha(:,:) =0. +endif + + zqla_est(:,:)=0. + zqsatth(:,:)=0. + zqla(:,:)=0. + detr_star(:,:)=0. + entr_star(:,:)=0. + alim_star(:,:)=0. + alim_star_tot(:)=0. + csc(:,:)=0. + detr(:,:)=0. + entr(:,:)=0. + zw2(:,:)=0. + zbuoy(:,:)=0. + zbuoyjam(:,:)=0. + gamma(:,:)=0. + zeps(:,:)=0. + w_est(:,:)=0. + f_star(:,:)=0. + wa_moy(:,:)=0. + linter(:)=1. +! linter(:)=1. +! Initialisation des variables entieres + lmix(:)=1 + lmix_bis(:)=2 + wmaxa(:)=0. + lalim(:)=1 + + +!------------------------------------------------------------------------- +! On ne considere comme actif que les colonnes dont les deux premieres +! couches sont instables. +!------------------------------------------------------------------------- + active(:)=ztv(:,1)>ztv(:,2) + +!------------------------------------------------------------------------- +! Definition de l'alimentation +!------------------------------------------------------------------------- + do l=1,nlay-1 + do ig=1,ngrid + if (ztv(ig,l)> ztv(ig,l+1) .and. ztv(ig,1)>=ztv(ig,l) ) then + alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.) & + & *sqrt(zlev(ig,l+1)) + lalim(ig)=l+1 + alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l) + endif + enddo + enddo + do l=1,nlay + do ig=1,ngrid + if (alim_star_tot(ig) > 1.e-10 ) then + alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig) + endif + enddo + enddo + alim_star_tot(:)=1. + + + +!------------------------------------------------------------------------------ +! Calcul dans la premiere couche +! On decide dans cette version que le thermique n'est actif que si la premiere +! couche est instable. +! Pourrait etre change si on veut que le thermiques puisse se d??clencher +! dans une couche l>1 +!------------------------------------------------------------------------------ +do ig=1,ngrid +! Le panache va prendre au debut les caracteristiques de l'air contenu +! dans cette couche. + if (active(ig)) then + ztla(ig,1)=zthl(ig,1) + zqta(ig,1)=po(ig,1) + zqla(ig,1)=zl(ig,1) +!cr: attention, prise en compte de f*(1)=1 + f_star(ig,2)=alim_star(ig,1) + zw2(ig,2)=2.*RG*(ztv(ig,1)-ztv(ig,2))/ztv(ig,2) & +& *(zlev(ig,2)-zlev(ig,1)) & +& *0.4*pphi(ig,1)/(pphi(ig,2)-pphi(ig,1)) + w_est(ig,2)=zw2(ig,2) + endif +enddo +! + +!============================================================================== +!boucle de calcul de la vitesse verticale dans le thermique +!============================================================================== +do l=2,nlay-1 +!============================================================================== + + +! On decide si le thermique est encore actif ou non +! AFaire : Il faut sans doute ajouter entr_star a alim_star dans ce test + do ig=1,ngrid + active(ig)=active(ig) & +& .and. zw2(ig,l)>1.e-10 & +& .and. f_star(ig,l)+alim_star(ig,l)>1.e-10 + enddo + + + +!--------------------------------------------------------------------------- +! calcul des proprietes thermodynamiques et de la vitesse de la couche l +! sans tenir compte du detrainement et de l'entrainement dans cette +! couche +! C'est a dire qu'on suppose +! ztla(l)=ztla(l-1) et zqta(l)=zqta(l-1) +! Ici encore, on doit pouvoir ajouter entr_star (qui peut etre calculer +! avant) a l'alimentation pour avoir un calcul plus propre +!--------------------------------------------------------------------------- + + ztemp(:)=zpspsk(:,l)*ztla(:,l-1) + call thermcell_qsat(ngrid,active,pplev(:,l),ztemp,zqta(:,l-1),zqsat(:)) + + do ig=1,ngrid +! print*,'active',active(ig),ig,l + if(active(ig)) then + zqla_est(ig,l)=max(0.,zqta(ig,l-1)-zqsat(ig)) + ztva_est(ig,l) = ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*zqla_est(ig,l) + zta_est(ig,l)=ztva_est(ig,l) + ztva_est(ig,l) = ztva_est(ig,l)/zpspsk(ig,l) + ztva_est(ig,l) = ztva_est(ig,l)*(1.+RETV*(zqta(ig,l-1) & + & -zqla_est(ig,l))-zqla_est(ig,l)) + +!------------------------------------------------ +!AJAM:nouveau calcul de w? +!------------------------------------------------ + zdz=zlev(ig,l+1)-zlev(ig,l) + zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) + + zw2fact=fact_epsilon*2.*zdz/(1.+betalpha) + zdw2=(afact)*zbuoy(ig,l)/(fact_epsilon) + w_est(ig,l+1)=Max(0.0001,exp(-zw2fact)*(w_est(ig,l)-zdw2)+zdw2) + + + if (w_est(ig,l+1).lt.0.) then + w_est(ig,l+1)=zw2(ig,l) + endif + endif + enddo + + +!------------------------------------------------- +!calcul des taux d'entrainement et de detrainement +!------------------------------------------------- + + do ig=1,ngrid + if (active(ig)) then + + zw2m=max(0.5*(w_est(ig,l)+w_est(ig,l+1)),0.1) + zw2m=w_est(ig,l+1) + zdz=zlev(ig,l+1)-zlev(ig,l) + zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) +! zbuoybis=zbuoy(ig,l)+RG*0.1/300. + zbuoybis=zbuoy(ig,l) + zalpha=f0(ig)*f_star(ig,l)/sqrt(w_est(ig,l+1))/rhobarz(ig,l) + zdqt(ig,l)=max(zqta(ig,l-1)-po(ig,l),0.)/po(ig,l) + + + entr_star(ig,l)=f_star(ig,l)*zdz* zbetalpha*MAX(0., & + & afact*zbuoybis/zw2m - fact_epsilon ) + + + detr_star(ig,l)=f_star(ig,l)*zdz & + & *MAX(1.e-3, -afact*zbetalpha*zbuoy(ig,l)/zw2m & + & + 0.012*(zdqt(ig,l)/zw2m)**0.5 ) + +! En dessous de lalim, on prend le max de alim_star et entr_star pour +! alim_star et 0 sinon + if (l.lt.lalim(ig)) then + alim_star(ig,l)=max(alim_star(ig,l),entr_star(ig,l)) + entr_star(ig,l)=0. + endif + +! Calcul du flux montant normalise + f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l) & + & -detr_star(ig,l) + + endif + enddo + + +!---------------------------------------------------------------------------- +!calcul de la vitesse verticale en melangeant Tl et qt du thermique +!--------------------------------------------------------------------------- + activetmp(:)=active(:) .and. f_star(:,l+1)>1.e-10 + do ig=1,ngrid + if (activetmp(ig)) then + Zsat=.false. + ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+ & + & (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l)) & + & /(f_star(ig,l+1)+detr_star(ig,l)) + zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+ & + & (alim_star(ig,l)+entr_star(ig,l))*po(ig,l)) & + & /(f_star(ig,l+1)+detr_star(ig,l)) + + endif + enddo + + ztemp(:)=zpspsk(:,l)*ztla(:,l) + call thermcell_qsat(ngrid,activetmp,pplev(:,l),ztemp,zqta(:,l),zqsatth(:,l)) + + do ig=1,ngrid + if (activetmp(ig)) then +! on ecrit de maniere conservative (sat ou non) +! T = Tl +Lv/Cp ql + zqla(ig,l)=max(0.,zqta(ig,l)-zqsatth(ig,l)) + ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l) + ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l) +!on rajoute le calcul de zha pour diagnostiques (temp potentielle) + zha(ig,l) = ztva(ig,l) + ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) & + & -zqla(ig,l))-zqla(ig,l)) + zbuoy(ig,l)=RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) + zdz=zlev(ig,l+1)-zlev(ig,l) + zeps(ig,l)=(entr_star(ig,l)+alim_star(ig,l))/(f_star(ig,l)*zdz) + + zw2fact=fact_epsilon*2.*zdz/(1.+betalpha) + zdw2=afact*zbuoy(ig,l)/(fact_epsilon) + zw2(ig,l+1)=Max(0.0001,exp(-zw2fact)*(zw2(ig,l)-zdw2)+zdw2) + endif + enddo + + if (prt_level.ge.20) print*,'coucou calcul detr 460: ig, l',ig, l +! +!--------------------------------------------------------------------------- +!initialisations pour le calcul de la hauteur du thermique, de l'inversion et de la vitesse verticale max +!--------------------------------------------------------------------------- + + nbpb=0 + do ig=1,ngrid + if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then +! stop'On tombe sur le cas particulier de thermcell_dry' +! print*,'On tombe sur le cas particulier de thermcell_plume' + nbpb=nbpb+1 + zw2(ig,l+1)=0. + linter(ig)=l+1 + endif + + if (zw2(ig,l+1).lt.0.) then + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) & + & -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. + elseif (f_star(ig,l+1).lt.0.) then + linter(ig)=(l*(f_star(ig,l+1)-f_star(ig,l)) & + & -f_star(ig,l))/(f_star(ig,l+1)-f_star(ig,l)) +! print*,"linter plume", linter(ig) + zw2(ig,l+1)=0. + endif + + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +! lmix est le niveau de la couche ou w (wa_moy) est maximum +!on rajoute le calcul de lmix_bis + if (zqla(ig,l).lt.1.e-10) then + lmix_bis(ig)=l+1 + endif + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + + if (nbpb>0) then + print*,'WARNING on tombe ',nbpb,' x sur un pb pour l=',l,' dans thermcell_plume' + endif + +!========================================================================= +! FIN DE LA BOUCLE VERTICALE + enddo +!========================================================================= + +!on recalcule alim_star_tot + do ig=1,ngrid + alim_star_tot(ig)=0. + enddo + do ig=1,ngrid + do l=1,lalim(ig)-1 + alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l) + enddo + enddo + + + if (prt_level.ge.20) print*,'coucou calcul detr 470: ig, l', ig, l + +#undef wrgrads_thermcell +#ifdef wrgrads_thermcell + call wrgradsfi(1,nlay,entr_star(igout,1:nlay),'esta ','esta ') + call wrgradsfi(1,nlay,detr_star(igout,1:nlay),'dsta ','dsta ') + call wrgradsfi(1,nlay,zbuoy(igout,1:nlay),'buoy ','buoy ') + call wrgradsfi(1,nlay,zdqt(igout,1:nlay),'dqt ','dqt ') + call wrgradsfi(1,nlay,w_est(igout,1:nlay),'w_est ','w_est ') + call wrgradsfi(1,nlay,w_est(igout,2:nlay+1),'w_es2 ','w_es2 ') + call wrgradsfi(1,nlay,zw2(igout,1:nlay),'zw2A ','zw2A ') +#endif + + + return + end +END MODULE lmdz_thermcell_plume_6A Index: LMDZ6/trunk/libf/phylmd/lmdz_thermcell_qsat.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/lmdz_thermcell_qsat.F90 (revision 4590) +++ LMDZ6/trunk/libf/phylmd/lmdz_thermcell_qsat.F90 (revision 4590) @@ -0,0 +1,99 @@ +MODULE lmdz_thermcell_qsat +CONTAINS + +subroutine thermcell_qsat(klon,active,pplev,ztemp,zqta,zqsat) +implicit none + +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" + + +!==================================================================== +! DECLARATIONS +!==================================================================== + +! Arguments +INTEGER klon +REAL zpspsk(klon),pplev(klon) +REAL ztemp(klon),zqta(klon),zqsat(klon) +LOGICAL active(klon) + +! Variables locales +INTEGER ig,iter +REAL Tbef(klon),DT(klon) +REAL tdelta,qsatbef,zcor,qlbef,zdelta,zcvm5,dqsat,num,denom,dqsat_dT +logical Zsat +REAL RLvCp + +REAL, SAVE :: DDT0=.01 +!$OMP THREADPRIVATE(DDT0) + +LOGICAL afaire(klon),tout_converge + +!==================================================================== +! INITIALISATIONS +!==================================================================== + +RLvCp = RLVTT/RCPD +tout_converge=.false. +afaire(:)=.false. +DT(:)=0. + + +!==================================================================== +! Routine a vectoriser en copiant active dans converge et en mettant +! la boucle sur les iterations a l'exterieur est en mettant +! converge= false des que la convergence est atteinte. +!==================================================================== + +do ig=1,klon + if (active(ig)) then + Tbef(ig)=ztemp(ig) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + qsatbef= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig) + qsatbef=MIN(0.5,qsatbef) + zcor=1./(1.-retv*qsatbef) + qsatbef=qsatbef*zcor + qlbef=max(0.,zqta(ig)-qsatbef) + DT(ig) = 0.5*RLvCp*qlbef + zqsat(ig)=qsatbef + endif +enddo + +! Traitement du cas ou il y a condensation mais faible +! On ne condense pas mais on dit que le qsat est le qta +do ig=1,klon + if (active(ig)) then + if (0.ztv(ig,k+1) .AND. ztv(ig,k+1)<=ztv(ig,k+2)) THEN - lentr(ig) = k + 1 - therm = .TRUE. - END IF - END DO - END DO - ! limitation de la valeur du lentr - ! do ig=1,ngrid - ! lentr(ig)=min(5,lentr(ig)) - ! enddo - ! determination du lmin: couche d ou provient le thermique - DO ig = 1, ngrid - lmin(ig) = 1 - END DO - DO ig = 1, ngrid - DO l = nlay, 2, -1 - IF (ztv(ig,l-1)>ztv(ig,l)) THEN - lmin(ig) = l - 1 - END IF - END DO - END DO - ! initialisations - DO ig = 1, ngrid - zalim(ig) = 0. - norme(ig) = 0. - lalim(ig) = 1 - END DO - DO k = 1, klev - 1 - DO ig = 1, ngrid - zalim(ig) = zalim(ig) + zlev(ig, k)*max(0., (ztv(ig,k)-ztv(ig, & - k+1))/(zlev(ig,k+1)-zlev(ig,k))) - ! s *(zlev(ig,k+1)-zlev(ig,k)) - norme(ig) = norme(ig) + max(0., (ztv(ig,k)-ztv(ig,k+1))/(zlev(ig, & - k+1)-zlev(ig,k))) - ! s *(zlev(ig,k+1)-zlev(ig,k)) - END DO - END DO - DO ig = 1, ngrid - IF (norme(ig)>1.E-10) THEN - zalim(ig) = max(10.*zalim(ig)/norme(ig), zlev(ig,2)) - ! zalim(ig)=min(zalim(ig),zlev(ig,lentr(ig))) - END IF - END DO - ! détermination du lalim correspondant - DO k = 1, klev - 1 - DO ig = 1, ngrid - IF ((zalim(ig)>zlev(ig,k)) .AND. (zalim(ig)<=zlev(ig,k+1))) THEN - lalim(ig) = k - END IF - END DO - END DO - - ! definition de l'entrainement des couches - DO l = 1, klev - 1 - DO ig = 1, ngrid - IF (ztv(ig,l)>ztv(ig,l+1) .AND. l>=lmin(ig) .AND. lztv(ig,l+1) .AND. l>=lmin(ig) .AND. l<=lalim(ig) .AND. & - zalim(ig)>1.E-10) THEN - ! if (l.le.lentr(ig)) then - ! entr_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1) - ! s /zalim(ig)))**(3./2.) - ! write(10,*)zlev(ig,l),entr_star(ig,l) - END IF - END DO - END DO - ! endif - ! pas de thermique si couche 1 stable - DO ig = 1, ngrid - IF (lmin(ig)>5) THEN - DO l = 1, klev - entr_star(ig, l) = 0. - END DO - END IF - END DO - ! calcul de l entrainement total - DO ig = 1, ngrid - entr_star_tot(ig) = 0. - END DO - DO ig = 1, ngrid - DO k = 1, klev - entr_star_tot(ig) = entr_star_tot(ig) + entr_star(ig, k) - END DO - END DO - ! Calcul entrainement normalise - DO ig = 1, ngrid - IF (entr_star_tot(ig)>1.E-10) THEN - ! do l=1,lentr(ig) - DO l = 1, klev - ! def possibles pour entr_star: zdthetadz, dthetadz, zdtheta - entr_star(ig, l) = entr_star(ig, l)/entr_star_tot(ig) - END DO - END IF - END DO - - ! print*,'fin calcul entr_star' - DO k = 1, klev - DO ig = 1, ngrid - ztva(ig, k) = ztv(ig, k) - END DO - END DO - ! RC - ! print*,'7 OK convect8' - DO k = 1, klev + 1 - DO ig = 1, ngrid - zw2(ig, k) = 0. - fmc(ig, k) = 0. - ! CR - f_star(ig, k) = 0. - ! RC - larg_cons(ig, k) = 0. - larg_detr(ig, k) = 0. - wa_moy(ig, k) = 0. - END DO - END DO - - ! print*,'8 OK convect8' - DO ig = 1, ngrid - linter(ig) = 1. - lmaxa(ig) = 1 - lmix(ig) = 1 - wmaxa(ig) = 0. - END DO - - ! CR: - DO l = 1, nlay - 2 - DO ig = 1, ngrid - IF (ztv(ig,l)>ztv(ig,l+1) .AND. entr_star(ig,l)>1.E-10 .AND. & - zw2(ig,l)<1E-10) THEN - f_star(ig, l+1) = entr_star(ig, l) - ! test:calcul de dteta - zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* & - (zlev(ig,l+1)-zlev(ig,l))*0.4*pphi(ig, l)/(pphi(ig,l+1)-pphi(ig,l)) - larg_detr(ig, l) = 0. - ELSE IF ((zw2(ig,l)>=1E-10) .AND. (f_star(ig,l)+entr_star(ig, & - l)>1.E-10)) THEN - f_star(ig, l+1) = f_star(ig, l) + entr_star(ig, l) - ztva(ig, l) = (f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)*ztv(ig,l))/ & - f_star(ig, l+1) - zw2(ig, l+1) = zw2(ig, l)*(f_star(ig,l)/f_star(ig,l+1))**2 + & - 2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, l)*(zlev(ig,l+1)-zlev(ig,l)) - END IF - ! determination de zmax continu par interpolation lineaire - IF (zw2(ig,l+1)<0.) THEN - ! test - IF (abs(zw2(ig,l+1)-zw2(ig,l))<1E-10) THEN - ! print*,'pb linter' - END IF - linter(ig) = (l*(zw2(ig,l+1)-zw2(ig,l))-zw2(ig,l))/(zw2(ig,l+1)-zw2( & - ig,l)) - zw2(ig, l+1) = 0. - lmaxa(ig) = l - ELSE - IF (zw2(ig,l+1)<0.) THEN - ! print*,'pb1 zw2<0' - END IF - wa_moy(ig, l+1) = sqrt(zw2(ig,l+1)) - END IF - IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN - ! lmix est le niveau de la couche ou w (wa_moy) est maximum - lmix(ig) = l + 1 - wmaxa(ig) = wa_moy(ig, l+1) - END IF - END DO - END DO - ! print*,'fin calcul zw2' - - ! Calcul de la couche correspondant a la hauteur du thermique - DO ig = 1, ngrid - lmax(ig) = lentr(ig) - ! lmax(ig)=lalim(ig) - END DO - DO ig = 1, ngrid - DO l = nlay, lentr(ig) + 1, -1 - ! do l=nlay,lalim(ig)+1,-1 - IF (zw2(ig,l)<=1.E-10) THEN - lmax(ig) = l - 1 - END IF - END DO - END DO - ! pas de thermique si couche 1 stable - DO ig = 1, ngrid - IF (lmin(ig)>5) THEN - lmax(ig) = 1 - lmin(ig) = 1 - lentr(ig) = 1 - lalim(ig) = 1 - END IF - END DO - - ! Determination de zw2 max - DO ig = 1, ngrid - wmax(ig) = 0. - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - IF (l<=lmax(ig)) THEN - IF (zw2(ig,l)<0.) THEN - ! print*,'pb2 zw2<0' - END IF - zw2(ig, l) = sqrt(zw2(ig,l)) - wmax(ig) = max(wmax(ig), zw2(ig,l)) - ELSE - zw2(ig, l) = 0. - END IF - END DO - END DO - - ! Longueur caracteristique correspondant a la hauteur des thermiques. - DO ig = 1, ngrid - zmax(ig) = 0. - zlevinter(ig) = zlev(ig, 1) - END DO - DO ig = 1, ngrid - ! calcul de zlevinter - zlevinter(ig) = (zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*linter(ig) + & - zlev(ig, lmax(ig)) - lmax(ig)*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig))) - zmax(ig) = max(zmax(ig), zlevinter(ig)-zlev(ig,lmin(ig))) - END DO - DO ig = 1, ngrid - ! write(8,*)zmax(ig),lmax(ig),lentr(ig),lmin(ig) - END DO - ! on stope après les calculs de zmax et wmax - RETURN - - ! print*,'avant fermeture' - ! Fermeture,determination de f - ! Attention! entrainement normalisé ou pas? - DO ig = 1, ngrid - entr_star2(ig) = 0. - END DO - DO ig = 1, ngrid - IF (entr_star_tot(ig)<1.E-10) THEN - f(ig) = 0. - ELSE - DO k = lmin(ig), lentr(ig) - ! do k=lmin(ig),lalim(ig) - entr_star2(ig) = entr_star2(ig) + entr_star(ig, k)**2/(rho(ig,k)*( & - zlev(ig,k+1)-zlev(ig,k))) - END DO - ! Nouvelle fermeture - f(ig) = wmax(ig)/(max(500.,zmax(ig))*r_aspect*entr_star2(ig)) - ! s *entr_star_tot(ig) - ! test - ! if (first) then - f(ig) = f(ig) + (f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)*wmax(ig)) - ! endif - END IF - f0(ig) = f(ig) - ! first=.true. - END DO - ! print*,'apres fermeture' - ! on stoppe après la fermeture - RETURN - ! Calcul de l'entrainement - DO k = 1, klev - DO ig = 1, ngrid - entr(ig, k) = f(ig)*entr_star(ig, k) - END DO - END DO - ! on stoppe après le calcul de entr - ! RETURN - ! CR:test pour entrainer moins que la masse - ! do ig=1,ngrid - ! do l=1,lentr(ig) - ! if ((entr(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then - ! entr(ig,l+1)=entr(ig,l+1)+entr(ig,l) - ! s -0.9*masse(ig,l)/ptimestep - ! entr(ig,l)=0.9*masse(ig,l)/ptimestep - ! endif - ! enddo - ! enddo - ! CR: fin test - ! Calcul des flux - DO ig = 1, ngrid - DO l = 1, lmax(ig) - 1 - fmc(ig, l+1) = fmc(ig, l) + entr(ig, l) - END DO - END DO - - ! RC - - - ! print*,'9 OK convect8' - ! print*,'WA1 ',wa_moy - - ! determination de l'indice du debut de la mixed layer ou w decroit - - ! calcul de la largeur de chaque ascendance dans le cas conservatif. - ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant - ! d'une couche est égale à la hauteur de la couche alimentante. - ! La vitesse maximale dans l'ascendance est aussi prise comme estimation - ! de la vitesse d'entrainement horizontal dans la couche alimentante. - - DO l = 2, nlay - DO ig = 1, ngrid - IF (l<=lmaxa(ig)) THEN - zw = max(wa_moy(ig,l), 1.E-10) - larg_cons(ig, l) = zmax(ig)*r_aspect*fmc(ig, l)/(rhobarz(ig,l)*zw) - END IF - END DO - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - IF (l<=lmaxa(ig)) THEN - ! if (idetr.eq.0) then - ! cette option est finalement en dur. - IF ((l_mix*zlev(ig,l))<0.) THEN - ! print*,'pb l_mix*zlev<0' - END IF - ! CR: test: nouvelle def de lambda - ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) - IF (zw2(ig,l)>1.E-10) THEN - larg_detr(ig, l) = sqrt((l_mix/zw2(ig,l))*zlev(ig,l)) - ELSE - larg_detr(ig, l) = sqrt(l_mix*zlev(ig,l)) - END IF - ! RC - ! else if (idetr.eq.1) then - ! larg_detr(ig,l)=larg_cons(ig,l) - ! s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) - ! else if (idetr.eq.2) then - ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) - ! s *sqrt(wa_moy(ig,l)) - ! else if (idetr.eq.4) then - ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) - ! s *wa_moy(ig,l) - ! endif - END IF - END DO - END DO - - ! print*,'10 OK convect8' - ! print*,'WA2 ',wa_moy - ! calcul de la fraction de la maille concernée par l'ascendance en tenant - ! compte de l'epluchage du thermique. - - ! CR def de zmix continu (profil parabolique des vitesses) - DO ig = 1, ngrid - IF (lmix(ig)>1.) THEN - ! test - IF (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- & - (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- & - zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))- & - (zlev(ig,lmix(ig)))))>1E-10) THEN - - zmix(ig) = ((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)) & - )**2-(zlev(ig,lmix(ig)+1))**2)-(zw2(ig,lmix(ig))-zw2(ig, & - lmix(ig)+1))*((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))/ & - (2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- & - (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- & - zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) - ELSE - zmix(ig) = zlev(ig, lmix(ig)) - ! print*,'pb zmix' - END IF - ELSE - zmix(ig) = 0. - END IF - ! test - IF ((zmax(ig)-zmix(ig))<0.) THEN - zmix(ig) = 0.99*zmax(ig) - ! print*,'pb zmix>zmax' - END IF - END DO - - ! calcul du nouveau lmix correspondant - DO ig = 1, ngrid - DO l = 1, klev - IF (zmix(ig)>=zlev(ig,l) .AND. zmix(ig)1.) THEN - ! print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' - fraca(ig, l) = (larg_cons(ig,l)-larg_detr(ig,l))/(r_aspect*zmax(ig)) - ! test - fraca(ig, l) = max(fraca(ig,l), 0.) - fraca(ig, l) = min(fraca(ig,l), 0.5) - fracd(ig, l) = 1. - fraca(ig, l) - fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) - ELSE - ! wa_moy(ig,l)=0. - fraca(ig, l) = 0. - fracc(ig, l) = 0. - fracd(ig, l) = 1. - END IF - END DO - END DO - ! CR: calcul de fracazmix - DO ig = 1, ngrid - fracazmix(ig) = (fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ & - (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + & - fraca(ig, lmix(ig)) - zlev(ig, lmix(ig))*(fraca(ig,lmix(ig)+1)-fraca(ig & - ,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig))) - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - IF (larg_cons(ig,l)>1.) THEN - IF (l>lmix(ig)) THEN - ! test - IF (zmax(ig)-zmix(ig)<1.E-10) THEN - ! print*,'pb xxx' - xxx(ig, l) = (lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig)) - ELSE - xxx(ig, l) = (zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig)) - END IF - IF (idetr==0) THEN - fraca(ig, l) = fracazmix(ig) - ELSE IF (idetr==1) THEN - fraca(ig, l) = fracazmix(ig)*xxx(ig, l) - ELSE IF (idetr==2) THEN - fraca(ig, l) = fracazmix(ig)*(1.-(1.-xxx(ig,l))**2) - ELSE - fraca(ig, l) = fracazmix(ig)*xxx(ig, l)**2 - END IF - ! print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' - fraca(ig, l) = max(fraca(ig,l), 0.) - fraca(ig, l) = min(fraca(ig,l), 0.5) - fracd(ig, l) = 1. - fraca(ig, l) - fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) - END IF - END IF - END DO - END DO - - ! print*,'fin calcul fraca' - ! print*,'11 OK convect8' - ! print*,'Ea3 ',wa_moy - ! ------------------------------------------------------------------ - ! Calcul de fracd, wd - ! somme wa - wd = 0 - ! ------------------------------------------------------------------ - - - DO ig = 1, ngrid - fm(ig, 1) = 0. - fm(ig, nlay+1) = 0. - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - fm(ig, l) = fraca(ig, l)*wa_moy(ig, l)*rhobarz(ig, l) - ! CR:test - IF (entr(ig,l-1)<1E-10 .AND. fm(ig,l)>fm(ig,l-1) .AND. l>lmix(ig)) THEN - fm(ig, l) = fm(ig, l-1) - ! write(1,*)'ajustement fm, l',l - END IF - ! write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) - ! RC - END DO - DO ig = 1, ngrid - IF (fracd(ig,l)<0.1) THEN - abort_message = 'fracd trop petit' - CALL abort_physic(modname, abort_message, 1) - - ELSE - ! vitesse descendante "diagnostique" - wd(ig, l) = fm(ig, l)/(fracd(ig,l)*rhobarz(ig,l)) - END IF - END DO - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) - masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg - END DO - END DO - - ! print*,'12 OK convect8' - ! print*,'WA4 ',wa_moy - ! c------------------------------------------------------------------ - ! calcul du transport vertical - ! ------------------------------------------------------------------ - - GO TO 4444 - ! print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep - DO l = 2, nlay - 1 - DO ig = 1, ngrid - IF (fm(ig,l+1)*ptimestep>masse(ig,l) .AND. fm(ig,l+1)*ptimestep>masse( & - ig,l+1)) THEN - ! print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' - ! s ,fm(ig,l+1)*ptimestep - ! s ,' M=',masse(ig,l),masse(ig,l+1) - END IF - END DO - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - IF (entr(ig,l)*ptimestep>masse(ig,l)) THEN - ! print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' - ! s ,entr(ig,l)*ptimestep - ! s ,' M=',masse(ig,l) - END IF - END DO - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - IF (.NOT. fm(ig,l)>=0. .OR. .NOT. fm(ig,l)<=10.) THEN - ! print*,'WARN!!! fm exagere ig=',ig,' l=',l - ! s ,' FM=',fm(ig,l) - END IF - IF (.NOT. masse(ig,l)>=1.E-10 .OR. .NOT. masse(ig,l)<=1.E4) THEN - ! print*,'WARN!!! masse exagere ig=',ig,' l=',l - ! s ,' M=',masse(ig,l) - ! print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', - ! s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) - ! print*,'zlev(ig,l+1),zlev(ig,l)' - ! s ,zlev(ig,l+1),zlev(ig,l) - ! print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' - ! s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) - END IF - IF (.NOT. entr(ig,l)>=0. .OR. .NOT. entr(ig,l)<=10.) THEN - ! print*,'WARN!!! entr exagere ig=',ig,' l=',l - ! s ,' E=',entr(ig,l) - END IF - END DO - END DO - -4444 CONTINUE - - ! CR:redefinition du entr - DO l = 1, nlay - DO ig = 1, ngrid - detr(ig, l) = fm(ig, l) + entr(ig, l) - fm(ig, l+1) - IF (detr(ig,l)<0.) THEN - ! entr(ig,l)=entr(ig,l)-detr(ig,l) - fm(ig, l+1) = fm(ig, l) + entr(ig, l) - detr(ig, l) = 0. - ! print*,'WARNING !!! detrainement negatif ',ig,l - END IF - END DO - END DO - ! RC - IF (w2di==1) THEN - fm0 = fm0 + ptimestep*(fm-fm0)/tho - entr0 = entr0 + ptimestep*(entr-entr0)/tho - ELSE - fm0 = fm - entr0 = entr - END IF - - IF (1==1) THEN - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zh, zdhadj, & - zha) - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zo, pdoadj, & - zoa) - ELSE - CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, & - zdhadj, zha) - CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, & - pdoadj, zoa) - END IF - - IF (1==0) THEN - CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, & - zu, zv, pduadj, pdvadj, zua, zva) - ELSE - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, & - zua) - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, & - zva) - END IF - - DO l = 1, nlay - DO ig = 1, ngrid - zf = 0.5*(fracc(ig,l)+fracc(ig,l+1)) - zf2 = zf/(1.-zf) - thetath2(ig, l) = zf2*(zha(ig,l)-zh(ig,l))**2 - wth2(ig, l) = zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 - END DO - END DO - - - - ! print*,'13 OK convect8' - ! print*,'WA5 ',wa_moy - DO l = 1, nlay - DO ig = 1, ngrid - pdtadj(ig, l) = zdhadj(ig, l)*zpspsk(ig, l) - END DO - END DO - - - ! do l=1,nlay - ! do ig=1,ngrid - ! if(abs(pdtadj(ig,l))*86400..gt.500.) then - ! print*,'WARN!!! ig=',ig,' l=',l - ! s ,' pdtadj=',pdtadj(ig,l) - ! endif - ! if(abs(pdoadj(ig,l))*86400..gt.1.) then - ! print*,'WARN!!! ig=',ig,' l=',l - ! s ,' pdoadj=',pdoadj(ig,l) - ! endif - ! enddo - ! enddo - - ! print*,'14 OK convect8' - ! ------------------------------------------------------------------ - ! Calculs pour les sorties - ! ------------------------------------------------------------------ - - IF (sorties) THEN - DO l = 1, nlay - DO ig = 1, ngrid - zla(ig, l) = (1.-fracd(ig,l))*zmax(ig) - zld(ig, l) = fracd(ig, l)*zmax(ig) - IF (1.-fracd(ig,l)>1.E-10) zwa(ig, l) = wd(ig, l)*fracd(ig, l)/ & - (1.-fracd(ig,l)) - END DO - END DO - - ! deja fait - ! do l=1,nlay - ! do ig=1,ngrid - ! detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) - ! if (detr(ig,l).lt.0.) then - ! entr(ig,l)=entr(ig,l)-detr(ig,l) - ! detr(ig,l)=0. - ! print*,'WARNING !!! detrainement negatif ',ig,l - ! endif - ! enddo - ! enddo - - ! print*,'15 OK convect8' - - isplit = isplit + 1 - - - ! #define und - GO TO 123 -#ifdef und - CALL writeg1d(1, nlay, wd, 'wd ', 'wd ') - CALL writeg1d(1, nlay, zwa, 'wa ', 'wa ') - CALL writeg1d(1, nlay, fracd, 'fracd ', 'fracd ') - CALL writeg1d(1, nlay, fraca, 'fraca ', 'fraca ') - CALL writeg1d(1, nlay, wa_moy, 'wam ', 'wam ') - CALL writeg1d(1, nlay, zla, 'la ', 'la ') - CALL writeg1d(1, nlay, zld, 'ld ', 'ld ') - CALL writeg1d(1, nlay, pt, 'pt ', 'pt ') - CALL writeg1d(1, nlay, zh, 'zh ', 'zh ') - CALL writeg1d(1, nlay, zha, 'zha ', 'zha ') - CALL writeg1d(1, nlay, zu, 'zu ', 'zu ') - CALL writeg1d(1, nlay, zv, 'zv ', 'zv ') - CALL writeg1d(1, nlay, zo, 'zo ', 'zo ') - CALL writeg1d(1, nlay, wh, 'wh ', 'wh ') - CALL writeg1d(1, nlay, wu, 'wu ', 'wu ') - CALL writeg1d(1, nlay, wv, 'wv ', 'wv ') - CALL writeg1d(1, nlay, wo, 'w15uo ', 'wXo ') - CALL writeg1d(1, nlay, zdhadj, 'zdhadj ', 'zdhadj ') - CALL writeg1d(1, nlay, pduadj, 'pduadj ', 'pduadj ') - CALL writeg1d(1, nlay, pdvadj, 'pdvadj ', 'pdvadj ') - CALL writeg1d(1, nlay, pdoadj, 'pdoadj ', 'pdoadj ') - CALL writeg1d(1, nlay, entr, 'entr ', 'entr ') - CALL writeg1d(1, nlay, detr, 'detr ', 'detr ') - CALL writeg1d(1, nlay, fm, 'fm ', 'fm ') - - CALL writeg1d(1, nlay, pdtadj, 'pdtadj ', 'pdtadj ') - CALL writeg1d(1, nlay, pplay, 'pplay ', 'pplay ') - CALL writeg1d(1, nlay, pplev, 'pplev ', 'pplev ') - - ! recalcul des flux en diagnostique... - ! print*,'PAS DE TEMPS ',ptimestep - CALL dt2f(pplev, pplay, pt, pdtadj, wh) - CALL writeg1d(1, nlay, wh, 'wh2 ', 'wh2 ') -#endif -123 CONTINUE - - END IF - - ! if(wa_moy(1,4).gt.1.e-10) stop - - ! print*,'19 OK convect8' - RETURN -END SUBROUTINE calcul_sec - -SUBROUTINE fermeture_seche(ngrid, nlay, pplay, pplev, pphi, zlev, rhobarz, & - f0, zpspsk, alim_star, zh, zo, lentr, lmin, nu_min, nu_max, r_aspect, & - zmax, wmax) - - USE dimphy - IMPLICIT NONE - - include "YOMCST.h" - - INTEGER ngrid, nlay - REAL pplay(ngrid, nlay), pplev(ngrid, nlay+1) - REAL pphi(ngrid, nlay) - REAL zlev(klon, klev+1) - REAL alim_star(klon, klev) - REAL f0(klon) - INTEGER lentr(klon) - INTEGER lmin(klon) - REAL zmax(klon) - REAL wmax(klon) - REAL nu_min - REAL nu_max - REAL r_aspect - REAL rhobarz(klon, klev+1) - REAL zh(klon, klev) - REAL zo(klon, klev) - REAL zpspsk(klon, klev) - - INTEGER ig, l - - REAL f_star(klon, klev+1) - REAL detr_star(klon, klev) - REAL entr_star(klon, klev) - REAL zw2(klon, klev+1) - REAL linter(klon) - INTEGER lmix(klon) - INTEGER lmax(klon) - REAL zlevinter(klon) - REAL wa_moy(klon, klev+1) - REAL wmaxa(klon) - REAL ztv(klon, klev) - REAL ztva(klon, klev) - REAL nu(klon, klev) - ! real zmax0_sec(klon) - ! save zmax0_sec - REAL, SAVE, ALLOCATABLE :: zmax0_sec(:) - !$OMP THREADPRIVATE(zmax0_sec) - LOGICAL, SAVE :: first = .TRUE. - !$OMP THREADPRIVATE(first) - - IF (first) THEN - ALLOCATE (zmax0_sec(klon)) - first = .FALSE. - END IF - - DO l = 1, nlay - DO ig = 1, ngrid - ztv(ig, l) = zh(ig, l)/zpspsk(ig, l) - ztv(ig, l) = ztv(ig, l)*(1.+retv*zo(ig,l)) - END DO - END DO - DO l = 1, nlay - 2 - DO ig = 1, ngrid - IF (ztv(ig,l)>ztv(ig,l+1) .AND. alim_star(ig,l)>1.E-10 .AND. & - zw2(ig,l)<1E-10) THEN - f_star(ig, l+1) = alim_star(ig, l) - ! test:calcul de dteta - zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* & - (zlev(ig,l+1)-zlev(ig,l))*0.4*pphi(ig, l)/(pphi(ig,l+1)-pphi(ig,l)) - ELSE IF ((zw2(ig,l)>=1E-10) .AND. (f_star(ig,l)+alim_star(ig, & - l))>1.E-10) THEN - ! estimation du detrainement a partir de la geometrie du pas - ! precedent - ! tests sur la definition du detr - nu(ig, l) = (nu_min+nu_max)/2.*(1.-(nu_max-nu_min)/(nu_max+nu_min)* & - tanh((((ztva(ig,l-1)-ztv(ig,l))/ztv(ig,l))/0.0005))) - - detr_star(ig, l) = rhobarz(ig, l)*sqrt(zw2(ig,l))/ & - (r_aspect*zmax0_sec(ig))* & ! s - ! /(r_aspect*zmax0(ig))* - (sqrt(nu(ig,l)*zlev(ig,l+1)/sqrt(zw2(ig,l)))-sqrt(nu(ig,l)*zlev(ig, & - l)/sqrt(zw2(ig,l)))) - detr_star(ig, l) = detr_star(ig, l)/f0(ig) - IF ((detr_star(ig,l))>f_star(ig,l)) THEN - detr_star(ig, l) = f_star(ig, l) - END IF - entr_star(ig, l) = 0.9*detr_star(ig, l) - IF ((l1.E-10) THEN - ! AM on melange Tl et qt du thermique - ztva(ig, l) = (f_star(ig,l)*ztva(ig,l-1)+(entr_star(ig, & - l)+alim_star(ig,l))*ztv(ig,l))/(f_star(ig,l+1)+detr_star(ig,l)) - zw2(ig, l+1) = zw2(ig, l)*(f_star(ig,l)/(f_star(ig, & - l+1)+detr_star(ig,l)))**2 + 2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, & - l)*(zlev(ig,l+1)-zlev(ig,l)) - END IF - END IF - - IF (zw2(ig,l+1)<0.) THEN - linter(ig) = (l*(zw2(ig,l+1)-zw2(ig,l))-zw2(ig,l))/(zw2(ig,l+1)-zw2( & - ig,l)) - zw2(ig, l+1) = 0. - ! print*,'linter=',linter(ig) - ELSE - wa_moy(ig, l+1) = sqrt(zw2(ig,l+1)) - END IF - IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN - ! lmix est le niveau de la couche ou w (wa_moy) est maximum - lmix(ig) = l + 1 - wmaxa(ig) = wa_moy(ig, l+1) - END IF - END DO - END DO - ! print*,'fin calcul zw2' - - ! Calcul de la couche correspondant a la hauteur du thermique - DO ig = 1, ngrid - lmax(ig) = lentr(ig) - END DO - DO ig = 1, ngrid - DO l = nlay, lentr(ig) + 1, -1 - IF (zw2(ig,l)<=1.E-10) THEN - lmax(ig) = l - 1 - END IF - END DO - END DO - ! pas de thermique si couche 1 stable - DO ig = 1, ngrid - IF (lmin(ig)>1) THEN - lmax(ig) = 1 - lmin(ig) = 1 - lentr(ig) = 1 - END IF - END DO - - ! Determination de zw2 max - DO ig = 1, ngrid - wmax(ig) = 0. - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - IF (l<=lmax(ig)) THEN - IF (zw2(ig,l)<0.) THEN - ! print*,'pb2 zw2<0' - END IF - zw2(ig, l) = sqrt(zw2(ig,l)) - wmax(ig) = max(wmax(ig), zw2(ig,l)) - ELSE - zw2(ig, l) = 0. - END IF - END DO - END DO - - ! Longueur caracteristique correspondant a la hauteur des thermiques. - DO ig = 1, ngrid - zmax(ig) = 0. - zlevinter(ig) = zlev(ig, 1) - END DO - DO ig = 1, ngrid - ! calcul de zlevinter - zlevinter(ig) = (zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*linter(ig) + & - zlev(ig, lmax(ig)) - lmax(ig)*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig))) - ! pour le cas ou on prend tjs lmin=1 - ! zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) - zmax(ig) = max(zmax(ig), zlevinter(ig)-zlev(ig,1)) - zmax0_sec(ig) = zmax(ig) - END DO - - RETURN -END SUBROUTINE fermeture_seche Index: LMDZ6/trunk/libf/phylmd/thermcell_alim.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/thermcell_alim.F90 (revision 4589) +++ (revision ) @@ -1,123 +1,0 @@ -! -! $Id: thermcell_plume.F90 2311 2015-06-25 07:45:24Z emillour $ -! - SUBROUTINE thermcell_alim(flag,ngrid,klev,ztv,d_temp,zlev,alim_star,lalim) -IMPLICIT NONE - -!-------------------------------------------------------------------------- -! FH : 2015/11/06 -! thermcell_alim: calcule la distribution verticale de l'alimentation -! laterale a la base des panaches thermiques -!-------------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: ngrid,klev - REAL, INTENT(IN) :: ztv(ngrid,klev) - REAL, INTENT(IN) :: d_temp(ngrid) - REAL, INTENT(IN) :: zlev(ngrid,klev+1) - REAL, INTENT(OUT) :: alim_star(ngrid,klev) - INTEGER, INTENT(OUT) :: lalim(ngrid) - INTEGER, INTENT(IN) :: flag - - REAL :: alim_star_tot(ngrid),zi(ngrid),zh(ngrid) - REAL :: zlay(ngrid,klev) - REAL ztv_parcel - - INTEGER ig,l - - REAL h,z,falim - falim(h,z)=0.2*((z-h)**5+h**5) - - -!=================================================================== - - lalim(:)=1 - alim_star_tot(:)=0. - -!------------------------------------------------------------------------- -! Definition de l'alimentation -!------------------------------------------------------------------------- - IF (flag==0) THEN ! CMIP5 version - do l=1,klev-1 - do ig=1,ngrid - if (ztv(ig,l)> ztv(ig,l+1) .and. ztv(ig,1)>=ztv(ig,l) ) then - alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.) & - & *sqrt(zlev(ig,l+1)) - lalim(ig)=l+1 - alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l) - endif - enddo - enddo - do l=1,klev - do ig=1,ngrid - if (alim_star_tot(ig) > 1.e-10 ) then - alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig) - endif - enddo - enddo - alim_star_tot(:)=1. - -!------------------------------------------------------------------------- -! Nouvelle definition avec possibilite d'introduire un DT en surface -! On suppose que la forme du profile d'alimentation scale avec la hauteur -! d'inversion calculée avec une particule partant de la premieere couche - -! Fonction f(z) = z ( h - z ) , avec h = zi/3 -! On utilise l'integralle -! Int_0^z f(z') dz' = z^2 ( h/2 - z/3 ) = falim(h,z) -! Pour calculer l'alimentation des couches -!------------------------------------------------------------------------- - ELSE -! Computing inversion height zi and zh=zi/3. - zi(:)=0. -! Il faut recalculer zlay qui n'est pas dispo dans thermcell_plume -! A changer eventuellement. - do l=1,klev - zlay(:,l)=0.5*(zlev(:,l)+zlev(:,l+1)) - enddo - - do l=klev-1,1,-1 - do ig=1,ngrid - ztv_parcel=ztv(ig,1)+d_temp(ig) - if (ztv_parcel zmax alors on pose zlcl = zmax - else - rhobarz0(ig)=0. - zlcl(ig)=zmax(ig) - endif - enddo -!!jyg fin - -!------------Calcul des propriétés du thermique au LCL - IF ( (iflag_trig_bl.ge.1) .or. (iflag_clos_bl.ge.1) ) THEN - - !-----Initialisation de la TKE moyenne - do l=1,nlay - do ig=1,ngrid - pbl_tke_max(ig,l)=0. - enddo - enddo - -!-----Calcul de la TKE moyenne - do nsrf=1,nbsrf - do l=1,nlay - do ig=1,ngrid - pbl_tke_max(ig,l)=pctsrf(ig,nsrf)*pbl_tke(ig,l,nsrf)+pbl_tke_max(ig,l) - enddo - enddo - enddo - -!-----Initialisations des TKE dans et hors des thermiques - do l=1,nlay - do ig=1,ngrid - therm_tke_max(ig,l)=pbl_tke_max(ig,l) - env_tke_max(ig,l)=pbl_tke_max(ig,l) - enddo - enddo - -!-----Calcul de la TKE transportée par les thermiques : therm_tke_max - call thermcell_tke_transport(ngrid,nlay,ptimestep,fm0,entr0, & ! in - & rg,pplev,therm_tke_max) ! out -! print *,' thermcell_tke_transport -> ' !!jyg - -!-----Calcul des profils verticaux de TKE hors thermiques : env_tke_max, et de la vitesse verticale grande échelle : W_ls - do l=1,nlay - do ig=1,ngrid - pbl_tke_max(ig,l)=fraca(ig,l)*therm_tke_max(ig,l)+(1.-fraca(ig,l))*env_tke_max(ig,l) ! Recalcul de TKE moyenne aprés transport de TKE_TH - env_tke_max(ig,l)=(pbl_tke_max(ig,l)-fraca(ig,l)*therm_tke_max(ig,l))/(1.-fraca(ig,l)) ! Recalcul de TKE dans l'environnement aprés transport de TKE_TH - w_ls(ig,l)=-1.*omega(ig,l)/(RG*rhobarz(ig,l)) ! Vitesse verticale de grande échelle - enddo - enddo -! print *,' apres w_ls = ' !!jyg - - do ig=1,ngrid - if (ok_lcl(ig)) then - fraca0(ig)=fraca(ig,klcl(ig))+(fraca(ig,klcl(ig)+1) & - & -fraca(ig,klcl(ig)))*interp(ig) - w0(ig)=zw2(ig,klcl(ig))+(zw2(ig,klcl(ig)+1) & - & -zw2(ig,klcl(ig)))*interp(ig) - w_conv(ig)=w_ls(ig,klcl(ig))+(w_ls(ig,klcl(ig)+1) & - & -w_ls(ig,klcl(ig)))*interp(ig) - therm_tke_max0(ig)=therm_tke_max(ig,klcl(ig)) & - & +(therm_tke_max(ig,klcl(ig)+1)-therm_tke_max(ig,klcl(ig)))*interp(ig) - env_tke_max0(ig)=env_tke_max(ig,klcl(ig))+(env_tke_max(ig,klcl(ig)+1) & - & -env_tke_max(ig,klcl(ig)))*interp(ig) - pbl_tke_max0(ig)=pbl_tke_max(ig,klcl(ig))+(pbl_tke_max(ig,klcl(ig)+1) & - & -pbl_tke_max(ig,klcl(ig)))*interp(ig) - if (therm_tke_max0(ig).ge.20.) therm_tke_max0(ig)=20. - if (env_tke_max0(ig).ge.20.) env_tke_max0(ig)=20. - if (pbl_tke_max0(ig).ge.20.) pbl_tke_max0(ig)=20. - else - fraca0(ig)=0. - w0(ig)=0. -!!jyg le 27/04/2012 -!! zlcl(ig)=0. -!! - endif - enddo - - ENDIF ! IF ( (iflag_trig_bl.ge.1) .or. (iflag_clos_bl.ge.1) ) -! print *,'ENDIF ( (iflag_trig_bl.ge.1) .or. (iflag_clos_bl.ge.1) ) ' !!jyg - -!------------Triggering------------------ - IF (iflag_trig_bl.ge.1) THEN - -!-----Initialisations - depth(:)=0. - n2(:)=0. - s2(:)=100. ! some low value, arbitrary - s_max(:)=0. - -!-----Epaisseur du nuage (depth) et détermination de la queue du spectre de panaches (n2,s2) et du panache le plus gros (s_max) - do ig=1,ngrid - zmax_moy(ig)=zlcl(ig)+zmax_moy_coef*(zmax(ig)-zlcl(ig)) - depth(ig)=zmax_moy(ig)-zlcl(ig) - hmin(ig)=hmincoef*zlcl(ig) - if (depth(ig).ge.10.) then - s2(ig)=(hcoef*depth(ig)+hmin(ig))**2 - n2(ig)=(1.-eps1)*fraca0(ig)*airephy(ig)/s2(ig) -!! -!!jyg le 27/04/2012 -!! s_max(ig)=s2(ig)*log(n2(ig)) -!! if (n2(ig) .lt. 1) s_max(ig)=0. - s_max(ig)=s2(ig)*log(max(n2(ig),1.)) -!!fin jyg - else - n2(ig)=0. - s_max(ig)=0. - endif - enddo -! print *,'avant Calcul de Wmax ' !!jyg - - susqr2pi=su_cst*sqrt(2.*Rpi) - reuler=exp(1.) - do ig=1,ngrid - if ( (depth(ig).ge.10.) .and. (s_max(ig).gt.susqr2pi*reuler) ) then - w_max(ig)=w0(ig)*(1.+sqrt(2.*log(s_max(ig)/susqr2pi)-log(2.*log(s_max(ig)/susqr2pi)))) - ale_bl_stat(ig)=0.5*w_max(ig)**2 - else - w_max(ig)=0. - ale_bl_stat(ig)=0. - endif - enddo - - ENDIF ! iflag_trig_bl -! print *,'ENDIF iflag_trig_bl' !!jyg - -!------------Closure------------------ - - IF (iflag_clos_bl.ge.2) THEN - -!-----Calcul de ALP_BL_STAT - do ig=1,ngrid - alp_bl_det(ig)=0.5*coef_m*rhobarz0(ig)*(w0(ig)**3)*fraca0(ig)*(1.-2.*fraca0(ig))/((1.-fraca0(ig))**2) - alp_bl_fluct_m(ig)=1.5*rhobarz0(ig)*fraca0(ig)*(w_conv(ig)+coef_m*w0(ig))* & - & (w0(ig)**2) - alp_bl_fluct_tke(ig)=3.*coef_m*rhobarz0(ig)*w0(ig)*fraca0(ig)*(therm_tke_max0(ig)-env_tke_max0(ig)) & - & +3.*rhobarz0(ig)*w_conv(ig)*pbl_tke_max0(ig) - if (iflag_clos_bl.ge.2) then - alp_bl_conv(ig)=1.5*coef_m*rhobarz0(ig)*fraca0(ig)*(fraca0(ig)/(1.-fraca0(ig)))*w_conv(ig)* & - & (w0(ig)**2) - else - alp_bl_conv(ig)=0. - endif - alp_bl_stat(ig)=alp_bl_det(ig)+alp_bl_fluct_m(ig)+alp_bl_fluct_tke(ig)+alp_bl_conv(ig) - enddo - -!-----Sécurité ALP infinie - do ig=1,ngrid - if (fraca0(ig).gt.0.98) alp_bl_stat(ig)=2. - enddo - - ENDIF ! (iflag_clos_bl.ge.2) - -!!! fin nrlmd le 10/04/2012 - -! print*,'avant calcul ale et alp' -!calcul de ALE et ALP pour la convection - alp_bl(:)=0. - ale_bl(:)=0. -! print*,'ALE,ALP ,l,zw2(ig,l),ale_bl(ig),alp_bl(ig)' - do l=1,nlay - do ig=1,ngrid - alp_bl(ig)=max(alp_bl(ig),0.5*rhobarz(ig,l)*wth3(ig,l) ) - ale_bl(ig)=max(ale_bl(ig),0.5*zw2(ig,l)**2) -! print*,'ALE,ALP',l,zw2(ig,l),ale_bl(ig),alp_bl(ig) - enddo - enddo - -! ale sec (max de wmax/2 sous la zone d'inhibition) dans -! le cas iflag_trig_bl=3 - IF (iflag_trig_bl==3) ale_bl(:)=0.5*wmax_sec(:)**2 - -!test:calcul de la ponderation des couches pour KE -!initialisations - - fm_tot(:)=0. - wght_th(:,:)=1. - lalim_conv(:)=lalim(:) - - do k=1,nlay - do ig=1,ngrid - if (k<=lalim_conv(ig)) fm_tot(ig)=fm_tot(ig)+fm(ig,k) - enddo - enddo - -! assez bizarre car, si on est dans la couche d'alim et que alim_star et -! plus petit que 1.e-10, on prend wght_th=1. - do k=1,nlay - do ig=1,ngrid - if (k<=lalim_conv(ig).and.alim_star(ig,k)>1.e-10) then - wght_th(ig,k)=alim_star(ig,k) - endif - enddo - enddo - -! print*,'apres wght_th' -!test pour prolonger la convection - do ig=1,ngrid -!v1d if ((alim_star(ig,1).lt.1.e-10).and.(therm)) then - if ((alim_star(ig,1).lt.1.e-10)) then - lalim_conv(ig)=1 - wght_th(ig,1)=1. -! print*,'lalim_conv ok',lalim_conv(ig),wght_th(ig,1) - endif - enddo - -!------------------------------------------------------------------------ -! Modif CR/FH 20110310 : alp integree sur la verticale. -! Integrale verticale de ALP. -! wth3 etant aux niveaux inter-couches, on utilise d play comme masse des -! couches -!------------------------------------------------------------------------ - - alp_int(:)=0. - dp_int(:)=0. - do l=2,nlay - do ig=1,ngrid - if(l.LE.lmax(ig)) THEN - zdp=pplay(ig,l-1)-pplay(ig,l) - alp_int(ig)=alp_int(ig)+0.5*rhobarz(ig,l)*wth3(ig,l)*zdp - dp_int(ig)=dp_int(ig)+zdp - endif - enddo - enddo - - if (iflag_coupl>=3 .and. iflag_coupl<=5) then - do ig=1,ngrid -!valeur integree de alp_bl * 0.5: - if (dp_int(ig)>0.) then - alp_bl(ig)=alp_int(ig)/dp_int(ig) - endif - enddo! - endif - - -! Facteur multiplicatif sur alp_bl - alp_bl(:)=alp_bl_k*alp_bl(:) - -!------------------------------------------------------------------------ - - - - return - end Index: LMDZ6/trunk/libf/phylmd/thermcell_closure.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/thermcell_closure.F90 (revision 4589) +++ (revision ) @@ -1,71 +1,0 @@ -! -! $Header$ -! - SUBROUTINE thermcell_closure(ngrid,nlay,r_aspect,ptimestep,rho, & - & zlev,lalim,alim_star,zmax,wmax,f) - -!------------------------------------------------------------------------- -!thermcell_closure: fermeture, determination de f -! -! Modification 7 septembre 2009 -! 1. On enleve alim_star_tot des arguments pour le recalculer et etre ainis -! coherent avec l'integrale au numerateur. -! 2. On ne garde qu'une version des couples wmax,zmax et wmax_sec,zmax_sec -! l'idee etant que le choix se fasse a l'appel de thermcell_closure -! 3. Vectorisation en mettant les boucles en l l'exterieur avec des if -!------------------------------------------------------------------------- - IMPLICIT NONE - -! --- arguments ------------------------------------------ -integer, intent(in) :: ngrid,nlay -real, intent(in) :: r_aspect,ptimestep -real, intent(in), dimension(ngrid,nlay) :: alim_star,rho,zlev -integer, intent(in), dimension(ngrid) :: lalim -real, intent(in), dimension(ngrid) :: zmax,wmax - -real, intent(out), dimension(ngrid) :: f - - -! --- local ------------------------------------------ -real, dimension(ngrid) :: zdenom,alim_star2,alim_star_tot -INTEGER llmax -INTEGER ig,k - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!print*,'THERMCELL CLOSURE 26E' - -alim_star2(:)=0. -alim_star_tot(:)=0. -f(:)=0. - -! Indice vertical max (max de lalim) atteint par les thermiques sur le domaine -llmax=1 -do ig=1,ngrid - if (lalim(ig)>llmax) llmax=lalim(ig) -enddo - - -! Calcul des integrales sur la verticale de alim_star et de -! alim_star^2/(rho dz) -do k=1,llmax-1 - do ig=1,ngrid - if (k1.e-10) then - f(ig)=wmax(ig)*alim_star_tot(ig)/ & -& (max(500.,zmax(ig))*r_aspect*alim_star2(ig)) - endif -enddo - - - - RETURN - end Index: LMDZ6/trunk/libf/phylmd/thermcell_down.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/thermcell_down.F90 (revision 4589) +++ (revision ) @@ -1,300 +1,0 @@ -SUBROUTINE thermcell_updown_dq(ngrid,nlay,ptimestep,lmax,eup,dup,edn,ddn,masse,trac,dtrac) - -USE thermcell_ini_mod, ONLY: iflag_thermals_down - - -!----------------------------------------------------------------- -! thermcell_updown_dq: computes the tendency of tracers associated -! with the presence of convective up/down drafts -! This routine that has been collectively written during the -! "ateliers downdrafts" in 2022/2023 -! Maelle, Frédéric, Catherine, Fleur, Florent, Etienne -!------------------------------------------------------------------ - - - IMPLICIT NONE - -! declarations -!============================================================== - -! input/output - - integer,intent(in) :: ngrid ! number of horizontal grid points - integer, intent(in) :: nlay ! number of vertical layers - real,intent(in) :: ptimestep ! time step of the physics [s] - real,intent(in), dimension(ngrid,nlay) :: eup ! entrainment to updrafts * dz [same unit as flux] - real,intent(in), dimension(ngrid,nlay) :: dup ! detrainment from updrafts * dz [same unit as flux] - real,intent(in), dimension(ngrid,nlay) :: edn ! entrainment to downdrafts * dz [same unit as flux] - real,intent(in), dimension(ngrid,nlay) :: ddn ! detrainment from downdrafts * dz [same unit as flux] - real,intent(in), dimension(ngrid,nlay) :: masse ! mass of layers = rho dz - real,intent(in), dimension(ngrid,nlay) :: trac ! tracer - integer, intent(in), dimension(ngrid) :: lmax ! max level index at which downdraft are present - real,intent(out),dimension(ngrid,nlay) ::dtrac ! tendance du traceur - - -! Local - - real, dimension(ngrid,nlay+1) :: fup,fdn,fc,fthu,fthd,fthe,fthtot - real, dimension(ngrid,nlay) :: tracu,tracd,traci,tracold - real :: www, mstar_inv - integer ig,ilay - real, dimension(ngrid,nlay):: s1,s2,num !coefficients pour la resolution implicite - integer :: iflag_impl=1 ! 0 pour explicite, 1 pour implicite "classique", 2 pour implicite avec entrainement et detrainement - - fdn(:,:)=0. - fup(:,:)=0. - fc(:,:)=0. - fthu(:,:)=0. - fthd(:,:)=0. - fthe(:,:)=0. - fthtot(:,:)=0. - tracd(:,:)=0. - tracu(:,:)=0. - traci(:,:)=trac(:,:) - tracold(:,:)=trac(:,:) - s1(:,:)=0. - s2(:,:)=0. - num(:,:)=1. - - if ( iflag_thermals_down < 10 ) then - call abort_physic("thermcell_updown_dq", & - 'thermcell_down_dq = 0 or >= 10', 1) - else - iflag_impl=iflag_thermals_down-10 - endif - - - ! lmax : indice tel que fu(kmax+1)=0 - ! Dans ce cas, pas besoin d'initialiser tracd(lmax) ( =trac(lmax) ) - ! Boucle pour le downdraft - do ilay=nlay,1,-1 - do ig=1,ngrid - !if ( lmax(ig) > nlay - 2 ) stop "les thermiques montent trop haut" - if (ilay.le.lmax(ig) .and. lmax(ig)>1 ) then - fdn(ig,ilay)=fdn(ig,ilay+1)+edn(ig,ilay)-ddn(ig,ilay) - if ( fdn(ig,ilay)+ddn(ig,ilay) > 0. ) then - www=fdn(ig,ilay+1)/ (fdn(ig,ilay)+ddn(ig,ilay)) - else - www=0. - endif - tracd(ig,ilay)=www*tracd(ig,ilay+1) + (1.-www)*trac(ig,ilay) - endif - enddo - enddo !Fin boucle sur l'updraft - fdn(:,1)=0. - - !Boucle pour l'updraft - do ilay=1,nlay,1 - do ig=1,ngrid - if (ilay.lt.lmax(ig) .and. lmax(ig)>1) then - fup(ig,ilay+1)=fup(ig,ilay)+eup(ig,ilay)-dup(ig,ilay) - if (fup(ig,ilay+1)+dup(ig,ilay) > 0.) then - www=fup(ig,ilay)/(fup(ig,ilay+1)+dup(ig,ilay)) - else - www=0. - endif - if (ilay == 1 ) then - tracu(ig,ilay)=trac(ig,ilay) - else - tracu(ig,ilay)=www*tracu(ig,ilay-1)+(1.-www)*trac(ig,ilay) - endif - endif - enddo - enddo !fin boucle sur le downdraft - - ! Calcul des flux des traceurs dans les updraft et les downdrfat - ! et du flux de masse compensateur - ! en ilay=1 et nlay+1, fthu=0 et fthd=0 - fthu(:,1)=0. - fthu(:,nlay+1)=0. - fthd(:,1)=0. - fthd(:,nlay+1)=0. - fc(:,1)=0. - fc(:,nlay+1)=0. - do ilay=2,nlay,1 !boucle sur les interfaces - do ig=1,ngrid - fthu(ig,ilay)=fup(ig,ilay)*tracu(ig,ilay-1) - fthd(ig,ilay)=-fdn(ig,ilay)*tracd(ig,ilay) - fc(ig,ilay)=fup(ig,ilay)-fdn(ig,ilay) - enddo - enddo - - - !Boucle pour calculer le flux du traceur flux updraft, flux downdraft, flux compensatoire - !Methode explicite : - if(iflag_impl==0) then - do ilay=2,nlay,1 - do ig=1,ngrid - !!!!ATTENTION HYPOTHESE de FLUX COMPENSATOIRE DESCENDANT ET DONC comme schema amont on va chercher trac au dessus!!!!! - !!!! tentative de prise en compte d'un flux compensatoire montant !!!! - if (fup(ig,ilay)-fdn(ig,ilay) .lt. 0.) then - call abort_physic("thermcell_updown_dq", 'flux compensatoire '& - // 'montant, cas non traite par thermcell_updown_dq', 1) - !fthe(ig,ilay)=(fup(ig,ilay)-fdn(ig,ilay))*trac(ig,ilay-1) - else - fthe(ig,ilay)=-(fup(ig,ilay)-fdn(ig,ilay))*trac(ig,ilay) - endif - !! si on voulait le prendre en compte on - !fthe(ig,ilay)=-(fup(ig,ilay)-fdn(ig,ilay))*trac(ig,ilay-1) - fthtot(ig,ilay)=fthu(ig,ilay)+fthd(ig,ilay)+fthe(ig,ilay) - enddo - enddo - !Boucle pour calculer trac - do ilay=1,nlay - do ig=1,ngrid - dtrac(ig,ilay)=(fthtot(ig,ilay)-fthtot(ig,ilay+1))/masse(ig,ilay) -! trac(ig,ilay)=trac(ig,ilay) + (fthtot(ig,ilay)-fthtot(ig,ilay+1))*(ptimestep/masse(ig,ilay)) - enddo - enddo !fin du calculer de la tendance du traceur avec la methode explicite - - !!! Reecriture du schéma explicite avec les notations du schéma implicite - else if(iflag_impl==-1) then - write(*,*) 'nouveau schéma explicite !!!' - !!! Calcul de s1 - do ilay=1,nlay - do ig=1,ngrid - s1(ig,ilay)=fthu(ig,ilay)-fthu(ig,ilay+1)+fthd(ig,ilay)-fthd(ig,ilay+1) - s2(ig,ilay)=s1(ig,ilay)+fthe(ig,ilay)-fthe(ig,ilay+1) - enddo - enddo - - do ilay=2,nlay,1 - do ig=1,ngrid - if (fup(ig,ilay)-fdn(ig,ilay) .lt. 0.) then - call abort_physic("thermcell_updown_dq", 'flux compensatoire ' & - // 'montant, cas non traite par thermcell_updown_dq', 1) - else - fthe(ig,ilay)=-(fup(ig,ilay)-fdn(ig,ilay))*trac(ig,ilay) - endif - fthtot(ig,ilay)=fthu(ig,ilay)+fthd(ig,ilay)+fthe(ig,ilay) - enddo - enddo - !Boucle pour calculer trac - do ilay=1,nlay - do ig=1,ngrid - ! dtrac(ig,ilay)=(fthtot(ig,ilay)-fthtot(ig,ilay+1))/masse(ig,ilay) - dtrac(ig,ilay)=(s1(ig,ilay)+fthe(ig,ilay)-fthe(ig,ilay+1))/masse(ig,ilay) -! trac(ig,ilay)=trac(ig,ilay) + (fthtot(ig,ilay)-fthtot(ig,ilay+1))*(ptimestep/masse(ig,ilay)) -! trac(ig,ilay)=trac(ig,ilay) + (s1(ig,ilay)+fthe(ig,ilay)-fthe(ig,ilay+1))*(ptimestep/masse(ig,ilay)) - enddo - enddo !fin du calculer de la tendance du traceur avec la methode explicite - - else if (iflag_impl==1) then - do ilay=1,nlay - do ig=1,ngrid - s1(ig,ilay)=fthu(ig,ilay)-fthu(ig,ilay+1)+fthd(ig,ilay)-fthd(ig,ilay+1) - enddo - enddo - - !Boucle pour calculer traci = trac((t+dt) - do ilay=nlay-1,1,-1 - do ig=1,ngrid - if((fup(ig,ilay)-fdn(ig,ilay)) .lt. 0) then - write(*,*) 'flux compensatoire montant, cas non traite par thermcell_updown_dq dans le cas d une resolution implicite, ilay : ', ilay - call abort_physic("thermcell_updown_dq", "", 1) - else - mstar_inv=ptimestep/masse(ig,ilay) - traci(ig,ilay)=((traci(ig,ilay+1)*fc(ig,ilay+1)+s1(ig,ilay))*mstar_inv+tracold(ig,ilay))/(1.+fc(ig,ilay)*mstar_inv) - endif - enddo - enddo - do ilay=1,nlay - do ig=1,ngrid - dtrac(ig,ilay)=(traci(ig,ilay)-tracold(ig,ilay))/ptimestep - enddo - enddo - - else - call abort_physic("thermcell_updown_dq", & - 'valeur de iflag_impl non prevue', 1) - endif - - RETURN - END - -!========================================================================= - - SUBROUTINE thermcell_down(ngrid,nlay,po,pt,pu,pv,pplay,pplev, & - & lmax,fup,eup,dup,theta) - -!-------------------------------------------------------------- -!thermcell_down: calcul des propri??t??s du panache descendant. -!-------------------------------------------------------------- - - - USE thermcell_ini_mod, ONLY : prt_level,RLvCp,RKAPPA,RETV,fact_thermals_down - IMPLICIT NONE - -! arguments - - integer,intent(in) :: ngrid,nlay - real,intent(in), dimension(ngrid,nlay) :: po,pt,pu,pv,pplay,eup,dup - real,intent(in), dimension(ngrid,nlay) :: theta - real,intent(in), dimension(ngrid,nlay+1) :: pplev,fup - integer, intent(in), dimension(ngrid) :: lmax - - - -! Local - - real, dimension(ngrid,nlay) :: edn,ddn,thetad - real, dimension(ngrid,nlay+1) :: fdn - - integer ig,ilay - real dqsat_dT - logical mask(ngrid,nlay) - - edn(:,:)=0. - ddn(:,:)=0. - fdn(:,:)=0. - thetad(:,:)=0. - - ! lmax : indice tel que fu(kmax+1)=0 - - ! Dans ce cas, pas besoin d'initialiser thetad(lmax) ( =theta(lmax) ) - -! FH MODIFS APRES REUNIONS POUR COMMISSIONS -! quelques erreurs de declaration -! probleme si lmax=1 ce qui a l'air d'??tre le cas en d??but de simu. Devrait ??tre 0 ? -! Remarques : -! on pourrait ??crire la formule de thetad -! www=fdn(ig,ilay+1)/ (fdn(ig,ilay)+ddn(ig,ilay)) -! thetad(ig,ilay)= www * thetad(ig,ilay+1) + (1.-www) * theta(ig,ilay) -! Elle a l'avantage de bien montr?? la conservation, l'id??e fondamentale dans le -! transport qu'on ne fait que sommer des "sources" au travers d'un "propagateur" -! (Green) -! Elle montre aussi beaucoup plus clairement pourquoi on n'a pas ?? se souccier (trop) -! de la possible nulit?? du d??nominateur - - - do ilay=nlay,1,-1 - do ig=1,ngrid - if (ilay.le.lmax(ig).and.lmax(ig)>1) then - edn(ig,ilay)=fact_thermals_down*dup(ig,ilay) - ddn(ig,ilay)=fact_thermals_down*eup(ig,ilay) - fdn(ig,ilay)=fdn(ig,ilay+1)+edn(ig,ilay)-ddn(ig,ilay) - thetad(ig,ilay)=( fdn(ig,ilay+1)*thetad(ig,ilay+1) + edn(ig,ilay)*theta(ig,ilay) ) / (fdn(ig,ilay)+ddn(ig,ilay)) - endif - enddo - enddo - - ! Suite du travail : - ! Ecrire la conservervation de theta_l dans le panache descendant - ! Eventuellement faire la transformation theta_l -> theta_v - ! Si l'air est sec (et qu'on oublie le c??t?? theta_v) on peut - ! se contenter de conserver theta. - ! - ! Connaissant thetadn, on peut calculer la flotabilit??. - ! Connaissant la flotabilit??, on peut calculer w de proche en proche - ! On peut calculer le detrainement de facon ?? garder alpha*rho = cste - ! On en d??duit l'entrainement lat??ral - ! C'est le mod??le des mini-projets. - -!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -! Initialisations : -!------------------ - - -! - RETURN - END Index: LMDZ6/trunk/libf/phylmd/thermcell_dq.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/thermcell_dq.F90 (revision 4589) +++ (revision ) @@ -1,326 +1,0 @@ - subroutine thermcell_dq(ngrid,nlay,impl,ptimestep,fm,entr, & - & masse,q,dq,qa,lev_out) - USE print_control_mod, ONLY: prt_level - implicit none - -!======================================================================= -! -! Calcul du transport verticale dans la couche limite en presence -! de "thermiques" explicitement representes -! calcul du dq/dt une fois qu'on connait les ascendances -! -! Modif 2013/01/04 (FH hourdin@lmd.jussieu.fr) -! Introduction of an implicit computation of vertical advection in -! the environment of thermal plumes in thermcell_dq -! impl = 0 : explicit, 1 : implicit, -1 : old version -! -!======================================================================= - -! arguments - integer, intent(in) :: ngrid,nlay,impl - real, intent(in) :: ptimestep - real, intent(in), dimension(ngrid,nlay) :: masse - real, intent(inout), dimension(ngrid,nlay) :: entr,q - real, intent(in), dimension(ngrid,nlay+1) :: fm - real, intent(out), dimension(ngrid,nlay) :: dq,qa - integer, intent(in) :: lev_out ! niveau pour les print - -! Local - real, dimension(ngrid,nlay) :: detr,qold - real, dimension(ngrid,nlay+1) :: wqd,fqa - real zzm - integer ig,k - real cfl - - integer niter,iter - CHARACTER (LEN=20) :: modname='thermcell_dq' - CHARACTER (LEN=80) :: abort_message - - -! Old explicite scheme -if (impl<=-1) then - - call thermcell_dq_o(ngrid,nlay,impl,ptimestep,fm,entr, & - & masse,q,dq,qa,lev_out) - -else - - -! Calcul du critere CFL pour l'advection dans la subsidence - cfl = 0. - do k=1,nlay - do ig=1,ngrid - zzm=masse(ig,k)/ptimestep - cfl=max(cfl,fm(ig,k)/zzm) - if (entr(ig,k).gt.zzm) then - print*,'entr*dt>m,1',k,entr(ig,k)*ptimestep,masse(ig,k) - abort_message = 'entr dt > m, 1st' - CALL abort_physic (modname,abort_message,1) - endif - enddo - enddo - - qold=q - - - if (prt_level.ge.1) print*,'Q2 THERMCEL_DQ 0' - -! calcul du detrainement - do k=1,nlay - do ig=1,ngrid - detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k) -! print*,'Q2 DQ ',detr(ig,k),fm(ig,k),entr(ig,k) -!test - if (detr(ig,k).lt.0.) then - entr(ig,k)=entr(ig,k)-detr(ig,k) - detr(ig,k)=0. -! print*,'detr2<0!!!','ig=',ig,'k=',k,'f=',fm(ig,k), -! s 'f+1=',fm(ig,k+1),'e=',entr(ig,k),'d=',detr(ig,k) - endif - if (fm(ig,k+1).lt.0.) then -! print*,'fm2<0!!!' - endif - if (entr(ig,k).lt.0.) then -! print*,'entr2<0!!!' - endif - enddo - enddo - -! Computation of tracer concentrations in the ascending plume - do ig=1,ngrid - qa(ig,1)=q(ig,1) - enddo - - do k=2,nlay - do ig=1,ngrid - if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt. & - & 1.e-5*masse(ig,k)) then - qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k)) & - & /(fm(ig,k+1)+detr(ig,k)) - else - qa(ig,k)=q(ig,k) - endif - if (qa(ig,k).lt.0.) then -! print*,'qa<0!!!' - endif - if (q(ig,k).lt.0.) then -! print*,'q<0!!!' - endif - enddo - enddo - -! Plume vertical flux - do k=2,nlay-1 - fqa(:,k)=fm(:,k)*qa(:,k-1) - enddo - fqa(:,1)=0. ; fqa(:,nlay)=0. - - -! Trace species evolution - if (impl==0) then - do k=1,nlay-1 - q(:,k)=q(:,k)+(fqa(:,k)-fqa(:,k+1)-fm(:,k)*q(:,k)+fm(:,k+1)*q(:,k+1)) & - & *ptimestep/masse(:,k) - enddo - else - do k=nlay-1,1,-1 -! FH debut de modif : le calcul ci dessous modifiait numériquement -! la concentration quand le flux de masse etait nul car on divisait -! puis multipliait par masse/ptimestep. -! q(:,k)=(masse(:,k)*q(:,k)/ptimestep+fqa(:,k)-fqa(:,k+1)+fm(:,k+1)*q(:,k+1)) & -! & /(fm(:,k)+masse(:,k)/ptimestep) - q(:,k)=(q(:,k)+ptimestep/masse(:,k)*(fqa(:,k)-fqa(:,k+1)+fm(:,k+1)*q(:,k+1))) & - & /(1.+fm(:,k)*ptimestep/masse(:,k)) -! FH fin de modif. - enddo - endif - -! Tendencies - do k=1,nlay - do ig=1,ngrid - dq(ig,k)=(q(ig,k)-qold(ig,k))/ptimestep - q(ig,k)=qold(ig,k) - enddo - enddo - -endif ! impl=-1 -RETURN -end - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Obsolete version kept for convergence with Cmip5 NPv3.1 simulations -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine thermcell_dq_o(ngrid,nlay,impl,ptimestep,fm,entr, & - & masse,q,dq,qa,lev_out) - USE print_control_mod, ONLY: prt_level - implicit none - -!======================================================================= -! -! Calcul du transport verticale dans la couche limite en presence -! de "thermiques" explicitement representes -! calcul du dq/dt une fois qu'on connait les ascendances -! -!======================================================================= - - integer ngrid,nlay,impl - - real ptimestep - real masse(ngrid,nlay),fm(ngrid,nlay+1) - real entr(ngrid,nlay) - real q(ngrid,nlay) - real dq(ngrid,nlay) - integer lev_out ! niveau pour les print - - real qa(ngrid,nlay),detr(ngrid,nlay),wqd(ngrid,nlay+1) - - real zzm - - integer ig,k - real cfl - - real qold(ngrid,nlay) - real ztimestep - integer niter,iter - CHARACTER (LEN=20) :: modname='thermcell_dq' - CHARACTER (LEN=80) :: abort_message - - - -! Calcul du critere CFL pour l'advection dans la subsidence - cfl = 0. - do k=1,nlay - do ig=1,ngrid - zzm=masse(ig,k)/ptimestep - cfl=max(cfl,fm(ig,k)/zzm) - if (entr(ig,k).gt.zzm) then - print*,'entr*dt>m,2',k,entr(ig,k)*ptimestep,masse(ig,k) - abort_message = 'entr dt > m, 2nd' - CALL abort_physic (modname,abort_message,1) - endif - enddo - enddo - -!IM 090508 print*,'CFL CFL CFL CFL ',cfl - -#undef CFL -#ifdef CFL -! On subdivise le calcul en niter pas de temps. - niter=int(cfl)+1 -#else - niter=1 -#endif - - ztimestep=ptimestep/niter - qold=q - - -do iter=1,niter - if (prt_level.ge.1) print*,'Q2 THERMCEL_DQ 0' - -! calcul du detrainement - do k=1,nlay - do ig=1,ngrid - detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k) -! print*,'Q2 DQ ',detr(ig,k),fm(ig,k),entr(ig,k) -!test - if (detr(ig,k).lt.0.) then - entr(ig,k)=entr(ig,k)-detr(ig,k) - detr(ig,k)=0. -! print*,'detr2<0!!!','ig=',ig,'k=',k,'f=',fm(ig,k), -! s 'f+1=',fm(ig,k+1),'e=',entr(ig,k),'d=',detr(ig,k) - endif - if (fm(ig,k+1).lt.0.) then -! print*,'fm2<0!!!' - endif - if (entr(ig,k).lt.0.) then -! print*,'entr2<0!!!' - endif - enddo - enddo - -! calcul de la valeur dans les ascendances - do ig=1,ngrid - qa(ig,1)=q(ig,1) - enddo - - do k=2,nlay - do ig=1,ngrid - if ((fm(ig,k+1)+detr(ig,k))*ztimestep.gt. & - & 1.e-5*masse(ig,k)) then - qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k)) & - & /(fm(ig,k+1)+detr(ig,k)) - else - qa(ig,k)=q(ig,k) - endif - if (qa(ig,k).lt.0.) then -! print*,'qa<0!!!' - endif - if (q(ig,k).lt.0.) then -! print*,'q<0!!!' - endif - enddo - enddo - -! Calcul du flux subsident - - do k=2,nlay - do ig=1,ngrid -#undef centre -#ifdef centre - wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k)) -#else - -#define plusqueun -#ifdef plusqueun -! Schema avec advection sur plus qu'une maille. - zzm=masse(ig,k)/ztimestep - if (fm(ig,k)>zzm) then - wqd(ig,k)=zzm*q(ig,k)+(fm(ig,k)-zzm)*q(ig,k+1) - else - wqd(ig,k)=fm(ig,k)*q(ig,k) - endif -#else - wqd(ig,k)=fm(ig,k)*q(ig,k) -#endif -#endif - - if (wqd(ig,k).lt.0.) then -! print*,'wqd<0!!!' - endif - enddo - enddo - do ig=1,ngrid - wqd(ig,1)=0. - wqd(ig,nlay+1)=0. - enddo - - -! Calcul des tendances - do k=1,nlay - do ig=1,ngrid - q(ig,k)=q(ig,k)+(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k) & - & -wqd(ig,k)+wqd(ig,k+1)) & - & *ztimestep/masse(ig,k) -! if (dq(ig,k).lt.0.) then -! print*,'dq<0!!!' -! endif - enddo - enddo - - -enddo - - -! Calcul des tendances - do k=1,nlay - do ig=1,ngrid - dq(ig,k)=(q(ig,k)-qold(ig,k))/ptimestep - q(ig,k)=qold(ig,k) - enddo - enddo - - return - end Index: LMDZ6/trunk/libf/phylmd/thermcell_dry.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/thermcell_dry.F90 (revision 4589) +++ (revision ) @@ -1,165 +1,0 @@ -! -! $Id$ -! - SUBROUTINE thermcell_dry(ngrid,nlay,zlev,pphi,ztv,alim_star, & - & lalim,lmin,zmax,wmax) - -!-------------------------------------------------------------------------- -!thermcell_dry: calcul de zmax et wmax du thermique sec -! Calcul de la vitesse maximum et de la hauteur maximum pour un panache -! ascendant avec une fonction d'alimentation alim_star et sans changement -! de phase. -! Le calcul pourrait etre sans doute simplifier. -! La temperature potentielle virtuelle dans la panache ascendant est -! la temperature potentielle virtuelle pondérée par alim_star. -!-------------------------------------------------------------------------- - USE thermcell_ini_mod, ONLY: prt_level, RG - IMPLICIT NONE - - integer, intent(in) :: ngrid,nlay - real, intent(in), dimension(ngrid,nlay+1) :: zlev,pphi,ztv,alim_star - integer, intent(in), dimension(ngrid) :: lalim - real, intent(out), dimension(ngrid) :: zmax,wmax - -!variables locales - REAL zw2(ngrid,nlay+1) - REAL f_star(ngrid,nlay+1) - REAL ztva(ngrid,nlay+1) - REAL wmaxa(ngrid) - REAL wa_moy(ngrid,nlay+1) - REAL linter(ngrid),zlevinter(ngrid) - INTEGER lmix(ngrid),lmax(ngrid),lmin(ngrid) - CHARACTER (LEN=20) :: modname='thermcell_dry' - CHARACTER (LEN=80) :: abort_message - INTEGER l,ig - -!initialisations - do ig=1,ngrid - do l=1,nlay+1 - zw2(ig,l)=0. - wa_moy(ig,l)=0. - enddo - enddo - do ig=1,ngrid - do l=1,nlay - ztva(ig,l)=ztv(ig,l) - enddo - enddo - do ig=1,ngrid - wmax(ig)=0. - wmaxa(ig)=0. - enddo -!calcul de la vitesse a partir de la CAPE en melangeant thetav - - -! Calcul des F^*, integrale verticale de E^* - f_star(:,1)=0. - do l=1,nlay - f_star(:,l+1)=f_star(:,l)+alim_star(:,l) - enddo - -! niveau (reel) auquel zw2 s'annule FH :n'etait pas initialise - linter(:)=0. - -! couche la plus haute concernee par le thermique. - lmax(:)=1 - -! Le niveau linter est une variable continue qui se trouve dans la couche -! lmax - - do l=1,nlay-2 - do ig=1,ngrid - if (l.eq.lmin(ig).and.lalim(ig).gt.1) then - -!------------------------------------------------------------------------ -! Calcul de la vitesse en haut de la premiere couche instable. -! Premiere couche du panache thermique -!------------------------------------------------------------------------ - - zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) & - & *(zlev(ig,l+1)-zlev(ig,l)) & - & *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l)) - -!------------------------------------------------------------------------ -! Tant que la vitesse en bas de la couche et la somme du flux de masse -! et de l'entrainement (c'est a dire le flux de masse en haut) sont -! positifs, on calcul -! 1. le flux de masse en haut f_star(ig,l+1) -! 2. la temperature potentielle virtuelle dans la couche ztva(ig,l) -! 3. la vitesse au carré en haut zw2(ig,l+1) -!------------------------------------------------------------------------ - - else if (zw2(ig,l).ge.1e-10) then - - ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+alim_star(ig,l) & - & *ztv(ig,l))/f_star(ig,l+1) - zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+ & - & 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) & - & *(zlev(ig,l+1)-zlev(ig,l)) - endif -! determination de zmax continu par interpolation lineaire -!------------------------------------------------------------------------ - - if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then -! stop'On tombe sur le cas particulier de thermcell_dry' -! print*,'On tombe sur le cas particulier de thermcell_dry' - zw2(ig,l+1)=0. - linter(ig)=l+1 - lmax(ig)=l - endif - - if (zw2(ig,l+1).lt.0.) then - linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) & - & -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) - zw2(ig,l+1)=0. - lmax(ig)=l -! endif -!CR:zmax continu 06/05/12: calcul de linter quand le thermique est stoppe par le detrainement - elseif (f_star(ig,l+1).lt.0.) then - linter(ig)=(l*(f_star(ig,l+1)-f_star(ig,l)) & - & -f_star(ig,l))/(f_star(ig,l+1)-f_star(ig,l)) - zw2(ig,l+1)=0. - lmax(ig)=l - endif -!CRfin - wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) - - if (wa_moy(ig,l+1).gt.wmaxa(ig)) then -! lmix est le niveau de la couche ou w (wa_moy) est maximum - lmix(ig)=l+1 - wmaxa(ig)=wa_moy(ig,l+1) - endif - enddo - enddo - if (prt_level.ge.1) print*,'fin calcul zw2' -! -! Determination de zw2 max - do ig=1,ngrid - wmax(ig)=0. - enddo - - do l=1,nlay - do ig=1,ngrid - if (l.le.lmax(ig)) then - zw2(ig,l)=sqrt(zw2(ig,l)) - wmax(ig)=max(wmax(ig),zw2(ig,l)) - else - zw2(ig,l)=0. - endif - enddo - enddo - -! Longueur caracteristique correspondant a la hauteur des thermiques. - do ig=1,ngrid - zmax(ig)=0. - zlevinter(ig)=zlev(ig,1) - enddo - do ig=1,ngrid -! calcul de zlevinter - zlevinter(ig)=zlev(ig,lmax(ig)) + & - & (linter(ig)-lmax(ig))*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig))) - zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) - enddo - - RETURN - END Index: LMDZ6/trunk/libf/phylmd/thermcell_dtke.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/thermcell_dtke.F90 (revision 4589) +++ (revision ) @@ -1,123 +1,0 @@ - subroutine thermcell_dtke(ngrid,nlay,nsrf,ptimestep,fm0,entr0, & - & rg,pplev,tke) - USE print_control_mod, ONLY: prt_level - implicit none - -!======================================================================= -! -! Calcul du transport verticale dans la couche limite en presence -! de "thermiques" explicitement representes -! calcul du dq/dt une fois qu'on connait les ascendances -! -!======================================================================= - - integer ngrid,nlay,nsrf - - real ptimestep - real masse0(ngrid,nlay),fm0(ngrid,nlay+1),pplev(ngrid,nlay+1) - real entr0(ngrid,nlay),rg - real tke(ngrid,nlay,nsrf) - real detr0(ngrid,nlay) - - - real masse(ngrid,nlay),fm(ngrid,nlay+1) - real entr(ngrid,nlay) - real q(ngrid,nlay) - integer lev_out ! niveau pour les print - - real qa(ngrid,nlay),detr(ngrid,nlay),wqd(ngrid,nlay+1) - - real zzm - - integer ig,k - integer isrf - - - lev_out=0 - - - if (prt_level.ge.1) print*,'Q2 THERMCEL_DQ 0' - -! calcul du detrainement - do k=1,nlay - detr0(:,k)=fm0(:,k)-fm0(:,k+1)+entr0(:,k) - masse0(:,k)=(pplev(:,k)-pplev(:,k+1))/RG - enddo - - -! Decalage vertical des entrainements et detrainements. - masse(:,1)=0.5*masse0(:,1) - entr(:,1)=0.5*entr0(:,1) - detr(:,1)=0.5*detr0(:,1) - fm(:,1)=0. - do k=1,nlay-1 - masse(:,k+1)=0.5*(masse0(:,k)+masse0(:,k+1)) - entr(:,k+1)=0.5*(entr0(:,k)+entr0(:,k+1)) - detr(:,k+1)=0.5*(detr0(:,k)+detr0(:,k+1)) - fm(:,k+1)=fm(:,k)+entr(:,k)-detr(:,k) - enddo - fm(:,nlay+1)=0. - -! calcul de la valeur dans les ascendances - do ig=1,ngrid - qa(ig,1)=q(ig,1) - enddo - - - -do isrf=1,nsrf - - q(:,:)=tke(:,:,isrf) - - if (1==1) then - do k=2,nlay - do ig=1,ngrid - if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt. & - & 1.e-5*masse(ig,k)) then - qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k)) & - & /(fm(ig,k+1)+detr(ig,k)) - else - qa(ig,k)=q(ig,k) - endif - if (qa(ig,k).lt.0.) then -! print*,'qa<0!!!' - endif - if (q(ig,k).lt.0.) then -! print*,'q<0!!!' - endif - enddo - enddo - -! Calcul du flux subsident - - do k=2,nlay - do ig=1,ngrid - wqd(ig,k)=fm(ig,k)*q(ig,k) - if (wqd(ig,k).lt.0.) then -! print*,'wqd<0!!!' - endif - enddo - enddo - do ig=1,ngrid - wqd(ig,1)=0. - wqd(ig,nlay+1)=0. - enddo - - -! Calcul des tendances - do k=1,nlay - do ig=1,ngrid - q(ig,k)=q(ig,k)+(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k) & - & -wqd(ig,k)+wqd(ig,k+1)) & - & *ptimestep/masse(ig,k) - enddo - enddo - - endif - - tke(:,:,isrf)=q(:,:) - -enddo - - return - end Index: LMDZ6/trunk/libf/phylmd/thermcell_dv2.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/thermcell_dv2.F90 (revision 4589) +++ (revision ) @@ -1,193 +1,0 @@ - subroutine thermcell_dv2(ngrid,nlay,ptimestep,fm,entr,masse & - & ,fraca,larga & - & ,u,v,du,dv,ua,va,lev_out) - USE print_control_mod, ONLY: prt_level,lunout - implicit none - -!======================================================================= -! -! Calcul du transport verticale dans la couche limite en presence -! de "thermiques" explicitement representes -! calcul du dq/dt une fois qu'on connait les ascendances -! -! Vectorisation, FH : 2010/03/08 -! -!======================================================================= - - - integer ngrid,nlay - - real ptimestep - real masse(ngrid,nlay),fm(ngrid,nlay+1) - real fraca(ngrid,nlay+1) - real larga(ngrid) - real entr(ngrid,nlay) - real u(ngrid,nlay) - real ua(ngrid,nlay) - real du(ngrid,nlay) - real v(ngrid,nlay) - real va(ngrid,nlay) - real dv(ngrid,nlay) - integer lev_out ! niveau pour les print - - real qa(ngrid,nlay),detr(ngrid,nlay),zf,zf2 - real wvd(ngrid,nlay+1),wud(ngrid,nlay+1) - real gamma0(ngrid,nlay+1),gamma(ngrid,nlay+1) - real ue(ngrid,nlay),ve(ngrid,nlay) - LOGICAL ltherm(ngrid,nlay) - real dua(ngrid,nlay),dva(ngrid,nlay) - integer iter - - integer ig,k,nlarga0 - -!------------------------------------------------------------------------- - -! calcul du detrainement -!--------------------------- - -! print*,'THERMCELL DV2 OPTIMISE 3' - - nlarga0=0. - - do k=1,nlay - do ig=1,ngrid - detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k) - enddo - enddo - -! calcul de la valeur dans les ascendances - do ig=1,ngrid - ua(ig,1)=u(ig,1) - va(ig,1)=v(ig,1) - ue(ig,1)=u(ig,1) - ve(ig,1)=v(ig,1) - enddo - - IF(prt_level>9)WRITE(lunout,*) & - & 'WARNING on initialise gamma(1:ngrid,1)=0.' - gamma(1:ngrid,1)=0. - do k=2,nlay - do ig=1,ngrid - ltherm(ig,k)=(fm(ig,k+1)+detr(ig,k))*ptimestep > 1.e-5*masse(ig,k) - if(ltherm(ig,k).and.larga(ig)>0.) then - gamma0(ig,k)=masse(ig,k) & - & *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) ) & - & *0.5/larga(ig) & - & *1. - else - gamma0(ig,k)=0. - endif - if (ltherm(ig,k).and.larga(ig)<=0.) nlarga0=nlarga0+1 - enddo - enddo - - gamma(:,:)=0. - - do k=2,nlay - - do ig=1,ngrid - if (ltherm(ig,k)) then - dua(ig,k)=ua(ig,k-1)-u(ig,k-1) - dva(ig,k)=va(ig,k-1)-v(ig,k-1) - else - ua(ig,k)=u(ig,k) - va(ig,k)=v(ig,k) - ue(ig,k)=u(ig,k) - ve(ig,k)=v(ig,k) - endif - enddo - - -! Debut des iterations -!---------------------- -do iter=1,5 - do ig=1,ngrid -! Pour memoire : calcul prenant en compte la fraction reelle -! zf=0.5*(fraca(ig,k)+fraca(ig,k+1)) -! zf2=1./(1.-zf) -! Calcul avec fraction infiniement petite - zf=0. - zf2=1. - -! la première fois on multiplie le coefficient de freinage -! par le module du vent dans la couche en dessous. -! Mais pourquoi donc ??? - if (ltherm(ig,k)) then -! On choisit une relaxation lineaire. -! gamma(ig,k)=gamma0(ig,k) -! On choisit une relaxation quadratique. - gamma(ig,k)=gamma0(ig,k)*sqrt(dua(ig,k)**2+dva(ig,k)**2) - ua(ig,k)=(fm(ig,k)*ua(ig,k-1) & - & +(zf2*entr(ig,k)+gamma(ig,k))*u(ig,k)) & - & /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2 & - & +gamma(ig,k)) - va(ig,k)=(fm(ig,k)*va(ig,k-1) & - & +(zf2*entr(ig,k)+gamma(ig,k))*v(ig,k)) & - & /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2 & - & +gamma(ig,k)) -! print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua(ig,k),dva(ig,k) - dua(ig,k)=ua(ig,k)-u(ig,k) - dva(ig,k)=va(ig,k)-v(ig,k) - ue(ig,k)=(u(ig,k)-zf*ua(ig,k))*zf2 - ve(ig,k)=(v(ig,k)-zf*va(ig,k))*zf2 - endif - enddo -! Fin des iterations -!-------------------- -enddo - - enddo ! k=2,nlay - - -! Calcul du flux vertical de moment dans l'environnement. -!--------------------------------------------------------- - do k=2,nlay - do ig=1,ngrid - wud(ig,k)=fm(ig,k)*ue(ig,k) - wvd(ig,k)=fm(ig,k)*ve(ig,k) - enddo - enddo - do ig=1,ngrid - wud(ig,1)=0. - wud(ig,nlay+1)=0. - wvd(ig,1)=0. - wvd(ig,nlay+1)=0. - enddo - -! calcul des tendances. -!----------------------- - do k=1,nlay - do ig=1,ngrid - du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k) & - & -(entr(ig,k)+gamma(ig,k))*ue(ig,k) & - & -wud(ig,k)+wud(ig,k+1)) & - & /masse(ig,k) - dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k) & - & -(entr(ig,k)+gamma(ig,k))*ve(ig,k) & - & -wvd(ig,k)+wvd(ig,k+1)) & - & /masse(ig,k) - enddo - enddo - - -! Sorties eventuelles. -!---------------------- - - if(prt_level.GE.10) then - do k=1,nlay - do ig=1,ngrid - print*,'th_dv2 ig k gamma entr detr ua ue va ve wud wvd masse',ig,k,gamma(ig,k), & - & entr(ig,k),detr(ig,k),ua(ig,k),ue(ig,k),va(ig,k),ve(ig,k),wud(ig,k),wvd(ig,k),wud(ig,k+1),wvd(ig,k+1), & - & masse(ig,k) - enddo - enddo - endif -! - if (nlarga0>0) then - print*,'WARNING !!!!!! DANS THERMCELL_DV2 ' - print*,nlarga0,' points pour lesquels laraga=0. dans un thermique' - print*,'Il faudrait decortiquer ces points' - endif - - return - end Index: LMDZ6/trunk/libf/phylmd/thermcell_env.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/thermcell_env.F90 (revision 4589) +++ (revision ) @@ -1,78 +1,0 @@ - SUBROUTINE thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay, & - & pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,pqsat,lev_out) - -!-------------------------------------------------------------- -!thermcell_env: calcule les caracteristiques de l environnement -!necessaires au calcul des proprietes dans le thermique -!-------------------------------------------------------------- - - - USE thermcell_ini_mod, ONLY : prt_level,RLvCp,RKAPPA,RETV - IMPLICIT NONE - -! arguments - - integer,intent(in) :: ngrid,nlay,lev_out - real,intent(in), dimension(ngrid,nlay) :: po,pt,pu,pv,pplay - real,intent(in), dimension(ngrid,nlay+1) :: pplev - real,intent(out), dimension(ngrid,nlay) :: zo,zl,zh,ztv,zthl - real,intent(out), dimension(ngrid,nlay) :: zpspsk,zu,zv,pqsat - -! Local - - integer ig,ll - real dqsat_dT - logical mask(ngrid,nlay) - - -!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -! Initialisations : -!------------------ - - mask(:,:)=.true. - -! -! calcul des caracteristiques de l environnement - DO ll=1,nlay - DO ig=1,ngrid - zo(ig,ll)=po(ig,ll) - zl(ig,ll)=0. - zh(ig,ll)=pt(ig,ll) - enddo - enddo - -! Condensation : -!--------------- -! Calcul de l'humidite a saturation et de la condensation - - call thermcell_qsat(ngrid*nlay,mask,pplev,pt,po,pqsat) - do ll=1,nlay - do ig=1,ngrid - zl(ig,ll) = max(0.,po(ig,ll)-pqsat(ig,ll)) - zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll) ! T = Tl + Lv/Cp ql - zo(ig,ll) = po(ig,ll)-zl(ig,ll) - enddo - enddo - -!----------------------------------------------------------------------- - if (prt_level.ge.1) print*,'0 OK convect8' - - do ll=1,nlay - do ig=1,ngrid - zpspsk(ig,ll)=(pplay(ig,ll)/100000.)**RKAPPA - zu(ig,ll)=pu(ig,ll) - zv(ig,ll)=pv(ig,ll) -!attention zh est maintenant le profil de T et plus le profil de theta ! -! Quelle horreur ! A eviter. -! T-> Theta - ztv(ig,ll)=zh(ig,ll)/zpspsk(ig,ll) -!Theta_v - ztv(ig,ll)=ztv(ig,ll)*(1.+RETV*(zo(ig,ll))-zl(ig,ll)) -!Thetal - zthl(ig,ll)=pt(ig,ll)/zpspsk(ig,ll) -! - enddo - enddo - - RETURN - END Index: LMDZ6/trunk/libf/phylmd/thermcell_flux2.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/thermcell_flux2.F90 (revision 4589) +++ (revision ) @@ -1,511 +1,0 @@ -! -! $Id$ -! - SUBROUTINE thermcell_flux2(ngrid,nlay,ptimestep,masse, & - & lalim,lmax,alim_star, & - & entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr, & - & detr,zqla,lev_out,lunout1,igout) -!IM 060508 & detr,zqla,zmax,lev_out,lunout,igout) - - -!--------------------------------------------------------------------------- -!thermcell_flux: deduction des flux -!--------------------------------------------------------------------------- - - USE thermcell_ini_mod, ONLY : prt_level,iflag_thermals_optflux - IMPLICIT NONE - -! arguments - INTEGER, intent(in) :: ngrid,nlay - REAL, intent(in) :: ptimestep - REAL, intent(in), dimension(ngrid,nlay) :: masse - INTEGER, intent(in), dimension(ngrid) :: lalim,lmax - REAL, intent(in), dimension(ngrid,nlay) :: alim_star,entr_star,detr_star - REAL, intent(in), dimension(ngrid) :: f - REAL, intent(in), dimension(ngrid,nlay) :: rhobarz - REAL, intent(in), dimension(ngrid,nlay+1) :: zw2,zlev -! FH : laisser ca le temps de verifier qu'on a bien fait de commenter les -! lignes faisant apparaitre zqla, zmax ... -! REAL, intent(in), dimension(ngrid) :: zmax(ngrid) -! enlever aussi zqla - REAL, intent(in), dimension(ngrid,nlay) :: zqla ! not used - integer, intent(in) :: lev_out, lunout1 - - REAL,intent(out), dimension(ngrid,nlay) :: entr,detr - REAL,intent(out), dimension(ngrid,nlay+1) :: fm - -! local - INTEGER ig,l - integer igout,lout - REAL zfm - integer ncorecfm1,ncorecfm2,ncorecfm3,ncorecalpha - integer ncorecfm4,ncorecfm5,ncorecfm6,ncorecfm7,ncorecfm8 - - - REAL f_old,ddd0,eee0,ddd,eee,zzz - - REAL,SAVE :: fomass_max=0.5 - REAL,SAVE :: alphamax=0.7 -!$OMP THREADPRIVATE(fomass_max,alphamax) - - logical check_debug,labort_physic - - character (len=20) :: modname='thermcell_flux2' - character (len=80) :: abort_message - - - ncorecfm1=0 - ncorecfm2=0 - ncorecfm3=0 - ncorecfm4=0 - ncorecfm5=0 - ncorecfm6=0 - ncorecfm7=0 - ncorecfm8=0 - ncorecalpha=0 - -!initialisation - fm(:,:)=0. - - if (prt_level.ge.10) then - write(lunout1,*) 'Dans thermcell_flux 0' - write(lunout1,*) 'flux base ',f(igout) - write(lunout1,*) 'lmax ',lmax(igout) - write(lunout1,*) 'lalim ',lalim(igout) - write(lunout1,*) 'ig= ',igout - write(lunout1,*) ' l E* A* D* ' - write(lunout1,'(i4,3e15.5)') (l,entr_star(igout,l),alim_star(igout,l),detr_star(igout,l) & - & ,l=1,lmax(igout)) - endif - - -!------------------------------------------------------------------------- -! Verification de la nullite des entrainement et detrainement au dessus -! de lmax(ig) -! Active uniquement si check_debug=.true. ou prt_level>=10 -!------------------------------------------------------------------------- - - check_debug=.false..or.prt_level>=10 - - if (check_debug) then - do l=1,nlay - do ig=1,ngrid - if (l.le.lmax(ig)) then - if (entr_star(ig,l).gt.1.) then - print*,'WARNING thermcell_flux 1 ig,l,lmax(ig)',ig,l,lmax(ig) - print*,'entr_star(ig,l)',entr_star(ig,l) - print*,'alim_star(ig,l)',alim_star(ig,l) - print*,'detr_star(ig,l)',detr_star(ig,l) - endif - else - if (abs(entr_star(ig,l))+abs(alim_star(ig,l))+abs(detr_star(ig,l)).gt.0.) then - print*,'cas 1 : ig,l,lmax(ig)',ig,l,lmax(ig) - print*,'entr_star(ig,l)',entr_star(ig,l) - print*,'alim_star(ig,l)',alim_star(ig,l) - print*,'detr_star(ig,l)',detr_star(ig,l) - abort_message = '' - labort_physic=.true. - CALL abort_physic (modname,abort_message,1) - endif - endif - enddo - enddo - endif - -!------------------------------------------------------------------------- -! Multiplication par le flux de masse issu de la femreture -!------------------------------------------------------------------------- - - do l=1,nlay - entr(:,l)=f(:)*(entr_star(:,l)+alim_star(:,l)) - detr(:,l)=f(:)*detr_star(:,l) - enddo - - if (prt_level.ge.10) then - write(lunout1,*) 'Dans thermcell_flux 1' - write(lunout1,*) 'flux base ',f(igout) - write(lunout1,*) 'lmax ',lmax(igout) - write(lunout1,*) 'lalim ',lalim(igout) - write(lunout1,*) 'ig= ',igout - write(lunout1,*) ' l E D W2' - write(lunout1,'(i4,3e15.5)') (l,entr(igout,l),detr(igout,l) & - & ,zw2(igout,l+1),l=1,lmax(igout)) - endif - - fm(:,1)=0. - do l=1,nlay - do ig=1,ngrid - if (l.lt.lmax(ig)) then - fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l) - elseif(l.eq.lmax(ig)) then - fm(ig,l+1)=0. - detr(ig,l)=fm(ig,l)+entr(ig,l) - else - fm(ig,l+1)=0. - endif - enddo - enddo - - - -! Test provisoire : pour comprendre pourquoi on corrige plein de fois -! le cas fm6, on commence par regarder une premiere fois avant les -! autres corrections. - - do l=1,nlay - do ig=1,ngrid - if (detr(ig,l).gt.fm(ig,l)) then - ncorecfm8=ncorecfm8+1 -! igout=ig - endif - enddo - enddo - -! if (prt_level.ge.10) & -! & call printflux(ngrid,nlay,lunout1,igout,f,lmax,lalim, & -! & ptimestep,masse,entr,detr,fm,'2 ') - - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! FH Version en cours de test; -! par rapport a thermcell_flux, on fait une grande boucle sur "l" -! et on modifie le flux avec tous les contr�les appliques d'affilee -! pour la meme couche -! Momentanement, on duplique le calcule du flux pour pouvoir comparer -! les flux avant et apres modif -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - do l=1,nlay - - do ig=1,ngrid - if (l.lt.lmax(ig)) then - fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l) - elseif(l.eq.lmax(ig)) then - fm(ig,l+1)=0. - detr(ig,l)=fm(ig,l)+entr(ig,l) - else - fm(ig,l+1)=0. - endif - enddo - - -!------------------------------------------------------------------------- -! Verification de la positivite des flux de masse -!------------------------------------------------------------------------- - -! do l=1,nlay - do ig=1,ngrid - if (fm(ig,l+1).lt.0.) then -! print*,'fm1<0',l+1,lmax(ig),fm(ig,l+1) - ncorecfm1=ncorecfm1+1 - fm(ig,l+1)=fm(ig,l) - detr(ig,l)=entr(ig,l) - endif - enddo -! enddo - - if (prt_level.ge.10) & - & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & - & entr(igout,l),detr(igout,l),fm(igout,l+1) - -!------------------------------------------------------------------------- -!Test sur fraca croissant -!------------------------------------------------------------------------- - if (iflag_thermals_optflux==0) then -! do l=1,nlay - do ig=1,ngrid - if (l.ge.lalim(ig).and.l.le.lmax(ig) & - & .and.(zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10) ) then -! zzz est le flux en l+1 a frac constant - zzz=fm(ig,l)*rhobarz(ig,l+1)*zw2(ig,l+1) & - & /(rhobarz(ig,l)*zw2(ig,l)) - if (fm(ig,l+1).gt.zzz) then - detr(ig,l)=detr(ig,l)+fm(ig,l+1)-zzz - fm(ig,l+1)=zzz - ncorecfm4=ncorecfm4+1 - endif - endif - enddo -! enddo - endif - - if (prt_level.ge.10) & - & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & - & entr(igout,l),detr(igout,l),fm(igout,l+1) - - -!------------------------------------------------------------------------- -!test sur flux de masse croissant -!------------------------------------------------------------------------- - if (iflag_thermals_optflux==0) then -! do l=1,nlay - do ig=1,ngrid - if ((fm(ig,l+1).gt.fm(ig,l)).and.(l.gt.lalim(ig))) then - f_old=fm(ig,l+1) - fm(ig,l+1)=fm(ig,l) - detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1) - ncorecfm5=ncorecfm5+1 - endif - enddo -! enddo - endif - - if (prt_level.ge.10) & - & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & - & entr(igout,l),detr(igout,l),fm(igout,l+1) - -!fin 1.eq.0 -!------------------------------------------------------------------------- -!detr ne peut pas etre superieur a fm -!------------------------------------------------------------------------- - - if(1.eq.1) then - -! do l=1,nlay - - - - labort_physic=.false. - do ig=1,ngrid - if (entr(ig,l)<0.) then - labort_physic=.true. - igout=ig - lout=l - endif - enddo - - if (labort_physic) then - print*,'N1 ig,l,entr',igout,lout,entr(igout,lout) - abort_message = 'entr negatif' - CALL abort_physic (modname,abort_message,1) - endif - - do ig=1,ngrid - if (detr(ig,l).gt.fm(ig,l)) then - ncorecfm6=ncorecfm6+1 - detr(ig,l)=fm(ig,l) - entr(ig,l)=fm(ig,l+1) - -! Dans le cas ou on est au dessus de la couche d'alimentation et que le -! detrainement est plus fort que le flux de masse, on stope le thermique. -!test:on commente -! if (l.gt.lalim(ig)) then -! lmax(ig)=l -! fm(ig,l+1)=0. -! entr(ig,l)=0. -! else -! ncorecfm7=ncorecfm7+1 -! endif - endif - - if(l.gt.lmax(ig)) then - detr(ig,l)=0. - fm(ig,l+1)=0. - entr(ig,l)=0. - endif - enddo - - labort_physic=.false. - do ig=1,ngrid - if (entr(ig,l).lt.0.) then - labort_physic=.true. - igout=ig - endif - enddo - if (labort_physic) then - ig=igout - print*,'ig,l,lmax(ig)',ig,l,lmax(ig) - print*,'entr(ig,l)',entr(ig,l) - print*,'fm(ig,l)',fm(ig,l) - abort_message = 'probleme dans thermcell flux' - CALL abort_physic (modname,abort_message,1) - endif - - -! enddo - endif - - - if (prt_level.ge.10) & - & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & - & entr(igout,l),detr(igout,l),fm(igout,l+1) - -!------------------------------------------------------------------------- -!fm ne peut pas etre negatif -!------------------------------------------------------------------------- - -! do l=1,nlay - do ig=1,ngrid - if (fm(ig,l+1).lt.0.) then - detr(ig,l)=detr(ig,l)+fm(ig,l+1) - fm(ig,l+1)=0. - ncorecfm2=ncorecfm2+1 - endif - enddo - - labort_physic=.false. - do ig=1,ngrid - if (detr(ig,l).lt.0.) then - labort_physic=.true. - igout=ig - endif - enddo - if (labort_physic) then - ig=igout - print*,'cas 2 : ig,l,lmax(ig)',ig,l,lmax(ig) - print*,'detr(ig,l)',detr(ig,l) - print*,'fm(ig,l)',fm(ig,l) - abort_message = 'probleme dans thermcell flux' - CALL abort_physic (modname,abort_message,1) - endif -! enddo - - if (prt_level.ge.10) & - & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & - & entr(igout,l),detr(igout,l),fm(igout,l+1) - -!----------------------------------------------------------------------- -!la fraction couverte ne peut pas etre superieure a 1 -!----------------------------------------------------------------------- - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! FH Partie a revisiter. -! Il semble qu'etaient codees ici deux optiques dans le cas -! F/ (rho *w) > 1 -! soit limiter la hauteur du thermique en considerant que c'est -! la derniere chouche, soit limiter F a rho w. -! Dans le second cas, il faut en fait limiter a un peu moins -! que ca parce qu'on a des 1 / ( 1 -alpha) un peu plus loin -! dans thermcell_main et qu'il semble de toutes facons deraisonable -! d'avoir des fractions de 1.. -! Ci dessous, et dans l'etat actuel, le premier des deux if est -! sans doute inutile. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! do l=1,nlay - do ig=1,ngrid - if (zw2(ig,l+1).gt.1.e-10) then - zfm=rhobarz(ig,l+1)*zw2(ig,l+1)*alphamax - if ( fm(ig,l+1) .gt. zfm) then - f_old=fm(ig,l+1) - fm(ig,l+1)=zfm - detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1) -! lmax(ig)=l+1 -! zmax(ig)=zlev(ig,lmax(ig)) -! print*,'alpha>1',l+1,lmax(ig) - ncorecalpha=ncorecalpha+1 - endif - endif - enddo -! enddo -! - - - if (prt_level.ge.10) & - & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & - & entr(igout,l),detr(igout,l),fm(igout,l+1) - -! Fin de la grande boucle sur les niveaux verticaux - enddo - -! if (prt_level.ge.10) & -! & call printflux(ngrid,nlay,lunout1,igout,f,lmax,lalim, & -! & ptimestep,masse,entr,detr,fm,'8 ') - - -!----------------------------------------------------------------------- -! On fait en sorte que la quantite totale d'air entraine dans le -! panache ne soit pas trop grande comparee a la masse de la maille -!----------------------------------------------------------------------- - - if (1.eq.1) then - labort_physic=.false. - do l=1,nlay-1 - do ig=1,ngrid - eee0=entr(ig,l) - ddd0=detr(ig,l) - eee=entr(ig,l)-masse(ig,l)*fomass_max/ptimestep - ddd=detr(ig,l)-eee - if (eee.gt.0.) then - ncorecfm3=ncorecfm3+1 - entr(ig,l)=entr(ig,l)-eee - if ( ddd.gt.0.) then -! l'entrainement est trop fort mais l'exces peut etre compense par une -! diminution du detrainement) - detr(ig,l)=ddd - else -! l'entrainement est trop fort mais l'exces doit etre compense en partie -! par un entrainement plus fort dans la couche superieure - if(l.eq.lmax(ig)) then - detr(ig,l)=fm(ig,l)+entr(ig,l) - else - if(l.ge.lmax(ig).and.0.eq.1) then - igout=ig - lout=l - labort_physic=.true. - endif - entr(ig,l+1)=entr(ig,l+1)-ddd - detr(ig,l)=0. - fm(ig,l+1)=fm(ig,l)+entr(ig,l) - detr(ig,l)=0. - endif - endif - endif - enddo - enddo - if (labort_physic) then - ig=igout - l=lout - print*,'ig,l',ig,l - print*,'eee0',eee0 - print*,'ddd0',ddd0 - print*,'eee',eee - print*,'ddd',ddd - print*,'entr',entr(ig,l) - print*,'detr',detr(ig,l) - print*,'masse',masse(ig,l) - print*,'fomass_max',fomass_max - print*,'masse(ig,l)*fomass_max/ptimestep',masse(ig,l)*fomass_max/ptimestep - print*,'ptimestep',ptimestep - print*,'lmax(ig)',lmax(ig) - print*,'fm(ig,l+1)',fm(ig,l+1) - print*,'fm(ig,l)',fm(ig,l) - abort_message = 'probleme dans thermcell_flux' - CALL abort_physic (modname,abort_message,1) - endif - endif -! -! ddd=detr(ig)-entre -!on s assure que tout s annule bien en zmax - do ig=1,ngrid - fm(ig,lmax(ig)+1)=0. - entr(ig,lmax(ig))=0. - detr(ig,lmax(ig))=fm(ig,lmax(ig))+entr(ig,lmax(ig)) - enddo - -!----------------------------------------------------------------------- -! Impression du nombre de bidouilles qui ont ete necessaires -!----------------------------------------------------------------------- - -!IM 090508 beg -! if (ncorecfm1+ncorecfm2+ncorecfm3+ncorecfm4+ncorecfm5+ncorecalpha > 0 ) then -! -! print*,'PB thermcell : on a du coriger ',ncorecfm1,'x fm1',& -! & ncorecfm2,'x fm2',ncorecfm3,'x fm3 et', & -! & ncorecfm4,'x fm4',ncorecfm5,'x fm5 et', & -! & ncorecfm6,'x fm6', & -! & ncorecfm7,'x fm7', & -! & ncorecfm8,'x fm8', & -! & ncorecalpha,'x alpha' -! endif -!IM 090508 end - -! if (prt_level.ge.10) & -! & call printflux(ngrid,nlay,lunout1,igout,f,lmax,lalim, & -! & ptimestep,masse,entr,detr,fm,'fin') - - - RETURN - end Index: LMDZ6/trunk/libf/phylmd/thermcell_height.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/thermcell_height.F90 (revision 4589) +++ (revision ) @@ -1,159 +1,0 @@ - SUBROUTINE thermcell_height(ngrid,nlay,lalim,lmin,linter,lmix, & - & zw2,zlev,lmax,zmax,zmax0,zmix,wmax) - IMPLICIT NONE - -!----------------------------------------------------------------------------- -!thermcell_height: calcul des caracteristiques du thermique: zmax,wmax,zmix -!----------------------------------------------------------------------------- - -! arguments - -! Entree - integer, intent(in) :: ngrid,nlay - real, intent(in), dimension(ngrid) :: linter - real, intent(in), dimension(ngrid,nlay+1) :: zlev -! Sortie - real, intent(out), dimension(ngrid) :: wmax,zmax,zmax0,zmix - integer, intent(out), dimension(ngrid) :: lmax -! Les deux - integer, intent(inout), dimension(ngrid) :: lmix,lalim,lmin - real, intent(inout), dimension(ngrid,nlay+1) :: zw2 - -! local - real, dimension(ngrid) :: num,denom,zlevinter - integer ig,l - -!calcul de la hauteur max du thermique - do ig=1,ngrid - lmax(ig)=lalim(ig) - enddo - do ig=1,ngrid - do l=nlay,lalim(ig)+1,-1 - if (zw2(ig,l).le.1.e-10) then - lmax(ig)=l-1 - endif - enddo - enddo - -! On traite le cas particulier qu'il faudrait éviter ou le thermique -! atteind le haut du modele ... - do ig=1,ngrid - if ( zw2(ig,nlay) > 1.e-10 ) then - print*,'WARNING !!!!! W2 thermiques non nul derniere couche ' - lmax(ig)=nlay - endif - enddo - -! pas de thermique si couche 1 stable - do ig=1,ngrid - if (lmin(ig).gt.1) then - lmax(ig)=1 - lmin(ig)=1 - lalim(ig)=1 - endif - enddo -! -! Determination de zw2 max - do ig=1,ngrid - wmax(ig)=0. - enddo - - do l=1,nlay - do ig=1,ngrid - if (l.le.lmax(ig)) then - if (zw2(ig,l).lt.0.)then - print*,'pb2 zw2<0' - endif - zw2(ig,l)=sqrt(zw2(ig,l)) - wmax(ig)=max(wmax(ig),zw2(ig,l)) - else - zw2(ig,l)=0. - endif - enddo - enddo - -! Longueur caracteristique correspondant a la hauteur des thermiques. - do ig=1,ngrid - zmax(ig)=0. - zlevinter(ig)=zlev(ig,1) - enddo - -! if (iflag_thermals_ed.ge.1) then - if (1==0) then -!CR:date de quand le calcul du zmax continu etait buggue - num(:)=0. - denom(:)=0. - do ig=1,ngrid - do l=1,nlay - num(ig)=num(ig)+zw2(ig,l)*zlev(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) - denom(ig)=denom(ig)+zw2(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) - enddo - enddo - do ig=1,ngrid - if (denom(ig).gt.1.e-10) then - zmax(ig)=2.*num(ig)/denom(ig) - zmax0(ig)=zmax(ig) - endif - enddo - - else -!CR:Calcul de zmax continu via le linter - do ig=1,ngrid -! calcul de zlevinter - zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))* & - & linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1) & - & -zlev(ig,lmax(ig))) -!pour le cas ou on prend tjs lmin=1 -! zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) - zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1)) - zmax0(ig)=zmax(ig) - enddo - - - endif -!endif iflag_thermals_ed -! -! def de zmix continu (profil parabolique des vitesses) - do ig=1,ngrid - if (lmix(ig).gt.1) then -! test - if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) & - & *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) & - & -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) & - & *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10) & - & then -! - zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) & - & *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2) & - & -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) & - & *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2)) & - & /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) & - & *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) & - & -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) & - & *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) - else - zmix(ig)=zlev(ig,lmix(ig)) - print*,'pb zmix' - endif - else - zmix(ig)=0. - endif -!test - if ((zmax(ig)-zmix(ig)).le.0.) then - zmix(ig)=0.9*zmax(ig) -! print*,'pb zmix>zmax' - endif - enddo -! -! calcul du nouveau lmix correspondant - do ig=1,ngrid - do l=1,nlay - if (zmix(ig).ge.zlev(ig,l).and. & - & zmix(ig).lt.zlev(ig,l+1)) then - lmix(ig)=l - endif - enddo - enddo -! - RETURN - end Index: LMDZ6/trunk/libf/phylmd/thermcell_ini_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/thermcell_ini_mod.F90 (revision 4589) +++ (revision ) @@ -1,113 +1,0 @@ -MODULE thermcell_ini_mod -IMPLICIT NONE - -save - - integer :: dvdq=1,dqimpl=-1,prt_level=0,lunout - real RG,RD,RCPD,RKAPPA,RLVTT,RLvCp,RETV - real :: r_aspect_thermals,tau_thermals,fact_thermals_ed_dz - integer :: iflag_thermals_ed,iflag_thermals_optflux,iflag_thermals_closure - integer :: iflag_thermals_down - real :: fact_thermals_down - -!$OMP THREADPRIVATE(dvdq,dqimpl,prt_level,lunout) -!$OMP THREADPRIVATE(RG,RD,RCPD,RKAPPA,RLVTT,RLvCp) -!$OMP THREADPRIVATE(r_aspect_thermals,tau_thermals,fact_thermals_ed_dz) -!$OMP THREADPRIVATE(iflag_thermals_ed,iflag_thermals_optflux,iflag_thermals_closure) -!$OMP THREADPRIVATE(iflag_thermals_down) -!$OMP THREADPRIVATE(fact_thermals_down) - - - REAL, SAVE :: fact_epsilon=0.002 - REAL, SAVE :: betalpha=0.9 - REAL, SAVE :: afact=2./3. - REAL, SAVE :: fact_shell=1. - REAL,SAVE :: detr_min=1.e-5 - REAL,SAVE :: entr_min=1.e-5 - REAL,SAVE :: detr_q_coef=0.012 - REAL,SAVE :: detr_q_power=0.5 - REAL,SAVE :: mix0=0. - INTEGER,SAVE :: thermals_flag_alim=0 - -!$OMP THREADPRIVATE(fact_epsilon, betalpha, afact, fact_shell) -!$OMP THREADPRIVATE(detr_min, entr_min, detr_q_coef, detr_q_power) -!$OMP THREADPRIVATE( mix0, thermals_flag_alim) - - -CONTAINS - -SUBROUTINE thermcell_ini(iflag_thermals,prt_level_in,tau_thermals_in,lunout_in, & - & RG_in,RD_in,RCPD_in,RKAPPA_in,RLVTT_in,RETV_in) - - USE ioipsl_getin_p_mod, ONLY : getin_p - -integer, intent(in) :: iflag_thermals,prt_level_in,lunout_in -real, intent(in) :: RG_in,RD_in,RCPD_in,RKAPPA_in,RLVTT_in,RETV_in,tau_thermals_in - -print*,'thermcell_ini' - if (iflag_thermals==15.or.iflag_thermals==16) then - dvdq=0 - dqimpl=-1 - else - dvdq=1 - dqimpl=1 - endif - prt_level=prt_level_in - RG=RG_in - RD=RD_in - RCPD=RCPD_in - RKAPPA=RKAPPA_in - RLVTT=RLVTT_in - RLvCp = RLVTT/RCPD - RETV=RETV_in - tau_thermals=tau_thermals_in - lunout=lunout_in - - -!===================================================================== -! a la fois les vieilles param et thermcell_main : -!===================================================================== - - r_aspect_thermals=2. - CALL getin_p('r_aspect_thermals',r_aspect_thermals) - - tau_thermals = 0. - CALL getin_p('tau_thermals',tau_thermals) - - fact_thermals_ed_dz = 0.1 - CALL getin_p('fact_thermals_ed_dz',fact_thermals_ed_dz) - - fact_thermals_ed_dz = 0.1 - CALL getin_p('fact_thermals_ed_dz',fact_thermals_ed_dz) - - iflag_thermals_ed = 0 - CALL getin_p('iflag_thermals_ed',iflag_thermals_ed) - - iflag_thermals_optflux = 0 - CALL getin_p('iflag_thermals_optflux',iflag_thermals_optflux) - - iflag_thermals_closure = 1 - CALL getin_p('iflag_thermals_closure',iflag_thermals_closure) - - iflag_thermals_down = 0 - CALL getin_p('iflag_thermals_down',iflag_thermals_down) - - fact_thermals_down = 0.5 - CALL getin_p('fact_thermals_down',fact_thermals_down) - - CALL getin_p('thermals_fact_epsilon',fact_epsilon) - CALL getin_p('thermals_betalpha',betalpha) - CALL getin_p('thermals_afact',afact) - CALL getin_p('thermals_fact_shell',fact_shell) - CALL getin_p('thermals_detr_min',detr_min) - CALL getin_p('thermals_entr_min',entr_min) - CALL getin_p('thermals_detr_q_coef',detr_q_coef) - CALL getin_p('thermals_detr_q_power',detr_q_power) - CALL getin_p('thermals_mix0',mix0) - CALL getin_p('thermals_flag_alim',thermals_flag_alim) - - - RETURN - -END SUBROUTINE thermcell_ini -END MODULE thermcell_ini_mod Index: LMDZ6/trunk/libf/phylmd/thermcell_main.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/thermcell_main.F90 (revision 4589) +++ (revision ) @@ -1,886 +1,0 @@ -! $Id$ -! - subroutine thermcell_main(itap,ngrid,nlay,ptimestep & - & ,pplay,pplev,pphi,debut & - & ,pu,pv,pt,po & - & ,pduadj,pdvadj,pdtadj,pdoadj & - & ,fm0,entr0,detr0,zqta,zqla,lmax & - & ,ratqscth,ratqsdiff,zqsatth & - & ,zmax0, f0,zw2,fraca,ztv & - & ,zpspsk,ztla,zthl,ztva & - & ,pcon,rhobarz,wth3,wmax_sec,lalim,fm,alim_star,zmax & -#ifdef ISO - & ,xtpo,xtpdoadj & -#endif - & ) - - - USE thermcell_ini_mod, ONLY: thermcell_ini,dqimpl,dvdq,prt_level,lunout,prt_level - USE thermcell_ini_mod, ONLY: iflag_thermals_closure,iflag_thermals_ed,tau_thermals,r_aspect_thermals - USE thermcell_ini_mod, ONLY: iflag_thermals_down, fact_thermals_down - USE thermcell_ini_mod, ONLY: RD,RG - -#ifdef ISO - USE infotrac_phy, ONLY : ntiso -#ifdef ISOVERIF - USE isotopes_mod, ONLY : iso_eau,iso_HDO - USE isotopes_verif_mod, ONLY: iso_verif_egalite, & - iso_verif_aberrant_encadre -#endif -#endif - - - IMPLICIT NONE - -!======================================================================= -! Auteurs: Frederic Hourdin, Catherine Rio, Anne Mathieu -! Version du 09.02.07 -! Calcul du transport vertical dans la couche limite en presence -! de "thermiques" explicitement representes avec processus nuageux -! -! Reecriture a partir d'un listing papier a Habas, le 14/02/00 -! -! le thermique est suppose homogene et dissipe par melange avec -! son environnement. la longueur l_mix controle l'efficacite du -! melange -! -! Le calcul du transport des differentes especes se fait en prenant -! en compte: -! 1. un flux de masse montant -! 2. un flux de masse descendant -! 3. un entrainement -! 4. un detrainement -! -! Modif 2013/01/04 (FH hourdin@lmd.jussieu.fr) -! Introduction of an implicit computation of vertical advection in -! the environment of thermal plumes in thermcell_dq -! impl = 0 : explicit, 1 : implicit, -1 : old version -! controled by iflag_thermals = -! 15, 16 run with impl=-1 : numerical convergence with NPv3 -! 17, 18 run with impl=1 : more stable -! 15 and 17 correspond to the activation of the stratocumulus "bidouille" -! -! Using -! abort_physic -! iso_verif_aberrant_encadre -! iso_verif_egalite -! test_ltherm -! thermcell_closure -! thermcell_dq -! thermcell_dry -! thermcell_dv2 -! thermcell_env -! thermcell_flux2 -! thermcell_height -! thermcell_plume -! thermcell_plume_5B -! thermcell_plume_6A -! -!======================================================================= - - -!----------------------------------------------------------------------- -! declarations: -! ------------- - - -! arguments: -! ---------- - integer, intent(in) :: itap,ngrid,nlay - real, intent(in) :: ptimestep - real, intent(in), dimension(ngrid,nlay) :: pt,pu,pv,po,pplay,pphi,zpspsk - real, intent(in), dimension(ngrid,nlay+1) :: pplev - integer, intent(out), dimension(ngrid) :: lmax - real, intent(out), dimension(ngrid,nlay) :: pdtadj,pduadj,pdvadj,pdoadj,entr0,detr0 - real, intent(out), dimension(ngrid,nlay) :: ztla,zqla,zqta,zqsatth,zthl - real, intent(out), dimension(ngrid,nlay+1) :: fm0,zw2,fraca - real, intent(inout), dimension(ngrid) :: zmax0,f0 - real, intent(out), dimension(ngrid,nlay) :: ztva,ztv - logical, intent(in) :: debut - real,intent(out), dimension(ngrid,nlay) :: ratqscth,ratqsdiff - - real, intent(out), dimension(ngrid) :: pcon - real, intent(out), dimension(ngrid,nlay) :: rhobarz,wth3 - real, intent(out), dimension(ngrid) :: wmax_sec - integer,intent(out), dimension(ngrid) :: lalim - real, intent(out), dimension(ngrid,nlay+1) :: fm - real, intent(out), dimension(ngrid,nlay) :: alim_star - real, intent(out), dimension(ngrid) :: zmax - -! local: -! ------ - - - integer,save :: igout=1 -!$OMP THREADPRIVATE(igout) - integer,save :: lunout1=6 -!$OMP THREADPRIVATE(lunout1) - integer,save :: lev_out=10 -!$OMP THREADPRIVATE(lev_out) - - real lambda, zf,zf2,var,vardiff,CHI - integer ig,k,l,ierr,ll - logical sorties - real, dimension(ngrid) :: linter,zmix, zmax_sec - integer,dimension(ngrid) :: lmin,lmix,lmix_bis,nivcon - real, dimension(ngrid,nlay) :: ztva_est - real, dimension(ngrid,nlay) :: deltaz,zlay,zh,zdthladj,zu,zv,zo,zl,zva,zua,zoa - real, dimension(ngrid,nlay) :: zta,zha,q2,wq,wthl,wthv,thetath2,wth2 - real, dimension(ngrid,nlay) :: rho,masse - real, dimension(ngrid,nlay+1) :: zw_est,zlev - real, dimension(ngrid) :: wmax,wmax_tmp - real, dimension(ngrid,nlay+1) :: f_star - real, dimension(ngrid,nlay) :: entr,detr,entr_star,detr_star,alim_star_clos - real, dimension(ngrid,nlay) :: zqsat,csc - real, dimension(ngrid) :: zcon,zcon2,alim_star_tot,f - real, dimension(ngrid,nlay) :: entrdn,detrdn - - character (len=20) :: modname='thermcell_main' - character (len=80) :: abort_message - - -#ifdef ISO - REAL xtpo(ntiso,ngrid,nlay),xtpdoadj(ntiso,ngrid,nlay) - REAL xtzo(ntiso,ngrid,nlay) - REAL xtpdoadj_tmp(ngrid,nlay) - REAL xtpo_tmp(ngrid,nlay) - REAL xtzo_tmp(ngrid,nlay) - integer ixt -#endif - -! - -!----------------------------------------------------------------------- -! initialisation: -! --------------- -! - fm=0. ; entr=0. ; detr=0. - - if (prt_level.ge.1) print*,'thermcell_main V4' - - sorties=.true. - IF(ngrid.NE.ngrid) THEN - PRINT* - PRINT*,'STOP dans convadj' - PRINT*,'ngrid =',ngrid - PRINT*,'ngrid =',ngrid - ENDIF -! -! write(lunout,*)'WARNING thermcell_main f0=max(f0,1.e-2)' - do ig=1,ngrid - f0(ig)=max(f0(ig),1.e-2) - zmax0(ig)=max(zmax0(ig),40.) -!IMmarche pas ?! if (f0(ig)<1.e-2) f0(ig)=1.e-2 - enddo - - if (prt_level.ge.20) then - do ig=1,ngrid - print*,'th_main ig f0',ig,f0(ig) - enddo - endif -!----------------------------------------------------------------------- -! Calcul de T,q,ql a partir de Tl et qT dans l environnement -! -------------------------------------------------------------------- -! - CALL thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay, & - & pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,zqsat,lev_out) - - if (prt_level.ge.1) print*,'thermcell_main apres thermcell_env' - -!------------------------------------------------------------------------ -! -------------------- -! -! -! + + + + + + + + + + + -! -! -! wa, fraca, wd, fracd -------------------- zlev(2), rhobarz -! wh,wt,wo ... -! -! + + + + + + + + + + + zh,zu,zv,zo,rho -! -! -! -------------------- zlev(1) -! \\\\\\\\\\\\\\\\\\\\ -! -! - -!----------------------------------------------------------------------- -! Calcul des altitudes des couches -!----------------------------------------------------------------------- - - do l=2,nlay - zlev(:,l)=0.5*(pphi(:,l)+pphi(:,l-1))/RG - enddo - zlev(:,1)=0. - zlev(:,nlay+1)=(2.*pphi(:,nlay)-pphi(:,nlay-1))/RG - do l=1,nlay - zlay(:,l)=pphi(:,l)/RG - enddo - do l=1,nlay - deltaz(:,l)=zlev(:,l+1)-zlev(:,l) - enddo - -!----------------------------------------------------------------------- -! Calcul des densites et masses -!----------------------------------------------------------------------- - - rho(:,:)=pplay(:,:)/(zpspsk(:,:)*RD*ztv(:,:)) - if (prt_level.ge.10) write(lunout,*) 'WARNING thermcell_main rhobarz(:,1)=rho(:,1)' - rhobarz(:,1)=rho(:,1) - do l=2,nlay - rhobarz(:,l)=0.5*(rho(:,l)+rho(:,l-1)) - enddo - do l=1,nlay - masse(:,l)=(pplev(:,l)-pplev(:,l+1))/RG - enddo - if (prt_level.ge.1) print*,'thermcell_main apres initialisation' - -!------------------------------------------------------------------ -! -! /|\ -! -------- | F_k+1 ------- -! ----> D_k -! /|\ <---- E_k , A_k -! -------- | F_k --------- -! ----> D_k-1 -! <---- E_k-1 , A_k-1 -! -! -! -! -! -! --------------------------- -! -! ----- F_lmax+1=0 ---------- \ -! lmax (zmax) | -! --------------------------- | -! | -! --------------------------- | -! | -! --------------------------- | -! | -! --------------------------- | -! | -! --------------------------- | -! | E -! --------------------------- | D -! | -! --------------------------- | -! | -! --------------------------- \ | -! lalim | | -! --------------------------- | | -! | | -! --------------------------- | | -! | A | -! --------------------------- | | -! | | -! --------------------------- | | -! lmin (=1 pour le moment) | | -! ----- F_lmin=0 ------------ / / -! -! --------------------------- -! ////////////////////////// -! -! -!============================================================================= -! Calculs initiaux ne faisant pas intervenir les changements de phase -!============================================================================= - -!------------------------------------------------------------------ -! 1. alim_star est le profil vertical de l'alimentation a la base du -! panache thermique, calcule a partir de la flotabilite de l'air sec -! 2. lmin et lalim sont les indices inferieurs et superieurs de alim_star -!------------------------------------------------------------------ -! - entr_star=0. ; detr_star=0. ; alim_star=0. ; alim_star_tot=0. - lmin=1 - -!----------------------------------------------------------------------------- -! 3. wmax_sec et zmax_sec sont les vitesses et altitudes maximum d'un -! panache sec conservatif (e=d=0) alimente selon alim_star -! Il s'agit d'un calcul de type CAPE -! zmax_sec est utilise pour determiner la geometrie du thermique. -!------------------------------------------------------------------------------ -!--------------------------------------------------------------------------------- -!calcul du melange et des variables dans le thermique -!-------------------------------------------------------------------------------- -! - if (prt_level.ge.1) print*,'avant thermcell_plume ',lev_out - -!===================================================================== -! Old version of thermcell_plume in thermcell_plume_6A.F90 -! It includes both thermcell_plume_6A and thermcell_plume_5B corresponding -! to the 5B and 6A versions used for CMIP5 and CMIP6. -! The latest was previously named thermcellV1_plume. -! The new thermcell_plume is a clean version (removing obsolete -! options) of thermcell_plume_6A. -! The 3 versions are controled by -! flag_thermals_ed <= 9 thermcell_plume_6A -! <= 19 thermcell_plume_5B -! else thermcell_plume (default 20 for convergence with 6A) -! Fredho -!===================================================================== - - if (iflag_thermals_ed<=9) then -! print*,'THERM NOUVELLE/NOUVELLE Arnaud' - CALL thermcell_plume_6A(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,& - & zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, & - & lalim,f0,detr_star,entr_star,f_star,csc,ztva, & - & ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter & - & ,lev_out,lunout1,igout) - - elseif (iflag_thermals_ed<=19) then -! print*,'THERM RIO et al 2010, version d Arnaud' - CALL thermcell_plume_5B(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,& - & zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, & - & lalim,f0,detr_star,entr_star,f_star,csc,ztva, & - & ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter & - & ,lev_out,lunout1,igout) - else - CALL thermcell_plume(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,& - & zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, & - & lalim,f0,detr_star,entr_star,f_star,csc,ztva, & - & ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter & - & ,lev_out,lunout1,igout) - endif - - if (prt_level.ge.1) print*,'apres thermcell_plume ',lev_out - - call test_ltherm(ngrid,nlay,pplay,lalim,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lalim ') - call test_ltherm(ngrid,nlay,pplay,lmix ,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lmix ') - - if (prt_level.ge.1) print*,'thermcell_main apres thermcell_plume' - if (prt_level.ge.10) then - write(lunout1,*) 'Dans thermcell_main 2' - write(lunout1,*) 'lmin ',lmin(igout) - write(lunout1,*) 'lalim ',lalim(igout) - write(lunout1,*) ' ig l alim_star entr_star detr_star f_star ' - write(lunout1,'(i6,i4,4e15.5)') (igout,l,alim_star(igout,l),entr_star(igout,l),detr_star(igout,l) & - & ,f_star(igout,l+1),l=1,nint(linter(igout))+5) - endif - -!------------------------------------------------------------------------------- -! Calcul des caracteristiques du thermique:zmax,zmix,wmax -!------------------------------------------------------------------------------- -! - CALL thermcell_height(ngrid,nlay,lalim,lmin,linter,lmix,zw2, & - & zlev,lmax,zmax,zmax0,zmix,wmax) -! Attention, w2 est transforme en sa racine carree dans cette routine -! Le probleme vient du fait que linter et lmix sont souvent egaux a 1. - wmax_tmp=0. - do l=1,nlay - wmax_tmp(:)=max(wmax_tmp(:),zw2(:,l)) - enddo -! print*,"ZMAX ",lalim,lmin,linter,lmix,lmax,zmax,zmax0,zmix,wmax - - - - call test_ltherm(ngrid,nlay,pplay,lalim,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lalim ') - call test_ltherm(ngrid,nlay,pplay,lmin ,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmin ') - call test_ltherm(ngrid,nlay,pplay,lmix ,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmix ') - call test_ltherm(ngrid,nlay,pplay,lmax ,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmax ') - - if (prt_level.ge.1) print*,'thermcell_main apres thermcell_height' - -!------------------------------------------------------------------------------- -! Fermeture,determination de f -!------------------------------------------------------------------------------- -! -! - CALL thermcell_dry(ngrid,nlay,zlev,pphi,ztv,alim_star, & - & lalim,lmin,zmax_sec,wmax_sec) - - -call test_ltherm(ngrid,nlay,pplay,lmin,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry lmin ') -call test_ltherm(ngrid,nlay,pplay,lalim,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry lalim ') - - if (prt_level.ge.1) print*,'thermcell_main apres thermcell_dry' - if (prt_level.ge.10) then - write(lunout1,*) 'Dans thermcell_main 1b' - write(lunout1,*) 'lmin ',lmin(igout) - write(lunout1,*) 'lalim ',lalim(igout) - write(lunout1,*) ' ig l alim_star entr_star detr_star f_star ' - write(lunout1,'(i6,i4,e15.5)') (igout,l,alim_star(igout,l) & - & ,l=1,lalim(igout)+4) - endif - - - - -! Choix de la fonction d'alimentation utilisee pour la fermeture. -! Apparemment sans importance - alim_star_clos(:,:)=alim_star(:,:) - alim_star_clos(:,:)=entr_star(:,:)+alim_star(:,:) -! -!CR Appel de la fermeture seche - if (iflag_thermals_closure.eq.1) then - - CALL thermcell_closure(ngrid,nlay,r_aspect_thermals,ptimestep,rho, & - & zlev,lalim,alim_star_clos,zmax_sec,wmax_sec,f) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Appel avec les zmax et wmax tenant compte de la condensation -! Semble moins bien marcher - else if (iflag_thermals_closure.eq.2) then - - CALL thermcell_closure(ngrid,nlay,r_aspect_thermals,ptimestep,rho, & - & zlev,lalim,alim_star,zmax,wmax,f) - - - endif - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - if(prt_level.ge.1)print*,'thermcell_closure apres thermcell_closure' - - if (tau_thermals>1.) then - lambda=exp(-ptimestep/tau_thermals) - f0=(1.-lambda)*f+lambda*f0 - else - f0=f - endif - -! Test valable seulement en 1D mais pas genant - if (.not. (f0(1).ge.0.) ) then - abort_message = '.not. (f0(1).ge.0.)' - CALL abort_physic (modname,abort_message,1) - endif - -!------------------------------------------------------------------------------- -!deduction des flux - - CALL thermcell_flux2(ngrid,nlay,ptimestep,masse, & - & lalim,lmax,alim_star, & - & entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr, & - & detr,zqla,lev_out,lunout1,igout) - -!IM 060508 & detr,zqla,zmax,lev_out,lunout,igout) - - if (prt_level.ge.1) print*,'thermcell_main apres thermcell_flux' - call test_ltherm(ngrid,nlay,pplay,lalim,ztv,po,ztva,zqla,f_star,zw2,'thermcell_flux lalim ') - call test_ltherm(ngrid,nlay,pplay,lmax ,ztv,po,ztva,zqla,f_star,zw2,'thermcell_flux lmax ') - -!------------------------------------------------------------------ -! On ne prend pas directement les profils issus des calculs precedents -! mais on s'autorise genereusement une relaxation vers ceci avec -! une constante de temps tau_thermals (typiquement 1800s). -!------------------------------------------------------------------ - - if (tau_thermals>1.) then - lambda=exp(-ptimestep/tau_thermals) - fm0=(1.-lambda)*fm+lambda*fm0 - entr0=(1.-lambda)*entr+lambda*entr0 - detr0=(1.-lambda)*detr+lambda*detr0 - else - fm0=fm - entr0=entr - detr0=detr - endif - -!------------------------------------------------------------------ -! Calcul de la fraction de l'ascendance -!------------------------------------------------------------------ - do ig=1,ngrid - fraca(ig,1)=0. - fraca(ig,nlay+1)=0. - enddo - do l=2,nlay - do ig=1,ngrid - if (zw2(ig,l).gt.1.e-10) then - fraca(ig,l)=fm(ig,l)/(rhobarz(ig,l)*zw2(ig,l)) - else - fraca(ig,l)=0. - endif - enddo - enddo - -!c------------------------------------------------------------------ -! calcul du transport vertical -!------------------------------------------------------------------ - IF (iflag_thermals_down .GT. 0) THEN - if (debut) print*,'WARNING !!! routine thermcell_down en cours de developpement' - entrdn=fact_thermals_down*detr0 - detrdn=fact_thermals_down*entr0 - ! we want to transport potential temperature, total water and momentum - CALL thermcell_updown_dq(ngrid,nlay,ptimestep,lmax,entr0,detr0,entrdn,detrdn,masse,zthl,zdthladj) - CALL thermcell_updown_dq(ngrid,nlay,ptimestep,lmax,entr0,detr0,entrdn,detrdn,masse,po,pdoadj) - CALL thermcell_updown_dq(ngrid,nlay,ptimestep,lmax,entr0,detr0,entrdn,detrdn,masse,zu,pduadj) - CALL thermcell_updown_dq(ngrid,nlay,ptimestep,lmax,entr0,detr0,entrdn,detrdn,masse,zv,pdvadj) - ELSE - !-------------------------------------------------------------- - - call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse, & - & zthl,zdthladj,zta,lev_out) - call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse, & - & po,pdoadj,zoa,lev_out) - -#ifdef ISO - ! C Risi: on utilise directement la meme routine - do ixt=1,ntiso - do ll=1,nlay - DO ig=1,ngrid - xtpo_tmp(ig,ll)=xtpo(ixt,ig,ll) - xtzo_tmp(ig,ll)=xtzo(ixt,ig,ll) - enddo - enddo - call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse, & - & xtpo_tmp,xtpdoadj_tmp,xtzo_tmp,lev_out) - do ll=1,nlay - DO ig=1,ngrid - xtpdoadj(ixt,ig,ll)=xtpdoadj_tmp(ig,ll) - enddo - enddo - enddo -#endif - -#ifdef ISO -#ifdef ISOVERIF - DO ll=1,nlay - DO ig=1,ngrid - if (iso_eau.gt.0) then - call iso_verif_egalite(xtpo(iso_eau,ig,ll), & - & po(ig,ll),'thermcell_main 594') - call iso_verif_egalite(xtpdoadj(iso_eau,ig,ll), & - & pdoadj(ig,ll),'thermcell_main 596') - endif - if (iso_HDO.gt.0) then - call iso_verif_aberrant_encadre(xtpo(iso_hdo,ig,ll) & - & /po(ig,ll),'thermcell_main 610') - endif - enddo - enddo !DO ll=1,nlay - write(*,*) 'thermcell_main 600 tmp: apres thermcell_dq' -#endif -#endif - - -!------------------------------------------------------------------ -! calcul du transport vertical du moment horizontal -!------------------------------------------------------------------ - -!IM 090508 - if (dvdq == 0 ) then - -! Calcul du transport de V tenant compte d'echange par gradient -! de pression horizontal avec l'environnement - - call thermcell_dv2(ngrid,nlay,ptimestep,fm0,entr0,masse & -! & ,fraca*dvdq,zmax & - & ,fraca,zmax & - & ,zu,zv,pduadj,pdvadj,zua,zva,lev_out) - - else - -! calcul purement conservatif pour le transport de V - call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse & - & ,zu,pduadj,zua,lev_out) - call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse & - & ,zv,pdvadj,zva,lev_out) - - endif - ENDIF - -! print*,'13 OK convect8' - do l=1,nlay - do ig=1,ngrid - pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l) - enddo - enddo - - if (prt_level.ge.1) print*,'14 OK convect8' -!------------------------------------------------------------------ -! Calculs de diagnostiques pour les sorties -!------------------------------------------------------------------ -!calcul de fraca pour les sorties - - if (sorties) then - if (prt_level.ge.1) print*,'14a OK convect8' -! calcul du niveau de condensation -! initialisation - do ig=1,ngrid - nivcon(ig)=0 - zcon(ig)=0. - enddo -!nouveau calcul - do ig=1,ngrid - CHI=zh(ig,1)/(1669.0-122.0*zo(ig,1)/zqsat(ig,1)-zh(ig,1)) - pcon(ig)=pplay(ig,1)*(zo(ig,1)/zqsat(ig,1))**CHI - enddo -!IM do k=1,nlay - do k=1,nlay-1 - do ig=1,ngrid - if ((pcon(ig).le.pplay(ig,k)) & - & .and.(pcon(ig).gt.pplay(ig,k+1))) then - zcon2(ig)=zlay(ig,k)-(pcon(ig)-pplay(ig,k))/(RG*rho(ig,k))/100. - endif - enddo - enddo -!IM - ierr=0 - do ig=1,ngrid - if (pcon(ig).le.pplay(ig,nlay)) then - zcon2(ig)=zlay(ig,nlay)-(pcon(ig)-pplay(ig,nlay))/(RG*rho(ig,nlay))/100. - ierr=1 - endif - enddo - if (ierr==1) then - abort_message = 'thermcellV0_main: les thermiques vont trop haut ' - CALL abort_physic (modname,abort_message,1) - endif - - if (prt_level.ge.1) print*,'14b OK convect8' - do k=nlay,1,-1 - do ig=1,ngrid - if (zqla(ig,k).gt.1e-10) then - nivcon(ig)=k - zcon(ig)=zlev(ig,k) - endif - enddo - enddo - if (prt_level.ge.1) print*,'14c OK convect8' -!calcul des moments -!initialisation - do l=1,nlay - do ig=1,ngrid - q2(ig,l)=0. - wth2(ig,l)=0. - wth3(ig,l)=0. - ratqscth(ig,l)=0. - ratqsdiff(ig,l)=0. - enddo - enddo - if (prt_level.ge.1) print*,'14d OK convect8' - if (prt_level.ge.10)write(lunout,*) & - & 'WARNING thermcell_main wth2=0. si zw2 > 1.e-10' - do l=1,nlay - do ig=1,ngrid - zf=fraca(ig,l) - zf2=zf/(1.-zf) -! - thetath2(ig,l)=zf2*(ztla(ig,l)-zthl(ig,l))**2 - if(zw2(ig,l).gt.1.e-10) then - wth2(ig,l)=zf2*(zw2(ig,l))**2 - else - wth2(ig,l)=0. - endif - wth3(ig,l)=zf2*(1-2.*fraca(ig,l))/(1-fraca(ig,l)) & - & *zw2(ig,l)*zw2(ig,l)*zw2(ig,l) - q2(ig,l)=zf2*(zqta(ig,l)*1000.-po(ig,l)*1000.)**2 -!test: on calcul q2/po=ratqsc - ratqscth(ig,l)=sqrt(max(q2(ig,l),1.e-6)/(po(ig,l)*1000.)) - enddo - enddo -!calcul des flux: q, thetal et thetav - do l=1,nlay - do ig=1,ngrid - wq(ig,l)=fraca(ig,l)*zw2(ig,l)*(zqta(ig,l)*1000.-po(ig,l)*1000.) - wthl(ig,l)=fraca(ig,l)*zw2(ig,l)*(ztla(ig,l)-zthl(ig,l)) - wthv(ig,l)=fraca(ig,l)*zw2(ig,l)*(ztva(ig,l)-ztv(ig,l)) - enddo - enddo - -!calcul du ratqscdiff - if (prt_level.ge.1) print*,'14e OK convect8' - var=0. - vardiff=0. - ratqsdiff(:,:)=0. - - do l=1,nlay - do ig=1,ngrid - if (l<=lalim(ig)) then - var=var+alim_star(ig,l)*zqta(ig,l)*1000. - endif - enddo - enddo - - if (prt_level.ge.1) print*,'14f OK convect8' - - do l=1,nlay - do ig=1,ngrid - if (l<=lalim(ig)) then - zf=fraca(ig,l) - zf2=zf/(1.-zf) - vardiff=vardiff+alim_star(ig,l)*(zqta(ig,l)*1000.-var)**2 - endif - enddo - enddo - - if (prt_level.ge.1) print*,'14g OK convect8' - do l=1,nlay - do ig=1,ngrid - ratqsdiff(ig,l)=sqrt(vardiff)/(po(ig,l)*1000.) - enddo - enddo - endif - - if (prt_level.ge.1) print*,'thermcell_main FIN OK' - - RETURN - end subroutine thermcell_main - -!============================================================================= -!///////////////////////////////////////////////////////////////////////////// -!============================================================================= - subroutine test_ltherm(ngrid,nlay,pplay,long,ztv,po,ztva, & ! in - & zqla,f_star,zw2,comment) ! in -!============================================================================= - USE thermcell_ini_mod, ONLY: prt_level - IMPLICIT NONE - - integer i, k, ngrid,nlay - real, intent(in), dimension(ngrid,nlay) :: pplay,ztv,po,ztva,zqla - real, intent(in), dimension(ngrid,nlay) :: f_star,zw2 - integer, intent(in), dimension(ngrid) :: long - real seuil - character*21 comment - - seuil=0.25 - - if (prt_level.ge.1) THEN - print*,'WARNING !!! TEST ',comment - endif - return - -! test sur la hauteur des thermiques ... - do i=1,ngrid -!IMtemp if (pplay(i,long(i)).lt.seuil*pplev(i,1)) then - if (prt_level.ge.10) then - print*,'WARNING ',comment,' au point ',i,' K= ',long(i) - print*,' K P(MB) THV(K) Qenv(g/kg)THVA QLA(g/kg) F* W2' - do k=1,nlay - write(6,'(i3,7f10.3)') k,pplay(i,k),ztv(i,k),1000*po(i,k),ztva(i,k),1000*zqla(i,k),f_star(i,k),zw2(i,k) - enddo - endif - enddo - - - return - end - -! nrlmd le 10/04/2012 Transport de la TKE par le thermique moyen pour la fermeture en ALP -! On transporte pbl_tke pour donner therm_tke -! Copie conforme de la subroutine DTKE dans physiq.F ecrite par Frederic Hourdin - -!======================================================================= -!/////////////////////////////////////////////////////////////////////// -!======================================================================= - - subroutine thermcell_tke_transport( & - & ngrid,nlay,ptimestep,fm0,entr0,rg,pplev, & ! in - & therm_tke_max) ! out - USE thermcell_ini_mod, ONLY: prt_level - implicit none - -!======================================================================= -! -! Calcul du transport verticale dans la couche limite en presence -! de "thermiques" explicitement representes -! calcul du dq/dt une fois qu'on connait les ascendances -! -!======================================================================= - - integer ngrid,nlay - - real, intent(in) :: ptimestep - real, intent(in), dimension(ngrid,nlay+1) :: fm0,pplev - real, intent(in), dimension(ngrid,nlay) :: entr0 - real, intent(in) :: rg - real, intent(out), dimension(ngrid,nlay) :: therm_tke_max - - real detr0(ngrid,nlay) - real masse0(ngrid,nlay) - real masse(ngrid,nlay),fm(ngrid,nlay+1) - real entr(ngrid,nlay) - real q(ngrid,nlay) - integer lev_out ! niveau pour les print - - real qa(ngrid,nlay),detr(ngrid,nlay),wqd(ngrid,nlay+1) - integer ig,k - - - lev_out=0 - - - if (prt_level.ge.1) print*,'Q2 THERMCEL_DQ 0' - -! calcul du detrainement - do k=1,nlay - detr0(:,k)=fm0(:,k)-fm0(:,k+1)+entr0(:,k) - masse0(:,k)=(pplev(:,k)-pplev(:,k+1))/RG - enddo - - -! Decalage vertical des entrainements et detrainements. - masse(:,1)=0.5*masse0(:,1) - entr(:,1)=0.5*entr0(:,1) - detr(:,1)=0.5*detr0(:,1) - fm(:,1)=0. - do k=1,nlay-1 - masse(:,k+1)=0.5*(masse0(:,k)+masse0(:,k+1)) - entr(:,k+1)=0.5*(entr0(:,k)+entr0(:,k+1)) - detr(:,k+1)=0.5*(detr0(:,k)+detr0(:,k+1)) - fm(:,k+1)=fm(:,k)+entr(:,k)-detr(:,k) - enddo - fm(:,nlay+1)=0. - - - q(:,:)=therm_tke_max(:,:) -!!! nrlmd le 16/09/2010 - do ig=1,ngrid - qa(ig,1)=q(ig,1) - enddo -!!! - - if (1==1) then - do k=2,nlay - do ig=1,ngrid - if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt. & - & 1.e-5*masse(ig,k)) then - qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k)) & - & /(fm(ig,k+1)+detr(ig,k)) - else - qa(ig,k)=q(ig,k) - endif - if (qa(ig,k).lt.0.) then -! print*,'qa<0!!!' - endif - if (q(ig,k).lt.0.) then -! print*,'q<0!!!' - endif - enddo - enddo - -! Calcul du flux subsident - - do k=2,nlay - do ig=1,ngrid - wqd(ig,k)=fm(ig,k)*q(ig,k) - if (wqd(ig,k).lt.0.) then -! print*,'wqd<0!!!' - endif - enddo - enddo - do ig=1,ngrid - wqd(ig,1)=0. - wqd(ig,nlay+1)=0. - enddo - -! Calcul des tendances - do k=1,nlay - do ig=1,ngrid - q(ig,k)=q(ig,k)+(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k) & - & -wqd(ig,k)+wqd(ig,k+1)) & - & *ptimestep/masse(ig,k) - enddo - enddo - - endif - - therm_tke_max(:,:)=q(:,:) - - return -!!! fin nrlmd le 10/04/2012 - end - Index: LMDZ6/trunk/libf/phylmd/thermcell_old.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/thermcell_old.F90 (revision 4589) +++ (revision ) @@ -1,5341 +1,0 @@ -SUBROUTINE thermcell_2002(ngrid, nlay, ptimestep, iflag_thermals, pplay, & - pplev, pphi, pu, pv, pt, po, pduadj, pdvadj, pdtadj, pdoadj, fm0, entr0, & - fraca, wa_moy, r_aspect, l_mix, w2di, tho) - - USE dimphy - USE write_field_phy - IMPLICIT NONE - - ! ======================================================================= - - ! Calcul du transport verticale dans la couche limite en presence - ! de "thermiques" explicitement representes - - ! Réécriture à partir d'un listing papier à Habas, le 14/02/00 - - ! le thermique est supposé homogène et dissipé par mélange avec - ! son environnement. la longueur l_mix contrôle l'efficacité du - ! mélange - - ! Le calcul du transport des différentes espèces se fait en prenant - ! en compte: - ! 1. un flux de masse montant - ! 2. un flux de masse descendant - ! 3. un entrainement - ! 4. un detrainement - - ! ======================================================================= - - ! ----------------------------------------------------------------------- - ! declarations: - ! ------------- - - include "YOMCST.h" - - ! arguments: - ! ---------- - - INTEGER ngrid, nlay, w2di, iflag_thermals - REAL tho - REAL ptimestep, l_mix, r_aspect - REAL pt(ngrid, nlay), pdtadj(ngrid, nlay) - REAL pu(ngrid, nlay), pduadj(ngrid, nlay) - REAL pv(ngrid, nlay), pdvadj(ngrid, nlay) - REAL po(ngrid, nlay), pdoadj(ngrid, nlay) - REAL pplay(ngrid, nlay), pplev(ngrid, nlay+1) - REAL pphi(ngrid, nlay) - REAL fraca(ngrid, nlay+1), zw2(ngrid, nlay+1) - - INTEGER, SAVE :: idetr = 3, lev_out = 1 - !$OMP THREADPRIVATE(idetr,lev_out) - - ! local: - ! ------ - - INTEGER, SAVE :: dvdq = 0, flagdq = 0, dqimpl = 1 - LOGICAL, SAVE :: debut = .TRUE. - !$OMP THREADPRIVATE(dvdq,flagdq,debut,dqimpl) - - INTEGER ig, k, l, lmax(klon, klev+1), lmaxa(klon), lmix(klon) - REAL zmax(klon), zw, zz, ztva(klon, klev), zzz - - REAL zlev(klon, klev+1), zlay(klon, klev) - REAL zh(klon, klev), zdhadj(klon, klev) - REAL ztv(klon, klev) - REAL zu(klon, klev), zv(klon, klev), zo(klon, klev) - REAL wh(klon, klev+1) - REAL wu(klon, klev+1), wv(klon, klev+1), wo(klon, klev+1) - REAL zla(klon, klev+1) - REAL zwa(klon, klev+1) - REAL zld(klon, klev+1) - REAL zwd(klon, klev+1) - REAL zsortie(klon, klev) - REAL zva(klon, klev) - REAL zua(klon, klev) - REAL zoa(klon, klev) - - REAL zha(klon, klev) - REAL wa_moy(klon, klev+1) - REAL fracc(klon, klev+1) - REAL zf, zf2 - REAL thetath2(klon, klev), wth2(klon, klev) - ! common/comtherm/thetath2,wth2 - - REAL count_time - - LOGICAL sorties - REAL rho(klon, klev), rhobarz(klon, klev+1), masse(klon, klev) - REAL zpspsk(klon, klev) - - REAL wmax(klon, klev), wmaxa(klon) - - REAL wa(klon, klev, klev+1) - REAL wd(klon, klev+1) - REAL larg_part(klon, klev, klev+1) - REAL fracd(klon, klev+1) - REAL xxx(klon, klev+1) - REAL larg_cons(klon, klev+1) - REAL larg_detr(klon, klev+1) - REAL fm0(klon, klev+1), entr0(klon, klev), detr(klon, klev) - REAL pu_therm(klon, klev), pv_therm(klon, klev) - REAL fm(klon, klev+1), entr(klon, klev) - REAL fmc(klon, klev+1) - - CHARACTER (LEN=2) :: str2 - CHARACTER (LEN=10) :: str10 - - CHARACTER (LEN=20) :: modname = 'thermcell2002' - CHARACTER (LEN=80) :: abort_message - - LOGICAL vtest(klon), down - - EXTERNAL scopy - - INTEGER ncorrec, ll - SAVE ncorrec - DATA ncorrec/0/ - !$OMP THREADPRIVATE(ncorrec) - - - ! ----------------------------------------------------------------------- - ! initialisation: - ! --------------- - - sorties = .TRUE. - IF (ngrid/=klon) THEN - PRINT * - PRINT *, 'STOP dans convadj' - PRINT *, 'ngrid =', ngrid - PRINT *, 'klon =', klon - END IF - - ! ----------------------------------------------------------------------- - ! incrementation eventuelle de tendances precedentes: - ! --------------------------------------------------- - - ! print*,'0 OK convect8' - - DO l = 1, nlay - DO ig = 1, ngrid - zpspsk(ig, l) = (pplay(ig,l)/pplev(ig,1))**rkappa - zh(ig, l) = pt(ig, l)/zpspsk(ig, l) - zu(ig, l) = pu(ig, l) - zv(ig, l) = pv(ig, l) - zo(ig, l) = po(ig, l) - ztv(ig, l) = zh(ig, l)*(1.+0.61*zo(ig,l)) - END DO - END DO - - ! print*,'1 OK convect8' - ! -------------------- - - - ! + + + + + + + + + + + - - - ! wa, fraca, wd, fracd -------------------- zlev(2), rhobarz - ! wh,wt,wo ... - - ! + + + + + + + + + + + zh,zu,zv,zo,rho - - - ! -------------------- zlev(1) - ! \\\\\\\\\\\\\\\\\\\\ - - - - ! ----------------------------------------------------------------------- - ! Calcul des altitudes des couches - ! ----------------------------------------------------------------------- - - IF (debut) THEN - flagdq = (iflag_thermals-1000)/100 - dvdq = (iflag_thermals-(1000+flagdq*100))/10 - IF (flagdq==2) dqimpl = -1 - IF (flagdq==3) dqimpl = 1 - debut = .FALSE. - END IF - PRINT *, 'TH flag th ', iflag_thermals, flagdq, dvdq, dqimpl - - DO l = 2, nlay - DO ig = 1, ngrid - zlev(ig, l) = 0.5*(pphi(ig,l)+pphi(ig,l-1))/rg - END DO - END DO - DO ig = 1, ngrid - zlev(ig, 1) = 0. - zlev(ig, nlay+1) = (2.*pphi(ig,klev)-pphi(ig,klev-1))/rg - END DO - DO l = 1, nlay - DO ig = 1, ngrid - zlay(ig, l) = pphi(ig, l)/rg - END DO - END DO - - ! print*,'2 OK convect8' - ! ----------------------------------------------------------------------- - ! Calcul des densites - ! ----------------------------------------------------------------------- - - DO l = 1, nlay - DO ig = 1, ngrid - rho(ig, l) = pplay(ig, l)/(zpspsk(ig,l)*rd*zh(ig,l)) - END DO - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - rhobarz(ig, l) = 0.5*(rho(ig,l)+rho(ig,l-1)) - END DO - END DO - - DO k = 1, nlay - DO l = 1, nlay + 1 - DO ig = 1, ngrid - wa(ig, k, l) = 0. - END DO - END DO - END DO - - ! print*,'3 OK convect8' - ! ------------------------------------------------------------------ - ! Calcul de w2, quarre de w a partir de la cape - ! a partir de w2, on calcule wa, vitesse de l'ascendance - - ! ATTENTION: Dans cette version, pour cause d'economie de memoire, - ! w2 est stoke dans wa - - ! ATTENTION: dans convect8, on n'utilise le calcule des wa - ! independants par couches que pour calculer l'entrainement - ! a la base et la hauteur max de l'ascendance. - - ! Indicages: - ! l'ascendance provenant du niveau k traverse l'interface l avec - ! une vitesse wa(k,l). - - ! -------------------- - - ! + + + + + + + + + + - - ! wa(k,l) ---- -------------------- l - ! /\ - ! /||\ + + + + + + + + + + - ! || - ! || -------------------- - ! || - ! || + + + + + + + + + + - ! || - ! || -------------------- - ! ||__ - ! |___ + + + + + + + + + + k - - ! -------------------- - - - - ! ------------------------------------------------------------------ - - - DO k = 1, nlay - 1 - DO ig = 1, ngrid - wa(ig, k, k) = 0. - wa(ig, k, k+1) = 2.*rg*(ztv(ig,k)-ztv(ig,k+1))/ztv(ig, k+1)* & - (zlev(ig,k+1)-zlev(ig,k)) - END DO - DO l = k + 1, nlay - 1 - DO ig = 1, ngrid - wa(ig, k, l+1) = wa(ig, k, l) + 2.*rg*(ztv(ig,k)-ztv(ig,l))/ztv(ig, l & - )*(zlev(ig,l+1)-zlev(ig,l)) - END DO - END DO - DO ig = 1, ngrid - wa(ig, k, nlay+1) = 0. - END DO - END DO - - ! print*,'4 OK convect8' - ! Calcul de la couche correspondant a la hauteur du thermique - DO k = 1, nlay - 1 - DO ig = 1, ngrid - lmax(ig, k) = k - END DO - DO l = nlay, k + 1, -1 - DO ig = 1, ngrid - IF (wa(ig,k,l)<=1.E-10) lmax(ig, k) = l - 1 - END DO - END DO - END DO - - ! print*,'5 OK convect8' - ! Calcule du w max du thermique - DO k = 1, nlay - DO ig = 1, ngrid - wmax(ig, k) = 0. - END DO - END DO - - DO k = 1, nlay - 1 - DO l = k, nlay - DO ig = 1, ngrid - IF (l<=lmax(ig,k)) THEN - wa(ig, k, l) = sqrt(wa(ig,k,l)) - wmax(ig, k) = max(wmax(ig,k), wa(ig,k,l)) - ELSE - wa(ig, k, l) = 0. - END IF - END DO - END DO - END DO - - DO k = 1, nlay - 1 - DO ig = 1, ngrid - pu_therm(ig, k) = sqrt(wmax(ig,k)) - pv_therm(ig, k) = sqrt(wmax(ig,k)) - END DO - END DO - - ! print*,'6 OK convect8' - ! Longueur caracteristique correspondant a la hauteur des thermiques. - DO ig = 1, ngrid - zmax(ig) = 500. - END DO - ! print*,'LMAX LMAX LMAX ' - DO k = 1, nlay - 1 - DO ig = 1, ngrid - zmax(ig) = max(zmax(ig), zlev(ig,lmax(ig,k))-zlev(ig,k)) - END DO - ! print*,k,lmax(1,k) - END DO - ! print*,'ZMAX ZMAX ZMAX ',zmax - ! call dump2d(iim,jjm-1,zmax(2:ngrid-1),'ZMAX ') - - ! print*,'OKl336' - ! Calcul de l'entrainement. - ! Le rapport d'aspect relie la largeur de l'ascendance a l'epaisseur - ! de la couche d'alimentation en partant du principe que la vitesse - ! maximum dans l'ascendance est la vitesse d'entrainement horizontale. - DO k = 1, nlay - DO ig = 1, ngrid - zzz = rho(ig, k)*wmax(ig, k)*(zlev(ig,k+1)-zlev(ig,k))/ & - (zmax(ig)*r_aspect) - IF (w2di==2) THEN - entr(ig, k) = entr(ig, k) + ptimestep*(zzz-entr(ig,k))/tho - ELSE - entr(ig, k) = zzz - END IF - ztva(ig, k) = ztv(ig, k) - END DO - END DO - - - ! print*,'7 OK convect8' - DO k = 1, klev + 1 - DO ig = 1, ngrid - zw2(ig, k) = 0. - fmc(ig, k) = 0. - larg_cons(ig, k) = 0. - larg_detr(ig, k) = 0. - wa_moy(ig, k) = 0. - END DO - END DO - - ! print*,'8 OK convect8' - DO ig = 1, ngrid - lmaxa(ig) = 1 - lmix(ig) = 1 - wmaxa(ig) = 0. - END DO - - - ! print*,'OKl372' - DO l = 1, nlay - 2 - DO ig = 1, ngrid - ! if (zw2(ig,l).lt.1.e-10.and.ztv(ig,l).gt.ztv(ig,l+1)) then - ! print*,'COUCOU ',l,zw2(ig,l),ztv(ig,l),ztv(ig,l+1) - IF (zw2(ig,l)<1.E-10 .AND. ztv(ig,l)>ztv(ig,l+1) .AND. & - entr(ig,l)>1.E-10) THEN - ! print*,'COUCOU cas 1' - ! Initialisation de l'ascendance - ! lmix(ig)=1 - ztva(ig, l) = ztv(ig, l) - fmc(ig, l) = 0. - fmc(ig, l+1) = entr(ig, l) - zw2(ig, l) = 0. - ! if (.not.ztv(ig,l+1).gt.150.) then - ! print*,'ig,l+1,ztv(ig,l+1)' - ! print*, ig,l+1,ztv(ig,l+1) - ! endif - zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* & - (zlev(ig,l+1)-zlev(ig,l)) - larg_detr(ig, l) = 0. - ELSE IF (zw2(ig,l)>=1.E-10 .AND. fmc(ig,l)+entr(ig,l)>1.E-10) THEN - ! Incrementation... - fmc(ig, l+1) = fmc(ig, l) + entr(ig, l) - ! if (.not.fmc(ig,l+1).gt.1.e-15) then - ! print*,'ig,l+1,fmc(ig,l+1)' - ! print*, ig,l+1,fmc(ig,l+1) - ! print*,'Fmc ',(fmc(ig,ll),ll=1,klev+1) - ! print*,'W2 ',(zw2(ig,ll),ll=1,klev+1) - ! print*,'Tv ',(ztv(ig,ll),ll=1,klev) - ! print*,'Entr ',(entr(ig,ll),ll=1,klev) - ! endif - ztva(ig, l) = (fmc(ig,l)*ztva(ig,l-1)+entr(ig,l)*ztv(ig,l))/ & - fmc(ig, l+1) - ! mise a jour de la vitesse ascendante (l'air entraine de la couche - ! consideree commence avec une vitesse nulle). - zw2(ig, l+1) = zw2(ig, l)*(fmc(ig,l)/fmc(ig,l+1))**2 + & - 2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, l)*(zlev(ig,l+1)-zlev(ig,l)) - END IF - IF (zw2(ig,l+1)<0.) THEN - zw2(ig, l+1) = 0. - lmaxa(ig) = l - ELSE - wa_moy(ig, l+1) = sqrt(zw2(ig,l+1)) - END IF - IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN - ! lmix est le niveau de la couche ou w (wa_moy) est maximum - lmix(ig) = l + 1 - wmaxa(ig) = wa_moy(ig, l+1) - END IF - ! print*,'COUCOU cas 2 LMIX=',lmix(ig),wa_moy(ig,l+1),wmaxa(ig) - END DO - END DO - - ! print*,'9 OK convect8' - ! print*,'WA1 ',wa_moy - - ! determination de l'indice du debut de la mixed layer ou w decroit - - ! calcul de la largeur de chaque ascendance dans le cas conservatif. - ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant - ! d'une couche est égale à la hauteur de la couche alimentante. - ! La vitesse maximale dans l'ascendance est aussi prise comme estimation - ! de la vitesse d'entrainement horizontal dans la couche alimentante. - - ! print*,'OKl439' - DO l = 2, nlay - DO ig = 1, ngrid - IF (l<=lmaxa(ig)) THEN - zw = max(wa_moy(ig,l), 1.E-10) - larg_cons(ig, l) = zmax(ig)*r_aspect*fmc(ig, l)/(rhobarz(ig,l)*zw) - END IF - END DO - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - IF (l<=lmaxa(ig)) THEN - ! if (idetr.eq.0) then - ! cette option est finalement en dur. - larg_detr(ig, l) = sqrt(l_mix*zlev(ig,l)) - ! else if (idetr.eq.1) then - ! larg_detr(ig,l)=larg_cons(ig,l) - ! s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) - ! else if (idetr.eq.2) then - ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) - ! s *sqrt(wa_moy(ig,l)) - ! else if (idetr.eq.4) then - ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) - ! s *wa_moy(ig,l) - ! endif - END IF - END DO - END DO - - ! print*,'10 OK convect8' - ! print*,'WA2 ',wa_moy - ! calcul de la fraction de la maille concernée par l'ascendance en tenant - ! compte de l'epluchage du thermique. - - DO l = 2, nlay - DO ig = 1, ngrid - IF (larg_cons(ig,l)>1.) THEN - ! print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' - fraca(ig, l) = (larg_cons(ig,l)-larg_detr(ig,l))/(r_aspect*zmax(ig)) - IF (l>lmix(ig)) THEN - xxx(ig, l) = (lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig)) - IF (idetr==0) THEN - fraca(ig, l) = fraca(ig, lmix(ig)) - ELSE IF (idetr==1) THEN - fraca(ig, l) = fraca(ig, lmix(ig))*xxx(ig, l) - ELSE IF (idetr==2) THEN - fraca(ig, l) = fraca(ig, lmix(ig))*(1.-(1.-xxx(ig,l))**2) - ELSE - fraca(ig, l) = fraca(ig, lmix(ig))*xxx(ig, l)**2 - END IF - END IF - ! print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' - fraca(ig, l) = max(fraca(ig,l), 0.) - fraca(ig, l) = min(fraca(ig,l), 0.5) - fracd(ig, l) = 1. - fraca(ig, l) - fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) - ELSE - ! wa_moy(ig,l)=0. - fraca(ig, l) = 0. - fracc(ig, l) = 0. - fracd(ig, l) = 1. - END IF - END DO - END DO - - ! print*,'11 OK convect8' - ! print*,'Ea3 ',wa_moy - ! ------------------------------------------------------------------ - ! Calcul de fracd, wd - ! somme wa - wd = 0 - ! ------------------------------------------------------------------ - - - DO ig = 1, ngrid - fm(ig, 1) = 0. - fm(ig, nlay+1) = 0. - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - fm(ig, l) = fraca(ig, l)*wa_moy(ig, l)*rhobarz(ig, l) - END DO - DO ig = 1, ngrid - IF (fracd(ig,l)<0.1) THEN - abort_message = 'fracd trop petit' - CALL abort_physic(modname, abort_message, 1) - ELSE - ! vitesse descendante "diagnostique" - wd(ig, l) = fm(ig, l)/(fracd(ig,l)*rhobarz(ig,l)) - END IF - END DO - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) - masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg - END DO - END DO - - ! print*,'12 OK convect8' - ! print*,'WA4 ',wa_moy - ! c------------------------------------------------------------------ - ! calcul du transport vertical - ! ------------------------------------------------------------------ - - GO TO 4444 - ! print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep - DO l = 2, nlay - 1 - DO ig = 1, ngrid - IF (fm(ig,l+1)*ptimestep>masse(ig,l) .AND. fm(ig,l+1)*ptimestep>masse( & - ig,l+1)) THEN - ! print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' - ! s ,fm(ig,l+1)*ptimestep - ! s ,' M=',masse(ig,l),masse(ig,l+1) - END IF - END DO - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - IF (entr(ig,l)*ptimestep>masse(ig,l)) THEN - ! print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' - ! s ,entr(ig,l)*ptimestep - ! s ,' M=',masse(ig,l) - END IF - END DO - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - IF (.NOT. fm(ig,l)>=0. .OR. .NOT. fm(ig,l)<=10.) THEN - ! print*,'WARN!!! fm exagere ig=',ig,' l=',l - ! s ,' FM=',fm(ig,l) - END IF - IF (.NOT. masse(ig,l)>=1.E-10 .OR. .NOT. masse(ig,l)<=1.E4) THEN - ! print*,'WARN!!! masse exagere ig=',ig,' l=',l - ! s ,' M=',masse(ig,l) - ! print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', - ! s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) - ! print*,'zlev(ig,l+1),zlev(ig,l)' - ! s ,zlev(ig,l+1),zlev(ig,l) - ! print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' - ! s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) - END IF - IF (.NOT. entr(ig,l)>=0. .OR. .NOT. entr(ig,l)<=10.) THEN - ! print*,'WARN!!! entr exagere ig=',ig,' l=',l - ! s ,' E=',entr(ig,l) - END IF - END DO - END DO - -4444 CONTINUE - ! print*,'OK 444 ' - - IF (w2di==1) THEN - fm0 = fm0 + ptimestep*(fm-fm0)/tho - entr0 = entr0 + ptimestep*(entr-entr0)/tho - ELSE - fm0 = fm - entr0 = entr - END IF - - IF (flagdq==0) THEN - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zh, zdhadj, & - zha) - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zo, pdoadj, & - zoa) - PRINT *, 'THERMALS OPT 1' - ELSE IF (flagdq==1) THEN - CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, & - zdhadj, zha) - CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, & - pdoadj, zoa) - PRINT *, 'THERMALS OPT 2' - ELSE - CALL thermcell_dq(ngrid, nlay, dqimpl, ptimestep, fm0, entr0, masse, zh, & - zdhadj, zha, lev_out) - CALL thermcell_dq(ngrid, nlay, dqimpl, ptimestep, fm0, entr0, masse, zo, & - pdoadj, zoa, lev_out) - PRINT *, 'THERMALS OPT 3', dqimpl - END IF - - PRINT *, 'TH VENT ', dvdq - IF (dvdq==0) THEN - ! print*,'TH VENT OK ',dvdq - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, & - zua) - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, & - zva) - ELSE IF (dvdq==1) THEN - CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, & - zu, zv, pduadj, pdvadj, zua, zva) - ELSE IF (dvdq==2) THEN - CALL thermcell_dv2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, & - zmax, zu, zv, pduadj, pdvadj, zua, zva, lev_out) - ELSE IF (dvdq==3) THEN - CALL thermcell_dq(ngrid, nlay, dqimpl, ptimestep, fm0, entr0, masse, zu, & - pduadj, zua, lev_out) - CALL thermcell_dq(ngrid, nlay, dqimpl, ptimestep, fm0, entr0, masse, zv, & - pdvadj, zva, lev_out) - END IF - - ! CALL writefield_phy('duadj',pduadj,klev) - - DO l = 1, nlay - DO ig = 1, ngrid - zf = 0.5*(fracc(ig,l)+fracc(ig,l+1)) - zf2 = zf/(1.-zf) - thetath2(ig, l) = zf2*(zha(ig,l)-zh(ig,l))**2 - wth2(ig, l) = zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 - END DO - END DO - - - - ! print*,'13 OK convect8' - ! print*,'WA5 ',wa_moy - DO l = 1, nlay - DO ig = 1, ngrid - pdtadj(ig, l) = zdhadj(ig, l)*zpspsk(ig, l) - END DO - END DO - - - ! do l=1,nlay - ! do ig=1,ngrid - ! if(abs(pdtadj(ig,l))*86400..gt.500.) then - ! print*,'WARN!!! ig=',ig,' l=',l - ! s ,' pdtadj=',pdtadj(ig,l) - ! endif - ! if(abs(pdoadj(ig,l))*86400..gt.1.) then - ! print*,'WARN!!! ig=',ig,' l=',l - ! s ,' pdoadj=',pdoadj(ig,l) - ! endif - ! enddo - ! enddo - - ! print*,'14 OK convect8' - ! ------------------------------------------------------------------ - ! Calculs pour les sorties - ! ------------------------------------------------------------------ - - IF (sorties) THEN - DO l = 1, nlay - DO ig = 1, ngrid - zla(ig, l) = (1.-fracd(ig,l))*zmax(ig) - zld(ig, l) = fracd(ig, l)*zmax(ig) - IF (1.-fracd(ig,l)>1.E-10) zwa(ig, l) = wd(ig, l)*fracd(ig, l)/ & - (1.-fracd(ig,l)) - END DO - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - detr(ig, l) = fm(ig, l) + entr(ig, l) - fm(ig, l+1) - IF (detr(ig,l)<0.) THEN - entr(ig, l) = entr(ig, l) - detr(ig, l) - detr(ig, l) = 0. - ! print*,'WARNING !!! detrainement negatif ',ig,l - END IF - END DO - END DO - END IF - - ! print*,'15 OK convect8' - - - ! if(wa_moy(1,4).gt.1.e-10) stop - - ! print*,'19 OK convect8' - RETURN -END SUBROUTINE thermcell_2002 - -SUBROUTINE thermcell_cld(ngrid, nlay, ptimestep, pplay, pplev, pphi, zlev, & - debut, pu, pv, pt, po, pduadj, pdvadj, pdtadj, pdoadj, fm0, entr0, zqla, & - lmax, zmax_sec, wmax_sec, zw_sec, lmix_sec, ratqscth, ratqsdiff & ! s - ! ,pu_therm,pv_therm - , r_aspect, l_mix, w2di, tho) - - USE dimphy - IMPLICIT NONE - - ! ======================================================================= - - ! Calcul du transport verticale dans la couche limite en presence - ! de "thermiques" explicitement representes - - ! Réécriture à partir d'un listing papier à Habas, le 14/02/00 - - ! le thermique est supposé homogène et dissipé par mélange avec - ! son environnement. la longueur l_mix contrôle l'efficacité du - ! mélange - - ! Le calcul du transport des différentes espèces se fait en prenant - ! en compte: - ! 1. un flux de masse montant - ! 2. un flux de masse descendant - ! 3. un entrainement - ! 4. un detrainement - - ! ======================================================================= - - ! ----------------------------------------------------------------------- - ! declarations: - ! ------------- - - include "YOMCST.h" - include "YOETHF.h" - include "FCTTRE.h" - - ! arguments: - ! ---------- - - INTEGER ngrid, nlay, w2di - REAL tho - REAL ptimestep, l_mix, r_aspect - REAL pt(ngrid, nlay), pdtadj(ngrid, nlay) - REAL pu(ngrid, nlay), pduadj(ngrid, nlay) - REAL pv(ngrid, nlay), pdvadj(ngrid, nlay) - REAL po(ngrid, nlay), pdoadj(ngrid, nlay) - REAL pplay(ngrid, nlay), pplev(ngrid, nlay+1) - REAL pphi(ngrid, nlay) - - INTEGER idetr - SAVE idetr - DATA idetr/3/ - !$OMP THREADPRIVATE(idetr) - - ! local: - ! ------ - - INTEGER ig, k, l, lmaxa(klon), lmix(klon) - REAL zsortie1d(klon) - ! CR: on remplace lmax(klon,klev+1) - INTEGER lmax(klon), lmin(klon), lentr(klon) - REAL linter(klon) - REAL zmix(klon), fracazmix(klon) - REAL alpha - SAVE alpha - DATA alpha/1./ - !$OMP THREADPRIVATE(alpha) - - ! RC - REAL zmax(klon), zw, zz, zw2(klon, klev+1), ztva(klon, klev), zzz - REAL zmax_sec(klon) - REAL zmax_sec2(klon) - REAL zw_sec(klon, klev+1) - INTEGER lmix_sec(klon) - REAL w_est(klon, klev+1) - ! on garde le zmax du pas de temps precedent - ! real zmax0(klon) - ! save zmax0 - ! real zmix0(klon) - ! save zmix0 - REAL, SAVE, ALLOCATABLE :: zmax0(:), zmix0(:) - !$OMP THREADPRIVATE(zmax0, zmix0) - - REAL zlev(klon, klev+1), zlay(klon, klev) - REAL deltaz(klon, klev) - REAL zh(klon, klev), zdhadj(klon, klev) - REAL zthl(klon, klev), zdthladj(klon, klev) - REAL ztv(klon, klev) - REAL zu(klon, klev), zv(klon, klev), zo(klon, klev) - REAL zl(klon, klev) - REAL wh(klon, klev+1) - REAL wu(klon, klev+1), wv(klon, klev+1), wo(klon, klev+1) - REAL zla(klon, klev+1) - REAL zwa(klon, klev+1) - REAL zld(klon, klev+1) - REAL zwd(klon, klev+1) - REAL zsortie(klon, klev) - REAL zva(klon, klev) - REAL zua(klon, klev) - REAL zoa(klon, klev) - - REAL zta(klon, klev) - REAL zha(klon, klev) - REAL wa_moy(klon, klev+1) - REAL fraca(klon, klev+1) - REAL fracc(klon, klev+1) - REAL zf, zf2 - REAL thetath2(klon, klev), wth2(klon, klev), wth3(klon, klev) - REAL q2(klon, klev) - REAL dtheta(klon, klev) - ! common/comtherm/thetath2,wth2 - - REAL ratqscth(klon, klev) - REAL sum - REAL sumdiff - REAL ratqsdiff(klon, klev) - REAL count_time - INTEGER ialt - - LOGICAL sorties - REAL rho(klon, klev), rhobarz(klon, klev+1), masse(klon, klev) - REAL zpspsk(klon, klev) - - ! real wmax(klon,klev),wmaxa(klon) - REAL wmax(klon), wmaxa(klon) - REAL wmax_sec(klon) - REAL wmax_sec2(klon) - REAL wa(klon, klev, klev+1) - REAL wd(klon, klev+1) - REAL larg_part(klon, klev, klev+1) - REAL fracd(klon, klev+1) - REAL xxx(klon, klev+1) - REAL larg_cons(klon, klev+1) - REAL larg_detr(klon, klev+1) - REAL fm0(klon, klev+1), entr0(klon, klev), detr(klon, klev) - REAL massetot(klon, klev) - REAL detr0(klon, klev) - REAL alim0(klon, klev) - REAL pu_therm(klon, klev), pv_therm(klon, klev) - REAL fm(klon, klev+1), entr(klon, klev) - REAL fmc(klon, klev+1) - - REAL zcor, zdelta, zcvm5, qlbef - REAL tbef(klon), qsatbef(klon) - REAL dqsat_dt, dt, num, denom - REAL reps, rlvcp, ddt0 - REAL ztla(klon, klev), zqla(klon, klev), zqta(klon, klev) - ! CR niveau de condensation - REAL nivcon(klon) - REAL zcon(klon) - REAL zqsat(klon, klev) - REAL zqsatth(klon, klev) - PARAMETER (ddt0=.01) - - - ! CR:nouvelles variables - REAL f_star(klon, klev+1), entr_star(klon, klev) - REAL detr_star(klon, klev) - REAL alim_star_tot(klon), alim_star2(klon) - REAL entr_star_tot(klon) - REAL detr_star_tot(klon) - REAL alim_star(klon, klev) - REAL alim(klon, klev) - REAL nu(klon, klev) - REAL nu_e(klon, klev) - REAL nu_min - REAL nu_max - REAL nu_r - REAL f(klon) - ! real f(klon), f0(klon) - ! save f0 - REAL, SAVE, ALLOCATABLE :: f0(:) - !$OMP THREADPRIVATE(f0) - - REAL f_old - REAL zlevinter(klon) - LOGICAL, SAVE :: first = .TRUE. - !$OMP THREADPRIVATE(first) - ! data first /.false./ - ! save first - LOGICAL nuage - ! save nuage - LOGICAL boucle - LOGICAL therm - LOGICAL debut - LOGICAL rale - INTEGER test(klon) - INTEGER signe_zw2 - ! RC - - CHARACTER *2 str2 - CHARACTER *10 str10 - - CHARACTER (LEN=20) :: modname = 'thermcell_cld' - CHARACTER (LEN=80) :: abort_message - - LOGICAL vtest(klon), down - LOGICAL zsat(klon) - - EXTERNAL scopy - - INTEGER ncorrec, ll - SAVE ncorrec - DATA ncorrec/0/ - !$OMP THREADPRIVATE(ncorrec) - - - - ! ----------------------------------------------------------------------- - ! initialisation: - ! --------------- - - IF (first) THEN - ALLOCATE (zmix0(klon)) - ALLOCATE (zmax0(klon)) - ALLOCATE (f0(klon)) - first = .FALSE. - END IF - - sorties = .FALSE. - ! print*,'NOUVEAU DETR PLUIE ' - IF (ngrid/=klon) THEN - PRINT * - PRINT *, 'STOP dans convadj' - PRINT *, 'ngrid =', ngrid - PRINT *, 'klon =', klon - END IF - - ! Initialisation - rlvcp = rlvtt/rcpd - reps = rd/rv - ! initialisations de zqsat - DO ll = 1, nlay - DO ig = 1, ngrid - zqsat(ig, ll) = 0. - zqsatth(ig, ll) = 0. - END DO - END DO - - ! on met le first a true pour le premier passage de la journée - DO ig = 1, klon - test(ig) = 0 - END DO - IF (debut) THEN - DO ig = 1, klon - test(ig) = 1 - f0(ig) = 0. - zmax0(ig) = 0. - END DO - END IF - DO ig = 1, klon - IF ((.NOT. debut) .AND. (f0(ig)<1.E-10)) THEN - test(ig) = 1 - END IF - END DO - ! do ig=1,klon - ! print*,'test(ig)',test(ig),zmax0(ig) - ! enddo - nuage = .FALSE. - ! ----------------------------------------------------------------------- - ! AM Calcul de T,q,ql a partir de Tl et qT - ! --------------------------------------------------- - - ! Pr Tprec=Tl calcul de qsat - ! Si qsat>qT T=Tl, q=qT - ! Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt) - ! On cherche DDT < DDT0 - - ! defaut - DO ll = 1, nlay - DO ig = 1, ngrid - zo(ig, ll) = po(ig, ll) - zl(ig, ll) = 0. - zh(ig, ll) = pt(ig, ll) - END DO - END DO - DO ig = 1, ngrid - zsat(ig) = .FALSE. - END DO - - - DO ll = 1, nlay - ! les points insatures sont definitifs - DO ig = 1, ngrid - tbef(ig) = pt(ig, ll) - zdelta = max(0., sign(1.,rtt-tbef(ig))) - qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, ll) - qsatbef(ig) = min(0.5, qsatbef(ig)) - zcor = 1./(1.-retv*qsatbef(ig)) - qsatbef(ig) = qsatbef(ig)*zcor - zsat(ig) = (max(0.,po(ig,ll)-qsatbef(ig))>1.E-10) - END DO - - DO ig = 1, ngrid - IF (zsat(ig) .AND. (1==1)) THEN - qlbef = max(0., po(ig,ll)-qsatbef(ig)) - ! si sature: ql est surestime, d'ou la sous-relax - dt = 0.5*rlvcp*qlbef - ! write(18,*),'DT0=',DT - ! on pourra enchainer 2 ou 3 calculs sans Do while - DO WHILE (abs(dt)>ddt0) - ! il faut verifier si c,a conserve quand on repasse en insature ... - tbef(ig) = tbef(ig) + dt - zdelta = max(0., sign(1.,rtt-tbef(ig))) - qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, ll) - qsatbef(ig) = min(0.5, qsatbef(ig)) - zcor = 1./(1.-retv*qsatbef(ig)) - qsatbef(ig) = qsatbef(ig)*zcor - ! on veut le signe de qlbef - qlbef = po(ig, ll) - qsatbef(ig) - zdelta = max(0., sign(1.,rtt-tbef(ig))) - zcvm5 = r5les*(1.-zdelta) + r5ies*zdelta - zcor = 1./(1.-retv*qsatbef(ig)) - dqsat_dt = foede(tbef(ig), zdelta, zcvm5, qsatbef(ig), zcor) - num = -tbef(ig) + pt(ig, ll) + rlvcp*qlbef - denom = 1. + rlvcp*dqsat_dt - IF (denom<1.E-10) THEN - PRINT *, 'pb denom' - END IF - dt = num/denom - END DO - ! on ecrit de maniere conservative (sat ou non) - zl(ig, ll) = max(0., qlbef) - ! T = Tl +Lv/Cp ql - zh(ig, ll) = pt(ig, ll) + rlvcp*zl(ig, ll) - zo(ig, ll) = po(ig, ll) - zl(ig, ll) - END IF - ! on ecrit zqsat - zqsat(ig, ll) = qsatbef(ig) - END DO - END DO - ! AM fin - - ! ----------------------------------------------------------------------- - ! incrementation eventuelle de tendances precedentes: - ! --------------------------------------------------- - - ! print*,'0 OK convect8' - - DO l = 1, nlay - DO ig = 1, ngrid - zpspsk(ig, l) = (pplay(ig,l)/100000.)**rkappa - ! zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA - ! zh(ig,l)=pt(ig,l)/zpspsk(ig,l) - zu(ig, l) = pu(ig, l) - zv(ig, l) = pv(ig, l) - ! zo(ig,l)=po(ig,l) - ! ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l)) - ! AM attention zh est maintenant le profil de T et plus le profil de - ! theta ! - - ! T-> Theta - ztv(ig, l) = zh(ig, l)/zpspsk(ig, l) - ! AM Theta_v - ztv(ig, l) = ztv(ig, l)*(1.+retv*(zo(ig,l))-zl(ig,l)) - ! AM Thetal - zthl(ig, l) = pt(ig, l)/zpspsk(ig, l) - - END DO - END DO - - ! print*,'1 OK convect8' - ! -------------------- - - - ! + + + + + + + + + + + - - - ! wa, fraca, wd, fracd -------------------- zlev(2), rhobarz - ! wh,wt,wo ... - - ! + + + + + + + + + + + zh,zu,zv,zo,rho - - - ! -------------------- zlev(1) - ! \\\\\\\\\\\\\\\\\\\\ - - - - ! ----------------------------------------------------------------------- - ! Calcul des altitudes des couches - ! ----------------------------------------------------------------------- - - DO l = 2, nlay - DO ig = 1, ngrid - zlev(ig, l) = 0.5*(pphi(ig,l)+pphi(ig,l-1))/rg - END DO - END DO - DO ig = 1, ngrid - zlev(ig, 1) = 0. - zlev(ig, nlay+1) = (2.*pphi(ig,klev)-pphi(ig,klev-1))/rg - END DO - DO l = 1, nlay - DO ig = 1, ngrid - zlay(ig, l) = pphi(ig, l)/rg - END DO - END DO - ! calcul de deltaz - DO l = 1, nlay - DO ig = 1, ngrid - deltaz(ig, l) = zlev(ig, l+1) - zlev(ig, l) - END DO - END DO - - ! print*,'2 OK convect8' - ! ----------------------------------------------------------------------- - ! Calcul des densites - ! ----------------------------------------------------------------------- - - DO l = 1, nlay - DO ig = 1, ngrid - ! rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l)) - rho(ig, l) = pplay(ig, l)/(zpspsk(ig,l)*rd*ztv(ig,l)) - END DO - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - rhobarz(ig, l) = 0.5*(rho(ig,l)+rho(ig,l-1)) - END DO - END DO - - DO k = 1, nlay - DO l = 1, nlay + 1 - DO ig = 1, ngrid - wa(ig, k, l) = 0. - END DO - END DO - END DO - ! Cr:ajout:calcul de la masse - DO l = 1, nlay - DO ig = 1, ngrid - ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) - masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg - END DO - END DO - ! print*,'3 OK convect8' - ! ------------------------------------------------------------------ - ! Calcul de w2, quarre de w a partir de la cape - ! a partir de w2, on calcule wa, vitesse de l'ascendance - - ! ATTENTION: Dans cette version, pour cause d'economie de memoire, - ! w2 est stoke dans wa - - ! ATTENTION: dans convect8, on n'utilise le calcule des wa - ! independants par couches que pour calculer l'entrainement - ! a la base et la hauteur max de l'ascendance. - - ! Indicages: - ! l'ascendance provenant du niveau k traverse l'interface l avec - ! une vitesse wa(k,l). - - ! -------------------- - - ! + + + + + + + + + + - - ! wa(k,l) ---- -------------------- l - ! /\ - ! /||\ + + + + + + + + + + - ! || - ! || -------------------- - ! || - ! || + + + + + + + + + + - ! || - ! || -------------------- - ! ||__ - ! |___ + + + + + + + + + + k - - ! -------------------- - - - - ! ------------------------------------------------------------------ - - ! CR: ponderation entrainement des couches instables - ! def des alim_star tels que alim=f*alim_star - DO l = 1, klev - DO ig = 1, ngrid - alim_star(ig, l) = 0. - alim(ig, l) = 0. - END DO - END DO - ! determination de la longueur de la couche d entrainement - DO ig = 1, ngrid - lentr(ig) = 1 - END DO - - ! on ne considere que les premieres couches instables - therm = .FALSE. - DO k = nlay - 2, 1, -1 - DO ig = 1, ngrid - IF (ztv(ig,k)>ztv(ig,k+1) .AND. ztv(ig,k+1)<=ztv(ig,k+2)) THEN - lentr(ig) = k + 1 - therm = .TRUE. - END IF - END DO - END DO - - ! determination du lmin: couche d ou provient le thermique - DO ig = 1, ngrid - lmin(ig) = 1 - END DO - DO ig = 1, ngrid - DO l = nlay, 2, -1 - IF (ztv(ig,l-1)>ztv(ig,l)) THEN - lmin(ig) = l - 1 - END IF - END DO - END DO - - ! definition de l'entrainement des couches - DO l = 1, klev - 1 - DO ig = 1, ngrid - IF (ztv(ig,l)>ztv(ig,l+1) .AND. l>=lmin(ig) .AND. l1.E-10) THEN - ! do l=1,lentr(ig) - DO l = 1, klev - ! def possibles pour entr_star: zdthetadz, dthetadz, zdtheta - alim_star(ig, l) = alim_star(ig, l)/alim_star_tot(ig) - END DO - END IF - END DO - - ! print*,'fin calcul alim_star' - - ! AM:initialisations - DO k = 1, nlay - DO ig = 1, ngrid - ztva(ig, k) = ztv(ig, k) - ztla(ig, k) = zthl(ig, k) - zqla(ig, k) = 0. - zqta(ig, k) = po(ig, k) - zsat(ig) = .FALSE. - END DO - END DO - DO k = 1, klev - DO ig = 1, ngrid - detr_star(ig, k) = 0. - entr_star(ig, k) = 0. - detr(ig, k) = 0. - entr(ig, k) = 0. - END DO - END DO - ! print*,'7 OK convect8' - DO k = 1, klev + 1 - DO ig = 1, ngrid - zw2(ig, k) = 0. - fmc(ig, k) = 0. - ! CR - f_star(ig, k) = 0. - ! RC - larg_cons(ig, k) = 0. - larg_detr(ig, k) = 0. - wa_moy(ig, k) = 0. - END DO - END DO - - ! n print*,'8 OK convect8' - DO ig = 1, ngrid - linter(ig) = 1. - lmaxa(ig) = 1 - lmix(ig) = 1 - wmaxa(ig) = 0. - END DO - - nu_min = l_mix - nu_max = 1000. - ! do ig=1,ngrid - ! nu_max=wmax_sec(ig) - ! enddo - DO ig = 1, ngrid - DO k = 1, klev - nu(ig, k) = 0. - nu_e(ig, k) = 0. - END DO - END DO - ! Calcul de l'excès de température du à la diffusion turbulente - DO ig = 1, ngrid - DO l = 1, klev - dtheta(ig, l) = 0. - END DO - END DO - DO ig = 1, ngrid - DO l = 1, lentr(ig) - 1 - dtheta(ig, l) = sqrt(10.*0.4*zlev(ig,l+1)**2*1.*((ztv(ig,l+1)- & - ztv(ig,l))/(zlev(ig,l+1)-zlev(ig,l)))**2) - END DO - END DO - ! do l=1,nlay-2 - DO l = 1, klev - 1 - DO ig = 1, ngrid - IF (ztv(ig,l)>ztv(ig,l+1) .AND. alim_star(ig,l)>1.E-10 .AND. & - zw2(ig,l)<1E-10) THEN - ! AM - ! test:on rajoute un excès de T dans couche alim - ! ztla(ig,l)=zthl(ig,l)+dtheta(ig,l) - ztla(ig, l) = zthl(ig, l) - ! test: on rajoute un excès de q dans la couche alim - ! zqta(ig,l)=po(ig,l)+0.001 - zqta(ig, l) = po(ig, l) - zqla(ig, l) = zl(ig, l) - ! AM - f_star(ig, l+1) = alim_star(ig, l) - ! test:calcul de dteta - zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* & - (zlev(ig,l+1)-zlev(ig,l))*0.4*pphi(ig, l)/(pphi(ig,l+1)-pphi(ig,l)) - w_est(ig, l+1) = zw2(ig, l+1) - larg_detr(ig, l) = 0. - ! print*,'coucou boucle 1' - ELSE IF ((zw2(ig,l)>=1E-10) .AND. (f_star(ig,l)+alim_star(ig, & - l))>1.E-10) THEN - ! print*,'coucou boucle 2' - ! estimation du detrainement a partir de la geometrie du pas - ! precedent - IF ((test(ig)==1) .OR. ((.NOT. debut) .AND. (f0(ig)<1.E-10))) THEN - detr_star(ig, l) = 0. - entr_star(ig, l) = 0. - ! print*,'coucou test(ig)',test(ig),f0(ig),zmax0(ig) - ELSE - ! print*,'coucou debut detr' - ! tests sur la definition du detr - IF (zqla(ig,l-1)>1.E-10) THEN - nuage = .TRUE. - END IF - - w_est(ig, l+1) = zw2(ig, l)*((f_star(ig,l))**2)/(f_star(ig,l)+ & - alim_star(ig,l))**2 + 2.*rg*(ztva(ig,l-1)-ztv(ig,l))/ztv(ig, l)*( & - zlev(ig,l+1)-zlev(ig,l)) - IF (w_est(ig,l+1)<0.) THEN - w_est(ig, l+1) = zw2(ig, l) - END IF - IF (l>2) THEN - IF ((w_est(ig,l+1)>w_est(ig,l)) .AND. (zlev(ig, & - l+1)f_star(ig,l)) THEN - detr_star(ig, l) = f_star(ig, l) - ! entr_star(ig,l)=0. - END IF - - IF ((l1.E-10) THEN - ! then - ! test - ! if (((f_star(ig,l+1)+detr_star(ig,l)).gt.1.e-10)) then - ! AM on melange Tl et qt du thermique - ! on rajoute un excès de T dans la couche alim - ! if (l.lt.lentr(ig)) then - ! ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+ - ! s - ! (alim_star(ig,l)+entr_star(ig,l))*(zthl(ig,l)+dtheta(ig,l))) - ! s /(f_star(ig,l+1)+detr_star(ig,l)) - ! else - ztla(ig, l) = (f_star(ig,l)*ztla(ig,l-1)+(alim_star(ig, & - l)+entr_star(ig,l))*zthl(ig,l))/(f_star(ig,l+1)+detr_star(ig,l)) - ! s /(f_star(ig,l+1)) - ! endif - ! on rajoute un excès de q dans la couche alim - ! if (l.lt.lentr(ig)) then - ! zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+ - ! s (alim_star(ig,l)+entr_star(ig,l))*(po(ig,l)+0.001)) - ! s /(f_star(ig,l+1)+detr_star(ig,l)) - ! else - zqta(ig, l) = (f_star(ig,l)*zqta(ig,l-1)+(alim_star(ig, & - l)+entr_star(ig,l))*po(ig,l))/(f_star(ig,l+1)+detr_star(ig,l)) - ! s /(f_star(ig,l+1)) - ! endif - ! AM on en deduit thetav et ql du thermique - ! CR test - ! Tbef(ig)=ztla(ig,l)*zpspsk(ig,l) - tbef(ig) = ztla(ig, l)*zpspsk(ig, l) - zdelta = max(0., sign(1.,rtt-tbef(ig))) - qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, l) - qsatbef(ig) = min(0.5, qsatbef(ig)) - zcor = 1./(1.-retv*qsatbef(ig)) - qsatbef(ig) = qsatbef(ig)*zcor - zsat(ig) = (max(0.,zqta(ig,l)-qsatbef(ig))>1.E-10) - - IF (zsat(ig) .AND. (1==1)) THEN - qlbef = max(0., zqta(ig,l)-qsatbef(ig)) - dt = 0.5*rlvcp*qlbef - ! write(17,*)'DT0=',DT - DO WHILE (abs(dt)>ddt0) - ! print*,'aie' - tbef(ig) = tbef(ig) + dt - zdelta = max(0., sign(1.,rtt-tbef(ig))) - qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, l) - qsatbef(ig) = min(0.5, qsatbef(ig)) - zcor = 1./(1.-retv*qsatbef(ig)) - qsatbef(ig) = qsatbef(ig)*zcor - qlbef = zqta(ig, l) - qsatbef(ig) - - zdelta = max(0., sign(1.,rtt-tbef(ig))) - zcvm5 = r5les*(1.-zdelta) + r5ies*zdelta - zcor = 1./(1.-retv*qsatbef(ig)) - dqsat_dt = foede(tbef(ig), zdelta, zcvm5, qsatbef(ig), zcor) - num = -tbef(ig) + ztla(ig, l)*zpspsk(ig, l) + rlvcp*qlbef - denom = 1. + rlvcp*dqsat_dt - IF (denom<1.E-10) THEN - PRINT *, 'pb denom' - END IF - dt = num/denom - ! write(17,*)'DT=',DT - END DO - zqla(ig, l) = max(0., zqta(ig,l)-qsatbef(ig)) - zqla(ig, l) = max(0., qlbef) - ! zqla(ig,l)=0. - END IF - ! zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig)) - - ! on ecrit de maniere conservative (sat ou non) - ! T = Tl +Lv/Cp ql - ! CR rq utilisation de humidite specifique ou rapport de melange? - ztva(ig, l) = ztla(ig, l)*zpspsk(ig, l) + rlvcp*zqla(ig, l) - ztva(ig, l) = ztva(ig, l)/zpspsk(ig, l) - ! on rajoute le calcul de zha pour diagnostiques (temp potentielle) - zha(ig, l) = ztva(ig, l) - ! if (l.lt.lentr(ig)) then - ! ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) - ! s -zqla(ig,l))-zqla(ig,l)) + 0.1 - ! else - ztva(ig, l) = ztva(ig, l)*(1.+retv*(zqta(ig,l)-zqla(ig, & - l))-zqla(ig,l)) - ! endif - ! ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l) - ! s /(1.-retv*zqla(ig,l)) - ! ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l) - ! ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) - ! s /(1.-retv*zqta(ig,l)) - ! s -zqla(ig,l)/(1.-retv*zqla(ig,l))) - ! s -zqla(ig,l)/(1.-retv*zqla(ig,l))) - ! write(13,*)zqla(ig,l),zqla(ig,l)/(1.-retv*zqla(ig,l)) - ! on ecrit zqsat - zqsatth(ig, l) = qsatbef(ig) - ! enddo - ! DO ig=1,ngrid - ! if (zw2(ig,l).ge.1.e-10.and. - ! s f_star(ig,l)+entr_star(ig,l).gt.1.e-10) then - ! mise a jour de la vitesse ascendante (l'air entraine de la couche - ! consideree commence avec une vitesse nulle). - - ! if (f_star(ig,l+1).gt.1.e-10) then - zw2(ig, l+1) = zw2(ig, l)* & ! s - ! ((f_star(ig,l)-detr_star(ig,l))**2) - ! s /f_star(ig,l+1)**2+ - ((f_star(ig,l))**2)/(f_star(ig,l+1)+detr_star(ig,l))**2 + & ! s - ! /(f_star(ig,l+1))**2+ - 2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, l)*(zlev(ig,l+1)-zlev(ig,l)) - ! s *(f_star(ig,l)/f_star(ig,l+1))**2 - - END IF - END IF - - IF (zw2(ig,l+1)<0.) THEN - linter(ig) = (l*(zw2(ig,l+1)-zw2(ig,l))-zw2(ig,l))/(zw2(ig,l+1)-zw2( & - ig,l)) - zw2(ig, l+1) = 0. - ! print*,'linter=',linter(ig) - ! else if ((zw2(ig,l+1).lt.1.e-10).and.(zw2(ig,l+1).ge.0.)) then - ! linter(ig)=l+1 - ! print*,'linter=l',zw2(ig,l),zw2(ig,l+1) - ELSE - wa_moy(ig, l+1) = sqrt(zw2(ig,l+1)) - ! wa_moy(ig,l+1)=zw2(ig,l+1) - END IF - IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN - ! lmix est le niveau de la couche ou w (wa_moy) est maximum - lmix(ig) = l + 1 - wmaxa(ig) = wa_moy(ig, l+1) - END IF - END DO - END DO - PRINT *, 'fin calcul zw2' - - ! Calcul de la couche correspondant a la hauteur du thermique - DO ig = 1, ngrid - lmax(ig) = lentr(ig) - END DO - DO ig = 1, ngrid - DO l = nlay, lentr(ig) + 1, -1 - IF (zw2(ig,l)<=1.E-10) THEN - lmax(ig) = l - 1 - END IF - END DO - END DO - ! pas de thermique si couche 1 stable - DO ig = 1, ngrid - IF (lmin(ig)>1) THEN - lmax(ig) = 1 - lmin(ig) = 1 - lentr(ig) = 1 - END IF - END DO - - ! Determination de zw2 max - DO ig = 1, ngrid - wmax(ig) = 0. - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - IF (l<=lmax(ig)) THEN - IF (zw2(ig,l)<0.) THEN - PRINT *, 'pb2 zw2<0' - END IF - zw2(ig, l) = sqrt(zw2(ig,l)) - wmax(ig) = max(wmax(ig), zw2(ig,l)) - ELSE - zw2(ig, l) = 0. - END IF - END DO - END DO - - ! Longueur caracteristique correspondant a la hauteur des thermiques. - DO ig = 1, ngrid - zmax(ig) = 0. - zlevinter(ig) = zlev(ig, 1) - END DO - DO ig = 1, ngrid - ! calcul de zlevinter - zlevinter(ig) = (zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*linter(ig) + & - zlev(ig, lmax(ig)) - lmax(ig)*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig))) - ! pour le cas ou on prend tjs lmin=1 - ! zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) - zmax(ig) = max(zmax(ig), zlevinter(ig)-zlev(ig,1)) - zmax0(ig) = zmax(ig) - WRITE (11, *) 'ig,lmax,linter', ig, lmax(ig), linter(ig) - WRITE (12, *) 'ig,zlevinter,zmax', ig, zmax(ig), zlevinter(ig) - END DO - - ! Calcul de zmax_sec et wmax_sec - CALL fermeture_seche(ngrid, nlay, pplay, pplev, pphi, zlev, rhobarz, f0, & - zpspsk, alim, zh, zo, lentr, lmin, nu_min, nu_max, r_aspect, zmax_sec2, & - wmax_sec2) - - PRINT *, 'avant fermeture' - ! Fermeture,determination de f - ! en lmax f=d-e - DO ig = 1, ngrid - ! entr_star(ig,lmax(ig))=0. - ! f_star(ig,lmax(ig)+1)=0. - ! detr_star(ig,lmax(ig))=f_star(ig,lmax(ig))+entr_star(ig,lmax(ig)) - ! s +alim_star(ig,lmax(ig)) - END DO - - DO ig = 1, ngrid - alim_star2(ig) = 0. - END DO - ! calcul de entr_star_tot - DO ig = 1, ngrid - DO k = 1, lmix(ig) - entr_star_tot(ig) = entr_star_tot(ig) & ! s - ! +entr_star(ig,k) - +alim_star(ig, k) - ! s -detr_star(ig,k) - detr_star_tot(ig) = detr_star_tot(ig) & ! s - ! +alim_star(ig,k) - -detr_star(ig, k) + entr_star(ig, k) - END DO - END DO - - DO ig = 1, ngrid - IF (alim_star_tot(ig)<1.E-10) THEN - f(ig) = 0. - ELSE - ! do k=lmin(ig),lentr(ig) - DO k = 1, lentr(ig) - alim_star2(ig) = alim_star2(ig) + alim_star(ig, k)**2/(rho(ig,k)*( & - zlev(ig,k+1)-zlev(ig,k))) - END DO - IF ((zmax_sec(ig)>1.E-10) .AND. (1==1)) THEN - f(ig) = wmax_sec(ig)/(max(500.,zmax_sec(ig))*r_aspect*alim_star2(ig)) - f(ig) = f(ig) + (f0(ig)-f(ig))*exp((-ptimestep/zmax_sec(ig))*wmax_sec & - (ig)) - ELSE - f(ig) = wmax(ig)/(max(500.,zmax(ig))*r_aspect*alim_star2(ig)) - f(ig) = f(ig) + (f0(ig)-f(ig))*exp((-ptimestep/zmax(ig))*wmax(ig)) - END IF - END IF - f0(ig) = f(ig) - END DO - PRINT *, 'apres fermeture' - ! Calcul de l'entrainement - DO ig = 1, ngrid - DO k = 1, klev - alim(ig, k) = f(ig)*alim_star(ig, k) - END DO - END DO - ! CR:test pour entrainer moins que la masse - ! do ig=1,ngrid - ! do l=1,lentr(ig) - ! if ((alim(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then - ! alim(ig,l+1)=alim(ig,l+1)+alim(ig,l) - ! s -0.9*masse(ig,l)/ptimestep - ! alim(ig,l)=0.9*masse(ig,l)/ptimestep - ! endif - ! enddo - ! enddo - ! calcul du détrainement - DO ig = 1, klon - DO k = 1, klev - detr(ig, k) = f(ig)*detr_star(ig, k) - IF (detr(ig,k)<0.) THEN - ! print*,'detr1<0!!!' - END IF - END DO - DO k = 1, klev - entr(ig, k) = f(ig)*entr_star(ig, k) - IF (entr(ig,k)<0.) THEN - ! print*,'entr1<0!!!' - END IF - END DO - END DO - - ! do ig=1,ngrid - ! do l=1,klev - ! if (((detr(ig,l)+entr(ig,l)+alim(ig,l))*ptimestep).gt. - ! s (masse(ig,l))) then - ! print*,'d2+e2+a2>m2','ig=',ig,'l=',l,'lmax(ig)=',lmax(ig),'d+e+a=' - ! s,(detr(ig,l)+entr(ig,l)+alim(ig,l))*ptimestep,'m=',masse(ig,l) - ! endif - ! enddo - ! enddo - ! Calcul des flux - - DO ig = 1, ngrid - DO l = 1, lmax(ig) - ! do l=1,klev - ! fmc(ig,l+1)=f(ig)*f_star(ig,l+1) - fmc(ig, l+1) = fmc(ig, l) + alim(ig, l) + entr(ig, l) - detr(ig, l) - ! print*,'??!!','ig=',ig,'l=',l,'lmax=',lmax(ig),'lmix=',lmix(ig), - ! s 'e=',entr(ig,l),'d=',detr(ig,l),'a=',alim(ig,l),'f=',fmc(ig,l), - ! s 'f+1=',fmc(ig,l+1) - IF (fmc(ig,l+1)<0.) THEN - PRINT *, 'fmc1<0', l + 1, lmax(ig), fmc(ig, l+1) - fmc(ig, l+1) = fmc(ig, l) - detr(ig, l) = alim(ig, l) + entr(ig, l) - ! fmc(ig,l+1)=0. - ! print*,'fmc1<0',l+1,lmax(ig),fmc(ig,l+1) - END IF - ! if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then - ! f_old=fmc(ig,l+1) - ! fmc(ig,l+1)=fmc(ig,l) - ! detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1) - ! endif - - ! if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then - ! f_old=fmc(ig,l+1) - ! fmc(ig,l+1)=fmc(ig,l) - ! detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l) - ! endif - ! rajout du test sur alpha croissant - ! if test - ! if (1.eq.0) then - - IF (l==klev) THEN - PRINT *, 'THERMCELL PB ig=', ig, ' l=', l - abort_message = 'THERMCELL PB' - CALL abort_physic(modname, abort_message, 1) - END IF - ! if ((zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10).and. - ! s (l.ge.lentr(ig)).and. - IF ((zw2(ig,l+1)>1.E-10) .AND. (zw2(ig,l)>1.E-10) .AND. (l>=lentr(ig))) & - THEN - IF (((fmc(ig,l+1)/(rhobarz(ig,l+1)*zw2(ig,l+1)))>(fmc(ig,l)/ & - (rhobarz(ig,l)*zw2(ig,l))))) THEN - f_old = fmc(ig, l+1) - fmc(ig, l+1) = fmc(ig, l)*rhobarz(ig, l+1)*zw2(ig, l+1)/ & - (rhobarz(ig,l)*zw2(ig,l)) - detr(ig, l) = detr(ig, l) + f_old - fmc(ig, l+1) - ! detr(ig,l)=(fmc(ig,l+1)-fmc(ig,l))/(0.4-1.) - ! entr(ig,l)=0.4*detr(ig,l) - ! entr(ig,l)=fmc(ig,l+1)-fmc(ig,l)+detr(ig,l) - END IF - END IF - IF ((fmc(ig,l+1)>fmc(ig,l)) .AND. (l>lentr(ig))) THEN - f_old = fmc(ig, l+1) - fmc(ig, l+1) = fmc(ig, l) - detr(ig, l) = detr(ig, l) + f_old - fmc(ig, l+1) - END IF - IF (detr(ig,l)>fmc(ig,l)) THEN - detr(ig, l) = fmc(ig, l) - entr(ig, l) = fmc(ig, l+1) - alim(ig, l) - END IF - IF (fmc(ig,l+1)<0.) THEN - detr(ig, l) = detr(ig, l) + fmc(ig, l+1) - fmc(ig, l+1) = 0. - PRINT *, 'fmc2<0', l + 1, lmax(ig) - END IF - - ! test pour ne pas avoir f=0 et d=e/=0 - ! if (fmc(ig,l+1).lt.1.e-10) then - ! detr(ig,l+1)=0. - ! entr(ig,l+1)=0. - ! zqla(ig,l+1)=0. - ! zw2(ig,l+1)=0. - ! lmax(ig)=l+1 - ! zmax(ig)=zlev(ig,lmax(ig)) - ! endif - IF (zw2(ig,l+1)>1.E-10) THEN - IF ((((fmc(ig,l+1))/(rhobarz(ig,l+1)*zw2(ig,l+1)))>1.)) THEN - f_old = fmc(ig, l+1) - fmc(ig, l+1) = rhobarz(ig, l+1)*zw2(ig, l+1) - zw2(ig, l+1) = 0. - zqla(ig, l+1) = 0. - detr(ig, l) = detr(ig, l) + f_old - fmc(ig, l+1) - lmax(ig) = l + 1 - zmax(ig) = zlev(ig, lmax(ig)) - PRINT *, 'alpha>1', l + 1, lmax(ig) - END IF - END IF - ! write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) - ! endif test - ! endif - END DO - END DO - DO ig = 1, ngrid - ! if (fmc(ig,lmax(ig)+1).ne.0.) then - fmc(ig, lmax(ig)+1) = 0. - entr(ig, lmax(ig)) = 0. - detr(ig, lmax(ig)) = fmc(ig, lmax(ig)) + entr(ig, lmax(ig)) + & - alim(ig, lmax(ig)) - ! endif - END DO - ! test sur le signe de fmc - DO ig = 1, ngrid - DO l = 1, klev + 1 - IF (fmc(ig,l)<0.) THEN - PRINT *, 'fm1<0!!!', 'ig=', ig, 'l=', l, 'a=', alim(ig, l-1), 'e=', & - entr(ig, l-1), 'f=', fmc(ig, l-1), 'd=', detr(ig, l-1), 'f+1=', & - fmc(ig, l) - END IF - END DO - END DO - ! test de verification - DO ig = 1, ngrid - DO l = 1, lmax(ig) - IF ((abs(fmc(ig,l+1)-fmc(ig,l)-alim(ig,l)-entr(ig,l)+ & - detr(ig,l)))>1.E-4) THEN - ! print*,'pbcm!!','ig=',ig,'l=',l,'lmax=',lmax(ig),'lmix=',lmix(ig), - ! s 'e=',entr(ig,l),'d=',detr(ig,l),'a=',alim(ig,l),'f=',fmc(ig,l), - ! s 'f+1=',fmc(ig,l+1) - END IF - IF (detr(ig,l)<0.) THEN - PRINT *, 'detrdemi<0!!!' - END IF - END DO - END DO - - ! RC - ! CR def de zmix continu (profil parabolique des vitesses) - DO ig = 1, ngrid - IF (lmix(ig)>1.) THEN - ! test - IF (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- & - (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- & - zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))- & - (zlev(ig,lmix(ig)))))>1E-10) THEN - - zmix(ig) = ((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)) & - )**2-(zlev(ig,lmix(ig)+1))**2)-(zw2(ig,lmix(ig))-zw2(ig, & - lmix(ig)+1))*((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))/ & - (2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- & - (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- & - zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) - ELSE - zmix(ig) = zlev(ig, lmix(ig)) - PRINT *, 'pb zmix' - END IF - ELSE - zmix(ig) = 0. - END IF - ! test - IF ((zmax(ig)-zmix(ig))<=0.) THEN - zmix(ig) = 0.9*zmax(ig) - ! print*,'pb zmix>zmax' - END IF - END DO - DO ig = 1, klon - zmix0(ig) = zmix(ig) - END DO - - ! calcul du nouveau lmix correspondant - DO ig = 1, ngrid - DO l = 1, klev - IF (zmix(ig)>=zlev(ig,l) .AND. zmix(ig)(fmc(ig,l)+alim(ig,l))+entr(ig,l)) THEN - PRINT *, 'detr2>fmc2!!!', 'ig=', ig, 'l=', l, 'd=', detr(ig, l), & - 'f=', fmc(ig, l), 'lmax=', lmax(ig) - ! detr(ig,l)=fmc(ig,l)+alim(ig,l)+entr(ig,l) - ! entr(ig,l)=0. - ! fmc(ig,l+1)=0. - ! zw2(ig,l+1)=0. - ! zqla(ig,l+1)=0. - PRINT *, 'pb!fm=0 et f_star>0', l, lmax(ig) - ! lmax(ig)=l - END IF - END DO - END DO - DO ig = 1, ngrid - DO l = lmax(ig) + 1, klev + 1 - ! fmc(ig,l)=0. - ! detr(ig,l)=0. - ! entr(ig,l)=0. - ! zw2(ig,l)=0. - ! zqla(ig,l)=0. - END DO - END DO - - ! Calcul du detrainement lors du premier passage - ! print*,'9 OK convect8' - ! print*,'WA1 ',wa_moy - - ! determination de l'indice du debut de la mixed layer ou w decroit - - ! calcul de la largeur de chaque ascendance dans le cas conservatif. - ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant - ! d'une couche est égale à la hauteur de la couche alimentante. - ! La vitesse maximale dans l'ascendance est aussi prise comme estimation - ! de la vitesse d'entrainement horizontal dans la couche alimentante. - - DO l = 2, nlay - DO ig = 1, ngrid - IF (l<=lmax(ig) .AND. (test(ig)==1)) THEN - zw = max(wa_moy(ig,l), 1.E-10) - larg_cons(ig, l) = zmax(ig)*r_aspect*fmc(ig, l)/(rhobarz(ig,l)*zw) - END IF - END DO - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - IF (l<=lmax(ig) .AND. (test(ig)==1)) THEN - ! if (idetr.eq.0) then - ! cette option est finalement en dur. - IF ((l_mix*zlev(ig,l))<0.) THEN - PRINT *, 'pb l_mix*zlev<0' - END IF - ! CR: test: nouvelle def de lambda - ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) - IF (zw2(ig,l)>1.E-10) THEN - larg_detr(ig, l) = sqrt((l_mix/zw2(ig,l))*zlev(ig,l)) - ELSE - larg_detr(ig, l) = sqrt(l_mix*zlev(ig,l)) - END IF - ! else if (idetr.eq.1) then - ! larg_detr(ig,l)=larg_cons(ig,l) - ! s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) - ! else if (idetr.eq.2) then - ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) - ! s *sqrt(wa_moy(ig,l)) - ! else if (idetr.eq.4) then - ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) - ! s *wa_moy(ig,l) - ! endif - END IF - END DO - END DO - - ! print*,'10 OK convect8' - ! print*,'WA2 ',wa_moy - ! cal1cul de la fraction de la maille concernée par l'ascendance en tenant - ! compte de l'epluchage du thermique. - - - DO l = 2, nlay - DO ig = 1, ngrid - IF (larg_cons(ig,l)>1. .AND. (test(ig)==1)) THEN - ! print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' - fraca(ig, l) = (larg_cons(ig,l)-larg_detr(ig,l))/(r_aspect*zmax(ig)) - ! test - fraca(ig, l) = max(fraca(ig,l), 0.) - fraca(ig, l) = min(fraca(ig,l), 0.5) - fracd(ig, l) = 1. - fraca(ig, l) - fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) - ELSE - ! wa_moy(ig,l)=0. - fraca(ig, l) = 0. - fracc(ig, l) = 0. - fracd(ig, l) = 1. - END IF - END DO - END DO - ! CR: calcul de fracazmix - DO ig = 1, ngrid - IF (test(ig)==1) THEN - fracazmix(ig) = (fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ & - (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + & - fraca(ig, lmix(ig)) - zlev(ig, lmix(ig))*(fraca(ig,lmix(ig)+1)-fraca( & - ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig))) - END IF - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - IF (larg_cons(ig,l)>1. .AND. (test(ig)==1)) THEN - IF (l>lmix(ig)) THEN - ! test - IF (zmax(ig)-zmix(ig)<1.E-10) THEN - ! print*,'pb xxx' - xxx(ig, l) = (lmax(ig)+1.-l)/(lmax(ig)+1.-lmix(ig)) - ELSE - xxx(ig, l) = (zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig)) - END IF - IF (idetr==0) THEN - fraca(ig, l) = fracazmix(ig) - ELSE IF (idetr==1) THEN - fraca(ig, l) = fracazmix(ig)*xxx(ig, l) - ELSE IF (idetr==2) THEN - fraca(ig, l) = fracazmix(ig)*(1.-(1.-xxx(ig,l))**2) - ELSE - fraca(ig, l) = fracazmix(ig)*xxx(ig, l)**2 - END IF - ! print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' - fraca(ig, l) = max(fraca(ig,l), 0.) - fraca(ig, l) = min(fraca(ig,l), 0.5) - fracd(ig, l) = 1. - fraca(ig, l) - fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) - END IF - END IF - END DO - END DO - - PRINT *, 'fin calcul fraca' - ! print*,'11 OK convect8' - ! print*,'Ea3 ',wa_moy - ! ------------------------------------------------------------------ - ! Calcul de fracd, wd - ! somme wa - wd = 0 - ! ------------------------------------------------------------------ - - - DO ig = 1, ngrid - fm(ig, 1) = 0. - fm(ig, nlay+1) = 0. - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - IF (test(ig)==1) THEN - fm(ig, l) = fraca(ig, l)*wa_moy(ig, l)*rhobarz(ig, l) - ! CR:test - IF (alim(ig,l-1)<1E-10 .AND. fm(ig,l)>fm(ig,l-1) .AND. l>lmix(ig)) & - THEN - fm(ig, l) = fm(ig, l-1) - ! write(1,*)'ajustement fm, l',l - END IF - ! write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) - ! RC - END IF - END DO - DO ig = 1, ngrid - IF (fracd(ig,l)<0.1 .AND. (test(ig)==1)) THEN - abort_message = 'fracd trop petit' - CALL abort_physic(modname, abort_message, 1) - ELSE - ! vitesse descendante "diagnostique" - wd(ig, l) = fm(ig, l)/(fracd(ig,l)*rhobarz(ig,l)) - END IF - END DO - END DO - - DO l = 1, nlay + 1 - DO ig = 1, ngrid - IF (test(ig)==0) THEN - fm(ig, l) = fmc(ig, l) - END IF - END DO - END DO - - ! fin du first - DO l = 1, nlay - DO ig = 1, ngrid - ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) - masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg - END DO - END DO - - ! print*,'12 OK convect8' - ! print*,'WA4 ',wa_moy - ! c------------------------------------------------------------------ - ! calcul du transport vertical - ! ------------------------------------------------------------------ - - GO TO 4444 - ! print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep - DO l = 2, nlay - 1 - DO ig = 1, ngrid - IF (fm(ig,l+1)*ptimestep>masse(ig,l) .AND. fm(ig,l+1)*ptimestep>masse( & - ig,l+1)) THEN - PRINT *, 'WARN!!! FM>M ig=', ig, ' l=', l, ' FM=', & - fm(ig, l+1)*ptimestep, ' M=', masse(ig, l), masse(ig, l+1) - END IF - END DO - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - IF ((alim(ig,l)+entr(ig,l))*ptimestep>masse(ig,l)) THEN - PRINT *, 'WARN!!! E>M ig=', ig, ' l=', l, ' E==', & - (entr(ig,l)+alim(ig,l))*ptimestep, ' M=', masse(ig, l) - END IF - END DO - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - IF (.NOT. fm(ig,l)>=0. .OR. .NOT. fm(ig,l)<=10.) THEN - ! print*,'WARN!!! fm exagere ig=',ig,' l=',l - ! s ,' FM=',fm(ig,l) - END IF - IF (.NOT. masse(ig,l)>=1.E-10 .OR. .NOT. masse(ig,l)<=1.E4) THEN - ! print*,'WARN!!! masse exagere ig=',ig,' l=',l - ! s ,' M=',masse(ig,l) - ! print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', - ! s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) - ! print*,'zlev(ig,l+1),zlev(ig,l)' - ! s ,zlev(ig,l+1),zlev(ig,l) - ! print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' - ! s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) - END IF - IF (.NOT. alim(ig,l)>=0. .OR. .NOT. alim(ig,l)<=10.) THEN - ! print*,'WARN!!! entr exagere ig=',ig,' l=',l - ! s ,' E=',entr(ig,l) - END IF - END DO - END DO - -4444 CONTINUE - - ! CR:redefinition du entr - ! CR:test:on ne change pas la def du entr mais la def du fm - DO l = 1, nlay - DO ig = 1, ngrid - IF (test(ig)==1) THEN - detr(ig, l) = fm(ig, l) + alim(ig, l) - fm(ig, l+1) - IF (detr(ig,l)<0.) THEN - ! entr(ig,l)=entr(ig,l)-detr(ig,l) - fm(ig, l+1) = fm(ig, l) + alim(ig, l) - detr(ig, l) = 0. - ! write(11,*)'l,ig,entr',l,ig,entr(ig,l) - ! print*,'WARNING !!! detrainement negatif ',ig,l - END IF - END IF - END DO - END DO - ! RC - - IF (w2di==1) THEN - fm0 = fm0 + ptimestep*(fm-fm0)/tho - entr0 = entr0 + ptimestep*(alim+entr-entr0)/tho - ELSE - fm0 = fm - entr0 = alim + entr - detr0 = detr - alim0 = alim - ! zoa=zqta - ! entr0=alim - END IF - - IF (1==1) THEN - ! call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse - ! . ,zh,zdhadj,zha) - ! call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse - ! . ,zo,pdoadj,zoa) - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zthl, & - zdthladj, zta) - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, po, pdoadj, & - zoa) - ELSE - CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, & - zdhadj, zha) - CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, & - pdoadj, zoa) - END IF - - IF (1==0) THEN - CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, & - zu, zv, pduadj, pdvadj, zua, zva) - ELSE - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, & - zua) - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, & - zva) - END IF - - ! Calcul des moments - ! do l=1,nlay - ! do ig=1,ngrid - ! zf=0.5*(fracc(ig,l)+fracc(ig,l+1)) - ! zf2=zf/(1.-zf) - ! thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2 - ! wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 - ! enddo - ! enddo - - - - - - - ! print*,'13 OK convect8' - ! print*,'WA5 ',wa_moy - DO l = 1, nlay - DO ig = 1, ngrid - ! pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l) - pdtadj(ig, l) = zdthladj(ig, l)*zpspsk(ig, l) - END DO - END DO - - - ! do l=1,nlay - ! do ig=1,ngrid - ! if(abs(pdtadj(ig,l))*86400..gt.500.) then - ! print*,'WARN!!! ig=',ig,' l=',l - ! s ,' pdtadj=',pdtadj(ig,l) - ! endif - ! if(abs(pdoadj(ig,l))*86400..gt.1.) then - ! print*,'WARN!!! ig=',ig,' l=',l - ! s ,' pdoadj=',pdoadj(ig,l) - ! endif - ! enddo - ! enddo - - ! print*,'14 OK convect8' - ! ------------------------------------------------------------------ - ! Calculs pour les sorties - ! ------------------------------------------------------------------ - ! calcul de fraca pour les sorties - DO l = 2, klev - DO ig = 1, klon - IF (zw2(ig,l)>1.E-10) THEN - fraca(ig, l) = fm(ig, l)/(rhobarz(ig,l)*zw2(ig,l)) - ELSE - fraca(ig, l) = 0. - END IF - END DO - END DO - IF (sorties) THEN - DO l = 1, nlay - DO ig = 1, ngrid - zla(ig, l) = (1.-fracd(ig,l))*zmax(ig) - zld(ig, l) = fracd(ig, l)*zmax(ig) - IF (1.-fracd(ig,l)>1.E-10) zwa(ig, l) = wd(ig, l)*fracd(ig, l)/ & - (1.-fracd(ig,l)) - END DO - END DO - ! CR calcul du niveau de condensation - ! initialisation - DO ig = 1, ngrid - nivcon(ig) = 0. - zcon(ig) = 0. - END DO - DO k = nlay, 1, -1 - DO ig = 1, ngrid - IF (zqla(ig,k)>1E-10) THEN - nivcon(ig) = k - zcon(ig) = zlev(ig, k) - END IF - ! if (zcon(ig).gt.1.e-10) then - ! nuage=.true. - ! else - ! nuage=.false. - ! endif - END DO - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - zf = fraca(ig, l) - zf2 = zf/(1.-zf) - thetath2(ig, l) = zf2*(zha(ig,l)-zh(ig,l)/zpspsk(ig,l))**2 - wth2(ig, l) = zf2*(zw2(ig,l))**2 - ! print*,'wth2=',wth2(ig,l) - wth3(ig, l) = zf2*(1-2.*fraca(ig,l))/(1-fraca(ig,l))*zw2(ig, l)* & - zw2(ig, l)*zw2(ig, l) - q2(ig, l) = zf2*(zqta(ig,l)*1000.-po(ig,l)*1000.)**2 - ! test: on calcul q2/po=ratqsc - ! if (nuage) then - ratqscth(ig, l) = sqrt(q2(ig,l))/(po(ig,l)*1000.) - ! else - ! ratqscth(ig,l)=0. - ! endif - END DO - END DO - ! calcul du ratqscdiff - sum = 0. - sumdiff = 0. - ratqsdiff(:, :) = 0. - DO ig = 1, ngrid - DO l = 1, lentr(ig) - sum = sum + alim_star(ig, l)*zqta(ig, l)*1000. - END DO - END DO - DO ig = 1, ngrid - DO l = 1, lentr(ig) - zf = fraca(ig, l) - zf2 = zf/(1.-zf) - sumdiff = sumdiff + alim_star(ig, l)*(zqta(ig,l)*1000.-sum)**2 - ! ratqsdiff=ratqsdiff+alim_star(ig,l)* - ! s (zqta(ig,l)*1000.-po(ig,l)*1000.)**2 - END DO - END DO - DO l = 1, klev - DO ig = 1, ngrid - ratqsdiff(ig, l) = sqrt(sumdiff)/(po(ig,l)*1000.) - ! write(11,*)'ratqsdiff=',ratqsdiff(ig,l) - END DO - END DO - - END IF - - ! print*,'19 OK convect8' - RETURN -END SUBROUTINE thermcell_cld - -SUBROUTINE thermcell_eau(ngrid, nlay, ptimestep, pplay, pplev, pphi, pu, pv, & - pt, po, pduadj, pdvadj, pdtadj, pdoadj, fm0, entr0 & ! s - ! ,pu_therm,pv_therm - , r_aspect, l_mix, w2di, tho) - - USE dimphy - IMPLICIT NONE - - ! ======================================================================= - - ! Calcul du transport verticale dans la couche limite en presence - ! de "thermiques" explicitement representes - - ! Réécriture à partir d'un listing papier à Habas, le 14/02/00 - - ! le thermique est supposé homogène et dissipé par mélange avec - ! son environnement. la longueur l_mix contrôle l'efficacité du - ! mélange - - ! Le calcul du transport des différentes espèces se fait en prenant - ! en compte: - ! 1. un flux de masse montant - ! 2. un flux de masse descendant - ! 3. un entrainement - ! 4. un detrainement - - ! ======================================================================= - - ! ----------------------------------------------------------------------- - ! declarations: - ! ------------- - - include "YOMCST.h" - include "YOETHF.h" - include "FCTTRE.h" - - ! arguments: - ! ---------- - - INTEGER ngrid, nlay, w2di - REAL tho - REAL ptimestep, l_mix, r_aspect - REAL pt(ngrid, nlay), pdtadj(ngrid, nlay) - REAL pu(ngrid, nlay), pduadj(ngrid, nlay) - REAL pv(ngrid, nlay), pdvadj(ngrid, nlay) - REAL po(ngrid, nlay), pdoadj(ngrid, nlay) - REAL pplay(ngrid, nlay), pplev(ngrid, nlay+1) - REAL pphi(ngrid, nlay) - - INTEGER idetr - SAVE idetr - DATA idetr/3/ - !$OMP THREADPRIVATE(idetr) - - ! local: - ! ------ - - INTEGER ig, k, l, lmaxa(klon), lmix(klon) - REAL zsortie1d(klon) - ! CR: on remplace lmax(klon,klev+1) - INTEGER lmax(klon), lmin(klon), lentr(klon) - REAL linter(klon) - REAL zmix(klon), fracazmix(klon) - ! RC - REAL zmax(klon), zw, zz, zw2(klon, klev+1), ztva(klon, klev), zzz - - REAL zlev(klon, klev+1), zlay(klon, klev) - REAL zh(klon, klev), zdhadj(klon, klev) - REAL zthl(klon, klev), zdthladj(klon, klev) - REAL ztv(klon, klev) - REAL zu(klon, klev), zv(klon, klev), zo(klon, klev) - REAL zl(klon, klev) - REAL wh(klon, klev+1) - REAL wu(klon, klev+1), wv(klon, klev+1), wo(klon, klev+1) - REAL zla(klon, klev+1) - REAL zwa(klon, klev+1) - REAL zld(klon, klev+1) - REAL zwd(klon, klev+1) - REAL zsortie(klon, klev) - REAL zva(klon, klev) - REAL zua(klon, klev) - REAL zoa(klon, klev) - - REAL zta(klon, klev) - REAL zha(klon, klev) - REAL wa_moy(klon, klev+1) - REAL fraca(klon, klev+1) - REAL fracc(klon, klev+1) - REAL zf, zf2 - REAL thetath2(klon, klev), wth2(klon, klev) - ! common/comtherm/thetath2,wth2 - - REAL count_time - INTEGER ialt - - LOGICAL sorties - REAL rho(klon, klev), rhobarz(klon, klev+1), masse(klon, klev) - REAL zpspsk(klon, klev) - - ! real wmax(klon,klev),wmaxa(klon) - REAL wmax(klon), wmaxa(klon) - REAL wa(klon, klev, klev+1) - REAL wd(klon, klev+1) - REAL larg_part(klon, klev, klev+1) - REAL fracd(klon, klev+1) - REAL xxx(klon, klev+1) - REAL larg_cons(klon, klev+1) - REAL larg_detr(klon, klev+1) - REAL fm0(klon, klev+1), entr0(klon, klev), detr(klon, klev) - REAL pu_therm(klon, klev), pv_therm(klon, klev) - REAL fm(klon, klev+1), entr(klon, klev) - REAL fmc(klon, klev+1) - - REAL zcor, zdelta, zcvm5, qlbef - REAL tbef(klon), qsatbef(klon) - REAL dqsat_dt, dt, num, denom - REAL reps, rlvcp, ddt0 - REAL ztla(klon, klev), zqla(klon, klev), zqta(klon, klev) - - PARAMETER (ddt0=.01) - - ! CR:nouvelles variables - REAL f_star(klon, klev+1), entr_star(klon, klev) - REAL entr_star_tot(klon), entr_star2(klon) - REAL f(klon), f0(klon) - REAL zlevinter(klon) - LOGICAL first - DATA first/.FALSE./ - SAVE first - !$OMP THREADPRIVATE(first) - - ! RC - - CHARACTER *2 str2 - CHARACTER *10 str10 - - CHARACTER (LEN=20) :: modname = 'thermcell_eau' - CHARACTER (LEN=80) :: abort_message - - LOGICAL vtest(klon), down - LOGICAL zsat(klon) - - EXTERNAL scopy - - INTEGER ncorrec, ll - SAVE ncorrec - DATA ncorrec/0/ - !$OMP THREADPRIVATE(ncorrec) - - - - ! ----------------------------------------------------------------------- - ! initialisation: - ! --------------- - - sorties = .TRUE. - IF (ngrid/=klon) THEN - PRINT * - PRINT *, 'STOP dans convadj' - PRINT *, 'ngrid =', ngrid - PRINT *, 'klon =', klon - END IF - - ! Initialisation - rlvcp = rlvtt/rcpd - reps = rd/rv - - ! ----------------------------------------------------------------------- - ! AM Calcul de T,q,ql a partir de Tl et qT - ! --------------------------------------------------- - - ! Pr Tprec=Tl calcul de qsat - ! Si qsat>qT T=Tl, q=qT - ! Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt) - ! On cherche DDT < DDT0 - - ! defaut - DO ll = 1, nlay - DO ig = 1, ngrid - zo(ig, ll) = po(ig, ll) - zl(ig, ll) = 0. - zh(ig, ll) = pt(ig, ll) - END DO - END DO - DO ig = 1, ngrid - zsat(ig) = .FALSE. - END DO - - - DO ll = 1, nlay - ! les points insatures sont definitifs - DO ig = 1, ngrid - tbef(ig) = pt(ig, ll) - zdelta = max(0., sign(1.,rtt-tbef(ig))) - qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, ll) - qsatbef(ig) = min(0.5, qsatbef(ig)) - zcor = 1./(1.-retv*qsatbef(ig)) - qsatbef(ig) = qsatbef(ig)*zcor - zsat(ig) = (max(0.,po(ig,ll)-qsatbef(ig))>0.00001) - END DO - - DO ig = 1, ngrid - IF (zsat(ig)) THEN - qlbef = max(0., po(ig,ll)-qsatbef(ig)) - ! si sature: ql est surestime, d'ou la sous-relax - dt = 0.5*rlvcp*qlbef - ! on pourra enchainer 2 ou 3 calculs sans Do while - DO WHILE (dt>ddt0) - ! il faut verifier si c,a conserve quand on repasse en insature ... - tbef(ig) = tbef(ig) + dt - zdelta = max(0., sign(1.,rtt-tbef(ig))) - qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, ll) - qsatbef(ig) = min(0.5, qsatbef(ig)) - zcor = 1./(1.-retv*qsatbef(ig)) - qsatbef(ig) = qsatbef(ig)*zcor - ! on veut le signe de qlbef - qlbef = po(ig, ll) - qsatbef(ig) - ! dqsat_dT - zdelta = max(0., sign(1.,rtt-tbef(ig))) - zcvm5 = r5les*(1.-zdelta) + r5ies*zdelta - zcor = 1./(1.-retv*qsatbef(ig)) - dqsat_dt = foede(tbef(ig), zdelta, zcvm5, qsatbef(ig), zcor) - num = -tbef(ig) + pt(ig, ll) + rlvcp*qlbef - denom = 1. + rlvcp*dqsat_dt - dt = num/denom - END DO - ! on ecrit de maniere conservative (sat ou non) - zl(ig, ll) = max(0., qlbef) - ! T = Tl +Lv/Cp ql - zh(ig, ll) = pt(ig, ll) + rlvcp*zl(ig, ll) - zo(ig, ll) = po(ig, ll) - zl(ig, ll) - END IF - END DO - END DO - ! AM fin - - ! ----------------------------------------------------------------------- - ! incrementation eventuelle de tendances precedentes: - ! --------------------------------------------------- - - ! print*,'0 OK convect8' - - DO l = 1, nlay - DO ig = 1, ngrid - zpspsk(ig, l) = (pplay(ig,l)/pplev(ig,1))**rkappa - ! zh(ig,l)=pt(ig,l)/zpspsk(ig,l) - zu(ig, l) = pu(ig, l) - zv(ig, l) = pv(ig, l) - ! zo(ig,l)=po(ig,l) - ! ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l)) - ! AM attention zh est maintenant le profil de T et plus le profil de - ! theta ! - - ! T-> Theta - ztv(ig, l) = zh(ig, l)/zpspsk(ig, l) - ! AM Theta_v - ztv(ig, l) = ztv(ig, l)*(1.+retv*(zo(ig,l))-zl(ig,l)) - ! AM Thetal - zthl(ig, l) = pt(ig, l)/zpspsk(ig, l) - - END DO - END DO - - ! print*,'1 OK convect8' - ! -------------------- - - - ! + + + + + + + + + + + - - - ! wa, fraca, wd, fracd -------------------- zlev(2), rhobarz - ! wh,wt,wo ... - - ! + + + + + + + + + + + zh,zu,zv,zo,rho - - - ! -------------------- zlev(1) - ! \\\\\\\\\\\\\\\\\\\\ - - - - ! ----------------------------------------------------------------------- - ! Calcul des altitudes des couches - ! ----------------------------------------------------------------------- - - DO l = 2, nlay - DO ig = 1, ngrid - zlev(ig, l) = 0.5*(pphi(ig,l)+pphi(ig,l-1))/rg - END DO - END DO - DO ig = 1, ngrid - zlev(ig, 1) = 0. - zlev(ig, nlay+1) = (2.*pphi(ig,klev)-pphi(ig,klev-1))/rg - END DO - DO l = 1, nlay - DO ig = 1, ngrid - zlay(ig, l) = pphi(ig, l)/rg - END DO - END DO - - ! print*,'2 OK convect8' - ! ----------------------------------------------------------------------- - ! Calcul des densites - ! ----------------------------------------------------------------------- - - DO l = 1, nlay - DO ig = 1, ngrid - ! rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l)) - rho(ig, l) = pplay(ig, l)/(zpspsk(ig,l)*rd*ztv(ig,l)) - END DO - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - rhobarz(ig, l) = 0.5*(rho(ig,l)+rho(ig,l-1)) - END DO - END DO - - DO k = 1, nlay - DO l = 1, nlay + 1 - DO ig = 1, ngrid - wa(ig, k, l) = 0. - END DO - END DO - END DO - - ! print*,'3 OK convect8' - ! ------------------------------------------------------------------ - ! Calcul de w2, quarre de w a partir de la cape - ! a partir de w2, on calcule wa, vitesse de l'ascendance - - ! ATTENTION: Dans cette version, pour cause d'economie de memoire, - ! w2 est stoke dans wa - - ! ATTENTION: dans convect8, on n'utilise le calcule des wa - ! independants par couches que pour calculer l'entrainement - ! a la base et la hauteur max de l'ascendance. - - ! Indicages: - ! l'ascendance provenant du niveau k traverse l'interface l avec - ! une vitesse wa(k,l). - - ! -------------------- - - ! + + + + + + + + + + - - ! wa(k,l) ---- -------------------- l - ! /\ - ! /||\ + + + + + + + + + + - ! || - ! || -------------------- - ! || - ! || + + + + + + + + + + - ! || - ! || -------------------- - ! ||__ - ! |___ + + + + + + + + + + k - - ! -------------------- - - - - ! ------------------------------------------------------------------ - - ! CR: ponderation entrainement des couches instables - ! def des entr_star tels que entr=f*entr_star - DO l = 1, klev - DO ig = 1, ngrid - entr_star(ig, l) = 0. - END DO - END DO - ! determination de la longueur de la couche d entrainement - DO ig = 1, ngrid - lentr(ig) = 1 - END DO - - ! on ne considere que les premieres couches instables - DO k = nlay - 1, 1, -1 - DO ig = 1, ngrid - IF (ztv(ig,k)>ztv(ig,k+1) .AND. ztv(ig,k+1)ztv(ig,l)) THEN - lmin(ig) = l - 1 - END IF - END DO - END DO - - ! definition de l'entrainement des couches - DO l = 1, klev - 1 - DO ig = 1, ngrid - IF (ztv(ig,l)>ztv(ig,l+1) .AND. l>=lmin(ig) .AND. l<=lentr(ig)) THEN - entr_star(ig, l) = (ztv(ig,l)-ztv(ig,l+1))*(zlev(ig,l+1)-zlev(ig,l)) - END IF - END DO - END DO - ! pas de thermique si couche 1 stable - DO ig = 1, ngrid - IF (lmin(ig)>1) THEN - DO l = 1, klev - entr_star(ig, l) = 0. - END DO - END IF - END DO - ! calcul de l entrainement total - DO ig = 1, ngrid - entr_star_tot(ig) = 0. - END DO - DO ig = 1, ngrid - DO k = 1, klev - entr_star_tot(ig) = entr_star_tot(ig) + entr_star(ig, k) - END DO - END DO - - DO k = 1, klev - DO ig = 1, ngrid - ztva(ig, k) = ztv(ig, k) - END DO - END DO - ! RC - ! AM:initialisations - DO k = 1, nlay - DO ig = 1, ngrid - ztva(ig, k) = ztv(ig, k) - ztla(ig, k) = zthl(ig, k) - zqla(ig, k) = 0. - zqta(ig, k) = po(ig, k) - zsat(ig) = .FALSE. - END DO - END DO - - ! print*,'7 OK convect8' - DO k = 1, klev + 1 - DO ig = 1, ngrid - zw2(ig, k) = 0. - fmc(ig, k) = 0. - ! CR - f_star(ig, k) = 0. - ! RC - larg_cons(ig, k) = 0. - larg_detr(ig, k) = 0. - wa_moy(ig, k) = 0. - END DO - END DO - - ! print*,'8 OK convect8' - DO ig = 1, ngrid - linter(ig) = 1. - lmaxa(ig) = 1 - lmix(ig) = 1 - wmaxa(ig) = 0. - END DO - - ! CR: - DO l = 1, nlay - 2 - DO ig = 1, ngrid - IF (ztv(ig,l)>ztv(ig,l+1) .AND. entr_star(ig,l)>1.E-10 .AND. & - zw2(ig,l)<1E-10) THEN - ! AM - ztla(ig, l) = zthl(ig, l) - zqta(ig, l) = po(ig, l) - zqla(ig, l) = zl(ig, l) - ! AM - f_star(ig, l+1) = entr_star(ig, l) - ! test:calcul de dteta - zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* & - (zlev(ig,l+1)-zlev(ig,l))*0.4*pphi(ig, l)/(pphi(ig,l+1)-pphi(ig,l)) - larg_detr(ig, l) = 0. - ELSE IF ((zw2(ig,l)>=1E-10) .AND. (f_star(ig,l)+entr_star(ig, & - l)>1.E-10)) THEN - f_star(ig, l+1) = f_star(ig, l) + entr_star(ig, l) - - ! AM on melange Tl et qt du thermique - ztla(ig, l) = (f_star(ig,l)*ztla(ig,l-1)+entr_star(ig,l)*zthl(ig,l))/ & - f_star(ig, l+1) - zqta(ig, l) = (f_star(ig,l)*zqta(ig,l-1)+entr_star(ig,l)*po(ig,l))/ & - f_star(ig, l+1) - - ! ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l) - ! s *ztv(ig,l))/f_star(ig,l+1) - - ! AM on en deduit thetav et ql du thermique - tbef(ig) = ztla(ig, l)*zpspsk(ig, l) - zdelta = max(0., sign(1.,rtt-tbef(ig))) - qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, l) - qsatbef(ig) = min(0.5, qsatbef(ig)) - zcor = 1./(1.-retv*qsatbef(ig)) - qsatbef(ig) = qsatbef(ig)*zcor - zsat(ig) = (max(0.,zqta(ig,l)-qsatbef(ig))>0.00001) - END IF - END DO - DO ig = 1, ngrid - IF (zsat(ig)) THEN - qlbef = max(0., zqta(ig,l)-qsatbef(ig)) - dt = 0.5*rlvcp*qlbef - DO WHILE (dt>ddt0) - tbef(ig) = tbef(ig) + dt - zdelta = max(0., sign(1.,rtt-tbef(ig))) - qsatbef(ig) = r2es*foeew(tbef(ig), zdelta)/pplev(ig, l) - qsatbef(ig) = min(0.5, qsatbef(ig)) - zcor = 1./(1.-retv*qsatbef(ig)) - qsatbef(ig) = qsatbef(ig)*zcor - qlbef = zqta(ig, l) - qsatbef(ig) - - zdelta = max(0., sign(1.,rtt-tbef(ig))) - zcvm5 = r5les*(1.-zdelta) + r5ies*zdelta - zcor = 1./(1.-retv*qsatbef(ig)) - dqsat_dt = foede(tbef(ig), zdelta, zcvm5, qsatbef(ig), zcor) - num = -tbef(ig) + ztla(ig, l)*zpspsk(ig, l) + rlvcp*qlbef - denom = 1. + rlvcp*dqsat_dt - dt = num/denom - END DO - zqla(ig, l) = max(0., zqta(ig,l)-qsatbef(ig)) - END IF - ! on ecrit de maniere conservative (sat ou non) - ! T = Tl +Lv/Cp ql - ztva(ig, l) = ztla(ig, l)*zpspsk(ig, l) + rlvcp*zqla(ig, l) - ztva(ig, l) = ztva(ig, l)/zpspsk(ig, l) - ztva(ig, l) = ztva(ig, l)*(1.+retv*(zqta(ig,l)-zqla(ig,l))-zqla(ig,l)) - - END DO - DO ig = 1, ngrid - IF (zw2(ig,l)>=1.E-10 .AND. f_star(ig,l)+entr_star(ig,l)>1.E-10) THEN - ! mise a jour de la vitesse ascendante (l'air entraine de la couche - ! consideree commence avec une vitesse nulle). - - zw2(ig, l+1) = zw2(ig, l)*(f_star(ig,l)/f_star(ig,l+1))**2 + & - 2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, l)*(zlev(ig,l+1)-zlev(ig,l)) - END IF - ! determination de zmax continu par interpolation lineaire - IF (zw2(ig,l+1)<0.) THEN - linter(ig) = (l*(zw2(ig,l+1)-zw2(ig,l))-zw2(ig,l))/(zw2(ig,l+1)-zw2( & - ig,l)) - zw2(ig, l+1) = 0. - lmaxa(ig) = l - ELSE - wa_moy(ig, l+1) = sqrt(zw2(ig,l+1)) - END IF - IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN - ! lmix est le niveau de la couche ou w (wa_moy) est maximum - lmix(ig) = l + 1 - wmaxa(ig) = wa_moy(ig, l+1) - END IF - END DO - END DO - - ! Calcul de la couche correspondant a la hauteur du thermique - DO ig = 1, ngrid - lmax(ig) = lentr(ig) - END DO - DO ig = 1, ngrid - DO l = nlay, lentr(ig) + 1, -1 - IF (zw2(ig,l)<=1.E-10) THEN - lmax(ig) = l - 1 - END IF - END DO - END DO - ! pas de thermique si couche 1 stable - DO ig = 1, ngrid - IF (lmin(ig)>1) THEN - lmax(ig) = 1 - lmin(ig) = 1 - END IF - END DO - - ! Determination de zw2 max - DO ig = 1, ngrid - wmax(ig) = 0. - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - IF (l<=lmax(ig)) THEN - zw2(ig, l) = sqrt(zw2(ig,l)) - wmax(ig) = max(wmax(ig), zw2(ig,l)) - ELSE - zw2(ig, l) = 0. - END IF - END DO - END DO - - ! Longueur caracteristique correspondant a la hauteur des thermiques. - DO ig = 1, ngrid - zmax(ig) = 500. - zlevinter(ig) = zlev(ig, 1) - END DO - DO ig = 1, ngrid - ! calcul de zlevinter - zlevinter(ig) = (zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*linter(ig) + & - zlev(ig, lmax(ig)) - lmax(ig)*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig))) - zmax(ig) = max(zmax(ig), zlevinter(ig)-zlev(ig,lmin(ig))) - END DO - - ! Fermeture,determination de f - DO ig = 1, ngrid - entr_star2(ig) = 0. - END DO - DO ig = 1, ngrid - IF (entr_star_tot(ig)<1.E-10) THEN - f(ig) = 0. - ELSE - DO k = lmin(ig), lentr(ig) - entr_star2(ig) = entr_star2(ig) + entr_star(ig, k)**2/(rho(ig,k)*( & - zlev(ig,k+1)-zlev(ig,k))) - END DO - ! Nouvelle fermeture - f(ig) = wmax(ig)/(zmax(ig)*r_aspect*entr_star2(ig))*entr_star_tot(ig) - ! test - IF (first) THEN - f(ig) = f(ig) + (f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)*wmax(ig)) - END IF - END IF - f0(ig) = f(ig) - first = .TRUE. - END DO - - ! Calcul de l'entrainement - DO k = 1, klev - DO ig = 1, ngrid - entr(ig, k) = f(ig)*entr_star(ig, k) - END DO - END DO - ! Calcul des flux - DO ig = 1, ngrid - DO l = 1, lmax(ig) - 1 - fmc(ig, l+1) = fmc(ig, l) + entr(ig, l) - END DO - END DO - - ! RC - - - ! print*,'9 OK convect8' - ! print*,'WA1 ',wa_moy - - ! determination de l'indice du debut de la mixed layer ou w decroit - - ! calcul de la largeur de chaque ascendance dans le cas conservatif. - ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant - ! d'une couche est égale à la hauteur de la couche alimentante. - ! La vitesse maximale dans l'ascendance est aussi prise comme estimation - ! de la vitesse d'entrainement horizontal dans la couche alimentante. - - DO l = 2, nlay - DO ig = 1, ngrid - IF (l<=lmaxa(ig)) THEN - zw = max(wa_moy(ig,l), 1.E-10) - larg_cons(ig, l) = zmax(ig)*r_aspect*fmc(ig, l)/(rhobarz(ig,l)*zw) - END IF - END DO - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - IF (l<=lmaxa(ig)) THEN - ! if (idetr.eq.0) then - ! cette option est finalement en dur. - larg_detr(ig, l) = sqrt(l_mix*zlev(ig,l)) - ! else if (idetr.eq.1) then - ! larg_detr(ig,l)=larg_cons(ig,l) - ! s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) - ! else if (idetr.eq.2) then - ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) - ! s *sqrt(wa_moy(ig,l)) - ! else if (idetr.eq.4) then - ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) - ! s *wa_moy(ig,l) - ! endif - END IF - END DO - END DO - - ! print*,'10 OK convect8' - ! print*,'WA2 ',wa_moy - ! calcul de la fraction de la maille concernée par l'ascendance en tenant - ! compte de l'epluchage du thermique. - - ! CR def de zmix continu (profil parabolique des vitesses) - DO ig = 1, ngrid - IF (lmix(ig)>1.) THEN - zmix(ig) = ((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig))) & - **2-(zlev(ig,lmix(ig)+1))**2)-(zw2(ig,lmix(ig))-zw2(ig, & - lmix(ig)+1))*((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))/ & - (2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- & - (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))*((zlev( & - ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) - ELSE - zmix(ig) = 0. - END IF - END DO - - ! calcul du nouveau lmix correspondant - DO ig = 1, ngrid - DO l = 1, klev - IF (zmix(ig)>=zlev(ig,l) .AND. zmix(ig)1.) THEN - ! print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' - fraca(ig, l) = (larg_cons(ig,l)-larg_detr(ig,l))/(r_aspect*zmax(ig)) - ! test - fraca(ig, l) = max(fraca(ig,l), 0.) - fraca(ig, l) = min(fraca(ig,l), 0.5) - fracd(ig, l) = 1. - fraca(ig, l) - fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) - ELSE - ! wa_moy(ig,l)=0. - fraca(ig, l) = 0. - fracc(ig, l) = 0. - fracd(ig, l) = 1. - END IF - END DO - END DO - ! CR: calcul de fracazmix - DO ig = 1, ngrid - fracazmix(ig) = (fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ & - (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + & - fraca(ig, lmix(ig)) - zlev(ig, lmix(ig))*(fraca(ig,lmix(ig)+1)-fraca(ig & - ,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig))) - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - IF (larg_cons(ig,l)>1.) THEN - IF (l>lmix(ig)) THEN - xxx(ig, l) = (zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig)) - IF (idetr==0) THEN - fraca(ig, l) = fracazmix(ig) - ELSE IF (idetr==1) THEN - fraca(ig, l) = fracazmix(ig)*xxx(ig, l) - ELSE IF (idetr==2) THEN - fraca(ig, l) = fracazmix(ig)*(1.-(1.-xxx(ig,l))**2) - ELSE - fraca(ig, l) = fracazmix(ig)*xxx(ig, l)**2 - END IF - ! print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' - fraca(ig, l) = max(fraca(ig,l), 0.) - fraca(ig, l) = min(fraca(ig,l), 0.5) - fracd(ig, l) = 1. - fraca(ig, l) - fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) - END IF - END IF - END DO - END DO - - ! print*,'11 OK convect8' - ! print*,'Ea3 ',wa_moy - ! ------------------------------------------------------------------ - ! Calcul de fracd, wd - ! somme wa - wd = 0 - ! ------------------------------------------------------------------ - - - DO ig = 1, ngrid - fm(ig, 1) = 0. - fm(ig, nlay+1) = 0. - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - fm(ig, l) = fraca(ig, l)*wa_moy(ig, l)*rhobarz(ig, l) - ! CR:test - IF (entr(ig,l-1)<1E-10 .AND. fm(ig,l)>fm(ig,l-1) .AND. l>lmix(ig)) THEN - fm(ig, l) = fm(ig, l-1) - ! write(1,*)'ajustement fm, l',l - END IF - ! write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) - ! RC - END DO - DO ig = 1, ngrid - IF (fracd(ig,l)<0.1) THEN - abort_message = 'fracd trop petit' - CALL abort_physic(modname, abort_message, 1) - ELSE - ! vitesse descendante "diagnostique" - wd(ig, l) = fm(ig, l)/(fracd(ig,l)*rhobarz(ig,l)) - END IF - END DO - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) - masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg - END DO - END DO - - ! print*,'12 OK convect8' - ! print*,'WA4 ',wa_moy - ! c------------------------------------------------------------------ - ! calcul du transport vertical - ! ------------------------------------------------------------------ - - GO TO 4444 - ! print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep - DO l = 2, nlay - 1 - DO ig = 1, ngrid - IF (fm(ig,l+1)*ptimestep>masse(ig,l) .AND. fm(ig,l+1)*ptimestep>masse( & - ig,l+1)) THEN - ! print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' - ! s ,fm(ig,l+1)*ptimestep - ! s ,' M=',masse(ig,l),masse(ig,l+1) - END IF - END DO - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - IF (entr(ig,l)*ptimestep>masse(ig,l)) THEN - ! print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' - ! s ,entr(ig,l)*ptimestep - ! s ,' M=',masse(ig,l) - END IF - END DO - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - IF (.NOT. fm(ig,l)>=0. .OR. .NOT. fm(ig,l)<=10.) THEN - ! print*,'WARN!!! fm exagere ig=',ig,' l=',l - ! s ,' FM=',fm(ig,l) - END IF - IF (.NOT. masse(ig,l)>=1.E-10 .OR. .NOT. masse(ig,l)<=1.E4) THEN - ! print*,'WARN!!! masse exagere ig=',ig,' l=',l - ! s ,' M=',masse(ig,l) - ! print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', - ! s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) - ! print*,'zlev(ig,l+1),zlev(ig,l)' - ! s ,zlev(ig,l+1),zlev(ig,l) - ! print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' - ! s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) - END IF - IF (.NOT. entr(ig,l)>=0. .OR. .NOT. entr(ig,l)<=10.) THEN - ! print*,'WARN!!! entr exagere ig=',ig,' l=',l - ! s ,' E=',entr(ig,l) - END IF - END DO - END DO - -4444 CONTINUE - - IF (w2di==1) THEN - fm0 = fm0 + ptimestep*(fm-fm0)/tho - entr0 = entr0 + ptimestep*(entr-entr0)/tho - ELSE - fm0 = fm - entr0 = entr - END IF - - IF (1==1) THEN - ! call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse - ! . ,zh,zdhadj,zha) - ! call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse - ! . ,zo,pdoadj,zoa) - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zthl, & - zdthladj, zta) - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, po, pdoadj, & - zoa) - ELSE - CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, & - zdhadj, zha) - CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, & - pdoadj, zoa) - END IF - - IF (1==0) THEN - CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, & - zu, zv, pduadj, pdvadj, zua, zva) - ELSE - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, & - zua) - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, & - zva) - END IF - - DO l = 1, nlay - DO ig = 1, ngrid - zf = 0.5*(fracc(ig,l)+fracc(ig,l+1)) - zf2 = zf/(1.-zf) - thetath2(ig, l) = zf2*(zha(ig,l)-zh(ig,l))**2 - wth2(ig, l) = zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 - END DO - END DO - - - - ! print*,'13 OK convect8' - ! print*,'WA5 ',wa_moy - DO l = 1, nlay - DO ig = 1, ngrid - ! pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l) - pdtadj(ig, l) = zdthladj(ig, l)*zpspsk(ig, l) - END DO - END DO - - - ! do l=1,nlay - ! do ig=1,ngrid - ! if(abs(pdtadj(ig,l))*86400..gt.500.) then - ! print*,'WARN!!! ig=',ig,' l=',l - ! s ,' pdtadj=',pdtadj(ig,l) - ! endif - ! if(abs(pdoadj(ig,l))*86400..gt.1.) then - ! print*,'WARN!!! ig=',ig,' l=',l - ! s ,' pdoadj=',pdoadj(ig,l) - ! endif - ! enddo - ! enddo - - ! print*,'14 OK convect8' - ! ------------------------------------------------------------------ - ! Calculs pour les sorties - ! ------------------------------------------------------------------ - - RETURN -END SUBROUTINE thermcell_eau - -SUBROUTINE thermcell(ngrid, nlay, ptimestep, pplay, pplev, pphi, pu, pv, pt, & - po, pduadj, pdvadj, pdtadj, pdoadj, fm0, entr0 & ! s - ! ,pu_therm,pv_therm - , r_aspect, l_mix, w2di, tho) - - USE dimphy - IMPLICIT NONE - - ! ======================================================================= - - ! Calcul du transport verticale dans la couche limite en presence - ! de "thermiques" explicitement representes - - ! Réécriture à partir d'un listing papier à Habas, le 14/02/00 - - ! le thermique est supposé homogène et dissipé par mélange avec - ! son environnement. la longueur l_mix contrôle l'efficacité du - ! mélange - - ! Le calcul du transport des différentes espèces se fait en prenant - ! en compte: - ! 1. un flux de masse montant - ! 2. un flux de masse descendant - ! 3. un entrainement - ! 4. un detrainement - - ! ======================================================================= - - ! ----------------------------------------------------------------------- - ! declarations: - ! ------------- - - include "YOMCST.h" - - ! arguments: - ! ---------- - - INTEGER ngrid, nlay, w2di - REAL tho - REAL ptimestep, l_mix, r_aspect - REAL pt(ngrid, nlay), pdtadj(ngrid, nlay) - REAL pu(ngrid, nlay), pduadj(ngrid, nlay) - REAL pv(ngrid, nlay), pdvadj(ngrid, nlay) - REAL po(ngrid, nlay), pdoadj(ngrid, nlay) - REAL pplay(ngrid, nlay), pplev(ngrid, nlay+1) - REAL pphi(ngrid, nlay) - - INTEGER idetr - SAVE idetr - DATA idetr/3/ - !$OMP THREADPRIVATE(idetr) - - ! local: - ! ------ - - INTEGER ig, k, l, lmaxa(klon), lmix(klon) - REAL zsortie1d(klon) - ! CR: on remplace lmax(klon,klev+1) - INTEGER lmax(klon), lmin(klon), lentr(klon) - REAL linter(klon) - REAL zmix(klon), fracazmix(klon) - ! RC - REAL zmax(klon), zw, zz, zw2(klon, klev+1), ztva(klon, klev), zzz - - REAL zlev(klon, klev+1), zlay(klon, klev) - REAL zh(klon, klev), zdhadj(klon, klev) - REAL ztv(klon, klev) - REAL zu(klon, klev), zv(klon, klev), zo(klon, klev) - REAL wh(klon, klev+1) - REAL wu(klon, klev+1), wv(klon, klev+1), wo(klon, klev+1) - REAL zla(klon, klev+1) - REAL zwa(klon, klev+1) - REAL zld(klon, klev+1) - REAL zwd(klon, klev+1) - REAL zsortie(klon, klev) - REAL zva(klon, klev) - REAL zua(klon, klev) - REAL zoa(klon, klev) - - REAL zha(klon, klev) - REAL wa_moy(klon, klev+1) - REAL fraca(klon, klev+1) - REAL fracc(klon, klev+1) - REAL zf, zf2 - REAL thetath2(klon, klev), wth2(klon, klev) - ! common/comtherm/thetath2,wth2 - - REAL count_time - INTEGER ialt - - LOGICAL sorties - REAL rho(klon, klev), rhobarz(klon, klev+1), masse(klon, klev) - REAL zpspsk(klon, klev) - - ! real wmax(klon,klev),wmaxa(klon) - REAL wmax(klon), wmaxa(klon) - REAL wa(klon, klev, klev+1) - REAL wd(klon, klev+1) - REAL larg_part(klon, klev, klev+1) - REAL fracd(klon, klev+1) - REAL xxx(klon, klev+1) - REAL larg_cons(klon, klev+1) - REAL larg_detr(klon, klev+1) - REAL fm0(klon, klev+1), entr0(klon, klev), detr(klon, klev) - REAL pu_therm(klon, klev), pv_therm(klon, klev) - REAL fm(klon, klev+1), entr(klon, klev) - REAL fmc(klon, klev+1) - - ! CR:nouvelles variables - REAL f_star(klon, klev+1), entr_star(klon, klev) - REAL entr_star_tot(klon), entr_star2(klon) - REAL f(klon), f0(klon) - REAL zlevinter(klon) - LOGICAL first - DATA first/.FALSE./ - SAVE first - !$OMP THREADPRIVATE(first) - ! RC - - CHARACTER *2 str2 - CHARACTER *10 str10 - - CHARACTER (LEN=20) :: modname = 'thermcell' - CHARACTER (LEN=80) :: abort_message - - LOGICAL vtest(klon), down - - EXTERNAL scopy - - INTEGER ncorrec, ll - SAVE ncorrec - DATA ncorrec/0/ - !$OMP THREADPRIVATE(ncorrec) - - - ! ----------------------------------------------------------------------- - ! initialisation: - ! --------------- - - sorties = .TRUE. - IF (ngrid/=klon) THEN - PRINT * - PRINT *, 'STOP dans convadj' - PRINT *, 'ngrid =', ngrid - PRINT *, 'klon =', klon - END IF - - ! ----------------------------------------------------------------------- - ! incrementation eventuelle de tendances precedentes: - ! --------------------------------------------------- - - ! print*,'0 OK convect8' - - DO l = 1, nlay - DO ig = 1, ngrid - zpspsk(ig, l) = (pplay(ig,l)/pplev(ig,1))**rkappa - zh(ig, l) = pt(ig, l)/zpspsk(ig, l) - zu(ig, l) = pu(ig, l) - zv(ig, l) = pv(ig, l) - zo(ig, l) = po(ig, l) - ztv(ig, l) = zh(ig, l)*(1.+0.61*zo(ig,l)) - END DO - END DO - - ! print*,'1 OK convect8' - ! -------------------- - - - ! + + + + + + + + + + + - - - ! wa, fraca, wd, fracd -------------------- zlev(2), rhobarz - ! wh,wt,wo ... - - ! + + + + + + + + + + + zh,zu,zv,zo,rho - - - ! -------------------- zlev(1) - ! \\\\\\\\\\\\\\\\\\\\ - - - - ! ----------------------------------------------------------------------- - ! Calcul des altitudes des couches - ! ----------------------------------------------------------------------- - - DO l = 2, nlay - DO ig = 1, ngrid - zlev(ig, l) = 0.5*(pphi(ig,l)+pphi(ig,l-1))/rg - END DO - END DO - DO ig = 1, ngrid - zlev(ig, 1) = 0. - zlev(ig, nlay+1) = (2.*pphi(ig,klev)-pphi(ig,klev-1))/rg - END DO - DO l = 1, nlay - DO ig = 1, ngrid - zlay(ig, l) = pphi(ig, l)/rg - END DO - END DO - - ! print*,'2 OK convect8' - ! ----------------------------------------------------------------------- - ! Calcul des densites - ! ----------------------------------------------------------------------- - - DO l = 1, nlay - DO ig = 1, ngrid - rho(ig, l) = pplay(ig, l)/(zpspsk(ig,l)*rd*zh(ig,l)) - END DO - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - rhobarz(ig, l) = 0.5*(rho(ig,l)+rho(ig,l-1)) - END DO - END DO - - DO k = 1, nlay - DO l = 1, nlay + 1 - DO ig = 1, ngrid - wa(ig, k, l) = 0. - END DO - END DO - END DO - - ! print*,'3 OK convect8' - ! ------------------------------------------------------------------ - ! Calcul de w2, quarre de w a partir de la cape - ! a partir de w2, on calcule wa, vitesse de l'ascendance - - ! ATTENTION: Dans cette version, pour cause d'economie de memoire, - ! w2 est stoke dans wa - - ! ATTENTION: dans convect8, on n'utilise le calcule des wa - ! independants par couches que pour calculer l'entrainement - ! a la base et la hauteur max de l'ascendance. - - ! Indicages: - ! l'ascendance provenant du niveau k traverse l'interface l avec - ! une vitesse wa(k,l). - - ! -------------------- - - ! + + + + + + + + + + - - ! wa(k,l) ---- -------------------- l - ! /\ - ! /||\ + + + + + + + + + + - ! || - ! || -------------------- - ! || - ! || + + + + + + + + + + - ! || - ! || -------------------- - ! ||__ - ! |___ + + + + + + + + + + k - - ! -------------------- - - - - ! ------------------------------------------------------------------ - - ! CR: ponderation entrainement des couches instables - ! def des entr_star tels que entr=f*entr_star - DO l = 1, klev - DO ig = 1, ngrid - entr_star(ig, l) = 0. - END DO - END DO - ! determination de la longueur de la couche d entrainement - DO ig = 1, ngrid - lentr(ig) = 1 - END DO - - ! on ne considere que les premieres couches instables - DO k = nlay - 2, 1, -1 - DO ig = 1, ngrid - IF (ztv(ig,k)>ztv(ig,k+1) .AND. ztv(ig,k+1)<=ztv(ig,k+2)) THEN - lentr(ig) = k - END IF - END DO - END DO - - ! determination du lmin: couche d ou provient le thermique - DO ig = 1, ngrid - lmin(ig) = 1 - END DO - DO ig = 1, ngrid - DO l = nlay, 2, -1 - IF (ztv(ig,l-1)>ztv(ig,l)) THEN - lmin(ig) = l - 1 - END IF - END DO - END DO - - ! definition de l'entrainement des couches - DO l = 1, klev - 1 - DO ig = 1, ngrid - IF (ztv(ig,l)>ztv(ig,l+1) .AND. l>=lmin(ig) .AND. l<=lentr(ig)) THEN - entr_star(ig, l) = (ztv(ig,l)-ztv(ig,l+1))*(zlev(ig,l+1)-zlev(ig,l)) - END IF - END DO - END DO - ! pas de thermique si couches 1->5 stables - DO ig = 1, ngrid - IF (lmin(ig)>5) THEN - DO l = 1, klev - entr_star(ig, l) = 0. - END DO - END IF - END DO - ! calcul de l entrainement total - DO ig = 1, ngrid - entr_star_tot(ig) = 0. - END DO - DO ig = 1, ngrid - DO k = 1, klev - entr_star_tot(ig) = entr_star_tot(ig) + entr_star(ig, k) - END DO - END DO - - PRINT *, 'fin calcul entr_star' - DO k = 1, klev - DO ig = 1, ngrid - ztva(ig, k) = ztv(ig, k) - END DO - END DO - ! RC - ! print*,'7 OK convect8' - DO k = 1, klev + 1 - DO ig = 1, ngrid - zw2(ig, k) = 0. - fmc(ig, k) = 0. - ! CR - f_star(ig, k) = 0. - ! RC - larg_cons(ig, k) = 0. - larg_detr(ig, k) = 0. - wa_moy(ig, k) = 0. - END DO - END DO - - ! print*,'8 OK convect8' - DO ig = 1, ngrid - linter(ig) = 1. - lmaxa(ig) = 1 - lmix(ig) = 1 - wmaxa(ig) = 0. - END DO - - ! CR: - DO l = 1, nlay - 2 - DO ig = 1, ngrid - IF (ztv(ig,l)>ztv(ig,l+1) .AND. entr_star(ig,l)>1.E-10 .AND. & - zw2(ig,l)<1E-10) THEN - f_star(ig, l+1) = entr_star(ig, l) - ! test:calcul de dteta - zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* & - (zlev(ig,l+1)-zlev(ig,l))*0.4*pphi(ig, l)/(pphi(ig,l+1)-pphi(ig,l)) - larg_detr(ig, l) = 0. - ELSE IF ((zw2(ig,l)>=1E-10) .AND. (f_star(ig,l)+entr_star(ig, & - l)>1.E-10)) THEN - f_star(ig, l+1) = f_star(ig, l) + entr_star(ig, l) - ztva(ig, l) = (f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)*ztv(ig,l))/ & - f_star(ig, l+1) - zw2(ig, l+1) = zw2(ig, l)*(f_star(ig,l)/f_star(ig,l+1))**2 + & - 2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, l)*(zlev(ig,l+1)-zlev(ig,l)) - END IF - ! determination de zmax continu par interpolation lineaire - IF (zw2(ig,l+1)<0.) THEN - ! test - IF (abs(zw2(ig,l+1)-zw2(ig,l))<1E-10) THEN - PRINT *, 'pb linter' - END IF - linter(ig) = (l*(zw2(ig,l+1)-zw2(ig,l))-zw2(ig,l))/(zw2(ig,l+1)-zw2( & - ig,l)) - zw2(ig, l+1) = 0. - lmaxa(ig) = l - ELSE - IF (zw2(ig,l+1)<0.) THEN - PRINT *, 'pb1 zw2<0' - END IF - wa_moy(ig, l+1) = sqrt(zw2(ig,l+1)) - END IF - IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN - ! lmix est le niveau de la couche ou w (wa_moy) est maximum - lmix(ig) = l + 1 - wmaxa(ig) = wa_moy(ig, l+1) - END IF - END DO - END DO - PRINT *, 'fin calcul zw2' - - ! Calcul de la couche correspondant a la hauteur du thermique - DO ig = 1, ngrid - lmax(ig) = lentr(ig) - END DO - DO ig = 1, ngrid - DO l = nlay, lentr(ig) + 1, -1 - IF (zw2(ig,l)<=1.E-10) THEN - lmax(ig) = l - 1 - END IF - END DO - END DO - ! pas de thermique si couches 1->5 stables - DO ig = 1, ngrid - IF (lmin(ig)>5) THEN - lmax(ig) = 1 - lmin(ig) = 1 - END IF - END DO - - ! Determination de zw2 max - DO ig = 1, ngrid - wmax(ig) = 0. - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - IF (l<=lmax(ig)) THEN - IF (zw2(ig,l)<0.) THEN - PRINT *, 'pb2 zw2<0' - END IF - zw2(ig, l) = sqrt(zw2(ig,l)) - wmax(ig) = max(wmax(ig), zw2(ig,l)) - ELSE - zw2(ig, l) = 0. - END IF - END DO - END DO - - ! Longueur caracteristique correspondant a la hauteur des thermiques. - DO ig = 1, ngrid - zmax(ig) = 0. - zlevinter(ig) = zlev(ig, 1) - END DO - DO ig = 1, ngrid - ! calcul de zlevinter - zlevinter(ig) = (zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*linter(ig) + & - zlev(ig, lmax(ig)) - lmax(ig)*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig))) - zmax(ig) = max(zmax(ig), zlevinter(ig)-zlev(ig,lmin(ig))) - END DO - - PRINT *, 'avant fermeture' - ! Fermeture,determination de f - DO ig = 1, ngrid - entr_star2(ig) = 0. - END DO - DO ig = 1, ngrid - IF (entr_star_tot(ig)<1.E-10) THEN - f(ig) = 0. - ELSE - DO k = lmin(ig), lentr(ig) - entr_star2(ig) = entr_star2(ig) + entr_star(ig, k)**2/(rho(ig,k)*( & - zlev(ig,k+1)-zlev(ig,k))) - END DO - ! Nouvelle fermeture - f(ig) = wmax(ig)/(max(500.,zmax(ig))*r_aspect*entr_star2(ig))* & - entr_star_tot(ig) - ! test - ! if (first) then - ! f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig) - ! s *wmax(ig)) - ! endif - END IF - ! f0(ig)=f(ig) - ! first=.true. - END DO - PRINT *, 'apres fermeture' - - ! Calcul de l'entrainement - DO k = 1, klev - DO ig = 1, ngrid - entr(ig, k) = f(ig)*entr_star(ig, k) - END DO - END DO - ! Calcul des flux - DO ig = 1, ngrid - DO l = 1, lmax(ig) - 1 - fmc(ig, l+1) = fmc(ig, l) + entr(ig, l) - END DO - END DO - - ! RC - - - ! print*,'9 OK convect8' - ! print*,'WA1 ',wa_moy - - ! determination de l'indice du debut de la mixed layer ou w decroit - - ! calcul de la largeur de chaque ascendance dans le cas conservatif. - ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant - ! d'une couche est égale à la hauteur de la couche alimentante. - ! La vitesse maximale dans l'ascendance est aussi prise comme estimation - ! de la vitesse d'entrainement horizontal dans la couche alimentante. - - DO l = 2, nlay - DO ig = 1, ngrid - IF (l<=lmaxa(ig)) THEN - zw = max(wa_moy(ig,l), 1.E-10) - larg_cons(ig, l) = zmax(ig)*r_aspect*fmc(ig, l)/(rhobarz(ig,l)*zw) - END IF - END DO - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - IF (l<=lmaxa(ig)) THEN - ! if (idetr.eq.0) then - ! cette option est finalement en dur. - IF ((l_mix*zlev(ig,l))<0.) THEN - PRINT *, 'pb l_mix*zlev<0' - END IF - larg_detr(ig, l) = sqrt(l_mix*zlev(ig,l)) - ! else if (idetr.eq.1) then - ! larg_detr(ig,l)=larg_cons(ig,l) - ! s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) - ! else if (idetr.eq.2) then - ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) - ! s *sqrt(wa_moy(ig,l)) - ! else if (idetr.eq.4) then - ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) - ! s *wa_moy(ig,l) - ! endif - END IF - END DO - END DO - - ! print*,'10 OK convect8' - ! print*,'WA2 ',wa_moy - ! calcul de la fraction de la maille concernée par l'ascendance en tenant - ! compte de l'epluchage du thermique. - - ! CR def de zmix continu (profil parabolique des vitesses) - DO ig = 1, ngrid - IF (lmix(ig)>1.) THEN - ! test - IF (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- & - (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- & - zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))- & - (zlev(ig,lmix(ig)))))>1E-10) THEN - - zmix(ig) = ((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)) & - )**2-(zlev(ig,lmix(ig)+1))**2)-(zw2(ig,lmix(ig))-zw2(ig, & - lmix(ig)+1))*((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))/ & - (2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- & - (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- & - zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) - ELSE - zmix(ig) = zlev(ig, lmix(ig)) - PRINT *, 'pb zmix' - END IF - ELSE - zmix(ig) = 0. - END IF - ! test - IF ((zmax(ig)-zmix(ig))<0.) THEN - zmix(ig) = 0.99*zmax(ig) - ! print*,'pb zmix>zmax' - END IF - END DO - - ! calcul du nouveau lmix correspondant - DO ig = 1, ngrid - DO l = 1, klev - IF (zmix(ig)>=zlev(ig,l) .AND. zmix(ig)1.) THEN - ! print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' - fraca(ig, l) = (larg_cons(ig,l)-larg_detr(ig,l))/(r_aspect*zmax(ig)) - ! test - fraca(ig, l) = max(fraca(ig,l), 0.) - fraca(ig, l) = min(fraca(ig,l), 0.5) - fracd(ig, l) = 1. - fraca(ig, l) - fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) - ELSE - ! wa_moy(ig,l)=0. - fraca(ig, l) = 0. - fracc(ig, l) = 0. - fracd(ig, l) = 1. - END IF - END DO - END DO - ! CR: calcul de fracazmix - DO ig = 1, ngrid - fracazmix(ig) = (fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ & - (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + & - fraca(ig, lmix(ig)) - zlev(ig, lmix(ig))*(fraca(ig,lmix(ig)+1)-fraca(ig & - ,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig))) - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - IF (larg_cons(ig,l)>1.) THEN - IF (l>lmix(ig)) THEN - ! test - IF (zmax(ig)-zmix(ig)<1.E-10) THEN - ! print*,'pb xxx' - xxx(ig, l) = (lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig)) - ELSE - xxx(ig, l) = (zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig)) - END IF - IF (idetr==0) THEN - fraca(ig, l) = fracazmix(ig) - ELSE IF (idetr==1) THEN - fraca(ig, l) = fracazmix(ig)*xxx(ig, l) - ELSE IF (idetr==2) THEN - fraca(ig, l) = fracazmix(ig)*(1.-(1.-xxx(ig,l))**2) - ELSE - fraca(ig, l) = fracazmix(ig)*xxx(ig, l)**2 - END IF - ! print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' - fraca(ig, l) = max(fraca(ig,l), 0.) - fraca(ig, l) = min(fraca(ig,l), 0.5) - fracd(ig, l) = 1. - fraca(ig, l) - fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) - END IF - END IF - END DO - END DO - - PRINT *, 'fin calcul fraca' - ! print*,'11 OK convect8' - ! print*,'Ea3 ',wa_moy - ! ------------------------------------------------------------------ - ! Calcul de fracd, wd - ! somme wa - wd = 0 - ! ------------------------------------------------------------------ - - - DO ig = 1, ngrid - fm(ig, 1) = 0. - fm(ig, nlay+1) = 0. - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - fm(ig, l) = fraca(ig, l)*wa_moy(ig, l)*rhobarz(ig, l) - ! CR:test - IF (entr(ig,l-1)<1E-10 .AND. fm(ig,l)>fm(ig,l-1) .AND. l>lmix(ig)) THEN - fm(ig, l) = fm(ig, l-1) - ! write(1,*)'ajustement fm, l',l - END IF - ! write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) - ! RC - END DO - DO ig = 1, ngrid - IF (fracd(ig,l)<0.1) THEN - abort_message = 'fracd trop petit' - CALL abort_physic(modname, abort_message, 1) - ELSE - ! vitesse descendante "diagnostique" - wd(ig, l) = fm(ig, l)/(fracd(ig,l)*rhobarz(ig,l)) - END IF - END DO - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) - masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg - END DO - END DO - - ! print*,'12 OK convect8' - ! print*,'WA4 ',wa_moy - ! c------------------------------------------------------------------ - ! calcul du transport vertical - ! ------------------------------------------------------------------ - - GO TO 4444 - ! print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep - DO l = 2, nlay - 1 - DO ig = 1, ngrid - IF (fm(ig,l+1)*ptimestep>masse(ig,l) .AND. fm(ig,l+1)*ptimestep>masse( & - ig,l+1)) THEN - ! print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' - ! s ,fm(ig,l+1)*ptimestep - ! s ,' M=',masse(ig,l),masse(ig,l+1) - END IF - END DO - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - IF (entr(ig,l)*ptimestep>masse(ig,l)) THEN - ! print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' - ! s ,entr(ig,l)*ptimestep - ! s ,' M=',masse(ig,l) - END IF - END DO - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - IF (.NOT. fm(ig,l)>=0. .OR. .NOT. fm(ig,l)<=10.) THEN - ! print*,'WARN!!! fm exagere ig=',ig,' l=',l - ! s ,' FM=',fm(ig,l) - END IF - IF (.NOT. masse(ig,l)>=1.E-10 .OR. .NOT. masse(ig,l)<=1.E4) THEN - ! print*,'WARN!!! masse exagere ig=',ig,' l=',l - ! s ,' M=',masse(ig,l) - ! print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', - ! s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) - ! print*,'zlev(ig,l+1),zlev(ig,l)' - ! s ,zlev(ig,l+1),zlev(ig,l) - ! print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' - ! s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) - END IF - IF (.NOT. entr(ig,l)>=0. .OR. .NOT. entr(ig,l)<=10.) THEN - ! print*,'WARN!!! entr exagere ig=',ig,' l=',l - ! s ,' E=',entr(ig,l) - END IF - END DO - END DO - -4444 CONTINUE - - ! CR:redefinition du entr - DO l = 1, nlay - DO ig = 1, ngrid - detr(ig, l) = fm(ig, l) + entr(ig, l) - fm(ig, l+1) - IF (detr(ig,l)<0.) THEN - entr(ig, l) = entr(ig, l) - detr(ig, l) - detr(ig, l) = 0. - ! print*,'WARNING !!! detrainement negatif ',ig,l - END IF - END DO - END DO - ! RC - IF (w2di==1) THEN - fm0 = fm0 + ptimestep*(fm-fm0)/tho - entr0 = entr0 + ptimestep*(entr-entr0)/tho - ELSE - fm0 = fm - entr0 = entr - END IF - - IF (1==1) THEN - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zh, zdhadj, & - zha) - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zo, pdoadj, & - zoa) - ELSE - CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, & - zdhadj, zha) - CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, & - pdoadj, zoa) - END IF - - IF (1==0) THEN - CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, & - zu, zv, pduadj, pdvadj, zua, zva) - ELSE - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, & - zua) - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, & - zva) - END IF - - DO l = 1, nlay - DO ig = 1, ngrid - zf = 0.5*(fracc(ig,l)+fracc(ig,l+1)) - zf2 = zf/(1.-zf) - thetath2(ig, l) = zf2*(zha(ig,l)-zh(ig,l))**2 - wth2(ig, l) = zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 - END DO - END DO - - - - ! print*,'13 OK convect8' - ! print*,'WA5 ',wa_moy - DO l = 1, nlay - DO ig = 1, ngrid - pdtadj(ig, l) = zdhadj(ig, l)*zpspsk(ig, l) - END DO - END DO - - - ! do l=1,nlay - ! do ig=1,ngrid - ! if(abs(pdtadj(ig,l))*86400..gt.500.) then - ! print*,'WARN!!! ig=',ig,' l=',l - ! s ,' pdtadj=',pdtadj(ig,l) - ! endif - ! if(abs(pdoadj(ig,l))*86400..gt.1.) then - ! print*,'WARN!!! ig=',ig,' l=',l - ! s ,' pdoadj=',pdoadj(ig,l) - ! endif - ! enddo - ! enddo - - ! print*,'14 OK convect8' - ! ------------------------------------------------------------------ - ! Calculs pour les sorties - ! ------------------------------------------------------------------ - - IF (sorties) THEN - DO l = 1, nlay - DO ig = 1, ngrid - zla(ig, l) = (1.-fracd(ig,l))*zmax(ig) - zld(ig, l) = fracd(ig, l)*zmax(ig) - IF (1.-fracd(ig,l)>1.E-10) zwa(ig, l) = wd(ig, l)*fracd(ig, l)/ & - (1.-fracd(ig,l)) - END DO - END DO - - ! deja fait - ! do l=1,nlay - ! do ig=1,ngrid - ! detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) - ! if (detr(ig,l).lt.0.) then - ! entr(ig,l)=entr(ig,l)-detr(ig,l) - ! detr(ig,l)=0. - ! print*,'WARNING !!! detrainement negatif ',ig,l - ! endif - ! enddo - ! enddo - - ! print*,'15 OK convect8' - - - ! #define und - GO TO 123 -#ifdef und - CALL writeg1d(1, nlay, wd, 'wd ', 'wd ') - CALL writeg1d(1, nlay, zwa, 'wa ', 'wa ') - CALL writeg1d(1, nlay, fracd, 'fracd ', 'fracd ') - CALL writeg1d(1, nlay, fraca, 'fraca ', 'fraca ') - CALL writeg1d(1, nlay, wa_moy, 'wam ', 'wam ') - CALL writeg1d(1, nlay, zla, 'la ', 'la ') - CALL writeg1d(1, nlay, zld, 'ld ', 'ld ') - CALL writeg1d(1, nlay, pt, 'pt ', 'pt ') - CALL writeg1d(1, nlay, zh, 'zh ', 'zh ') - CALL writeg1d(1, nlay, zha, 'zha ', 'zha ') - CALL writeg1d(1, nlay, zu, 'zu ', 'zu ') - CALL writeg1d(1, nlay, zv, 'zv ', 'zv ') - CALL writeg1d(1, nlay, zo, 'zo ', 'zo ') - CALL writeg1d(1, nlay, wh, 'wh ', 'wh ') - CALL writeg1d(1, nlay, wu, 'wu ', 'wu ') - CALL writeg1d(1, nlay, wv, 'wv ', 'wv ') - CALL writeg1d(1, nlay, wo, 'w15uo ', 'wXo ') - CALL writeg1d(1, nlay, zdhadj, 'zdhadj ', 'zdhadj ') - CALL writeg1d(1, nlay, pduadj, 'pduadj ', 'pduadj ') - CALL writeg1d(1, nlay, pdvadj, 'pdvadj ', 'pdvadj ') - CALL writeg1d(1, nlay, pdoadj, 'pdoadj ', 'pdoadj ') - CALL writeg1d(1, nlay, entr, 'entr ', 'entr ') - CALL writeg1d(1, nlay, detr, 'detr ', 'detr ') - CALL writeg1d(1, nlay, fm, 'fm ', 'fm ') - - CALL writeg1d(1, nlay, pdtadj, 'pdtadj ', 'pdtadj ') - CALL writeg1d(1, nlay, pplay, 'pplay ', 'pplay ') - CALL writeg1d(1, nlay, pplev, 'pplev ', 'pplev ') - - ! recalcul des flux en diagnostique... - ! print*,'PAS DE TEMPS ',ptimestep - CALL dt2f(pplev, pplay, pt, pdtadj, wh) - CALL writeg1d(1, nlay, wh, 'wh2 ', 'wh2 ') -#endif -123 CONTINUE - - END IF - - ! if(wa_moy(1,4).gt.1.e-10) stop - - ! print*,'19 OK convect8' - RETURN -END SUBROUTINE thermcell - -SUBROUTINE dqthermcell(ngrid, nlay, ptimestep, fm, entr, masse, q, dq, qa) - USE dimphy - IMPLICIT NONE - - ! ======================================================================= - - ! Calcul du transport verticale dans la couche limite en presence - ! de "thermiques" explicitement representes - ! calcul du dq/dt une fois qu'on connait les ascendances - - ! ======================================================================= - - INTEGER ngrid, nlay - - REAL ptimestep - REAL masse(ngrid, nlay), fm(ngrid, nlay+1) - REAL entr(ngrid, nlay) - REAL q(ngrid, nlay) - REAL dq(ngrid, nlay) - - REAL qa(klon, klev), detr(klon, klev), wqd(klon, klev+1) - - INTEGER ig, k - - ! calcul du detrainement - - DO k = 1, nlay - DO ig = 1, ngrid - detr(ig, k) = fm(ig, k) - fm(ig, k+1) + entr(ig, k) - ! test - IF (detr(ig,k)<0.) THEN - entr(ig, k) = entr(ig, k) - detr(ig, k) - detr(ig, k) = 0. - ! print*,'detr2<0!!!','ig=',ig,'k=',k,'f=',fm(ig,k), - ! s 'f+1=',fm(ig,k+1),'e=',entr(ig,k),'d=',detr(ig,k) - END IF - IF (fm(ig,k+1)<0.) THEN - ! print*,'fm2<0!!!' - END IF - IF (entr(ig,k)<0.) THEN - ! print*,'entr2<0!!!' - END IF - END DO - END DO - - ! calcul de la valeur dans les ascendances - DO ig = 1, ngrid - qa(ig, 1) = q(ig, 1) - END DO - - DO k = 2, nlay - DO ig = 1, ngrid - IF ((fm(ig,k+1)+detr(ig,k))*ptimestep>1.E-5*masse(ig,k)) THEN - qa(ig, k) = (fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k))/ & - (fm(ig,k+1)+detr(ig,k)) - ELSE - qa(ig, k) = q(ig, k) - END IF - IF (qa(ig,k)<0.) THEN - ! print*,'qa<0!!!' - END IF - IF (q(ig,k)<0.) THEN - ! print*,'q<0!!!' - END IF - END DO - END DO - - DO k = 2, nlay - DO ig = 1, ngrid - ! wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k)) - wqd(ig, k) = fm(ig, k)*q(ig, k) - IF (wqd(ig,k)<0.) THEN - ! print*,'wqd<0!!!' - END IF - END DO - END DO - DO ig = 1, ngrid - wqd(ig, 1) = 0. - wqd(ig, nlay+1) = 0. - END DO - - DO k = 1, nlay - DO ig = 1, ngrid - dq(ig, k) = (detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k)-wqd(ig,k)+wqd(ig,k+ & - 1))/masse(ig, k) - ! if (dq(ig,k).lt.0.) then - ! print*,'dq<0!!!' - ! endif - END DO - END DO - - RETURN -END SUBROUTINE dqthermcell -SUBROUTINE dvthermcell(ngrid, nlay, ptimestep, fm, entr, masse, fraca, larga, & - u, v, du, dv, ua, va) - USE dimphy - IMPLICIT NONE - - ! ======================================================================= - - ! Calcul du transport verticale dans la couche limite en presence - ! de "thermiques" explicitement representes - ! calcul du dq/dt une fois qu'on connait les ascendances - - ! ======================================================================= - - INTEGER ngrid, nlay - - REAL ptimestep - REAL masse(ngrid, nlay), fm(ngrid, nlay+1) - REAL fraca(ngrid, nlay+1) - REAL larga(ngrid) - REAL entr(ngrid, nlay) - REAL u(ngrid, nlay) - REAL ua(ngrid, nlay) - REAL du(ngrid, nlay) - REAL v(ngrid, nlay) - REAL va(ngrid, nlay) - REAL dv(ngrid, nlay) - - REAL qa(klon, klev), detr(klon, klev) - REAL wvd(klon, klev+1), wud(klon, klev+1) - REAL gamma0, gamma(klon, klev+1) - REAL dua, dva - INTEGER iter - - INTEGER ig, k - - ! calcul du detrainement - - DO k = 1, nlay - DO ig = 1, ngrid - detr(ig, k) = fm(ig, k) - fm(ig, k+1) + entr(ig, k) - END DO - END DO - - ! calcul de la valeur dans les ascendances - DO ig = 1, ngrid - ua(ig, 1) = u(ig, 1) - va(ig, 1) = v(ig, 1) - END DO - - DO k = 2, nlay - DO ig = 1, ngrid - IF ((fm(ig,k+1)+detr(ig,k))*ptimestep>1.E-5*masse(ig,k)) THEN - ! On itère sur la valeur du coeff de freinage. - ! gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)) - gamma0 = masse(ig, k)*sqrt(0.5*(fraca(ig,k+1)+fraca(ig, & - k)))*0.5/larga(ig) - ! gamma0=0. - ! la première fois on multiplie le coefficient de freinage - ! par le module du vent dans la couche en dessous. - dua = ua(ig, k-1) - u(ig, k-1) - dva = va(ig, k-1) - v(ig, k-1) - DO iter = 1, 5 - gamma(ig, k) = gamma0*sqrt(dua**2+dva**2) - ua(ig, k) = (fm(ig,k)*ua(ig,k-1)+(entr(ig,k)+gamma(ig, & - k))*u(ig,k))/(fm(ig,k+1)+detr(ig,k)+gamma(ig,k)) - va(ig, k) = (fm(ig,k)*va(ig,k-1)+(entr(ig,k)+gamma(ig, & - k))*v(ig,k))/(fm(ig,k+1)+detr(ig,k)+gamma(ig,k)) - ! print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva - dua = ua(ig, k) - u(ig, k) - dva = va(ig, k) - v(ig, k) - END DO - ELSE - ua(ig, k) = u(ig, k) - va(ig, k) = v(ig, k) - gamma(ig, k) = 0. - END IF - END DO - END DO - - DO k = 2, nlay - DO ig = 1, ngrid - wud(ig, k) = fm(ig, k)*u(ig, k) - wvd(ig, k) = fm(ig, k)*v(ig, k) - END DO - END DO - DO ig = 1, ngrid - wud(ig, 1) = 0. - wud(ig, nlay+1) = 0. - wvd(ig, 1) = 0. - wvd(ig, nlay+1) = 0. - END DO - - DO k = 1, nlay - DO ig = 1, ngrid - du(ig, k) = ((detr(ig,k)+gamma(ig,k))*ua(ig,k)-(entr(ig,k)+gamma(ig, & - k))*u(ig,k)-wud(ig,k)+wud(ig,k+1))/masse(ig, k) - dv(ig, k) = ((detr(ig,k)+gamma(ig,k))*va(ig,k)-(entr(ig,k)+gamma(ig, & - k))*v(ig,k)-wvd(ig,k)+wvd(ig,k+1))/masse(ig, k) - END DO - END DO - - RETURN -END SUBROUTINE dvthermcell -SUBROUTINE dqthermcell2(ngrid, nlay, ptimestep, fm, entr, masse, frac, q, dq, & - qa) - USE dimphy - IMPLICIT NONE - - ! ======================================================================= - - ! Calcul du transport verticale dans la couche limite en presence - ! de "thermiques" explicitement representes - ! calcul du dq/dt une fois qu'on connait les ascendances - - ! ======================================================================= - - INTEGER ngrid, nlay - - REAL ptimestep - REAL masse(ngrid, nlay), fm(ngrid, nlay+1) - REAL entr(ngrid, nlay), frac(ngrid, nlay) - REAL q(ngrid, nlay) - REAL dq(ngrid, nlay) - - REAL qa(klon, klev), detr(klon, klev), wqd(klon, klev+1) - REAL qe(klon, klev), zf, zf2 - - INTEGER ig, k - - ! calcul du detrainement - - DO k = 1, nlay - DO ig = 1, ngrid - detr(ig, k) = fm(ig, k) - fm(ig, k+1) + entr(ig, k) - END DO - END DO - - ! calcul de la valeur dans les ascendances - DO ig = 1, ngrid - qa(ig, 1) = q(ig, 1) - qe(ig, 1) = q(ig, 1) - END DO - - DO k = 2, nlay - DO ig = 1, ngrid - IF ((fm(ig,k+1)+detr(ig,k))*ptimestep>1.E-5*masse(ig,k)) THEN - zf = 0.5*(frac(ig,k)+frac(ig,k+1)) - zf2 = 1./(1.-zf) - qa(ig, k) = (fm(ig,k)*qa(ig,k-1)+zf2*entr(ig,k)*q(ig,k))/ & - (fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2) - qe(ig, k) = (q(ig,k)-zf*qa(ig,k))*zf2 - ELSE - qa(ig, k) = q(ig, k) - qe(ig, k) = q(ig, k) - END IF - END DO - END DO - - DO k = 2, nlay - DO ig = 1, ngrid - ! wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k)) - wqd(ig, k) = fm(ig, k)*qe(ig, k) - END DO - END DO - DO ig = 1, ngrid - wqd(ig, 1) = 0. - wqd(ig, nlay+1) = 0. - END DO - - DO k = 1, nlay - DO ig = 1, ngrid - dq(ig, k) = (detr(ig,k)*qa(ig,k)-entr(ig,k)*qe(ig,k)-wqd(ig,k)+wqd(ig,k & - +1))/masse(ig, k) - END DO - END DO - - RETURN -END SUBROUTINE dqthermcell2 -SUBROUTINE dvthermcell2(ngrid, nlay, ptimestep, fm, entr, masse, fraca, & - larga, u, v, du, dv, ua, va) - USE dimphy - IMPLICIT NONE - - ! ======================================================================= - - ! Calcul du transport verticale dans la couche limite en presence - ! de "thermiques" explicitement representes - ! calcul du dq/dt une fois qu'on connait les ascendances - - ! ======================================================================= - - INTEGER ngrid, nlay - - REAL ptimestep - REAL masse(ngrid, nlay), fm(ngrid, nlay+1) - REAL fraca(ngrid, nlay+1) - REAL larga(ngrid) - REAL entr(ngrid, nlay) - REAL u(ngrid, nlay) - REAL ua(ngrid, nlay) - REAL du(ngrid, nlay) - REAL v(ngrid, nlay) - REAL va(ngrid, nlay) - REAL dv(ngrid, nlay) - - REAL qa(klon, klev), detr(klon, klev), zf, zf2 - REAL wvd(klon, klev+1), wud(klon, klev+1) - REAL gamma0, gamma(klon, klev+1) - REAL ue(klon, klev), ve(klon, klev) - REAL dua, dva - INTEGER iter - - INTEGER ig, k - - ! calcul du detrainement - - DO k = 1, nlay - DO ig = 1, ngrid - detr(ig, k) = fm(ig, k) - fm(ig, k+1) + entr(ig, k) - END DO - END DO - - ! calcul de la valeur dans les ascendances - DO ig = 1, ngrid - ua(ig, 1) = u(ig, 1) - va(ig, 1) = v(ig, 1) - ue(ig, 1) = u(ig, 1) - ve(ig, 1) = v(ig, 1) - END DO - - DO k = 2, nlay - DO ig = 1, ngrid - IF ((fm(ig,k+1)+detr(ig,k))*ptimestep>1.E-5*masse(ig,k)) THEN - ! On itère sur la valeur du coeff de freinage. - ! gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)) - gamma0 = masse(ig, k)*sqrt(0.5*(fraca(ig,k+1)+fraca(ig, & - k)))*0.5/larga(ig)*1. - ! s *0.5 - ! gamma0=0. - zf = 0.5*(fraca(ig,k)+fraca(ig,k+1)) - zf = 0. - zf2 = 1./(1.-zf) - ! la première fois on multiplie le coefficient de freinage - ! par le module du vent dans la couche en dessous. - dua = ua(ig, k-1) - u(ig, k-1) - dva = va(ig, k-1) - v(ig, k-1) - DO iter = 1, 5 - ! On choisit une relaxation lineaire. - gamma(ig, k) = gamma0 - ! On choisit une relaxation quadratique. - gamma(ig, k) = gamma0*sqrt(dua**2+dva**2) - ua(ig, k) = (fm(ig,k)*ua(ig,k-1)+(zf2*entr(ig,k)+gamma(ig, & - k))*u(ig,k))/(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2+gamma(ig,k) & - ) - va(ig, k) = (fm(ig,k)*va(ig,k-1)+(zf2*entr(ig,k)+gamma(ig, & - k))*v(ig,k))/(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2+gamma(ig,k) & - ) - ! print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva - dua = ua(ig, k) - u(ig, k) - dva = va(ig, k) - v(ig, k) - ue(ig, k) = (u(ig,k)-zf*ua(ig,k))*zf2 - ve(ig, k) = (v(ig,k)-zf*va(ig,k))*zf2 - END DO - ELSE - ua(ig, k) = u(ig, k) - va(ig, k) = v(ig, k) - ue(ig, k) = u(ig, k) - ve(ig, k) = v(ig, k) - gamma(ig, k) = 0. - END IF - END DO - END DO - - DO k = 2, nlay - DO ig = 1, ngrid - wud(ig, k) = fm(ig, k)*ue(ig, k) - wvd(ig, k) = fm(ig, k)*ve(ig, k) - END DO - END DO - DO ig = 1, ngrid - wud(ig, 1) = 0. - wud(ig, nlay+1) = 0. - wvd(ig, 1) = 0. - wvd(ig, nlay+1) = 0. - END DO - - DO k = 1, nlay - DO ig = 1, ngrid - du(ig, k) = ((detr(ig,k)+gamma(ig,k))*ua(ig,k)-(entr(ig,k)+gamma(ig, & - k))*ue(ig,k)-wud(ig,k)+wud(ig,k+1))/masse(ig, k) - dv(ig, k) = ((detr(ig,k)+gamma(ig,k))*va(ig,k)-(entr(ig,k)+gamma(ig, & - k))*ve(ig,k)-wvd(ig,k)+wvd(ig,k+1))/masse(ig, k) - END DO - END DO - - RETURN -END SUBROUTINE dvthermcell2 -SUBROUTINE thermcell_sec(ngrid, nlay, ptimestep, pplay, pplev, pphi, zlev, & - pu, pv, pt, po, pduadj, pdvadj, pdtadj, pdoadj, fm0, entr0 & ! s - ! ,pu_therm,pv_therm - , r_aspect, l_mix, w2di, tho) - - USE dimphy - IMPLICIT NONE - - ! ======================================================================= - - ! Calcul du transport verticale dans la couche limite en presence - ! de "thermiques" explicitement representes - - ! Réécriture à partir d'un listing papier à Habas, le 14/02/00 - - ! le thermique est supposé homogène et dissipé par mélange avec - ! son environnement. la longueur l_mix contrôle l'efficacité du - ! mélange - - ! Le calcul du transport des différentes espèces se fait en prenant - ! en compte: - ! 1. un flux de masse montant - ! 2. un flux de masse descendant - ! 3. un entrainement - ! 4. un detrainement - - ! ======================================================================= - - ! ----------------------------------------------------------------------- - ! declarations: - ! ------------- - - include "YOMCST.h" - - ! arguments: - ! ---------- - - INTEGER ngrid, nlay, w2di - REAL tho - REAL ptimestep, l_mix, r_aspect - REAL pt(ngrid, nlay), pdtadj(ngrid, nlay) - REAL pu(ngrid, nlay), pduadj(ngrid, nlay) - REAL pv(ngrid, nlay), pdvadj(ngrid, nlay) - REAL po(ngrid, nlay), pdoadj(ngrid, nlay) - REAL pplay(ngrid, nlay), pplev(ngrid, nlay+1) - REAL pphi(ngrid, nlay) - - INTEGER idetr - SAVE idetr - DATA idetr/3/ - !$OMP THREADPRIVATE(idetr) - - ! local: - ! ------ - - INTEGER ig, k, l, lmaxa(klon), lmix(klon) - REAL zsortie1d(klon) - ! CR: on remplace lmax(klon,klev+1) - INTEGER lmax(klon), lmin(klon), lentr(klon) - REAL linter(klon) - REAL zmix(klon), fracazmix(klon) - ! RC - REAL zmax(klon), zw, zz, zw2(klon, klev+1), ztva(klon, klev), zzz - - REAL zlev(klon, klev+1), zlay(klon, klev) - REAL zh(klon, klev), zdhadj(klon, klev) - REAL ztv(klon, klev) - REAL zu(klon, klev), zv(klon, klev), zo(klon, klev) - REAL wh(klon, klev+1) - REAL wu(klon, klev+1), wv(klon, klev+1), wo(klon, klev+1) - REAL zla(klon, klev+1) - REAL zwa(klon, klev+1) - REAL zld(klon, klev+1) - REAL zwd(klon, klev+1) - REAL zsortie(klon, klev) - REAL zva(klon, klev) - REAL zua(klon, klev) - REAL zoa(klon, klev) - - REAL zha(klon, klev) - REAL wa_moy(klon, klev+1) - REAL fraca(klon, klev+1) - REAL fracc(klon, klev+1) - REAL zf, zf2 - REAL thetath2(klon, klev), wth2(klon, klev) - ! common/comtherm/thetath2,wth2 - - REAL count_time - INTEGER ialt - - LOGICAL sorties - REAL rho(klon, klev), rhobarz(klon, klev+1), masse(klon, klev) - REAL zpspsk(klon, klev) - - ! real wmax(klon,klev),wmaxa(klon) - REAL wmax(klon), wmaxa(klon) - REAL wa(klon, klev, klev+1) - REAL wd(klon, klev+1) - REAL larg_part(klon, klev, klev+1) - REAL fracd(klon, klev+1) - REAL xxx(klon, klev+1) - REAL larg_cons(klon, klev+1) - REAL larg_detr(klon, klev+1) - REAL fm0(klon, klev+1), entr0(klon, klev), detr(klon, klev) - REAL pu_therm(klon, klev), pv_therm(klon, klev) - REAL fm(klon, klev+1), entr(klon, klev) - REAL fmc(klon, klev+1) - - ! CR:nouvelles variables - REAL f_star(klon, klev+1), entr_star(klon, klev) - REAL entr_star_tot(klon), entr_star2(klon) - REAL f(klon), f0(klon) - REAL zlevinter(klon) - LOGICAL first - DATA first/.FALSE./ - SAVE first - !$OMP THREADPRIVATE(first) - ! RC - - CHARACTER *2 str2 - CHARACTER *10 str10 - - CHARACTER (LEN=20) :: modname = 'thermcell_sec' - CHARACTER (LEN=80) :: abort_message - - LOGICAL vtest(klon), down - - EXTERNAL scopy - - INTEGER ncorrec, ll - SAVE ncorrec - DATA ncorrec/0/ - !$OMP THREADPRIVATE(ncorrec) - - - ! ----------------------------------------------------------------------- - ! initialisation: - ! --------------- - - sorties = .TRUE. - IF (ngrid/=klon) THEN - PRINT * - PRINT *, 'STOP dans convadj' - PRINT *, 'ngrid =', ngrid - PRINT *, 'klon =', klon - END IF - - ! ----------------------------------------------------------------------- - ! incrementation eventuelle de tendances precedentes: - ! --------------------------------------------------- - - ! print*,'0 OK convect8' - - DO l = 1, nlay - DO ig = 1, ngrid - zpspsk(ig, l) = (pplay(ig,l)/pplev(ig,1))**rkappa - zh(ig, l) = pt(ig, l)/zpspsk(ig, l) - zu(ig, l) = pu(ig, l) - zv(ig, l) = pv(ig, l) - zo(ig, l) = po(ig, l) - ztv(ig, l) = zh(ig, l)*(1.+0.61*zo(ig,l)) - END DO - END DO - - ! print*,'1 OK convect8' - ! -------------------- - - - ! + + + + + + + + + + + - - - ! wa, fraca, wd, fracd -------------------- zlev(2), rhobarz - ! wh,wt,wo ... - - ! + + + + + + + + + + + zh,zu,zv,zo,rho - - - ! -------------------- zlev(1) - ! \\\\\\\\\\\\\\\\\\\\ - - - - ! ----------------------------------------------------------------------- - ! Calcul des altitudes des couches - ! ----------------------------------------------------------------------- - - DO l = 2, nlay - DO ig = 1, ngrid - zlev(ig, l) = 0.5*(pphi(ig,l)+pphi(ig,l-1))/rg - END DO - END DO - DO ig = 1, ngrid - zlev(ig, 1) = 0. - zlev(ig, nlay+1) = (2.*pphi(ig,klev)-pphi(ig,klev-1))/rg - END DO - DO l = 1, nlay - DO ig = 1, ngrid - zlay(ig, l) = pphi(ig, l)/rg - END DO - END DO - - ! print*,'2 OK convect8' - ! ----------------------------------------------------------------------- - ! Calcul des densites - ! ----------------------------------------------------------------------- - - DO l = 1, nlay - DO ig = 1, ngrid - rho(ig, l) = pplay(ig, l)/(zpspsk(ig,l)*rd*zh(ig,l)) - END DO - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - rhobarz(ig, l) = 0.5*(rho(ig,l)+rho(ig,l-1)) - END DO - END DO - - DO k = 1, nlay - DO l = 1, nlay + 1 - DO ig = 1, ngrid - wa(ig, k, l) = 0. - END DO - END DO - END DO - - ! print*,'3 OK convect8' - ! ------------------------------------------------------------------ - ! Calcul de w2, quarre de w a partir de la cape - ! a partir de w2, on calcule wa, vitesse de l'ascendance - - ! ATTENTION: Dans cette version, pour cause d'economie de memoire, - ! w2 est stoke dans wa - - ! ATTENTION: dans convect8, on n'utilise le calcule des wa - ! independants par couches que pour calculer l'entrainement - ! a la base et la hauteur max de l'ascendance. - - ! Indicages: - ! l'ascendance provenant du niveau k traverse l'interface l avec - ! une vitesse wa(k,l). - - ! -------------------- - - ! + + + + + + + + + + - - ! wa(k,l) ---- -------------------- l - ! /\ - ! /||\ + + + + + + + + + + - ! || - ! || -------------------- - ! || - ! || + + + + + + + + + + - ! || - ! || -------------------- - ! ||__ - ! |___ + + + + + + + + + + k - - ! -------------------- - - - - ! ------------------------------------------------------------------ - - ! CR: ponderation entrainement des couches instables - ! def des entr_star tels que entr=f*entr_star - DO l = 1, klev - DO ig = 1, ngrid - entr_star(ig, l) = 0. - END DO - END DO - ! determination de la longueur de la couche d entrainement - DO ig = 1, ngrid - lentr(ig) = 1 - END DO - - ! on ne considere que les premieres couches instables - DO k = nlay - 2, 1, -1 - DO ig = 1, ngrid - IF (ztv(ig,k)>ztv(ig,k+1) .AND. ztv(ig,k+1)<=ztv(ig,k+2)) THEN - lentr(ig) = k - END IF - END DO - END DO - - ! determination du lmin: couche d ou provient le thermique - DO ig = 1, ngrid - lmin(ig) = 1 - END DO - DO ig = 1, ngrid - DO l = nlay, 2, -1 - IF (ztv(ig,l-1)>ztv(ig,l)) THEN - lmin(ig) = l - 1 - END IF - END DO - END DO - - ! definition de l'entrainement des couches - DO l = 1, klev - 1 - DO ig = 1, ngrid - IF (ztv(ig,l)>ztv(ig,l+1) .AND. l>=lmin(ig) .AND. l<=lentr(ig)) THEN - entr_star(ig, l) = (ztv(ig,l)-ztv(ig,l+1))** & ! s - ! (zlev(ig,l+1)-zlev(ig,l)) - sqrt(zlev(ig,l+1)) - END IF - END DO - END DO - ! pas de thermique si couche 1 stable - DO ig = 1, ngrid - IF (lmin(ig)>1) THEN - DO l = 1, klev - entr_star(ig, l) = 0. - END DO - END IF - END DO - ! calcul de l entrainement total - DO ig = 1, ngrid - entr_star_tot(ig) = 0. - END DO - DO ig = 1, ngrid - DO k = 1, klev - entr_star_tot(ig) = entr_star_tot(ig) + entr_star(ig, k) - END DO - END DO - - ! print*,'fin calcul entr_star' - DO k = 1, klev - DO ig = 1, ngrid - ztva(ig, k) = ztv(ig, k) - END DO - END DO - ! RC - ! print*,'7 OK convect8' - DO k = 1, klev + 1 - DO ig = 1, ngrid - zw2(ig, k) = 0. - fmc(ig, k) = 0. - ! CR - f_star(ig, k) = 0. - ! RC - larg_cons(ig, k) = 0. - larg_detr(ig, k) = 0. - wa_moy(ig, k) = 0. - END DO - END DO - - ! print*,'8 OK convect8' - DO ig = 1, ngrid - linter(ig) = 1. - lmaxa(ig) = 1 - lmix(ig) = 1 - wmaxa(ig) = 0. - END DO - - ! CR: - DO l = 1, nlay - 2 - DO ig = 1, ngrid - IF (ztv(ig,l)>ztv(ig,l+1) .AND. entr_star(ig,l)>1.E-10 .AND. & - zw2(ig,l)<1E-10) THEN - f_star(ig, l+1) = entr_star(ig, l) - ! test:calcul de dteta - zw2(ig, l+1) = 2.*rg*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig, l+1)* & - (zlev(ig,l+1)-zlev(ig,l))*0.4*pphi(ig, l)/(pphi(ig,l+1)-pphi(ig,l)) - larg_detr(ig, l) = 0. - ELSE IF ((zw2(ig,l)>=1E-10) .AND. (f_star(ig,l)+entr_star(ig, & - l)>1.E-10)) THEN - f_star(ig, l+1) = f_star(ig, l) + entr_star(ig, l) - ztva(ig, l) = (f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)*ztv(ig,l))/ & - f_star(ig, l+1) - zw2(ig, l+1) = zw2(ig, l)*(f_star(ig,l)/f_star(ig,l+1))**2 + & - 2.*rg*(ztva(ig,l)-ztv(ig,l))/ztv(ig, l)*(zlev(ig,l+1)-zlev(ig,l)) - END IF - ! determination de zmax continu par interpolation lineaire - IF (zw2(ig,l+1)<0.) THEN - ! test - IF (abs(zw2(ig,l+1)-zw2(ig,l))<1E-10) THEN - ! print*,'pb linter' - END IF - linter(ig) = (l*(zw2(ig,l+1)-zw2(ig,l))-zw2(ig,l))/(zw2(ig,l+1)-zw2( & - ig,l)) - zw2(ig, l+1) = 0. - lmaxa(ig) = l - ELSE - IF (zw2(ig,l+1)<0.) THEN - ! print*,'pb1 zw2<0' - END IF - wa_moy(ig, l+1) = sqrt(zw2(ig,l+1)) - END IF - IF (wa_moy(ig,l+1)>wmaxa(ig)) THEN - ! lmix est le niveau de la couche ou w (wa_moy) est maximum - lmix(ig) = l + 1 - wmaxa(ig) = wa_moy(ig, l+1) - END IF - END DO - END DO - ! print*,'fin calcul zw2' - - ! Calcul de la couche correspondant a la hauteur du thermique - DO ig = 1, ngrid - lmax(ig) = lentr(ig) - END DO - DO ig = 1, ngrid - DO l = nlay, lentr(ig) + 1, -1 - IF (zw2(ig,l)<=1.E-10) THEN - lmax(ig) = l - 1 - END IF - END DO - END DO - ! pas de thermique si couche 1 stable - DO ig = 1, ngrid - IF (lmin(ig)>1) THEN - lmax(ig) = 1 - lmin(ig) = 1 - END IF - END DO - - ! Determination de zw2 max - DO ig = 1, ngrid - wmax(ig) = 0. - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - IF (l<=lmax(ig)) THEN - IF (zw2(ig,l)<0.) THEN - ! print*,'pb2 zw2<0' - END IF - zw2(ig, l) = sqrt(zw2(ig,l)) - wmax(ig) = max(wmax(ig), zw2(ig,l)) - ELSE - zw2(ig, l) = 0. - END IF - END DO - END DO - - ! Longueur caracteristique correspondant a la hauteur des thermiques. - DO ig = 1, ngrid - zmax(ig) = 0. - zlevinter(ig) = zlev(ig, 1) - END DO - DO ig = 1, ngrid - ! calcul de zlevinter - zlevinter(ig) = (zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*linter(ig) + & - zlev(ig, lmax(ig)) - lmax(ig)*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig))) - zmax(ig) = max(zmax(ig), zlevinter(ig)-zlev(ig,lmin(ig))) - END DO - - ! print*,'avant fermeture' - ! Fermeture,determination de f - DO ig = 1, ngrid - entr_star2(ig) = 0. - END DO - DO ig = 1, ngrid - IF (entr_star_tot(ig)<1.E-10) THEN - f(ig) = 0. - ELSE - DO k = lmin(ig), lentr(ig) - entr_star2(ig) = entr_star2(ig) + entr_star(ig, k)**2/(rho(ig,k)*( & - zlev(ig,k+1)-zlev(ig,k))) - END DO - ! Nouvelle fermeture - f(ig) = wmax(ig)/(max(500.,zmax(ig))*r_aspect*entr_star2(ig))* & - entr_star_tot(ig) - ! test - ! if (first) then - ! f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig) - ! s *wmax(ig)) - ! endif - END IF - ! f0(ig)=f(ig) - ! first=.true. - END DO - ! print*,'apres fermeture' - - ! Calcul de l'entrainement - DO k = 1, klev - DO ig = 1, ngrid - entr(ig, k) = f(ig)*entr_star(ig, k) - END DO - END DO - ! CR:test pour entrainer moins que la masse - DO ig = 1, ngrid - DO l = 1, lentr(ig) - IF ((entr(ig,l)*ptimestep)>(0.9*masse(ig,l))) THEN - entr(ig, l+1) = entr(ig, l+1) + entr(ig, l) - & - 0.9*masse(ig, l)/ptimestep - entr(ig, l) = 0.9*masse(ig, l)/ptimestep - END IF - END DO - END DO - ! CR: fin test - ! Calcul des flux - DO ig = 1, ngrid - DO l = 1, lmax(ig) - 1 - fmc(ig, l+1) = fmc(ig, l) + entr(ig, l) - END DO - END DO - - ! RC - - - ! print*,'9 OK convect8' - ! print*,'WA1 ',wa_moy - - ! determination de l'indice du debut de la mixed layer ou w decroit - - ! calcul de la largeur de chaque ascendance dans le cas conservatif. - ! dans ce cas simple, on suppose que la largeur de l'ascendance provenant - ! d'une couche est égale à la hauteur de la couche alimentante. - ! La vitesse maximale dans l'ascendance est aussi prise comme estimation - ! de la vitesse d'entrainement horizontal dans la couche alimentante. - - DO l = 2, nlay - DO ig = 1, ngrid - IF (l<=lmaxa(ig)) THEN - zw = max(wa_moy(ig,l), 1.E-10) - larg_cons(ig, l) = zmax(ig)*r_aspect*fmc(ig, l)/(rhobarz(ig,l)*zw) - END IF - END DO - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - IF (l<=lmaxa(ig)) THEN - ! if (idetr.eq.0) then - ! cette option est finalement en dur. - IF ((l_mix*zlev(ig,l))<0.) THEN - ! print*,'pb l_mix*zlev<0' - END IF - ! CR: test: nouvelle def de lambda - ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) - IF (zw2(ig,l)>1.E-10) THEN - larg_detr(ig, l) = sqrt((l_mix/zw2(ig,l))*zlev(ig,l)) - ELSE - larg_detr(ig, l) = sqrt(l_mix*zlev(ig,l)) - END IF - ! RC - ! else if (idetr.eq.1) then - ! larg_detr(ig,l)=larg_cons(ig,l) - ! s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) - ! else if (idetr.eq.2) then - ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) - ! s *sqrt(wa_moy(ig,l)) - ! else if (idetr.eq.4) then - ! larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) - ! s *wa_moy(ig,l) - ! endif - END IF - END DO - END DO - - ! print*,'10 OK convect8' - ! print*,'WA2 ',wa_moy - ! calcul de la fraction de la maille concernée par l'ascendance en tenant - ! compte de l'epluchage du thermique. - - ! CR def de zmix continu (profil parabolique des vitesses) - DO ig = 1, ngrid - IF (lmix(ig)>1.) THEN - ! test - IF (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- & - (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- & - zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))- & - (zlev(ig,lmix(ig)))))>1E-10) THEN - - zmix(ig) = ((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)) & - )**2-(zlev(ig,lmix(ig)+1))**2)-(zw2(ig,lmix(ig))-zw2(ig, & - lmix(ig)+1))*((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))/ & - (2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))*((zlev(ig,lmix(ig)))- & - (zlev(ig,lmix(ig)+1)))-(zw2(ig,lmix(ig))- & - zw2(ig,lmix(ig)+1))*((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) - ELSE - zmix(ig) = zlev(ig, lmix(ig)) - ! print*,'pb zmix' - END IF - ELSE - zmix(ig) = 0. - END IF - ! test - IF ((zmax(ig)-zmix(ig))<0.) THEN - zmix(ig) = 0.99*zmax(ig) - ! print*,'pb zmix>zmax' - END IF - END DO - - ! calcul du nouveau lmix correspondant - DO ig = 1, ngrid - DO l = 1, klev - IF (zmix(ig)>=zlev(ig,l) .AND. zmix(ig)1.) THEN - ! print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' - fraca(ig, l) = (larg_cons(ig,l)-larg_detr(ig,l))/(r_aspect*zmax(ig)) - ! test - fraca(ig, l) = max(fraca(ig,l), 0.) - fraca(ig, l) = min(fraca(ig,l), 0.5) - fracd(ig, l) = 1. - fraca(ig, l) - fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) - ELSE - ! wa_moy(ig,l)=0. - fraca(ig, l) = 0. - fracc(ig, l) = 0. - fracd(ig, l) = 1. - END IF - END DO - END DO - ! CR: calcul de fracazmix - DO ig = 1, ngrid - fracazmix(ig) = (fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ & - (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + & - fraca(ig, lmix(ig)) - zlev(ig, lmix(ig))*(fraca(ig,lmix(ig)+1)-fraca(ig & - ,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig))) - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - IF (larg_cons(ig,l)>1.) THEN - IF (l>lmix(ig)) THEN - ! test - IF (zmax(ig)-zmix(ig)<1.E-10) THEN - ! print*,'pb xxx' - xxx(ig, l) = (lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig)) - ELSE - xxx(ig, l) = (zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig)) - END IF - IF (idetr==0) THEN - fraca(ig, l) = fracazmix(ig) - ELSE IF (idetr==1) THEN - fraca(ig, l) = fracazmix(ig)*xxx(ig, l) - ELSE IF (idetr==2) THEN - fraca(ig, l) = fracazmix(ig)*(1.-(1.-xxx(ig,l))**2) - ELSE - fraca(ig, l) = fracazmix(ig)*xxx(ig, l)**2 - END IF - ! print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' - fraca(ig, l) = max(fraca(ig,l), 0.) - fraca(ig, l) = min(fraca(ig,l), 0.5) - fracd(ig, l) = 1. - fraca(ig, l) - fracc(ig, l) = larg_cons(ig, l)/(r_aspect*zmax(ig)) - END IF - END IF - END DO - END DO - - ! print*,'fin calcul fraca' - ! print*,'11 OK convect8' - ! print*,'Ea3 ',wa_moy - ! ------------------------------------------------------------------ - ! Calcul de fracd, wd - ! somme wa - wd = 0 - ! ------------------------------------------------------------------ - - - DO ig = 1, ngrid - fm(ig, 1) = 0. - fm(ig, nlay+1) = 0. - END DO - - DO l = 2, nlay - DO ig = 1, ngrid - fm(ig, l) = fraca(ig, l)*wa_moy(ig, l)*rhobarz(ig, l) - ! CR:test - IF (entr(ig,l-1)<1E-10 .AND. fm(ig,l)>fm(ig,l-1) .AND. l>lmix(ig)) THEN - fm(ig, l) = fm(ig, l-1) - ! write(1,*)'ajustement fm, l',l - END IF - ! write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) - ! RC - END DO - DO ig = 1, ngrid - IF (fracd(ig,l)<0.1) THEN - abort_message = 'fracd trop petit' - CALL abort_physic(modname, abort_message, 1) - ELSE - ! vitesse descendante "diagnostique" - wd(ig, l) = fm(ig, l)/(fracd(ig,l)*rhobarz(ig,l)) - END IF - END DO - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - ! masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) - masse(ig, l) = (pplev(ig,l)-pplev(ig,l+1))/rg - END DO - END DO - - ! print*,'12 OK convect8' - ! print*,'WA4 ',wa_moy - ! c------------------------------------------------------------------ - ! calcul du transport vertical - ! ------------------------------------------------------------------ - - GO TO 4444 - ! print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep - DO l = 2, nlay - 1 - DO ig = 1, ngrid - IF (fm(ig,l+1)*ptimestep>masse(ig,l) .AND. fm(ig,l+1)*ptimestep>masse( & - ig,l+1)) THEN - ! print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' - ! s ,fm(ig,l+1)*ptimestep - ! s ,' M=',masse(ig,l),masse(ig,l+1) - END IF - END DO - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - IF (entr(ig,l)*ptimestep>masse(ig,l)) THEN - ! print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' - ! s ,entr(ig,l)*ptimestep - ! s ,' M=',masse(ig,l) - END IF - END DO - END DO - - DO l = 1, nlay - DO ig = 1, ngrid - IF (.NOT. fm(ig,l)>=0. .OR. .NOT. fm(ig,l)<=10.) THEN - ! print*,'WARN!!! fm exagere ig=',ig,' l=',l - ! s ,' FM=',fm(ig,l) - END IF - IF (.NOT. masse(ig,l)>=1.E-10 .OR. .NOT. masse(ig,l)<=1.E4) THEN - ! print*,'WARN!!! masse exagere ig=',ig,' l=',l - ! s ,' M=',masse(ig,l) - ! print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', - ! s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) - ! print*,'zlev(ig,l+1),zlev(ig,l)' - ! s ,zlev(ig,l+1),zlev(ig,l) - ! print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' - ! s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) - END IF - IF (.NOT. entr(ig,l)>=0. .OR. .NOT. entr(ig,l)<=10.) THEN - ! print*,'WARN!!! entr exagere ig=',ig,' l=',l - ! s ,' E=',entr(ig,l) - END IF - END DO - END DO - -4444 CONTINUE - - ! CR:redefinition du entr - DO l = 1, nlay - DO ig = 1, ngrid - detr(ig, l) = fm(ig, l) + entr(ig, l) - fm(ig, l+1) - IF (detr(ig,l)<0.) THEN - entr(ig, l) = entr(ig, l) - detr(ig, l) - detr(ig, l) = 0. - ! print*,'WARNING !!! detrainement negatif ',ig,l - END IF - END DO - END DO - ! RC - IF (w2di==1) THEN - fm0 = fm0 + ptimestep*(fm-fm0)/tho - entr0 = entr0 + ptimestep*(entr-entr0)/tho - ELSE - fm0 = fm - entr0 = entr - END IF - - IF (1==1) THEN - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zh, zdhadj, & - zha) - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zo, pdoadj, & - zoa) - ELSE - CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zh, & - zdhadj, zha) - CALL dqthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zo, & - pdoadj, zoa) - END IF - - IF (1==0) THEN - CALL dvthermcell2(ngrid, nlay, ptimestep, fm0, entr0, masse, fraca, zmax, & - zu, zv, pduadj, pdvadj, zua, zva) - ELSE - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zu, pduadj, & - zua) - CALL dqthermcell(ngrid, nlay, ptimestep, fm0, entr0, masse, zv, pdvadj, & - zva) - END IF - - DO l = 1, nlay - DO ig = 1, ngrid - zf = 0.5*(fracc(ig,l)+fracc(ig,l+1)) - zf2 = zf/(1.-zf) - thetath2(ig, l) = zf2*(zha(ig,l)-zh(ig,l))**2 - wth2(ig, l) = zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 - END DO - END DO - - - - ! print*,'13 OK convect8' - ! print*,'WA5 ',wa_moy - DO l = 1, nlay - DO ig = 1, ngrid - pdtadj(ig, l) = zdhadj(ig, l)*zpspsk(ig, l) - END DO - END DO - - - ! do l=1,nlay - ! do ig=1,ngrid - ! if(abs(pdtadj(ig,l))*86400..gt.500.) then - ! print*,'WARN!!! ig=',ig,' l=',l - ! s ,' pdtadj=',pdtadj(ig,l) - ! endif - ! if(abs(pdoadj(ig,l))*86400..gt.1.) then - ! print*,'WARN!!! ig=',ig,' l=',l - ! s ,' pdoadj=',pdoadj(ig,l) - ! endif - ! enddo - ! enddo - - ! print*,'14 OK convect8' - ! ------------------------------------------------------------------ - ! Calculs pour les sorties - ! ------------------------------------------------------------------ - - RETURN -END SUBROUTINE thermcell_sec - Index: LMDZ6/trunk/libf/phylmd/thermcell_plume.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/thermcell_plume.F90 (revision 4589) +++ (revision ) @@ -1,447 +1,0 @@ -! -! $Id: thermcell_plume.F90 3074 2017-11-15 13:31:44Z fhourdin $ -! - SUBROUTINE thermcell_plume(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz, & - & zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, & - & lalim,f0,detr_star,entr_star,f_star,csc,ztva, & - & ztla,zqla,zqta,zha,zw2,w_est,ztva_est,zqsatth,lmix,lmix_bis,linter & - & ,lev_out,lunout1,igout) -! & ,lev_out,lunout1,igout,zbuoy,zbuoyjam) -!-------------------------------------------------------------------------- -! Auhtors : Catherine Rio, Frédéric Hourdin, Arnaud Jam -! -!thermcell_plume: calcule les valeurs de qt, thetal et w dans l ascendance -! This versions starts from a cleaning of thermcell_plume_6A (2019/01/20) -! thermcell_plume_6A is activate for flag_thermas_ed < 10 -! thermcell_plume_5B for flag_thermas_ed < 20 -! thermcell_plume for flag_thermals_ed>= 20 -! Various options are controled by the flag_thermals_ed parameter -! = 20 : equivalent to thermcell_plume_6A with flag_thermals_ed=8 -! = 21 : the Jam strato-cumulus modif is not activated in detrainment -! = 29 : an other way to compute the modified buoyancy (to be tested) -!-------------------------------------------------------------------------- - - USE thermcell_ini_mod, ONLY: prt_level,fact_thermals_ed_dz,iflag_thermals_ed,RLvCP,RETV,RG - USE thermcell_ini_mod, ONLY: fact_epsilon, betalpha, afact, fact_shell - USE thermcell_ini_mod, ONLY: detr_min, entr_min, detr_q_coef, detr_q_power - USE thermcell_ini_mod, ONLY: mix0, thermals_flag_alim - - IMPLICIT NONE - - integer,intent(in) :: itap,lev_out,lunout1,igout,ngrid,nlay - real,intent(in) :: ptimestep - real,intent(in),dimension(ngrid,nlay) :: ztv - real,intent(in),dimension(ngrid,nlay) :: zthl - real,intent(in),dimension(ngrid,nlay) :: po - real,intent(in),dimension(ngrid,nlay) :: zl - real,intent(in),dimension(ngrid,nlay) :: rhobarz - real,intent(in),dimension(ngrid,nlay+1) :: zlev - real,intent(in),dimension(ngrid,nlay+1) :: pplev - real,intent(in),dimension(ngrid,nlay) :: pphi - real,intent(in),dimension(ngrid,nlay) :: zpspsk - real,intent(in),dimension(ngrid) :: f0 - - integer,intent(out) :: lalim(ngrid) - real,intent(out),dimension(ngrid,nlay) :: alim_star - real,intent(out),dimension(ngrid) :: alim_star_tot - real,intent(out),dimension(ngrid,nlay) :: detr_star - real,intent(out),dimension(ngrid,nlay) :: entr_star - real,intent(out),dimension(ngrid,nlay+1) :: f_star - real,intent(out),dimension(ngrid,nlay) :: csc - real,intent(out),dimension(ngrid,nlay) :: ztva - real,intent(out),dimension(ngrid,nlay) :: ztla - real,intent(out),dimension(ngrid,nlay) :: zqla - real,intent(out),dimension(ngrid,nlay) :: zqta - real,intent(out),dimension(ngrid,nlay) :: zha - real,intent(out),dimension(ngrid,nlay+1) :: zw2 - real,intent(out),dimension(ngrid,nlay+1) :: w_est - real,intent(out),dimension(ngrid,nlay) :: ztva_est - real,intent(out),dimension(ngrid,nlay) :: zqsatth - integer,intent(out),dimension(ngrid) :: lmix(ngrid) - integer,intent(out),dimension(ngrid) :: lmix_bis(ngrid) - real,intent(out),dimension(ngrid) :: linter(ngrid) - - - REAL,dimension(ngrid,nlay+1) :: wa_moy - REAL,dimension(ngrid,nlay) :: entr,detr - REAL,dimension(ngrid,nlay) :: ztv_est - REAL,dimension(ngrid,nlay) :: zqla_est - REAL,dimension(ngrid,nlay) :: zta_est - REAL,dimension(ngrid) :: ztemp,zqsat - REAL zdw2,zdw2bis - REAL zw2modif - REAL zw2fact,zw2factbis - REAL,dimension(ngrid,nlay) :: zeps - - REAL,dimension(ngrid) :: wmaxa - - INTEGER ig,l,k,lt,it,lm,nbpb - - real,dimension(ngrid,nlay) :: zbuoy,gamma,zdqt - real zdz,zalpha,zw2m - real,dimension(ngrid,nlay) :: zbuoyjam,zdqtjam - real zdz2,zdz3,lmel,entrbis,zdzbis - real,dimension(ngrid) :: d_temp - real ztv1,ztv2,factinv,zinv,zlmel - real zlmelup,zlmeldwn,zlt,zltdwn,zltup - real atv1,atv2,btv1,btv2 - real ztv_est1,ztv_est2 - real zcor,zdelta,zcvm5,qlbef - real zbetalpha, coefzlmel - real eps - logical Zsat - LOGICAL,dimension(ngrid) :: active,activetmp - REAL fact_gamma,fact_gamma2,fact_epsilon2 - - - REAL,dimension(ngrid,nlay) :: c2 - - if (ngrid==1) print*,'THERMCELL PLUME MODIFIE 2014/07/11' - Zsat=.false. -! Initialisation - - - zbetalpha=betalpha/(1.+betalpha) - - -! Initialisations des variables r?elles -if (1==1) then - ztva(:,:)=ztv(:,:) - ztva_est(:,:)=ztva(:,:) - ztv_est(:,:)=ztv(:,:) - ztla(:,:)=zthl(:,:) - zqta(:,:)=po(:,:) - zqla(:,:)=0. - zha(:,:) = ztva(:,:) -else - ztva(:,:)=0. - ztv_est(:,:)=0. - ztva_est(:,:)=0. - ztla(:,:)=0. - zqta(:,:)=0. - zha(:,:) =0. -endif - - zqla_est(:,:)=0. - zqsatth(:,:)=0. - zqla(:,:)=0. - detr_star(:,:)=0. - entr_star(:,:)=0. - alim_star(:,:)=0. - alim_star_tot(:)=0. - csc(:,:)=0. - detr(:,:)=0. - entr(:,:)=0. - zw2(:,:)=0. - zbuoy(:,:)=0. - zbuoyjam(:,:)=0. - gamma(:,:)=0. - zeps(:,:)=0. - w_est(:,:)=0. - f_star(:,:)=0. - wa_moy(:,:)=0. - linter(:)=1. -! linter(:)=1. -! Initialisation des variables entieres - lmix(:)=1 - lmix_bis(:)=2 - wmaxa(:)=0. - - -!------------------------------------------------------------------------- -! On ne considere comme actif que les colonnes dont les deux premieres -! couches sont instables. -!------------------------------------------------------------------------- - - active(:)=ztv(:,1)>ztv(:,2) - d_temp(:)=0. ! Pour activer un contraste de temperature a la base - ! du panache -! Cet appel pourrait être fait avant thermcell_plume dans thermcell_main - CALL thermcell_alim(thermals_flag_alim,ngrid,nlay,ztv,d_temp,zlev,alim_star,lalim) - -!------------------------------------------------------------------------------ -! Calcul dans la premiere couche -! On decide dans cette version que le thermique n'est actif que si la premiere -! couche est instable. -! Pourrait etre change si on veut que le thermiques puisse se d??clencher -! dans une couche l>1 -!------------------------------------------------------------------------------ -do ig=1,ngrid -! Le panache va prendre au debut les caracteristiques de l'air contenu -! dans cette couche. - if (active(ig)) then - ztla(ig,1)=zthl(ig,1) - zqta(ig,1)=po(ig,1) - zqla(ig,1)=zl(ig,1) -!cr: attention, prise en compte de f*(1)=1 - f_star(ig,2)=alim_star(ig,1) - zw2(ig,2)=2.*RG*(ztv(ig,1)-ztv(ig,2))/ztv(ig,2) & -& *(zlev(ig,2)-zlev(ig,1)) & -& *0.4*pphi(ig,1)/(pphi(ig,2)-pphi(ig,1)) - w_est(ig,2)=zw2(ig,2) - endif -enddo -! - -!============================================================================== -!boucle de calcul de la vitesse verticale dans le thermique -!============================================================================== -do l=2,nlay-1 -!============================================================================== - - -! On decide si le thermique est encore actif ou non -! AFaire : Il faut sans doute ajouter entr_star a alim_star dans ce test - do ig=1,ngrid - active(ig)=active(ig) & -& .and. zw2(ig,l)>1.e-10 & -& .and. f_star(ig,l)+alim_star(ig,l)>1.e-10 - enddo - - - -!--------------------------------------------------------------------------- -! calcul des proprietes thermodynamiques et de la vitesse de la couche l -! sans tenir compte du detrainement et de l'entrainement dans cette -! couche -! C'est a dire qu'on suppose -! ztla(l)=ztla(l-1) et zqta(l)=zqta(l-1) -! Ici encore, on doit pouvoir ajouter entr_star (qui peut etre calculer -! avant) a l'alimentation pour avoir un calcul plus propre -!--------------------------------------------------------------------------- - - ztemp(:)=zpspsk(:,l)*ztla(:,l-1) - call thermcell_qsat(ngrid,active,pplev(:,l),ztemp,zqta(:,l-1),zqsat(:)) - do ig=1,ngrid -! print*,'active',active(ig),ig,l - if(active(ig)) then - zqla_est(ig,l)=max(0.,zqta(ig,l-1)-zqsat(ig)) - ztva_est(ig,l) = ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*zqla_est(ig,l) - zta_est(ig,l)=ztva_est(ig,l) - ztva_est(ig,l) = ztva_est(ig,l)/zpspsk(ig,l) - ztva_est(ig,l) = ztva_est(ig,l)*(1.+RETV*(zqta(ig,l-1) & - & -zqla_est(ig,l))-zqla_est(ig,l)) - - -!Modif AJAM - - zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) - zdz=zlev(ig,l+1)-zlev(ig,l) - lmel=fact_thermals_ed_dz*zlev(ig,l) -! lmel=0.09*zlev(ig,l) - zlmel=zlev(ig,l)+lmel - zlmelup=zlmel+(zdz/2) - zlmeldwn=zlmel-(zdz/2) - - lt=l+1 - zlt=zlev(ig,lt) - zdz3=zlev(ig,lt+1)-zlt - zltdwn=zlt-zdz3/2 - zltup=zlt+zdz3/2 - -!========================================================================= -! 3. Calcul de la flotabilite modifie par melange avec l'air au dessus -!========================================================================= - -!-------------------------------------------------- - lt=l+1 - zlt=zlev(ig,lt) - zdz2=zlev(ig,lt)-zlev(ig,l) - - do while (lmel.gt.zdz2) - lt=lt+1 - zlt=zlev(ig,lt) - zdz2=zlt-zlev(ig,l) - enddo - zdz3=zlev(ig,lt+1)-zlt - zltdwn=zlev(ig,lt)-zdz3/2 - zlmelup=zlmel+(zdz/2) - coefzlmel=Min(1.,(zlmelup-zltdwn)/zdz) - zbuoyjam(ig,l)=1.*RG*(coefzlmel*(ztva_est(ig,l)- & - & ztv(ig,lt))/ztv(ig,lt)+(1.-coefzlmel)*(ztva_est(ig,l)- & - & ztv(ig,lt-1))/ztv(ig,lt-1))+0.*zbuoy(ig,l) - -!------------------------------------------------ -!AJAM:nouveau calcul de w? -!------------------------------------------------ - zdz=zlev(ig,l+1)-zlev(ig,l) - zdzbis=zlev(ig,l)-zlev(ig,l-1) - zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) - zw2fact=fact_epsilon*2.*zdz/(1.+betalpha) - zw2factbis=fact_epsilon*2.*zdzbis/(1.+betalpha) - zdw2=afact*zbuoy(ig,l)/fact_epsilon - zdw2bis=afact*zbuoy(ig,l-1)/fact_epsilon - lm=Max(1,l-2) - w_est(ig,l+1)=Max(0.0001,exp(-zw2fact)*(w_est(ig,l)-zdw2)+zdw2) - endif - enddo - - -!------------------------------------------------- -!calcul des taux d'entrainement et de detrainement -!------------------------------------------------- - - do ig=1,ngrid - if (active(ig)) then - -! zw2m=max(0.5*(w_est(ig,l)+w_est(ig,l+1)),0.1) - zw2m=w_est(ig,l+1) - zdz=zlev(ig,l+1)-zlev(ig,l) - zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) - zalpha=f0(ig)*f_star(ig,l)/sqrt(w_est(ig,l+1))/rhobarz(ig,l) - zdqt(ig,l)=max(zqta(ig,l-1)-po(ig,l),0.)/po(ig,l) - -!========================================================================= -! 4. Calcul de l'entrainement et du detrainement -!========================================================================= - - detr_star(ig,l)=f_star(ig,l)*zdz & - & *( mix0 * 0.1 / (zalpha+0.001) & - & + MAX(detr_min, -afact*zbetalpha*zbuoyjam(ig,l)/zw2m & - & + detr_q_coef*(zdqt(ig,l)/zw2m)**detr_q_power)) - - if ( iflag_thermals_ed == 20 ) then - entr_star(ig,l)=f_star(ig,l)*zdz* ( & - & mix0 * 0.1 / (zalpha+0.001) & - & + zbetalpha*MAX(entr_min, & - & afact*zbuoyjam(ig,l)/zw2m - fact_epsilon)) - else - entr_star(ig,l)=f_star(ig,l)*zdz* ( & - & mix0 * 0.1 / (zalpha+0.001) & - & + zbetalpha*MAX(entr_min, & - & afact*zbuoy(ig,l)/zw2m - fact_epsilon)) - endif - -! En dessous de lalim, on prend le max de alim_star et entr_star pour -! alim_star et 0 sinon - if (l.lt.lalim(ig)) then - alim_star(ig,l)=max(alim_star(ig,l),entr_star(ig,l)) - entr_star(ig,l)=0. - endif - f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l) & - & -detr_star(ig,l) - - endif - enddo - - -!============================================================================ -! 5. calcul de la vitesse verticale en melangeant Tl et qt du thermique -!=========================================================================== - - activetmp(:)=active(:) .and. f_star(:,l+1)>1.e-10 - do ig=1,ngrid - if (activetmp(ig)) then - Zsat=.false. - ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+ & - & (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l)) & - & /(f_star(ig,l+1)+detr_star(ig,l)) - zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+ & - & (alim_star(ig,l)+entr_star(ig,l))*po(ig,l)) & - & /(f_star(ig,l+1)+detr_star(ig,l)) - - endif - enddo - - ztemp(:)=zpspsk(:,l)*ztla(:,l) - call thermcell_qsat(ngrid,activetmp,pplev(:,l),ztemp,zqta(:,l),zqsatth(:,l)) - do ig=1,ngrid - if (activetmp(ig)) then -! on ecrit de maniere conservative (sat ou non) -! T = Tl +Lv/Cp ql - zqla(ig,l)=max(0.,zqta(ig,l)-zqsatth(ig,l)) - ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l) - ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l) -!on rajoute le calcul de zha pour diagnostiques (temp potentielle) - zha(ig,l) = ztva(ig,l) - ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) & - & -zqla(ig,l))-zqla(ig,l)) - zbuoy(ig,l)=RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) - zdz=zlev(ig,l+1)-zlev(ig,l) - zdzbis=zlev(ig,l)-zlev(ig,l-1) - zeps(ig,l)=(entr_star(ig,l)+alim_star(ig,l))/(f_star(ig,l)*zdz) - zw2fact=fact_epsilon*2.*zdz/(1.+betalpha) - zw2factbis=fact_epsilon*2.*zdzbis/(1.+betalpha) - zdw2= afact*zbuoy(ig,l)/(fact_epsilon) - zdw2bis= afact*zbuoy(ig,l-1)/(fact_epsilon) - zw2(ig,l+1)=Max(0.0001,exp(-zw2fact)*(zw2(ig,l)-zdw2)+zdw2) - endif - enddo - - if (prt_level.ge.20) print*,'coucou calcul detr 460: ig, l',ig, l -! -!=========================================================================== -! 6. initialisations pour le calcul de la hauteur du thermique, de l'inversion et de la vitesse verticale max -!=========================================================================== - - nbpb=0 - do ig=1,ngrid - if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then -! stop'On tombe sur le cas particulier de thermcell_dry' -! print*,'On tombe sur le cas particulier de thermcell_plume' - nbpb=nbpb+1 - zw2(ig,l+1)=0. - linter(ig)=l+1 - endif - - if (zw2(ig,l+1).lt.0.) then - linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) & - & -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) - zw2(ig,l+1)=0. -!+CR:04/05/12:correction calcul linter pour calcul de zmax continu - elseif (f_star(ig,l+1).lt.0.) then - linter(ig)=(l*(f_star(ig,l+1)-f_star(ig,l)) & - & -f_star(ig,l))/(f_star(ig,l+1)-f_star(ig,l)) - zw2(ig,l+1)=0. -!fin CR:04/05/12 - endif - - wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) - - if (wa_moy(ig,l+1).gt.wmaxa(ig)) then -! lmix est le niveau de la couche ou w (wa_moy) est maximum -!on rajoute le calcul de lmix_bis - if (zqla(ig,l).lt.1.e-10) then - lmix_bis(ig)=l+1 - endif - lmix(ig)=l+1 - wmaxa(ig)=wa_moy(ig,l+1) - endif - enddo - - if (nbpb>0) then - print*,'WARNING on tombe ',nbpb,' x sur un pb pour l=',l,' dans thermcell_plume' - endif - -!========================================================================= -! FIN DE LA BOUCLE VERTICALE - enddo -!========================================================================= - -!on recalcule alim_star_tot - do ig=1,ngrid - alim_star_tot(ig)=0. - enddo - do ig=1,ngrid - do l=1,lalim(ig)-1 - alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l) - enddo - enddo - - - if (prt_level.ge.20) print*,'coucou calcul detr 470: ig, l', ig, l - -#undef wrgrads_thermcell -#ifdef wrgrads_thermcell - call wrgradsfi(1,nlay,entr_star(igout,1:nlay),'esta ','esta ') - call wrgradsfi(1,nlay,detr_star(igout,1:nlay),'dsta ','dsta ') - call wrgradsfi(1,nlay,zbuoy(igout,1:nlay),'buoy ','buoy ') - call wrgradsfi(1,nlay,zdqt(igout,1:nlay),'dqt ','dqt ') - call wrgradsfi(1,nlay,w_est(igout,1:nlay),'w_est ','w_est ') - call wrgradsfi(1,nlay,w_est(igout,2:nlay+1),'w_es2 ','w_es2 ') - call wrgradsfi(1,nlay,zw2(igout,1:nlay),'zw2A ','zw2A ') -#endif - - - RETURN - end Index: LMDZ6/trunk/libf/phylmd/thermcell_plume_6A.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/thermcell_plume_6A.F90 (revision 4589) +++ (revision ) @@ -1,1110 +1,0 @@ -! -! $Id$ -! - SUBROUTINE thermcell_plume_6A(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz, & - & zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, & - & lalim,f0,detr_star,entr_star,f_star,csc,ztva, & - & ztla,zqla,zqta,zha,zw2,w_est,ztva_est,zqsatth,lmix,lmix_bis,linter & - & ,lev_out,lunout1,igout) -! & ,lev_out,lunout1,igout,zbuoy,zbuoyjam) -!-------------------------------------------------------------------------- -!thermcell_plume: calcule les valeurs de qt, thetal et w dans l ascendance -!-------------------------------------------------------------------------- - - USE thermcell_ini_mod, ONLY: prt_level,fact_thermals_ed_dz,iflag_thermals_ed,RLvCP,RETV,RG - USE thermcell_ini_mod, ONLY: fact_epsilon, betalpha, afact, fact_shell - USE thermcell_ini_mod, ONLY: detr_min, entr_min, detr_q_coef, detr_q_power - USE thermcell_ini_mod, ONLY: mix0, thermals_flag_alim - - IMPLICIT NONE - - integer,intent(in) :: itap,lev_out,lunout1,igout,ngrid,nlay - real,intent(in) :: ptimestep - real,intent(in),dimension(ngrid,nlay) :: ztv - real,intent(in),dimension(ngrid,nlay) :: zthl - real,intent(in),dimension(ngrid,nlay) :: po - real,intent(in),dimension(ngrid,nlay) :: zl - real,intent(in),dimension(ngrid,nlay) :: rhobarz - real,intent(in),dimension(ngrid,nlay+1) :: zlev - real,intent(in),dimension(ngrid,nlay+1) :: pplev - real,intent(in),dimension(ngrid,nlay) :: pphi - real,intent(in),dimension(ngrid,nlay) :: zpspsk - real,intent(in),dimension(ngrid) :: f0 - - integer,intent(out) :: lalim(ngrid) - real,intent(out),dimension(ngrid,nlay) :: alim_star - real,intent(out),dimension(ngrid) :: alim_star_tot - real,intent(out),dimension(ngrid,nlay) :: detr_star - real,intent(out),dimension(ngrid,nlay) :: entr_star - real,intent(out),dimension(ngrid,nlay+1) :: f_star - real,intent(out),dimension(ngrid,nlay) :: csc - real,intent(out),dimension(ngrid,nlay) :: ztva - real,intent(out),dimension(ngrid,nlay) :: ztla - real,intent(out),dimension(ngrid,nlay) :: zqla - real,intent(out),dimension(ngrid,nlay) :: zqta - real,intent(out),dimension(ngrid,nlay) :: zha - real,intent(out),dimension(ngrid,nlay+1) :: zw2 - real,intent(out),dimension(ngrid,nlay+1) :: w_est - real,intent(out),dimension(ngrid,nlay) :: ztva_est - real,intent(out),dimension(ngrid,nlay) :: zqsatth - integer,intent(out),dimension(ngrid) :: lmix - integer,intent(out),dimension(ngrid) :: lmix_bis - real,intent(out),dimension(ngrid) :: linter - - REAL zdw2,zdw2bis - REAL zw2modif - REAL zw2fact,zw2factbis - REAL,dimension(ngrid,nlay) :: zeps - - REAL, dimension(ngrid) :: wmaxa(ngrid) - - INTEGER ig,l,k,lt,it,lm - integer nbpb - - real,dimension(ngrid,nlay) :: detr - real,dimension(ngrid,nlay) :: entr - real,dimension(ngrid,nlay+1) :: wa_moy - real,dimension(ngrid,nlay) :: ztv_est - real,dimension(ngrid) :: ztemp,zqsat - real,dimension(ngrid,nlay) :: zqla_est - real,dimension(ngrid,nlay) :: zta_est - - real,dimension(ngrid,nlay) :: zbuoy,gamma,zdqt - real zdz,zalpha,zw2m - real,dimension(ngrid,nlay) :: zbuoyjam,zdqtjam - real zbuoybis,zdz2,zdz3,lmel,entrbis,zdzbis - real, dimension(ngrid) :: d_temp - real ztv1,ztv2,factinv,zinv,zlmel - real zlmelup,zlmeldwn,zlt,zltdwn,zltup - real atv1,atv2,btv1,btv2 - real ztv_est1,ztv_est2 - real zcor,zdelta,zcvm5,qlbef - real zbetalpha, coefzlmel - real eps - logical Zsat - LOGICAL,dimension(ngrid) :: active,activetmp - REAL fact_gamma,fact_gamma2,fact_epsilon2 - REAL coefc - REAL,dimension(ngrid,nlay) :: c2 - - if (ngrid==1) print*,'THERMCELL PLUME MODIFIE 2014/07/11' - Zsat=.false. -! Initialisation - - - zbetalpha=betalpha/(1.+betalpha) - - -! Initialisations des variables r?elles -if (1==1) then - ztva(:,:)=ztv(:,:) - ztva_est(:,:)=ztva(:,:) - ztv_est(:,:)=ztv(:,:) - ztla(:,:)=zthl(:,:) - zqta(:,:)=po(:,:) - zqla(:,:)=0. - zha(:,:) = ztva(:,:) -else - ztva(:,:)=0. - ztv_est(:,:)=0. - ztva_est(:,:)=0. - ztla(:,:)=0. - zqta(:,:)=0. - zha(:,:) =0. -endif - - zqla_est(:,:)=0. - zqsatth(:,:)=0. - zqla(:,:)=0. - detr_star(:,:)=0. - entr_star(:,:)=0. - alim_star(:,:)=0. - alim_star_tot(:)=0. - csc(:,:)=0. - detr(:,:)=0. - entr(:,:)=0. - zw2(:,:)=0. - zbuoy(:,:)=0. - zbuoyjam(:,:)=0. - gamma(:,:)=0. - zeps(:,:)=0. - w_est(:,:)=0. - f_star(:,:)=0. - wa_moy(:,:)=0. - linter(:)=1. -! linter(:)=1. -! Initialisation des variables entieres - lmix(:)=1 - lmix_bis(:)=2 - wmaxa(:)=0. - -! Initialisation a 0 en cas de sortie dans replay - zqsat(:)=0. - zta_est(:,:)=0. - zdqt(:,:)=0. - zdqtjam(:,:)=0. - c2(:,:)=0. - - -!------------------------------------------------------------------------- -! On ne considere comme actif que les colonnes dont les deux premieres -! couches sont instables. -!------------------------------------------------------------------------- - - active(:)=ztv(:,1)>ztv(:,2) - d_temp(:)=0. ! Pour activer un contraste de temperature a la base - ! du panache -! Cet appel pourrait être fait avant thermcell_plume dans thermcell_main - CALL thermcell_alim(thermals_flag_alim,ngrid,nlay,ztv,d_temp,zlev,alim_star,lalim) - -!------------------------------------------------------------------------------ -! Calcul dans la premiere couche -! On decide dans cette version que le thermique n'est actif que si la premiere -! couche est instable. -! Pourrait etre change si on veut que le thermiques puisse se d??clencher -! dans une couche l>1 -!------------------------------------------------------------------------------ -do ig=1,ngrid -! Le panache va prendre au debut les caracteristiques de l'air contenu -! dans cette couche. - if (active(ig)) then - ztla(ig,1)=zthl(ig,1) - zqta(ig,1)=po(ig,1) - zqla(ig,1)=zl(ig,1) -!cr: attention, prise en compte de f*(1)=1 - f_star(ig,2)=alim_star(ig,1) - zw2(ig,2)=2.*RG*(ztv(ig,1)-ztv(ig,2))/ztv(ig,2) & -& *(zlev(ig,2)-zlev(ig,1)) & -& *0.4*pphi(ig,1)/(pphi(ig,2)-pphi(ig,1)) - w_est(ig,2)=zw2(ig,2) - endif -enddo -! - -!============================================================================== -!boucle de calcul de la vitesse verticale dans le thermique -!============================================================================== -do l=2,nlay-1 -!============================================================================== - - -! On decide si le thermique est encore actif ou non -! AFaire : Il faut sans doute ajouter entr_star a alim_star dans ce test - do ig=1,ngrid - active(ig)=active(ig) & -& .and. zw2(ig,l)>1.e-10 & -& .and. f_star(ig,l)+alim_star(ig,l)>1.e-10 - enddo - - - -!--------------------------------------------------------------------------- -! calcul des proprietes thermodynamiques et de la vitesse de la couche l -! sans tenir compte du detrainement et de l'entrainement dans cette -! couche -! C'est a dire qu'on suppose -! ztla(l)=ztla(l-1) et zqta(l)=zqta(l-1) -! Ici encore, on doit pouvoir ajouter entr_star (qui peut etre calculer -! avant) a l'alimentation pour avoir un calcul plus propre -!--------------------------------------------------------------------------- - - ztemp(:)=zpspsk(:,l)*ztla(:,l-1) - call thermcell_qsat(ngrid,active,pplev(:,l),ztemp,zqta(:,l-1),zqsat(:)) - do ig=1,ngrid -! print*,'active',active(ig),ig,l - if(active(ig)) then - zqla_est(ig,l)=max(0.,zqta(ig,l-1)-zqsat(ig)) - ztva_est(ig,l) = ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*zqla_est(ig,l) - zta_est(ig,l)=ztva_est(ig,l) - ztva_est(ig,l) = ztva_est(ig,l)/zpspsk(ig,l) - ztva_est(ig,l) = ztva_est(ig,l)*(1.+RETV*(zqta(ig,l-1) & - & -zqla_est(ig,l))-zqla_est(ig,l)) - - -!Modif AJAM - - zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) - zdz=zlev(ig,l+1)-zlev(ig,l) - lmel=fact_thermals_ed_dz*zlev(ig,l) -! lmel=0.09*zlev(ig,l) - zlmel=zlev(ig,l)+lmel - zlmelup=zlmel+(zdz/2) - zlmeldwn=zlmel-(zdz/2) - - lt=l+1 - zlt=zlev(ig,lt) - zdz3=zlev(ig,lt+1)-zlt - zltdwn=zlt-zdz3/2 - zltup=zlt+zdz3/2 - -!========================================================================= -! 3. Calcul de la flotabilite modifie par melange avec l'air au dessus -!========================================================================= - -!-------------------------------------------------- - if (iflag_thermals_ed.lt.8) then -!-------------------------------------------------- -!AJ052014: J'ai remplac?? la boucle do par un do while -! afin de faire moins de calcul dans la boucle -!-------------------------------------------------- - do while (zlmelup.gt.zltup) - lt=lt+1 - zlt=zlev(ig,lt) - zdz3=zlev(ig,lt+1)-zlt - zltdwn=zlt-zdz3/2 - zltup=zlt+zdz3/2 - enddo -!-------------------------------------------------- -!AJ052014: Si iflag_thermals_ed<8 (par ex 6), alors -! on cherche o?? se trouve l'altitude d'inversion -! en calculant ztv1 (interpolation de la valeur de -! theta au niveau lt en utilisant les niveaux lt-1 et -! lt-2) et ztv2 (interpolation avec les niveaux lt+1 -! et lt+2). Si theta r??ellement calcul??e au niveau lt -! comprise entre ztv1 et ztv2, alors il y a inversion -! et on calcule son altitude zinv en supposant que ztv(lt) -! est une combinaison lineaire de ztv1 et ztv2. -! Ensuite, on calcule la flottabilite en comparant -! la temperature de la couche l a celle de l'air situe -! l+lmel plus haut, ce qui necessite de savoir quel fraction -! de cet air est au-dessus ou en-dessous de l'inversion -!-------------------------------------------------- - atv1=(ztv(ig,lt-1)-ztv(ig,lt-2))/(zlev(ig,lt-1)-zlev(ig,lt-2)) - btv1=(ztv(ig,lt-2)*zlev(ig,lt-1)-ztv(ig,lt-1)*zlev(ig,lt-2)) & - & /(zlev(ig,lt-1)-zlev(ig,lt-2)) - atv2=(ztv(ig,lt+2)-ztv(ig,lt+1))/(zlev(ig,lt+2)-zlev(ig,lt+1)) - btv2=(ztv(ig,lt+1)*zlev(ig,lt+2)-ztv(ig,lt+2)*zlev(ig,lt+1)) & - & /(zlev(ig,lt+2)-zlev(ig,lt+1)) - - ztv1=atv1*zlt+btv1 - ztv2=atv2*zlt+btv2 - - if (ztv(ig,lt).gt.ztv1.and.ztv(ig,lt).lt.ztv2) then - -!-------------------------------------------------- -!AJ052014: D??calage de zinv qui est entre le haut -! et le bas de la couche lt -!-------------------------------------------------- - factinv=(ztv2-ztv(ig,lt))/(ztv2-ztv1) - zinv=zltdwn+zdz3*factinv - - - if (zlmeldwn.ge.zinv) then - ztv_est(ig,l)=atv2*zlmel+btv2 - zbuoyjam(ig,l)=fact_shell*RG*(ztva_est(ig,l)-ztv_est(ig,l))/ztv_est(ig,l) & - & +(1.-fact_shell)*zbuoy(ig,l) - elseif (zlmelup.ge.zinv) then - ztv_est2=atv2*0.5*(zlmelup+zinv)+btv2 - ztv_est1=atv1*0.5*(zinv+zlmeldwn)+btv1 - ztv_est(ig,l)=((zlmelup-zinv)/zdz)*ztv_est2+((zinv-zlmeldwn)/zdz)*ztv_est1 - - zbuoyjam(ig,l)=fact_shell*RG*(((zlmelup-zinv)/zdz)*(ztva_est(ig,l)- & - & ztv_est2)/ztv_est2+((zinv-zlmeldwn)/zdz)*(ztva_est(ig,l)- & - & ztv_est1)/ztv_est1)+(1.-fact_shell)*zbuoy(ig,l) - - else - ztv_est(ig,l)=atv1*zlmel+btv1 - zbuoyjam(ig,l)=fact_shell*RG*(ztva_est(ig,l)-ztv_est(ig,l))/ztv_est(ig,l) & - & +(1.-fact_shell)*zbuoy(ig,l) - endif - - else ! if (ztv(ig,lt).gt.ztv1.and.ztv(ig,lt).lt.ztv2) then - - if (zlmeldwn.gt.zltdwn) then - zbuoyjam(ig,l)=fact_shell*RG*((ztva_est(ig,l)- & - & ztv(ig,lt))/ztv(ig,lt))+(1.-fact_shell)*zbuoy(ig,l) - else - zbuoyjam(ig,l)=fact_shell*RG*(((zlmelup-zltdwn)/zdz)*(ztva_est(ig,l)- & - & ztv(ig,lt))/ztv(ig,lt)+((zltdwn-zlmeldwn)/zdz)*(ztva_est(ig,l)- & - & ztv(ig,lt-1))/ztv(ig,lt-1))+(1.-fact_shell)*zbuoy(ig,l) - - endif - -! zbuoyjam(ig,l)=fact_shell*RG*(((zlmelup-zltdwn)/zdz)*(ztva_est(ig,l)- & -! & ztv1)/ztv1+((zltdwn-zlmeldwn)/zdz)*(ztva_est(ig,l)- & -! & ztv(ig,lt-1))/ztv(ig,lt-1))+(1.-fact_shell)*zbuoy(ig,l) -! zdqt(ig,l)=Max(0.,((lmel+zdz3-zdz2)/zdz3)*(zqta(ig,l-1)- & -! & po(ig,lt))/po(ig,lt)+((zdz2-lmel)/zdz3)*(zqta(ig,l-1)- & -! & po(ig,lt-1))/po(ig,lt-1)) - endif ! if (ztv(ig,lt).gt.ztv1.and.ztv(ig,lt).lt.ztv2) then - - else ! if (iflag_thermals_ed.lt.8) then - lt=l+1 - zlt=zlev(ig,lt) - zdz2=zlev(ig,lt)-zlev(ig,l) - - do while (lmel.gt.zdz2) - lt=lt+1 - zlt=zlev(ig,lt) - zdz2=zlt-zlev(ig,l) - enddo - zdz3=zlev(ig,lt+1)-zlt - zltdwn=zlev(ig,lt)-zdz3/2 - zlmelup=zlmel+(zdz/2) - coefzlmel=Min(1.,(zlmelup-zltdwn)/zdz) - zbuoyjam(ig,l)=1.*RG*(coefzlmel*(ztva_est(ig,l)- & - & ztv(ig,lt))/ztv(ig,lt)+(1.-coefzlmel)*(ztva_est(ig,l)- & - & ztv(ig,lt-1))/ztv(ig,lt-1))+0.*zbuoy(ig,l) - endif ! if (iflag_thermals_ed.lt.8) then - -!------------------------------------------------ -!AJAM:nouveau calcul de w? -!------------------------------------------------ - zdz=zlev(ig,l+1)-zlev(ig,l) - zdzbis=zlev(ig,l)-zlev(ig,l-1) - zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) - - zw2fact=fact_epsilon*2.*zdz/(1.+betalpha) - zw2factbis=fact_epsilon*2.*zdzbis/(1.+betalpha) - zdw2=afact*zbuoy(ig,l)/fact_epsilon - zdw2bis=afact*zbuoy(ig,l-1)/fact_epsilon -! zdw2bis=0.5*(zdw2+zdw2bis) - lm=Max(1,l-2) -! zdw2=(afact/fact_epsilon)*((zdz/zdzbis)*zbuoy(ig,l) & -! & +((zdzbis-zdz)/zdzbis)*zbuoy(ig,l-1)) -! zdw2bis=(afact/fact_epsilon)*((zdz/zdzbis)*zbuoy(ig,l-1) & -! & +((zdzbis-zdz)/zdzbis)*zbuoy(ig,l-1)) -! w_est(ig,l+1)=Max(0.0001,exp(-zw2fact)*(w_est(ig,l)-zdw2)+zdw2) -! w_est(ig,l+1)=(zdz/zdzbis)*Max(0.0001,exp(-zw2fact)* & -! & (w_est(ig,l)-zdw2)+zdw2)+(zdzbis-zdz)/zdzbis* & -! & Max(0.0001,exp(-zw2factbis)*(w_est(ig,l-1)-zdw2bis)+zdw2) -! w_est(ig,l+1)=Max(0.0001,(1-exp(-zw2fact))*zdw2+w_est(ig,l)*exp(-zw2fact)) - -!-------------------------------------------------- -!AJ052014: J'ai remplac? w_est(ig,l) par zw2(ig,l) -!-------------------------------------------------- - if (iflag_thermals_ed==8) then -! Ancienne version -! w_est(ig,l+1)=Max(0.0001,(zdz/zdzbis)*(exp(-zw2fact)* & -! & (w_est(ig,l)-zdw2)+zdw2)+(zdzbis-zdz)/zdzbis* & -! & (exp(-zw2factbis)*(w_est(ig,l-1)-zdw2bis)+zdw2)) - - w_est(ig,l+1)=Max(0.0001,exp(-zw2fact)*(w_est(ig,l)-zdw2)+zdw2) - -! Nouvelle version Arnaud - else -! w_est(ig,l+1)=Max(0.0001,(zdz/zdzbis)*(exp(-zw2fact)* & -! & (w_est(ig,l)-zdw2)+zdw2)+(zdzbis-zdz)/zdzbis* & -! & (exp(-zw2factbis)*(w_est(ig,l-1)-zdw2bis)+zdw2)) - - w_est(ig,l+1)=Max(0.0001,exp(-zw2fact)*(w_est(ig,l)-zdw2bis)+zdw2) - -! w_est(ig,l+1)=Max(0.0001,(zdz/(zdzbis+zdz))*(exp(-zw2fact)* & -! & (w_est(ig,l)-zdw2bis)+zdw2)+(zdzbis/(zdzbis+zdz))* & -! & (exp(-zw2factbis)*(w_est(ig,l-1)-zdw2bis)+zdw2bis)) - - - -! w_est(ig,l+1)=Max(0.0001,(w_est(ig,l)+zdw2bis*zw2fact)*exp(-zw2fact)) - -! w_est(ig,l+1)=Max(0.0001,(zdz/zdzbis)*(zw2(ig,l)+zdw2*zw2fact)*exp(-zw2fact)+ & -! & (zdzbis-zdz)/zdzbis*(zw2(ig,l-1)+zdw2bis*zw2factbis)*exp(-zw2factbis)) - -! w_est(ig,l+1)=Max(0.0001,exp(-zw2factbis)*(w_est(ig,l-1)-zdw2bis)+zdw2) - - endif - - - if (iflag_thermals_ed<6) then - zalpha=f0(ig)*f_star(ig,l)/sqrt(w_est(ig,l+1))/rhobarz(ig,l) -! fact_epsilon=0.0005/(zalpha+0.025)**0.5 -! fact_epsilon=Min(0.003,0.0004/(zalpha)**0.5) - fact_epsilon=0.0002/(zalpha+0.1) - zw2fact=fact_epsilon*2.*zdz/(1.+betalpha) - zw2factbis=fact_epsilon*2.*zdzbis/(1.+betalpha) - zdw2=afact*zbuoy(ig,l)/fact_epsilon - zdw2bis=afact*zbuoy(ig,l-1)/fact_epsilon -! w_est(ig,l+1)=Max(0.0001,(zw2(ig,l)+zdw2*zw2fact)*exp(-zw2fact)) - -! w_est(ig,l+1)=Max(0.0001,(zdz/zdzbis)*(exp(-zw2fact)* & -! & (zw2(ig,l)-zdw2)+zdw2)+(zdzbis-zdz)/zdzbis* & -! & (exp(-zw2factbis)*(zw2(ig,l-1)-zdw2bis)+zdw2)) - - w_est(ig,l+1)=Max(0.0001,exp(-zw2fact)*(w_est(ig,l)-zdw2bis)+zdw2) - - - endif -!-------------------------------------------------- -!AJ052014: J'ai comment? ce if plus n?cessaire puisqu' -!on fait max(0.0001,.....) -!-------------------------------------------------- - -! if (w_est(ig,l+1).lt.0.) then -! w_est(ig,l+1)=zw2(ig,l) -! w_est(ig,l+1)=0.0001 -! endif - - endif - enddo - - -!------------------------------------------------- -!calcul des taux d'entrainement et de detrainement -!------------------------------------------------- - - do ig=1,ngrid - if (active(ig)) then - -! zw2m=max(0.5*(w_est(ig,l)+w_est(ig,l+1)),0.1) - zw2m=w_est(ig,l+1) -! zw2m=zw2(ig,l) - zdz=zlev(ig,l+1)-zlev(ig,l) - zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) -! zbuoybis=zbuoy(ig,l)+RG*0.1/300. - zbuoybis=zbuoy(ig,l) - zalpha=f0(ig)*f_star(ig,l)/sqrt(w_est(ig,l+1))/rhobarz(ig,l) - zdqt(ig,l)=max(zqta(ig,l-1)-po(ig,l),0.)/po(ig,l) - - -! entr_star(ig,l)=f_star(ig,l)*zdz*zbetalpha*MAX(0., & -! & afact*zbuoybis/zw2m - fact_epsilon ) - -! entr_star(ig,l)=MAX(0.,f_star(ig,l)*zdz*zbetalpha* & -! & afact*zbuoybis/zw2m - fact_epsilon ) - - - -! zbuoyjam(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) - -!========================================================================= -! 4. Calcul de l'entrainement et du detrainement -!========================================================================= - -! entr_star(ig,l)=f_star(ig,l)*zdz*zbetalpha*MAX(0., & -! & afact*zbuoyjam(ig,l)/zw2m - fact_epsilon ) -! entrbis=entr_star(ig,l) - - if (iflag_thermals_ed.lt.6) then - fact_epsilon=0.0002/(zalpha+0.1) - endif - - - - detr_star(ig,l)=f_star(ig,l)*zdz & - & *( mix0 * 0.1 / (zalpha+0.001) & - & + MAX(detr_min, -afact*zbetalpha*zbuoyjam(ig,l)/zw2m & - & + detr_q_coef*(zdqt(ig,l)/zw2m)**detr_q_power)) - -! detr_star(ig,l)=(zdz/zdzbis)*detr_star(ig,l)+ & -! & ((zdzbis-zdz)/zdzbis)*detr_star(ig,l-1) - - zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) - - entr_star(ig,l)=f_star(ig,l)*zdz* ( & - & mix0 * 0.1 / (zalpha+0.001) & - & + zbetalpha*MAX(entr_min, & - & afact*zbuoyjam(ig,l)/zw2m - fact_epsilon)) - - -! entr_star(ig,l)=f_star(ig,l)*zdz* ( & -! & mix0 * 0.1 / (zalpha+0.001) & -! & + MAX(entr_min, & -! & zbetalpha*afact*zbuoyjam(ig,l)/zw2m - fact_epsilon + & -! & detr_q_coef*(zdqt(ig,l)/zw2m)**detr_q_power)) - - -! entr_star(ig,l)=(zdz/zdzbis)*entr_star(ig,l)+ & -! & ((zdzbis-zdz)/zdzbis)*entr_star(ig,l-1) - -! entr_star(ig,l)=Max(0.,f_star(ig,l)*zdz*zbetalpha* & -! & afact*zbuoy(ig,l)/zw2m & -! & - 1.*fact_epsilon) - - -! En dessous de lalim, on prend le max de alim_star et entr_star pour -! alim_star et 0 sinon - if (l.lt.lalim(ig)) then - alim_star(ig,l)=max(alim_star(ig,l),entr_star(ig,l)) - entr_star(ig,l)=0. - endif -! if (l.lt.lalim(ig).and.alim_star(ig,l)>alim_star(ig,l-1)) then -! alim_star(ig,l)=entrbis -! endif - -! print*,'alim0',zlev(ig,l),entr_star(ig,l),detr_star(ig,l),zw2m,zbuoy(ig,l),f_star(ig,l) -! Calcul du flux montant normalise - f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l) & - & -detr_star(ig,l) - - endif - enddo - - -!============================================================================ -! 5. calcul de la vitesse verticale en melangeant Tl et qt du thermique -!=========================================================================== - - activetmp(:)=active(:) .and. f_star(:,l+1)>1.e-10 - do ig=1,ngrid - if (activetmp(ig)) then - Zsat=.false. - ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+ & - & (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l)) & - & /(f_star(ig,l+1)+detr_star(ig,l)) - zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+ & - & (alim_star(ig,l)+entr_star(ig,l))*po(ig,l)) & - & /(f_star(ig,l+1)+detr_star(ig,l)) - - endif - enddo - - ztemp(:)=zpspsk(:,l)*ztla(:,l) - call thermcell_qsat(ngrid,activetmp,pplev(:,l),ztemp,zqta(:,l),zqsatth(:,l)) - do ig=1,ngrid - if (activetmp(ig)) then -! on ecrit de maniere conservative (sat ou non) -! T = Tl +Lv/Cp ql - zqla(ig,l)=max(0.,zqta(ig,l)-zqsatth(ig,l)) - ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l) - ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l) -!on rajoute le calcul de zha pour diagnostiques (temp potentielle) - zha(ig,l) = ztva(ig,l) - ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) & - & -zqla(ig,l))-zqla(ig,l)) - zbuoy(ig,l)=RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) - zdz=zlev(ig,l+1)-zlev(ig,l) - zdzbis=zlev(ig,l)-zlev(ig,l-1) - zeps(ig,l)=(entr_star(ig,l)+alim_star(ig,l))/(f_star(ig,l)*zdz) -!!!!!!! fact_epsilon=0.002 - zw2fact=fact_epsilon*2.*zdz/(1.+betalpha) - zw2factbis=fact_epsilon*2.*zdzbis/(1.+betalpha) - zdw2= afact*zbuoy(ig,l)/(fact_epsilon) - zdw2bis= afact*zbuoy(ig,l-1)/(fact_epsilon) -! zdw2=(afact/fact_epsilon)*((zdz/zdzbis)*zbuoy(ig,l) & -! & +((zdzbis-zdz)/zdzbis)*zbuoy(ig,l-1)) -! lm=Max(1,l-2) -! zdw2bis=(afact/fact_epsilon)*((zdz/zdzbis)*zbuoy(ig,l-1) & -! & +((zdzbis-zdz)/zdzbis)*zbuoy(ig,l-1)) -! zw2(ig,l+1)=Max(0.0001,exp(-zw2fact)*(zw2(ig,l)-zdw2bis)+zdw2) -! zw2(ig,l+1)=Max(0.0001,(zdz/zdzbis)*(zw2(ig,l)+zdw2*zw2fact)*exp(-zw2fact)+ & -! & (zdzbis-zdz)/zdzbis*(zw2(ig,l-1)+zdw2bis*zw2factbis)*exp(-zw2factbis)) -! zw2(ig,l+1)=Max(0.0001,(zw2(ig,l)+zdw2*zw2fact)*exp(-zw2fact)) -! zw2(ig,l+1)=Max(0.0001,(zdz/zdzbis)*(exp(-zw2fact)* & -! & (zw2(ig,l)-zdw2)+zdw2)+(zdzbis-zdz)/zdzbis* & -! & (exp(-zw2factbis)*(zw2(ig,l-1)-zdw2bis)+zdw2)) - if (iflag_thermals_ed==8) then - zw2(ig,l+1)=Max(0.0001,exp(-zw2fact)*(zw2(ig,l)-zdw2)+zdw2) - else - zw2(ig,l+1)=Max(0.0001,exp(-zw2fact)*(zw2(ig,l)-zdw2bis)+zdw2) - endif -! zw2(ig,l+1)=Max(0.0001,(zdz/(zdz+zdzbis))*(exp(-zw2fact)* & -! & (zw2(ig,l)-zdw2)+zdw2bis)+(zdzbis/(zdz+zdzbis))* & -! & (exp(-zw2factbis)*(zw2(ig,l-1)-zdw2bis)+zdw2bis)) - - - if (iflag_thermals_ed.lt.6) then - zalpha=f0(ig)*f_star(ig,l)/sqrt(zw2(ig,l+1))/rhobarz(ig,l) -! fact_epsilon=0.0005/(zalpha+0.025)**0.5 -! fact_epsilon=Min(0.003,0.0004/(zalpha)**0.5) - fact_epsilon=0.0002/(zalpha+0.1)**1 - zw2fact=fact_epsilon*2.*zdz/(1.+betalpha) - zw2factbis=fact_epsilon*2.*zdzbis/(1.+betalpha) - zdw2= afact*zbuoy(ig,l)/(fact_epsilon) - zdw2bis= afact*zbuoy(ig,l-1)/(fact_epsilon) - -! zw2(ig,l+1)=Max(0.0001,(zdz/zdzbis)*(exp(-zw2fact)* & -! & (zw2(ig,l)-zdw2)+zdw2)+(zdzbis-zdz)/zdzbis* & -! & (exp(-zw2factbis)*(zw2(ig,l-1)-zdw2bis)+zdw2)) -! zw2(ig,l+1)=Max(0.0001,(zw2(ig,l)+zdw2*zw2fact)*exp(-zw2fact)) - zw2(ig,l+1)=Max(0.0001,exp(-zw2fact)*(zw2(ig,l)-zdw2bis)+zdw2) - - endif - - - endif - enddo - - if (prt_level.ge.20) print*,'coucou calcul detr 460: ig, l',ig, l -! -!=========================================================================== -! 6. initialisations pour le calcul de la hauteur du thermique, de l'inversion et de la vitesse verticale max -!=========================================================================== - - nbpb=0 - do ig=1,ngrid - if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then -! stop'On tombe sur le cas particulier de thermcell_dry' -! print*,'On tombe sur le cas particulier de thermcell_plume' - nbpb=nbpb+1 - zw2(ig,l+1)=0. - linter(ig)=l+1 - endif - - if (zw2(ig,l+1).lt.0.) then - linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) & - & -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) - zw2(ig,l+1)=0. -!+CR:04/05/12:correction calcul linter pour calcul de zmax continu - elseif (f_star(ig,l+1).lt.0.) then - linter(ig)=(l*(f_star(ig,l+1)-f_star(ig,l)) & - & -f_star(ig,l))/(f_star(ig,l+1)-f_star(ig,l)) - zw2(ig,l+1)=0. -!fin CR:04/05/12 - endif - - wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) - - if (wa_moy(ig,l+1).gt.wmaxa(ig)) then -! lmix est le niveau de la couche ou w (wa_moy) est maximum -!on rajoute le calcul de lmix_bis - if (zqla(ig,l).lt.1.e-10) then - lmix_bis(ig)=l+1 - endif - lmix(ig)=l+1 - wmaxa(ig)=wa_moy(ig,l+1) - endif - enddo - - if (nbpb>0) then - print*,'WARNING on tombe ',nbpb,' x sur un pb pour l=',l,' dans thermcell_plume' - endif - -!========================================================================= -! FIN DE LA BOUCLE VERTICALE - enddo -!========================================================================= - -!on recalcule alim_star_tot - do ig=1,ngrid - alim_star_tot(ig)=0. - enddo - do ig=1,ngrid - do l=1,lalim(ig)-1 - alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l) - enddo - enddo - - - if (prt_level.ge.20) print*,'coucou calcul detr 470: ig, l', ig, l - -#undef wrgrads_thermcell -#ifdef wrgrads_thermcell - call wrgradsfi(1,nlay,entr_star(igout,1:nlay),'esta ','esta ') - call wrgradsfi(1,nlay,detr_star(igout,1:nlay),'dsta ','dsta ') - call wrgradsfi(1,nlay,zbuoy(igout,1:nlay),'buoy ','buoy ') - call wrgradsfi(1,nlay,zdqt(igout,1:nlay),'dqt ','dqt ') - call wrgradsfi(1,nlay,w_est(igout,1:nlay),'w_est ','w_est ') - call wrgradsfi(1,nlay,w_est(igout,2:nlay+1),'w_es2 ','w_es2 ') - call wrgradsfi(1,nlay,zw2(igout,1:nlay),'zw2A ','zw2A ') -#endif - - - RETURN - end - - - - - - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - SUBROUTINE thermcell_plume_5B(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz, & -& zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, & -& lalim,f0,detr_star,entr_star,f_star,csc,ztva, & -& ztla,zqla,zqta,zha,zw2,w_est,ztva_est,zqsatth,lmix,lmix_bis,linter & -& ,lev_out,lunout1,igout) -!& ,lev_out,lunout1,igout,zbuoy,zbuoyjam) - -!-------------------------------------------------------------------------- -!thermcell_plume: calcule les valeurs de qt, thetal et w dans l ascendance -! Version conforme a l'article de Rio et al. 2010. -! Code ecrit par Catherine Rio, Arnaud Jam et Frederic Hourdin -!-------------------------------------------------------------------------- - - USE thermcell_ini_mod, ONLY: prt_level,fact_thermals_ed_dz,iflag_thermals_ed,RLvCP,RETV,RG - IMPLICIT NONE - - INTEGER itap - INTEGER lunout1,igout - INTEGER ngrid,nlay - REAL ptimestep - REAL ztv(ngrid,nlay) - REAL zthl(ngrid,nlay) - REAL po(ngrid,nlay) - REAL zl(ngrid,nlay) - REAL rhobarz(ngrid,nlay) - REAL zlev(ngrid,nlay+1) - REAL pplev(ngrid,nlay+1) - REAL pphi(ngrid,nlay) - REAL zpspsk(ngrid,nlay) - REAL alim_star(ngrid,nlay) - REAL f0(ngrid) - INTEGER lalim(ngrid) - integer lev_out ! niveau pour les print - integer nbpb - - real alim_star_tot(ngrid) - - REAL ztva(ngrid,nlay) - REAL ztla(ngrid,nlay) - REAL zqla(ngrid,nlay) - REAL zqta(ngrid,nlay) - REAL zha(ngrid,nlay) - - REAL detr_star(ngrid,nlay) - REAL coefc - REAL entr_star(ngrid,nlay) - REAL detr(ngrid,nlay) - REAL entr(ngrid,nlay) - - REAL csc(ngrid,nlay) - - REAL zw2(ngrid,nlay+1) - REAL w_est(ngrid,nlay+1) - REAL f_star(ngrid,nlay+1) - REAL wa_moy(ngrid,nlay+1) - - REAL ztva_est(ngrid,nlay) - REAL zqla_est(ngrid,nlay) - REAL zqsatth(ngrid,nlay) - REAL zta_est(ngrid,nlay) - REAL zbuoyjam(ngrid,nlay) - REAL ztemp(ngrid),zqsat(ngrid) - REAL zdw2 - REAL zw2modif - REAL zw2fact - REAL zeps(ngrid,nlay) - - REAL linter(ngrid) - INTEGER lmix(ngrid) - INTEGER lmix_bis(ngrid) - REAL wmaxa(ngrid) - - INTEGER ig,l,k - - real zdz,zbuoy(ngrid,nlay),zalpha,gamma(ngrid,nlay),zdqt(ngrid,nlay),zw2m - real zbuoybis - real zcor,zdelta,zcvm5,qlbef,zdz2 - real betalpha,zbetalpha - real eps, afact - logical Zsat - LOGICAL active(ngrid),activetmp(ngrid) - REAL fact_gamma,fact_epsilon,fact_gamma2,fact_epsilon2 - REAL c2(ngrid,nlay) - Zsat=.false. -! Initialisation - - fact_epsilon=0.002 - betalpha=0.9 - afact=2./3. - - zbetalpha=betalpha/(1.+betalpha) - - -! Initialisations des variables reeles -if (1==1) then - ztva(:,:)=ztv(:,:) - ztva_est(:,:)=ztva(:,:) - ztla(:,:)=zthl(:,:) - zqta(:,:)=po(:,:) - zha(:,:) = ztva(:,:) -else - ztva(:,:)=0. - ztva_est(:,:)=0. - ztla(:,:)=0. - zqta(:,:)=0. - zha(:,:) =0. -endif - - zqla_est(:,:)=0. - zqsatth(:,:)=0. - zqla(:,:)=0. - detr_star(:,:)=0. - entr_star(:,:)=0. - alim_star(:,:)=0. - alim_star_tot(:)=0. - csc(:,:)=0. - detr(:,:)=0. - entr(:,:)=0. - zw2(:,:)=0. - zbuoy(:,:)=0. - zbuoyjam(:,:)=0. - gamma(:,:)=0. - zeps(:,:)=0. - w_est(:,:)=0. - f_star(:,:)=0. - wa_moy(:,:)=0. - linter(:)=1. -! linter(:)=1. -! Initialisation des variables entieres - lmix(:)=1 - lmix_bis(:)=2 - wmaxa(:)=0. - lalim(:)=1 - - -!------------------------------------------------------------------------- -! On ne considere comme actif que les colonnes dont les deux premieres -! couches sont instables. -!------------------------------------------------------------------------- - active(:)=ztv(:,1)>ztv(:,2) - -!------------------------------------------------------------------------- -! Definition de l'alimentation -!------------------------------------------------------------------------- - do l=1,nlay-1 - do ig=1,ngrid - if (ztv(ig,l)> ztv(ig,l+1) .and. ztv(ig,1)>=ztv(ig,l) ) then - alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.) & - & *sqrt(zlev(ig,l+1)) - lalim(ig)=l+1 - alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l) - endif - enddo - enddo - do l=1,nlay - do ig=1,ngrid - if (alim_star_tot(ig) > 1.e-10 ) then - alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig) - endif - enddo - enddo - alim_star_tot(:)=1. - - - -!------------------------------------------------------------------------------ -! Calcul dans la premiere couche -! On decide dans cette version que le thermique n'est actif que si la premiere -! couche est instable. -! Pourrait etre change si on veut que le thermiques puisse se d??clencher -! dans une couche l>1 -!------------------------------------------------------------------------------ -do ig=1,ngrid -! Le panache va prendre au debut les caracteristiques de l'air contenu -! dans cette couche. - if (active(ig)) then - ztla(ig,1)=zthl(ig,1) - zqta(ig,1)=po(ig,1) - zqla(ig,1)=zl(ig,1) -!cr: attention, prise en compte de f*(1)=1 - f_star(ig,2)=alim_star(ig,1) - zw2(ig,2)=2.*RG*(ztv(ig,1)-ztv(ig,2))/ztv(ig,2) & -& *(zlev(ig,2)-zlev(ig,1)) & -& *0.4*pphi(ig,1)/(pphi(ig,2)-pphi(ig,1)) - w_est(ig,2)=zw2(ig,2) - endif -enddo -! - -!============================================================================== -!boucle de calcul de la vitesse verticale dans le thermique -!============================================================================== -do l=2,nlay-1 -!============================================================================== - - -! On decide si le thermique est encore actif ou non -! AFaire : Il faut sans doute ajouter entr_star a alim_star dans ce test - do ig=1,ngrid - active(ig)=active(ig) & -& .and. zw2(ig,l)>1.e-10 & -& .and. f_star(ig,l)+alim_star(ig,l)>1.e-10 - enddo - - - -!--------------------------------------------------------------------------- -! calcul des proprietes thermodynamiques et de la vitesse de la couche l -! sans tenir compte du detrainement et de l'entrainement dans cette -! couche -! C'est a dire qu'on suppose -! ztla(l)=ztla(l-1) et zqta(l)=zqta(l-1) -! Ici encore, on doit pouvoir ajouter entr_star (qui peut etre calculer -! avant) a l'alimentation pour avoir un calcul plus propre -!--------------------------------------------------------------------------- - - ztemp(:)=zpspsk(:,l)*ztla(:,l-1) - call thermcell_qsat(ngrid,active,pplev(:,l),ztemp,zqta(:,l-1),zqsat(:)) - - do ig=1,ngrid -! print*,'active',active(ig),ig,l - if(active(ig)) then - zqla_est(ig,l)=max(0.,zqta(ig,l-1)-zqsat(ig)) - ztva_est(ig,l) = ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*zqla_est(ig,l) - zta_est(ig,l)=ztva_est(ig,l) - ztva_est(ig,l) = ztva_est(ig,l)/zpspsk(ig,l) - ztva_est(ig,l) = ztva_est(ig,l)*(1.+RETV*(zqta(ig,l-1) & - & -zqla_est(ig,l))-zqla_est(ig,l)) - -!------------------------------------------------ -!AJAM:nouveau calcul de w? -!------------------------------------------------ - zdz=zlev(ig,l+1)-zlev(ig,l) - zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) - - zw2fact=fact_epsilon*2.*zdz/(1.+betalpha) - zdw2=(afact)*zbuoy(ig,l)/(fact_epsilon) - w_est(ig,l+1)=Max(0.0001,exp(-zw2fact)*(w_est(ig,l)-zdw2)+zdw2) - - - if (w_est(ig,l+1).lt.0.) then - w_est(ig,l+1)=zw2(ig,l) - endif - endif - enddo - - -!------------------------------------------------- -!calcul des taux d'entrainement et de detrainement -!------------------------------------------------- - - do ig=1,ngrid - if (active(ig)) then - - zw2m=max(0.5*(w_est(ig,l)+w_est(ig,l+1)),0.1) - zw2m=w_est(ig,l+1) - zdz=zlev(ig,l+1)-zlev(ig,l) - zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) -! zbuoybis=zbuoy(ig,l)+RG*0.1/300. - zbuoybis=zbuoy(ig,l) - zalpha=f0(ig)*f_star(ig,l)/sqrt(w_est(ig,l+1))/rhobarz(ig,l) - zdqt(ig,l)=max(zqta(ig,l-1)-po(ig,l),0.)/po(ig,l) - - - entr_star(ig,l)=f_star(ig,l)*zdz* zbetalpha*MAX(0., & - & afact*zbuoybis/zw2m - fact_epsilon ) - - - detr_star(ig,l)=f_star(ig,l)*zdz & - & *MAX(1.e-3, -afact*zbetalpha*zbuoy(ig,l)/zw2m & - & + 0.012*(zdqt(ig,l)/zw2m)**0.5 ) - -! En dessous de lalim, on prend le max de alim_star et entr_star pour -! alim_star et 0 sinon - if (l.lt.lalim(ig)) then - alim_star(ig,l)=max(alim_star(ig,l),entr_star(ig,l)) - entr_star(ig,l)=0. - endif - -! Calcul du flux montant normalise - f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l) & - & -detr_star(ig,l) - - endif - enddo - - -!---------------------------------------------------------------------------- -!calcul de la vitesse verticale en melangeant Tl et qt du thermique -!--------------------------------------------------------------------------- - activetmp(:)=active(:) .and. f_star(:,l+1)>1.e-10 - do ig=1,ngrid - if (activetmp(ig)) then - Zsat=.false. - ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+ & - & (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l)) & - & /(f_star(ig,l+1)+detr_star(ig,l)) - zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+ & - & (alim_star(ig,l)+entr_star(ig,l))*po(ig,l)) & - & /(f_star(ig,l+1)+detr_star(ig,l)) - - endif - enddo - - ztemp(:)=zpspsk(:,l)*ztla(:,l) - call thermcell_qsat(ngrid,activetmp,pplev(:,l),ztemp,zqta(:,l),zqsatth(:,l)) - - do ig=1,ngrid - if (activetmp(ig)) then -! on ecrit de maniere conservative (sat ou non) -! T = Tl +Lv/Cp ql - zqla(ig,l)=max(0.,zqta(ig,l)-zqsatth(ig,l)) - ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l) - ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l) -!on rajoute le calcul de zha pour diagnostiques (temp potentielle) - zha(ig,l) = ztva(ig,l) - ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) & - & -zqla(ig,l))-zqla(ig,l)) - zbuoy(ig,l)=RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) - zdz=zlev(ig,l+1)-zlev(ig,l) - zeps(ig,l)=(entr_star(ig,l)+alim_star(ig,l))/(f_star(ig,l)*zdz) - - zw2fact=fact_epsilon*2.*zdz/(1.+betalpha) - zdw2=afact*zbuoy(ig,l)/(fact_epsilon) - zw2(ig,l+1)=Max(0.0001,exp(-zw2fact)*(zw2(ig,l)-zdw2)+zdw2) - endif - enddo - - if (prt_level.ge.20) print*,'coucou calcul detr 460: ig, l',ig, l -! -!--------------------------------------------------------------------------- -!initialisations pour le calcul de la hauteur du thermique, de l'inversion et de la vitesse verticale max -!--------------------------------------------------------------------------- - - nbpb=0 - do ig=1,ngrid - if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then -! stop'On tombe sur le cas particulier de thermcell_dry' -! print*,'On tombe sur le cas particulier de thermcell_plume' - nbpb=nbpb+1 - zw2(ig,l+1)=0. - linter(ig)=l+1 - endif - - if (zw2(ig,l+1).lt.0.) then - linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) & - & -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) - zw2(ig,l+1)=0. - elseif (f_star(ig,l+1).lt.0.) then - linter(ig)=(l*(f_star(ig,l+1)-f_star(ig,l)) & - & -f_star(ig,l))/(f_star(ig,l+1)-f_star(ig,l)) -! print*,"linter plume", linter(ig) - zw2(ig,l+1)=0. - endif - - wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) - - if (wa_moy(ig,l+1).gt.wmaxa(ig)) then -! lmix est le niveau de la couche ou w (wa_moy) est maximum -!on rajoute le calcul de lmix_bis - if (zqla(ig,l).lt.1.e-10) then - lmix_bis(ig)=l+1 - endif - lmix(ig)=l+1 - wmaxa(ig)=wa_moy(ig,l+1) - endif - enddo - - if (nbpb>0) then - print*,'WARNING on tombe ',nbpb,' x sur un pb pour l=',l,' dans thermcell_plume' - endif - -!========================================================================= -! FIN DE LA BOUCLE VERTICALE - enddo -!========================================================================= - -!on recalcule alim_star_tot - do ig=1,ngrid - alim_star_tot(ig)=0. - enddo - do ig=1,ngrid - do l=1,lalim(ig)-1 - alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l) - enddo - enddo - - - if (prt_level.ge.20) print*,'coucou calcul detr 470: ig, l', ig, l - -#undef wrgrads_thermcell -#ifdef wrgrads_thermcell - call wrgradsfi(1,nlay,entr_star(igout,1:nlay),'esta ','esta ') - call wrgradsfi(1,nlay,detr_star(igout,1:nlay),'dsta ','dsta ') - call wrgradsfi(1,nlay,zbuoy(igout,1:nlay),'buoy ','buoy ') - call wrgradsfi(1,nlay,zdqt(igout,1:nlay),'dqt ','dqt ') - call wrgradsfi(1,nlay,w_est(igout,1:nlay),'w_est ','w_est ') - call wrgradsfi(1,nlay,w_est(igout,2:nlay+1),'w_es2 ','w_es2 ') - call wrgradsfi(1,nlay,zw2(igout,1:nlay),'zw2A ','zw2A ') -#endif - - - return - end Index: LMDZ6/trunk/libf/phylmd/thermcell_qsat.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/thermcell_qsat.F90 (revision 4589) +++ (revision ) @@ -1,95 +1,0 @@ -subroutine thermcell_qsat(klon,active,pplev,ztemp,zqta,zqsat) -implicit none - -#include "YOMCST.h" -#include "YOETHF.h" -#include "FCTTRE.h" - - -!==================================================================== -! DECLARATIONS -!==================================================================== - -! Arguments -INTEGER klon -REAL zpspsk(klon),pplev(klon) -REAL ztemp(klon),zqta(klon),zqsat(klon) -LOGICAL active(klon) - -! Variables locales -INTEGER ig,iter -REAL Tbef(klon),DT(klon) -REAL tdelta,qsatbef,zcor,qlbef,zdelta,zcvm5,dqsat,num,denom,dqsat_dT -logical Zsat -REAL RLvCp - -REAL, SAVE :: DDT0=.01 -!$OMP THREADPRIVATE(DDT0) - -LOGICAL afaire(klon),tout_converge - -!==================================================================== -! INITIALISATIONS -!==================================================================== - -RLvCp = RLVTT/RCPD -tout_converge=.false. -afaire(:)=.false. -DT(:)=0. - - -!==================================================================== -! Routine a vectoriser en copiant active dans converge et en mettant -! la boucle sur les iterations a l'exterieur est en mettant -! converge= false des que la convergence est atteinte. -!==================================================================== - -do ig=1,klon - if (active(ig)) then - Tbef(ig)=ztemp(ig) - zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) - qsatbef= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig) - qsatbef=MIN(0.5,qsatbef) - zcor=1./(1.-retv*qsatbef) - qsatbef=qsatbef*zcor - qlbef=max(0.,zqta(ig)-qsatbef) - DT(ig) = 0.5*RLvCp*qlbef - zqsat(ig)=qsatbef - endif -enddo - -! Traitement du cas ou il y a condensation mais faible -! On ne condense pas mais on dit que le qsat est le qta -do ig=1,klon - if (active(ig)) then - if (0.