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

Last change on this file since 3464 was 3464, checked in by kanani, 3 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
Line 
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!
22! Current revisions:
23! ------------------
24!
25!
26! Former revisions:
27! -----------------
28! $Id$
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
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! ------------
123!> PT_BASIC.F90   Version of perceived temperature (PT, ï¿œC) for
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
138    REAL(wp), INTENT ( IN )  :: tt2m   !< Local air temperature (ï¿œC)
139    REAL(wp), INTENT ( IN )  :: el2m   !< Local vapour pressure (hPa)
140    REAL(wp), INTENT ( IN )  :: tmrt   !< Local mean radiant temperature (ï¿œC)
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
145    REAL(wp), INTENT ( OUT ) :: pt_basic  !< Perceived temperature (ï¿œC)
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
308!> (hPa = hecto Pascal) for a given temperature tt (ï¿œC).
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
315    REAL(wp), INTENT ( IN )  ::  tt   !< ambient air temperature (ï¿œC)
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
323!--    tt  < 0 (ï¿œC): saturation water vapour pressure over ice
324       b = 17.84362_wp
325       c = 245.425_wp
326    ELSE
327!--    tt >= 0 (ï¿œC): saturation water vapour pressure over water
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:
353    REAL(wp), INTENT ( IN )  :: tt2m     !< Ambient temperature (ï¿œC)
354    REAL(wp), INTENT ( IN )  :: tmrt     !< Mean radiant temperature (ï¿œC)
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)
369    REAL(wp), INTENT ( OUT ) :: top      !< Operative temperature (ï¿œC) at found root of Fanger's PMV
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)
495    REAL(wp), INTENT ( OUT ) ::  pt   !< pt (ï¿œC) corresponding to given PMV / clo
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:
524    REAL(wp), INTENT ( IN ) ::  tt       !< Ambient air temperature (ï¿œC)
525    REAL(wp), INTENT ( IN ) ::  tmrt     !< Mean radiant temperature (ï¿œC)
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)
537    REAL(wp), INTENT ( OUT ) ::  top      !< operative temperature (ï¿œC)
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
645    REAL(wp),     INTENT ( IN )  :: tt2m     !< Ambient temperature (ï¿œC) at screen level
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
648    REAL(wp),     INTENT ( IN )  :: tmrt     !< Mean radiant temperature (ï¿œC) at screen level
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
731!--       Due to conditions of regressï¿œon: r.H. >= 5 %
732          pa = p10
733       ELSE
734!--       Due to conditions of regressï¿œon: r.H. <= 95 %
735          pa = p95
736       ENDIF
737    ENDIF
738    IF ( pa > 0._wp ) THEN
739!--    Natural logarithm of pa
740       apa = LOG ( pa )
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
748       dapa   = apa - LOG ( pa_p50 )
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
772    gew = MOD ( pmv, 1._wp )
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
841!>                                       gtc > 16.826 (ï¿œC)
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
911    REAL(wp), INTENT ( IN ) :: tt2m      !< Air temperature (ï¿œC) 2 m above ground
912    REAL(wp), INTENT ( IN ) :: vau1m     !< Relative wind velocity 1 m above ground (m/s)
913    REAL(wp), INTENT ( IN ) :: tmrt      !< Mean radiant temperature (ï¿œC)
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
1043!> for gt < 10 (ï¿œC)
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
1066!-- Regression only defined for gt <= 10 (ï¿œC)
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.