Context Navigation

alpale_th.F90 @ 5106

Last change on this file since 5106 was 5106, checked in by abarral, 4 months ago
Turn coefils.h into lmdz_coefils.f90 Put filtreg.F90 inside lmdz_filtreg.F90 Turn mod_filtreg_p.F90 into lmdz_filtreg_p.F90 Delete obsolete parafilt.h* (lint) remove spaces between routine name and args
Property svn:keywords set to `Id`
File size: 13.1 KB

Line
1
2	! $Id: alpale_th.F90 5106 2024-07-23 20:21:18Z abarral $
3
4	SUBROUTINE alpale_th( dtime, lmax_th, t_seri, cell_area, &
5	cin, s2, n2, strig, &
6	ale_bl_trig, ale_bl_stat, ale_bl, &
7	alp_bl, alp_bl_stat, &
8	proba_notrig, random_notrig, birth_rate)
9
10	! **************************************************************
11	! *
12	! ALPALE_TH *
13	! *
14	! *
15	! written by : Jean-Yves Grandpeix, 11/05/2016 *
16	! modified by : *
17	! **************************************************************
18
19	USE dimphy
20	USE ioipsl_getin_p_mod, ONLY: getin_p
21	USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level
22
23	IMPLICIT NONE
24
25	!================================================================
26	! Auteur(s) : Jean-Yves Grandpeix, 11/05/2016
27	! Objet : Contribution of the thermal scheme to Ale and Alp
28	!================================================================
29
30	! Input arguments
31	!----------------
32	REAL, INTENT(IN) :: dtime
33	REAL, DIMENSION(klon), INTENT(IN) :: cell_area
34	INTEGER, DIMENSION(klon), INTENT(IN) :: lmax_th
35	REAL, DIMENSION(klon,klev), INTENT(IN) :: t_seri
36	REAL, DIMENSION(klon), INTENT(IN) :: ale_bl_stat
37	REAL, DIMENSION(klon), INTENT(IN) :: cin
38	REAL, DIMENSION(klon), INTENT(IN) :: s2, n2, strig
39
40	REAL, DIMENSION(klon), INTENT(INOUT) :: ale_bl_trig, ale_bl
41	REAL, DIMENSION(klon), INTENT(INOUT) :: alp_bl
42	REAL, DIMENSION(klon), INTENT(INOUT) :: alp_bl_stat
43	REAL, DIMENSION(klon), INTENT(INOUT) :: proba_notrig
44
45	REAL, DIMENSION(klon), INTENT(OUT) :: random_notrig
46
47	REAL, DIMENSION(klon), INTENT(OUT) :: birth_rate
48
49	include "alpale.h"
50
51	! Local variables
52	!----------------
53	INTEGER :: i
54	LOGICAL, SAVE :: first = .TRUE.
55	LOGICAL, SAVE :: multiply_proba_notrig = .FALSE.
56	REAL, SAVE :: random_notrig_max=1.
57	REAL, SAVE :: cv_feed_area
58	REAL :: birth_number
59	REAL, DIMENSION(klon) :: ale_bl_ref
60	REAL, DIMENSION(klon) :: tau_trig
61
62	!$OMP THREADPRIVATE(multiply_proba_notrig)
63	!$OMP THREADPRIVATE(random_notrig_max)
64	!$OMP THREADPRIVATE(cv_feed_area)
65	!$OMP THREADPRIVATE(first)
66
67	REAL umexp ! expression of (1.-exp(-x))/x valid for all x, especially when x->0
68	REAL x
69
70	CHARACTER (LEN=20) :: modname='alpale_th'
71	CHARACTER (LEN=80) :: abort_message
72
73	umexp(x) = max(sign(1.,x-1.e-3),0.)*(1.-exp(-x))/max(x,1.e-3) + &
74	(1.-max(sign(1.,x-1.e-3),0.))(1.-0.5x(1.-x/3.(1.-0.25*x))) !!! correct formula (jyg)
75	!!! (1.-max(sign(1.,x-1.e-3),0.))(-0.5x(1.-x/3.(1.-0.25*x))) !!! bug introduced by mistake (jyg)
76	!!! (1.-max(sign(1.,x-1.e-3),0.))(1.-0.5x(1.-x/3.(1.-0.25*x))) !!! initial correct formula (jyg)
77
78	!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
79	! JYG, 20160513 : Introduction of the Effective Lifting Power (ELP), which
80	! takes into account the area (cv_feed_area) covered by thermals contributing
81	! to each cumulonimbus.
82	! The use of ELP prevents singularities when the trigger probability tends to
83	! zero. It is activated by iflag_clos_bl = 3.
84	! The ELP values are stored in the ALP_bl variable.
85
86	!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
87
88	IF (first) THEN
89	CALL getin_p('multiply_proba_notrig',multiply_proba_notrig)
90	IF (iflag_clos_bl < 3) THEN
91	random_notrig_max=1.
92	CALL getin_p('random_notrig_max',random_notrig_max)
93	ELSEIF (iflag_clos_bl == 3) THEN ! (iflag_clos_bl .LT. 3)
94	cv_feed_area = 1.e10 ! m2
95	CALL getin_p('cv_feed_area', cv_feed_area)
96	ENDIF !! (iflag_clos_bl .LT. 3)
97	first=.FALSE.
98	ENDIF
99
100	!!
101	!! Control of the multiplication of no-trigger probabilities between calls
102	!! to the convection scheme. If multiply_proba_notrig is .FALSE., then
103	!! proba_notrig is set to 1 at each CALL to alpale_th, so that only the last CALL
104	!! plays a role in the triggering of convection. If it is .TRUE., then propa_notrig
105	!! is saved between calls to convection and is reset to 1 only after calling the
106	!! convection scheme.
107	!! For instance, if the probability of no_trigger is 0.9 at each call, and if
108	!! there are 3 calls to alpale_th between calls to the convection scheme, then the
109	!! probability of triggering convection will be 0.1 (= 1.-0.9) if
110	!! multiply_proba_notrig is .FALSE. and 0.271 (= 1.-0.9^3) if multiply_proba_notrig
111	!! is .TRUE.
112	!!
113	IF (.NOT.multiply_proba_notrig) THEN
114	DO i=1,klon
115	proba_notrig(i)=1.
116	ENDDO
117	ENDIF !! (.NOT.multiply_proba_notrig)
118	!!
119	!!
120	!---------------------------------------
121	IF (iflag_clos_bl < 3) THEN
122	!---------------------------------------
123
124	! Original code (Nicolas Rochetin)
125	! --------------------------------
126	!cc nrlmd le 10/04/2012
127	!-----------Stochastic triggering-----------
128	if (iflag_trig_bl>=1) then
129
130	IF (prt_level >= 10) THEN
131	WRITE(lunout,*)'cin, ale_bl_stat, alp_bl, alp_bl_stat ', &
132	cin, ale_bl_stat, alp_bl, alp_bl_stat
133	ENDIF
134
135
136	!----Initialisations
137	do i=1,klon
138	!!jyg proba_notrig(i)=1.
139	random_notrig(i)=1e6ale_bl_stat(i)-int(1e6ale_bl_stat(i))
140	if ( random_notrig(i) > random_notrig_max ) random_notrig(i)=0.
141	if ( ale_bl_trig(i) < abs(cin(i))+1.e-10 ) then
142	tau_trig(i)=tau_trig_shallow
143	else
144	tau_trig(i)=tau_trig_deep
145	endif
146	enddo
147
148	IF (prt_level >= 10) THEN
149	WRITE(lunout,*)'random_notrig, tau_trig ', &
150	random_notrig, tau_trig
151	WRITE(lunout,*)'s_trig,s2,n2 ', &
152	s_trig,s2,n2
153	ENDIF
154
155	!Option pour re-activer l'ancien calcul de Ale_bl (iflag_trig_bl=2)
156	IF (iflag_trig_bl==1) then
157
158	!----Tirage al\'eatoire et calcul de ale_bl_trig
159	do i=1,klon
160	if ( (ale_bl_stat(i) > abs(cin(i))+1.e-10) ) then
161	proba_notrig(i)=proba_notrig(i)* &
162	(1.-exp(-strig(i)/s2(i)))*(n2(i)dtime/tau_trig(i))
163	! print *, 'proba_notrig(i) ',proba_notrig(i)
164	if (random_notrig(i) >= proba_notrig(i)) then
165	ale_bl_trig(i)=ale_bl_stat(i)
166	else
167	ale_bl_trig(i)=0.
168	endif
169	birth_rate(i) = n2(i)exp(-strig(i)/s2(i))/(tau_trig(i)cell_area(i))
170	!!! birth_rate(i) = max(birth_rate(i),1.e-18)
171	else
172	!!jyg proba_notrig(i)=1.
173	birth_rate(i) = 0.
174	random_notrig(i)=0.
175	ale_bl_trig(i)=0.
176	endif
177	enddo
178
179	ELSE IF (iflag_trig_bl>=2) then
180
181	do i=1,klon
182	if ( (Ale_bl(i) > abs(cin(i))+1.e-10) ) then
183	proba_notrig(i)=proba_notrig(i)* &
184	(1.-exp(-strig(i)/s2(i)))*(n2(i)dtime/tau_trig(i))
185	! print *, 'proba_notrig(i) ',proba_notrig(i)
186	if (random_notrig(i) >= proba_notrig(i)) then
187	ale_bl_trig(i)=Ale_bl(i)
188	else
189	ale_bl_trig(i)=0.
190	endif
191	birth_rate(i) = n2(i)exp(-strig(i)/s2(i))/(tau_trig(i)cell_area(i))
192	!!! birth_rate(i) = max(birth_rate(i),1.e-18)
193	else
194	!!jyg proba_notrig(i)=1.
195	birth_rate(i) = 0.
196	random_notrig(i)=0.
197	ale_bl_trig(i)=0.
198	endif
199	enddo
200
201	ENDIF
202
203	IF (prt_level >= 10) THEN
204	WRITE(lunout,*)'proba_notrig, ale_bl_trig ', &
205	proba_notrig, ale_bl_trig
206	ENDIF
207
208	endif !(iflag_trig_bl)
209
210	!-----------Statistical closure-----------
211	if (iflag_clos_bl==1) then
212
213	do i=1,klon
214	!CR: alp probabiliste
215	if (ale_bl_trig(i)>0.) then
216	alp_bl(i)=alp_bl(i)/(1.-min(proba_notrig(i),0.999))
217	endif
218	enddo
219
220	else if (iflag_clos_bl==2) then
221
222	!CR: alp calculee dans thermcell_main
223	do i=1,klon
224	alp_bl(i)=alp_bl_stat(i)
225	enddo
226
227	else
228
229	alp_bl_stat(:)=0.
230
231	endif !(iflag_clos_bl)
232
233	!---------------------------------------
234	ELSEIF (iflag_clos_bl == 3) THEN ! (iflag_clos_bl .LT. 3)
235	!---------------------------------------
236
237	! New code with Effective Lifting Power
238	! -------------------------------------
239
240	!-----------Stochastic triggering-----------
241	if (iflag_trig_bl>=1) then
242
243	IF (prt_level >= 10) THEN
244	WRITE(lunout,*)'cin, ale_bl_stat, alp_bl_stat ', &
245	cin, ale_bl_stat, alp_bl_stat
246	ENDIF
247
248	! Use ale_bl_stat (Rochetin's code) or ale_bl (old code) according to
249	! iflag_trig_bl value.
250	IF (iflag_trig_bl==1) then ! use ale_bl_stat (Rochetin computation)
251	do i=1,klon
252	ale_bl_ref(i)=ale_bl_stat(i)
253	enddo
254	ELSE IF (iflag_trig_bl>=2) then ! use ale_bl (old computation)
255	do i=1,klon
256	ale_bl_ref(i)=Ale_bl(i)
257	enddo
258	ENDIF ! (iflag_trig_bl.eq.1)
259
260
261	!----Initializations and random number generation
262	do i=1,klon
263	!!jyg proba_notrig(i)=1.
264	random_notrig(i)=1e6ale_bl_stat(i)-int(1e6ale_bl_stat(i))
265	if ( ale_bl_trig(i) < abs(cin(i))+1.e-10 ) then
266	tau_trig(i)=tau_trig_shallow
267	else
268	tau_trig(i)=tau_trig_deep
269	endif
270	enddo
271
272	IF (prt_level >= 10) THEN
273	WRITE(lunout,*)'random_notrig, tau_trig ', &
274	random_notrig, tau_trig
275	WRITE(lunout,*)'s_trig,s2,n2 ', &
276	s_trig,s2,n2
277	ENDIF
278
279	!----alp_bl computation
280	do i=1,klon
281	if ( (ale_bl_ref(i) > abs(cin(i))+1.e-10) ) then
282	birth_number = n2(i)*exp(-strig(i)/s2(i))
283	birth_rate(i) = birth_number/(tau_trig(i)*cell_area(i))
284	!!! birth_rate(i) = max(birth_rate(i),1.e-18)
285	proba_notrig(i)=proba_notrig(i)exp(-birth_numberdtime/tau_trig(i))
286	Alp_bl(i) = Alp_bl(i)* &
287	umexp(-birth_number*cv_feed_area/cell_area(i))/ &
288	umexp(-birth_numberdtime/tau_trig(i)) &
289	tau_trig(i)cv_feed_area/(dtimecell_area(i))
290	else
291	!!jyg proba_notrig(i)=1.
292	birth_rate(i)=0.
293	random_notrig(i)=0.
294	alp_bl(i)=0.
295	endif
296	enddo
297
298	!----ale_bl_trig computation
299	do i=1,klon
300	if (random_notrig(i) >= proba_notrig(i)) then
301	ale_bl_trig(i)=ale_bl_ref(i)
302	else
303	ale_bl_trig(i)=0.
304	endif
305	enddo
306
307	IF (prt_level >= 10) THEN
308	WRITE(lunout,*)'proba_notrig, ale_bl_trig ', &
309	proba_notrig, ale_bl_trig
310	ENDIF
311
312	endif !(iflag_trig_bl .ge. 1)
313
314	!---------------------------------------
315	ENDIF ! (iflag_clos_bl .LT. 3)
316	!---------------------------------------
317
318	IF (prt_level >= 10) THEN
319	WRITE(lunout,*)'alpale_th: ale_bl_trig, alp_bl_stat, birth_rate ', &
320	ale_bl_trig(1), alp_bl_stat(1), birth_rate(1)
321	ENDIF
322
323	!cc fin nrlmd le 10/04/2012
324
325	!IM/FH: 2011/02/23
326	! Couplage Thermiques/Emanuel seulement si T<0
327	if (iflag_coupl==2) then
328	IF (prt_level >= 10) THEN
329	WRITE(lunout,*)'Couplage Thermiques/Emanuel seulement si T<0'
330	ENDIF
331	do i=1,klon
332	if (t_seri(i,lmax_th(i))>273.) then
333	Ale_bl(i)=0.
334	endif
335	enddo
336	! print *,'In order to run with iflag_coupl=2, you have to comment out the following stop '
337	! STOP
338	abort_message='In order to run with iflag_coupl=2, you have to comment out the following abort'
339	CALL abort_physic(modname,abort_message,1)
340	endif
341	RETURN
342	END
343

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

Download in other formats:

Original Format