Context Navigation

lmdz_thermcell_main.F90 @ 5450

Last change on this file since 5450 was 5390, checked in by yann meurdesoif, 3 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)

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
Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

File size: 35.2 KB

Line
1	MODULE lmdz_thermcell_main
2	! $Id: lmdz_thermcell_main.F90 5390 2024-12-05 16:09:25Z aborella $
3	!
4	! A REGARDER !!!!!!!!!!!!!!!!!
5	! ATTENTION : zpspsk est inout et out mais c'est pas forcement pour de bonnes raisons (FH, 2023)
6	! ATTENTION : dans thermcell_env, on condense potentiellement de l'eau. Mais comme on ne mélange pas l'eau liquide supposant qu'il n'y en n'a pas, c'est potentiellement un souci
7	CONTAINS
8
9	subroutine thermcell_main(itap,ngrid,nlay,ptimestep &
10	& ,pplay,pplev,pphi,debut &
11	& ,puwind,pvwind,ptemp,p_o,ptemp_env, po_env &
12	& ,pduadj,pdvadj,pdtadj,pdoadj &
13	& ,fm0,entr0,detr0,zqta,zqla,lmax &
14	& ,ratqscth,ratqsdiff,zqsatth &
15	& ,zmax0, f0,zw2,fraca,ztv &
16	& ,zpspsk,ztla,zthl,ztva &
17	& ,pcon,rhobarz,wth3,wmax_sec,lalim,fm,alim_star,zmax,zcong &
18	#ifdef ISO
19	& ,xtpo,xtpdoadj &
20	#endif
21	& )
22
23
24
25	! USE necessaires pour les lignes importees de thermcell_env
26	USE lmdz_thermcell_ini, ONLY: thermcell_ini,dqimpl,dvdq,prt_level,lunout,prt_level
27	USE lmdz_thermcell_ini, ONLY: iflag_thermals_closure,iflag_thermals_ed,tau_thermals,r_aspect_thermals
28	USE lmdz_thermcell_ini, ONLY: iflag_thermals_down,fact_thermals_down
29	USE lmdz_thermcell_ini, ONLY: iflag_thermals_tenv
30	USE lmdz_thermcell_ini, ONLY: RD,RG
31
32	USE lmdz_thermcell_down, ONLY: thermcell_updown_dq
33	USE lmdz_thermcell_closure, ONLY: thermcell_closure
34	USE lmdz_thermcell_dq, ONLY: thermcell_dq
35	USE lmdz_thermcell_dry, ONLY: thermcell_dry
36	USE lmdz_thermcell_dv2, ONLY: thermcell_dv2
37	USE lmdz_thermcell_env, ONLY: thermcell_env
38	USE lmdz_thermcell_flux2, ONLY: thermcell_flux2
39	USE lmdz_thermcell_height, ONLY: thermcell_height
40	USE lmdz_thermcell_plume, ONLY: thermcell_plume
41	USE lmdz_thermcell_plume_6A, ONLY: thermcell_plume_6A,thermcell_plume_5B
42
43	! USE necessaires pour les lignes importees de thermcell_env
44	USE lmdz_thermcell_ini, ONLY : RLvCp,RKAPPA,RETV
45	USE lmdz_thermcell_qsat, ONLY : thermcell_qsat
46
47
48	#ifdef ISO
49	USE infotrac_phy, ONLY : ntiso
50	#ifdef ISOVERIF
51	USE isotopes_mod, ONLY : iso_eau,iso_HDO
52	USE isotopes_verif_mod, ONLY: iso_verif_egalite, &
53	iso_verif_aberrant_encadre
54	#endif
55	#endif
56
57
58	IMPLICIT NONE
59
60	!=======================================================================
61	! Auteurs: Frederic Hourdin, Catherine Rio, Anne Mathieu
62	! Version du 09.02.07
63	! Calcul du transport vertical dans la couche limite en presence
64	! de "thermiques" explicitement representes avec processus nuageux
65	!
66	! Reecriture a partir d'un listing papier a Habas, le 14/02/00
67	!
68	! le thermique est suppose homogene et dissipe par melange avec
69	! son environnement. la longueur l_mix controle l'efficacite du
70	! melange
71	!
72	! Le calcul du transport des differentes especes se fait en prenant
73	! en compte:
74	! 1. un flux de masse montant
75	! 2. un flux de masse descendant
76	! 3. un entrainement
77	! 4. un detrainement
78	!
79	! Modif 2013/01/04 (FH hourdin@lmd.jussieu.fr)
80	! Introduction of an implicit computation of vertical advection in
81	! the environment of thermal plumes in thermcell_dq
82	! impl = 0 : explicit, 1 : implicit, -1 : old version
83	! controled by iflag_thermals =
84	! 15, 16 run with impl=-1 : numerical convergence with NPv3
85	! 17, 18 run with impl=1 : more stable
86	! 15 and 17 correspond to the activation of the stratocumulus "bidouille"
87	!
88	! Using
89	! abort_physic
90	! iso_verif_aberrant_encadre
91	! iso_verif_egalite
92	! test_ltherm
93	! thermcell_closure
94	! thermcell_dq
95	! thermcell_dry
96	! thermcell_dv2
97	! thermcell_env
98	! thermcell_flux2
99	! thermcell_height
100	! thermcell_plume
101	! thermcell_plume_5B
102	! thermcell_plume_6A
103	!
104	!=======================================================================
105
106
107	!-----------------------------------------------------------------------
108	! declarations:
109	! -------------
110
111
112	! arguments:
113	! ----------
114	integer, intent(in) :: itap,ngrid,nlay
115	real, intent(in) :: ptimestep
116	real, intent(in), dimension(ngrid,nlay) :: ptemp,puwind,pvwind,pplay,pphi,ptemp_env,po_env
117	! ATTENTION : zpspsk est inout et out mais c'est pas forcement pour de bonnes raisons (FH, 2023)
118	real, intent(in), dimension(ngrid,nlay) :: p_o
119	real, intent(out), dimension(ngrid,nlay) :: zpspsk
120	real, intent(in), dimension(ngrid,nlay+1) :: pplev
121	integer, intent(out), dimension(ngrid) :: lmax
122	real, intent(out), dimension(ngrid,nlay) :: pdtadj,pduadj,pdvadj,pdoadj,entr0,detr0
123	real, intent(out), dimension(ngrid,nlay) :: ztla,zqla,zqta,zqsatth,zthl
124	real, intent(out), dimension(ngrid,nlay+1) :: fm0,zw2,fraca
125	real, intent(inout), dimension(ngrid) :: zmax0,f0
126	real, intent(out), dimension(ngrid,nlay) :: ztva,ztv
127	logical, intent(in) :: debut
128	real,intent(out), dimension(ngrid,nlay) :: ratqscth,ratqsdiff
129
130	real, intent(out), dimension(ngrid) :: pcon
131	real, intent(out), dimension(ngrid,nlay) :: rhobarz,wth3
132	real, intent(out), dimension(ngrid) :: wmax_sec
133	integer,intent(out), dimension(ngrid) :: lalim
134	real, intent(out), dimension(ngrid,nlay+1) :: fm
135	real, intent(out), dimension(ngrid,nlay) :: alim_star
136	real, intent(out), dimension(ngrid) :: zmax,zcong
137
138	! local:
139	! ------
140
141
142	integer,save :: igout=1
143	!$OMP THREADPRIVATE(igout)
144	integer,save :: lunout1=6
145	!$OMP THREADPRIVATE(lunout1)
146	integer,save :: lev_out=10
147	!$OMP THREADPRIVATE(lev_out)
148
149	real lambda, zf,zf2,var,vardiff,CHI
150	integer ig,k,l,ierr,ll
151	logical sorties
152	real, dimension(ngrid) :: linter,zmix, zmax_sec,lintercong
153	integer,dimension(ngrid) :: lmin,lmix,lmix_bis,nivcon, lcong
154	real, dimension(ngrid,nlay) :: ztva_est
155	real, dimension(ngrid,nlay) :: deltaz,zlay,zdthladj,zu,zv,z_o,zl,zva,zua,z_oa
156	real, dimension(ngrid,nlay) :: ztemp_env ! temperarure liquide de l'environnement
157	real, dimension(ngrid,nlay) :: zta,zha,q2,wq,wthl,wthv,thetath2,wth2
158	real, dimension(ngrid,nlay) :: rho,masse
159	real, dimension(ngrid,nlay+1) :: zw_est,zlev
160	real, dimension(ngrid) :: wmax,wmax_tmp
161	real, dimension(ngrid,nlay+1) :: f_star
162	real, dimension(ngrid,nlay) :: entr,detr,entr_star,detr_star,alim_star_clos
163	real, dimension(ngrid,nlay) :: zqsat,csc
164	real, dimension(ngrid) :: zcon,zcon2,alim_star_tot,f
165	real, dimension(ngrid,nlay) :: entrdn,detrdn
166	logical, dimension(ngrid,nlay) :: mask
167
168	character (len=20) :: modname='thermcell_main'
169	character (len=80) :: abort_message
170
171
172	#ifdef ISO
173	REAL xtpo(ntiso,ngrid,nlay),xtpdoadj(ntiso,ngrid,nlay)
174	REAL xtzo(ntiso,ngrid,nlay)
175	REAL xtpdoadj_tmp(ngrid,nlay)
176	REAL xtpo_tmp(ngrid,nlay)
177	REAL xtzo_tmp(ngrid,nlay)
178	integer ixt
179	#endif
180
181	!
182
183	!-----------------------------------------------------------------------
184	! initialisation:
185	! ---------------
186	!
187	fm=0. ; entr=0. ; detr=0.
188
189	if (prt_level.ge.1) print*,'thermcell_main V4'
190
191	sorties=.true.
192	IF(ngrid.NE.ngrid) THEN
193	PRINT*
194	PRINT*,'STOP dans convadj'
195	PRINT*,'ngrid =',ngrid
196	PRINT*,'ngrid =',ngrid
197	ENDIF
198	!
199	!print*,'thermcell_main debut'
200	! write(lunout,*)'WARNING thermcell_main f0=max(f0,1.e-2)'
201	do ig=1,ngrid
202	f0(ig)=max(f0(ig),1.e-2)
203	zmax0(ig)=max(zmax0(ig),40.)
204	!IMmarche pas ?! if (f0(ig)<1.e-2) f0(ig)=1.e-2
205	enddo
206
207	if (prt_level.ge.20) then
208	do ig=1,ngrid
209	print*,'th_main ig f0',ig,f0(ig)
210	enddo
211	endif
212
213	!-----------------------------------------------------------------------
214	! Calcul de T,q,ql a partir de Tl et qT dans l environnement
215	! --------------------------------------------------------------------
216	!
217	! On condense l'eau liquide si besoin.
218	! En fait on arrive ici d'habitude (jusque 6A) après réévaporation
219	! Dans une nouvelle mouture, on passe les profiles
220	! avant la couche limite : iflag_thermals_tenv=1
221	! dés le début de la physique : iflag_thermals_tenv=2
222	! Mais même pour 2) on ne veut sans doute pas réévaporer.
223	! On veut comparer thetav dans le thermique, après condensation,
224	! avec le theta_v effectif de l'environnement.
225
226	if (iflag_thermals_tenv - 10 * ( iflag_thermals_tenv / 10 ) == 0) then
227
228	CALL thermcell_env(ngrid,nlay,p_o,ptemp_env,puwind,pvwind,pplay, &
229	& pplev,z_o,ztemp_env,zl,ztv,zthl,zu,zv,zpspsk,zqsat,lcong,lintercong,lev_out)
230
231	else
232
233	! Chantier en cours : ne pas effacer (Fredho). 15 septembre 2023
234	! Dans la version originale de thermcell_env, on condense l'eau de l'environnement
235	! pour calculer une temperature potentielle liquide.
236	! On en déduit un Theta v.
237
238	! ...
239	! contenu de thermcell_env
240	! SUBROUTINE thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay, &
241	! & pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,pqsat,lev_out)
242	! contenu thermcell_env : call thermcell_qsat(ngrid*nlay,mask,pplev,pt,po,pqsat)
243	! contenu thermcell_env : do ll=1,nlay
244	! contenu thermcell_env : do ig=1,ngrid
245	! contenu thermcell_env : zl(ig,ll) = max(0.,po(ig,ll)-pqsat(ig,ll))
246	! contenu thermcell_env : zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll) ! T = Tl + Lv/Cp ql
247	! contenu thermcell_env : zo(ig,ll) = po(ig,ll)-zl(ig,ll)
248	! contenu thermcell_env : enddo
249	! contenu thermcell_env : enddo
250	! contenu thermcell_env : do ll=1,nlay
251	! contenu thermcell_env : do ig=1,ngrid
252	! contenu thermcell_env : zpspsk(ig,ll)=(pplay(ig,ll)/100000.)**RKAPPA
253	! contenu thermcell_env : zu(ig,ll)=pu(ig,ll)
254	! contenu thermcell_env : zv(ig,ll)=pv(ig,ll)
255	! contenu thermcell_env : ztv(ig,ll)=zh(ig,ll)/zpspsk(ig,ll)
256	! contenu thermcell_env : ztv(ig,ll)=ztv(ig,ll)(1.+RETV(zo(ig,ll))-zl(ig,ll))
257	! contenu thermcell_env : zthl(ig,ll)=pt(ig,ll)/zpspsk(ig,ll)
258	! contenu thermcell_env : enddo
259	! contenu thermcell_env : enddo
260
261	do l=1,nlay
262	do ig=1,ngrid
263	zl(ig,l)=0.
264	zu(ig,l)=puwind(ig,l)
265	zv(ig,l)=pvwind(ig,l)
266	ztemp_env(ig,l)=ptemp_env(ig,l)
267	zpspsk(ig,l)=(pplay(ig,l)/100000.)**RKAPPA
268	ztv(ig,l)=ztemp_env(ig,l)/zpspsk(ig,l)
269	ztv(ig,l)=ztv(ig,l)(1.+RETVpo_env(ig,l))
270	zthl(ig,l)=ptemp(ig,l)/zpspsk(ig,l)
271	mask(ig,l)=.true.
272	enddo
273	enddo
274	call thermcell_qsat(ngrid*nlay,mask,pplev,ptemp_env,p_o,zqsat)
275
276	endif
277
278	if (prt_level.ge.1) print*,'thermcell_main apres thermcell_env'
279
280	!------------------------------------------------------------------------
281	! --------------------
282	!
283	!
284	! + + + + + + + + + + +
285	!
286	!
287	! wa, fraca, wd, fracd -------------------- zlev(2), rhobarz
288	! wh,wt,wo ...
289	!
290	! + + + + + + + + + + + zh,zu,zv,z_o,rho
291	!
292	!
293	! -------------------- zlev(1)
294	! \\\\\\\\\\\\\\\\\\\\
295	!
296	!
297
298	!-----------------------------------------------------------------------
299	! Calcul des altitudes des couches
300	!-----------------------------------------------------------------------
301
302	do l=2,nlay
303	zlev(:,l)=0.5*(pphi(:,l)+pphi(:,l-1))/RG
304	enddo
305	zlev(:,1)=0.
306	zlev(:,nlay+1)=(2.*pphi(:,nlay)-pphi(:,nlay-1))/RG
307	do l=1,nlay
308	zlay(:,l)=pphi(:,l)/RG
309	enddo
310	do l=1,nlay
311	deltaz(:,l)=zlev(:,l+1)-zlev(:,l)
312	enddo
313
314	!-----------------------------------------------------------------------
315	! Calcul des densites et masses
316	!-----------------------------------------------------------------------
317
318	rho(:,:)=pplay(:,:)/(zpspsk(:,:)RDztv(:,:))
319	if (prt_level.ge.10) write(lunout,*) 'WARNING thermcell_main rhobarz(:,1)=rho(:,1)'
320	rhobarz(:,1)=rho(:,1)
321	do l=2,nlay
322	rhobarz(:,l)=0.5*(rho(:,l)+rho(:,l-1))
323	enddo
324	do l=1,nlay
325	masse(:,l)=(pplev(:,l)-pplev(:,l+1))/RG
326	enddo
327	if (prt_level.ge.1) print*,'thermcell_main apres initialisation'
328
329	!------------------------------------------------------------------
330	!
331	! /\|\
332	! -------- \| F_k+1 -------
333	! ----> D_k
334	! /\|\ <---- E_k , A_k
335	! -------- \| F_k ---------
336	! ----> D_k-1
337	! <---- E_k-1 , A_k-1
338	!
339	!
340	!
341	!
342	!
343	! ---------------------------
344	!
345	! ----- F_lmax+1=0 ---------- \
346	! lmax (zmax) \|
347	! --------------------------- \|
348	! \|
349	! --------------------------- \|
350	! \|
351	! --------------------------- \|
352	! \|
353	! --------------------------- \|
354	! \|
355	! --------------------------- \|
356	! \| E
357	! --------------------------- \| D
358	! \|
359	! --------------------------- \|
360	! \|
361	! --------------------------- \ \|
362	! lalim \| \|
363	! --------------------------- \| \|
364	! \| \|
365	! --------------------------- \| \|
366	! \| A \|
367	! --------------------------- \| \|
368	! \| \|
369	! --------------------------- \| \|
370	! lmin (=1 pour le moment) \| \|
371	! ----- F_lmin=0 ------------ / /
372	!
373	! ---------------------------
374	! //////////////////////////
375	!
376	!
377	!=============================================================================
378	! Calculs initiaux ne faisant pas intervenir les changements de phase
379	!=============================================================================
380
381	!------------------------------------------------------------------
382	! 1. alim_star est le profil vertical de l'alimentation a la base du
383	! panache thermique, calcule a partir de la flotabilite de l'air sec
384	! 2. lmin et lalim sont les indices inferieurs et superieurs de alim_star
385	!------------------------------------------------------------------
386	!
387	entr_star=0. ; detr_star=0. ; alim_star=0. ; alim_star_tot=0.
388	lmin=1
389
390	!-----------------------------------------------------------------------------
391	! 3. wmax_sec et zmax_sec sont les vitesses et altitudes maximum d'un
392	! panache sec conservatif (e=d=0) alimente selon alim_star
393	! Il s'agit d'un calcul de type CAPE
394	! zmax_sec est utilise pour determiner la geometrie du thermique.
395	!------------------------------------------------------------------------------
396	!---------------------------------------------------------------------------------
397	!calcul du melange et des variables dans le thermique
398	!--------------------------------------------------------------------------------
399	!
400	if (prt_level.ge.1) print*,'avant thermcell_plume ',lev_out
401
402	!=====================================================================
403	! Old version of thermcell_plume in thermcell_plume_6A.F90
404	! It includes both thermcell_plume_6A and thermcell_plume_5B corresponding
405	! to the 5B and 6A versions used for CMIP5 and CMIP6.
406	! The latest was previously named thermcellV1_plume.
407	! The new thermcell_plume is a clean version (removing obsolete
408	! options) of thermcell_plume_6A.
409	! The 3 versions are controled by
410	! flag_thermals_ed <= 9 thermcell_plume_6A
411	! <= 19 thermcell_plume_5B
412	! else thermcell_plume (default 20 for convergence with 6A)
413	! Fredho
414	!=====================================================================
415
416	if (iflag_thermals_ed<=9) then
417	! print*,'THERM NOUVELLE/NOUVELLE Arnaud'
418	CALL thermcell_plume_6A(itap,ngrid,nlay,ptimestep,ztv,zthl,p_o,zl,rhobarz,&
419	& zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, &
420	& lalim,f0,detr_star,entr_star,f_star,csc,ztva, &
421	& ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter &
422	& ,lev_out,lunout1,igout)
423
424	elseif (iflag_thermals_ed<=19) then
425	! print*,'THERM RIO et al 2010, version d Arnaud'
426	CALL thermcell_plume_5B(itap,ngrid,nlay,ptimestep,ztv,zthl,p_o,zl,rhobarz,&
427	& zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, &
428	& lalim,f0,detr_star,entr_star,f_star,csc,ztva, &
429	& ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter &
430	& ,lev_out,lunout1,igout)
431	else
432	CALL thermcell_plume(itap,ngrid,nlay,ptimestep,ztv,zthl,p_o,zl,rhobarz,&
433	& zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, &
434	& lalim,f0,detr_star,entr_star,f_star,csc,ztva, &
435	& ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter &
436	& ,lev_out,lunout1,igout)
437	endif
438
439	if (prt_level.ge.1) print*,'apres thermcell_plume ',lev_out
440
441	call test_ltherm(ngrid,nlay,pplay,lalim,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_plum lalim ')
442	call test_ltherm(ngrid,nlay,pplay,lmix ,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_plum lmix ')
443
444	if (prt_level.ge.1) print*,'thermcell_main apres thermcell_plume'
445	if (prt_level.ge.10) then
446	write(lunout1,*) 'Dans thermcell_main 2'
447	write(lunout1,*) 'lmin ',lmin(igout)
448	write(lunout1,*) 'lalim ',lalim(igout)
449	write(lunout1,*) ' ig l alim_star entr_star detr_star f_star '
450	write(lunout1,'(i6,i4,4e15.5)') (igout,l,alim_star(igout,l),entr_star(igout,l),detr_star(igout,l) &
451	& ,f_star(igout,l+1),l=1,nint(linter(igout))+5)
452	endif
453
454	!-------------------------------------------------------------------------------
455	! Calcul des caracteristiques du thermique:zmax,zmix,wmax
456	!-------------------------------------------------------------------------------
457	!
458	CALL thermcell_height(ngrid,nlay,lalim,lmin,linter,lcong,lintercong,lmix,zw2, &
459	& zlev,lmax,zmax,zmax0,zmix,wmax,zcong)
460	! Attention, w2 est transforme en sa racine carree dans cette routine
461	! Le probleme vient du fait que linter et lmix sont souvent egaux a 1.
462	wmax_tmp=0.
463	do l=1,nlay
464	wmax_tmp(:)=max(wmax_tmp(:),zw2(:,l))
465	enddo
466	! print*,"ZMAX ",lalim,lmin,linter,lmix,lmax,zmax,zmax0,zmix,wmax
467
468
469
470	call test_ltherm(ngrid,nlay,pplay,lalim,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_heig lalim ')
471	call test_ltherm(ngrid,nlay,pplay,lmin ,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_heig lmin ')
472	call test_ltherm(ngrid,nlay,pplay,lmix ,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_heig lmix ')
473	call test_ltherm(ngrid,nlay,pplay,lmax ,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_heig lmax ')
474
475	if (prt_level.ge.1) print*,'thermcell_main apres thermcell_height'
476
477	!-------------------------------------------------------------------------------
478	! Fermeture,determination de f
479	!-------------------------------------------------------------------------------
480	!
481	!
482	CALL thermcell_dry(ngrid,nlay,zlev,pphi,ztv,alim_star, &
483	& lalim,lmin,zmax_sec,wmax_sec)
484
485
486	call test_ltherm(ngrid,nlay,pplay,lmin,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_dry lmin ')
487	call test_ltherm(ngrid,nlay,pplay,lalim,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_dry lalim ')
488
489	if (prt_level.ge.1) print*,'thermcell_main apres thermcell_dry'
490	if (prt_level.ge.10) then
491	write(lunout1,*) 'Dans thermcell_main 1b'
492	write(lunout1,*) 'lmin ',lmin(igout)
493	write(lunout1,*) 'lalim ',lalim(igout)
494	write(lunout1,*) ' ig l alim_star entr_star detr_star f_star '
495	write(lunout1,'(i6,i4,e15.5)') (igout,l,alim_star(igout,l) &
496	& ,l=1,lalim(igout)+4)
497	endif
498
499
500
501
502	! Choix de la fonction d'alimentation utilisee pour la fermeture.
503	! Apparemment sans importance
504	alim_star_clos(:,:)=alim_star(:,:)
505	alim_star_clos(:,:)=entr_star(:,:)+alim_star(:,:)
506	!
507	!CR Appel de la fermeture seche
508	if (iflag_thermals_closure.eq.1) then
509
510	CALL thermcell_closure(ngrid,nlay,r_aspect_thermals,ptimestep,rho, &
511	& zlev,lalim,alim_star_clos,zmax_sec,wmax_sec,f)
512
513	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
514	! Appel avec les zmax et wmax tenant compte de la condensation
515	! Semble moins bien marcher
516	else if (iflag_thermals_closure.eq.2) then
517
518	CALL thermcell_closure(ngrid,nlay,r_aspect_thermals,ptimestep,rho, &
519	& zlev,lalim,alim_star,zmax,wmax,f)
520
521
522	endif
523
524	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
525
526	if(prt_level.ge.1)print*,'thermcell_closure apres thermcell_closure'
527
528	if (tau_thermals>1.) then
529	lambda=exp(-ptimestep/tau_thermals)
530	f0=(1.-lambda)f+lambdaf0
531	else
532	f0=f
533	endif
534
535	! Test valable seulement en 1D mais pas genant
536	if (.not. (f0(1).ge.0.) ) then
537	abort_message = '.not. (f0(1).ge.0.)'
538	CALL abort_physic (modname,abort_message,1)
539	endif
540
541	!-------------------------------------------------------------------------------
542	!deduction des flux
543
544	CALL thermcell_flux2(ngrid,nlay,ptimestep,masse, &
545	& lalim,lmax,alim_star, &
546	& entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr, &
547	& detr,zqla,lev_out,lunout1,igout)
548
549	!IM 060508 & detr,zqla,zmax,lev_out,lunout,igout)
550
551	if (prt_level.ge.1) print*,'thermcell_main apres thermcell_flux'
552	call test_ltherm(ngrid,nlay,pplay,lalim,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_flux lalim ')
553	call test_ltherm(ngrid,nlay,pplay,lmax ,ztv,p_o,ztva,zqla,f_star,zw2,'thermcell_flux lmax ')
554
555	!------------------------------------------------------------------
556	! On ne prend pas directement les profils issus des calculs precedents
557	! mais on s'autorise genereusement une relaxation vers ceci avec
558	! une constante de temps tau_thermals (typiquement 1800s).
559	!------------------------------------------------------------------
560
561	if (tau_thermals>1.) then
562	lambda=exp(-ptimestep/tau_thermals)
563	fm0=(1.-lambda)fm+lambdafm0
564	entr0=(1.-lambda)entr+lambdaentr0
565	detr0=(1.-lambda)detr+lambdadetr0
566	else
567	fm0=fm
568	entr0=entr
569	detr0=detr
570	endif
571
572	!------------------------------------------------------------------
573	! Calcul de la fraction de l'ascendance
574	!------------------------------------------------------------------
575	do ig=1,ngrid
576	fraca(ig,1)=0.
577	fraca(ig,nlay+1)=0.
578	enddo
579	do l=2,nlay
580	do ig=1,ngrid
581	if (zw2(ig,l).gt.1.e-10) then
582	fraca(ig,l)=fm(ig,l)/(rhobarz(ig,l)*zw2(ig,l))
583	else
584	fraca(ig,l)=0.
585	endif
586	enddo
587	enddo
588
589	!c------------------------------------------------------------------
590	! calcul du transport vertical
591	!------------------------------------------------------------------
592	IF (iflag_thermals_down .GT. 0) THEN
593	if (debut) print*,'WARNING !!! routine thermcell_down en cours de developpement'
594	entrdn=fact_thermals_down*detr0
595	detrdn=fact_thermals_down*entr0
596	! we want to transport potential temperature, total water and momentum
597	CALL thermcell_updown_dq(ngrid,nlay,ptimestep,lmax,entr0,detr0,entrdn,detrdn,masse,zthl,zdthladj)
598	CALL thermcell_updown_dq(ngrid,nlay,ptimestep,lmax,entr0,detr0,entrdn,detrdn,masse,p_o,pdoadj)
599	CALL thermcell_updown_dq(ngrid,nlay,ptimestep,lmax,entr0,detr0,entrdn,detrdn,masse,zu,pduadj)
600	CALL thermcell_updown_dq(ngrid,nlay,ptimestep,lmax,entr0,detr0,entrdn,detrdn,masse,zv,pdvadj)
601	ELSE
602	!--------------------------------------------------------------
603
604	! Temperature potentielle liquide effectivement mélangée par les thermiques
605	do ll=1,nlay
606	do ig=1,ngrid
607	zthl(ig,ll)=ptemp(ig,ll)/zpspsk(ig,ll)
608	enddo
609	enddo
610	call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse, &
611	& zthl,zdthladj,zta,lev_out)
612
613	do ll=1,nlay
614	do ig=1,ngrid
615	z_o(ig,ll)=p_o(ig,ll)
616	enddo
617	enddo
618	call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse, &
619	& z_o,pdoadj,z_oa,lev_out)
620
621	#ifdef ISO
622	! C Risi: on utilise directement la meme routine
623	do ixt=1,ntiso
624	do ll=1,nlay
625	DO ig=1,ngrid
626	xtpo_tmp(ig,ll)=xtpo(ixt,ig,ll)
627	xtzo_tmp(ig,ll)=xtzo(ixt,ig,ll)
628	enddo
629	enddo
630	call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse, &
631	& xtpo_tmp,xtpdoadj_tmp,xtzo_tmp,lev_out)
632	do ll=1,nlay
633	DO ig=1,ngrid
634	xtpdoadj(ixt,ig,ll)=xtpdoadj_tmp(ig,ll)
635	enddo
636	enddo
637	enddo
638	#endif
639
640	#ifdef ISO
641	#ifdef ISOVERIF
642	DO ll=1,nlay
643	DO ig=1,ngrid
644	if (iso_eau.gt.0) then
645	call iso_verif_egalite(xtpo(iso_eau,ig,ll), &
646	& p_o(ig,ll),'thermcell_main 594')
647	call iso_verif_egalite(xtpdoadj(iso_eau,ig,ll), &
648	& pdoadj(ig,ll),'thermcell_main 596')
649	endif
650	if (iso_HDO.gt.0) then
651	call iso_verif_aberrant_encadre(xtpo(iso_hdo,ig,ll) &
652	& /p_o(ig,ll),'thermcell_main 610')
653	endif
654	enddo
655	enddo !DO ll=1,nlay
656	write(,) 'thermcell_main 600 tmp: apres thermcell_dq'
657	#endif
658	#endif
659
660
661	!------------------------------------------------------------------
662	! calcul du transport vertical du moment horizontal
663	!------------------------------------------------------------------
664
665	!IM 090508
666	if (dvdq == 0 ) then
667
668	! Calcul du transport de V tenant compte d'echange par gradient
669	! de pression horizontal avec l'environnement
670
671	call thermcell_dv2(ngrid,nlay,ptimestep,fm0,entr0,masse &
672	! & ,fraca*dvdq,zmax &
673	& ,fraca,zmax &
674	& ,zu,zv,pduadj,pdvadj,zua,zva,lev_out)
675
676	else
677
678	! calcul purement conservatif pour le transport de V
679	call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse &
680	& ,zu,pduadj,zua,lev_out)
681	call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse &
682	& ,zv,pdvadj,zva,lev_out)
683
684	endif
685	ENDIF
686
687	! print*,'13 OK convect8'
688	do l=1,nlay
689	do ig=1,ngrid
690	pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l)
691	enddo
692	enddo
693
694	if (prt_level.ge.1) print*,'14 OK convect8'
695	!------------------------------------------------------------------
696	! Calculs de diagnostiques pour les sorties
697	!------------------------------------------------------------------
698	!calcul de fraca pour les sorties
699
700	if (sorties) then
701	if (prt_level.ge.1) print*,'14a OK convect8'
702	! calcul du niveau de condensation
703	! initialisation
704	do ig=1,ngrid
705	nivcon(ig)=0
706	zcon(ig)=0.
707	enddo
708	!nouveau calcul
709	do ig=1,ngrid
710	! WARNING !!! verifier que c'est bien ztemp_env qu'on veut là
711	CHI=ztemp_env(ig,1)/(1669.0-122.0*z_o(ig,1)/zqsat(ig,1)-ztemp_env(ig,1))
712	pcon(ig)=pplay(ig,1)(z_o(ig,1)/zqsat(ig,1))*CHI
713	enddo
714	!IM do k=1,nlay
715	do k=1,nlay-1
716	do ig=1,ngrid
717	if ((pcon(ig).le.pplay(ig,k)) &
718	& .and.(pcon(ig).gt.pplay(ig,k+1))) then
719	zcon2(ig)=zlay(ig,k)-(pcon(ig)-pplay(ig,k))/(RG*rho(ig,k))/100.
720	endif
721	enddo
722	enddo
723	!IM
724	ierr=0
725	do ig=1,ngrid
726	if (pcon(ig).le.pplay(ig,nlay)) then
727	zcon2(ig)=zlay(ig,nlay)-(pcon(ig)-pplay(ig,nlay))/(RG*rho(ig,nlay))/100.
728	ierr=1
729	endif
730	enddo
731	! if (ierr==1) then
732	! abort_message = 'thermcellV0_main: les thermiques vont trop haut '
733	! CALL abort_physic (modname,abort_message,1)
734	! endif
735
736	if (prt_level.ge.1) print*,'14b OK convect8'
737	do k=nlay,1,-1
738	do ig=1,ngrid
739	if (zqla(ig,k).gt.1e-10) then
740	nivcon(ig)=k
741	zcon(ig)=zlev(ig,k)
742	endif
743	enddo
744	enddo
745	if (prt_level.ge.1) print*,'14c OK convect8'
746	!calcul des moments
747	!initialisation
748	do l=1,nlay
749	do ig=1,ngrid
750	q2(ig,l)=0.
751	wth2(ig,l)=0.
752	wth3(ig,l)=0.
753	ratqscth(ig,l)=0.
754	ratqsdiff(ig,l)=0.
755	enddo
756	enddo
757	if (prt_level.ge.1) print*,'14d OK convect8'
758	if (prt_level.ge.10)write(lunout,*) &
759	& 'WARNING thermcell_main wth2=0. si zw2 > 1.e-10'
760	do l=1,nlay
761	do ig=1,ngrid
762	zf=fraca(ig,l)
763	zf2=zf/(1.-zf)
764	!
765	thetath2(ig,l)=zf2(ztla(ig,l)-zthl(ig,l))*2
766	if(zw2(ig,l).gt.1.e-10) then
767	wth2(ig,l)=zf2(zw2(ig,l))*2
768	else
769	wth2(ig,l)=0.
770	endif
771	wth3(ig,l)=zf2(1-2.fraca(ig,l))/(1-fraca(ig,l)) &
772	& zw2(ig,l)zw2(ig,l)*zw2(ig,l)
773	q2(ig,l)=zf2(zqta(ig,l)1000.-p_o(ig,l)1000.)*2
774	!test: on calcul q2/p_o=ratqsc
775	ratqscth(ig,l)=sqrt(max(q2(ig,l),1.e-6)/(p_o(ig,l)*1000.))
776	enddo
777	enddo
778	!calcul des flux: q, thetal et thetav
779	do l=1,nlay
780	do ig=1,ngrid
781	wq(ig,l)=fraca(ig,l)zw2(ig,l)(zqta(ig,l)1000.-p_o(ig,l)1000.)
782	wthl(ig,l)=fraca(ig,l)zw2(ig,l)(ztla(ig,l)-zthl(ig,l))
783	wthv(ig,l)=fraca(ig,l)zw2(ig,l)(ztva(ig,l)-ztv(ig,l))
784	enddo
785	enddo
786
787	!calcul du ratqscdiff
788	if (prt_level.ge.1) print*,'14e OK convect8'
789	var=0.
790	vardiff=0.
791	ratqsdiff(:,:)=0.
792
793	do l=1,nlay
794	do ig=1,ngrid
795	if (l<=lalim(ig)) then
796	var=var+alim_star(ig,l)zqta(ig,l)1000.
797	endif
798	enddo
799	enddo
800
801	if (prt_level.ge.1) print*,'14f OK convect8'
802
803	do l=1,nlay
804	do ig=1,ngrid
805	if (l<=lalim(ig)) then
806	zf=fraca(ig,l)
807	zf2=zf/(1.-zf)
808	vardiff=vardiff+alim_star(ig,l)(zqta(ig,l)1000.-var)**2
809	endif
810	enddo
811	enddo
812
813	if (prt_level.ge.1) print*,'14g OK convect8'
814	do l=1,nlay
815	do ig=1,ngrid
816	ratqsdiff(ig,l)=sqrt(vardiff)/(p_o(ig,l)*1000.)
817	enddo
818	enddo
819	endif
820
821	if (prt_level.ge.1) print*,'thermcell_main FIN OK'
822
823	!print*,'thermcell_main fin'
824	RETURN
825	end subroutine thermcell_main
826
827	!=============================================================================
828	!/////////////////////////////////////////////////////////////////////////////
829	!=============================================================================
830	subroutine test_ltherm(ngrid,nlay,pplay,long,ztv,p_o,ztva, & ! in
831	& zqla,f_star,zw2,comment) ! in
832	!=============================================================================
833	USE lmdz_thermcell_ini, ONLY: prt_level
834	IMPLICIT NONE
835
836	integer i, k, ngrid,nlay
837	real, intent(in), dimension(ngrid,nlay) :: pplay,ztv,p_o,ztva,zqla
838	real, intent(in), dimension(ngrid,nlay) :: f_star,zw2
839	integer, intent(in), dimension(ngrid) :: long
840	real seuil
841	character*21 comment
842
843	seuil=0.25
844
845	if (prt_level.ge.1) THEN
846	print*,'WARNING !!! TEST ',comment
847	endif
848	return
849
850	! test sur la hauteur des thermiques ...
851	do i=1,ngrid
852	!IMtemp if (pplay(i,long(i)).lt.seuil*pplev(i,1)) then
853	if (prt_level.ge.10) then
854	print*,'WARNING ',comment,' au point ',i,' K= ',long(i)
855	print,' K P(MB) THV(K) Qenv(g/kg)THVA QLA(g/kg) F W2'
856	do k=1,nlay
857	write(6,'(i3,7f10.3)') k,pplay(i,k),ztv(i,k),1000p_o(i,k),ztva(i,k),1000zqla(i,k),f_star(i,k),zw2(i,k)
858	enddo
859	endif
860	enddo
861
862
863	return
864	end subroutine test_ltherm
865
866	! nrlmd le 10/04/2012 Transport de la TKE par le thermique moyen pour la fermeture en ALP
867	! On transporte pbl_tke pour donner therm_tke
868	! Copie conforme de la subroutine DTKE dans physiq.F ecrite par Frederic Hourdin
869
870	!=======================================================================
871	!///////////////////////////////////////////////////////////////////////
872	!=======================================================================
873
874	subroutine thermcell_tke_transport( &
875	& ngrid,nlay,ptimestep,fm0,entr0,rg,pplev, & ! in
876	& therm_tke_max) ! out
877	USE lmdz_thermcell_ini, ONLY: prt_level
878	implicit none
879
880	!=======================================================================
881	!
882	! Calcul du transport verticale dans la couche limite en presence
883	! de "thermiques" explicitement representes
884	! calcul du dq/dt une fois qu'on connait les ascendances
885	!
886	!=======================================================================
887
888	integer ngrid,nlay
889
890	real, intent(in) :: ptimestep
891	real, intent(in), dimension(ngrid,nlay+1) :: fm0,pplev
892	real, intent(in), dimension(ngrid,nlay) :: entr0
893	real, intent(in) :: rg
894	real, intent(out), dimension(ngrid,nlay) :: therm_tke_max
895
896	real detr0(ngrid,nlay)
897	real masse0(ngrid,nlay)
898	real masse(ngrid,nlay),fm(ngrid,nlay+1)
899	real entr(ngrid,nlay)
900	real q(ngrid,nlay)
901	integer lev_out ! niveau pour les print
902
903	real qa(ngrid,nlay),detr(ngrid,nlay),wqd(ngrid,nlay+1)
904	integer ig,k
905
906
907	lev_out=0
908
909
910	if (prt_level.ge.1) print*,'Q2 THERMCEL_DQ 0'
911
912	! calcul du detrainement
913	do k=1,nlay
914	detr0(:,k)=fm0(:,k)-fm0(:,k+1)+entr0(:,k)
915	masse0(:,k)=(pplev(:,k)-pplev(:,k+1))/RG
916	enddo
917
918
919	! Decalage vertical des entrainements et detrainements.
920	masse(:,1)=0.5*masse0(:,1)
921	entr(:,1)=0.5*entr0(:,1)
922	detr(:,1)=0.5*detr0(:,1)
923	fm(:,1)=0.
924	do k=1,nlay-1
925	masse(:,k+1)=0.5*(masse0(:,k)+masse0(:,k+1))
926	entr(:,k+1)=0.5*(entr0(:,k)+entr0(:,k+1))
927	detr(:,k+1)=0.5*(detr0(:,k)+detr0(:,k+1))
928	fm(:,k+1)=fm(:,k)+entr(:,k)-detr(:,k)
929	enddo
930	fm(:,nlay+1)=0.
931
932
933	q(:,:)=therm_tke_max(:,:)
934	!!! nrlmd le 16/09/2010
935	do ig=1,ngrid
936	qa(ig,1)=q(ig,1)
937	enddo
938	!!!
939
940	if (1==1) then
941	do k=2,nlay
942	do ig=1,ngrid
943	if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt. &
944	& 1.e-5*masse(ig,k)) then
945	qa(ig,k)=(fm(ig,k)qa(ig,k-1)+entr(ig,k)q(ig,k)) &
946	& /(fm(ig,k+1)+detr(ig,k))
947	else
948	qa(ig,k)=q(ig,k)
949	endif
950	if (qa(ig,k).lt.0.) then
951	! print*,'qa<0!!!'
952	endif
953	if (q(ig,k).lt.0.) then
954	! print*,'q<0!!!'
955	endif
956	enddo
957	enddo
958
959	! Calcul du flux subsident
960
961	do k=2,nlay
962	do ig=1,ngrid
963	wqd(ig,k)=fm(ig,k)*q(ig,k)
964	if (wqd(ig,k).lt.0.) then
965	! print*,'wqd<0!!!'
966	endif
967	enddo
968	enddo
969	do ig=1,ngrid
970	wqd(ig,1)=0.
971	wqd(ig,nlay+1)=0.
972	enddo
973
974	! Calcul des tendances
975	do k=1,nlay
976	do ig=1,ngrid
977	q(ig,k)=q(ig,k)+(detr(ig,k)qa(ig,k)-entr(ig,k)q(ig,k) &
978	& -wqd(ig,k)+wqd(ig,k+1)) &
979	& *ptimestep/masse(ig,k)
980	enddo
981	enddo
982
983	endif
984
985	therm_tke_max(:,:)=q(:,:)
986
987	return
988	!!! fin nrlmd le 10/04/2012
989	end subroutine thermcell_tke_transport
990
991	END MODULE lmdz_thermcell_main

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format