source: palm/tags/release-6.0/SOURCE/biometeorology_ipt_mod.f90 @ 4095

Last change on this file since 4095 was 3448, checked in by kanani, 5 years ago

Implementation of human thermal indices (from branch biomet_p2 at r3444)

  • Property svn:executable set to *
File size: 21.0 KB
Line 
1!> @file biometeorology_ipt_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: 001
23! -----------------
24!
25!
26! Former revisions: 001
27! -----------------
28! $Id$
29! Initial revision 001
30!
31!
32!
33! Authors:
34! --------
35! @author Dominik Froehlich <dominik.froehlich@mailbox.org>
36!
37!
38! Description:
39! ------------
40!> Module for the calculation of the dynamic thermal index iPT
41!>
42!> @todo
43!>
44!> @note nothing now
45!>
46!> @bug  no known bugs by now
47!------------------------------------------------------------------------------!
48 MODULE biometeorology_ipt_mod
49!
50!-- Load required variables from existing modules
51    USE kinds  !< to set precision of INTEGER and REAL arrays according to PALM
52
53    USE biometeorology_pt_mod,                                                 &
54       ONLY: saturation_vapor_pressure, deltapmv, dpmv_adj, dpmv_cold,         &
55             calc_sultr, pt_regression, ireq_neutral, iso_ridder
56
57    IMPLICIT NONE
58
59    PRIVATE  !-- No private interfaces --!
60
61    PUBLIC ipt_cycle, ipt_init
62
63!-- PALM interfaces:
64    INTERFACE ipt_cycle
65       MODULE PROCEDURE ipt_cycle
66    END INTERFACE ipt_cycle
67
68    INTERFACE ipt_init
69       MODULE PROCEDURE ipt_init
70    END INTERFACE ipt_init
71
72
73 CONTAINS
74
75
76
77!------------------------------------------------------------------------------!
78! Description:
79! ------------
80!> The SUBROUTINE surface area calculates the surface area of the individual
81!> according to its height (m), weight (kg), and age (y)
82!------------------------------------------------------------------------------!
83 SUBROUTINE surface_area ( height_cm, weight, age, surf )
84
85    IMPLICIT NONE
86
87    REAL(wp)    , INTENT(in)  :: weight
88    REAL(wp)    , INTENT(in)  :: height_cm
89    INTEGER(iwp), INTENT(in)  :: age
90    REAL(wp)    , INTENT(out) :: surf
91    REAL(wp)                  :: height
92
93    height = height_cm * 100._wp
94
95!-- According to Gehan-George, for children
96    IF ( age < 19_iwp ) THEN
97       IF ( age < 5_iwp ) THEN
98          surf = 0.02667_wp * height**0.42246_wp * weight**0.51456_wp
99          RETURN
100       END IF
101       surf = 0.03050_wp * height**0.35129_wp * weight**0.54375_wp
102       RETURN
103    END IF
104
105!-- DuBois D, DuBois EF: A formula to estimate the approximate surface area if
106!   height and weight be known. In: Arch. Int. Med.. 17, 1916, S. 863?871.
107    surf = 0.007184_wp * height**0.725_wp * weight**0.425_wp
108    RETURN
109
110 END SUBROUTINE surface_area
111
112!------------------------------------------------------------------------------!
113! Description:
114! ------------
115!> The SUBROUTINE persdat calculates
116!>  - the total internal energy production = metabolic + workload,
117!>  - the total internal energy production for a standardized surface (actlev)
118!>  - the DuBois - area (a_surf [m2])
119!> from
120!>  - the persons age (years),
121!>  - weight (kg),
122!>  - height (m),
123!>  - sex (1 = male, 2 = female),
124!>  - work load (W)
125!> for a sample human.
126!------------------------------------------------------------------------------!
127 SUBROUTINE persdat ( age, weight, height, sex, work, a_surf, actlev )
128!
129    IMPLICIT NONE
130
131    REAL(wp), INTENT(in) ::  age
132    REAL(wp), INTENT(in) ::  weight
133    REAL(wp), INTENT(in) ::  height
134    REAL(wp), INTENT(in) ::  work
135    INTEGER(iwp), INTENT(in) ::  sex
136    REAL(wp), INTENT(out) ::  actlev
137    REAL(wp) ::  a_surf
138    REAL(wp) ::  energieumsatz
139    REAL(wp) ::  s
140    REAL(wp) ::  factor
141    REAL(wp) ::  heightundumsatz
142
143    CALL surface_area ( height, weight, INT( age ), a_surf )
144    s = height * 100._wp / ( weight ** ( 1._wp / 3._wp ) )
145    factor = 1._wp + .004_wp  * ( 30._wp - age )
146    heightundumsatz = 0.
147    IF ( sex == 1_iwp ) THEN
148       heightundumsatz = 3.45_wp * weight ** ( 3._wp / 4._wp ) * ( factor +    &
149                     .01_wp  * ( s - 43.4_wp ) )
150    ELSE IF ( sex == 2_iwp ) THEN
151       heightundumsatz = 3.19_wp * weight ** ( 3._wp / 4._wp ) * ( factor +    &
152                    .018_wp * ( s - 42.1_wp ) )
153    END IF
154
155    energieumsatz = work + heightundumsatz
156    actlev = energieumsatz / a_surf
157
158 END SUBROUTINE persdat
159
160
161!------------------------------------------------------------------------------!
162! Description:
163! ------------
164!> SUBROUTINE ipt_init
165!> initializes the instationary perceived temperature
166!------------------------------------------------------------------------------!
167
168 SUBROUTINE ipt_init (age, weight, height, sex, work, actlev, clo,             &
169     ta, vp, vau1m, tmrt, pb, dt, storage, t_clothing,                         &
170     ipt )
171
172    IMPLICIT NONE
173
174!-- Input parameters
175    REAL(wp), INTENT(in) ::  age        !< Persons age          (years)
176    REAL(wp), INTENT(in) ::  weight     !< Persons weight       (kg)
177    REAL(wp), INTENT(in) ::  height     !< Persons height       (m)
178    REAL(wp), INTENT(in) ::  work       !< Current workload     (W)
179    REAL(wp), INTENT(in) ::  ta         !< Air Temperature      (°C)
180    REAL(wp), INTENT(in) ::  vp         !< Vapor pressure       (hPa)
181    REAL(wp), INTENT(in) ::  vau1m      !< Wind speed in approx. 1.1m (m/s)
182    REAL(wp), INTENT(in) ::  tmrt       !< Mean radiant temperature   (°C)
183    REAL(wp), INTENT(in) ::  pb         !< Air pressure         (hPa)
184    REAL(wp), INTENT(in) ::  dt         !< Timestep             (s)
185    INTEGER(iwp), INTENT(in)  :: sex    !< Persons sex (1 = male, 2 = female)
186
187!-- Output parameters
188    REAL(wp), INTENT(out) ::  actlev
189    REAL(wp), INTENT(out) ::  clo
190    REAL(wp), INTENT(out) ::  storage
191    REAL(wp), INTENT(out) ::  t_clothing
192    REAL(wp), INTENT(out) ::  ipt
193
194!-- Internal variables
195    REAL(wp), PARAMETER :: eps = 0.0005_wp
196    REAL(wp), PARAMETER :: eta = 0._wp
197    REAL(wp) ::  uclo
198    REAL(wp) ::  oclo
199    REAL(wp) ::  d_pmv
200    REAL(wp) ::  svp_tt
201    REAL(wp) ::  sult_lim
202    REAL(wp) ::  dgtcm
203    REAL(wp) ::  dgtcstd
204    REAL(wp) ::  clon
205    REAL(wp) ::  ireq_minimal
206    REAL(wp) ::  clo_fanger
207    REAL(wp) ::  pmv_o
208    REAL(wp) ::  pmv_u
209    REAL(wp) ::  pmva
210    REAL(wp) ::  ptc
211    REAL(wp) ::  d_std
212    REAL(wp) ::  pmvs
213    REAL(wp) ::  top
214    REAL(wp) ::  a_surf
215    REAL(wp) ::  acti
216    INTEGER(iwp) ::  nzaehl
217    INTEGER(iwp) ::  nerr_kalt
218    INTEGER(iwp) ::  nerr
219
220    LOGICAL ::  sultrieness
221
222    storage = 0._wp
223    CALL persdat ( age, weight, height, sex, work, a_surf, actlev )
224
225!-- Initialise
226    t_clothing = -999.0_wp
227    ipt        = -999.0_wp
228    nerr       = 0_wp
229    nzaehl     = 0_wp
230    sultrieness    = .FALSE.
231!-- Tresholds: clothing insulation (account for model inaccuracies)
232!-- Summer clothing
233    uclo     = 0.44453_wp
234!-- Winter clothing
235    oclo     = 1.76267_wp
236
237!-- Decision: firstly calculate for winter or summer clothing
238    IF ( ta <= 10._wp ) THEN
239
240!--    First guess: winter clothing insulation: cold stress
241       clo = oclo
242       t_clothing = -999.0_wp  ! force initial run
243       CALL fanger_s_acti ( ta, tmrt, vp, vau1m, pb, clo, actlev, work,        &
244          t_clothing, storage, dt, pmva )
245       pmv_o = pmva
246
247       IF ( pmva > 0._wp ) THEN
248
249!--       Case summer clothing insulation: heat load ?           
250          clo = uclo
251          t_clothing = -999.0_wp  ! force initial run
252          CALL fanger_s_acti ( ta, tmrt, vp, vau1m, pb, clo, actlev, work,     &
253             t_clothing, storage, dt, pmva )
254          pmv_u = pmva
255          IF ( pmva <= 0._wp ) THEN
256!--          Case: comfort achievable by varying clothing insulation
257!            between winter and summer set values
258             CALL iso_ridder ( ta, tmrt, vp, vau1m, pb, actlev, eta , uclo,    &
259                            pmv_u, oclo, pmv_o, eps, pmva, top, nzaehl, clo )
260             IF ( nzaehl < 0_iwp ) THEN
261                nerr = -1_iwp
262                RETURN
263             ENDIF
264          ELSE IF ( pmva > 0.06_wp ) THEN
265             clo = 0.5_wp
266             t_clothing = -999.0_wp
267             CALL fanger_s_acti ( ta, tmrt, vp, vau1m, pb, clo, actlev, work,  &
268                t_clothing, storage, dt, pmva )
269          ENDIF
270       ELSE IF ( pmva < -0.11_wp ) THEN
271          clo = 1.75_wp
272          t_clothing = -999.0_wp
273          CALL fanger_s_acti ( ta, tmrt, vp, vau1m, pb, clo, actlev, work,     &
274             t_clothing, storage, dt, pmva )
275       ENDIF
276
277    ELSE
278
279!--    First guess: summer clothing insulation: heat load
280       clo = uclo
281       t_clothing = -999.0_wp
282       CALL fanger_s_acti ( ta, tmrt, vp, vau1m, pb, clo, actlev, work,        &
283          t_clothing, storage, dt, pmva )
284       pmv_u = pmva
285
286       IF ( pmva < 0._wp ) THEN
287
288!--       Case winter clothing insulation: cold stress ?
289          clo = oclo
290          t_clothing = -999.0_wp
291          CALL fanger_s_acti ( ta, tmrt, vp, vau1m, pb, clo, actlev, work,     &
292             t_clothing, storage, dt, pmva )
293          pmv_o = pmva
294
295          IF ( pmva >= 0._wp ) THEN
296
297!--          Case: comfort achievable by varying clothing insulation
298!            between winter and summer set values
299             CALL iso_ridder ( ta, tmrt, vp, vau1m, pb, actlev, eta, uclo,     &
300                               pmv_u, oclo, pmv_o, eps, pmva, top, nzaehl, clo )
301             IF ( nzaehl < 0_wp ) THEN
302                nerr = -1_iwp
303                RETURN
304             ENDIF
305          ELSE IF ( pmva < -0.11_wp ) THEN
306             clo = 1.75_wp
307             t_clothing = -999.0_wp
308             CALL fanger_s_acti ( ta, tmrt, vp, vau1m, pb, clo, actlev, work,  &
309                t_clothing, storage, dt, pmva )
310          ENDIF
311       ELSE IF ( pmva > 0.06_wp ) THEN
312          clo = 0.5_wp
313          t_clothing = -999.0_wp
314          CALL fanger_s_acti ( ta, tmrt, vp, vau1m, pb, clo, actlev, work,     &
315             t_clothing, storage, dt, pmva )
316       ENDIF
317
318    ENDIF
319
320!-- Determine perceived temperature by regression equation + adjustments
321    pmvs = pmva
322    CALL pt_regression ( pmva, clo, ipt )
323    ptc = ipt
324    IF ( clo >= 1.75_wp .AND. pmva <= -0.11_wp ) THEN
325!--    Adjust for cold conditions according to Gagge 1986
326       CALL dpmv_cold ( pmva, ta, vau1m, tmrt, nerr_kalt, d_pmv )
327       IF ( nerr_kalt > 0_iwp ) nerr = -5_iwp
328       pmvs = pmva - d_pmv
329       IF ( pmvs > -0.11_wp ) THEN
330          d_pmv  = 0._wp
331          pmvs   = -0.11_wp
332       ENDIF
333       CALL pt_regression ( pmvs, clo, ipt )
334    ENDIF
335    clo_fanger = clo
336    clon = clo
337    IF ( clo > 0.5_wp .AND. ipt <= 8.73_wp ) THEN
338!--    Required clothing insulation (ireq) is exclusively defined for
339!      operative temperatures (top) less 10 (C) for a
340!      reference wind of 0.2 m/s according to 8.73 (C) for 0.1 m/s
341       clon = ireq_neutral ( ipt, ireq_minimal, nerr )
342       clo = clon
343    ENDIF
344    CALL calc_sultr ( ptc, dgtcm, dgtcstd, sult_lim )
345    sultrieness    = .FALSE.
346    d_std      = -99._wp
347    IF ( pmva > 0.06_wp .AND. clo <= 0.5_wp ) THEN
348!--    Adjust for warm/humid conditions according to Gagge 1986
349       CALL saturation_vapor_pressure ( ta, svp_tt )
350       d_pmv  = deltapmv ( pmva, ta, vp, svp_tt, tmrt, vau1m, nerr )
351       pmvs   = pmva + d_pmv
352       CALL pt_regression ( pmvs, clo, ipt )
353       IF ( sult_lim < 99._wp ) THEN
354          IF ( (ipt - ptc) > sult_lim ) sultrieness = .TRUE.
355       ENDIF
356    ENDIF
357
358 
359 END SUBROUTINE ipt_init
360 
361!------------------------------------------------------------------------------!
362! Description:
363! ------------
364!> SUBROUTINE ipt_cycle
365!> Calculates one timestep for the instationary version of perceived
366!> temperature (iPT, °C) for
367!>  - standard measured/predicted meteorological values and TMRT
368!>    as input;
369!>  - regressions for determination of PT;
370!>  - adjustment to Gagge's PMV* (2-node-model, 1986) as base of PT
371!>    under warm/humid conditions (Icl= 0.50 clo) and under cold
372!>    conditions (Icl= 1.75 clo)
373!>
374!------------------------------------------------------------------------------!
375 SUBROUTINE ipt_cycle( ta, vp, vau1m, tmrt, pb, dt, storage, t_clothing, clo,  &
376     actlev, work, ipt )
377
378    IMPLICIT NONE
379
380!-- Type of input of the argument list
381    REAL(wp), INTENT ( IN )  ::  ta      !< Air temperature             (°C)
382    REAL(wp), INTENT ( IN )  ::  vp      !< Vapor pressure              (hPa)
383    REAL(wp), INTENT ( IN )  ::  tmrt    !< Mean radiant temperature    (°C)
384    REAL(wp), INTENT ( IN )  ::  vau1m   !< Wind speed                  (m/s)
385    REAL(wp), INTENT ( IN )  ::  pb      !< Air pressure                (hPa)
386    REAL(wp), INTENT ( IN )  ::  dt      !< Timestep                    (s)
387    REAL(wp), INTENT ( IN )  ::  clo     !< Clothing index              (no dim)
388    REAL(wp), INTENT ( IN )  ::  actlev  !< Internal heat production    (W)
389    REAL(wp), INTENT ( IN )  ::  work    !< Mechanical work load        (W)
390
391!-- In and output parameters
392    REAL(wp), INTENT (INOUT) ::  storage     !< Heat storage            (W)
393    REAL(wp), INTENT (INOUT) ::  t_clothing  !< Clothig temperature     (°C)
394
395!-- Type of output of the argument list
396    REAL(wp), INTENT ( OUT ) ::  ipt  !< Instationary perceived temperature (°C)
397
398!-- Type of program variables
399    REAL(wp), PARAMETER ::  eps = 0.0005_wp
400    REAL(wp) ::  d_pmv
401    REAL(wp) ::  pmv_o
402    REAL(wp) ::  pmv_s
403    REAL(wp) ::  storage_rate
404    REAL(wp) ::  ener_in
405    REAL(wp) ::  svp_tt
406    REAL(wp) ::  sult_lim
407    REAL(wp) ::  dgtcm
408    REAL(wp) ::  dgtcstd
409    REAL(wp) ::  clon
410    REAL(wp) ::  ireq_minimal
411    REAL(wp) ::  clo_fanger
412    REAL(wp) ::  pmv_u
413    REAL(wp) ::  half_hour_frac
414    REAL(wp) ::  storage_delta
415    REAL(wp) ::  storage_delta_max
416    REAL(wp) ::  pmva
417    REAL(wp) ::  ptc
418    REAL(wp) ::  d_std
419    REAL(wp) ::  pmvs
420    REAL(wp) ::  top
421    INTEGER(iwp) ::  nzaehl
422    INTEGER(iwp) ::  nerr_kalt
423    INTEGER(iwp) ::  nerr
424
425    LOGICAL ::  sultrieness
426
427!-- Initialise
428    ipt = -999.0_wp
429
430    nerr     = 0_iwp
431    nzaehl   = 0_iwp
432    sultrieness  = .FALSE.
433
434!-- Determine pmv_adjusted for current conditions
435    CALL fanger_s_acti ( ta, tmrt, vp, vau1m, pb, clo, actlev, work,           &
436       t_clothing, storage, dt, pmva )
437    pmv_s = pmva  !< PMV considering storage
438
439!-- Determine perceived temperature by regression equation + adjustments
440    CALL pt_regression ( pmva, clo, ipt )
441
442    IF ( clo >= 1.75_wp .AND. pmva <= -0.11_wp ) THEN
443!--    Adjust for cold conditions according to Gagge 1986
444       CALL dpmv_cold ( pmva, ta, vau1m, tmrt, nerr_kalt, d_pmv )
445       IF ( nerr_kalt > 0_iwp ) nerr = -5_iwp
446       pmvs = pmva - d_pmv
447       IF ( pmvs > -0.11_wp ) THEN
448          d_pmv  = 0._wp
449          pmvs   = -0.11_wp
450       ENDIF
451       CALL pt_regression ( pmvs, clo, ipt )
452    ENDIF
453
454!-- Consider sultriness if appropriate
455    ptc = ipt
456    CALL calc_sultr ( ptc, dgtcm, dgtcstd, sult_lim )
457    sultrieness    = .FALSE.
458    d_std      = -99._wp
459    IF ( pmva > 0.06_wp .AND. clo <= 0.5_wp ) THEN
460!--    Adjust for warm/humid conditions according to Gagge 1986
461       CALL saturation_vapor_pressure ( ta, svp_tt )
462       d_pmv  = deltapmv ( pmva, ta, vp, svp_tt, tmrt, vau1m, nerr )
463       pmvs   = pmva + d_pmv
464       CALL pt_regression ( pmvs, clo, ipt )
465       IF ( sult_lim < 99._wp ) THEN
466          IF ( (ipt - ptc) > sult_lim ) sultrieness = .TRUE.
467       ENDIF
468    ENDIF
469
470 END SUBROUTINE ipt_cycle
471
472!------------------------------------------------------------------------------!
473! Description:
474! ------------
475!> SUBROUTINE fanger_s calculates the
476!> actual Predicted Mean Vote (dimensionless) according
477!> to Fanger corresponding to meteorological (tt,tmrt,pa,vau,pb)
478!> and individual variables (clo, actlev, eta) considering a storage
479!> and clothing temperature for a given timestep.
480!------------------------------------------------------------------------------!
481 SUBROUTINE fanger_s_acti( tt, tmrt, pa, in_vau, pb, in_clo, actlev,           &
482    activity, t_cloth, s, dt, pmva )
483
484    IMPLICIT NONE
485
486!--  Input argument types
487    REAL(wp), INTENT ( IN )  ::  tt       !< Air temperature          (°C)
488    REAL(wp), INTENT ( IN )  ::  tmrt     !< Mean radiant temperature (°C)
489    REAL(wp), INTENT ( IN )  ::  pa       !< Vapour pressure          (hPa)
490    REAL(wp), INTENT ( IN )  ::  pb       !< Air pressure             (hPa)
491    REAL(wp), INTENT ( IN )  ::  in_vau   !< Wind speed               (m/s)
492    REAL(wp), INTENT ( IN )  ::  actlev   !< Metabolic + work energy  (W/m²)
493    REAL(wp), INTENT ( IN )  ::  dt       !< Timestep                 (s)
494    REAL(wp), INTENT ( IN )  ::  activity !< Work load                (W/m²)
495    REAL(wp), INTENT ( IN )  ::  in_clo   !< Clothing index (clo)     (no dim)
496
497!-- Output argument types
498    REAL(wp), INTENT ( OUT ) ::  pmva  !< actual Predicted Mean Vote (no dim)
499
500    REAL(wp), INTENT (INOUT) ::  s  !< storage var. of energy balance (W/m2)
501    REAL(wp), INTENT (INOUT) ::  t_cloth  !< clothing temperature (°C)
502
503!-- Internal variables
504    REAL(wp) ::  f_cl
505    REAL(wp) ::  heat_convection
506    REAL(wp) ::  t_skin_aver
507    REAL(wp) ::  bc
508    REAL(wp) ::  cc
509    REAL(wp) ::  dc
510    REAL(wp) ::  ec
511    REAL(wp) ::  gc
512    REAL(wp) ::  hr
513    REAL(wp) ::  clo
514    REAL(wp) ::  vau
515    REAL(wp) ::  z1
516    REAL(wp) ::  z2
517    REAL(wp) ::  z3
518    REAL(wp) ::  z4
519    REAL(wp) ::  z5
520    REAL(wp) ::  z6
521    REAL(wp) ::  en
522    REAL(wp) ::  d_s
523    REAL(wp) ::  t_clothing   !< Clothing index value   (dimensionless)
524    REAL(wp) ::  adjustrate
525    REAL(wp) ::  adjustrate_cloth
526    REAL(wp), PARAMETER  ::  time_equil = 7200._wp
527    INTEGER(iwp) ::  i
528    INTEGER(iwp) ::  niter  !< Running index
529
530
531!-- Clo must be > 0. to avoid div. by 0!
532    clo = in_clo
533    IF ( clo < 001._wp ) clo = .001_wp
534
535!-- Increase in surface due to clothing
536    f_cl = 1._wp + .15_wp * clo
537
538!-- Case of free convection (vau < 0.1 m/s ) not considered
539    vau = in_vau
540    IF ( vau < .1_wp ) THEN
541       vau = .1_wp
542    ENDIF
543
544!-- Heat_convection = forced convection
545    heat_convection = 12.1_wp * SQRT ( vau * pb / 1013.25_wp )
546
547!-- Average skin temperature
548    t_skin_aver = 35.7_wp - .0275_wp * activity
549
550!-- Calculation of constants for evaluation below
551    bc = .155_wp * clo * 3.96_wp * 10._wp**( -8._wp ) * f_cl
552    cc = f_cl * heat_convection
553    ec = .155_wp * clo
554    dc = ( 1._wp + ec * cc ) / bc
555    gc = ( t_skin_aver + bc * ( tmrt + 273.2_wp )**4._wp + ec * cc * tt ) / bc
556
557!-- Calculation of clothing surface temperature (t_clothing) based on
558!   newton-approximation with air temperature as initial guess
559    niter = dt
560    adjustrate = 1._wp - EXP ( -1._wp * ( 10._wp / time_equil ) * dt )
561    IF ( adjustrate >= 1._wp ) adjustrate = 1._wp
562    adjustrate_cloth = adjustrate * 30._wp
563    t_clothing = t_cloth
564
565    IF ( t_cloth <= -998.0_wp ) THEN  ! If initial run
566       niter = 3_wp
567       adjustrate = 1._wp
568       adjustrate_cloth = 1._wp
569       t_clothing = tt
570    ENDIF
571
572    DO i = 1, niter
573       t_clothing = t_clothing - adjustrate_cloth * ( ( t_clothing +           &
574          273.2_wp )**4._wp + t_clothing *                                     &
575          dc - gc ) / ( 4._wp * ( t_clothing + 273.2_wp )**3._wp + dc )
576    ENDDO
577
578!-- Empiric factor for the adaption of the heat ballance equation
579!   to the psycho-physical scale (Equ. 40 in FANGER)
580    z1 = ( .303_wp * EXP ( -.036_wp * actlev ) + .0275_wp )
581
582!-- Water vapour diffution through the skin
583    z2 = .31_wp * ( 57.3_wp - .07_wp * activity-pa )
584
585!-- Sweat evaporation from the skin surface
586    z3 = .42_wp * ( activity - 58._wp )
587
588!-- Loss of latent heat through respiration
589    z4 = .0017_wp * actlev * ( 58.7_wp - pa ) + .0014_wp * actlev *            &
590      ( 34._wp - tt )
591
592!-- Loss of radiational heat
593    z5 = 3.96e-8_wp * f_cl * ( ( t_clothing + 273.2_wp )**4 - ( tmrt +         &
594       273.2_wp )**4 )
595
596!-- Heat loss through forced convection
597    z6 = cc * ( t_clothing - tt )
598
599!-- Write together as energy ballance
600    en = activity - z2 - z3 - z4 - z5 - z6
601
602!-- Manage storage
603    d_s = adjustrate * en + ( 1._wp - adjustrate ) * s
604
605!-- Predicted Mean Vote
606    pmva = z1 * d_s
607
608!-- Update storage
609    s = d_s
610    t_cloth = t_clothing
611
612 END SUBROUTINE fanger_s_acti
613
614
615 END MODULE biometeorology_ipt_mod
Note: See TracBrowser for help on using the repository browser.