Context Navigation

alpale_th.f90 @ 5833

Last change on this file since 5833 was 5833, checked in by rkazeroni, 8 weeks ago

For GPU porting of alpale_th and alpale_wk routines:

Put routine into module (speeds up source-to-source transformation)
Add "horizontal" comment to specify possible names of horizontal variables
Move declaration of variables with SAVE attributes from the compute routine to the module
Move one-time instructions (allocate, getin, print) to a dedicated routine_first

Property svn:keywords set to Id

File size: 13.5 KB

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

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

Download in other formats:

Original Format