Home

Context Navigation

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

Last change on this file since 2059 was 2038, checked in by knoop, 8 years ago
last commit documented
Property svn:keywords set to `Id`
File size: 22.2 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |