Home

Context Navigation

source: palm/trunk/SOURCE/ls_forcing_mod.f90 @ 2258

Last change on this file since 2258 was 2233, checked in by suehring, 7 years ago
last commit documented
Property svn:keywords set to `Id`
File size: 24.9 KB

Line
1	!> @file ls_forcing_mod.f90
2	!------------------------------------------------------------------------------!
3	! This file is part of PALM.
4	!
5	! PALM is free software: you can redistribute it and/or modify it under the
6	! terms of the GNU General Public License as published by the Free Software
7	! Foundation, either version 3 of the License, or (at your option) any later
8	! version.
9	!
10	! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11	! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12	! A PARTICULAR PURPOSE. See the GNU General Public License for more details.
13	!
14	! You should have received a copy of the GNU General Public License along with
15	! PALM. If not, see <http://www.gnu.org/licenses/>.
16	!
17	! Copyright 1997-2017 Leibniz Universitaet Hannover
18	!------------------------------------------------------------------------------!
19	!
20	! Current revisions:
21	! ------------------
22	!
23	!
24	! Former revisions:
25	! -----------------
26	! $Id: ls_forcing_mod.f90 2233 2017-05-30 18:08:54Z suehring $
27	!
28	! 2232 2017-05-30 17:47:52Z suehring
29	! Adopt to new topography structure, even though no well-conceived topography
30	! concept concerning nudging and large-scale for exist so far.
31	!
32	! Also adopt to new surface-structure, i.e. fluxes are obtained from data-types
33	!
34	! 2104 2017-01-06 16:01:15Z knoop
35	! Bugfix for approximation related flux input conversion
36	!
37	! 2071 2016-11-17 11:22:14Z maronga
38	! Small bugfix (Resler)
39	!
40	! 2037 2016-10-26 11:15:40Z knoop
41	! Anelastic approximation implemented
42	!
43	! 2000 2016-08-20 18:09:15Z knoop
44	! Forced header and separation lines into 80 columns
45	!
46	! 1850 2016-04-08 13:29:27Z maronga
47	! Module renamed
48	!
49	!
50	! 1682 2015-10-07 23:56:08Z knoop
51	! Code annotations made doxygen readable
52	!
53	! 1602 2015-06-22 07:50:56Z heinze
54	! PA0370 changed to PA0363
55	!
56	! 1382 2014-04-30 12:15:41Z boeske
57	! Renamed variables which store large scale forcing tendencies
58	! pt_lsa -> td_lsa_lpt, pt_subs -> td_sub_lpt,
59	! q_lsa -> td_lsa_q, q_subs -> td_sub_q,
60	! high\|lowpt_lsa -> high\|low_td_lsa_lpt, ...
61	!
62	! 1365 2014-04-22 15:03:56Z boeske
63	! Usage of large scale forcing for pt and q enabled:
64	! Added new subroutine ls_advec for horizontal large scale advection and large
65	! scale subsidence,
66	! error message in init_ls_forcing specified,
67	! variable t renamed nt
68	!
69	! 1353 2014-04-08 15:21:23Z heinze
70	! REAL constants provided with KIND-attribute
71	!
72	! 1320 2014-03-20 08:40:49Z raasch
73	! ONLY-attribute added to USE-statements,
74	! kind-parameters added to all INTEGER and REAL declaration statements,
75	! kinds are defined in new module kinds,
76	! comment fields (!:) to be used for variable explanations added to
77	! all variable declaration statements
78	!
79	! 1318 2014-03-17 13:35:16Z raasch
80	! module interfaces removed
81	!
82	! 1299 2014-03-06 13:15:21Z heinze
83	! Ensure a zero large scale vertical velocity at the surface
84	! Bugfix: typo in case of boundary condition in if-clause
85	!
86	! 1276 2014-01-15 13:40:41Z heinze
87	! Use LSF_DATA also in case of Dirichlet bottom boundary condition for scalars
88	!
89	! 1249 2013-11-06 10:45:47Z heinze
90	! remove call of user module
91	! reformatting
92	!
93	! 1241 2013-10-30 11:36:58Z heinze
94	! Initial revision
95	!
96	! Description:
97	! ------------
98	!> Calculates large scale forcings (geostrophic wind and subsidence velocity) as
99	!> well as surfaces fluxes dependent on time given in an external file (LSF_DATA).
100	!> Code is based in parts on DALES and UCLA-LES.
101	!--------------------------------------------------------------------------------!
102	MODULE ls_forcing_mod
103
104
105	PRIVATE
106	PUBLIC init_ls_forcing, ls_forcing_surf, ls_forcing_vert, ls_advec
107	SAVE
108
109	INTERFACE ls_advec
110	MODULE PROCEDURE ls_advec
111	MODULE PROCEDURE ls_advec_ij
112	END INTERFACE ls_advec
113
114	CONTAINS
115
116	!------------------------------------------------------------------------------!
117	! Description:
118	! ------------
119	!> @todo Missing subroutine description.
120	!------------------------------------------------------------------------------!
121	SUBROUTINE init_ls_forcing
122
123	USE arrays_3d, &
124	ONLY: p_surf, pt_surf, q_surf, qsws_surf, shf_surf, td_lsa_lpt, &
125	td_lsa_q, td_sub_lpt, td_sub_q, time_surf, time_vert, &
126	ug_vert, vg_vert, wsubs_vert, zu
127
128	USE control_parameters, &
129	ONLY: end_time, lsf_surf, lsf_vert, message_string, nlsf
130
131	USE indices, &
132	ONLY: ngp_sums_ls, nzb, nz, nzt
133
134	USE kinds
135
136	USE statistics, &
137	ONLY: sums_ls_l
138
139
140	IMPLICIT NONE
141
142	CHARACTER(100) :: chmess !<
143	CHARACTER(1) :: hash !<
144
145	INTEGER(iwp) :: ierrn !<
146	INTEGER(iwp) :: finput = 90 !<
147	INTEGER(iwp) :: k !<
148	INTEGER(iwp) :: nt !<
149
150	REAL(wp) :: fac !<
151	REAL(wp) :: highheight !<
152	REAL(wp) :: highug_vert !<
153	REAL(wp) :: highvg_vert !<
154	REAL(wp) :: highwsubs_vert !<
155	REAL(wp) :: lowheight !<
156	REAL(wp) :: lowug_vert !<
157	REAL(wp) :: lowvg_vert !<
158	REAL(wp) :: lowwsubs_vert !<
159	REAL(wp) :: high_td_lsa_lpt !<
160	REAL(wp) :: low_td_lsa_lpt !<
161	REAL(wp) :: high_td_lsa_q !<
162	REAL(wp) :: low_td_lsa_q !<
163	REAL(wp) :: high_td_sub_lpt !<
164	REAL(wp) :: low_td_sub_lpt !<
165	REAL(wp) :: high_td_sub_q !<
166	REAL(wp) :: low_td_sub_q !<
167	REAL(wp) :: r_dummy !<
168
169	ALLOCATE( p_surf(0:nlsf), pt_surf(0:nlsf), q_surf(0:nlsf), &
170	qsws_surf(0:nlsf), shf_surf(0:nlsf), &
171	td_lsa_lpt(nzb:nzt+1,0:nlsf), td_lsa_q(nzb:nzt+1,0:nlsf), &
172	td_sub_lpt(nzb:nzt+1,0:nlsf), td_sub_q(nzb:nzt+1,0:nlsf), &
173	time_vert(0:nlsf), time_surf(0:nlsf), &
174	ug_vert(nzb:nzt+1,0:nlsf), vg_vert(nzb:nzt+1,0:nlsf), &
175	wsubs_vert(nzb:nzt+1,0:nlsf) )
176
177	p_surf = 0.0_wp; pt_surf = 0.0_wp; q_surf = 0.0_wp; qsws_surf = 0.0_wp
178	shf_surf = 0.0_wp; time_vert = 0.0_wp; td_lsa_lpt = 0.0_wp
179	td_lsa_q = 0.0_wp; td_sub_lpt = 0.0_wp; td_sub_q = 0.0_wp
180	time_surf = 0.0_wp; ug_vert = 0.0_wp; vg_vert = 0.0_wp
181	wsubs_vert = 0.0_wp
182
183	!
184	!-- Array for storing large scale forcing and nudging tendencies at each
185	!-- timestep for data output
186	ALLOCATE( sums_ls_l(nzb:nzt+1,0:7) )
187	sums_ls_l = 0.0_wp
188
189	ngp_sums_ls = (nz+2)*6
190
191	OPEN ( finput, FILE='LSF_DATA', STATUS='OLD', &
192	FORM='FORMATTED', IOSTAT=ierrn )
193
194	IF ( ierrn /= 0 ) THEN
195	message_string = 'file LSF_DATA does not exist'
196	CALL message( 'ls_forcing', 'PA0368', 1, 2, 0, 6, 0 )
197	ENDIF
198
199	ierrn = 0
200	!
201	!-- First three lines of LSF_DATA contain header
202	READ ( finput, FMT='(a100)', IOSTAT=ierrn ) chmess
203	READ ( finput, FMT='(a100)', IOSTAT=ierrn ) chmess
204	READ ( finput, FMT='(a100)', IOSTAT=ierrn ) chmess
205
206	IF ( ierrn /= 0 ) THEN
207	message_string = 'errors in file LSF_DATA'
208	CALL message( 'ls_forcing', 'PA0369', 1, 2, 0, 6, 0 )
209	ENDIF
210
211	!
212	!-- Surface values are read in
213	nt = 0
214	ierrn = 0
215
216	DO WHILE ( time_surf(nt) < end_time )
217	nt = nt + 1
218	READ ( finput, *, IOSTAT = ierrn ) time_surf(nt), shf_surf(nt), &
219	qsws_surf(nt), pt_surf(nt), &
220	q_surf(nt), p_surf(nt)
221
222	IF ( ierrn < 0 ) THEN
223	WRITE ( message_string, * ) 'No time dependent surface variables ',&
224	'in&LSF_DATA for end of run found'
225
226	CALL message( 'ls_forcing', 'PA0363', 1, 2, 0, 6, 0 )
227	ENDIF
228	ENDDO
229
230	IF ( time_surf(1) > end_time ) THEN
231	WRITE ( message_string, * ) 'No time dependent surface variables in ',&
232	'&LSF_DATA for end of run found - ', &
233	'lsf_surf is set to FALSE'
234	CALL message( 'ls_forcing', 'PA0371', 0, 0, 0, 6, 0 )
235	lsf_surf = .FALSE.
236	ENDIF
237
238	!
239	!-- Go to the end of the list with surface variables
240	DO WHILE ( ierrn == 0 )
241	READ ( finput, *, IOSTAT = ierrn ) r_dummy
242	ENDDO
243
244	!
245	!-- Profiles of ug, vg and w_subs are read in (large scale forcing)
246
247	nt = 0
248	DO WHILE ( time_vert(nt) < end_time )
249	nt = nt + 1
250	hash = "#"
251	ierrn = 1 ! not zero
252	!
253	!-- Search for the next line consisting of "# time",
254	!-- from there onwards the profiles will be read
255	DO WHILE ( .NOT. ( hash == "#" .AND. ierrn == 0 ) )
256	READ ( finput, *, IOSTAT=ierrn ) hash, time_vert(nt)
257	IF ( ierrn < 0 ) THEN
258	WRITE( message_string, * ) 'No time dependent vertical profiles',&
259	' in&LSF_DATA for end of run found'
260	CALL message( 'ls_forcing', 'PA0372', 1, 2, 0, 6, 0 )
261	ENDIF
262	ENDDO
263
264	IF ( nt == 1 .AND. time_vert(nt) > end_time ) EXIT
265
266	READ ( finput, *, IOSTAT=ierrn ) lowheight, lowug_vert, lowvg_vert, &
267	lowwsubs_vert, low_td_lsa_lpt, &
268	low_td_lsa_q, low_td_sub_lpt, &
269	low_td_sub_q
270	IF ( ierrn /= 0 ) THEN
271	message_string = 'errors in file LSF_DATA'
272	CALL message( 'ls_forcing', 'PA0369', 1, 2, 0, 6, 0 )
273	ENDIF
274
275	READ ( finput, *, IOSTAT=ierrn ) highheight, highug_vert, &
276	highvg_vert, highwsubs_vert, &
277	high_td_lsa_lpt, high_td_lsa_q, &
278	high_td_sub_lpt, high_td_sub_q
279
280	IF ( ierrn /= 0 ) THEN
281	message_string = 'errors in file LSF_DATA'
282	CALL message( 'ls_forcing', 'PA0369', 1, 2, 0, 6, 0 )
283	ENDIF
284
285
286	DO k = nzb, nzt+1
287	IF ( highheight < zu(k) ) THEN
288	lowheight = highheight
289	lowug_vert = highug_vert
290	lowvg_vert = highvg_vert
291	lowwsubs_vert = highwsubs_vert
292	low_td_lsa_lpt = high_td_lsa_lpt
293	low_td_lsa_q = high_td_lsa_q
294	low_td_sub_lpt = high_td_sub_lpt
295	low_td_sub_q = high_td_sub_q
296
297	ierrn = 0
298	READ ( finput, *, IOSTAT=ierrn ) highheight, highug_vert, &
299	highvg_vert, highwsubs_vert, &
300	high_td_lsa_lpt, &
301	high_td_lsa_q, &
302	high_td_sub_lpt, high_td_sub_q
303
304	IF ( ierrn /= 0 ) THEN
305	WRITE( message_string, * ) 'zu(nzt+1) = ', zu(nzt+1), 'm ', &
306	'is higher than the maximum height in LSF_DATA which ',&
307	'is ', lowheight, 'm. Interpolation on PALM ', &
308	'grid is not possible.'
309	CALL message( 'ls_forcing', 'PA0395', 1, 2, 0, 6, 0 )
310	ENDIF
311
312	ENDIF
313
314	!
315	!-- Interpolation of prescribed profiles in space
316	fac = (highheight-zu(k))/(highheight - lowheight)
317
318	ug_vert(k,nt) = fac * lowug_vert &
319	+ ( 1.0_wp - fac ) * highug_vert
320	vg_vert(k,nt) = fac * lowvg_vert &
321	+ ( 1.0_wp - fac ) * highvg_vert
322	wsubs_vert(k,nt) = fac * lowwsubs_vert &
323	+ ( 1.0_wp - fac ) * highwsubs_vert
324
325	td_lsa_lpt(k,nt) = fac * low_td_lsa_lpt &
326	+ ( 1.0_wp - fac ) * high_td_lsa_lpt
327	td_lsa_q(k,nt) = fac * low_td_lsa_q &
328	+ ( 1.0_wp - fac ) * high_td_lsa_q
329	td_sub_lpt(k,nt) = fac * low_td_sub_lpt &
330	+ ( 1.0_wp - fac ) * high_td_sub_lpt
331	td_sub_q(k,nt) = fac * low_td_sub_q &
332	+ ( 1.0_wp - fac ) * high_td_sub_q
333
334	ENDDO
335
336	ENDDO
337
338	!
339	!-- Large scale vertical velocity has to be zero at the surface
340	wsubs_vert(nzb,:) = 0.0_wp
341
342	IF ( time_vert(1) > end_time ) THEN
343	WRITE ( message_string, * ) 'Time dependent large scale profile ', &
344	'forcing from&LSF_DATA sets in after end of ' , &
345	'simulation - lsf_vert is set to FALSE'
346	CALL message( 'ls_forcing', 'PA0373', 0, 0, 0, 6, 0 )
347	lsf_vert = .FALSE.
348	ENDIF
349
350	CLOSE( finput )
351
352
353	END SUBROUTINE init_ls_forcing
354
355
356	!------------------------------------------------------------------------------!
357	! Description:
358	! ------------
359	!> @todo Missing subroutine description.
360	!------------------------------------------------------------------------------!
361	SUBROUTINE ls_forcing_surf ( time )
362
363	USE arrays_3d, &
364	ONLY: p_surf, pt_surf, q_surf, qsws_surf, shf_surf, &
365	heatflux_input_conversion, waterflux_input_conversion, &
366	time_surf, time_vert, ug, ug_vert, vg, vg_vert
367
368	USE control_parameters, &
369	ONLY: bc_q_b, ibc_pt_b, ibc_q_b, pt_surface, q_surface, &
370	surface_pressure
371
372	USE indices, &
373	ONLY: nzb
374
375	USE kinds
376
377	USE surface_mod, &
378	ONLY: surf_def_h, surf_lsm_h, surf_usm_h
379
380	IMPLICIT NONE
381
382	INTEGER(iwp) :: nt !<
383
384	REAL(wp) :: dum_surf_flux !<
385	REAL(wp) :: fac !<
386	REAL(wp), INTENT(in) :: time !<
387
388	!
389	!-- Interpolation in time of LSF_DATA at the surface
390	nt = 1
391	DO WHILE ( time > time_surf(nt) )
392	nt = nt + 1
393	ENDDO
394	IF ( time /= time_surf(nt) ) THEN
395	nt = nt - 1
396	ENDIF
397
398	fac = ( time -time_surf(nt) ) / ( time_surf(nt+1) - time_surf(nt) )
399
400	IF ( ibc_pt_b == 0 ) THEN
401	!
402	!-- In case of Dirichlet boundary condition shf must not
403	!-- be set - it is calculated via MOST in prandtl_fluxes
404	pt_surface = pt_surf(nt) + fac * ( pt_surf(nt+1) - pt_surf(nt) )
405
406	ELSEIF ( ibc_pt_b == 1 ) THEN
407	!
408	!-- In case of Neumann boundary condition pt_surface is needed for
409	!-- calculation of reference density
410	dum_surf_flux = ( shf_surf(nt) + fac * &
411	( shf_surf(nt+1) - shf_surf(nt) ) &
412	) * heatflux_input_conversion(nzb)
413	!
414	!-- Save surface sensible heat flux on default, natural and urban surface
415	!-- type, if required
416	IF ( surf_def_h(0)%ns >= 1 ) surf_def_h(0)%shf(:) = dum_surf_flux
417	IF ( surf_lsm_h%ns >= 1 ) surf_lsm_h%shf(:) = dum_surf_flux
418	IF ( surf_usm_h%ns >= 1 ) surf_usm_h%shf(:) = dum_surf_flux
419
420	pt_surface = pt_surf(nt) + fac * ( pt_surf(nt+1) - pt_surf(nt) )
421
422	ENDIF
423
424	IF ( ibc_q_b == 0 ) THEN
425	!
426	!-- In case of Dirichlet boundary condition qsws must not
427	!-- be set - it is calculated via MOST in prandtl_fluxes
428	q_surface = q_surf(nt) + fac * ( q_surf(nt+1) - q_surf(nt) )
429
430	ELSEIF ( ibc_q_b == 1 ) THEN
431	dum_surf_flux = ( qsws_surf(nt) + fac * &
432	( qsws_surf(nt+1) - qsws_surf(nt) ) &
433	) * waterflux_input_conversion(nzb)
434	!
435	!-- Save surface sensible heat flux on default, natural and urban surface
436	!-- type, if required
437	IF ( surf_def_h(0)%ns >= 1 ) surf_def_h(0)%qsws(:) = dum_surf_flux
438	IF ( surf_lsm_h%ns >= 1 ) surf_lsm_h%qsws(:) = dum_surf_flux
439	IF ( surf_usm_h%ns >= 1 ) surf_usm_h%qsws(:) = dum_surf_flux
440
441	ENDIF
442
443	surface_pressure = p_surf(nt) + fac * ( p_surf(nt+1) - p_surf(nt) )
444
445	END SUBROUTINE ls_forcing_surf
446
447
448	!------------------------------------------------------------------------------!
449	! Description:
450	! ------------
451	!> @todo Missing subroutine description.
452	!------------------------------------------------------------------------------!
453	SUBROUTINE ls_forcing_vert ( time )
454
455	USE arrays_3d, &
456	ONLY: time_vert, ug, ug_vert, vg, vg_vert, w_subs, wsubs_vert
457
458	USE control_parameters, &
459	ONLY: large_scale_subsidence
460
461	USE kinds
462
463	IMPLICIT NONE
464
465	INTEGER(iwp) :: nt !<
466
467	REAL(wp) :: fac !<
468	REAL(wp), INTENT(in) :: time !<
469
470	!
471	!-- Interpolation in time of LSF_DATA for ug, vg and w_subs
472	nt = 1
473	DO WHILE ( time > time_vert(nt) )
474	nt = nt + 1
475	ENDDO
476	IF ( time /= time_vert(nt) ) THEN
477	nt = nt - 1
478	ENDIF
479
480	fac = ( time-time_vert(nt) ) / ( time_vert(nt+1)-time_vert(nt) )
481
482	ug = ug_vert(:,nt) + fac * ( ug_vert(:,nt+1) - ug_vert(:,nt) )
483	vg = vg_vert(:,nt) + fac * ( vg_vert(:,nt+1) - vg_vert(:,nt) )
484
485	IF ( large_scale_subsidence ) THEN
486	w_subs = wsubs_vert(:,nt) &
487	+ fac * ( wsubs_vert(:,nt+1) - wsubs_vert(:,nt) )
488	ENDIF
489
490	END SUBROUTINE ls_forcing_vert
491
492
493	!------------------------------------------------------------------------------!
494	! Description:
495	! ------------
496	!> Call for all grid points
497	!------------------------------------------------------------------------------!
498	SUBROUTINE ls_advec ( time, prog_var )
499
500	USE arrays_3d, &
501	ONLY: td_lsa_lpt, td_lsa_q, td_sub_lpt, td_sub_q, tend, time_vert
502
503	USE control_parameters, &
504	ONLY: large_scale_subsidence, use_subsidence_tendencies
505
506	USE indices
507
508	USE kinds
509
510	IMPLICIT NONE
511
512	CHARACTER (LEN=*) :: prog_var !<
513
514	REAL(wp), INTENT(in) :: time !<
515	REAL(wp) :: fac !<
516
517	INTEGER(iwp) :: i !<
518	INTEGER(iwp) :: j !<
519	INTEGER(iwp) :: k !<
520	INTEGER(iwp) :: nt !<
521
522	!
523	!-- Interpolation in time of LSF_DATA
524	nt = 1
525	DO WHILE ( time > time_vert(nt) )
526	nt = nt + 1
527	ENDDO
528	IF ( time /= time_vert(nt) ) THEN
529	nt = nt - 1
530	ENDIF
531
532	fac = ( time-time_vert(nt) ) / ( time_vert(nt+1)-time_vert(nt) )
533
534	!
535	!-- Add horizontal large scale advection tendencies of pt and q
536	SELECT CASE ( prog_var )
537
538	CASE ( 'pt' )
539
540	DO i = nxl, nxr
541	DO j = nys, nyn
542	DO k = nzb+1, nzt
543	tend(k,j,i) = tend(k,j,i) + td_lsa_lpt(k,nt) + fac * &
544	( td_lsa_lpt(k,nt+1) - td_lsa_lpt(k,nt) ) *&
545	MERGE( 1.0_wp, 0.0_wp, &
546	BTEST( wall_flags_0(k,j,i), 0 ) )
547	ENDDO
548	ENDDO
549	ENDDO
550
551	CASE ( 'q' )
552
553	DO i = nxl, nxr
554	DO j = nys, nyn
555	DO k = nzb+1, nzt
556	tend(k,j,i) = tend(k,j,i) + td_lsa_q(k,nt) + fac * &
557	( td_lsa_q(k,nt+1) - td_lsa_q(k,nt) ) * &
558	MERGE( 1.0_wp, 0.0_wp, &
559	BTEST( wall_flags_0(k,j,i), 0 ) )
560	ENDDO
561	ENDDO
562	ENDDO
563
564	END SELECT
565
566	!
567	!-- Subsidence of pt and q with prescribed subsidence tendencies
568	IF ( large_scale_subsidence .AND. use_subsidence_tendencies ) THEN
569
570	SELECT CASE ( prog_var )
571
572	CASE ( 'pt' )
573
574	DO i = nxl, nxr
575	DO j = nys, nyn
576	DO k = nzb+1, nzt
577	tend(k,j,i) = tend(k,j,i) + td_sub_lpt(k,nt) + fac * &
578	( td_sub_lpt(k,nt+1) - td_sub_lpt(k,nt) )*&
579	MERGE( 1.0_wp, 0.0_wp, &
580	BTEST( wall_flags_0(k,j,i), 0 ) )
581	ENDDO
582	ENDDO
583	ENDDO
584
585	CASE ( 'q' )
586
587	DO i = nxl, nxr
588	DO j = nys, nyn
589	DO k = nzb+1, nzt
590	tend(k,j,i) = tend(k,j,i) + td_sub_q(k,nt) + fac * &
591	( td_sub_q(k,nt+1) - td_sub_q(k,nt) ) * &
592	MERGE( 1.0_wp, 0.0_wp, &
593	BTEST( wall_flags_0(k,j,i), 0 ) )
594	ENDDO
595	ENDDO
596	ENDDO
597
598	END SELECT
599
600	ENDIF
601
602	END SUBROUTINE ls_advec
603
604
605	!------------------------------------------------------------------------------!
606	! Description:
607	! ------------
608	!> Call for grid point i,j
609	!------------------------------------------------------------------------------!
610	SUBROUTINE ls_advec_ij ( i, j, time, prog_var )
611
612	USE arrays_3d, &
613	ONLY: td_lsa_lpt, td_lsa_q, td_sub_lpt, td_sub_q, tend, time_vert
614
615	USE control_parameters, &
616	ONLY: large_scale_subsidence, use_subsidence_tendencies
617
618	USE indices
619
620	USE kinds
621
622	IMPLICIT NONE
623
624	CHARACTER (LEN=*) :: prog_var !<
625
626	REAL(wp), INTENT(in) :: time !<
627	REAL(wp) :: fac !<
628
629	INTEGER(iwp) :: i !<
630	INTEGER(iwp) :: j !<
631	INTEGER(iwp) :: k !<
632	INTEGER(iwp) :: nt !<
633
634	!
635	!-- Interpolation in time of LSF_DATA
636	nt = 1
637	DO WHILE ( time > time_vert(nt) )
638	nt = nt + 1
639	ENDDO
640	IF ( time /= time_vert(nt) ) THEN
641	nt = nt - 1
642	ENDIF
643
644	fac = ( time-time_vert(nt) ) / ( time_vert(nt+1)-time_vert(nt) )
645
646	!
647	!-- Add horizontal large scale advection tendencies of pt and q
648	SELECT CASE ( prog_var )
649
650	CASE ( 'pt' )
651
652	DO k = nzb+1, nzt
653	tend(k,j,i) = tend(k,j,i) + td_lsa_lpt(k,nt) &
654	+ fac * ( td_lsa_lpt(k,nt+1) - td_lsa_lpt(k,nt) )*&
655	MERGE( 1.0_wp, 0.0_wp, &
656	BTEST( wall_flags_0(k,j,i), 0 ) )
657	ENDDO
658
659	CASE ( 'q' )
660
661	DO k = nzb+1, nzt
662	tend(k,j,i) = tend(k,j,i) + td_lsa_q(k,nt) &
663	+ fac * ( td_lsa_q(k,nt+1) - td_lsa_q(k,nt) ) * &
664	MERGE( 1.0_wp, 0.0_wp, &
665	BTEST( wall_flags_0(k,j,i), 0 ) )
666	ENDDO
667
668	END SELECT
669
670	!
671	!-- Subsidence of pt and q with prescribed profiles
672	IF ( large_scale_subsidence .AND. use_subsidence_tendencies ) THEN
673
674	SELECT CASE ( prog_var )
675
676	CASE ( 'pt' )
677
678	DO k = nzb+1, nzt
679	tend(k,j,i) = tend(k,j,i) + td_sub_lpt(k,nt) + fac * &
680	( td_sub_lpt(k,nt+1) - td_sub_lpt(k,nt) ) * &
681	MERGE( 1.0_wp, 0.0_wp, &
682	BTEST( wall_flags_0(k,j,i), 0 ) )
683	ENDDO
684
685	CASE ( 'q' )
686
687	DO k = nzb+1, nzt
688	tend(k,j,i) = tend(k,j,i) + td_sub_q(k,nt) + fac * &
689	( td_sub_q(k,nt+1) - td_sub_q(k,nt) ) * &
690	MERGE( 1.0_wp, 0.0_wp, &
691	BTEST( wall_flags_0(k,j,i), 0 ) )
692	ENDDO
693
694	END SELECT
695
696	ENDIF
697
698	END SUBROUTINE ls_advec_ij
699
700
701	END MODULE ls_forcing_mod

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |