Context Navigation

alpale_th.F90 @ 5116

Last change on this file since 5116 was 5116, checked in by abarral, 4 months ago
rename modules properly lmdz_* move ismin, ismax, minmax into new lmdz_libmath.f90 (lint) uppercase fortran keywords
Property svn:keywords set to `Id`
File size: 13.1 KB

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

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

Download in other formats:

Original Format