Context Navigation

wx_pbl_mod.F90 @ 3932

Last change on this file since 3932 was 3927, checked in by Laurent Fairhead, 3 years ago
Initial import of the physics wih isotopes from Camille Risi CR
File size: 20.0 KB

Line
1	MODULE wx_pbl_mod
2	!
3	! Planetary Boundary Layer and Surface module
4	!
5	! This module manage the calculation of turbulent diffusion in the boundary layer
6	! and all interactions towards the differents sub-surfaces.
7	!
8	!
9	USE dimphy
10
11	IMPLICIT NONE
12
13	REAL, ALLOCATABLE, DIMENSION(:), SAVE :: Kech_Tp, Kech_T_xp, Kech_T_wp
14	REAL, ALLOCATABLE, DIMENSION(:), SAVE :: dd_KTp, KxKwTp, dd_AT, dd_BT
15	!$OMP THREADPRIVATE(Kech_Tp, Kech_T_xp, Kech_T_wp, dd_KTp, KxKwTp, dd_AT, dd_BT)
16	REAL, ALLOCATABLE, DIMENSION(:), SAVE :: Kech_Qp, Kech_Q_xp, Kech_Q_wp
17	REAL, ALLOCATABLE, DIMENSION(:), SAVE :: dd_KQp, KxKwQp, dd_AQ, dd_BQ
18	!$OMP THREADPRIVATE(Kech_Qp, Kech_Q_xp, Kech_Q_wp, dd_KQp, KxKwQp, dd_AQ, dd_BQ)
19	REAL, ALLOCATABLE, DIMENSION(:), SAVE :: Kech_Up, Kech_U_xp, Kech_U_wp
20	REAL, ALLOCATABLE, DIMENSION(:), SAVE :: dd_KUp, KxKwUp, dd_AU, dd_BU
21	!$OMP THREADPRIVATE(Kech_Up, Kech_U_xp, Kech_U_wp, dd_KUp, KxKwUp, dd_AU, dd_BU)
22	REAL, ALLOCATABLE, DIMENSION(:), SAVE :: Kech_Vp, Kech_V_xp, Kech_V_wp
23	REAL, ALLOCATABLE, DIMENSION(:), SAVE :: dd_KVp, KxKwVp, dd_AV, dd_BV
24	!$OMP THREADPRIVATE(Kech_Vp, Kech_V_xp, Kech_V_wp, dd_KVp, KxKwVp, dd_AV, dd_BV)
25
26	CONTAINS
27	!
28	!****************************************************************************************
29	!
30	SUBROUTINE wx_pbl_init
31
32	! Local variables
33	!****************************************************************************************
34	INTEGER :: ierr
35
36
37	!****************************************************************************************
38	! Allocate module variables
39	!
40	!****************************************************************************************
41
42	ierr = 0
43
44	ALLOCATE(Kech_Tp(klon), stat=ierr)
45	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
46
47	ALLOCATE(Kech_T_xp(klon), stat=ierr)
48	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
49
50	ALLOCATE(Kech_T_wp(klon), stat=ierr)
51	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
52
53	ALLOCATE(dd_KTp(klon), stat=ierr)
54	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
55
56	ALLOCATE(KxKwTp(klon), stat=ierr)
57	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
58
59	ALLOCATE(dd_AT(klon), stat=ierr)
60	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
61
62	ALLOCATE(dd_BT(klon), stat=ierr)
63	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
64
65	!----------------------------------------------------------------------------
66	ALLOCATE(Kech_Qp(klon), stat=ierr)
67	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
68
69	ALLOCATE(Kech_Q_xp(klon), stat=ierr)
70	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
71
72	ALLOCATE(Kech_Q_wp(klon), stat=ierr)
73	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
74
75	ALLOCATE(dd_KQp(klon), stat=ierr)
76	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
77
78	ALLOCATE(KxKwQp(klon), stat=ierr)
79	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
80
81	ALLOCATE(dd_AQ(klon), stat=ierr)
82	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
83
84	ALLOCATE(dd_BQ(klon), stat=ierr)
85	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
86
87	!----------------------------------------------------------------------------
88	ALLOCATE(Kech_Up(klon), stat=ierr)
89	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
90
91	ALLOCATE(Kech_U_xp(klon), stat=ierr)
92	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
93
94	ALLOCATE(Kech_U_wp(klon), stat=ierr)
95	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
96
97	ALLOCATE(dd_KUp(klon), stat=ierr)
98	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
99
100	ALLOCATE(KxKwUp(klon), stat=ierr)
101	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
102
103	ALLOCATE(dd_AU(klon), stat=ierr)
104	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
105
106	ALLOCATE(dd_BU(klon), stat=ierr)
107	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
108
109	!----------------------------------------------------------------------------
110	ALLOCATE(Kech_Vp(klon), stat=ierr)
111	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
112
113	ALLOCATE(Kech_V_xp(klon), stat=ierr)
114	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
115
116	ALLOCATE(Kech_V_wp(klon), stat=ierr)
117	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
118
119	ALLOCATE(dd_KVp(klon), stat=ierr)
120	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
121
122	ALLOCATE(KxKwVp(klon), stat=ierr)
123	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
124
125	ALLOCATE(dd_AV(klon), stat=ierr)
126	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
127
128	ALLOCATE(dd_BV(klon), stat=ierr)
129	IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
130
131	!----------------------------------------------------------------------------
132
133	END SUBROUTINE wx_pbl_init
134
135	SUBROUTINE wx_pbl0_fuse(knon, dtime, ypplay, ywake_s, &
136	yt_x, yt_w, yq_x, yq_w, &
137	yu_x, yu_w, yv_x, yv_w, &
138	ycdragh_x, ycdragh_w, ycdragm_x, ycdragm_w, &
139	AcoefT_x, AcoefT_w, AcoefQ_x, AcoefQ_w, &
140	AcoefU_x, AcoefU_w, AcoefV_x, AcoefV_w, &
141	BcoefT_x, BcoefT_w, BcoefQ_x, BcoefQ_w, &
142	BcoefU_x, BcoefU_w, BcoefV_x, BcoefV_w, &
143	AcoefT, AcoefQ, AcoefU, AcoefV, &
144	BcoefT, BcoefQ, BcoefU, BcoefV, &
145	ycdragh, ycdragm, &
146	yt1, yq1, yu1, yv1 &
147	#ifdef ISO
148	,yxt_x,yxt_w,yxt1 &
149	#endif
150	)
151	!
152	USE print_control_mod, ONLY: prt_level,lunout
153
154	#ifdef ISO
155	USE infotrac_phy, ONLY: ntraciso ! ajout C Risi pour isos
156	#endif
157	!
158	INCLUDE "YOMCST.h"
159	!
160	INTEGER, INTENT(IN) :: knon ! number of grid cells
161	REAL, INTENT(IN) :: dtime ! time step size (s)
162	REAL, DIMENSION(knon,klev), INTENT(IN) :: ypplay ! mid-layer pressure (Pa)
163	REAL, DIMENSION(knon), INTENT(IN) :: ywake_s ! cold pools fractional area
164	REAL, DIMENSION(knon,klev), INTENT(IN) :: yt_x, yt_w, yq_x, yq_w
165	REAL, DIMENSION(knon,klev), INTENT(IN) :: yu_x, yu_w, yv_x, yv_w
166	REAL, DIMENSION(knon), INTENT(IN) :: ycdragh_x, ycdragh_w, ycdragm_x, ycdragm_w
167	REAL, DIMENSION(knon), INTENT(IN) :: AcoefT_x, AcoefT_w, AcoefQ_x, AcoefQ_w
168	REAL, DIMENSION(knon), INTENT(IN) :: AcoefU_x, AcoefU_w, AcoefV_x, AcoefV_w
169	REAL, DIMENSION(knon), INTENT(IN) :: BcoefT_x, BcoefT_w, BcoefQ_x, BcoefQ_w
170	REAL, DIMENSION(knon), INTENT(IN) :: BcoefU_x, BcoefU_w, BcoefV_x, BcoefV_w
171	REAL, DIMENSION(knon), INTENT(OUT) :: AcoefT, AcoefQ, AcoefU, AcoefV
172	REAL, DIMENSION(knon), INTENT(OUT) :: BcoefT, BcoefQ, BcoefU, BcoefV
173	REAL, DIMENSION(knon), INTENT(OUT) :: ycdragh, ycdragm
174	REAL, DIMENSION(knon), INTENT(OUT) :: yt1, yq1, yu1, yv1 ! Apparent T, q, u, v at first level, as
175	!seen by surface modules
176	#ifdef ISO
177	REAL, DIMENSION(ntraciso,knon,klev), INTENT(IN) :: yxt_x, yxt_w
178	REAL, DIMENSION(ntraciso,knon), INTENT(OUT) :: yxt1
179	#endif
180	!
181	! Local variables
182	INTEGER :: j
183	REAL :: rho1
184	REAL :: mod_wind_x
185	REAL :: mod_wind_w
186	REAL :: dd_Cdragh
187	REAL :: dd_Cdragm
188	REAL :: dd_Kh
189	REAL :: dd_Km
190	REAL :: dd_u
191	REAL :: dd_v
192	REAL :: dd_t
193	REAL :: dd_q
194	#ifdef ISO
195	REAL, DIMENSION(ntraciso) :: dd_xt
196	integer :: ixt
197	#endif
198	!
199	REAL :: KCT, KCQ, KCU, KCV
200	!
201	REAL :: BBT, BBQ, BBU, BBV
202	REAL :: DDT, DDQ, DDU, DDV
203	REAL :: LambdaT, LambdaQ, LambdaU, LambdaV
204	REAL :: LambdaTs, LambdaQs, LambdaUs, LambdaVs
205	!
206	REAL, DIMENSION(knon) :: sigx ! fractional area of (x) region
207
208	REAL, DIMENSION(knon) :: Kech_h ! Energy exchange coefficient
209	REAL, DIMENSION(knon) :: Kech_h_x, Kech_h_w
210	REAL, DIMENSION(knon) :: Kech_m ! Momentum exchange coefficient
211	REAL, DIMENSION(knon) :: Kech_m_x, Kech_m_w
212
213	!!!
214	!!! jyg le 09/04/2013 ; passage aux nouvelles expressions en differences
215
216	sigx(:) = 1.-ywake_s(:)
217
218	DO j=1,knon
219	!
220	! Calcul des coefficients d echange
221	mod_wind_x = 1.0+SQRT(yu_x(j,1)2+yv_x(j,1)2)
222	mod_wind_w = 1.0+SQRT(yu_w(j,1)2+yv_w(j,1)2)
223	!! rho1 = ypplay(j,1)/(RD*yt(j,1))
224	rho1 = ypplay(j,1)/(RD(yt_x(j,1) + ywake_s(j)(yt_w(j,1)-yt_x(j,1))))
225	Kech_h_x(j) = ycdragh_x(j) * mod_wind_x * rho1
226	Kech_h_w(j) = ycdragh_w(j) * mod_wind_w * rho1
227	Kech_m_x(j) = ycdragm_x(j) * mod_wind_x * rho1
228	Kech_m_w(j) = ycdragm_w(j) * mod_wind_w * rho1
229	!
230	dd_Kh = Kech_h_w(j) - Kech_h_x(j)
231	dd_Km = Kech_m_w(j) - Kech_m_x(j)
232	IF (prt_level >=10) THEN
233	print *,' mod_wind_x, mod_wind_w ', mod_wind_x, mod_wind_w
234	print *,' rho1 ',rho1
235	print *,' ycdragh_x(j),ycdragm_x(j) ',ycdragh_x(j),ycdragm_x(j)
236	print *,' ycdragh_w(j),ycdragm_w(j) ',ycdragh_w(j),ycdragm_w(j)
237	print *,' dd_Kh: ',dd_Kh
238	ENDIF
239	!
240	Kech_h(j) = Kech_h_x(j) + ywake_s(j)*dd_Kh
241	Kech_m(j) = Kech_m_x(j) + ywake_s(j)*dd_Km
242	!
243	! Calcul des coefficients d echange corriges des retroactions
244	Kech_T_xp(j) = Kech_h_x(j)/(1.-BcoefT_x(j)Kech_h_x(j)dtime)
245	Kech_T_wp(j) = Kech_h_w(j)/(1.-BcoefT_w(j)Kech_h_w(j)dtime)
246	Kech_Q_xp(j) = Kech_h_x(j)/(1.-BcoefQ_x(j)Kech_h_x(j)dtime)
247	Kech_Q_wp(j) = Kech_h_w(j)/(1.-BcoefQ_w(j)Kech_h_w(j)dtime)
248	Kech_U_xp(j) = Kech_m_x(j)/(1.-BcoefU_x(j)Kech_m_x(j)dtime)
249	Kech_U_wp(j) = Kech_m_w(j)/(1.-BcoefU_w(j)Kech_m_w(j)dtime)
250	Kech_V_xp(j) = Kech_m_x(j)/(1.-BcoefV_x(j)Kech_m_x(j)dtime)
251	Kech_V_wp(j) = Kech_m_w(j)/(1.-BcoefV_w(j)Kech_m_w(j)dtime)
252	!
253	dd_KTp(j) = Kech_T_wp(j) - Kech_T_xp(j)
254	dd_KQp(j) = Kech_Q_wp(j) - Kech_Q_xp(j)
255	dd_KUp(j) = Kech_U_wp(j) - Kech_U_xp(j)
256	dd_KVp(j) = Kech_V_wp(j) - Kech_V_xp(j)
257	!
258	Kech_Tp(j) = Kech_T_xp(j) + ywake_s(j)*dd_KTp(j)
259	Kech_Qp(j) = Kech_Q_xp(j) + ywake_s(j)*dd_KQp(j)
260	Kech_Up(j) = Kech_U_xp(j) + ywake_s(j)*dd_KUp(j)
261	Kech_Vp(j) = Kech_V_xp(j) + ywake_s(j)*dd_KVp(j)
262	!
263	! Calcul des differences w-x
264	dd_Cdragm = ycdragm_w(j) - ycdragm_x(j)
265	dd_Cdragh = ycdragh_w(j) - ycdragh_x(j)
266	dd_u = yu_w(j,1) - yu_x(j,1)
267	dd_v = yv_w(j,1) - yv_x(j,1)
268	dd_t = yt_w(j,1) - yt_x(j,1)
269	dd_q = yq_w(j,1) - yq_x(j,1)
270	#ifdef ISO
271	do ixt=1,ntraciso
272	dd_xt(ixt) = yxt_w(ixt,j,1) - yxt_x(ixt,j,1)
273	enddo !do ixt=1,ntraciso
274	#endif
275	dd_AT(j) = AcoefT_w(j) - AcoefT_x(j)
276	dd_AQ(j) = AcoefQ_w(j) - AcoefQ_x(j)
277	dd_AU(j) = AcoefU_w(j) - AcoefU_x(j)
278	dd_AV(j) = AcoefV_w(j) - AcoefV_x(j)
279	dd_BT(j) = BcoefT_w(j) - BcoefT_x(j)
280	dd_BQ(j) = BcoefQ_w(j) - BcoefQ_x(j)
281	dd_BU(j) = BcoefU_w(j) - BcoefU_x(j)
282	dd_BV(j) = BcoefV_w(j) - BcoefV_x(j)
283	!
284	KxKwTp(j) = Kech_T_xp(j)*Kech_T_wp(j)
285	KxKwQp(j) = Kech_Q_xp(j)*Kech_Q_wp(j)
286	KxKwUp(j) = Kech_U_xp(j)*Kech_U_wp(j)
287	KxKwVp(j) = Kech_V_xp(j)*Kech_V_wp(j)
288	BBT = (BcoefT_x(j) + sigx(j)dd_BT(j))dtime
289	BBQ = (BcoefQ_x(j) + sigx(j)dd_BQ(j))dtime
290	BBU = (BcoefU_x(j) + sigx(j)dd_BU(j))dtime
291	BBV = (BcoefV_x(j) + sigx(j)dd_BV(j))dtime
292	KCT = Kech_h(j)
293	KCQ = Kech_h(j)
294	KCU = Kech_m(j)
295	KCV = Kech_m(j)
296	DDT = Kech_Tp(j)
297	DDQ = Kech_Qp(j)
298	DDU = Kech_Up(j)
299	DDV = Kech_Vp(j)
300	LambdaT = dd_Kh/KCT
301	LambdaQ = dd_Kh/KCQ
302	LambdaU = dd_Km/KCU
303	LambdaV = dd_Km/KCV
304	LambdaTs = dd_KTp(j)/DDT
305	LambdaQs = dd_KQp(j)/DDQ
306	LambdaUs = dd_KUp(j)/DDU
307	LambdaVs = dd_KVp(j)/DDV
308	!
309	IF (prt_level >=10) THEN
310	print *,'Variables pour la fusion : Kech_T_xp(j)' ,Kech_T_xp(j)
311	print *,'Variables pour la fusion : Kech_T_wp(j)' ,Kech_T_wp(j)
312	print *,'Variables pour la fusion : Kech_Tp(j)' ,Kech_Tp(j)
313	print *,'Variables pour la fusion : Kech_h(j)' ,Kech_h(j)
314	ENDIF
315	!
316	! Calcul des coef A, B \'equivalents dans la couche 1
317	!
318	AcoefT(j) = AcoefT_x(j) + ywake_s(j)dd_AT(j)(1.+sigx(j)*LambdaTs)
319	AcoefQ(j) = AcoefQ_x(j) + ywake_s(j)dd_AQ(j)(1.+sigx(j)*LambdaQs)
320	AcoefU(j) = AcoefU_x(j) + ywake_s(j)dd_AU(j)(1.+sigx(j)*LambdaUs)
321	AcoefV(j) = AcoefV_x(j) + ywake_s(j)dd_AV(j)(1.+sigx(j)*LambdaVs)
322	!
323	BcoefT(j) = BcoefT_x(j) + ywake_s(j)BcoefT_x(j)sigx(j)LambdaTLambdaTs &
324	+ ywake_s(j)dd_BT(j)(1.+sigx(j)LambdaT)(1.+sigx(j)*LambdaTs)
325
326	BcoefQ(j) = BcoefQ_x(j) + ywake_s(j)BcoefQ_x(j)sigx(j)LambdaQLambdaQs &
327	+ ywake_s(j)dd_BQ(j)(1.+sigx(j)LambdaQ)(1.+sigx(j)*LambdaQs)
328
329	BcoefU(j) = BcoefU_x(j) + ywake_s(j)BcoefU_x(j)sigx(j)LambdaULambdaUs &
330	+ ywake_s(j)dd_BU(j)(1.+sigx(j)LambdaU)(1.+sigx(j)*LambdaUs)
331
332	BcoefV(j) = BcoefV_x(j) + ywake_s(j)BcoefV_x(j)sigx(j)LambdaVLambdaVs &
333	+ ywake_s(j)dd_BV(j)(1.+sigx(j)LambdaV)(1.+sigx(j)*LambdaVs)
334
335	!
336	! Calcul des cdrag \'equivalents dans la couche
337	!
338	ycdragm(j) = ycdragm_x(j) + ywake_s(j)*dd_Cdragm
339	ycdragh(j) = ycdragh_x(j) + ywake_s(j)*dd_Cdragh
340	!
341	! Calcul de T, q, u et v \'equivalents dans la couche 1
342	!! yt1(j) = yt_x(j,1) + ywake_s(j)dd_t(1.+sigx(j)*dd_Kh/KCT)
343	!! yq1(j) = yq_x(j,1) + ywake_s(j)dd_q(1.+sigx(j)*dd_Kh/KCQ)
344	!! yu1(j) = yu_x(j,1) + ywake_s(j)dd_u(1.+sigx(j)*dd_Km/KCU)
345	!! yv1(j) = yv_x(j,1) + ywake_s(j)dd_v(1.+sigx(j)*dd_Km/KCV)
346	yt1(j) = yt_x(j,1) + ywake_s(j)*dd_t
347	yq1(j) = yq_x(j,1) + ywake_s(j)*dd_q
348	yu1(j) = yu_x(j,1) + ywake_s(j)*dd_u
349	yv1(j) = yv_x(j,1) + ywake_s(j)*dd_v
350	#ifdef ISO
351	yxt1(ixt,j) = yxt_x(ixt,j,1) + ywake_s(j)*dd_xt(ixt)
352	#endif
353
354
355	ENDDO
356
357	RETURN
358
359	END SUBROUTINE wx_pbl0_fuse
360
361	SUBROUTINE wx_pbl0_split(knon, dtime, ywake_s, &
362	y_flux_t1, y_flux_q1, y_flux_u1, y_flux_v1, &
363	y_flux_t1_x, y_flux_t1_w, &
364	y_flux_q1_x, y_flux_q1_w, &
365	y_flux_u1_x, y_flux_u1_w, &
366	y_flux_v1_x, y_flux_v1_w, &
367	yfluxlat_x, yfluxlat_w, &
368	y_delta_tsurf &
369	)
370	!
371	USE print_control_mod, ONLY: prt_level,lunout
372	!
373	INCLUDE "YOMCST.h"
374	!
375	INTEGER, INTENT(IN) :: knon ! number of grid cells
376	REAL, INTENT(IN) :: dtime ! time step size (s)
377	REAL, DIMENSION(knon), INTENT(IN) :: ywake_s ! cold pools fractional area
378	REAL, DIMENSION(knon), INTENT(IN) :: y_flux_t1, y_flux_q1, y_flux_u1, y_flux_v1
379	!
380	REAL, DIMENSION(knon), INTENT(OUT) :: y_flux_t1_x, y_flux_t1_w
381	REAL, DIMENSION(knon), INTENT(OUT) :: y_flux_q1_x, y_flux_q1_w
382	REAL, DIMENSION(knon), INTENT(OUT) :: y_flux_u1_x, y_flux_u1_w
383	REAL, DIMENSION(knon), INTENT(OUT) :: y_flux_v1_x, y_flux_v1_w
384	REAL, DIMENSION(knon), INTENT(OUT) :: yfluxlat_x, yfluxlat_w
385	REAL, DIMENSION(knon), INTENT(OUT) :: y_delta_tsurf
386	!
387	!! Local variables
388	INTEGER :: j
389	REAL, DIMENSION(knon) :: y_delta_flux_t1, y_delta_flux_q1, y_delta_flux_u1, y_delta_flux_v1
390	!
391	REAL :: DDT, DDQ, DDU, DDV
392	REAL :: LambdaTs, LambdaQs, LambdaUs, LambdaVs
393	!
394	REAL, DIMENSION(knon) :: sigx ! fractional area of (x) region
395	!!
396	sigx(:) = 1.-ywake_s(:)
397
398	DO j=1,knon
399	!
400	DDT = Kech_Tp(j)
401	DDQ = Kech_Qp(j)
402	DDU = Kech_Up(j)
403	DDV = Kech_Vp(j)
404	!
405	LambdaTs = dd_KTp(j)/DDT
406	LambdaQs = dd_KQp(j)/DDQ
407	LambdaUs = dd_KUp(j)/DDU
408	LambdaVs = dd_KVp(j)/DDV
409	!
410	y_delta_flux_t1(j) = y_flux_t1(j)LambdaTs + dd_AT(j)KxKwTp(j)/DDT
411	y_delta_flux_q1(j) = y_flux_q1(j)LambdaQs + dd_AQ(j)KxKwQp(j)/DDQ
412	y_delta_flux_u1(j) = y_flux_u1(j)LambdaUs + dd_AU(j)KxKwUp(j)/DDU
413	y_delta_flux_v1(j) = y_flux_v1(j)LambdaVs + dd_AV(j)KxKwVp(j)/DDV
414	!
415	y_flux_t1_x(j)=y_flux_t1(j) - ywake_s(j)*y_delta_flux_t1(j)
416	y_flux_t1_w(j)=y_flux_t1(j) + (1.-ywake_s(j))*y_delta_flux_t1(j)
417	y_flux_q1_x(j)=y_flux_q1(j) - ywake_s(j)*y_delta_flux_q1(j)
418	y_flux_q1_w(j)=y_flux_q1(j) + (1.-ywake_s(j))*y_delta_flux_q1(j)
419	y_flux_u1_x(j)=y_flux_u1(j) - ywake_s(j)*y_delta_flux_u1(j)
420	y_flux_u1_w(j)=y_flux_u1(j) + (1.-ywake_s(j))*y_delta_flux_u1(j)
421	y_flux_v1_x(j)=y_flux_v1(j) - ywake_s(j)*y_delta_flux_v1(j)
422	y_flux_v1_w(j)=y_flux_v1(j) + (1.-ywake_s(j))*y_delta_flux_v1(j)
423	!
424	yfluxlat_x(j)=y_flux_q1_x(j)*RLVTT
425	yfluxlat_w(j)=y_flux_q1_w(j)*RLVTT
426	!
427	! Delta_tsurf computation
428	!! y_delta_tsurf(j) = (1./RCPD)(ah(j)dd_AT(j) + &
429	!! ah(j)y_flux_t1(j)dd_BT(j)*dtime + &
430	!! y_delta_flux_t1(j)(ah(j)BBT+bh(j)) )
431	!
432	y_delta_tsurf(j) = 0.
433	!
434	ENDDO
435	!
436	RETURN
437
438	END SUBROUTINE wx_pbl0_split
439
440	SUBROUTINE wx_pbl_final
441	!
442	!****************************************************************************************
443	! Deallocate module variables
444	!
445	!****************************************************************************************
446	!
447	IF (ALLOCATED(Kech_Tp)) DEALLOCATE(Kech_Tp)
448	IF (ALLOCATED(Kech_T_xp)) DEALLOCATE(Kech_T_xp)
449	IF (ALLOCATED(Kech_T_wp)) DEALLOCATE(Kech_T_wp)
450	IF (ALLOCATED(dd_KTp)) DEALLOCATE(dd_KTp)
451	IF (ALLOCATED(KxKwTp)) DEALLOCATE(KxKwTp)
452	IF (ALLOCATED(dd_AT)) DEALLOCATE(dd_AT)
453	IF (ALLOCATED(dd_BT)) DEALLOCATE(dd_BT)
454	IF (ALLOCATED(Kech_Qp)) DEALLOCATE(Kech_Qp)
455	IF (ALLOCATED(Kech_Q_xp)) DEALLOCATE(Kech_Q_xp)
456	IF (ALLOCATED(Kech_Q_wp)) DEALLOCATE(Kech_Q_wp)
457	IF (ALLOCATED(dd_KQp)) DEALLOCATE(dd_KQp)
458	IF (ALLOCATED(KxKwQp)) DEALLOCATE(KxKwQp)
459	IF (ALLOCATED(dd_AQ)) DEALLOCATE(dd_AQ)
460	IF (ALLOCATED(dd_BQ)) DEALLOCATE(dd_BQ)
461	IF (ALLOCATED(Kech_Up)) DEALLOCATE(Kech_Up)
462	IF (ALLOCATED(Kech_U_xp)) DEALLOCATE(Kech_U_xp)
463	IF (ALLOCATED(Kech_U_wp)) DEALLOCATE(Kech_U_wp)
464	IF (ALLOCATED(dd_KUp)) DEALLOCATE(dd_KUp)
465	IF (ALLOCATED(KxKwUp)) DEALLOCATE(KxKwUp)
466	IF (ALLOCATED(dd_AU)) DEALLOCATE(dd_AU)
467	IF (ALLOCATED(dd_BU)) DEALLOCATE(dd_BU)
468	IF (ALLOCATED(Kech_Vp)) DEALLOCATE(Kech_Vp)
469	IF (ALLOCATED(Kech_V_xp)) DEALLOCATE(Kech_V_xp)
470	IF (ALLOCATED(Kech_V_wp)) DEALLOCATE(Kech_V_wp)
471	IF (ALLOCATED(KxKwVp)) DEALLOCATE(KxKwVp)
472	IF (ALLOCATED(dd_KVp)) DEALLOCATE(dd_KVp)
473	IF (ALLOCATED(dd_AV)) DEALLOCATE(dd_AV)
474	IF (ALLOCATED(dd_BV)) DEALLOCATE(dd_BV)
475
476	END SUBROUTINE wx_pbl_final
477
478	END MODULE wx_pbl_mod
479

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

Download in other formats:

Original Format