Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |