Home

Context Navigation

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

Last change on this file since 1922 was 1851, checked in by maronga, 9 years ago
last commit documented
Property svn:keywords set to `Id`
File size: 21.8 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |