source: LMDZ6/branches/contrails/libf/phylmd/lmdz_ratqs_main.f90 @ 5440

Last change on this file since 5440 was 5268, checked in by abarral, 2 months ago

.f90 <-> .F90 depending on cpp key use
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
File size: 10.3 KB
Line 
1MODULE lmdz_ratqs_main
2
3CONTAINS
4
5SUBROUTINE ratqs_main(klon,klev,nbsrf,prt_level,lunout,       &
6           iflag_ratqs,iflag_con,iflag_cld_th,pdtphys, &
7           ratqsbas,ratqshaut,ratqsp0,ratqsdp, &
8           pctsrf,s_pblh,zstd, &
9           tau_ratqs,fact_cldcon,wake_s, wake_deltaq,   &
10           ptconv,ptconvth,clwcon0th, rnebcon0th,       &
11           paprs,pplay,t_seri,q_seri,                   &
12           qtc_cv, sigt_cv,detrain_cv,fm_cv,fqd,fqcomp,sigd,zqsat,             &
13           omega,tke,tke_dissip,lmix,wprime, &
14           t2m,q2m,fm_therm,entr_therm,detr_therm,cell_area,&
15           ratqs,ratqsc,ratqs_inter_,sigma_qtherm)
16
17
18USE lmdz_ratqs_multi,   ONLY: ratqs_inter, ratqs_oro, ratqs_hetero, ratqs_tke
19
20implicit none
21
22!========================================================================
23! Computation of ratqs, the width of the subrid scale water distribution
24! (normalized by the mean value)
25! Various options controled by flags iflag_con and iflag_ratqs
26! F Hourdin 2012/12/06
27!========================================================================
28
29! Declarations
30
31! Input
32integer,intent(in) :: klon,klev,nbsrf,prt_level,lunout
33integer,intent(in) :: iflag_con,iflag_cld_th,iflag_ratqs
34real,intent(in) :: pdtphys,ratqsbas,ratqshaut,fact_cldcon,tau_ratqs
35real,intent(in) :: ratqsp0, ratqsdp
36real, dimension(klon,klev),intent(in) :: omega
37real, dimension(klon,klev+1),intent(in) :: paprs,tke,tke_dissip,lmix,wprime
38real, dimension(klon,klev),intent(in) :: pplay,t_seri,q_seri,zqsat
39real, dimension(klon,klev),intent(in) :: entr_therm,detr_therm,qtc_cv, sigt_cv
40real, dimension(klon,klev) :: detrain_cv,fm_cv,fqd,fqcomp
41real, dimension(klon) :: sigd
42
43real, dimension(klon,klev+1),intent(in) :: fm_therm
44logical, dimension(klon,klev),intent(in) :: ptconv
45real, dimension(klon,klev),intent(in) :: rnebcon0th,clwcon0th
46real, dimension(klon,klev),intent(in) :: wake_deltaq,wake_s
47real, dimension(klon,nbsrf),intent(in) :: t2m,q2m
48real, dimension(klon), intent(in) :: cell_area
49real, dimension(klon,nbsrf),intent(in) :: pctsrf
50real, dimension(klon),intent(in) :: s_pblh
51real, dimension(klon),intent(in) :: zstd
52
53! Output
54real, dimension(klon,klev),intent(inout) :: ratqs,ratqsc,ratqs_inter_,sigma_qtherm
55
56logical, dimension(klon,klev),intent(inout) :: ptconvth
57
58! local
59integer i,k
60real, dimension(klon,klev) :: ratqss
61real facteur,zfratqs1,zfratqs2
62real, dimension(klon,klev) :: ratqs_hetero_,ratqs_oro_,ratqs_tke_
63real resol,resolmax,fact
64
65!-------------------------------------------------------------------------
66!  Caclul des ratqs
67!-------------------------------------------------------------------------
68
69!      print*,'calcul des ratqs'
70!   ratqs convectifs a l'ancienne en fonction de q(z=0)-q / q
71!   ----------------
72!   on ecrase le tableau ratqsc calcule par clouds_gno
73      if (iflag_cld_th.eq.1) then
74         do k=1,klev
75         do i=1,klon
76            if(ptconv(i,k)) then
77              ratqsc(i,k)=ratqsbas &
78              +fact_cldcon*(q_seri(i,1)-q_seri(i,k))/q_seri(i,k)
79            else
80               ratqsc(i,k)=0.
81            endif
82         enddo
83         enddo
84
85!-----------------------------------------------------------------------
86!  par nversion de la fonction log normale
87!-----------------------------------------------------------------------
88      else if (iflag_cld_th.eq.4) then
89         ptconvth(:,:)=.false.
90         ratqsc(:,:)=0.
91         if(prt_level.ge.9) print*,'avant clouds_gno thermique'
92         call clouds_gno &
93         (klon,klev,q_seri,zqsat,clwcon0th,ptconvth,ratqsc,rnebcon0th)
94         if(prt_level.ge.9) print*,' CLOUDS_GNO OK'
95       
96       endif
97
98!   ratqs stables
99!   -------------
100
101      if (iflag_ratqs.eq.0) then
102
103! Le cas iflag_ratqs=0 correspond a la version IPCC 2005 du modele.
104         do k=1,klev
105            do i=1, klon
106               ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)* &
107               min((paprs(i,1)-pplay(i,k))/(paprs(i,1)-30000.),1.)
108            enddo
109         enddo
110
111! Pour iflag_ratqs=1 ou 2, le ratqs est constant au dessus de
112! 300 hPa (ratqshaut), varie lineariement en fonction de la pression
113! entre 600 et 300 hPa et est soit constant (ratqsbas) pour iflag_ratqs=1
114! soit lineaire (entre 0 a la surface et ratqsbas) pour iflag_ratqs=2
115! Il s'agit de differents tests dans la phase de reglage du modele
116! avec thermiques.
117
118      else if (iflag_ratqs.eq.1) then
119
120         do k=1,klev
121            do i=1, klon
122               if (pplay(i,k).ge.60000.) then
123                  ratqss(i,k)=ratqsbas
124               else if ((pplay(i,k).ge.30000.).and.(pplay(i,k).lt.60000.)) then
125                  ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)*(60000.-pplay(i,k))/(60000.-30000.)
126               else
127                  ratqss(i,k)=ratqshaut
128               endif
129            enddo
130         enddo
131
132      else if (iflag_ratqs.eq.2) then
133
134         do k=1,klev
135            do i=1, klon
136               if (pplay(i,k).ge.60000.) then
137                  ratqss(i,k)=ratqsbas*(paprs(i,1)-pplay(i,k))/(paprs(i,1)-60000.)
138               else if ((pplay(i,k).ge.30000.).and.(pplay(i,k).lt.60000.)) then
139                    ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)*(60000.-pplay(i,k))/(60000.-30000.)
140               else
141                    ratqss(i,k)=ratqshaut
142               endif
143            enddo
144         enddo
145
146      else if (iflag_ratqs==3) then
147         do k=1,klev
148           ratqss(:,k)=ratqsbas+(ratqshaut-ratqsbas) &
149           *min( ((paprs(:,1)-pplay(:,k))/70000.)**2 , 1. )
150         enddo
151
152      else if (iflag_ratqs==4) then
153         do k=1,klev
154           ratqss(:,k)=ratqsbas+0.5*(ratqshaut-ratqsbas) &
155!          *( tanh( (50000.-pplay(:,k))/20000.) + 1.)
156           *( tanh( (ratqsp0-pplay(:,k))/ratqsdp) + 1.)
157         enddo
158
159
160      else if (iflag_ratqs==5) then
161! Dependency of ratqs on model resolution
162! Audran, Meryl, Lea, Gwendal and Etienne
163! April 2023
164        resolmax=sqrt(maxval(cell_area))
165         do k=1,klev
166            do i=1,klon
167              resol=sqrt(cell_area(i))
168              fact=sqrt(resol/resolmax)
169              ratqss(i,k)=ratqsbas*fact+0.5*(ratqshaut-ratqsbas)*fact &
170              *( tanh( (ratqsp0-pplay(i,k))/ratqsdp) + 1.)
171           enddo
172         enddo
173
174
175       else if (iflag_ratqs .GT. 9) then
176 
177       ! interactive ratqs calculations that depend on cold pools, orography, surface heterogeneity and small-scale turbulence
178       ! This should help getting a more realistic ratqs in the low and mid troposphere
179       ! We however need a "background" ratqs to account for subgrid distribution of qt (or qt/qs)
180       ! in the high troposphere
181       
182       ! background ratqs and initialisations
183          do k=1,klev
184             do i=1,klon
185              ratqss(i,k)=ratqsbas+0.5*(ratqshaut-ratqsbas) &
186              *( tanh( (ratqsp0-pplay(i,k))/ratqsdp) + 1.)
187              ratqss(i,k)=max(ratqss(i,k),0.0)
188              ratqs_hetero_(i,k)=0.
189              ratqs_oro_(i,k)=0.
190              ratqs_tke_(i,k)=0.
191              ratqs_inter_(i,k)=0
192             enddo
193          enddo
194     
195          if (iflag_ratqs .EQ. 10) then
196             print*,'avant ratqs_inter'
197            ! interactive ratqs with several sources
198             call ratqs_inter(klon,klev,iflag_ratqs,pdtphys,paprs, &
199                       ratqsbas,wake_deltaq,wake_s,q_seri,qtc_cv, sigt_cv, &
200                       fm_therm,entr_therm,detr_therm,detrain_cv,fm_cv,fqd,fqcomp,sigd, &
201                       ratqs_inter_,sigma_qtherm)
202             ratqss=ratqss+ratqs_inter_
203          else if (iflag_ratqs .EQ. 11) then
204            print*,'avant ratqs_inter'
205            ! interactive ratqs with several sources
206             call ratqs_inter(klon,klev,iflag_ratqs,pdtphys,paprs, &
207                       ratqsbas,wake_deltaq,wake_s,q_seri,qtc_cv, sigt_cv, &
208                       fm_therm,entr_therm,detr_therm,detrain_cv,fm_cv,fqd,fqcomp,sigd, &
209                       ratqs_inter_,sigma_qtherm)
210             ratqss=ratqss+ratqs_inter_
211          else if (iflag_ratqs .EQ. 12) then
212             ! contribution of surface heterogeneities to ratqs
213             call ratqs_hetero(klon,klev,pctsrf,s_pblh,t2m,q2m,t_seri,q_seri,pplay,paprs,ratqs_hetero_)
214             ratqss=ratqss+ratqs_hetero_
215          else if (iflag_ratqs .EQ. 13) then
216             ! contribution of ubgrid orography to ratqs
217             call ratqs_oro(klon,klev,pctsrf,zstd,zqsat,t_seri,pplay,paprs,ratqs_oro_)
218             ratqss=ratqss+ratqs_oro_
219          else if (iflag_ratqs .EQ. 14) then
220             ! effect of subgrid-scale TKE on ratqs (in development)
221             call ratqs_tke(klon,klev,pdtphys,t_seri,q_seri,zqsat,pplay,paprs,omega,tke,tke_dissip,lmix,wprime,ratqs_tke_)     
222             ratqss=ratqss+ratqs_tke_
223          endif
224         
225     
226      endif
227
228
229!  ratqs final
230!  -----------
231
232      if (iflag_cld_th.eq.1 .or.iflag_cld_th.eq.2.or.iflag_cld_th.eq.4) then
233
234! On ajoute une constante au ratqsc*2 pour tenir compte de
235! fluctuations turbulentes de petite echelle
236
237         do k=1,klev
238            do i=1,klon
239               if ((fm_therm(i,k)>1.e-10)) then
240                  ratqsc(i,k)=sqrt(ratqsc(i,k)**2+0.05**2)
241               endif
242            enddo
243         enddo
244
245!   les ratqs sont une combinaison de ratqss et ratqsc
246       if(prt_level.ge.9) write(lunout,*)'PHYLMD NOUVEAU TAU_RATQS ',tau_ratqs
247
248         if (tau_ratqs>1.e-10) then
249            facteur=exp(-pdtphys/tau_ratqs)
250         else
251            facteur=0.
252         endif
253         ratqs(:,:)=ratqsc(:,:)*(1.-facteur)+ratqs(:,:)*facteur
254!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
255! FH 22/09/2009
256! La ligne ci-dessous faisait osciller le modele et donnait une solution
257! assymptotique bidon et d??pendant fortement du pas de temps.
258!        ratqs(:,:)=sqrt(ratqs(:,:)**2+ratqss(:,:)**2)
259!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
260         ratqs(:,:)=max(ratqs(:,:),ratqss(:,:))
261      else if (iflag_cld_th<=6) then
262!   on ne prend que le ratqs stable pour fisrtilp
263         ratqs(:,:)=ratqss(:,:)
264      else
265          zfratqs1=exp(-pdtphys/10800.)
266          zfratqs2=exp(-pdtphys/10800.)
267          do k=1,klev
268             do i=1,klon
269                if (ratqsc(i,k).gt.1.e-10) then
270                   ratqs(i,k)=ratqs(i,k)*zfratqs2+(iflag_cld_th/100.)*ratqsc(i,k)*(1.-zfratqs2)
271                endif
272                ratqs(i,k)=min(ratqs(i,k)*zfratqs1+ratqss(i,k)*(1.-zfratqs1),0.5)
273             enddo
274          enddo
275      endif
276
277
278return
279END SUBROUTINE ratqs_main
280
281END MODULE lmdz_ratqs_main
Note: See TracBrowser for help on using the repository browser.