source: LMDZ6/trunk/libf/phylmd/lmdz_thermcell_alp.f90 @ 5441

Last change on this file since 5441 was 5390, checked in by yann meurdesoif, 2 weeks ago
  • Remove UTF8 character that inihibit fortran parsing with GPU morphosis
  • Add missing END SUBROUTINE instead of simple END, that inhibit correct parsing with regulat expression parser (quick and dirty parsing)

YM
File size: 15.1 KB
Line 
1MODULE lmdz_thermcell_alp
2! $Id: thermcell_main.F90 2351 2015-08-25 15:14:59Z emillour $
3!
4CONTAINS
5
6      SUBROUTINE thermcell_alp(ngrid,nlay,ptimestep  &                         ! in
7     &                  ,pplay,pplev  &                                        ! in
8     &                  ,fm0,entr0,lmax  &                                     ! in
9     &                  ,pbl_tke,pctsrf,omega,airephy &                        ! in
10     &                  ,zw2,fraca &                                           ! in
11     &                  ,pcon,rhobarz,wth3,wmax_sec,lalim,fm,alim_star,zmax &  ! in
12!
13     &                  ,zcong,ale_bl,alp_bl,lalim_conv,wght_th &                    ! out
14     &                  ,zlcl,fraca0,w0,w_conv,therm_tke_max0,env_tke_max0 &   ! out
15     &                  ,n2,s2,strig,ale_bl_stat &                                   ! out
16     &                  ,therm_tke_max,env_tke_max &                           ! out
17     &                  ,alp_bl_det,alp_bl_fluct_m,alp_bl_fluct_tke &          ! out
18     &                  ,alp_bl_conv,alp_bl_stat &                             ! out
19     &)
20
21USE yoethf_mod_h
22      USE alpale_mod
23            USE yomcst_mod_h
24      USE indice_sol_mod
25      USE lmdz_thermcell_main, ONLY : thermcell_tke_transport
26      IMPLICIT NONE
27
28!=======================================================================
29!
30!   Auteurs: Catherine Rio
31!   Modifications :
32!   Nicolas Rochetin et Jean-Yves Grandpeix
33!         pour la fermeture stochastique. 2012
34!   Fr�d�ric Hourdin :
35!         netoyage informatique. 2022
36!
37!=======================================================================
38!-----------------------------------------------------------------------
39!   declarations:
40!   -------------
41
42      INCLUDE "FCTTRE.h"
43
44!   arguments:
45!   ----------
46
47!------Entrees
48      integer, intent(in) :: ngrid,nlay
49      real, intent(in) :: ptimestep
50      real, intent(in) :: pplay(ngrid,nlay),pplev(ngrid,nlay+1)
51      integer, intent(in), dimension(ngrid) ::lmax,lalim
52      real, intent(in), dimension(ngrid) :: zmax, zcong
53      real, intent(in), dimension(ngrid,nlay+1) :: zw2
54      real, intent(in), dimension(ngrid,nlay+1) :: fraca
55      real, intent(in), dimension(ngrid,nlay) :: wth3
56      real, intent(in), dimension(ngrid,nlay) :: rhobarz
57      real, intent(in), dimension(ngrid) :: wmax_sec
58      real, intent(in), dimension(ngrid,nlay) :: entr0
59      real, intent(in), dimension(ngrid,nlay+1) :: fm0,fm
60      real, intent(in), dimension(ngrid) :: pcon
61      real, intent(in), dimension(ngrid,nlay) :: alim_star
62      real, intent(in), dimension(ngrid,nlay+1,nbsrf) :: pbl_tke
63      real, intent(in), dimension(ngrid,nbsrf) :: pctsrf
64      real, intent(in), dimension(ngrid,nlay) :: omega
65      real, intent(in), dimension(ngrid) :: airephy
66!------Sorties
67      real, intent(out), dimension(ngrid) :: ale_bl,alp_bl
68      real, intent(out), dimension(ngrid,nlay) :: wght_th
69      integer, intent(out), dimension(ngrid) :: lalim_conv
70      real, intent(out), dimension(ngrid) :: zlcl,fraca0,w0,w_conv
71      real, intent(out), dimension(ngrid) :: therm_tke_max0,env_tke_max0,n2,s2,ale_bl_stat,strig
72      real, intent(out), dimension(ngrid,nlay) :: therm_tke_max,env_tke_max
73      real, intent(out), dimension(ngrid) :: alp_bl_det,alp_bl_fluct_m,alp_bl_fluct_tke
74      real, intent(out), dimension(ngrid) :: alp_bl_conv,alp_bl_stat
75
76!=============================================================================================
77!------Local
78!=============================================================================================
79
80      REAL susqr2pi, reuler
81      INTEGER ig,k,l
82      integer nsrf
83      real rhobarz0(ngrid)                    ! Densit� au LCL
84      logical ok_lcl(ngrid)                   ! Existence du LCL des thermiques
85      integer klcl(ngrid)                     ! Niveau du LCL
86      real interp(ngrid)                      ! Coef d'interpolation pour le LCL
87!--Triggering
88      real, parameter :: su_cst=4e4              ! Surface unite: celle d'un updraft �l�mentaire
89      real, parameter :: hcoef=1             ! Coefficient directeur pour le calcul de s2
90      real, parameter :: hmincoef=0.3        ! Coefficient directeur pour l'ordonn�e � l'origine pour le calcul de s2
91      real, parameter :: eps1=0.3            ! Fraction de surface occup�e par la population 1 : eps1=n1*s1/(fraca0*Sd)
92      real, dimension(ngrid) :: hmin         ! Ordonn�e � l'origine pour le calcul de s2
93      real, dimension(ngrid) :: zmax_moy     ! Hauteur moyenne des thermiques : zmax_moy = zlcl + 0.33 (zmax-zlcl)
94      real, parameter :: zmax_moy_coef=0.33
95      real, dimension(ngrid) :: depth        ! Epaisseur moyenne du cumulus
96      real, dimension(ngrid) :: zcong_moy
97      real, dimension(ngrid) ::  w_max                 ! Vitesse max statistique
98      real, dimension(ngrid) ::  s_max(ngrid)
99!--Closure
100      real, dimension(ngrid,nlay) :: pbl_tke_max       ! Profil de TKE moyenne
101      real, dimension(ngrid) :: pbl_tke_max0           ! TKE moyenne au LCL
102      real, dimension(ngrid,nlay) :: w_ls              ! Vitesse verticale grande �chelle (m/s)
103      real, parameter :: coef_m=1.            ! On consid�re un rendement pour alp_bl_fluct_m
104      real, parameter :: coef_tke=1.          ! On consid�re un rendement pour alp_bl_fluct_tke
105      real :: zdp
106      real, dimension(ngrid) :: alp_int,dp_int
107      real, dimension(ngrid) :: fm_tot
108
109!------------------------------------------------------------
110!  Initialize output arrays related to stochastic triggering
111!------------------------------------------------------------
112  DO ig = 1,ngrid
113     zlcl(ig) = 0.
114     fraca0(ig) = 0.
115     w0(ig) = 0.
116     w_conv(ig) = 0.
117     therm_tke_max0(ig) = 0.
118     env_tke_max0(ig) = 0.
119     n2(ig) = 0.
120     s2(ig) = 0.
121     ale_bl_stat(ig) = 0.
122     strig(ig) = 0.
123     alp_bl_det(ig) = 0.
124     alp_bl_fluct_m(ig) = 0.
125     alp_bl_fluct_tke(ig) = 0.
126     alp_bl_conv(ig) = 0.
127     alp_bl_stat(ig) = 0.
128  ENDDO
129  DO l = 1,nlay
130    DO ig = 1,ngrid
131     therm_tke_max(ig,l) = 0.
132     env_tke_max(ig,l) = 0.
133    ENDDO
134  ENDDO
135
136!------------Test sur le LCL des thermiques
137    do ig=1,ngrid
138      ok_lcl(ig)=.false.
139      if ( (pcon(ig) .gt. pplay(ig,nlay-1)) .and. (pcon(ig) .lt. pplay(ig,1)) ) ok_lcl(ig)=.true.
140    enddo
141
142!------------Localisation des niveaux entourant le LCL et du coef d'interpolation
143    do l=1,nlay-1
144      do ig=1,ngrid
145        if (ok_lcl(ig)) then
146!ATTENTION,zw2 calcule en pplev
147!          if ((pplay(ig,l) .ge. pcon(ig)) .and. (pplay(ig,l+1) .le. pcon(ig))) then
148!          klcl(ig)=l
149!          interp(ig)=(pcon(ig)-pplay(ig,klcl(ig)))/(pplay(ig,klcl(ig)+1)-pplay(ig,klcl(ig)))
150!          endif
151          if ((pplev(ig,l) .ge. pcon(ig)) .and. (pplev(ig,l+1) .le. pcon(ig))) then
152          klcl(ig)=l
153          interp(ig)=(pcon(ig)-pplev(ig,klcl(ig)))/(pplev(ig,klcl(ig)+1)-pplev(ig,klcl(ig)))
154          endif
155        endif
156      enddo
157    enddo
158
159    do ig =1,ngrid
160!CR:REHABILITATION ZMAX CONTINU
161     if (ok_lcl(ig)) then
162      rhobarz0(ig)=rhobarz(ig,klcl(ig))+(rhobarz(ig,klcl(ig)+1) &
163 &               -rhobarz(ig,klcl(ig)))*interp(ig)
164      zlcl(ig)=(pplev(ig,1)-pcon(ig))/(rhobarz0(ig)*RG)
165      zlcl(ig)=min(zlcl(ig),zmax(ig))   ! Si zlcl > zmax alors on pose zlcl = zmax
166     else
167      rhobarz0(ig)=0.
168      zlcl(ig)=zmax(ig)
169     endif
170    enddo
171!!jyg fin
172
173!------------Calcul des propri�t�s du thermique au LCL
174  IF ( (iflag_trig_bl.ge.1) .or. (iflag_clos_bl.ge.1) ) THEN
175
176  !-----Initialisation de la TKE moyenne
177   do l=1,nlay
178    do ig=1,ngrid
179     pbl_tke_max(ig,l)=0.
180    enddo
181   enddo
182
183!-----Calcul de la TKE moyenne
184   do nsrf=1,nbsrf
185    do l=1,nlay
186     do ig=1,ngrid
187     pbl_tke_max(ig,l)=pctsrf(ig,nsrf)*pbl_tke(ig,l,nsrf)+pbl_tke_max(ig,l)
188     enddo
189    enddo
190   enddo
191
192!-----Initialisations des TKE dans et hors des thermiques
193   do l=1,nlay
194    do ig=1,ngrid
195    therm_tke_max(ig,l)=pbl_tke_max(ig,l)
196    env_tke_max(ig,l)=pbl_tke_max(ig,l)
197    enddo
198   enddo
199
200!-----Calcul de la TKE transport�e par les thermiques : therm_tke_max
201   call thermcell_tke_transport(ngrid,nlay,ptimestep,fm0,entr0,  &  ! in
202  &           rg,pplev,therm_tke_max)                               ! out
203!   print *,' thermcell_tke_transport -> '   !!jyg
204
205!-----Calcul des profils verticaux de TKE hors thermiques : env_tke_max, et de la vitesse verticale grande �chelle : W_ls
206   do l=1,nlay
207    do ig=1,ngrid
208     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
209     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
210     w_ls(ig,l)=-1.*omega(ig,l)/(RG*rhobarz(ig,l))                                                !  Vitesse verticale de grande �chelle
211    enddo
212   enddo
213!    print *,' apres w_ls = '   !!jyg
214
215  do ig=1,ngrid
216   if (ok_lcl(ig)) then
217     fraca0(ig)=fraca(ig,klcl(ig))+(fraca(ig,klcl(ig)+1) &
218 &             -fraca(ig,klcl(ig)))*interp(ig)
219     w0(ig)=zw2(ig,klcl(ig))+(zw2(ig,klcl(ig)+1) &
220 &         -zw2(ig,klcl(ig)))*interp(ig)
221     w_conv(ig)=w_ls(ig,klcl(ig))+(w_ls(ig,klcl(ig)+1) &
222 &             -w_ls(ig,klcl(ig)))*interp(ig)
223     therm_tke_max0(ig)=therm_tke_max(ig,klcl(ig)) &
224 &                     +(therm_tke_max(ig,klcl(ig)+1)-therm_tke_max(ig,klcl(ig)))*interp(ig)
225     env_tke_max0(ig)=env_tke_max(ig,klcl(ig))+(env_tke_max(ig,klcl(ig)+1) &
226 &                   -env_tke_max(ig,klcl(ig)))*interp(ig)
227     pbl_tke_max0(ig)=pbl_tke_max(ig,klcl(ig))+(pbl_tke_max(ig,klcl(ig)+1) &
228 &                   -pbl_tke_max(ig,klcl(ig)))*interp(ig)
229     if (therm_tke_max0(ig).ge.20.) therm_tke_max0(ig)=20.
230     if (env_tke_max0(ig).ge.20.) env_tke_max0(ig)=20.
231     if (pbl_tke_max0(ig).ge.20.) pbl_tke_max0(ig)=20.
232   else
233     fraca0(ig)=0.
234     w0(ig)=0.
235!!jyg le 27/04/2012
236!!     zlcl(ig)=0.
237!!
238   endif
239  enddo
240
241  ENDIF ! IF ( (iflag_trig_bl.ge.1) .or. (iflag_clos_bl.ge.1) )
242!  print *,'ENDIF  ( (iflag_trig_bl.ge.1) .or. (iflag_clos_bl.ge.1) ) '    !!jyg
243
244!------------Triggering------------------
245  IF (iflag_trig_bl.ge.1) THEN
246
247!-----Initialisations
248   depth(:)=0.
249   n2(:)=0.
250   s2(:)=100. ! some low value, arbitrary
251   s_max(:)=0.
252
253
254
255!-----Epaisseur du nuage (depth) et d�termination de la queue du spectre de panaches (n2,s2) et du panache le plus gros (s_max)
256   do ig=1,ngrid
257     zmax_moy(ig)=zlcl(ig)+zmax_moy_coef*(zmax(ig)-zlcl(ig))
258     depth(ig)=zmax_moy(ig)-zlcl(ig)
259     hmin(ig)=hmincoef*zlcl(ig)
260     if (depth(ig).ge.10.) then
261       s2(ig)=(hcoef*depth(ig)+hmin(ig))**2
262       n2(ig)=(1.-eps1)*fraca0(ig)*airephy(ig)/s2(ig)
263!!
264!!jyg le 27/04/2012
265!!       s_max(ig)=s2(ig)*log(n2(ig))
266!!       if (n2(ig) .lt. 1) s_max(ig)=0.
267       s_max(ig)=s2(ig)*log(max(n2(ig),1.))
268!!fin jyg
269     else
270       n2(ig)=0.
271       s_max(ig)=0.
272     endif
273   enddo
274!   print *,'avant Calcul de Wmax '    !!jyg
275
276!CR: calcul de strig
277   if (iflag_strig.eq.0) then
278      strig(:)=s_trig
279   else if (iflag_strig.eq.1) then
280      do ig=1,ngrid
281!         zcong_moy(ig)=zlcl(ig)+zmax_moy_coef*(zcong(ig)-zlcl(ig))
282!         strig(ig)=(hcoef*(zcong_moy(ig)-zlcl(ig))+hmin(ig))**2 
283         strig(ig)=(zcong(ig)-zlcl(ig))**2 
284      enddo
285   else if (iflag_strig.eq.2) then
286      do ig=1,ngrid
287         if (h_trig.gt.zlcl(ig)) then
288         strig(ig)=(h_trig-zlcl(ig))**2
289         else
290         strig(ig)=s_trig
291         endif
292      enddo   
293   endif
294
295   susqr2pi=su_cst*sqrt(2.*Rpi)
296   reuler=exp(1.)
297   do ig=1,ngrid
298     if ( (depth(ig).ge.10.) .and. (s_max(ig).gt.susqr2pi*reuler) ) then
299      w_max(ig)=w0(ig)*(1.+sqrt(2.*log(s_max(ig)/susqr2pi)-log(2.*log(s_max(ig)/susqr2pi))))
300      ale_bl_stat(ig)=0.5*w_max(ig)**2
301     else
302      w_max(ig)=0.
303      ale_bl_stat(ig)=0.
304     endif
305   enddo
306
307  ENDIF ! iflag_trig_bl
308!  print *,'ENDIF  iflag_trig_bl'    !!jyg
309
310!------------Closure------------------
311
312  IF (iflag_clos_bl.ge.2) THEN
313
314!-----Calcul de ALP_BL_STAT
315  do ig=1,ngrid
316  alp_bl_det(ig)=0.5*coef_m*rhobarz0(ig)*(w0(ig)**3)*fraca0(ig)*(1.-2.*fraca0(ig))/((1.-fraca0(ig))**2)
317  alp_bl_fluct_m(ig)=1.5*rhobarz0(ig)*fraca0(ig)*(w_conv(ig)+coef_m*w0(ig))* &
318 &                   (w0(ig)**2)
319  alp_bl_fluct_tke(ig)=3.*coef_m*rhobarz0(ig)*w0(ig)*fraca0(ig)*(therm_tke_max0(ig)-env_tke_max0(ig)) &
320 &                    +3.*rhobarz0(ig)*w_conv(ig)*pbl_tke_max0(ig)
321    if (iflag_clos_bl.ge.2) then
322    alp_bl_conv(ig)=1.5*coef_m*rhobarz0(ig)*fraca0(ig)*(fraca0(ig)/(1.-fraca0(ig)))*w_conv(ig)* &
323 &                   (w0(ig)**2)
324    else
325    alp_bl_conv(ig)=0.
326    endif
327  alp_bl_stat(ig)=alp_bl_det(ig)+alp_bl_fluct_m(ig)+alp_bl_fluct_tke(ig)+alp_bl_conv(ig)
328  enddo
329
330!-----S�curit� ALP infinie
331  do ig=1,ngrid
332   if (fraca0(ig).gt.0.98) alp_bl_stat(ig)=2.
333  enddo
334
335  ENDIF ! (iflag_clos_bl.ge.2)
336
337!!! fin nrlmd le 10/04/2012
338
339!      print*,'avant calcul ale et alp'
340!calcul de ALE et ALP pour la convection
341      alp_bl(:)=0.
342      ale_bl(:)=0.
343!          print*,'ALE,ALP ,l,zw2(ig,l),ale_bl(ig),alp_bl(ig)'
344      do l=1,nlay
345      do ig=1,ngrid
346           alp_bl(ig)=max(alp_bl(ig),0.5*rhobarz(ig,l)*wth3(ig,l) )
347           ale_bl(ig)=max(ale_bl(ig),0.5*zw2(ig,l)**2)
348!          print*,'ALE,ALP',l,zw2(ig,l),ale_bl(ig),alp_bl(ig)
349      enddo
350      enddo
351
352! ale sec (max de wmax/2 sous la zone d'inhibition) dans
353! le cas iflag_trig_bl=3
354      IF (iflag_trig_bl==3) ale_bl(:)=0.5*wmax_sec(:)**2
355
356!test:calcul de la ponderation des couches pour KE
357!initialisations
358
359      fm_tot(:)=0.
360      wght_th(:,:)=1.
361      lalim_conv(:)=lalim(:)
362
363      do k=1,nlay
364         do ig=1,ngrid
365            if (k<=lalim_conv(ig)) fm_tot(ig)=fm_tot(ig)+fm(ig,k)
366         enddo
367      enddo
368
369! assez bizarre car, si on est dans la couche d'alim et que alim_star et
370! plus petit que 1.e-10, on prend wght_th=1.
371      do k=1,nlay
372         do ig=1,ngrid
373            if (k<=lalim_conv(ig).and.alim_star(ig,k)>1.e-10) then
374               wght_th(ig,k)=alim_star(ig,k)
375            endif
376         enddo
377      enddo
378
379!      print*,'apres wght_th'
380!test pour prolonger la convection
381      do ig=1,ngrid
382!v1d  if ((alim_star(ig,1).lt.1.e-10).and.(therm)) then
383      if ((alim_star(ig,1).lt.1.e-10)) then
384      lalim_conv(ig)=1
385      wght_th(ig,1)=1.
386!      print*,'lalim_conv ok',lalim_conv(ig),wght_th(ig,1)
387      endif
388      enddo
389
390!------------------------------------------------------------------------
391! Modif CR/FH 20110310 : alp integree sur la verticale.
392! Integrale verticale de ALP.
393! wth3 etant aux niveaux inter-couches, on utilise d play comme masse des
394! couches
395!------------------------------------------------------------------------
396
397      alp_int(:)=0.
398      dp_int(:)=0.
399      do l=2,nlay
400        do ig=1,ngrid
401           if(l.LE.lmax(ig)) THEN
402           zdp=pplay(ig,l-1)-pplay(ig,l)
403           alp_int(ig)=alp_int(ig)+0.5*rhobarz(ig,l)*wth3(ig,l)*zdp
404           dp_int(ig)=dp_int(ig)+zdp
405           endif
406        enddo
407      enddo
408
409      if (iflag_coupl>=3 .and. iflag_coupl<=5) then
410      do ig=1,ngrid
411!valeur integree de alp_bl * 0.5:
412        if (dp_int(ig)>0.) then
413        alp_bl(ig)=alp_int(ig)/dp_int(ig)
414        endif
415      enddo!
416      endif
417
418
419! Facteur multiplicatif sur alp_bl
420      alp_bl(:)=alp_bl_k*alp_bl(:)
421
422!------------------------------------------------------------------------
423
424
425
426      return
427    END SUBROUTINE thermcell_alp
428END MODULE lmdz_thermcell_alp
Note: See TracBrowser for help on using the repository browser.