MODULE lmdz_ratqs_main CONTAINS SUBROUTINE ratqs_main(klon,klev,nbsrf,prt_level,lunout, & iflag_ratqs,iflag_con,iflag_cld_th,pdtphys, & ratqsbas,ratqshaut,ratqsp0,ratqsdp, & pctsrf,s_pblh,zstd, & tau_ratqs,fact_cldcon,wake_s, wake_deltaq, & ptconv,ptconvth,clwcon0th, rnebcon0th, & paprs,pplay,t_seri,q_seri, & qtc_cv, sigt_cv,detrain_cv,fm_cv,fqd,fqcomp,sigd,zqsat, & omega,tke,tke_dissip,lmix,wprime, & t2m,q2m,fm_therm,entr_therm,detr_therm,cell_area,& ratqs,ratqsc,ratqs_inter_) USE lmdz_ratqs_multi, ONLY: ratqs_inter, ratqs_oro, ratqs_hetero, ratqs_tke IMPLICIT NONE !======================================================================== ! Computation of ratqs, the width of the subrid scale water distribution ! (normalized by the mean value) ! Various options controled by flags iflag_con and iflag_ratqs ! F Hourdin 2012/12/06 !======================================================================== ! Declarations ! Input INTEGER,INTENT(IN) :: klon,klev,nbsrf,prt_level,lunout INTEGER,INTENT(IN) :: iflag_con,iflag_cld_th,iflag_ratqs REAL,INTENT(IN) :: pdtphys,ratqsbas,ratqshaut,fact_cldcon,tau_ratqs REAL,INTENT(IN) :: ratqsp0, ratqsdp REAL, DIMENSION(klon,klev),INTENT(IN) :: omega REAL, DIMENSION(klon,klev+1),INTENT(IN) :: paprs,tke,tke_dissip,lmix,wprime REAL, DIMENSION(klon,klev),INTENT(IN) :: pplay,t_seri,q_seri,zqsat REAL, DIMENSION(klon,klev),INTENT(IN) :: entr_therm,detr_therm,qtc_cv, sigt_cv REAL, DIMENSION(klon,klev) :: detrain_cv,fm_cv,fqd,fqcomp REAL, DIMENSION(klon) :: sigd REAL, DIMENSION(klon,klev+1),INTENT(IN) :: fm_therm logical, DIMENSION(klon,klev),INTENT(IN) :: ptconv REAL, DIMENSION(klon,klev),INTENT(IN) :: rnebcon0th,clwcon0th REAL, DIMENSION(klon,klev),INTENT(IN) :: wake_deltaq,wake_s REAL, DIMENSION(klon,nbsrf),INTENT(IN) :: t2m,q2m REAL, DIMENSION(klon), INTENT(IN) :: cell_area REAL, DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf REAL, DIMENSION(klon),INTENT(IN) :: s_pblh REAL, DIMENSION(klon),INTENT(IN) :: zstd ! Output REAL, DIMENSION(klon,klev),INTENT(INOUT) :: ratqs,ratqsc,ratqs_inter_ logical, DIMENSION(klon,klev),INTENT(INOUT) :: ptconvth ! local INTEGER i,k REAL, DIMENSION(klon,klev) :: ratqss REAL facteur,zfratqs1,zfratqs2 REAL, DIMENSION(klon,klev) :: ratqs_hetero_,ratqs_oro_,ratqs_tke_ REAL resol,resolmax,fact !------------------------------------------------------------------------- ! Caclul des ratqs !------------------------------------------------------------------------- ! PRINT*,'calcul des ratqs' ! ratqs convectifs a l'ancienne en fonction de q(z=0)-q / q ! ---------------- ! on ecrase le tableau ratqsc calcule par clouds_gno IF (iflag_cld_th==1) THEN DO k=1,klev DO i=1,klon IF(ptconv(i,k)) THEN ratqsc(i,k)=ratqsbas & +fact_cldcon*(q_seri(i,1)-q_seri(i,k))/q_seri(i,k) else ratqsc(i,k)=0. endif enddo enddo !----------------------------------------------------------------------- ! par nversion de la fonction log normale !----------------------------------------------------------------------- ELSE IF (iflag_cld_th==4) THEN ptconvth(:,:)=.FALSE. ratqsc(:,:)=0. IF(prt_level>=9) PRINT*,'avant clouds_gno thermique' CALL clouds_gno & (klon,klev,q_seri,zqsat,clwcon0th,ptconvth,ratqsc,rnebcon0th) IF(prt_level>=9) PRINT*,' CLOUDS_GNO OK' endif ! ratqs stables ! ------------- IF (iflag_ratqs==0) THEN ! Le cas iflag_ratqs=0 correspond a la version IPCC 2005 du modele. DO k=1,klev DO i=1, klon ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)* & min((paprs(i,1)-pplay(i,k))/(paprs(i,1)-30000.),1.) enddo enddo ! Pour iflag_ratqs=1 ou 2, le ratqs est constant au dessus de ! 300 hPa (ratqshaut), varie lineariement en fonction de la pression ! entre 600 et 300 hPa et est soit constant (ratqsbas) pour iflag_ratqs=1 ! soit lineaire (entre 0 a la surface et ratqsbas) pour iflag_ratqs=2 ! Il s'agit de differents tests dans la phase de reglage du modele ! avec thermiques. ELSE IF (iflag_ratqs==1) THEN DO k=1,klev DO i=1, klon IF (pplay(i,k)>=60000.) THEN ratqss(i,k)=ratqsbas ELSE IF ((pplay(i,k)>=30000.).AND.(pplay(i,k)<60000.)) THEN ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)*(60000.-pplay(i,k))/(60000.-30000.) else ratqss(i,k)=ratqshaut endif enddo enddo ELSE IF (iflag_ratqs==2) THEN DO k=1,klev DO i=1, klon IF (pplay(i,k)>=60000.) THEN ratqss(i,k)=ratqsbas*(paprs(i,1)-pplay(i,k))/(paprs(i,1)-60000.) ELSE IF ((pplay(i,k)>=30000.).AND.(pplay(i,k)<60000.)) THEN ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)*(60000.-pplay(i,k))/(60000.-30000.) else ratqss(i,k)=ratqshaut endif enddo enddo ELSE IF (iflag_ratqs==3) THEN DO k=1,klev ratqss(:,k)=ratqsbas+(ratqshaut-ratqsbas) & *min( ((paprs(:,1)-pplay(:,k))/70000.)**2 , 1. ) enddo ELSE IF (iflag_ratqs==4) THEN DO k=1,klev ratqss(:,k)=ratqsbas+0.5*(ratqshaut-ratqsbas) & ! *( tanh( (50000.-pplay(:,k))/20000.) + 1.) *( tanh( (ratqsp0-pplay(:,k))/ratqsdp) + 1.) enddo ELSE IF (iflag_ratqs==5) THEN ! Dependency of ratqs on model resolution ! Audran, Meryl, Lea, Gwendal and Etienne ! April 2023 resolmax=sqrt(maxval(cell_area)) DO k=1,klev DO i=1,klon resol=sqrt(cell_area(i)) fact=sqrt(resol/resolmax) ratqss(i,k)=ratqsbas*fact+0.5*(ratqshaut-ratqsbas)*fact & *( tanh( (ratqsp0-pplay(i,k))/ratqsdp) + 1.) enddo enddo ELSE IF (iflag_ratqs > 9) THEN ! interactive ratqs calculations that depend on cold pools, orography, surface heterogeneity and small-scale turbulence ! This should help getting a more realistic ratqs in the low and mid troposphere ! We however need a "background" ratqs to account for subgrid distribution of qt (or qt/qs) ! in the high troposphere ! background ratqs and initialisations DO k=1,klev DO i=1,klon ratqss(i,k)=ratqsbas+0.5*(ratqshaut-ratqsbas) & *( tanh( (ratqsp0-pplay(i,k))/ratqsdp) + 1.) ratqss(i,k)=max(ratqss(i,k),0.0) ratqs_hetero_(i,k)=0. ratqs_oro_(i,k)=0. ratqs_tke_(i,k)=0. ratqs_inter_(i,k)=0 enddo enddo IF (iflag_ratqs == 10) THEN ! interactive ratqs in presence of cold pools CALL ratqs_inter(klon,klev,iflag_ratqs,pdtphys,paprs, & ratqsbas,wake_deltaq,wake_s,q_seri,qtc_cv, sigt_cv, & fm_therm,entr_therm,detr_therm,detrain_cv,fm_cv,fqd,fqcomp,sigd, & ratqs_inter_) DO k=1,klev DO i=1,klon ratqs_inter_(i,k)=ratqs_inter_(i,k)-0.5*ratqs_inter_(i,k)*(tanh((ratqsp0-pplay(i,k))/ratqsdp)+1.) enddo enddo ratqss=ratqss+ratqs_inter_ ELSE IF (iflag_ratqs == 11) THEN PRINT*,'avant ratqs_inter' ! interactive ratqs with several sources CALL ratqs_inter(klon,klev,iflag_ratqs,pdtphys,paprs, & ratqsbas,wake_deltaq,wake_s,q_seri,qtc_cv, sigt_cv, & fm_therm,entr_therm,detr_therm,detrain_cv,fm_cv,fqd,fqcomp,sigd, & ratqs_inter_) ratqss=ratqss+ratqs_inter_ ELSE IF (iflag_ratqs == 12) THEN ! contribution of surface heterogeneities to ratqs CALL ratqs_hetero(klon,klev,pctsrf,s_pblh,t2m,q2m,t_seri,q_seri,pplay,paprs,ratqs_hetero_) ratqss=ratqss+ratqs_hetero_ ELSE IF (iflag_ratqs == 13) THEN ! contribution of ubgrid orography to ratqs CALL ratqs_oro(klon,klev,pctsrf,zstd,zqsat,t_seri,pplay,paprs,ratqs_oro_) ratqss=ratqss+ratqs_oro_ ELSE IF (iflag_ratqs == 14) THEN ! effect of subgrid-scale TKE on ratqs (in development) CALL ratqs_tke(klon,klev,pdtphys,t_seri,q_seri,zqsat,pplay,paprs,omega,tke,tke_dissip,lmix,wprime,ratqs_tke_) ratqss=ratqss+ratqs_tke_ endif endif ! ratqs final ! ----------- IF (iflag_cld_th==1 .OR.iflag_cld_th==2.OR.iflag_cld_th==4) THEN ! On ajoute une constante au ratqsc*2 pour tenir compte de ! fluctuations turbulentes de petite echelle DO k=1,klev DO i=1,klon IF ((fm_therm(i,k)>1.e-10)) THEN ratqsc(i,k)=sqrt(ratqsc(i,k)**2+0.05**2) endif enddo enddo ! les ratqs sont une combinaison de ratqss et ratqsc IF(prt_level>=9) WRITE(lunout,*)'PHYLMD NOUVEAU TAU_RATQS ',tau_ratqs IF (tau_ratqs>1.e-10) THEN facteur=exp(-pdtphys/tau_ratqs) else facteur=0. endif ratqs(:,:)=ratqsc(:,:)*(1.-facteur)+ratqs(:,:)*facteur !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! FH 22/09/2009 ! La ligne ci-dessous faisait osciller le modele et donnait une solution ! assymptotique bidon et d??pendant fortement du pas de temps. ! ratqs(:,:)=sqrt(ratqs(:,:)**2+ratqss(:,:)**2) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ratqs(:,:)=max(ratqs(:,:),ratqss(:,:)) ELSE IF (iflag_cld_th<=6) THEN ! on ne prend que le ratqs stable pour fisrtilp ratqs(:,:)=ratqss(:,:) else zfratqs1=exp(-pdtphys/10800.) zfratqs2=exp(-pdtphys/10800.) DO k=1,klev DO i=1,klon IF (ratqsc(i,k)>1.e-10) THEN ratqs(i,k)=ratqs(i,k)*zfratqs2+(iflag_cld_th/100.)*ratqsc(i,k)*(1.-zfratqs2) endif ratqs(i,k)=min(ratqs(i,k)*zfratqs1+ratqss(i,k)*(1.-zfratqs1),0.5) enddo enddo endif END SUBROUTINE ratqs_main END MODULE lmdz_ratqs_main