Home

Context Navigation

source: palm/trunk/SOURCE/biometeorology_pt_mod.f90 @ 3477

Last change on this file since 3477 was 3464, checked in by kanani, 6 years ago
from branch resler@3462: add MRT shaping function (radiation_model_mod), use basic constants (biometeorology_mod), adjust precision to wp (biometeorology_pt_mod)
Property svn:executable set to ``*
File size: 39.0 KB

Rev	Line
[3448]	1	!> @file biometeorology_pt_mod.f90
	2	!--------------------------------------------------------------------------------!
	3	! This file is part of PALM-4U.
	4	!
	5	! PALM-4U 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-4U 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-2019, Deutscher Wetterdienst (DWD) /
	18	! German Meteorological Service (DWD) and
	19	! Leibniz Universitaet Hannover
	20	!--------------------------------------------------------------------------------!
	21	!
[3464]	22	! Current revisions:
	23	! ------------------
[3448]	24	!
	25	!
[3464]	26	! Former revisions:
[3448]	27	! -----------------
	28	! $Id$
[3464]	29	! From branch resler@3462, pavelkrc:
	30	! replace specific precision DLOG, DMOD intrinsics with generic precision for
	31	! compatibility with 'wp'
	32	!
	33	!
	34	! Initial revision
[3448]	35	!
	36	!
	37	!
	38	! Authors:
	39	! --------
	40	! @author Dominik Froehlich <dominik.froehlich@mailbox.org>
	41	!
	42	!
	43	! Description:
	44	! ------------
	45	!> Module for the calculation of the thermal index perceived temperature (PT).
	46	!> The Perceived Temperature is the air temperature in a reference environ-
	47	!> ment that results in the same Predicted Mean Vote (Fanger 1972), PMV, as
	48	!> the real environment. In the reference environment the mean radiant
	49	!> temperature is equal to the air temperature and the wind speed is reduced
	50	!> to a value set at 0.1 m/s. The Perceived Temperature is linked to a
	51	!> reference individual: male aged 35 years, body height 1.75 m, weight
	52	!> 75 kg, walking with 4 km per hour on a horizontal plain (related to an
	53	!> internal heat production of 172.5 W). The person varies the thermal
	54	!> resistance of clothing (clo) in the range Icl=1.75 clo (winter) and
	55	!> Icl=0.50 clo (summer) to achieve thermal comfort (PMV = 0) if possible.
	56	!> If not possible the individual perceives cold stress (winter, 1.75 clo)
	57	!> or heat load (summer, 0.5 clo).
	58	!>
	59	!> @todo
	60	!>
	61	!> @note nothing now
	62	!>
	63	!> @bug no known bugs by now
	64	!------------------------------------------------------------------------------!
	65	MODULE biometeorology_pt_mod
	66
	67	!-- Load required variables from existing modules
	68	USE kinds !< to set precision of INTEGER and REAL arrays according to PALM
	69
	70	IMPLICIT NONE
	71
	72	PRIVATE !-- no private interfaces --!
	73
	74	PUBLIC calculate_pt_static, saturation_vapor_pressure, deltapmv, dpmv_adj, &
	75	dpmv_cold, fanger, calc_sultr, pt_regression, ireq_neutral, iso_ridder
	76
	77	!-- PALM interfaces:
	78	INTERFACE calculate_pt_static
	79	MODULE PROCEDURE calculate_pt_static
	80	END INTERFACE calculate_pt_static
	81
	82	INTERFACE saturation_vapor_pressure
	83	MODULE PROCEDURE saturation_vapor_pressure
	84	END INTERFACE saturation_vapor_pressure
	85
	86	INTERFACE deltapmv
	87	MODULE PROCEDURE deltapmv
	88	END INTERFACE deltapmv
	89
	90	INTERFACE dpmv_adj
	91	MODULE PROCEDURE dpmv_adj
	92	END INTERFACE dpmv_adj
	93
	94	INTERFACE dpmv_cold
	95	MODULE PROCEDURE dpmv_cold
	96	END INTERFACE dpmv_cold
	97
	98	INTERFACE fanger
	99	MODULE PROCEDURE fanger
	100	END INTERFACE fanger
	101
	102	INTERFACE calc_sultr
	103	MODULE PROCEDURE calc_sultr
	104	END INTERFACE calc_sultr
	105
	106	INTERFACE pt_regression
	107	MODULE PROCEDURE pt_regression
	108	END INTERFACE pt_regression
	109
	110	INTERFACE ireq_neutral
	111	MODULE PROCEDURE ireq_neutral
	112	END INTERFACE ireq_neutral
	113
	114	INTERFACE iso_ridder
	115	MODULE PROCEDURE iso_ridder
	116	END INTERFACE iso_ridder
	117
	118	CONTAINS
	119
	120	!------------------------------------------------------------------------------!
	121	! Description:
	122	! ------------
[3464]	123	!> PT_BASIC.F90 Version of perceived temperature (PT, ï¿œC) for
[3448]	124	!> - standard measured/predicted meteorological values and TMRT
	125	!> as input;
	126	!> - regressions for determination of PT;
	127	!> - adjustment to Gagge's PMV* (2-node-model, 1986) as base of PT
	128	!> under warm/humid conditions (Icl= 0.50 clo) and under cold
	129	!> conditions (Icl= 1.75 clo)
	130	!>
	131	!> Function value is the Perceived Temperature, degree centigrade
	132	!------------------------------------------------------------------------------!
	133	SUBROUTINE calculate_pt_static( tt2m, el2m, vau1m, tmrt, pb, clo, pt_basic )
	134
	135	IMPLICIT NONE
	136
	137	!-- Type of input of the argument list
[3464]	138	REAL(wp), INTENT ( IN ) :: tt2m !< Local air temperature (ï¿œC)
[3448]	139	REAL(wp), INTENT ( IN ) :: el2m !< Local vapour pressure (hPa)
[3464]	140	REAL(wp), INTENT ( IN ) :: tmrt !< Local mean radiant temperature (ï¿œC)
[3448]	141	REAL(wp), INTENT ( IN ) :: vau1m !< Local wind velocitry (m/s)
	142	REAL(wp), INTENT ( IN ) :: pb !< Local barometric air pressure (hPa)
	143
	144	!-- Type of output of the argument list
[3464]	145	REAL(wp), INTENT ( OUT ) :: pt_basic !< Perceived temperature (ï¿œC)
[3448]	146	REAL(wp), INTENT ( OUT ) :: clo !< Clothing index (dimensionless)
	147
	148	!-- Parameters for standard "Klima-Michel"
	149	REAL(wp), PARAMETER :: eta = 0._wp !< Mechanical work efficiency for walking on flat ground (compare to Fanger (1972) pp 24f)
	150	REAL(wp), PARAMETER :: actlev = 134.6862_wp !< Workload by activity per standardized surface (A_Du)
	151
	152	!-- Type of program variables
	153	REAL(wp), PARAMETER :: eps = 0.0005 !< Accuracy in clothing insulation (clo) for evaluation the root of Fanger's PMV (pmva=0)
	154	REAL(wp) :: uclo
	155	REAL(wp) :: oclo
	156	REAL(wp) :: d_pmv
	157	REAL(wp) :: svp_tt
	158	REAL(wp) :: sult_lim
	159	REAL(wp) :: dgtcm
	160	REAL(wp) :: dgtcstd
	161	REAL(wp) :: clon
	162	REAL(wp) :: ireq_minimal
	163	REAL(wp) :: clo_fanger
	164	REAL(wp) :: pmv_o
	165	REAL(wp) :: pmv_u
	166	REAL(wp) :: pmva
	167	REAL(wp) :: ptc
	168	REAL(wp) :: d_std
	169	REAL(wp) :: pmvs
	170	REAL(wp) :: top
	171
	172	INTEGER(iwp) :: nzaehl, nerr_kalt, nerr
	173
	174	LOGICAL :: sultrieness
	175
	176	!-- Initialise
	177	pt_basic = 9999.0_wp
	178
	179	nerr = 0_iwp
	180	nzaehl = 0_iwp
	181	sultrieness = .FALSE.
	182	!-- Tresholds: clothing insulation (account for model inaccuracies)
	183	! summer clothing
	184	uclo = 0.44453_wp
	185	! winter clothing
	186	oclo = 1.76267_wp
	187
	188	!-- decision: firstly calculate for winter or summer clothing
	189	IF ( tt2m <= 10._wp ) THEN
	190
	191	!-- First guess: winter clothing insulation: cold stress
	192	clo = oclo
	193	CALL fanger ( tt2m, tmrt, el2m, vau1m, pb, clo, actlev, eta, pmva, top )
	194	pmv_o = pmva
	195
	196	IF ( pmva > 0._wp ) THEN
	197
	198	!-- Case summer clothing insulation: heat load ?
	199	clo = uclo
	200	CALL fanger ( tt2m, tmrt, el2m, vau1m, pb, clo, actlev, eta, pmva, &
	201	top )
	202	pmv_u = pmva
	203	IF ( pmva <= 0._wp ) THEN
	204	!-- Case: comfort achievable by varying clothing insulation
	205	!-- Between winter and summer set values
	206	CALL iso_ridder ( tt2m, tmrt, el2m, vau1m, pb, actlev, eta, uclo, &
	207	pmv_u, oclo, pmv_o, eps, pmva, top, nzaehl, clo )
	208	IF ( nzaehl < 0_iwp ) THEN
	209	nerr = -1_iwp
	210	RETURN
	211	ENDIF
	212	ELSE IF ( pmva > 0.06_wp ) THEN
	213	clo = 0.5_wp
	214	CALL fanger ( tt2m, tmrt, el2m, vau1m, pb, clo, actlev, eta, &
	215	pmva, top )
	216	ENDIF
	217	ELSE IF ( pmva < -0.11_wp ) THEN
	218	clo = 1.75_wp
	219	CALL fanger ( tt2m, tmrt, el2m, vau1m, pb, clo, actlev, eta, pmva, &
	220	top )
	221	ENDIF
	222	ELSE
	223
	224	!-- First guess: summer clothing insulation: heat load
	225	clo = uclo
	226	CALL fanger ( tt2m, tmrt, el2m, vau1m, pb, clo, actlev, eta, pmva, top )
	227	pmv_u = pmva
	228
	229	IF ( pmva < 0._wp ) THEN
	230
	231	!-- Case winter clothing insulation: cold stress ?
	232	clo = oclo
	233	CALL fanger ( tt2m, tmrt, el2m, vau1m, pb, clo, actlev, eta, pmva, &
	234	top )
	235	pmv_o = pmva
	236
	237	IF ( pmva >= 0._wp ) THEN
	238
	239	!-- Case: comfort achievable by varying clothing insulation
	240	! between winter and summer set values
	241	CALL iso_ridder ( tt2m, tmrt, el2m, vau1m, pb, actlev, eta, uclo, &
	242	pmv_u, oclo, pmv_o, eps, pmva, top, nzaehl, clo )
	243	IF ( nzaehl < 0_iwp ) THEN
	244	nerr = -1_iwp
	245	RETURN
	246	ENDIF
	247	ELSE IF ( pmva < -0.11_wp ) THEN
	248	clo = 1.75_wp
	249	CALL fanger ( tt2m, tmrt, el2m, vau1m, pb, clo, actlev, eta, &
	250	pmva, top )
	251	ENDIF
	252	ELSE IF ( pmva > 0.06_wp ) THEN
	253	clo = 0.5_wp
	254	CALL fanger ( tt2m, tmrt, el2m, vau1m, pb, clo, actlev, eta, pmva, &
	255	top )
	256	ENDIF
	257
	258	ENDIF
	259
	260	!-- Determine perceived temperature by regression equation + adjustments
	261	pmvs = pmva
	262	CALL pt_regression ( pmva, clo, pt_basic )
	263	ptc = pt_basic
	264	IF ( clo >= 1.75_wp .AND. pmva <= -0.11_wp ) THEN
	265	!-- Adjust for cold conditions according to Gagge 1986
	266	CALL dpmv_cold ( pmva, tt2m, vau1m, tmrt, nerr_kalt, d_pmv )
	267	IF ( nerr_kalt > 0_iwp ) nerr = -5_iwp
	268	pmvs = pmva - d_pmv
	269	IF ( pmvs > -0.11_wp ) THEN
	270	d_pmv = 0._wp
	271	pmvs = -0.11_wp
	272	ENDIF
	273	CALL pt_regression ( pmvs, clo, pt_basic )
	274	ENDIF
	275	clo_fanger = clo
	276	clon = clo
	277	IF ( clo > 0.5_wp .AND. pt_basic <= 8.73_wp ) THEN
	278	!-- Required clothing insulation (ireq) is exclusively defined for
	279	! operative temperatures (top) less 10 (C) for a
	280	! reference wind of 0.2 m/s according to 8.73 (C) for 0.1 m/s
	281	clon = ireq_neutral ( pt_basic, ireq_minimal, nerr )
	282	clo = clon
	283	ENDIF
	284	CALL calc_sultr ( ptc, dgtcm, dgtcstd, sult_lim )
	285	sultrieness = .FALSE.
	286	d_std = -99._wp
	287	IF ( pmva > 0.06_wp .AND. clo <= 0.5_wp ) THEN
	288	!-- Adjust for warm/humid conditions according to Gagge 1986
	289	CALL saturation_vapor_pressure ( tt2m, svp_tt )
	290	d_pmv = deltapmv ( pmva, tt2m, el2m, svp_tt, tmrt, vau1m, nerr )
	291	pmvs = pmva + d_pmv
	292	CALL pt_regression ( pmvs, clo, pt_basic )
	293	IF ( sult_lim < 99._wp ) THEN
	294	IF ( (pt_basic - ptc) > sult_lim ) sultrieness = .TRUE.
	295	!-- Set factor to threshold for sultriness
	296	IF ( dgtcstd /= 0_iwp ) THEN
	297	d_std = ( ( pt_basic - ptc ) - dgtcm ) / dgtcstd
	298	ENDIF
	299	ENDIF
	300	ENDIF
	301
	302	END SUBROUTINE calculate_pt_static
	303
	304	!------------------------------------------------------------------------------!
	305	! Description:
	306	! ------------
	307	!> The SUBROUTINE calculates the saturation water vapour pressure
[3464]	308	!> (hPa = hecto Pascal) for a given temperature tt (ï¿œC).
[3448]	309	!> For example, tt can be the air temperature or the dew point temperature.
	310	!------------------------------------------------------------------------------!
	311	SUBROUTINE saturation_vapor_pressure( tt, p_st )
	312
	313	IMPLICIT NONE
	314
[3464]	315	REAL(wp), INTENT ( IN ) :: tt !< ambient air temperature (ï¿œC)
[3448]	316	REAL(wp), INTENT ( OUT ) :: p_st !< saturation water vapour pressure (hPa)
	317
	318	REAL(wp) :: b
	319	REAL(wp) :: c
	320
	321
	322	IF ( tt < 0._wp ) THEN
[3464]	323	!-- tt < 0 (ï¿œC): saturation water vapour pressure over ice
[3448]	324	b = 17.84362_wp
	325	c = 245.425_wp
	326	ELSE
[3464]	327	!-- tt >= 0 (ï¿œC): saturation water vapour pressure over water
[3448]	328	b = 17.08085_wp
	329	c = 234.175_wp
	330	ENDIF
	331
	332	!-- Saturation water vapour pressure
	333	p_st = 6.1078_wp * EXP ( b * tt / ( c + tt ) )
	334
	335	END SUBROUTINE saturation_vapor_pressure
	336
	337	!------------------------------------------------------------------------------!
	338	! Description:
	339	! ------------
	340	! Find the clothing insulation value clo_res (clo) to make Fanger's Predicted
	341	! Mean Vote (PMV) equal comfort (pmva=0) for actual meteorological conditions
	342	! (tt2m,tmrt, el2m, vau1m, pb) and values of individual's activity level
	343	! (Klima-Michel: 134.682 W/m2 = 2.3 met, mechanincal work load eta= 0 W/m2),
	344	! i.e. find the root of Fanger's comfort equation
	345	!------------------------------------------------------------------------------!
	346	SUBROUTINE iso_ridder( tt2m, tmrt, el2m, vau1m, pb, actlev, eta, uclo, &
	347	pmv_u, oclo, pmv_o, eps, pmva, top, nerr, &
	348	clo_res )
	349
	350	IMPLICIT NONE
	351
	352	!-- Input variables of argument list:
[3464]	353	REAL(wp), INTENT ( IN ) :: tt2m !< Ambient temperature (ï¿œC)
	354	REAL(wp), INTENT ( IN ) :: tmrt !< Mean radiant temperature (ï¿œC)
[3448]	355	REAL(wp), INTENT ( IN ) :: el2m !< Water vapour pressure (hPa)
	356	REAL(wp), INTENT ( IN ) :: vau1m !< Wind speed (m/s) 1 m above ground
	357	REAL(wp), INTENT ( IN ) :: pb !< Barometric pressure (hPa)
	358	REAL(wp), INTENT ( IN ) :: actlev !< Individuals activity level per unit surface area (W/m2)
	359	REAL(wp), INTENT ( IN ) :: eta !< Individuals work efficiency (dimensionless)
	360	REAL(wp), INTENT ( IN ) :: uclo !< Lower threshold of bracketing clothing insulation (clo)
	361	REAL(wp), INTENT ( IN ) :: oclo !< Upper threshold of bracketing clothing insulation (clo)
	362	REAL(wp), INTENT ( IN ) :: eps !< (0.05) accuracy in clothing insulation (clo) for
	363	! evaluation the root of Fanger's PMV (pmva=0)
	364	REAL(wp), INTENT ( IN ) :: pmv_o !< Fanger's PMV corresponding to oclo
	365	REAL(wp), INTENT ( IN ) :: pmv_u !< Fanger's PMV corresponding to uclo
	366
	367	! Output variables of argument list:
	368	REAL(wp), INTENT ( OUT ) :: pmva !< 0 (set to zero, because clo is evaluated for comfort)
[3464]	369	REAL(wp), INTENT ( OUT ) :: top !< Operative temperature (ï¿œC) at found root of Fanger's PMV
[3448]	370	REAL(wp), INTENT ( OUT ) :: clo_res !< Resulting clothing insulation value (clo)
	371	INTEGER(iwp), INTENT ( OUT ) :: nerr !< Error status / quality flag
	372	! nerr >= 0, o.k., and nerr is the number of iterations for
	373	! convergence
	374	! nerr = -1: error = malfunction of Ridder's convergence method
	375	! nerr = -2: error = maximum iterations (max_iteration) exceeded
	376	! nerr = -3: error = root not bracketed between uclo and oclo
	377
	378	!-- Type of program variables
	379	INTEGER(iwp), PARAMETER :: max_iteration = 15_iwp
	380	REAL(wp), PARAMETER :: guess_0 = -1.11e30_wp
	381	REAL(wp) :: x_ridder
	382	REAL(wp) :: clo_u
	383	REAL(wp) :: clo_o
	384	REAL(wp) :: x_unten
	385	REAL(wp) :: x_oben
	386	REAL(wp) :: x_mittel
	387	REAL(wp) :: x_neu
	388	REAL(wp) :: y_unten
	389	REAL(wp) :: y_oben
	390	REAL(wp) :: y_mittel
	391	REAL(wp) :: y_neu
	392	REAL(wp) :: s
	393	INTEGER(iwp) :: j
	394
	395	!-- Initialise
	396	nerr = 0_iwp
	397
	398	!-- Set pmva = 0 (comfort): Root of PMV depending on clothing insulation
	399	pmva = 0._wp
	400	clo_u = uclo
	401	y_unten = pmv_u
	402	clo_o = oclo
	403	y_oben = pmv_o
	404	IF ( ( y_unten > 0._wp .AND. y_oben < 0._wp ) .OR. &
	405	( y_unten < 0._wp .AND. y_oben > 0._wp ) ) THEN
	406	x_unten = clo_u
	407	x_oben = clo_o
	408	x_ridder = guess_0
	409
	410	DO j = 1_iwp, max_iteration
	411	x_mittel = 0.5_wp * ( x_unten + x_oben )
	412	CALL fanger ( tt2m, tmrt, el2m, vau1m, pb, x_mittel, actlev, eta, &
	413	y_mittel, top )
	414	s = SQRT ( y_mittel*2 - y_unten y_oben )
	415	IF ( s == 0._wp ) THEN
	416	clo_res = x_mittel
	417	nerr = j
	418	RETURN
	419	ENDIF
	420	x_neu = x_mittel + ( x_mittel - x_unten ) * &
	421	( SIGN ( 1._wp, y_unten - y_oben ) * y_mittel / s )
	422	IF ( ABS ( x_neu - x_ridder ) <= eps ) THEN
	423	clo_res = x_ridder
	424	nerr = j
	425	RETURN
	426	ENDIF
	427	x_ridder = x_neu
	428	CALL fanger ( tt2m, tmrt, el2m, vau1m, pb, x_ridder, actlev, eta, &
	429	y_neu, top )
	430	IF ( y_neu == 0._wp ) THEN
	431	clo_res = x_ridder
	432	nerr = j
	433	RETURN
	434	ENDIF
	435	IF ( SIGN ( y_mittel, y_neu ) /= y_mittel ) THEN
	436	x_unten = x_mittel
	437	y_unten = y_mittel
	438	x_oben = x_ridder
	439	y_oben = y_neu
	440	ELSE IF ( SIGN ( y_unten, y_neu ) /= y_unten ) THEN
	441	x_oben = x_ridder
	442	y_oben = y_neu
	443	ELSE IF ( SIGN ( y_oben, y_neu ) /= y_oben ) THEN
	444	x_unten = x_ridder
	445	y_unten = y_neu
	446	ELSE
	447	!-- Never get here in x_ridder: singularity in y
	448	nerr = -1_iwp
	449	clo_res = x_ridder
	450	RETURN
	451	ENDIF
	452	IF ( ABS ( x_oben - x_unten ) <= eps ) THEN
	453	clo_res = x_ridder
	454	nerr = j
	455	RETURN
	456	ENDIF
	457	ENDDO
	458	!-- x_ridder exceed maximum iterations
	459	nerr = -2_iwp
	460	clo_res = y_neu
	461	RETURN
	462	ELSE IF ( y_unten == 0. ) THEN
	463	x_ridder = clo_u
	464	ELSE IF ( y_oben == 0. ) THEN
	465	x_ridder = clo_o
	466	ELSE
	467	!-- x_ridder not bracketed by u_clo and o_clo
	468	nerr = -3_iwp
	469	clo_res = x_ridder
	470	RETURN
	471	ENDIF
	472
	473	END SUBROUTINE iso_ridder
	474
	475	!------------------------------------------------------------------------------!
	476	! Description:
	477	! ------------
	478	!> Regression relations between perceived temperature (gt) and (adjusted)
	479	!> PMV (21.11.1996, files F3PMVPGT.TXT und F3CLOGT.TXT). Three cases:
	480	!>
	481	!> - PMV < 0: gt = 5.805 + 12.6784*pmv
	482	!> - PMV = 0 (gt depends on clothing insulation, FUNCTION iso_ridder):
	483	!> gt = 21.258 - 9.558*clo
	484	!> - PMV > 0: 16.826 + 6.163*pmv
	485	!>
	486	!> The regression presumes the Klima-Michel settings for reference
	487	!> individual and reference environment.
	488	!------------------------------------------------------------------------------!
	489	SUBROUTINE pt_regression( pmv, clo, pt )
	490
	491	IMPLICIT NONE
	492
	493	REAL(wp), INTENT ( IN ) :: pmv !< Fangers predicted mean vote (dimensionless)
	494	REAL(wp), INTENT ( IN ) :: clo !< clothing insulation index (clo)
[3464]	495	REAL(wp), INTENT ( OUT ) :: pt !< pt (ï¿œC) corresponding to given PMV / clo
[3448]	496
	497	IF ( pmv <= -0.11_wp ) THEN
	498	pt = 5.805_wp + 12.6784_wp * pmv
	499	ELSE
	500	IF ( pmv >= + 0.01_wp ) THEN
	501	pt = 16.826_wp + 6.163_wp * pmv
	502	ELSE
	503	pt = 21.258_wp - 9.558_wp * clo
	504	ENDIF
	505	ENDIF
	506
	507	END SUBROUTINE pt_regression
	508
	509	!------------------------------------------------------------------------------!
	510	! Description:
	511	! ------------
	512	!> FANGER.F90
	513	!>
	514	!> SI-VERSION: ACTLEV W m-2, DAMPFDRUCK hPa
	515	!> Berechnet das aktuelle Predicted Mean Vote nach Fanger
	516	!>
	517	!> The case of free convection (vau < 0.1 m/s) is dealt with vau = 0.1 m/s
	518	!------------------------------------------------------------------------------!
	519	SUBROUTINE fanger( tt, tmrt, pa, in_vau, pb, in_clo, actlev, eta, pmva, top )
	520
	521	IMPLICIT NONE
	522
	523	!-- Input variables of argument list:
[3464]	524	REAL(wp), INTENT ( IN ) :: tt !< Ambient air temperature (ï¿œC)
	525	REAL(wp), INTENT ( IN ) :: tmrt !< Mean radiant temperature (ï¿œC)
[3448]	526	REAL(wp), INTENT ( IN ) :: pa !< Water vapour pressure (hPa)
	527	REAL(wp), INTENT ( IN ) :: pb !< Barometric pressure (hPa) at site
	528	REAL(wp), INTENT ( IN ) :: in_vau !< Wind speed (m/s) 1 m above ground
	529	REAL(wp), INTENT ( IN ) :: in_clo !< Clothing insulation (clo)
	530	REAL(wp), INTENT ( IN ) :: actlev !< Individuals activity level per unit surface area (W/m2)
	531	REAL(wp), INTENT ( IN ) :: eta !< Individuals mechanical work efficiency (dimensionless)
	532
	533	!-- Output variables of argument list:
	534	REAL(wp), INTENT ( OUT ) :: pmva !< Actual Predicted Mean Vote (dimensionless) according
	535	! to Fanger corresponding to meteorological (tt,tmrt,pa,vau,pb)
	536	! and individual variables (clo, actlev, eta)
[3464]	537	REAL(wp), INTENT ( OUT ) :: top !< operative temperature (ï¿œC)
[3448]	538
	539	!-- Internal variables
	540	REAL(wp), PARAMETER :: cels_offs = 273.15_wp !< Kelvin Celsius Offset (K)
	541	REAL(wp) :: f_cl
	542	REAL(wp) :: heat_convection
	543	REAL(wp) :: activity
	544	REAL(wp) :: t_skin_aver
	545	REAL(wp) :: bc
	546	REAL(wp) :: cc
	547	REAL(wp) :: dc
	548	REAL(wp) :: ec
	549	REAL(wp) :: gc
	550	REAL(wp) :: t_clothing
	551	REAL(wp) :: hr
	552	REAL(wp) :: clo
	553	REAL(wp) :: vau
	554	REAL(wp) :: z1
	555	REAL(wp) :: z2
	556	REAL(wp) :: z3
	557	REAL(wp) :: z4
	558	REAL(wp) :: z5
	559	REAL(wp) :: z6
	560	INTEGER(iwp) :: i
	561
	562	!-- Clo must be > 0. to avoid div. by 0!
	563	clo = in_clo
	564	IF ( clo <= 0._wp ) clo = .001_wp
	565
	566	!-- f_cl = Increase in surface due to clothing
	567	f_cl = 1._wp + .15_wp * clo
	568
	569	!-- Case of free convection (vau < 0.1 m/s ) not considered
	570	vau = in_vau
	571	IF ( vau < .1_wp ) THEN
	572	vau = .1_wp
	573	ENDIF
	574
	575	!-- Heat_convection = forced convection
	576	heat_convection = 12.1_wp * SQRT ( vau * pb / 1013.25_wp )
	577
	578	!-- Activity = inner heat produktion per standardized surface
	579	activity = actlev * ( 1._wp - eta )
	580
	581	!-- T_skin_aver = average skin temperature
	582	t_skin_aver = 35.7_wp - .0275_wp * activity
	583
	584	!-- Calculation of constants for evaluation below
	585	bc = .155_wp * clo * 3.96_wp * 10._wp*( -8 ) f_cl
	586	cc = f_cl * heat_convection
	587	ec = .155_wp * clo
	588	dc = ( 1._wp + ec * cc ) / bc
	589	gc = ( t_skin_aver + bc * ( tmrt + cels_offs )*4 + ec cc * tt ) / bc
	590
	591	!-- Calculation of clothing surface temperature (t_clothing) based on
	592	! Newton-approximation with air temperature as initial guess
	593	t_clothing = tt
	594	DO I = 1, 3
	595	t_clothing = t_clothing - ( ( t_clothing + cels_offs )**4 + t_clothing &
	596	* dc - gc ) / ( 4._wp * ( t_clothing + cels_offs )**3 + dc )
	597	ENDDO
	598
	599	!-- Empiric factor for the adaption of the heat ballance equation
	600	! to the psycho-physical scale (Equ. 40 in FANGER)
	601	z1 = ( .303_wp * EXP ( -.036_wp * actlev ) + .0275_wp )
	602
	603	!-- Water vapour diffution through the skin
	604	z2 = .31_wp * ( 57.3_wp - .07_wp * activity-pa )
	605
	606	!-- Sweat evaporation from the skin surface
	607	z3 = .42_wp * ( activity - 58._wp )
	608
	609	!-- Loss of latent heat through respiration
	610	z4 = .0017_wp * actlev * ( 58.7_wp - pa ) + .0014_wp * actlev * &
	611	( 34._wp - tt )
	612
	613	!-- Loss of radiational heat
	614	z5 = 3.96e-8_wp * f_cl * ( ( t_clothing + cels_offs )**4 - ( tmrt + &
	615	cels_offs )**4 )
	616	IF ( ABS ( t_clothing - tmrt ) > 0._wp ) THEN
	617	hr = z5 / f_cl / ( t_clothing - tmrt )
	618	ELSE
	619	hr = 0._wp
	620	ENDIF
	621
	622	!-- Heat loss through forced convection cc*(t_clothing-TT)
	623	z6 = cc * ( t_clothing - tt )
	624
	625	!-- Predicted Mean Vote
	626	pmva = z1 * ( activity - z2 - z3 - z4 - z5 - z6 )
	627
	628	!-- Operative temperatur
	629	top = ( hr * tmrt + heat_convection * tt ) / ( hr + heat_convection )
	630
	631	END SUBROUTINE fanger
	632
	633	!------------------------------------------------------------------------------!
	634	! Description:
	635	! ------------
	636	!> For pmva > 0 and clo =0.5 the increment (deltapmv) is calculated
	637	!> that converts pmva into Gagge's et al. (1986) PMV*.
	638	!------------------------------------------------------------------------------!
	639	REAL(wp) FUNCTION deltapmv( pmva, tt2m, el2m, svp_tt, tmrt, vau1m, nerr )
	640
	641	IMPLICIT NONE
	642
	643	!-- Input variables of argument list:
	644	REAL(wp), INTENT ( IN ) :: pmva !< Actual Predicted Mean Vote (PMV) according to Fanger
[3464]	645	REAL(wp), INTENT ( IN ) :: tt2m !< Ambient temperature (ï¿œC) at screen level
[3448]	646	REAL(wp), INTENT ( IN ) :: el2m !< Water vapour pressure (hPa) at screen level
	647	REAL(wp), INTENT ( IN ) :: svp_tt !< Saturation water vapour pressure (hPa) at tt2m
[3464]	648	REAL(wp), INTENT ( IN ) :: tmrt !< Mean radiant temperature (ï¿œC) at screen level
[3448]	649	REAL(wp), INTENT ( IN ) :: vau1m !< Wind speed (m/s) 1 m above ground
	650
	651	!-- Output variables of argument list:
	652	INTEGER(iwp), INTENT ( OUT ) :: nerr !< Error status / quality flag
	653	! 0 = o.k.
	654	! -2 = pmva outside valid regression range
	655	! -3 = rel. humidity set to 5 % or 95 %, respectively
	656	! -4 = deltapmv set to avoid pmvs < 0
	657
	658	!-- Internal variable types:
	659	REAL(wp) :: pmv
	660	REAL(wp) :: pa_p50
	661	REAL(wp) :: pa
	662	REAL(wp) :: apa
	663	REAL(wp) :: dapa
	664	REAL(wp) :: sqvel
	665	REAL(wp) :: ta
	666	REAL(wp) :: dtmrt
	667	REAL(wp) :: p10
	668	REAL(wp) :: p95
	669	REAL(wp) :: gew
	670	REAL(wp) :: gew2
	671	REAL(wp) :: dpmv_1
	672	REAL(wp) :: dpmv_2
	673	REAL(wp) :: pmvs
	674	REAL(wp) :: bpmv(0:7)
	675	REAL(wp) :: bpa_p50(0:7)
	676	REAL(wp) :: bpa(0:7)
	677	REAL(wp) :: bapa(0:7)
	678	REAL(wp) :: bdapa(0:7)
	679	REAL(wp) :: bsqvel(0:7)
	680	REAL(wp) :: bta(0:7)
	681	REAL(wp) :: bdtmrt(0:7)
	682	REAL(wp) :: aconst(0:7)
	683	INTEGER(iwp) :: nreg
	684
	685	DATA bpmv / &
	686	-0.0556602_wp, -0.1528680_wp, -0.2336104_wp, -0.2789387_wp, -0.3551048_wp,&
	687	-0.4304076_wp, -0.4884961_wp, -0.4897495_wp /
	688	DATA bpa_p50 / &
	689	-0.1607154_wp, -0.4177296_wp, -0.4120541_wp, -0.0886564_wp, +0.4285938_wp,&
	690	+0.6281256_wp, +0.5067361_wp, +0.3965169_wp /
	691	DATA bpa / &
	692	+0.0580284_wp, +0.0836264_wp, +0.1009919_wp, +0.1020777_wp, +0.0898681_wp,&
	693	+0.0839116_wp, +0.0853258_wp, +0.0866589_wp /
	694	DATA bapa / &
	695	-1.7838788_wp, -2.9306231_wp, -1.6350334_wp, +0.6211547_wp, +3.3918083_wp,&
	696	+5.5521025_wp, +8.4897418_wp, +16.6265851_wp /
	697	DATA bdapa / &
	698	+1.6752720_wp, +2.7379504_wp, +1.2940526_wp, -1.0985759_wp, -3.9054732_wp,&
	699	-6.0403012_wp, -8.9437119_wp, -17.0671201_wp /
	700	DATA bsqvel / &
	701	-0.0315598_wp, -0.0286272_wp, -0.0009228_wp, +0.0483344_wp, +0.0992366_wp,&
	702	+0.1491379_wp, +0.1951452_wp, +0.2133949_wp /
	703	DATA bta / &
	704	+0.0953986_wp, +0.1524760_wp, +0.0564241_wp, -0.0893253_wp, -0.2398868_wp,&
	705	-0.3515237_wp, -0.5095144_wp, -0.9469258_wp /
	706	DATA bdtmrt / &
	707	-0.0004672_wp, -0.0000514_wp, -0.0018037_wp, -0.0049440_wp, -0.0069036_wp,&
	708	-0.0075844_wp, -0.0079602_wp, -0.0089439_wp /
	709	DATA aconst / &
	710	+1.8686215_wp, +3.4260713_wp, +2.0116185_wp, -0.7777552_wp, -4.6715853_wp,&
	711	-7.7314281_wp, -11.7602578_wp, -23.5934198_wp /
	712
	713	!-- Test for compliance with regression range
	714	IF ( pmva < -1.0_wp .OR. pmva > 7.0_wp ) THEN
	715	nerr = -2_iwp
	716	ELSE
	717	nerr = 0_iwp
	718	ENDIF
	719
	720	!-- Initialise classic PMV
	721	pmv = pmva
	722
	723	!-- Water vapour pressure of air
	724	p10 = 0.05_wp * svp_tt
	725	p95 = 1.00_wp * svp_tt
	726	IF ( el2m >= p10 .AND. el2m <= p95 ) THEN
	727	pa = el2m
	728	ELSE
	729	nerr = -3_iwp
	730	IF ( el2m < p10 ) THEN
[3464]	731	!-- Due to conditions of regressï¿œon: r.H. >= 5 %
[3448]	732	pa = p10
	733	ELSE
[3464]	734	!-- Due to conditions of regressï¿œon: r.H. <= 95 %
[3448]	735	pa = p95
	736	ENDIF
	737	ENDIF
	738	IF ( pa > 0._wp ) THEN
	739	!-- Natural logarithm of pa
[3464]	740	apa = LOG ( pa )
[3448]	741	ELSE
	742	apa = -5._wp
	743	ENDIF
	744
	745	!-- Ratio actual water vapour pressure to that of a r.H. of 50 %
	746	pa_p50 = 0.5_wp * svp_tt
	747	IF ( pa_p50 > 0._wp .AND. pa > 0._wp ) THEN
[3464]	748	dapa = apa - LOG ( pa_p50 )
[3448]	749	pa_p50 = pa / pa_p50
	750	ELSE
	751	dapa = -5._wp
	752	pa_p50 = 0._wp
	753	ENDIF
	754	!-- Square root of wind velocity
	755	IF ( vau1m >= 0._wp ) THEN
	756	sqvel = SQRT ( vau1m )
	757	ELSE
	758	sqvel = 0._wp
	759	ENDIF
	760	!-- Air temperature
	761	ta = tt2m
	762	!-- Difference mean radiation to air temperature
	763	dtmrt = tmrt - ta
	764
	765	!-- Select the valid regression coefficients
	766	nreg = INT ( pmv )
	767	IF ( nreg < 0_iwp ) THEN
	768	!-- value of the FUNCTION in the case pmv <= -1
	769	deltapmv = 0._wp
	770	RETURN
	771	ENDIF
[3464]	772	gew = MOD ( pmv, 1._wp )
[3448]	773	IF ( gew < 0._wp ) gew = 0._wp
	774	IF ( nreg > 5_iwp ) THEN
	775	! nreg=6
	776	nreg = 5_iwp
	777	gew = pmv - 5._wp
	778	gew2 = pmv - 6._wp
	779	IF ( gew2 > 0_iwp ) THEN
	780	gew = ( gew - gew2 ) / gew
	781	ENDIF
	782	ENDIF
	783
	784	!-- Regression valid for 0. <= pmv <= 6.
	785	dpmv_1 = &
	786	+ bpa ( nreg ) * pa &
	787	+ bpmv ( nreg ) * pmv &
	788	+ bapa ( nreg ) * apa &
	789	+ bta ( nreg ) * ta &
	790	+ bdtmrt ( nreg ) * dtmrt &
	791	+ bdapa ( nreg ) * dapa &
	792	+ bsqvel ( nreg ) * sqvel &
	793	+ bpa_p50 ( nreg ) * pa_p50 &
	794	+ aconst ( nreg )
	795
	796	dpmv_2 = 0._wp
	797	IF ( nreg < 6_iwp ) THEN
	798	dpmv_2 = &
	799	+ bpa ( nreg + 1_iwp ) * pa &
	800	+ bpmv ( nreg + 1_iwp ) * pmv &
	801	+ bapa ( nreg + 1_iwp ) * apa &
	802	+ bta ( nreg + 1_iwp ) * ta &
	803	+ bdtmrt ( nreg + 1_iwp ) * dtmrt &
	804	+ bdapa ( nreg + 1_iwp ) * dapa &
	805	+ bsqvel ( nreg + 1_iwp ) * sqvel &
	806	+ bpa_p50 ( nreg + 1_iwp ) * pa_p50 &
	807	+ aconst ( nreg + 1_iwp )
	808	ENDIF
	809
	810	!-- Calculate pmv modification
	811	deltapmv = ( 1._wp - gew ) * dpmv_1 + gew * dpmv_2
	812	pmvs = pmva + deltapmv
	813	IF ( ( pmvs ) < 0._wp ) THEN
	814	!-- Prevent negative pmv* due to problems with clothing insulation
	815	nerr = -4_iwp
	816	IF ( pmvs > -0.11_wp ) THEN
	817	!-- Threshold from FUNCTION pt_regression for winter clothing insulation
	818	deltapmv = deltapmv + 0.11_wp
	819	ELSE
	820	!-- Set pmvs to "0" for compliance with summer clothing insulation
	821	deltapmv = -1._wp * pmva
	822	ENDIF
	823	ENDIF
	824
	825	END FUNCTION deltapmv
	826
	827	!------------------------------------------------------------------------------!
	828	! Description:
	829	! ------------
	830	!> The subroutine "calc_sultr" returns a threshold value to perceived
	831	!> temperature allowing to decide whether the actual perceived temperature
	832	!> is linked to perecption of sultriness. The threshold values depends
	833	!> on the Fanger's classical PMV, expressed here as perceived temperature
	834	!> gtc. It is derived from all synoptic observations 1966-1995 of the sites
	835	!> 10170 Rostock-Warnemuende and 10803 Freiburg showing heat load. The
	836	!> threshold value is valid for subjects acclimatised to Central European
	837	!> climate conditions. It includes all effective influences as air
	838	!> temperature, relative humidity, mean radiant temperature, and wind
	839	!> velocity:
	840	!> - defined only under warm conditions: gtc based on 0.5 (clo) and
[3464]	841	!> gtc > 16.826 (ï¿œC)
[3448]	842	!> - undefined: sultr_res set at +99.
	843	!------------------------------------------------------------------------------!
	844	SUBROUTINE calc_sultr( gtc, dgtcm, dgtcstd, sultr_res )
	845
	846	IMPLICIT NONE
	847
	848	!-- Input of the argument list:
	849	REAL(wp), INTENT ( IN ) :: gtc !< Classical perceived temperature: Base is Fanger's PMV
	850
	851	!-- Additional output variables of argument list:
	852	REAL(wp), INTENT ( OUT ) :: dgtcm !< Mean deviation gtc (classical gt) to gt* (rational gt
	853	! calculated based on Gagge's rational PMV*)
	854	REAL(wp), INTENT ( OUT ) :: dgtcstd !< dgtcm plus its standard deviation times a factor
	855	! determining the significance to perceive sultriness
	856	REAL(wp), INTENT ( OUT ) :: sultr_res
	857
	858	!-- Types of coefficients mean deviation: third order polynomial
	859	REAL(wp), PARAMETER :: dgtcka = +7.5776086_wp
	860	REAL(wp), PARAMETER :: dgtckb = -0.740603_wp
	861	REAL(wp), PARAMETER :: dgtckc = +0.0213324_wp
	862	REAL(wp), PARAMETER :: dgtckd = -0.00027797237_wp
	863
	864	!-- Types of coefficients mean deviation plus standard deviation
	865	! regression coefficients: third order polynomial
	866	REAL(wp), PARAMETER :: dgtcsa = +0.0268918_wp
	867	REAL(wp), PARAMETER :: dgtcsb = +0.0465957_wp
	868	REAL(wp), PARAMETER :: dgtcsc = -0.00054709752_wp
	869	REAL(wp), PARAMETER :: dgtcsd = +0.0000063714823_wp
	870
	871	!-- Factor to mean standard deviation defining SIGNificance for
	872	! sultriness
	873	REAL(wp), PARAMETER :: faktor = 1._wp
	874
	875	!-- Initialise
	876	sultr_res = +99._wp
	877	dgtcm = 0._wp
	878	dgtcstd = 999999._wp
	879
	880	IF ( gtc < 16.826_wp .OR. gtc > 56._wp ) THEN
	881	!-- Unallowed classical PMV/gtc
	882	RETURN
	883	ENDIF
	884
	885	!-- Mean deviation dependent on gtc
	886	dgtcm = dgtcka + dgtckb * gtc + dgtckc * gtc*2._wp + dgtckd gtc**3._wp
	887
	888	!-- Mean deviation plus its standard deviation
	889	dgtcstd = dgtcsa + dgtcsb * gtc + dgtcsc * gtc*2._wp + dgtcsd gtc**3._wp
	890
	891	!-- Value of the FUNCTION
	892	sultr_res = dgtcm + faktor * dgtcstd
	893	IF ( ABS ( sultr_res ) > 99._wp ) sultr_res = +99._wp
	894
	895	END SUBROUTINE calc_sultr
	896
	897	!------------------------------------------------------------------------------!
	898	! Description:
	899	! ------------
	900	!> Multiple linear regression to calculate an increment delta_kalt,
	901	!> to adjust Fanger's classical PMV (pmva) by Gagge's 2 node model,
	902	!> applying Fanger's convective heat transfer coefficient, hcf.
	903	!> Wind velocitiy of the reference environment is 0.10 m/s
	904	!------------------------------------------------------------------------------!
	905	SUBROUTINE dpmv_cold( pmva, tt2m, vau1m, tmrt, nerr, dpmv_cold_res )
	906
	907	IMPLICIT NONE
	908
	909	!-- Type of input arguments
	910	REAL(wp), INTENT ( IN ) :: pmva !< Fanger's classical predicted mean vote
[3464]	911	REAL(wp), INTENT ( IN ) :: tt2m !< Air temperature (ï¿œC) 2 m above ground
[3448]	912	REAL(wp), INTENT ( IN ) :: vau1m !< Relative wind velocity 1 m above ground (m/s)
[3464]	913	REAL(wp), INTENT ( IN ) :: tmrt !< Mean radiant temperature (ï¿œC)
[3448]	914
	915	!-- Type of output argument
	916	INTEGER(iwp), INTENT ( OUT ) :: nerr !< Error indicator: 0 = o.k., +1 = denominator for intersection = 0
	917	REAL(wp), INTENT ( OUT ) :: dpmv_cold_res !< Increment to adjust pmva according to the results of Gagge's
	918	! 2 node model depending on the input
	919
	920	!-- Type of program variables
	921	REAL(wp) :: delta_kalt(3)
	922	REAL(wp) :: pmv_cross(2)
	923	REAL(wp) :: reg_a(3)
	924	REAL(wp) :: coeff(3,5)
	925	REAL(wp) :: r_nenner
	926	REAL(wp) :: pmvc
	927	REAL(wp) :: dtmrt
	928	REAL(wp) :: SQRT_v1m
	929	INTEGER(iwp) :: i
	930	INTEGER(iwp) :: j
	931	INTEGER(iwp) :: i_bin
	932
	933	!-- Coefficient of the 3 regression lines
	934	! 1:const 2:pmvc 3:tt2m 4:SQRT_v1m 5:dtmrt
	935	coeff(1,1:5) = &
	936	(/ +0.161_wp, +0.130_wp, -1.125E-03_wp, +1.106E-03_wp, -4.570E-04_wp /)
	937	coeff(2,1:5) = &
	938	(/ 0.795_wp, 0.713_wp, -8.880E-03_wp, -1.803E-03_wp, -2.816E-03_wp/)
	939	coeff(3,1:5) = &
	940	(/ +0.05761_wp, +0.458_wp, -1.829E-02_wp, -5.577E-03_wp, -1.970E-03_wp /)
	941
	942	!-- Initialise
	943	nerr = 0_iwp
	944	dpmv_cold_res = 0._wp
	945	pmvc = pmva
	946	dtmrt = tmrt - tt2m
	947	SQRT_v1m = vau1m
	948	IF ( SQRT_v1m < 0.10_wp ) THEN
	949	SQRT_v1m = 0.10_wp
	950	ELSE
	951	SQRT_v1m = SQRT ( SQRT_v1m )
	952	ENDIF
	953
	954	DO i = 1, 3
	955	delta_kalt (i) = 0._wp
	956	IF ( i < 3 ) THEN
	957	pmv_cross (i) = pmvc
	958	ENDIF
	959	ENDDO
	960
	961	DO i = 1, 3
	962	!-- Regression constant for given meteorological variables
	963	reg_a(i) = coeff(i, 1) + coeff(i, 3) * tt2m + coeff(i, 4) * SQRT_v1m + &
	964	coeff(i,5)*dtmrt
	965	delta_kalt(i) = reg_a(i) + coeff(i, 2) * pmvc
	966	ENDDO
	967
	968	!-- Intersection points of regression lines in terms of Fanger's PMV
	969	DO i = 1, 2
	970	r_nenner = coeff (i, 2) - coeff (i + 1, 2)
	971	IF ( ABS ( r_nenner ) > 0.00001_wp ) THEN
	972	pmv_cross(i) = ( reg_a (i + 1) - reg_a (i) ) / r_nenner
	973	ELSE
	974	nerr = 1_iwp
	975	RETURN
	976	ENDIF
	977	ENDDO
	978
	979	i_bin = 3
	980	DO i = 1, 2
	981	IF ( pmva > pmv_cross (i) ) THEN
	982	i_bin = i
	983	EXIT
	984	ENDIF
	985	ENDDO
	986	!-- Adjust to operative temperature scaled according
	987	! to classical PMV (Fanger)
	988	dpmv_cold_res = delta_kalt(i_bin) - dpmv_adj(pmva)
	989
	990	END SUBROUTINE dpmv_cold
	991
	992	!------------------------------------------------------------------------------!
	993	! Description:
	994	! ------------
	995	!> Calculates the summand dpmv_adj adjusting to the operative temperature
	996	!> scaled according to classical PMV (Fanger)
	997	!> Reference environment: v_1m = 0.10 m/s, dTMRT = 0 K, r.h. = 50 %
	998	!------------------------------------------------------------------------------!
	999	REAL(wp) FUNCTION dpmv_adj( pmva )
	1000
	1001	IMPLICIT NONE
	1002
	1003	REAL(wp), INTENT ( IN ) :: pmva
	1004	INTEGER(iwp), PARAMETER :: n_bin = 3
	1005	INTEGER(iwp), PARAMETER :: n_ca = 0
	1006	INTEGER(iwp), PARAMETER :: n_ce = 3
	1007	REAL(wp), dimension (n_bin, n_ca:n_ce) :: coef
	1008
	1009	REAL(wp) :: pmv
	1010	INTEGER(iwp) :: i, i_bin
	1011
	1012	! range_1 range_2 range_3
	1013	DATA (coef(i, 0), i = 1, n_bin) /+0.0941540_wp, -0.1506620_wp, -0.0871439_wp/
	1014	DATA (coef(i, 1), i = 1, n_bin) /+0.0783162_wp, -1.0612651_wp, +0.1695040_wp/
	1015	DATA (coef(i, 2), i = 1, n_bin) /+0.1350144_wp, -1.0049144_wp, -0.0167627_wp/
	1016	DATA (coef(i, 3), i = 1, n_bin) /+0.1104037_wp, -0.2005277_wp, -0.0003230_wp/
	1017
	1018	IF ( pmva <= -2.1226_wp ) THEN
	1019	i_bin = 3_iwp
	1020	ELSE IF ( pmva <= -1.28_wp ) THEN
	1021	i_bin = 2_iwp
	1022	ELSE
	1023	i_bin = 1_iwp
	1024	ENDIF
	1025
	1026	dpmv_adj = coef( i_bin, n_ca )
	1027	pmv = 1._wp
	1028
	1029	DO i = n_ca + 1, n_ce
	1030	pmv = pmv * pmva
	1031	dpmv_adj = dpmv_adj + coef(i_bin, i) * pmv
	1032	ENDDO
	1033	RETURN
	1034	END FUNCTION dpmv_adj
	1035
	1036	!------------------------------------------------------------------------------!
	1037	! Description:
	1038	! ------------
	1039	!> Based on perceived temperature (gt) as input, ireq_neutral determines
	1040	!> the required clothing insulation (clo) for thermally neutral conditions
	1041	!> (neither body cooling nor body heating). It is related to the Klima-
	1042	!> Michel activity level (134.682 W/m2). IREQ_neutral is only defined
[3464]	1043	!> for gt < 10 (ï¿œC)
[3448]	1044	!------------------------------------------------------------------------------!
	1045	REAL(wp) FUNCTION ireq_neutral( gt, ireq_minimal, nerr )
	1046
	1047	IMPLICIT NONE
	1048
	1049	!-- Type declaration of arguments
	1050	REAL(wp), INTENT ( IN ) :: gt
	1051	REAL(wp), INTENT ( OUT ) :: ireq_minimal
	1052	INTEGER(iwp), INTENT ( OUT ) :: nerr
	1053
	1054	!-- Type declaration for internal varables
	1055	REAL(wp) :: top02
	1056
	1057	!-- Initialise
	1058	nerr = 0_iwp
	1059
	1060	!-- Convert perceived temperature from basis 0.1 m/s to basis 0.2 m/s
	1061	top02 = 1.8788_wp + 0.9296_wp * gt
	1062
	1063	!-- IREQ neutral conditions (thermal comfort)
	1064	ireq_neutral = 1.62_wp - 0.0564_wp * top02
	1065
[3464]	1066	!-- Regression only defined for gt <= 10 (ï¿œC)
[3448]	1067	IF ( ireq_neutral < 0.5_wp ) THEN
	1068	IF ( ireq_neutral < 0.48_wp ) THEN
	1069	nerr = 1_iwp
	1070	ENDIF
	1071	ireq_neutral = 0.5_wp
	1072	ENDIF
	1073
	1074	!-- Minimal required clothing insulation: maximal acceptable body cooling
	1075	ireq_minimal = 1.26_wp - 0.0588_wp * top02
	1076	IF ( nerr > 0_iwp ) THEN
	1077	ireq_minimal = ireq_neutral
	1078	ENDIF
	1079
	1080	RETURN
	1081	END FUNCTION ireq_neutral
	1082
	1083	END MODULE biometeorology_pt_mod

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |