Context Navigation

alpale_th.f90 @ 5433

Last change on this file since 5433 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 svn:keywords set to Id

File size: 13.2 KB

Line
1	!
2	! $Id: alpale_th.f90 5390 2024-12-05 16:09:25Z evignon $
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	USE alpale_mod
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	! Local variables
50	!----------------
51	INTEGER :: i
52	LOGICAL, SAVE :: first = .TRUE.
53	LOGICAL, SAVE :: multiply_proba_notrig = .FALSE.
54	REAL, SAVE :: random_notrig_max=1.
55	REAL, SAVE :: cv_feed_area
56	REAL :: birth_number
57	REAL, DIMENSION(klon) :: ale_bl_ref
58	REAL, DIMENSION(klon) :: tau_trig
59	!
60	!$OMP THREADPRIVATE(multiply_proba_notrig)
61	!$OMP THREADPRIVATE(random_notrig_max)
62	!$OMP THREADPRIVATE(cv_feed_area)
63	!$OMP THREADPRIVATE(first)
64	!
65	REAL umexp ! expression of (1.-exp(-x))/x valid for all x, especially when x->0
66	REAL x
67	!
68	CHARACTER (LEN=20) :: modname='alpale_th'
69	CHARACTER (LEN=80) :: abort_message
70
71	umexp(x) = max(sign(1.,x-1.e-3),0.)*(1.-exp(-x))/max(x,1.e-3) + &
72	(1.-max(sign(1.,x-1.e-3),0.))(1.-0.5x(1.-x/3.(1.-0.25*x))) !!! correct formula (jyg)
73	!!! (1.-max(sign(1.,x-1.e-3),0.))(-0.5x(1.-x/3.(1.-0.25*x))) !!! bug introduced by mistake (jyg)
74	!!! (1.-max(sign(1.,x-1.e-3),0.))(1.-0.5x(1.-x/3.(1.-0.25*x))) !!! initial correct formula (jyg)
75	!
76	!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
77	! JYG, 20160513 : Introduction of the Effective Lifting Power (ELP), which
78	! takes into account the area (cv_feed_area) covered by thermals contributing
79	! to each cumulonimbus.
80	! The use of ELP prevents singularities when the trigger probability tends to
81	! zero. It is activated by iflag_clos_bl = 3.
82	! The ELP values are stored in the ALP_bl variable.
83	!
84	!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
85	!
86
87	IF (first) THEN
88	CALL getin_p('multiply_proba_notrig',multiply_proba_notrig)
89	IF (iflag_clos_bl .LT. 3) THEN
90	random_notrig_max=1.
91	CALL getin_p('random_notrig_max',random_notrig_max)
92	ELSEIF (iflag_clos_bl .EQ. 3) THEN ! (iflag_clos_bl .LT. 3)
93	cv_feed_area = 1.e10 ! m2
94	CALL getin_p('cv_feed_area', cv_feed_area)
95	ENDIF !! (iflag_clos_bl .LT. 3)
96	first=.FALSE.
97	ENDIF
98
99	!!
100	!! Control of the multiplication of no-trigger probabilities between calls
101	!! to the convection scheme. If multiply_proba_notrig is .false., then
102	!! proba_notrig is set to 1 at each call to alpale_th, so that only the last call
103	!! plays a role in the triggering of convection. If it is .true., then propa_notrig
104	!! is saved between calls to convection and is reset to 1 only after calling the
105	!! convection scheme.
106	!! For instance, if the probability of no_trigger is 0.9 at each call, and if
107	!! there are 3 calls to alpale_th between calls to the convection scheme, then the
108	!! probability of triggering convection will be 0.1 (= 1.-0.9) if
109	!! multiply_proba_notrig is .false. and 0.271 (= 1.-0.9^3) if multiply_proba_notrig
110	!! is .true.
111	!!
112	IF (.NOT.multiply_proba_notrig) THEN
113	DO i=1,klon
114	proba_notrig(i)=1.
115	ENDDO
116	ENDIF !! (.NOT.multiply_proba_notrig)
117	!!
118	!!
119	!---------------------------------------
120	IF (iflag_clos_bl .LT. 3) THEN
121	!---------------------------------------
122	!
123	! Original code (Nicolas Rochetin)
124	! --------------------------------
125	!cc nrlmd le 10/04/2012
126	!-----------Stochastic triggering-----------
127	if (iflag_trig_bl.ge.1) then
128	!
129	IF (prt_level .GE. 10) THEN
130	WRITE(lunout,*)'cin, ale_bl_stat, alp_bl, alp_bl_stat ', &
131	cin, ale_bl_stat, alp_bl, alp_bl_stat
132	ENDIF
133
134
135	!----Initialisations
136	do i=1,klon
137	!!jyg proba_notrig(i)=1.
138	random_notrig(i)=1e6ale_bl_stat(i)-int(1e6ale_bl_stat(i))
139	if ( random_notrig(i) > random_notrig_max ) random_notrig(i)=0.
140	if ( ale_bl_trig(i) .lt. abs(cin(i))+1.e-10 ) then
141	tau_trig(i)=tau_trig_shallow
142	else
143	tau_trig(i)=tau_trig_deep
144	endif
145	enddo
146	!
147	IF (prt_level .GE. 10) THEN
148	WRITE(lunout,*)'random_notrig, tau_trig ', &
149	random_notrig, tau_trig
150	WRITE(lunout,*)'s_trig,s2,n2 ', &
151	s_trig,s2,n2
152	ENDIF
153
154	!Option pour re-activer l'ancien calcul de Ale_bl (iflag_trig_bl=2)
155	IF (iflag_trig_bl.eq.1) then
156
157	!----Tirage al\'eatoire et calcul de ale_bl_trig
158	do i=1,klon
159	if ( (ale_bl_stat(i) .gt. 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) .ge. 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.ge.2) then
179
180	do i=1,klon
181	if ( (Ale_bl(i) .gt. abs(cin(i))+1.e-10) ) then
182	proba_notrig(i)=proba_notrig(i)* &
183	(1.-exp(-strig(i)/s2(i)))*(n2(i)dtime/tau_trig(i))
184	! print *, 'proba_notrig(i) ',proba_notrig(i)
185	if (random_notrig(i) .ge. proba_notrig(i)) then
186	ale_bl_trig(i)=Ale_bl(i)
187	else
188	ale_bl_trig(i)=0.
189	endif
190	birth_rate(i) = n2(i)exp(-strig(i)/s2(i))/(tau_trig(i)cell_area(i))
191	!!! birth_rate(i) = max(birth_rate(i),1.e-18)
192	else
193	!!jyg proba_notrig(i)=1.
194	birth_rate(i) = 0.
195	random_notrig(i)=0.
196	ale_bl_trig(i)=0.
197	endif
198	enddo
199
200	ENDIF
201
202	!
203	IF (prt_level .GE. 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.eq.1) then
212
213	do i=1,klon
214	!CR: alp probabiliste
215	if (ale_bl_trig(i).gt.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.eq.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	!---------------------------------------
235	ELSEIF (iflag_clos_bl .EQ. 3) THEN ! (iflag_clos_bl .LT. 3)
236	!---------------------------------------
237	!
238	! New code with Effective Lifting Power
239	! -------------------------------------
240
241	!-----------Stochastic triggering-----------
242	if (iflag_trig_bl.ge.1) then
243	!
244	IF (prt_level .GE. 10) THEN
245	WRITE(lunout,*)'cin, ale_bl_stat, alp_bl_stat ', &
246	cin, ale_bl_stat, alp_bl_stat
247	ENDIF
248
249	! Use ale_bl_stat (Rochetin's code) or ale_bl (old code) according to
250	! iflag_trig_bl value.
251	IF (iflag_trig_bl.eq.1) then ! use ale_bl_stat (Rochetin computation)
252	do i=1,klon
253	ale_bl_ref(i)=ale_bl_stat(i)
254	enddo
255	ELSE IF (iflag_trig_bl.ge.2) then ! use ale_bl (old computation)
256	do i=1,klon
257	ale_bl_ref(i)=Ale_bl(i)
258	enddo
259	ENDIF ! (iflag_trig_bl.eq.1)
260
261
262	!----Initializations and random number generation
263	do i=1,klon
264	!!jyg proba_notrig(i)=1.
265	random_notrig(i)=1e6ale_bl_stat(i)-int(1e6ale_bl_stat(i))
266	if ( ale_bl_trig(i) .lt. abs(cin(i))+1.e-10 ) then
267	tau_trig(i)=tau_trig_shallow
268	else
269	tau_trig(i)=tau_trig_deep
270	endif
271	enddo
272	!
273	IF (prt_level .GE. 10) THEN
274	WRITE(lunout,*)'random_notrig, tau_trig ', &
275	random_notrig, tau_trig
276	WRITE(lunout,*)'s_trig,s2,n2 ', &
277	s_trig,s2,n2
278	ENDIF
279
280	!----alp_bl computation
281	do i=1,klon
282	if ( (ale_bl_ref(i) .gt. abs(cin(i))+1.e-10) ) then
283	birth_number = n2(i)*exp(-strig(i)/s2(i))
284	birth_rate(i) = birth_number/(tau_trig(i)*cell_area(i))
285	!!! birth_rate(i) = max(birth_rate(i),1.e-18)
286	proba_notrig(i)=proba_notrig(i)exp(-birth_numberdtime/tau_trig(i))
287	Alp_bl(i) = Alp_bl(i)* &
288	umexp(-birth_number*cv_feed_area/cell_area(i))/ &
289	umexp(-birth_numberdtime/tau_trig(i)) &
290	tau_trig(i)cv_feed_area/(dtimecell_area(i))
291	else
292	!!jyg proba_notrig(i)=1.
293	birth_rate(i)=0.
294	random_notrig(i)=0.
295	alp_bl(i)=0.
296	endif
297	enddo
298
299	!----ale_bl_trig computation
300	do i=1,klon
301	if (random_notrig(i) .ge. proba_notrig(i)) then
302	ale_bl_trig(i)=ale_bl_ref(i)
303	else
304	ale_bl_trig(i)=0.
305	endif
306	enddo
307
308	!
309	IF (prt_level .GE. 10) THEN
310	WRITE(lunout,*)'proba_notrig, ale_bl_trig ', &
311	proba_notrig, ale_bl_trig
312	ENDIF
313
314	endif !(iflag_trig_bl .ge. 1)
315
316	!---------------------------------------
317	ENDIF ! (iflag_clos_bl .LT. 3)
318	!---------------------------------------
319
320	IF (prt_level .GE. 10) THEN
321	WRITE(lunout,*)'alpale_th: ale_bl_trig, alp_bl_stat, birth_rate ', &
322	ale_bl_trig(1), alp_bl_stat(1), birth_rate(1)
323	ENDIF
324
325	!cc fin nrlmd le 10/04/2012
326	!
327	!IM/FH: 2011/02/23
328	! Couplage Thermiques/Emanuel seulement si T<0
329	if (iflag_coupl==2) then
330	IF (prt_level .GE. 10) THEN
331	WRITE(lunout,*)'Couplage Thermiques/Emanuel seulement si T<0'
332	ENDIF
333	do i=1,klon
334	if (t_seri(i,lmax_th(i))>273.) then
335	Ale_bl(i)=0.
336	endif
337	enddo
338	! print *,'In order to run with iflag_coupl=2, you have to comment out the following stop'
339	! STOP
340	abort_message='In order to run with iflag_coupl=2, you have to comment out the following abort'
341	CALL abort_physic(modname,abort_message,1)
342	endif
343	RETURN
344	END SUBROUTINE alpale_th
345

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

Download in other formats:

Original Format