From c41e92774a4c3910ca832609c1cda6bb82c3a960 Mon Sep 17 00:00:00 2001 From: Stikstofje Date: Wed, 29 Jan 2020 10:51:31 +0100 Subject: [PATCH] Update to v4.6.2.5 --- binas.f90 | 244 +++++++++++++ m_commonconst.f90 | 108 +++--- m_commonfile.f90 | 62 +++- m_error.f90 | 157 ++++++-- m_getkey.f90 | 40 +- m_ops_building.f90 | 733 +++++++++++++++++++++++++++++++++++++ m_ops_emis.f90 | 848 +++++++++++++++++++++++++++++++++++++++++++ m_ops_plumerise.f90 | 655 +++++++++++++++++++++++++++++++++ m_ops_utils.f90 | 188 ++++++++++ m_utils.f90 | 24 +- ops_bron_rek.f90 | 156 ++++---- ops_brondepl.f90 | 13 +- ops_calc_stats.f90 | 12 +- ops_conc_ini.f90 | 7 +- ops_conc_rek.f90 | 9 +- ops_conltexp.f90 | 13 +- ops_depoparexp.f90 | 10 +- ops_depos_rc.f90 | 6 +- ops_gen_fnames.f90 | 1 + ops_gen_precip.f90 | 18 +- ops_init.f90 | 35 +- ops_logfile.f90 | 8 +- ops_main.f90 | 76 ++-- ops_monitor.f90 | 95 ----- ops_rcp_char_1.f90 | 9 +- ops_rcp_char_all.f90 | 10 +- ops_read_emis.f90 | 33 +- ops_read_meteo.f90 | 25 +- ops_read_source.f90 | 451 ++++------------------- ops_reken.f90 | 146 ++++++-- ops_resist_rek.f90 | 18 +- ops_stab_rek.f90 | 64 ++-- ops_statparexp.f90 | 134 ++++--- ops_surface.f90 | 29 +- ops_tra_char.f90 | 7 +- ops_vertdisp.f90 | 9 +- ops_wv_powerlaw.f90 | 65 ++++ ops_z0corr.f90 | 40 +- 38 files changed, 3659 insertions(+), 899 deletions(-) create mode 100644 binas.f90 create mode 100644 m_ops_building.f90 create mode 100644 m_ops_emis.f90 create mode 100644 m_ops_plumerise.f90 create mode 100644 m_ops_utils.f90 delete mode 100644 ops_monitor.f90 create mode 100644 ops_wv_powerlaw.f90 diff --git a/binas.f90 b/binas.f90 new file mode 100644 index 0000000..9eb7fad --- /dev/null +++ b/binas.f90 @@ -0,0 +1,244 @@ +!------------------------------------------------------------------------------------------------------------------------------- +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . +! +! Copyright (C) 2002 by +! National Institute of Public Health and Environment +! Laboratory for Air Research (RIVM/LLO) +! The Netherlands +!------------------------------------------------------------------------------------------------------------------------------- +module Binas + + implicit none + + public + + ! + !ProTeX: 1.14-AJS + ! + !BOI + ! + ! !TITLE: Binas - geometrical and physical constants + ! !AUTHORS: Arjo Segers + ! !AFFILIATION: KNMI + ! !DATE: \today + ! + ! !INTRODUCTION: Introduction + ! + ! 'BINAS' is the name an in The Netherlands common used table-book + ! with scientific constants and formulae. + ! + ! + ! !INTRODUCTION: Constants + ! + !BOC + + ! --------------------------------------------------------------- + ! gonio + ! --------------------------------------------------------------- + + ! defintions for pi : + ! o old definition: + !real, parameter :: pi = 3.1415927 + ! o EMOS definition (emos/interpolation/strlat.F, parameter PPI) + real, parameter :: pi = 3.14159265358979 + + ! two pi : + real, parameter :: twopi = 2*pi + + ! factors to convert to radians from degrees and the otrher way around; + ! alpha_deg = alpha_rad*rad2deg + ! alpha_rad = alpha_deg*deg2rad + real, parameter :: deg2rad = pi/180.0 ! rad/deg + real, parameter :: rad2deg = 180.0/pi ! deg/rad + + + ! --------------------------------------------------------------- + ! earth + ! --------------------------------------------------------------- + + ! Radius of earth as used in EMOS library (ECMWF model), + ! see for example "jvod2uv.F" + ! NOTE: the value 6.375e6 was used in TM ! + real, parameter :: ae = 6.371e6 ! m + + ! acceleration of gravity: + !real, parameter :: grav = 9.81 ! m/s2 + real, parameter :: grav = 9.80665 ! m/s2 + + ! Earth's angular speed of rotation + ! Omega = 2 * pi * (365.25/364.25) / (86400.0) + real, parameter :: Omega = 7.292e-5 ! rad/s + + + ! --------------------------------------------------------------- + ! molecules, mols, etc + ! --------------------------------------------------------------- + + ! Avogadro number + real, parameter :: Avog = 6.02205e23 ! mlc/mol + + ! Dobson units: + real,parameter :: Dobs = 2.68668e16 ! (mlc/cm2) / DU + + + ! + ! molar weights of components + ! + + ! naming convention: + ! o old names 'xm***' are in g/mol + ! o new names 'xm_***' are in kg/mol + ! + + ! atomic weights: + real, parameter :: xm_H = 1.00790e-3 ! kg/mol + real, parameter :: xm_N = 14.00670e-3 ! kg/mol + real, parameter :: xm_C = 12.01115e-3 ! kg/mol + real, parameter :: xm_S = 32.06400e-3 ! kg/mol + real, parameter :: xm_O = 15.99940e-3 ! kg/mol + real, parameter :: xm_F = 18.99840e-3 ! kg/mol + real, parameter :: xm_Na = 22.98977e-3 ! kg/mol + real, parameter :: xm_Cl = 35.45300e-3 ! kg/mol + real, parameter :: xm_Rn222 = 222.0e-3 ! kg/mol + real, parameter :: xm_Pb210 = 210.0e-3 ! kg/mol + + ! molecule weights: + real, parameter :: xm_h2o = xm_H * 2 + xm_O ! kg/mol + real, parameter :: xm_o3 = xm_O * 3 ! kg/mol + real, parameter :: xm_N2O5 = xm_N * 2 + xm_O * 5 ! kg/mol + real, parameter :: xm_HNO3 = xm_H + xm_N + xm_O * 3 ! kg/mol + real, parameter :: xm_NH4 = xm_N + xm_O * 4 ! kg/mol + real, parameter :: xm_SO4 = xm_S + xm_O * 4 ! kg/mol + real, parameter :: xm_NO3 = xm_N + xm_O * 3 ! kg/mol + + ! mass of air + real, parameter :: xm_air = 28.964e-3 ! kg/mol + real, parameter :: xmair = 28.94 ! g/mol; old name! + + ! dummy weight, used for complex molecules: + real, parameter :: xm_dummy = 1000.0e-3 ! kg/mol + + ! * seasalt + + ! sesalt composition: + ! (Seinfeld and Pandis, "Atmospheric Chemistry and Physics", + ! table 7.8 "Composition of Sea-Salt", p. 444) + real, parameter :: massfrac_Cl_in_seasalt = 0.5504 ! (kg Cl )/(kg seasalt) + real, parameter :: massfrac_Na_in_seasalt = 0.3061 ! (kg Na )/(kg seasalt) + real, parameter :: massfrac_SO4_in_seasalt = 0.0768 ! (kg SO4)/(kg seasalt) + + ! other numbers (wikipedia ?) + real, parameter :: xm_seasalt = 74.947e-3 ! kg/mol : NaCl, SO4, .. + real, parameter :: rho_seasalt = 2.2e3 ! kg/m3 + + ! * amonium sulphate + + real, parameter :: xm_NH4HSO4 = xm_NH4 + xm_H + xm_SO4 ! kg/mol + real, parameter :: rho_NH4HSO4a = 1.8e3 ! kg/m3 + + + ! mlc/mol + ! [cdob] = ------------------------ = DU / (kg/m2) + ! kg/mol cm2/m2 mlc/cm2/DU + ! + + real, parameter :: cdob_o3 = Avog / ( xm_o3 * 1.0e4 * Dobs ) ! DU/(kg/m2) + + ! --------------------------------------------------------------- + ! gas + ! --------------------------------------------------------------- + + ! gas constant + real, parameter :: Rgas = 8.3144 ! J/mol/K + + ! gas constant for dry air + !real, parameter :: rgas_x = 287.05 + ! NEW: + ! Rgas_air = Rgas / xmair = 287.0598 + real, parameter :: Rgas_air = Rgas / xm_air ! J/kg/K + + ! water vapour + !real,parameter :: rgasv = 461.51 + real, parameter :: Rgas_h2o = Rgas / xm_h2o ! J/kg/K + + ! standard pressure + real, parameter :: p0 = 1.0e5 ! Pa + !real, parameter :: p0 = 1.01325e5 ! Pa <-- suggestion Bram Bregman + + ! global mean pressure: + real,parameter :: p_global = 98500.0 ! Pa + + ! specific heat of dry air at constant pressure + !real, parameter :: cp0 = 1004.0 ! J/kg/K + real, parameter :: cp_air = 1004.0 ! J/kg/K + + ! Latent heat of evaporation + real, parameter :: lvap = 2.5e6 ! [J kg-1] + + ! Latent heat of condensation at 0 deg Celcius + ! (heat (J) necesarry to evaporate 1 kg of water) + real, parameter :: Lc = 22.6e5 ! J/kg + + ! kappa = R/cp = 2/7 + real, parameter :: kappa = 2.0/7.0 + ! 'kapa' is probably 'kappa' .... + !real, parameter :: kapa = 0.286 + + ! Von Karman constant (dry_dep) + real, parameter :: vkarman = 0.4 + + ! Boltzmann constant: + real, parameter :: kbolz = 1.38066e-23 ! J/K + + ! --------------------------------------------------------------- + ! virtual temperature : Tv = T * ( 1 + eps1*q ) + ! --------------------------------------------------------------- + + real, parameter :: eps = Rgas_air / Rgas_h2o + real, parameter :: eps1 = ( 1.0 - eps )/eps + + + ! --------------------------------------------------------------- + ! other + ! --------------------------------------------------------------- + + ! melting point + real, parameter :: T0 = 273.16 ! K + + ! Rv/Rd + real, parameter :: gamma = 6.5e-3 + + ! density of pure water at 0 deg C + real, parameter :: rol = 1000. ! kg/m^3 + + ! density of ice water at 0 deg C + real, parameter :: roi = 917. ! kg/m^3 + + ! density of pure water at 15 deg C + real, parameter :: rho_water = 999.0 ! kg/m^3 + + ! density of dry air at 20 oC and 1013.25 hPa : + real, parameter :: rho_dry_air_20C_1013hPa = 1.2041 ! kg/m3 + + ! Planck times velocity of light + real, parameter :: hc = 6.626176e-34 * 2.997924580e8 ! Jm + + + ! --------------------------------------------------------------- + ! end + ! --------------------------------------------------------------- + + !EOC + +end module Binas diff --git a/m_commonconst.f90 b/m_commonconst.f90 index fc0af03..96b0902 100644 --- a/m_commonconst.f90 +++ b/m_commonconst.f90 @@ -36,65 +36,69 @@ ! UPDATE HISTORY : !------------------------------------------------------------------------------------------------------------------------------- MODULE m_commonconst + +USE Binas, only: pi -INTEGER*4, PARAMETER :: NUNIT = 6 -INTEGER*4, PARAMETER :: NMETREG = 6 -INTEGER*4, PARAMETER :: NSEK = 12 -INTEGER*4, PARAMETER :: NSTAB = 6 -INTEGER*4, PARAMETER :: NTRAJ = 4 -INTEGER*4, PARAMETER :: NCOMP = 27 -INTEGER*4, PARAMETER :: NHRBLOCKS = 12 -INTEGER*4, PARAMETER :: NPARTCLASS = 6 -INTEGER*4, PARAMETER :: NMONTH = 12 -INTEGER*4, PARAMETER :: NKLIGEB = 8 -INTEGER*4, PARAMETER :: LSBUF = 4000 -INTEGER*4, PARAMETER :: NBRMAX = 10 -INTEGER*4, PARAMETER :: NCATMAX = 199 -INTEGER*4, PARAMETER :: NLANDMAX = 50 -INTEGER*4, PARAMETER :: NBGMAPS = 5 -INTEGER*4, PARAMETER :: NYEARS = 41 -INTEGER*4, PARAMETER :: MAXDIST = 9999 -INTEGER*4, PARAMETER :: MAXROW = 9999 -INTEGER*4, PARAMETER :: MAXCOL = 9999 -INTEGER*4, PARAMETER :: NLU = 9 +INTEGER*4, PARAMETER :: NUNIT = 6 ! number of units for deposition +INTEGER*4, PARAMETER :: NMETREG = 6 ! number of meteo regions +INTEGER*4, PARAMETER :: NSEK = 12 ! number of wind sectors +INTEGER*4, PARAMETER :: NSTAB = 6 ! number of stability classes +INTEGER*4, PARAMETER :: NTRAJ = 4 ! number of distance classes +INTEGER*4, PARAMETER :: NCOMP = 27 ! number of components in meteo input (from METPRO) +INTEGER*4, PARAMETER :: NHRBLOCKS = 12 ! number of two-hour blocks in a day +INTEGER*4, PARAMETER :: NPARTCLASS = 6 ! number of particle size classes +INTEGER*4, PARAMETER :: NMONTH = 12 ! number of months in a year +INTEGER*4, PARAMETER :: NKLIGEB = 8 ! number of climate regions in NL (KLIGEB << klimaatgebieden = climate regions) +INTEGER*4, PARAMETER :: LSBUF = 4000 ! size of buffer for reading emissions +INTEGER*4, PARAMETER :: NBRMAX = 10 ! maximal number of emission sources for which there is emission data written to print file +INTEGER*4, PARAMETER :: NCATMAX = 199 ! maximal number of emission categories +INTEGER*4, PARAMETER :: NLANDMAX = 50 ! maximal number of emission countries (land << country) +INTEGER*4, PARAMETER :: NBGMAPS = 5 ! number of background maps +INTEGER*4, PARAMETER :: NYEARS = 41 ! number of years for interpolating backgground maps +INTEGER*4, PARAMETER :: MAXDISTR = 9999 ! maximal number of distributions (for particle size or emission variation) +INTEGER*4, PARAMETER :: MAXROW = 9999 ! maximal number of rows in receptor grid +INTEGER*4, PARAMETER :: MAXCOL = 9999 ! maximal number of columns in receptor grid +INTEGER*4, PARAMETER :: NLU = 9 ! number of landuse classes +INTEGER*4, PARAMETER :: ncolBuildingEffectTable = 5 ! 1st column corresponds to distance from building. 2-5 correspond to different building types ! CONSTANTS - overige -REAL*4 :: z0_FACT_NL = 10000. ! default factor for conversion of z0_nl gridvalue to meters -REAL*4 :: z0_FACT_EUR = 10000. ! default factor for conversion of z0_eur gridvalue to meters +REAL*4 :: z0_FACT_NL = 10000. ! default factor for conversion of z0_nl gridvalue to meters +REAL*4 :: z0_FACT_EUR = 10000. ! default factor for conversion of z0_eur gridvalue to meters + +REAL*4, PARAMETER :: zmet_T = 1.5 ! reference height for temperature measurements [m] -INTEGER*4, PARAMETER :: IGEO = 0 -INTEGER*4, PARAMETER :: MISVALNUM = -9999 -INTEGER*4, PARAMETER :: FIRSTYEAR = 1977 -INTEGER*4, PARAMETER :: FUTUREYEAR = 2020 -REAL*4 :: r4_for_tiny -REAL*8 :: r8_for_tiny -REAL*4, PARAMETER :: EPS_DELTA = tiny(r4_for_tiny) -REAL*8, PARAMETER :: DPEPS_DELTA = tiny(r8_for_tiny) -REAL*4, PARAMETER :: PI = 3.141592 -REAL*4, PARAMETER :: CONV = 360./(2*PI) -REAL*4, PARAMETER :: HUMAX = 500. -CHARACTER*8, PARAMETER :: MODVERSIE = '4.5.2.2' -CHARACTER*20, PARAMETER :: RELEASEDATE = '10 jan 2018' +INTEGER*4, PARAMETER :: IGEO = 0 ! 1 -> Geographical coordinates lon-lat [degrees]; 0 -> RDM coordinates [m] +INTEGER*4, PARAMETER :: MISVALNUM = -9999 ! missing value +INTEGER*4, PARAMETER :: FIRSTYEAR = 1977 ! first year, used for interpolating background maps +INTEGER*4, PARAMETER :: FUTUREYEAR = 2020 ! future year, used for interpolating background maps +REAL*4 :: r4_for_tiny ! help variable to define EPS_DELTA +REAL*8 :: r8_for_tiny ! help variable to define DEPS_DELTA +REAL*4, PARAMETER :: EPS_DELTA = tiny(r4_for_tiny) ! tiny number (real) +REAL*8, PARAMETER :: DPEPS_DELTA = tiny(r8_for_tiny) ! tiny number (double precision) +! REAL*4, PARAMETER :: PI = 3.14159265 +REAL*4, PARAMETER :: HUMAX = 500. ! maximal plume height [m] +CHARACTER*8, PARAMETER :: MODVERSIE = '4.6.2.5' ! model version OPS-LT +CHARACTER*20, PARAMETER :: RELEASEDATE = '06 dec 2019' ! release date ! ! CONSTANTS - Data ! -INTEGER*4 :: NACHTZOMER(NSTAB, NTRAJ) -INTEGER*4 :: NACHTWINTER(NSTAB, NTRAJ) -REAL*4 :: DISPH(NSTAB) -REAL*4 :: STOKES(NPARTCLASS) -REAL*4 :: SCWINTER(NSTAB) -REAL*4 :: cf_so2(NBGMAPS) -REAL*4 :: cf_nox(NBGMAPS) -REAL*4 :: cf_nh3(NBGMAPS) -REAL*4 :: tf_so2(NYEARS + 1) -REAL*4 :: tf_no2(NYEARS + 1) -REAL*4 :: tf_nh3(NYEARS + 1) -REAL*4 :: nox_no2_beta(2) ! coefficient in conversion NO2 = beta(1)*log(NOx) + beta(2) -CHARACTER*10 :: CNAME(3,5) -CHARACTER*10 :: UNITS(2) ! units for concentration -CHARACTER*10 :: DEPUNITS(NUNIT) -CHARACTER*40 :: KLIGEB(NKLIGEB) +INTEGER*4 :: NACHTZOMER(NSTAB, NTRAJ) ! relative occurrences (%) of nighttime hours in summer (for each stability class and distance class) ("NACHT" = night, "ZOMER" = summer) +INTEGER*4 :: NACHTWINTER(NSTAB, NTRAJ) ! relative occurrences (%) of nighttime hours in winter (for each stability class and distance class) ("NACHT" = night) +REAL*4 :: DISPH(NSTAB) ! coefficients for vertical dispersion coefficient sigma_z; sigma_z = dispg*x**disph +REAL*4 :: STOKES(NPARTCLASS) ! Sedimentation velocity (m/s) needed for plume descent in case of heavy particles, for each particle class +REAL*4 :: SCWINTER(NSTAB) ! variation in NO2/NOx ratio (relative to stability class S2) for each stability class (only in winter) +REAL*4 :: cf_so2(NBGMAPS) ! correction factors for the difference between model output and measurements for SO2 +REAL*4 :: cf_nox(NBGMAPS) ! correction factors for the difference between model output and measurements for NOx +REAL*4 :: cf_nh3(NBGMAPS) ! correction factors for the difference between model output and measurements for NH3 +REAL*4 :: tf_so2(NYEARS + 1) ! trendfactors for SO2: concentration in year T, relative to the concentration in reference year +REAL*4 :: tf_no2(NYEARS + 1) ! trendfactors for NO2: concentration in year T, relative to the concentration in reference year +REAL*4 :: tf_nh3(NYEARS + 1) ! trendfactors for NH3: concentration in year T, relative to the concentration in reference year +REAL*4 :: nox_no2_beta(2) ! coefficient in conversion NO2 = beta(1)*log(NOx) + beta(2) +CHARACTER*10 :: CNAME(3,5) ! names of substances (primary, secondary, second secondary, deposited, name in DEPAC) +CHARACTER*10 :: UNITS(2) ! units for concentration +CHARACTER*10 :: DEPUNITS(NUNIT) ! units for deposition +CHARACTER*40 :: KLIGEB(NKLIGEB) ! climate regions in NL (KLIGEB << klimaatgebieden = climate regions) ! ! Set coefficients in conversion function NO2 = beta1*log(NOx) + beta2; @@ -110,7 +114,7 @@ MODULE m_commonconst DATA NACHTWINTER /0 , 0 , 66, 66, 100, 99, 25, 25, 71, 71, 77, 92, 62, 64, 74, 63, 64, 63, 62, 74, 74, 63, 64, 63/ ! ! Set coefficients for vertical dispersion coefficient; sigma_z = dispg*x**disph - +! (For DISPG, see ops_main DATA statements) DATA DISPH /.82,.82,.76,.76,.67,.76/ ! ! Sedimentation velocity (m/s) needed for plume descent in case of heavy particles, for each particle class. diff --git a/m_commonfile.f90 b/m_commonfile.f90 index 0b12999..dfe66f0 100644 --- a/m_commonfile.f90 +++ b/m_commonfile.f90 @@ -45,6 +45,9 @@ MODULE m_commonfile CHARACTER*12, PARAMETER :: Z0EURFILE = 'z0eur.ops' ! standard file for z0 in Europe CHARACTER*12, PARAMETER :: DVFILE = 'dvepre.ops' ! standard file for diurnal variations CHARACTER*12, PARAMETER :: PSDFILE = 'pmdpre.ops' ! standard file for particle size distributions +CHARACTER*24, PARAMETER :: BUILDINGCLASSFILE = 'buildingClassesTable.dat' ! name of file with definition of parameter classes for building effect +! CHARACTER*24, PARAMETER :: BUILDINGFACTFILE = 'buildingFactorsTable.dat' ! name of file with building effect factors as function of different classes +CHARACTER*24, PARAMETER :: BUILDINGFACTFILE = 'buildingFactorsTable.unf' ! name of unformatted file with building effect factors as function of different classes ! ! CONSTANTS - Standard fileunits ! @@ -63,6 +66,7 @@ MODULE m_commonfile INTEGER*4, PARAMETER :: fu_scratch = 400 ! unit number scratch file INTEGER*4, PARAMETER :: fu_bron = 500 ! unit number sources file INTEGER*4, PARAMETER :: fu_dist = 550 ! unit number distributions file (e.g. diurnal variations, particle size distributions) +INTEGER*4, PARAMETER :: fu_tmp = 560 ! unit number temporary file INTEGER*4, PARAMETER :: fu_recep = 600 ! unit number receptor file INTEGER*4, PARAMETER :: fu_mask = 600 ! unit number mask file INTEGER*4, PARAMETER :: fu_klim = 700 ! unit number meteo statistics file @@ -80,7 +84,7 @@ MODULE m_commonfile CHARACTER*512 :: ctrnam ! name of control file CHARACTER*512 :: indnam ! name of file with progress indicator CHARACTER*512 :: errnam ! name of file with error information -CHARACTER*512 :: logname ! name of log file +CHARACTER*512 :: lognam ! name of log file CHARACTER*512 :: brnam ! name of file with emission sources CHARACTER*512 :: namrecept ! name of file with receptor coordinates @@ -90,6 +94,8 @@ MODULE m_commonfile CHARACTER*512 :: pltnam ! name of plot output file CHARACTER*512 :: dvnam ! name of file with pre-defined diurnal variations +CHARACTER*512 :: buildingClassFilename ! name of file with definition of parameter classes for building effect +CHARACTER*512 :: buildingFactFilename ! name of file with building effect factors as function of different classes CHARACTER*512 :: psdnam ! name of file with pre-defined particle size distributions CHARACTER*512 :: usdvnam ! name of file with user-defined diurnal variations CHARACTER*512 :: uspsdnam ! name of file with user-defined particle size distributions @@ -186,4 +192,58 @@ SUBROUTINE MakeCommonPath(fileentry, filepath, error) RETURN END SUBROUTINE MakeCommonPath +!---------------------------------------------------------------------------------------------------------- +SUBROUTINE MakeMonitorNames(error) + +! Make file names of monitor files; log file "base".log, error file "base".err, process indicator file "base".ind. +! "base" is the name of the input (control) file, without the extension. + +USE m_error +USE m_string + +IMPLICIT NONE +! +! USED VARIABLES +! ctrnam: name of control (input) file +! lognam: name of log file +! indnam: name of progress indicator file +! errnam: name of error file + +! SUBROUTINE ARGUMENTS - OUTPUT +TYPE (TError), INTENT(OUT) :: error ! Error handling record + +! LOCAL VARIABLES +INTEGER*4 :: extpos ! position in control file name where extension starts. +CHARACTER*512 :: base ! base name of monitor files (i.e. control file name without extension) + +! CONSTANTS +CHARACTER*512 :: ROUTINENAAM +PARAMETER (ROUTINENAAM = 'MakeMonitorNames') + +!------------------------------------------------------------------------------------------------------------------------------- + +! Get the base of the control (input) file name (so skip the extension): +extpos = INDEX(ctrnam, '.',.TRUE.) - 1 +CALL CopyStrPart(ctrnam, 1, extpos, base, error) +IF (error%haserror) GOTO 9999 + +! Progress indicator file = base'.ind': +CALL StringMerge(base,'.ind', indnam, error) +IF (error%haserror) GOTO 9999 + +! Log file = base'.log': +CALL StringMerge(base,'.log', lognam, error) +IF (error%haserror) GOTO 9999 + +! Error file = base'.err': +CALL StringMerge(base,'.err', errnam, error) +IF (error%haserror) GOTO 9999 + +RETURN + +9999 CALL ErrorCall(ROUTINENAAM, error) +RETURN + +END SUBROUTINE MakeMonitorNames + END MODULE m_commonfile diff --git a/m_error.f90 b/m_error.f90 index 4dcf20e..850a052 100644 --- a/m_error.f90 +++ b/m_error.f90 @@ -87,6 +87,7 @@ MODULE m_error TYPE (TErrorParam), pointer :: firstparam ! first parameter in error message TYPE (TErrorParam), pointer :: lastparam ! last parameter in error message + LOGICAL :: debug ! if true -> debug parameters are written to screen; only useful for a limited number of receptors and sources END TYPE TError !------------------------------------------------------------------------------------------------------------------------------- @@ -113,11 +114,13 @@ MODULE m_error !------------------------------------------------------------------------------------------------------------------------------- INTERFACE ErrorParam MODULE PROCEDURE error_iparam ! integer*4 parameter + MODULE PROCEDURE error_iaparam ! integer*4 parameter array MODULE PROCEDURE error_lparam ! logical parameter MODULE PROCEDURE error_rparam ! real*4 parameter + MODULE PROCEDURE error_raparam ! real*4 parameter array MODULE PROCEDURE error_sparam ! character*(*) string parameter - MODULE PROCEDURE error_wparam ! character*(*) string parameter, but only first - ! word is written + MODULE PROCEDURE error_wparam ! character*(*) string parameter, but only first word is written + MODULE PROCEDURE error_saparam ! character*(*) string parameter array END INTERFACE !------------------------------------------------------------------------------------------------------------------------------- @@ -298,6 +301,37 @@ SUBROUTINE error_iparam(paramname, value, error) RETURN END SUBROUTINE error_iparam + +!------------------------------------------------------------------------------------------------------------------------------- +! Subroutine error_iaparam +! Purpose Sets values for an integer parameter array. +!------------------------------------------------------------------------------------------------------------------------------- +SUBROUTINE error_iaparam(paramname, value, error) + +!DEC$ ATTRIBUTES DLLEXPORT:: error_iaparam + +! SUBROUTINE ARGUMENTS - INPUT +CHARACTER*(*), INTENT(IN) :: paramname ! parameter name +INTEGER*4, INTENT(IN) :: value(:) ! parameter values + +! SUBROUTINE ARGUMENTS - I/O +TYPE (TError), INTENT(INOUT) :: error ! error object + +! LOCAL VARIABLES +TYPE (TErrorParam), POINTER :: param ! error parameter object +INTEGER*4 :: i ! index into array +!------------------------------------------------------------------------------------------------------------------------------- +IF (.NOT.error%blockparam) THEN + param => make_parameter(paramname, error) + CALL SimpleAppend(value(1), param%stringvalue) + do i = 2,size(value) + CALL SimpleAppend(1,value(i), param%stringvalue) ! prepend 1 space + enddo +ENDIF + +RETURN +END SUBROUTINE error_iaparam + !------------------------------------------------------------------------------------------------------------------------------- ! Subroutine error_lparam ! Purpose Sets values for a logical parameter. @@ -350,6 +384,37 @@ SUBROUTINE error_rparam(paramname, value, error) RETURN END SUBROUTINE error_rparam + +!------------------------------------------------------------------------------------------------------------------------------- +! Subroutine error_raparam +! Purpose Sets values for a real parameter array. +!------------------------------------------------------------------------------------------------------------------------------- +SUBROUTINE error_raparam(paramname, value, error) + +!DEC$ ATTRIBUTES DLLEXPORT:: error_raparam + +! SUBROUTINE ARGUMENTS - INPUT +CHARACTER*(*), INTENT(IN) :: paramname ! +REAL*4, INTENT(IN) :: value(:) ! + +! SUBROUTINE ARGUMENTS - I/O +TYPE (TError), INTENT(INOUT) :: error ! + +! LOCAL VARIABLES +TYPE (TErrorParam), POINTER :: param ! +INTEGER*4 :: i +!------------------------------------------------------------------------------------------------------------------------------- +IF (.NOT.error%blockparam) THEN + param => make_parameter(paramname, error) + CALL SimpleAppend(value(1), 4, param%stringvalue) + do i = 2,size(value) + CALL SimpleAppend(2, value(i), 4, param%stringvalue) ! prepend 2 spaces + enddo +ENDIF + +RETURN +END SUBROUTINE error_raparam + !------------------------------------------------------------------------------------------------------------------------------- ! Subroutine error_sparam ! Purpose Sets values for a string parameter. @@ -437,6 +502,38 @@ SUBROUTINE error_wparam(paramname, value, wordonly, error) RETURN END SUBROUTINE error_wparam +!------------------------------------------------------------------------------------------------------------------------------- +! Subroutine error_saparam +! Purpose Sets values for a string parameter array. +!------------------------------------------------------------------------------------------------------------------------------- +SUBROUTINE error_saparam(paramname, value, error) + +!DEC$ ATTRIBUTES DLLEXPORT:: error_saparam + +! SUBROUTINE ARGUMENTS - INPUT +CHARACTER*(*), INTENT(IN) :: paramname ! +CHARACTER*(*), INTENT(IN) :: value(:) ! + +! SUBROUTINE ARGUMENTS - I/O +TYPE (TError), INTENT(INOUT) :: error ! + +! LOCAL +integer :: i ! index +character(1000) :: str1 ! output string + +!------------------------------------------------------------------------------------------------------------------------------- +str1 = '' +do i = 1,size(value) + str1 = trim(str1) // ' / ' // trim(value(i)) + ! str1 = str1 // '/' // trim(value(i)(1:le_trim(value(i))) + ! str1 = str1(1:len_trim(str1)) // '/' // value(i)(1:len_trim(value(i))) + ! CALL ErrorParam(paramname, value(i), .FALSE., error) +enddo +CALL ErrorParam(paramname, str1, .FALSE., error) + +RETURN +END SUBROUTINE error_saparam + !------------------------------------------------------------------------------------------------------------------------------- ! Subroutine error_call ! Purpose Routinename is added onto the call stack. @@ -478,7 +575,7 @@ END SUBROUTINE error_call !------------------------------------------------------------------------------------------------------------------------------- ! Subroutine write_error -! Purpose Writing out of error message +! Purpose Writing out of error message; if error%haserror = .FALSE. -> issue warning instead of error !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE write_error(unit, error) @@ -507,13 +604,22 @@ SUBROUTINE write_error(unit, error) hascaller = ASSOCIATED(caller) IF (hascaller) THEN length = LEN_TRIM(caller%routinename) - WRITE (unit,'(A, 1X, A)') 'Error in subroutine:', caller%routinename(:length) + IF (error%haserror) THEN + WRITE (unit,'(/,A, 1X, A)') 'Error in subroutine:', caller%routinename(:length) + ELSE + WRITE (unit,'(/,A, 1X, A)') 'Warning in subroutine:', caller%routinename(:length) + ENDIF ENDIF ! ! Write out the error message. ! -WRITE (unit,'(/, A, 1X, A)') 'Error:', error%message +IF (error%haserror) THEN + WRITE (unit,'(/, A, 1X, A)') 'Error:', trim(error%message) +ELSE + WRITE (unit,'(/, A, 1X, A)') 'Warning:', trim(error%message) +ENDIF WRITE (unit, '()') + ! ! Determine the longest parameter. We want all the = signs neatly below each other. ! @@ -538,23 +644,32 @@ SUBROUTINE write_error(unit, error) param => nextparam ENDDO ! -! Write out the remainder of the call routine stack +! Write out the remainder of the call routine stack (only for error) ! -IF (hascaller) THEN - nextcaller => caller%nextcall - IF (ASSOCIATED(nextcaller)) THEN - length = LEN_TRIM(caller%routinename) - WRITE(unit,'(/, 3A)') 'Procedure ''', caller%routinename(1:length), ''' was called by:' - ENDIF - DEALLOCATE(caller) - - DO WHILE (ASSOCIATED(nextcaller)) - caller => nextcaller - nextcaller => caller%nextcall - length = LEN_TRIM(caller%routinename) - WRITE(unit,'(2X, A)') caller%routinename(:length) - DEALLOCATE(caller) - ENDDO +IF (error%haserror) THEN + IF (hascaller) THEN + nextcaller => caller%nextcall + IF (ASSOCIATED(nextcaller)) THEN + length = LEN_TRIM(caller%routinename) + WRITE(unit,'(/, 3A)') 'Procedure ''', caller%routinename(1:length), ''' was called by:' + ENDIF + DEALLOCATE(caller) + + DO WHILE (ASSOCIATED(nextcaller)) + caller => nextcaller + nextcaller => caller%nextcall + length = LEN_TRIM(caller%routinename) + WRITE(unit,'(2X, A)') caller%routinename(:length) + DEALLOCATE(caller) + ENDDO + ENDIF +ENDIF + +! Write message to screen: +IF (error%haserror) THEN + write(*,'(/,/,a,/,/)') '>>>>> An error has occurred; see the error file for more information. <<<<<' +ELSE + write(*,'(/,/,a,/,/)') '>>>>> WARNING; see the log file for more information. <<<<<' ENDIF RETURN diff --git a/m_getkey.f90 b/m_getkey.f90 index 89cb736..de59a43 100644 --- a/m_getkey.f90 +++ b/m_getkey.f90 @@ -73,23 +73,27 @@ MODULE m_getkey ! FUNCTION : GetCheckedKey ! DESCRIPTION : This function checks a string for the name of input parameter. Then the value of the parameter is extracted and ! assigned to it. This function also checks whether the parameter is inside a specified range. If no value is -! extracted a default is set. +! extracted, a default is set. ! INPUTS : parname (character*(*)). Name of the parameter. ! lower (type, type is generic). Lower limit of value allowed. ! upper (type, type is generic). Upper limit of value allowed. -! isrequired (logical) Whether a value is required. If not a default can be assigned. +! isrequired (logical) Whether a value is required. If not, a default can be assigned. ! OUTPUTS : value (type, type is generic) value assigned to the parameter. ! error (TError object). Assigned when an error occurred. ! RESULT : Logical. False if an error was detected. ! REMARK : GetCheckedKey is generic for the following types: ! integer*4 ! real*4 -! REMARK2 : A special checked key instance checks filepaths and has a different profile (isrequired is not passed): -! : parname (character*(*)). Name of the parameter. checkdefine(logical). If flag is set: test whether name was -! entered. -! checkexists(logical) If flag is set: test whether file path is present, otherwise an error is returned. -! value (character*(*)) Output: the path of the file. the parameter. -! error (TError object). Assigned when an error occurred. +! logical +! real*4 +! REMARK2 : A special GetCheckedKey instance (check_exist_file) checks filepaths and has a different argument list (isrequired is not passed): +! INPUTS +! parname (character*(*)) Name of the parameter. +! checkdefine(logical) file name must be defined (must be present on the input line); note that this is not checked if checkexist is .false. +! checkexists(logical) file name must exist +! OUTPUTS +! value (character*(*)) The name of the file +! error (TError object). Assigned when an error occurred. !------------------------------------------------------------------------------------------------------------------------------- INTERFACE GetCheckedKey MODULE PROCEDURE check_range_real @@ -788,12 +792,24 @@ FUNCTION check_exist_file(parname, checkdefine, checkexist, filename, error) USE m_fileutils ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: parname ! -LOGICAL, INTENT(IN) :: checkdefine ! if set and checkexist set, this function -LOGICAL, INTENT(IN) :: checkexist ! if set, this function checks whether filename +CHARACTER*(*), INTENT(IN) :: parname ! name of the parameter +LOGICAL, INTENT(IN) :: checkdefine ! file name must be defined (must be present on the input line); note that this is not checked if checkexist is .false. +LOGICAL, INTENT(IN) :: checkexist ! file name must exist + + ! if checkexist -> if filename empty -> if checkdefine -> error + ! -> if NOT checkdefine -> OK + ! if filename not empty -> file exists -> OK + ! -> file does not exist -> error + ! if NOT checkexist -> OK (no checks) + + ! Special case checkdefine = .TRUE. + ! if checkexist -> if filename empty -> error + ! if filename not empty -> file exists -> OK + ! -> file does not exist -> error + ! if NOT checkexist -> OK (no checks) ! SUBROUTINE ARGUMENTS - OUTPUT -CHARACTER*(*), INTENT(OUT) :: filename ! +CHARACTER*(*), INTENT(OUT) :: filename ! name of the file TYPE (TError), INTENT(OUT) :: error ! error handling record ! RESULT diff --git a/m_ops_building.f90 b/m_ops_building.f90 new file mode 100644 index 0000000..de2724a --- /dev/null +++ b/m_ops_building.f90 @@ -0,0 +1,733 @@ +!------------------------------------------------------------------------------------------------------------------------------- +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . +! +! Copyright (C) 2002 by +! National Institute of Public Health and Environment +! Laboratory for Air Research (RIVM/LLO) +! The Netherlands +!------------------------------------------------------------------------------------------------------------------------------- +module m_ops_building + +implicit none + +! module for simulating building effect by means of a multidimensional table with building effect factors. + +! General setup up of multi dimensional lookup table +! +! 1) Class definition file: +! A file with n parameters at n rows; each row contains a parameter with a generic names of the parameter in the first column, +! followed by a number of columns with representative parameter values for each class. Note that each parameter can have a different number of classes. +! Example file: +! p1 5.0 9.0 16.0 25 50 75 100 +! p2 5.0 9.0 20.0 +! ** +! pn 10 20 30 40 50 60 +! +! Last two parameters must be (source-receptor angle, source-receptor distance) +! +! 2) Lookup table: +! Table with n + 1 columns containing the class indices for n parameters and the associated building effect factor. +! Example lookup table +! 1. last parameter varies first, then last but one, ... THIS IS ESSENTIAL FOR CORRECT READING OF THE DATA! +! 2. ! Last two parameters must be (source-receptor angle, source-receptor distance +! p1 p2 *** pn buildingFact +! 1 1 1 2.20 +! 1 1 2 2.10 +! 1 1 3 1.90 +! 1 1 4 1.85 +! 1 1 5 1.20 +! 1 1 6 1.00 +! 1 2 1 2.30 +! 1 2 2 2.15 +! ....... +! 3 2 5 1.26 +! 3 2 6 1.05 +! +! Note that class i of a parameter corresponds to column i+1 for this parameter in the class definition file. + +private +public mParam, mClass +public Tbuilding, TbuildingEffect +public ops_building_file_names, ops_building_read_tables, ops_building_read_classes, ops_building_read_building_factors, ops_building_get_function, ops_building_get_factor + +integer, parameter :: mParam = 9 ! maximal number of parameters +integer, parameter :: mClass = 100 ! maximal number of classes for any parameter + +! Define parameter names - these must be the same as the parameters as filled into valueArray (see ops_bron_rek) - distance must be last parameter ! +!character(len=200) :: buildingParamNames(3) = (/'hEmis', 'angleSRxaxis', 'distance' /) ! 3 parameters, simple test +character(len=200) :: buildingParamNames(9) = (/'hEmis', 'V_stack', 'D_stack', 'buildingHeight', 'buildingLength', 'buildingWLRatio', 'buildingOrientation', 'angleSRxaxis', 'distance' /) ! 9 parameters +! character(len=200) :: buildingParamNames(7) = (/'hEmis', 'V_stack', 'D_stack', 'buildingHeight', 'buildingLength', 'buildingWLRatio', 'distance' /) ! 7 parameters +! character(len=200) :: buildingParamNames(4) = (/'V_stack', 'buildingHeight', 'hEmis', 'distance' /) ! simple test with 4 parameters + +Type Tbuilding + real :: length ! building length [m] + real :: width ! building width [m] + real :: height ! building height [m] + real :: orientation ! building orientation (degrees w.r.t. North) + real, allocatable :: buildingFactFunction(:,:) ! building effect function (function of source receptor angle, source receptor distance) + integer :: type ! building type for determining distance function for building effect [-]; type = 0 -> no building effect +End Type Tbuilding + +type TbuildingEffect + integer :: nParam ! number of building parameters (read from file) + real, allocatable :: classdefinitionArray(:) ! array with representative class values for each parameter + ! (stored in one-dimensional array: [nClass(1) values for p1, nClass(2) values for p2, ...]) + integer :: nClass(mParam) ! number of classes for each parameter + real :: minClass(mParam) ! minimum of class values for each parameter + real :: maxClass(mParam) ! maximum of class values for each parameter + real, allocatable :: buildingFactArray(:) ! building effect factors for each parameter/class, stored in a one-dimensional array + real, allocatable :: buildingFactAngleSRxaxis(:) ! source receptor angles (w.r.t. x-axis) where to evaluate 2D function of building effect + real, allocatable :: buildingFactDistances(:) ! distances where to evaluate 2D function of building effect +end type TbuildingEffect + +contains + +!----------------------------------------------------------------------------------- +subroutine ops_building_file_names(error) + +! Set standard file names for building effect tables + +USE m_error +USE m_fileutils +USE m_commonfile + +CHARACTER*512, PARAMETER :: ROUTINENAAM = 'ops_building_file_names' + +type(Terror), intent(out) :: error ! error handling record + +! Set standard file names for building effect tables: +CALL MakeCommonPath(BUILDINGCLASSFILE, buildingClassFilename, error) +CALL MakeCommonPath(BUILDINGFACTFILE, buildingFactFilename, error) +if (error%haserror) goto 9999 + +RETURN + +9999 CALL ErrorCall(ROUTINENAAM, error) + +end subroutine ops_building_file_names + +!----------------------------------------------------------------------------------- +subroutine ops_building_read_tables(buildingEffect, error) + +! Read class definition of building parameters and factors for building effect + +use m_error + +CHARACTER*512, PARAMETER :: ROUTINENAAM = 'ops_building_read_tables' + +! Output: +type(tbuildingEffect), intent(out) :: buildingEffect ! structure containing data for building effect +type(Terror), intent(out) :: error ! error handling record + +! Local: +integer :: nClassProd ! product of number of classes for each parameter + +! Read classes for building parameters: +call ops_building_read_classes(mParam, mClass, buildingEffect%classdefinitionArray, buildingEffect%buildingFactAngleSRxaxis, buildingEffect%buildingFactDistances, & + buildingEffect%nParam, buildingEffect%nClass, buildingEffect%minClass, buildingEffect%maxClass, nClassProd, error) +if (error%haserror) goto 9999 + +! Read building factors: +call ops_building_read_building_factors(mClass, buildingEffect%nParam, nClassProd, buildingEffect%nClass, buildingEffect%buildingFactArray, error) +if (error%haserror) goto 9999 + +RETURN + +9999 CALL ErrorCall(ROUTINENAAM, error) + +end subroutine ops_building_read_tables + +!----------------------------------------------------------------------------------- +subroutine ops_building_read_classes(mParam, mClass, & + classdefinitionArray, buildingFactAngleSRxaxis, buildingFactDistances, nParam, nClass, minClass, maxClass, nClassProd, error) + +use m_commonfile, only: buildingClassFilename, fu_tmp +use m_error +use m_fileutils + + CHARACTER*512, PARAMETER :: ROUTINENAAM = 'ops_building_read_classes' + + ! Input: + integer, intent(in) :: mParam ! maximal number of parameters + integer, intent(in) :: mClass ! maximal number of classes for any parameter + + ! Output: + real, allocatable, intent(out) :: classdefinitionArray(:) ! array with representative class values for each parameter + ! (stored in one-dimensional array: [nClass(1) values for p1, nClass(2) values for p2, ...]) + real, allocatable, intent(out) :: buildingFactAngleSRxaxis(:) ! source rceptor angles (w.r.t. x-axis) where to evaluate 2D function of building effect + real, allocatable, intent(out) :: buildingFactDistances(:) ! distances where to evaluate 2D function of building effect + integer, intent(out) :: nParam ! actual number of parameters (read from file) + integer, intent(out) :: nClass(mParam) ! number of classes for each parameter + real , intent(out) :: minClass(mParam) ! minimum of class values for each parameter + real , intent(out) :: maxClass(mParam) ! maximum of class values for each parameter + integer, intent(out) :: nClassProd ! product of number of classes for each parameter + type(Terror), intent(out) :: error ! error handling record + + ! Local: + real :: classdefinitionArrayTemp(mClass*mParam) ! temporary array for reading classdefinitionArray + integer :: iParam ! index of parameter + character(1000) :: line ! line read from file + integer :: ilast ! index of last value in classdefinitionArrayTemp (during reading) + character(100) :: pName ! parameter name + real :: pVals( mClass ) ! representative parameter values for classes for one parameter + integer :: n ! number of values read from file + character(100) :: paramNames(mParam) ! parameter names + integer :: nClassSum ! sum of number of classes for each parameter + + ! Initialisation: + iParam = 0 + ilast = 0 ! index of last value in classdefinitionArrayTemp + + ! Open file: + IF (.NOT. sysopen(fu_tmp, buildingClassFilename, 'r', 'class definition file for building effect', error)) GOTO 9999 + + ! Loop over lines in file: + do + ! Read line from file and split into name and values: + read( fu_tmp, "(a)", end=500 ) line + call split1( mClass, line, pName, pVals, n ) + if ( n == 0 ) then + call SetError('No parameter values found in file ',error) + goto 9998 + else + ! New parameter has been read: + !write(*,'(a30,99(1x,f8.3))') pName, pVals(1:n) + iParam = iParam + 1 + if (iParam .gt. mParam) then + call SetError('Too many parameters in file ',error) + call ErrorParam('maximal number of parameters allowed', mParam, error) + goto 9998 + endif + + ! Set number of classes for this parameter and fill paramNames and classdefinitionArrayTemp: + nClass(iParam) = n + paramNames(iParam) = pName + classdefinitionArrayTemp(ilast+1:ilast+n) = pVals(1:n) ! note that pVals has to be sorted .. check? + minClass(iParam) = minval(pVals(1:n)) + maxClass(iParam) = maxval(pVals(1:n)) + ilast = ilast + n + endif + enddo +500 continue + close( fu_tmp ) + + ! Now we know the number of parameters and the number of classes: + nParam = iParam + nClassSum = sum(nClass(1:nParam)) + nClassProd = product(nClass(1:nParam)) + + ! Check: + if (ilast .ne. nClassSum) then + write(*,*) 'Internal programming error in ', ROUTINENAAM + write(*,*) 'ilast = ',ilast, ' nClassSum = ',nClassSum + write(*,*) 'ilast must be nClassSum ' + stop + endif + + ! Check parameter names: + if (any(paramNames(1:nParam) .ne. buildingParamNames)) then + call SetError('Error in parameter names ',error) + call ErrorParam('parameter names in file ', paramNames(1:nParam), error) + call ErrorParam('expected parameter names', buildingParamNames, error) + goto 9999 + endif + + ! **** Allocate memory and fill class definition table ***** + + allocate(classdefinitionArray(nClassSum)) + classdefinitionArray = classdefinitionArrayTemp(1:nClassSum) + + ! Allocate and fill array with source rceptor angles (w.r.t. x-axis) used to evaluate building factors + ! (one but last parameter in classdefinitionArray): + allocate(buildingFactAngleSRxaxis(nClass(nParam-1))) + buildingFactAngleSRxaxis = classdefinitionArray(nClassSum - nClass(nParam) - nClass(nParam-1) + 1 : nClassSum - nClass(nParam)) + + ! Allocate and fill array with distances used to evaluate building factors + ! (last parameter in classdefinitionArray): + allocate(buildingFactDistances(nClass(nParam))) + buildingFactDistances = classdefinitionArray(nClassSum - nClass(nParam) + 1 : nClassSum) + + !write(*,*) 'ops_building_read_classes/buildingFactDistances:',buildingFactDistances + !write(*,*) 'ops_building_read_classes/buildingFactAngleSRxaxis:',buildingFactAngleSRxaxis + + RETURN + +9998 CALL ErrorParam('line read from file', trim(line), error) + +9999 CALL ErrorParam('file name', buildingClassFilename, error) +CALL ErrorCall(ROUTINENAAM, error) + +end subroutine ops_building_read_classes + +!----------------------------------------------------------------------------------------- +subroutine ops_building_read_building_factors(mClass, nParam, nClassProd, nClass, buildingFactArray, error) + +use m_commonfile, only: buildingFactFilename, fu_tmp +use m_error +use m_fileutils + + ! **** Read factors for building effects table from file ***** + + CHARACTER*512, PARAMETER :: ROUTINENAAM = 'ops_building_read_building_factors' + + ! Input: + integer, intent(in) :: mClass ! maximal number of classes for any parameter + integer, intent(in) :: nParam ! actual number of parameters (read from file) + integer, intent(in) :: nClassProd ! product of number of classes for each parameter + integer, intent(in) :: nClass(:) ! number of classes for each parameter + + + ! Output: + real, allocatable, intent(out) :: buildingFactArray(:) ! building effect factors for each parameter/class, stored in a one-dimensional array + type(Terror), intent(out) :: error ! error handling record + + ! Local: + character(1000) :: line ! line read from file + integer :: iLine ! index of line read (includes header line) + integer :: iParam ! index of parameter + character(100) :: colNames(nParam+1) ! column names in building effect table + integer :: iClassRead(nParam) ! class indices read from file + real :: buildingFactInput ! buiding effect factor read from input file + character(len = 100) :: fmt ! format for writeing output to screen + integer :: i ! index (debug) + integer :: iClassExpected(nParam) ! class indices as expected by the order in which SILUPM wants it (last index fastest, then last but one, ...) + logical :: shiftNext ! shift next parameter index (counting from last to first parameter) + logical :: read_unformatted = .true. ! read unformatted file (is much faster than formatted file) + + ! Allocate memory for building effects table: + allocate(buildingFactArray(nClassProd)) + + if (read_unformatted) then + ! Open file, read array with building factors and close file: + IF (.NOT. sysopen(fu_tmp, buildingFactFilename, 'rb', 'file with building effect factors', error)) GOTO 9999 + read(fu_tmp) buildingFactArray + close(fu_tmp) + + else + !------------------------------------------------------------------------------------------------------ + ! This part of the subroutine is not used anymore in OPS; there is a separate program to convert + ! the ASCII table into an unformatted file which read musch faster. This separate program uses + ! the code below. + !------------------------------------------------------------------------------------------------------ + + ! Construct format for write to screen + fmt = '(i6,": ", (1x,i4),1x,f8.3)' + write(fmt(10:11),'(i2)') nParam + + ! Open file: + IF (.NOT. sysopen(fu_tmp, buildingFactFilename, 'r', 'file with building effect factors', error)) GOTO 9999 + + ! Initialise: + iClassExpected = 1 + + ! Read file until end-of-file: + iLine = 0 + do + read( fu_tmp, "(a)", end=510 ) line + ! print *,line + + ! Skip empty line: + if (len_trim(line) > 0) then + iLine = iLine + 1 + if (iLine .eq. 1) then + ! Header line + read( line, *) colNames(1:nParam+1 ) + !write(*,*) 'Table ' + !write(*,'(99(1x,a))') colNames(1:nParam+1 ) + + ! Check parameter names: + if (any(colNames(1:nParam) .ne. buildingParamNames)) then + call SetError('Error in parameter names ',error) + call ErrorParam('parameter names in file ', colNames(1:nParam), error) + call ErrorParam('expected parameter names', buildingParamNames, error) + goto 9999 + endif + + else + ! Check number of lines read: + if (iLine-1 .gt. nClassProd) then + call SetError('number of lines read from file larger than expected ',error) + call ErrorParam('line number ', iLine, error) + call ErrorParam('number of lines expected', nClassProd+1, error) ! including header line + goto 9998 + endif + + ! Split line into nParam integer class indices and (last value) buiding effect factor: + call split2( line, nParam, iClassRead, buildingFactInput) + + ! Check class indices read from file: + if (any(iClassExpected .ne. iClassRead)) then + call SetError('Incorrect set of class indices.','Last index must vary fastest, then last but one, ...',error) + call ErrorParam('line number ', iLine, error) + call ErrorParam('expected class indices', iClassExpected, error) + goto 9998 + endif + + ! Shift to next set of class indices ((must be in order for routine SILUPM: last index varies fast, then last but one, ...): + shiftNext = .true. + iParam = nParam + do while (shiftNext .and. iParam .ge. 1) + iClassExpected(iParam) = iClassExpected(iParam) + 1 + + ! If this parameter exceeds the number of classes -> reset to 1 and shift to next parameter: + if (iClassExpected(iParam) .gt. nClass(iParam)) then + iClassExpected(iParam) = 1 + shiftNext = .true. + else + shiftNext = .false. + endif + iParam = iParam - 1 + enddo + + ! Fill building effect factor into buildingFactArray; + ! order of lines is essential here and has been checked above (iClassRead = iClassExpected). See definition SILUPM for 2D array ((y(x1(i), x2(j)), j=1:NTAB(2)), i=1:NTAB(1)) + ! if (iLine .le. 3) write(*,fmt) iLine-1,iClassRead(1:nParam),buildingFactInput + buildingFactArray(iLine-1) = buildingFactInput + endif ! iLine .eq. 1 + endif ! len_trim(line) > 0 + enddo +510 continue + close( fu_tmp ) + + ! write(*,'(a)') '............................' + ! write(*,fmt) iLine-1,iClassRead(1:nparam),buildingFactInput + + ! Check number of lines read: + if (iLine-1 .ne. nClassProd) then + call SetError('number of lines read from file smaller than expected ',error) + call ErrorParam('line number ', iLine, error) + call ErrorParam('number of lines expected', nClassProd+1, error) ! including header line + goto 9999 + endif + endif ! read_unformatted + + ! **** Printing/checking building effects table ***** + if (.FALSE.) then + do i = 1,nClassProd + print *, i, buildingFactArray(i) + enddo + endif + + RETURN + +9998 CALL ErrorParam('line read from file', trim(line), error) + +9999 CALL ErrorParam('file name', buildingFactFilename, error) +CALL ErrorCall(ROUTINENAAM, error) + +end subroutine ops_building_read_building_factors + +!----------------------------------------------------------------------------------------- +! subroutine ops_building_get_function(nParam, valueArray, nClass, classdefinitionArray, buildingFactArray, buildingFactFunction, NTAB, NDEG, LUP, IOPT, EOPT) +subroutine ops_building_get_function(nParam, valueArray, nClass, classdefinitionArray, buildingFactAngleSRxaxis, buildingFactDistances, buildingFactArray, buildingFactFunction,error) + + ! Get 2D building effect function (function of source-receptor angle and distance to source) for a specific set of building parameter values in valueArray; + ! interpolate this factor from factors in buildingFactArray, based on the location of valueArray within the table classdefinitionArray. + + use m_error + + CHARACTER*512, PARAMETER :: ROUTINENAAM = 'ops_building_get_function' + + ! Input: + integer, intent(IN) :: nParam ! number of parameters + integer, intent(IN) :: nClass(nParam) ! number of classes for each parameter + real, intent(IN) :: classdefinitionArray(:) ! array with representative class values for each parameter + real, intent(IN) :: buildingFactAngleSRxaxis(:) ! source-receptor angles (w.r.t. x-axis) where to evaluate 2D building effect function + real, intent(IN) :: buildingFactDistances(:) ! distances where to evaluate 2D building effect function + real, intent(IN) :: buildingFactArray(:) ! building effect factors for each parameter/class. + + ! Input/output: + real, intent(INOUT) :: valueArray(nParam) ! array with set of parameter values for specific building (output: values outside table are moved to boundaries of table) + + ! Output: + real, allocatable, intent(OUT) :: buildingFactFunction(:,:) ! 2D buiding effect function for specific building (function of angle, distance) + type(Terror), intent(out) :: error ! error handling record + + ! Arguments for SILUPM + ! Local variables for SILUPM + integer :: NTAB(2*nParam+1) + integer :: NDEG(nParam) + integer :: LUP(nParam) + integer :: IOPT(3) ! options used for output of SILUPM + real :: EOPT(6*nParam) ! error estimate + + ! Local: + integer :: iParam ! parameter index + integer :: ix, iy ! loop indices + + ! print *, "Building effects table from within subroutine getbuildingEffect" + ! do ix = 1,size(buildingFactArray) + ! print *, ix, buildingFactArray(ix) + ! enddo + +! ! Interpolate multidimensional table: +! ! CALL SILUPM(NDIM, X, Y, NTAB, XT, YT, NDEG, LUP, IOPT, EOPT) +! ! NDIM = nParam +! ! X = ValueArray (input for a specific building) +! ! Y = buildingFactFunction(ix,iy) (output) +! ! NTAB = number of values (classes) for each parameter + extra spzce needed for SILUPM +! ! XT = class parameter values, stored in a one-dimensional array (NTAB(1) values for p1, NTAB(2) values for p2, ...) = classdefinitionArray +! ! YT = building factors for each parameter/class, stored in a one-dimensional array ; see doc SILUPM = buildingFactArray +! ! NDEG = degree of polynomial used for interpolation (= 1 -> linear interpolation). +! ! LUP = type of lookup method (binary search or sequntial search, see doc SILUPM) +! ! IOPT = options used for output + + + NTAB(1:nParam) = nClass(1:nParam) + NTAB(nParam+1) = 0 ! as required by SILUPM + NDEG = 1 + LUP = 1 ! binary search + + ! Set IOPT: + IOPT(1) = 1 + !IOPT(2) = 0 + !IOPT(3) = 0 + IOPT(2) = 6*nParam; ! size(EOPT) + IOPT(3) = 0 + + ! Loop over distances for building effect function: + allocate(buildingFactFunction(size(buildingFactAngleSRxaxis),size(buildingFactDistances))) + + ! write(*,*) '===================================================================================' + ! write(*,*) 'ops_building_get_function/valueArray = ',ValueArray + ! write(*,*) 'ops_building_get_function/buildingFactAngleSRxaxis: ', buildingFactAngleSRxaxis + ! write(*,*) 'ops_building_get_function/buildingFactDistances: ', buildingFactDistances + ! write(*,*) 'ops_building_get_function/classdefinitionArray: ',classdefinitionArray + ! write(*,*) 'ops_building_get_function/nParam:',nParam + ! write(*,*) 'ops_building_get_function/buildingFactArray:',buildingFactArray ! can be very large + + ! Loop over angles and distances for building effect function: + do iy = 1,size(buildingFactDistances) + do ix = 1,size(buildingFactAngleSRxaxis) + + ! Put current angle, distance as last two values in valueArray: + valueArray(nParam-1) = buildingFactAngleSRxaxis(ix) + valueArray(nParam) = buildingFactDistances(iy) + + ! Look up building factor in table and put factor into buildingFactFunction(ix,iy): + CALL SILUPM(nParam, ValueArray, buildingFactFunction(ix,iy), NTAB, classdefinitionArray, buildingFactArray, NDEG, LUP, IOPT, EOPT) + enddo + enddo + + ! do ix = 1,size(buildingFactAngleSRxaxis) + ! write(*,*) 'ops_building_get_function/buildingFactFunction for angle ',buildingFactAngleSRxaxis(ix),'degrees : ', buildingFactFunction(ix,:) + ! enddo + ! write(*,*) '===================================================================================' + + if (IOPT(1) .ne. 0) then + if (IOPT(1) .eq. 1) then + call SetError('Error in look up in table of building factors; parameter values outside domain of the table ',error) + else + call ErrorParam('error status (see documentation netlib/SILUPM) ', IOPT(1), error) + endif + call ErrorParam('parameter names ', buildingParamNames, error) + call ErrorParam('parameter values ', valueArray, error) + goto 9999 + endif + + RETURN + +9999 CALL ErrorCall(ROUTINENAAM, error) + +end subroutine ops_building_get_function + +!------------------------------------------------------------------------------------------------------------------------------- +! Copyright by +! National Institute of Public Health and Environment +! Laboratory for Air Research (RIVM/LLO) +! The Netherlands +! No part of this software may be used, copied or distributed without permission of RIVM/LLO (2002) +! +! SUBROUTINE +! NAME : %M% +! SCCS (SOURCE) : %P% +! RELEASE - LEVEL : %R% - %L% +! BRANCH - SEQUENCE : %B% - %S% +! DATE - TIME : %E% - %U% +! WHAT : %W%:%E% +! AUTHOR : Sjoerd van Ratingen +! FIRM/INSTITUTE : RIVM/LLO +! LANGUAGE : FORTRAN-77/90 +! DESCRIPTION : Returns closest and interpolated building effect based on "buildingEffectTable", +! DESCRIPTION : given a source catergory and a distance from source to receptor. +! EXIT CODES : +! FILES I/O DEVICES : +! SYSTEM DEPENDENCIES : HP Fortran +! CALLED FUNCTIONS : +! UPDATE HISTORY : +!------------------------------------------------------------------------------------------------------------------------------- +SUBROUTINE ops_building_get_factor(buildingType, angle_SR_xaxis, dist, buildingFactAngleSRxaxis, buildingFactDistances, buildingFactFunction, buildingFact) + +IMPLICIT NONE + +! Get building effect factor for a specified distance from source, given a building effect function (function of distance). +! Note the cut-off value of 50 m from the source. + +! CONSTANTS +CHARACTER*512 :: ROUTINENAAM ! +PARAMETER (ROUTINENAAM = 'ops_building_get_factor') + +! SUBROUTINE ARGUMENTS - INPUT +INTEGER, INTENT(IN) :: buildingType ! = 0 -> no building effect (factor = 1) +REAL*4, INTENT(IN) :: angle_SR_xaxis ! angle between source-receptor vector and x-axis (needed for building effect) [degrees] +REAL*4, INTENT(IN) :: dist ! distance between source and receptor +REAL*4, INTENT(IN) :: buildingFactDistances(:) ! distances for which building effect function has been computed +REAL*4, INTENT(IN) :: buildingFactAngleSRxaxis(:) ! source receptor angles (w.r.t. x-axis) for which building effect function has been computed +REAL*4, INTENT(IN) :: buildingFactFunction(:,:) ! 2D building effect function (function of angle, distance) + +! SUBROUTINE ARGUMENTS - OUTPUT +REAL*4, INTENT(OUT) :: buildingFact ! building effect factor interpolated between (angle, distance) values in buildingFactFunction + +! LOCAL VARIABLES +REAL :: distcor ! corrected distance for distances below cut-off distance; for these distances take the effect at the cut-off distance + +!------------------------------------------------------------------------------------------------------------------------------- +IF (buildingType .eq. 0) THEN + buildingFact = 1.0 +ELSE + + ! Use first distance in table as cut-off distance; below this value the building factor is constant: + distcor = max(dist,buildingFactDistances(1)) + + ! If source receptor distance larger than largest distance in table -> no building effect; else interpolate building factor from 2d table: + + if (distcor > buildingFactDistances(size(buildingFactDistances))) then + buildingFact = 1.0 + else + buildingFact = interpol_2d(buildingFactAngleSRxaxis,buildingFactDistances,buildingFactFunction,size(buildingFactAngleSRxaxis),size(buildingFactDistances),angle_SR_xaxis,distcor) + endif + ! write(*,*) 'interpolation: ',angle_SR_xaxis, dist,distcor,buildingFact +END IF + +END SUBROUTINE ops_building_get_factor + +!--------------------------------------------------------- +real function interpol_2d(tabx,taby,f,nx,ny,x,y) + +! 2D (bilinear) interpolation + +implicit none + +integer, intent(in) :: nx ! length of array tabx +integer, intent(in) :: ny ! length of array taby +real , intent(in) :: tabx(nx) ! array of table entries, x dimension +real , intent(in) :: taby(ny) ! array of table entries, y dimension +real , intent(in) :: f(nx,ny) ! function values +real , intent(in) :: x ! x value where to interpolate +real , intent(in) :: y ! y value where to interpolate + +integer :: i,ix,iy ! array indices +real :: x_intp,y_intp ! 1D interpolation factors + +! Check if outside tabel boundaries (normally this should not occur, because values have been shifted +! inside table boundaries before call -> normal error handling not needed): +if (x < tabx(1) .or. x > tabx(nx)) then + write(*,*) ' ' + write(*,*) ' error: x index outside table' + write(*,*) ' boundaries: ',tabx(1), tabx(nx) + write(*,*) ' value : ',x + stop +endif +if (y < taby(1) .or. y > taby(ny)) then + write(*,*) ' ' + write(*,*) ' error: y index outside table' + write(*,*) ' boundaries: ',taby(1), taby(ny) + write(*,*) ' value : ',y + stop +endif + +! Find index ix, such that tabx(ix) < x <= tabx(ix+1) +! Note: first interval includes left boundary: tabx(1) <= x <= tabx(2) +do i = 1,nx-1 + if (x <= tabx(i+1)) then + ix = i + exit + endif +enddo + +! Find index iy, such that taby(iy) < y <= taby(iy+1) +! Note: first interval includes left boundary: taby(1) <= y <= taby(2) +do i = 1,ny-1 + if (y <= taby(i+1)) then + iy = i + exit + endif +enddo + +! Interpolation factors in x- and y-direction: +x_intp = (x-tabx(ix))/(tabx(ix+1)-tabx(ix)) +y_intp = (y-taby(iy))/(taby(iy+1)-taby(iy)) + +! Interpolate between four corner values: +interpol_2d = (1-x_intp)*(1-y_intp)*f(ix,iy) + x_intp*(1-y_intp)*f(ix+1,iy) + x_intp*y_intp*f(ix+1,iy+1) + (1-x_intp)*y_intp*f(ix,iy+1) + +end function interpol_2d + +!------------------------------------------------------------------------------------------- +subroutine split1( mClass, line, pName , pVals, n ) + + implicit none + + ! Input: + integer, intent(IN) :: mClass ! maximal number of classes for any parameter + character(*), intent(in) :: line ! line read from file with parameter names and parameter values + + ! Output: + character(100), intent(out) :: pName ! parameter name + real, intent(out) :: pVals(*) ! parameter values + integer, intent(out) :: n ! number of parameter values read + + ! Local + character*100 :: cbuf( mClass ) + integer :: m + + ! Read word for word from line: + n = 1 + do + read( line, *, end=100) cbuf( 1 : n) ! !! (See Appendix for why buf is used here) + read(cbuf(1),*) pName + do m = 2,n + read(cbuf(m),*) pVals(m-1) + !print *, pVals(m) + enddo + n = n + 1 + enddo +100 continue + n = n - 1 ! length of cbuf + n = n - 1 ! number of reals behind first column with parameter name +end subroutine split1 + +!------------------------------------------------------------------------------------------- +subroutine split2( line, nParam, iClassRead, buildingFactInput) + + implicit none + + ! Input: + character(*), intent(in) :: line ! line read from file with class indices for each parameter and corresponding building effect factor + integer, intent(in) :: nParam ! number of parameters + + ! Output: + integer, intent(out) :: iClassRead(nParam) ! class indices for each parameter + real, intent(out) :: buildingFactInput ! buiding effect factor, read from input + + ! Local variables: + character*8 :: cbuf( nParam+1 ) + integer :: iParam + + ! Read data from line: + read( line, *) (iClassRead(iParam), iParam = 1,nParam), buildingFactInput + + end subroutine split2 + + end module m_ops_building diff --git a/m_ops_emis.f90 b/m_ops_emis.f90 new file mode 100644 index 0000000..d0e9e3f --- /dev/null +++ b/m_ops_emis.f90 @@ -0,0 +1,848 @@ +!------------------------------------------------------------------------------------------------------------------------------- +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . +! +! Copyright (C) 2002 by +! National Institute of Public Health and Environment +! Laboratory for Air Research (RIVM/LLO) +! The Netherlands +!------------------------------------------------------------------------------------------------------------------------------- +module m_ops_emis + +! Emission module, contains subroutines to read emissions. + +implicit none + +PRIVATE ! default for module +PUBLIC :: ops_emis_read_header, ops_emis_read_annual1 + +contains + +!---------------------------------------------------------------------------------------------------------------------------------- +SUBROUTINE ops_emis_read_header(fu_bron, brn_version, VsDs_opt, nrec, numbron, error) + +! Read header from the emission file (brn-file; brn << bron = source)) and return information of the version of the source file (BRN-VERSION). +! The header may contain multiple lines which start with "!" in column 1. +! no BRN-VERSION header -> fixed format +! BRN-VERSION 0 -> fixed format +! BRN-VERSION 1 -> free format +! BRN-VERSION 2 -> free format, include stack parameters D_stack, V_stack, Ts_stack. +! BRN-VERSION 3 -> free format, include stack parameters D_stack, V_stack, Ts_stack, building type +! The file pointer is left at start of the first data record. + +USE m_error +USE m_fileutils + +IMPLICIT NONE + +! CONSTANTS +CHARACTER*512 :: ROUTINENAAM +PARAMETER (ROUTINENAAM = 'ops_emis_read_header') + +! SUBROUTINE ARGUMENTS - INPUT +INTEGER, INTENT(IN) :: fu_bron ! file unit brn-file (emission file) + +! SUBROUTINE ARGUMENTS - OUTPUT +INTEGER, INTENT(OUT) :: brn_version ! version of emission file +LOGICAL, INTENT(OUT) :: VsDs_opt ! read stack parameters Ds/Vs/Ts from source file +INTEGER, INTENT(OUT) :: nrec ! number of records read (= number of records in header) +INTEGER, INTENT(OUT) :: numbron ! number of (selected) sources (initial value = 0) +TYPE (TError), INTENT(OUT) :: error ! Error handling record + +! LOCAL VARIABLES +LOGICAL :: end_of_info ! end of info has been reached +CHARACTER*512 :: cbuf ! character buffer, used to store an emission record +CHARACTER*180 :: word ! word read from character buffer +INTEGER :: ierr ! error status +INTEGER :: idum ! dummy integer read from first header line +INTEGER :: brn_version_read ! source version, read from first line of header + +!------------------------------------------------------------------------------------------------------------------------------- + +! Initialisation: +numbron = 0 +nrec = 0 +end_of_info = .FALSE. + +! Default (if no ! BRN-VERSION can be found) -> old brn-file, no stack parameters: +brn_version = 0 +VsDs_opt = .FALSE. + +! Read first header line: +CALL sysread(fu_bron, cbuf, end_of_info, error) +nrec = nrec + 1 +IF (error%haserror) GOTO 9999 + +! If first line is a line with first word a number (no header line), backspace the file: +READ (cbuf, '(i4)', IOSTAT = ierr) idum +if (ierr .eq. 0) then + backspace(fu_bron) + nrec = nrec - 1 +endif + +! Get version from first header line: +IF (cbuf(1:1) .EQ. "!") THEN + READ (cbuf(2:len_trim(cbuf)),*,IOSTAT = ierr) word, brn_version_read + if (ierr .eq. 0) then + if (word .EQ. "BRN-VERSION") then + brn_version = brn_version_read + VsDs_opt = (brn_version .GE. 2) + CALL check_isource2('', 0, 4, brn_version, error) + if (error%haserror) goto 9999 + else + CALL SetError('Cannot find BRN-VERSION in first line of header', error) + goto 9999 + endif + else + call SetError('Error while reading BRN-VERSION version_number in first line of header', error) + goto 9999 + endif + + ! Read rest of header lines: + DO WHILE (.NOT. end_of_info) + CALL sysread(fu_bron, cbuf, end_of_info, error) + nrec = nrec + 1 + IF (error%haserror) GOTO 9999 + IF (cbuf(1:1) .NE. "!") THEN + end_of_info = .TRUE. + + ! First real emission record has been reached, so we backspace 1 line: + backspace(fu_bron) + nrec = nrec - 1 + ENDIF + ENDDO +ENDIF + +RETURN + +9999 CALL ErrorParam('emission record', cbuf, error) +CALL ErrorParam('record nr. in emission file', nrec, error) +CALL ErrorCall(ROUTINENAAM, error) + +END SUBROUTINE ops_emis_read_header + +!---------------------------------------------------------------------------------------------------------------------------------- +SUBROUTINE ops_emis_read_annual1(fu_bron, icm, check_psd, presentcode, brn_version, VsDs_opt, nrec, numbron, building_present1, & + mm, x, y, qob, qww, hbron, diameter, szopp, D_stack, V_stack, Ts_stack, emis_horizontal, building, ibtg, ibroncat, iland, idgr, end_of_file, error) + +! Read one data line from the emission file (brn-file; brn << bron = source)) and return emission parameters. +! Emission parameters that lie outside a specified range generate an error. +! This subroutine supports old type of emission files (with no BRN-VERSION header or BRN-VERSION 1 +! both in fixed format (old type of brn-files) and free format and extended free format (with V_stack, D_stack, Ts_stack) . + +USE m_error +USE m_fileutils +USE m_geoutils +USE m_commonconst, only: EPS_DELTA, HUMAX, MAXDISTR, ncolBuildingEffectTable +USE Binas, only: T0 +use m_ops_utils, only: is_missing +use m_ops_building + +IMPLICIT NONE + +! CONSTANTS +CHARACTER*512 :: ROUTINENAAM +PARAMETER (ROUTINENAAM = 'ops_emis_read_annual1') + +! SUBROUTINE ARGUMENTS - INPUT +INTEGER, INTENT(IN) :: fu_bron ! file unit brn-file (emission file) +INTEGER, INTENT(IN) :: icm ! component nummer +LOGICAL, INTENT(IN) :: check_psd ! check whether particle size distribution has been read +LOGICAL, INTENT(IN) :: presentcode(MAXDISTR,4) ! which distribution codes are present + ! presentcode(:,1): diurnal variations + ! presentcode(:,2): particle size distributions + ! presentcode(:,3): user-defined diurnal variation + ! presentcode(:,4): user-defined particle size distributions +INTEGER, INTENT(IN) :: brn_version ! version of emission file +LOGICAL, INTENT(IN) :: VsDs_opt ! read stack parameters Ds/Vs/Ts from source file + +! SUBROUTINE ARGUMENTS - INPUT/OUTPUT +INTEGER, INTENT(INOUT) :: nrec ! record number of source file +INTEGER, INTENT(INOUT) :: numbron ! number of (selected) source +LOGICAL, INTENT(INOUT) :: building_present1 ! at least one building is present in the source file + +! SUBROUTINE ARGUMENTS - OUTPUT +INTEGER, INTENT(OUT) :: mm ! source identification number [-] +REAL , INTENT(OUT) :: x ! x coordinate of source location (RDM [m]) +REAL , INTENT(OUT) :: y ! y coordinate of source location (RDM [m]) +REAL , INTENT(OUT) :: qob ! emission strength [g/s] +REAL , INTENT(OUT) :: qww ! heat content [MW] +REAL , INTENT(OUT) :: hbron ! emission height [m] +REAL , INTENT(OUT) :: diameter ! diameter area source (NOT stack diameter) [m] +REAL , INTENT(OUT) :: szopp ! deviation emission height for area source = initial sigma_z [m] +real , INTENT(OUT) :: D_stack ! diameter of the stack [m] +real , INTENT(OUT) :: V_stack ! exit velocity of plume at stack tip [m/s] +real , INTENT(OUT) :: Ts_stack ! temperature of effluent from stack [K] +logical, INTENT(OUT) :: emis_horizontal ! horizontal outflow of emission +type(Tbuilding), INTENT(OUT) :: building ! structure with building parameters +INTEGER, INTENT(OUT) :: ibtg ! diurnal emission variation code [-] +INTEGER, INTENT(OUT) :: ibroncat ! emission category code [-] +INTEGER, INTENT(OUT) :: iland ! country/area code [-] +INTEGER, INTENT(OUT) :: idgr ! particle size distribution code [-] +LOGICAL, INTENT(OUT) :: end_of_file ! end of file has been reached +TYPE (TError), INTENT(OUT) :: error ! Error handling record + +! LOCAL VARIABLES +INTEGER :: ierr ! I/O error value +REAL :: gl ! x coordinate of source location (longitude [degrees]) +REAL :: gb ! y coordinate of source location (latitude [degrees]) +CHARACTER*512 :: cbuf ! character buffer, used to store an emission record +real :: Ts_stack_C ! temperature of effluent from stack [C] + +!------------------------------------------------------------------------------------------------------------------------------- +100 FORMAT (i4, 2f8.3, e10.3, f7.3, f6.1, f7.0, f6.1, 4i4) ! format for reading fixed format file with lon-lat coordinates +150 FORMAT (i4, 2f8.0, e10.3, f7.3, f6.1, f7.0, f6.1, 4i4) ! format for reading fixed format file with RDM coordinates + +! write(*,*) 'ops_emis_read_annual1, fu_bron, brn_version, VsDs_opt: ', fu_bron, brn_version, VsDs_opt + +! Default no horizontal outflow, no exit velocity/stack diameter/effluent gas temperature, no building +emis_horizontal = .FALSE. +D_stack = -999.0 +V_stack = -999.0 +Ts_stack = -999.0 +building%length = -999.0 +building%width = -999.0 +building%height = -999.0 +building%orientation = -999.0 + +! Read string cbuf from emission file: +CALL sysread(fu_bron, cbuf, end_of_file, error) +IF (error%haserror) GOTO 9999 + +IF (.NOT. end_of_file) THEN + IF (brn_version .GE. 1) THEN + !************************************************************************* + ! New brn-file, free format + ! BRN-VERSION 1 -> no D_stack, V_stack, Ts_stack + ! BRN-VERSION 2 -> include D_stack, V_stack, Ts_stack + ! BRN-VERSION 3 -> include D_stack, V_stack, Ts_stack, building%type + ! BRN-VERSION 4 -> free format, include include D_stack, V_stack, Ts_stack, building%length, building%width, building%height, building%orientation + !************************************************************************* + idgr=-999 + + ! Read emission line: + IF (VsDs_opt) then + IF (brn_version .GE. 4) THEN + READ (cbuf, *, IOSTAT = ierr) mm, x, y, qob, qww, hbron, diameter, szopp, D_stack, V_stack, Ts_stack_C, ibtg, ibroncat, iland, idgr, & + building%length, building%width, building%height, building%orientation + + ! Building orientation must be between 0 and 180 degrees: + if (.not. is_missing (building%orientation)) building%orientation = modulo(building%orientation, 180.0) + + ! Set flag if one building is present: + if (.not. building_present1) building_present1 = (.not. (is_missing(building%length) .or. is_missing(building%width) .or. is_missing(building%height) .or. is_missing(building%orientation))) + + ELSEIF (brn_version .EQ. 3) THEN + READ (cbuf, *, IOSTAT = ierr) mm, x, y, qob, qww, hbron, diameter, szopp, D_stack, V_stack, Ts_stack_C, ibtg, ibroncat, iland, idgr, building%type + + ELSE + READ (cbuf, *, IOSTAT = ierr) mm, x, y, qob, qww, hbron, diameter, szopp, D_stack, V_stack, Ts_stack_C, ibtg, ibroncat, iland, idgr + ENDIF + + ! Negative V_stack in input -> horizontal outflow (except V_stack = -999 -> missing value): + if (V_stack .lt. 0.0 .and. .not. is_missing(V_stack)) then + V_stack = -V_stack + emis_horizontal = .TRUE. + endif + + ELSE + READ (cbuf, *, IOSTAT = ierr) mm, x, y, qob, qww, hbron, diameter, szopp, ibtg, ibroncat, iland, idgr + ENDIF + ! write(*,*) 'ops_read_source VsDs_opt = ',VsDs_opt + ! write(*,'(a,i6,10(1x,e12.5),4(1x,i4),1x,l6)') 'ops_read_source a ',mm, x, y, qob, qww, hbron, diameter, szopp, D_stack, V_stack, Ts_stack_C, ibtg, ibroncat, iland, idgr,emis_horizontal + ! write(*,*) 'ops_read_source a, nrec, ierr = ',nrec,ierr + + IF (ierr == 0) THEN + + ! Convert lon-lat coordinates to RDM coordinates; lon-lat coordinates are detected if the value read for y is less than 90 degrees: + IF ( abs(y) .LT. 90 ) THEN + gb = y + gl = x + CALL geo2amc(gb, gl, x, y) ! (x,y) in km + x = AINT(x*1000.) ! [m] + y = AINT(y*1000.) ! [m] + ENDIF + ENDIF + ELSE + !******************************************************* + ! Old brn-file, fixed format + ! Reading of D_stack, V_stack, Ts_stack not supported. + !******************************************************* + ! In the old format, if there is a dot at position 9, coordinates are assumed to be lon-lat + IF ( cbuf(9:9) .EQ. '.' ) THEN + + ! Read source record with lon-lat coordinates (gl,gb) + ! "g" << geographical coordinates; "l" << lengtegraad = longitude, "b" << breedtegraad = latitude + READ (cbuf, 100, IOSTAT = ierr) mm, gl, gb, qob, qww, hbron, diameter, szopp, ibtg, ibroncat, iland, idgr + + IF (ierr == 0) THEN + + ! Convert lon-lat coordinates to RDM coordinates + CALL geo2amc(gb, gl, x, y) ! (x,y) in km + x = AINT(x*1000.) ! [m] + y = AINT(y*1000.) ! [m] + ENDIF + ELSE + + ! Read source record with RDM coordinates: + READ (cbuf, 150, IOSTAT = ierr) mm, x, y, qob, qww, hbron, diameter, szopp, ibtg, ibroncat, iland, idgr + ENDIF + ENDIF ! IF (brn_version .GE. 1) + + ! Current emission record has been read and coordinates have been converted to RDM; + ! add 1 to record number (unless ierr < 0 = end-of-file): + IF (ierr .GE. 0 ) nrec = nrec + 1 + ! write(*,*) 'nrec, ierr = ',nrec,ierr + ! write(*,'(a,a)') 'cbuf: ',trim(cbuf) + + IF (ierr == 0) THEN + + ! Check emission strength, heat content, emission height and diameter area source. + ! Note: check is only performed inside check_source2 if no error has occurred; + ! therefore there is no need to check for error%haserror here each time. + ! JA* check is only needed if source is selected. + ! + + ! Check range for + ! deviation : 0 <= szopp <= hbron + ! diurnal variation : -999 <= ibtg <= 999 + ! emission category : 1 <= ibroncat <= 9999 + ! country (= 'land') : 1 <= iland <= 9999 + ! paricle size distribution code: -999 <= idgr <= 999 + if (brn_version .lt. 2) then + ! Adjust value within range and continue OPS; write warning to log-file (backward compatibility for old emission files): + CALL check_source (nrec, '', 0., 99999., qob, error) + if (.not. is_missing(qww)) CALL check_source(nrec, '', 0., 999., qww, error) + CALL check_source (nrec, '', 0., 5000.0, hbron, error) + CALL check_source (nrec, '',-999999., 999999., diameter, error) + CALL check_source (nrec, '', 0., hbron, szopp, error) + CALL check_isource(nrec, '', -999, 999, ibtg, error) + CALL check_isource(nrec, '', 1, 9999, ibroncat, error) + CALL check_isource(nrec, '', 1, 9999, iland, error) + CALL check_isource(nrec, '', -999, MAXDISTR, idgr, error) + + else + ! Generate error and stop OPS: + CALL check_source2('', 0., 99999., qob, error) + if (.not. is_missing(qww)) CALL check_source2('', 0., 999., qww, error) + ! CALL check_source2('', 0., HUMAX, hbron, error) + CALL check_source2('', 0., 5000.0, hbron, error) + CALL check_source2('',-999999., 999999., diameter, error) + CALL check_source2 ('', 0., hbron, szopp, error) + CALL check_isource2('', -999, 999, ibtg, error) + CALL check_isource2('', 1, 9999, ibroncat, error) + CALL check_isource2('', 1, 9999, iland, error) + CALL check_isource2('', -999, MAXDISTR, idgr, error) + + ! Check stack parameters: + call check_stack_param(qww, VsDs_opt, D_stack, V_stack, Ts_stack_C, error) + + ! Check building type: + if (brn_version .ge. 3) then + CALL check_isource2('', 0, ncolBuildingEffectTable, building%type, error) + endif + + ! Check building parameters: + if (brn_version .ge. 4) then + call check_building_param(building, hbron, qww, D_stack, V_stack, error) + endif + endif + + if (VsDs_opt) then + ! Convert Ts_stack to K: + if (is_missing(Ts_stack_C)) then + Ts_stack = Ts_stack_C + else + Ts_stack = Ts_stack_C + T0 + endif + endif + + ! Check whether ibtg and idgr distributions in this record have been read (using presentcode array). + ! Check whether ibtg is not for NH3 (icm=3) and NOx (icm=2) if a special diurnal variation (4 or 5) is used. + ! Check whether particle size distribution has been read. + IF (.NOT.((icm == 2 .OR. icm == 3) .AND. (ibtg == 4 .OR. ibtg == 5))) THEN + CALL check_verdeling(ibtg, presentcode, 1, 3, 'ibtg', error) + ENDIF + IF (check_psd) THEN + CALL check_verdeling(idgr, presentcode, 2, 4, 'idgr', error) + ENDIF + IF (error%haserror) GOTO 9999 + + ELSE + + ! IERR .NE. 0 -> I/O error has occurred - set error message: + CALL SetError('I/O error while reading emissions; for a list of I/O errors, see your compiler manual.', error) + CALL ErrorParam('I/O error', ierr, error) + goto 9999 + ENDIF ! IF I/O error +ENDIF ! IF (.NOT. end_of_file) + +RETURN + +9999 CALL ErrorParam('emission record', cbuf, error) +CALL ErrorParam('record nr. in emission file', nrec, error) +CALL ErrorParam('selected source number', numbron, error) +CALL ErrorCall(ROUTINENAAM, error) + +END SUBROUTINE ops_emis_read_annual1 + +!------------------------------------------------------------------------------------------------------------------------------- +! SUBROUTINE NAME : check_source +! DESCRIPTION : check whether a source parameter lies within a specified range. If not, the paramater is fixed at either +! the lower or upper limit of the range. In this case, a warning is written to the log file; +! this warning includes the record number of the source. +! Included for backward compatibility of old source files; better use check_source2. +! CALLED FUNCTIONS : +!------------------------------------------------------------------------------------------------------------------------------- +SUBROUTINE check_source(nr, varnaam, onder, boven, varwaarde, error) + +USE m_error +USE m_commonfile, only: fu_log +USE m_commonconst, only: EPS_DELTA + +! CONSTANTS +CHARACTER*512 :: ROUTINENAAM +PARAMETER (ROUTINENAAM = 'check_source') + +! SUBROUTINE ARGUMENTS - INPUT +INTEGER*4, INTENT(IN) :: nr ! record number of source file +CHARACTER*(*), INTENT(IN) :: varnaam ! variable to be checked +REAL*4, INTENT(IN) :: onder ! lower limit +REAL*4, INTENT(IN) :: boven ! upper limit + +! SUBROUTINE ARGUMENTS - I/O +REAL*4, INTENT(INOUT) :: varwaarde ! (adapted) value of variable +TYPE (TError), INTENT(INOUT) :: error ! error handling record + +! LOCAL VARIABLES +INTEGER*4 :: mlen ! length of variable name +LOGICAL*1 :: switch ! indicates weather WARNING has already been printed +LOGICAL :: ops_openlog ! function for opening log file + +!------------------------------------------------------------------------------------------------------------------------------- +! +! Check and possibly open log file. From here there is always going to be something written to it, so the opening is allowed. +! +IF (error%haserror) GOTO 9999 + +switch = .FALSE. + +! +! Check upper limit; if needed, write warning and fix variable at upper limit. +! +IF (varwaarde .GT. (boven + EPS_DELTA)) THEN ! varwaarde too large + + IF (.NOT. switch) THEN + IF (.NOT. ops_openlog(error)) GOTO 9000 + WRITE(fu_log,'("WARNING: OPS has detected a value outside", " its limits in routine ", A)') & + & ROUTINENAAM(:LEN_TRIM(ROUTINENAAM)) + ENDIF + + switch=.TRUE. + + mlen = LEN_TRIM(varnaam) + WRITE(fu_log,'('' Record number '',I6,'': Value of '', ''emission variable '', a, '' ('', G10.3, & + & '') is outside range '', ''('', G10.3, '' - '', G10.3, '')'')') nr, varnaam(:mlen), varwaarde, onder , boven + WRITE(fu_log,'(25x,''and has been set to maximum value'')') + + varwaarde = boven + +! +! Check lower limit; if needed, write warning and fix variable at lower limit. +! +ELSEIF (varwaarde .LT. (onder - EPS_DELTA)) THEN ! varwaarde too small + + IF (.NOT. switch) THEN + IF (.NOT. ops_openlog(error)) GOTO 9000 + WRITE(fu_log,'("WARNING: OPS has detected a value outside", " its limits in routine ", A)') & + & ROUTINENAAM(:LEN_TRIM(ROUTINENAAM)) + ENDIF + + switch=.TRUE. + + mlen = LEN_TRIM(varnaam) + WRITE(fu_log,'('' Record number '',I6,'': Value of '', ''emission variable '', a, '' ('', G10.3, & + & '') is outside range '', ''('', G10.3, '' - '', G10.3, '')'')') nr, varnaam(:mlen), varwaarde, onder , boven + + IF (varnaam .EQ. '') THEN + WRITE(fu_log,'(25x,''Record will be skipped'')') ! Zero emissions are meaningless + ELSE + WRITE(fu_log,'(25x,''and has been set to minimum value'')') + ENDIF + + varwaarde = onder + +ELSE + CONTINUE +ENDIF +RETURN + +9000 CALL ErrorCall(ROUTINENAAM, error) +9999 RETURN + +END SUBROUTINE check_source + +!------------------------------------------------------------------------------------------------------------------------------- +! SUBROUTINE NAME : check_isource +! DESCRIPTION : check whether an integer source parameter lies within a specified range. If not, the paramater is fixed at either +! the lower or upper limit of the range. In this case, a warning is written to the log file; +! this warning includes the record number of the source. +! Included for backward compatibility of old source files; better use check_isource2. +! CALLED FUNCTIONS : +!------------------------------------------------------------------------------------------------------------------------------- +SUBROUTINE check_isource(nr, varnaam, onder, boven, varwaarde, error) + +USE m_error + +! CONSTANTS +CHARACTER*512 :: ROUTINENAAM +PARAMETER (ROUTINENAAM = 'check_source') + +! SUBROUTINE ARGUMENTS - INPUT +INTEGER*4, INTENT(IN) :: nr ! record number of source file +CHARACTER*(*), INTENT(IN) :: varnaam ! variable to be checked +INTEGER*4, INTENT(IN) :: onder ! lower limit +INTEGER*4, INTENT(IN) :: boven ! upper limit + +! SUBROUTINE ARGUMENTS - I/O +INTEGER*4, INTENT(INOUT) :: varwaarde ! (adapted) value of variable +TYPE (TError), INTENT(INOUT) :: error ! error handling record + +! LOCAL VARIABLES +REAL*4 :: var ! help variable (= float(varwaarde)) + +var = FLOAT(varwaarde) +CALL check_source(nr, varnaam, FLOAT(onder), FLOAT(boven), var, error) +varwaarde = NINT(var) + +END SUBROUTINE check_isource + +!------------------------------------------------------------------------------------------------------------------------------- +! SUBROUTINE NAME : check_source2 +! DESCRIPTION : check whether a source parameter lies within a specified range. If not, an error message is generated +! and returned back to the calling routine. The error has to be handled in the calling routine. +! Note: check_source adjusts the value and generates a warning. +! CALLED FUNCTIONS : +!------------------------------------------------------------------------------------------------------------------------------- +SUBROUTINE check_source2(varnaam, onder, boven, varwaarde, error) + +USE m_error +USE m_commonconst, only: EPS_DELTA + +! CONSTANTS +CHARACTER*512 :: ROUTINENAAM +PARAMETER (ROUTINENAAM = 'check_source2') + +! SUBROUTINE ARGUMENTS - INPUT +CHARACTER*(*), INTENT(IN) :: varnaam ! variable to be checked +REAL*4, INTENT(IN) :: onder ! lower limit +REAL*4, INTENT(IN) :: boven ! upper limit +REAL*4, INTENT(IN) :: varwaarde ! value of variable + +! SUBROUTINE ARGUMENTS - I/O +TYPE (TError), INTENT(INOUT) :: error ! error handling record + +! LOCAL VARIABLES + +!------------------------------------------------------------------------------------------------------------------------------- +! +! If an error has already occurred, this check is skipped +IF (.NOT. error%haserror) THEN + + ! Check range: + IF (varwaarde .LT. (onder - EPS_DELTA) .OR. varwaarde .GT. (boven + EPS_DELTA)) THEN + + CALL SetError(trim(varnaam),' outside permitted range', error) + CALL ErrorParam('lower limit', onder, error) + CALL ErrorParam(trim(varnaam), varwaarde, error) + CALL ErrorParam('upper limit', boven, error) + CALL ErrorCall(ROUTINENAAM, error) + ENDIF +ENDIF + +RETURN + +END SUBROUTINE check_source2 + +!------------------------------------------------------------------------------------------------------------------------------- +! SUBROUTINE NAME : check_source3 +! DESCRIPTION : check whether a source parameter lies within a specified range. If not, a warning message is generated +! and returned back to the calling routine. The warning has to be handled in the calling routine. +! CALLED FUNCTIONS : +!------------------------------------------------------------------------------------------------------------------------------- +SUBROUTINE check_source3(warning1, varnaam, onder, boven, varwaarde, error) + +USE m_error +USE m_commonconst, only: EPS_DELTA +USE m_commonfile, only: fu_log + +! CONSTANTS +CHARACTER*512 :: ROUTINENAAM +PARAMETER (ROUTINENAAM = 'check_source3') + +! SUBROUTINE ARGUMENTS - INPUT +CHARACTER*(*), INTENT(IN) :: warning1 ! first part of warning +CHARACTER*(*), INTENT(IN) :: varnaam ! variable to be checked +REAL*4, INTENT(IN) :: onder ! lower limit +REAL*4, INTENT(IN) :: boven ! upper limit +REAL*4, INTENT(IN) :: varwaarde ! value of variable + +! SUBROUTINE ARGUMENTS - I/O +TYPE (TError), INTENT(INOUT) :: error ! error handling record + +! LOCAL VARIABLES + +!------------------------------------------------------------------------------------------------------------------------------- +! + +! Check range: +IF (varwaarde .LT. (onder - EPS_DELTA) .OR. varwaarde .GT. (boven + EPS_DELTA)) THEN + CALL SetError(trim(warning1) // '; ' // trim(varnaam) ,' outside permitted range', error) + CALL ErrorParam('lower limit', onder, error) + CALL ErrorParam(trim(varnaam), varwaarde, error) + CALL ErrorParam('upper limit', boven, error) + CALL ErrorCall(ROUTINENAAM, error) + + ! Reset error message (only warning): + error%haserror = .FALSE. + + ! Write warning to log file: + CALL WriteError(fu_log, error) + +ENDIF + +RETURN + +END SUBROUTINE check_source3 + +!------------------------------------------------------------------------------------------------------------------------------- +! SUBROUTINE NAME : check_isource2 +! DESCRIPTION : check whether an integer source parameter lies within a specified range. If not, an error message is generated +! and returned back to the calling routine. The error has to be handled in the calling routine. +! Note: check_isource adjusts the value and generates a warning. +! CALLED FUNCTIONS : +!------------------------------------------------------------------------------------------------------------------------------- +SUBROUTINE check_isource2(varnaam, onder, boven, varwaarde, error) + +USE m_error + +! CONSTANTS +CHARACTER*512 :: ROUTINENAAM +PARAMETER (ROUTINENAAM = 'check_source2') + +! SUBROUTINE ARGUMENTS - INPUT +CHARACTER*(*), INTENT(IN) :: varnaam ! variable to be checked +INTEGER*4, INTENT(IN) :: onder ! lower limit +INTEGER*4, INTENT(IN) :: boven ! upper limit +INTEGER*4, INTENT(IN) :: varwaarde ! value of variable + +! SUBROUTINE ARGUMENTS - I/O +TYPE (TError), INTENT(INOUT) :: error ! error handling record + +! LOCAL VARIABLES + +CALL check_source2(varnaam, FLOAT(onder), FLOAT(boven), FLOAT(varwaarde), error) + +END SUBROUTINE check_isource2 + +!------------------------------------------------------------------------------------------------------------------------------- +! SUBROUTINE NAME : check_verdeling +! DESCRIPTION : Check whether distribution (=verdeling) has been read. +! CALLED FUNCTIONS : +!------------------------------------------------------------------------------------------------------------------------------- +SUBROUTINE check_verdeling(icode, presentcode, stdclass, usdclass, parname, error) + +USE m_error +USE m_commonconst, only: MAXDISTR + +! CONSTANTS +CHARACTER*512 :: ROUTINENAAM +PARAMETER (ROUTINENAAM = 'check_verdeling') + +! SUBROUTINE ARGUMENTS - INPUT +INTEGER*4, INTENT(IN) :: icode ! code that has to be checked; + ! if icode < 0 -> check whether a user defined distribution is present + ! if icode > 0 -> check whether a standard distribution is present + ! if icode = 0 -> do not check anything +LOGICAL, INTENT(IN) :: presentcode(MAXDISTR,4) +INTEGER*4, INTENT(IN) :: stdclass ! index of standard distributions in 2nd dimension of presentcode +INTEGER*4, INTENT(IN) :: usdclass ! index of user defined distributions in 2nd dimension of presentcode +CHARACTER*(*), INTENT(IN) :: parname ! parameter name in error messages + +! SUBROUTINE ARGUMENTS - I/O +TYPE (TError), INTENT(INOUT) :: error ! error handling record + +! LOCAL VARIABLES +INTEGER*4 :: klasse ! 2nd index into presentcode + +! +! Check for user defined distributions, in case icode < 0, +! check for standard distributions, in case icode > 0 +! +IF (.NOT.error%haserror .and. icode /= 0) THEN + IF (icode < 0) THEN + klasse = usdclass + ELSE + klasse = stdclass + ENDIF + IF (.NOT. presentcode(ABS(icode), klasse)) THEN + CALL SetError('No distribution available for this code of', parname, error) + CALL ErrorParam(parname, icode, error) + CALL ErrorCall(ROUTINENAAM, error) + ENDIF +ELSE + IF (icode == 0 .and. parname == "idgr") THEN + CALL SetError('It is not permitted to use code 0 for', parname, error) + CALL ErrorParam(parname, icode, error) + CALL ErrorCall(ROUTINENAAM, error) + ENDIF +ENDIF + +END SUBROUTINE check_verdeling + +!------------------------------------------------------------------------------------------------------------------------------- +! SUBROUTINE NAME : check_stack_param +! DESCRIPTION : Check stack parameters qww, D_stack, V_stack, Ts_stack_C +! CALLED FUNCTIONS : +!------------------------------------------------------------------------------------------------------------------------------- +SUBROUTINE check_stack_param(qww, VsDs_opt, D_stack, V_stack, Ts_stack_C, error) + +USE m_error +USE m_ops_utils, only: is_missing +USE m_commonconst, only: EPS_DELTA + +! CONSTANTS +CHARACTER*512 :: ROUTINENAAM +PARAMETER (ROUTINENAAM = 'check_stack_param') + +! SUBROUTINE ARGUMENTS - INPUT +real , intent(in) :: qww ! heat content[ MW] +logical, intent(in) :: VsDs_opt ! read stack parameters Ds/Vs/Ts from source file +real , intent(in) :: D_stack ! diameter of the stack [m] +real , intent(in) :: V_stack ! exit velocity of plume at stack tip [m/s] +real , intent(in) :: Ts_stack_C ! temperature of effluent from stack [C] + +! SUBROUTINE ARGUMENTS - I/O +TYPE (TError), INTENT(INOUT) :: error ! error handling record + +! LOCAL VARIABLES + +! Check that either Qw or Ts_stack_C is defined (and not both): +if (VsDs_opt) then + if ((is_missing(Ts_stack_C) .and. is_missing(qww)) .or. (.not. is_missing(Ts_stack_C) .and. .not. is_missing(qww))) then + CALL SetError('One of heat content (Qw) or temperature effluent gas (Ts_stack_C) must be specified, other must be -999.', error) + CALL ErrorParam('Ts_stack_C', Ts_stack_C, error) + CALL ErrorParam('Qw', qww, error) + CALL ErrorCall(ROUTINENAAM, error) + endif +else + if (is_missing(qww)) then + CALL SetError('Heat content (Qw) must be specified', error) + CALL ErrorParam('Qw', qww, error) + CALL ErrorCall(ROUTINENAAM, error) + endif +endif + +! Check ranges: +! (for the check on Ts_stack_C -> see also check in m_ops_plume_rise - ops_plumerise_qw_Ts) +if (.not. is_missing(D_stack)) CALL check_source2('' , 0.01 , 30.0 , D_stack, error) ! Infomil NNM 2.1.2 - Modelinvoer +if (.not. is_missing(V_stack)) CALL check_source2('' , 0.0 , 50.0 , V_stack, error) ! V_stack = 0 is ok; in this case Qw = 0. Upper limit V_stack? +if (.not. is_missing(Ts_stack_C)) CALL check_source2('' , 0.0 , 2000.0 , Ts_stack_C, error) ! temperature waste burning ~ 1300 C + +! Check whether V_stack = 0 and Qw > 0 -> error +if (.not. is_missing(V_stack)) then + if (V_stack .lt. EPS_DELTA .and. qww .gt. EPS_DELTA) then + CALL SetError('If exit velocity (V_stack) is zero, then heat content (Qw) must be zero also.','Use V_stack = -999. if you only want to specify Qw.', error) + CALL ErrorParam('V_stack', V_stack, error) + CALL ErrorParam('Qw', qww, error) + CALL ErrorCall(ROUTINENAAM, error) + endif +endif + +END SUBROUTINE check_stack_param + +!------------------------------------------------------------------------------------------------------------------------------- +! SUBROUTINE NAME : check_building_param +! DESCRIPTION : Check building parameters +! CALLED FUNCTIONS : +!------------------------------------------------------------------------------------------------------------------------------- +SUBROUTINE check_building_param(building, hbron, qww, D_stack, V_stack, error) + +USE m_error +USE m_ops_utils, only: is_missing +USE m_commonconst, only: EPS_DELTA +use m_ops_building +USE m_commonfile, only: fu_log + +! CONSTANTS +CHARACTER*512 :: ROUTINENAAM +PARAMETER (ROUTINENAAM = 'check_building_param') + +! Input: +type(Tbuilding), intent(in) :: building ! structure with building parameters +real, intent(in) :: hbron ! emission height [m] +real, intent(in) :: qww ! heat content [MW] +real, intent(in) :: D_stack ! stack diameter [m] +real, intent(in) :: V_stack ! exit velocity [m/s] + +! SUBROUTINE ARGUMENTS - I/O +TYPE (TError), INTENT(INOUT) :: error ! error handling record + +! Local: +real :: wlratio ! ratio width/length building + +! Check only needed if all building dimensions have been specified: +if (.not. (is_missing(building%length) .or. is_missing(building%width) .or. is_missing(building%height) .or. is_missing(building%orientation))) then + + ! Set width/length ratio: + if (building%length > 0.0) then + wlRatio = building%width/building%length + else + ! if length = 0 -> buildingType = 0 (see below) + wlRatio = HUGE(1.0) + endif + + ! If values outside limits -> warning + ! limits based on data for 2500 animal houses in 2018 + ! Note that it is already checked that all building dimensions (length, width, height) have been specified + + ! Open log file if not already open: + call ops_openlog(error) + if (error%haserror) goto 9999 + + ! Error if Qw must be specified (= 0) and cannot be missing: + if (is_missing(qww)) then + CALL SetError('If building is present, then heat content (Qw) must be zero (cannot be missing).', error) + CALL ErrorParam('Qw', qww, error) + goto 9999 + endif + + ! Warnings if value is outside table boundaries: + CALL check_source3('check table building effect ','' , 0.0 , 20.0 , building%height, error) + if (.not. is_missing(hbron)) CALL check_source3('check table building effect ','' , 0.0 , 20.0 , hbron, error) + CALL check_source3('check table building effect ','' , 0.0 , 0.0 , qww, error) ! Table only for qww = 0 + if (.not. is_missing(V_stack)) CALL check_source3('check table building effect ','' , 0.0 , 8.4 , V_stack, error) + if (.not. is_missing(D_stack)) CALL check_source3('check table building effect ','' , 0.01 , 5.0 , D_stack, error) + CALL check_source3('check table building effect ','' , 0.15 , 1.0 , wlRatio, error) + CALL check_source3('check table building effect ','' , 10.0 , 105.0 , building%length, error) + CALL check_source3('check table building effect ','' , 0.0 , 180.0 , building%orientation, error) + +endif + +RETURN + +9999 CALL ErrorCall(ROUTINENAAM, error) + +END SUBROUTINE check_building_param + +END MODULE m_ops_emis diff --git a/m_ops_plumerise.f90 b/m_ops_plumerise.f90 new file mode 100644 index 0000000..a1b57ad --- /dev/null +++ b/m_ops_plumerise.f90 @@ -0,0 +1,655 @@ +!------------------------------------------------------------------------------------------------------------------------------- +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . +! +! Copyright (C) 2002 by +! National Institute of Public Health and Environment +! Laboratory for Air Research (RIVM/LLO) +! The Netherlands +!------------------------------------------------------------------------------------------------------------------------------- +module m_ops_plumerise + +! module m_ops_plumerise with plume rise due to either buoyancy or momentum +! Marina Sterk and Ferd Sauter 2018-02-20 + +! ops_plumerise : main routine containing the calls to different parts of the final plume rise, and the calculation of the final plume rise +! ops_plumerise_buoyancy : determine plume rise due to buoyancy +! ops_plumerise_momentum : determine plume rise due to momentum +! ops_plume_penetration : determine plume penetration (fraction of plume that penetrates the mixing height) + +implicit none + +! T0 = reference temperature = 273.15 K = 0 C +! P0 = reference pressure = 1 atm = 101.325 kPa +real, parameter :: rho0 = 1.293 ! reference density air at pressure P0, temperature T0 (= 1.293 kg/m3) +real, parameter :: Cp0 = 1005 ! reference specific heat of air at pressure P0, temperature T0 (= 1005 J/kg/K) + +contains + +!------------------------------------------------------------ +subroutine ops_plumerise_prelim(istab, isek, astat, hemis0, qw, D_stack, V_stack, Ts_stack, emis_horizontal, hemis1, error) + +! Compute preliminary plume rise, based on stability class and preliminary wind sector (ol, uster, ... still unknown) + +use m_commonconst, only: NTRAJ, NCOMP, NSTAB, NSEK +use m_ops_utils, only: is_missing +use m_error + +! Input: +integer, intent(in) :: istab ! index of stability class and preliminary wind sector +integer, intent(in) :: isek ! index of preliminary wind sector (wind shear not yet taken into account) +real , intent(in) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) ! statistical meteo parameters +real, intent(in) :: hemis0 ! initial emission height = stack height [m] +real, intent(in) :: qw ! heat content [MW] +real, intent(in) :: D_stack ! diameter of the stack [m] +real, intent(in) :: V_stack ! exit velocity of plume at stack tip [m/s] +real, intent(in) :: Ts_stack ! temperature of effluent from stack [K] +logical, intent(in) :: emis_horizontal ! horizontal outflow of emission + +! Output: +real, intent(out) :: hemis1 ! emission height, including plume rise [m] +type (TError), intent(out) :: error ! error handling record + +! Local: +logical :: prelim ! preliminary plume rise, based on stability class and preliminary wind sector (ol, uster, ... still unknown) + ! if prelim = true -> ol = -999, uster = -999, z0 = -999, zmix = zmix_loc = -999 + ! these parameters are still unknown; + ! wind profile is based on power law with coefficient based on stability class +logical :: VsDs_opt ! include exit velocity (Vs = V_stack), stack diameter (Ds = D_stack) and effluent temperature (Ts_stack) in the emission file +real :: dum ! dummy output of ops_plumerise +real :: temp_C ! ambient temperature at height zmet_T [C], default value + +character(len = 80), parameter :: ROUTINENAAM = 'ops_plumerise_prelim' + +prelim = .true. +VsDs_opt = .not. is_missing(V_stack) +temp_C = 12.0 ! default average value (is not a sensitive parameter for preliminary estimate) +call ops_plumerise(-999., hemis0, -999., -999., qw, VsDs_opt, D_stack, V_stack, Ts_stack, emis_horizontal, temp_C, -999., -999., & + hemis1, dum, error, prelim, istab, isek, astat) +! write(*,'(a,4(1x,e12.5))') 'in routine ops_plumerise_prelim a: ',hemis0,hemis1,hemis1-hemis0,-999.0 + +if (error%haserror) call ErrorCall(ROUTINENAAM, error) + +end subroutine ops_plumerise_prelim + +!------------------------------------------------------------ +subroutine ops_plumerise(z0, hemis0, uster, ol, qw, VsDs_opt, D_stack, V_stack, Ts_stack, emis_horizontal, temp_C, zmix, zmix_loc, & + hemis1, onder, error, prelim, istab, isek, astat) + +! Main routine for the different plume rise calculations + +use Binas, only: T0 ! melting point of ice [K] +use m_commonconst, only: zmet_T, NTRAJ, NCOMP, NSTAB, NSEK, EPS_DELTA +use m_error + +! Input +real, intent(in) :: z0 ! roughness length [m] +real, intent(in) :: hemis0 ! initial emission height = stack height [m] +real, intent(in) :: uster ! friction velocity [m/s] +real, intent(in) :: ol ! Monin-Obukhov length [m] +real, intent(in) :: qw ! heat content [MW] +logical, intent(in) :: VsDs_opt ! include exit velocity (Vs = V_stack), stack diameter (Ds = D_stack) and effluent temperature (Ts_stack) in the emission file +real, intent(in) :: D_stack ! diameter of the stack [m] +real, intent(in) :: V_stack ! exit velocity of plume at stack tip [m/s] +real, intent(in) :: Ts_stack ! temperature of effluent from stack [K] +logical, intent(in) :: emis_horizontal ! horizontal outflow of emission +real, intent(in) :: temp_C ! ambient temperature at height zmet_T [C] +real, intent(in) :: zmix ! mixing height [m] +real, intent(in) :: zmix_loc ! mixing height, local scale [m] + +! Output +real, intent(out) :: hemis1 ! emission height, including plume rise [m] +real, intent(out) :: onder ! part of plume below mixing height +type (TError), intent(out) :: error ! error handling record + +! Input, optional: +logical, intent(in), optional :: prelim ! preliminary plume rise, based on stability class and preliminary wind sector (ol, uster, ... still unknown) + ! if prelim = true -> ol = -999, uster = -999, z0 = -999, zmix = zmix_loc = -999 + ! these parameters are still unknown; + ! wind profile is based on power law with coefficient based on stability class + ! if prelim = false or not present -> istab, isek are not used + ! wind profile is computed with ops_wvprofile (logarithmic profile) using z0, ol, uster +integer, intent(in), optional :: istab ! index of stability class and preliminary wind sector +integer, intent(in), optional :: isek ! index of preliminary wind sector (wind shear not yet taken into account) +real , intent(in), optional :: astat(NTRAJ, NCOMP, NSTAB, NSEK) ! statistical meteo parameters + +! Local +real :: u_stack ! wind speed at stack height [m/s] +real :: u_threshold ! threshold wind speed at height z_u_threshold [m/s] +real :: dh_buoyancy ! plume rise due to buoyancy [m] +real :: dh_momentum ! plume rise due to momentum [m] +real :: dh ! plume rise due to either buoyancy or momentum [m] +real :: dthetadz_stable ! fixed potential temperature gradient dtheta/dz [K/m] for stable conditions, used for dh_buoyancy and dh_momentum +real :: Ta_stack ! ambient temperature at stack height [K] +real, parameter :: z_u_threshold = 10.0 ! threshold height below which the wind speed is cut-off [m] +real :: Ts_stack2 ! effluent temperature at stack height, but missing value replaced by computation from Qw [K] +real :: qw2 ! heat content emission, but missing value replaced by computation from Ts [MW] +real :: V0 ! normal volume flux [m0^3/s] +logical :: prelim1 ! = prelim if present, otherwise false +real :: vw10 ! wind velocity at 10 m heigth [m/s] +real :: pcoef ! coefficient in wind speed power law +logical :: non_stable ! non-stable (unstable/neutral) conditions + +character(len = 80), parameter :: ROUTINENAAM = 'ops_plumerise' + +! Check optional argument: +if (.not. present(prelim)) then + prelim1 = .false. +else + prelim1 = prelim +endif + +! write(*,'(a,4(1x,e12.5))') 'in routine ops_plumerise a: ',hemis0,hemis1,hemis1-hemis0,-999.0 + +! Set fixed potential temperature gradient dtheta/dz for stable conditions. +! In the OPS manual (just below Eq. 4.6) it is stated that an average value of 0.006 K/m is taken as representative +! for stable situations, following TNO (1976). +! TNO (1976) Modellen voor de berekening van de verspreiding van luchtverontreiniging inclusief aanbevelingen voor de waarden van +! parameters in het lange-termijnmodel. Staatsuitgeverij, The Hague, the Netherlands. +! Just above Eq. 4.3 of the OPS manual it is stated that this is the reference to the Dutch National Model. +! However, in the manual of the NNM (March 2002), 0.006 is not used, but the profile is reviewed per 10m layer. +! For stable conditions a dtheta/dz of at least 0.005 K/m is applied. +! MS Possibly better to calculate dtheta/dz per layer as well? Also due to changing stability with height which affects plume rise? +dthetadz_stable = 0.006 + +! Obtain temperature at stack height. +! Use theta(z) = T(z) + Tau*z (Tau = 9.8*10^-3 K/m = dry adiabatic lapse rate = g/Cp) (Stull 2000, Meteorology for Scientists and Engineers, Second Edition). +! +! T(z2) - T(z1) + Tau*(z2-z1) +! dtheta/dz = --------------------------- --> T(z2) = dtheta/dz * (z2-z1) - Tau*(z2-z1) + T(z1); +! z2 - z1 +! T(z1) is the temperature at z1, taken as the temperature from the meteo-file at zmet_T = 1.5m height. +Ta_stack = dthetadz_stable*(hemis0-zmet_T) - (9.8e-3)*(hemis0-zmet_T) + (temp_C + T0) + +! Check for non-stable (unstable/neutral) conditions: +if (prelim1) then + non_stable = ( istab .lt. 5 ) +else + non_stable = ( ol .lt. (0. - EPS_DELTA) .or. abs(ol) .gt. 50 ) +endif + +! 1. Compute effluent temperature Ts_stack or heat content Qw depending on input specified; +! Ts missing -> compute Qw, Qw missing -> compute Ts: +call ops_plumerise_qw_Ts(VsDs_opt, qw, D_stack, V_stack, Ts_stack, emis_horizontal, Ta_stack, qw2, Ts_stack2, error) +if (error%haserror) goto 9999 + +! 2. Compute wind speed at stack height: +if (prelim1) then + call ops_wv_powerlaw(istab,isek,astat,hemis0,u_stack,vw10,pcoef) +else + call ops_wvprofile(z0,hemis0,uster,ol,u_stack) +endif + +! 3. Determine plume rise due to buoyancy. This is including iterations to resolve the interdependency between plume rise and wind speed +if (present(prelim)) then + call ops_plumerise_buoyancy(z0,ol,uster,non_stable,qw2,Ta_stack,dthetadz_stable,u_stack,hemis0,dh_buoyancy,prelim,istab,isek,astat) +else + call ops_plumerise_buoyancy(z0,ol,uster,non_stable,qw2,Ta_stack,dthetadz_stable,u_stack,hemis0,dh_buoyancy) +endif + +! write(*,'(a,4(1x,e12.5))') 'in routine ops_plumerise b: ',hemis0,hemis1,hemis1-hemis0,-999.0 + +! 4. Determine plume rise due to momentum (no momentum plume rise in case of horizontal emission): +if (VsDs_opt .and. .not. emis_horizontal) then + + ! Low stack with low wind velocity may lead to large oversestimation of plume rise -> + ! 10 m is used as threshold for wind speed calculation (personal communication Hans Erbrink): + if (hemis0 .lt. z_u_threshold) then + if (prelim1) then + call ops_wv_powerlaw(istab,isek,astat,z_u_threshold,u_threshold,vw10,pcoef) + else + call ops_wvprofile(z0,z_u_threshold,uster,ol,u_threshold) + endif + call ops_plumerise_momentum(u_threshold,D_stack,V_stack,Ts_stack2,Ta_stack,dthetadz_stable,non_stable,dh_momentum) + else + call ops_plumerise_momentum(u_stack,D_stack,V_stack,Ts_stack2,Ta_stack,dthetadz_stable,non_stable,dh_momentum) + endif +else + dh_momentum = 0.0 +endif +! write(*,'(a,4(1x,e12.5))') 'in routine ops_plumerise : ',dh_buoyancy,dh_momentum + +! 5. Compare plume rise due to buoyancy and momentum, which process is dominant? Adopt that plume rise. +! If buoyancy plume rise is greater than momentum plume rise, discard momentum plume rise, +! because in the parameterisation of buoyancy plume rise, momentum plume rise has been taken into account (see NNM Paarse boekje): +if (dh_buoyancy .ge. dh_momentum) then + dh = dh_buoyancy +else + dh = dh_momentum +endif +hemis1 = hemis0 + dh +! write(*,'(a,4(1x,e12.5))') 'in routine ops_plumerise c: ',hemis0,hemis1,hemis1-hemis0,-999.0 + +! 6. plume penetration +if (.not. prelim1) call ops_plume_penetration(hemis0,zmix,zmix_loc,ol,dh,hemis1,onder) +! write(*,'(a,4(1x,e12.5))') 'in routine ops_plumerise d: ',hemis0,hemis1,hemis1-hemis0,-999.0 + +return + +9999 call ErrorCall(ROUTINENAAM, error) + +end subroutine ops_plumerise + +!------------------------------------------------------------------------------------------------------------------------------- +subroutine ops_plumerise_qw_Ts(VsDs_opt, qw, D_stack, V_stack, Ts_stack, emis_horizontal, Ta_stack, qw2, Ts_stack2, error) + +! Compute effluent temperature Ts_stack or heat content Qw depending on input specified; +! Ts_stack missing -> compute Qw, Qw missing -> compute Ts_stack. Note that is has been checked already that either one of them is missing. +! + +use Binas, only: T0, pi ! melting point of ice [K], pi +use m_ops_utils, only: is_missing +use m_error + +! Input +logical, intent(in) :: VsDs_opt ! include exit velocity (Vs = V_stack), stack diameter (Ds = D_stack) and effluent temperature (Ts_stack) in the emission file +real, intent(in) :: qw ! heat content [MW] +real, intent(in) :: D_stack ! diameter of the stack [m] +real, intent(in) :: V_stack ! exit velocity of plume at stack tip [m/s] +real, intent(in) :: Ts_stack ! temperature of effluent from stack [K] +logical, intent(in) :: emis_horizontal ! horizontal outflow of emission +real, intent(in) :: Ta_stack ! ambient temperature at stack height (K) + +! Output: +real, intent(out) :: Ts_stack2 ! effluent temperature at stack height, but missing value replaced by computation from Qw [K] +real, intent(out) :: qw2 ! heat content emission, but missing value replaced by computation from Ts [MW] +type (TError), intent(out) :: error ! error handling record + +!Local: +real :: C1 ! help variable = rho0*Cp0*(pi*(0.5*D_stack)**2)*V_stack*T0*(1.0e-6). Needed for Ts_stack2 +real :: V0 ! normal volume flux [m0**3/s) + +character(len = 80), parameter :: ROUTINENAAM = 'ops_plumerise_qw_Ts' + +! qw = rho0*Cp0*V0*(Ts - Ta)*1e-6 or 1e6*qw/(rho0*Cp0*V0) = Ts - Ta <=> Ts = Ta + 1e6*qw/(rho0*Cp0*V0) +! T0 = reference temperature = 273.15 K = 0 C +! P0 = reference pressure = 1 atm = 101.325 kPa +! rho0 = reference density air (= 1.293 kg/m3) at pressure P0, temperature T0 +! Cp0 = reference specific heat of air at pressure P0, temperature T0 (= 1005 J/kg/K) +! V0 = normal volume flux (m03/s) at pressure P0, temperature T0 +! Ts = effluent temperature (K) +! Ta = ambient temperature at stack height (K) + +! write(*,*) 'ops_plumerise_qw_Ts a:',VsDs_opt,qw,Ts_stack +if (VsDs_opt) then + if (is_missing(Ts_stack)) then + + !---------------------------------------------------------------- + ! Heat content qw given, compute effluent temperature Ts_stack2 + !---------------------------------------------------------------- + + if (emis_horizontal) then + Ts_stack2 = -999.0 + else + if (qw .eq. 0.0) then + Ts_stack2 = Ta_stack + else + ! Compute effluent temperature (not needed in case of horizontal outflow): + ! Ts = Ta + 1e6*qw/(rho0*Cp0*V0) (1) + ! V0 = (pi*(0.5*D_stack)**2)*V_stack*T0/Ts_stack (2) + ! Substitute (2) in (1) gives Ts = Ta + f Ts <=> Ts = Ta/(1-f), with f = 1e6*qw/(rho0*Cp0*(pi*(0.5*D_stack)**2)*V_stack*T0): + C1 = rho0*Cp0*(pi*(0.5*D_stack)**2)*V_stack*T0*(1.0e-6) + Ts_stack2 = Ta_stack/(1.0 - qw/C1) + + ! Check: + ! This check is not needed; next check is more stringent: + ! if (qw .ge. C1) then + ! CALL SetError('Computing negative effluent gas temperature Ts_stack [K] from given heat content.', & + ! 'Probably, the given exit velocity and/or stack diameter are not in agreement with the given heat content.', error) + ! endif + ! Check temperature range (degrees C) (see also check in ops_read_source - check_stack_param): + if (Ts_stack2-T0 .lt. 0.0 .or. Ts_stack2-T0 .gt. 2000.0) then ! See also check in ops_read_source - check_stack_param + call SetError('Computing effluent gas temperature Ts_stack from given heat content -> Ts_stack outside permitted range.',error) + call ErrorParam('heat content [MW]',qw,error) + call ErrorParam('diameter of the stack [m]',D_stack,error) + call ErrorParam('exit velocity of plume at stack tip [m/s]',V_stack,error) + call ErrorParam('ambient temperature at stack height [C]',Ta_stack-T0,error) + call ErrorParam('lower limit effluent gas temperature [C]',0.0,error) + call ErrorParam('',Ts_stack2-T0,error) + call ErrorParam('upper limit effluent gas temperature [C]',2000.0,error) + call ErrorCall(ROUTINENAAM, error) + endif + endif ! if qw = 0 + endif ! if emis_horizontal + qw2 = qw + else + + !------------------------------------------------ + ! Ts_stack is given; compute heat content qw2 + !------------------------------------------------ + + ! Compute normal volume flux, according to ideal gas-law (at constant pressure): V0_flux/T0 = Vs_flux/Ts, Vs_flux = pi R**2 Vs_stack + V0 = (pi*(0.5*D_stack)**2)*V_stack*T0/Ts_stack + + ! Compute qw: + Ts_stack2 = Ts_stack + qw2 = rho0*Cp0*V0*(Ts_stack - Ta_stack)*1e-6 + endif +else + ! VsDs_opt = FALSE: + Ts_stack2 = Ts_stack ! is missing, but not used hereafter + qw2 = qw +endif +! write(*,*) 'ops_plumerise_qw_Ts b:',VsDs_opt,qw2,Ts_stack2 + +end subroutine ops_plumerise_qw_Ts + +!------------------------------------------------------------ +subroutine ops_plumerise_buoyancy(z0, ol, uster, non_stable, qw, Ta_stack, dthetadz_stable, u_stack, hemis0, dh_buoyancy, prelim, istab, isek, astat) +!------------------------------------------------------------------------------------------------------------------------------- +! +! DESCRIPTION: This routine calculates the plume rise due to buoyancy. +! This routine includes plume rise formulations given by Briggs(1969) and Briggs(1971). +! This method is equal to the method used in the (old) Dutch National Model (TNO, 1976). +! HvJ 960121 +! Extra iteration, because wind speed depends on plume height and vice versa. +! +!------------------------------------------------------------------------------------------------------------------------------- + +use m_commonconst, only: pi, NTRAJ, NCOMP, NSTAB, NSEK, EPS_DELTA +use Binas, only: grav, T0 ! acceleration of gravity [m/s2], melting point of ice [K] + +! Input +real, intent(in) :: z0 ! roughness length [m] +real, intent(in) :: ol ! Monin-Obukhovlengte [m] +real, intent(in) :: uster ! friction velocity [m/s] +logical, intent(in):: non_stable ! non-stable (unstable/neutral) conditions +real, intent(in) :: qw ! heat content (MW) +real, intent(in) :: Ta_stack ! ambient temperature at stack height [K] +real, intent(in) :: dthetadz_stable ! fixed potential temperature gradient dtheta/dz [K/m] for stable conditions, used for dh_buoyancy and dh_momentum +real, intent(in) :: u_stack ! wind speed at stack height [m/s] +real, intent(in) :: hemis0 ! initial emission height = stack height [m] + +! Output +real, intent(out) :: dh_buoyancy ! plume rise due to buoyancy [m] + +! Input, optional: +logical, intent(in), optional :: prelim ! preliminary plume rise, based on stability class and preliminary wind sector (ol, uster, ... still unknown) + ! if prelim = true -> ol = -999, uster = -999, z0 = -999, zmix = zmix_loc = -999 + ! these parameters are still unknown; + ! wind profile is based on power law with coefficient based on stability class + ! if prelim = false or not present -> istab, isek are not used + ! wind profile is computed with ops_wvprofile (logarithmic profile) using z0, ol, uster +integer, intent(in), optional :: istab ! index of stability class and preliminary wind sector +integer, intent(in), optional :: isek ! index of preliminary wind sector (wind shear not yet taken into account) +real , intent(in), optional :: astat(NTRAJ, NCOMP, NSTAB, NSEK) ! statistical meteo parameters + +! Local +real :: f ! stack buoyancy flux [m^4/s^3] +real :: u_plume ! wind speed at effective plume height, representative for the whole plume rise length [m/s] +real :: dtdz ! potential temperature gradient [K/m] +real :: s ! stability parameter [s^-2] +logical :: prelim1 ! = prelim if present, otherwise false +real :: vw10 ! wind velocity at 10 m heigth [m/s] +real :: pcoef ! coefficient in wind speed power law +character(len=1) :: char_debug1 ! debug character (test only) + +! Iteration variables +! iteration converges if |dh_buoyancy - dh_buoyancy_prev| < epsa + epsr*dh_buoyancy +integer :: it ! iteration index +logical :: converged ! iteration has converged +real :: dh_buoyancy_prev ! plume rise of previous iteration +integer, parameter :: maxit = 10 ! maximal number of iterations +real, parameter :: epsa = 0.1 ! absolute error tolerance (m) +real, parameter :: epsr = 0.05 ! relative error tolerance + +!------------------------------------------------------------------------------------------------------------------------------- +! MS Briggs is developed for large stacks (energy production,..); should not be used for low emissions, e.g. emissions from animal housing. + +! Check optional argument: +if (.not. present(prelim)) then + prelim1 = .false. +else + prelim1 = prelim +endif + +if ( qw .gt. (0. + EPS_DELTA)) then + + !Initialization + u_plume = u_stack + dh_buoyancy = 0.0 + ! if (prelim1) write(*,'(a,2(1x,e12.5))') 'ops_plumerise_buoyancy a',hemis0,u_stack + + ! f = stack buoyancy flux (4.5 in 'The OPS-model Description of OPS 4.5.0). Briggs 1982, eq. 11. Assumed that Ps/Pa = 1. + ! f = g/(pi*0.0013*T)*qw = 9.81/(3.14*0.0013*273)*qw ! 0.0013 = rho*cp*fac_W_to_MW = 1.293*1005*1e-6 + ! f = 8.8*qw + f = (grav*1.0e6/(pi*rho0*Cp0*T0))*qw + + ! We want to use a wind speed that is representative for the whole plume rise length, + ! but because we don't know the plume rise yet, we need an iteration. + ! Initialisation for iteration: + converged = .false. + it = 1 + dh_buoyancy_prev = -999. + + ! Do iteration: + do while (.not. converged .and. it .le. maxit) + + ! plume rise for unstable or neutral conditions, L < 0 or |L| > 50 (Eq 4.3 - 4.4 in 'The OPS-model Description of OPS 4.5.0): + ! original value plrise_nonstab_Fbsplit = 55 + if ( non_stable ) then + if ( f .ge. 55 ) then + dh_buoyancy = 38.8*f**0.6/u_plume ! Briggs 1971 (as in the Dutch Nat. Mod.) + ! char_debug1 = 'd' + else + dh_buoyancy = 21.3*f**0.75/u_plume + ! char_debug1 = 'c' + endif + else + ! Stable conditions, 0 < L < 50 (3.28 OPS report) + ! use fixed potential temperature gradient dtheta/dz = 0.006 (K/m); is valid for conditions above mixing layer. + ! For low emissions and stable atmospheric conditions, dtheta/dz = 0.2 K/m + ! original value: plrise_stab_dtheta_dz = 0.006 + s = 9.81/Ta_stack*dthetadz_stable ! Stability parameter, Briggs (1969) Eq. 4.16. + dh_buoyancy = 2.6*(f/(s*u_plume))**0.333 ! Briggs 1982, Eq. 59. + + ! Check with old code of routine voorlpl: + ! if (prelim1) then + ! ! voorlpl: dh_buoyancy = 65.*(qw/u_plume)**.333 + ! ! 2.6*(f/(s*u_plume))**0.333 = 2.6*(8.8*qw/(s*u_plume))**0.333 = 2.6*(8.8**.333)*((1/s)**.333)*(qw/u_plume)**.333 + ! write(*,'(a,7(1x,e12.5))') 'ops_plumerise_buoyancy b',hemis0,dh_buoyancy,2.6*(f/s)**0.333,65.*qw**0.333,(grav*1.0e6/(pi*rho0*Cp0*T0)),2.6*((grav*1.0e6/(pi*rho0*Cp0*T0))**.333)*((1.0/s)**.333),Ta_stack + ! char_debug1 = 'b' + ! endif + endif + + ! Check for convergence: + converged = (abs(dh_buoyancy - dh_buoyancy_prev) .lt. epsa + epsr*dh_buoyancy ) + + ! Update for next iteration: + if (.not. converged .and. it .lt. maxit) then + ! Compute wind speed at z = h_stack + 1/2 plume_rise: + if (prelim1) then + call ops_wv_powerlaw(istab,isek,astat,hemis0+dh_buoyancy/2,u_plume,vw10,pcoef) + else + call ops_wvprofile(z0,hemis0+dh_buoyancy/2,uster,ol,u_plume) + endif + dh_buoyancy_prev = dh_buoyancy + endif + it = it + 1 + enddo + ! if (prelim1) write(*,'(a,a1,2(1x,e12.5))') 'ops_plumerise_buoyancy ',char_debug1,hemis0,dh_buoyancy ! char_debug1 the same as in voorlpl + + ! Check for convergence: + ! if (.not. converged) then + ! write(fu_err,*) ' -------------------------------------------------------' + ! write(fu_err,*) ' WARNING, iteration in ops_plumerise has not converged' + ! write(fu_err,*) ' plume rise : ', delh + ! write(fu_err,*) ' plume rise previous iteration: ', delh_prev + ! write(fu_err,*) ' max. number of iterations : ', maxit + ! write(fu_err,*) ' heat content (MW) : ', qw + ! write(fu_err,*) ' stack height : ', hs + ! endif + +ELSE + ! Qw = 0 + dh_buoyancy = 0.0 +ENDIF + +end subroutine ops_plumerise_buoyancy + + +!------------------------------------------------------------ +subroutine ops_plumerise_momentum(u_stack,D_stack,V_stack,Ts_stack,Ta_stack,dthetadz_stable,non_stable,dh_momentum) + +! Subroutine ops_plumerise_momentum computes plume rise due to the momentum of a emission with a vertical exit velocity. +! Fortran-version of STACKS routine impulsstijging.dat (Hans Erbrink). +! Based on: +! C.A. Briggs, Plume Rise (1969) +! Air resources atmospheric turbulence and diffusion laboratory +! Environmental science services administration +! Oak Ridge Tennessee. +! +! See also: D. Bruce Turner, Thomas Chico and Joseph A. Catalano +! TUPOS- A MULTIPLE SOURCE GAUSSIAN DISPERSION +! ALGORITHM USING ON-SITE TURBULENCE DATA +! ATMOSPHERIC SCIENCES RESEARCH LARORATORY +! OFFICE OF RESEARCH AND DEVELOPMENT +! U. S. ENVIRONMENTAL PROTECTION AGENCY +! RESEARCH TRIANGLE PARK, NC +! See also: ISCST3 Tech Guide +! Gaussian Plume Air Dispersion Model +! https://www.weblakes.com/guides/iscst3/section6/6_1_4.html (14-2-2018) + +use m_commonconst, only: EPS_DELTA +use m_ops_utils, only: is_missing + +! Input: +real , intent(in) :: u_stack ! wind speed at stack height [m/s]. For low sources the threshold height of 10m is applied. +real , intent(in) :: D_stack ! stack internal diameter [m] +real , intent(in) :: V_stack ! exit velocity of plume at stack tip [m/s] +real , intent(in) :: Ts_stack ! temperature of effluent from stack [K] +real , intent(in) :: Ta_stack ! ambient temperature at stack height [K] +real , intent(in) :: dthetadz_stable ! fixed potential temperature gradient dtheta/dz [K/m] for stable conditions, used for dh_buoyancy and dh_momentum +logical, intent(in) :: non_stable ! non-stable (unstable/neutral) conditions + +! Output: +real , intent(out) :: dh_momentum ! plume rise due to momentum [m] + +! Local: +real :: dh_nonstable ! plume rise due to momentum in non-stable conditions (unstable/neutral) [m] +real :: dh_stable ! plume rise due to momentum in stable conditions [m] + +if (V_stack .le. 0.0) then + ! No momentum: + dh_momentum = 0.0 +else + + ! Plume rise due to momentum for non-stable (unstable/neutral) conditions (Briggs, 1969, Eq. 5.2) + dh_nonstable = 3*D_stack*V_stack/u_stack + + ! Plume rise due to momentum for stable conditions: + ! 2 2 + ! Vs D_stack 1/3 1/2 -1/6 + ! dh = 0.646 [ --------------- ] (Ta) (dTdz) + ! Ts Us + ! This originates from (Briggs 1969: Eq. 4.28, 4.19b, 4.16), see also Turner et al. (1986): + ! Fm 1/3 -1/6 rhos 2 2 Ps*Ta 2 2 g dtheta + ! dh = 1.5 [ ------- ] [s] ; Fm = ------ (Vs) (r0) = -------- (Vs) 0.25 (D_stack) ; s = [ --- ------ ] + ! u_stack rho P*Ts Ta dz + ! with: + ! Fm = momentum flux parameter (m4/s3) + ! rhos = density of gases emitted from stack (g/m3) + ! rho = average density of ambient air (g/m3) + ! Vs = exit velocity of plume at stack tip (m/s) ( = V_stack below) + ! r0 = internal stack radius (m) + ! ideal gas law: P = rho*R*Ta + ! P = pressure ambient air, Ps = pressure of gases emitted from the stack, R = gas constant + ! Ta = average absolute temperature of ambient air (K) ( = Ta_stack below) + ! Ts = temperature of gases emitted from the stack (K) ( = Ts_stack below) + + ! This can be rewritten to (assuming Ps/P = 1): + ! 2 2 2 2 + ! 1/3 -1/6 Ps Vs D_stack 1/3 1/3 1/6 -1/6 Vs D_stack 1/3 1/2 -1/6 + ! dh = 1.5 * 0.25 * 9.81 [ ---- -------------- ] (Ta) (Ta) (dtheta/dz) = 0.646 [ -------------- ] (Ta) (dtheta/dz) + ! P Ts u_stack Ts u_stack + ! + ! For stable conditions, the lower value of dh_nonstable and dh_stable is chosen (see also Turner et al., 1986) + dh_stable = 0.646 * (( (V_stack**2.)*(D_stack**2.) / (Ts_stack*u_stack) )**(1./3.)) * (Ta_stack**0.5) * (dthetadz_stable**(-1./6.)) + if (dh_stable > dh_nonstable) dh_stable = dh_nonstable + + ! Set output plume rise dh_momentum, depending on stability: + if (non_stable) then + dh_momentum = dh_nonstable + else + dh_momentum = dh_stable + endif + +endif + +end subroutine ops_plumerise_momentum + +!------------------------------------------------------------ +subroutine ops_plume_penetration(hemis0,zmix,zmix_loc,ol,dh,hemis1,onder) +! +! Subroutine to determine whether there is plume penetration. +! +use m_commonconst, only: EPS_DELTA + +! Input +real, intent(in) :: hemis0 ! initial emission height = stack height [m] +real, intent(in) :: zmix ! mixing height [m] +real, intent(in) :: zmix_loc ! mixing height, local scale [m] +real, intent(in) :: ol ! Monin-Obukhov length [m] +real, intent(in) :: dh ! plume rise due to either buoyancy or momentum [m] + +! Input/Output +real, intent(inout) :: hemis1 ! emission height, including plume rise [m] + +! Output +real, intent(out) :: onder ! part of plume below mixing height +! The emission distribution of an area source has a sigma equal to the height of the source hemis0. +! If hemis0 is close to the inversion height, the emission must be distributed over mixing layer and reservoir layer. +! last change: 21 Oct 2002 +! Based on Kincaid data +! +! hemis1 < hemis0 not yet possible (only plume rise is computed here) +! hemis1 = hemis0 is possible +! onder is fraction (0-1) of plume in mixing layer ("onder"= below) +! onder = 1 -> plume completely below mixing height +! onder = 0 -> plume completely above mixing height +if( (hemis0 .gt. zmix + EPS_DELTA) .or. (hemis1 .le. hemis0 + EPS_DELTA) ) then + onder = (zmix - hemis1)/zmix + 0.5 ! OPS +else + onder = (zmix - hemis1)/dh + 0.5 ! Briggs (1975) and NNM +endif +! +! Temperature inversion effects in stable and unstable situations. +! In principle only applicable in situations close to the source, not if mixing height has increased much compared to the local +! mixing height. +! Laatst gewijzigd: 21 Oct 2002 +! +! Stable and unstable conditions and stack < mixing height -> add extra amount plrise_ci_add_stab_unstab to onder; + +if ( hemis0 .lt. zmix_loc .and. abs(ol) .lt. 100 ) then + onder = onder + 0.35 +endif + +! Limit onder, such that 0 <= onder <= 1 +if (onder .gt. (1. + EPS_DELTA)) then + onder = 1. +else if (onder .LT. (0. - EPS_DELTA)) then + onder = 0. +else + continue +endif + +! Plume centre is maximal equal to mixing haight: +if ((hemis1 .gt. (zmix + EPS_DELTA)) .and. (onder .gt. (0. + EPS_DELTA))) then + hemis1 = zmix +endif + +return + +end subroutine ops_plume_penetration + +end module m_ops_plumerise diff --git a/m_ops_utils.f90 b/m_ops_utils.f90 new file mode 100644 index 0000000..d7b0758 --- /dev/null +++ b/m_ops_utils.f90 @@ -0,0 +1,188 @@ +!------------------------------------------------------------------------------------------------------------------------------- +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . +! +! Copyright (C) 2002 by +! National Institute of Public Health and Environment +! Laboratory for Air Research (RIVM/LLO) +! The Netherlands +!------------------------------------------------------------------------------------------------------------------------------- +module m_ops_utils + +! Different utility routines and functions +! +! logical function is_missing(x) : determine whether x is a missing value (-999). +! logical function between_angle(n,a,b): between_angle is true, if angle n is between angles a and b (all angles in radians). +! real function angle180(a) : return angle in interval (-pi,pi]. +! subroutine proj_point : get projected point P' of P on a line segment. + +implicit none + +contains + +!---------------------------------------------------------------------------------------------- +logical function is_missing(x) + +real, intent(in) :: x + +! bandwidth for checking (in)equalities of floats +real, parameter :: EPS = 1.0e-5 + +is_missing = (abs(x + 999.) .le. EPS) + +end function is_missing + +!---------------------------------------------------------------------------------------------- +logical function between_angle(n,a,b) + +use Binas, only: pi + +! between_angle is true, if angle n is between angles a and b (all angles in radians). + +! Input: +real, intent(in) :: n ! angle to be checked +real, intent(in) :: a +real, intent(in) :: b + +! Local +real :: a180 ! angle a transformed to interval (-pi,pi] +real :: b180 ! angle b transformed to interval (-pi,pi] + +!------- +! http://www.monkey-x.com/Community/posts.php?topic=2866 +! +! Function betweenAngle:Bool(n:Float, a:Float, b:Float) +! +! a = Angle180( a - n ) +! b = Angle180( b - n ) +! Return ( Sgn( a ) <> Sgn( b ) ) And ( Abs( a ) + Abs( b ) <= 180 ) Or a = 0 Or b = 0 +! +! End Function +! +! Function Angle180:Float( a:Float ) +! +! a Mod= 360 +! If a > 180 Then Return a-360 +! If a <= -180 Then Return a+360 +! Return a +! +! End Function +!------- + +! Check whether angle n-n is between a-n and b-n; first subtract n from a and b (result between -pi and +pi): +a180 = angle180( a - n ) +b180 = angle180( b - n ) + +! b b +! / \ +! / in_between = true \ in_between = false in_between = false +! / \ +! / \ +! ----------- n ------------- n ---------------- n +! \ / \. +! \ / \ . +! \ / \ . +! \ / \ . +! a a a b + +! 1. a and b on opposite sides (sign(a) .ne. sign(b)) and (angle between a and b) < pi -> in_between = true. +! 2. n is the same angle as a or b -> in_between also true (result is not critical?? otherwise use EPS) +between_angle = (( sign(1.0,a180) .ne. sign(1.0,b180) ) .and. ( abs(a180) + abs(b180) <= pi ) .or. a180 .eq. 0.0 .or. b180 .eq. 0.0) + +! write(*,'(in between f6.1 f6.1 f6.1 !l4)') (180/pi)*n,(180/pi)*a,(180/pi)*b,in_between + +end function between_angle + +!----------------------------------------------------------------------------------- +real function angle180(a) + +use Binas, only: pi + +! Return angle in interval (-pi,pi] +! Input +real, intent(in) :: a ! angle [radians] + +! Local +real :: aa ! angle in interval (-pi,pi] [radians] + +aa = mod(a,2*pi) +if (aa > pi) aa = aa-2*pi +if (aa <= -pi) aa = aa+2*pi + +angle180 = aa + +end function angle180 + +!----------------------------------------------------------------------------------- +subroutine proj_point(v1x,v1y,v2x,v2y,px,py,p_projx,p_projy,fac,len2) + + +! Get projected point P' of P on line segment [v1 v2] and interpolation factor fac +! between v1 and v2, from v1 (fac = 0) to v2 (fac = 1); len2 is squared length of (v2-v1). +! +! P +! | +! | +! | +! v1 ----|--------- v2 +! P' +! +! http://www.sunshine2k.de/coding/java/PointOnLine/PointOnLine.html + +! Input: +real, intent(in) :: v1x ! x-coordinate begin point of segment +real, intent(in) :: v1y ! y-coordinate begin point of segment +real, intent(in) :: v2x ! x-coordinate end point of segment +real, intent(in) :: v2y ! y-coordinate end point of segment +real, intent(in) :: px ! x-coordinate point P +real, intent(in) :: py ! y-coordinate point P + +! Output: +real, intent(out) :: p_projx ! x-coordinate point P' +real, intent(out) :: p_projy ! y-coordinate point P' +real, intent(out) :: fac ! interpolation factor between v1 and v2, from v1 (fac = 0) to v2 (fac = 1) +real, intent(out) :: len2 ! squared length of e1 = v2-v1 + +! Local +real :: e1x,e1y ! coordinates of e1 = v2-v1 +real :: e2x,e2y ! coordinates of e2 = p-v1 +real :: dot_prod ! dot product of e1,e2 + +! e1 = v2-v1: +e1x = v2x - v1x; +e1y = v2y - v1y; + +! e2 = p-v1: +e2x = px - v1x; +e2y = py - v1y; + +! Dot product of e1, e2: +dot_prod = e1x*e2x + e1y*e2y; + +! Squared length of e1: +len2 = e1x*e1x + e1y*e1y; + +! Interpolation factor between v1 and v2, from v1 (fac = 0) and v2 (fac = 1): +fac = dot_prod/len2; + +! Projected point: +! p_proj.x = (v1.x + (dot_product * e1.x) / len2); +! p_proj.y = (v1.y + (dot_product * e1.y) / len2); +p_projx = v1x + fac*e1x; +p_projy = v1y + fac*e1y; + +end subroutine proj_point + +end module m_ops_utils + + diff --git a/m_utils.f90 b/m_utils.f90 index f76473c..c7aca71 100644 --- a/m_utils.f90 +++ b/m_utils.f90 @@ -1146,9 +1146,18 @@ SUBROUTINE byteswap(ishort) ENDIF k1 = mod(ishort, maxint2) k2 = ishort/maxint2 -j = k1*maxint2 + k2 + iflg -IF ( j .GT. 32768 ) THEN - j = j - 65536 +!! The following code may lead to overflow +!! j = k1*maxint2 + k2 + iflg +!! IF ( j .GT. 32768 ) THEN +!! j = j - 65536 +!! ENDIF +IF (k1 > 128) THEN ! 32768/maxint2 = 128 + j = (k1-256)*maxint2 + k2 + iflg ! 256*maxint2 = 65536 +ELSE + j = k1*maxint2 + k2 + iflg + IF ( j .GT. 32768 ) THEN + j = j - 65536 + ENDIF ENDIF ishort = j @@ -1275,6 +1284,15 @@ SUBROUTINE GetOS(os, slash) rtc = GETCWD(directory) +!! ! GETCWD is compiler dependent; alternative with IFNDEF Unix: +!! #ifndef UNIX +!! os = 1 ! Windows +!! IF (PRESENT(slash)) slash = '\' +!! #else +!! os = 0 ! Unix +!! IF (PRESENT(slash)) slash = '/' +!! #endif + colonpos = INDEX(directory,':') IF (ANY(colonpos == (/2,3/)) .AND. directory(colonpos+1:colonpos+1) == '\') THEN diff --git a/ops_bron_rek.f90 b/ops_bron_rek.f90 index ac69c60..4c2ce45 100644 --- a/ops_bron_rek.f90 +++ b/ops_bron_rek.f90 @@ -37,14 +37,16 @@ ! CALLED FUNCTIONS : ! UPDATE HISTORY : !------------------------------------------------------------------------------------------------------------------------------- -SUBROUTINE ops_bron_rek(emtrend, landmax, emis, nsbuf, bnr, bx, by, bdiam, bsterkte, bwarmte, bhoogte, bsigmaz, btgedr, & - & bdegr, bqrv, bqtr, bcatnr, blandnr, eof, error) +SUBROUTINE ops_bron_rek(emtrend, buildingEffect, landmax, emis, nsbuf, bnr, bx, by, bdiam, bsterkte, bwarmte, bhoogte, bsigmaz, bD_stack, bV_stack, bTs_stack, & + bemis_horizontal, bbuilding, btgedr, bdegr, bqrv, bqtr, bcatnr, blandnr, eof, error) USE m_commonconst USE m_commonfile USE m_error USE m_geoutils USE m_fileutils +USE m_ops_building +use m_ops_utils, only: is_missing IMPLICIT NONE @@ -53,7 +55,8 @@ SUBROUTINE ops_bron_rek(emtrend, landmax, emis, nsbuf, bnr, bx, by, bdiam, bster PARAMETER (ROUTINENAAM = 'ops_bron_rek') ! SUBROUTINE ARGUMENTS - INPUT -REAL*4, INTENT(IN) :: emtrend +REAL*4, INTENT(IN) :: emtrend +type(TbuildingEffect) :: buildingEffect ! structure with building effect tables ! SUBROUTINE ARGUMENTS - I/O INTEGER*4, INTENT(INOUT) :: landmax @@ -68,8 +71,13 @@ SUBROUTINE ops_bron_rek(emtrend, landmax, emis, nsbuf, bnr, bx, by, bdiam, bster REAL*4, INTENT(OUT) :: bsterkte(LSBUF) REAL*4, INTENT(OUT) :: bwarmte(LSBUF) REAL*4, INTENT(OUT) :: bhoogte(LSBUF) -REAL*4, INTENT(OUT) :: bsigmaz(LSBUF) -INTEGER*4, INTENT(OUT) :: btgedr(LSBUF) +REAL*4, INTENT(OUT) :: bsigmaz(LSBUF) +REAL*4, INTENT(OUT) :: bD_stack(LSBUF) ! diameter of the stack [m] +REAL*4, INTENT(OUT) :: bV_stack(LSBUF) ! exit velocity of plume at stack tip [m/s] +REAL*4, INTENT(OUT) :: bTs_stack(LSBUF) ! temperature of effluent from stack [K] +LOGICAL, INTENT(OUT) :: bemis_horizontal(LSBUF) ! horizontal outflow of emission +type(Tbuilding), INTENT(OUT) :: bbuilding(LSBUF) ! array with structures with building parameters +INTEGER*4, INTENT(OUT) :: btgedr(LSBUF) INTEGER*4, INTENT(OUT) :: bdegr(LSBUF) REAL*4, INTENT(OUT) :: bqrv(LSBUF) REAL*4, INTENT(OUT) :: bqtr(LSBUF) @@ -81,7 +89,6 @@ SUBROUTINE ops_bron_rek(emtrend, landmax, emis, nsbuf, bnr, bx, by, bdiam, bster ! LOCAL VARIABLES INTEGER*4 :: mm ! INTEGER*4 :: ibtg ! -INTEGER*4 :: ierr ! INTEGER*4 :: ibroncat ! INTEGER*4 :: idgr ! INTEGER*4 :: iland ! country code @@ -96,71 +103,85 @@ SUBROUTINE ops_bron_rek(emtrend, landmax, emis, nsbuf, bnr, bx, by, bdiam, bster REAL*4 :: qww ! REAL*4 :: hbron ! REAL*4 :: szopp ! +REAL*4 :: D_stack ! diameter of the stack [m] +REAL*4 :: V_stack ! exit velocity of plume at stack tip [m/s] +REAL*4 :: Ts_stack ! temperature of effluent from stack [K] +LOGICAL :: emis_horizontal ! horizontal outflow of emission +type(Tbuilding) :: building ! structure with building paramaters REAL*4 :: qrv ! -CHARACTER*80 :: cbuf ! +CHARACTER*512 :: cbuf ! character buffer +REAL :: valueArray(buildingEffect%nParam) ! array with parameters needed to compute building effect +INTEGER :: iParam ! index of building parameter ! SCCS-ID VARIABLES CHARACTER*81 :: sccsida ! sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- -100 FORMAT (i4, 2f8.3, e10.3, f7.3, f6.1, f7.0, f6.1, 4i4) -150 FORMAT (i4, 2f9.0, e10.3, f7.3, f6.1, f8.0, f6.1, 4i4) + 50 FORMAT (i4, 2f9.0, es12.3, f9.3, f6.1, f8.0, f6.1, 3e12.5, l2, 4i4, 4f9.3) ! format for writing to scratch (RDM; includes D_stack, V_stack, Ts_stack, building parameters possibly -999). Also possible -999 for qw ! ! Initialise nsbuf = 0 (no sources in buffer arrays). ! nsbuf = 0 ! -! Read source data until nsbuf = LSBUF or end-of-file +! Read source data from scratch file in block of length LSBUF (or till end-of-file) and put data into buffer arrays of size LSBUF. ! + DO WHILE (nsbuf /= LSBUF) ! ! Read source record cbuf from scratch file ! CALL sysread(fu_scratch, cbuf, eof, error) - IF (error%haserror) GOTO 9999 + IF (error%haserror) GOTO 9998 ! ! If end of file has been reached, nothing is left to do here ! IF (eof) RETURN ! -! If there is a dot at position 9, coordinates are assumed to be lon-lat -! - IF (cbuf(9:9) == '.') THEN +! Read source record with RDM coordinates ! -! Read source record with lon-lat coordinates (gl,gb) -! "g" << geographical coordinates; "l" << lengtegraad = longitude, "b" << breedtegraad = latitude + READ (cbuf, 50) mm, x, y, qob, qww, hbron, diameter, szopp, D_stack, V_stack, Ts_stack, emis_horizontal, ibtg, ibroncat, iland, idgr, building%length, building%width, building%height, building%orientation + nsbuf = nsbuf + 1 -! - READ (cbuf, 100, IOSTAT = ierr) mm, gl, gb, qob, qww, hbron, diameter, szopp, ibtg, ibroncat, iland, idgr - IF (ierr == 0) THEN -! -! Convert lon-lat coordinates to RDM coordinates [m] -! - CALL geo2amc(gb, gl, x, y) - x = AINT(x*1000.) - y = AINT(y*1000.) - ENDIF - ELSE -! -! Read source record with RDM coordinates + !write(*,'(a,i6,10(1x,e12.5),1x,l2,4(1x,i4),4(1x,e12.5))') 'ops_bron_rek a ',mm, x, y, qob, qww, hbron, diameter, szopp, D_stack, V_stack, Ts_stack, emis_horizontal, & + ! ibtg, ibroncat, iland, idgr, building%length, building%width, building%height, building%orientation -! - READ (cbuf, 150, IOSTAT = ierr) mm, x, y, qob, qww, hbron, diameter, szopp, ibtg, ibroncat, iland, idgr - ENDIF -! -! ierr > 0: error occurred while reading. Jump to error section. -! - IF (ierr > 0) GOTO 1000 -! -! ierr < 0: end-of-file. Nothing left to do here (return). -! - IF (ierr < 0) then - eof = .TRUE. - RETURN - ENDIF -! -! ierr = 0: no error or end-of-file; Store data in source buffer arrays. -! + ! Determine building factor function (function of source receptor angle and source receptor distance): + if (is_missing(building%length) .or. is_missing(building%width) .or. is_missing(building%height) .or. is_missing(building%orientation)) then + building%type = 0 ! no building effect + else + building%type = 1 ! building effect is present + + ! Fill array with parameters relevant for building effect (last two values (angle_SR_axis, distance) are filled in subroutine ops_building_get_function and are set to -999 here); + ! parameters must correspond with buildingParamNames(9) = (/'hEmis', 'V_stack', 'D_stack', 'buildingHeight', 'buildingLength', 'buildingWLRatio', 'buildingOrientation', 'angleSRxaxis', 'distance' /) in m_ops_building + ! horizontal emission -> no momentum plume rise -> set valueArray(2) = 0 -> V_stack uses minimal value in table for building effect + if (emis_horizontal) then + valueArray = (/ hbron, 0.0 , D_stack, building%height, building%length, building%width/building%length, building%orientation, -999.0, -999.0 /) + ! valueArray = (/ hbron, -999.0, -999.0 /) ! TEST with three parameters + ! valueArray = (/ 0.0, building%height, hbron, -999.0 /) ! TEST with four parameters as in test6_fs2 + else + valueArray = (/ hbron, V_stack, D_stack, building%height, building%length, building%width/building%length, building%orientation, -999.0, -999.0 /) + ! valueArray = (/ hbron, -999.0, -999.0 /) ! TEST with three parameters + ! valueArray = (/ V_stack, building%height, hbron, -999.0 /) ! TEST with four parameters as in test6_fs2 + endif + + ! Values outside the table input are moved to the boundary of the table ('constant extrapolation'): + do iParam = 1,buildingEffect%nParam + valueArray(iParam) = min(max(valueArray(iParam),buildingEffect%minClass(iParam)),buildingEffect%maxClass(iParam)) + enddo + + ! write(*,*) 'ops_bron_rek/valueArray: ',valueArray + ! write(*,*) 'ops_bron_rek/classdefinitionArray: ',buildingEffect%classdefinitionArray + ! write(*,*) 'ops_bron_rek/nParam = ',buildingEffect%nParam + ! write(*,*) 'ops_bron_rek/nClass = ',buildingEffect%nClass(1:buildingEffect%nParam) + ! write(*,*) 'ops_bron_rek/minClass = ',buildingEffect%minClass(1:buildingEffect%nParam) + ! write(*,*) 'ops_bron_rek/maxClass = ',buildingEffect%maxClass(1:buildingEffect%nParam) + ! write(*,*) 'ops_bron_rek/buildingFactArray(1:10): ',buildingEffect%buildingFactArray(1:10) + + call ops_building_get_function(buildingEffect%nParam, valueArray, buildingEffect%nClass, buildingEffect%classdefinitionArray, & + buildingEffect%buildingFactAngleSRxaxis, buildingEffect%buildingFactDistances, buildingEffect%buildingFactArray, building%buildingFactFunction, error) + ! write(*,*) 'buildingFactFunction = ',building%buildingFactFunction + if (error%haserror) goto 9999 + endif ! Default source strength of traffic and space heating = 0 qtr = 0. @@ -179,7 +200,7 @@ SUBROUTINE ops_bron_rek(emtrend, landmax, emis, nsbuf, bnr, bx, by, bdiam, bster CONTINUE ENDIF - ! Muliply emission with a trend factor for the current year + ! Multiply emission with a trend factor for the current year qob = qob*emtrend qrv = qrv*emtrend qtr = qtr*emtrend @@ -217,34 +238,39 @@ SUBROUTINE ops_bron_rek(emtrend, landmax, emis, nsbuf, bnr, bx, by, bdiam, bster ! ! Store data for this source in buffer array ! - nsbuf = nsbuf + 1 IF (IGEO /= 1) THEN bnr(nsbuf) = mm bx(nsbuf) = NINT(x) by(nsbuf) = NINT(y) + ELSE + write(*,*) 'IGEO in ops_bron_rek = ',IGEO + stop ENDIF - bsterkte(nsbuf) = qob - bwarmte(nsbuf) = qww - bhoogte(nsbuf) = hbron - bdiam(nsbuf) = diameter - bsigmaz(nsbuf) = szopp - btgedr(nsbuf) = ibtg - bdegr(nsbuf) = idgr - bqrv(nsbuf) = qrv - bqtr(nsbuf) = qtr - bcatnr(nsbuf) = ibroncat - blandnr(nsbuf) = iland + bsterkte(nsbuf) = qob + bwarmte(nsbuf) = qww + bhoogte(nsbuf) = hbron + bdiam(nsbuf) = diameter + bsigmaz(nsbuf) = szopp + bD_stack(nsbuf) = D_stack + bV_stack(nsbuf) = V_stack + bTs_stack(nsbuf) = Ts_stack + bemis_horizontal(nsbuf) = emis_horizontal + + bbuilding(nsbuf) = building + btgedr(nsbuf) = ibtg + bdegr(nsbuf) = idgr + bqrv(nsbuf) = qrv + bqtr(nsbuf) = qtr + bcatnr(nsbuf) = ibroncat + blandnr(nsbuf) = iland ENDIF -ENDDO +ENDDO ! Loop over nsbuf RETURN -1000 CALL SetError('Error reading sources', error) -CALL ErrorParam('error number', ierr, error) - -9999 CALL ErrorParam('file', 'scratch', error) -CALL ErrorParam('source number', nsbuf, error) +9998 CALL ErrorParam('file', 'scratch', error) +9999 CALL ErrorParam('source number', nsbuf, error) CALL ErrorCall(ROUTINENAAM, error) END SUBROUTINE ops_bron_rek diff --git a/ops_brondepl.f90 b/ops_brondepl.f90 index a031ac7..e3b300b 100644 --- a/ops_brondepl.f90 +++ b/ops_brondepl.f90 @@ -44,9 +44,10 @@ SUBROUTINE ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc, xl100, vw10, pcoef, virty, radius, zm, & & ra4_rcp, raz_rcp, rc_rcp, rb_rcp, z0_src, ol_src, uster_src, htot, ra4src, rb_src, rcsrc, qbstf, & & vg0tra, onder, flag, vchem, vnatpri, diameter, dispg, cgt, cgt_z, cdn, ugem, hf, a, cq1, cq2, uxr, zu, & - & sigzr, dxeff) + & sigzr, dxeff, error) USE m_commonconst +USE m_error IMPLICIT NONE @@ -97,7 +98,9 @@ SUBROUTINE ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc ! SUBROUTINE ARGUMENTS - I/O REAL*4, INTENT(INOUT) :: cgt ! -REAL*4, INTENT(INOUT) :: cgt_z ! hoogte afhankelijke cgt +REAL*4, INTENT(INOUT) :: cgt_z ! height dependent cgt +TYPE (TError), INTENT(INOUT) :: error ! error handling record + ! SUBROUTINE ARGUMENTS - OUTPUT REAL*4, INTENT(OUT) :: cdn ! @@ -295,8 +298,8 @@ SUBROUTINE ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc a=disx-radius/1.33 ENDIF -! Compute cgt = (1 - grad)(1 - exp[-t/tau]), t = a/ugem, tau = z1/vd(z1) = 4*(Ra + Rb + Rc): -cgt = cgt*(1.-exp(-a/(4.*(ra4_rcp+rb_rcp+rc_rcp)*ugem))) +! Compute cgt = (1 - grad)(1 - exp[-t/tau]), t = a/ugem, tau = z1/vd(z1) = 4*(Ra(4) + Rb + Rc): +cgt = cgt*(1.-exp(-a/(4.*(ra4_rcp+rb_rcp+rc_rcp)*ugem))) cgt_z = cgt_z*(1.-exp(-a/(zm*(raz_rcp+rb_rcp+rc_rcp)*ugem))) !----------------------------------------------------------------------------------------------------------- @@ -318,7 +321,7 @@ SUBROUTINE ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc ! at the top of the mixing layer and at the ground surface ! s2 : sigma_z at x ! - CALL ops_vertdisp(z0_src, xl, ol_src, uster_src, htot, radius*2., uxr, zu, s2) ! output uxr is not used here + CALL ops_vertdisp(z0_src, xl, ol_src, uster_src, htot, radius*2., uxr, zu, s2, error) ! output uxr is not used here sigzr = s2/alog((htot + s2)/htot) ! (see OPS-doc/dispersion, bookmark area_source_sigma_z) for sigma_zi = htot ! s2 = sigma_z(r2), s1 = sigma_z(r1) = 0 diff --git a/ops_calc_stats.f90 b/ops_calc_stats.f90 index f735df1..e74b7ce 100644 --- a/ops_calc_stats.f90 +++ b/ops_calc_stats.f90 @@ -137,8 +137,16 @@ SUBROUTINE ops_calc_stats(nrrcp, frac, cpri, csec, drydep, wetdep, gemre, sdrypr gemddep = somddep/somfrac gemddpri = sdrypri/somfrac*ugmoldep*amol21 gemddsec = sdrysec/somfrac*ugmoldep -ddrpri = sdrypri/somcpri/36 ! factor 36 from conversion of [ug/m2/h]/[ug/m3] to [cm/s] -ddrsec = sdrysec/somcsec/36 +if (somcpri .gt. 0.0) then + ddrpri = sdrypri/somcpri/36 ! factor 36 from conversion of [ug/m2/h]/[ug/m3] to [cm/s] +else + ddrpri = -999.0 +endif +if (somcsec .gt. 0.0) then + ddrsec = sdrysec/somcsec/36 +else + ddrsec = -999.0 +endif ! (3) wet deposition IF (ABS(somvnpri) .LE. DPEPS_DELTA) THEN diff --git a/ops_conc_ini.f90 b/ops_conc_ini.f90 index c55c21f..d632d72 100644 --- a/ops_conc_ini.f90 +++ b/ops_conc_ini.f90 @@ -35,9 +35,10 @@ ! UPDATE HISTORY : !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE ops_conc_ini(gasv, vw10, htt, pcoef, disx, kdeel, qbpri, z0_src, szopp, rond, uster_src, ol_src, istab, iwd, qww, & - & hbron,dispg, radius, xl, onder, htot, grof, c, sigz, ueff, virty, ccc) + & hbron,dispg, radius, xl, onder, htot, grof, c, sigz, ueff, virty, ccc, error) USE m_commonconst +USE m_error IMPLICIT NONE @@ -68,6 +69,8 @@ SUBROUTINE ops_conc_ini(gasv, vw10, htt, pcoef, disx, kdeel, qbpri, z0_src, szop REAL*4, INTENT(INOUT) :: radius ! REAL*4, INTENT(INOUT) :: xl ! REAL*4, INTENT(INOUT) :: onder ! +TYPE (TError), INTENT(INOUT) :: error ! error handling record + ! SUBROUTINE ARGUMENTS - OUTPUT REAL*4, INTENT(OUT) :: htot ! plume height, including plume descent due to heavy particles [m] @@ -173,7 +176,7 @@ SUBROUTINE ops_conc_ini(gasv, vw10, htt, pcoef, disx, kdeel, qbpri, z0_src, szop ! Compute concentration for this distance and meteo class ! CALL ops_conltexp(rond, ol_src, qbpri, szopp, uster_src, z0_src, htt, onder, vw10, pcoef, istab, disx, grof, iwd, qww, hbron, & - & dispg, radius, htot, ccc, sigz, ueff, xl, virty) + & dispg, radius, htot, ccc, sigz, ueff, xl, virty, error) ! ! Correct for plume below or above the mixing layer; mass above the mixing layer does not contribute to ! concentration at surface. diff --git a/ops_conc_rek.f90 b/ops_conc_rek.f90 index 384a8cc..2b0f6e1 100644 --- a/ops_conc_rek.f90 +++ b/ops_conc_rek.f90 @@ -40,7 +40,8 @@ SUBROUTINE ops_conc_rek(ueff, qbpri, isec, rcsec, routsec, ccc, amol1, amol2, si & rb_rcp, amol21, ugmoldep, cch, cgt, cgt_z, grof, percvk, onder, regenk, virty, ri, vw10, hbron, pcoef, & & rkc, disx, vnatpri, vchem, radius, xl, xloc, htot, twt, rb, ra50, xvghbr, xvglbr, grad, frac, & & cdn, cq2, c, sdrypri, sdrysec, snatsec, somvnsec, telvnsec, vvchem, vtel, snatpri, somvnpri, & - & telvnpri, ddepri, drydep, wetdep, dm, qsec, consec, pr, vg50trans, ra50tra, rb_tra, rclocal, vgpart, xg) + & telvnpri, ddepri, drydep, wetdep, dm, qsec, consec, pr, vg50trans, ra50tra, rb_tra, rclocal, vgpart, xg,& + & buildingFact) USE m_commonconst @@ -99,6 +100,7 @@ SUBROUTINE ops_conc_rek(ueff, qbpri, isec, rcsec, routsec, ccc, amol1, amol2, si REAL*4, INTENT(IN) :: rb_tra ! REAL*4, INTENT(IN) :: rclocal ! REAL*4, INTENT(IN) :: vgpart ! +REAL*4, INTENT(IN) :: buildingFact ! Building Effect interpolated from building table ! SUBROUTINE ARGUMENTS - I/O REAL*4, INTENT(INOUT) :: cdn ! @@ -167,8 +169,8 @@ SUBROUTINE ops_conc_rek(ueff, qbpri, isec, rcsec, routsec, ccc, amol1, amol2, si ! meaning that the concentration is higher due to sedimentation ! vv = total source depletion factor for primary component ! -c_z = c*cdn*cch*(1. - cgt_z)*(1. - (1. - cq2)/(1. + grof)) -c = c*cdn*cch*(1. - cgt)*(1. - (1. - cq2)/(1. + grof)) +c_z = c*cdn*cch*(1. - cgt_z)*(1. - (1. - cq2)/(1. + grof))*buildingFact +c = c*cdn*cch*(1. - cgt)*(1. - (1. - cq2)/(1. + grof))*buildingFact vv = cdn*cq2*cch ! @@ -273,6 +275,7 @@ SUBROUTINE ops_conc_rek(ueff, qbpri, isec, rcsec, routsec, ccc, amol1, amol2, si CALL ops_seccmp(qbpri, ueff, rcsec, routsec, ccc, vv, amol1, amol2, xvg, sigz, grad, utr, radius, disx, xl, xloc, vw10, & & pcoef, virty, regenk, htot, onder, twt, ri, rb, ra50, cgt, xvghbr, xvglbr, vnatpri, vchem, ra4_rcp, & & ra50_rcp, rb_rcp, rc_sec_rcp, pr, vnatsec, cgtsec, vgsec, qsec, consec, vg50trans, ra50tra, rb_tra, xg) + consec = consec*buildingFact ! ! Compute for secondary component: ! vg_sec_rcp: dry deposition velocity [m/s] diff --git a/ops_conltexp.f90 b/ops_conltexp.f90 index 2a15697..05584aa 100644 --- a/ops_conltexp.f90 +++ b/ops_conltexp.f90 @@ -42,9 +42,10 @@ ! UPDATE HISTORY : !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE ops_conltexp(rond, ol, qbron, szopp, uster, z0, htt, onder, vw10, pcoef, istab, disx, grof, iwd, qww, hbron, & - & dispg, radius, htot, c, sigz, ueff, xl, virty) + & dispg, radius, htot, c, sigz, ueff, xl, virty, error) USE m_commonconst +USE m_error IMPLICIT NONE @@ -82,6 +83,8 @@ SUBROUTINE ops_conltexp(rond, ol, qbron, szopp, uster, z0, htt, onder, vw10, pco ! SUBROUTINE ARGUMENTS - I/O REAL*4, INTENT(INOUT) :: radius ! REAL*4, INTENT(INOUT) :: htot ! +TYPE (TError), INTENT(INOUT) :: error ! error handling record + ! SUBROUTINE ARGUMENTS - OUTPUT REAL*4, INTENT(OUT) :: c ! long-term concentation at receptor at z = 0; excluding removal processes @@ -214,6 +217,8 @@ SUBROUTINE ops_conltexp(rond, ol, qbron, szopp, uster, z0, htt, onder, vw10, pco ! CALL par_puntbr(qww, istab, disx, disp, htt, htot, hbron, dispg, sigz, hf, a, virty) ENDIF + if (error%debug) write(*,'(3a,2(1x,i6),99(1x,e12.5))') trim(ROUTINENAAM),',A,',' ircp,istab,qww, disx, disp, htt, htot, hbron, onder, pld, dispg(istab), sigz, hf, a, virty:', & + -999,istab,qww, disx, disp, htt, htot, hbron, onder, pld, dispg(istab), sigz, hf, a, virty ! ! Compute help variable pp = sigma_z/mixing_height = sigma_z/zi ! @@ -380,6 +385,8 @@ SUBROUTINE ops_conltexp(rond, ol, qbron, szopp, uster, z0, htt, onder, vw10, pco !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE par_oppbr(rond, iwd, disx, istab, disp, htt, grof, dispg, zwcor, radius, sz, virty, rr, sigz, pld, htot) +USE Binas, only: deg2rad + ! CONSTANTS CHARACTER*512 :: ROUTINENAAM ! PARAMETER (ROUTINENAAM = 'par_oppbr') @@ -438,8 +445,8 @@ SUBROUTINE par_oppbr(rond, iwd, disx, istab, disp, htt, grof, dispg, zwcor, radi ! Square area source; ! Compute correction factor cr for corrected source radius r' = r*cr, such that r' represents a square area source ! - dx = ABS(radius*SIN(FLOAT(iwd)/CONV)) - dy = ABS(radius*COS(FLOAT(iwd)/CONV)) + dx = ABS(radius*SIN(FLOAT(iwd)*deg2rad)) + dy = ABS(radius*COS(FLOAT(iwd)*deg2rad)) rr = AMAX1(dx, dy) cr = radius/rr ENDIF diff --git a/ops_depoparexp.f90 b/ops_depoparexp.f90 index 451d563..375802e 100644 --- a/ops_depoparexp.f90 +++ b/ops_depoparexp.f90 @@ -257,7 +257,7 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc routpri = RORATIO(kdeel) ENDIF ! -! Coarse particles; +! Gas or fine particles (grof .ne. 1); ! compute deposition velocity vg = 1/(Ra + Rb + Rc) at different locations/heights and ! grad = depositon velocity gradient over height = vg(50)/vg(4) ! @@ -269,12 +269,12 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc grad = (ra4_rcp + rb_rcp + rc_rcp)/ (ra50_rcp + rb_rcp + rc_rcp) grad_z = (raz_rcp + rb_rcp + rc_rcp)/ (ra50_rcp + rb_rcp + rc_rcp) ! -! Fine particles; +! Coarse particles (grof = 1); ! get deposition velocity vg = 1/(Ra + Rb + Rc) at different locations/heights and ! set grad = depositon velocity gradient over height = 1 ! ELSE - vg50_rcp = VGDEEL(kdeel) + vg50_rcp = VGDEEL(kdeel) vgpart = VGDEEL(kdeel) vg50tra = vg50_rcp vg0tra = vg50_rcp @@ -322,7 +322,7 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc ! F(50) = F(4) <=> -vd(50)*c(50) = -vd(4)*c(4) <=> ------ = ------ <=> c(4) = grad*c(50) ! vd(4) c(50) ! vg(z2) -! Note: cgt = (1 - grad) = (1 - -------) is ued as input for ops_brondepl (see there). +! Note: cgt = (1 - grad) = (1 - -------) is used as input for ops_brondepl (see there). ! vg(z1) ! cgt = 1. - grad @@ -520,7 +520,7 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc CALL ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc, xl100, vw10, pcoef, virty, radius, zm, & & ra4_rcp, raz_rcp, rc_rcp, rb_rcp, z0_src, ol_src, uster_src, htot, ra4src, rb_src, rcsrc, qbstf, vg0tra, & - & onder, flag, vchem, vnatpri, diameter, dispg, cgt, cgt_z, cdn, ugem, hf, a, cq1, cq2, uxr, zu, sigzr, dxeff) + & onder, flag, vchem, vnatpri, diameter, dispg, cgt, cgt_z, cdn, ugem, hf, a, cq1, cq2, uxr, zu, sigzr, dxeff, error) ! ! In order to compute utr = average wind speed over the trajectory, the plume is split into three parts ! (x: source receptor distance, R: radius area source, u: wind speed): diff --git a/ops_depos_rc.f90 b/ops_depos_rc.f90 index cd93a76..af82b04 100644 --- a/ops_depos_rc.f90 +++ b/ops_depos_rc.f90 @@ -36,7 +36,7 @@ ! CALLED FUNCTIONS : depac ! UPDATE HISTORY : !------------------------------------------------------------------------------------------------------------------------------- -SUBROUTINE ops_depos_rc(icm, iseiz, mb, gym ,tem, uster, glrad, hum, nwet, ratns, catm, c_ave_prev, lu_per, ra, rb, rc_eff_pos, rc_eff) +SUBROUTINE ops_depos_rc(icm, iseiz, mb, gym ,temp_C, uster, glrad, hum, nwet, ratns, catm, c_ave_prev, lu_per, ra, rb, rc_eff_pos, rc_eff) USE m_commonconst USE m_depac318 @@ -54,7 +54,7 @@ SUBROUTINE ops_depos_rc(icm, iseiz, mb, gym ,tem, uster, glrad, hum, nwet, ratns INTEGER*4, INTENT(IN) :: nwet ! REAL*4, INTENT(IN) :: hum ! REAL*4, INTENT(IN) :: uster ! friction velocity [m/s] -REAL*4, INTENT(IN) :: tem ! +REAL*4, INTENT(IN) :: temp_C ! temperature at height zmet_T [C] REAL*4, INTENT(IN) :: gym ! REAL*4, INTENT(IN) :: glrad ! REAL*4, INTENT(IN) :: ratns ! @@ -155,7 +155,7 @@ SUBROUTINE ops_depos_rc(icm, iseiz, mb, gym ,tem, uster, glrad, hum, nwet, ratns ! ccomp_tot : total compensation point (is not used here) ! rc_eff_depac: effective Rc (includes effect of compensation point); rc_eff_depac depends on the value of Ra and Rb. ! - CALL depac318(CNAME(icm,5), day_of_year, gym ,tem, uster, glrad, sinphi, hum, nwet, luclass, nint(ratns), & + CALL depac318(CNAME(icm,5), day_of_year, gym ,temp_C, uster, glrad, sinphi, hum, nwet, luclass, nint(ratns), & & rc_tot, c_ave_prev, max(catm,catm_min), ccomp_tot, ra, rb, rc_eff_depac) ! ! Detect missing values and set default values diff --git a/ops_gen_fnames.f90 b/ops_gen_fnames.f90 index 01dcaa1..e0b5fc9 100644 --- a/ops_gen_fnames.f90 +++ b/ops_gen_fnames.f90 @@ -72,6 +72,7 @@ SUBROUTINE ops_gen_fnames(gasv, spgrid, intpol, error) !------------------------------------------------------------------------------------------------------------------------------- ! Standard file for diurnal variations of emissions CALL MakeCommonPath(DVFILE, dvnam, error) + ! Standard file for particle size distributions IF (.NOT.gasv) THEN CALL MakeCommonPath(PSDFILE, psdnam, error) diff --git a/ops_gen_precip.f90 b/ops_gen_precip.f90 index 4c643a6..a35bba7 100644 --- a/ops_gen_precip.f90 +++ b/ops_gen_precip.f90 @@ -72,6 +72,10 @@ SUBROUTINE ops_gen_precip(uurtot, astat, trafst, precip, error) REAL*4 :: qww ! heat content of source, dummy input for ops_statparexp; ! setting it to 0 prevents unnecessary computation of plume rise ! in ops_statparexp +REAL*4 :: V_stack ! here a dummy +REAL*4 :: Ts_stack ! here a dummy +LOGICAL :: emis_horizontal ! here a dummy +REAL*4 :: D_stack ! here a dummy REAL*4 :: vw10 ! here a dummy REAL*4 :: aksek(12) ! here a dummy REAL*4 :: h0 ! here a dummy @@ -81,7 +85,7 @@ SUBROUTINE ops_gen_precip(uurtot, astat, trafst, precip, error) REAL*4 :: rcaerd ! here a dummy REAL*4 :: rcnh3d ! here a dummy REAL*4 :: rcno2d ! here a dummy -REAL*4 :: tem ! here a dummy +REAL*4 :: temp_C ! here a dummy REAL*4 :: uster ! here a dummy REAL*4 :: pcoef ! here a dummy REAL*4 :: htot ! here a dummy @@ -97,7 +101,7 @@ SUBROUTINE ops_gen_precip(uurtot, astat, trafst, precip, error) REAL*4 :: xl100 ! here a dummy REAL*4 :: rad ! here a dummy REAL*4 :: rcso2 ! here a dummy -REAL*4 :: temp ! here a dummy +REAL*4 :: coef_space_heating ! here a dummy REAL*4 :: buil ! here a dummy REAL*4 :: regenk REAL*4 :: rint @@ -115,6 +119,10 @@ SUBROUTINE ops_gen_precip(uurtot, astat, trafst, precip, error) hbron = 10 radius = 0 qww = 0 +D_stack = -999. +V_stack = -999. +Ts_stack = -999. +emis_horizontal = .FALSE. ! Initialise summed precipitation for this receptorpoint: precip=0 @@ -128,9 +136,9 @@ SUBROUTINE ops_gen_precip(uurtot, astat, trafst, precip, error) ! percvk (fraction of occurrence of meteo class) for this wind direction sector and stability class ! - CALL ops_statparexp(istab, hbron, qww, iwd, radius, uurtot, astat, trafst, disx, isek, disxx, isekt, vw10, aksek, h0, & - & hum, ol, shear, rcaerd, rcnh3d, rcno2d, tem, uster, pcoef, htot, htt, itra, aant, xl, rb, ra4, & - & ra50, xvglbr, xvghbr, xloc, xl100, rad, rcso2, temp, regenk, buil, rint, percvk, error) + CALL ops_statparexp(istab, hbron, qww, D_stack, V_stack, Ts_stack, emis_horizontal, iwd, radius, uurtot, astat, trafst, disx, isek, disxx, isekt, vw10, aksek, h0, & + & hum, ol, shear, rcaerd, rcnh3d, rcno2d, temp_C, uster, pcoef, htot, htt, itra, aant, xl, rb, ra4, & + & ra50, xvglbr, xvghbr, xloc, xl100, rad, rcso2, coef_space_heating, regenk, buil, rint, percvk, error) IF (error%haserror) GOTO 9999 ! ! Add contribution to precipitation amount (8760 = number of hours in a year) diff --git a/ops_init.f90 b/ops_init.f90 index 655ac58..b04a6cf 100644 --- a/ops_init.f90 +++ b/ops_init.f90 @@ -36,14 +36,14 @@ ! CALLED FUNCTIONS : ops_masknew, amcgeo ! UPDATE HISTORY : !------------------------------------------------------------------------------------------------------------------------------- -SUBROUTINE ops_init (gasv, idep, kdeppar, knatdeppar, ddeppar, wdeppar, amol2, ideh, icm, isec, iseiz, mb, astat, dverl, & +SUBROUTINE ops_init (gasv, idep, building_present1, kdeppar, knatdeppar, ddeppar, wdeppar, amol2, ideh, icm, isec, iseiz, mb, astat, dverl, & & usdverl, dv, usdv, namco, amol1, dg, irev, vchemc, vchemv, emtrend, rc, coneh, amol21, depeh, namsec, & & namse3, ugmoldep, scavcoef, rcno, rhno2, rchno3, routsec, routpri, conc_cf, koh, croutpri, somcsec, & - & ar, rno2nox, ecvl, namseccor) + & ar, rno2nox, ecvl, namseccor, buildingEffect, error) USE m_commonconst -USE m_commonfile USE m_error +USE m_ops_building IMPLICIT NONE @@ -53,7 +53,8 @@ SUBROUTINE ops_init (gasv, idep, kdeppar, knatdeppar, ddeppar, wdeppar, amol2, i ! SUBROUTINE ARGUMENTS - INPUT LOGICAL, INTENT(IN) :: gasv -LOGICAL, INTENT(IN) :: idep +LOGICAL, INTENT(IN) :: idep +LOGICAL, INTENT(IN) :: building_present1 ! at least one building is present in the source file INTEGER*4, INTENT(IN) :: kdeppar REAL*4, INTENT(IN) :: ddeppar REAL*4, INTENT(IN) :: wdeppar @@ -63,8 +64,8 @@ SUBROUTINE ops_init (gasv, idep, kdeppar, knatdeppar, ddeppar, wdeppar, amol2, i INTEGER*4, INTENT(IN) :: iseiz INTEGER*4, INTENT(IN) :: mb REAL*4, INTENT(IN) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) -REAL*4, INTENT(IN) :: dverl(NHRBLOCKS,MAXDIST) -REAL*4, INTENT(IN) :: usdverl(NHRBLOCKS,MAXDIST) +REAL*4, INTENT(IN) :: dverl(NHRBLOCKS,MAXDISTR) +REAL*4, INTENT(IN) :: usdverl(NHRBLOCKS,MAXDISTR) INTEGER*4, INTENT(IN) :: dv INTEGER*4, INTENT(IN) :: usdv @@ -102,16 +103,21 @@ SUBROUTINE ops_init (gasv, idep, kdeppar, knatdeppar, ddeppar, wdeppar, amol2, i REAL*4, INTENT(OUT) :: ar REAL*4, INTENT(OUT) :: rno2nox REAL*4, INTENT(OUT) :: ecvl(NSTAB, NTRAJ, *) -CHARACTER*(*), INTENT(OUT) :: namseccor +CHARACTER*(*), INTENT(OUT) :: namseccor +type(TbuildingEffect), INTENT(OUT) :: buildingEffect ! structure with building effect tables +TYPE (TError), INTENT(OUT) :: error ! error handling record + ! LOCAL VARIABLES INTEGER*4 :: i +INTEGER*4 :: j INTEGER*4 :: ndv INTEGER*4 :: itraj INTEGER*4 :: istab INTEGER*4 :: iu REAL*4 :: vgmax -REAL*4 :: som +REAL*4 :: som +CHARACTER*512 :: line ! SCCS-ID VARIABLES CHARACTER*81 :: sccsida ! @@ -274,6 +280,8 @@ SUBROUTINE ops_init (gasv, idep, kdeppar, knatdeppar, ddeppar, wdeppar, amol2, i ELSE ! conversion ug/m2/h -> g/m2/j: ugmoldep = 8.76/1000. ENDIF +ELSE + ugmoldep = 1.0 ENDIF IF (icm .EQ. 2) THEN @@ -374,5 +382,16 @@ SUBROUTINE ops_init (gasv, idep, kdeppar, knatdeppar, ddeppar, wdeppar, amol2, i ENDDO ENDDO +! Read building effect tables: +if (building_present1) then + call ops_building_read_tables(buildingEffect,error) + !write(*,*) 'ops_init/classdefinitionArray: ',buildingEffect%classdefinitionArray + !write(*,*) 'ops_init/buildingFactArray:',buildingEffect%buildingFactArray + if (error%haserror) goto 9999 +endif + RETURN + +9999 CALL ErrorCall(ROUTINENAAM, error) + END SUBROUTINE ops_init diff --git a/ops_logfile.f90 b/ops_logfile.f90 index 8a9fb2b..f99ff41 100644 --- a/ops_logfile.f90 +++ b/ops_logfile.f90 @@ -38,7 +38,7 @@ !------------------------------------------------------------------------------------------------------------------------------- ! Function ops_openlog ! Purpose Opens log file if not done before. -! Uses logname in COMMONLOG, which is the name of the log file. +! Uses lognam in m_commonfile, which is the name of the log file. !------------------------------------------------------------------------------------------------------------------------------- FUNCTION ops_openlog(error) @@ -71,7 +71,7 @@ FUNCTION ops_openlog(error) INQUIRE(UNIT = fu_log, OPENED = isopen) IF (.NOT. isopen) THEN - IF (.NOT.sysopen(fu_log, logname, 'w', 'log file', error)) THEN + IF (.NOT.sysopen(fu_log, lognam, 'w', 'log file', error)) THEN CALL ErrorCall(ROUTINENAAM, error) ops_openlog =.FALSE. ENDIF @@ -83,7 +83,7 @@ END FUNCTION ops_openlog !------------------------------------------------------------------------------------------------------------------------------- ! Subroutine ops_closelog ! Purpose Closes the log file if it is open. -! Uses logname in COMMONLOG, which is the name of the log file. +! Uses lognam in m_commonfile, which is the name of the log file. !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE ops_closelog(error) @@ -113,7 +113,7 @@ SUBROUTINE ops_closelog(error) ! INQUIRE(UNIT = fu_log, OPENED = isopen) IF (isopen) THEN - CALL sysclose(fu_log, logname, error) + CALL sysclose(fu_log, lognam, error) IF (.NOT.haderror .AND. error%haserror) THEN CALL ErrorCall(ROUTINENAAM, error) ENDIF diff --git a/ops_main.f90 b/ops_main.f90 index 7e3837f..9272a84 100644 --- a/ops_main.f90 +++ b/ops_main.f90 @@ -65,6 +65,7 @@ !------------------------------------------------------------------------------------------------------------------------------- PROGRAM opsmode +USE m_ops_building USE m_aps USE m_depac318 USE m_utils @@ -95,7 +96,8 @@ PROGRAM opsmode INTEGER*4 :: blandnr(LSBUF) INTEGER*4 :: bx(LSBUF) INTEGER*4 :: by(LSBUF) -INTEGER*4 :: bnr(LSBUF) +INTEGER*4 :: bnr(LSBUF) +type(TbuildingEffect) :: buildingEffect ! structure with building effect tables INTEGER*4 :: jb INTEGER*4 :: mb INTEGER*4 :: idb @@ -146,7 +148,6 @@ PROGRAM opsmode REAL*4 :: rc REAL*4 :: ugmoldep REAL*4 :: gemre -REAL*4 :: gemtemp REAL*4 :: somcsec REAL*4 :: gemcpri REAL*4 :: gemcsec @@ -172,8 +173,14 @@ PROGRAM opsmode REAL*4 :: bsterkte(LSBUF) REAL*4 :: bwarmte(LSBUF) REAL*4 :: bhoogte(LSBUF) -REAL*4 :: bsigmaz(LSBUF) -REAL*4 :: emis(6,NLANDMAX) +REAL*4 :: bsigmaz(LSBUF) +REAL*4 :: bD_stack(LSBUF) ! diameter of the stack [m] +REAL*4 :: bV_stack(LSBUF) ! exit velocity of plume at stack tip [m/s] +REAL*4 :: bTs_stack(LSBUF) ! temperature of effluent from stack [K] +LOGICAL :: bemis_horizontal(LSBUF) ! horizontal outflow of emission +type(Tbuilding) :: bbuilding(LSBUF) ! array with structures with building parameters +LOGICAL :: building_present1 ! at least one building is present in the source file +REAL*4 :: emis(6,NLANDMAX) REAL*4 :: conc_cf REAL*4 :: astat(NTRAJ, NCOMP, NSTAB, NSEK) REAL*4 :: ar @@ -185,16 +192,15 @@ PROGRAM opsmode REAL*4 :: bqtr(LSBUF) REAL*4 :: cs(NTRAJ, NCOMP, NSTAB, NSEK, NMETREG) REAL*4 :: rainreg(NMETREG) -REAL*4 :: tempreg(NMETREG) REAL*4 :: z0_metreg(NMETREG) ! roughness lengths of NMETREG meteo regions; scale < 50 km [m] REAL*4 :: xreg(NMETREG) REAL*4 :: yreg(NMETREG) REAL*4 :: hourreg(NMETREG) -REAL*4 :: ecvl(NSTAB, NTRAJ,2*MAXDIST) -REAL*4 :: dverl(NHRBLOCKS,MAXDIST) -REAL*4 :: usdverl(NHRBLOCKS,MAXDIST) -REAL*4 :: pmd(NPARTCLASS,MAXDIST) -REAL*4 :: uspmd(NPARTCLASS,MAXDIST) +REAL*4 :: ecvl(NSTAB, NTRAJ,2*MAXDISTR) +REAL*4 :: dverl(NHRBLOCKS,MAXDISTR) +REAL*4 :: usdverl(NHRBLOCKS,MAXDISTR) +REAL*4 :: pmd(NPARTCLASS,MAXDISTR) +REAL*4 :: uspmd(NPARTCLASS,MAXDISTR) REAL*4 :: amol1 REAL*4 :: emtrend REAL*4 :: grid @@ -256,7 +262,7 @@ PROGRAM opsmode CHARACTER*80 :: dll_date LOGICAL*4 :: f_z0user -LOGICAL :: presentcode(MAXDIST,4) +LOGICAL :: presentcode(MAXDISTR,4) LOGICAL :: verb LOGICAL :: isec LOGICAL :: igrens @@ -335,8 +341,9 @@ PROGRAM opsmode DATA no2sek /0.81, 0.88, 1.08, 1.30, 1.33, 1.40, 1.25, 1.03, 0.83, 0.71, 0.70, 0.68/ ! Initialise +error%debug = .FALSE. ! if true -> debug parameters are written to screen; only useful for a limited number of receptors and sources verb = .FALSE. -error%haserror = .FALSE. ! no error detected yet +error%haserror = .FALSE. ! no error detected yet ! ! Read program arguments and determine the name of the control file, which may be derived from the current working directory. ! As a first parameter the diag flag is returned. @@ -367,9 +374,9 @@ PROGRAM opsmode WRITE (6,*) 'Verbose is: ', verb ! -! Get the file names for process monitoring (log, error and progress files) +! Make the file names for process monitoring (log, error and progress files) ! -CALL ops_monitor(logname, error) +CALL MakeMonitorNames(error) IF (error%haserror) GOTO 1000 ! GOTO error handling at end of program ! ! Allocate memory for catsel and landsel @@ -393,14 +400,21 @@ PROGRAM opsmode ! ! Read source file and copy selected sources to scratch ! -CALL ops_read_emis(icm, gasv, ncatsel, catsel, nlandsel, landsel, spgrid, grid, numbron, dverl, usdverl, pmd, uspmd, dv, & - & usdv, presentcode, error) +CALL ops_read_emis(icm, gasv, ncatsel, catsel, nlandsel, landsel, numbron, dverl, usdverl, pmd, uspmd, dv, & + & usdv, presentcode, building_present1, error) IF (error%haserror) GOTO 1000 ! GOTO error handling at end of program + +! Set file names for building effect tables: +if (building_present1) then + call ops_building_file_names(error) + IF (error%haserror) GOTO 1000 ! GOTO error handling at end of program +endif + ! ! Read meteo statistics ! -CALL ops_read_meteo (intpol, jb, mb, idb, jt, mt, idt, uurtot, iseiz, zf, astat, trafst, gemre, gemtemp, z0_metreg_user, cs, rainreg, & - & tempreg, z0_metreg, xreg, yreg, hourreg, error) +CALL ops_read_meteo (intpol, jb, mb, idb, jt, mt, idt, uurtot, iseiz, zf, astat, trafst, gemre, z0_metreg_user, cs, rainreg, & + & z0_metreg, xreg, yreg, hourreg, error) IF (error%haserror) GOTO 1000 ! GOTO error handling at end of program ! ! Read roughness length (z0) grids for NL and Europe and land use values. @@ -461,10 +475,10 @@ PROGRAM opsmode ! ! Initialisation ! -CALL ops_init (gasv, idep, kdeppar, knatdeppar, ddeppar, wdeppar, amol2, ideh, icm, isec, iseiz, mb, astat, dverl, & +CALL ops_init (gasv, idep, building_present1, kdeppar, knatdeppar, ddeppar, wdeppar, amol2, ideh, icm, isec, iseiz, mb, astat, dverl, & & usdverl, dv, usdv, namco, amol1, dg, irev, vchemc, vchemv, emtrend, rc, coneh, amol21, depeh, namsec, & & namse3, ugmoldep, scavcoef, rcno, rhno2, rchno3, routsec, routpri, conc_cf, koh, croutpri, somcsec, & - & ar, rno2nox, ecvl, namseccor) + & ar, rno2nox, ecvl, namseccor, buildingEffect, error) IF (error%haserror) GOTO 3300 ! GOTO deallocate all arrays and do error handling at end of program. ! Allocate miscellaneous arrays for receptor points @@ -479,7 +493,8 @@ PROGRAM opsmode ! Fill arrays with roughness length, landuse and rhno3_rcp for all receptor points ! CALL ops_rcp_char_all(icm, isec, xm, ym, f_z0user, z0_user, z0nlgrid, z0eurgrid, lugrid, so2bggrid, nh3bggrid, nrrcp, gxm, gym, & - & lu_rcp_dom_all, z0_rcp_all, rhno3_rcp, nh3bg_rcp, domlu) + & lu_rcp_dom_all, z0_rcp_all, rhno3_rcp, nh3bg_rcp, domlu, error) + ! ! Allocate other arrays for receptor points; ! directly after deallocating memory for different grids, some other receptor-vectors are allocated (see below). @@ -550,14 +565,14 @@ PROGRAM opsmode maxidx = NPARTCLASS ENDIF ! -! start loop over sources (until end-of-file of scratch file with sources) +! start loop over source data blocks of length LSBUF (until end-of-file of scratch file with source data) ! DO WHILE (.NOT. eof) ! - ! read source characteristics from scratch file and fill into buffer (sources are read in - ! blocks of length LSBUF (LSBUF=40)) + ! read source characteristics from scratch file and fill into buffer arrays (source data are read in + ! blocks of length LSBUF (LSBUF=4000)) ! - CALL ops_bron_rek (emtrend, landmax, emis, nsbuf, bnr, bx, by, bdiam, bsterkte, bwarmte, bhoogte, bsigmaz, btgedr, & + CALL ops_bron_rek (emtrend, buildingEffect, landmax, emis, nsbuf, bnr, bx, by, bdiam, bsterkte, bwarmte, bhoogte, bsigmaz, bD_stack, bV_stack, bTs_stack, bemis_horizontal, bbuilding, btgedr, & & bdegr, bqrv, bqtr, bcatnr, blandnr, eof, error) IF (error%haserror) GOTO 3300 ! GOTO deallocate all arrays and do error handling at end of program. @@ -598,13 +613,15 @@ PROGRAM opsmode IF (error%haserror) GOTO 3300 ! GOTO deallocate all arrays and do error handling at end of program. ! ! compute concentrations and depositions - ! + CALL ops_reken(idep, isec, icm, gasv, intpol, vchemc, vchemv, dv, amol1, amol2, amol21, ar, rno2nox, ecvl, iseiz, zf, & & trafst, knatdeppar, mb, ugmoldep, dg, irev, scavcoef, koh, croutpri, rcno, rhno2, rchno3, & & nrrcp, ircp, gxm(ircp), gym(ircp), xm(ircp), ym(ircp), zm(ircp), & & frac(ircp), nh3bg_rcp(ircp), rhno3_rcp(ircp), & & bqrv(mmm), bqtr(mmm), bx(mmm), by(mmm), bdiam(mmm), bsterkte(mmm), bwarmte(mmm), bhoogte(mmm), & - & bsigmaz(mmm), btgedr(mmm), bdegr(mmm), z0_src, z0_tra, z0_rcp, z0_metreg_rcp, lu_tra_per, & + & bsigmaz(mmm), bD_stack(mmm), bV_stack(mmm), bTs_stack(mmm), bemis_horizontal(mmm), bbuilding(mmm), & + & buildingEffect,btgedr(mmm), bdegr(mmm), & + & z0_src, z0_tra, z0_rcp, z0_metreg_rcp, lu_tra_per, & & lu_rcp_per, so2sek, no2sek, so2bgtra, no2bgtra, nh3bgtra, maxidx, pmd, uspmd, spgrid, grid, & & subbron, uurtot, routsec, rc, somvnsec_arr, telvnsec_arr, vvchem_arr, vtel_arr, somvnpri_arr, & & telvnpri_arr, ddepri_d, sdrypri_arr, snatpri_arr, sdrysec_arr, snatsec_arr, & @@ -620,8 +637,7 @@ PROGRAM opsmode CALL ops_write_progress(aind, '(F5.1)', 5, memdone) ENDDO ! end loop over receptors - -ENDDO ! end loop over sources +ENDDO ! end loop over source data blocks of length LSBUF (until end-of-file of scratch file with source data) CLOSE (fu_progress) ! ! Deallocate memory not required anymore and close the progression file. @@ -762,7 +778,7 @@ PROGRAM opsmode ! Write additional data to print file ! CALL ops_print_info (project, gasv, isec, intpol, spgrid, z0_rcp, namco, nbron, bnr, bx, by, bsterkte, bqrv, bqtr, bwarmte, & - & bhoogte, bdiam, bsigmaz, btgedr, bdegr, bcatnr, blandnr, emis, emtrend, jb, mb, idb, jt, mt, idt, iseiz, & + & bhoogte, bdiam, bsigmaz, btgedr, bdegr, bcatnr, blandnr, emis, emtrend, jb, mb, idb, jt, mt, idt, iseiz, & & f_z0user, landmax, error) IF (error%haserror) GOTO 4000 diff --git a/ops_monitor.f90 b/ops_monitor.f90 deleted file mode 100644 index 7e54fd9..0000000 --- a/ops_monitor.f90 +++ /dev/null @@ -1,95 +0,0 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see . -! -! Copyright (C) 2002 by -! National Institute of Public Health and Environment -! Laboratory for Air Research (RIVM/LLO) -! The Netherlands -! -! -! SUBROUTINE -! NAME : %M% -! SCCS(SOURCE) : %P% -! RELEASE - LEVEL : %R% - %L% -! BRANCH -SEQUENCE : %B% - %S% -! DATE - TIME : %E% - %U% -! WHAT : %W%:%E% -! AUTHOR : -! FIRM/INSTITUTE : RIVM/LLO -! LANGUAGE : FORTRAN-77/90 -! DESCRIPTION : Get file name of monitor files (log, error and progress files). -! EXIT CODES : -! REFERENCE : -! FILES AND OTHER : -! I/O DEVICES -! SYSTEM DEPENDENCIES: HP-Fortran -! CALLED FUNCTIONS : -! UPDATE HISTORY : -!------------------------------------------------------------------------------------------------------------------------------- -SUBROUTINE ops_monitor(lognam, error) - -USE m_error -USE m_string -USE m_commonfile - -IMPLICIT NONE -! -! USED VARIABLES -! indnam: name of progress indicator file -! errnam: name of error file - -! SUBROUTINE ARGUMENTS - OUTPUT -character*(*), INTENT(OUT) :: lognam ! name of log file -TYPE (TError), INTENT(OUT) :: error ! Error handling record - -! LOCAL VARIABLES -INTEGER*4 :: extpos ! position in control file name where extension starts. -CHARACTER*512 :: base ! base name of monitor files (i.e. control file name without extension) - -! CONSTANTS -CHARACTER*512 :: ROUTINENAAM -PARAMETER (ROUTINENAAM = 'ops_monitor') - -! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! -sccsida = '%W%:%E%'// char (0) -!------------------------------------------------------------------------------------------------------------------------------- -! -! Get the base of the control file name (so skip the extension) -! -extpos = INDEX(ctrnam, '.',.TRUE.) - 1 -CALL CopyStrPart(ctrnam, 1, extpos, base, error) -IF (error%haserror) GOTO 9999 -! -! Progress indicator file = base'.ind' -! -CALL StringMerge(base,'.ind', indnam, error) -IF (error%haserror) GOTO 9999 -! -! Log file = base'.log' -! -CALL StringMerge(base,'.log', lognam, error) -IF (error%haserror) GOTO 9999 -! -! Error file = base'.err' -! -CALL StringMerge(base,'.err', errnam, error) -IF (error%haserror) GOTO 9999 - -RETURN - -9999 CALL ErrorCall(ROUTINENAAM, error) -RETURN - -END SUBROUTINE ops_monitor diff --git a/ops_rcp_char_1.f90 b/ops_rcp_char_1.f90 index 4100c52..83ad508 100644 --- a/ops_rcp_char_1.f90 +++ b/ops_rcp_char_1.f90 @@ -165,7 +165,10 @@ SUBROUTINE ops_rcp_char_1(ircp, nrrcp, intpol, gxm_rcp, gym_rcp, cs, z0_metreg, IF (sum(lu_rcp_per(1:NLU)) .le. 0) THEN lu_rcp_per = 0.0 lu_rcp_per(1) = 100.0 -ENDIF +ENDIF + +if (error%debug) write(*,'(3a,1x,i6,99(1x,e12.5))') trim(ROUTINENAAM),',A,',' ircp,z0_rcp,lu_rcp_per: ',ircp,z0_rcp,lu_rcp_per + 9999 CALL ErrorCall(ROUTINENAAM, error) RETURN @@ -179,6 +182,8 @@ SUBROUTINE ops_rcp_char_1(ircp, nrrcp, intpol, gxm_rcp, gym_rcp, cs, z0_metreg, !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE reginpo(x, y, cs, z0_metreg, xreg, yreg, i1, z0_metreg_xy, uurtot, astat, error) +USE Binas, only: deg2rad + ! CONSTANTS CHARACTER*512 :: ROUTINENAAM ! PARAMETER (ROUTINENAAM = 'reginpo') @@ -243,7 +248,7 @@ SUBROUTINE reginpo(x, y, cs, z0_metreg, xreg, yreg, i1, z0_metreg_xy, uurtot, as sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! Set a = cos(y); needed in computation of dx = (x2 - x1)*cos(y) for geographical coordinates -a = COS(y/CONV) +a = COS(y*deg2rad) ! Initialise sums: s = 0. diff --git a/ops_rcp_char_all.f90 b/ops_rcp_char_all.f90 index 5514bd8..4de5086 100644 --- a/ops_rcp_char_all.f90 +++ b/ops_rcp_char_all.f90 @@ -37,11 +37,12 @@ ! UPDATE HISTORY : !------------------------------------------------------------------------------------------------------------------------------- subroutine ops_rcp_char_all(icm, isec, xm, ym, f_z0user, z0_user, z0nlgrid, z0eurgrid, lugrid, so2bggrid, nh3bggrid, & - & nrrcp, gxm, gym, lu_rcp_dom_all, z0_rcp_all, rhno3_rcp, nh3bg_rcp, domlu) + & nrrcp, gxm, gym, lu_rcp_dom_all, z0_rcp_all, rhno3_rcp, nh3bg_rcp, domlu, error) USE m_aps USE m_geoutils USE m_commonconst +USE m_error IMPLICIT NONE @@ -70,13 +71,14 @@ subroutine ops_rcp_char_all(icm, isec, xm, ym, f_z0user, z0_user, z0nlgrid, z0eu REAL*4, INTENT(OUT) :: rhno3_rcp(nrrcp) REAL*4, INTENT(OUT) :: nh3bg_rcp(nrrcp) -! SUBROUTINE ARGUMENTS - OUTPUT +! SUBROUTINE ARGUMENTS - INPUT/OUTPUT INTEGER*4 :: landuse(NLU+1) ! land-use value at receptor ! landuse(1) = index of dominant landuse ! landuse(lu+1) = percentage of grid cell with landuse class lu, lu = 1,NLU ! For locations outside lugrid, a default land use class = 1 (grass) is taken. INTEGER*4, INTENT(INOUT) :: lu_rcp_dom_all(nrrcp) ! index of dominant land use for all receptor points REAL*4, INTENT(INOUT) :: z0_rcp_all(nrrcp) ! roughness lengths for all receptors; from z0-map or receptor file [m] +TYPE (TError), INTENT(INOUT) :: error ! error handling record ! LOCAL VARIABLES INTEGER*4 :: ircp ! index of receptor @@ -153,7 +155,9 @@ subroutine ops_rcp_char_all(icm, isec, xm, ym, f_z0user, z0_user, z0nlgrid, z0eu nh3bg_rcp(ircp)=nh3bgconc*17/24 ENDIF - + + if (error%debug) write(*,'(3a,1x,i6,99(1x,e12.5))') trim(ROUTINENAAM),',A,',' ircp,z0_rcp_all(ircp),lu_rcp_dom_all(ircp),nh3bg_rcp(ircp): ', & + ircp,z0_rcp_all(ircp),lu_rcp_dom_all(ircp),nh3bg_rcp(ircp) ENDDO RETURN diff --git a/ops_read_emis.f90 b/ops_read_emis.f90 index 2bb332c..206c650 100644 --- a/ops_read_emis.f90 +++ b/ops_read_emis.f90 @@ -39,8 +39,8 @@ ! CALLED FUNCTIONS : ! UPDATE HISTORY : !------------------------------------------------------------------------------------------------------------------------------- -SUBROUTINE ops_read_emis(icm, gasv, ncatsel, catsel, nlandsel, landsel, spgrid, grid, numbron, dverl, usdverl, pmd, uspmd, & - & dv, usdv, presentcode, error) +SUBROUTINE ops_read_emis(icm, gasv, ncatsel, catsel, nlandsel, landsel, numbron, dverl, usdverl, pmd, uspmd, & + & dv, usdv, presentcode, building_present1, error) USE m_commonconst USE m_commonfile @@ -60,25 +60,26 @@ SUBROUTINE ops_read_emis(icm, gasv, ncatsel, catsel, nlandsel, landsel, spgrid, INTEGER*4, INTENT(IN) :: catsel(*) INTEGER*4, INTENT(IN) :: nlandsel INTEGER*4, INTENT(IN) :: landsel(*) -INTEGER*4, INTENT(IN) :: spgrid -REAL, INTENT(IN) :: grid + ! SUBROUTINE ARGUMENTS - I/O TYPE (TError), INTENT(INOUT) :: error ! error handling record ! SUBROUTINE ARGUMENTS - OUTPUT INTEGER*4, INTENT(OUT) :: numbron ! number of selected sources -REAL*4, INTENT(OUT) :: dverl(NHRBLOCKS,MAXDIST) ! standard diurnal emission variations distributions -REAL*4, INTENT(OUT) :: usdverl(NHRBLOCKS,MAXDIST) ! user-defined diurnal emission variations distributions -REAL*4, INTENT(OUT) :: pmd(NPARTCLASS,MAXDIST) ! standard particle size distributions -REAL*4, INTENT(OUT) :: uspmd(NPARTCLASS,MAXDIST) ! user-defined particle size distributions +REAL*4, INTENT(OUT) :: dverl(NHRBLOCKS,MAXDISTR) ! standard diurnal emission variations distributions +REAL*4, INTENT(OUT) :: usdverl(NHRBLOCKS,MAXDISTR)! user-defined diurnal emission variations distributions +REAL*4, INTENT(OUT) :: pmd(NPARTCLASS,MAXDISTR) ! standard particle size distributions +REAL*4, INTENT(OUT) :: uspmd(NPARTCLASS,MAXDISTR) ! user-defined particle size distributions INTEGER*4, INTENT(OUT) :: dv ! maximum code diurnal emission variation dverl INTEGER*4, INTENT(OUT) :: usdv ! maximum code user specified diurnal emission variation usdverl -LOGICAL, INTENT(OUT) :: presentcode(MAXDIST,4) ! which distribution codes are present +LOGICAL, INTENT(OUT) :: presentcode(MAXDISTR,4) ! which distribution codes are present ! presentcode(:,1): diurnal variations ! presentcode(:,2): particle size distributions ! presentcode(:,3): user-defined diurnal variation ! presentcode(:,4): user-defined particle size distributions +LOGICAL, INTENT(OUT) :: building_present1 ! at least one building is present in the source file + ! LOCAL VARIABLES INTEGER*4 :: ps ! maximum code pmd distribution (dummy) @@ -124,7 +125,7 @@ SUBROUTINE ops_read_emis(icm, gasv, ncatsel, catsel, nlandsel, landsel, spgrid, ! Read brnam, the file with sources. Note that this file (and other files later on) are also closed if an error occurred during ! reading, therefore the error check is not before the close statement. ! -IF (.NOT.sysopen(fu_bron, brnam, 'r', 'sources file', error)) GOTO 9999 +IF (.NOT.sysopen(fu_bron, brnam, 'r', 'emission file', error)) GOTO 9999 ! ! Open scratch file ! @@ -133,10 +134,10 @@ SUBROUTINE ops_read_emis(icm, gasv, ncatsel, catsel, nlandsel, landsel, spgrid, ! ! Read, select and check sources ! -CALL ops_read_source(icm, gasv, ncatsel, catsel, nlandsel, landsel, presentcode, spgrid, grid, numbron, error) +CALL ops_read_source(icm, gasv, ncatsel, catsel, nlandsel, landsel, presentcode, numbron, building_present1, error) IF (error%haserror) THEN - CALL ErrorParam('Sources file', brnam, error) + CALL ErrorParam('emission file', brnam, error) ENDIF CALL sysclose(fu_bron, brnam, error) @@ -181,15 +182,15 @@ SUBROUTINE read_variation(distnam, fmt, nrclass, normalvalue, compdesc, fraction LOGICAL, INTENT(IN) :: fraction ! whether conversion to fractions is required (instead of %) ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: distrib(nrclass,MAXDIST) ! array with all distributions +REAL*4, INTENT(OUT) :: distrib(nrclass,MAXDISTR) ! array with all distributions INTEGER*4, INTENT(OUT) :: maxcode ! maximum code used for distribution -LOGICAL, INTENT(OUT) :: presentcode(MAXDIST) ! which distribution codes are present +LOGICAL, INTENT(OUT) :: presentcode(MAXDISTR) ! which distribution codes are present TYPE (TError), INTENT(OUT) :: error ! error handling record ! LOCAL VARIABLES INTEGER*4 :: distcode ! code used for distribution; ! read from the first column of the distributions file. - ! (|distcode| = index into 2nd dimension of distrib(nclass, MAXDIST)) + ! (|distcode| = index into 2nd dimension of distrib(nclass, MAXDISTR)) ! LOCAL VARIABLES INTEGER*4 :: i ! DO LOOP counter @@ -235,7 +236,7 @@ SUBROUTINE read_variation(distnam, fmt, nrclass, normalvalue, compdesc, fraction ! ! Check whether distcode is allowed. ! - IF (distcode > MAXDIST) THEN + IF (distcode > MAXDISTR) THEN CALL SetError('Distribution code exceeds maximum', error) GOTO 2000 ELSEIF (presentcode(distcode)) THEN diff --git a/ops_read_meteo.f90 b/ops_read_meteo.f90 index d864790..d939ae8 100644 --- a/ops_read_meteo.f90 +++ b/ops_read_meteo.f90 @@ -36,8 +36,8 @@ ! CALLED FUNCTIONS : ops_statfil, ops_readstexp, wr_error ! UPDATE HISTORY : !------------------------------------------------------------------------------------------------------------------------------- -SUBROUTINE ops_read_meteo(intpol, jb, mb, idb, jt, mt, idt, uurtot, iseiz, zf, astat, trafst, gemre, gemtemp, z0_metreg_user, cs, & - & rainreg, tempreg, z0_metreg, xreg, yreg, hourreg, error ) +SUBROUTINE ops_read_meteo(intpol, jb, mb, idb, jt, mt, idt, uurtot, iseiz, zf, astat, trafst, gemre, z0_metreg_user, cs, & + & rainreg, z0_metreg, xreg, yreg, hourreg, error ) USE m_error USE m_commonconst @@ -67,11 +67,9 @@ SUBROUTINE ops_read_meteo(intpol, jb, mb, idb, jt, mt, idt, uurtot, iseiz, zf, a REAL*4, INTENT(OUT) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) REAL*4, INTENT(OUT) :: trafst(NTRAJ) REAL*4, INTENT(OUT) :: gemre -REAL*4, INTENT(OUT) :: gemtemp REAL*4, INTENT(OUT) :: z0_metreg_user ! roughness length of user specified meteo region [m] REAL*4, INTENT(OUT) :: cs(NTRAJ, NCOMP, NSTAB, NSEK, NMETREG) REAL*4, INTENT(OUT) :: rainreg(NMETREG) -REAL*4, INTENT(OUT) :: tempreg(NMETREG) REAL*4, INTENT(OUT) :: z0_metreg(NMETREG) ! roughness lengths of NMETREG meteo regions; scale < 50 km [m] REAL*4, INTENT(OUT) :: xreg(NMETREG) REAL*4, INTENT(OUT) :: yreg(NMETREG) @@ -97,14 +95,14 @@ SUBROUTINE ops_read_meteo(intpol, jb, mb, idb, jt, mt, idt, uurtot, iseiz, zf, a ! IF (intpol.EQ.0) THEN ! Fill meteo parameters for every region (calls ops_readstexp NMETREG+1 times) - CALL ops_statfil(jb, mb, idb,jt, mt, idt, uurtot, iseiz, zf, astat, trafst, cs, rainreg, tempreg, z0_metreg, xreg, yreg, & + CALL ops_statfil(jb, mb, idb,jt, mt, idt, uurtot, iseiz, zf, astat, trafst, cs, rainreg, z0_metreg, xreg, yreg, & & hourreg, error) ! average precipitation amount [mm/h]: gemre = SUM(rainreg(:NMETREG))/NMETREG ELSE ! Read meteo parameters for one region or from user specified file - CALL ops_readstexp(kname, jb, mb, idb, gemre, gemtemp, iyr, imon, iday, xpos, ypos, z0_metreg1, jt, mt, idt, uurtot, & + CALL ops_readstexp(kname, jb, mb, idb, gemre, iyr, imon, iday, xpos, ypos, z0_metreg1, jt, mt, idt, uurtot, & & iseiz, zf, astat, trafst, error) z0_metreg_user = z0_metreg1 ENDIF @@ -120,7 +118,7 @@ END SUBROUTINE ops_read_meteo ! SUBROUTINE : ops_statfil ! DESCRIPTION : Read meteo parameters for all meteo regions. !------------------------------------------------------------------------------------------------------------------------------- -SUBROUTINE ops_statfil(jb, mb, idb, jt, mt, idt, uurtot, iseiz, zf, astat, trafst, cs, rainreg, tempreg, z0_metreg, xreg, yreg, & +SUBROUTINE ops_statfil(jb, mb, idb, jt, mt, idt, uurtot, iseiz, zf, astat, trafst, cs, rainreg, z0_metreg, xreg, yreg, & & hourreg, error) USE m_commonconst @@ -152,7 +150,6 @@ SUBROUTINE ops_statfil(jb, mb, idb, jt, mt, idt, uurtot, iseiz, zf, astat, trafs REAL*4, INTENT(OUT) :: trafst(NTRAJ) REAL*4, INTENT(OUT) :: cs(NTRAJ, NCOMP, NSTAB, NSEK, NMETREG) REAL*4, INTENT(OUT) :: rainreg(NMETREG) -REAL*4, INTENT(OUT) :: tempreg(NMETREG) REAL*4, INTENT(OUT) :: z0_metreg(NMETREG) ! roughness lengths of NMETREG meteo regions; scale < 50 km [m] REAL*4, INTENT(OUT) :: xreg(NMETREG) REAL*4, INTENT(OUT) :: yreg(NMETREG) @@ -166,7 +163,6 @@ SUBROUTINE ops_statfil(jb, mb, idb, jt, mt, idt, uurtot, iseiz, zf, astat, trafs INTEGER*4 :: iyr ! year of time stamp of meteo file; currently not used INTEGER :: idx ! index of '.' in name of meteo statistics file REAL*4 :: gemre ! average amount of precipitation (mm/h) -REAL*4 :: gemtemp REAL*4 :: xpos REAL*4 :: ypos REAL*4 :: z0_metreg1 ! roughness length of 1 meteo region [m] @@ -193,7 +189,7 @@ SUBROUTINE ops_statfil(jb, mb, idb, jt, mt, idt, uurtot, iseiz, zf, astat, trafs WRITE (nfile,'(A,I3.3)') kname(1:idx), ireg ! Read meteo parameters for this meteo region - CALL ops_readstexp(nfile, jb, mb, idb, gemre, gemtemp, iyr, imon, iday, xpos, ypos, z0_metreg1, jt, mt, idt, uurtot, & + CALL ops_readstexp(nfile, jb, mb, idb, gemre, iyr, imon, iday, xpos, ypos, z0_metreg1, jt, mt, idt, uurtot, & & iseiz, zf, astat, trafst, error) IF (error%haserror) THEN @@ -212,7 +208,6 @@ SUBROUTINE ops_statfil(jb, mb, idb, jt, mt, idt, uurtot, iseiz, zf, astat, trafs ! Fill cs and other meteo arrays for this region cs(:, :, :, :, ireg) = astat(:NTRAJ, :NCOMP, :NSTAB, :NSEK) rainreg(ireg) = gemre - tempreg(ireg) = gemtemp z0_metreg(ireg) = z0_metreg1 xreg(ireg) = xpos yreg(ireg) = ypos @@ -223,7 +218,7 @@ SUBROUTINE ops_statfil(jb, mb, idb, jt, mt, idt, uurtot, iseiz, zf, astat, trafs ! these data are used in ops_init for the evlauation of diurnal emission variation ! nfile( idx+3:idx+3 ) = '5' -CALL ops_readstexp(nfile, jb, mb, idb, gemre, gemtemp, iyr, imon, iday, xpos, ypos, z0_metreg1, jt, mt, idt, uurtot, & +CALL ops_readstexp(nfile, jb, mb, idb, gemre, iyr, imon, iday, xpos, ypos, z0_metreg1, jt, mt, idt, uurtot, & & iseiz, zf, astat, trafst, error) RETURN @@ -236,7 +231,7 @@ END SUBROUTINE ops_statfil ! DESCRIPTION : This routine reads the climatology (meteo statistics) file and fills the meteodata array. ! Depending on the value of intpol, this routine is called only once, or for each region. !------------------------------------------------------------------------------------------------------------------------------- -SUBROUTINE ops_readstexp(nfile, jb, mb, idb, gemre, gemtemp, iyr, imon, iday, xpos, ypos, z0_metreg1, jt, mt, idt, & +SUBROUTINE ops_readstexp(nfile, jb, mb, idb, gemre, iyr, imon, iday, xpos, ypos, z0_metreg1, jt, mt, idt, & & uurtot, iseiz, zf, astat, trafst, error) USE m_commonconst @@ -262,7 +257,6 @@ SUBROUTINE ops_readstexp(nfile, jb, mb, idb, gemre, gemtemp, iyr, imon, iday, xp INTEGER*4, INTENT(OUT) :: mb ! start month (meteo statistics period) ("b" << begin = start) INTEGER*4, INTENT(OUT) :: idb ! start day (meteo statistics period) ("b" << begin = start) REAL*4, INTENT(OUT) :: gemre ! average precipitation amount [mm/h] -REAL*4, INTENT(OUT) :: gemtemp INTEGER*4, INTENT(OUT) :: iyr ! year of time stamp of meteo file; currently not used INTEGER*4, INTENT(OUT) :: imon ! month of time stamp of meteo file; currently not used INTEGER*4, INTENT(OUT) :: iday ! day of time stamp of meteo file; currently not used @@ -356,9 +350,8 @@ SUBROUTINE ops_readstexp(nfile, jb, mb, idb, gemre, gemtemp, iyr, imon, iday, xp astat(:, icomp, :, :) = astat(:, icomp, :, :)/ISCALE(icomp) ENDDO ! -! Compute average domestic heating coefficient (degree day) [degree C] and precipitation amount [mm/h] +! Compute average precipitation amount [mm/h] ! -gemtemp = SUM( astat(1, 1, :NSTAB, :NSEK) * astat(1, 10, :, :)) / uurtot gemre = SUM( astat(1, 1, :NSTAB, :NSEK) * astat(1, 11, :, :) * astat(1, 13, :, :)) / uurtot ! ! Convert two digit year (from meteostatistics file) to four digits diff --git a/ops_read_source.f90 b/ops_read_source.f90 index 73e42e5..5a33845 100644 --- a/ops_read_source.f90 +++ b/ops_read_source.f90 @@ -31,8 +31,7 @@ ! DESCRIPTION : Read source file with emissions. ! Emissions are read from a source file and emissions for selected emission categories and countries ! are then copied to a scratch file (line for line); -! emission parameters that lie outside a specified range are fixed at the lower or upper limit of this range. -! If this occurs, a warning is written to a log file. +! emission parameters that lie outside a specified range agenerate an error. ! EXIT CODES : ! FILES AND OTHER : ! I/O DEVICES @@ -40,13 +39,13 @@ ! CALLED FUNCTIONS : flrs, ops_check, sysread ! UPDATE HISTORY : !------------------------------------------------------------------------------------------------------------------------------- -SUBROUTINE ops_read_source(icm, gasv, ncatsel, catsel, nlandsel, landsel, presentcode, spgrid, grid, numbron, error) +SUBROUTINE ops_read_source(icm, gasv, ncatsel, catsel, nlandsel, landsel, presentcode, numbron, building_present1, error) USE m_error -USE m_fileutils -USE m_geoutils -USE m_commonfile -USE m_commonconst ! EPS_DELTA only +USE m_commonfile, only: fu_scratch, fu_bron +USE m_commonconst, only: EPS_DELTA, MAXDISTR +USE m_ops_emis +USE m_ops_building IMPLICIT NONE @@ -56,17 +55,21 @@ SUBROUTINE ops_read_source(icm, gasv, ncatsel, catsel, nlandsel, landsel, presen ! SUBROUTINE ARGUMENTS - INPUT INTEGER*4, INTENT(IN) :: icm ! component nummer -LOGICAL, INTENT(IN) :: gasv -INTEGER*4, INTENT(IN) :: ncatsel -INTEGER*4, INTENT(IN) :: catsel(*) -INTEGER*4, INTENT(IN) :: nlandsel -INTEGER*4, INTENT(IN) :: landsel(*) -LOGICAL, INTENT(IN) :: presentcode(MAXDIST,4) -INTEGER*4, INTENT(IN) :: spgrid -REAL, INTENT(IN) :: grid +LOGICAL, INTENT(IN) :: gasv ! component is gasuous +INTEGER*4, INTENT(IN) :: ncatsel ! number of selected emission categories +INTEGER*4, INTENT(IN) :: catsel(*) ! selected emission categories +INTEGER*4, INTENT(IN) :: nlandsel ! number of selected emission countries +INTEGER*4, INTENT(IN) :: landsel(*) ! selected emission countries +LOGICAL, INTENT(IN) :: presentcode(MAXDISTR,4) ! which distribution codes are present + ! presentcode(:,1): diurnal variations + ! presentcode(:,2): particle size distributions + ! presentcode(:,3): user-defined diurnal variation + ! presentcode(:,4): user-defined particle size distributions ! SUBROUTINE ARGUMENTS - OUTPUT +! Note: emission parameters are written to scratch file and are not part of the output arguments INTEGER*4, INTENT(OUT) :: numbron ! number of (selected) sources +LOGICAL, INTENT(OUT) :: building_present1 ! at least one building is present in the source file TYPE (TError), INTENT(OUT) :: error ! Error handling record ! LOCAL VARIABLES @@ -75,216 +78,69 @@ SUBROUTINE ops_read_source(icm, gasv, ncatsel, catsel, nlandsel, landsel, presen INTEGER*4 :: mm ! source identification number INTEGER*4 :: iland ! country/area code read from emission record INTEGER*4 :: idgr ! particle size distribution code read from emission record -INTEGER*4 :: cattel ! index for selected emission category -INTEGER*4 :: landtel ! index for selected country INTEGER*4 :: ibroncat ! emission category code read from emission record INTEGER*4 :: ierr ! error value LOGICAL*4 :: end_of_file ! end of file has been reached -LOGICAL*4 :: end_of_info ! end of info has been reached -LOGICAL*4 :: new_brnfile ! new version of emission file -REAL*4 :: qob -REAL*4 :: qww -REAL*4 :: hbron -REAL*4 :: diameter -REAL*4 :: szopp -REAL*4 :: brn_version ! version of emission inputfile +INTEGER*4 :: brn_version ! version of emission file +REAL*4 :: qob ! emission strength read from emission record [g/s] +REAL*4 :: qww ! heat content read from emission record [MW] +REAL*4 :: hbron ! emission height read from emission record [m] +REAL*4 :: diameter ! diameter area source read from emission record (NOT stack diameter) [m] +REAL*4 :: szopp ! deviation emission height for area source = initial sigma_z [m] REAL*4 :: x ! x coordinate of source location (RDM [m]) REAL*4 :: y ! y coordinate of source location (RDM [m]) -REAL*4 :: gl ! x coordinate of source location (longitude [degrees]) -REAL*4 :: gb ! y coordinate of source location (latitude [degrees]) -CHARACTER*180 :: cbuf ! character buffer, used to store an emission record -CHARACTER*180 :: word ! sting read from character buffer +LOGICAL :: country_selected ! emission country has been selected +LOGICAL :: category_selected ! emission category has been selected +LOGICAL :: VsDs_opt ! read stack parameters Ds/Vs/Ts from source file +REAL :: D_stack ! diameter of the stack [m] +REAL :: V_stack ! exit velocity of plume at stack tip [m/s] +REAL :: Ts_stack ! temperature of effluent from stack [K] +LOGICAL :: emis_horizontal ! horizontal outflow of emission +type(Tbuilding) :: building ! structure with building parameters +LOGICAL :: check_psd ! check whether particle size distribution has been read !------------------------------------------------------------------------------------------------------------------------------- -50 FORMAT (i4, 2f9.0, es10.3, f7.3, f6.1, f8.0, f6.1, 4i4) -100 FORMAT (i4, 2f8.3, e10.3, f7.3, f6.1, f7.0, f6.1, 4i4) -150 FORMAT (i4, 2f8.0, e10.3, f7.3, f6.1, f7.0, f6.1, 4i4) + 50 FORMAT (i4, 2f9.0, es12.3, f9.3, f6.1, f8.0, f6.1, 3e12.5, l2, 4i4, 4f9.3) ! format for writing to scratch (RDM; includes D_stack, V_stack, Ts_stack, building parameters, possibly -999). Also possible -999 for qw -numbron = 0 -nrec = 0 -new_brnfile = .FALSE. +! Initialisation: end_of_file = .FALSE. -end_of_info = .FALSE. -! -! First check the version of brnfile -! -CALL sysread(fu_bron, cbuf, end_of_info, error) +building_present1 = .FALSE. + +! Read file header (lines starting with !) and determine BRN-VERSION (= version of brn-file; brn << bron = source): +! no BRN-VERSION header -> fixed format +! BRN-VERSION 0 -> fixed format +! BRN-VERSION 1 -> free format +! BRN-VERSION 2 -> free format, include stack parameters D_stack, V_stack, Ts_stack. +! BRN-VERSION 3 -> free format, add parameter building%type with respect to BRN-VERSION 2 - NOT SUPPORTED ANYMORE ! +! BRN-VERSION 4 -> free format, add parameters building%length, building%width, building%height, building%orientation with respect to BRN-VERSION 2 +call ops_emis_read_header(fu_bron, brn_version, VsDs_opt, nrec, numbron, error) IF (error%haserror) GOTO 9999 -! -! If first character is "!" and (on first line) BRN-VERSION = 1 we have a new-brnfile -! -IF (cbuf(1:1) .EQ. "!") THEN - READ (cbuf(2:len_trim(cbuf)),*,end=33,err=33) word, brn_version - IF (word .EQ. "BRN-VERSION" .AND. brn_version .EQ. 1) new_brnfile=.TRUE. - 33 continue - DO WHILE (.NOT. end_of_info) - CALL sysread(fu_bron, cbuf, end_of_info, error) - IF (error%haserror) GOTO 9999 - IF (cbuf(1:1) .NE. "!") THEN - end_of_info = .TRUE. - ENDIF - ENDDO -ENDIF -! -! This is the first real emission record so we backspace 1 line -! -backspace(fu_bron) -! -! Read source file until end of file in order to check for errors. -! -DO WHILE (.NOT. end_of_file) - ! - ! Read string cbuf from file - ! - CALL sysread(fu_bron, cbuf, end_of_file, error) - IF (error%haserror) GOTO 9999 - ! - IF (.NOT. end_of_file) THEN - IF (new_brnfile) THEN - idgr=-999 - READ (cbuf, *, IOSTAT = ierr) mm, x, y, qob, qww, hbron, diameter, szopp, ibtg, ibroncat, iland, idgr - IF ( idgr .LT. 0 .OR. idgr .GT. MAXDIST ) THEN - ierr = -99 - ELSE - IF ( abs(y) .LT. 90 ) THEN - gb = y - gl = x -! -! Convert lon-lat coordinates to RDM coordinates -! - CALL geo2amc(gb, gl, x, y) ! (x,y) in km - x = AINT(x*1000.) ! [m] - y = AINT(y*1000.) ! [m] - ENDIF - ENDIF - ELSE - ! - ! If there is a dot at position 9, coordinates are assumed to be lon-lat - ! or, in a new_brnfile if the value read for y is less or equal to 99 - ! - IF ( cbuf(9:9) .EQ. '.' ) THEN -! -! Read source record with lon-lat coordinates (gl,gb) -! "g" << geographical coordinates; "l" << lengtegraad = longitude, "b" << breedtegraad = latitude - -! - READ (cbuf, 100, IOSTAT = ierr) mm, gl, gb, qob, qww, hbron, diameter, szopp, ibtg, ibroncat, iland, idgr -! - IF (ierr == 0) THEN -! -! Convert lon-lat coordinates to RDM coordinates -! - CALL geo2amc(gb, gl, x, y) ! (x,y) in km - x = AINT(x*1000.) ! [m] - y = AINT(y*1000.) ! [m] - ENDIF - ELSE - ! - ! Read source record with RDM coordinates - - ! - READ (cbuf, 150, IOSTAT = ierr) mm, x, y, qob, qww, hbron, diameter, szopp, ibtg, ibroncat, iland, idgr - ENDIF - ENDIF - - IF (ierr == 0) THEN +! Read source file until end of file: +DO WHILE (.NOT. end_of_file) - nrec=nrec+1 -! -! Check source strength ("sterkte"), heat content ("warmte") and source height ("hoogte"). -! Note: check is only perfomed inside check_source if no error has occurred; -! therefore there is no need to check for error%haserror here each time. -! -! JA* check is only needed if source is selected. - CALL check_source(nrec, '', 0., 99999., qob, error) - CALL check_source(nrec, '', 0., 999., qww, error) - CALL check_source(nrec, '', 0., 9999., hbron, error) -! -! Check whether the source diameter >= grid resolution -! << not yet active >> -! -! IF ( spgrid /= 2 ) THEN -! CALL check_source(nrec, '',grid, 999999., !i -! + diameter, error) !i/o -! ELSE - CALL check_source(nrec, '',-999999., 999999., diameter, error) -! ENDIF + ! Do not check particle size distribution for gaseous component: + check_psd = (.not. gasv) -! -! Check lower and upper boundary -! deviation : 0 <= szopp <= hbron -! diurnal variation : -999 <= ibtg <= 999 -! emission category : 1 <= ibroncat <= 9999 -! country (= 'land') : 1 <= iland <= 9999 -! paricle size distribution code: -999 <= idgr <= 999 -! - CALL check_source(nrec, '', 0., hbron, szopp, error) - CALL check_isource(nrec, '', -999, 999, ibtg, error) - CALL check_isource(nrec, '', 1, 9999, ibroncat, error) - CALL check_isource(nrec, '', 1, 9999, iland, error) - CALL check_isource(nrec, '', -999, MAXDIST, idgr, error) -! -! Check whether ibtg and idgr distributions in this record have been read (using presentcodes array). -! Check of ibtg is not for NH3 (icm=3) and NOx (icm=2) if a special diurnal variation (4 or 5) is used. -! Check of particle size distribution is only for particles (.not. gasv). + ! Read emission record and check whether parameters are within range: + call ops_emis_read_annual1(fu_bron, icm, check_psd, presentcode, brn_version, VsDs_opt, nrec, numbron, building_present1, & + mm, x, y, qob, qww, hbron, diameter, szopp, D_stack, V_stack, Ts_stack, emis_horizontal, building, ibtg, ibroncat, iland, idgr, end_of_file, error) + IF (error%haserror) GOTO 9999 + + IF (.NOT. end_of_file) THEN - IF (.NOT.((icm == 2 .OR. icm == 3) .AND. (ibtg == 4 .OR. ibtg == 5))) THEN - CALL check_verdeling(ibtg, presentcode, 1, 3, 'ibtg', error) - ENDIF - IF (.NOT. gasv) THEN - CALL check_verdeling(idgr, presentcode, 2, 4, 'idgr', error) - ENDIF - IF (error%haserror) GOTO 9999 -! -! Copy valid (emission > 0) and selected sources to scratch file -! + ! Copy valid (emission > 0) and selected sources to scratch file: IF (qob .GT. EPS_DELTA) THEN - - ! - ! Loop over selected emission categories and countries - ! - DO cattel = 1, ncatsel - DO landtel = 1, nlandsel - - ! Write emission record of each country in case landsel = 0; - ! write emission record of each emission category in case catsel = 0 - IF (landsel(landtel) .EQ. 0 ) THEN - IF (catsel(cattel) .EQ. 0 ) THEN - WRITE (fu_scratch, 50) mm,x,y,qob,qww, hbron, diameter, szopp, ibtg, ibroncat, iland, idgr - numbron=numbron+1 - ELSE - - ! write emission record if emission category has been selected - IF (ibroncat .EQ. catsel(cattel)) THEN - WRITE (fu_scratch, 50) mm,x,y,qob,qww, hbron, diameter, szopp, ibtg, ibroncat, iland, idgr - numbron=numbron+1 - ENDIF - ENDIF - ELSE - - ! write emission record if country has been selected, ... - IF (iland .EQ. landsel(landtel)) THEN - - ! ... for each emission category - IF (catsel(cattel) .EQ. 0 ) THEN - WRITE (fu_scratch, 50) mm,x,y,qob,qww, hbron, diameter, szopp, ibtg, ibroncat, iland, idgr - numbron=numbron+1 - ELSE - - ! ... for selected emission category - IF (ibroncat .EQ. catsel(cattel)) THEN - WRITE (fu_scratch, 50) mm,x,y,qob,qww,hbron, diameter, szopp, ibtg, ibroncat, iland, idgr - numbron=numbron+1 - ENDIF - ENDIF - ENDIF - ENDIF - ENDDO - ENDDO + + country_selected = any((landsel(1:nlandsel) .eq. 0) .OR. (iland .eq. landsel(1:nlandsel))) + category_selected = any((catsel(1:ncatsel) .eq. 0) .OR. (ibroncat .eq. catsel(1:ncatsel))) + + IF (country_selected .AND. category_selected) THEN + WRITE (fu_scratch, 50) mm,x,y,qob,qww, hbron, diameter, szopp, D_stack, V_stack, Ts_stack, emis_horizontal, ibtg, ibroncat, iland, idgr, building%length, building%width, building%height, building%orientation + numbron = numbron+1 + ENDIF ENDIF - ENDIF - ENDIF + ENDIF ENDDO REWIND (fu_scratch) @@ -294,181 +150,4 @@ SUBROUTINE ops_read_source(icm, gasv, ncatsel, catsel, nlandsel, landsel, presen CALL ErrorParam('nrec', nrec, error) CALL ErrorCall(ROUTINENAAM, error) -CONTAINS - -!------------------------------------------------------------------------------------------------------------------------------- -! SUBROUTINE NAME : check_source -! DESCRIPTION : check whether a source parameter lies within a specified range. If not, the paramater is fixed at either -! the lower or upper limit of the range. In this case, a warning is written to the log file; -! this warning includes the record number of the source. -! CALLED FUNCTIONS : -!------------------------------------------------------------------------------------------------------------------------------- -SUBROUTINE check_source(nr, varnaam, onder, boven, varwaarde, error) - -! CONSTANTS -CHARACTER*512 :: ROUTINENAAM -PARAMETER (ROUTINENAAM = 'check_source') - -! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: nr ! record number of source file -CHARACTER*(*), INTENT(IN) :: varnaam ! variable to be checked -REAL*4, INTENT(IN) :: onder ! lower limit -REAL*4, INTENT(IN) :: boven ! upper limit - -! SUBROUTINE ARGUMENTS - I/O -REAL*4, INTENT(INOUT) :: varwaarde ! (adapted) value of variable -TYPE (TError), INTENT(INOUT) :: error ! error handling record - -! LOCAL VARIABLES -INTEGER*4 :: mlen ! length of variable name -LOGICAL*1 :: switch ! indicates weather WARNING has already been printed -LOGICAL :: ops_openlog ! function for opening log file - -!------------------------------------------------------------------------------------------------------------------------------- -! -! Check and possibly open log file. From here there is always going to be something written to it, so the opening is allowed. -! -IF (error%haserror) GOTO 9999 - -switch = .FALSE. - -! -! Check upper limit; if needed, write warning and fix variable at upper limit. -! -IF (varwaarde .GT. (boven + EPS_DELTA)) THEN ! varwaarde too large - - IF (.NOT. switch) THEN - IF (.NOT. ops_openlog(error)) GOTO 9000 - WRITE(fu_log,'("WARNING: OPS has detected a value outside", " its limits in routine ", A)') & - & ROUTINENAAM(:LEN_TRIM(ROUTINENAAM)) - ENDIF - - switch=.TRUE. - - mlen = LEN_TRIM(varnaam) - WRITE(fu_log,'('' Record number '',I6,'': Value of '', ''emission variable '', a, '' ('', G10.3, & - & '') is outside range '', ''('', G10.3, '' - '', G10.3, '')'')') nr, varnaam(:mlen), varwaarde, onder , boven - WRITE(fu_log,'(25x,''and has been set to maximum value'')') - - varwaarde = boven - -! -! Check lower limit; if needed, write warning and fix variable at lower limit. -! -ELSEIF (varwaarde .LT. (onder - EPS_DELTA)) THEN ! varwaarde too small - - IF (.NOT. switch) THEN - IF (.NOT. ops_openlog(error)) GOTO 9000 - WRITE(fu_log,'("WARNING: OPS has detected a value outside", " its limits in routine ", A)') & - & ROUTINENAAM(:LEN_TRIM(ROUTINENAAM)) - ENDIF - - switch=.TRUE. - - mlen = LEN_TRIM(varnaam) - WRITE(fu_log,'('' Record number '',I6,'': Value of '', ''emission variable '', a, '' ('', G10.3, & - & '') is outside range '', ''('', G10.3, '' - '', G10.3, '')'')') nr, varnaam(:mlen), varwaarde, onder , boven - - IF (varnaam .EQ. '') THEN - WRITE(fu_log,'(25x,''Record will be skipped'')') ! Zero emissions are meaningless - ELSE - WRITE(fu_log,'(25x,''and has been set to minimum value'')') - ENDIF - - varwaarde = onder - -ELSE - CONTINUE -ENDIF -RETURN - -9000 CALL ErrorCall(ROUTINENAAM, error) -9999 RETURN - -END SUBROUTINE check_source - -!------------------------------------------------------------------------------------------------------------------------------- -! SUBROUTINE NAME : check_isource -! DESCRIPTION : check whether an integer source parameter lies within a specified range. If not, the paramater is fixed at either -! the lower or upper limit of the range. In this case, a warning is written to the log file; -! this warning includes the record number of the source. -! CALLED FUNCTIONS : -!------------------------------------------------------------------------------------------------------------------------------- -SUBROUTINE check_isource(nr, varnaam, onder, boven, varwaarde, error) - -! CONSTANTS -CHARACTER*512 :: ROUTINENAAM -PARAMETER (ROUTINENAAM = 'check_source') - -! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: nr ! record number of source file -CHARACTER*(*), INTENT(IN) :: varnaam ! variable to be checked -INTEGER*4, INTENT(IN) :: onder ! lower limit -INTEGER*4, INTENT(IN) :: boven ! upper limit - -! SUBROUTINE ARGUMENTS - I/O -INTEGER*4, INTENT(INOUT) :: varwaarde ! (adapted) value of variable -TYPE (TError), INTENT(INOUT) :: error ! error handling record - -! LOCAL VARIABLES -REAL*4 :: var ! help variable (= float(varwaarde)) - -var = FLOAT(varwaarde) -CALL check_source(nr, varnaam, FLOAT(onder), FLOAT(boven), var, error) -varwaarde = NINT(var) - -END SUBROUTINE check_isource - -!------------------------------------------------------------------------------------------------------------------------------- -! SUBROUTINE NAME : check_verdeling -! DESCRIPTION : Check whether distribution (=verdeling) has been read. -! CALLED FUNCTIONS : -!------------------------------------------------------------------------------------------------------------------------------- -SUBROUTINE check_verdeling(icode, presentcode, stdclass, usdclass, parname, error) - -! CONSTANTS -CHARACTER*512 :: ROUTINENAAM -PARAMETER (ROUTINENAAM = 'check_verdeling') - -! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: icode ! code that has to be checked; - ! if icode < 0 -> check whether a user defined distribution is present - ! if icode > 0 -> check whether a standard distribution is present - ! if icode = 0 -> do not check anything -LOGICAL, INTENT(IN) :: presentcode(MAXDIST,4) -INTEGER*4, INTENT(IN) :: stdclass ! index of standard distributions in 2nd dimension of presentcode -INTEGER*4, INTENT(IN) :: usdclass ! index of user defined distributions in 2nd dimension of presentcode -CHARACTER*(*), INTENT(IN) :: parname ! parameter name in error messages - -! SUBROUTINE ARGUMENTS - I/O -TYPE (TError), INTENT(INOUT) :: error ! error handling record - -! LOCAL VARIABLES -INTEGER*4 :: klasse ! 2nd index into presentcode - -! -! Check for user defined distributions, in case icode < 0, -! check for standard distributions, in case icode > 0 -! -IF (.NOT.error%haserror .and. icode /= 0) THEN - IF (icode < 0) THEN - klasse = usdclass - ELSE - klasse = stdclass - ENDIF - IF (.NOT. presentcode(ABS(icode), klasse)) THEN - CALL SetError('No distribution available for this code of', parname, error) - CALL ErrorParam(parname, icode, error) - CALL ErrorCall(ROUTINENAAM, error) - ENDIF -ELSE - IF (icode == 0 .and. parname == "idgr") THEN - CALL SetError('It is not permitted to use code 0 for', parname, error) - CALL ErrorParam(parname, icode, error) - CALL ErrorCall(ROUTINENAAM, error) - ENDIF -ENDIF - -END SUBROUTINE check_verdeling - END SUBROUTINE ops_read_source diff --git a/ops_reken.f90 b/ops_reken.f90 index 149fbe6..251248c 100644 --- a/ops_reken.f90 +++ b/ops_reken.f90 @@ -40,7 +40,9 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, vchemv, dv, amol1, a & trafst, knatdeppar, mb, ugmoldep, dg, irev, scavcoef, koh, croutpri, rcno, rhno2, rchno3, & & nrrcp, ircp, gxm, gym, xm, ym, zm, frac, nh3bg_rcp, rhno3_rcp, & & bqrv, bqtr, bx, by, bdiam, bsterkte, bwarmte, bhoogte, & - & bsigmaz, btgedr, bdegr, z0_src, z0_tra, z0_rcp, z0_metreg_rcp, lu_tra_per, lu_rcp_per, & + & bsigmaz, bD_stack, bV_stack, bTs_stack, bemis_horizontal, bbuilding, buildingEffect, & + & btgedr, bdegr, & + & z0_src, z0_tra, z0_rcp, z0_metreg_rcp, lu_tra_per, lu_rcp_per, & & so2sek, no2sek, so2bgtra, no2bgtra, nh3bgtra, maxidx, pmd, uspmd, spgrid, grid, subbron, uurtot, routsec, & & rc, somvnsec, telvnsec, vvchem, vtel, somvnpri, & & telvnpri, ddepri, sdrypri, snatpri, sdrysec, snatsec, cpri, csec, drydep, wetdep, astat, rno2_nox_sum, & @@ -54,6 +56,8 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, vchemv, dv, amol1, a USE m_error USE m_aps USE m_geoutils +USE m_ops_building + use m_ops_utils, only: is_missing IMPLICIT NONE @@ -123,6 +127,12 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, vchemv, dv, amol1, a REAL*4, INTENT(IN) :: bhoogte ! source height [m] REAL*4, INTENT(IN) :: bsigmaz ! spread in source height to represent different sources in a area source; ! also used for initial sigma_z (vertical dispersion) of emission (e.g. traffic, building influence) [m] +REAL*4, INTENT(IN) :: bD_stack ! diameter of the stack [m] +REAL*4, INTENT(IN) :: bV_stack ! exit velocity of plume at stack tip [m/s] +REAL*4, INTENT(IN) :: bTs_stack ! temperature of effluent from stack [K] +LOGICAL, INTENT(IN) :: bemis_horizontal ! horizontal outflow of emission +type(Tbuilding), INTENT(IN) :: bbuilding ! structure with building parameters +type(TbuildingEffect), INTENT(IN) :: buildingEffect ! structure containing building effect tables INTEGER*4, INTENT(IN) :: btgedr ! temporal behaviour of sources (tgedr << "tijdsgedrag"== temporal behaviour)[-] INTEGER*4, INTENT(IN) :: bdegr ! option for particle size distribution ! bdegr >= 0 -> standard particle size distribution pmd @@ -139,8 +149,8 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, vchemv, dv, amol1, a REAL*4, INTENT(IN) :: no2bgtra ! NO2 background concentration, trajectory averaged [ppb] REAL*4, INTENT(IN) :: nh3bgtra ! NH3 background concentration, trajectory averaged [ppb] INTEGER*4, INTENT(IN) :: maxidx ! max. number of particle classes (= 1 for gas) -REAL*4, INTENT(IN) :: pmd(NPARTCLASS,MAXDIST) ! standard particle size distributions -REAL*4, INTENT(IN) :: uspmd(NPARTCLASS,MAXDIST) ! user-defined particle size distributions +REAL*4, INTENT(IN) :: pmd(NPARTCLASS,MAXDISTR) ! standard particle size distributions +REAL*4, INTENT(IN) :: uspmd(NPARTCLASS,MAXDISTR) ! user-defined particle size distributions INTEGER*4, INTENT(IN) :: spgrid ! indicator for type of receptor points ! spgrid = 0: regular grid of receptors, NL ! spgrid = 1: rectangular regular grid of receptors, user defined @@ -201,12 +211,12 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, vchemv, dv, amol1, a ! 26. surface resistance Rc of NH3 [s/m] ! 27. surface resistance Rc of NO3 aerosol [s/m] REAL*4, INTENT(INOUT) :: rno2_nox_sum(nrrcp) ! NO2/NOx ratio, weighed sum over classes +TYPE (TError), INTENT(INOUT) :: error ! error handling record ! SUBROUTINE ARGUMENTS - OUTPUT (OUT) REAL*4, INTENT(OUT) :: precip ! precipitation amount [mm] REAL*4, INTENT(OUT) :: routpri ! in-cloud (rain-out) scavenging ratio for primary component [-] REAL*4, INTENT(OUT) :: dispg(NSTAB) ! dispersion coefficients for vertical dispersion; sigma_z = dispg*x^disph [-] -TYPE (TError), INTENT(OUT) :: error ! error handling record ! LOCAL VARIABLES INTEGER*4 :: istab ! teller over stabiliteitsklassen @@ -251,14 +261,21 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, vchemv, dv, amol1, a REAL*4 :: diam ! REAL*4 :: diameter ! REAL*4 :: szopp ! +REAL*4 :: D_stack ! diameter of the stack [m] +REAL*4 :: V_stack ! exit velocity of plume at stack tip [m/s] +REAL*4 :: Ts_stack ! temperature of effluent from stack [K] +LOGICAL :: emis_horizontal ! horizontal outflow of emission +type(Tbuilding) :: building ! structure with building paramaters +REAL*4 :: buildingFact ! The interpolated building effect from the buildingTable REAL*4 :: qrv ! REAL*4 :: virty ! REAL*4 :: consec ! -REAL*4 :: disx ! -REAL*4 :: disxx ! +REAL*4 :: angle_SR_xaxis ! angle between source-receptor vector and x-axis (needed for building effect) [degrees] +REAL*4 :: disx ! linear distance between source and receptor [m] +REAL*4 :: disxx ! effective travel distance between source and receptor [m] REAL*4 :: radius ! REAL*4 :: uster_metreg_rcp ! -REAL*4 :: tem ! +REAL*4 :: temp_C ! temperature at height zmet_T [C] REAL*4 :: shear ! REAL*4 :: ol_metreg_rcp ! REAL*4 :: h0 ! @@ -283,7 +300,7 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, vchemv, dv, amol1, a REAL*4 :: xl100 ! REAL*4 :: rad ! REAL*4 :: rcso2 ! -REAL*4 :: temp ! +REAL*4 :: coef_space_heating ! space heating coefficient (degree-day values in combination with a wind speed correction) [C m^1/2 / s^1/2] REAL*4 :: regenk ! REAL*4 :: buil ! REAL*4 :: rint ! @@ -476,9 +493,14 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, vchemv, dv, amol1, a ! Get emission data for current source and compute wind sector for source - receptor direction ! - CALL wind_rek(bx, by, bdiam, bsterkte, bwarmte, bhoogte, bsigmaz, btgedr, bdegr, bqrv, bqtr, gxm, gym, xm, & - & ym, grid, nk, nr, mrcp, nrcp, kk, nb, karea, larea, disx, x, y, qob, qww, hbron, szopp, ibtg, idgr, & + CALL wind_rek(bx, by, bdiam, bsterkte, bwarmte, bhoogte, bsigmaz, bD_stack, bV_stack, bTs_stack, bemis_horizontal, bbuilding, btgedr, bdegr, bqrv, bqtr, gxm, gym, xm, & + & ym, grid, nk, nr, mrcp, nrcp, kk, nb, karea, larea, angle_SR_xaxis, disx, x, y, qob, qww, hbron, szopp, D_stack, V_stack, Ts_stack, emis_horizontal, building, ibtg, idgr, & & qrv, qtr, rond, diameter, iwd, isek) + + ! Compute building effect (depends on source-receptor distance; we can use linear distance, because the building effect is only present near the source): + call ops_building_get_factor(building%type, angle_SR_xaxis, disx, buildingEffect%buildingFactAngleSRxaxis, buildingEffect%buildingFactDistances, building%buildingFactFunction, buildingFact) + ! write(*,*) 'ops_reken/disx;buildingFact', angle_SR_xaxis, disx, buildingFact + if (error%debug) write(*,'(a,a,a,3(1x,i6),3(1x,e12.5))') trim(ROUTINENAAM),' A ',' ircp,iwd,isek,angle_SR_xaxis,disx,buildingFact:',ircp,iwd,isek,angle_SR_xaxis,disx,buildingFact ! ! Compute chemical parameters (conversion rates, concentration ratios) in case of secondary components ! @@ -486,6 +508,8 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, vchemv, dv, amol1, a CALL ops_par_chem(icm, isek, so2sek, no2sek, so2bgtra, no2bgtra, nh3bgtra, disx, diameter, vchemnh3, rhno3, & & rrno2nox, rations) ENDIF + if (error%debug) write(*,'(3a,1x,i6,4(1x,e12.5))') trim(ROUTINENAAM),' B ',' ircp,vchemnh3, rhno3, rrno2nox, rations :',ircp,vchemnh3, rhno3, rrno2nox, rations + ! !++++++++++ Loop over stability classes ++++++++++++++++++++++++ @@ -498,10 +522,23 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, vchemv, dv, amol1, a ! Get relevant parameters from meteo statistics (dependent on wind direction and source-receptor distance), for the current ! stability class and compute the effective source height. ! - CALL ops_statparexp(istab, hbron, qww, iwd, radius, uurtot, astat, trafst, disx, isek, disxx, isekt, vw10, aksek, & - & h0, hum, ol_metreg_rcp, shear, rcaerd, rcnh3d, rcno2d, tem, uster_metreg_rcp, pcoef, & + CALL ops_statparexp(istab, hbron, qww, D_stack, V_stack, Ts_stack, emis_horizontal, iwd, radius, uurtot, astat, trafst, disx, isek, disxx, isekt, vw10, aksek, & + & h0, hum, ol_metreg_rcp, shear, rcaerd, rcnh3d, rcno2d, temp_C, uster_metreg_rcp, pcoef, & & htot, htt, itra, aant, xl, rb, ra4, ra50, xvglbr, xvghbr, xloc, xl100, rad, rcso2, & - & temp, regenk, buil, rint, percvk, error) + & coef_space_heating, regenk, buil, rint, percvk, error) + if (error%debug) then + write(*,'(3a,99(1x,i6))') trim(ROUTINENAAM),',C1,',' ircp,istab, isek, isekt, itra :', & + ircp,istab, isek, isekt, itra + write(*,'(3a,2(1x,i6),99(1x,e12.5))') trim(ROUTINENAAM),',C2,',' ircp,istab, disx, disxx, vw10 :', & + ircp,istab,disx, disxx, vw10 + write(*,'(3a,2(1x,i6),99(1x,e12.5))') trim(ROUTINENAAM),',C3,',' ircp,istab, h0, hum, ol_metreg_rcp, shear, rcaerd, rcnh3d, rcno2d, temp_C, uster_metreg_rcp, pcoef :', & + ircp,istab, h0, hum, ol_metreg_rcp, shear, rcaerd, rcnh3d, rcno2d, temp_C, uster_metreg_rcp, pcoef + write(*,'(3a,2(1x,i6),99(1x,e12.5))') trim(ROUTINENAAM),',C4,',' ircp,istab, htot, htt, aant, xl, rb, ra4, ra50, xvglbr, xvghbr, xloc, xl100, rad, rcso2 :', & + ircp,istab, htot, htt, aant, xl, rb, ra4, ra50, xvglbr, xvghbr, xloc, xl100, rad, rcso2 + write(*,'(3a,2(1x,i6),99(1x,e12.5))') trim(ROUTINENAAM),',C5,',' ircp,istab, coef_space_heating, regenk, buil, rint, percvk :', & + ircp,istab, coef_space_heating, regenk, buil, rint, percvk + endif + IF (error%haserror) GOTO 9999 ! ! Negative sensible heat flux H0 [W/m2] not allowed. @@ -521,10 +558,13 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, vchemv, dv, amol1, a ! Compute parameters which depend on stability class (friction velocity, Monin-Obukhov length, plume rise, ! vertical dispersion coefficient). Adjust yearly averaged emission for the current {stability, distance} class. ! - CALL ops_stab_rek(icm, rb, tem, h0, z0_metreg_rcp, disxx, z0_rcp, xl, radius, qtr, qrv, dv, ecvl, temp, ibtg, & - & uster_metreg_rcp, hbron, qww, istab, itra, qob, xloc, regenk, ra4, z0_tra, z0_src, & - & ol_metreg_rcp, error, uster_rcp, ol_rcp, uster_src, ol_src, uster_tra, ol_tra, & + CALL ops_stab_rek(icm, rb, temp_C, h0, z0_metreg_rcp, disxx, z0_rcp, xl, radius, qtr, qrv, dv, ecvl, coef_space_heating, ibtg, & + & uster_metreg_rcp, hbron, qww, D_stack, V_stack, Ts_stack, emis_horizontal, istab, itra, qob, xloc, regenk, ra4, z0_tra, z0_src, & + & ol_metreg_rcp, error, uster_rcp, ol_rcp, uster_src, ol_src, uster_tra, ol_tra, & & htot, htt, onder, uh, zu, qruim, qbron, dispg) + if (error%debug) write(*,'(3a,2(1x,i6),99(1x,e12.5))') & + trim(ROUTINENAAM),',D,',' ircp,istab, uster_rcp,ol_rcp,uster_src,ol_src,uster_tra,ol_tra,htot,htt,onder,uh,zu,qruim,qbron,dispg :', & + ircp,istab,uster_rcp,ol_rcp,uster_src,ol_src,uster_tra,ol_tra,htot,htt,onder,uh,zu,qruim,qbron,dispg(istab) IF (error%haserror) GOTO 9999 ! ! Continue if source strength > 0 @@ -577,7 +617,9 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, vchemv, dv, amol1, a ! CALL ops_conc_ini(gasv, vw10, htt, pcoef, disxx, kdeel, qbpri, z0_src, szopp, rond, uster_src, ol_src, & & istab, iwd, qww, hbron, dispg, radius, xl, onder, & - & htot, grof, c, sigz, ueff, virty, ccc) + & htot, grof, c, sigz, ueff, virty, ccc, error) + if (error%debug) write(*,'(3a,2(1x,i6),99(1x,e12.5))') trim(ROUTINENAAM),',E,',' ircp,istab,radius,xl,onder,htot,grof,c,sigz,ueff,virty,ccc:', & + ircp,istab,radius,xl,onder,htot,grof,c,sigz,ueff,virty,ccc ! ! Compute deposition velocities for dry and wet deposition and the concentration decrease as a result ! of deposition and (chemical) conversion. Only if idep = TRUE. @@ -585,7 +627,7 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, vchemv, dv, amol1, a IF (idep) THEN CALL ops_resist_rek(vchemc, vchemv, rad, isec, icm, rcso2, regenk, rcaerd, iseiz, istab, itra, ar, & & rno2nox, rcnh3d, vchemnh3, hum, uster_rcp, ol_rcp, uster_tra, ol_tra, & - & z0_rcp, z0_metreg_rcp, rcno2d, kdeel, mb, vw10, tem, disxx, zm, koh, & + & z0_rcp, z0_metreg_rcp, rcno2d, kdeel, mb, vw10, temp_C, disxx, zm, koh, & & rations, rhno3, rcno, rhno2, rchno3, croutpri, rrno2nox, rhno3_rcp, & & rb, ra4, ra50, rc, routpri, vchem, rcsec, uh, rc_sec_rcp, rc_rcp, rb_rcp, & & ra4_rcp, ra50_rcp, raz_rcp, z0_src, ol_src, uster_src, z0_tra, rctra_0, rcsrc, & @@ -610,12 +652,15 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, vchemv, dv, amol1, a & sdrysec(kdeel), snatsec(kdeel), somvnsec(kdeel), telvnsec(kdeel), vvchem(kdeel), & & vtel(kdeel), snatpri(kdeel), somvnpri(kdeel), telvnpri(kdeel), ddepri(ircp,kdeel), & & drydep(ircp,kdeel), wetdep(ircp,kdeel), dm, qsec, consec, pr, & - & vg50trans, ra50tra, rb_tra, rclocal, vgpart, xg) + & vg50trans, ra50tra, rb_tra, rclocal, vgpart, xg, buildingFact) + ! ! Update summed concentration for secondary concentration ! csec(ircp,kdeel) = csec(ircp,kdeel) + (consec*percvk) - + ELSE + ! Building effect for idep = 0: + c = c*buildingFact ENDIF ! end condition idep (compute deposition) ! ! Update summed concentration for primary concentration @@ -639,6 +684,8 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, vchemv, dv, amol1, a ENDDO ! end loop over sub receptors (y-direction) ENDDO ! end loop over sub receptors (x-direction) + ! Computation for this source completed, deallocate buildingFactFunction for this source: + if (building%type > 0) deallocate(building%buildingFactFunction) RETURN ! ! Negative concentration. Create error message and close the progress file. @@ -681,10 +728,12 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, vchemv, dv, amol1, a ! DESCRIPTION : Compute preliminary wind sector, not including wind shear. ! Also get all source data for the current source !------------------------------------------------------------------------------------------------------------------------------- -SUBROUTINE wind_rek(bx, by, bdiam, bsterkte, bwarmte, bhoogte, bsigmaz, btgedr, bdegr, bqrv, bqtr, gxm, gym, xm, ym, & - & grid, nk, nr, mrcp, nrcp, kk, nb, karea,larea, disxx, x, y, qob, qww, hbron, szopp, ibtg, idgr, qrv, & +SUBROUTINE wind_rek(bx, by, bdiam, bsterkte, bwarmte, bhoogte, bsigmaz, bD_stack, bV_stack, bTs_stack, bemis_horizontal, bbuilding, btgedr, bdegr, bqrv, bqtr, gxm, gym, xm, ym, & + & grid, nk, nr, mrcp, nrcp, kk, nb, karea, larea, angle_SR_xaxis, disx, x, y, qob, qww, hbron, szopp, D_stack, V_stack, Ts_stack, emis_horizontal, building, ibtg, idgr, qrv, & & qtr, rond, diameter, iwd, isek) +USE Binas, only: deg2rad, rad2deg + ! CONSTANTS CHARACTER*512 :: ROUTINENAAM ! PARAMETER (ROUTINENAAM = 'wind_rek') @@ -697,6 +746,11 @@ SUBROUTINE wind_rek(bx, by, bdiam, bsterkte, bwarmte, bhoogte, bsigmaz, btgedr, REAL*4, INTENT(IN) :: bwarmte ! REAL*4, INTENT(IN) :: bhoogte ! REAL*4, INTENT(IN) :: bsigmaz ! +REAL*4, INTENT(IN) :: bD_stack ! diameter of the stack [m] +REAL*4, INTENT(IN) :: bV_stack ! exit velocity of plume at stack tip [m/s] +REAL*4, INTENT(IN) :: bTs_stack ! temperature of effluent from stack [K] +LOGICAL, INTENT(IN) :: bemis_horizontal ! horizontal outflow of emission +type(Tbuilding), INTENT(IN) :: bbuilding ! structure with building parameters INTEGER*4, INTENT(IN) :: btgedr ! INTEGER*4, INTENT(IN) :: bdegr ! REAL*4, INTENT(IN) :: bqrv ! @@ -716,13 +770,19 @@ SUBROUTINE wind_rek(bx, by, bdiam, bsterkte, bwarmte, bhoogte, bsigmaz, btgedr, INTEGER*4, INTENT(IN) :: larea ! ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: disxx ! +REAL*4, INTENT(OUT) :: angle_SR_xaxis ! angle between source-receptor vector and x-axis (needed for building effect) [degrees] +REAL*4, INTENT(OUT) :: disx ! linear distance between source and receptor [m] REAL*4, INTENT(OUT) :: x ! REAL*4, INTENT(OUT) :: y ! REAL*4, INTENT(OUT) :: qob ! REAL*4, INTENT(OUT) :: qww ! REAL*4, INTENT(OUT) :: hbron ! REAL*4, INTENT(OUT) :: szopp ! +REAL*4, INTENT(OUT) :: D_stack ! diameter of the stack [m] +REAL*4, INTENT(OUT) :: V_stack ! exit velocity of plume at stack tip [m/s] +REAL*4, INTENT(OUT) :: Ts_stack ! temperature of effluent from stack [K] +LOGICAL, INTENT(OUT) :: emis_horizontal ! horizontal outflow of emission +type(Tbuilding), INTENT(OUT) :: building ! strucure with building parameters INTEGER*4, INTENT(OUT) :: ibtg ! INTEGER*4, INTENT(OUT) :: idgr ! REAL*4, INTENT(OUT) :: qrv ! @@ -751,11 +811,16 @@ SUBROUTINE wind_rek(bx, by, bdiam, bsterkte, bwarmte, bhoogte, bsigmaz, btgedr, qob = (bsterkte/nb)/nr ! Other source parameters: -qww = bwarmte -hbron = bhoogte -szopp = bsigmaz -ibtg = btgedr -idgr = bdegr +qww = bwarmte ! heat content[MW] +hbron = bhoogte ! emission height [m] +szopp = bsigmaz ! spread in emission height [m] +D_stack = bD_stack ! diameter of the stack [m] +V_stack = bV_stack ! exit velocity of plume at stack tip [m/s] +Ts_stack = bTs_stack ! temperature of effluent from stack [K] +emis_horizontal = bemis_horizontal ! horizontal outflow of emission +building = bbuilding ! building parameters +ibtg = btgedr ! diurnal variation code +idgr = bdegr ! particle size distribution code ! Source strengths for space heating and traffic: qrv = (bqrv/nb)/nr @@ -773,23 +838,23 @@ SUBROUTINE wind_rek(bx, by, bdiam, bsterkte, bwarmte, bhoogte, bsigmaz, btgedr, ENDIF ! ! Determine source - (sub) receptor distance (in meters), given source = (x1,y1) and receptor = (x2,y2) in degrees. -! CONV = pi/180. R = earth radius (m). -! distance in y-direction = R*(y2 - y1)*CONV, y latitude -! distance in x-direction = R*cos(y*CONV)*(x2 - x1)*CONV, x longitude -! distance between 1 and 2: R*sqrt([cos(y*CONV)*(x2-x1)*CONV]^2 + [(y2-y1)*CONV]^2) = R*CONV*([cos(y*CONV)*(x2-x1)]^2 + (y2-y1)^2) -! Note: R1 = equatorial radius: 6378.137 km, R2 = distance centre - pole: 6356.752 km -! R1*CONV = 111319.5 m, R2*CONV = 110946.3 m (average = 111132.9 m). +! deg2rad = pi/180. R = earth radius (m). +! distance in y-direction = R*(y2 - y1)*deg2rad, y latitude +! distance in x-direction = R*cos(y*deg2rad)*(x2 - x1)*deg2rad, x longitude +! distance between 1 and 2: R*sqrt([cos(y*deg2rad)*(x2-x1)*deg2rad]^2 + [(y2-y1)*deg2rad]^2) = R*deg2rad*([cos(y*deg2rad)*(x2-x1)]^2 + (y2-y1)^2) +! Note: R1 = equatorial radius: 6378.137 km, R2 = distance centre - pole: 6356.752 km +! R1*deg2rad = 111319.5 m, R2*deg2rad = 110946.3 m (average = 111132.9 m). Here rounded to 111000 m. ! IF (IGEO .EQ. 1) THEN ! Geographical coordinates (degrees) dy = gym - y - dx = (gxm - x)*COS((y + dy/2.)/CONV) - disxx = 111000.*SQRT(dx*dx + dy*dy) + dx = (gxm - x)*COS((y + dy/2.)*deg2rad) + disx = 111000.*SQRT(dx*dx + dy*dy) ELSE ! RDM coordinates [m] dx = xm + mrcp*grid/(nk*2 + 1) - x dy = ym + nrcp*grid/(nk*2 + 1) - y - disxx = SQRT((dx*dx) + (dy*dy)) + disx = SQRT((dx*dx) + (dy*dy)) ENDIF ! North receptor @@ -809,8 +874,8 @@ SUBROUTINE wind_rek(bx, by, bdiam, bsterkte, bwarmte, bhoogte, bsigmaz, btgedr, ! Angle with North = pi/2 - alpha = pi/2 - atan2(dy,dx) = atan2(dx,dy). ! The addition of 180 degrees is because we need the wind direction coming from the source. ! -IF (disxx .GT. 2.) THEN - iwd = NINT(ATAN2(dx, dy)*CONV + 180) +IF (disx .GT. 2.) THEN + iwd = NINT(ATAN2(dx, dy)*rad2deg + 180) IF (iwd.EQ.360) iwd = 0 ELSE ! @@ -827,6 +892,9 @@ SUBROUTINE wind_rek(bx, by, bdiam, bsterkte, bwarmte, bhoogte, bsigmaz, btgedr, isek = 1 ENDIF +! Determine angle between source-receptor vector and x-axis, betweeen 0 and 360 degrees (needed for building effect): +angle_SR_xaxis = modulo(atan2(dy,dx)*rad2deg, 360.0) ! degrees + RETURN END SUBROUTINE wind_rek diff --git a/ops_resist_rek.f90 b/ops_resist_rek.f90 index a9a4d21..c7049eb 100644 --- a/ops_resist_rek.f90 +++ b/ops_resist_rek.f90 @@ -38,7 +38,7 @@ !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE ops_resist_rek(vchemc, vchemv, rad, isec, icm, rcso2, regenk, rcaerd, iseiz, istab, itra, ar, & rno2nox, rcnh3d, vchemnh3, hum, uster_rcp, ol_rcp, uster_tra, ol_tra, & - z0_rcp, z0_metreg_rcp, rcno2d, kdeel, mb, vw10, tem, disx, zm, koh, & + z0_rcp, z0_metreg_rcp, rcno2d, kdeel, mb, vw10, temp_C, disx, zm, koh, & rations, rhno3, rcno, rhno2, rchno3, croutpri, rrno2nox, rhno3_rcp, & rb, ra4, ra50, rc, routpri, vchem, rcsec, uh, rc_sec_rcp, rc_rcp, rb_rcp, & ra4_rcp, ra50_rcp, raz_rcp, z0_src, ol_src, uster_src, z0_tra, rctra_0, rcsrc, ra4src, & @@ -80,7 +80,7 @@ SUBROUTINE ops_resist_rek(vchemc, vchemv, rad, isec, icm, rcso2, regenk, rcaerd, INTEGER*4, INTENT(IN) :: kdeel ! INTEGER*4, INTENT(IN) :: mb ! REAL*4, INTENT(IN) :: vw10 ! -REAL*4, INTENT(IN) :: tem ! +REAL*4, INTENT(IN) :: temp_C ! temperature at height zmet_T [C] REAL*4, INTENT(IN) :: disx ! REAL*4, INTENT(IN) :: zm ! REAL*4, INTENT(IN) :: koh ! @@ -394,7 +394,7 @@ SUBROUTINE ops_resist_rek(vchemc, vchemv, rad, isec, icm, rcso2, regenk, rcaerd, ! rc_rcp : canopy resistance at receptor, no re-emission allowed [s/m]; ! is used for deposition gradient at receptor ! rclocal: canopy resistance at receptor, re-emission allowed [s/m]; -! is used for the computation of drypri, the local depsosition at the receptor +! is used for the computation of drypri, the local deposition at the receptor !------------------------------------------------------------------------------------------- ! Wesely parameterization @@ -432,8 +432,9 @@ SUBROUTINE ops_resist_rek(vchemc, vchemv, rad, isec, icm, rcso2, regenk, rcaerd, ! catm = nh3bgtra*17/24 c_ave_prev = nh3bgtra*17/24 -! - CALL ops_depos_rc(icm, iseiz, mb, gym ,tem, uster_tra, glrad, hum, nwet, ratns, catm, c_ave_prev, lu_tra_per, ra4tra, rb_tra, & + ! write(*,'(a,2(1x,e12.5))') 'catm,c_ave_prev traj = ',catm,c_ave_prev + + CALL ops_depos_rc(icm, iseiz, mb, gym ,temp_C, uster_tra, glrad, hum, nwet, ratns, catm, c_ave_prev, lu_tra_per, ra4tra, rb_tra, & & rctra_0, rclocal) rcsrc = rctra_0 ! ! @@ -446,8 +447,9 @@ SUBROUTINE ops_resist_rek(vchemc, vchemv, rad, isec, icm, rcso2, regenk, rcaerd, ! catm = nh3bg_rcp c_ave_prev = nh3bg_rcp -! - CALL ops_depos_rc(icm, iseiz, mb, gym ,tem, uster_rcp, glrad, hum, nwet, ratns, catm, c_ave_prev, lu_rcp_per, ra4_rcp, rb_rcp, & + !write(*,'(a,2(1x,e12.5))') 'catm,c_ave_prev rcp = ',catm,c_ave_prev + + CALL ops_depos_rc(icm, iseiz, mb, gym ,temp_C, uster_rcp, glrad, hum, nwet, ratns, catm, c_ave_prev, lu_rcp_per, ra4_rcp, rb_rcp, & & rc_rcp, rclocal) !------------------------------------------------------------------ @@ -489,7 +491,7 @@ SUBROUTINE ops_resist_rek(vchemc, vchemv, rad, isec, icm, rcso2, regenk, rcaerd, ! Rc(NOx) + Rb + Ra Rc(NO2)+ Rb + Ra Rc(NO) + Rb + Ra Rc(HNO2) + Rb + Ra ! r = rb + ra4 - rc_rcp = 1./(rnox/(rc_rcp+r) + (1.-rnox)/(rcno+r) + rhno2/(rchno2+r)) - r + rc_rcp = 1./(rnox/(rc_rcp+r) + (1.-rnox)/(rcno+r) + rhno2/(rchno2+r)) - r rclocal = rc_rcp rctra_0 = 1./(rnox/(rctra_0+r) + (1.-rnox)/(rcno+r) + rhno2/(rchno2+r)) - r rcsrc = rctra_0 diff --git a/ops_stab_rek.f90 b/ops_stab_rek.f90 index 7e8f13c..5860e3b 100644 --- a/ops_stab_rek.f90 +++ b/ops_stab_rek.f90 @@ -37,14 +37,17 @@ ! CALLED FUNCTIONS : ! UPDATE HISTORY : !------------------------------------------------------------------------------------------------------------------------------- -SUBROUTINE ops_stab_rek(icm, rb, tem, h0, z0_metreg_rcp, disx, z0_rcp, xl, radius, qtr, qrv, dv, ecvl, temp, ibtg, & - & uster_metreg_rcp, hbron, qww, istab, itra, qob, xloc, regenk, ra4, z0_tra, z0_src, ol_metreg_rcp,error, & - & uster_rcp, ol_rcp, uster_src, ol_src, uster_tra, ol_tra, htot, htt, onder, uh, zu, qruim, qbron, & +SUBROUTINE ops_stab_rek(icm, rb, temp_C, h0, z0_metreg_rcp, disx, z0_rcp, xl, radius, qtr, qrv, dv, ecvl, coef_space_heating, ibtg, & + & uster_metreg_rcp, hbron, qww, D_stack, V_stack, Ts_stack, emis_horizontal, istab, itra, qob, xloc, regenk, ra4, z0_tra, z0_src, ol_metreg_rcp,error, & + & uster_rcp, ol_rcp, uster_src, ol_src, uster_tra, ol_tra, htot, htt, onder, uh, zu, qruim, qbron, & & dispg) USE m_commonconst USE m_commonfile USE m_error +! USE m_ops_plumerise, only ops_plumerise +USE m_ops_plumerise +use m_ops_utils, only: is_missing IMPLICIT NONE @@ -55,7 +58,7 @@ SUBROUTINE ops_stab_rek(icm, rb, tem, h0, z0_metreg_rcp, disx, z0_rcp, xl, radiu ! SUBROUTINE ARGUMENTS - INPUT INTEGER*4, INTENT(IN) :: icm ! componentnummer REAL*4, INTENT(IN) :: rb ! -REAL*4, INTENT(IN) :: tem ! +REAL*4, INTENT(IN) :: temp_C ! temperature at height zmet_T [C] REAL*4, INTENT(IN) :: h0 ! REAL*4, INTENT(IN) :: z0_metreg_rcp ! roughness length at receptor; interpolated from meteo regions [m] REAL*4, INTENT(IN) :: disx ! @@ -66,11 +69,15 @@ SUBROUTINE ops_stab_rek(icm, rb, tem, h0, z0_metreg_rcp, disx, z0_rcp, xl, radiu REAL*4, INTENT(IN) :: qrv ! INTEGER*4, INTENT(IN) :: dv ! REAL*4, INTENT(IN) :: ecvl(NSTAB, NTRAJ, *) ! -REAL*4, INTENT(IN) :: temp ! +REAL*4, INTENT(IN) :: coef_space_heating ! space heating coefficient (degree-day values in combination with a wind speed correction) [C m^1/2 / s^1/2] INTEGER*4, INTENT(IN) :: ibtg ! -REAL*4, INTENT(IN) :: uster_metreg_rcp ! +REAL*4, INTENT(IN) :: uster_metreg_rcp ! REAL*4, INTENT(IN) :: hbron ! REAL*4, INTENT(IN) :: qww ! +REAL*4, INTENT(IN) :: D_stack ! diameter of the stack [m] +REAL*4, INTENT(IN) :: V_stack ! exit velocity of plume at stack tip [m/s] +REAL*4, INTENT(IN) :: Ts_stack ! temperature of effluent from stack [K] +LOGICAL, INTENT(IN) :: emis_horizontal ! horizontal outflow of emission INTEGER*4, INTENT(IN) :: istab ! INTEGER*4, INTENT(IN) :: itra ! REAL*4, INTENT(IN) :: qob ! @@ -116,6 +123,7 @@ SUBROUTINE ops_stab_rek(icm, rb, tem, h0, z0_metreg_rcp, disx, z0_rcp, xl, radiu REAL*4 :: rcor ! REAL*4 :: dncor ! REAL*4 :: emf ! +logical :: VsDs_opt ! read stack parameters Ds/Vs/Ts from source file ! SUBROUTINE AND FUNCTION CALLS EXTERNAL ops_z0corr @@ -157,12 +165,12 @@ SUBROUTINE ops_stab_rek(icm, rb, tem, h0, z0_metreg_rcp, disx, z0_rcp, xl, radiu ! cp : specific heat capacity = 1003.5 J/(kg K), sea level, dry, T=0 C; 1012 J/(kg/K), typical room conditions (T = 23 C) ! kappa : von Karman constant = 0.4 [-] ! g : accelaration of gravity = 9.81 m/s2 -! T : absolute temperature = (273 + tem) K +! T : absolute temperature [K] ! H0 : surface heat flux [W/m2] ! ! actual values in code: rho= 1.29 kg/m3, cp = 1005 J/(kg K), kappa=0.4, g=9.8 m/s2. ! -ol_metreg_from_rb_rcp = -uster_metreg_from_rb_rcp**3*1.29*1005*(273 + tem)/(0.4*9.8*h0) +ol_metreg_from_rb_rcp = -uster_metreg_from_rb_rcp**3*1.29*1005*(273 + temp_C)/(0.4*9.8*h0) IF (ol_metreg_rcp .GT. (0. + EPS_DELTA)) THEN IF (ol_metreg_rcp .LE. 5.) THEN ! MdH: EPS_DELTA overbodig, want deze is continue ol_metreg_rcp = 10. @@ -203,8 +211,12 @@ SUBROUTINE ops_stab_rek(icm, rb, tem, h0, z0_metreg_rcp, disx, z0_rcp, xl, radiu !-------------------------------------------------------------------------- ! Compute plume rise and inverse penetration according to Briggs (1971) !-------------------------------------------------------------------------- -CALL ops_plrise71(z0_src, xl, ol_src, uster_src, hbron, qww, xloc, htt, onder) +!CALL ops_plrise71(z0_src, xl, ol_src, uster_src, hbron, qww, xloc, htt, onder) +VsDs_opt = .not. is_missing(V_stack) +call ops_plumerise(z0_src, hbron, uster_src, ol_src, qww, VsDs_opt, D_stack, V_stack, Ts_stack, emis_horizontal, temp_C, xl, xloc, htt, onder, error) +! write(*,'(a,4(1x,e12.5))') 'after call ops_plumerise: ',hbron,htt,htt-hbron,onder htot = htt +if (error%haserror) goto 9999 !------------------------------------------------ ! Compute vertical dispersion coefficient sigma_z @@ -214,14 +226,19 @@ SUBROUTINE ops_stab_rek(icm, rb, tem, h0, z0_metreg_rcp, disx, z0_rcp, xl, radiu ! in other cases (area source, point source and receptor further away) compute vertical dispersion. dsx = AMAX1(disx, radius) IF (dsx .GT. (1. + EPS_DELTA)) THEN -! -! Compute vertical dispersion coefficient at source site -! - CALL ops_vertdisp(z0_src, xl, ol_src, uster_src, htot, dsx, uh, zu, szsrc) -! -! Compute vertical dispersion coefficient at receptor -! - CALL ops_vertdisp(z0_rcp, xl, ol_rcp, uster_rcp, htot, dsx, uh_rcp, zu_rcp, sz_rcp) + + ! Compute vertical dispersion coefficient at receptor with (z0,u*,L,uh,zu) of source site + CALL ops_vertdisp(z0_src, xl, ol_src, uster_src, htot, dsx, uh, zu, szsrc, error) + if (error%debug) write(*,'(3a,2(1x,i6),99(1x,e12.5))') trim(ROUTINENAAM),',A,', & + ' ircp,istab,z0_src, xl, ol_src, uster_src, htot, dsx, uh, zu, szsrc:', & + -999,istab,z0_src, xl, ol_src, uster_src, htot, dsx, uh, zu, szsrc + + ! Compute vertical dispersion coefficient at receptor with (z0,u*,L,uh,zu) of receptor site + CALL ops_vertdisp(z0_rcp, xl, ol_rcp, uster_rcp, htot, dsx, uh_rcp, zu_rcp, sz_rcp, error) + if (error%debug) write(*,'(3a,2(1x,i6),99(1x,e12.5))') trim(ROUTINENAAM),',B,', & + ' ircp,istab,z0_rcp, xl, ol_rcp, uster_rcp, htot, dsx, uh_rcp, zu_rcp, sz_rcp:', & + -999,istab,z0_rcp, xl, ol_rcp, uster_rcp, htot, dsx, uh_rcp, zu_rcp, sz_rcp + ! ! Limit sigma_z at source, such that sigma_z(source) < sigma_z(receptor) ! @@ -233,10 +250,9 @@ SUBROUTINE ops_stab_rek(icm, rb, tem, h0, z0_metreg_rcp, disx, z0_rcp, xl, radiu ! sigma_z = dispg*disx**disph <=> dispg = sigma_z/(disx**disph), 3.16 new! OPS report ! Since in the rest of the code the old formula sigma_z = dispg*disx**disph is still used, ! we need dispg and disph and we do not use szsrc and sz_rcp hereafter. - -! dispg(istab) = (szsrc + sz_rcp)*0.5/(dsx**DISPH(istab)) - + if (error%debug) write(*,'(3a,2(1x,i6),99(1x,e12.5))') trim(ROUTINENAAM),',C,', ' ircp,istab,dispg(istab):', -999,istab,dispg(istab) + ! Check limits 0 <= dispg <= 50; if outside limits, generate warning: IF ((dispg(istab) .LT. (0. - EPS_DELTA)) .OR. (dispg(istab) .GT. (50. + EPS_DELTA))) THEN IF (.NOT. ops_openlog(error)) GOTO 9999 @@ -254,9 +270,9 @@ SUBROUTINE ops_stab_rek(icm, rb, tem, h0, z0_metreg_rcp, disx, z0_rcp, xl, radiu ! Compute space ("ruimte" = space) heating emission as function of the temperature. ! space_heating_coefficent = (19 - T24)*sqrt(u10/3.2), for T24 < 12 C; 5.1 OPS report ! T24 = daily average outdoor temperature (C). -! u10 = wind speeed at 10 m (m/s) +! u10 = wind speed at 10 m (m/s) ! 0.1042 = 1/mean(space_heating_coefficient), longterm average, is used to normalise the space_heating_coefficent. -qruim = .1042*temp*qrv +qruim = .1042*coef_space_heating*qrv ! ! Choose type of diurnal variation of emission, depending on ibtg ! and current {stability,distance} class and adjust source strengths. @@ -294,7 +310,7 @@ SUBROUTINE ops_stab_rek(icm, rb, tem, h0, z0_metreg_rcp, disx, z0_rcp, xl, radiu ! Temperature correction tcor = 1 + (T - Tavg)/f = 1 + T/f - 10/f = (1-10/f) + T/f = (f-10)/f + T/f = (T + f-10)/f; ! Here f = 34, corresponding with a factor 1/34 = 0.0294 (0.04 in 6.33 OPS report). ! - tcor=amax1((tem+24)/34, 0.2) + tcor=amax1((temp_C+24)/34, 0.2) ! Influence of day/night rithm of animals on emissions; half the industrial emission variation @@ -310,7 +326,7 @@ SUBROUTINE ops_stab_rek(icm, rb, tem, h0, z0_metreg_rcp, disx, z0_rcp, xl, radiu rcor=amax1(rcor,0.5) rcor=amin1(rcor,1.5) - emf=0.0000155*((100./(ra4+rb))**0.8*(tem+23)**2.3)**1.25 ! 981209 + emf=0.0000155*((100./(ra4+rb))**0.8*(temp_C+23)**2.3)**1.25 ! 981209 qobb=qob*rcor*emf ! 980922; corr 990227 ELSE diff --git a/ops_statparexp.f90 b/ops_statparexp.f90 index 68a840d..9a3f656 100644 --- a/ops_statparexp.f90 +++ b/ops_statparexp.f90 @@ -38,15 +38,16 @@ ! CONTAINS PROCEDURES: bepafst, voorlpl, ronafhpar, windsek, windcorr, interp_ctr, interp_tra, interp_sek ! UPDATE HISTORY : !------------------------------------------------------------------------------------------------------------------------------- -SUBROUTINE ops_statparexp(istab, hbron, qww, iwd, radius, uurtot, astat, trafst, disx, isek, disxx, isekt, vw10, aksek, h0, & - & hum, ol_metreg_rcp, shear, rcaer, rcnh3, rcno2, tem, uster_metreg_rcp, pcoef, htot, htt, itra, aant, & - & xl, rb, ra4, ra50, xvglbr, xvghbr, xloc,xl100, rad, rcso2, temp, regenk, buil, rint, percvk, error) +SUBROUTINE ops_statparexp(istab, hbron, qww, D_stack, V_stack, Ts_stack, emis_horizontal, iwd, radius, uurtot, astat, trafst, disx, isek, disxx, isekt, vw10, aksek, h0, & + & hum, ol_metreg_rcp, shear, rcaer, rcnh3, rcno2, temp_C, uster_metreg_rcp, pcoef, htot, htt, itra, aant, & + & xl, rb, ra4, ra50, xvglbr, xvghbr, xloc,xl100, rad, rcso2, coef_space_heating, regenk, buil, rint, percvk, error) !DEC$ ATTRIBUTES DLLEXPORT:: ops_statparexp USE m_error USE m_commonconst USE m_commonfile +USE m_ops_plumerise IMPLICIT NONE @@ -57,32 +58,36 @@ SUBROUTINE ops_statparexp(istab, hbron, qww, iwd, radius, uurtot, astat, trafst, ! SUBROUTINE ARGUMENTS - INPUT INTEGER*4, INTENT(IN) :: istab REAL*4, INTENT(IN) :: hbron -REAL*4, INTENT(IN) :: qww +REAL*4, INTENT(IN) :: qww +REAL*4, INTENT(IN) :: D_stack ! diameter of the stack [m] +REAL*4, INTENT(IN) :: V_stack ! exit velocity of plume at stack tip [m/s] +REAL*4, INTENT(IN) :: Ts_stack ! temperature of effluent from stack [K] +LOGICAL, INTENT(IN) :: emis_horizontal ! horizontal outflow of emission INTEGER*4, INTENT(IN) :: iwd REAL*4, INTENT(IN) :: radius REAL*4, INTENT(IN) :: uurtot REAL*4, INTENT(IN) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) REAL*4, INTENT(IN) :: trafst(NTRAJ) -REAL*4, INTENT(IN) :: disx +REAL*4, INTENT(IN) :: disx ! linear distance between source and receptor [m] INTEGER*4, INTENT(IN) :: isek ! ! SUBROUTINE ARGUMENTS - I/O TYPE (TError), INTENT(INOUT) :: error ! error handling record ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: disxx +REAL*4, INTENT(OUT) :: disxx ! effective travel distance between source and receptor [m] INTEGER*4, INTENT(OUT) :: isekt ! REAL*4, INTENT(OUT) :: vw10 ! REAL*4, INTENT(OUT) :: aksek(12) ! REAL*4, INTENT(OUT) :: h0 ! REAL*4, INTENT(OUT) :: hum ! -REAL*4, INTENT(OUT) :: ol_metreg_rcp ! +REAL*4, INTENT(OUT) :: ol_metreg_rcp ! REAL*4, INTENT(OUT) :: shear ! REAL*4, INTENT(OUT) :: rcaer ! REAL*4, INTENT(OUT) :: rcnh3 ! REAL*4, INTENT(OUT) :: rcno2 ! -REAL*4, INTENT(OUT) :: tem ! -REAL*4, INTENT(OUT) :: uster_metreg_rcp ! +REAL*4, INTENT(OUT) :: temp_C ! temperature at height zmet_T [C] +REAL*4, INTENT(OUT) :: uster_metreg_rcp ! REAL*4, INTENT(OUT) :: pcoef ! REAL*4, INTENT(OUT) :: htot ! REAL*4, INTENT(OUT) :: htt ! @@ -98,7 +103,7 @@ SUBROUTINE ops_statparexp(istab, hbron, qww, iwd, radius, uurtot, astat, trafst, REAL*4, INTENT(OUT) :: xl100 ! REAL*4, INTENT(OUT) :: rad ! REAL*4, INTENT(OUT) :: rcso2 ! -REAL*4, INTENT(OUT) :: temp ! +REAL*4, INTENT(OUT) :: coef_space_heating ! space heating coefficient (degree-day values in combination with a wind speed correction) [C m^1/2 / s^1/2] REAL*4, INTENT(OUT) :: regenk ! REAL*4, INTENT(OUT) :: buil ! REAL*4, INTENT(OUT) :: rint ! @@ -134,6 +139,7 @@ SUBROUTINE ops_statparexp(istab, hbron, qww, iwd, radius, uurtot, astat, trafst, REAL*4 :: sa ! REAL*4 :: so ! REAL*4 :: sp ! +real :: dum ! dummy output variable ! SCCS-ID VARIABLES CHARACTER*81 :: sccsida ! @@ -141,11 +147,17 @@ SUBROUTINE ops_statparexp(istab, hbron, qww, iwd, radius, uurtot, astat, trafst, !------------------------------------------------------------------------------------------------------------------------------- ! ! Compute preliminary plume rise; preliminary in the sense that later on (ops_conc_ini) -! corrections may be applied (e.g. for heavy particles). -! ("voorl" << voorlopig = preliminary, pl << plume) -! -CALL voorlpl(istab, isek, hbron, qww, astat, vw10, pcoef, htt) +! stability is defined in terms of L and U*, instead of stability class (as in ops_plumerise_prelim) +! and that corrections may be applied (e.g. for heavy particles). +! Also get values of vw10 and pcoef ! +! write(*,'(a,4(1x,e12.5),2(1x,i6))') 'before call ops_plumerise_prelim: ',hbron,htt,htt-hbron,-999.0,istab,isek +! write(*,'(a,4(1x,e12.5))') 'before call ops_plumerise_prelim: ',hbron,htt,htt-hbron,-999.0 +call ops_plumerise_prelim(istab,isek,astat,hbron,qww,D_stack,V_stack,Ts_stack,emis_horizontal,htt,error) +if (error%haserror) goto 9999 +call ops_wv_powerlaw(istab,isek,astat,hbron,dum,vw10,pcoef) +!write(*,'(a,4(1x,e12.5))') 'after call ops_plumerise_prelim: ',hbron,htt,htt-hbron,-999.0 + ! Compute, given a source - receptor direction (taking into account plume rise and wind shear), ! the wind sector where this direction lies in (iss), the wind sectors between which to ! interpolate (isekt,is) and the interpolation factor (s). @@ -210,8 +222,8 @@ SUBROUTINE ops_statparexp(istab, hbron, qww, iwd, radius, uurtot, astat, trafst, ! Interpolate meteo parameters over wind sectors ! CALL interp_sek(istab, iss, itrx, is, s, isekt, stt, astat, xl, vw10, rb, ra4, ra50, xvglbr, xvghbr, uster_metreg_rcp, & - & tem, ol_metreg_rcp, h0, xloc, xl100, sp, rad, rcso2, hum, pcoef, rcnh3, rcno2, rcaer, & - & buil, rint, shear, dscor, temp, regenk) + & temp_C, ol_metreg_rcp, h0, xloc, xl100, sp, rad, rcso2, hum, pcoef, rcnh3, rcno2, rcaer, & + & buil, rint, shear, dscor, coef_space_heating, regenk) ! ! Compute the effective travel distance between source and receptor ! @@ -248,23 +260,23 @@ SUBROUTINE ops_statparexp(istab, hbron, qww, iwd, radius, uurtot, astat, trafst, ! ! Note: rcso2 is no longer used; instead OPS uses DEPAC RC-values ! - so = (r*sa) + (1. - r)*so - xl = (r*stta(2)) + (1. - r)*sttr(2) - rb = (r*stta(4)) + (1. - r)*sttr(4) - r4 = (r*stta(5)) + (1. - r)*sttr(5) - r50 = (r*stta(6)) + (1. - r)*sttr(6) - regenk = (r*stta(11)) + (1. - r)*sttr(11) - rad = (r*stta(14)) + (1. - r)*sttr(14) - rcso2 = (r*stta(16)) + (1. - r)*sttr(16) - uster_metreg_rcp = (r*stta(19)) + (1. - r)*sttr(19) - tem = (r*stta(20)) + (1. - r)*sttr(20) - ol_metreg_rcp = (r*stta(22)) + (1. - r)*sttr(22) - h0 = (r*stta(23)) + (1. - r)*sttr(23) - rcno2 = (r*stta(25)) + (1. - r)*sttr(25) - rcnh3 = (r*stta(26)) + (1. - r)*sttr(26) - rcaer = (r*stta(27)) + (1. - r)*sttr(27) - ra4 = r4 - rb - ra50 = r50 - rb + so = (r*sa) + (1. - r)*so + xl = (r*stta(2)) + (1. - r)*sttr(2) + rb = (r*stta(4)) + (1. - r)*sttr(4) + r4 = (r*stta(5)) + (1. - r)*sttr(5) + r50 = (r*stta(6)) + (1. - r)*sttr(6) + regenk = (r*stta(11)) + (1. - r)*sttr(11) + rad = (r*stta(14)) + (1. - r)*sttr(14) + rcso2 = (r*stta(16)) + (1. - r)*sttr(16) + uster_metreg_rcp = (r*stta(19)) + (1. - r)*sttr(19) + temp_C = (r*stta(20)) + (1. - r)*sttr(20) + ol_metreg_rcp = (r*stta(22)) + (1. - r)*sttr(22) + h0 = (r*stta(23)) + (1. - r)*sttr(23) + rcno2 = (r*stta(25)) + (1. - r)*sttr(25) + rcnh3 = (r*stta(26)) + (1. - r)*sttr(26) + rcaer = (r*stta(27)) + (1. - r)*sttr(27) + ra4 = r4 - rb + ra50 = r50 - rb ELSE @@ -328,14 +340,14 @@ SUBROUTINE bepafst(itra, s, trafst, disx, dscor, xl, disxx) INTEGER*4, INTENT(IN) :: itra ! REAL*4, INTENT(IN) :: s(NTRAJ) ! REAL*4, INTENT(IN) :: trafst(NTRAJ) ! -REAL*4, INTENT(IN) :: disx ! +REAL*4, INTENT(IN) :: disx ! linear distance between source and receptor ('as the crow flies') [m] ! SUBROUTINE ARGUMENTS - I/O REAL*4, INTENT(INOUT) :: dscor(NTRAJ) ! Note: dscor is not used anymore after this routine REAL*4, INTENT(INOUT) :: xl ! ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: disxx ! +REAL*4, INTENT(OUT) :: disxx ! effective travel distance between source and receptor [m] ! LOCAL VARIABLES INTEGER*4 :: ids ! @@ -487,6 +499,7 @@ SUBROUTINE voorlpl(istab, isek, hbron, qww, astat, vw10, pcoef, htt) ELSE utop = vw10 ENDIF + write(*,'(a,2(1x,e12.5))') 'voorlpl a',hbron,utop IF (istab .GE. 5) THEN ! @@ -496,14 +509,18 @@ SUBROUTINE voorlpl(istab, isek, hbron, qww, astat, vw10, pcoef, htt) ! more suited for industrial sources ! delh = 65.*(qww/utop)**.333 + write(*,'(a,2(1x,e12.5))') 'voorlpl b',hbron,delh + ! ! plume rise for non-stable conditions; split into Qww < 6 and Qww > 6 ! (3.25, 3.26 OPS report) ! ELSE IF (qww .LT. (6. - EPS_DELTA)) THEN delh = 109.*(qww**.75)/utop + write(*,'(a,2(1x,e12.5))') 'voorlpl c',hbron,delh ELSE delh = 143.*(qww**.6)/utop + write(*,'(a,2(1x,e12.5))') 'voorlpl d',hbron,delh ENDIF ! ! Compute preliminary plume height @@ -875,6 +892,8 @@ END SUBROUTINE windsek !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE windcorr(itra, istab, radius, disx, isek, iwdd, is, astat, iss, ispecial, phi, s) +USE Binas, only: rad2deg + ! CONSTANTS CHARACTER*512 :: ROUTINENAAM ! PARAMETER (ROUTINENAAM = 'windcorr') @@ -922,7 +941,7 @@ SUBROUTINE windcorr(itra, istab, radius, disx, isek, iwdd, is, astat, iss, ispec ! disx < radius, then phi = 60 degrees ! IF (radius .LT. (disx - EPS_DELTA)) THEN - phi = (ASIN(radius/disx) + PI/NSEK)*CONV + phi = (ASIN(radius/disx) + PI/NSEK)*rad2deg ELSE phi = 60. ENDIF @@ -1147,9 +1166,9 @@ END SUBROUTINE interp_tra ! DESCRIPTION : In deze routine worden de meteostatistiek geinterpoleerd over de windsektoren. ! Note that interp_sek is calles with isek = isekt. !------------------------------------------------------------------------------------------------------------------------------- -SUBROUTINE interp_sek(istab, iss, itrx, is, s, isek, stt, astat, xl, vw10, rb, ra4, ra50, xvglbr, xvghbr, uster_metreg_rcp, & - & tem, ol_metreg_rcp, h0, xloc, xl100, sp, rad, rcso2, hum, pcoef, rcnh3, rcno2, rcaer, buil, rint, shear, & - & dscor, temp, regenk) +SUBROUTINE interp_sek(istab, iss, itrx, is, s, isek, stt, astat, xl, vw10, rb, ra4, ra50, xvglbr, xvghbr, uster_metreg_rcp, & + & temp_C, ol_metreg_rcp, h0, xloc, xl100, sp, rad, rcso2, hum, pcoef, rcnh3, rcno2, rcaer, buil, rint, shear, & + & dscor, coef_space_heating, regenk) ! CONSTANTS CHARACTER*512 :: ROUTINENAAM ! @@ -1176,9 +1195,9 @@ SUBROUTINE interp_sek(istab, iss, itrx, is, s, isek, stt, astat, xl, vw10, rb, r REAL*4, INTENT(OUT) :: ra50 ! REAL*4, INTENT(OUT) :: xvglbr ! REAL*4, INTENT(OUT) :: xvghbr ! -REAL*4, INTENT(OUT) :: uster_metreg_rcp ! -REAL*4, INTENT(OUT) :: tem ! -REAL*4, INTENT(OUT) :: ol_metreg_rcp ! +REAL*4, INTENT(OUT) :: uster_metreg_rcp ! +REAL*4, INTENT(OUT) :: temp_C ! temperature at height zmet_T [C] +REAL*4, INTENT(OUT) :: ol_metreg_rcp ! REAL*4, INTENT(OUT) :: h0 ! REAL*4, INTENT(OUT) :: xloc ! REAL*4, INTENT(OUT) :: xl100 ! @@ -1194,7 +1213,7 @@ SUBROUTINE interp_sek(istab, iss, itrx, is, s, isek, stt, astat, xl, vw10, rb, r REAL*4, INTENT(OUT) :: rint ! REAL*4, INTENT(OUT) :: shear ! REAL*4, INTENT(OUT) :: dscor(NTRAJ) ! -REAL*4, INTENT(OUT) :: temp ! +REAL*4, INTENT(OUT) :: coef_space_heating ! space heating coefficient (degree-day values in combination with a wind speed correction) [C m^1/2 / s^1/2] REAL*4, INTENT(OUT) :: regenk ! ! DATA @@ -1223,18 +1242,18 @@ SUBROUTINE interp_sek(istab, iss, itrx, is, s, isek, stt, astat, xl, vw10, rb, r ! 22. Monin-Obukhov length L [m] ! 23. sensible heat flux H0 [W/m2] ! -xl = stt(2) -vw10 = stt(3) -rb = stt(4) -ra4 = stt(5) - rb -ra50 = stt(6) - rb -xvglbr = stt(7) -xvghbr = stt(8) -uster_metreg_rcp = stt(19) -tem = stt(20) -shear = stt(21) -ol_metreg_rcp = stt(22) -h0 = stt(23) +xl = stt(2) +vw10 = stt(3) +rb = stt(4) +ra4 = stt(5) - rb +ra50 = stt(6) - rb +xvglbr = stt(7) +xvghbr = stt(8) +uster_metreg_rcp = stt(19) +temp_C = stt(20) +shear = stt(21) +ol_metreg_rcp = stt(22) +h0 = stt(23) ! ! Special cases for mixing height ! xl100: mixing height at 100 km @@ -1296,9 +1315,8 @@ SUBROUTINE interp_sek(istab, iss, itrx, is, s, isek, stt, astat, xl, vw10, rb, r ! Interpolate meteo parameters 10-11 for current stability class and distance class, ! between wind direction sectors isek and is ! -temp = (1. - sp)*astat(itrx, 10, istab, isek) + sp*astat(itrx, 10, istab, is) - -regenk = (1. - sp)*astat(itrx, 11, istab, isek) + sp*astat(itrx, 11, istab, is) +coef_space_heating = (1. - sp)*astat(itrx, 10, istab, isek) + sp*astat(itrx, 10, istab, is) +regenk = (1. - sp)*astat(itrx, 11, istab, isek) + sp*astat(itrx, 11, istab, is) ! ! No interpolation for buil (length of rainfall period) and rint (rain intensity); ! they are not interpolated, because there may be many zeros (-> does not occur) in one of the two interpolating sectors diff --git a/ops_surface.f90 b/ops_surface.f90 index 4d3495a..853fac1 100644 --- a/ops_surface.f90 +++ b/ops_surface.f90 @@ -144,12 +144,14 @@ SUBROUTINE ops_surface(z0, zi, ol, uster, h, x, uh, zu, szs) szs = SQRT(2.*kz*x/uh) ! Compute new values of zw and zu, depending on value of sigma_z - IF (last .NE. 1 .AND. iter .LE. 12 ) THEN + IF (last .NE. 1 .AND. iter .LE. 12 ) THEN + ! IF (iter .LE. 12 ) THEN last = 0 iter = iter + 1 ! s = effective plume width - s = szs*.69 ! OPS report s = 0.67*szs (see text below 3.18) + s = szs*.69 ! OPS report s = 0.67*szs (see text below 3.18) + ! s = szs*.69 + h/3 !-------------------------------------------------------------------------------------------------- ! 1. Plume well mixed (s > zi/2) @@ -165,6 +167,10 @@ SUBROUTINE ops_surface(z0, zi, ol, uster, h, x, uh, zu, szs) zw = zu ENDIF last = 1 + !write(*,'(3a,3(1x,i6),99(1x,e12.5))') trim(ROUTINENAAM),',A1,', & + ! ' ircp,istab,iter,zw,zu,uh,szs,s:', & + ! -999,-999,iter,zw,zu,uh,szs,s + GOTO 50 !-------------------------------------------------------------------------------------------------- @@ -173,17 +179,21 @@ SUBROUTINE ops_surface(z0, zi, ol, uster, h, x, uh, zu, szs) ELSE IF (h .GE. (s - EPS_DELTA)) THEN ! zw = h - sigma_z - zw = h - szs + zw = h - szs + ! zw = h - 0.1*s ! zw < h/2 -> zw = h/2, zu = stack_height; iteration finished - IF (zw .LT. (h/2. - EPS_DELTA)) THEN - zw = h/2. + IF (zw .LT. (h/2. - EPS_DELTA)) THEN + zw = h/2. + !IF (zw .LT. (h - EPS_DELTA)) THEN + ! zw = h zu = h last = 1 ! zw > h/2 AND relative difference between zw and zwold > 10% -> ! -> subtract 0.6*(difference between iterands) to get new zw value (0.6 is relaxation factor); set zu = stack_height - ELSE IF ((ABS((zw - zwold)/zw)) .GT. (0.1 + EPS_DELTA)) THEN + ELSE IF ((ABS((zw - zwold)/zw)) .GT. (0.1 + EPS_DELTA)) THEN + !ELSE IF ((ABS((zw - zwold)/zw)) .GT. (0.01 + EPS_DELTA)) THEN zw = zw - (zw - zwold)*0.6 ! 960202 zu = h zwold = zw @@ -199,6 +209,10 @@ SUBROUTINE ops_surface(z0, zi, ol, uster, h, x, uh, zu, szs) last = 1 zu = h ENDIF + !write(*,'(3a,3(1x,i6),99(1x,e12.5))') trim(ROUTINENAAM),',A2,', & + ! ' ircp,istab,iter,zw,zu,uh,szs,s:', & + ! -999,-999,iter,zw,zu,uh,szs,s + GOTO 50 !-------------------------------------------------------------------------------------------------- @@ -224,6 +238,9 @@ SUBROUTINE ops_surface(z0, zi, ol, uster, h, x, uh, zu, szs) ELSE zw = zu ENDIF + !write(*,'(3a,2(1x,i6),99(1x,e12.5))') trim(ROUTINENAAM),',A3,', & + ! ' ircp,istab,iter,zw,zu,uh,szs,s:', & + ! -999,-999,iter,zw,zu,uh,szs,s GOTO 50 ELSE ! relative difference between zu and s <= 10% -> finish iteration diff --git a/ops_tra_char.f90 b/ops_tra_char.f90 index bdd664b..ae02a1c 100644 --- a/ops_tra_char.f90 +++ b/ops_tra_char.f90 @@ -37,7 +37,7 @@ ! UPDATE HISTORY : !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE ops_tra_char (icm, f_z0user, z0_user, nrrcp, x_rcp, y_rcp, x_src, y_src, & - & lugrid, z0nlgrid, z0eurgrid, so2bggrid, no2bggrid, nh3bggrid, domlu, & + & lugrid, z0nlgrid, z0eurgrid, so2bggrid, no2bggrid, nh3bggrid, domlu, & & z0_tra, lu_tra_per, so2bgtra, no2bgtra, nh3bgtra, & & error) @@ -94,6 +94,9 @@ SUBROUTINE ops_tra_char (icm, f_z0user, z0_user, nrrcp, x_rcp, y_rcp, x_src, y_s CALL ops_getz0_tra(x_rcp, y_rcp, float(x_src), float(y_src), z0nlgrid, z0eurgrid, z0_tra) CALL ops_getlu_tra(x_rcp, y_rcp, float(x_src), float(y_src), lugrid, domlu, lu_tra_per) ENDIF +!write(*,'(a,a,1x,e12.5)') trim(ROUTINENAAM),' z0_tra:',z0_tra +!write(*,'(a,a,99(1x,e12.5))') trim(ROUTINENAAM),' lu_tra_per:',lu_tra_per + ! ! Calculate average (actual) concentration levels of SO2, NO2 and NH3 between source and receptor ! from background concentration maps which are scaled on the basis of measurements @@ -101,6 +104,8 @@ SUBROUTINE ops_tra_char (icm, f_z0user, z0_user, nrrcp, x_rcp, y_rcp, x_src, y_s IF (ANY(icm == (/1,3/))) CALL ops_bgcon_tra(x_rcp, y_rcp, float(x_src), float(y_src), so2bggrid, so2bgtra) IF (ANY(icm == (/2,3/))) CALL ops_bgcon_tra(x_rcp, y_rcp, float(x_src), float(y_src), no2bggrid, no2bgtra) IF (ANY(icm == (/1,2,3/))) CALL ops_bgcon_tra(x_rcp, y_rcp, float(x_src), float(y_src), nh3bggrid, nh3bgtra) +! write(*,'(a,a,3(1x,e12.5))') trim(ROUTINENAAM),' so2bgtra,no2bgtra,nh3bgtra:',so2bgtra,no2bgtra,nh3bgtra + RETURN 9999 CALL ErrorCall(ROUTINENAAM, error) diff --git a/ops_vertdisp.f90 b/ops_vertdisp.f90 index 76c53ac..1f14aa9 100644 --- a/ops_vertdisp.f90 +++ b/ops_vertdisp.f90 @@ -35,9 +35,10 @@ ! CALLED FUNCTIONS : ! UPDATE HISTORY : !------------------------------------------------------------------------------------------------------------------------------- -SUBROUTINE ops_vertdisp(z0, zi, ol, uster, hh, x, uh, zu, sz) +SUBROUTINE ops_vertdisp(z0, zi, ol, uster, hh, x, uh, zu, sz, error) USE m_commonconst ! EPS_DELTA only +USE m_error IMPLICIT NONE @@ -59,6 +60,9 @@ SUBROUTINE ops_vertdisp(z0, zi, ol, uster, hh, x, uh, zu, sz) ! at the top of the mixing layer and at the ground surface REAL*4, INTENT(OUT) :: sz ! vertical dispersion coefficient (m) +TYPE (TError), INTENT(INOUT) :: error ! error handling record + + ! LOCAL VARIABLES REAL*4 :: h ! bronhoogte (m) REAL*4 :: szc ! convexe dispersie (m) @@ -135,6 +139,9 @@ SUBROUTINE ops_vertdisp(z0, zi, ol, uster, hh, x, uh, zu, sz) CALL ops_surface(z0,zi,ol,uster,h,x, uh, zu, szs) sz = szs ENDIF +if (error%debug) write(*,'(3a,2(1x,i6),99(1x,e12.5))') trim(ROUTINENAAM),',A,', & + ' ircp,istab,h,zi,ol,h/zi/0.1,zi/ol,fm,fs,szs,szc,szn:', & + -999,-999,h,zi,ol,h/zi/0.1,zi/ol,fm,fs,szs,szc,szn RETURN END SUBROUTINE ops_vertdisp diff --git a/ops_wv_powerlaw.f90 b/ops_wv_powerlaw.f90 new file mode 100644 index 0000000..f43e9b3 --- /dev/null +++ b/ops_wv_powerlaw.f90 @@ -0,0 +1,65 @@ +!------------------------------------------------------------------------------------------------------------------------------- +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . +! +! Copyright (C) 2002 by +! National Institute of Public Health and Environment +! Laboratory for Air Research (RIVM/LLO) +! The Netherlands +!------------------------------------------------------------------------------------------------------------------------------- +subroutine ops_wv_powerlaw(istab,isek,astat,z,uz,vw10,pcoef) + +! Compute wind profile based on power law. Note that below the reference height of 10 m, +! the wind profile is assumed to be constant: uz(z < 10) = uz(z = 10). + +USE m_commonconst + +implicit none + +! Input: +integer, intent(in) :: istab ! index of stability class +integer, intent(in) :: isek ! index of wind sector +real , intent(in) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) ! statistical meteo parameters +real , intent(in) :: z ! heigth where to compute wind velocity [m] + +! Output: +real , intent(out) :: uz ! wind velocity at height z [m/s] +real , intent(out) :: vw10 ! wind velocity at 10 m heigth [m/s] +real , intent(out) :: pcoef ! coefficient in wind speed power law + +! Local: +real, parameter :: zref = 10.0 ! reference height for wind speed [m] +real :: VWREP(NSTAB) ! representative (long term average) wind speed per stability class +DATA VWREP /2.6, 3.8, 4.0, 6.9, 1.4, 2.5/ + +!------------------------------------------------------------------------------------------------------------------------------- +! Get wind speed [m/s] at 10 m height from meteo statistics. +! Use VWREP if we have a zero wind speed from meteo statistics. +! +IF (ABS(astat(1, 3, istab, isek)) .LE. EPS_DELTA) THEN + vw10 = VWREP(istab) +ELSE + vw10 = astat(1, 3, istab, isek) +ENDIF + +! Get coefficient in wind speed power law +pcoef = astat(1, 15, istab, isek) + +! use power law to determine wind velocity: +IF (z .GT. zref) THEN + uz = vw10*(z/zref)**pcoef +ELSE + uz = vw10 +ENDIF + +end subroutine ops_wv_powerlaw diff --git a/ops_z0corr.f90 b/ops_z0corr.f90 index f547f1f..5363a1d 100644 --- a/ops_z0corr.f90 +++ b/ops_z0corr.f90 @@ -27,7 +27,7 @@ ! AUTHOR : HvJ/Franka Loeve (Cap Volmac) ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 -! DESCRIPTION : Correct friction velocity (uster) and Monin-Obukhov length (ol) at a standard roughness length for a +! DESCRIPTION : Correct friction velocity (uster) and Monin-Obukhov length (ol) at a standard roughness length for a ! situation with another roughness length. The main assumption here is that the wind speed at 50 m height ! is not influenced by the roughness of the surface. Temperature effects are not taken into account. ! An iterative procedure is used: starting with uster1 compute a new uster2 and ol2 and continue the iteration, @@ -46,40 +46,40 @@ SUBROUTINE ops_z0corr(z01, uster1, ol1, z02, uster2, ol2) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM ! PARAMETER (ROUTINENAAM = 'ops_z0corr') ! CONSTANTS -REAL*4 :: C1 ! -REAL*4 :: Z ! -PARAMETER (C1 = 93500.) +REAL*4 :: C1 ! +REAL*4 :: Z ! +PARAMETER (C1 = 93500.) PARAMETER (Z = 50.) ! SUBROUTINE ARGUMENTS - INPUT REAL*4, INTENT(IN) :: z01 ! standard roughness length [m] -REAL*4, INTENT(IN) :: uster1 ! friction velocity at standard roughness length +REAL*4, INTENT(IN) :: uster1 ! friction velocity at standard roughness length REAL*4, INTENT(IN) :: ol1 ! Monin-Obukhov length at standard roughness length [m] REAL*4, INTENT(IN) :: z02 ! new roughness length [m] ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: uster2 ! friction velocity at new roughness length +REAL*4, INTENT(OUT) :: uster2 ! friction velocity at new roughness length REAL*4, INTENT(OUT) :: ol2 ! Monin-Obukhov length at standard roughness length [m] ! LOCAL VARIABLES INTEGER*4 :: n ! iteration index -REAL*4 :: h0 ! +REAL*4 :: h0 ! REAL*4 :: delta ! difference between old and new iterand for uster2 -REAL*4 :: phim ! +REAL*4 :: phim ! REAL*4 :: u50 ! wind speed at 50 m height REAL*4 :: uold ! uster at previous iteration REAL*4 :: delta_old ! old difference between old and new iterand for uster2 REAL*4 :: ur ! ratio uster/uold ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida ! sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- -! +! ! T rho_a cp (u*)^3 ! (2.1) OPS report: L = ------------------- ! g H0 kappa @@ -87,16 +87,16 @@ SUBROUTINE ops_z0corr(z01, uster1, ol1, z02, uster2, ol2) ! rho_a : air density = 1.292 kg/m3 (0 C), 1.247 kg/m3 (20 C), 1.204 kg/m3 (20 C), pressure = 1 atm ! cp : specific heat capacity = 1003.5 J/(kg K), sea level, dry, T=0 C; 1012 J/(kg/K), typical room conditions (T = 23 C) ! kappa : von Karman constant = 0.4 [-] -! g : accelaration of gravity = 9.81 m/s2 -! T : absolute temperature = 273 + tem K +! g : accelaration of gravity = 9.81 m/s2 +! T : absolute temperature [K] ! H0 : surface heat flux [W/m2] ! -! T rho_a cp (u*)^3 T rho_a cp (u*)^3 (u*)^3 +! T rho_a cp (u*)^3 T rho_a cp (u*)^3 (u*)^3 ! From this follows: H0 = ----------------- = ------------ ------ = C1 ------ -! g L kappa g kappa L L +! g L kappa g kappa L L ! ! T rho_a cp K kg J s2 kg m2 s2 kg -! [C1] = [ ------------ ] = ------------- = --------- = ------ (J = kg m2/s2) +! [C1] = [ ------------ ] = ------------- = --------- = ------ (J = kg m2/s2) ! g kappa m3 kg K m s2 m4 m2 ! ! actual values in code: rho = 1.29 kg/m3, cp = 1005 J/(kg K), kappa=0.4, g=9.81 m/s2, T=283 K; c1=rho*cp*T/(kappa*g) = 93467 kg/m2. @@ -143,13 +143,13 @@ SUBROUTINE ops_z0corr(z01, uster1, ol1, z02, uster2, ol2) h0 = h0*ur**0.1 ENDIF - ! If percentual difference of iterands > 1.5% AND number of iterations < 40 -> continue iteration + ! If percentual difference of iterands > 1.5% AND number of iterations < 40 -> continue iteration IF ((delta .GT. (0.015*uster2 + EPS_DELTA)) .AND. (n .LT. 40)) THEN GOTO 50 ENDIF ! Converged OR number of iterations >= 40; -! limit L, u* such that +! limit L, u* such that ! -5 < L < 0 -> L = -5 ! 0 < L < 5 -> L = 5 ! u* >= 0.06 m/s @@ -178,7 +178,7 @@ SUBROUTINE ops_z0corr(z01, uster1, ol1, z02, uster2, ol2) SUBROUTINE stabcm(h, ol, phim) ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM ! PARAMETER (ROUTINENAAM = 'stabcm') ! SUBROUTINE ARGUMENTS - INPUT @@ -192,7 +192,7 @@ SUBROUTINE stabcm(h, ol, phim) REAL*4 :: y ! hulpvariabele voor berekening ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida ! sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- IF (ol .GT. (0. + EPS_DELTA)) THEN