source: LMDZ6/trunk/libf/phylmd/lmdz_ratqs_main.f90 @ 5833

Last change on this file since 5833 was 5831, checked in by rkazeroni, 2 months ago

Finish GPU porting work on ratqs_main:

  • Computation of resolmax takes parallelization into account using reduce_max (variable now defined as resolmax_glo)


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