Changeset 3693 for palm/trunk/SOURCE/biometeorology_mod.f90
- Timestamp:
- Jan 23, 2019 3:20:53 PM (5 years ago)
- File:
-
- 1 edited
-
palm/trunk/SOURCE/biometeorology_mod.f90 (modified) (75 diffs)
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/SOURCE/biometeorology_mod.f90
r3685 r3693 27 27 ! ----------------- 28 28 ! $Id$ 29 ! Added usage of time_averaged mean radiant temperature, together with calculation, 30 ! grid and restart routines. General cleanup and commenting. 31 ! 32 ! 3685 2019-01-21 01:02:11Z knoop 29 33 ! Some interface calls moved to module_interface + cleanup 30 34 ! … … 113 117 surface_pressure 114 118 115 USE date_and_time_mod, 119 USE date_and_time_mod, & 116 120 ONLY: calc_date_and_time, day_of_year, time_utc 117 121 … … 125 129 USE kinds !< Set precision of INTEGER and REAL arrays according to PALM 126 130 127 USE netcdf_data_input_mod, 128 ONLY: netcdf_data_input_uvem, uvem_projarea_f, uvem_radiance_f, 131 USE netcdf_data_input_mod, & 132 ONLY: netcdf_data_input_uvem, uvem_projarea_f, uvem_radiance_f, & 129 133 uvem_irradiance_f, uvem_integration_f, building_obstruction_f 130 134 ! … … 152 156 !-- Grids for averaged thermal indices 153 157 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrt_av_grid !< time average mean 158 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tmrt_av_grid !< tmrt results (degree_C) 154 159 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: perct_av !< PT results (aver. input) (degree_C) 155 160 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: utci_av !< UTCI results (aver. input) (degree_C) … … 165 170 ! 166 171 !-- 167 LOGICAL :: aver_perct = .FALSE. !< switch: do perct averaging in this module? (if .FALSE. this is done globally) 168 LOGICAL :: aver_q = .FALSE. !< switch: do e averaging in this module? 169 LOGICAL :: aver_u = .FALSE. !< switch: do u averaging in this module? 170 LOGICAL :: aver_v = .FALSE. !< switch: do v averaging in this module? 171 LOGICAL :: aver_w = .FALSE. !< switch: do w averaging in this module? 172 LOGICAL :: do_average_theta = .FALSE. !< switch: do theta averaging in this module? (if .FALSE. this is done globally) 173 LOGICAL :: do_average_q = .FALSE. !< switch: do e averaging in this module? 174 LOGICAL :: do_average_u = .FALSE. !< switch: do u averaging in this module? 175 LOGICAL :: do_average_v = .FALSE. !< switch: do v averaging in this module? 176 LOGICAL :: do_average_w = .FALSE. !< switch: do w averaging in this module? 177 LOGICAL :: do_average_mrt = .FALSE. !< switch: do mrt averaging in this module? 172 178 LOGICAL :: average_trigger_perct = .FALSE. !< update averaged input on call to bio_perct? 173 179 LOGICAL :: average_trigger_utci = .FALSE. !< update averaged input on call to bio_utci? 174 180 LOGICAL :: average_trigger_pet = .FALSE. !< update averaged input on call to bio_pet? 175 181 176 LOGICAL :: thermal_comfort = . TRUE. !< Turn all thermal indices on or off182 LOGICAL :: thermal_comfort = .FALSE. !< Turn all thermal indices on or off 177 183 LOGICAL :: bio_perct = .TRUE. !< Turn index PT (instant. input) on or off 178 184 LOGICAL :: bio_perct_av = .TRUE. !< Turn index PT (averaged input) on or off … … 378 384 ! 379 385 !-- Averaging, as well as the allocation of the required grids must be 380 ! 381 ! 382 ! 383 ! 384 ! Indices are in unknown order as depending on the input file,385 ! 386 !-- done only once, independent from for how many thermal indices 387 !-- averaged output is desired. 388 !-- Therefore wee need to memorize which index is the one that controls 389 !-- the averaging (what must be the first thermal index called). 390 !-- Indices are in unknown order as depending on the input file, 391 !-- determine first index to average und update only once 386 392 387 393 !-- Only proceed here if this was not done for any index before. This 388 ! 394 !-- is done only once during the whole model run. 389 395 IF ( .NOT. average_trigger_perct .AND. & 390 396 .NOT. average_trigger_utci .AND. & … … 413 419 IF ( .NOT. ALLOCATED( pt_av ) ) THEN 414 420 ALLOCATE( pt_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 415 aver_perct= .TRUE.421 do_average_theta = .TRUE. 416 422 pt_av = 0.0_wp 417 423 ENDIF … … 419 425 IF ( .NOT. ALLOCATED( q_av ) ) THEN 420 426 ALLOCATE( q_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 421 aver_q = .TRUE.427 do_average_q = .TRUE. 422 428 q_av = 0.0_wp 423 429 ENDIF … … 425 431 IF ( .NOT. ALLOCATED( u_av ) ) THEN 426 432 ALLOCATE( u_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 427 aver_u = .TRUE.433 do_average_u = .TRUE. 428 434 u_av = 0.0_wp 429 435 ENDIF … … 431 437 IF ( .NOT. ALLOCATED( v_av ) ) THEN 432 438 ALLOCATE( v_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 433 aver_v = .TRUE.439 do_average_v = .TRUE. 434 440 v_av = 0.0_wp 435 441 ENDIF … … 437 443 IF ( .NOT. ALLOCATED( w_av ) ) THEN 438 444 ALLOCATE( w_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 439 aver_w = .TRUE.445 do_average_w = .TRUE. 440 446 w_av = 0.0_wp 447 ENDIF 448 449 IF ( .NOT. ALLOCATED( mrt_av_grid ) ) THEN 450 ALLOCATE( mrt_av_grid(nmrtbl) ) 451 do_average_mrt = .TRUE. 452 mrt_av_grid = 0.0_wp 441 453 ENDIF 442 454 … … 480 492 RETURN 481 493 482 IF ( ALLOCATED( pt_av ) .AND. aver_perct) THEN494 IF ( ALLOCATED( pt_av ) .AND. do_average_theta ) THEN 483 495 DO i = nxl, nxr 484 496 DO j = nys, nyn … … 490 502 ENDIF 491 503 492 IF ( ALLOCATED( q_av ) .AND. aver_q ) THEN504 IF ( ALLOCATED( q_av ) .AND. do_average_q ) THEN 493 505 DO i = nxl, nxr 494 506 DO j = nys, nyn … … 500 512 ENDIF 501 513 502 IF ( ALLOCATED( u_av ) .AND. aver_u ) THEN514 IF ( ALLOCATED( u_av ) .AND. do_average_u ) THEN 503 515 DO i = nxlg, nxrg !< yes, ghost points are required here! 504 516 DO j = nysg, nyng … … 510 522 ENDIF 511 523 512 IF ( ALLOCATED( v_av ) .AND. aver_v ) THEN524 IF ( ALLOCATED( v_av ) .AND. do_average_v ) THEN 513 525 DO i = nxlg, nxrg !< yes, ghost points are required here! 514 526 DO j = nysg, nyng … … 520 532 ENDIF 521 533 522 IF ( ALLOCATED( w_av ) .AND. aver_w ) THEN534 IF ( ALLOCATED( w_av ) .AND. do_average_w ) THEN 523 535 DO i = nxlg, nxrg !< yes, ghost points are required here! 524 536 DO j = nysg, nyng … … 528 540 ENDDO 529 541 ENDDO 542 ENDIF 543 544 IF ( ALLOCATED( mrt_av_grid ) .AND. do_average_mrt ) THEN 545 546 IF ( mrt_include_sw ) THEN 547 mrt_av_grid(:) = mrt_av_grid(:) + & 548 (( human_absorb * mrtinsw(:) + human_emiss * mrtinlw(:)) & 549 / (human_emiss * sigma_sb)) ** .25_wp - degc_to_k 550 ELSE 551 mrt_av_grid(:) = mrt_av_grid(:) + & 552 (human_emiss * mrtinlw(:) / sigma_sb) ** .25_wp & 553 - degc_to_k 554 ENDIF 530 555 ENDIF 531 556 ! … … 564 589 TRIM( variable ) /= 'bio_pet*' ) RETURN 565 590 566 IF ( ALLOCATED( pt_av ) .AND. aver_perct) THEN591 IF ( ALLOCATED( pt_av ) .AND. do_average_theta ) THEN 567 592 DO i = nxl, nxr 568 593 DO j = nys, nyn … … 575 600 ENDIF 576 601 577 IF ( ALLOCATED( q_av ) .AND. aver_q ) THEN602 IF ( ALLOCATED( q_av ) .AND. do_average_q ) THEN 578 603 DO i = nxl, nxr 579 604 DO j = nys, nyn … … 586 611 ENDIF 587 612 588 IF ( ALLOCATED( u_av ) .AND. aver_u ) THEN613 IF ( ALLOCATED( u_av ) .AND. do_average_u ) THEN 589 614 DO i = nxlg, nxrg !< yes, ghost points are required here! 590 615 DO j = nysg, nyng … … 597 622 ENDIF 598 623 599 IF ( ALLOCATED( v_av ) .AND. aver_v ) THEN624 IF ( ALLOCATED( v_av ) .AND. do_average_v ) THEN 600 625 DO i = nxlg, nxrg 601 626 DO j = nysg, nyng … … 608 633 ENDIF 609 634 610 IF ( ALLOCATED( w_av ) .AND. aver_w ) THEN635 IF ( ALLOCATED( w_av ) .AND. do_average_w ) THEN 611 636 DO i = nxlg, nxrg 612 637 DO j = nysg, nyng … … 618 643 ENDDO 619 644 ENDIF 645 646 IF ( ALLOCATED( mrt_av_grid ) .AND. do_average_mrt ) THEN 647 mrt_av_grid(:) = mrt_av_grid(:) / REAL( average_count_3d, KIND=wp ) 648 ENDIF 649 620 650 ! 621 651 !-- Udate all thermal index grids with updated averaged input … … 793 823 794 824 !------------------------------------------------------------------------------! 795 !796 825 ! Description: 797 826 ! ------------ … … 817 846 CHARACTER (LEN=*), INTENT(OUT) :: grid !< Grid type (always "zu1" for biom) 818 847 LOGICAL, INTENT(OUT) :: found !< Output found? 819 LOGICAL, INTENT(OUT) :: two_d !< Flag parameter that indicates 2D variables, horizontal cross sections, must be .TRUE. 848 LOGICAL, INTENT(OUT) :: two_d !< Flag parameter that indicates 2D variables, 849 !< horizontal cross sections, must be .TRUE. for thermal indices and uv 820 850 REAL(wp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) :: local_pf !< Temp. result grid to return 821 851 ! … … 911 941 END IF 912 942 913 943 ! 914 944 !-- Before data is transfered to local_pf, transfer is it 2D dummy variable and exchange ghost points therein. 915 945 !-- However, at this point this is only required for instantaneous arrays, time-averaged quantities are already exchanged. … … 950 980 951 981 !------------------------------------------------------------------------------! 952 !953 982 ! Description: 954 983 ! ------------ … … 1211 1240 ! Description: 1212 1241 ! ------------ 1242 !> Soubroutine reads global biometeorology configuration from restart file(s) 1243 !------------------------------------------------------------------------------! 1244 SUBROUTINE bio_rrd_global( found ) 1245 1246 USE control_parameters, & 1247 ONLY: length, restart_string 1248 1249 1250 IMPLICIT NONE 1251 1252 LOGICAL, INTENT(OUT) :: found !< variable found? yes = .T., no = .F. 1253 1254 found = .TRUE. 1255 1256 1257 SELECT CASE ( restart_string(1:length) ) 1258 1259 ! 1260 !-- read control flags to determine if input grids need to be averaged 1261 CASE ( 'do_average_theta' ) 1262 READ ( 13 ) do_average_theta 1263 1264 CASE ( 'do_average_q' ) 1265 READ ( 13 ) do_average_q 1266 1267 CASE ( 'do_average_u' ) 1268 READ ( 13 ) do_average_u 1269 1270 CASE ( 'do_average_v' ) 1271 READ ( 13 ) do_average_v 1272 1273 CASE ( 'do_average_w' ) 1274 READ ( 13 ) do_average_w 1275 1276 CASE ( 'do_average_mrt' ) 1277 READ ( 13 ) do_average_mrt 1278 1279 ! 1280 !-- read control flags to determine which thermal index needs to trigger averaging 1281 CASE ( 'average_trigger_perct' ) 1282 READ ( 13 ) average_trigger_perct 1283 1284 CASE ( 'average_trigger_utci' ) 1285 READ ( 13 ) average_trigger_utci 1286 1287 CASE ( 'average_trigger_pet' ) 1288 READ ( 13 ) average_trigger_pet 1289 1290 1291 CASE DEFAULT 1292 1293 found = .FALSE. 1294 1295 END SELECT 1296 1297 1298 END SUBROUTINE bio_rrd_global 1299 1300 1301 !------------------------------------------------------------------------------! 1302 ! Description: 1303 ! ------------ 1304 !> Soubroutine reads local biometeorology configuration from restart file(s) 1305 !------------------------------------------------------------------------------! 1306 SUBROUTINE bio_rrd_local( found ) 1307 1308 1309 USE control_parameters, & 1310 ONLY: length, restart_string 1311 1312 1313 IMPLICIT NONE 1314 1315 1316 LOGICAL, INTENT(OUT) :: found !< variable found? yes = .T., no = .F. 1317 1318 found = .TRUE. 1319 1320 1321 SELECT CASE ( restart_string(1:length) ) 1322 1323 CASE ( 'nmrtbl' ) 1324 READ ( 13 ) bio_nmrtbl 1325 1326 CASE ( 'mrt_av_grid' ) 1327 IF ( .NOT. ALLOCATED( mrt_av_grid ) ) THEN 1328 ALLOCATE( mrt_av_grid(bio_nmrtbl) ) 1329 ENDIF 1330 READ ( 13 ) mrt_av_grid 1331 1332 1333 CASE DEFAULT 1334 1335 found = .FALSE. 1336 1337 END SELECT 1338 1339 1340 END SUBROUTINE bio_rrd_local 1341 1342 !------------------------------------------------------------------------------! 1343 ! Description: 1344 ! ------------ 1345 !> Write global restart data for the biometeorology module. 1346 !------------------------------------------------------------------------------! 1347 SUBROUTINE bio_wrd_global 1348 1349 IMPLICIT NONE 1350 1351 CALL wrd_write_string( 'do_average_theta' ) 1352 WRITE ( 14 ) do_average_theta 1353 CALL wrd_write_string( 'do_average_q' ) 1354 WRITE ( 14 ) do_average_q 1355 CALL wrd_write_string( 'do_average_u' ) 1356 WRITE ( 14 ) do_average_u 1357 CALL wrd_write_string( 'do_average_v' ) 1358 WRITE ( 14 ) do_average_v 1359 CALL wrd_write_string( 'do_average_w' ) 1360 WRITE ( 14 ) do_average_w 1361 CALL wrd_write_string( 'do_average_mrt' ) 1362 WRITE ( 14 ) do_average_mrt 1363 CALL wrd_write_string( 'average_trigger_perct' ) 1364 WRITE ( 14 ) average_trigger_perct 1365 CALL wrd_write_string( 'average_trigger_utci' ) 1366 WRITE ( 14 ) average_trigger_utci 1367 CALL wrd_write_string( 'average_trigger_pet' ) 1368 WRITE ( 14 ) average_trigger_pet 1369 1370 END SUBROUTINE bio_wrd_global 1371 1372 1373 !------------------------------------------------------------------------------! 1374 ! Description: 1375 ! ------------ 1376 !> Write local restart data for the biometeorology module. 1377 !------------------------------------------------------------------------------! 1378 SUBROUTINE bio_wrd_local 1379 1380 IMPLICIT NONE 1381 1382 ! 1383 !-- First nmrtbl has to be written/read, because it is the dimension of mrt_av_grid 1384 CALL wrd_write_string( 'nmrtbl' ) 1385 WRITE ( 14 ) nmrtbl 1386 1387 IF ( ALLOCATED( mrt_av_grid ) ) THEN 1388 CALL wrd_write_string( 'mrt_av_grid' ) 1389 WRITE ( 14 ) mrt_av_grid 1390 ENDIF 1391 1392 1393 END SUBROUTINE bio_wrd_local 1394 1395 1396 !------------------------------------------------------------------------------! 1397 ! Description: 1398 ! ------------ 1213 1399 !> Calculate biometeorology MRT for all 2D grid 1214 1400 !------------------------------------------------------------------------------! … … 1225 1411 INTEGER(iwp) :: l !< Running index, radiation coordinates 1226 1412 1413 1414 IF ( av ) THEN 1415 IF ( .NOT. ALLOCATED( tmrt_av_grid ) ) THEN 1416 ALLOCATE( tmrt_av_grid (nys:nyn,nxl:nxr) ) 1417 ENDIF 1418 1419 DO l = 1, nmrtbl 1420 i = mrtbl(ix,l) 1421 j = mrtbl(iy,l) 1422 k = mrtbl(iz,l) 1423 IF ( k - get_topography_top_index_ji( j, i, 's' ) == & 1424 bio_cell_level + 1_iwp) THEN 1425 1426 tmrt_av_grid(j,i) = mrt_av_grid(l) 1427 1428 ENDIF 1429 ENDDO 1430 1431 ELSE 1432 1227 1433 ! 1228 1434 !-- Calculate biometeorology MRT from local radiation fluxes calculated by RTM and assign 1229 1435 !-- into 2D grid. Depending on selected output quantities, tmrt_grid might not have been 1230 1436 !-- allocated in bio_check_data_output yet. 1231 IF ( .NOT. ALLOCATED( tmrt_grid ) ) THEN 1232 ALLOCATE( tmrt_grid (nys:nyn,nxl:nxr) ) 1233 ENDIF 1234 tmrt_grid = REAL( bio_fill_value, KIND = wp ) 1235 1236 DO l = 1, nmrtbl 1237 i = mrtbl(ix,l) 1238 j = mrtbl(iy,l) 1239 k = mrtbl(iz,l) 1240 IF ( k - get_topography_top_index_ji( j, i, 's' ) == bio_cell_level + & 1241 1_iwp) THEN 1242 IF ( mrt_include_sw ) THEN 1243 tmrt_grid(j,i) = ((human_absorb*mrtinsw(l) + & 1244 human_emiss*mrtinlw(l)) / & 1245 (human_emiss*sigma_sb)) ** .25_wp - degc_to_k 1246 ELSE 1247 tmrt_grid(j,i) = (human_emiss*mrtinlw(l) / sigma_sb) ** .25_wp & 1248 - degc_to_k 1437 IF ( .NOT. ALLOCATED( tmrt_grid ) ) THEN 1438 ALLOCATE( tmrt_grid (nys:nyn,nxl:nxr) ) 1439 ENDIF 1440 tmrt_grid = REAL( bio_fill_value, KIND = wp ) 1441 1442 DO l = 1, nmrtbl 1443 i = mrtbl(ix,l) 1444 j = mrtbl(iy,l) 1445 k = mrtbl(iz,l) 1446 IF ( k - get_topography_top_index_ji( j, i, 's' ) == bio_cell_level + & 1447 1_iwp) THEN 1448 IF ( mrt_include_sw ) THEN 1449 tmrt_grid(j,i) = ((human_absorb*mrtinsw(l) + & 1450 human_emiss*mrtinlw(l)) / & 1451 (human_emiss*sigma_sb)) ** .25_wp - degc_to_k 1452 ELSE 1453 tmrt_grid(j,i) = (human_emiss*mrtinlw(l) / sigma_sb) ** .25_wp & 1454 - degc_to_k 1455 ENDIF 1249 1456 ENDIF 1250 END IF1251 END DO1457 ENDDO 1458 ENDIF 1252 1459 1253 1460 END SUBROUTINE bio_calculate_mrt_grid … … 1342 1549 !-- local mtr value at [i,j] 1343 1550 tmrt = bio_fill_value !< this can be a valid result (e.g. for inside some ostacle) 1344 IF ( radiation) THEN1551 IF ( .NOT. average_input ) THEN 1345 1552 ! 1346 1553 !-- Use MRT from RTM precalculated in tmrt_grid 1347 1554 tmrt = tmrt_grid(j,i) 1555 ELSE 1556 tmrt = tmrt_av_grid(j,i) 1348 1557 ENDIF 1349 1558 … … 1488 1697 REAL(wp), INTENT ( OUT ) :: ipt !< Instationary perceived temp. (degree_C) 1489 1698 ! 1699 !-- return immediatelly if nothing to do! 1700 IF ( .NOT. thermal_comfort ) THEN 1701 RETURN 1702 ENDIF 1703 ! 1490 1704 !-- If clo equals the initial value, this is the initial call 1491 1705 IF ( clo <= -998._wp ) THEN … … 1505 1719 END SUBROUTINE bio_calc_ipt 1506 1720 1507 !------------------------------------------------------------------------------!1508 ! Description:1509 ! ------------1510 !> Soubroutine reads global biometeorology configuration from restart file(s)1511 !------------------------------------------------------------------------------!1512 SUBROUTINE bio_rrd_global( found )1513 1514 USE control_parameters, &1515 ONLY: length, restart_string1516 1517 1518 IMPLICIT NONE1519 1520 LOGICAL, INTENT(OUT) :: found !< variable found? yes = .T., no = .F.1521 1522 found = .TRUE.1523 1524 1525 SELECT CASE ( restart_string(1:length) )1526 1527 !1528 !-- read control flags to determine if input grids need to be averaged1529 CASE ( 'aver_perct' )1530 READ ( 13 ) aver_perct1531 1532 CASE ( 'aver_q' )1533 READ ( 13 ) aver_q1534 1535 CASE ( 'aver_u' )1536 READ ( 13 ) aver_u1537 1538 CASE ( 'aver_v' )1539 READ ( 13 ) aver_v1540 1541 CASE ( 'aver_w' )1542 READ ( 13 ) aver_w1543 !1544 !-- read control flags to determine which thermal index needs to trigger averaging1545 CASE ( 'average_trigger_perct' )1546 READ ( 13 ) average_trigger_perct1547 1548 CASE ( 'average_trigger_utci' )1549 READ ( 13 ) average_trigger_utci1550 1551 CASE ( 'average_trigger_pet' )1552 READ ( 13 ) average_trigger_pet1553 1554 1555 CASE DEFAULT1556 1557 found = .FALSE.1558 1559 END SELECT1560 1561 1562 END SUBROUTINE bio_rrd_global1563 1564 1565 !------------------------------------------------------------------------------!1566 ! Description:1567 ! ------------1568 !> Soubroutine reads local biometeorology configuration from restart file(s)1569 !------------------------------------------------------------------------------!1570 SUBROUTINE bio_rrd_local( found )1571 1572 1573 USE control_parameters, &1574 ONLY: length, restart_string1575 1576 1577 IMPLICIT NONE1578 1579 1580 LOGICAL, INTENT(OUT) :: found !< variable found? yes = .T., no = .F.1581 1582 found = .TRUE.1583 1584 1585 SELECT CASE ( restart_string(1:length) )1586 1587 CASE ( 'nmrtbl' )1588 READ ( 13 ) bio_nmrtbl1589 1590 CASE ( 'mrt_av_grid' )1591 IF ( .NOT. ALLOCATED( mrt_av_grid ) ) THEN1592 ALLOCATE( mrt_av_grid(bio_nmrtbl) )1593 ENDIF1594 READ ( 13 ) mrt_av_grid1595 1596 1597 CASE DEFAULT1598 1599 found = .FALSE.1600 1601 END SELECT1602 1603 1604 END SUBROUTINE bio_rrd_local1605 1606 !------------------------------------------------------------------------------!1607 ! Description:1608 ! ------------1609 !> Write global restart data for the biometeorology module.1610 !------------------------------------------------------------------------------!1611 SUBROUTINE bio_wrd_global1612 1613 IMPLICIT NONE1614 1615 CALL wrd_write_string( 'aver_perct' )1616 WRITE ( 14 ) aver_perct1617 CALL wrd_write_string( 'aver_q' )1618 WRITE ( 14 ) aver_q1619 CALL wrd_write_string( 'aver_u' )1620 WRITE ( 14 ) aver_u1621 CALL wrd_write_string( 'aver_v' )1622 WRITE ( 14 ) aver_v1623 CALL wrd_write_string( 'aver_w' )1624 WRITE ( 14 ) aver_w1625 CALL wrd_write_string( 'average_trigger_perct' )1626 WRITE ( 14 ) average_trigger_perct1627 CALL wrd_write_string( 'average_trigger_utci' )1628 WRITE ( 14 ) average_trigger_utci1629 CALL wrd_write_string( 'average_trigger_pet' )1630 WRITE ( 14 ) average_trigger_pet1631 1632 END SUBROUTINE bio_wrd_global1633 1634 1635 !------------------------------------------------------------------------------!1636 ! Description:1637 ! ------------1638 !> Write local restart data for the biometeorology module.1639 !------------------------------------------------------------------------------!1640 SUBROUTINE bio_wrd_local1641 1642 IMPLICIT NONE1643 1644 !1645 !-- First nmrtbl has to be written/read, because it is the dimension of mrt_av_grid1646 CALL wrd_write_string( 'nmrtbl' )1647 WRITE ( 14 ) nmrtbl1648 1649 IF ( ALLOCATED( mrt_av_grid ) ) THEN1650 CALL wrd_write_string( 'mrt_av_grid' )1651 WRITE ( 14 ) mrt_av_grid1652 ENDIF1653 1654 1655 END SUBROUTINE bio_wrd_local1656 1721 1657 1722 … … 1661 1726 !> SUBROUTINE for calculating UTCI Temperature (UTCI) 1662 1727 !> computed by a 6th order approximation 1663 ! 1728 !> 1664 1729 !> UTCI regression equation after 1665 1730 !> Bröde P, Fiala D, Blazejczyk K, Holmér I, Jendritzky G, Kampmann B, Tinz B, … … 1667 1732 !> Climate Index (UTCI). International Journal of Biometeorology 56 (3):481-494. 1668 1733 !> doi:10.1007/s00484-011-0454-1 1669 ! 1734 !> 1670 1735 !> original source available at: 1671 1736 !> www.utci.org … … 1728 1793 ! 1729 1794 !-- Wind altitude correction from hag to 10m after Broede et al. (2012), eq.3 1730 ! 1795 !-- z(0) is set to 0.01 according to UTCI profile definition 1731 1796 va = ws_hag * log ( 10.0_wp / 0.01_wp ) / log ( hag / 0.01_wp ) 1732 1797 ! … … 1749 1814 ! 1750 1815 !-- For routine application. For wind speeds and relative 1751 ! 1752 ! 1816 !-- humidity values below 0.5 m/s or 5%, respectively, the 1817 !-- user is advised to use the lower bounds for the calculations. 1753 1818 IF ( va < 0.5_wp ) va = 0.5_wp 1754 1819 IF ( va > 17._wp ) va = 17._wp … … 1988 2053 ( 1.33374846e-03_wp ) * ta2 * pa4 + & 1989 2054 ( 3.55375387e-03_wp ) * va * pa4 + & 1990 ( -5.13027851e-04_wp ) * ta * va *pa4 + &2055 ( -5.13027851e-04_wp ) * ta * va * pa4 + & 1991 2056 ( 1.02449757e-04_wp ) * va2 * pa4 + & 1992 2057 ( -1.48526421e-03_wp ) * d_tmrt * pa4 + & … … 2034 2099 ! 2035 2100 !-- Parameters for standard "Klima-Michel" 2036 REAL(wp), PARAMETER :: eta = 0._wp !< Mechanical work efficiency for walking on flat ground (compare to Fanger (1972) pp 24f) 2037 REAL(wp), PARAMETER :: actlev = 134.6862_wp !< Workload by activity per standardized surface (A_Du) 2101 REAL(wp), PARAMETER :: eta = 0._wp !< Mechanical work efficiency for walking on flat ground 2102 !< (compare to Fanger (1972) pp 24f) 2103 REAL(wp), PARAMETER :: actlev = 134.6862_wp !< Workload by activity per standardized surface (A_Du) 2038 2104 ! 2039 2105 !-- Type of program variables … … 2072 2138 !-- Tresholds: clothing insulation (account for model inaccuracies) 2073 2139 ! 2074 ! 2140 !-- summer clothing 2075 2141 sclo = 0.44453_wp 2076 2142 ! 2077 ! 2143 !-- winter clothing 2078 2144 wclo = 1.76267_wp 2079 2145 ! … … 2096 2162 ! 2097 2163 !-- Case: comfort achievable by varying clothing insulation 2098 ! 2164 !-- Between winter and summer set values 2099 2165 CALL iso_ridder ( ta, tmrt, vp, ws, pair, actlev, eta, sclo, & 2100 2166 pmv_s, wclo, pmv_w, eps, pmva, top, ncount, clo ) … … 2131 2197 ! 2132 2198 !-- Case: comfort achievable by varying clothing insulation 2133 ! 2199 !-- between winter and summer set values 2134 2200 CALL iso_ridder ( ta, tmrt, vp, ws, pair, actlev, eta, sclo, & 2135 2201 pmv_s, wclo, pmv_w, eps, pmva, top, ncount, clo ) … … 2172 2238 ! 2173 2239 !-- Required clothing insulation (ireq) is exclusively defined for 2174 ! 2175 ! 2240 !-- operative temperatures (top) less 10 (C) for a 2241 !-- reference wind of 0.2 m/s according to 8.73 (C) for 0.1 m/s 2176 2242 clon = ireq_neutral ( perct_ij, ireq_minimal, nerr ) 2177 2243 clo = clon … … 2202 2268 ! Description: 2203 2269 ! ------------ 2204 !> The SUBROUTINE calculates the saturationwater vapour pressure2270 !> The SUBROUTINE calculates the (saturation) water vapour pressure 2205 2271 !> (hPa = hecto Pascal) for a given temperature ta (degC). 2206 !> For example, ta can be the air temperature or the dew point temperature. 2272 !> 'ta' can be the air temperature or the dew point temperature. The first will 2273 !> result in the current vapor pressure (hPa), the latter will calulate the 2274 !> saturation vapor pressure (hPa). 2207 2275 !------------------------------------------------------------------------------! 2208 2276 SUBROUTINE saturation_vapor_pressure( ta, svp_ta ) … … 2211 2279 2212 2280 REAL(wp), INTENT ( IN ) :: ta !< ambient air temperature (degC) 2213 REAL(wp), INTENT ( OUT ) :: svp_ta !< saturationwater vapour pressure (hPa)2281 REAL(wp), INTENT ( OUT ) :: svp_ta !< water vapour pressure (hPa) 2214 2282 2215 2283 REAL(wp) :: b … … 2219 2287 IF ( ta < 0._wp ) THEN 2220 2288 ! 2221 !-- ta < 0 (degC): saturationwater vapour pressure over ice2289 !-- ta < 0 (degC): water vapour pressure over ice 2222 2290 b = 17.84362_wp 2223 2291 c = 245.425_wp 2224 2292 ELSE 2225 2293 ! 2226 !-- ta >= 0 (degC): saturationwater vapour pressure over water2294 !-- ta >= 0 (degC): water vapour pressure over water 2227 2295 b = 17.08085_wp 2228 2296 c = 234.175_wp … … 2248 2316 ! 2249 2317 !-- Input variables of argument list: 2250 REAL(wp), INTENT ( IN ) :: ta !< Ambient temperature (degC)2318 REAL(wp), INTENT ( IN ) :: ta !< Ambient temperature (degC) 2251 2319 REAL(wp), INTENT ( IN ) :: tmrt !< Mean radiant temperature (degC) 2252 REAL(wp), INTENT ( IN ) :: vp !< Water vapour pressure (hPa)2253 REAL(wp), INTENT ( IN ) :: ws !< Wind speed (m/s) 1 m above ground2254 REAL(wp), INTENT ( IN ) :: pair !< Barometricpressure (hPa)2320 REAL(wp), INTENT ( IN ) :: vp !< Water vapour pressure (hPa) 2321 REAL(wp), INTENT ( IN ) :: ws !< Wind speed (m/s) 1 m above ground 2322 REAL(wp), INTENT ( IN ) :: pair !< Barometric air pressure (hPa) 2255 2323 REAL(wp), INTENT ( IN ) :: actlev !< Individuals activity level per unit surface area (W/m2) 2256 2324 REAL(wp), INTENT ( IN ) :: eta !< Individuals work efficiency (dimensionless) … … 2262 2330 REAL(wp), INTENT ( IN ) :: pmv_s !< Fanger's PMV corresponding to sclo 2263 2331 ! 2264 ! Output variables of argument list:2332 !-- Output variables of argument list: 2265 2333 REAL(wp), INTENT ( OUT ) :: pmva !< 0 (set to zero, because clo is evaluated for comfort) 2266 2334 REAL(wp), INTENT ( OUT ) :: top !< Operative temperature (degC) at found root of Fanger's PMV 2267 2335 REAL(wp), INTENT ( OUT ) :: clo_res !< Resulting clothing insulation value (clo) 2268 2336 INTEGER(iwp), INTENT ( OUT ) :: nerr !< Error status / quality flag 2269 ! nerr >= 0, o.k., and nerr is the number of iterations for 2270 ! convergence 2271 ! nerr = -1: error = malfunction of Ridder's convergence method 2272 ! nerr = -2: error = maximum iterations (max_iteration) exceeded 2273 ! nerr = -3: error = root not bracketed between sclo and wclo 2337 !< nerr >= 0, o.k., and nerr is the number of iterations for convergence 2338 !< nerr = -1: error = malfunction of Ridder's convergence method 2339 !< nerr = -2: error = maximum iterations (max_iteration) exceeded 2340 !< nerr = -3: error = root not bracketed between sclo and wclo 2274 2341 ! 2275 2342 !-- Type of program variables … … 2428 2495 !-- Output variables of argument list: 2429 2496 REAL(wp), INTENT ( OUT ) :: pmva !< Actual Predicted Mean Vote (PMV, 2430 !dimensionless) according to Fanger corresponding to meteorological2431 !(ta,tmrt,pa,ws,pair) and individual variables (clo, actlev, eta)2497 !< dimensionless) according to Fanger corresponding to meteorological 2498 !< (ta,tmrt,pa,ws,pair) and individual variables (clo, actlev, eta) 2432 2499 REAL(wp), INTENT ( OUT ) :: top !< operative temperature (degC) 2433 2500 ! … … 2447 2514 REAL(wp) :: ws !< wind speed (m/s) 2448 2515 REAL(wp) :: z1 !< Empiric factor for the adaption of the heat 2449 !ballance equation to the psycho-physical scale (Equ. 40 in FANGER)2516 !< ballance equation to the psycho-physical scale (Equ. 40 in FANGER) 2450 2517 REAL(wp) :: z2 !< Water vapour diffution through the skin 2451 2518 REAL(wp) :: z3 !< Sweat evaporation from the skin surface … … 2485 2552 ! 2486 2553 !-- Calculation of clothing surface temperature (t_clothing) based on 2487 ! 2554 !-- Newton-approximation with air temperature as initial guess 2488 2555 t_clothing = ta 2489 2556 DO i = 1, 3 … … 2493 2560 ! 2494 2561 !-- Empiric factor for the adaption of the heat ballance equation 2495 ! 2562 !-- to the psycho-physical scale (Equ. 40 in FANGER) 2496 2563 z1 = ( .303_wp * EXP ( -.036_wp * actlev ) + .0275_wp ) 2497 2564 ! … … 2535 2602 2536 2603 IMPLICIT NONE 2604 2537 2605 ! 2538 2606 !-- Input variables of argument list: … … 2543 2611 REAL(wp), INTENT ( IN ) :: tmrt !< Mean radiant temperature (degC) at screen level 2544 2612 REAL(wp), INTENT ( IN ) :: ws !< Wind speed (m/s) 1 m above ground 2613 2545 2614 ! 2546 2615 !-- Output variables of argument list: 2547 2616 INTEGER(iwp), INTENT ( OUT ) :: nerr !< Error status / quality flag 2548 ! 0 = o.k. 2549 ! -2 = pmva outside valid regression range 2550 ! -3 = rel. humidity set to 5 % or 95 %, respectively 2551 ! -4 = deltapmv set to avoid pmvs < 0 2552 ! 2553 !-- Internal variable types: 2554 REAL(wp) :: pmv !< 2555 REAL(wp) :: pa_p50 !< 2556 REAL(wp) :: pa !< 2557 REAL(wp) :: apa !< 2558 REAL(wp) :: dapa !< 2559 REAL(wp) :: sqvel !< 2560 REAL(wp) :: dtmrt !< 2561 REAL(wp) :: p10 !< 2562 REAL(wp) :: p95 !< 2563 REAL(wp) :: gew !< 2564 REAL(wp) :: gew2 !< 2617 !< 0 = o.k. 2618 !< -2 = pmva outside valid regression range 2619 !< -3 = rel. humidity set to 5 % or 95 %, respectively 2620 !< -4 = deltapmv set to avoid pmvs < 0 2621 2622 ! 2623 !-- Internal variables: 2624 REAL(wp) :: pmv !< temp storage og predicted mean vote 2625 REAL(wp) :: pa_p50 !< ratio actual water vapour pressure to that of relative humidity of 50 % 2626 REAL(wp) :: pa !< vapor pressure (hPa) with hard bounds 2627 REAL(wp) :: apa !< natural logarithm of pa (with hard lower border) 2628 REAL(wp) :: dapa !< difference of apa and pa_p50 2629 REAL(wp) :: sqvel !< square root of local wind velocity 2630 REAL(wp) :: dtmrt !< difference mean radiation to air temperature 2631 REAL(wp) :: p10 !< lower bound for pa 2632 REAL(wp) :: p95 !< upper bound for pa 2633 REAL(wp) :: weight !< 2634 REAL(wp) :: weight2 !< 2565 2635 REAL(wp) :: dpmv_1 !< 2566 2636 REAL(wp) :: dpmv_2 !< … … 2657 2727 ENDIF 2658 2728 ! 2659 !-- Air temperature2660 ! ta = ta2661 2729 !-- Difference mean radiation to air temperature 2662 2730 dtmrt = tmrt - ta … … 2670 2738 RETURN 2671 2739 ENDIF 2672 gew= MOD ( pmv, 1._wp )2673 IF ( gew < 0._wp ) gew= 0._wp2740 weight = MOD ( pmv, 1._wp ) 2741 IF ( weight < 0._wp ) weight = 0._wp 2674 2742 IF ( nreg > 5_iwp ) THEN 2675 2743 ! nreg=6 2676 2744 nreg = 5_iwp 2677 gew= pmv - 5._wp2678 gew2 = pmv - 6._wp2679 IF ( gew2 > 0_iwp ) THEN2680 gew = ( gew - gew2 ) / gew2745 weight = pmv - 5._wp 2746 weight2 = pmv - 6._wp 2747 IF ( weight2 > 0_iwp ) THEN 2748 weight = ( weight - weight2 ) / weight 2681 2749 ENDIF 2682 2750 ENDIF … … 2709 2777 ! 2710 2778 !-- Calculate pmv modification 2711 deltapmv = ( 1._wp - gew ) * dpmv_1 + gew* dpmv_22779 deltapmv = ( 1._wp - weight ) * dpmv_1 + weight * dpmv_2 2712 2780 pmvs = pmva + deltapmv 2713 2781 IF ( ( pmvs ) < 0._wp ) THEN … … 2746 2814 !-- Additional output variables of argument list: 2747 2815 REAL(wp), INTENT ( OUT ) :: dperctm !< Mean deviation perct (classical gt) to gt* (rational gt 2748 !calculated based on Gagge's rational PMV*)2816 !< calculated based on Gagge's rational PMV*) 2749 2817 REAL(wp), INTENT ( OUT ) :: dperctstd !< dperctm plus its standard deviation times a factor 2750 !determining the significance to perceive sultriness2818 !< determining the significance to perceive sultriness 2751 2819 REAL(wp), INTENT ( OUT ) :: sultr_res 2752 2820 ! … … 2758 2826 ! 2759 2827 !-- Types of coefficients mean deviation plus standard deviation 2760 ! 2828 !-- regression coefficients: third order polynomial 2761 2829 REAL(wp), PARAMETER :: dperctsa = +0.0268918_wp 2762 2830 REAL(wp), PARAMETER :: dperctsb = +0.0465957_wp … … 2765 2833 ! 2766 2834 !-- Factor to mean standard deviation defining SIGNificance for 2767 ! 2835 !-- sultriness 2768 2836 REAL(wp), PARAMETER :: faktor = 1._wp 2769 2837 ! … … 2814 2882 INTEGER(iwp), INTENT ( OUT ) :: nerr !< Error indicator: 0 = o.k., +1 = denominator for intersection = 0 2815 2883 REAL(wp), INTENT ( OUT ) :: dpmv_cold_res !< Increment to adjust pmva according to the results of Gagge's 2816 !2 node model depending on the input2884 !< 2 node model depending on the input 2817 2885 ! 2818 2886 !-- Type of program variables … … 2826 2894 REAL(wp) :: sqrt_ws 2827 2895 INTEGER(iwp) :: i 2828 ! INTEGER(iwp) :: j2829 2896 INTEGER(iwp) :: i_bin 2830 2897 ! … … 2839 2906 ! 2840 2907 !-- Initialise 2841 nerr = 0_iwp2908 nerr = 0_iwp 2842 2909 dpmv_cold_res = 0._wp 2843 pmvc = pmva2844 dtmrt = tmrt - ta2845 sqrt_ws = ws2910 pmvc = pmva 2911 dtmrt = tmrt - ta 2912 sqrt_ws = ws 2846 2913 IF ( sqrt_ws < 0.10_wp ) THEN 2847 2914 sqrt_ws = 0.10_wp … … 2885 2952 ! 2886 2953 !-- Adjust to operative temperature scaled according 2887 ! 2954 !-- to classical PMV (Fanger) 2888 2955 dpmv_cold_res = delta_cold(i_bin) - dpmv_adj(pmva) 2889 2956 … … 2909 2976 REAL(wp) :: pmv 2910 2977 INTEGER(iwp) :: i, i_bin 2911 2912 ! 2978 ! 2979 !-- range_1 range_2 range_3 2913 2980 DATA (coef(i, 0), i = 1, n_bin) /0.0941540_wp, -0.1506620_wp, -0.0871439_wp/ 2914 2981 DATA (coef(i, 1), i = 1, n_bin) /0.0783162_wp, -1.0612651_wp, 0.1695040_wp/ … … 3011 3078 ! 3012 3079 !-- DuBois D, DuBois EF: A formula to estimate the approximate surface area if 3013 ! 3080 !-- height and weight be known. In: Arch. Int. Med.. 17, 1916, S. 863?871. 3014 3081 surf = 0.007184_wp * height**0.725_wp * weight**0.425_wp 3015 3082 RETURN … … 3033 3100 !------------------------------------------------------------------------------! 3034 3101 SUBROUTINE persdat ( age, weight, height, sex, work, a_surf, actlev ) 3035 ! 3102 3036 3103 IMPLICIT NONE 3037 3104 … … 3164 3231 ! 3165 3232 !-- Case: comfort achievable by varying clothing insulation 3166 ! 3233 !-- between winter and summer set values 3167 3234 CALL iso_ridder ( ta, tmrt, vp, ws, pair, actlev, eta , sclo, & 3168 3235 pmv_s, wclo, pmv_w, eps, pmva, top, ncount, clo ) … … 3205 3272 ! 3206 3273 !-- Case: comfort achievable by varying clothing insulation 3207 ! 3274 !-- between winter and summer set values 3208 3275 CALL iso_ridder ( ta, tmrt, vp, ws, pair, actlev, eta, sclo, & 3209 3276 pmv_s, wclo, pmv_w, eps, pmva, top, ncount, clo ) … … 3248 3315 ! 3249 3316 !-- Required clothing insulation (ireq) is exclusively defined for 3250 ! 3251 ! 3317 !-- operative temperatures (top) less 10 (C) for a 3318 !-- reference wind of 0.2 m/s according to 8.73 (C) for 0.1 m/s 3252 3319 clon = ireq_neutral ( ipt, ireq_minimal, nerr ) 3253 3320 clo = clon … … 3387 3454 REAL(wp), INTENT ( IN ) :: pa !< Vapour pressure (hPa) 3388 3455 REAL(wp), INTENT ( IN ) :: pair !< Air pressure (hPa) 3389 REAL(wp), INTENT ( IN ) :: in_ws !< Wind speed (m/s)3456 REAL(wp), INTENT ( IN ) :: in_ws !< Wind speed (m/s) 3390 3457 REAL(wp), INTENT ( IN ) :: actlev !< Metabolic + work energy (W/m²) 3391 3458 REAL(wp), INTENT ( IN ) :: dt !< Timestep (s) … … 3415 3482 REAL(wp) :: ws !< wind speed (m/s) 3416 3483 REAL(wp) :: z1 !< Empiric factor for the adaption of the heat 3417 !ballance equation to the psycho-physical scale (Equ. 40 in FANGER)3484 !< ballance equation to the psycho-physical scale (Equ. 40 in FANGER) 3418 3485 REAL(wp) :: z2 !< Water vapour diffution through the skin 3419 3486 REAL(wp) :: z3 !< Sweat evaporation from the skin surface … … 3427 3494 3428 3495 INTEGER(iwp) :: i !< running index 3429 INTEGER(iwp) :: niter !< Running index3496 INTEGER(iwp) :: niter !< Running index 3430 3497 3431 3498 ! … … 3457 3524 ! 3458 3525 !-- Calculation of clothing surface temperature (t_clothing) based on 3459 ! 3526 !-- newton-approximation with air temperature as initial guess 3460 3527 niter = INT( dt * 10._wp, KIND=iwp ) 3461 3528 IF ( niter < 1 ) niter = 1_iwp … … 3479 3546 ! 3480 3547 !-- Empiric factor for the adaption of the heat ballance equation 3481 ! 3548 !-- to the psycho-physical scale (Equ. 40 in FANGER) 3482 3549 z1 = ( .303_wp * EXP ( -.036_wp * actlev ) + .0275_wp ) 3483 3550 ! … … 3617 3684 REAL(wp), INTENT( OUT ) :: int_heat !< internal heat production (W) 3618 3685 REAL(wp), INTENT( OUT ) :: rtv !< respiratory volume 3619 !3620 !-- Constants:3621 ! REAL(wp), PARAMETER :: cair = 1010._wp !< replaced by c_p3622 ! REAL(wp), PARAMETER :: evap = 2.42_wp * 10._wp **6._wp !< replaced by l_v3623 3686 ! 3624 3687 !-- Internal variables:
Note: See TracChangeset
for help on using the changeset viewer.
