diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..83fe632 --- /dev/null +++ b/.gitignore @@ -0,0 +1,9 @@ +/*.mod +/*.o +/dependencies +/*.exe +/mess.f +/optchk.f +/silup.f +/silupm.f +/smess.f diff --git a/README.MD b/README.MD index 767fd2b..972a361 100644 --- a/README.MD +++ b/README.MD @@ -2,7 +2,7 @@ OPS (Operationele Prioritaire Stoffen) is een rekenprogramma om de verspreiding Daarnaast berekent het model hoeveel van die stoffen per hectare op bodem of gewas terechtkomt (depositie). Het model wordt sinds 1989 gebruikt om de relatie tussen de uitstoot van stoffen in Europa enerzijds en de concentratie of depositie van die stoffen anderzijds op de schaal van Nederland te bepalen. -Meer informatie en een uitgebreide documentatie van de werking van het model vindt u op www.rivm.nl/ops. +Meer informatie en een uitgebreide documentatie van de werking van het model vindt u op https://www.rivm.nl/operationele-prioritaire-stoffen-model Een Windows-executable van OPS + Grafische User Interface om invoerbestanden voor OPS te genereren is te downloaden via dezelfde website. diff --git a/binas.f90 b/binas.f90 index bc866fd..016abbc 100644 --- a/binas.f90 +++ b/binas.f90 @@ -1,31 +1,31 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 . +! module Binas implicit none - + public - - ! + + !ProTeX: 1.14-AJS - ! + !BOI - ! + ! !TITLE: Binas - geometrical and physical constants - ! !AUTHORS: + ! !AUTHORS: ! !AFFILIATION: KNMI ! !DATE: \today ! @@ -33,25 +33,25 @@ module Binas ! ! '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 : + ! 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 @@ -62,42 +62,42 @@ module Binas ! --------------------------------------------------------------- ! 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 ! + ! 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: + + ! 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 @@ -117,57 +117,57 @@ module Binas 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 + + ! 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 @@ -185,7 +185,7 @@ module Binas ! 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' .... @@ -203,15 +203,15 @@ module Binas 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 @@ -223,18 +223,18 @@ module Binas ! 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/inum.f90 b/inum.f90 new file mode 100644 index 0000000..21bf245 --- /dev/null +++ b/inum.f90 @@ -0,0 +1,9 @@ +FUNCTION INUM(s) + +IMPLICIT NONE +INTEGER :: INUM +character*(*) :: s +integer i +read(s,*) i +inum = i +END FUNCTION INUM diff --git a/m_aps.f90 b/m_aps.f90 index 83ef28a..fe319f5 100644 --- a/m_aps.f90 +++ b/m_aps.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -32,7 +32,7 @@ ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO/IS ! LANGUAGE : FORTRAN(HP-F90) ! DESCRIPTION : Handling of aps grid data. @@ -88,7 +88,7 @@ MODULE m_aps !------------------------------------------------------------------------------------------------------------------------------- ! SUBROUTINE : ReadAps ! DESCRIPTION : Reading of aps file with grid data. -! INPUTS : filename (character*(*)). Name of the aps file +! INPUTS : filename (character*(*)). Name of the aps file ! gridtitle (character*(*)). Description of grid shown in error messages. ! OUTPUTS : gridvalues (type). Grid values read from grid file. Generic for different types of grid (float, integer). ! error (TError object). Assigned when an error occurred. @@ -127,7 +127,7 @@ MODULE m_aps !------------------------------------------------------------------------------------------------------------------------------- ! SUBROUTINE : SetAverage -! DESCRIPTION : Sets average field in aps grid structure. Average is calculated over all cells with value > 0. It is possible +! DESCRIPTION : Sets average field in aps grid structure. Average is calculated over all cells with value > 0. It is possible ! to multiply all values by a certain factor first. ! INPUTS : factor (real*4, optional). Multiplication factor. ! INPUT/OUTPUTS: grid (TApsGridReal). The field grid.average is adjusted. @@ -156,11 +156,11 @@ SUBROUTINE read_aps_real(filename, gridtitle, floatgrid, error) !DEC$ ATTRIBUTES DLLEXPORT:: read_aps_real ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: filename ! name of the aps file +CHARACTER*(*), INTENT(IN) :: filename ! name of the aps file CHARACTER*(*), INTENT(IN) :: gridtitle ! description of grid shown in error messages -! INPUTS : filename (character*(*)). -! gridtitle (character*(*)). -! OUTPUTS : gridvalues (type). +! INPUTS : filename (character*(*)). +! gridtitle (character*(*)). +! OUTPUTS : gridvalues (type). ! error (TError object). . ! SUBROUTINE ARGUMENTS - OUTPUT @@ -184,14 +184,14 @@ SUBROUTINE read_aps_real(filename, gridtitle, floatgrid, error) PARAMETER (ROUTINENAAM = 'read_aps_real') ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! ! Open aps file and read header. ! nfield = 1 -CALL read_aps_header(88, filename, gridtitle, floatgrid%gridheader, error) +CALL read_aps_header(88, filename, gridtitle, floatgrid%gridheader, error) IF (error%haserror) GOTO 3000 ! Allocate help grid: @@ -243,7 +243,7 @@ SUBROUTINE read_aps_real(filename, gridtitle, floatgrid, error) DO n = 1,nfield READ (88, IOSTAT=ierr) teststring -! CALL read_aps_header(88, filename, gridtitle, floatgrid%gridheader, error) +! CALL read_aps_header(88, filename, gridtitle, floatgrid%gridheader, error) ! ! Read float grid values. ! @@ -288,11 +288,11 @@ SUBROUTINE read_aps_integer(filename, gridtitle, intgrid, error) !DEC$ ATTRIBUTES DLLEXPORT:: read_aps_integer ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: filename ! name of the aps file +CHARACTER*(*), INTENT(IN) :: filename ! name of the aps file CHARACTER*(*), INTENT(IN) :: gridtitle ! description of grid shown in error messages -! INPUTS : filename (character*(*)). -! gridtitle (character*(*)). -! OUTPUTS : gridvalues (type). +! INPUTS : filename (character*(*)). +! gridtitle (character*(*)). +! OUTPUTS : gridvalues (type). ! error (TError object). . ! SUBROUTINE ARGUMENTS - OUTPUT @@ -313,12 +313,12 @@ SUBROUTINE read_aps_integer(filename, gridtitle, intgrid, error) ! CONSTANTS CHARACTER*512 :: ROUTINENAAM ! name of subroutine PARAMETER (ROUTINENAAM = 'read_aps_integer') -! +! !------------------------------------------------------------------------------------------------------------------------------- ! ! Open aps file and read header. ! -CALL read_aps_header(88, filename, gridtitle, intgrid%gridheader, error) +CALL read_aps_header(88, filename, gridtitle, intgrid%gridheader, error) nrcol = intgrid%gridheader%nrcol nrrow = intgrid%gridheader%nrrow ALLOCATE(helpgrid(nrcol,nrrow)) @@ -353,7 +353,7 @@ SUBROUTINE read_aps_integer(filename, gridtitle, intgrid, error) DO n = 1,nfield READ (88, IOSTAT=ierr) j -! CALL read_aps_header(88, filename, gridtitle, intgrid%gridheader, error) +! CALL read_aps_header(88, filename, gridtitle, intgrid%gridheader, error) ! ! Read integer grid values. ! @@ -453,16 +453,16 @@ SUBROUTINE read_aps_header(fileunit, filename, gridtitle, gridheader, error) ! LOCAL VARIABLES CHARACTER*22 :: comment ! comment in grid header -CHARACTER*10 :: kmpnm ! component name (parameter name of grid values) +CHARACTER*10 :: kmpnm ! component name (parameter name of grid values) CHARACTER*10 :: eenheid ! unit of parameter CHARACTER*10 :: oors ! origin of grid values CHARACTER*6 :: form ! format which is used to read grid values (?? is this used?) -INTEGER*4 :: ij ! -INTEGER*4 :: inu1 ! -INTEGER*4 :: inu2 ! -INTEGER*4 :: inu3 ! -INTEGER*4 :: kode ! -INTEGER*4 :: ierr ! +INTEGER*4 :: ij +INTEGER*4 :: inu1 +INTEGER*4 :: inu2 +INTEGER*4 :: inu3 +INTEGER*4 :: kode +INTEGER*4 :: ierr ! CONSTANTS CHARACTER*512 :: ROUTINENAAM ! name of subroutine @@ -554,7 +554,7 @@ SUBROUTINE grid_value_integer(x, y, grid, gridvalue, iscell, fieldnumber) TYPE (TAPSGridInt), INTENT(IN) :: grid ! integer APS grid ! SUBROUTINE ARGUMENTS - OUTPUT -INTEGER*4, INTENT(OUT) :: gridvalue ! the value in the grid cell or the default value +INTEGER*4, INTENT(OUT) :: gridvalue ! the value in the grid cell or the default value ! (in case of location outside grid) LOGICAL, INTENT(OUT) :: iscell ! whether value comes from a grid cell INTEGER, OPTIONAL, INTENT(IN) :: fieldnumber ! fieldnumber to retreive data from @@ -598,7 +598,7 @@ SUBROUTINE grid_value_real(x, y, grid, gridvalue, iscell, fieldnumber) TYPE (TAPSGridReal), INTENT(IN) :: grid ! real APS grid ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: gridvalue ! the value in the grid cell or the default value +REAL*4, INTENT(OUT) :: gridvalue ! the value in the grid cell or the default value ! (in case of location outside grid) LOGICAL, INTENT(OUT) :: iscell ! whether value comes from a grid cell INTEGER, OPTIONAL, INTENT(IN) :: fieldnumber ! fieldnumber to retreive data from @@ -643,7 +643,7 @@ SUBROUTINE grid_cell_index(x, y, gridheader, m, n, iscell) ! SUBROUTINE ARGUMENTS - OUTPUT INTEGER*4, INTENT(OUT) :: m ! x-index of cell INTEGER*4, INTENT(OUT) :: n ! y-index of cell -LOGICAL, INTENT(OUT) :: iscell ! whether (x,y) is inside grid +LOGICAL, INTENT(OUT) :: iscell ! whether (x,y) is inside grid ! CONSTANTS CHARACTER*512 :: ROUTINENAAM ! name of subroutine diff --git a/m_commonconst.f90 b/m_commonconst.f90 index bfcb97f..bc7bb4c 100644 --- a/m_commonconst.f90 +++ b/m_commonconst.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-F90 ! DESCRIPTION : Defines common parameters, values, etc. @@ -40,12 +40,12 @@ !------------------------------------------------------------------------------------------------------------------------------- MODULE m_commonconst -USE Binas, only: pi - +USE Binas, only: pi + 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 :: 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 @@ -58,7 +58,7 @@ MODULE m_commonconst 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 = 42 ! 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 :: 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 @@ -67,10 +67,10 @@ MODULE m_commonconst ! 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, PARAMETER :: zmet_T = 1.5 ! reference height for temperature measurements [m] -INTEGER*4, PARAMETER :: IGEO = 0 ! 1 -> Geographical coordinates lon-lat [degrees]; 0 -> RDM coordinates [m] +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 @@ -78,7 +78,7 @@ MODULE m_commonconst 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 :: HUMAX = 500. ! maximal plume height [m] +REAL*4, PARAMETER :: HUMAX = 500. ! maximal plume height [m] CHARACTER*8, PARAMETER :: MODVERSIE = '5.0.0.0' ! model version OPS-LT CHARACTER*20, PARAMETER :: RELEASEDATE = '26 dec 2019' ! release date @@ -87,7 +87,7 @@ MODULE m_commonconst ! 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 :: 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 @@ -105,7 +105,7 @@ MODULE m_commonconst ! ! Set coefficients in conversion function NO2 = beta1*log(NOx) + beta2; -! based on LML-measurements in 1993 +! based on LML-measurements in 1993 ! DATA nox_no2_beta /8.6, -12.4/ @@ -116,13 +116,13 @@ MODULE m_commonconst DATA NACHTZOMER /0, 0, 61, 61, 100, 98, 17, 17, 68, 68, 63, 83, 43, 43, 44, 44, 42, 44, 43, 43, 44, 44, 42, 44/ 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 +! 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/ +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. +! Sedimentation velocity (m/s) needed for plume descent in case of heavy particles, for each particle class. ! Sedimentation velocity depends on particle size according to Stokes law; see ops_conc_ini -DATA STOKES /0., 0., 0.0003, 0.0012, 0.0055, 0.047/ +DATA STOKES /0., 0., 0.0003, 0.0012, 0.0055, 0.047/ ! ! Set SCWINTER (variation in NO2/NOx ratio (relative to stability class S2) for each stability class (only in winter)) ! see OPS-doc/chem, bookmark table_no2_nox. [0.47 0.47 0.62 0.69 0.39 0.58] /0.58 = [0.81 0.81 1.19 1.03 0.67 1.00] @@ -132,7 +132,7 @@ MODULE m_commonconst ! Correction factors for the difference between model output and measurements ! These correction factors are given for 4 historical years and one year in ! the future. The correction factor for the future year is by definition equal -! to the correction factor for the last historical year. +! to the correction factor for the last historical year. ! DATA cf_so2 / 1.04, 0.96, 0.69, 0.72, 0.72 / DATA cf_nox / 0.93, 0.94, 0.77, 0.94, 0.94 / @@ -172,9 +172,9 @@ MODULE m_commonconst & ' ', 'NO3' , ' ', & & 'SOx', 'NOy' , 'NHx', & & 'SO2', 'NO2' , 'NH3' / - -! CNAME_SEC is defined in ops_read_ctr -! DATA CNAME_SUBSEC /'HNO3', 'NO3_C', 'NO3_F' / ! HNO3, NO3_coarse (in PM10-PM2.5), NO3_fine (in PM2.5) + +! CNAME_SEC is defined in ops_read_ctr +! DATA CNAME_SUBSEC /'HNO3', 'NO3_C', 'NO3_F' / ! HNO3, NO3_coarse (in PM10-PM2.5), NO3_fine (in PM2.5) ! DATA CNAME_SUBSEC /'HNO3', 'NO3_AER' / ! HNO3, NO3_aerosol (in PM10) ! ! Units for concentration and deposition @@ -186,7 +186,7 @@ MODULE m_commonconst ! meteo regions (KLIGEB << klimaatgebieden = climate regions) ! DATA KLIGEB /'The_Netherlands ', & - & 'N-Holland, N-Friesland, N-Groningen', & + & 'N-Holland, N-Friesland, N-Groningen', & & 'Randstad, W-Brabant, E-Zeeland ', & & 'Drente, S-Friesland, S-Groningen ', & & 'W-Zeeland, ZH-Islands ', & diff --git a/m_commonfile.f90 b/m_commonfile.f90 index ba83dd4..c8d2048 100644 --- a/m_commonfile.f90 +++ b/m_commonfile.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-F90 ! DESCRIPTION : Define file unit numbers and file names. Subroutine to make full file name. @@ -46,7 +46,7 @@ MODULE m_commonfile ! CHARACTER*12, PARAMETER :: BASEMASK = 'basemask.ops' ! base mask for The Netherlands (500mx500m) 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 :: 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 @@ -56,9 +56,9 @@ MODULE m_commonfile ! INTEGER*4, PARAMETER :: IOB_IU = 1 ! currently not used INTEGER*4, PARAMETER :: IOB_SETUP = 2 ! currently not used -INTEGER*4, PARAMETER :: IOB_STDIN = 5 ! currently not used -INTEGER*4, PARAMETER :: IOB_STDOUT = 6 ! standard output -INTEGER*4, PARAMETER :: IOB_STDERR = 7 ! currently not used +INTEGER*4, PARAMETER :: IOB_STDIN = 5 ! currently not used +INTEGER*4, PARAMETER :: IOB_STDOUT = 6 ! standard output +INTEGER*4, PARAMETER :: IOB_STDERR = 7 ! currently not used ! ! CONSTANTS - Other fileunits ! @@ -146,15 +146,15 @@ MODULE m_commonfile SUBROUTINE get_version_core(dll_version, dll_date) ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'get_version_core') ! SUBROUTINE ARGUMENTS - OUTPUT -CHARACTER*(*), INTENT(OUT) :: dll_version ! -CHARACTER*(*), INTENT(OUT) :: dll_date ! +CHARACTER*(*), INTENT(OUT) :: dll_version +CHARACTER*(*), INTENT(OUT) :: dll_date ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'// char (0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -184,7 +184,7 @@ SUBROUTINE MakeCommonPath(fileentry, filepath, error) CHARACTER*(*), INTENT(OUT) :: filepath ! File name including path ! ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'MakeCommonPath') IF (.NOT. error%haserror) THEN @@ -227,7 +227,7 @@ SUBROUTINE MakeMonitorNames(error) CHARACTER*512 :: base ! base name of monitor files (i.e. control file name without extension) ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'MakeMonitorNames') !------------------------------------------------------------------------------------------------------------------------------- diff --git a/m_depac.f90 b/m_depac.f90 index 9d85ce6..a3a8bab 100644 --- a/m_depac.f90 +++ b/m_depac.f90 @@ -1,23 +1,23 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 . +! !************************************************************************ -! 2013-09-17: this version has been derived from the 'hybrid' version -! depac_GCN2010, which consisted of a shell around version +! 2013-09-17: this version has been derived from the 'hybrid' version +! depac_GCN2010, which consisted of a shell around version ! depac311 (for NH3) and depac33 (for other species). -! In this version, only depac311 has been retained, with some +! In this version, only depac311 has been retained, with some ! bug fixes, !************************************************************************ @@ -25,12 +25,12 @@ ! Copyright by ! National Institute of Public Health and Environment ! The Netherlands -! No part of this software may be used, copied or distributed +! No part of this software may be used, copied or distributed ! without permission of RIVM (2010) ! ! MODULE : m_depac ! INTERFACE : depac -! AUTHOR : +! AUTHOR : ! FIRM/INSTITUTE : RIVM ! LANGUAGE : FORTRAN-90 ! DESCRIPTION : In this subroutine the canopy or surface resistance Rc @@ -40,25 +40,25 @@ ! Deposition fluxes are computed using one of the following resistance approaches; ! Note that, with the appopriate definitions (see below), B and C are totally equivalent. ! -! A: classical approach ! B: with compensation points ! C: with total -! ! ! compensation point -! zr ---------------------------- Catm ! zr ---------------------------- Catm ! zr --------- Catm -! | | ! | ! | -! Ra | ! Ra ! Ra -! | | F ! | ! | -! Rb | ! Rb ! Rb -! | V ! | ! | -! z0 ---------------------------- Cc ! z0 ---------------------------- Cc ! z0 --------- Cc -! | | | | ! | | | ! | -! | Rinc | | ! | Rinc | ! Rc -! | | | | F ! | | | ! | -! Rw Rsoil Rstom | ! Rw Rsoil Rstom ! --------- Ccomp_tot -! | | | | ! | | | ! -! | | | V !--- Cw ---- Csoil ---- Cstom ! -! zs ---------------------------- C=0 ! -! -! zr : reference height (m) -! z0 : roughness length (m) +! A: classical approach ! B: with compensation points ! C: with total +! ! ! compensation point +! zr ---------------------------- Catm ! zr ---------------------------- Catm ! zr --------- Catm +! | | ! | ! | +! Ra | ! Ra ! Ra +! | | F ! | ! | +! Rb | ! Rb ! Rb +! | V ! | ! | +! z0 ---------------------------- Cc ! z0 ---------------------------- Cc ! z0 --------- Cc +! | | | | ! | | | ! | +! | Rinc | | ! | Rinc | ! Rc +! | | | | F ! | | | ! | +! Rw Rsoil Rstom | ! Rw Rsoil Rstom ! --------- Ccomp_tot +! | | | | ! | | | ! +! | | | V !--- Cw ---- Csoil ---- Cstom ! +! zs ---------------------------- C=0 ! +! +! zr : reference height (m) +! z0 : roughness length (m) ! zs : surface height (m) ! Catm : atmospheric concentration (ug/m3) ! Cc : concentration at canopy top (ug/m3) @@ -80,41 +80,41 @@ ! H : layer height of numerical model ! ! A. classical approach ! B and C. compensation points -! ! -! 1 1 1 1 ! 1 1 1 1 -! -- = ---- + ----------- + ----- ! -- = ---- + ----------- + ----- -! Rc Rw Rsoil_eff Rstom ! Rc Rw Rsoil_eff Rstom ! ! -! deposition velocity: ! exchange velocity (deposition or emission): -! vd = 1/(Ra + Rb + Rc) ! ve = 1/(Ra + Rb + Rc) +! 1 1 1 1 ! 1 1 1 1 +! -- = ---- + ----------- + ----- ! -- = ---- + ----------- + ----- +! Rc Rw Rsoil_eff Rstom ! Rc Rw Rsoil_eff Rstom +! +! deposition velocity: ! exchange velocity (deposition or emission): +! vd = 1/(Ra + Rb + Rc) ! ve = 1/(Ra + Rb + Rc) +! +! ! Separate fluxes over external leaf, soil and stomata (B) equal total flux +! ! between Cc and Ccomp_tot (C): ! ! -! ! Separate fluxes over external leaf, soil and stomata (B) equal total flux -! ! between Cc and Ccomp_tot (C): -! ! -! ! (Cc - Cw ) (Cc - Csoil) (Cc - Cstom) (Cc - Ccomp_tot) +! ! (Cc - Cw ) (Cc - Csoil) (Cc - Cstom) (Cc - Ccomp_tot) ! ! ------------ + ------------ + ------------ = ---------------- <=> (Cc-terms cancel) -! ! Rw Rsoil_eff Rstom Rc -! ! +! ! Rw Rsoil_eff Rstom Rc +! ! ! ! 1 1 1 1 ! ! --- Ccomp_tot = ---- Cw + --------- Csoil + ----- Cstom. -! ! Rc Rw Rsoil_eff Rstom -! ! -! F = -vd*Catm ! F = -ve*[Catm - Ccomp_tot] -! ! -! Mass balance: ! Mass balance: -! ! -! dCatm ! dCatm -! H ----- = F = -vd*Catm, ! H ----- = F = -ve*[Catm - Ccomp_tot], -! dt ! dt -! ! -! with solution: ! with solution (assuming Ccomp_tot constant): +! ! Rc Rw Rsoil_eff Rstom +! ! +! F = -vd*Catm ! F = -ve*[Catm - Ccomp_tot] ! ! -! Catm(t+dt) = Catm(t)*exp(-(vd/H)*dt) ! Catm(t+dt) = Ccomp_tot + [Catm(t) - Ccomp_tot]*exp(-(ve/H)*dt) -! +! Mass balance: ! Mass balance: +! ! +! dCatm ! dCatm +! H ----- = F = -vd*Catm, ! H ----- = F = -ve*[Catm - Ccomp_tot], +! dt ! dt +! ! +! with solution: ! with solution (assuming Ccomp_tot constant): +! +! Catm(t+dt) = Catm(t)*exp(-(vd/H)*dt) ! Catm(t+dt) = Ccomp_tot + [Catm(t) - Ccomp_tot]*exp(-(ve/H)*dt) +! ! Approach C' uses the same scheme as C (compensation point), but computes a ! effective total resistance Rc', such that the differential equation of approach A can be used ! (see rc_comp_point_rc_eff). -! +! ! Note that DEPAC is restricted to the computation of the canopy or surface resistance Rc (A) ! and (optionally) a total compensation point (B/C) and/or an effective Rc (C'). ! Ra, Rb, deposition fluxes and new concentrations are computed outside DEPAC. @@ -134,23 +134,23 @@ ! ratns=1 low ratio NH3/SO2 ! ratns=2 high ratio NH3/SO2 ! ratns=3 very low ratio NH3/SO2 -! see calling routine: +! see calling routine: ! [SO2] < 0.5 then ! iratns = 1 ! low -! else +! else ! [NH3]/[SO2] < 0.02 -> iratns = 3 ! very low ! [NH3]/[SO2] > 2 -> iratns = 2 ! high ! 0.02 <= [NH3]/[SO2] <= 2 -> iratns = 1 ! low ! endif ! -! - DEPAC is used for the following gaseous components: +! - DEPAC is used for the following gaseous components: ! HNO3, NO, NO2, O3, SO2, NH3. ! In this version of DEPAC, component numbers are not used anymore, only names ! (only upper case!). ! ! In order to prevent problems with typing errors in the call to DEPAC or -! when new species are introduced into DEPAC, -! the following CASE construct is used throughout this module; this means that +! when new species are introduced into DEPAC, +! the following CASE construct is used throughout this module; this means that ! if a new species is introduced, all these CASE constructs have to be wended. ! select case(trim(compnam)) ! case('HNO3') @@ -172,26 +172,26 @@ ! missing deposition path !**************************************************************************************** ! A missing deposition path (e.g. deposition via stomata for land use "water") is -! represented by parameter values of -999; -! a logical function "missing" is available to check whether a parameter value +! represented by parameter values of -999; +! a logical function "missing" is available to check whether a parameter value ! corresponds to a missing deposition path or not. ! The effect of a missing deposition path is that the corresponding conductance is set to 0. ! -! Note that in previous versions of DEPAC, the value -1000 was also (mis)used to +! Note that in previous versions of DEPAC, the value -1000 was also (mis)used to ! represent a missing deposition path (probably to avoid rounding error problems ! when checking parameter_value < -999). This use of -1000 has been banned; instead ! the logical function "missing" uses an EPS (i.e. small value) band to avoid these ! problems with rounding errors. ! ! Missing output data for rc_tot is given a value of -9999; this means that DEPAC was not -! able to calculate a value for the total canopy resistance and that there is no deposition; +! able to calculate a value for the total canopy resistance and that there is no deposition; ! the calling routine should check for this output value of -9999! -! +! !**************************************************************************************** ! Land use types !**************************************************************************************** ! DEPAC is based on RIVM/LBG land use data, 8 classes, plus 1 extra class -! for special use: +! for special use: ! 1 = grass ! 2 = arable land ! 3 = permanent crops @@ -207,7 +207,7 @@ ! temp_conif, temp_decid, med_needle, med_broadleaf, temp_crop, med_crop, root_crop, moorland, grass, ! medscrub, wetlands, tundra, desert, water, ice, urban. ! -! Translation tables for leaf area index and for stomatal resistance (Rs) parameters are somewhat different, +! Translation tables for leaf area index and for stomatal resistance (Rs) parameters are somewhat different, ! since the Emberson parameterisation of the growing season (needed for the LAI) for temperate crop ! was considered to be too short. ! @@ -225,16 +225,16 @@ ! Note that in this version of DEPAC all translations have been done already ! and are directly seen in the appropriate values of the parameters used. ! -! UPDATE HISTORY : +! UPDATE HISTORY : ! 1994 , article Erisman & van Pul, Atm. Env. -! ? , Franka Loeve (Cap Volmac) +! ? , OPS-Support ! Jan 2003, : made single depac module. ! ? , ? (TNO) : added rc for O3 ! ? , ? (TNO) : separate routines for each species. ! Nov 2008, (RIVM): v3.0 synthesis of OPS and LOTOS-EUROS versions of DEPAC ! v3.0 model structure improved; common tasks in separate routines; documentation added ! names have been changed for readability: -! +! ! old name -> new name : explanation ! ---------------------------------------- ! rinc -> rinc : in canopy resistance (s/m) @@ -250,7 +250,7 @@ ! gsoeff -> gsoil_eff : effective soil conductance (m/s) ! gs -> gstom : stomatal conductance (m/s) ! gstot -> gc_tot : total canopy conductance (m/s) -! +! ! 10 Dec 2008, (RIVM): v3.1 try-out version with new model structure; ! v3.1 no calls to separate routines in subroutine depac, but all components ! are dealt with in subroutine depac. @@ -258,21 +258,21 @@ ! ! 11 Dec 2008, (RIVM): v3.2 new model structure; ! v3.2 in subroutine depac, calls are made to routines for separate conductances, e.g. -! for external, stomatal, soil conductance; the dependence on the components is +! for external, stomatal, soil conductance; the dependence on the components is ! placed inside these conductance-routines. ! ! 22 Jan 2009, (RIVM): v3.3 bug fix in season dependency leaf area index; ! v3.3 see function rc_lai. Older versions of this routine use a wrong numbering of -! land use types (no conversion to Olson land use types). +! land use types (no conversion to Olson land use types). ! rc_gstom_wes (Wesely) readability improved; routine gives the same results. -! +! ! 03 Feb 2009, (RIVM): v3.4 Rsoil(NH3,urban) = 100 (was 1000). ! v3.4 ! ! 03 Feb 2009, (RIVM): v3.5 Rinc(grass) = Inf (was 0). ! v3.5 ! -! 03 Feb 2009, (RIVM): v3.6 stomatal compensation point and +! 03 Feb 2009, (RIVM): v3.6 stomatal compensation point and ! v3.6 new parameterisation Rw. ! New routines: ! rc_comp_point (called from depac) @@ -281,11 +281,11 @@ ! New option ipar_rw_nh3. (obsolete in final version MCvZ Nov 2009) ! New (optional) arguments of depac: see header of depac. ! -! 02 Mar 2009, (RIVM): v3.7 -! v3.7 - added compensation point for external leaf; +! 02 Mar 2009, (RIVM): v3.7 +! v3.7 - added compensation point for external leaf; ! new parameterisation for Rw (routine rw_nh3_sutton replaces rw_nh3_rwk); ! - added compensation point for soil; value of compensation point -! set to zero, due to lack of data. +! set to zero, due to lack of data. ! - the same parameterisations as in v3.6 for gamma_stom (only new variable name) ! - Wesely for Rstom; note that the parameterisation for Rw is deduced using the Baldocchi ! parameterisation of Rstom; it was decided to change not everything in this version @@ -293,98 +293,98 @@ ! ! 10 Mar 2009, (RIVM): v3.8 ! v3.8 - the same as v3.7, but Baldocchi for Rstom -! +! ! 24 Mar 2009, (RIVM): v3.8.1 LAI in external leaf resistance -! v3.8.1 gw = (lai/lai(grass)) * gw (adjusted Oct 2009; lai -> sai and +! v3.8.1 gw = (lai/lai(grass)) * gw (adjusted Oct 2009; lai -> sai and ! sai_grass scaling inside rw_nh3_sutton routine) ! ! 9 Apr 2009, (RIVM): v3.8.2 bug fix in temperature -! v3.8.2 correction factor Baldocchi BT +! v3.8.2 correction factor Baldocchi BT ! ! 6 July 2009, (RIVM): v3.9 call added to calculate Rstom with Emberson ! v3.9 ! -! 13 Aug 2009, Margreet van Zanten (RIVM): Emberson update, PARshade and PARsun added +! 13 Aug 2009, OPS-Support (RIVM): Emberson update, PARshade and PARsun added ! (Zhang et al., 2001 Ae 4463-4470 which is update of Norman, 1982 ! -! 17 Aug 2009, Margreet van Zanten (RIVM): update gamma parametrization according to +! 17 Aug 2009, OPS-Support (RIVM): update gamma parametrization according to ! submitted version of Wichink Kruit, 2009 (implemented eq 15 and 14a + eq 12) -! -! 9 Sep 2009, Margreet van Zanten (RIVM): calc of PARdir and PARdiff in Emberson +! +! 9 Sep 2009, OPS-Support (RIVM): calc of PARdir and PARdiff in Emberson ! according to Weiss and Norman 1985 ! ! 22 Sep 2009, (RIVM): gstom of Emberson scaled with diffc/dO3 (instead of ! v3.10 erroneously with dwat) ! -! 24 Sep 2009, Margreet van Zanten (RIVM): choices made on lu classes, F_phen set to 1 +! 24 Sep 2009, OPS-Support (RIVM): choices made on lu classes, F_phen set to 1 ! since described effect is negligible for chosen lu's -! +! ! 29 Sep 2009, (RIVM): Emberson parameterisation of leaf area index (rc_lai); ! new subroutine arguments for DEPAC: day_of_year and lat (latitude). ! -! 2 Oct 2009, Margreet van Zanten (RIVM): v3.10 Merged version of earlier version of 3.10 and 3.9.2 -! Contains soil compensation point. Currently csoil = 0 for all lu's except lu = 6 +! 2 Oct 2009, OPS-Support (RIVM): v3.10 Merged version of earlier version of 3.10 and 3.9.2 +! Contains soil compensation point. Currently csoil = 0 for all lu's except lu = 6 ! for which a basic parametrization for the calc. of csoil is added. ! In this parametrization no disctinction is made between salt and fresh water. ! -! 6 Oct 2009, Margreet van Zanten (RIVM): Distinction made between area index for stom. resistance (LAI) +! 6 Oct 2009, OPS-Support (RIVM): Distinction made between area index for stom. resistance (LAI) ! and external resistance Rw (SAI = LAI + area index of stems and branches). ! rw (external leaf resistance) scaled with fixed sai_grass value (valid for Haarweg data) instead of Gw -! (external canopy resistance). Only Rw_nh3_sutton is scaled not Rw when it is freezing +! (external canopy resistance). Only Rw_nh3_sutton is scaled not Rw when it is freezing ! Old logical vegetetation_present is splitted into LAI_present and SAI_present. ! -! 4 Nov 2009, Margreet van Zanten (RIVM): v3.11, all obsolete code (Wesely, Baldocchi, old LAI parameterisations) +! 4 Nov 2009, OPS-Support (RIVM): v3.11, all obsolete code (Wesely, Baldocchi, old LAI parameterisations) ! v3.11 removed; functionally identical to DEPAC v3.10. ! -! 6 Nov 2009, Margreet van Zanten (RIVM): Differences between LE and OPS version of DEPAC straightened. -! v3.11 Choice for either LE or OPS version, guided by description of DEPAC in Erisman et al, 1994. +! 6 Nov 2009, OPS-Support (RIVM): Differences between LE and OPS version of DEPAC straightened. +! v3.11 Choice for either LE or OPS version, guided by description of DEPAC in Erisman et al, 1994. ! Rw for NO set to -9999. instead of either LE or OPS option ! Rc calculated for lu = 8 (other) is once more identical to the one for grass (rinc is missing instead of 0) ! ! 6 Nov 2009, version v3.11 renamed in depac.f90 ! -! 25 Nov 2009, Margreet van Zanten (RIVM): bug fix for LE implementation -! v3.11 ccomp_tot set to zero in rc_special to avoid use of outdated value of ccomp_tot when -! calling depac routine for several components in a row (esp. NO after NH3), +! 25 Nov 2009, OPS-Support (RIVM): bug fix for LE implementation +! v3.11 ccomp_tot set to zero in rc_special to avoid use of outdated value of ccomp_tot when +! calling depac routine for several components in a row (esp. NO after NH3), ! ccomp_tot added as optional argument to rc_special routine ! -! 18 Dec 2009, Margreet van Zanten (RIVM): SAI for arable land (lu = 2) set to 0.5 outside growing season +! 18 Dec 2009, OPS-Support (RIVM): SAI for arable land (lu = 2) set to 0.5 outside growing season ! v3.13 (instead of 0) ! ! 18 Dec 2009, depac.f90 renamed in depac_2010.f90 ! -! 22 Dec 2009, Margreet van Zanten (RIVM): v3.14 -> copy of depac_2010.f90. Write statements for test output added +! 22 Dec 2009, OPS-Support (RIVM): v3.14 -> copy of depac_2010.f90. Write statements for test output added ! v3.14 from depac_313. Frozen version ! -! 22 Dec 2009, Margreet van Zanten (RIVM): v3.15 copy of 3.14, two comments related to Rinc added (see 3.13) +! 22 Dec 2009, OPS-Support (RIVM): v3.15 copy of 3.14, two comments related to Rinc added (see 3.13) ! v3.15 small bug fixed in rw_constant and rc_rctot so that rw can be set to -9999. correctly -! -! 4 Jan 2010, Margreet van Zanten (RIVM): depac_f90 and depac_3.11 merged, thus following bug fix dated Nov 25 2009 +! +! 4 Jan 2010, OPS-Support (RIVM): depac_f90 and depac_3.11 merged, thus following bug fix dated Nov 25 2009 ! v3.11 in depac.f90 implemented in 3.11 ! bug fix for LE implementation -! ccomp_tot set to zero in rc_special to avoid use of outdated value of ccomp_tot when -! calling depac routine for several components in a row (esp. NO after NH3), +! ccomp_tot set to zero in rc_special to avoid use of outdated value of ccomp_tot when +! calling depac routine for several components in a row (esp. NO after NH3), ! ccomp_tot added as optional argument to rc_special routine ! -! 04 Jan 2010, (RIVM): v3.16 is shell around versions 3.11 ('new' DEPAC for NH3 only) -! v3.16 and 3.3 (old DEPAC for other species). +! 04 Jan 2010, (RIVM): v3.16 is shell around versions 3.11 ('new' DEPAC for NH3 only) +! v3.16 and 3.3 (old DEPAC for other species). ! This file is constructed as follows: ! module m_depac311 ! module m_depac33 ! module m_depac316 ! ! 04 Jan 2010, (RIVM): iopt_debug -> optional writing of debug output -! v3.16 added to m_depac311 and m_depac33 in this file +! v3.16 added to m_depac311 and m_depac33 in this file ! -! 04 Jan 2010, Margreet van Zanten(RIVM): frozen version of depac v3.16, renamed in depac_GCN2010 +! 04 Jan 2010, OPS-Support(RIVM): frozen version of depac v3.16, renamed in depac_GCN2010 ! depac_GCN2010 ! -! 2013-09-17 this version has been derived from the 'hybrid' version -! v3.18 depac_GCN2010, which consisted of a shell around version +! 2013-09-17 this version has been derived from the 'hybrid' version +! v3.18 depac_GCN2010, which consisted of a shell around version ! depac311 (for NH3) and depac33 (for other species). -! In this version, only depac311 has been retained, with some +! In this version, only depac311 has been retained, with some ! bug fixes, -! +! !************************************************************************ !************************************************************************************ ! @@ -395,7 +395,7 @@ module m_depac318 implicit none - + ! Make all variables and procedures private, except depac PRIVATE PUBLIC depac318 @@ -425,15 +425,15 @@ SUBROUTINE get_version_depac(dll_version, dll_date) !DEC$ ATTRIBUTES DLLEXPORT:: get_version_depac ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'get_version_depac') ! SUBROUTINE ARGUMENTS - OUTPUT -CHARACTER*(*), INTENT(OUT) :: dll_version ! -CHARACTER*(*), INTENT(OUT) :: dll_date ! +CHARACTER*(*), INTENT(OUT) :: dll_version +CHARACTER*(*), INTENT(OUT) :: dll_date ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'// char (0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -463,7 +463,7 @@ subroutine depac318(compnam, day_of_year, lat, t, ust, glrad, sinphi, rh, nwet, ! A. compute Rc without compensation points: ! call depac (compnam, day_of_year, lat, t, ust, glrad, sinphi, rh, nwet, lu, iratns, rc_tot) ! -! B. compute Rc (incl. new parameterisation Rw) and compensation points (used for LOTOS-EUROS): +! B. compute Rc (incl. new parameterisation Rw) and compensation points (used for LOTOS-EUROS): ! call depac (compnam, day_of_year, lat, t, ust, glrad, sinphi, rh, nwet, lu, iratns, rc_tot, & ! c_ave_prev_nh3, c_ave_prev_so2, catm, ccomp_tot) ! @@ -478,8 +478,8 @@ subroutine depac318(compnam, day_of_year, lat, t, ust, glrad, sinphi, rh, nwet, ! 'HNO3','NO','NO2','O3','SO2','NH3' integer , intent(in) :: day_of_year ! day of year, 1 ... 365 (366) real , intent(in) :: lat ! latitude Northern hemisphere (degrees) (DEPAC cannot be used for S. hemisphere) -real , intent(in) :: t ! temperature (C) - ! NB discussion issue is temp T_2m or T_surf of T_leaf? +real , intent(in) :: t ! temperature (C) + ! NB discussion issue is temp T_2m or T_surf of T_leaf? real , intent(in) :: ust ! friction velocity (m/s) real , intent(in) :: glrad ! global radiation (W/m2) real , intent(in) :: sinphi ! sin of solar elevation angle @@ -494,7 +494,7 @@ subroutine depac318(compnam, day_of_year, lat, t, ust, glrad, sinphi, rh, nwet, ! optional arguments needed only if compensation points are computed real, optional , intent(in) :: c_ave_prev_nh3 ! air concentration averaged over a previous - ! period (e.g. previous year or month) (ug/m3) + ! period (e.g. previous year or month) (ug/m3) real, optional , intent(in) :: c_ave_prev_so2 ! air concentration averaged over a previous ! period (e.g. previous year or month) (ug/m3) real, optional , intent(in) :: catm ! actual atmospheric concentration (ug/m3) @@ -510,20 +510,20 @@ subroutine depac318(compnam, day_of_year, lat, t, ust, glrad, sinphi, rh, nwet, real :: lai ! one-sided leaf area index (-) real :: sai ! surface area index (-) (lai + branches and stems) logical :: ready ! Rc has been set -real :: diffc ! diffusion coefficient of the gas involved +real :: diffc ! diffusion coefficient of the gas involved integer :: ipar_snow ! parameterisation in case of snow: ! = 1 -> constant Rc ! = 2 -> temperature dependent Rc real :: rsoil_wet ! soil resistance for wet soil real :: rsoil_frozen ! soil resistance for frozen soil real , dimension(nlu) :: rsoil ! soil resistance -real :: gw ! external leaf conductance (m/s) +real :: gw ! external leaf conductance (m/s) real :: gstom ! stomatal conductance (m/s) real :: gsoil_eff ! effective soil conductance (m/s) real :: gc_tot ! total canopy conductance (m/s) ! Compute one-sided leaf area index: -call rc_lai(day_of_year,lat,lu,lai,sai) +call rc_lai(day_of_year,lat,lu,lai,sai) ! Check whether vegetation is present (in that case the leaf or surface area index > 0): LAI_present = (lai .gt. 0.0) @@ -539,17 +539,17 @@ subroutine depac318(compnam, day_of_year, lat, t, ust, glrad, sinphi, rh, nwet, if (.not. ready) then ! External conductance: - call rc_gw(compnam,iratns,t,rh,nwet,sai,gw) + call rc_gw(compnam,iratns,t,rh,nwet,sai,gw) ! Stomatal conductance: - call rc_gstom(compnam,lu,lai,glrad,sinphi,t,rh,diffc,gstom) + call rc_gstom(compnam,lu,lai,glrad,sinphi,t,rh,diffc,gstom) ! Effective soil conductance: call rc_gsoil_eff(lu,sai,ust,nwet,t,rsoil,rsoil_wet,rsoil_frozen,gsoil_eff) ! Total canopy conductance (gc_tot) and resistance Rc (rc_tot): call rc_rctot(gstom,gsoil_eff,gw,gc_tot,rc_tot) - + ! Compensation points: if (present(c_ave_prev_nh3) .and. present(c_ave_prev_so2) .and. present(catm) .and. present(ccomp_tot)) then call rc_comp_point(compnam,lu,day_of_year,t,catm,c_ave_prev_nh3,c_ave_prev_so2,gw,gstom,gsoil_eff,gc_tot,ccomp_tot) @@ -576,7 +576,7 @@ subroutine rc_getpar(compnam,diffc,rsoil_wet,rsoil_frozen,ipar_snow,rsoil) ! Define component specific parameters: character(len=*), intent(in) :: compnam ! component name -real , intent(out) :: diffc ! diffusion coefficient of the gas involved +real , intent(out) :: diffc ! diffusion coefficient of the gas involved real , intent(out) :: rsoil_wet ! soil resistance for wet soil real , intent(out) :: rsoil_frozen ! soil resistance for frozen soil integer, intent(out) :: ipar_snow ! parameterisation in case of snow: @@ -594,33 +594,33 @@ subroutine rc_getpar(compnam,diffc,rsoil_wet,rsoil_frozen,ipar_snow,rsoil) ipar_snow = 1 rsoil_wet = -999 rsoil_frozen = -999 - + ! grass arable perm. conif. decid. water urban other desert ! land crops forest frest - ! 1 2 3 4 5 6 7 8 9 + ! 1 2 3 4 5 6 7 8 9 rsoil = (/ -999, -999, -999, -999, -999, 2000, 1000, -999 , 2000 /) case('NO2') diffc = 0.13e-4 ipar_snow = 1 - rsoil_wet = 2000 - rsoil_frozen = 2000 + rsoil_wet = 2000 + rsoil_frozen = 2000 ! grass arable perm. conif. decid. water urban other desert ! land crops forest forest - ! 1 2 3 4 5 6 7 8 9 + ! 1 2 3 4 5 6 7 8 9 rsoil = (/ 1000, 1000, 1000, 1000, 1000, 2000, 1000, 1000, 1000/) - + case('O3') diffc = dO3 ipar_snow = 1 - rsoil_wet = 2000 - rsoil_frozen = 2000 + rsoil_wet = 2000 + rsoil_frozen = 2000 ! grass arable perm. conif. decid. water urban other desert ! land crops forest forest - ! 1 2 3 4 5 6 7 8 9 + ! 1 2 3 4 5 6 7 8 9 ! rsoil = (/ 200, 200, 200, 200, 200, 2000, 200, 200, 200/) rsoil = (/1000, 200, 200, 200, 200, 2000, 400, 400, 2000/) - + case('SO2') diffc = 0.11e-4 ipar_snow = 2 @@ -628,17 +628,17 @@ subroutine rc_getpar(compnam,diffc,rsoil_wet,rsoil_frozen,ipar_snow,rsoil) rsoil_frozen = 500 ! grass arable perm. conif. decid. water urban other desert ! land crops forest forest - ! 1 2 3 4 5 6 7 8 9 + ! 1 2 3 4 5 6 7 8 9 rsoil = (/ 1000, 1000, 1000, 1000, 1000, 10, 1000, 1000, 1000/) case('NH3') diffc = 0.21e-4 ipar_snow = 2 - rsoil_wet = 10 + rsoil_wet = 10 rsoil_frozen = 1000 ! grass arable perm. conif. decid. water urban other desert ! land crops forest forest - ! 1 2 3 4 5 6 7 8 9 + ! 1 2 3 4 5 6 7 8 9 rsoil = (/ 100, 100, 100, 100, 100, 10, 100, 100, 100/) case default @@ -670,7 +670,7 @@ subroutine rc_special(compnam,lu,t,ipar_snow,nwet,rc_tot,ready,ccomp_tot) ! Default compensation point in special cases = 0: if (present(ccomp_tot)) ccomp_tot = 0.0 - + select case(trim(compnam)) case('HNO3') ! No separate resistances for HNO3; just one total canopy resistance: @@ -682,7 +682,7 @@ subroutine rc_special(compnam,lu,t,ipar_snow,nwet,rc_tot,ready,ccomp_tot) rc_tot = 10.0 endif ready = .true. - + case('NO') if (lu .eq. 6) then ! water rc_tot = 2000. @@ -740,13 +740,13 @@ subroutine rc_gw(compnam,iratns,t,rh,nwet,sai,gw) select case(trim(compnam)) !case('HNO3') this routine is not called for HNO3 - + case('NO2') call rw_constant(2000.,gw) case('NO') call rw_constant(-9999.,gw) ! see Erisman et al, 1994 section 3.2.3 - + case('O3') call rw_constant(1000.,gw) @@ -758,7 +758,7 @@ subroutine rc_gw(compnam,iratns,t,rh,nwet,sai,gw) ! conversion from leaf resistance to canopy resistance by multiplying with SAI: Gw = sai*gw - + case default print *, 'error in subroutine rc_gw ' print *, 'component ',trim(compnam),' not supported' @@ -790,8 +790,8 @@ subroutine rw_so2(t,nwet,rh,iratns,gw) ! Check if vegetation present: if (SAI_present) then - - if (nwet .eq. 0) then + + if (nwet .eq. 0) then !-------------------------- ! dry surface !-------------------------- @@ -831,7 +831,7 @@ subroutine rw_so2(t,nwet,rh,iratns,gw) end subroutine rw_so2 !------------------------------------------------------------------- -! rw_nh3_sutton: compute external leaf conductance for NH3, +! rw_nh3_sutton: compute external leaf conductance for NH3, ! following Sutton & Fowler, 1993 !------------------------------------------------------------------- subroutine rw_nh3_sutton(tsurf,rh,gw) @@ -848,22 +848,22 @@ subroutine rw_nh3_sutton(tsurf,rh,gw) real :: rw ! external leaf resistance (s/m) real :: sai_grass_haarweg ! surface area index at experimental site Haarweg -! Fix SAI_grass at value valid for Haarweg data for which gamma_w parametrization is derived -sai_grass_haarweg = 3.5 +! Fix SAI_grass at value valid for Haarweg data for which gamma_w parametrization is derived +sai_grass_haarweg = 3.5 -! 100 - rh +! 100 - rh ! rw = 2.0 * exp(----------) ! 12 if (SAI_present) then - + ! External resistance according to Sutton & Fowler, 1993 rw = 2.0 * exp((100.0 - rh)/12.0) - rw = sai_grass_haarweg * rw + rw = sai_grass_haarweg * rw ! Frozen soil (from Depac v1): if (tsurf .lt. 0) rw = 200 - + ! Conductance: gw = 1./rw else @@ -898,16 +898,16 @@ end subroutine rw_constant ! rc_lai: compute one-sided leaf area index ! based on Simpson et al, EMEP status report 2003 + EMEP code !------------------------------------------------------------------- -subroutine rc_lai(day_of_year,lat,lu,lai,sai) +subroutine rc_lai(day_of_year,lat,lu,lai,sai) implicit none ! Input/output variables -integer, intent (in) :: day_of_year ! day of year +integer, intent (in) :: day_of_year ! day of year real , intent (in) :: lat ! latitude (degrees) integer, intent (in) :: lu ! landuse class real , intent(out) :: lai ! one-sided leaf area index -real , intent(out) :: sai ! surface area index +real , intent(out) :: sai ! surface area index ! Define type for LAI (leaf area index) parameters: type laitype @@ -918,7 +918,7 @@ subroutine rc_lai(day_of_year,lat,lu,lai,sai) real :: degs ! shift in end growing season (days/degree latitude) ! degs < 0 -> end-growing-season later in the south, earlier in the north real :: laimin ! leaf area index at start and end of growing season (m2 leaf/m2 ground surface); - ! outside growing season LAI = 0. Note that the SAI can be > 0 outside the + ! outside growing season LAI = 0. Note that the SAI can be > 0 outside the ! growing season. real :: laimax ! maximal leaf area index (m2 leaf/m2 ground surface) integer :: s_lai_len ! length of starting phase of LAI (days) @@ -949,9 +949,9 @@ subroutine rc_lai(day_of_year,lat,lu,lai,sai) ! | / \ ! | / \ ! | / \ -! laimin| / \ +! laimin| / \ +! | | | ! | | | -! | | | ! ---------|------|--------|-----|----------- ! sgs sgs+ egs- egs ! s_lai_len e_lai_len @@ -964,12 +964,12 @@ subroutine rc_lai(day_of_year,lat,lu,lai,sai) ! degs ! shift in end growing season (days/degree latitude) ! degs < 0 -> end-growing-season later in the south, earlier in the north ! laimin ! leaf area index at start and end of growing season (m2 leaf/m2 ground surface); - ! outside growing season LAI = 0. Note that the SAI can be > 0 outside the + ! outside growing season LAI = 0. Note that the SAI can be > 0 outside the ! growing season. ! laimax ! maximal leaf area index (m2 leaf/m2 ground surface) ! s_lai_len ! length of starting phase of LAI (days) ! e_lai_len ! length of end phase of LAI (days) - + ! local variables: integer :: sgs ! start growing season at certain latitude (days) integer :: egs ! end growing season at certain latitude (days) @@ -993,19 +993,19 @@ subroutine rc_lai(day_of_year,lat,lu,lai,sai) lai = 0.0; else if (day_of_year <= sgs + lai_par1%s_lai_len ) then - + ! (lai - laimin) (day_of_year - sgs) ! ----------------- = ------------------- ! (laimax - laimin) s_lai_len - + lai = lai_par1%laimin + (lai_par1%laimax-lai_par1%laimin)*(day_of_year-sgs)/lai_par1%s_lai_len - + elseif (day_of_year >= egs - lai_par1%e_lai_len) then - + ! (lai - laimin) (egs - day_of_year) ! ----------------- = ------------------- ! (laimax - laimin) e_lai_len - + lai = lai_par1%laimin + (lai_par1%laimax-lai_par1%laimin)*(egs-day_of_year)/lai_par1%e_lai_len else lai = lai_par1%laimax @@ -1018,7 +1018,7 @@ subroutine rc_lai(day_of_year,lat,lu,lai,sai) sai = lai + .5 ! pers. comm. Roy Wichink Kruit elseif (lu .eq. 2) then ! arable land if (day_of_year < sgs .or. day_of_year > egs) then ! EMEP report 1/2003 Simpson et al. - sai = lai + sai = lai elseif (day_of_year <= sgs + lai_par1%s_lai_len) then sai = max(5.0/3.5*lai,lai + 1.5) ! max statement is used to avoid hiccup in sai value elseif (day_of_year >= egs - lai_par1%e_lai_len) then @@ -1026,7 +1026,7 @@ subroutine rc_lai(day_of_year,lat,lu,lai,sai) else sai = lai + 1.5 endif - else ! rest + else ! rest sai = lai endif endif @@ -1056,7 +1056,7 @@ subroutine rc_gstom(compnam,lu,lai,glrad,sinphi, t,rh,diffc,gstom) ! Local variables real :: vpd ! vapour pressure deficit (kPa) - + select case(trim(compnam)) !case('HNO3') this routine is not called for HNO3 @@ -1066,22 +1066,22 @@ subroutine rc_gstom(compnam,lu,lai,glrad,sinphi, t,rh,diffc,gstom) gstom = 0.0 case('NO2','O3','SO2','NH3') - + ! if vegetation present: if (LAI_present) then - + if (glrad .gt. 0.0) then call rc_get_vpd(t,rh,vpd) call rc_gstom_emb(lu,glrad,t,vpd,lai,sinphi,gstom) - gstom = gstom*diffc/dO3 ! Gstom of Emberson is derived for ozone + gstom = gstom*diffc/dO3 ! Gstom of Emberson is derived for ozone else gstom = 0.0 endif - else + else ! no vegetation; zero conductance (infinite resistance): gstom = 0.0 endif - + case default print *, 'error in subroutine rc_gstom ' print *, 'component ',trim(compnam),' not supported' @@ -1118,7 +1118,7 @@ SUBROUTINE rc_gstom_emb(lu,glrad,T,vpd,lai,sinp,Gsto) ! 8 = other GR = grassland ! 9 = desert DE = desert ! -! Parameters: values from EMEP DO3SE.csv Jan 31st 2007 inputfile, +! Parameters: values from EMEP DO3SE.csv Jan 31st 2007 inputfile, ! some values (mainly lu 4,5 and 8) updated compared to Emberson report. ! set F_min: real, dimension(nlu), parameter :: F_min =(/0.01, 0.01, 0.01 ,0.1, 0.1,-999., -999.,0.01 ,-999. /) @@ -1132,7 +1132,7 @@ SUBROUTINE rc_gstom_emb(lu,glrad,T,vpd,lai,sinp,Gsto) real, dimension(nlu), parameter :: Tmax =(/40.0 ,40.0 ,40.0 ,36.0 ,35.0 , -999.,-999.,40.0,-999. /) ! Set maximal conductance (m/s) -! (R T/P) = 1/41000 mmol/m3 is given for 20 deg C to go from mmmol O3/m2/s to m/s +! (R T/P) = 1/41000 mmol/m3 is given for 20 deg C to go from mmmol O3/m2/s to m/s ! Could be refined to a function of T and P. in Jones real, dimension(nlu), parameter :: g_max =(/270. ,300. ,300. ,140. ,150. , -999.,-999.,270.,-999. /)/41000 @@ -1167,7 +1167,7 @@ SUBROUTINE rc_gstom_emb(lu,glrad,T,vpd,lai,sinp,Gsto) sinphi = 0.0001 else sinphi = sinp - end if + end if ! Direct and diffuse PAR, Photoactive (=visible) radiation: call par_dir_diff(glrad,sinphi,pres,pres_0,PARdir,PARdiff) @@ -1179,25 +1179,25 @@ SUBROUTINE rc_gstom_emb(lu,glrad,T,vpd,lai,sinp,Gsto) end if ! PAR for sunlit leaves (canopy averaged): - ! alpha -> mean angle between leaves and the sun is fixed at 60 deg -> i.e. cos alpha = 0.5 + ! alpha -> mean angle between leaves and the sun is fixed at 60 deg -> i.e. cos alpha = 0.5 PARsun = PARdir*0.5/sinphi + PARshade ! Norman, 1982 if (glrad .gt. 200 .and. LAI .gt. 2.5) then PARsun = PARdir**0.8*0.5/sinphi + PARshade ! Zhang et al., 2001 end if - + ! leaf area index for sunlit and shaded leaves: - if (sinphi .gt. 0) then - LAIsun = 2*sinphi*(1-exp(-0.5*LAI/sinphi )) + if (sinphi .gt. 0) then + LAIsun = 2*sinphi*(1-exp(-0.5*LAI/sinphi )) LAIshade = LAI -LAIsun else LAIsun = 0 LAIshade = LAI end if - + ! correction factor for radiation (Emberson): F_light = (LAIsun*(1 - exp(-1.*alpha(lu)*PARsun)) + LAIshade*(1 - exp(-1.*alpha(lu)*PARshade)))/LAI F_light = max(F_light,F_min(lu)) - + ! temperature influence BT = (Tmax(lu)-Topt(lu))/(Topt(lu)-Tmin(lu)) F_temp = ((T-Tmin(lu))/(Topt(lu)-Tmin(lu))) * ((Tmax(lu)-T)/(Tmax(lu)-Topt(lu)))**BT @@ -1214,18 +1214,18 @@ SUBROUTINE rc_gstom_emb(lu,glrad,T,vpd,lai,sinp,Gsto) ! ignored for now in DEPAC since influence of F_phen on lu classes in use is negligible. ! When other EMEP classes (e.g. med. broadleaf) are used f_phen might be too important to ignore F_phen = 1. - + ! evaluate total stomatal conductance F_env = F_temp*F_vpd*F_swp F_env = max(F_env,F_min(lu)) gsto = G_max(lu) * F_light * F_phen * F_env - ! gstom expressed per m2 leafarea; + ! gstom expressed per m2 leafarea; ! this is converted with LAI to m2 surface. Gsto = lai*gsto ! in m/s ELSE - GSto = 0.0 + GSto = 0.0 ENDIF END SUBROUTINE rc_gstom_emb @@ -1252,7 +1252,7 @@ SUBROUTINE par_dir_diff(glrad,sinphi,pres,pres_0,par_dir,par_diff) real, intent(in) :: pres_0 ! pressure at sea level (Pa) real, intent(out) :: par_dir ! PAR direct : visible (photoactive) direct beam radiation (W m-2) real, intent(out) :: par_diff ! PAR diffuse: visible (photoactive) diffuse radiation (W m-2) - + ! fn = near-infrared direct beam fraction (dimensionless) ! fv = PAR direct beam fraction (dimensionless) ! ratio = ratio measured to potential solar radiation (dimensionless) @@ -1270,16 +1270,16 @@ SUBROUTINE par_dir_diff(glrad,sinphi,pres,pres_0,par_dir,par_diff) ! 600 W m-2 represents average amount of PAR (400-700 nm wavelength) ! at the top of the atmosphere; this is roughly 0.45*solar constant (solar constant=1320 Wm-2) rdu=600.*exp(-0.185*(pres/pres_0)/sinphi)*sinphi - + ! Calculate potential visible diffuse radiation rdv=0.4*(600.- rdu)*sinphi - -! Calculate the water absorption in the-near infrared + +! Calculate the water absorption in the-near infrared ww=1320*10**( -1.195+0.4459*log10(1./sinphi)-0.0345*(log10(1./sinphi))**2 ) - + ! Calculate potential direct beam near-infrared radiation rdm=(720.*exp(-0.06*(pres/pres_0)/sinphi)-ww)*sinphi !720 = solar constant - 600 - + ! Calculate potential diffuse near-infrared radiation rdn=0.6*(720-rdm-ww)*sinphi @@ -1289,10 +1289,10 @@ SUBROUTINE par_dir_diff(glrad,sinphi,pres,pres_0,par_dir,par_diff) ! Compute ratio between input global radiation and total radiation computed here ratio=min(0.9,glrad/(rv+rn)) - + ! Calculate total visible radiation sv=ratio*rv - + ! Calculate fraction of PAR in the direct beam fv=min(0.99, (0.9-ratio)/0.7) ! help variable fv=max(0.01,rdu/rv*(1.0-fv**0.6667)) ! fraction of PAR in the direct beam @@ -1343,7 +1343,7 @@ subroutine rc_snow(ipar_snow,t,rc_tot) ! ipar_snow = 2 : temperature dependent parameterisation real , intent(in) :: t ! temperature (C) real , intent(out) :: rc_tot ! total canopy resistance Rc (s/m) - + ! Local variables: real, parameter :: rssnow = 2000. ! constant resistance in case of snow and ipar_snow = 1 @@ -1354,14 +1354,14 @@ subroutine rc_snow(ipar_snow,t,rc_tot) if (t .lt. -1.) then rc_tot = 500. elseif (t .gt. 1.) then - rc_tot = 70. + rc_tot = 70. else ! (t .ge. -1. .and. t .le. 1.) rc_tot = 70.*(2.-t) endif else write(*,*) ' programming error in subroutine rc_snow' write(*,*) ' unknown value of ipar_snow: ',ipar_snow - stop + stop endif end subroutine rc_snow @@ -1399,7 +1399,7 @@ subroutine rc_gsoil_eff(lu,sai,ust,nwet,t,rsoil,rsoil_wet,rsoil_frozen,gsoil_eff ! Frozen soil (temperature below 0): if (t .lt. 0.0) then - if (missing(rsoil_frozen)) then + if (missing(rsoil_frozen)) then rsoil_eff = -9999. else rsoil_eff = rsoil_frozen + rinc @@ -1412,7 +1412,7 @@ subroutine rc_gsoil_eff(lu,sai,ust,nwet,t,rsoil,rsoil_wet,rsoil_frozen,gsoil_eff else rsoil_eff = rsoil(lu) + rinc endif - + ! Non-frozen soil; wet: elseif (nwet .eq. 1) then if (missing(rsoil_wet)) then @@ -1421,8 +1421,8 @@ subroutine rc_gsoil_eff(lu,sai,ust,nwet,t,rsoil,rsoil_wet,rsoil_frozen,gsoil_eff rsoil_eff = rsoil_wet + rinc endif else - write(*,*) ' programming error in rc_gsoil_eff' - write(*,*) ' nwet can only be 0 or 1: ',nwet + write(*,*) ' programming error in rc_gsoil_eff' + write(*,*) ' nwet can only be 0 or 1: ',nwet stop endif endif @@ -1438,7 +1438,7 @@ subroutine rc_gsoil_eff(lu,sai,ust,nwet,t,rsoil,rsoil_wet,rsoil_frozen,gsoil_eff end subroutine rc_gsoil_eff !------------------------------------------------------------------- -! rc_rinc: compute in canopy (or in crop) resistance +! rc_rinc: compute in canopy (or in crop) resistance ! van Pul and Jacobs, 1993, BLM !------------------------------------------------------------------- subroutine rc_rinc(lu,sai,ust,rinc) @@ -1455,8 +1455,8 @@ subroutine rc_rinc(lu,sai,ust,rinc) ! grass arable perm. conif. decid. water urban other desert ! land crops forest forest -! 1 2 3 4 5 6 7 8 9 -data b / -999, 14, 14, 14, 14, -999, -999, -999, -999/ +! 1 2 3 4 5 6 7 8 9 +data b / -999, 14, 14, 14, 14, -999, -999, -999, -999/ data h / -999, 1, 1, 20, 20, -999, -999, -999, -999/ ! Compute Rinc only for arable land, perm. crops, forest; otherwise Rinc = 0: @@ -1479,7 +1479,7 @@ subroutine rc_rinc(lu,sai,ust,rinc) end subroutine rc_rinc !------------------------------------------------------------------- -! rc_rctot: compute total canopy (or surface) resistance Rc +! rc_rctot: compute total canopy (or surface) resistance Rc !------------------------------------------------------------------- subroutine rc_rctot(gstom,gsoil_eff,gw,gc_tot,rc_tot) @@ -1516,11 +1516,11 @@ subroutine rc_comp_point(compnam,lu,day_of_year,t,catm,c_ave_prev_nh3,c_ave_prev ! 2.75e15 -1.04e4 ! ccomp = gamma ------- exp(-------) ! Tk Tk -! with +! with ! gamma : [NH4+]/[H+] ratio in apoplast (or leaf) -! Tk : temperature (K) -! -! The [NH4+]/[H+] ratio gamma depends on +! Tk : temperature (K) +! +! The [NH4+]/[H+] ratio gamma depends on ! 1. for stomata ! the average concentration over a previous period: ! gamma_stom = gamma_stom_c_fac * c_ave_prev_nh3 @@ -1540,25 +1540,25 @@ subroutine rc_comp_point(compnam,lu,day_of_year,t,catm,c_ave_prev_nh3,c_ave_prev character(len=*), intent(in) :: compnam ! component name ! 'HNO3','NO','NO2','O3','SO2','NH3' integer, intent(in) :: lu ! land use type, lu = 1,...,9 -integer, intent (in) :: day_of_year ! day of year -real, intent(in) :: t ! temperature (C) +integer, intent (in) :: day_of_year ! day of year +real, intent(in) :: t ! temperature (C) real, intent(in) :: catm ! actual atmospheric concentration (ug/m3) real, intent(in) :: c_ave_prev_nh3 ! air concentration averaged over a previous - ! period (e.g. previous year or month) (ug/m3) + ! period (e.g. previous year or month) (ug/m3) !real, optional, intent(in) :: c_ave_prev_so2 ! air concentration averaged over a previous real, intent(in) :: c_ave_prev_so2 ! air concentration averaged over a previous ! period (e.g. previous year or month) (ug/m3) -real, intent(in) :: gw ! external leaf conductance (m/s) +real, intent(in) :: gw ! external leaf conductance (m/s) real, intent(in) :: gstom ! stomatal conductance (m/s) real, intent(in) :: gsoil_eff ! effective soil conductance (m/s) real, intent(in) :: gc_tot ! total canopy conductance (m/s) -real, intent(out) :: ccomp_tot ! total compensation point (weighed average of +real, intent(out) :: ccomp_tot ! total compensation point (weighed average of ! separate compensation points) (ug/m3) ! Variables from module: ! gamma_stom_c_fac: factor in linear relation between gamma_stom and NH3 air concentration. ! LAI_present or SAI_present: vegetation is present - + ! Local variables: real :: cw ! external leaf compensation point (ug/m3) real :: cstom ! stomatal compensation point (ug/m3) @@ -1566,9 +1566,9 @@ subroutine rc_comp_point(compnam,lu,day_of_year,t,catm,c_ave_prev_nh3,c_ave_prev real :: gamma_stom ! [NH4+]/[H+] ratio in apoplast real :: gamma_soil ! [NH4+]/[H+] ratio in soil real :: gamma_w ! [NH4+]/[H+] ratio in external leaf surface water -real :: tk ! temperature (K) +real :: tk ! temperature (K) real :: tfac ! temperature factor = (2.75e15/tk)*exp(-1.04e4/tk) -real :: co_dep_fac ! co-deposition factor +real :: co_dep_fac ! co-deposition factor real , dimension(nlu) :: gamma_stom_c_fac ! factor in linear relation between gamma_stom and NH3 ! air concentration; gamma_stom = [NH4+]/[H+] ratio in apoplast @@ -1577,9 +1577,9 @@ subroutine rc_comp_point(compnam,lu,day_of_year,t,catm,c_ave_prev_nh3,c_ave_prev ! ! grass arable perm. conif. decid. water urban other desert ! land crops forest forest -! 1 2 3 4 5 6 7 8 9 +! 1 2 3 4 5 6 7 8 9 ! for current parametrization gamma_stom_c_fac is independent of lu -data gamma_stom_c_fac / 362, 362, 362, 362, 362, -999, -999, 362, -999 / +data gamma_stom_c_fac / 362, 362, 362, 362, 362, -999, -999, 362, -999 / data gamma_soil_c_fac / -999, -999, -999, -999, -999, 430, -999, -999, -999 / select case(trim(compnam)) @@ -1588,47 +1588,47 @@ subroutine rc_comp_point(compnam,lu,day_of_year,t,catm,c_ave_prev_nh3,c_ave_prev case('NO','NO2','O3','SO2') ! no compensation points: ccomp_tot = 0.0 - + case('NH3') ! Temperature factor: - + ! parametrized temperature of surface water including yearly cycle - ! parametrization based on NL Waterbase data for 2003-2008, for ~25 locations + ! parametrization based on NL Waterbase data for 2003-2008, for ~25 locations ! for which NH4+, PH and temperature measurements are present - if (lu .eq. 6) then ! water + if (lu .eq. 6) then ! water tk = 286.2 + 8.3*sin(day_of_year -113.5) else tk = t + 273.15 endif tfac = (2.75e15/tk)*exp(-1.04e4/tk) - + ! Stomatal compensation point: if (LAI_present .and. c_ave_prev_nh3 .gt. 0.) then - ! gamma_stom ([NH4+]/[H+] ratio in apoplast) is linearly dependent on an + ! gamma_stom ([NH4+]/[H+] ratio in apoplast) is linearly dependent on an ! averaged air concentration in a previous period (stored in soil and leaves): gamma_stom = gamma_stom_c_fac(lu)*c_ave_prev_nh3*4.7*exp(-0.071*t) - + ! calculate stomatal compensation point for NH3 in ug/m3: cstom = max(0.0,gamma_stom*tfac) else ! No concentration in previous period or no gamma-c factor: cstom = 0.0 endif - + ! External leaf gamma depends on atmospheric concentration and ! surface temperature (assumed to hold for all land use types with vegetation): ! if (SAI_present .and. present(catm) .and. present(c_ave_prev_nh3) .and. present(c_ave_prev_so2) .and. c_ave_prev_nh3 .gt. 0. .and. c_ave_prev_so2 .gt. 0.) then if (SAI_present .and. c_ave_prev_nh3 .gt. 0. .and. c_ave_prev_so2 .gt. 0.) then gamma_w = -850.+1840.*catm*exp(-0.11*t) - ! correction gamma_w for co deposition + ! correction gamma_w for co deposition ! xxx documentation to be added - ! gamma(with SNratio) = [1.12-1.32*SNratio(molair)] * gamma_original + ! gamma(with SNratio) = [1.12-1.32*SNratio(molair)] * gamma_original ! where SNratio(molar) = (CSO2longterm/64)/(CNH3longterm/17)) ! where CSO2longterm and CNH3longterm in ug m-3. co_dep_fac = 1.12 - 1.32 * ((c_ave_prev_so2/64.)/(c_ave_prev_nh3/17.)) - co_dep_fac = max(0.0,co_dep_fac) - gamma_w = co_dep_fac * gamma_w + co_dep_fac = max(0.0,co_dep_fac) + gamma_w = co_dep_fac * gamma_w cw = max(0.0,gamma_w*tfac) ! elseif (SAI_present .and. present(catm)) then elseif (SAI_present) then @@ -1642,11 +1642,11 @@ subroutine rc_comp_point(compnam,lu,day_of_year,t,catm,c_ave_prev_nh3,c_ave_prev ! Soil compensation point: if (c_ave_prev_nh3 .gt. 0. .and. gamma_soil_c_fac(lu) > 0) then if (lu .eq. 6)then - ! gamma_soil for water is determined to be 430 based on Waterbase data, - ! here it is 'calculated' analogous to the other gamma_stom + ! gamma_soil for water is determined to be 430 based on Waterbase data, + ! here it is 'calculated' analogous to the other gamma_stom gamma_soil = gamma_soil_c_fac(lu)*1. else - ! gamma_soil ([NH4+]/[H+] ratio in soil) is linearly dependent on an + ! gamma_soil ([NH4+]/[H+] ratio in soil) is linearly dependent on an ! averaged air concentration in a previous period: gamma_soil = gamma_soil_c_fac(lu)*c_ave_prev_nh3 endif @@ -1655,11 +1655,11 @@ subroutine rc_comp_point(compnam,lu,day_of_year,t,catm,c_ave_prev_nh3,c_ave_prev else ! No concentration in previous period or no gamma-c factor: csoil = 0.0 - endif - + endif + ! Total compensation point is weighed average of separate compensation points: ccomp_tot = (gw/gc_tot)*cw + (gstom/gc_tot)*cstom + (gsoil_eff/gc_tot)*csoil - + case default print *, 'error in subroutine rc_comp_point ' print *, 'component ',trim(compnam),' not supported' @@ -1673,7 +1673,7 @@ end subroutine rc_comp_point ! based on one or more compensation points !------------------------------------------------------------------- ! -! old name: NH3rc (see depac v3.6 is based on Avero workshop Marc Sutton. p. 173. +! old name: NH3rc (see depac v3.6 is based on Avero workshop Marc Sutton. p. 173. ! Sutton 1998 AE 473-480) ! ! Documentation by , 2008; see also documentation block in header of this module. @@ -1681,51 +1681,51 @@ end subroutine rc_comp_point ! ! C: with total compensation point -! -! zr --------- Catm -! | -! Ra -! | -! Rb -! | -! z0 --------- Cc -! | -! Rc -! | -! --------- Ccomp_tot -! -! The effective Rc is defined such that instead of using +! +! zr --------- Catm +! | +! Ra +! | +! Rb +! | +! z0 --------- Cc +! | +! Rc +! | +! --------- Ccomp_tot +! +! The effective Rc is defined such that instead of using ! ! F = -vd*[Catm - Ccomp_tot] (1) ! -! we can use the 'normal' flux formula +! we can use the 'normal' flux formula ! ! F = -vd'*Catm, (2) ! ! with vd' = 1/(Ra + Rb + Rc') (3) ! -! and Rc' the effective Rc (rc_eff). -! (Catm - Ccomp_tot) +! and Rc' the effective Rc (rc_eff). +! (Catm - Ccomp_tot) ! vd'*Catm = vd*(Catm - Ccomp_tot) <=> vd' = vd* ------------------ ! Catm ! -! (Catm - Ccomp_tot) +! (Catm - Ccomp_tot) ! 1/(Ra + Rb + Rc') = (1/Ra + Rb + Rc) * ------------------ ! Catm ! ! Catm ! (Ra + Rb + Rc') = (Ra + Rb + Rc) * ------------------ -! (Catm - Ccomp_tot) +! (Catm - Ccomp_tot) ! ! Catm ! Rc' = (Ra + Rb + Rc) * ------------------ - Ra - Rb -! (Catm - Ccomp_tot) +! (Catm - Ccomp_tot) ! ! Catm Catm -! Rc' = (Ra + Rb) [------------------ - 1 ] + Rc * ------------------ -! (Catm - Ccomp_tot) (Catm - Ccomp_tot) +! Rc' = (Ra + Rb) [------------------ - 1 ] + Rc * ------------------ +! (Catm - Ccomp_tot) (Catm - Ccomp_tot) ! -! Rc' = [(Ra + Rb)*Ccomp_tot + Rc*Catm ] / (Catm - Ccomp_tot) +! Rc' = [(Ra + Rb)*Ccomp_tot + Rc*Catm ] / (Catm - Ccomp_tot) ! ! This is not the most efficient way to do this; ! in the current LE version, (1) is used directly in the calling routine @@ -1734,9 +1734,9 @@ end subroutine rc_comp_point ! ------------------------------------------------------------------------------------------- ! In fact it is the question if this correct; note the difference in differential equations ! -! dCatm ! dCatm -! H ----- = F = -vd'*Catm, ! H ----- = F = -vd*[Catm - Ccomp_tot], -! dt ! dt +! dCatm ! dCatm +! H ----- = F = -vd'*Catm, ! H ----- = F = -vd*[Catm - Ccomp_tot], +! dt ! dt ! ! where in the left colum vd' is a function of Catm and not a constant anymore. ! @@ -1746,7 +1746,7 @@ end subroutine rc_comp_point subroutine rc_comp_point_rc_eff(ccomp_tot,catm,ra,rb,rc_tot,rc_eff) -implicit none +implicit none ! Input/output variables: real, intent(in) :: ccomp_tot ! total compensation point (weighed average of separate compensation points) (ug/m3) @@ -1758,7 +1758,7 @@ subroutine rc_comp_point_rc_eff(ccomp_tot,catm,ra,rb,rc_tot,rc_eff) ! Compute effective resistance: if (catm .ne. ccomp_tot)then - rc_eff = ((ra + rb)*ccomp_tot + rc_tot*catm)/(catm-ccomp_tot) + rc_eff = ((ra + rb)*ccomp_tot + rc_tot*catm)/(catm-ccomp_tot) else ! rc_eff = -999. ! no flux, resistance undefined rc_eff = -9999. ! no flux, resistance undefined diff --git a/m_error.f90 b/m_error.f90 index ae5868f..1aae754 100644 --- a/m_error.f90 +++ b/m_error.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-F90 ! DESCRIPTION : Handling of errors occurring in ops. @@ -82,7 +82,7 @@ MODULE m_error !------------------------------------------------------------------------------------------------------------------------------- TYPE TError LOGICAL :: haserror ! error has occurred - LOGICAL :: blockparam ! + LOGICAL :: blockparam CHARACTER*512 :: message ! string with error message TYPE (TErrorCall), pointer :: callroutines ! call stack @@ -253,7 +253,7 @@ FUNCTION set_error(error) TYPE (TError), INTENT(INOUT) :: error ! error object ! FUNCTION RESULT -LOGICAL :: set_error ! +LOGICAL :: set_error !------------------------------------------------------------------------------------------------------------------------------- IF (error%haserror) THEN @@ -344,14 +344,14 @@ SUBROUTINE error_lparam(paramname, value, error) !DEC$ ATTRIBUTES DLLEXPORT:: error_lparam ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: paramname ! -LOGICAL, INTENT(IN) :: value ! +CHARACTER*(*), INTENT(IN) :: paramname +LOGICAL, INTENT(IN) :: value ! SUBROUTINE ARGUMENTS - I/O -TYPE (TError), INTENT(INOUT) :: error ! +TYPE (TError), INTENT(INOUT) :: error ! LOCAL VARIABLES -TYPE (TErrorParam), POINTER :: param ! +TYPE (TErrorParam), POINTER :: param !------------------------------------------------------------------------------------------------------------------------------- IF (.NOT.error%blockparam) THEN @@ -371,14 +371,14 @@ SUBROUTINE error_rparam(paramname, value, error) !DEC$ ATTRIBUTES DLLEXPORT:: error_rparam ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: paramname ! -REAL*4, INTENT(IN) :: value ! +CHARACTER*(*), INTENT(IN) :: paramname +REAL*4, INTENT(IN) :: value ! SUBROUTINE ARGUMENTS - I/O -TYPE (TError), INTENT(INOUT) :: error ! +TYPE (TError), INTENT(INOUT) :: error ! LOCAL VARIABLES -TYPE (TErrorParam), POINTER :: param ! +TYPE (TErrorParam), POINTER :: param !------------------------------------------------------------------------------------------------------------------------------- IF (.NOT.error%blockparam) THEN param => make_parameter(paramname, error) @@ -397,14 +397,14 @@ SUBROUTINE error_raparam(paramname, value, error) !DEC$ ATTRIBUTES DLLEXPORT:: error_raparam ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: paramname ! -REAL*4, INTENT(IN) :: value(:) ! +CHARACTER*(*), INTENT(IN) :: paramname +REAL*4, INTENT(IN) :: value(:) ! SUBROUTINE ARGUMENTS - I/O -TYPE (TError), INTENT(INOUT) :: error ! +TYPE (TError), INTENT(INOUT) :: error ! LOCAL VARIABLES -TYPE (TErrorParam), POINTER :: param ! +TYPE (TErrorParam), POINTER :: param INTEGER*4 :: i !------------------------------------------------------------------------------------------------------------------------------- IF (.NOT.error%blockparam) THEN @@ -427,11 +427,11 @@ SUBROUTINE error_sparam(paramname, value, error) !DEC$ ATTRIBUTES DLLEXPORT:: error_sparam ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: paramname ! -CHARACTER*(*), INTENT(IN) :: value ! +CHARACTER*(*), INTENT(IN) :: paramname +CHARACTER*(*), INTENT(IN) :: value ! SUBROUTINE ARGUMENTS - I/O -TYPE (TError), INTENT(INOUT) :: error ! +TYPE (TError), INTENT(INOUT) :: error !------------------------------------------------------------------------------------------------------------------------------- CALL ErrorParam(paramname, value, .FALSE., error) @@ -448,18 +448,18 @@ SUBROUTINE error_wparam(paramname, value, wordonly, error) !DEC$ ATTRIBUTES DLLEXPORT:: error_wparam ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: paramname ! -CHARACTER*(*), INTENT(IN) :: value ! -LOGICAL, INTENT(IN) :: wordonly ! +CHARACTER*(*), INTENT(IN) :: paramname +CHARACTER*(*), INTENT(IN) :: value +LOGICAL, INTENT(IN) :: wordonly ! SUBROUTINE ARGUMENTS - I/O -TYPE (TError), INTENT(INOUT) :: error ! +TYPE (TError), INTENT(INOUT) :: error ! LOCAL VARIABLES -INTEGER*4 :: startpos ! -INTEGER*4 :: endpos ! -INTEGER*4 :: length ! -TYPE (TErrorParam), POINTER :: param ! +INTEGER*4 :: startpos +INTEGER*4 :: endpos +INTEGER*4 :: length +TYPE (TErrorParam), POINTER :: param !------------------------------------------------------------------------------------------------------------------------------- IF (.NOT.error%blockparam) THEN @@ -514,11 +514,11 @@ SUBROUTINE error_saparam(paramname, value, error) !DEC$ ATTRIBUTES DLLEXPORT:: error_saparam ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: paramname ! -CHARACTER*(*), INTENT(IN) :: value(:) ! +CHARACTER*(*), INTENT(IN) :: paramname +CHARACTER*(*), INTENT(IN) :: value(:) ! SUBROUTINE ARGUMENTS - I/O -TYPE (TError), INTENT(INOUT) :: error ! +TYPE (TError), INTENT(INOUT) :: error ! LOCAL integer :: i ! index @@ -546,13 +546,13 @@ SUBROUTINE error_call(routinename, error) !DEC$ ATTRIBUTES DLLEXPORT:: error_call ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: routinename ! +CHARACTER*(*), INTENT(IN) :: routinename ! SUBROUTINE ARGUMENTS - I/O -TYPE (TError), INTENT(INOUT) :: error ! +TYPE (TError), INTENT(INOUT) :: error ! LOCAL VARIABLES -TYPE (TErrorCall), POINTER :: caller ! +TYPE (TErrorCall), POINTER :: caller !------------------------------------------------------------------------------------------------------------------------------- ! @@ -585,19 +585,19 @@ SUBROUTINE write_error(unit, error) !DEC$ ATTRIBUTES DLLEXPORT:: write_error ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: unit ! -TYPE (TError), INTENT(IN) :: error ! +INTEGER*4, INTENT(IN) :: unit +TYPE (TError), INTENT(IN) :: error ! LOCAL VARIABLES -INTEGER*4 :: length ! -INTEGER*4 :: maxlen ! -LOGICAL :: hascaller ! +INTEGER*4 :: length +INTEGER*4 :: maxlen +LOGICAL :: hascaller -TYPE (TErrorParam), POINTER :: param ! -TYPE (TErrorParam), POINTER :: nextparam ! +TYPE (TErrorParam), POINTER :: param +TYPE (TErrorParam), POINTER :: nextparam -TYPE (TErrorCall), POINTER :: caller ! -TYPE (TErrorCall), POINTER :: nextcaller ! +TYPE (TErrorCall), POINTER :: caller +TYPE (TErrorCall), POINTER :: nextcaller !------------------------------------------------------------------------------------------------------------------------------- ! @@ -657,7 +657,7 @@ SUBROUTINE write_error(unit, error) WRITE(unit,'(/, 3A)') 'Procedure ''', caller%routinename(1:length), ''' was called by:' ENDIF DEALLOCATE(caller) - + DO WHILE (ASSOCIATED(nextcaller)) caller => nextcaller nextcaller => caller%nextcall @@ -686,13 +686,13 @@ END SUBROUTINE write_error FUNCTION make_parameter(paramname, error) ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: paramname ! +CHARACTER*(*), INTENT(IN) :: paramname ! SUBROUTINE ARGUMENTS - I/O -TYPE (TError), INTENT(INOUT) :: error ! +TYPE (TError), INTENT(INOUT) :: error ! FUNCTION RESULT -TYPE (TErrorParam), pointer :: make_parameter ! +TYPE (TErrorParam), pointer :: make_parameter !------------------------------------------------------------------------------------------------------------------------------- ! ! Allocate memory for new parameter @@ -760,8 +760,8 @@ SUBROUTINE simple_sb_copy(indentpos, sourcestring, targetstring) CHARACTER*(*), INTENT(INOUT) :: targetstring ! string where copied to ! LOCAL VARIABLES -INTEGER*4 :: sourcelength ! -INTEGER*4 :: maxlength ! +INTEGER*4 :: sourcelength +INTEGER*4 :: maxlength !------------------------------------------------------------------------------------------------------------------------------- ! @@ -814,7 +814,7 @@ SUBROUTINE simple_sb_append(nrblanks, sourcestring, targetstring) !DEC$ ATTRIBUTES DLLEXPORT:: simple_sb_append ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: nrblanks ! +INTEGER*4, INTENT(IN) :: nrblanks CHARACTER*(*), INTENT(IN) :: sourcestring ! string to be appended ! SUBROUTINE ARGUMENTS - I/O @@ -875,7 +875,7 @@ SUBROUTINE simple_lb_append(nrblanks, value, targetstring) !DEC$ ATTRIBUTES DLLEXPORT:: simple_lb_append ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: nrblanks ! +INTEGER*4, INTENT(IN) :: nrblanks LOGICAL, INTENT(IN) :: value ! logical whose value is to be appended. ! SUBROUTINE ARGUMENTS - I/O @@ -919,7 +919,7 @@ SUBROUTINE simple_ib_append(nrblanks, intvalue, targetstring) !DEC$ ATTRIBUTES DLLEXPORT:: simple_ib_append ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: nrblanks ! +INTEGER*4, INTENT(IN) :: nrblanks INTEGER*4, INTENT(IN) :: intvalue ! string to be appended ! SUBROUTINE ARGUMENTS - I/O @@ -1018,7 +1018,7 @@ SUBROUTINE simple_rb_append(nrblanks, realvalue, significance, targetstring) USE m_commonconst ! EPS_DELTA only ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: nrblanks ! +INTEGER*4, INTENT(IN) :: nrblanks REAL*4, INTENT(IN) :: realvalue ! string to be appended INTEGER*4, INTENT(IN) :: significance ! number of significant digits @@ -1034,7 +1034,7 @@ SUBROUTINE simple_rb_append(nrblanks, realvalue, significance, targetstring) INTEGER*4 :: intcopy ! copy of significant realvalue INTEGER*4 :: intcopy2 ! copy of significant realvalue INTEGER*4 :: char0 ! '0' character -LOGICAL :: negative ! +LOGICAL :: negative !------------------------------------------------------------------------------------------------------------------------------- ! @@ -1137,13 +1137,13 @@ END SUBROUTINE simple_rb_append FUNCTION appendblanks(nrblanks, targetstring) ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: nrblanks ! +INTEGER*4, INTENT(IN) :: nrblanks ! SUBROUTINE ARGUMENTS - I/O CHARACTER*(*), INTENT(INOUT) :: targetstring ! string waarachter wordt geplakt ! FUNCTION RESULT -INTEGER*4 :: appendblanks ! +INTEGER*4 :: appendblanks ! LOCAL VARIABLES INTEGER*4 :: position ! insertion position in targetstring diff --git a/m_fileutils.f90 b/m_fileutils.f90 index 3b77498..4d8bc09 100644 --- a/m_fileutils.f90 +++ b/m_fileutils.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO/IS ! LANGUAGE : FORTRAN-90 ! DESCRIPTION : This module contains all utilities handling files. @@ -79,7 +79,7 @@ MODULE m_fileutils ! PURPOSE : Checking the existence of a file. If the file does not exist the error message is assigned. The callback of the ! error is not assigned, so that it appears the non-existing error is detected in the calling procedure (which is ! what the user wants to know). -! AUTHOR : OPS-support . +! AUTHOR : OPS-support ! INPUTS : fname (character*(*)). The full path of the file. ! OUTPUTS : error (type TError). Is assigned when the file does not exist. ! RESULT : .TRUE. when the file exists, .FALSE. if not. @@ -91,7 +91,7 @@ MODULE m_fileutils !------------------------------------------------------------------------------------------------------------------------------- ! FUNCTION : sysopen ! PURPOSE : Opens a file for reading or writing. -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! INPUTS : iu (integer*4). Unit number of file. ! filename (character*(*)). Path of file to be opened. ! rw (character*(*)). Whether reading or writing. Options: @@ -112,7 +112,7 @@ MODULE m_fileutils !------------------------------------------------------------------------------------------------------------------------------- ! SUBROUTINE : sysclose ! PURPOSE : Closes a file. Low level. -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! ADAPTATIONS : 2002 - Error handling through error object (Martien de Haan, ARIS). ! INPUTS : iu (integer*4). Unit number of file. ! filename (character*(*)). Name of file. Only relevant when error is written. @@ -126,7 +126,7 @@ MODULE m_fileutils ! SUBROUTINE : sysread ! PURPOSE : Reads a string from an input device. ! PRECONDITION: Input file: Ascii, recordlength <= 512 -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! ADAPTATIONS : 2002 - Error handling through error object (Martien de Haan, ARIS). ! INPUTS : iu (integer*4). Unit number of file. ! OUTPUTS : end_of_file (logical) Whether end-of-file was reached, so that nothing was read. @@ -161,14 +161,14 @@ SUBROUTINE get_directory(fullpath, directory, error) !DEC$ ATTRIBUTES DLLEXPORT:: get_directory ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'get_directory') ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: fullpath ! +CHARACTER*(*), INTENT(IN) :: fullpath ! SUBROUTINE ARGUMENTS - OUTPUT -CHARACTER*(*), INTENT(OUT) :: directory ! +CHARACTER*(*), INTENT(OUT) :: directory TYPE (TError), INTENT(OUT) :: error ! error handling record ! LOCAL VARIABLES @@ -178,7 +178,7 @@ SUBROUTINE get_directory(fullpath, directory, error) CHARACTER*1 :: slash ! directory separator (\ or /) ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'// char (0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -221,14 +221,14 @@ SUBROUTINE get_filename(fullpath, filename, error) !DEC$ ATTRIBUTES DLLEXPORT:: get_filename ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'get_filename') ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: fullpath ! +CHARACTER*(*), INTENT(IN) :: fullpath ! SUBROUTINE ARGUMENTS - OUTPUT -CHARACTER*(*), INTENT(OUT) :: filename ! +CHARACTER*(*), INTENT(OUT) :: filename TYPE (TError), INTENT(OUT) :: error ! error handling record ! ! LOCAL VARIABLES @@ -278,7 +278,7 @@ FUNCTION chk_file_exist(fname, error) !DEC$ ATTRIBUTES DLLEXPORT:: chk_file_exist ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'chk_file_exist') ! SUBROUTINE ARGUMENTS - INPUT @@ -288,10 +288,10 @@ FUNCTION chk_file_exist(fname, error) TYPE (TError), INTENT(OUT) :: error ! error handling record ! FUNCTION RESULT -LOGICAL :: chk_file_exist ! +LOGICAL :: chk_file_exist ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'// char (0) !------------------------------------------------------------------------------------------------------------------------------- INQUIRE (FILE = fname, EXIST = chk_file_exist) @@ -318,10 +318,10 @@ FUNCTION sys_open_file(iu, filename, rw, filetype, error, LREC) CHARACTER*(*), INTENT(IN) :: filename ! File path CHARACTER*(*), INTENT(IN) :: rw ! Whether reading or writing (see interface) CHARACTER*(*), INTENT(IN) :: filetype ! Type of the file, written in error messages +INTEGER, INTENT(IN), OPTIONAL :: LREC ! Lenght of a direct access record ! SUBROUTINE ARGUMENTS - OUTPUT TYPE (TError), INTENT(OUT) :: error ! Error handling record -INTEGER, INTENT(OUT), OPTIONAL :: LREC ! Lenght of a direct access record ! FUNCTION RESULT LOGICAL :: sys_open_file ! .FALSE. when error detected @@ -335,8 +335,8 @@ FUNCTION sys_open_file(iu, filename, rw, filetype, error, LREC) LOGICAL :: isdirect ! Whether reading/writing binary file ! CONSTANTS -CHARACTER*512 :: tmp_ROUTINENAAM ! -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: tmp_ROUTINENAAM +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'sysopen') !------------------------------------------------------------------------------------------------------------------------------- @@ -447,11 +447,11 @@ SUBROUTINE sys_close_file(iu, filename, error) INTEGER*4 :: io_status ! Status of I/O action ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'sysclose') ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'// char (0) !------------------------------------------------------------------------------------------------------------------------------- CLOSE (iu, IOSTAT = io_status) @@ -470,13 +470,13 @@ END SUBROUTINE sys_close_file !------------------------------------------------------------------------------------------------------------------------------- ! SUBROUTINE: sysopen_read ! PURPOSE : Opening of text file for reading. See interface definition -! AUTHOR : OPS-support +! AUTHOR : OPS-support !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE sysopen_read(iu, fnam, io_status) ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: iu ! -CHARACTER*(*), INTENT(IN) :: fnam ! +INTEGER*4, INTENT(IN) :: iu +CHARACTER*(*), INTENT(IN) :: fnam ! SUBROUTINE ARGUMENTS - OUTPUT INTEGER*4, INTENT(OUT) :: io_status ! Status of I/O action @@ -485,7 +485,7 @@ SUBROUTINE sysopen_read(iu, fnam, io_status) INTEGER*4 :: flen ! Length of filename ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'// char (0) !------------------------------------------------------------------------------------------------------------------------------- flen = LEN_TRIM(fnam) @@ -502,19 +502,19 @@ END SUBROUTINE sysopen_read !------------------------------------------------------------------------------------------------------------------------------- ! SUBROUTINE: sysopen_read_bin ! PURPOSE : Opening of binary file for reading. -! AUTHOR : OPS-support +! AUTHOR : OPS-support !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE sysopen_read_bin(iu, fnam, io_status) ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: iu ! -CHARACTER*(*), INTENT(IN) :: fnam ! +INTEGER*4, INTENT(IN) :: iu +CHARACTER*(*), INTENT(IN) :: fnam ! SUBROUTINE ARGUMENTS - OUTPUT INTEGER*4, INTENT(OUT) :: io_status ! Status of I/O action ! LOCAL VARIABLES -INTEGER*4 :: flen ! +INTEGER*4 :: flen !------------------------------------------------------------------------------------------------------------------------------- flen = LEN_TRIM(fnam) @@ -531,7 +531,7 @@ END SUBROUTINE sysopen_read_bin !------------------------------------------------------------------------------------------------------------------------------- ! SUBROUTINE: sysopen_write ! PURPOSE : Opening of text file for writing. -! AUTHOR : OPS-support +! AUTHOR : OPS-support !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE sysopen_write(iu, fnam, io_status) @@ -550,7 +550,7 @@ SUBROUTINE sysopen_write(iu, fnam, io_status) INTEGER*4 :: flen ! Length of filename ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'// char (0) !------------------------------------------------------------------------------------------------------------------------------- flen = LEN_TRIM(fnam) @@ -567,7 +567,7 @@ END SUBROUTINE sysopen_write !------------------------------------------------------------------------------------------------------------------------------- ! SUBROUTINE: sysopen_direct ! PURPOSE : Opening of direct-access file for reading. -! AUTHOR : OPS-support +! AUTHOR : OPS-support !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE sysopen_direct(iu, fnam, LREC, io_status) @@ -587,7 +587,7 @@ SUBROUTINE sysopen_direct(iu, fnam, LREC, io_status) INTEGER*4 :: flen ! Length of filename ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'// char (0) !------------------------------------------------------------------------------------------------------------------------------- flen = LEN_TRIM(fnam) @@ -604,14 +604,14 @@ END SUBROUTINE sysopen_direct !------------------------------------------------------------------------------------------------------------------------------- ! SUBROUTINE: sysread ! PURPOSE : Reading a string from a file -! AUTHOR : OPS-support +! AUTHOR : OPS-support !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE sys_read_string(fdin, in_str, end_of_file, error) !DEC$ ATTRIBUTES DLLEXPORT:: sys_read_string ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'sys_read_string') ! SUBROUTINE ARGUMENTS - INPUT @@ -626,7 +626,7 @@ SUBROUTINE sys_read_string(fdin, in_str, end_of_file, error) INTEGER*4 :: io_status ! Status of IO-actions ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'// char (0) !------------------------------------------------------------------------------------------------------------------------------- end_of_file = .FALSE. diff --git a/m_geoutils.f90 b/m_geoutils.f90 index 9aee7a2..a42f8f0 100644 --- a/m_geoutils.f90 +++ b/m_geoutils.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -29,13 +29,13 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM LLO ! LANGUAGE : FORTRAN-90 ! DESCRIPTION : This module contains geographical utilities. ! : - amcgeo: conversion of RDM to geographical lon-lat coordinates ! : - flrs: conversion of geographical lon-lat coordinates to RDM coordinates -! RDM coordinates are based on a km grid over the Netherlands, centred at Amersfoort; +! RDM coordinates are based on a km grid over the Netherlands, centred at Amersfoort; ! RDM coordinates are also called "Amersfoortse coordinaten". RDM stands for RijksDriehoeksMeting, ! since this grid is determined by triangulation (driehoek = triangle) measurements (meting = meeasurements) ! of the Netherlands government (Rijk ~ government). @@ -56,7 +56,7 @@ MODULE m_geoutils ! SUBROUTINE : amc2geo ! PURPOSE : conversion of RDM to geographical lon-lat coordinates ! DESCRIPTION : Given input RDM coordinates (x,y), amcgeo uses an iterative method to compute the geographical coordinates (gl,gb). -! Given an initial guess for (geol,geob), the corresponding RDM coordinates (x0,y0) are computed and compared with the +! Given an initial guess for (geol,geob), the corresponding RDM coordinates (x0,y0) are computed and compared with the ! input coordinates (amcx,amcy). In a next step, (geol,geob) are adjusted as function of the difference (dx,dy) = (xi-x,yi-y). ! This iterative procedure continues until (dx,dy) is samller than a specified threshold (difx,dify). ! limits: ca. 10000 km oost (y < 3000 km) 100 lon 16 lat @@ -127,7 +127,7 @@ SUBROUTINE amc2geo(amcx, amcy, geol, geob) USE m_commonconst ! EPS_DELTA only ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'amc2geo') ! SUBROUTINE ARGUMENTS - INPUT @@ -148,7 +148,7 @@ SUBROUTINE amc2geo(amcx, amcy, geol, geob) REAL*4 :: amcy0 ! RDM y-coordinate that corresponds with (gb,gl) ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- @@ -174,7 +174,7 @@ SUBROUTINE amc2geo(amcx, amcy, geol, geob) !----------------------------- 50 CONTINUE - ! Compute (x0,y0) = RDM coordinates that correspond with (gb,gl) + ! Compute (x0,y0) = RDM coordinates that correspond with (gb,gl) CALL geo2amc(geob, geol, amcx0, amcy0) ! Compute difference between input (x,y) and iterand (x0,y0); if x or y is relatively large, @@ -196,19 +196,19 @@ SUBROUTINE amc2geo(amcx, amcy, geol, geob) ! No convergence yet; adjust lon-lat for next iteration; ! 111.1984 is R*CONV = R*180/pi in km, with R = earth radius. See also ops_reken geob = geob + (dy/111.1984) - geol = geol + (dx/(111.1984*COS(geob/57.2958))) + geol = geol + (dx/(111.1984*COS(geob/57.2958))) tel = tel + 1 - + ! Goto next iteration (if number of iterations < 300): IF (tel .LT. 300) THEN GOTO 50 ENDIF - + ! WRITE (*, '( '' x and/or y coord. in subr. amcgeo beyond limits'')') ! WRITE (*, '( '' x ='', f6.0, '' y ='', f6.0, '' km'')') x, y - + ENDIF - + ! Iteration has converged or tel >= 300 RETURN @@ -224,14 +224,14 @@ SUBROUTINE geo2amc(geob, geol, amcx, amcy) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'geo2amc') ! CONSTANTS REAL*4 :: AMFI ! longitude (phi) of Amersfoort (centre of RDM grid) REAL*4 :: AMLA ! latitude (lambda) of Amersfoort (centre of RDM grid) -PARAMETER (AMFI = 18.7762) -PARAMETER (AMLA = 1.9395) +PARAMETER (AMFI = 18.7762) +PARAMETER (AMLA = 1.9395) ! 1 degree = 3600 seconds; AMFI, AMLA in units of 10000 seconds; conversion factor to degrees = 10000/3600: ! 10000*[AMFI, AMLA]/3600 = [AMFI, AMLA]/0.36 = [18.7762 1.9395]/0.36 = [52.1561 5.3875] = [Lat, Lon]_Amersfoort @@ -244,11 +244,11 @@ SUBROUTINE geo2amc(geob, geol, amcx, amcy) REAL*4, INTENT(OUT) :: amcy ! RDM y-coordinate (km ! LOCAL VARIABLES -REAL*4 :: f1 ! -REAL*4 :: l1 ! +REAL*4 :: f1 +REAL*4 :: l1 ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- @@ -272,7 +272,7 @@ SUBROUTINE amc2lam(amcx, amcy, lamx, lamy) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'amc2lam') ! CONSTANTS @@ -290,7 +290,7 @@ SUBROUTINE amc2lam(amcx, amcy, lamx, lamy) REAL*4 :: geob ! hulpvariabele voor lambda ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -317,7 +317,7 @@ SUBROUTINE geo2lam(geob, geol, lamx, lamy) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'geo2lam') ! CONSTANTS @@ -359,11 +359,11 @@ SUBROUTINE geo2lam(geob, geol, lamx, lamy) real*8 :: y ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! -! Documentation: http://mathworld.wolfram.com/LambertAzimuthalEqual-AreaProjection.html +! Documentation: http://mathworld.wolfram.com/LambertAzimuthalEqual-AreaProjection.html ! lat = dble(geob) lon = dble(geol) diff --git a/m_getkey.f90 b/m_getkey.f90 index 2542ab4..b64b782 100644 --- a/m_getkey.f90 +++ b/m_getkey.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -28,7 +28,7 @@ ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-90 ! DESCRIPTION : Checks name of parameter and extracts a value for that parameter, or sets a default. @@ -123,18 +123,18 @@ FUNCTION get_key_integer(parname, value, error) !DEC$ ATTRIBUTES DLLEXPORT:: get_key_integer ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: parname ! +CHARACTER*(*), INTENT(IN) :: parname ! SUBROUTINE ARGUMENTS - OUTPUT -INTEGER*4, INTENT(OUT) :: value ! +INTEGER*4, INTENT(OUT) :: value TYPE (TError), INTENT(OUT) :: error ! Error handling record ! RESULT -LOGICAL :: get_key_integer ! +LOGICAL :: get_key_integer ! LOCAL VARIABLES -LOGICAL :: isdefault ! -CHARACTER*512 :: string ! +LOGICAL :: isdefault +CHARACTER*512 :: string !------------------------------------------------------------------------------------------------------------------------------- ! ! Check presence of parname and determine which part of the string should contain the value. @@ -173,18 +173,18 @@ FUNCTION get_key_logical(parname, isrequired, value, error) !DEC$ ATTRIBUTES DLLEXPORT:: get_key_logical ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: parname ! -LOGICAL, INTENT(IN) :: isrequired ! +CHARACTER*(*), INTENT(IN) :: parname +LOGICAL, INTENT(IN) :: isrequired ! SUBROUTINE ARGUMENTS - OUTPUT -LOGICAL, INTENT(OUT) :: value ! +LOGICAL, INTENT(OUT) :: value TYPE (TError), INTENT(OUT) :: error ! Error handling record ! LOCAL VARIABLES -INTEGER*4 :: intvalue ! +INTEGER*4 :: intvalue ! RESULT -LOGICAL :: get_key_logical ! +LOGICAL :: get_key_logical !------------------------------------------------------------------------------------------------------------------------------- ! @@ -227,18 +227,18 @@ FUNCTION get_key_real(parname, value, error) !DEC$ ATTRIBUTES DLLEXPORT:: get_key_real ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: parname ! +CHARACTER*(*), INTENT(IN) :: parname ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: value ! +REAL*4, INTENT(OUT) :: value TYPE (TError), INTENT(OUT) :: error ! Error handling record ! RESULT -LOGICAL :: get_key_real ! +LOGICAL :: get_key_real ! LOCAL VARIABLES -LOGICAL :: nopart ! -CHARACTER*512 :: string ! +LOGICAL :: nopart +CHARACTER*512 :: string !------------------------------------------------------------------------------------------------------------------------------- ! ! Check the validity of the keyword and determine which part of the string should contain the value. @@ -278,21 +278,21 @@ FUNCTION get_key_string(parname, string, error) !DEC$ ATTRIBUTES DLLEXPORT:: get_key_string ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: parname ! +CHARACTER*(*), INTENT(IN) :: parname ! SUBROUTINE ARGUMENTS - OUTPUT CHARACTER*(*), INTENT(OUT) :: string ! parameter value TYPE (TError), INTENT(OUT) :: error ! Error handling record ! RESULT -LOGICAL :: get_key_string ! +LOGICAL :: get_key_string ! LOCAL VARIABLES -INTEGER*4 :: length ! -INTEGER*4 :: cutpos ! -INTEGER*4 :: position ! -INTEGER*4 :: blankpos ! -LOGICAL :: stillblank ! +INTEGER*4 :: length +INTEGER*4 :: cutpos +INTEGER*4 :: position +INTEGER*4 :: blankpos +LOGICAL :: stillblank !------------------------------------------------------------------------------------------------------------------------------- ! ! Check whether a parname is located in string and determine the value of the parameter in the string. @@ -300,7 +300,7 @@ FUNCTION get_key_string(parname, string, error) get_key_string = checkparname(parname,string,error) IF (error%haserror) GOTO 9999 ! -! Move up until we reach commentary. Remove the commentary. This is either the first character a a blank followed by a ! +! Move up until we reach commentary. Remove the commentary. This is either the first character a a blank followed by a ! length = LEN_TRIM(string) IF (length.GT.0) THEN @@ -361,12 +361,12 @@ FUNCTION checkparname(parname, string, error) TYPE (TError), INTENT(OUT) :: error ! error handling record ! RESULT -LOGICAL :: checkparname ! +LOGICAL :: checkparname ! CONSTANTS INTEGER*4 :: capsdiff ! 'A' - 'a' PARAMETER (capsdiff = ichar('A')-ichar('a')) -CHARACTER*14 :: ROUTINENAAM ! +CHARACTER*14 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'checkparname') ! LOCAL VARIABLES @@ -505,7 +505,7 @@ SUBROUTINE cutfromstring(startpos, endpos, string) INTEGER*4 :: newendpos ! new string length ! CONSTANTS -CHARACTER*14 :: ROUTINENAAM ! +CHARACTER*14 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'cutfromstring') ! lengte = LEN(string) @@ -528,7 +528,7 @@ FUNCTION check_range_real(parname,lower,upper,isrequired, value, error) !DEC$ ATTRIBUTES DLLEXPORT:: check_range_real ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: parname ! +CHARACTER*(*), INTENT(IN) :: parname REAL*4, INTENT(IN) :: lower ! lower limit of value REAL*4, INTENT(IN) :: upper ! upper limit of value LOGICAL, INTENT(IN) :: isrequired ! whether a value is required @@ -538,7 +538,7 @@ FUNCTION check_range_real(parname,lower,upper,isrequired, value, error) TYPE (TError), INTENT(OUT) :: error ! error handling record ! RESULT -LOGICAL :: check_range_real ! +LOGICAL :: check_range_real !------------------------------------------------------------------------------------------------------------------------------- ! @@ -592,7 +592,7 @@ FUNCTION check_range_integer(parname, lower, upper, isrequired, value, error) !DEC$ ATTRIBUTES DLLEXPORT:: check_range_integer ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: parname ! +CHARACTER*(*), INTENT(IN) :: parname INTEGER*4, INTENT(IN) :: lower ! lower limit of value INTEGER*4, INTENT(IN) :: upper ! upper limit of value LOGICAL, INTENT(IN) :: isrequired ! whether a value is required @@ -602,7 +602,7 @@ FUNCTION check_range_integer(parname, lower, upper, isrequired, value, error) TYPE (TError), INTENT(OUT) :: error ! Error handling record ! RESULT -LOGICAL :: check_range_integer ! +LOGICAL :: check_range_integer !------------------------------------------------------------------------------------------------------------------------------- ! @@ -671,11 +671,12 @@ FUNCTION check_range_integer_array(parname, lower, upper, isrequired, nword, val INTEGER :: endpos ! end-position of a single word INTEGER :: endlpos ! end-position of a line INTEGER :: i ! loop-teller -INTEGER :: first ! TRUE is character is blank +LOGICAL :: first ! TRUE is character is blank CHARACTER*512 :: string ! Help-string ! RESULT -LOGICAL :: check_range_integer_array ! +LOGICAL :: check_range_integer_array +INTEGER :: inum !------------------------------------------------------------------------------------------------------------------------------- ! ! Retrieve the integer array value for parname. @@ -792,16 +793,16 @@ FUNCTION check_exist_file(parname, checkdefine, checkexist, filename, error) USE m_fileutils ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: parname ! +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 ! SUBROUTINE ARGUMENTS - OUTPUT -CHARACTER*(*), INTENT(OUT) :: filename ! +CHARACTER*(*), INTENT(OUT) :: filename TYPE (TError), INTENT(OUT) :: error ! error handling record ! RESULT -LOGICAL :: check_exist_file ! +LOGICAL :: check_exist_file !------------------------------------------------------------------------------------------------------------------------------- ! @@ -851,8 +852,8 @@ END FUNCTION check_exist_file ! DESCRIPTION : This function checks a string for the name of the parameter. Then the string value of the parameter is ! extracted and assigned to the parameter. ! If no value is extracted a default is set (empty string). If a value is extracted it is checked whether the value lies -! within input limits (for strings, the lower and upper limits are normally the same, which means that the input string -! must be equal to the limit values. +! within input limits (for strings, the lower and upper limits are normally the same, which means that the input string +! must be equal to the limit values. ! RESULT : False if an error was detected. ! CALLED FUNCTIONS : get_key !------------------------------------------------------------------------------------------------------------------------------- @@ -871,7 +872,7 @@ FUNCTION check_range_string(parname,lower,upper,isrequired, value, error) TYPE (TError), INTENT(OUT) :: error ! error handling record ! RESULT -LOGICAL :: check_range_string ! +LOGICAL :: check_range_string !------------------------------------------------------------------------------------------------------------------------------- ! diff --git a/m_ops_building.f90 b/m_ops_building.f90 index 90ef777..bdff721 100644 --- a/m_ops_building.f90 +++ b/m_ops_building.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 . +! module m_ops_building implicit none @@ -22,11 +22,11 @@ module m_ops_building ! 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, +! 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 +! p2 5.0 9.0 20.0 ! ** ! pn 10 20 30 40 50 60 ! @@ -34,11 +34,11 @@ module m_ops_building ! ! 2) Lookup table: ! Table with n + 1 columns containing the class indices for n parameters and the associated building effect factor. -! Example lookup table +! 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 1 2.20 ! 1 1 2 2.10 ! 1 1 3 1.90 ! 1 1 4 1.85 @@ -47,7 +47,7 @@ module m_ops_building ! 1 2 1 2.30 ! 1 2 2 2.15 ! ....... -! 3 2 5 1.26 +! 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. @@ -60,9 +60,19 @@ module m_ops_building 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 ! +! 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 +integer, parameter :: mBparms = 9 +character(len=200) :: CbuildingParamNames(mBparms) = & + (/'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 @@ -71,23 +81,23 @@ module m_ops_building 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) + 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 +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 + 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 + 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 +contains !----------------------------------------------------------------------------------- subroutine ops_building_file_names(error) @@ -125,16 +135,16 @@ subroutine ops_building_read_tables(buildingEffect, error) ! Output: type(tbuildingEffect), intent(out) :: buildingEffect ! structure containing data for building effect type(Terror), intent(out) :: error ! error handling record - -! Local: + +! 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, & +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: + +! Read building factors: call ops_building_read_building_factors(mClass, buildingEffect%nParam, nClassProd, buildingEffect%nClass, buildingEffect%buildingFactArray, error) if (error%haserror) goto 9999 @@ -145,31 +155,31 @@ subroutine ops_building_read_tables(buildingEffect, error) end subroutine ops_building_read_tables !----------------------------------------------------------------------------------- -subroutine ops_building_read_classes(mParam, mClass, & +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 + 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 + 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) :: 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 @@ -178,16 +188,22 @@ subroutine ops_building_read_classes(mParam, mClass, & 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 + character(100) :: paramNames(mParam) ! parameter names integer :: nClassSum ! sum of number of classes for each parameter +character(len=200) :: buildingParamNames(mBparms) +integer :: j + do j = 1, mBparms + buildingParamNames(j) = trim( CbuildingParamNames(j) ) + enddo + ! 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: @@ -202,30 +218,30 @@ subroutine ops_building_read_classes(mParam, mClass, & 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) + 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 + 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)) + 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)) - + nClassSum = sum(nClass(1:nParam)) + nClassProd = product(nClass(1:nParam)) + ! Check: if (ilast .ne. nClassSum) then - write(*,*) 'Internal programming error in ', ROUTINENAAM + write(*,*) 'Internal programming error in ', ROUTINENAAM write(*,*) 'ilast = ',ilast, ' nClassSum = ',nClassSum write(*,*) 'ilast must be nClassSum ' stop @@ -234,31 +250,31 @@ subroutine ops_building_read_classes(mParam, mClass, & ! 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) + 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 memory and fill class definition table ***** + allocate(classdefinitionArray(nClassSum)) - classdefinitionArray = classdefinitionArrayTemp(1: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))) + 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))) + 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) @@ -273,22 +289,22 @@ subroutine ops_building_read_building_factors(mClass, nParam, nClassProd, nClass use m_error use m_fileutils - ! **** Read factors for building effects table from file ***** + ! **** Read factors for building effects table from file ***** - CHARACTER*512, PARAMETER :: ROUTINENAAM = 'ops_building_read_building_factors' + 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 + 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: + ! Local: character(1000) :: line ! line read from file integer :: iLine ! index of line read (includes header line) integer :: iParam ! index of parameter @@ -300,82 +316,87 @@ subroutine ops_building_read_building_factors(mClass, nParam, nClassProd, nClass 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) +character(len=200) :: buildingParamNames(mBparms) +integer :: j + do j = 1, mBparms + buildingParamNames(j) = trim( CbuildingParamNames(j) ) + enddo ! Allocate memory for building effects table: - allocate(buildingFactArray(nClassProd)) + 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 + 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 ) + read( line, *) colNames(1:nParam+1 ) !write(*,*) 'Table ' - !write(*,'(99(1x,a))') colNames(1:nParam+1 ) - + !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) + 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('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: + + ! 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) + 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) + 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 @@ -385,43 +406,43 @@ subroutine ops_building_read_building_factors(mClass, nParam, nClassProd, nClass 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 + 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('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 + 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 !----------------------------------------------------------------------------------------- @@ -430,44 +451,44 @@ subroutine ops_building_get_function(nParam, valueArray, nClass, classdefinition ! 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 + 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 + ! Arguments for SILUPM ! Local variables for SILUPM - integer :: NTAB(2*nParam+1) - integer :: NDEG(nParam) - integer :: LUP(nParam) + 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 + real :: EOPT(6*nParam) ! error estimate + + ! Local: + integer :: iParam ! parameter index integer :: ix, iy ! loop indices - - ! print *, "Building effects table from within subroutine getbuildingEffect" + + ! print *, "Building effects table from within subroutine getbuildingEffect" ! do ix = 1,size(buildingFactArray) ! print *, ix, buildingFactArray(ix) ! enddo - -! ! Interpolate multidimensional table: + +! ! Interpolate multidimensional table: ! ! CALL SILUPM(NDIM, X, Y, NTAB, XT, YT, NDEG, LUP, IOPT, EOPT) ! ! NDIM = nParam ! ! X = ValueArray (input for a specific building) @@ -479,23 +500,23 @@ subroutine ops_building_get_function(nParam, valueArray, nClass, classdefinition ! ! 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(1) = 1 !IOPT(2) = 0 !IOPT(3) = 0 - IOPT(2) = 6*nParam; ! size(EOPT) + IOPT(2) = 6*nParam; ! size(EOPT) IOPT(3) = 0 - + ! Loop over distances for building effect function: - allocate(buildingFactFunction(size(buildingFactAngleSRxaxis),size(buildingFactDistances))) + allocate(buildingFactFunction(size(buildingFactAngleSRxaxis),size(buildingFactDistances))) - ! write(*,*) '===================================================================================' + ! write(*,*) '===================================================================================' ! write(*,*) 'ops_building_get_function/valueArray = ',ValueArray ! write(*,*) 'ops_building_get_function/buildingFactAngleSRxaxis: ', buildingFactAngleSRxaxis ! write(*,*) 'ops_building_get_function/buildingFactDistances: ', buildingFactDistances @@ -506,34 +527,34 @@ subroutine ops_building_get_function(nParam, valueArray, nClass, classdefinition ! 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) - + 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(*,*) '===================================================================================' - + ! 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) + call ErrorParam('error status (see documentation netlib/SILUPM) ', IOPT(1), error) endif - call ErrorParam('parameter names ', buildingParamNames, error) + call ErrorParam('parameter names ', CbuildingParamNames, error) call ErrorParam('parameter values ', valueArray, error) goto 9999 endif RETURN - + 9999 CALL ErrorCall(ROUTINENAAM, error) end subroutine ops_building_get_function @@ -552,11 +573,11 @@ end subroutine ops_building_get_function ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! 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. +! 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 @@ -571,11 +592,11 @@ SUBROUTINE ops_building_get_factor(buildingType, angle_SR_xaxis, dist, buildingF ! Note the cut-off value of 50 m from the source. ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_building_get_factor') ! SUBROUTINE ARGUMENTS - INPUT -INTEGER, INTENT(IN) :: buildingType ! = 0 -> no building effect (factor = 1) +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 @@ -597,7 +618,7 @@ SUBROUTINE ops_building_get_factor(buildingType, angle_SR_xaxis, dist, buildingF 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 @@ -626,24 +647,24 @@ real function interpol_2d(tabx,taby,f,nx,ny,x,y) 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 +! 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(*,*) ' 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(*,*) ' 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) + +! 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 @@ -672,58 +693,58 @@ 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: + ! 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) + 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 + n = n - 1 ! number of reals behind first column with parameter name end subroutine split1 !------------------------------------------------------------------------------------------- -subroutine split2( line, nParam, iClassRead, buildingFactInput) - +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 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 index 8d76f9d..5e09d1f 100644 --- a/m_ops_emis.f90 +++ b/m_ops_emis.f90 @@ -1,22 +1,22 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 . +! module m_ops_emis -! Emission module, contains subroutines to read emissions. - +! Emission module, contains subroutines to read emissions. + implicit none PRIVATE ! default for module @@ -42,7 +42,7 @@ SUBROUTINE ops_emis_read_header(fu_bron, brn_version, VsDs_opt, nrec, numbron, e IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_emis_read_header') ! SUBROUTINE ARGUMENTS - INPUT @@ -65,14 +65,14 @@ SUBROUTINE ops_emis_read_header(fu_bron, brn_version, VsDs_opt, nrec, numbron, e !------------------------------------------------------------------------------------------------------------------------------- -! Initialisation: +! 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. +VsDs_opt = .FALSE. ! Read first header line: CALL sysread(fu_bron, cbuf, end_of_info, error) @@ -103,7 +103,7 @@ SUBROUTINE ops_emis_read_header(fu_bron, brn_version, VsDs_opt, nrec, numbron, e 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) @@ -111,7 +111,7 @@ SUBROUTINE ops_emis_read_header(fu_bron, brn_version, VsDs_opt, nrec, numbron, e 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 @@ -133,7 +133,7 @@ SUBROUTINE ops_emis_read_annual1(fu_bron, icm, check_psd, presentcode, brn_versi ! 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 +! 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 @@ -147,7 +147,7 @@ SUBROUTINE ops_emis_read_annual1(fu_bron, icm, check_psd, presentcode, brn_versi IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_emis_read_annual1') ! SUBROUTINE ARGUMENTS - INPUT @@ -165,11 +165,11 @@ SUBROUTINE ops_emis_read_annual1(fu_bron, icm, check_psd, presentcode, brn_versi ! 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 +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) :: 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] @@ -190,8 +190,8 @@ SUBROUTINE ops_emis_read_annual1(fu_bron, icm, check_psd, presentcode, brn_versi ! 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]) +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] @@ -213,53 +213,53 @@ SUBROUTINE ops_emis_read_annual1(fu_bron, icm, check_psd, presentcode, brn_versi ! Read string cbuf from emission file: CALL sysread(fu_bron, cbuf, end_of_file, error) -IF (error%haserror) GOTO 9999 +IF (error%haserror) GOTO 9999 -IF (.NOT. end_of_file) THEN +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 + ! 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) - + 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))) - + 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 + + 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 - + ! 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 @@ -271,45 +271,45 @@ SUBROUTINE ops_emis_read_annual1(fu_bron, icm, check_psd, presentcode, brn_versi ENDIF ELSE !******************************************************* - ! Old brn-file, fixed format + ! 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) + + ! 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; + ! 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 .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; + ! 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 + ! 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 @@ -318,7 +318,7 @@ SUBROUTINE ops_emis_read_annual1(fu_bron, icm, check_psd, presentcode, brn_versi 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) + 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) @@ -330,7 +330,7 @@ SUBROUTINE ops_emis_read_annual1(fu_bron, icm, check_psd, presentcode, brn_versi 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) + 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) @@ -339,7 +339,7 @@ SUBROUTINE ops_emis_read_annual1(fu_bron, icm, check_psd, presentcode, brn_versi 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) @@ -353,26 +353,26 @@ SUBROUTINE ops_emis_read_annual1(fu_bron, icm, check_psd, presentcode, brn_versi 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 + 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. + ! 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 + IF (check_psd) THEN CALL check_verdeling(idgr, presentcode, 2, 4, 'idgr', error) ENDIF - IF (error%haserror) GOTO 9999 + IF (error%haserror) GOTO 9999 ELSE @@ -396,7 +396,7 @@ 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. +! this warning includes the record number of the source. ! Included for backward compatibility of old source files; better use check_source2. ! CALLED FUNCTIONS : !------------------------------------------------------------------------------------------------------------------------------- @@ -407,7 +407,7 @@ SUBROUTINE check_source(nr, varnaam, onder, boven, varwaarde, error) USE m_commonconst, only: EPS_DELTA ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'check_source') ! SUBROUTINE ARGUMENTS - INPUT @@ -492,7 +492,7 @@ 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. +! this warning includes the record number of the source. ! Included for backward compatibility of old source files; better use check_isource2. ! CALLED FUNCTIONS : !------------------------------------------------------------------------------------------------------------------------------- @@ -501,7 +501,7 @@ SUBROUTINE check_isource(nr, varnaam, onder, boven, varwaarde, error) USE m_error ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'check_source') ! SUBROUTINE ARGUMENTS - INPUT @@ -515,7 +515,7 @@ SUBROUTINE check_isource(nr, varnaam, onder, boven, varwaarde, error) TYPE (TError), INTENT(INOUT) :: error ! error handling record ! LOCAL VARIABLES -REAL*4 :: var ! help variable (= float(varwaarde)) +REAL*4 :: var ! help variable (= float(varwaarde)) var = FLOAT(varwaarde) CALL check_source(nr, varnaam, FLOAT(onder), FLOAT(boven), var, error) @@ -536,7 +536,7 @@ SUBROUTINE check_source2(varnaam, onder, boven, varwaarde, error) USE m_commonconst, only: EPS_DELTA ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'check_source2') ! SUBROUTINE ARGUMENTS - INPUT @@ -583,7 +583,7 @@ SUBROUTINE check_source3(warning1, varnaam, onder, boven, varwaarde, error) USE m_commonfile, only: fu_log ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'check_source3') ! SUBROUTINE ARGUMENTS - INPUT @@ -608,10 +608,10 @@ SUBROUTINE check_source3(warning1, varnaam, onder, boven, varwaarde, 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) @@ -633,7 +633,7 @@ SUBROUTINE check_isource2(varnaam, onder, boven, varwaarde, error) USE m_error ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'check_source2') ! SUBROUTINE ARGUMENTS - INPUT @@ -662,15 +662,15 @@ SUBROUTINE check_verdeling(icode, presentcode, stdclass, usdclass, parname, erro USE m_commonconst, only: MAXDISTR ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'check_verdeling') ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: icode ! code that has to be checked; +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) +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 @@ -718,7 +718,7 @@ SUBROUTINE check_stack_param(qww, VsDs_opt, D_stack, V_stack, Ts_stack_C, error) USE m_commonconst, only: EPS_DELTA ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'check_stack_param') ! SUBROUTINE ARGUMENTS - INPUT @@ -745,14 +745,14 @@ SUBROUTINE check_stack_param(qww, VsDs_opt, D_stack, V_stack, Ts_stack_C, error) if (is_missing(qww)) then CALL SetError('Heat content (Qw) must be specified', error) CALL ErrorParam('Qw', qww, error) - CALL ErrorCall(ROUTINENAAM, 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(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 @@ -761,7 +761,7 @@ SUBROUTINE check_stack_param(qww, VsDs_opt, D_stack, V_stack, Ts_stack_C, error) 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) + CALL ErrorCall(ROUTINENAAM, error) endif endif @@ -769,7 +769,7 @@ END SUBROUTINE check_stack_param !------------------------------------------------------------------------------------------------------------------------------- ! SUBROUTINE NAME : check_building_param -! DESCRIPTION : Check building parameters +! DESCRIPTION : Check building parameters ! CALLED FUNCTIONS : !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE check_building_param(building, hbron, qww, D_stack, V_stack, error) @@ -781,7 +781,7 @@ SUBROUTINE check_building_param(building, hbron, qww, D_stack, V_stack, error) USE m_commonfile, only: fu_log ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'check_building_param') ! Input: @@ -796,33 +796,35 @@ SUBROUTINE check_building_param(building, hbron, qww, D_stack, V_stack, error) ! Local: real :: wlratio ! ratio width/length building +LOGICAL :: ops_openlog ! function for opening log file +LOGICAL :: ierr ! 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 + 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 + + ! 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) + ! Open log file if not already open: + ierr = 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 + 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) @@ -832,9 +834,9 @@ SUBROUTINE check_building_param(building, hbron, qww, D_stack, V_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) diff --git a/m_ops_plumerise.f90 b/m_ops_plumerise.f90 index 64ac3bb..5cfcbfe 100644 --- a/m_ops_plumerise.f90 +++ b/m_ops_plumerise.f90 @@ -1,22 +1,22 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 . +! module m_ops_plumerise ! module m_ops_plumerise with plume rise due to either buoyancy or momentum -! Marina Sterk and 2018-02-20 +! OPS-Support 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 @@ -27,7 +27,7 @@ module m_ops_plumerise ! 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 :: 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 @@ -36,11 +36,11 @@ module m_ops_plumerise 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) @@ -54,12 +54,12 @@ subroutine ops_plumerise_prelim(istab, isek, astat, hemis0, qw, D_stack, V_stack ! Output: real, intent(out) :: hemis1 ! emission height, including plume rise [m] -type (TError), intent(out) :: error ! error handling record +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; + ! 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 @@ -70,16 +70,16 @@ subroutine ops_plumerise_prelim(istab, isek, astat, hemis0, qw, D_stack, V_stack 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., & +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) - +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, & +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 @@ -99,27 +99,27 @@ subroutine ops_plumerise(z0, hemis0, uster, ol, qw, VsDs_opt, D_stack, V_stack, 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) :: 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 +! 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 +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; + ! 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 + ! 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 + +! 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] @@ -147,37 +147,37 @@ subroutine ops_plumerise(z0, hemis0, uster, ol, qw, VsDs_opt, D_stack, V_stack, ! 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. +! 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 +! 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. +! 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 +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). +! 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); +! 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 ) + non_stable = ( istab .lt. 5 ) else - non_stable = ( ol .lt. (0. - EPS_DELTA) .or. abs(ol) .gt. 50 ) + 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 +if (error%haserror) goto 9999 ! 2. Compute wind speed at stack height: if (prelim1) then @@ -188,17 +188,17 @@ subroutine ops_plumerise(z0, hemis0, uster, ol, qw, VsDs_opt, D_stack, V_stack, ! 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) + 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) + 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 -> + + ! 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 @@ -210,14 +210,14 @@ subroutine ops_plumerise(z0, hemis0, uster, ol, qw, VsDs_opt, D_stack, V_stack, else call ops_plumerise_momentum(u_stack,D_stack,V_stack,Ts_stack2,Ta_stack,dthetadz_stable,non_stable,dh_momentum) endif -else +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 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 @@ -227,12 +227,12 @@ subroutine ops_plumerise(z0, hemis0, uster, ol, qw, VsDs_opt, D_stack, V_stack, ! 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) +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) +9999 call ErrorCall(ROUTINENAAM, error) end subroutine ops_plumerise @@ -240,7 +240,7 @@ 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. +! 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 @@ -254,41 +254,41 @@ subroutine ops_plumerise_qw_Ts(VsDs_opt, qw, D_stack, V_stack, Ts_stack, emis_ho 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) +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 +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 +!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) +! 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) +! 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 + Ts_stack2 = Ta_stack else ! Compute effluent temperature (not needed in case of horizontal outflow): ! Ts = Ta + 1e6*qw/(rho0*Cp0*V0) (1) @@ -296,7 +296,7 @@ subroutine ops_plumerise_qw_Ts(VsDs_opt, qw, D_stack, V_stack, Ts_stack, emis_ho ! 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 @@ -313,20 +313,20 @@ subroutine ops_plumerise_qw_Ts(VsDs_opt, qw, D_stack, V_stack, Ts_stack, emis_ho 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) + call ErrorCall(ROUTINENAAM, error) endif endif ! if qw = 0 - endif ! if emis_horizontal + 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 - + 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 @@ -343,8 +343,8 @@ 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. +! +! 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). ! 960121 @@ -356,31 +356,31 @@ subroutine ops_plumerise_buoyancy(z0, ol, uster, non_stable, qw, Ta_stack, dthet 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) :: z0 ! roughness length [m] real, intent(in) :: ol ! Monin-Obukhovlengte [m] -real, intent(in) :: uster ! friction velocity [m/s] +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] +real, intent(in) :: hemis0 ! initial emission height = stack height [m] -! Output +! 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; + ! 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 + ! 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 + +! 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] @@ -388,17 +388,17 @@ subroutine ops_plumerise_buoyancy(z0, ol, uster, non_stable, qw, Ta_stack, dthet 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) +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 +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 - +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. @@ -414,14 +414,14 @@ subroutine ops_plumerise_buoyancy(z0, ol, uster, non_stable, qw, Ta_stack, dthet !Initialization u_plume = u_stack dh_buoyancy = 0.0 - ! if (prelim1) write(*,'(a,2(1x,e12.5))') 'ops_plumerise_buoyancy a',hemis0,u_stack + ! 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 = 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, + + ! 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. @@ -429,8 +429,8 @@ subroutine ops_plumerise_buoyancy(z0, ol, uster, non_stable, qw, Ta_stack, dthet dh_buoyancy_prev = -999. ! Do iteration: - do while (.not. converged .and. it .le. maxit) - + 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 @@ -438,7 +438,7 @@ subroutine ops_plumerise_buoyancy(z0, ol, uster, non_stable, qw, Ta_stack, dthet 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 + dh_buoyancy = 21.3*f**0.75/u_plume ! char_debug1 = 'c' endif else @@ -446,13 +446,13 @@ subroutine ops_plumerise_buoyancy(z0, ol, uster, non_stable, qw, Ta_stack, dthet ! 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. - + 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 + ! ! 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 @@ -460,7 +460,7 @@ subroutine ops_plumerise_buoyancy(z0, ol, uster, non_stable, qw, Ta_stack, dthet ! 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: @@ -488,7 +488,7 @@ subroutine ops_plumerise_buoyancy(z0, ol, uster, non_stable, qw, Ta_stack, dthet ELSE ! Qw = 0 - dh_buoyancy = 0.0 + dh_buoyancy = 0.0 ENDIF end subroutine ops_plumerise_buoyancy @@ -516,18 +516,18 @@ subroutine ops_plumerise_momentum(u_stack,D_stack,V_stack,Ts_stack,Ta_stack,dthe ! 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_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) :: 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] @@ -540,16 +540,16 @@ subroutine ops_plumerise_momentum(u_stack,D_stack,V_stack,Ts_stack,Ta_stack,dthe 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 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) + ! 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 + ! 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: @@ -562,47 +562,47 @@ subroutine ops_plumerise_momentum(u_stack,D_stack,V_stack,Ts_stack,Ta_stack,dthe ! 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 + ! 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 + else dh_momentum = dh_stable endif endif -end subroutine ops_plumerise_momentum +end subroutine ops_plumerise_momentum !------------------------------------------------------------ -subroutine ops_plume_penetration(hemis0,zmix,zmix_loc,ol,dh,hemis1,onder) +subroutine ops_plume_penetration(hemis0,zmix,zmix_loc,ol,dh,hemis1,onder) ! -! Subroutine to determine whether there is plume penetration. +! Subroutine to determine whether there is plume penetration. ! -use m_commonconst, only: EPS_DELTA +use m_commonconst, only: EPS_DELTA -! Input +! Input real, intent(in) :: hemis0 ! initial emission height = stack height [m] -real, intent(in) :: zmix ! mixing 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 +! Input/Output real, intent(inout) :: hemis1 ! emission height, including plume rise [m] -! Output -real, intent(out) :: onder ! part of plume below mixing height +! 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 @@ -614,7 +614,7 @@ subroutine ops_plume_penetration(hemis0,zmix,zmix_loc,ol,dh,hemis1,onder) ! 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 + onder = (zmix - hemis1)/zmix + 0.5 ! OPS else onder = (zmix - hemis1)/dh + 0.5 ! Briggs (1975) and NNM endif @@ -626,8 +626,8 @@ subroutine ops_plume_penetration(hemis0,zmix,zmix_loc,ol,dh,hemis1,onder) ! ! 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 +if ( hemis0 .lt. zmix_loc .and. abs(ol) .lt. 100 ) then + onder = onder + 0.35 endif ! Limit onder, such that 0 <= onder <= 1 @@ -637,7 +637,7 @@ subroutine ops_plume_penetration(hemis0,zmix,zmix_loc,ol,dh,hemis1,onder) onder = 0. else continue -endif +endif ! Plume centre is maximal equal to mixing haight: if ((hemis1 .gt. (zmix + EPS_DELTA)) .and. (onder .gt. (0. + EPS_DELTA))) then diff --git a/m_ops_utils.f90 b/m_ops_utils.f90 index b33447d..2e55f5a 100644 --- a/m_ops_utils.f90 +++ b/m_ops_utils.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 . +! module m_ops_utils ! Different utility routines and functions @@ -105,7 +105,7 @@ real function angle180(a) use Binas, only: pi ! Return angle in interval (-pi,pi] -! Input +! Input real, intent(in) :: a ! angle [radians] ! Local @@ -161,7 +161,7 @@ subroutine proj_point(v1x,v1y,v2x,v2y,px,py,p_projx,p_projy,fac,len2) ! e2 = p-v1: e2x = px - v1x; e2y = py - v1y; - + ! Dot product of e1, e2: dot_prod = e1x*e2x + e1y*e2y; diff --git a/m_ops_vchem.f90 b/m_ops_vchem.f90 index 5e3ac4b..20d0377 100644 --- a/m_ops_vchem.f90 +++ b/m_ops_vchem.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,14 +27,14 @@ ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM ! LANGUAGE : FORTRAN-F90 ! DESCRIPTION : Define structure for chemical conversion rates ! EXIT CODES : ! FILES AND OTHER : ! I/O DEVICES -! SYSTEM DEPENDENCIES: +! SYSTEM DEPENDENCIES: ! CALLED FUNCTIONS : ! UPDATE HISTORY : !------------------------------------------------------------------------------------------------------------------------------- @@ -45,7 +45,7 @@ MODULE m_ops_vchem IMPLICIT NONE type Tvchem - + TYPE (TApsGridReal) :: mass_prec_grid ! APS grid with column averaged mass of precursor pre chemistry step (from chemistry model, e.g. EMEP) [ug/m2] TYPE (TApsGridReal) :: mass_conv_dtfac_grid ! APS grid with (100/dt) * column averaged mass, converted during chemistry step (from chemistry model, e.g. EMEP) [(ug/m2) (%/h)] diff --git a/m_string.f90 b/m_string.f90 index bcd99a3..54656f9 100644 --- a/m_string.f90 +++ b/m_string.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -32,7 +32,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! EXIT CODES : @@ -153,16 +153,16 @@ SUBROUTINE copystrpart(sourcestring, startpos, endpos, targetstring, error) TYPE (TError), INTENT(OUT) :: error ! Error handling record ! LOCAL VARIABLES -INTEGER*4 :: eindsourcepos ! -INTEGER*4 :: eindtargetpos ! +INTEGER*4 :: eindsourcepos +INTEGER*4 :: eindtargetpos LOGICAL :: changeany ! false if nothing has been set ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'copystrpart') ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'// char (0) !------------------------------------------------------------------------------------------------------------------------------- IF (stringsetlimits(ROUTINENAAM, sourcestring, startpos, endpos, 0, targetstring, eindsourcepos, eindtargetpos, changeany, & @@ -196,7 +196,7 @@ SUBROUTINE copystring(sourcestring, targetstring, error) TYPE (TError), INTENT(OUT) :: error ! Error handling record ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'copystring') !------------------------------------------------------------------------------------------------------------------------------- CALL copystrpart(sourcestring, 1, -1, targetstring, error) @@ -227,13 +227,13 @@ SUBROUTINE appendstrpart(sourcestring, startpos, endpos, targetstring, error) TYPE (TError), INTENT(INOUT) :: error ! Error handling record ! LOCAL VARIABLES -INTEGER*4 :: targetlengte ! -INTEGER*4 :: eindsourcepos ! -INTEGER*4 :: eindtargetpos ! +INTEGER*4 :: targetlengte +INTEGER*4 :: eindsourcepos +INTEGER*4 :: eindtargetpos LOGICAL :: changeany ! false als er niets gezet wordt ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'appendstrpart') !------------------------------------------------------------------------------------------------------------------------------- targetlengte=LEN_TRIM(targetstring) @@ -268,7 +268,7 @@ SUBROUTINE appendstring(targetstring, sourcestring, error) TYPE (TError), INTENT(INOUT) :: error ! Error handling record ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'appendstring') CALL appendstrpart(sourcestring, 1, -1, targetstring, error) @@ -298,10 +298,10 @@ SUBROUTINE appendinteger(targetstring, value, error) TYPE (TError), INTENT(INOUT) :: error ! Error handling record ! LOCAL VARIABLES -INTEGER*4 :: strlen ! +INTEGER*4 :: strlen ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'appendinteger') !------------------------------------------------------------------------------------------------------------------------------- @@ -343,14 +343,14 @@ SUBROUTINE insertstrpart(insertpos, sourcestring,startpos,endpos, targetstring, TYPE (TError), INTENT(INOUT) :: error ! Error handling record ! LOCAL VARIABLES -INTEGER*4 :: targetlengte ! -INTEGER*4 :: eindsourcepos ! -INTEGER*4 :: eindtargetpos ! -INTEGER*4 :: insertdiff ! +INTEGER*4 :: targetlengte +INTEGER*4 :: eindsourcepos +INTEGER*4 :: eindtargetpos +INTEGER*4 :: insertdiff LOGICAL :: changeany ! false als er niets gezet wordt ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'insertstrpart') !------------------------------------------------------------------------------------------------------------------------------- targetlengte=LEN_TRIM(targetstring) @@ -391,7 +391,7 @@ SUBROUTINE insertstring(sourcestring, insertpos, targetstring, error) TYPE (TError), INTENT(OUT) :: error ! Error handling record ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'insertstring') !------------------------------------------------------------------------------------------------------------------------------- CALL insertstrpart(insertpos, sourcestring, 1, -1, targetstring, error) @@ -426,7 +426,7 @@ SUBROUTINE insertinteger(value, insertpos, targetstring, error) CHARACTER*(80) :: intasstring ! integer geconverteerd naar string ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'insertinteger') !------------------------------------------------------------------------------------------------------------------------------- ! @@ -472,7 +472,7 @@ SUBROUTINE mergestrpart(sourcestring1,startpos1,endpos1, sourcestring2, startpos TYPE (TError), INTENT(INOUT) :: error ! Error handling record ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'mergestrpart') !------------------------------------------------------------------------------------------------------------------------------- CALL copystrpart(sourcestring1,startpos1,endpos1, targetstring, error) @@ -507,7 +507,7 @@ SUBROUTINE mergestring(sourcestring1, sourcestring2, targetstring, error) TYPE (TError), INTENT(INOUT) :: error ! Error handling record ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'mergestring') !------------------------------------------------------------------------------------------------------------------------------- CALL mergestrpart(sourcestring1, 1, -1, sourcestring2, 1, -1, targetstring, error) @@ -540,13 +540,13 @@ FUNCTION stringtestlimits(routinename, string, startpos, endpos, finalpos, chang TYPE (TError), INTENT(OUT) :: error ! Error handling record ! RESULTAAT -LOGICAL :: stringtestlimits ! +LOGICAL :: stringtestlimits ! LOCAL VARIABLES INTEGER*4 :: lengte ! lengte van de string ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'stringtestlimits') !------------------------------------------------------------------------------------------------------------------------------- ! @@ -616,15 +616,15 @@ FUNCTION stringsetlimits(inputroutine, sourcestring, startpos, endpos, targetlen TYPE (TError), INTENT(OUT) :: error ! Error handling record ! RESULT -LOGICAL :: stringsetlimits ! +LOGICAL :: stringsetlimits ! LOCAL VARIABLES -INTEGER*4 :: teller ! +INTEGER*4 :: teller INTEGER*4 :: targetmaxlengte ! dclaratie lengte in targetstring INTEGER*4 :: sourcelengte ! bijdrage sourcestring in lengte ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'stringsetlimits') !------------------------------------------------------------------------------------------------------------------------------- diff --git a/m_utils.f90 b/m_utils.f90 index 31c1d54..8968b72 100644 --- a/m_utils.f90 +++ b/m_utils.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO/IS ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : General utilities @@ -55,7 +55,9 @@ MODULE m_utils USE m_error USE m_string +#ifndef GNU USE IFPORT +#endif IMPLICIT NONE @@ -171,7 +173,7 @@ MODULE m_utils !------------------------------------------------------------------------------------------------------------------------------- ! FUNCTION : WisselBytes ! DESCRIPTION : Converts integer*2 internal notation from HP fortran to Microsoft Fortran and visa versa -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! INPUTS : string (character*(*)) The string which should represent the number to be extracted. ! OUTPUTS : default (logical) Returns .TRUE. if no value was read because no value was defined following the = sign. ! error (type TError). Is assigned when an error occurred in the number defined in the string. @@ -187,7 +189,7 @@ MODULE m_utils ! PURPOSE : Initial assignment to a format string. ! DESCRIPTION : To be called when starting the creation of a format string. The format string is then extended through ! AppendFormat and PrependFormat. -! AUTHOR : OPS-support . +! AUTHOR : OPS-support ! OUTPUTS : formatstring (character*(*)) The formnat string to be created. ! error (type TError). Is assigned when an error occurred in the assignment FormatString. !------------------------------------------------------------------------------------------------------------------------------- @@ -204,7 +206,7 @@ MODULE m_utils ! REMARK : AppendFormat checks first whether an error has occurred. If so nothing happens. This is handy, because the ! calling procedure only has to check the error status once after all append and prepend procedures have been ! called. -! AUTHOR : OPS-support . +! AUTHOR : OPS-support ! INPUTS : nrelts (integer*4, optional) Assigns how many descriptor fields are present (that is number of integers, ! floats or whatever in the format string). ! descriptor (character*(*)) The descriptor appended, such as 'I6', or 'F7.3' or 'X, I3'. This descriptor is @@ -222,7 +224,7 @@ MODULE m_utils ! PURPOSE : Puts format descriptor at beginning of a format string. ! DESCRIPTION : See AppendFormat. ! REMARK : See AppendFormat. -! AUTHOR : OPS-support . +! AUTHOR : OPS-support ! INPUTS : nrelts (integer*4, optional) Assigns how many descriptor fields are present (that is number of integers, ! floats or whatever in the format string). ! descriptor (character*(*)) The descriptor appended, such as 'I6', or 'F7.3' or 'X, I3'. This descriptor is @@ -272,15 +274,15 @@ SUBROUTINE get_version_utils(dll_version, dll_date) !DEC$ ATTRIBUTES DLLEXPORT:: get_version_utils ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'get_version_utils') ! SUBROUTINE ARGUMENTS - OUTPUT -CHARACTER*(*), INTENT(OUT) :: dll_version ! -CHARACTER*(*), INTENT(OUT) :: dll_date ! +CHARACTER*(*), INTENT(OUT) :: dll_version +CHARACTER*(*), INTENT(OUT) :: dll_date ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'// char (0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -299,14 +301,14 @@ SUBROUTINE allocreal0(dim, arr, error) !DEC$ ATTRIBUTES DLLEXPORT:: allocreal0 ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: dim ! +INTEGER*4, INTENT(IN) :: dim ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT), DIMENSION(:), POINTER :: arr ! +REAL*4, INTENT(OUT), DIMENSION(:), POINTER :: arr TYPE (TError), INTENT(OUT) :: error ! Error handling record ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'allocreal0') !------------------------------------------------------------------------------------------------------------------------------- @@ -324,18 +326,18 @@ SUBROUTINE allocreal(dim, defvalue, arr, error) !DEC$ ATTRIBUTES DLLEXPORT:: allocreal ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: dim ! -REAL*4, INTENT(IN) :: defvalue ! +INTEGER*4, INTENT(IN) :: dim +REAL*4, INTENT(IN) :: defvalue ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT), DIMENSION(:), POINTER :: arr ! +REAL*4, INTENT(OUT), DIMENSION(:), POINTER :: arr TYPE (TError), INTENT(OUT) :: error ! Error handling record ! LOCAL VARIABLES -INTEGER*4 :: ierr ! +INTEGER*4 :: ierr ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'allocreal') !------------------------------------------------------------------------------------------------------------------------------- @@ -361,14 +363,14 @@ SUBROUTINE allocdouble0(dim, arr, error) !DEC$ ATTRIBUTES DLLEXPORT:: allocdouble0 ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: dim ! +INTEGER*4, INTENT(IN) :: dim ! SUBROUTINE ARGUMENTS - OUTPUT -DOUBLE PRECISION, INTENT(OUT), DIMENSION(:), POINTER :: arr ! +DOUBLE PRECISION, INTENT(OUT), DIMENSION(:), POINTER :: arr TYPE (TError), INTENT(OUT) :: error ! Error handling record ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'allocdouble0') !------------------------------------------------------------------------------------------------------------------------------- @@ -386,18 +388,18 @@ SUBROUTINE allocdouble(dim, defvalue, arr, error) !DEC$ ATTRIBUTES DLLEXPORT:: allocdouble ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: dim ! -REAL*4, INTENT(IN) :: defvalue ! +INTEGER*4, INTENT(IN) :: dim +REAL*4, INTENT(IN) :: defvalue ! SUBROUTINE ARGUMENTS - OUTPUT -DOUBLE PRECISION, INTENT(OUT), DIMENSION(:), POINTER :: arr ! +DOUBLE PRECISION, INTENT(OUT), DIMENSION(:), POINTER :: arr TYPE (TError), INTENT(OUT) :: error ! Error handling record ! LOCAL VARIABLES -INTEGER*4 :: ierr ! +INTEGER*4 :: ierr ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'allocdouble') !------------------------------------------------------------------------------------------------------------------------------- @@ -423,18 +425,18 @@ SUBROUTINE allocreal2(dim1, dim2, arr, error) !DEC$ ATTRIBUTES DLLEXPORT:: allocreal2 ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: dim1 ! -INTEGER*4, INTENT(IN) :: dim2 ! +INTEGER*4, INTENT(IN) :: dim1 +INTEGER*4, INTENT(IN) :: dim2 ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT), DIMENSION(:,:), POINTER :: arr ! +REAL*4, INTENT(OUT), DIMENSION(:,:), POINTER :: arr TYPE (TError), INTENT(OUT) :: error ! Error handling record ! LOCAL VARIABLES -INTEGER*4 :: ierr ! +INTEGER*4 :: ierr ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'allocreal2') !------------------------------------------------------------------------------------------------------------------------------- @@ -458,18 +460,18 @@ SUBROUTINE allocreal2a(dim1, dim2, arr, error) !DEC$ ATTRIBUTES DLLEXPORT:: allocreal2a ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: dim1 ! -INTEGER*4, INTENT(IN) :: dim2 ! +INTEGER*4, INTENT(IN) :: dim1 +INTEGER*4, INTENT(IN) :: dim2 ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: arr ! +REAL*4, INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: arr TYPE (TError), INTENT(OUT) :: error ! Error handling record ! LOCAL VARIABLES -INTEGER*4 :: ierr ! +INTEGER*4 :: ierr ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'allocreal2') !------------------------------------------------------------------------------------------------------------------------------- @@ -494,18 +496,18 @@ SUBROUTINE allocdouble2(dim1, dim2, arr, error) !DEC$ ATTRIBUTES DLLEXPORT:: allocdouble2 ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: dim1 ! -INTEGER*4, INTENT(IN) :: dim2 ! +INTEGER*4, INTENT(IN) :: dim1 +INTEGER*4, INTENT(IN) :: dim2 ! SUBROUTINE ARGUMENTS - OUTPUT -DOUBLE PRECISION, INTENT(OUT), DIMENSION(:,:), POINTER :: arr ! +DOUBLE PRECISION, INTENT(OUT), DIMENSION(:,:), POINTER :: arr TYPE (TError), INTENT(OUT) :: error ! Error handling record ! LOCAL VARIABLES -INTEGER*4 :: ierr ! +INTEGER*4 :: ierr ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'allocdouble2') !------------------------------------------------------------------------------------------------------------------------------- @@ -530,19 +532,19 @@ SUBROUTINE allocreal3(dim1, dim2, dim3, arr, error) !DEC$ ATTRIBUTES DLLEXPORT:: allocreal3 ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: dim1 ! -INTEGER*4, INTENT(IN) :: dim2 ! -INTEGER*4, INTENT(IN) :: dim3 ! +INTEGER*4, INTENT(IN) :: dim1 +INTEGER*4, INTENT(IN) :: dim2 +INTEGER*4, INTENT(IN) :: dim3 ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT), DIMENSION(:,:,:), POINTER :: arr ! +REAL*4, INTENT(OUT), DIMENSION(:,:,:), POINTER :: arr TYPE (TError), INTENT(OUT) :: error ! Error handling record ! LOCAL VARIABLES -INTEGER*4 :: ierr ! +INTEGER*4 :: ierr ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'allocreal3') !------------------------------------------------------------------------------------------------------------------------------- @@ -568,14 +570,14 @@ SUBROUTINE allocinteger0(dim, arr, error) !DEC$ ATTRIBUTES DLLEXPORT:: allocinteger0 ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: dim ! +INTEGER*4, INTENT(IN) :: dim ! SUBROUTINE ARGUMENTS - OUTPUT -INTEGER*4, INTENT(OUT), DIMENSION(:), POINTER :: arr ! +INTEGER*4, INTENT(OUT), DIMENSION(:), POINTER :: arr TYPE (TError), INTENT(OUT) :: error ! Error handling record ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'allocinteger0') !------------------------------------------------------------------------------------------------------------------------------- @@ -593,18 +595,18 @@ SUBROUTINE allocinteger(dim, defvalue, arr, error) !DEC$ ATTRIBUTES DLLEXPORT:: allocinteger ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: dim ! -INTEGER*4, INTENT(IN) :: defvalue ! +INTEGER*4, INTENT(IN) :: dim +INTEGER*4, INTENT(IN) :: defvalue ! SUBROUTINE ARGUMENTS - OUTPUT -INTEGER*4, INTENT(OUT), DIMENSION(:), POINTER :: arr ! +INTEGER*4, INTENT(OUT), DIMENSION(:), POINTER :: arr TYPE (TError), INTENT(OUT) :: error ! Error handling record ! LOCAL VARIABLES -INTEGER*4 :: ierr ! +INTEGER*4 :: ierr ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'allocinteger') !------------------------------------------------------------------------------------------------------------------------------- @@ -630,18 +632,18 @@ SUBROUTINE allocinteger2(dim1, dim2, arr, error) !DEC$ ATTRIBUTES DLLEXPORT:: allocinteger2 ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: dim1 ! -INTEGER*4, INTENT(IN) :: dim2 ! +INTEGER*4, INTENT(IN) :: dim1 +INTEGER*4, INTENT(IN) :: dim2 ! SUBROUTINE ARGUMENTS - OUTPUT -INTEGER, INTENT(OUT), DIMENSION(:,:), POINTER :: arr ! +INTEGER, INTENT(OUT), DIMENSION(:,:), POINTER :: arr TYPE (TError), INTENT(OUT) :: error ! Error handling record ! LOCAL VARIABLES -INTEGER*4 :: ierr ! +INTEGER*4 :: ierr ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'allocinteger2') !------------------------------------------------------------------------------------------------------------------------------- @@ -666,17 +668,17 @@ SUBROUTINE allocstring(dim, arr, error) !DEC$ ATTRIBUTES DLLEXPORT:: allocstring ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: dim ! +INTEGER*4, INTENT(IN) :: dim ! SUBROUTINE ARGUMENTS - OUTPUT -CHARACTER*(*), INTENT(OUT), DIMENSION(:), POINTER :: arr ! +CHARACTER*(*), INTENT(OUT), DIMENSION(:), POINTER :: arr TYPE (TError), INTENT(OUT) :: error ! Error handling record ! LOCAL VARIABLES -INTEGER*4 :: ierr ! +INTEGER*4 :: ierr ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'allocstring') !------------------------------------------------------------------------------------------------------------------------------- @@ -737,10 +739,10 @@ SUBROUTINE deallocreal(arr) !DEC$ ATTRIBUTES DLLEXPORT:: deallocreal ! SUBROUTINE ARGUMENTS - I/O -REAL*4, INTENT(INOUT), DIMENSION(:), POINTER :: arr ! +REAL*4, INTENT(INOUT), DIMENSION(:), POINTER :: arr ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'deallocreal') !------------------------------------------------------------------------------------------------------------------------------- @@ -756,10 +758,10 @@ SUBROUTINE deallocdouble(arr) !DEC$ ATTRIBUTES DLLEXPORT:: deallocdouble ! SUBROUTINE ARGUMENTS - I/O -DOUBLE PRECISION, INTENT(INOUT), DIMENSION(:), POINTER :: arr ! +DOUBLE PRECISION, INTENT(INOUT), DIMENSION(:), POINTER :: arr ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'deallocdouble') !------------------------------------------------------------------------------------------------------------------------------- @@ -776,10 +778,10 @@ SUBROUTINE deallocreal2(arr) !DEC$ ATTRIBUTES DLLEXPORT:: deallocreal2 ! SUBROUTINE ARGUMENTS - I/O -REAL*4, INTENT(INOUT), DIMENSION(:,:), POINTER :: arr ! +REAL*4, INTENT(INOUT), DIMENSION(:,:), POINTER :: arr ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'deallocreal2') !------------------------------------------------------------------------------------------------------------------------------- @@ -796,10 +798,10 @@ SUBROUTINE deallocdouble2(arr) !DEC$ ATTRIBUTES DLLEXPORT:: deallocdouble2 ! SUBROUTINE ARGUMENTS - I/O -DOUBLE PRECISION, INTENT(INOUT), DIMENSION(:,:), POINTER :: arr ! +DOUBLE PRECISION, INTENT(INOUT), DIMENSION(:,:), POINTER :: arr ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'deallocdouble2') !------------------------------------------------------------------------------------------------------------------------------- @@ -816,10 +818,10 @@ SUBROUTINE deallocreal3(arr) !DEC$ ATTRIBUTES DLLEXPORT:: deallocreal3 ! SUBROUTINE ARGUMENTS - I/O -REAL*4, INTENT(INOUT), DIMENSION(:,:,:), POINTER :: arr ! +REAL*4, INTENT(INOUT), DIMENSION(:,:,:), POINTER :: arr ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'deallocreal3') !------------------------------------------------------------------------------------------------------------------------------- @@ -835,10 +837,10 @@ SUBROUTINE deallocinteger(arr) !DEC$ ATTRIBUTES DLLEXPORT:: deallocinteger ! SUBROUTINE ARGUMENTS - I/O -INTEGER*4, INTENT(INOUT), DIMENSION(:), POINTER :: arr ! +INTEGER*4, INTENT(INOUT), DIMENSION(:), POINTER :: arr ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'deallocinteger') !------------------------------------------------------------------------------------------------------------------------------- @@ -855,10 +857,10 @@ SUBROUTINE deallocstring(arr) !DEC$ ATTRIBUTES DLLEXPORT:: deallocstring ! SUBROUTINE ARGUMENTS - I/O -CHARACTER*(*), INTENT(INOUT), DIMENSION(:), POINTER :: arr ! +CHARACTER*(*), INTENT(INOUT), DIMENSION(:), POINTER :: arr ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'deallocstring') !------------------------------------------------------------------------------------------------------------------------------- @@ -877,17 +879,17 @@ FUNCTION Jaartal(number) !DEC$ ATTRIBUTES DLLEXPORT:: Jaartal ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: number ! +INTEGER*4, INTENT(IN) :: number ! FUNCTION RESULT -INTEGER*4 :: Jaartal ! +INTEGER*4 :: Jaartal ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'Jaartal') ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- IF (number < 50) THEN @@ -916,7 +918,7 @@ SUBROUTINE getreal (string, value, nopart, error) CHARACTER*(*), INTENT(IN) :: string ! String with real number, starting at pos. 1. ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: value ! +REAL*4, INTENT(OUT) :: value LOGICAL, INTENT(OUT) :: nopart ! TRUE als er geen real is gelezen TYPE (TError), INTENT(OUT) :: error ! Error handling record @@ -930,11 +932,11 @@ SUBROUTINE getreal (string, value, nopart, error) CHARACTER :: testchar ! Character looked at ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'getreal') ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -1024,13 +1026,13 @@ END SUBROUTINE getreal !------------------------------------------------------------------------------------------------------------------------------- ! SUBROUTINE : getint -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! PURPOSE : Extraheren van integer waarde uit een string. Geeft terug of er een waarde was, welke positie, etc. ! CALLED FUNCTIONS : extractint !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE getint (string, value, isdefault, error) -!DEC$ ATTRIBUTES DLLEXPORT:: getint +!DEC$ ATTRIBUTES DLLEXPORT:: getint USE m_error ! leave this here, otherwise you get compiler error!(?) @@ -1038,16 +1040,16 @@ SUBROUTINE getint (string, value, isdefault, error) CHARACTER*(*), INTENT(IN) :: string ! String met geheel getal, beginnend op pos. 1. ! SUBROUTINE ARGUMENTS - OUTPUT -INTEGER*4, INTENT(OUT) :: value ! +INTEGER*4, INTENT(OUT) :: value LOGICAL, INTENT(OUT) :: isdefault ! Whether nothing is extracted -TYPE (TError), INTENT(OUT) :: error ! +TYPE (TError), INTENT(OUT) :: error ! LOCAL PARAMETERS INTEGER*4 :: beyondpos ! First position beyond integer in string INTEGER*4 :: intvalue ! Value extracted ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'getint') !------------------------------------------------------------------------------------------------------------------------------- @@ -1089,7 +1091,7 @@ END SUBROUTINE getint !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE byteswap1(ishort, shortdim) -!DEC$ ATTRIBUTES DLLEXPORT:: byteswap1 +!DEC$ ATTRIBUTES DLLEXPORT:: byteswap1 ! SUBROUTINE ARGUMENTS - INPUT INTEGER*4, INTENT(IN) :: shortdim ! number of elements in ishort @@ -1101,11 +1103,11 @@ SUBROUTINE byteswap1(ishort, shortdim) INTEGER*4 :: i ! tellers ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'byteswap1') ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- DO i = 1, shortdim @@ -1134,11 +1136,11 @@ SUBROUTINE byteswap2(ishort, dim1, dim2) INTEGER*4 :: i, j ! tellers ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'byteswap2') ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- DO i = 1, dim1 @@ -1153,7 +1155,7 @@ END SUBROUTINE byteswap2 !------------------------------------------------------------------------------------------------------------------------------- ! SUBROUTINE : byteswap ! DESCRIPTION : Converts integer*2 internal notation from HP fortran to Microsoft Fortran and visa versa. -! AUTHOR : OPS-support +! AUTHOR : OPS-support !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE byteswap(ishort) @@ -1168,11 +1170,11 @@ SUBROUTINE byteswap(ishort) INTEGER*2 :: maxint2 ! maximum integerwaarde bij INT2 ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'byteswap') ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- maxint2 = 256 @@ -1211,17 +1213,17 @@ FUNCTION extractint (string, intvalue, beyondpos, error) ! SUBROUTINE ARGUMENTS - OUTPUT INTEGER*4, INTENT(OUT) :: intvalue ! First position beyond integer read. 0 if end of line. INTEGER*4, INTENT(OUT) :: beyondpos ! First position beyond integer read. 0 if end of line. -TYPE (TError), INTENT(OUT) :: error ! +TYPE (TError), INTENT(OUT) :: error ! RESULT -LOGICAL :: extractint ! +LOGICAL :: extractint ! LOCAL VARIABLES -INTEGER*4 :: zerochar,lengte ! -LOGICAL :: negative,doorgaan ! +INTEGER*4 :: zerochar,lengte +LOGICAL :: negative,doorgaan ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'extractint') !------------------------------------------------------------------------------------------------------------------------------- @@ -1299,22 +1301,22 @@ SUBROUTINE GetOS(os, slash) !DEC$ ATTRIBUTES DLLEXPORT:: GetOS ! SUBROUTINE ARGUMENTS - OUTPUT -INTEGER*4, INTENT(OUT) :: os ! -CHARACTER, INTENT(OUT), OPTIONAL :: slash ! +INTEGER*4, INTENT(OUT) :: os +CHARACTER, INTENT(OUT), OPTIONAL :: slash ! ! Local variables: ! -INTEGER*4 :: rtc ! -INTEGER*4 :: colonpos ! +INTEGER*4 :: rtc +INTEGER*4 :: colonpos ! ! De declaratie van GETCWD is uitgecommentarieerd omdat CWD in IFPORT is opgenomen. IFPORT declareert GETCWD. Als het hier toch ! wordt gedeclareerd neemt de compiler aan, dat dit een externe functie is. Bij het linken wordt die dan niet gevonden. ! ! INTEGER*4 :: GETCWD -CHARACTER*512 :: directory ! +CHARACTER*512 :: directory ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'GetOS') rtc = GETCWD(directory) @@ -1340,14 +1342,14 @@ SUBROUTINE GetCLArg(progpath, nrarg, arg, error) !DEC$ ATTRIBUTES DLLEXPORT:: GetCLArg ! SUBROUTINE ARGUMENTS - OUTPUT -CHARACTER*512, INTENT(OUT) :: progpath ! -INTEGER*4, INTENT(OUT) :: nrarg ! -CHARACTER*512, INTENT(OUT), DIMENSION(:), POINTER :: arg ! +CHARACTER*512, INTENT(OUT) :: progpath +INTEGER*4, INTENT(OUT) :: nrarg +CHARACTER*512, INTENT(OUT), DIMENSION(:), POINTER :: arg TYPE (TError), INTENT(OUT) :: error ! Error handling record ! ! External FUNCTIONS implemented on both HP-UX and WINNT. ! -INTEGER*4 :: iargc ! +INTEGER*4 :: iargc ! ! Local variables. ! @@ -1355,7 +1357,7 @@ SUBROUTINE GetCLArg(progpath, nrarg, arg, error) INTEGER*4 :: ierr ! error status in allocation ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'GetCLArg') !------------------------------------------------------------------------------------------------------------------------------- @@ -1403,11 +1405,11 @@ SUBROUTINE StartFormat(formatstring, error) TYPE (TError), INTENT(OUT) :: error ! Error handling record ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'startformat') ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'// char (0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -1437,7 +1439,7 @@ SUBROUTINE append_format_string1(typestring, formatstring, error) TYPE (TError), INTENT(OUT) :: error ! Error handling record ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'append_format_string1') !------------------------------------------------------------------------------------------------------------------------------- @@ -1468,11 +1470,11 @@ SUBROUTINE append_format_string(nrelts, typestring, formatstring, error) INTEGER*4 :: lastpos ! Last position in the string (=text lengte) ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'append_format_string') ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'// char (0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -1543,7 +1545,7 @@ SUBROUTINE prepend_format_string1(typestring, formatstring, error) TYPE (TError), INTENT(OUT) :: error ! Error handling record ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'prepend_format_string1') !------------------------------------------------------------------------------------------------------------------------------- @@ -1575,11 +1577,11 @@ SUBROUTINE prepend_format_string(nrelts, typestring, formatstring, error) INTEGER*4 :: lastpos ! Last position in the string (=text lengte) ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'prepend_format_string') ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'// char (0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -1637,18 +1639,18 @@ SUBROUTINE SortMatrix (matrix, nobs, column) !DEC$ ATTRIBUTES DLLEXPORT:: SortMatrix ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: nobs ! -INTEGER*4, INTENT(IN) :: column ! +INTEGER*4, INTENT(IN) :: nobs +INTEGER*4, INTENT(IN) :: column ! SUBROUTINE ARGUMENTS - I/O -REAL*4, INTENT(INOUT) :: matrix(:,:) ! +REAL*4, INTENT(INOUT) :: matrix(:,:) ! LOCAL VARIABLES -INTEGER*4 :: i ! -INTEGER*4 :: j ! -INTEGER*4 :: ctr ! -INTEGER*4 :: isize ! -REAL*4, ALLOCATABLE :: tmp(:) ! +INTEGER*4 :: i +INTEGER*4 :: j +INTEGER*4 :: ctr +INTEGER*4 :: isize +REAL*4, ALLOCATABLE :: tmp(:) isize=SIZE(matrix,DIM=1) ALLOCATE(tmp(isize)) @@ -1683,7 +1685,7 @@ SUBROUTINE GetIndex(code, index) INTEGER*4, INTENT(INOUT) :: index ! index for numerical code ! LOCAL VARIABLES -INTEGER*4 :: idents (50) ! identities that are already known (max 50) +INTEGER*4 :: idents (50) ! identities that are already known (max 50) INTEGER*4 :: nidents ! number of identities that are already known INTEGER*4 :: i ! do loop index LOGICAL :: found ! true if identity has been encountered earlier diff --git a/makedependencies.pl b/makedependencies.pl new file mode 100644 index 0000000..83daff9 --- /dev/null +++ b/makedependencies.pl @@ -0,0 +1,57 @@ +#!/bin/perl +# On stdout, create dependencies based on USE and MODULE statements in the fortran source files provided on the command line. +# method: from the files in the argument list, extract dependencies from the USE statements and locate the MODULEs + +# Gerard Cats, 27 July 2020 + +# loop over arguments - must be Fortran files +while ( $file = shift ) { + open( IN, "<$file") or die "cannot open $file: $!\n"; + $target = $file; + $target =~ s/\.f.*$/.o/i; # dependencies ara formulated at the object level + undef %deps; + while ( ) { + +# in the parsing of Fortran, it is assumed that USE and MODULE are the first words +# the second word, starting with a letter and ending with a letter or digit +# Be aware in Fortran case and spaces are insignificant + +# USE statements: this target depends on the used name + if ( /^\s*u\s*s\s*e\s*([A-Za-z_][A-Za-z0-9_\s]*[A-Za-z0-9_])/i ) { # assumes used names are at least two characters + $s = lc($1); + $s =~ s/\s//g; + $deps{ $s } = 1; # multiple occurences are collapsed + } +# MODULE statements: remember this is the source of this module + if ( /^\s*m\s*o\s*d\s*u\s*l\s*e\s*([A-Za-z_][A-Za-z0-9_\s]*[A-Za-z0-9_])/i ) { # assumes module names are at least two characters + $s = lc($1); + $s =~ s/\s//g; + $src { $s } = $target; + } + } + close IN; + +# remember the list of prerequisites + if ( %deps ) { + for my $j ( sort keys %deps ) { + $prerq{ $target } .= ";$j"; + } + } +} +# the prerequisites define the dependants in their keys +for my $j ( sort keys %prerq ) { + undef $deps; + @prerq = split(";", $prerq{ $j }); + for (my $jj = 1; $jj <= $#prerq; $jj ++ ) { + $src = $src { $prerq[ $jj ] }; + if ( $src ) { + $deps .= " $src"; + } else { + print stderr "Warning: no source found for $prerq[ $jj ] needed by $j\n"; + print "# $j: $prerq[ $jj ]\t\tNo source found\n"; + } + } + if ( $deps ) { + print "$j: $deps\n"; + } +} diff --git a/makefile b/makefile new file mode 100644 index 0000000..2f105ef --- /dev/null +++ b/makefile @@ -0,0 +1,115 @@ +# a makefile for GNU Linux installations +# Gerard Cats, 27 July 2020 + +.SUFFIXES: .f .o + +OPS: OPS.exe + +# if debugging +# ------------ +ifeq ($(MAKECMDGOALS),debug) + DB = db + debug: OPS$(DB).exe + OPT = -O0 +else + OPT = -O3 +endif + +# sources are separated into modules and others, but this distinction is not used further on +# ------- + +MODULES := binas.f90 m_aps.f90 m_commonconst.f90 m_commonfile.f90 m_depac.f90 m_error.f90 m_fileutils.f90 m_geoutils.f90 \ + m_getkey.f90 m_ops_building.f90 m_ops_emis.f90 m_ops_plumerise.f90 m_ops_utils.f90 \ + m_ops_vchem.f90 m_string.f90 m_utils.f90 \ + ops_bgcon.f90 ops_print_table.f90 + +SOURCES := ops_bgcon_tra.f90 ops_bron_rek.f90 ops_brondepl.f90 ops_calc_stats.f90 ops_conc_ini.f90 \ + ops_conc_rek.f90 ops_conltexp.f90 ops_convec.f90 ops_depoparexp.f90 ops_depos_rc.f90 ops_depu.f90 \ + ops_gen_fnames.f90 ops_gen_precip.f90 ops_gen_rcp.f90 ops_get_arg.f90 ops_get_dim.f90 ops_getlu.f90 \ + ops_getlu_tra.f90 ops_getz0.f90 ops_getz0_tra.f90 ops_init.f90 ops_logfile.f90 ops_main.f90 ops_neutral.f90 \ + ops_outp_prep.f90 ops_par_chem.f90 ops_plot_uitv.f90 ops_plrise71.f90 ops_print_grid.f90 ops_print_info.f90 \ + ops_print_kop.f90 ops_print_recep.f90 ops_rcp_char_1.f90 ops_rcp_char_all.f90 \ + ops_read_bg.f90 ops_read_ctr.f90 ops_read_emis.f90 ops_read_meteo.f90 ops_read_source.f90 ops_reken.f90 \ + ops_resist_rek.f90 ops_scalefac.f90 ops_seccmp.f90 ops_src_char.f90 ops_stab_rek.f90 ops_statparexp.f90 \ + ops_surface.f90 ops_tra_char.f90 ops_vertdisp.f90 ops_virtdist.f90 ops_write_progress.f90 ops_wv_powerlaw.f90 \ + ops_wvprofile.f90 ops_z0corr.f90 + +# +# r1mach was added for proper behaviour on double precision. +# +SOURCES := $(SOURCES) r1mach.f90 +# +# Files to be added to the download from math77, such as found on +# https://netlib.org/math/math77.tgz +# +SOURCESmath77 = mess.f silup.f silupm.f optchk.f smess.f + + +# configurations +# -------------- +ifeq ($(MAKECONF),GNU_Linux) + SOURCES := $(SOURCES) inum.f90 # no IFPORT library + FC = gfortran + CPPFLAGS = -DUNIX -DGNU + FFLAGSb = $(OPT) -ffree-line-length-0 -finit-local-zero -cpp + ifeq ($(MAKECMDGOALS),OPS8) + FFLAGSb += -fdefault-real-8 + endif + FFLAGS = $(FFLAGSb) + +# optimisation problems + ops_statparexp.o : FFLAGS = $(FFLAGSb:O3=O0) + +# LDLIBS = -lMATH77 + LDLIBS = + LDFLAGS = -L /usr/local/lib +else + FC = ifort + CPPFLAGS = -DUNIX -fpp + ifeq ($(MAKECMDGOALS),debug) + FFLAGS = -nowarn -fpp -assume byterecl -check bounds -gen-interfaces -warn interfaces -debug-parameters all \ + -traceback -O0 -g -fpe0 -extend_source + else + FFLAGS = -nowarn -fpp -assume byterecl -O2 -extend_source + endif +endif +#_______________________________________________________________________________ + +# double precision, to be installed immediately +OPS8: OPS.exe + mv $< $@ + cp $@ $(MYPATH)/ + +#_______________________________________________________________________________ + +# generics +# -------- +OBJECTS := $(MODULES:.f90=.o) $(SOURCES:.f90=.o) $(SOURCESmath77:.f=.o) + +OPS$(DB).exe: $(OBJECTS) + $(FC) $(LDFLAGS) $(OBJECTS) $(LDLIBS) -o $@ + +%.o %.mod: %.f90 + $(FC) $(CPPFLAGS) $(FFLAGS) -c $< + +# dependencies list is created from sources +# ------------ +dependencies: $(MODULES) $(SOURCES) makedependencies.pl + perl makedependencies.pl $(MODULES) $(SOURCES) > $@ + +ifneq ($(MAKECMDGOALS),clean) + include dependencies +endif + +.PHONY: clean +clean: + @echo removing dependencies, .o, .mod and .exe + $(RM) dependencies OPS.exe OPSdb.exe *.mod *.o + +# install: put the executable in your path (default: ~/bin). NB not for the debug version +# ------- +ifeq ($(MYPATH),) + MYPATH := $(HOME)/bin +endif +install: OPS.exe + cp $< $(MYPATH) diff --git a/ops_bgcon.f90 b/ops_bgcon.f90 index 038de0b..7f02829 100644 --- a/ops_bgcon.f90 +++ b/ops_bgcon.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,11 +27,11 @@ ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO/IS ! LANGUAGE : FORTRAN(HP-UX, HP-F77, HP-F90) -! DESCRIPTION : Returns grid value at a specific location. -! Originally made for background concentrations (bgcon), but now also used for other grids. +! DESCRIPTION : Returns grid value at a specific location. +! Originally made for background concentrations (bgcon), but now also used for other grids. ! EXIT CODES : ! FILES AND OTHER : ! I/O DEVICES @@ -51,7 +51,7 @@ SUBROUTINE ops_bgcon(x, y, bgdata, bgcon, fieldnumber) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_bgcon') ! SUBROUTINE ARGUMENTS - INPUT @@ -67,21 +67,21 @@ SUBROUTINE ops_bgcon(x, y, bgdata, bgcon, fieldnumber) LOGICAL :: iscell ! whether (x,y) is inside APS-grid bgdata !------------------------------------------------------------------------------------------------------------------------------- ! -! Get value of background concentration bgdata at location (x,y); return grid average if point is outside grid or if value is negative +! Get value of background concentration bgdata at location (x,y); return grid average if point is outside grid or if value is negative ! Note: arguments of GridValue must be in km ! if (present(fieldnumber)) then CALL GridValue(x/1000., y/1000., bgdata, bgcon, iscell, fieldnumber) - IF (iscell .AND. bgcon < 0.+EPS_DELTA) THEN + IF (iscell .AND. bgcon < 0.+EPS_DELTA) THEN bgcon = bgdata%average(fieldnumber) ENDIF else CALL GridValue(x/1000., y/1000., bgdata, bgcon, iscell) - IF (iscell .AND. bgcon < 0.+EPS_DELTA) THEN + IF (iscell .AND. bgcon < 0.+EPS_DELTA) THEN bgcon = bgdata%average(1) ENDIF endif -! write(*,'(a,3(1x,e12.5),L3,1x,e12.5)') 'ops_bgcon: ',x,y,bgcon,iscell,bgdata%average +! write(*,'(a,3(1x,e12.5),L3,1x,e12.5)') 'ops_bgcon: ',x,y,bgcon,iscell,bgdata%average RETURN END SUBROUTINE ops_bgcon diff --git a/ops_bgcon_tra.f90 b/ops_bgcon_tra.f90 index 3668114..9cd449a 100644 --- a/ops_bgcon_tra.f90 +++ b/ops_bgcon_tra.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,10 +27,10 @@ ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO/IS ! LANGUAGE : FORTRAN(HP-UX, HP-F77, HP-F90) -! DESCRIPTION : This routine reads for a given location the background conc. and +! DESCRIPTION : This routine reads for a given location the background conc. and ! calculates the average conc. between the receptor and the source location ! EXIT CODES : ! FILES AND OTHER : @@ -51,18 +51,18 @@ SUBROUTINE ops_bgcon_tra(xr, yr, xb, yb, bgdata, bgcon) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_bgcon_tra') ! SUBROUTINE ARGUMENTS - INPUT REAL*4, INTENT(IN) :: xr ! x coordinate receptor REAL*4, INTENT(IN) :: yr ! y coordinate receptor REAL*4, INTENT(IN) :: xb ! x coordinate source (b << "bron" = source) -REAL*4, INTENT(IN) :: yb ! y coordinate source +REAL*4, INTENT(IN) :: yb ! y coordinate source TYPE (TApsGridReal), INTENT(IN) :: bgdata ! grid with background concentrations ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: bgcon ! background concentration averaged over trajecory +REAL*4, INTENT(OUT) :: bgcon ! background concentration averaged over trajecory ! between source and receptor ! LOCAL VARIABLES @@ -84,7 +84,7 @@ SUBROUTINE ops_bgcon_tra(xr, yr, xb, yb, bgdata, bgcon) ! x=xr+(xb-xr)/ns*i y=yr+(yb-yr)/ns*i - + ! ! Calculate background concentration contribution at this point and add to total ! diff --git a/ops_bron_rek.f90 b/ops_bron_rek.f90 index e3521c5..79c77b4 100644 --- a/ops_bron_rek.f90 +++ b/ops_bron_rek.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,12 +27,12 @@ ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! Chris Twenh"ofel (Cap Gemini) ! FIRM/INSTITUTE : RIVM/LLO/IS ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Read source data from scratch file and fill source related variables into buffer-arrays of size LSBUF. -! See also ops_read_source +! See also ops_read_source ! EXIT CODES : ! FILES AND OTHER : ! I/O DEVICES @@ -40,7 +40,7 @@ ! CALLED FUNCTIONS : ! UPDATE HISTORY : !------------------------------------------------------------------------------------------------------------------------------- -SUBROUTINE ops_bron_rek(emtrend, buildingEffect, landmax, emis, nsbuf, bnr, bx, by, bdiam, bsterkte, bwarmte, bhoogte, bsigmaz, bD_stack, bV_stack, bTs_stack, & +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 @@ -54,74 +54,74 @@ SUBROUTINE ops_bron_rek(emtrend, buildingEffect, landmax, emis, nsbuf, bnr, bx, IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_bron_rek') ! SUBROUTINE ARGUMENTS - INPUT -REAL*4, INTENT(IN) :: emtrend -type(TbuildingEffect) :: buildingEffect ! structure with building effect tables +REAL*4, INTENT(IN) :: emtrend +type(TbuildingEffect) :: buildingEffect ! structure with building effect tables ! SUBROUTINE ARGUMENTS - I/O -INTEGER*4, INTENT(INOUT) :: landmax -REAL*4, INTENT(INOUT) :: emis(6,NLANDMAX) +INTEGER*4, INTENT(INOUT) :: landmax +REAL*4, INTENT(INOUT) :: emis(6,NLANDMAX) ! SUBROUTINE ARGUMENTS - OUTPUT -INTEGER*4, INTENT(OUT) :: nsbuf -INTEGER*4, INTENT(OUT) :: bnr(LSBUF) -INTEGER*4, INTENT(OUT) :: bx(LSBUF) -INTEGER*4, INTENT(OUT) :: by(LSBUF) -REAL*4, INTENT(OUT) :: bdiam(LSBUF) -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) :: nsbuf +INTEGER*4, INTENT(OUT) :: bnr(LSBUF) +INTEGER*4, INTENT(OUT) :: bx(LSBUF) +INTEGER*4, INTENT(OUT) :: by(LSBUF) +REAL*4, INTENT(OUT) :: bdiam(LSBUF) +REAL*4, INTENT(OUT) :: bsterkte(LSBUF) +REAL*4, INTENT(OUT) :: bwarmte(LSBUF) +REAL*4, INTENT(OUT) :: bhoogte(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] +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) -INTEGER*4, INTENT(OUT) :: bcatnr(LSBUF) -INTEGER*4, INTENT(OUT) :: blandnr(LSBUF) -LOGICAL, INTENT(OUT) :: eof ! end of file has been reached +INTEGER*4, INTENT(OUT) :: bdegr(LSBUF) +REAL*4, INTENT(OUT) :: bqrv(LSBUF) +REAL*4, INTENT(OUT) :: bqtr(LSBUF) +INTEGER*4, INTENT(OUT) :: bcatnr(LSBUF) +INTEGER*4, INTENT(OUT) :: blandnr(LSBUF) +LOGICAL, INTENT(OUT) :: eof ! end of file has been reached TYPE (TError), INTENT(OUT) :: error ! error handling record ! LOCAL VARIABLES -INTEGER*4 :: mm ! -INTEGER*4 :: ibtg ! -INTEGER*4 :: ibroncat ! -INTEGER*4 :: idgr ! +INTEGER*4 :: mm +INTEGER*4 :: ibtg +INTEGER*4 :: ibroncat +INTEGER*4 :: idgr INTEGER*4 :: iland ! country code INTEGER*4 :: index ! index of country code iland, in list of country codes -REAL*4 :: gl ! -REAL*4 :: gb ! -REAL*4 :: qtr ! -REAL*4 :: qob ! -REAL*4 :: x ! -REAL*4 :: y ! -REAL*4 :: diameter ! -REAL*4 :: qww ! -REAL*4 :: hbron ! -REAL*4 :: szopp ! +REAL*4 :: gl +REAL*4 :: gb +REAL*4 :: qtr +REAL*4 :: qob +REAL*4 :: x +REAL*4 :: y +REAL*4 :: diameter +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] +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 ! +REAL*4 :: qrv 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 ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- - 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 -! + 50 FORMAT (i8, 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 @@ -145,28 +145,28 @@ SUBROUTINE ops_bron_rek(emtrend, buildingEffect, landmax, emis, nsbuf, bnr, bx, 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 - !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, & + !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 ! 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 + 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, 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, 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)) @@ -179,8 +179,8 @@ SUBROUTINE ops_bron_rek(emtrend, buildingEffect, landmax, emis, nsbuf, bnr, bx, ! 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, & + + 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 @@ -214,12 +214,12 @@ SUBROUTINE ops_bron_rek(emtrend, buildingEffect, landmax, emis, nsbuf, bnr, bx, ENDIF ! Check whether the source has a positive emission: - IF ((qob + qrv + qtr) > (0. + EPS_DELTA)) THEN + IF ((qob + qrv + qtr) > (0. + EPS_DELTA)) THEN ! ! Compute emission totals per land and for 4 categories (see ops_print_info). ! 1: country number, 2: industry/high, 3: industry/low, 4: space heating, 5:traffic, 6: total); ! - + ! Find the index of the country for this source record ! Note: a list of maximal 50 country codes is kept inside the routine GetIndex CALL GetIndex(iland, index) @@ -245,9 +245,9 @@ SUBROUTINE ops_bron_rek(emtrend, buildingEffect, landmax, emis, nsbuf, bnr, bx, bnr(nsbuf) = mm bx(nsbuf) = NINT(x) by(nsbuf) = NINT(y) - ELSE - write(*,*) 'IGEO in ops_bron_rek = ',IGEO - stop + ELSE + write(*,*) 'IGEO in ops_bron_rek = ',IGEO + stop ENDIF bsterkte(nsbuf) = qob @@ -259,7 +259,7 @@ SUBROUTINE ops_bron_rek(emtrend, buildingEffect, landmax, emis, nsbuf, bnr, bx, bV_stack(nsbuf) = V_stack bTs_stack(nsbuf) = Ts_stack bemis_horizontal(nsbuf) = emis_horizontal - + bbuilding(nsbuf) = building btgedr(nsbuf) = ibtg bdegr(nsbuf) = idgr diff --git a/ops_brondepl.f90 b/ops_brondepl.f90 index 80b0baa..db3a6c5 100644 --- a/ops_brondepl.f90 +++ b/ops_brondepl.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN(HP-UX, HP-F77) ! DESCRIPTION : Compute source depletion (brondepl << "bron" = source, depl << depletion). @@ -35,7 +35,7 @@ ! In a source depletion model, the loss of airborne material due to deposition or other removal processes ! is accounted for by appropriately reducing the source strength as a function of down-wind distance. ! (2) Surface correction -! Since more material is deposited near the ground surface, a vertical concentration profile is established +! Since more material is deposited near the ground surface, a vertical concentration profile is established ! that is characterised by a gradient factor cgt. ! EXIT CODES : ! FILES AND OTHER : @@ -55,86 +55,86 @@ SUBROUTINE ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_brondepl') ! SUBROUTINE ARGUMENTS - INPUT -REAL*4, INTENT(IN) :: disx ! -REAL*4, INTENT(IN) :: xg ! +REAL*4, INTENT(IN) :: disx +REAL*4, INTENT(IN) :: xg REAL*4, INTENT(IN) :: c ! undepleted concentration at z = 0 m ! (without part of plume above mixing layer) REAL*4, INTENT(IN) :: ux0 ! wind speed near source at plume height (m/s) -REAL*4, INTENT(IN) :: ueff ! wind speed at effective transport height heff (m/s); +REAL*4, INTENT(IN) :: ueff ! wind speed at effective transport height heff (m/s); ! for short distances heff = plume height; ! for large distances heff = 1/2 mixing height; ! heff is interpolated for intermediate distances. -REAL*4, INTENT(IN) :: sigz ! -REAL*4, INTENT(IN) :: vg50trans ! -REAL*4, INTENT(IN) :: xl ! -INTEGER*4, INTENT(IN) :: istab ! -REAL*4, INTENT(IN) :: xloc ! -REAL*4, INTENT(IN) :: xl100 ! -REAL*4, INTENT(IN) :: vw10 ! -REAL*4, INTENT(IN) :: pcoef ! -REAL*4, INTENT(IN) :: virty ! -REAL*4, INTENT(IN) :: radius ! -REAL*4, INTENT(IN) :: ra4_rcp ! -REAL*4, INTENT(IN) :: raz_rcp ! EvdS: hoogte afhankelijkheid -REAL*4, INTENT(IN) :: rc_rcp ! -REAL*4, INTENT(IN) :: rb_rcp ! +REAL*4, INTENT(IN) :: sigz +REAL*4, INTENT(IN) :: vg50trans +REAL*4, INTENT(IN) :: xl +INTEGER*4, INTENT(IN) :: istab +REAL*4, INTENT(IN) :: xloc +REAL*4, INTENT(IN) :: xl100 +REAL*4, INTENT(IN) :: vw10 +REAL*4, INTENT(IN) :: pcoef +REAL*4, INTENT(IN) :: virty +REAL*4, INTENT(IN) :: radius +REAL*4, INTENT(IN) :: ra4_rcp +REAL*4, INTENT(IN) :: raz_rcp ! EvdS: hoogte afhankelijkheid +REAL*4, INTENT(IN) :: rc_rcp +REAL*4, INTENT(IN) :: rb_rcp REAL*4, INTENT(IN) :: z0_src ! roughness length at source; from z0-map [m] -REAL*4, INTENT(IN) :: ol_src ! -REAL*4, INTENT(IN) :: uster_src ! -REAL*4, INTENT(IN) :: htot ! -REAL*4, INTENT(IN) :: ra4src ! -REAL*4, INTENT(IN) :: rb_src ! -REAL*4, INTENT(IN) :: rcsrc ! -REAL*4, INTENT(IN) :: qbstf ! -REAL*4, INTENT(IN) :: vg0tra ! -REAL*4, INTENT(IN) :: onder ! -INTEGER*4, INTENT(IN) :: flag ! stable meteo class and stack emitting above mixing layer -REAL*4, INTENT(IN) :: vchem ! -REAL*4, INTENT(IN) :: vnatpri ! -REAL*4, INTENT(IN) :: diameter ! -REAL*4, INTENT(IN) :: dispg(NSTAB) ! +REAL*4, INTENT(IN) :: ol_src +REAL*4, INTENT(IN) :: uster_src +REAL*4, INTENT(IN) :: htot +REAL*4, INTENT(IN) :: ra4src +REAL*4, INTENT(IN) :: rb_src +REAL*4, INTENT(IN) :: rcsrc +REAL*4, INTENT(IN) :: qbstf +REAL*4, INTENT(IN) :: vg0tra +REAL*4, INTENT(IN) :: onder +INTEGER*4, INTENT(IN) :: flag ! stable meteo class and stack emitting above mixing layer +REAL*4, INTENT(IN) :: vchem +REAL*4, INTENT(IN) :: vnatpri +REAL*4, INTENT(IN) :: diameter +REAL*4, INTENT(IN) :: dispg(NSTAB) REAL*4, INTENT(IN) :: zm ! z-coordinate of receptor points (RDM) ! SUBROUTINE ARGUMENTS - I/O -REAL*4, INTENT(INOUT) :: cgt ! +REAL*4, INTENT(INOUT) :: 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 ! +REAL*4, INTENT(OUT) :: cdn REAL*4, INTENT(OUT) :: ugem ! average wind speed depending on phase of plume development (m/s) -REAL*4, INTENT(OUT) :: hf ! -REAL*4, INTENT(OUT) :: a ! -REAL*4, INTENT(OUT) :: cq1 ! -REAL*4, INTENT(OUT) :: cq2 ! +REAL*4, INTENT(OUT) :: hf +REAL*4, INTENT(OUT) :: a +REAL*4, INTENT(OUT) :: cq1 +REAL*4, INTENT(OUT) :: cq2 REAL*4, INTENT(OUT) :: uxr ! wind speed representative for plume over area source (m/s) -REAL*4, INTENT(OUT) :: zu ! representative plume height (m), taking into account reflection +REAL*4, INTENT(OUT) :: zu ! representative plume height (m), taking into account reflection ! at the top of the mixing layer and at the ground surface -REAL*4, INTENT(OUT) :: sigzr ! -REAL*4, INTENT(OUT) :: dxeff ! +REAL*4, INTENT(OUT) :: sigzr +REAL*4, INTENT(OUT) :: dxeff ! LOCAL VARIABLES REAL*4 :: cxx ! representative concentration (undepleted) for plume in phase 2 REAL*4 :: xx ! representative distance for plume in phase 2 REAL*4 :: sigzxg ! sigma_z at xx -REAL*4 :: xlxg ! -REAL*4 :: uxg ! -REAL*4 :: s2 ! -REAL*4 :: vdoppb ! -REAL*4 :: sh ! -REAL*4 :: al ! +REAL*4 :: xlxg +REAL*4 :: uxg +REAL*4 :: s2 +REAL*4 :: vdoppb +REAL*4 :: sh +REAL*4 :: al ! SUBROUTINE AND FUNCTION CALLS EXTERNAL ops_vertdisp EXTERNAL ops_wvprofile ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -142,30 +142,30 @@ SUBROUTINE ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc ! ------------- xl (mixing height) -------------------------.------------------------------------------------------------- . ! . ! . 3 phases of plume development which play a role in dry deposition: -! . 1. inside an area source +! . 1. inside an area source ! . 2. plume reaches the ground, but is not yet fully mixed ! . 3. plume is fully mixed over the mixing layer. -! . +! . ! htt - -! | . - +! | . - ! | . - central -! | . - axis -! | . - of -! | . - plume ---- xl (mixing height) ---------------------.--- +! | . - axis +! | . - of +! | . - plume ---- xl (mixing height) ---------------------.--- ! | . - . ! | . - . ! hbron| . - htot . -! | | . . +! | | . . ! | | . . ! | | . . -! | | . . +! | | . . ! | | . area source ! -----.-----------------------------------------.2222222222.3333333.33333333 -----|11111111111|22222222222222222222222222.33333333333 -! source no deposition xg receptor +! source no deposition xg receptor ! ! Note: the mixing height is also rising as function of the distance. ! -! Compute source depletion ratio = ratio of source strengths of depleted and undepleted source = +! Compute source depletion ratio = ratio of source strengths of depleted and undepleted source = ! ! x ! / vd(z) @@ -180,14 +180,14 @@ SUBROUTINE ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc ! cq1 : source depletion ratio for dry deposition for phase 1 (area source); ! cq1 = 1 for a point source ! cq2 : source depletion ratio for dry deposition for phase 2 (plume not yet mixed over mixing layer). -! This region starts at x = 0 (source) or at the edge of an area source and ends at x = xg. -! cq2 = 1 outside this region, and also in the case that we have a stable meteo class (class 5,6) and +! This region starts at x = 0 (source) or at the edge of an area source and ends at x = xg. +! cq2 = 1 outside this region, and also in the case that we have a stable meteo class (class 5,6) and ! a stack emitting above the mixing layer. ! disx : location of receptor (source at x = 0) ! xg : location where the plume is just fully mixed ! xx : representative distance for plume in phase 2 ! cxx : representative concentration (undepleted) for plume in phase 2 -! sigzxg: sigma_z at location xx +! sigzxg: sigma_z at location xx ! !----------------------------------------------------------------------------------------------------------- @@ -197,11 +197,11 @@ SUBROUTINE ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc ! for different phases of the plume. !----------------------------------------------------------------------------------------------------------- IF (disx .LT. (xg - EPS_DELTA)) THEN - + ! Receptor located where plume is in phase 1 (area source) or 2 (plume not yet fully mixed over mixing height): cdn = 1. - ! Representative distance and concentration for phase 2 of plume is that of the receptor + ! Representative distance and concentration for phase 2 of plume is that of the receptor xx = disx cxx = c @@ -212,50 +212,50 @@ SUBROUTINE ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc sigzxg = sigz ELSE - + ! Receptor located where plume is in phase 3: homogeneously mixed part of the plume -> Dz(x) = 1/xl = 1/mixing_height, 4.14 OPS report - ! + ! x ! / vd(z) (x - xg) vd(z) ! cdn = exp[- | ------- dksi ] = exp[- -------------- ], in which we substitute x = disx, vd(z) = vd(50) = vg50trans, u = ueff ! / u xl u xl ! ksi=xg - ! - ! + + cdn = EXP( - ((disx - xg)/ueff*vg50trans/xl)) ! Set representative distance for phase 2 of the plume and compute sigma_z there: xx = xg sigzxg = dispg(istab)*(xx**DISPH(istab)) - - ! Compute xlxg = mixing height at xg [m] by linear interpolation of xloc (near source at x = 0) and - ! xl100 (at 100 km from source), assuming a linear growth of the maximal mixing height with distance - ! + + ! Compute xlxg = mixing height at xg [m] by linear interpolation of xloc (near source at x = 0) and + ! xl100 (at 100 km from source), assuming a linear growth of the maximal mixing height with distance + ! xl(xg) - xl(0) xl(100) - xl(0) xg xg - ! --------------- = ---------------- <=> xlxg - xloc = ------(xl100 - xloc) <=> xlxg = xloc + ------(xl100 - xloc), in km + ! --------------- = ---------------- <=> xlxg - xloc = ------(xl100 - xloc) <=> xlxg = xloc + ------(xl100 - xloc), in km ! xg - 0 100 - 0 100 100 - + xlxg = xloc + xg/100000.*(xl100 - xloc) ! in m - + ! Compute wind speed uxg, using a power law. ! ux0 : wind speed at the beginning of the trajectory (near source) at plume height ! uxg : wind speed at (x,z) = (xg,mixing_height/2) ! ugem: average wind speed depending on phase of plume development; for phase 3, ugem ! is the average of near source wind speed (ux0) and uxg ! c : undepleted concentration at receptor at z = 0 m (without part of plume above mixing layer) - ! - ! + + ! |--------------------|------------------------------------------------| ! x=0 (source) xg (fully mixed) x=disx (receptor) - ! + ! cxx : undepleted concentration at xg; is used in the computation of cq2 (phase 2); we cannot use concentration c - ! (at receptor) here since the receptor is further away (where the plume is in phase 3); + ! (at receptor) here since the receptor is further away (where the plume is in phase 3); ! compute cxx (upstream) using linear scaling of concentration c at receptor with distance (factor disx/xg) ! and mixing layer height (factor xl/xlxg): ! cxx disx xl ! --- = ----- ------ (scaling factors are > 1, so cxx > c). ! c xg xlxg - ! + IF (xlxg/2. .GT. (HUMAX + EPS_DELTA)) THEN hf = HUMAX ELSE @@ -270,7 +270,7 @@ SUBROUTINE ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc !----------------------------------------------------------------------------------------------------------- ! Compute cgt = 1 - concentration gradient between heights z1 = 4 m and z2 = 50 m. !----------------------------------------------------------------------------------------------------------- -! A concentration gradient is caused by the deposition flux; +! A concentration gradient is caused by the deposition flux; ! it is assumed to start when the plume is well mixed in the mixing layer. ! ! vg(z2) @@ -282,7 +282,7 @@ SUBROUTINE ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc ! new formula for tau; ! ! According to OPS report 4.9, the concentration gradient at height z1 is: c(x,z1) = (1 - cgt) c(x,z2). -! +! ! Note: for t = 0 : cgt = 0; c(x,z1) = (1 - cgt)c(x,z2) = c(x,z2) (No concentration gradient installed yet) ! ! vg(z2) @@ -291,9 +291,9 @@ SUBROUTINE ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc ! First set a = representative distance between source and receptor; ! a = radius/4, for a receptor inside the area source (see dxeff in ops_depoparexp) -! a = x - radius/(4/3) = +! a = x - radius/(4/3) = ! = x - (3/4)radius, for a receptor outside the area source. -! At the edge of the area source, a = radius - (3/4)radius = radius/4, +! At the edge of the area source, a = radius - (3/4)radius = radius/4, ! so we have a continuous transition here. if (disx.lt.(radius-EPS_DELTA)) THEN a=radius/4 @@ -306,11 +306,11 @@ SUBROUTINE ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc cgt_z = cgt_z*(1.-exp(-a/(zm*(raz_rcp+rb_rcp+rc_rcp)*ugem))) !----------------------------------------------------------------------------------------------------------- -! Compute help variables for an area source, such as sigma_z, wind speeds ugem and uxr, effective height hf -! and vdoppb +! Compute help variables for an area source, such as sigma_z, wind speeds ugem and uxr, effective height hf +! and vdoppb !----------------------------------------------------------------------------------------------------------- ! Source depletion inside an area source is computed separately, because the behaviour of sigma_z is different. -! We choose here an approach as if sigma_z is constant within the area source and the concentration +! We choose here an approach as if sigma_z is constant within the area source and the concentration ! within height sigma_z is homogeneously distributed. ! IF (radius .GT. (0. + EPS_DELTA)) THEN @@ -318,18 +318,18 @@ SUBROUTINE ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc ! Receptor outside area source IF (disx .GT. (radius + EPS_DELTA)) THEN - ! Compute vertical dispersion coefficient s2 + ! Compute vertical dispersion coefficient s2 ! x = downwind distance = 2*radius = sa; see OPS report figure 3.6 - ! zu : representative plume height (m), taking into account reflection + ! zu : representative plume height (m), taking into account reflection ! 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, 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 + 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 - + ! Compute uxr = wind speed representative for plume over area source; (x = near source, h = effective plume height area source hf) - hf = (sigzr/4 + htot + 6.)/2. + hf = (sigzr/4 + htot + 6.)/2. CALL ops_wvprofile(z0_src, hf, uster_src, ol_src, uxr) ! Compute ugem = average wind speed, average between uxr (plume over area source) and ueff (at effective transport height) @@ -344,11 +344,11 @@ SUBROUTINE ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc IF (sigzr .GT. (xl100 + EPS_DELTA)) THEN sigzr = xl100 ENDIF - vdoppb = 1./((ra4src + rb_src + rcsrc)*sigzr) + vdoppb = 1./((ra4src + rb_src + rcsrc)*sigzr) ENDIF !----------------------------------------------------------------------------------------------------------- -! Compute cq2 = source depletion ratio for dry deposition for phase 2 +! Compute cq2 = source depletion ratio for dry deposition for phase 2 ! (plume is not yet homogeneously mixed over the mixing layer). !----------------------------------------------------------------------------------------------------------- ! This region starts at x = 0 (source) or at the edge of an area source and ends at x = xg; cq2 = 1 outside this region. @@ -361,19 +361,19 @@ SUBROUTINE ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc ! ! S = diameter area source; edge of area source at S/2 ! => 5.20 new OPS report: -! -! 2 beta vd(z) (x-R) x C(x) u 2 pi -! cq2 = exp(- --------------------- --------- ------ ) and C(x) = cxx*(1-cgt), Q0 = qbstf +! +! 2 beta vd(z) (x-R) x C(x) u 2 pi +! cq2 = exp(- --------------------- --------- ------ ) and C(x) = cxx*(1-cgt), Q0 = qbstf ! u Q0 Ns -! +! ! ueff: wind speed at receptor at effective transport height heff; for short distances heff = plume height; ! for large distances heff = 1/2 mixing height; heff is interpolated for intermediate distances. ! ugem: average wind speed depending on phase of plume development ! ! source code: ! 2.*al*1.e-6*vg0tra*(xx - radius) (xx + virty)*cxx*ueff*(1.-cgt) 2 pi FS -! cq2 = EXP( - ---------------------------------- -------------------------------- ------) -! ugem onder*qbstf 12 +! cq2 = EXP( - ---------------------------------- -------------------------------- ------) +! ugem onder*qbstf 12 ! cxx/onder is the concentration including the part above the mixing layer ?? ! Note error in (2.5.15) thesis van Jaarsveld with factor 2 instead of 4 @@ -383,15 +383,15 @@ SUBROUTINE ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc ! Compute help variables sh = sigma_z**2/h**2 and al = beta: sh = (sigzxg/htot)**2 al = 8./PI*sh/((1.+SQRT(1.+8/PI*sh))**2) - + ! If NOT (stable meteo class and stack emitting above mixing layer), compute cq2 (else cq2 = 1): - IF (flag .NE. 1) THEN + IF (flag .NE. 1) THEN cq2 = EXP( -(2.*al/qbstf*1.e-6*vg0tra/12*2*PI*(xx + virty)* cxx*ueff/ugem/onder*(xx - radius)*(1.-cgt))) ENDIF ENDIF !----------------------------------------------------------------------------------------------------------------- -! Compute cq1 = source depletion ratio for dry deposition for phase 1, area source (cq1 = 1 for a point source). +! Compute cq1 = source depletion ratio for dry deposition for phase 1, area source (cq1 = 1 for a point source). !----------------------------------------------------------------------------------------------------------------- ! ! 2 @@ -399,19 +399,19 @@ SUBROUTINE ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc ! z sqrt(2 pi) sigma_z ! ! Because all terms inside the integral are independent of x, we get: -! x -! / 2 vd(z) x 2 1 -! cq1 = exp[- | ----------- ----------- dx ] = exp[-vd(z) --- ----------- --------- ] -! / sqrt(2 pi) u sigma_z u sqrt(2 pi) sigma_z -! 0 +! x +! / 2 vd(z) x 2 1 +! cq1 = exp[- | ----------- ----------- dx ] = exp[-vd(z) --- ----------- --------- ] +! / sqrt(2 pi) u sigma_z u sqrt(2 pi) sigma_z +! 0 ! x: effective distance over which deposition takes place within an area source = diameter/4 (thesis van Jaarsveld 2.5.13) ! u: wind speed representative for area source = uxr -! Note: vdoppb = vd/sigma_z +! Note: vdoppb = vd/sigma_z ! ! source code: -! vdoppb*dxeff vd/sigma_z (S/4) exp(-a/18) vd (S/4) exp(-((vchem+vnatpri+vd/sigma_z) S)/(18 uxr )) -! cq1 = EXP( - ------------) = EXP( - ---------------------------) = EXP( - --------------------------------------------------------) -! uxr uxr uxr sigma_z +! vdoppb*dxeff vd/sigma_z (S/4) exp(-a/18) vd (S/4) exp(-((vchem+vnatpri+vd/sigma_z) S)/(18 uxr )) +! cq1 = EXP( - ------------) = EXP( - ---------------------------) = EXP( - --------------------------------------------------------) +! uxr uxr uxr sigma_z ! ! factor 3.6e5: conversion from percentage per hour -> fraction per second @@ -421,15 +421,15 @@ SUBROUTINE ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc ! k_wetdep = conversion rate for wet deposition = vnatpri/(3600*100) [1/s] ! k_chem = conversion rate for chemical conversion = vchem/(3600*100) [1/s] ! -! dxeff = distance over which deposition takes place = (S/4)*exp[-k*t], +! dxeff = distance over which deposition takes place = (S/4)*exp[-k*t], ! with t = travel time from centre of the area source to the edge = (radius/uxr) = diameter/(2*uxr) ! Parameterisation based on comparison with surface depletion model. ! -! help variable a = k*t = (k_chem + k_wetdep + k_drydep)*(diameter/(2*uxr)) = -! = ((vchem + vnatpri)/3.6e5 + vdoppb)*(diameter/(2*uxr)) +! help variable a = k*t = (k_chem + k_wetdep + k_drydep)*(diameter/(2*uxr)) = +! = ((vchem + vnatpri)/3.6e5 + vdoppb)*(diameter/(2*uxr)) ! -! .49 -! a > 15 -> a = 15 (a/15) +! .49 +! a > 15 -> a = 15 (a/15) ! ! See also ops_seccmp for dxeff = effective distance over which deposition takes place ! @@ -437,7 +437,7 @@ SUBROUTINE ops_brondepl(disx, xg, c, ux0, ueff, sigz, vg50trans, xl, istab, xloc ! for the area sources that are nowadays (2011) common in OPS, this correction is probably not important IF (ABS(radius) .GT. EPS_DELTA) THEN a = ((vchem + vnatpri)/3.6e5 + vdoppb)*diameter/uxr - IF (a .GT. (15. + EPS_DELTA)) THEN + IF (a .GT. (15. + EPS_DELTA)) THEN a = (a/15.)**.49*15. ENDIF dxeff = diameter/4.*EXP( -a/18.) ! factor 18 (or 9) is calibration factor from multipointsource test diff --git a/ops_calc_stats.f90 b/ops_calc_stats.f90 index 7d4cf47..8512882 100644 --- a/ops_calc_stats.f90 +++ b/ops_calc_stats.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -47,7 +47,7 @@ SUBROUTINE ops_calc_stats(nrrcp, nsubsec, frac, cpri, csec, drydep, wetdep, gemr IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_calc_stats') ! SUBROUTINE ARGUMENTS - INPUT @@ -59,23 +59,23 @@ SUBROUTINE ops_calc_stats(nrrcp, nsubsec, frac, cpri, csec, drydep, wetdep, gemr REAL*4, INTENT(IN) :: drydep(nrrcp) ! dry deposition REAL*4, INTENT(IN) :: wetdep(nrrcp) ! wet deposition REAL*4, INTENT(IN) :: gemre ! yearly mean precipitation from meteo statistics [mm/h] -DOUBLE PRECISION, INTENT(IN) :: sdrypri ! -DOUBLE PRECISION, INTENT(IN) :: sdrysec ! -DOUBLE PRECISION, INTENT(IN) :: somvnpri ! -DOUBLE PRECISION, INTENT(IN) :: somvnsec ! -DOUBLE PRECISION, INTENT(IN) :: vvchem ! -DOUBLE PRECISION, INTENT(IN) :: vtel ! -DOUBLE PRECISION, INTENT(IN) :: telvnpri ! -DOUBLE PRECISION, INTENT(IN) :: telvnsec ! -REAL*4, INTENT(IN) :: grid ! -REAL*4, INTENT(IN) :: conc_cf ! -REAL*4, INTENT(IN) :: amol21 ! -REAL*4, INTENT(IN) :: ugmoldep ! +DOUBLE PRECISION, INTENT(IN) :: sdrypri +DOUBLE PRECISION, INTENT(IN) :: sdrysec +DOUBLE PRECISION, INTENT(IN) :: somvnpri +DOUBLE PRECISION, INTENT(IN) :: somvnsec +DOUBLE PRECISION, INTENT(IN) :: vvchem +DOUBLE PRECISION, INTENT(IN) :: vtel +DOUBLE PRECISION, INTENT(IN) :: telvnpri +DOUBLE PRECISION, INTENT(IN) :: telvnsec +REAL*4, INTENT(IN) :: grid +REAL*4, INTENT(IN) :: conc_cf +REAL*4, INTENT(IN) :: amol21 +REAL*4, INTENT(IN) :: ugmoldep REAL*4, INTENT(IN) :: csubsec(nrrcp,nsubsec) ! concentration of sub-secondary species [ug/m3] ! SUBROUTINE ARGUMENTS - I/O -DOUBLE PRECISION, INTENT(INOUT) :: snatpri ! -DOUBLE PRECISION, INTENT(INOUT) :: snatsec ! +DOUBLE PRECISION, INTENT(INOUT) :: snatpri +DOUBLE PRECISION, INTENT(INOUT) :: snatsec ! SUBROUTINE ARGUMENTS - OUTPUT REAL*4, INTENT(OUT) :: gemcpri ! grid mean for primary concentration [ug/m3] @@ -111,7 +111,7 @@ SUBROUTINE ops_calc_stats(nrrcp, nsubsec, frac, cpri, csec, drydep, wetdep, gemr INTEGER*4 :: isubsec ! index of sub-secondary species ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! Summation over grid cells diff --git a/ops_conc_ini.f90 b/ops_conc_ini.f90 index dce9451..4e66fd3 100644 --- a/ops_conc_ini.f90 +++ b/ops_conc_ini.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO/IS ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Compute initial concentrations due to transport and dispersion; no removal processes yet. @@ -46,55 +46,55 @@ SUBROUTINE ops_conc_ini(gasv, vw10, htt, pcoef, disx, kdeel, qbpri, z0_src, szop IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_conc_ini') ! SUBROUTINE ARGUMENTS - INPUT -LOGICAL, INTENT(IN) :: gasv ! -REAL*4, INTENT(IN) :: vw10 ! +LOGICAL, INTENT(IN) :: gasv +REAL*4, INTENT(IN) :: vw10 REAL*4, INTENT(IN) :: htt ! plume height, excluding plume descent due to heavy particles [m] -REAL*4, INTENT(IN) :: pcoef ! -REAL*4, INTENT(IN) :: disx ! -INTEGER*4, INTENT(IN) :: kdeel ! -REAL*4, INTENT(IN) :: qbpri ! -REAL*4, INTENT(IN) :: z0_src ! roughness length at source; from z0-map [m] -REAL*4, INTENT(IN) :: szopp ! -INTEGER*4, INTENT(IN) :: rond ! -REAL*4, INTENT(IN) :: uster_src ! -REAL*4, INTENT(IN) :: ol_src ! -INTEGER*4, INTENT(IN) :: istab ! -INTEGER*4, INTENT(IN) :: iwd ! -REAL*4, INTENT(IN) :: qww ! -REAL*4, INTENT(IN) :: hbron ! -REAL*4, INTENT(IN) :: dispg(NSTAB) ! +REAL*4, INTENT(IN) :: pcoef +REAL*4, INTENT(IN) :: disx +INTEGER*4, INTENT(IN) :: kdeel +REAL*4, INTENT(IN) :: qbpri +REAL*4, INTENT(IN) :: z0_src ! roughness length at source; from z0-map [m] +REAL*4, INTENT(IN) :: szopp +INTEGER*4, INTENT(IN) :: rond +REAL*4, INTENT(IN) :: uster_src +REAL*4, INTENT(IN) :: ol_src +INTEGER*4, INTENT(IN) :: istab +INTEGER*4, INTENT(IN) :: iwd +REAL*4, INTENT(IN) :: qww +REAL*4, INTENT(IN) :: hbron +REAL*4, INTENT(IN) :: dispg(NSTAB) ! SUBROUTINE ARGUMENTS - I/O -REAL*4, INTENT(INOUT) :: radius ! -REAL*4, INTENT(INOUT) :: xl ! -REAL*4, INTENT(INOUT) :: onder ! -TYPE (TError), INTENT(INOUT) :: error ! error handling record +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] - ! htot = htt - pldaling -REAL*4, INTENT(OUT) :: grof ! -REAL*4, INTENT(OUT) :: c ! -REAL*4, INTENT(OUT) :: sigz ! -REAL*4, INTENT(OUT) :: ueff ! wind speed at effective transport height heff; + ! htot = htt - pldaling +REAL*4, INTENT(OUT) :: grof +REAL*4, INTENT(OUT) :: c +REAL*4, INTENT(OUT) :: sigz +REAL*4, INTENT(OUT) :: ueff ! wind speed at effective transport height heff; ! for short distances heff = plume height; ! for large distances heff = 1/2 mixing height; ! heff is interpolated for intermediate distances. -REAL*4, INTENT(OUT) :: virty ! -REAL*4, INTENT(OUT) :: ccc ! +REAL*4, INTENT(OUT) :: virty +REAL*4, INTENT(OUT) :: ccc ! LOCAL VARIABLES -REAL*4 :: ff ! -REAL*4 :: pldaling ! +REAL*4 :: ff +REAL*4 :: pldaling ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -104,23 +104,23 @@ SUBROUTINE ops_conc_ini(gasv, vw10, htt, pcoef, disx, kdeel, qbpri, z0_src, szop ! htot : plume height at receptor, including plume descent due to heavy particles; htot = htt - pldaling [m] ! ! htt \ -! | \ +! | \ ! | \ ! | \ ! | \ -! | \ +! | \ ! | \ ! | \ ! hbron| \ ! | | \ htot -! | | -! | | -! | | -! | | -! | | -! | | -! | | -! | | +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! | | ! ------------------------------------------------- ! source receptor ! @@ -136,7 +136,7 @@ SUBROUTINE ops_conc_ini(gasv, vw10, htt, pcoef, disx, kdeel, qbpri, z0_src, szop ! with vt : sedimentation or terminal settling velocity [m/s] ! rho_p : density of particle [kg/m3] ~ 1000 kg/m3 ! rho_air: density of air [kg/m3] = 1.293 kg/m3 (0 C), 1.205 kg/m3 (20 C) -! D_p : diameter of particle [m] +! D_p : diameter of particle [m] ! g : accelaration of gravity = 9.807 m/s2 ! mu : viscosity of air = 1.81e-5 [Pa s = N s/m2 = kg /(s m)] ! @@ -151,7 +151,7 @@ SUBROUTINE ops_conc_ini(gasv, vw10, htt, pcoef, disx, kdeel, qbpri, z0_src, szop ! (travel_distance/wind_speed) * sedimentation velocity pldaling = disx/ff*STOKES(kdeel) ! pl << plume, "daling" = descent -! Heavy particles if sedimentation velocity > 2 cm/s: +! Heavy particles if sedimentation velocity > 2 cm/s: IF (STOKES(kdeel) .GT. (.02 + EPS_DELTA)) THEN grof = 1. ! @@ -181,8 +181,8 @@ SUBROUTINE ops_conc_ini(gasv, vw10, htt, pcoef, disx, kdeel, qbpri, z0_src, szop 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, error) ! -! Correct for plume below or above the mixing layer; mass above the mixing layer does not contribute to -! concentration at surface. +! Correct for plume below or above the mixing layer; mass above the mixing layer does not contribute to +! concentration at surface. ! c : concentration at z = 0 m (without the part above the mixing layer); is needed for e.g. dry deposition ! ccc: concentration at z = 0 m (including part above mixing layer); is needed for e.g. wet deposition. ! diff --git a/ops_conc_rek.f90 b/ops_conc_rek.f90 index 7b52ae6..6dfa8ef 100644 --- a/ops_conc_rek.f90 +++ b/ops_conc_rek.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO/IS ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Compute concentration, taking into account source depletion factors for dry deposition, @@ -51,102 +51,102 @@ SUBROUTINE ops_conc_rek(ueff, qbpri, isec, rcsec, routsec, ccc, amol1, amol2, si IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_conc_rek') ! SUBROUTINE ARGUMENTS - INPUT -REAL*4, INTENT(IN) :: ueff ! -REAL*4, INTENT(IN) :: qbpri ! -LOGICAL, INTENT(IN) :: isec ! -REAL*4, INTENT(IN) :: rcsec ! +REAL*4, INTENT(IN) :: ueff +REAL*4, INTENT(IN) :: qbpri +LOGICAL, INTENT(IN) :: isec +REAL*4, INTENT(IN) :: rcsec REAL*4, INTENT(IN) :: routsec ! in-cloud scavenging ratio for secondary component ! (rout << rain-out = in-cloud) [-] -REAL*4, INTENT(IN) :: ccc ! -REAL*4, INTENT(IN) :: amol1 ! -REAL*4, INTENT(IN) :: amol2 ! -REAL*4, INTENT(IN) :: sigz ! +REAL*4, INTENT(IN) :: ccc +REAL*4, INTENT(IN) :: amol1 +REAL*4, INTENT(IN) :: amol2 +REAL*4, INTENT(IN) :: sigz REAL*4, INTENT(IN) :: utr ! average wind speed over the trajectory (m/s) -REAL*4, INTENT(IN) :: rc_sec_rcp ! -REAL*4, INTENT(IN) :: ra4_rcp ! -REAL*4, INTENT(IN) :: ra50_rcp ! -REAL*4, INTENT(IN) :: rb_rcp ! -REAL*4, INTENT(IN) :: amol21 ! -REAL*4, INTENT(IN) :: ugmoldep ! -REAL*4, INTENT(IN) :: cch ! -REAL*4, INTENT(IN) :: cgt ! +REAL*4, INTENT(IN) :: rc_sec_rcp +REAL*4, INTENT(IN) :: ra4_rcp +REAL*4, INTENT(IN) :: ra50_rcp +REAL*4, INTENT(IN) :: rb_rcp +REAL*4, INTENT(IN) :: amol21 +REAL*4, INTENT(IN) :: ugmoldep +REAL*4, INTENT(IN) :: cch +REAL*4, INTENT(IN) :: cgt REAL*4, INTENT(IN) :: cgt_z ! height dependent cgt -REAL*4, INTENT(IN) :: grof ! -REAL*4, INTENT(IN) :: percvk ! -REAL*4, INTENT(IN) :: onder ! -REAL*4, INTENT(IN) :: regenk ! -REAL*4, INTENT(IN) :: virty ! -REAL*4, INTENT(IN) :: ri ! -REAL*4, INTENT(IN) :: vw10 ! -REAL*4, INTENT(IN) :: hbron ! -REAL*4, INTENT(IN) :: pcoef ! -REAL*4, INTENT(IN) :: rkc ! -REAL*4, INTENT(IN) :: disx ! -REAL*4, INTENT(IN) :: vnatpri ! -REAL*4, INTENT(IN) :: vchem ! -REAL*4, INTENT(IN) :: radius ! -REAL*4, INTENT(IN) :: xl ! -REAL*4, INTENT(IN) :: xloc ! -REAL*4, INTENT(IN) :: htot ! -REAL*4, INTENT(IN) :: twt ! -REAL*4, INTENT(IN) :: rb ! -REAL*4, INTENT(IN) :: ra50 ! -REAL*4, INTENT(IN) :: xvghbr ! -REAL*4, INTENT(IN) :: xvglbr ! -REAL*4, INTENT(IN) :: grad ! +REAL*4, INTENT(IN) :: grof +REAL*4, INTENT(IN) :: percvk +REAL*4, INTENT(IN) :: onder +REAL*4, INTENT(IN) :: regenk +REAL*4, INTENT(IN) :: virty +REAL*4, INTENT(IN) :: ri +REAL*4, INTENT(IN) :: vw10 +REAL*4, INTENT(IN) :: hbron +REAL*4, INTENT(IN) :: pcoef +REAL*4, INTENT(IN) :: rkc +REAL*4, INTENT(IN) :: disx +REAL*4, INTENT(IN) :: vnatpri +REAL*4, INTENT(IN) :: vchem +REAL*4, INTENT(IN) :: radius +REAL*4, INTENT(IN) :: xl +REAL*4, INTENT(IN) :: xloc +REAL*4, INTENT(IN) :: htot +REAL*4, INTENT(IN) :: twt +REAL*4, INTENT(IN) :: rb +REAL*4, INTENT(IN) :: ra50 +REAL*4, INTENT(IN) :: xvghbr +REAL*4, INTENT(IN) :: xvglbr +REAL*4, INTENT(IN) :: grad REAL*4, INTENT(IN) :: frac ! fraction of this grid cell that is relevant -REAL*4, INTENT(IN) :: ra50tra ! -REAL*4, INTENT(IN) :: rb_tra ! -REAL*4, INTENT(IN) :: rclocal ! -REAL*4, INTENT(IN) :: vgpart ! +REAL*4, INTENT(IN) :: ra50tra +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 ! -REAL*4, INTENT(INOUT) :: cq2 ! -REAL*4, INTENT(INOUT) :: c ! -DOUBLE PRECISION, INTENT(INOUT) :: sdrypri ! -DOUBLE PRECISION, INTENT(INOUT) :: sdrysec ! -DOUBLE PRECISION, INTENT(INOUT) :: snatsec ! -DOUBLE PRECISION, INTENT(INOUT) :: somvnsec ! -DOUBLE PRECISION, INTENT(INOUT) :: telvnsec ! -DOUBLE PRECISION, INTENT(INOUT) :: vvchem ! -DOUBLE PRECISION, INTENT(INOUT) :: vtel ! -DOUBLE PRECISION, INTENT(INOUT) :: snatpri ! -DOUBLE PRECISION, INTENT(INOUT) :: somvnpri ! -DOUBLE PRECISION, INTENT(INOUT) :: telvnpri ! -DOUBLE PRECISION, INTENT(INOUT) :: ddepri ! -DOUBLE PRECISION, INTENT(INOUT) :: drydep ! -DOUBLE PRECISION, INTENT(INOUT) :: wetdep ! +REAL*4, INTENT(INOUT) :: cdn +REAL*4, INTENT(INOUT) :: cq2 +REAL*4, INTENT(INOUT) :: c +DOUBLE PRECISION, INTENT(INOUT) :: sdrypri +DOUBLE PRECISION, INTENT(INOUT) :: sdrysec +DOUBLE PRECISION, INTENT(INOUT) :: snatsec +DOUBLE PRECISION, INTENT(INOUT) :: somvnsec +DOUBLE PRECISION, INTENT(INOUT) :: telvnsec +DOUBLE PRECISION, INTENT(INOUT) :: vvchem +DOUBLE PRECISION, INTENT(INOUT) :: vtel +DOUBLE PRECISION, INTENT(INOUT) :: snatpri +DOUBLE PRECISION, INTENT(INOUT) :: somvnpri +DOUBLE PRECISION, INTENT(INOUT) :: telvnpri +DOUBLE PRECISION, INTENT(INOUT) :: ddepri +DOUBLE PRECISION, INTENT(INOUT) :: drydep +DOUBLE PRECISION, INTENT(INOUT) :: wetdep ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: qsec ! -REAL*4, INTENT(OUT) :: consec ! -REAL*4, INTENT(OUT) :: pr ! -REAL*4, INTENT(OUT) :: vg50trans ! +REAL*4, INTENT(OUT) :: qsec +REAL*4, INTENT(OUT) :: consec +REAL*4, INTENT(OUT) :: pr +REAL*4, INTENT(OUT) :: vg50trans ! LOCAL VARIABLES REAL*4 :: qpri_depl ! depleted source strength = integrated mass flux [g/s] -REAL*4 :: vv ! -REAL*4 :: drypri ! -REAL*4 :: ddrup ! -REAL*4 :: vdrup ! -REAL*4 :: umid ! -REAL*4 :: virnat ! -REAL*4 :: dn ! -REAL*4 :: dnatpri ! +REAL*4 :: vv +REAL*4 :: drypri +REAL*4 :: ddrup +REAL*4 :: vdrup +REAL*4 :: umid +REAL*4 :: virnat +REAL*4 :: dn +REAL*4 :: dnatpri REAL*4 :: xvg ! factor not used; xvg = 1 -REAL*4 :: cgtsec ! -REAL*4 :: vgsec ! -REAL*4 :: vg_sec_rcp ! -REAL*4 :: vnatsec ! -REAL*4 :: drysec ! -REAL*4 :: dnatsec ! -REAL*4 :: vg4lok ! +REAL*4 :: cgtsec +REAL*4 :: vgsec +REAL*4 :: vg_sec_rcp +REAL*4 :: vnatsec +REAL*4 :: drysec +REAL*4 :: dnatsec +REAL*4 :: vg4lok REAL*4 :: c_z ! bewaren van de hoogte afhankelijke c REAL*4 :: xg @@ -155,10 +155,10 @@ SUBROUTINE ops_conc_rek(ueff, qbpri, isec, rcsec, routsec, ccc, amol1, amol2, si EXTERNAL ops_seccmp ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- -! Initialisation +! Initialisation drysec = 0. dnatsec = 0. ! @@ -166,10 +166,10 @@ SUBROUTINE ops_conc_rek(ueff, qbpri, isec, rcsec, routsec, ccc, amol1, amol2, si ! source depletion factor for wet deposition/chemical conversion (cch) and gradient factor (1-cgt). ! ! grof = 0 -> cdn*cch*(1. - cgt)*(1. - (1. - cq2)/(1. + grof)) = cdn*cch*(1. - cgt)*cq2 -! grof = 1 -> cdn*cch*(1. - cgt)*(1. - (1. - cq2)/(1. + grof)) = cdn*cch*(1. - cgt)*(1 + cq2)/2 +! grof = 1 -> cdn*cch*(1. - cgt)*(1. - (1. - cq2)/(1. + grof)) = cdn*cch*(1. - cgt)*(1 + cq2)/2 ! (1+cq2)/2 = 0.5 for cq2 = 0 (all depleted) -! (1+cq2)/2 = 1 for cq2 = 1 (nothing depleted), and linear for 0 < cq2 < 1 -! meaning that the concentration is higher due to sedimentation +! (1+cq2)/2 = 1 for cq2 = 1 (nothing depleted), and linear for 0 < cq2 < 1 +! 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))*buildingFact @@ -177,7 +177,7 @@ SUBROUTINE ops_conc_rek(ueff, qbpri, isec, rcsec, routsec, ccc, amol1, amol2, si vv = cdn*cq2*cch ! -! Dry deposition velocity +! Dry deposition velocity ! IF (grof .EQ. 1) THEN vg4lok = 1./(ra4_rcp+rb_rcp) + vgpart @@ -186,10 +186,10 @@ SUBROUTINE ops_conc_rek(ueff, qbpri, isec, rcsec, routsec, ccc, amol1, amol2, si ENDIF ! ! Compute drypri = dry deposition mass flux [ug/m2/h] of primary component = -vd*concentration -! and sdrypri = summed dry deposition [ug/m2/h] of primary component (weighed with fraction cell inside NL) +! and sdrypri = summed dry deposition [ug/m2/h] of primary component (weighed with fraction cell inside NL) ! -! grof = 0 -> (1. - .5*grof) = 1 -! grof = 1 -> (1. - .5*grof) = 1/2 +! grof = 0 -> (1. - .5*grof) = 1 +! grof = 1 -> (1. - .5*grof) = 1/2 ! ! factor 3600 -> flux in ug/m2/h ! factor percvk -> fraction of occurrence of {distance/stability/wind-direction} class @@ -249,13 +249,13 @@ SUBROUTINE ops_conc_rek(ueff, qbpri, isec, rcsec, routsec, ccc, amol1, amol2, si ! qpri_depl = qbpri*cdn*cq2*cch ! -! Compute dnatpri = wet deposition flux [ug/m2/h] of primary component +! Compute dnatpri = wet deposition flux [ug/m2/h] of primary component ! and snatpri = summed wet deposition of primary component (weighed with fraction cell inside NL) ! vnatpri: [%/h] wet deposition loss rate for primary components -! qpri_depl : [g/s] +! qpri_depl : [g/s] ! dn : [s/m2 ug/g] ! qpri_depl*dn : [ug/m2] deposited mass per area, during time step dt; qpri_depl*dn = Q(x)*dt*percvk*1e6/A -! +! IF ((disx + virty) .LT. (virnat - EPS_DELTA)) THEN dnatpri = 0. ELSE @@ -270,7 +270,7 @@ SUBROUTINE ops_conc_rek(ueff, qbpri, isec, rcsec, routsec, ccc, amol1, amol2, si telvnpri = telvnpri + qpri_depl*dn ! ! Compute concentration and deposition of secondary component (SO4, NO3, NH4) -! +! IF (isec) THEN IF (vchem .GT. (0. + EPS_DELTA)) THEN xvg = 1. @@ -280,24 +280,24 @@ SUBROUTINE ops_conc_rek(ueff, qbpri, isec, rcsec, routsec, ccc, amol1, amol2, si & 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: +! Compute for secondary component: ! vg_sec_rcp: dry deposition velocity [m/s] ! drysec : dry deposition flux = -vd*C [ug/m3 m/s s/h] = [ug/m2/h] -! consec : concentration of plume below mixing layer, +! consec : concentration of plume below mixing layer, ! assuming a vertical profile (factor 1-cgtsec) [ug/m3] -! dnatsec : wet deposition flux [g/s 1/h s/m2 ug/g] = [ug/m2/h] +! dnatsec : wet deposition flux [g/s 1/h s/m2 ug/g] = [ug/m2/h] ! sdrysec : summed dry deposition flux [ug/m2/h] ! snatsec : summed wet deposition flux [ug/m2/h] ! Summed fluxed (drysec and snatsec) are weighed with the fraction of cell inside NL -! +! vg_sec_rcp = 1./(rc_sec_rcp + ra50_rcp + rb_rcp) drysec = consec*percvk*vg_sec_rcp*3600*onder sdrysec = sdrysec + drysec*frac consec = consec*onder*(1. - cgtsec) - dnatsec = qsec*vnatsec*dn + dnatsec = qsec*vnatsec*dn snatsec = snatsec + dnatsec*frac ! -! Sum wet deposition flux for secondary component +! Sum wet deposition flux for secondary component ! IF (regenk .GT. (0. + EPS_DELTA)) THEN somvnsec = somvnsec + dnatsec @@ -306,13 +306,13 @@ SUBROUTINE ops_conc_rek(ueff, qbpri, isec, rcsec, routsec, ccc, amol1, amol2, si ENDIF ENDIF ! -! Sum chemical conversion rate (weighed with qpri_depl*dn = deposited mass per area [ug/m2]) +! Sum chemical conversion rate (weighed with qpri_depl*dn = deposited mass per area [ug/m2]) ! vvchem = vvchem + (vchem*qpri_depl*dn) vtel = vtel + (qpri_depl*dn) ! ! Sum deposition (drydep = dry/primary+secondary, ddepri = dry/primary, wetdep = wet/primary+secondary); -! convert from ug/m2/h to mol/ha/y +! convert from ug/m2/h to mol/ha/y ! drydep = drydep + (drypri*amol21 + drysec)*ugmoldep ddepri = ddepri + (drypri*amol21*ugmoldep) diff --git a/ops_conltexp.f90 b/ops_conltexp.f90 index 3c0ac0a..defde5e 100644 --- a/ops_conltexp.f90 +++ b/ops_conltexp.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,11 +27,11 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Compute long term concentration for a given source and source-receptor distance; -! special version including correction for heavy plumes. +! special version including correction for heavy plumes. ! Concentration due to transport and dispersion only; no removal processes yet. ! Here, the concentration is computed at z = 0 m height. May be a problem very near a source, ! where there is a strong concentration profile. Later on, we apply a concentration profile, due to deposition, @@ -53,7 +53,7 @@ SUBROUTINE ops_conltexp(rond, ol, qbron, szopp, uster, z0, htt, onder, vw10, pco IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_conltexp') ! CONSTANTS @@ -65,67 +65,67 @@ SUBROUTINE ops_conltexp(rond, ol, qbron, szopp, uster, z0, htt, onder, vw10, pco PARAMETER (PS = 159155.) ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: rond ! +INTEGER*4, INTENT(IN) :: rond REAL*4, INTENT(IN) :: ol ! Monin-Obukhov lengte -REAL*4, INTENT(IN) :: qbron ! +REAL*4, INTENT(IN) :: qbron REAL*4, INTENT(IN) :: szopp ! initial vertical dispersion of source REAL*4, INTENT(IN) :: uster ! frictiesnelheid REAL*4, INTENT(IN) :: z0 ! ruwheidslengte (m) -REAL*4, INTENT(IN) :: htt ! -REAL*4, INTENT(IN) :: onder ! -REAL*4, INTENT(IN) :: vw10 ! -REAL*4, INTENT(IN) :: pcoef ! -INTEGER*4, INTENT(IN) :: istab ! -REAL*4, INTENT(IN) :: disx ! -REAL*4, INTENT(IN) :: grof ! -INTEGER*4, INTENT(IN) :: iwd ! -REAL*4, INTENT(IN) :: qww ! -REAL*4, INTENT(IN) :: hbron ! -REAL*4, INTENT(IN) :: dispg(NSTAB) ! +REAL*4, INTENT(IN) :: htt +REAL*4, INTENT(IN) :: onder +REAL*4, INTENT(IN) :: vw10 +REAL*4, INTENT(IN) :: pcoef +INTEGER*4, INTENT(IN) :: istab +REAL*4, INTENT(IN) :: disx +REAL*4, INTENT(IN) :: grof +INTEGER*4, INTENT(IN) :: iwd +REAL*4, INTENT(IN) :: qww +REAL*4, INTENT(IN) :: hbron +REAL*4, INTENT(IN) :: dispg(NSTAB) ! SUBROUTINE ARGUMENTS - I/O -REAL*4, INTENT(INOUT) :: radius ! -REAL*4, INTENT(INOUT) :: htot ! -TYPE (TError), INTENT(INOUT) :: error ! error handling record +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 -REAL*4, INTENT(OUT) :: sigz ! -REAL*4, INTENT(OUT) :: ueff ! wind speed at effective transport height heff; +REAL*4, INTENT(OUT) :: sigz +REAL*4, INTENT(OUT) :: ueff ! wind speed at effective transport height heff; ! for short distances heff = plume height; ! for large distances heff = 1/2 mixing height; ! heff is interpolated for intermediate distances. -REAL*4, INTENT(OUT) :: xl ! -REAL*4, INTENT(OUT) :: virty ! +REAL*4, INTENT(OUT) :: xl +REAL*4, INTENT(OUT) :: virty ! LOCAL VARIABLES REAL*4 :: a ! reflection term source-surface-mixing height-surface REAL*4 :: b ! reflection term source-mixing height-surface -REAL*4 :: cls ! -REAL*4 :: disp ! -REAL*4 :: f ! -REAL*4 :: f1 ! -REAL*4 :: f2 ! -REAL*4 :: h ! +REAL*4 :: cls +REAL*4 :: disp +REAL*4 :: f +REAL*4 :: f1 +REAL*4 :: f2 +REAL*4 :: h REAL*4 :: hf ! effective transport height [m] REAL*4 :: pld ! pluimdaling -REAL*4 :: pp ! -REAL*4 :: qq ! -REAL*4 :: rr ! -REAL*4 :: sz ! -REAL*4 :: tl ! -REAL*4 :: u1 ! -REAL*4 :: utl ! +REAL*4 :: pp +REAL*4 :: qq +REAL*4 :: rr +REAL*4 :: sz +REAL*4 :: tl +REAL*4 :: u1 +REAL*4 :: utl ! FUNCTIONS -REAL*4 :: ops_virtdist ! +REAL*4 :: ops_virtdist !DATA DATA ZWCOR/1.2, 1.1, 0.8, 0.6, 0.75, 0.6/ ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -141,7 +141,7 @@ SUBROUTINE ops_conltexp(rond, ol, qbron, szopp, uster, z0, htt, onder, vw10, pco ! IF (ABS(onder) .LE. EPS_DELTA) THEN ! -! Set h = plume height, including plume descent due to heavy particles and limit to HUMAX +! Set h = plume height, including plume descent due to heavy particles and limit to HUMAX ! IF (htot .GT. (HUMAX + EPS_DELTA)) THEN h = HUMAX @@ -190,7 +190,7 @@ SUBROUTINE ops_conltexp(rond, ol, qbron, szopp, uster, z0, htt, onder, vw10, pco ! grof = 1 ("grof" = coarse): heavy particles ! correction for large distances and heavy plumes ! -! Compute u1 = wind speed at htt/2 +! Compute u1 = wind speed at htt/2 ! htt = plume height, excluding plume descent due to heavy particles [m] u1 = vw10*((htt/20.)**pcoef) @@ -201,7 +201,7 @@ SUBROUTINE ops_conltexp(rond, ol, qbron, szopp, uster, z0, htt, onder, vw10, pco ELSE tl = 500. ENDIF - + ! utl = u1 * tl + radius = characteristic travel distance [m] utl = (u1*tl) + radius IF (utl .LT. (disx - EPS_DELTA)) THEN @@ -260,7 +260,7 @@ SUBROUTINE ops_conltexp(rond, ol, qbron, szopp, uster, z0, htt, onder, vw10, pco ueff = vw10*((hf/10.)**pcoef) ! 920906 ! ! Compute concentration at receptor for case 3: -! +! ! Q(x) Q(x) NSEK 1 ! C(x) = ----- D (x) D (x) = ----- -------- ---- , 3.7, 3.8, 3.9 OPS report ! u y z u 2 pi x zi @@ -277,7 +277,7 @@ SUBROUTINE ops_conltexp(rond, ol, qbron, szopp, uster, z0, htt, onder, vw10, pco ! qq = .6*sqrt(1. - htot/xl) ! -! Compute hf = effective transport height over trajectory, by interpolating effective plume height at short distance and +! Compute hf = effective transport height over trajectory, by interpolating effective plume height at short distance and ! (mixing heigth)/2 at large distance (where plume is assumed to be well mixed over whole mixing layer). ! For heavy particles (grof > 0.2) hf = plume_height/2 ! hf = (1. - pp/1.6)*htt + (pp/1.6)*xl/2. ? @@ -297,21 +297,21 @@ SUBROUTINE ops_conltexp(rond, ol, qbron, szopp, uster, z0, htt, onder, vw10, pco ! ! Compute wind speed at effective transport height by either a power law (hf > 50 m) ! or by a logarithmic wind profile (hf <= 50 m). -! +! IF ( hf .GT. 50 ) THEN ueff = vw10*(hf/10)**pcoef ELSE CALL ops_wvprofile(z0, hf, uster, ol, ueff) ENDIF -! +! ! qq = .6*sqrt(1. - htot/xl) ! pp = sigma_z/mixing_height ! ! For coarse particles (grof = 1) switch pp > qq/3 instead of pp > qq; ! idea is that for coarse particles we have a descending plume and the reflection -! at the earth surface takes place earlier +! at the earth surface takes place earlier - IF (pp .GT. (qq/(grof*2. + 1.) + EPS_DELTA)) THEN + IF (pp .GT. (qq/(grof*2. + 1.) + EPS_DELTA)) THEN ! ! Case 2 (intermediate distance) ! @@ -319,30 +319,30 @@ SUBROUTINE ops_conltexp(rond, ol, qbron, szopp, uster, z0, htt, onder, vw10, pco ! b = reflection term from source-mixing_layer-surface ! ! 3.15 in OPS report is rewritten as follows -! +! ! In the following h = htot = htt - pld ! ! 2 -h**2 -(2 zi + h)**2 -(2 zi - h)**2 -! D (x) = ------------------- { exp[--------------] + exp [----------------] + exp [---------------] } = +! D (x) = ------------------- { exp[--------------] + exp [----------------] + exp [---------------] } = ! z sqrt(2 pi) sigma_z 2 sigma_z**2 2 sigma_z**2 2 sigma_z**2 ! ! 2 -h**2 -[(2 zi + h)**2 - h**2] -[(2 zi - h)**2 - h**2] ! = ------------------- exp[--------------] * {1 + exp [------------------------] + exp [----------------------] } ! sqrt(2 pi) sigma_z 2 sigma_z**2 2 sigma_z**2 2 sigma_z**2 ! -! 2 -h**2 -! = ------------------- exp[--------------] * {1 + a + b} = -! sqrt(2 pi) sigma_z 2 sigma_z**2 +! 2 -h**2 +! = ------------------- exp[--------------] * {1 + a + b} = +! sqrt(2 pi) sigma_z 2 sigma_z**2 ! ! -! 2 -h**2 +! 2 -h**2 ! = ------------------- exp[--------------] * cls . -! sqrt(2 pi) sigma_z 2 sigma_z**2 +! sqrt(2 pi) sigma_z 2 sigma_z**2 ! ! rr = sigz*sigz*2. ! - a = EXP( - 4.*xl*pld/rr)* EXP( - ((2.*xl + htot)**2 - htot*htot)/rr) - b = EXP( - 4*(xl-htt)*pld/rr)* EXP(-((2*xl-htt-pld)**2 - htot*htot)/rr) + a = EXP( - 4.*xl*pld/rr)* EXP( - ((2.*xl + htot)**2 - htot*htot)/rr) + b = EXP( - 4*(xl-htt)*pld/rr)* EXP(-((2*xl-htt-pld)**2 - htot*htot)/rr) cls = 1. + a + b ELSE ! @@ -352,8 +352,8 @@ SUBROUTINE ops_conltexp(rond, ol, qbron, szopp, uster, z0, htt, onder, vw10, pco ENDIF ! ! Compute concentration at receptor for cases 1 and 2 -! -! Q(x) Q(x) NSEK 2 -h**2 +! +! Q(x) Q(x) NSEK 2 -h**2 ! C(x) = ----- D (x) D (x) = ----- -------- ------------------- exp[--------------] * cls, 3.7, 3.8, 3.15 OPS report ! u y z u 2 pi x sqrt(2 pi) sigma_z 2 sigma_z**2 ! @@ -372,7 +372,7 @@ SUBROUTINE ops_conltexp(rond, ol, qbron, szopp, uster, z0, htt, onder, vw10, pco f = (disx + virty)/virty f1 = (radius - disx)/radius f2 = EXP( - (htt*htt)/(sigz*sigz)) - c = c*((f - 1)*(f1**.4)*f2 + 1.) + c = c*((f - 1)*(f1**.4)*f2 + 1.) ENDIF ENDIF @@ -391,47 +391,47 @@ SUBROUTINE par_oppbr(rond, iwd, disx, istab, disp, htt, grof, dispg, zwcor, radi USE Binas, only: deg2rad ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'par_oppbr') ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: rond ! -INTEGER*4, INTENT(IN) :: iwd ! -REAL*4, INTENT(IN) :: disx ! -INTEGER*4, INTENT(IN) :: istab ! -REAL*4, INTENT(IN) :: disp ! -REAL*4, INTENT(IN) :: htt ! -REAL*4, INTENT(IN) :: grof ! -REAL*4, INTENT(IN) :: dispg(NSTAB) ! -REAL*4, INTENT(IN) :: zwcor(NSTAB) ! +INTEGER*4, INTENT(IN) :: rond +INTEGER*4, INTENT(IN) :: iwd +REAL*4, INTENT(IN) :: disx +INTEGER*4, INTENT(IN) :: istab +REAL*4, INTENT(IN) :: disp +REAL*4, INTENT(IN) :: htt +REAL*4, INTENT(IN) :: grof +REAL*4, INTENT(IN) :: dispg(NSTAB) +REAL*4, INTENT(IN) :: zwcor(NSTAB) ! SUBROUTINE ARGUMENTS - I/O -REAL*4, INTENT(INOUT) :: radius ! -REAL*4, INTENT(INOUT) :: sz ! +REAL*4, INTENT(INOUT) :: radius +REAL*4, INTENT(INOUT) :: sz ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: virty ! -REAL*4, INTENT(OUT) :: rr ! -REAL*4, INTENT(OUT) :: sigz ! -REAL*4, INTENT(OUT) :: pld ! -REAL*4, INTENT(OUT) :: htot ! +REAL*4, INTENT(OUT) :: virty +REAL*4, INTENT(OUT) :: rr +REAL*4, INTENT(OUT) :: sigz +REAL*4, INTENT(OUT) :: pld +REAL*4, INTENT(OUT) :: htot ! LOCAL VARIABLES -REAL*4 :: cr ! -REAL*4 :: radr ! -REAL*4 :: dx ! -REAL*4 :: dy ! -REAL*4 :: sta1 ! -REAL*4 :: sta2 ! -REAL*4 :: s1 ! -REAL*4 :: s2 ! -REAL*4 :: dsx ! +REAL*4 :: cr +REAL*4 :: radr +REAL*4 :: dx +REAL*4 :: dy +REAL*4 :: sta1 +REAL*4 :: sta2 +REAL*4 :: s1 +REAL*4 :: s2 +REAL*4 :: dsx ! FUNCTIONS -REAL*4 :: ops_virtdist ! +REAL*4 :: ops_virtdist ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -446,7 +446,7 @@ SUBROUTINE par_oppbr(rond, iwd, disx, istab, disp, htt, grof, dispg, zwcor, radi ELSE ! ! Square area source; -! Compute correction factor cr for corrected source radius r' = r*cr, such that r' represents a 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)*deg2rad)) dy = ABS(radius*COS(FLOAT(iwd)*deg2rad)) @@ -472,10 +472,10 @@ SUBROUTINE par_oppbr(rond, iwd, disx, istab, disp, htt, grof, dispg, zwcor, radi s1 = dispg(istab)*((disx - radr)**disp) dsx = disx ENDIF -s2 = 0.92*dispg(istab)*((dsx + radius)**disp) +s2 = 0.92*dispg(istab)*((dsx + radius)**disp) ! sz OPS report: represents the distribution of source heights within the area source -sz = 0.1 +sz = 0.1 IF (abs(s2-s1) .LE. 1.E-04) s2 = s1*1.001 @@ -502,27 +502,27 @@ END SUBROUTINE par_oppbr SUBROUTINE par_puntbr(qww, istab, disx, disp, htt, htot, hbron, dispg, sigz, hf, a, virty) ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'par_puntbr') ! SUBROUTINE ARGUMENTS - INPUT -REAL*4, INTENT(IN) :: qww ! -INTEGER*4, INTENT(IN) :: istab ! -REAL*4, INTENT(IN) :: disx ! -REAL*4, INTENT(IN) :: disp ! -REAL*4, INTENT(IN) :: htt ! -REAL*4, INTENT(IN) :: htot ! -REAL*4, INTENT(IN) :: hbron ! -REAL*4, INTENT(IN) :: dispg(NSTAB) ! +REAL*4, INTENT(IN) :: qww +INTEGER*4, INTENT(IN) :: istab +REAL*4, INTENT(IN) :: disx +REAL*4, INTENT(IN) :: disp +REAL*4, INTENT(IN) :: htt +REAL*4, INTENT(IN) :: htot +REAL*4, INTENT(IN) :: hbron +REAL*4, INTENT(IN) :: dispg(NSTAB) ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: sigz ! -REAL*4, INTENT(OUT) :: hf ! -REAL*4, INTENT(OUT) :: a ! -REAL*4, INTENT(OUT) :: virty ! +REAL*4, INTENT(OUT) :: sigz +REAL*4, INTENT(OUT) :: hf +REAL*4, INTENT(OUT) :: a +REAL*4, INTENT(OUT) :: virty ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -544,7 +544,7 @@ SUBROUTINE par_puntbr(qww, istab, disx, disp, htt, htot, hbron, dispg, sigz, hf, ! Add extra vertical dispersion due to buoyant plumes; 2.5066 = sqrt(2*pi); ! taken from OML model (Berkowicz and Olesen, 1986) - a = (htot - hbron)/2.5066 + a = (htot - hbron)/2.5066 a = AMIN1(sigz, a)/1.5 ! 960115 sigz = SQRT((sigz*sigz) + (a*a)) ENDIF diff --git a/ops_convec.f90 b/ops_convec.f90 index de313c8..6ba2560 100644 --- a/ops_convec.f90 +++ b/ops_convec.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN(HP-UX, HP-F77) ! DESCRIPTION : This routine calculates sigmaz for convective cases according to Weil and Brower (1982) formally defined @@ -46,7 +46,7 @@ SUBROUTINE ops_convec(z0, zi, ol, uster, h, x, uh, zu, szc) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_convec') ! CONSTANTS @@ -63,19 +63,19 @@ SUBROUTINE ops_convec(z0, zi, ol, uster, h, x, uh, zu, szc) ! SUBROUTINE ARGUMENTS - OUTPUT REAL*4, INTENT(OUT) :: uh ! windspeed at representative plume height (m/s) -REAL*4, INTENT(OUT) :: zu ! representative plume height (m), taking into account reflection +REAL*4, INTENT(OUT) :: zu ! representative plume height (m), taking into account reflection ! at the top of the mixing layer and at the ground surface REAL*4, INTENT(OUT) :: szc ! convective vertical dispersion coefficient (m) ! LOCAL VARIABLES -INTEGER*4 :: last ! -REAL*4 :: s ! -REAL*4 :: wster ! -REAL*4 :: xs ! -LOGICAL :: finished ! +INTEGER*4 :: last +REAL*4 :: s +REAL*4 :: wster +REAL*4 :: xs +LOGICAL :: finished ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -96,9 +96,9 @@ SUBROUTINE ops_convec(z0, zi, ol, uster, h, x, uh, zu, szc) ! (2.1, 3.19, 3.20 OPS report) ! ! 3 3 -! T rho_a cp (u*) (u*) g H0 +! T rho_a cp (u*) (u*) g H0 ! L = ---------------- => --------- = ------------ -! g H0 kappa L kappa T rho_a cp +! g H0 kappa L kappa T rho_a cp ! ! 3 ! g H0 zi 1/3 zi (u*) 1/3 @@ -109,7 +109,7 @@ SUBROUTINE ops_convec(z0, zi, ol, uster, h, x, uh, zu, szc) ! (sigma_wm/w*)^2 = (1.26 u*/w*)^2 (Panowski et al , 1977) ! Extra factor 0.7 for szc from calibration on Gryning and Holtslag data; ! - wster = (zi*uster**3/(-ol*0.4))**.333 + wster = (zi*uster**3/(-ol*0.4))**.333 xs = (wster*x)/(uh*zi) szc = (zi*xs*(0.314 + (1.26*uster/wster)**2)**0.5)*0.7 ! @@ -118,7 +118,7 @@ SUBROUTINE ops_convec(z0, zi, ol, uster, h, x, uh, zu, szc) ! s = 0.69*szc ! -! For low sources (h < z1/2), the ground surface forces the centre of mass of the plume upwards. +! For low sources (h < z1/2), the ground surface forces the centre of mass of the plume upwards. ! Three cases ! 1. s < h, relatively small plume that does not touch the ground -> no action anymore, zu = h = stack height ! 2. s > h @@ -133,15 +133,15 @@ SUBROUTINE ops_convec(z0, zi, ol, uster, h, x, uh, zu, szc) ENDIF last = 1 ! -! For high sources (h > z1/2), the inversion at the mixing height forces the centre of mass of the plume downwards. +! For high sources (h > z1/2), the inversion at the mixing height forces the centre of mass of the plume downwards. ! Three cases ! 1. s < zi-h, relatively small plume that does not touch the mixing height -> no action anymore, zu = h = stack height ! 2. s > zi-h ! 2a. zi-s < zi/2 <=> s > zi/2, very broad plume that touches both the ground and the mixing height -> zu = zi/2 = 1/2 mixing height -! 2b. zi-s > zi/2 <=> s < zi/2, relatively broad plume that touches only the mixing height -> zu = zi - s (lower than h, +! 2b. zi-s > zi/2 <=> s < zi/2, relatively broad plume that touches only the mixing height -> zu = zi - s (lower than h, ! because zi - s < zi - (zi-h) = h) ! - ELSE IF ((h .GT. (zi/2. + EPS_DELTA)) .AND. (s .GT. (zi - h + EPS_DELTA)) .AND. (last .EQ. 1)) THEN + ELSE IF ((h .GT. (zi/2. + EPS_DELTA)) .AND. (s .GT. (zi - h + EPS_DELTA)) .AND. (last .EQ. 1)) THEN IF ((zi - s) .LT. (zi/2. - EPS_DELTA)) THEN zu = zi/2. ELSE diff --git a/ops_depoparexp.f90 b/ops_depoparexp.f90 index d47e03d..1f480cd 100644 --- a/ops_depoparexp.f90 +++ b/ops_depoparexp.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,11 +27,11 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Get parameters needed for dry deposition, wet deposition and chemical conversion. -! Not only deposition velocities, but especially those parameters that deal with the mass loss +! Not only deposition velocities, but especially those parameters that deal with the mass loss ! due to these processes over a certain travel distance. In an analytical model, this mass loss is not ! summed on a step-by-step basis along a trajectory, but instead, the integral of the mass loss at ! the receptor is computed. @@ -49,10 +49,10 @@ ! For wet deposition, the cloud base is assumed to be equal to the mixing height. ! ! In this routine, we distinguish gaseous and particulate substances; the deposition of particles depends -! on the particle size. Heavy particles cause a plume to descend. Coarse particles (>20 um) are treated +! on the particle size. Heavy particles cause a plume to descend. Coarse particles (>20 um) are treated ! separately; it is assumed that the deposition velocity of coarse particles equals half the sedimentation ! velocity. -! +! ! EXIT CODES : ! FILES AND OTHER : ! I/O DEVICES @@ -66,7 +66,7 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc & error, pr, twt, cratio, rc_rcp, grad, rc, utr, vg50_rcp, routpri, vg50trans, rkc, ri, vnatpri, & & cgt, cgt_z, cq2, cdn, cch, z0_src, ol_src, uster_src, z0_tra, rctra_0, rcsrc, ra4src, rb_src, & & ra50src, ra4tra, ra50tra, rb_tra, vgpart, xm, ym, zm, bx, by, xg) - + USE m_commonconst USE m_commonfile @@ -75,141 +75,141 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_depoparexp') ! CONSTANTS REAL*4 :: RCDEEL(NPARTCLASS) ! waarden van rc per deeltjesklasse REAL*4 :: RDS(NSTAB) ! grenslaagweerstand per stab. klasse REAL*4 :: RORATIO(NPARTCLASS) ! (geschatte) waarden scavenging ratio per deeltjesklasse -REAL*4 :: VGDEEL(NPARTCLASS) ! -REAL*4 :: RA4S(NSTAB) ! +REAL*4 :: VGDEEL(NPARTCLASS) +REAL*4 :: RA4S(NSTAB) ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: kdeel ! -REAL*4, INTENT(IN) :: c ! +INTEGER*4, INTENT(IN) :: kdeel +REAL*4, INTENT(IN) :: c REAL*4, INTENT(IN) :: ol ! Monin-Obukhov lengte REAL*4, INTENT(IN) :: qbstf ! source strength current source (for current particle class) REAL*4, INTENT(IN) :: ra4_rcp ! ra at receptor (4m) REAL*4, INTENT(IN) :: ra50_rcp ! ra at receptor (50m) REAL*4, INTENT(IN) :: raz_rcp ! height dependent ra on receptor -REAL*4, INTENT(IN) :: rb_rcp ! -REAL*4, INTENT(IN) :: sigz ! -REAL*4, INTENT(IN) :: ueff ! wind speed at effective transport height heff; +REAL*4, INTENT(IN) :: rb_rcp +REAL*4, INTENT(IN) :: sigz +REAL*4, INTENT(IN) :: ueff ! wind speed at effective transport height heff; ! for short distances heff = plume height; ! for large distances heff = 1/2 mixing height; ! heff is interpolated for intermediate distances. REAL*4, INTENT(IN) :: uster REAL*4, INTENT(IN) :: z0 -REAL*4, INTENT(IN) :: virty ! -LOGICAL, INTENT(IN) :: gasv ! -INTEGER*4, INTENT(IN) :: itra ! -REAL*4, INTENT(IN) :: rb ! -REAL*4, INTENT(IN) :: ra4 ! -INTEGER*4, INTENT(IN) :: istab ! -REAL*4, INTENT(IN) :: grof ! -REAL*4, INTENT(IN) :: ra50 ! -REAL*4, INTENT(IN) :: xvghbr ! -REAL*4, INTENT(IN) :: xvglbr ! -REAL*4, INTENT(IN) :: regenk ! -REAL*4, INTENT(IN) :: rint ! -REAL*4, INTENT(IN) :: buil ! -REAL*4, INTENT(IN) :: zf ! -INTEGER*4, INTENT(IN) :: isek ! -INTEGER*4, INTENT(IN) :: iseiz ! -INTEGER*4, INTENT(IN) :: mb ! -REAL*4, INTENT(IN) :: disx ! -REAL*4, INTENT(IN) :: radius ! -REAL*4, INTENT(IN) :: xl ! -REAL*4, INTENT(IN) :: onder ! -REAL*4, INTENT(IN) :: dg ! -INTEGER*4, INTENT(IN) :: knatdeppar ! -REAL*4, INTENT(IN) :: scavcoef ! -LOGICAL, INTENT(IN) :: irev ! -REAL*4, INTENT(IN) :: htt ! -REAL*4, INTENT(IN) :: xloc ! -REAL*4, INTENT(IN) :: xl100 ! -REAL*4, INTENT(IN) :: vw10 ! -REAL*4, INTENT(IN) :: pcoef ! -REAL*4, INTENT(IN) :: vchem ! -REAL*4, INTENT(IN) :: dispg(NSTAB) ! +REAL*4, INTENT(IN) :: virty +LOGICAL, INTENT(IN) :: gasv +INTEGER*4, INTENT(IN) :: itra +REAL*4, INTENT(IN) :: rb +REAL*4, INTENT(IN) :: ra4 +INTEGER*4, INTENT(IN) :: istab +REAL*4, INTENT(IN) :: grof +REAL*4, INTENT(IN) :: ra50 +REAL*4, INTENT(IN) :: xvghbr +REAL*4, INTENT(IN) :: xvglbr +REAL*4, INTENT(IN) :: regenk +REAL*4, INTENT(IN) :: rint +REAL*4, INTENT(IN) :: buil +REAL*4, INTENT(IN) :: zf +INTEGER*4, INTENT(IN) :: isek +INTEGER*4, INTENT(IN) :: iseiz +INTEGER*4, INTENT(IN) :: mb +REAL*4, INTENT(IN) :: disx +REAL*4, INTENT(IN) :: radius +REAL*4, INTENT(IN) :: xl +REAL*4, INTENT(IN) :: onder +REAL*4, INTENT(IN) :: dg +INTEGER*4, INTENT(IN) :: knatdeppar +REAL*4, INTENT(IN) :: scavcoef +LOGICAL, INTENT(IN) :: irev +REAL*4, INTENT(IN) :: htt +REAL*4, INTENT(IN) :: xloc +REAL*4, INTENT(IN) :: xl100 +REAL*4, INTENT(IN) :: vw10 +REAL*4, INTENT(IN) :: pcoef +REAL*4, INTENT(IN) :: vchem +REAL*4, INTENT(IN) :: dispg(NSTAB) REAL*4, INTENT(IN) :: z0_src ! roughness length at source; from z0-map [m] -REAL*4, INTENT(IN) :: ol_src ! -REAL*4, INTENT(IN) :: uster_src ! +REAL*4, INTENT(IN) :: ol_src +REAL*4, INTENT(IN) :: uster_src REAL*4, INTENT(IN) :: z0_tra ! roughness length representative for trajectory [m] -REAL*4, INTENT(IN) :: ra4src ! -REAL*4, INTENT(IN) :: rb_src ! -REAL*4, INTENT(IN) :: ra50src ! -REAL*4, INTENT(IN) :: ra4tra ! -REAL*4, INTENT(IN) :: rb_tra ! -REAL*4, INTENT(IN) :: ra50tra ! +REAL*4, INTENT(IN) :: ra4src +REAL*4, INTENT(IN) :: rb_src +REAL*4, INTENT(IN) :: ra50src +REAL*4, INTENT(IN) :: ra4tra +REAL*4, INTENT(IN) :: rb_tra +REAL*4, INTENT(IN) :: ra50tra REAL*4, INTENT(IN) :: xm REAL*4, INTENT(IN) :: ym REAL*4, INTENT(IN) :: zm ! z-coordinate of receptor points (RDM) -INTEGER*4, INTENT(IN) :: bx +INTEGER*4, INTENT(IN) :: bx INTEGER*4, INTENT(IN) :: by ! SUBROUTINE ARGUMENTS - I/O -REAL*4, INTENT(INOUT) :: rctra_0 ! -REAL*4, INTENT(INOUT) :: htot ! -REAL*4, INTENT(INOUT) :: rcsrc ! +REAL*4, INTENT(INOUT) :: rctra_0 +REAL*4, INTENT(INOUT) :: htot +REAL*4, INTENT(INOUT) :: rcsrc TYPE (TError), INTENT(INOUT) :: error ! error handling record ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: pr ! -REAL*4, INTENT(OUT) :: twt ! -REAL*4, INTENT(OUT) :: cratio ! -REAL*4, INTENT(OUT) :: rc_rcp ! -REAL*4, INTENT(OUT) :: grad ! -REAL*4, INTENT(OUT) :: rc +REAL*4, INTENT(OUT) :: pr +REAL*4, INTENT(OUT) :: twt +REAL*4, INTENT(OUT) :: cratio +REAL*4, INTENT(OUT) :: rc_rcp +REAL*4, INTENT(OUT) :: grad +REAL*4, INTENT(OUT) :: rc REAL*4, INTENT(OUT) :: utr ! average wind speed over the trajectory (m/s) -REAL*4, INTENT(OUT) :: vg50_rcp ! -REAL*4, INTENT(OUT) :: vgpart ! +REAL*4, INTENT(OUT) :: vg50_rcp +REAL*4, INTENT(OUT) :: vgpart REAL*4, INTENT(OUT) :: routpri ! in-cloud scavenging ratio for primary component ! (rout << rain-out = in-cloud) [-] -REAL*4, INTENT(OUT) :: vg50trans ! -REAL*4, INTENT(OUT) :: rkc ! -REAL*4, INTENT(OUT) :: ri ! +REAL*4, INTENT(OUT) :: vg50trans +REAL*4, INTENT(OUT) :: rkc +REAL*4, INTENT(OUT) :: ri REAL*4, INTENT(OUT) :: vnatpri ! wet deposition loss rate for primary components [%/h] -REAL*4, INTENT(OUT) :: cgt ! +REAL*4, INTENT(OUT) :: cgt REAL*4, INTENT(OUT) :: cgt_z ! height dependent cgt -REAL*4, INTENT(OUT) :: cq2 ! -REAL*4, INTENT(OUT) :: cdn ! -REAL*4, INTENT(OUT) :: cch ! +REAL*4, INTENT(OUT) :: cq2 +REAL*4, INTENT(OUT) :: cdn +REAL*4, INTENT(OUT) :: cch ! LOCAL VARIABLES -INTEGER*4 :: flag ! stable meteo class and stack emitting above mixing layer -REAL*4 :: a ! -REAL*4 :: cq1 ! -REAL*4 :: diameter ! +INTEGER*4 :: flag ! stable meteo class and stack emitting above mixing layer +REAL*4 :: a +REAL*4 :: cq1 +REAL*4 :: diameter REAL*4 :: dxeff ! effective distance over which deposition takes place within an area source REAL*4 :: grad_z ! height dependent grad -REAL*4 :: hf ! -REAL*4 :: p1 ! -REAL*4 :: p2 ! -REAL*4 :: pldaling ! -REAL*4 :: sigzr ! +REAL*4 :: hf +REAL*4 :: p1 +REAL*4 :: p2 +REAL*4 :: pldaling +REAL*4 :: sigzr REAL*4 :: ux0 ! wind speed near source at plume height (m/s) REAL*4 :: uxr ! wind speed representative for plume over area source (m/s) REAL*4 :: ugem ! average wind speed depending on phase of plume development (m/s) -REAL*4 :: vg0tra ! -REAL*4 :: vg50tra ! -REAL*4 :: xg ! -REAL*4 :: zu ! +REAL*4 :: vg0tra +REAL*4 :: vg50tra +REAL*4 :: xg +REAL*4 :: zu LOGICAL :: ops_openlog ! function for opening log file ! ! VGDEEL = deposition velocity per particle class [m/s]; ! Sehmel G.A. and Hodgson W.H. (1980) A model for predicting dry deposition of particles and gases to environmental surfaces. -! AIChE Symposium Series 86, 218-230. See also +! AIChE Symposium Series 86, 218-230. See also ! ! DATA DATA VGDEEL/.00030, .0013, .0046, .009, .024, .054/ ! -! RCDEEL: surface resistance Rc per per particle class computed from Ra and Rb values per particle class and +! RCDEEL: surface resistance Rc per per particle class computed from Ra and Rb values per particle class and ! averaged dry deposition velocities vg (weighed over stability classes). ! See new OPS report, Table 5.2 -! +! DATA RCDEEL/3200., 700., 150., 50., 2., -17./ ! ! roratio: scavenging ratio per particle class . @@ -217,9 +217,9 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc ! See nok/luk reports "Luchtverontreniging t.g.v. de uitworp van kolengestookte installaties" ! Potma C.J., Onderdelinden D. and Slanina J. (1986): bijdrage van een kolengestookte elecktriciteitscentrale -! aan de lokale luchtconcentratie- en depositiveniveaus. PEO report NOK-LUK 3, no. 20.70-017.10, +! aan de lokale luchtconcentratie- en depositiveniveaus. PEO report NOK-LUK 3, no. 20.70-017.10, ! RIVM report 22822 02 004, Bilthoven. -! van Jaarsveld en Onderdelinden (1986): Modelmatige beschrijving van concentratie en depositie van kolen relevante +! van Jaarsveld en Onderdelinden (1986): Modelmatige beschrijving van concentratie en depositie van kolen relevante ! componenten in NL veroorzaakt door emissies in Europa, PEO report NOK-LUK 3, RIVM report 2282 02 002, Bilthoven. ! See Table III measurements in Lelystad and Bilthoven . ! DATA RORATIO / 120000.,1000000.,5000000.,2*9000000./ aangepast (zie EUTREND) 931120 @@ -235,7 +235,7 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc DATA RA4S /24., 17., 23., 13., 226., 52./ ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -244,10 +244,10 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc sigzr = 0.0 ! Square area source is represented by a circular area source with the same area; -! (area circle with radius r) = (area square with 1/2 side = radius) <=> pi*r**2 = (2*radius)**2 <=> +! (area circle with radius r) = (area square with 1/2 side = radius) <=> pi*r**2 = (2*radius)**2 <=> ! <=> r = (2/sqrt(pi))*radius <=> r = 1.128*radius ! See ops_virtdist: virty = (radius*12.)/PI*1.128 -diameter = (virty*PI)/(6.*1.128) +diameter = (virty*PI)/(6.*1.128) ! ! Set surface resistances Rc for particles at different locations (receptor, source, average over trajectory) ! and set routpri = in-cloud scavenging ratio [-] for the current particle class @@ -287,10 +287,10 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc ! ! vg50tra = average deposition velocity over trajectory, when the plume is not yet fully mixed over the mixing layer ! vg50trans = average deposition velocity over trajectory, when the plume is fully mixed over the mixing layer -! xvglbr = ratio effective dry deposition velocity over transport distance and +! xvglbr = ratio effective dry deposition velocity over transport distance and ! average dry deposition velocity over transport distance for low sources [-] ! See OPS-doc/meteo, bookmark correction_factor_deposition_velocity -! xvghbr = ratio effective dry deposition velocity over transport distance and +! xvghbr = ratio effective dry deposition velocity over transport distance and ! average dry deposition velocity over transport distance for high sources [-] ! See OPS-doc/meteo, bookmark correction_factor_deposition_velocity ! xvghbr and xvglbr are read from the meteo statistics file @@ -303,7 +303,7 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc ! Check whether source emits above the mixing layer or not: !ELSE IF (htot .GT. (200. + EPS_DELTA)) THEN -ELSE IF (htot .GT. xloc) THEN +ELSE IF (htot .GT. xloc) THEN vg50trans = xvghbr*vg50tra ELSE vg50trans = xvglbr*vg50tra @@ -322,7 +322,7 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc ! Gradient term; grad = vg(50)/vg(4); assuming a constant flux over height, we derive: ! ! vd(50) c(4) -! F(50) = F(4) <=> -vd(50)*c(50) = -vd(4)*c(4) <=> ------ = ------ <=> c(4) = grad*c(50) +! 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 used as input for ops_brondepl (see there). @@ -331,14 +331,14 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc cgt = 1. - grad cgt_z = 1. - grad_z ! EvdS -! Default value for wind speed for area source +! Default value for wind speed for area source uxr = ueff ! ! onder is fraction of plume in mixing layer ("onder"= below) ! onder = 1 -> plume completely below mixing height ! onder = 0 -> plume completely above mixing height ! -! Plume above mixing height or coarse particles +! Plume above mixing height or coarse particles ! IF ((ABS(onder) .LE. EPS_DELTA) .OR. (ABS(grof - 1.) .LE. EPS_DELTA)) THEN cq2 = 1. @@ -346,12 +346,12 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc cq1 = 1. cgt = 0. cgt_z = 0. - utr = ueff + utr = ueff ! dxeff is effective travel distance, computed by using a large number of point sources and by ! comparing concentrations from the area source with those point sources; this means that sources ! that are close have more effect than point sources further away. - ! + dxeff = diameter/4. ELSE ! @@ -367,24 +367,24 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc ! ------------- xl (mixing height) -------------------------.------------------------------------------------------------- . ! . ! . 3 stages of plume development: -! . 1. plume does not reach the ground +! . 1. plume does not reach the ground ! . 2. plume reaches the ground, but is not yet fully mixed ! . 3. plume is fully mixed over the mixing layer -! . +! . ! htt - -! | . - +! | . - ! | . - central -! | . - axis +! | . - axis ! | . - of -! | . - plume +! | . - plume ! | . - ! | . - ! hbron| . - htot -! | | . -! | | . -! | | . -! | | . -! | | . +! | | . +! | | . +! | | . +! | | . +! | | . ! -----.11111111111111111111111111111111111111111.2222222222.3333333.33333333 ! source xg receptor ! @@ -392,7 +392,7 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc ! ! xloc : mixing height near source at x = 0 ! xl100: mixing height at 100 km from source. -! +! ! A. (flag = 1) Plume is released above the mixing layer, then the plume travels a while above the mixing layer ! before it is caught inside the mixing layer and transported to the ground. ! We assume: @@ -401,20 +401,20 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc ! the plume within the mixing layer can be neglected). ! 3. the plume travels without dispersion above the mixing layer. ! -! .C' xl(100) -! . -! . +! .C' xl(100) +! . +! . ! plume above mixing layer . ! htot-------------------------------------.C ! | . @ -! | . @ +! | . @ ! | . layer @ ! | . mixing @ -! xl(0).A rising @ B B' -! | @ -! | @ -! hbron| @ plume -! | | @ transported +! xl(0).A rising @ B B' +! | @ +! | @ +! hbron| @ plume +! | | @ transported ! | | @ to ground ! | | @ ! | | @ @@ -427,42 +427,42 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc ! BA B'A ! ! htot - xl(0) xl(100) - xl(0) xg htot - xloc -! --------------- = ---------------- <=> htot - xloc = ------(xl100 - xloc) <=> xg = 100 * ----------------, in km +! --------------- = ---------------- <=> htot - xloc = ------(xl100 - xloc) <=> xg = 100 * ----------------, in km ! xg - 0 100 - 0 100 xl100 - xloc ! -! Special cases: htot = xloc -> xg = 0 km (direct downward mixing of plume) +! Special cases: htot = xloc -> xg = 0 km (direct downward mixing of plume) ! htot = xl100 -> xg = 100 km ! ! B. (flag = 0) Plume is released inside the mixing layer ! ! ------------- xl (mixing height) -------------------------.------------------------------------------------------------- . ! . -! . -! . -! . -! . -! . +! . +! . +! . +! . +! . ! htot. -! | . -! | . +! | . +! | . ! | . ! | . ! | . ! | . ! | . ! hbron| . -! | | . -! | | . -! | | . -! | | . -! | | . +! | | . +! | | . +! | | . +! | | . +! | | . ! -----.----------------------------------------------------|----------------- ! source xg ! ! sigma_z = dispg*x**disph <=> x = (sigma_z/dispg)**(1/disph); ! xg is the location where the plume is fully mixed, this means that there the width of the plume (sigma_z) ! equals the mixing height (xloc) -> xg = (xloc/dispg)**(1/disph); -! Here we assume no mixing layer growth with distance +! Here we assume no mixing layer growth with distance ! IF (htot .LT. (htt/2. - EPS_DELTA)) THEN htot = htt/2. @@ -472,10 +472,10 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc CONTINUE ENDIF - ! istab > 4 -> stable classes; in this case we may have stacks that emit - ! above the mixing layer + ! istab > 4 -> stable classes; in this case we may have stacks that emit + ! above the mixing layer IF ((istab .GT. 4) .AND. (htot .GT. (xloc + EPS_DELTA))) THEN - + ! A. (flag = 1) htot > xloc, so plume starts above mixing layer IF (xl100 .GT. (xloc + EPS_DELTA)) THEN xg = (htot - xloc)*100000./(xl100 - xloc) ! in m @@ -500,7 +500,7 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc ENDIF ! ! Compute ux0 = wind speed at the beginning of the trajectory (near source) at plume height; -! this is needed in order to compute the mass loss, since the wind speed increases +! this is needed in order to compute the mass loss, since the wind speed increases ! with increasing sigma_z (especially for low sources). ! IF (htot .LT. (1. - EPS_DELTA)) THEN @@ -513,7 +513,7 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc CALL ops_wvprofile(z0_src, hf, uster_src, ol_src, ux0) ! ! Compute source depletion (brondepl << "bron" = source, depl << depletion) and compute source depletion factors cdn, cq1, cq2 -! (to compute a depleted source strength) and a gradient factor cgt (to correct for the fact that concentrations at the +! (to compute a depleted source strength) and a gradient factor cgt (to correct for the fact that concentrations at the ! surface are lower than the plume average). ! @@ -530,7 +530,7 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc ! 1. plume inside area source 0 < x < R, u = uxr ! 2. plume reaches the ground, but is not yet fully mixed R < x < xg, u = ugem ! 3. plume is fully mixed over the mixing layer xg < x, u = ueff -! +! ! 1+2+3: x*utr = R*uxr + (xg-R)*ugem + (x-xg)*ueff ! 1+2 : x*utr = R*uxr + (xg-R)*ugem ! 1 : utr = uxr = ueff (see ops_brondepl: inside an area source, we have uxr = ueff) @@ -552,7 +552,7 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc IF (disx .LE. (radius + EPS_DELTA)) THEN a = dxeff ELSE - a = disx - dxeff + a = disx - dxeff ENDIF cch = EXP( - (a/utr*(vnatpri + vchem)/360000.)) ! @@ -569,25 +569,25 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc ENDIF ! ! Compute combined effect of source depletion inside or outside area source; -! Gaussian part of plume (not yet homogeneously mixed) +! Gaussian part of plume (not yet homogeneously mixed) ! cq2 = cq2*cq1 ! -! Compute depletion factor due to dry deposition of heavy plume; based on work of Onderdelinden; no ref +! Compute depletion factor due to dry deposition of heavy plume; based on work of Onderdelinden; no ref ! ! htt - pldaling htt + pldaling ! p1 = ----------------, p2 = ---------------- (sqrt(2) = 1.414 ! sqrt(2)*sigz sqrt(2)*sigz ! -! 1 1 1 +! 1 1 1 ! htot > 0 -> cq2 = 1 - ----------*EXP( -p1^2)*[------------------------ - -------------------------] ! SQRT(PI) p1 + SQRT(p1^2 + 4/PI) p2 + SQRT(p2^2 + 4/PI)) -! -! -! 1 1 1 +! +! +! 1 1 1 ! htot = 0 -> p1 = -p1, cq2 = ----------*EXP( -p1^2)*[------------------------ + -------------------------] ! SQRT(PI) p1 + SQRT(p1^2 + 4/PI) p2 + SQRT(p2^2 + 4/PI)) -! +! ! IF (ABS(grof - 1.) .LE. EPS_DELTA) THEN pldaling = htt - htot @@ -610,70 +610,70 @@ SUBROUTINE ops_depoparexp(kdeel, c, ol, qbstf, ra4_rcp, ra50_rcp, raz_rcp, rb_rc !------------------------------------------------------------------------------------------------------------------------------- ! SUBROUTINE : par_nat ! DESCRIPTION : Compute rain intensity and the wet deposition loss rate for primary components vnatpri -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! SYSTEM DEPENDENCIES: NON-ANSI F77 !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE par_nat(regenk, rint, buil, zf, isek, iseiz, mb, disx, radius, diameter, ueff, xl, onder, sigz, htot, gasv, dg, & & knatdeppar, scavcoef, routpri, kdeel, irev, c, qbstf, virty, twt, pr, cratio, ri, a, vnatpri) ! CONSTANTS -REAL*4 :: PS ! +REAL*4 :: PS PARAMETER (PS = 1.e6/(2.*PI)) REAL*4 :: TWETZ(NSEK) ! duration of rain shower in summer REAL*4 :: TWETW(NSEK) ! duration of rain shower in winter REAL*4 :: RIW(NSEK) ! rain intensity winter REAL*4 :: RIZ(NSEK) ! rain intensity summer REAL*4 :: CMND(NMONTH) ! monthly correction shower duration -REAL*4 :: EPSILON(NPARTCLASS) ! +REAL*4 :: EPSILON(NPARTCLASS) ! SUBROUTINE ARGUMENTS - INPUT -REAL*4, INTENT(IN) :: regenk ! -REAL*4, INTENT(IN) :: rint ! -REAL*4, INTENT(IN) :: buil ! -REAL*4, INTENT(IN) :: zf ! -INTEGER*4, INTENT(IN) :: isek ! -INTEGER*4, INTENT(IN) :: iseiz ! -INTEGER*4, INTENT(IN) :: mb ! -REAL*4, INTENT(IN) :: disx ! -REAL*4, INTENT(IN) :: radius ! -REAL*4, INTENT(IN) :: diameter ! -REAL*4, INTENT(IN) :: ueff ! wind speed at effective transport height heff; +REAL*4, INTENT(IN) :: regenk +REAL*4, INTENT(IN) :: rint +REAL*4, INTENT(IN) :: buil +REAL*4, INTENT(IN) :: zf +INTEGER*4, INTENT(IN) :: isek +INTEGER*4, INTENT(IN) :: iseiz +INTEGER*4, INTENT(IN) :: mb +REAL*4, INTENT(IN) :: disx +REAL*4, INTENT(IN) :: radius +REAL*4, INTENT(IN) :: diameter +REAL*4, INTENT(IN) :: ueff ! wind speed at effective transport height heff; ! for short distances heff = plume height; ! for large distances heff = 1/2 mixing height; ! heff is interpolated for intermediate distances. -REAL*4, INTENT(IN) :: xl ! -REAL*4, INTENT(IN) :: onder ! -REAL*4, INTENT(IN) :: sigz ! -REAL*4, INTENT(IN) :: htot ! -LOGICAL, INTENT(IN) :: gasv ! -REAL*4, INTENT(IN) :: dg ! -INTEGER*4, INTENT(IN) :: knatdeppar ! -REAL*4, INTENT(IN) :: scavcoef ! +REAL*4, INTENT(IN) :: xl +REAL*4, INTENT(IN) :: onder +REAL*4, INTENT(IN) :: sigz +REAL*4, INTENT(IN) :: htot +LOGICAL, INTENT(IN) :: gasv +REAL*4, INTENT(IN) :: dg +INTEGER*4, INTENT(IN) :: knatdeppar +REAL*4, INTENT(IN) :: scavcoef REAL*4, INTENT(IN) :: routpri ! in-cloud scavenging ratio for primary component ! (rout << rain-out = in-cloud) [-] -INTEGER*4, INTENT(IN) :: kdeel ! -LOGICAL, INTENT(IN) :: irev ! -REAL*4, INTENT(IN) :: c ! -REAL*4, INTENT(IN) :: qbstf ! -REAL*4, INTENT(IN) :: virty ! +INTEGER*4, INTENT(IN) :: kdeel +LOGICAL, INTENT(IN) :: irev +REAL*4, INTENT(IN) :: c +REAL*4, INTENT(IN) :: qbstf +REAL*4, INTENT(IN) :: virty ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: twt ! -REAL*4, INTENT(OUT) :: pr ! -REAL*4, INTENT(OUT) :: cratio ! -REAL*4, INTENT(OUT) :: ri ! -REAL*4, INTENT(OUT) :: a ! +REAL*4, INTENT(OUT) :: twt +REAL*4, INTENT(OUT) :: pr +REAL*4, INTENT(OUT) :: cratio +REAL*4, INTENT(OUT) :: ri +REAL*4, INTENT(OUT) :: a REAL*4, INTENT(OUT) :: vnatpri ! wet deposition loss rate for primary components [%/h] ! LOCAL VARIABLES -REAL*4 :: twet ! -REAL*4 :: treis ! +REAL*4 :: twet +REAL*4 :: treis REAL*4 :: h ! thickness over which wet deposition takes place [m] -REAL*4 :: hl ! +REAL*4 :: hl REAL*4 :: vnatrain ! wet deposition loss rate for rainout (in-cloud) [%/h] -REAL*4 :: epsi ! -REAL*4 :: beta ! -REAL*4 :: lambda0 ! +REAL*4 :: epsi +REAL*4 :: beta +REAL*4 :: lambda0 REAL*4 :: vnatwash ! wet deposition loss rate for washout (below-cloud) [%/h] ! DATA figure 4.1 OPS-report (depends on particle class) and @@ -694,7 +694,7 @@ SUBROUTINE par_nat(regenk, rint, buil, zf, isek, iseiz, mb, disx, radius, diamet DATA CMND /0.8, 0.9, 1.2, 0.8, 1.0, 1.2, 1.2, 1.0, 0.8, 1.2, 1.0, 0.9/ ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- @@ -712,7 +712,7 @@ SUBROUTINE par_nat(regenk, rint, buil, zf, isek, iseiz, mb, disx, radius, diamet ! (buil << "bui" = shower, l << length) ! IF ((rint .GT. (0. + EPS_DELTA)) .AND. (buil .GT. (0. + EPS_DELTA))) THEN - twet = buil*.7 + twet = buil*.7 ri = rint ELSE ! @@ -745,7 +745,7 @@ SUBROUTINE par_nat(regenk, rint, buil, zf, isek, iseiz, mb, disx, radius, diamet ENDIF ! ! Determine treis = travel time [h] ("reis"= travel) -! +! treis = a/(ueff*3600.) ! ! twt = tau_w = average duration of a rainfall period, dependent on source - receptor distance [h] (4.23) OPS report @@ -753,7 +753,7 @@ SUBROUTINE par_nat(regenk, rint, buil, zf, isek, iseiz, mb, disx, radius, diamet ! twt depends on the travel time; note that exp(-y) ~ 1 - y ! 1. x small -> twt ~ 0.4*treis -! +! twt = 1.0*twet*(1. - EXP( - 0.4*treis/twet)) ! 950119 IF (twt .LT. (.01 - EPS_DELTA)) THEN twt = .01 @@ -761,13 +761,13 @@ SUBROUTINE par_nat(regenk, rint, buil, zf, isek, iseiz, mb, disx, radius, diamet ! ! Compute thickness h over which wet deposition takes place; ! (onder = 0 -> plume completely above mixing height) -! +! IF (ABS(onder - 0.) .LE. EPS_DELTA) THEN h = 2.*sigz ELSE h = xl ENDIF - + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! Distribution factor between washout (below cloud) and rainout (in cloud) pr [-] !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -777,11 +777,11 @@ SUBROUTINE par_nat(regenk, rint, buil, zf, isek, iseiz, mb, disx, radius, diamet ! (4.19), (4.20) ... OPS report; a = factor cw in OPS report 4.19 ! IF (radius .GT. (0. + EPS_DELTA)) THEN - + ! Area source; check for inside or outside area source - + IF (disx .LT. (radius - EPS_DELTA)) THEN - hl = xl - htot + sigz*(radius - disx)/radius + hl = xl - htot + sigz*(radius - disx)/radius a = 3. ELSE hl = xl - htot - (radius**3)/(200*disx**2) ! radius = sa/2 -> extra factor 2**3 = 8 accounts for factor 1600 in OPS report @@ -795,22 +795,22 @@ SUBROUTINE par_nat(regenk, rint, buil, zf, isek, iseiz, mb, disx, radius, diamet IF ((ABS(onder - 0) .LE. EPS_DELTA) .OR. (hl .LT. (0. - EPS_DELTA))) THEN hl = 0. ENDIF - pr = EXP(-(hl+5)**2/(2*sigz*sigz*a)) - + pr = EXP(-(hl+5)**2/(2*sigz*sigz*a)) + ! Correction near source (travel time < 1 hour); disx/(ueff*3600) is travel time in h: - pr = pr*AMIN1(1., disx/(ueff*3600.)) ! 950316 + pr = pr*AMIN1(1., disx/(ueff*3600.)) ! 950316 ! !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! Washout (below-cloud) loss rate vnatwash [%/h] (gasses, irreversible) !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! Parameterisation of (irreversible) washout coefficient of gasses (A.J Janssen en H.M ten Brink (ECN)) +! Parameterisation of (irreversible) washout coefficient of gasses (A.J Janssen en H.M ten Brink (ECN)) ! droplet spectrum according to Best, smallest droplet radius .0125 cm. ! 4.22 OPS report: LAMBDA_eff = (Pp/twt)*(1 - exp(-LAMBDA*twt) ! Pp = regenk : probability of wet deposition [-] (regen << rain, k << kans = chance) ! LAMBDA : wet scavenging rate [1/h] ! twt = tau_w = average duration of a rainfall period, dependent on source - receptor distance [h] (4.23) OPS report -! 4.17 OPS report: LAMBDA = alpha1*(D_g**alpha2)*(Ri**alpha3); +! 4.17 OPS report: LAMBDA = alpha1*(D_g**alpha2)*(Ri**alpha3); ! alpha1 = 1.21, alpha2 = 0.744, alpha3 = 0.628; dg = diffusion coefficient [cm2/s] ! IF (gasv) THEN @@ -818,10 +818,10 @@ SUBROUTINE par_nat(regenk, rint, buil, zf, isek, iseiz, mb, disx, radius, diamet ENDIF !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! Rainout (in-cloud) loss rate vnatrain [%/h] +! Rainout (in-cloud) loss rate vnatrain [%/h] !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! -! Parameterisation of rain out (in-cloud), considered as a total loss process by rain, +! Parameterisation of rain out (in-cloud), considered as a total loss process by rain, ! when a plume is mixed homogeneously in the mixing layer. ! vnatrain = loss rate due to rain out [%/h] ! 4.22 OPS report: LAMBDA_eff = (Pp/twt)*(1 - exp(-LAMBDA*twt) @@ -833,10 +833,10 @@ SUBROUTINE par_nat(regenk, rint, buil, zf, isek, iseiz, mb, disx, radius, diamet vnatrain = regenk*100./twt*(1 - EXP( -scavcoef/100.*twt)) ELSE ! -! scavenging ratio W = routpri (rout << rain-out = in-cloud) has been defined, +! scavenging ratio W = routpri (rout << rain-out = in-cloud) has been defined, ! either read (ops_read_ctr) or set inside OPS ! (see ops_resist_rek for acidifying components or RORATIO for particles) -! LAMBDA = W Ri/h (6.1 new OPS report); plume completely above mixing height -> h = 2 sigma_z +! LAMBDA = W Ri/h (6.1 new OPS report); plume completely above mixing height -> h = 2 sigma_z ! otherwise -> h = zi. ! Ri in mm/h, zi = h in m -> extra factor 1000. ! @@ -847,7 +847,7 @@ SUBROUTINE par_nat(regenk, rint, buil, zf, isek, iseiz, mb, disx, radius, diamet ! Washout (below-cloud) loss rate vnatwash [%/h] (particles) ! Ratio cratio = C(z=0)/C_average, with C_average = averaged mixing layer concentration !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - + IF (.NOT.gasv) THEN ! ! Parametrisation of wash out (below-cloud) of particles according to Slinn @@ -868,11 +868,11 @@ SUBROUTINE par_nat(regenk, rint, buil, zf, isek, iseiz, mb, disx, radius, diamet IF (vnatwash .GT. (vnatrain + EPS_DELTA)) THEN vnatwash = vnatrain ENDIF - + IF (irev) THEN ! ! Reversible wet deposition -! cratio = ratio surface concentration (= c) and concentration at full mixing in mixing layer (needed for reversible wet deposition). +! cratio = ratio surface concentration (= c) and concentration at full mixing in mixing layer (needed for reversible wet deposition). ! (4.16) OPS report, figure 6.1 new OPS report ! cratio = c/(qbstf*NSEK*PS/(ueff*(disx + virty)*xl)) @@ -882,13 +882,13 @@ SUBROUTINE par_nat(regenk, rint, buil, zf, isek, iseiz, mb, disx, radius, diamet ELSE ! ! irreversible wet deposition -! +! cratio = 1. ENDIF ENDIF ! !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! Wet deposition loss rate for primary components vnatpri [%/h] +! Wet deposition loss rate for primary components vnatpri [%/h] !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! Combine wash out and rain out (4.19 OPS report) ! @@ -896,7 +896,7 @@ SUBROUTINE par_nat(regenk, rint, buil, zf, isek, iseiz, mb, disx, radius, diamet ELSE ! ! precipitation probability = 0 -! +! vnatpri = 0. ENDIF diff --git a/ops_depos_rc.f90 b/ops_depos_rc.f90 index 358bc80..2488fed 100644 --- a/ops_depos_rc.f90 +++ b/ops_depos_rc.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-F77/90 ! USAGE : %M% @@ -48,21 +48,21 @@ SUBROUTINE ops_depos_rc(icm, iseiz, mb, gym ,temp_C, uster, glrad, hum, nwet, ra IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_depos_rc') ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: icm ! -INTEGER*4, INTENT(IN) :: iseiz ! -INTEGER*4, INTENT(IN) :: mb ! -INTEGER*4, INTENT(IN) :: nwet ! -REAL*4, INTENT(IN) :: hum ! +INTEGER*4, INTENT(IN) :: icm +INTEGER*4, INTENT(IN) :: iseiz +INTEGER*4, INTENT(IN) :: mb +INTEGER*4, INTENT(IN) :: nwet +REAL*4, INTENT(IN) :: hum REAL*4, INTENT(IN) :: uster ! friction velocity [m/s] 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 ! -REAL*4, INTENT(IN) :: catm +REAL*4, INTENT(IN) :: gym +REAL*4, INTENT(IN) :: glrad +REAL*4, INTENT(IN) :: ratns +REAL*4, INTENT(IN) :: catm REAL*4, INTENT(IN) :: c_ave_prev_nh3 REAL*4, INTENT(IN) :: c_ave_prev_so2 REAL*4, INTENT(IN) :: ra @@ -70,28 +70,28 @@ SUBROUTINE ops_depos_rc(icm, iseiz, mb, gym ,temp_C, uster, glrad, hum, nwet, ra REAL*4, INTENT(IN) :: lu_per(NLU) ! land use percentages for all land use classes ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: rc_eff_pos ! canopy resistance, no re-emission [s/m] -REAL*4, INTENT(OUT) :: rc_eff ! canopy resistance, re-emission allowed [s/m]; +REAL*4, INTENT(OUT) :: rc_eff_pos ! canopy resistance, no re-emission [s/m] +REAL*4, INTENT(OUT) :: rc_eff ! canopy resistance, re-emission allowed [s/m]; ! LOCAL VARIABLES -INTEGER*4 :: day_of_year ! -INTEGER*4 :: mnt ! -INTEGER*4, DIMENSION(2) :: mnt_select ! -INTEGER*4 :: luclass ! +INTEGER*4 :: day_of_year +INTEGER*4 :: mnt +INTEGER*4, DIMENSION(2) :: mnt_select +INTEGER*4 :: luclass REAL*4 :: som_vd_month ! summed vd over representative months REAL*4 :: som_vd_eff_ave ! summed vd over land use classes (vd = 1/Ra + Rb + Rc_eff) REAL*4 :: som_vd_eff_ave_pos ! summed vd over land use classes (vd = 1/Ra + Rb + Rc_eff_pos) -REAL*4 :: telmaand +REAL*4 :: telmaand REAL*4 :: rc_eff_ave ! canopy resistance, re-emission allowed, averaged over representative months REAL*4 :: rc_eff_ave_pos ! canopy resistance, no re-emission, averaged over representative months REAL*4 :: rc_tot REAL*4 :: sinphi REAL*4 :: ccomp_tot REAL*4, PARAMETER :: catm_min = 0.1E-05 -REAL*4 :: rc_eff_depac ! canopy resistance from depac, re-emission allowed [s/m]; +REAL*4 :: rc_eff_depac ! canopy resistance from depac, re-emission allowed [s/m]; ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- @@ -100,7 +100,7 @@ SUBROUTINE ops_depos_rc(icm, iseiz, mb, gym ,temp_C, uster, glrad, hum, nwet, ra som_vd_month = 0.0 som_vd_eff_ave = 0.0 som_vd_eff_ave_pos = 0.0 - + ! loop over land use classes: DO luclass = 1,NLU IF (lu_per(luclass) /= 0.0) THEN @@ -137,36 +137,36 @@ SUBROUTINE ops_depos_rc(icm, iseiz, mb, gym ,temp_C, uster, glrad, hum, nwet, ra CASE DEFAULT mnt_select=mb END SELECT -! Compute Rc only for mnt_select(1) and if necessary mnt_select(2) +! Compute Rc only for mnt_select(1) and if necessary mnt_select(2) ! DO mnt=1,12 IF (mnt .EQ. mnt_select(1) .OR. mnt .EQ. mnt_select(2) ) THEN ! ! Set approximate day of year: ! - day_of_year = mnt*30-15 + day_of_year = mnt*30-15 ! -! Set sin of solar elevation angle; +! Set sin of solar elevation angle; ! fit of sinphi is based on hourly data of global radiation (cloudy hours are filtered out) ! - sinphi = 0.00237*glrad-.00000186*glrad*glrad + sinphi = 0.00237*glrad-.00000186*glrad*glrad ! ! Update month counter: -! +! telmaand = telmaand+1 ! ! DEPAC has 3 outputs: ! rc_tot : total canopy resistance Rc (is not used here) ! 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 ,temp_C, 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_nh3, c_ave_prev_so2, max(catm,catm_min), ccomp_tot, ra, rb, rc_eff_depac) ! ! Detect missing values and set default values ! IF (rc_eff_depac .EQ. -9999) rc_eff_depac = 10000 - + som_vd_month = som_vd_month + 1/(rc_eff_depac + ra + rb) ENDIF ENDDO ! loop over representative months @@ -175,12 +175,12 @@ SUBROUTINE ops_depos_rc(icm, iseiz, mb, gym ,temp_C, uster, glrad, hum, nwet, ra ! rc_eff_ave = telmaand / som_vd_month - (ra + rb) ! -! Negative values for effective Rc (re-emission) is not allowed in _pos variables; reset Rc = 1000 -! +! Negative values for effective Rc (re-emission) is not allowed in _pos variables; reset Rc = 1000 +! IF (rc_eff_ave .GT. 0 ) THEN rc_eff_ave_pos = rc_eff_ave ELSE - rc_eff_ave_pos = 1000 + rc_eff_ave_pos = 1000 ENDIF ! ! Compute average weighted conductance over the landuse types @@ -190,7 +190,7 @@ SUBROUTINE ops_depos_rc(icm, iseiz, mb, gym ,temp_C, uster, glrad, hum, nwet, ra ENDIF ENDDO ! loop over land use classes ! -! Compute rc with and without (_pos) re-emission: +! Compute rc with and without (_pos) re-emission: rc_eff_pos = 1/som_vd_eff_ave_pos - (ra + rb) rc_eff = 1/som_vd_eff_ave - (ra + rb) diff --git a/ops_depu.f90 b/ops_depu.f90 index 775990c..3ff0116 100644 --- a/ops_depu.f90 +++ b/ops_depu.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! USAGE : @@ -71,7 +71,7 @@ SUBROUTINE ops_depu(icnr, z0, zra, d, rc, ol, uster, vg, ra, rb) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_depu') ! CONSTANTS @@ -102,12 +102,12 @@ SUBROUTINE ops_depu(icnr, z0, zra, d, rc, ol, uster, vg, ra, rb) REAL*4 :: zru ! correction for displacement height ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! ! Schmidt number: -! (note: in calling routine only icnr = 1 or 9 +! (note: in calling routine only icnr = 1 or 9 ! IF (icnr .EQ. 1 .OR. icnr .LE. 0) THEN ! SO2 or user-defined substance sc = 1.25 @@ -150,14 +150,14 @@ SUBROUTINE ops_depu(icnr, z0, zra, d, rc, ol, uster, vg, ra, rb) ! DESCRIPTION : Stability correction function in the surface layer temperature profile. The present model is an empirical ! fit by Holtslag and De Bruin(1987) of data by Hicks (1976, Quart. J. R. Meteor. Soc., 102, 535-551). ! See also Holtslag (1984, BLM, 29, 225-250) -! AUTHOR : OPS-support +! AUTHOR : OPS-support !------------------------------------------------------------------------------------------------------------------------------- REAL FUNCTION fpsih(eta) USE m_commonconst ! EPS_DELTA only ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'fpsih') ! SUBROUTINE ARGUMENTS - INPUT @@ -170,7 +170,7 @@ REAL FUNCTION fpsih(eta) REAL*4 :: y ! hulpvariabele bij de berekening ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- IF (eta .LT. (0. - EPS_DELTA)) THEN diff --git a/ops_gen_fnames.f90 b/ops_gen_fnames.f90 index ab706e2..b3b63c8 100644 --- a/ops_gen_fnames.f90 +++ b/ops_gen_fnames.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -28,13 +28,13 @@ ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% ! USAGE : -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-90 -! DESCRIPTION : Check existence and generate full file names of those files that have not been explicitly defined +! DESCRIPTION : Check existence and generate full file names of those files that have not been explicitly defined ! in the control file: files for diurnal variation, particle size distribution, z0-Europe, NL-mask, ! meteo statistics. Note: meteo statisctics file names are generated in ops_read_meteo. -! CHANGES : +! CHANGES : ! EXIT CODES : ! REFERENCE : ! FILES AND OTHER : @@ -53,13 +53,13 @@ SUBROUTINE ops_gen_fnames(gasv, spgrid, intpol, error) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_gen_fnames') ! SUBROUTINE ARGUMENTS - INPUT -LOGICAL, INTENT(IN) :: gasv -INTEGER*4, INTENT(IN) :: spgrid -INTEGER*4, INTENT(IN) :: intpol +LOGICAL, INTENT(IN) :: gasv +INTEGER*4, INTENT(IN) :: spgrid +INTEGER*4, INTENT(IN) :: intpol ! SUBROUTINE ARGUMENTS - OUTPUT TYPE (TError), INTENT(OUT) :: error ! Error handling record @@ -70,13 +70,13 @@ SUBROUTINE ops_gen_fnames(gasv, spgrid, intpol, error) CHARACTER*512 :: helpfile ! meteostatistics file name, includes region number ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! Standard file for diurnal variations of emissions CALL MakeCommonPath(DVFILE, dvnam, error) -! Standard file for particle size distributions +! Standard file for particle size distributions IF (.NOT.gasv) THEN CALL MakeCommonPath(PSDFILE, psdnam, error) ENDIF diff --git a/ops_gen_precip.f90 b/ops_gen_precip.f90 index 5cd6e34..563187d 100644 --- a/ops_gen_precip.f90 +++ b/ops_gen_precip.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -28,7 +28,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Generate precipitation for receptors (sum of precipitation over @@ -49,13 +49,13 @@ SUBROUTINE ops_gen_precip(uurtot, astat, trafst, precip, error) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_gen_precip') ! SUBROUTINE ARGUMENTS - INPUT -REAL*4, INTENT(IN) :: uurtot -REAL*4, INTENT(IN) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) -REAL*4, INTENT(IN) :: trafst(NTRAJ) +REAL*4, INTENT(IN) :: uurtot +REAL*4, INTENT(IN) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) +REAL*4, INTENT(IN) :: trafst(NTRAJ) ! SUBROUTINE ARGUMENTS - OUTPUT REAL*4, INTENT(OUT) :: precip ! array with precipitation per receptorpoint @@ -63,7 +63,7 @@ SUBROUTINE ops_gen_precip(uurtot, astat, trafst, precip, error) ! LOCAL VARIABLES INTEGER*4 :: i ! index of receptor -INTEGER*4 :: isek ! index of wind sector +INTEGER*4 :: isek ! index of wind sector INTEGER*4 :: isekt ! dummy output of ops_statparexp INTEGER*4 :: istab ! index of stability class INTEGER*4 :: iwd ! wind direction [degrees] @@ -72,11 +72,11 @@ SUBROUTINE ops_gen_precip(uurtot, astat, trafst, precip, error) REAL*4 :: disx ! distance source receptor, dummy input for ops_statparexp REAL*4 :: disxx ! dummy output of ops_statparexp REAL*4 :: radius ! source diameter, dummy input for ops_statparexp -REAL*4 :: qww ! heat content of source, dummy input for ops_statparexp; +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 + ! in ops_statparexp REAL*4 :: V_stack ! here a dummy -REAL*4 :: Ts_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 @@ -106,19 +106,19 @@ SUBROUTINE ops_gen_precip(uurtot, astat, trafst, precip, error) REAL*4 :: rcso2 ! here a dummy REAL*4 :: coef_space_heating ! here a dummy REAL*4 :: buil ! here a dummy -REAL*4 :: regenk -REAL*4 :: rint -REAL*4 :: percvk +REAL*4 :: regenk +REAL*4 :: rint +REAL*4 :: percvk ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! ! Initialise dummy source; this is needed because ops_statparexp needs source information -! in order to retrieve the correct meteo data from meteo statistics; +! in order to retrieve the correct meteo data from meteo statistics; ! the source influences the distance class, and wind shear (via plume rise). -disx = 100 ! (first distance class, i.e. local meteo) +disx = 100 ! (first distance class, i.e. local meteo) hbron = 10 radius = 0 qww = 0 @@ -135,7 +135,7 @@ SUBROUTINE ops_gen_precip(uurtot, astat, trafst, precip, error) iwd=(isek-1)*360/NSEK ! wind direction [degrees] DO istab = 1, NSTAB ! -! Compute relevant parameters regenk (rain probability), rint (rain intensity) and +! Compute relevant parameters regenk (rain probability), rint (rain intensity) and ! percvk (fraction of occurrence of meteo class) for this wind direction sector and stability class ! diff --git a/ops_gen_rcp.f90 b/ops_gen_rcp.f90 index 5b63db6..3d73438 100644 --- a/ops_gen_rcp.f90 +++ b/ops_gen_rcp.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO/IS ! LANGUAGE : FORTRAN(HP-UX, HP-F77, HP-F90) ! DESCRIPTION : Generate coordinates of receptor points. @@ -50,26 +50,26 @@ SUBROUTINE ops_gen_rcp(spgrid, igrens, masker, grid, nrcol, nrrow, nrrcp, xorg, IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_gen_rcp') ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: spgrid -LOGICAL, INTENT(IN) :: igrens -TYPE (TApsGridReal), INTENT(IN) :: masker -REAL*4, INTENT(IN) :: grid -INTEGER*4, INTENT(IN) :: nrcol -INTEGER*4, INTENT(IN) :: nrrow +INTEGER*4, INTENT(IN) :: spgrid +LOGICAL, INTENT(IN) :: igrens +TYPE (TApsGridReal), INTENT(IN) :: masker +REAL*4, INTENT(IN) :: grid +INTEGER*4, INTENT(IN) :: nrcol +INTEGER*4, INTENT(IN) :: nrrow INTEGER*4, INTENT(IN) :: nrrcp ! number of receptor points -REAL*4, INTENT(IN) :: xorg -REAL*4, INTENT(IN) :: yorg -LOGICAL, INTENT(IN) :: varz +REAL*4, INTENT(IN) :: xorg +REAL*4, INTENT(IN) :: yorg +LOGICAL, INTENT(IN) :: varz LOGICAL, INTENT(IN) :: perc -LOGICAL, INTENT(IN) :: domlu +LOGICAL, INTENT(IN) :: domlu ! SUBROUTINE ARGUMENTS - OUTPUT -INTEGER*4, INTENT(OUT) :: jump(nrrcp+1) -INTEGER*4, INTENT(OUT) :: lu_rcp_dom_all(nrrcp) ! +INTEGER*4, INTENT(OUT) :: jump(nrrcp+1) +INTEGER*4, INTENT(OUT) :: lu_rcp_dom_all(nrrcp) REAL*4, INTENT(OUT) :: xm(nrrcp) ! x-coordinates REAL*4, INTENT(OUT) :: ym(nrrcp) ! y-coordinates REAL*4, INTENT(OUT) :: zm(nrrcp) ! z-coordinates @@ -80,7 +80,7 @@ SUBROUTINE ops_gen_rcp(spgrid, igrens, masker, grid, nrcol, nrrow, nrrcp, xorg, TYPE (TError), INTENT(OUT) :: error ! error handling record ! LOCAL VARIABLES -INTEGER*4 :: m ! column index +INTEGER*4 :: m ! column index INTEGER*4 :: n ! row index INTEGER*4 :: i ! index of receptor point INTEGER*4 :: h ! number of header lines @@ -90,23 +90,23 @@ SUBROUTINE ops_gen_rcp(spgrid, igrens, masker, grid, nrcol, nrrow, nrrcp, xorg, INTEGER*4 :: lu_dom ! landuse INTEGER*4 :: nwords ! number of words in string INTEGER*4 :: check_nwords ! number of words in string -INTEGER*4 :: ix ! x coordinate of receptor point (read from file) -INTEGER*4 :: iy ! y coordinate of receptor point (read from file) -REAL*4 :: zrcp ! z coordinate of receptor point (read from file) +real :: ix ! x coordinate of receptor point (read from file) +real :: iy ! y coordinate of receptor point (read from file) +REAL*4 :: zrcp ! z coordinate of receptor point (read from file) INTEGER*4 :: p ! receptor point number (dummy) INTEGER*4 :: ierr ! error status -REAL*4 :: x_rcp ! x coordinate receptor point -REAL*4 :: y_rcp ! y coordinate receptor point +REAL*4 :: x_rcp ! x coordinate receptor point +REAL*4 :: y_rcp ! y coordinate receptor point REAL*4 :: cellvalue ! value of masker grid cell at receptor point -REAL*4 :: z0 ! +REAL*4 :: z0 INTEGER :: lu_rcp_per_user(NLU) ! percentages of landuse classes for this receptor LOGICAL :: iscell ! whether point is inside masker grid CHARACTER*12 :: namrp ! name of receptor point -CHARACTER*512 :: string ! -CHARACTER*512 :: tmpstring ! +CHARACTER*512 :: string +CHARACTER*512 :: tmpstring ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- @@ -118,13 +118,13 @@ SUBROUTINE ops_gen_rcp(spgrid, igrens, masker, grid, nrcol, nrrow, nrrcp, xorg, IF (ANY(spgrid == (/0,1/))) THEN ! ! Regular grid of receptors. -! Compute the coordinates of the centres of the grid cells. If receptors must be inside NL (igrens = 0), a receptor is only +! Compute the coordinates of the centres of the grid cells. If receptors must be inside NL (igrens = 0), a receptor is only ! accepted, if the area inside NL of the surrounding grid cell > 0. ! The area is stored in order to compute area averaged values. ! ! Note: The call to GridValue needs coordinates in km. ! -! Arrays xm, ym and jump are filled per row (nrrow in outer loop). +! Arrays xm, ym and jump are filled per row (nrrow in outer loop). ! This way jump is assigned the right values for writing output per row, which happens in ops_print_grid ! i = 1 @@ -156,7 +156,7 @@ SUBROUTINE ops_gen_rcp(spgrid, igrens, masker, grid, nrcol, nrrow, nrrcp, xorg, ENDDO zm = zrcp ! User specified receptor points, spgrid = 2, 3 -ELSE +ELSE IF (.NOT. sysopen(fu_recep, namrecept, 'r', 'receptor file', error)) GOTO 9999 ! @@ -179,13 +179,13 @@ SUBROUTINE ops_gen_rcp(spgrid, igrens, masker, grid, nrcol, nrrow, nrrcp, xorg, ! Inirialise number of data lines (i) and number of header lines (h): i = 0 h = 0 - + ! Loop over lines until an valid data line (ierr = 0) has been detected: DO WHILE (ierr.GT.0) z0=0 - lu_dom=0 + lu_dom=0 check_nwords = 0 - + ! Read line: READ (fu_recep,'(a)',IOSTAT=ierr) string @@ -194,17 +194,17 @@ SUBROUTINE ops_gen_rcp(spgrid, igrens, masker, grid, nrcol, nrrow, nrrcp, xorg, DO WHILE (len_trim(string) .ne. 1) DO WHILE (string(1:1) .ne. char(32) .and. string(1:1) .ne. char(9)) tmpstring=string(2:len_trim(string)) - string=tmpstring + string=tmpstring IF (len_trim(string) .eq. 0) goto 323 - ENDDO + ENDDO DO WHILE (string(1:1) .eq. char(32) .or. string(1:1) .eq. char(9)) tmpstring=string(2:len_trim(string)) string=tmpstring IF (len_trim(string) .eq. 0) goto 323 ENDDO - check_nwords = check_nwords + 1 + check_nwords = check_nwords + 1 ENDDO - + 323 BACKSPACE(fu_recep) ! Check number of words and check whether we have a valid line with data: @@ -218,14 +218,14 @@ SUBROUTINE ops_gen_rcp(spgrid, igrens, masker, grid, nrcol, nrrow, nrrcp, xorg, ELSEIF (nwords .EQ. 16) THEN READ (fu_recep,*,IOSTAT=ierr) p,namrp,ix,iy,zrcp,z0,lu_dom,(lu_rcp_per_user(ii),ii=1,NLU) ENDIF - + ! Update counter for number of data lines (i) and number of header lines (h): IF (ierr == 0) THEN i = i + 1 ELSE h = h + 1 ENDIF - + ELSE ! number of words in header line or first data line must be correct; if not -> error: CALL SetError('Error reading receptor file', error) @@ -234,8 +234,8 @@ SUBROUTINE ops_gen_rcp(spgrid, igrens, masker, grid, nrcol, nrrow, nrrcp, xorg, CALL ErrorParam('nwords read from rcp-file should be:', nwords, error) GOTO 9999 ENDIF - - ! Check data on data line: + + ! Check data on data line: IF (ierr == 0) THEN IF (z0 > 0 .and. (nwords == 15 .or. nwords == 16) .and. sum(lu_rcp_per_user(1:NLU)) .lt. 99 .or. sum(lu_rcp_per_user(1:NLU)) .gt. 101) THEN CALL SetError('INPUT ERROR: No correct input in receptorfile', error) @@ -246,7 +246,7 @@ SUBROUTINE ops_gen_rcp(spgrid, igrens, masker, grid, nrcol, nrrow, nrrcp, xorg, ENDIF ENDIF ENDDO - + ! Loop until end-of-file and read rest of data lines: DO WHILE (ierr.EQ.0) ! @@ -257,7 +257,7 @@ SUBROUTINE ops_gen_rcp(spgrid, igrens, masker, grid, nrcol, nrrow, nrrcp, xorg, ym(i) = iy zm(i) = zrcp IF (nwords == 15 .OR. nwords == 16) THEN - z0_rcp_all(i)=z0 + z0_rcp_all(i)=z0 lu_rcp_dom_all(i)=lu_dom DO lu = 1,NLU lu_rcp_per_user_all(i,lu)=lu_rcp_per_user(lu) @@ -281,15 +281,15 @@ SUBROUTINE ops_gen_rcp(spgrid, igrens, masker, grid, nrcol, nrrow, nrrcp, xorg, DO WHILE (len_trim(string) .ne. 1) DO WHILE (string(1:1) .ne. char(32) .and. string(1:1) .ne. char(9)) tmpstring=string(2:len_trim(string)) - string=tmpstring + string=tmpstring IF (len_trim(string) .eq. 0) goto 321 - ENDDO + ENDDO DO WHILE (string(1:1) .eq. char(32) .or. string(1:1) .eq. char(9)) tmpstring=string(2:len_trim(string)) string=tmpstring IF (len_trim(string) .eq. 0) goto 321 ENDDO - check_nwords = check_nwords + 1 + check_nwords = check_nwords + 1 ENDDO 321 BACKSPACE(fu_recep) @@ -321,10 +321,10 @@ SUBROUTINE ops_gen_rcp(spgrid, igrens, masker, grid, nrcol, nrrow, nrrcp, xorg, ENDIF IF (ierr == 0) i = i + 1 ENDDO - + ! spgrid = 3 -> regular grid, but not necessarily rectangular. ! Cordinates have already been read above, array jump (number of successive points that can be skipped for output purposes) -! is filled per row (nrrow in outer loop). +! is filled per row (nrrow in outer loop). ! This way jump is assigned the right values for writing output per row, which happens in ops_print_grid ! IF (spgrid == 3) THEN @@ -335,7 +335,7 @@ SUBROUTINE ops_gen_rcp(spgrid, igrens, masker, grid, nrcol, nrrow, nrrcp, xorg, x_rcp = xorg + FLOAT(m - 1)*grid y_rcp = yorg - FLOAT(n - 1)*grid DO j = 1, nrrcp - IF (x_rcp == xm(j) .and. y_rcp == ym(j) ) THEN + IF (x_rcp == xm(j) .and. y_rcp == ym(j) ) THEN i = i + 1 goto 100 ENDIF diff --git a/ops_get_arg.f90 b/ops_get_arg.f90 index 0a015b2..7767938 100644 --- a/ops_get_arg.f90 +++ b/ops_get_arg.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -28,7 +28,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Retrieves the command line arguments and determines whether syntax is correct. If so, the complete @@ -51,15 +51,15 @@ SUBROUTINE ops_get_arg (diag, subbron, domlu, varz, perc, error) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_get_arg') ! SUBROUTINE ARGUMENTS - OUTPUT -INTEGER*4, INTENT(OUT) :: diag -LOGICAL, INTENT(INOUT) :: subbron -LOGICAL, INTENT(INOUT) :: domlu -LOGICAL, INTENT(INOUT) :: varz -LOGICAL, INTENT(INOUT) :: perc +INTEGER*4, INTENT(OUT) :: diag +LOGICAL, INTENT(INOUT) :: subbron +LOGICAL, INTENT(INOUT) :: domlu +LOGICAL, INTENT(INOUT) :: varz +LOGICAL, INTENT(INOUT) :: perc TYPE (TError), INTENT(OUT) :: error ! error handling record ! LOCAL VARIABLES @@ -77,7 +77,7 @@ SUBROUTINE ops_get_arg (diag, subbron, domlu, varz, perc, error) ! INTEGER*4 GETCWD ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -103,35 +103,35 @@ SUBROUTINE ops_get_arg (diag, subbron, domlu, varz, perc, error) ! ! Check for the optional arguments ! -IF (numarg == 3) THEN +IF (numarg == 3) THEN IF (arg(3) == '-nosub') subbron = .FALSE. IF (arg(3) == '-domlu') domlu = .TRUE. IF (arg(3) == '-varz') varz = .TRUE. IF (arg(3) == '-perc') perc = .TRUE. ENDIF -IF (numarg == 4) THEN +IF (numarg == 4) THEN IF (arg(3) == '-nosub' .or. arg(4) == '-nosub' ) subbron = .FALSE. IF (arg(3) == '-domlu' .or. arg(4) == '-domlu' ) domlu = .TRUE. IF (arg(3) == '-varz' .or. arg(4) == '-varz' ) varz = .TRUE. IF (arg(3) == '-perc' .or. arg(4) == '-perc') perc = .TRUE. ENDIF -IF (numarg == 5) THEN +IF (numarg == 5) THEN IF (arg(3) == '-nosub' .or. arg(4) == '-nosub' .or. arg(5) == '-nosub' ) subbron = .FALSE. IF (arg(3) == '-domlu' .or. arg(4) == '-domlu' .or. arg(5) == '-domlu' ) domlu = .TRUE. IF (arg(3) == '-varz' .or. arg(4) == '-varz' .or. arg(5) == '-varz' ) varz = .TRUE. IF (arg(3) == '-perc' .or. arg(4) == '-perc' .or. arg(5) == '-perc') perc = .TRUE. ENDIF -IF (numarg == 6) THEN +IF (numarg == 6) THEN IF (arg(3) == '-nosub' .or. arg(4) == '-nosub' .or. arg(5) == '-nosub' .or. arg(6) == '-nosub' ) subbron = .FALSE. IF (arg(3) == '-domlu' .or. arg(4) == '-domlu' .or. arg(5) == '-domlu' .or. arg(6) == '-domlu' ) domlu = .TRUE. IF (arg(3) == '-varz' .or. arg(4) == '-varz' .or. arg(5) == '-varz' .or. arg(6) == '-varz' ) varz = .TRUE. IF (arg(3) == '-perc' .or. arg(4) == '-perc' .or. arg(5) == '-perc' .or. arg(6) == '-perc') perc = .TRUE. ENDIF -IF (.NOT.subbron) numarg = numarg -1 -IF (domlu) numarg = numarg -1 -IF (varz) numarg = numarg -1 -IF (perc) numarg = numarg -1 +IF (.NOT.subbron) numarg = numarg -1 +IF (domlu) numarg = numarg -1 +IF (varz) numarg = numarg -1 +IF (perc) numarg = numarg -1 ! Check number of arguments: IF ((numarg < 1) .OR. (numarg > 3)) THEN diff --git a/ops_get_dim.f90 b/ops_get_dim.f90 index f08b227..1d7a1bf 100644 --- a/ops_get_dim.f90 +++ b/ops_get_dim.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO/IS ! LANGUAGE : FORTRAN(HP-UX, HP-F77, HP-F90) ! DESCRIPTION : Calculation of dimension of receptor point grids. @@ -49,15 +49,15 @@ SUBROUTINE ops_get_dim(spgrid, igrens, xc, yc, grid, nrcol, nrrow, nrrcp, xorg, IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_get_dim') ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: spgrid -LOGICAL, INTENT(IN) :: igrens -REAL*4, INTENT(IN) :: xc -REAL*4, INTENT(IN) :: yc -REAL*4, INTENT(IN) :: grid +INTEGER*4, INTENT(IN) :: spgrid +LOGICAL, INTENT(IN) :: igrens +REAL*4, INTENT(IN) :: xc +REAL*4, INTENT(IN) :: yc +REAL*4, INTENT(IN) :: grid ! SUBROUTINE ARGUMENTS - I/O INTEGER*4, INTENT(INOUT) :: nrcol ! number of colums in grid @@ -65,42 +65,42 @@ SUBROUTINE ops_get_dim(spgrid, igrens, xc, yc, grid, nrcol, nrrow, nrrcp, xorg, ! SUBROUTINE ARGUMENTS - OUTPUT INTEGER*4, INTENT(OUT) :: nrrcp ! number of receptor points -REAL*4, INTENT(OUT) :: xorg -REAL*4, INTENT(OUT) :: yorg -TYPE (TApsGridReal), INTENT(OUT) :: masker +REAL*4, INTENT(OUT) :: xorg +REAL*4, INTENT(OUT) :: yorg +TYPE (TApsGridReal), INTENT(OUT) :: masker TYPE (TError), INTENT(OUT) :: error ! error handling record ! LOCAL VARIABLES REAL*4, PARAMETER :: GRID_XSTART = 0.000 ! x-coordinate of left upper corner point of NL grid REAL*4, PARAMETER :: GRID_YSTART = 620000.000 ! y-coordinate of left upper corner point of NL grid -REAL*4, PARAMETER :: NL_XLEFT = 13562.623 ! -REAL*4, PARAMETER :: NL_XRIGHT = 278018.313 ! -REAL*4, PARAMETER :: NL_YUPPER = 619122.750 ! -REAL*4, PARAMETER :: NL_YLOWER = 306838.813 ! +REAL*4, PARAMETER :: NL_XLEFT = 13562.623 +REAL*4, PARAMETER :: NL_XRIGHT = 278018.313 +REAL*4, PARAMETER :: NL_YUPPER = 619122.750 +REAL*4, PARAMETER :: NL_YLOWER = 306838.813 ! LOCAL VARIABLES -INTEGER*4 :: i ! grid index -INTEGER*4 :: m ! column index +INTEGER*4 :: i ! grid index +INTEGER*4 :: m ! column index INTEGER*4 :: n ! row index -INTEGER*4 :: ix ! x coordinate of receptor point (read from file) -INTEGER*4 :: iy ! y coordinate of receptor point (read from file) +real :: ix ! x coordinate of receptor point (read from file) +real :: iy ! y coordinate of receptor point (read from file) INTEGER*4 :: p ! receptor point number (dummy) INTEGER*4 :: ierr ! error status -REAL*4 :: lower +REAL*4 :: lower REAL*4 :: xmax ! maximum x coordinate of receptor points -REAL*4 :: xmax2 +REAL*4 :: xmax2 REAL*4 :: xmin ! minimum x coordinate of receptor points REAL*4 :: ymax ! maximum y coordinate of receptor points -REAL*4 :: ymax2 +REAL*4 :: ymax2 REAL*4 :: ymin ! minimum y coordinate of receptor points -REAL*4 :: x_rcp ! x coordinate receptor point -REAL*4 :: y_rcp ! y coordinate receptor point +REAL*4 :: x_rcp ! x coordinate receptor point +REAL*4 :: y_rcp ! y coordinate receptor point REAL*4 :: cellvalue ! value of masker grid cell at receptor point LOGICAL :: iscell ! whether point is inside masker grid CHARACTER*12 :: namrp ! name of receptor point ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) ! @@ -118,8 +118,8 @@ SUBROUTINE ops_get_dim(spgrid, igrens, xc, yc, grid, nrcol, nrrow, nrrcp, xorg, DO WHILE (GRID_XSTART + i*grid < NL_XLEFT) i=i+1 ENDDO - - + + xorg = (i-1)*grid + 0.5*grid ! Start from GRID_YSTART, move in steps of grid = grid resolution and get first index, such that y <= NL_YUPPER; @@ -154,7 +154,7 @@ SUBROUTINE ops_get_dim(spgrid, igrens, xc, yc, grid, nrcol, nrrow, nrrcp, xorg, ! ! In this case (grid with receptor points inside NL), a mask is generated with the current grid resolution, that fits NL; ! "masker" is an APS-grid (type TApsGridReal) with the requested grid resolution, which contains the fraction of NL area -! within a grid cell. +! within a grid cell. ! CALL gen_mask(grid, masker, error) IF (error%haserror) GOTO 9999 @@ -178,7 +178,7 @@ SUBROUTINE ops_get_dim(spgrid, igrens, xc, yc, grid, nrcol, nrrow, nrrcp, xorg, ENDIF ! User specified receptor points, spgrid = 2, 3 -ELSE +ELSE ! ! --- Read receptor file for first time, just to see how many records it contains --- ! It's data are assigned the second time, which is in ops_gen_rcp. @@ -273,11 +273,11 @@ SUBROUTINE gen_mask(grid, maskergrid, error) !------------------------------------------------------------------------------------------------------------------------------- ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'gen_mask') ! SUBROUTINE ARGUMENTS - INPUT -REAL*4, INTENT(IN) :: grid +REAL*4, INTENT(IN) :: grid ! SUBROUTINE ARGUMENTS - OUTPUT TYPE (TApsGridReal), INTENT(OUT) :: maskergrid ! APS-grid with fraction of area inside NL for each grid cell @@ -296,7 +296,7 @@ SUBROUTINE gen_mask(grid, maskergrid, error) INTEGER*4 :: nrrow ! number of rows in output mask grid REAL*4 :: outputres ! resolution of output mask grid [km] CHARACTER*1 :: gridname ! denotes direction 'x' or 'y' where error occurred when checking - ! for grid resolution conformity + ! for grid resolution conformity !------------------------------------------------------------------------------------------------------------------------------- ! @@ -306,12 +306,12 @@ SUBROUTINE gen_mask(grid, maskergrid, error) IF (error%haserror) GOTO 9999 ! -! Check whether the output grid resolution is an N times the resolution of the base grid (N integer). +! Check whether the output grid resolution is an N times the resolution of the base grid (N integer). ! If not, generate an error. -! Note: better to check this when reading the control file. +! Note: better to check this when reading the control file. ! -! First convert output resolution to km +! First convert output resolution to km outputres = grid /1000. ! Check ratio (output resolution) : (base grid resolution) and jump to error section if not ok @@ -349,7 +349,7 @@ SUBROUTINE gen_mask(grid, maskergrid, error) ! ALLOCATE (maskergrid%value(nrcol,nrrow,1)) -! Loop over output mask grid and compute fraction of area NL inside grid cell, +! Loop over output mask grid and compute fraction of area NL inside grid cell, ! i.e. the average of 0's and 1's of base grid that lie inside an output mask grid cell. ! Note that the accuracy of this area fraction depends on the ratio of the grid resolutions of ! the output mask grid and the base grid. diff --git a/ops_getlu.f90 b/ops_getlu.f90 index 0bcf067..377c2a8 100644 --- a/ops_getlu.f90 +++ b/ops_getlu.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Retrieve dominant landuse class and percentages of each landuse class for a specific point. @@ -44,7 +44,7 @@ SUBROUTINE ops_getlu(xr, yr, lugrid, landuse) USE m_commonconst ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'getlu') ! SUBROUTINE ARGUMENTS - INPUT @@ -53,7 +53,7 @@ SUBROUTINE ops_getlu(xr, yr, lugrid, landuse) TYPE (TApsGridInt), INTENT(IN) :: lugrid ! grid with landuse information ! SUBROUTINE ARGUMENTS - OUTPUT -INTEGER*4, INTENT(OUT) :: landuse(NLU+1) ! land-use value at (xr,yr); +INTEGER*4, INTENT(OUT) :: landuse(NLU+1) ! land-use value at (xr,yr); ! 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. diff --git a/ops_getlu_tra.f90 b/ops_getlu_tra.f90 index b5a63c2..bf3ff20 100644 --- a/ops_getlu_tra.f90 +++ b/ops_getlu_tra.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Compute dominant land use class and percentage of each land use @@ -47,7 +47,7 @@ SUBROUTINE ops_getlu_tra(xr, yr, xb, yb, lugrid, domlu, lu_tra_per) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_getlu_tra') ! SUBROUTINE ARGUMENTS - INPUT @@ -62,7 +62,7 @@ SUBROUTINE ops_getlu_tra(xr, yr, xb, yb, lugrid, domlu, lu_tra_per) REAL*4, INTENT(OUT) :: lu_tra_per(NLU) ! percentages of land use classes over trajectorie (over intermediate points) ! LOCAL VARIABLES -REAL*4 :: x ! x-coordinate intermediate point +REAL*4 :: x ! x-coordinate intermediate point REAL*4 :: y ! y-coordinate intermediate point INTEGER*4 :: lu_tra_per_sum(NLU) ! sum of percentages of land use classes over trajectorie (over intermediate points) INTEGER*4 :: lu_tra_dom ! dominant land use class over trajectory source-receptor @@ -71,8 +71,8 @@ SUBROUTINE ops_getlu_tra(xr, yr, xb, yb, lugrid, domlu, lu_tra_per) INTEGER*4 :: landuse(NLU+1) ! land use information at intermediate point; for locations outside lugrid ! a default land use class = 1 (grass) is taken. INTEGER*4 :: ludom ! maximum of dominant land use classes over intermediate points -INTEGER*4, DIMENSION(NLU) :: lu_count ! total number of intermediate points that have a certain land use class - +INTEGER*4, DIMENSION(NLU) :: lu_count ! total number of intermediate points that have a certain land use class + INTEGER*4 :: ns ! number of sub sectors between intermediate points !------------------------------------------------------------------------------------------------------------------------------- ! @@ -127,7 +127,7 @@ SUBROUTINE ops_getlu_tra(xr, yr, xb, yb, lugrid, domlu, lu_tra_per) IF (sum(lu_tra_per_sum(1:NLU)) .le. 0) THEN lu_tra_per_sum=0 lu_tra_per_sum(1)=100 -ENDIF +ENDIF ! ! Compute percentages per land use class diff --git a/ops_getz0.f90 b/ops_getz0.f90 index 04e2fba..d140f58 100644 --- a/ops_getz0.f90 +++ b/ops_getz0.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Retrieve roughness length z0 for a specific location. @@ -35,7 +35,7 @@ ! FILES AND OTHER : ! I/O DEVICES ! SYSTEM DEPENDENCIES: HP-Fortran -! CALLED FUNCTIONS : +! CALLED FUNCTIONS : ! UPDATE HISTORY : !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE ops_getz0(xr, yr, z0nlgrid, z0eurgrid, z0) @@ -45,7 +45,7 @@ SUBROUTINE ops_getz0(xr, yr, z0nlgrid, z0eurgrid, z0) USE m_commonconst ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_getz0') ! SUBROUTINE ARGUMENTS - INPUT @@ -67,7 +67,7 @@ SUBROUTINE ops_getz0(xr, yr, z0nlgrid, z0eurgrid, z0) LOGICAL :: iscell ! whether point is inside z0 grid !------------------------------------------------------------------------------------------------------------------------------- ! -! Retrieve z0 from NL grid (z0nlgrid). +! Retrieve z0 from NL grid (z0nlgrid). ! Note: arguments to GridValue must be in km. ! cellvalue = 0 @@ -82,7 +82,7 @@ SUBROUTINE ops_getz0(xr, yr, z0nlgrid, z0eurgrid, z0) ! ! Could not retrieve z0 from NL grid, so try European grid (z0eurgrid). ! the new z0eurgrid is in lambert azimuthal coordinatensystem. -! Before this was a geographical coordinatesystem. +! Before this was a geographical coordinatesystem. ! The gridsize of the geographical map was 0.5x0.5 grade, now it is 10x10 km. ! IF (z0eurgrid%gridheader%grixl == 0.5) THEN diff --git a/ops_getz0_tra.f90 b/ops_getz0_tra.f90 index f573f40..5d0a880 100644 --- a/ops_getz0_tra.f90 +++ b/ops_getz0_tra.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Compute average roughness length z0 over a trajectory. @@ -45,7 +45,7 @@ SUBROUTINE ops_getz0_tra(xr, yr, xb, yb, z0nlgrid, z0eurgrid, z0_tra) USE m_commonconst ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_getz0_tra') ! SUBROUTINE ARGUMENTS - INPUT @@ -75,7 +75,7 @@ SUBROUTINE ops_getz0_tra(xr, yr, xb, yb, z0nlgrid, z0eurgrid, z0_tra) ! ns=20 total=0. -! +! ! Loop over intermediate points ! DO i=0,ns @@ -89,7 +89,7 @@ SUBROUTINE ops_getz0_tra(xr, yr, xb, yb, z0nlgrid, z0eurgrid, z0_tra) ! CALL ops_getz0(x, y, z0nlgrid, z0eurgrid, z0) ! -! Add log(1/z0) to total +! Add log(1/z0) to total ! total = total + alog(1/z0) ENDDO diff --git a/ops_init.f90 b/ops_init.f90 index c650551..583a252 100644 --- a/ops_init.f90 +++ b/ops_init.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -28,7 +28,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Initialisation of variables based on data from the control file and on meteo statistics. @@ -43,7 +43,7 @@ SUBROUTINE ops_init (gasv, idep, building_present1, kdeppar, knatdeppar, ddeppar & 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, nam_subsec, buildingEffect, error) - + USE m_commonconst USE m_error USE m_ops_building @@ -51,91 +51,91 @@ SUBROUTINE ops_init (gasv, idep, building_present1, kdeppar, knatdeppar, ddeppar IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_init') ! SUBROUTINE ARGUMENTS - INPUT -LOGICAL, INTENT(IN) :: gasv -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 -INTEGER*4, INTENT(IN) :: ideh -INTEGER*4, INTENT(IN) :: icm -LOGICAL, INTENT(IN) :: isec -INTEGER*4, INTENT(IN) :: nsubsec ! number of sub-secondary species -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,MAXDISTR) -REAL*4, INTENT(IN) :: usdverl(NHRBLOCKS,MAXDISTR) -INTEGER*4, INTENT(IN) :: dv -INTEGER*4, INTENT(IN) :: usdv +LOGICAL, INTENT(IN) :: gasv +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 +INTEGER*4, INTENT(IN) :: ideh +INTEGER*4, INTENT(IN) :: icm +LOGICAL, INTENT(IN) :: isec +INTEGER*4, INTENT(IN) :: nsubsec ! number of sub-secondary species +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,MAXDISTR) +REAL*4, INTENT(IN) :: usdverl(NHRBLOCKS,MAXDISTR) +INTEGER*4, INTENT(IN) :: dv +INTEGER*4, INTENT(IN) :: usdv ! SUBROUTINE ARGUMENTS - I/O -INTEGER*4, INTENT(INOUT) :: knatdeppar -REAL*4, INTENT(INOUT) :: amol2 -CHARACTER*(*), INTENT(INOUT) :: namco -REAL*4, INTENT(INOUT) :: amol1 -REAL*4, INTENT(INOUT) :: dg -LOGICAL, INTENT(INOUT) :: irev -REAL*4, INTENT(INOUT) :: vchemc -REAL*4, INTENT(INOUT) :: vchemv -REAL*4, INTENT(INOUT) :: emtrend +INTEGER*4, INTENT(INOUT) :: knatdeppar +REAL*4, INTENT(INOUT) :: amol2 +CHARACTER*(*), INTENT(INOUT) :: namco +REAL*4, INTENT(INOUT) :: amol1 +REAL*4, INTENT(INOUT) :: dg +LOGICAL, INTENT(INOUT) :: irev +REAL*4, INTENT(INOUT) :: vchemc +REAL*4, INTENT(INOUT) :: vchemv +REAL*4, INTENT(INOUT) :: emtrend ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: rc -CHARACTER*(*), INTENT(OUT) :: coneh -REAL*4, INTENT(OUT) :: amol21 -CHARACTER*(*), INTENT(OUT) :: depeh -CHARACTER*(*), INTENT(OUT) :: namsec -CHARACTER*(*), INTENT(OUT) :: namse3 -REAL*4, INTENT(OUT) :: ugmoldep -REAL*4, INTENT(OUT) :: scavcoef -REAL*4, INTENT(OUT) :: rcno -REAL*4, INTENT(OUT) :: rhno2 -REAL*4, INTENT(OUT) :: rchno3 +REAL*4, INTENT(OUT) :: rc +CHARACTER*(*), INTENT(OUT) :: coneh +REAL*4, INTENT(OUT) :: amol21 +CHARACTER*(*), INTENT(OUT) :: depeh +CHARACTER*(*), INTENT(OUT) :: namsec +CHARACTER*(*), INTENT(OUT) :: namse3 +REAL*4, INTENT(OUT) :: ugmoldep +REAL*4, INTENT(OUT) :: scavcoef +REAL*4, INTENT(OUT) :: rcno +REAL*4, INTENT(OUT) :: rhno2 +REAL*4, INTENT(OUT) :: rchno3 REAL*4, INTENT(OUT) :: routsec ! in-cloud scavenging ratio for secondary component - ! (rout << rain-out = in-cloud) [-] + ! (rout << rain-out = in-cloud) [-] REAL*4, INTENT(OUT) :: routpri ! in-cloud scavenging ratio for primary component ! (rout << rain-out = in-cloud) [-] REAL*4, INTENT(OUT) :: conc_cf -REAL*4, INTENT(OUT) :: koh -REAL*4, INTENT(OUT) :: croutpri ! constant (initial) in-cloud scavenging ratio [-] for primary component -REAL*4, INTENT(OUT) :: somcsec -REAL*4, INTENT(OUT) :: ar -REAL*4, INTENT(OUT) :: rno2nox -REAL*4, INTENT(OUT) :: ecvl(NSTAB, NTRAJ, *) -CHARACTER*(*), INTENT(OUT) :: nam_subsec(nsubsec) +REAL*4, INTENT(OUT) :: koh +REAL*4, INTENT(OUT) :: croutpri ! constant (initial) in-cloud scavenging ratio [-] for primary component +REAL*4, INTENT(OUT) :: somcsec +REAL*4, INTENT(OUT) :: ar +REAL*4, INTENT(OUT) :: rno2nox +REAL*4, INTENT(OUT) :: ecvl(NSTAB, NTRAJ, *) +CHARACTER*(*), INTENT(OUT) :: nam_subsec(nsubsec) 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 -CHARACTER*512 :: line +INTEGER*4 :: i +INTEGER*4 :: j +INTEGER*4 :: ndv +INTEGER*4 :: itraj +INTEGER*4 :: istab +INTEGER*4 :: iu +REAL*4 :: vgmax +REAL*4 :: som +CHARACTER*512 :: line ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! -! Limit emission trend correction factor; if emtrend = 0 -> emtrend = 1 +! Limit emission trend correction factor; if emtrend = 0 -> emtrend = 1 ! IF (ABS(emtrend) .LE. EPS_DELTA) emtrend = 1. ! ! Parameterisation substance properties ! -! Molecular weight [g/mol] for secondary component equals amol1, by default +! Molecular weight [g/mol] for secondary component equals amol1, by default amol2 = amol1 ! Default concentration correction factor @@ -154,10 +154,10 @@ SUBROUTINE ops_init (gasv, idep, building_present1, kdeppar, knatdeppar, ddeppar IF (.NOT.isec) THEN ! Secondary components not present (so not SO2, NOx or NH3). - ! Compute surface resistance Rc [s/m], scavenging rate (scavcoef [%/h]) or scavenging ratio W (routpri [-]), + ! Compute surface resistance Rc [s/m], scavenging rate (scavcoef [%/h]) or scavenging ratio W (routpri [-]), ! diffusion coefficient in air (dg [cm^2/s]) (according to Durham et al, 1981: Atm Env. 15, 1059-1068) ! and logical irev (reversible uptake of gas in droplets is possible) - IF (kdeppar .EQ. 1) rc = 1./ddeppar - 1./SQRT(vgmax*ddeppar) ! if ddeppar = vgmax -> Rc = 0; + IF (kdeppar .EQ. 1) rc = 1./ddeppar - 1./SQRT(vgmax*ddeppar) ! if ddeppar = vgmax -> Rc = 0; ! ddeppar < vgmax is not possible (check in ops_read_ctr) IF (kdeppar .EQ. 2) rc = ddeppar @@ -165,7 +165,7 @@ SUBROUTINE ops_init (gasv, idep, building_present1, kdeppar, knatdeppar, ddeppar ! note: amol2 = amol1 IF (knatdeppar .EQ. 1) THEN scavcoef = wdeppar - dg = SQRT(1./amol2) + dg = SQRT(1./amol2) irev = .FALSE. ELSEIF (knatdeppar .EQ. 2) THEN routpri = wdeppar @@ -174,7 +174,7 @@ SUBROUTINE ops_init (gasv, idep, building_present1, kdeppar, knatdeppar, ddeppar ELSE routpri=wdeppar ENDIF - + ELSE ! secondary components present [SO2, NO2, NH3] -> knatdeppar = 3. @@ -186,13 +186,13 @@ SUBROUTINE ops_init (gasv, idep, building_present1, kdeppar, knatdeppar, ddeppar ! (rout << rain-out = in-cloud) [-]) ! conc_cf : concentration correction factor for output. ! Section 6.3 OPS report FS - + knatdeppar = 3 scavcoef = 0 ! icm = 1: SO2 (secondary component SO4) IF (icm .EQ. 1) THEN - amol2 = 96. + amol2 = 96. croutpri = 100000. routsec = 2.0e6 conc_cf = 1. @@ -203,27 +203,27 @@ SUBROUTINE ops_init (gasv, idep, building_present1, kdeppar, knatdeppar, ddeppar croutpri = 20000. routsec = 1.4e7 - ! Set parameters specific for NOx + ! Set parameters specific for NOx ! rhno2 : ratio [HNO2]/[NOx] based on measurements Speuld, Slanina et al 1990, but they report 4% (p. 66 OPS report) FS - ! koh : second order reaction rate constant of reaction NO2 + OH -> HNO3 [cm3/(molec s)] + ! koh : second order reaction rate constant of reaction NO2 + OH -> HNO3 [cm3/(molec s)] ! Baulch et al 1982 (OPS report Table 6.2 FS): kOH = 1.035e-11 cm3/(molec s) = 1000.9 ppb-1 h-1, at T = 0 C ! = 932.6 ppb-1 h-1, at T = 20 C ! = 917.0 ppb-1 h-1, at T = 25 C - ! Baulch D.L., Cox, R.A. Crutzen P.J., Hampson R.F. Jr., Kerr, F.A. Troe, J. and Watson R.P. (1982) + ! Baulch D.L., Cox, R.A. Crutzen P.J., Hampson R.F. Jr., Kerr, F.A. Troe, J. and Watson R.P. (1982) ! Evaluated kinetic and photochemical data for atmospheric chemistry: J. Phys. Chem. Ref. Data 11 (Suppl. 1), 327-496. ! conc_cf: correction factor (8%) for NOx (to account for HNO2 and PAN contributions to NO2) - ! rcno : surface resistance NO (set at 'high' value) [s/m] + ! rcno : surface resistance NO (set at 'high' value) [s/m] ! rchno3 : surface resistance HNO3 (set at 'low' value) [s/m] - + rhno2 = 0.03 koh = 1020.*0.9 ! = 918 ppb-1 h-1 rcno = 2000 rchno3 = 10 conc_cf = 1./1.08 - ! + ! icm = 3: NH3 (secondary component NH4) - ! + ELSE IF (icm .EQ. 3) THEN amol2 = 18. croutpri = 1.4e6 @@ -258,10 +258,10 @@ SUBROUTINE ops_init (gasv, idep, building_present1, kdeppar, knatdeppar, ddeppar ! ! Units for concentration and deposition and conversion factors ! (see m_commonconst for definition of UNITS and DEPUNITS). -! Note: +! Note: ! 1/(number of seconds in an hour) = 1/3600 = 0.278e-3 ! number of hours in a year = 8760 -! amol2 = molecular weight secondary component in g/mol +! amol2 = molecular weight secondary component in g/mol ! IF (icm .EQ. 2) THEN ! NOx coneh = UNITS(2) ! ug/m3 NO2 @@ -292,9 +292,9 @@ SUBROUTINE ops_init (gasv, idep, building_present1, kdeppar, knatdeppar, ddeppar ! ! Set ar and rno2nox. ! -! ar = proportionality constant [ppb J-1 cm2 h] in relation [OH] = ar Qr, with -! [OH] = OH radical concentration [ppb] , Qr = global radiation in J/cm2/h, see -! Van Egmond N.D. and Kesseboom H. (1985) A numerical mesoscale model for long-term average NOx and NO2-concentration. +! ar = proportionality constant [ppb J-1 cm2 h] in relation [OH] = ar Qr, with +! [OH] = OH radical concentration [ppb] , Qr = global radiation in J/cm2/h, see +! Van Egmond N.D. and Kesseboom H. (1985) A numerical mesoscale model for long-term average NOx and NO2-concentration. ! Atmospheric Environment 19, 587-595. ! Table 6.1 OPS-report: ! ar(summer) = 7345 molec cm-3 W-1 m2 @@ -315,7 +315,7 @@ SUBROUTINE ops_init (gasv, idep, building_present1, kdeppar, knatdeppar, ddeppar ! Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec ! 32.1 40.1 54.0 70.0 83.9 91.9 91.9 83.9 70.0 54.0 40.1 32.1 *1e-8 ! -! rno2nox = season dependent [NO2]/[NOx] ratio, see Table 6.3 OPS report for stability class S2: +! rno2nox = season dependent [NO2]/[NOx] ratio, see Table 6.3 OPS report for stability class S2: ! rno2nox(summer) = 0.78, rno2nox(winter) = 0.58; rno2nox(year) = average of summer and winter value = 0.68. ! For a specific month, 2 cos-functions are used, such that rno2nox(Feb) = 0.57, rno2nox(Aug) = 0.78: ! Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec @@ -355,10 +355,10 @@ SUBROUTINE ops_init (gasv, idep, building_present1, kdeppar, knatdeppar, ddeppar som = 0. ecvl(istab, itraj, :ndv) = 0. - ! Loop over hour blocks and compute, for each stability/distance class, the average over hours: - ! ecvl = weighed average of diurnal emission variation; + ! Loop over hour blocks and compute, for each stability/distance class, the average over hours: + ! ecvl = weighed average of diurnal emission variation; ! weighing factors are astat(17): distribution of stability classes over day, source oriented [-]. - + ! Factor 1.0e-2 is to convert from dverl as percentage to ecvl as fraction. ! Note: astat() has been filled with meteo parameters of most central region in NL (region 5); see ops_statfil @@ -371,7 +371,7 @@ SUBROUTINE ops_init (gasv, idep, building_present1, kdeppar, knatdeppar, ddeppar ecvl(istab, itraj, i) = ecvl(istab, itraj, i) + dverl(iu, i) * astat(itraj, 17, istab, iu)*1.e-2 ENDDO ! -! Add contribution of user specified diurnal emission variation. If there is no user specified emission variation +! Add contribution of user specified diurnal emission variation. If there is no user specified emission variation ! (usdvnam has string length 0), then ndv = dv and we have an empty loop. ! DO i = dv+1, ndv @@ -386,7 +386,7 @@ SUBROUTINE ops_init (gasv, idep, building_present1, kdeppar, knatdeppar, ddeppar ENDDO ENDDO -! Read building effect tables: +! Read building effect tables: if (building_present1) then call ops_building_read_tables(buildingEffect,error) !write(*,*) 'ops_init/classdefinitionArray: ',buildingEffect%classdefinitionArray @@ -396,6 +396,6 @@ SUBROUTINE ops_init (gasv, idep, building_present1, kdeppar, knatdeppar, ddeppar RETURN -9999 CALL ErrorCall(ROUTINENAAM, error) +9999 CALL ErrorCall(ROUTINENAAM, error) END SUBROUTINE ops_init diff --git a/ops_logfile.f90 b/ops_logfile.f90 index 16d195c..7c47af2 100644 --- a/ops_logfile.f90 +++ b/ops_logfile.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -26,7 +26,7 @@ ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-F77/90 ! DESCRIPTION : Handling of log file. The log file is only opened and closed if something is written to it. @@ -58,14 +58,14 @@ FUNCTION ops_openlog(error) LOGICAL :: isopen ! file is open ! FUNCTION RESULT -LOGICAL :: ops_openlog ! +LOGICAL :: ops_openlog ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_openlog') ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) ! ! Inquire whether the log file is already opened. If not so, open the log file. @@ -101,10 +101,10 @@ SUBROUTINE ops_closelog(error) ! LOCAL VARIABLES LOGICAL :: isopen ! file is open -LOGICAL :: haderror ! +LOGICAL :: haderror ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_closelog') ! ! We also come here when an error has already occurred. In that case this routine should not appear in the traceback. This is diff --git a/ops_main.f90 b/ops_main.f90 index ff8e4d8..f28a499 100644 --- a/ops_main.f90 +++ b/ops_main.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/FORTRAN-90 ! DESCRIPTION : @@ -41,30 +41,30 @@ ! ! The OPS-model is a long-term Lagrangian transport and deposition model that describes ! relations between individual sources or source areas, and individual receptors. The model is statistical in -! the sense that concentration and deposition values are calculated for a number of typical situations -! (distance/meteo classes) and the long-term value is obtained by summation of these values, weighed with +! the sense that concentration and deposition values are calculated for a number of typical situations +! (distance/meteo classes) and the long-term value is obtained by summation of these values, weighed with ! their relative frequencies. All relations governing the transport and deposition process are solved analytically, ! allowing the use of nongridded receptors and sources, and variable grid sizes. ! ! Meteo data for the requested period are read from a meteo statistics file, which has been prepared before (meteo-preprocessor). -! In this meteo statistics file, there are four distance classes: 0-100, 100-300, 300-1000 and >1000 km, 6 stability classes +! In this meteo statistics file, there are four distance classes: 0-100, 100-300, 300-1000 and >1000 km, 6 stability classes ! (neutral/stable/unstable, each with a relatively high or low mixing height) and 12 wind sectors of 30 degrees. ! ! OPS computes long term (1 month to 10 year) concentration and deposition at receptor points, either in a regularly spaced grid, -! or at user specified locations, e.g. locations of measuring stations. +! or at user specified locations, e.g. locations of measuring stations. ! ! EXIT CODES : ! REFERENCE : ! FILES AND I/O DEVICES : ! SYSTEM DEPENDENCIES : HP-Fortran ! CALLED FUNCTIONS : -! UPDATE HISTORY : +! UPDATE HISTORY : ! 2012-01-24, : documentation added; also references to OPS-report. In close cooperation ! with . ! DISCLAIMER: although care has been taken to make the documentation as clear as possible, -! it should be noted that documentation has been added some 20 years after the start of the model. +! it should be noted that documentation has been added some 20 years after the start of the model. ! This means that not all references have been resolved and that in some cases, source code -! may have been misinterpreted. +! may have been misinterpreted. !------------------------------------------------------------------------------------------------------------------------------- PROGRAM ops_main @@ -76,13 +76,15 @@ PROGRAM ops_main USE m_error USE m_commonconst USE m_commonfile +#ifndef GNU USE IFPORT +#endif USE m_ops_vchem IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_main') ! LOCAL VARIABLES @@ -90,36 +92,36 @@ PROGRAM ops_main INTEGER*4 :: numbron INTEGER*4 :: ncatsel ! number of categories selected INTEGER*4 :: nlandsel ! number of countries selected -INTEGER*4 :: spgrid -INTEGER*4 :: landmax -INTEGER*4 :: nbron -INTEGER*4 :: nsbuf -INTEGER*4 :: btgedr(LSBUF) -INTEGER*4 :: bdegr(LSBUF) -INTEGER*4 :: bcatnr(LSBUF) -INTEGER*4 :: blandnr(LSBUF) -INTEGER*4 :: bx(LSBUF) -INTEGER*4 :: by(LSBUF) -INTEGER*4 :: bnr(LSBUF) +INTEGER*4 :: spgrid +INTEGER*4 :: landmax +INTEGER*4 :: nbron +INTEGER*4 :: nsbuf +INTEGER*4 :: btgedr(LSBUF) +INTEGER*4 :: bdegr(LSBUF) +INTEGER*4 :: bcatnr(LSBUF) +INTEGER*4 :: blandnr(LSBUF) +INTEGER*4 :: bx(LSBUF) +INTEGER*4 :: by(LSBUF) +INTEGER*4 :: bnr(LSBUF) type(TbuildingEffect) :: buildingEffect ! structure with building effect tables -INTEGER*4 :: jb -INTEGER*4 :: mb -INTEGER*4 :: idb -INTEGER*4 :: jt -INTEGER*4 :: mt -INTEGER*4 :: idt -INTEGER*4 :: dv -INTEGER*4 :: usdv -INTEGER*4 :: iseiz -INTEGER*4 :: icm -INTEGER*4 :: nsubsec ! number of sub-secondary species -INTEGER*4 :: nrrcp -INTEGER*4 :: nrcol -INTEGER*4 :: nrrow -INTEGER*4 :: intpol -INTEGER*4 :: kdeppar -INTEGER*4 :: knatdeppar -INTEGER*4 :: ideh +INTEGER*4 :: jb +INTEGER*4 :: mb +INTEGER*4 :: idb +INTEGER*4 :: jt +INTEGER*4 :: mt +INTEGER*4 :: idt +INTEGER*4 :: dv +INTEGER*4 :: usdv +INTEGER*4 :: iseiz +INTEGER*4 :: icm +INTEGER*4 :: nsubsec ! number of sub-secondary species +INTEGER*4 :: nrrcp +INTEGER*4 :: nrcol +INTEGER*4 :: nrrow +INTEGER*4 :: intpol +INTEGER*4 :: kdeppar +INTEGER*4 :: knatdeppar +INTEGER*4 :: ideh INTEGER*4 :: i INTEGER*4 :: ircp INTEGER*4 :: mmm @@ -127,9 +129,9 @@ PROGRAM ops_main INTEGER*4 :: lu_rcp_dom ! dominant landuse class at receptor point REAL*4 :: lu_tra_per(NLU) ! percentages of landuse classes over trajectorie REAL*4 :: lu_rcp_per(NLU) ! percentages of landuse classes at receptor points -INTEGER*4 :: i1(NTRAJ-1) ! -INTEGER*4 :: year -INTEGER*4 :: memdone +INTEGER*4 :: i1(NTRAJ-1) +INTEGER*4 :: year +INTEGER*4 :: memdone INTEGER*4 :: maxidx ! max. value of NPARTCLASS INTEGER*4 :: result ! returncode of system call INTEGER*4 :: ierr ! error code for array allocation @@ -138,151 +140,151 @@ PROGRAM ops_main INTEGER*4 :: bottom REAL*4 :: aind ! hourglass -REAL*4 :: amol2 -REAL*4 :: amol21 -REAL*4 :: z0_metreg_user ! roughness length of user specified meteo region [m] +REAL*4 :: amol2 +REAL*4 :: amol21 +REAL*4 :: z0_metreg_user ! roughness length of user specified meteo region [m] REAL*4 :: z0_user ! roughness length specified by user [m] REAL*4 :: z0_metreg_rcp ! roughness length at receptor; interpolated from meteo regions [m] REAL*4 :: z0_rcp ! roughness length at receptor; from z0-map [m] REAL*4 :: z0_src ! roughness length at source; from z0-map [m] REAL*4 :: z0_tra ! roughness length representative for trajectory [m] -REAL*4 :: vchemc -INTEGER*4 :: iopt_vchem ! option for chemical conversion rate (0 = old OPS, 1 = EMEP) -REAL*4 :: vchemv -REAL*4 :: xc -REAL*4 :: yc -REAL*4 :: rc -REAL*4 :: ugmoldep -REAL*4 :: gemre -REAL*4 :: somcsec +REAL*4 :: vchemc +INTEGER*4 :: iopt_vchem ! option for chemical conversion rate (0 = old OPS, 1 = EMEP) +REAL*4 :: vchemv +REAL*4 :: xc +REAL*4 :: yc +REAL*4 :: rc +REAL*4 :: ugmoldep +REAL*4 :: gemre +REAL*4 :: somcsec REAL*4 :: gemcpri -REAL*4 :: gemcsec -REAL*4 :: totddep -REAL*4 :: gemddep -REAL*4 :: gemddpri -REAL*4 :: gemddsec -REAL*4 :: ddrpri -REAL*4 :: ddrsec -REAL*4 :: totwdep -REAL*4 :: gemwdep -REAL*4 :: gemwdpri -REAL*4 :: gemwdsec -REAL*4 :: wdrpri -REAL*4 :: wdrsec -REAL*4 :: tottdep -REAL*4 :: gemtdep -REAL*4 :: gemprec -REAL*4 :: ccr -REAL*4 :: xorg -REAL*4 :: yorg -REAL*4 :: bdiam(LSBUF) -REAL*4 :: bsterkte(LSBUF) -REAL*4 :: bwarmte(LSBUF) -REAL*4 :: bhoogte(LSBUF) -REAL*4 :: bsigmaz(LSBUF) +REAL*4 :: gemcsec +REAL*4 :: totddep +REAL*4 :: gemddep +REAL*4 :: gemddpri +REAL*4 :: gemddsec +REAL*4 :: ddrpri +REAL*4 :: ddrsec +REAL*4 :: totwdep +REAL*4 :: gemwdep +REAL*4 :: gemwdpri +REAL*4 :: gemwdsec +REAL*4 :: wdrpri +REAL*4 :: wdrsec +REAL*4 :: tottdep +REAL*4 :: gemtdep +REAL*4 :: gemprec +REAL*4 :: ccr +REAL*4 :: xorg +REAL*4 :: yorg +REAL*4 :: bdiam(LSBUF) +REAL*4 :: bsterkte(LSBUF) +REAL*4 :: bwarmte(LSBUF) +REAL*4 :: bhoogte(LSBUF) +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] +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) +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 -REAL*4 :: rno2nox -REAL*4 :: uurtot -REAL*4 :: zf -REAL*4 :: trafst(NTRAJ) -REAL*4 :: bqrv(LSBUF) -REAL*4 :: bqtr(LSBUF) -REAL*4 :: cs(NTRAJ, NCOMP, NSTAB, NSEK, NMETREG) -REAL*4 :: rainreg(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*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 -REAL*4 :: wdeppar -REAL*4 :: scavcoef +REAL*4 :: astat(NTRAJ, NCOMP, NSTAB, NSEK) +REAL*4 :: ar +REAL*4 :: rno2nox +REAL*4 :: uurtot +REAL*4 :: zf +REAL*4 :: trafst(NTRAJ) +REAL*4 :: bqrv(LSBUF) +REAL*4 :: bqtr(LSBUF) +REAL*4 :: cs(NTRAJ, NCOMP, NSTAB, NSEK, NMETREG) +REAL*4 :: rainreg(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*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 +REAL*4 :: wdeppar +REAL*4 :: scavcoef REAL*4 :: routsec ! in-cloud scavenging ratio for secondary component ! (rout << rain-out = in-cloud) [-] REAL*4 :: routpri ! in-cloud scavenging ratio for primary component ! (rout << rain-out = in-cloud) [-] -REAL*4 :: croutpri ! constant (initial) in-cloud scavenging ratio [-] for primary component -REAL*4 :: rcno -REAL*4 :: rhno2 -REAL*4 :: rchno3 -REAL*4 :: dg -REAL*4 :: dispg(NSTAB) -REAL*4 :: ddeppar -REAL*4 :: koh -REAL*4 :: so2sek(NSEK) -REAL*4 :: no2sek(NSEK) -REAL*4, DIMENSION(:), POINTER :: gem_subsec ! grid mean for concentration of sub-secondary species [ug/m3] -REAL*4 :: scale_con -REAL*4 :: scale_sec -REAL*4, DIMENSION(:), POINTER :: scale_subsec -REAL*4 :: scale_dep -REAL*4 :: so2bgtra ! -REAL*4 :: no2bgtra ! -REAL*4 :: nh3bgtra ! -type(Tvchem) :: vchem2 -REAL*8, DIMENSION(:), POINTER :: sdrypri_arr -REAL*8 :: sdrypri -REAL*8, DIMENSION(:), POINTER :: snatpri_arr -REAL*8 :: snatpri -REAL*8, DIMENSION(:), POINTER :: somvnpri_arr -REAL*8 :: somvnpri -REAL*8, DIMENSION(:), POINTER :: telvnpri_arr -REAL*8 :: telvnpri -REAL*8, DIMENSION(:), POINTER :: sdrysec_arr -REAL*8 :: sdrysec -REAL*8, DIMENSION(:), POINTER :: snatsec_arr -REAL*8 :: snatsec -REAL*8, DIMENSION(:), POINTER :: somvnsec_arr -REAL*8 :: somvnsec -REAL*8, DIMENSION(:), POINTER :: telvnsec_arr -REAL*8 :: telvnsec -REAL*8, DIMENSION(:), POINTER :: vvchem_arr -REAL*8 :: vvchem -REAL*8, DIMENSION(:), POINTER :: vtel_arr -REAL*8 :: vtel - -CHARACTER*512 :: namco -CHARACTER*80 :: project -CHARACTER*80 :: runid -CHARACTER*80 :: namsec -CHARACTER*80, DIMENSION(:), POINTER :: nam_subsec -CHARACTER*80 :: namse3 -CHARACTER*10 :: coneh -CHARACTER*10 :: depeh -CHARACTER*80 :: dll_version -CHARACTER*80 :: dll_date - -LOGICAL*4 :: f_z0user -LOGICAL :: presentcode(MAXDISTR,4) -LOGICAL :: verb -LOGICAL :: isec -LOGICAL :: igrens -LOGICAL :: igrid -LOGICAL :: checked -LOGICAL :: irev -LOGICAL :: gasv -LOGICAL :: idep -LOGICAL :: eof -LOGICAL :: subbron +REAL*4 :: croutpri ! constant (initial) in-cloud scavenging ratio [-] for primary component +REAL*4 :: rcno +REAL*4 :: rhno2 +REAL*4 :: rchno3 +REAL*4 :: dg +REAL*4 :: dispg(NSTAB) +REAL*4 :: ddeppar +REAL*4 :: koh +REAL*4 :: so2sek(NSEK) +REAL*4 :: no2sek(NSEK) +REAL*4, DIMENSION(:), POINTER :: gem_subsec ! grid mean for concentration of sub-secondary species [ug/m3] +REAL*4 :: scale_con +REAL*4 :: scale_sec +REAL*4, DIMENSION(:), POINTER :: scale_subsec +REAL*4 :: scale_dep +REAL*4 :: so2bgtra +REAL*4 :: no2bgtra +REAL*4 :: nh3bgtra +type(Tvchem) :: vchem2 +REAL*8, DIMENSION(:), POINTER :: sdrypri_arr +REAL*8 :: sdrypri +REAL*8, DIMENSION(:), POINTER :: snatpri_arr +REAL*8 :: snatpri +REAL*8, DIMENSION(:), POINTER :: somvnpri_arr +REAL*8 :: somvnpri +REAL*8, DIMENSION(:), POINTER :: telvnpri_arr +REAL*8 :: telvnpri +REAL*8, DIMENSION(:), POINTER :: sdrysec_arr +REAL*8 :: sdrysec +REAL*8, DIMENSION(:), POINTER :: snatsec_arr +REAL*8 :: snatsec +REAL*8, DIMENSION(:), POINTER :: somvnsec_arr +REAL*8 :: somvnsec +REAL*8, DIMENSION(:), POINTER :: telvnsec_arr +REAL*8 :: telvnsec +REAL*8, DIMENSION(:), POINTER :: vvchem_arr +REAL*8 :: vvchem +REAL*8, DIMENSION(:), POINTER :: vtel_arr +REAL*8 :: vtel + +CHARACTER*512 :: namco +CHARACTER*80 :: project +CHARACTER*80 :: runid +CHARACTER*80 :: namsec +CHARACTER*80, DIMENSION(:), POINTER :: nam_subsec +CHARACTER*80 :: namse3 +CHARACTER*10 :: coneh +CHARACTER*10 :: depeh +CHARACTER*80 :: dll_version +CHARACTER*80 :: dll_date + +LOGICAL*4 :: f_z0user +LOGICAL :: presentcode(MAXDISTR,4) +LOGICAL :: verb +LOGICAL :: isec +LOGICAL :: igrens +LOGICAL :: igrid +LOGICAL :: checked +LOGICAL :: irev +LOGICAL :: gasv +LOGICAL :: idep +LOGICAL :: eof +LOGICAL :: subbron LOGICAL :: domlu -LOGICAL :: varz ! indicator whether value for receptorheight is read from receptorfile +LOGICAL :: varz ! indicator whether value for receptorheight is read from receptorfile LOGICAL :: perc ! indicator whether percentages for landuse are read from receptorfile -LOGICAL :: outputfile_opened +LOGICAL :: outputfile_opened !LOGICAL :: iscell ! whether point is inside masker grid INTEGER*4, DIMENSION(:), POINTER :: catsel ! selection of categories (0: all categories) @@ -290,61 +292,61 @@ PROGRAM ops_main INTEGER*4, DIMENSION(:), POINTER :: lu_rcp_dom_all ! land use at receptor points INTEGER*4, DIMENSION(:), POINTER :: jump ! indices skipped because grid cell is outside NL -REAL*4, DIMENSION(:), POINTER :: xm -REAL*4, DIMENSION(:), POINTER :: ym -REAL*4, DIMENSION(:), POINTER :: zm +REAL*4, DIMENSION(:), POINTER :: xm +REAL*4, DIMENSION(:), POINTER :: ym +REAL*4, DIMENSION(:), POINTER :: zm REAL*4, DIMENSION(:), POINTER :: frac ! fraction of output cell on land surface INTEGER, DIMENSION(:,:), POINTER :: lu_rcp_per_user_all ! percentage of landuse for all receptors, used defined in receptor file -REAL*4, DIMENSION(:), POINTER :: gxm -REAL*4, DIMENSION(:), POINTER :: gym +REAL*4, DIMENSION(:), POINTER :: gxm +REAL*4, DIMENSION(:), POINTER :: gym REAL*4, DIMENSION(:), POINTER :: z0_rcp_all ! roughness lengths for all receptors; from z0-map or receptor file [m] -REAL*4, DIMENSION(:), POINTER :: rhno3_rcp -REAL*4, DIMENSION(:,:), ALLOCATABLE :: f_subsec_rcp ! fractions for sub-secondary species, HNO3/NO3_total, NO3_C/NO3_total, NO3_F/NO3_total [-] -REAL*4, DIMENSION(:), POINTER :: precip +REAL*4, DIMENSION(:), POINTER :: rhno3_rcp +REAL*4, DIMENSION(:,:), ALLOCATABLE :: f_subsec_rcp ! fractions for sub-secondary species, HNO3/NO3_total, NO3_C/NO3_total, NO3_F/NO3_total [-] +REAL*4, DIMENSION(:), POINTER :: precip DOUBLE PRECISION, DIMENSION(:,:), POINTER :: cpri_d ! concentration of primary component, double precision [ug/m3] REAL*4, DIMENSION(:), POINTER :: cpri ! concentration of primary component [ug/m3] DOUBLE PRECISION, DIMENSION(:,:), POINTER :: csec_d ! concentration of secondary component, double precision [ug/m3] REAL*4, DIMENSION(:), POINTER :: csec ! concentration of secondary component [ug/m3] -DOUBLE PRECISION, DIMENSION(:,:), POINTER :: drydep_d -REAL*4, DIMENSION(:), POINTER :: drydep -DOUBLE PRECISION, DIMENSION(:,:), POINTER :: wetdep_d -REAL*4, DIMENSION(:), POINTER :: wetdep -DOUBLE PRECISION, DIMENSION(:,:), POINTER :: ddepri_d -REAL*4, DIMENSION(:), POINTER :: ddepri -REAL*4, DIMENSION(:), POINTER :: totdep -REAL*4, DIMENSION(:,:), POINTER :: csubsec ! concentration of sub-secondary species [ug/m3] -REAL*4, DIMENSION(:), POINTER :: nh3bg_rcp -REAL*4, DIMENSION(:), POINTER :: so2bg_rcp +DOUBLE PRECISION, DIMENSION(:,:), POINTER :: drydep_d +REAL*4, DIMENSION(:), POINTER :: drydep +DOUBLE PRECISION, DIMENSION(:,:), POINTER :: wetdep_d +REAL*4, DIMENSION(:), POINTER :: wetdep +DOUBLE PRECISION, DIMENSION(:,:), POINTER :: ddepri_d +REAL*4, DIMENSION(:), POINTER :: ddepri +REAL*4, DIMENSION(:), POINTER :: totdep +REAL*4, DIMENSION(:,:), POINTER :: csubsec ! concentration of sub-secondary species [ug/m3] +REAL*4, DIMENSION(:), POINTER :: nh3bg_rcp +REAL*4, DIMENSION(:), POINTER :: so2bg_rcp REAL*4, DIMENSION(:), POINTER :: rno2_nox_sum ! NO2/NOx ratio, weighed sum over classes CHARACTER*12, DIMENSION(:), POINTER :: namrcp ! receptor names TYPE (TApsGridInt) :: z0nlgrid ! map of roughness lengths in NL [m] -TYPE (TApsGridInt) :: lugrid +TYPE (TApsGridInt) :: lugrid TYPE (TApsGridInt) :: z0eurgrid ! map of roughness lengths in Europe [m] -TYPE (TApsGridReal) :: so2bggrid -TYPE (TApsGridReal) :: no2bggrid -TYPE (TApsGridReal) :: nh3bggrid -TYPE (TApsGridReal) :: f_subsec_grid ! grids of fractions for sub-secondary species, HNO3/NO3_total, NO3_C/NO3_total, NO3_F/NO3_total [-] -TYPE (TApsGridReal) :: masker -TYPE (TError) :: error +TYPE (TApsGridReal) :: so2bggrid +TYPE (TApsGridReal) :: no2bggrid +TYPE (TApsGridReal) :: nh3bggrid +TYPE (TApsGridReal) :: f_subsec_grid ! grids of fractions for sub-secondary species, HNO3/NO3_total, NO3_C/NO3_total, NO3_F/NO3_total [-] +TYPE (TApsGridReal) :: masker +TYPE (TError) :: error ! ! SCCS-ID VARIABLES ! -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! DATA: DATA dispg /.28,.28,.20,.20,.12,.20/ ! -! Set coefficients in correction factors for SO2 background concentration for each wind direction sector +! Set coefficients in correction factors for SO2 background concentration for each wind direction sector ! derived from 24 regional LML stations over 2003 (eastern wind -> higher SO2) ! DATA so2sek /0.77, 0.73, 0.88, 1.09, 1.30, 1.34, 1.28, 1.14, 0.97, 0.94, 0.90, 0.77/ ! -! Set coefficients in correction factor for nO2 background concentration for each wind direction sector +! Set coefficients in correction factor for nO2 background concentration for each wind direction sector ! derived from 15 regional LML stations over 2004 (eastern wind -> higher NO2) ! 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/ @@ -368,11 +370,11 @@ PROGRAM ops_main IF (diag == 3) THEN WRITE(6,*) "dll's used by OPS:" CALL get_version_core(dll_version, dll_date) - WRITE(6,*) 'ops_core version: ',dll_version(1:LEN_TRIM(dll_version)),'; Release date: ', dll_date(1:11) + WRITE(6,*) 'ops_core version: ',dll_version(1:LEN_TRIM(dll_version)),'; Release date: ', dll_date(1:11) CALL get_version_depac(dll_version, dll_date) - WRITE(6,*) 'depac version: ',dll_version(1:LEN_TRIM(dll_version)),'; Release date: ', dll_date(1:11) + WRITE(6,*) 'depac version: ',dll_version(1:LEN_TRIM(dll_version)),'; Release date: ', dll_date(1:11) CALL get_version_utils(dll_version, dll_date) - WRITE(6,*) 'ops_utils version: ',dll_version(1:LEN_TRIM(dll_version)),'; Release date: ', dll_date(1:11) + WRITE(6,*) 'ops_utils version: ',dll_version(1:LEN_TRIM(dll_version)),'; Release date: ', dll_date(1:11) ENDIF GOTO 1000 ! GOTO error handling at end of program ELSEIF (diag == 2) THEN @@ -436,7 +438,7 @@ PROGRAM ops_main CALL ReadAps(z0eurnam, 'z0 grid Europe', z0eurgrid, error) IF (error%haserror) GOTO 1000 ! GOTO error handling at end of program - ! Note; for other primary components than acidifying components (which have secondary components) + ! Note; for other primary components than acidifying components (which have secondary components) ! no information of relation between land use and deposition available. IF (isec) THEN CALL ReadAps(lufile, 'land use grid', lugrid, error) @@ -449,7 +451,7 @@ PROGRAM ops_main IF (isec) THEN allocate(nam_subsec(nsubsec)) allocate(scale_subsec(nsubsec)) - allocate(gem_subsec(nsubsec)) + allocate(gem_subsec(nsubsec)) CALL ops_read_bg(icm, iopt_vchem, nsubsec, year, so2bggrid, no2bggrid, nh3bggrid, f_subsec_grid, vchem2, error) IF (error%haserror) GOTO 1000 ! GOTO error handling at end of program ENDIF @@ -499,9 +501,9 @@ PROGRAM ops_main CALL alloc(nrrcp, gym, error) CALL alloc(nrrcp, nh3bg_rcp, error) -CALL alloc(nrrcp, so2bg_rcp, error) +CALL alloc(nrrcp, so2bg_rcp, error) CALL alloc(nrrcp, rhno3_rcp, error) -CALL alloc(nrrcp, nsubsec, f_subsec_rcp, error) +CALL alloc(nrrcp, nsubsec, f_subsec_rcp, error) IF (error%haserror) GOTO 3300 ! GOTO deallocate all arrays and do error handling at end of program. ! @@ -515,11 +517,14 @@ PROGRAM ops_main ! CALL alloc(nrrcp, precip, error) IF (error%haserror) GOTO 3300 ! GOTO deallocate all arrays and do error handling at end of program. + +#ifndef GNU ! -! Clear screen -! -result = SYSTEM("clear") +! Clear screen ! + result = SYSTEM("clear") +#endif + ! Open the progress file and write 0.0 progression to screen. ! Numbs (= # characters to backspace for screen progress indicator) is 11 for this first progress call. ! @@ -582,10 +587,10 @@ PROGRAM ops_main ! 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 arrays (source data are read in ! blocks of length LSBUF (LSBUF=4000)) - ! + 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) @@ -593,13 +598,13 @@ PROGRAM ops_main ! Adjust number of processed sources nbron = nbron + nsbuf - ! + ! Initialise i1 - ! + i1(:NTRAJ-1) = 0. - ! - ! Loop over all receptor points ++++++++++++++++++++++++ - ! + + ! Loop over all receptor points ++++++++++++++++++++++++ + ndone = 0 DO ircp = 1, nrrcp ! @@ -609,43 +614,43 @@ PROGRAM ops_main & spgrid, xm(ircp), ym(ircp), lugrid, domlu, perc, lu_rcp_per_user_all, lu_rcp_dom_all, f_z0user, z0_rcp_all, & & uurtot, z0_metreg_rcp, lu_rcp_per, lu_rcp_dom, z0_rcp, error) IF (error%haserror) GOTO 3300 ! GOTO deallocate all arrays and do error handling at end of program. - ! + ! Loop over nsbuf sources in the buffer ++++++++++++++++++++++++ - ! + DO mmm = 1, nsbuf - ! + ! compute source characteristics - ! + CALL ops_src_char (f_z0user, z0_user, bx(mmm), by(mmm), z0nlgrid, z0eurgrid, z0_src, error) IF (error%haserror) GOTO 3300 ! GOTO deallocate all arrays and do error handling at end of program. - ! + ! compute trajectory characteristics - ! + CALL ops_tra_char (icm, iopt_vchem, f_z0user, z0_user, nrrcp, xm(ircp), ym(ircp), bx(mmm), by(mmm), & - & lugrid, z0nlgrid, z0eurgrid, so2bggrid, no2bggrid, nh3bggrid, vchem2, domlu, & + & lugrid, z0nlgrid, z0eurgrid, so2bggrid, no2bggrid, nh3bggrid, vchem2, domlu, & & z0_tra, lu_tra_per, so2bgtra, no2bgtra, nh3bgtra, error) 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, iopt_vchem, 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), so2bg_rcp(ircp), rhno3_rcp(ircp), & + & frac(ircp), nh3bg_rcp(ircp), so2bg_rcp(ircp), rhno3_rcp(ircp), & & bqrv(mmm), bqtr(mmm), bx(mmm), by(mmm), bdiam(mmm), bsterkte(mmm), bwarmte(mmm), bhoogte(mmm), & & bsigmaz(mmm), bD_stack(mmm), bV_stack(mmm), bTs_stack(mmm), bemis_horizontal(mmm), bbuilding(mmm), & - & buildingEffect,btgedr(mmm), bdegr(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, vchem2, 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, & + & telvnpri_arr, ddepri_d, sdrypri_arr, snatpri_arr, sdrysec_arr, snatsec_arr, & & cpri_d, csec_d, drydep_d, wetdep_d, astat, rno2_nox_sum, precip(ircp), routpri, dispg, error) IF (error%haserror) GOTO 3300 ! GOTO deallocate all arrays and do error handling at end of program. ENDDO ! end loop over sources in buffer - ! + ! Write progress (update each 2%) - ! + ndone = ndone+1 aind= 100.*FLOAT(nbron-nsbuf)/FLOAT(numbron)+ (100.*FLOAT(nsbuf)/FLOAT(numbron))* (FLOAT(ndone)/FLOAT(nrrcp)) CALL ops_write_progress(aind, '(F5.1)', 5, memdone) @@ -665,7 +670,7 @@ PROGRAM ops_main CALL dealloc(no2bggrid) CALL dealloc(so2bggrid) CALL dealloc(nh3bg_rcp) -CALL dealloc(so2bg_rcp) +CALL dealloc(so2bg_rcp) CALL dealloc(gxm) CALL dealloc(gym) @@ -688,7 +693,7 @@ PROGRAM ops_main CALL alloc(nrrcp, nsubsec, csubsec, error); if (nsubsec .gt. 0) csubsec = 0.0 ! ntodo: number of particle size classes that are relevant for producing output fields -! Default value for ntodo (for gas): +! Default value for ntodo (for gas): ntodo = 1 ! ! For non-gaseous components we use all 6 particle size classes, @@ -777,7 +782,7 @@ PROGRAM ops_main ENDIF IF (error%haserror) GOTO 4000 ! -! Open plot file and write data +! Open plot file and write data ! IF (.not.outputfile_opened) THEN IF (.NOT. sysopen(fu_plt, pltnam, 'w', 'plot file', error)) GOTO 3300 @@ -793,7 +798,7 @@ PROGRAM ops_main ! 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_neutral.f90 b/ops_neutral.f90 index ff70a29..f107b03 100644 --- a/ops_neutral.f90 +++ b/ops_neutral.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : This routine calculates sigmaz for near neutral cases according to Gryning et al. (1987). @@ -46,11 +46,11 @@ SUBROUTINE ops_neutral(z0, zi, ol, uster, h, x, uh, zu, szn) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_neutral') ! CONSTANTS -REAL*4 :: A ! correctiefactor to obtain equal limit values |L| > $ +REAL*4 :: A ! correctiefactor to obtain equal limit values |L| > $ REAL*4 :: K ! von Karmanconstante PARAMETER (A = 1. ) PARAMETER (K = 0.4) @@ -65,20 +65,20 @@ SUBROUTINE ops_neutral(z0, zi, ol, uster, h, x, uh, zu, szn) ! SUBROUTINE ARGUMENTS - OUTPUT REAL*4, INTENT(OUT) :: uh ! windspeed at downwind distance x and height zu (m/s) -REAL*4, INTENT(OUT) :: zu ! representative plume height (m), taking into account reflection +REAL*4, INTENT(OUT) :: zu ! representative plume height (m), taking into account reflection ! at the top of the mixing layer and at the ground surface REAL*4, INTENT(OUT) :: szn ! vertical dispersion coefficient for near neutral upper layer (m) ! LOCAL VARIABLES -INTEGER*4 :: last ! -REAL*4 :: fz ! -REAL*4 :: s ! -REAL*4 :: sw ! -REAL*4 :: tl ! -LOGICAL :: finished ! +INTEGER*4 :: last +REAL*4 :: fz +REAL*4 :: s +REAL*4 :: sw +REAL*4 :: tl +LOGICAL :: finished ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -114,16 +114,16 @@ SUBROUTINE ops_neutral(z0, zi, ol, uster, h, x, uh, zu, szn) fz = 1/(1 + (x/(uh*2*tl))**0.5) szn = (sw*x)/uh*fz ELSE - sw = uster*SQRT(A*1.7*(1. - h/zi)**1.5) + sw = uster*SQRT(A*1.7*(1. - h/zi)**1.5) fz = 1/(1 + (x/(uh*2*tl))**0.5) szn = (sw*x)/uh*fz ENDIF ! ! s is a representative height ! - s = 0.69*szn + s = 0.69*szn ! -! For low sources (h < z1/2), the ground surface forces the centre of mass of the plume upwards. +! For low sources (h < z1/2), the ground surface forces the centre of mass of the plume upwards. ! Three cases ! 1. s < h, relatively small plume that does not touch the ground -> no action anymore, zu = h = stack height ! 2. s > h @@ -137,14 +137,14 @@ SUBROUTINE ops_neutral(z0, zi, ol, uster, h, x, uh, zu, szn) zu = s ENDIF last = 1 - + ! -! For high sources (h > z1/2), the inversion at the mixing height forces the centre of mass of the plume downwards. +! For high sources (h > z1/2), the inversion at the mixing height forces the centre of mass of the plume downwards. ! Three cases ! 1. s < zi-h, relatively small plume that does not touch the mixing height -> no action anymore, zu = h = stack height ! 2. s > zi-h ! 2a. zi-s < zi/2 <=> s > zi/2, very broad plume that touches both the ground and the mixing height -> zu = zi/2 = 1/2 mixing height -! 2b. zi-s > zi/2 <=> s < zi/2, relatively broad plume that touches only the mixing height -> zu = zi - s (lower than h, +! 2b. zi-s > zi/2 <=> s < zi/2, relatively broad plume that touches only the mixing height -> zu = zi - s (lower than h, ! because zi - s < zi - (zi-h) = h) ! ELSE IF ((h .GT. (zi/2. + EPS_DELTA)) .AND. (s .GT. (zi - h + EPS_DELTA)) .AND. (last .EQ. 0)) THEN diff --git a/ops_outp_prep.f90 b/ops_outp_prep.f90 index b5e427d..b07115a 100644 --- a/ops_outp_prep.f90 +++ b/ops_outp_prep.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -28,7 +28,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Prepare output process (print/plot) @@ -45,45 +45,45 @@ SUBROUTINE ops_outp_prep(nrrcp, icm, nsubsec, conc_cf, rhno3_rcp, f_subsec_rcp, IMPLICIT NONE ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: nrrcp ! -INTEGER*4, INTENT(IN) :: icm ! -INTEGER*4, INTENT(IN) :: nsubsec ! number of sub-secondary species -REAL*4, INTENT(IN) :: conc_cf ! -REAL*4, INTENT(IN) :: rhno3_rcp(nrrcp) ! +INTEGER*4, INTENT(IN) :: nrrcp +INTEGER*4, INTENT(IN) :: icm +INTEGER*4, INTENT(IN) :: nsubsec ! number of sub-secondary species +REAL*4, INTENT(IN) :: conc_cf +REAL*4, INTENT(IN) :: rhno3_rcp(nrrcp) REAL*4, INTENT(OUT) :: f_subsec_rcp(nrrcp,nsubsec) ! fractions for sub-secondary species, HNO3/NO3_total, NO3_C/NO3_total, NO3_F/NO3_total [-] -REAL*4, INTENT(IN) :: csec(nrrcp) ! -REAL*4, INTENT(IN) :: drydep(nrrcp) ! -REAL*4, INTENT(IN) :: wetdep(nrrcp) ! +REAL*4, INTENT(IN) :: csec(nrrcp) +REAL*4, INTENT(IN) :: drydep(nrrcp) +REAL*4, INTENT(IN) :: wetdep(nrrcp) ! SUBROUTINE ARGUMENTS - I/O -REAL*4, INTENT(INOUT) :: cpri(nrrcp) ! +REAL*4, INTENT(INOUT) :: cpri(nrrcp) ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: totdep(nrrcp) ! +REAL*4, INTENT(OUT) :: totdep(nrrcp) REAL*4, INTENT(OUT) :: csubsec(nrrcp,nsubsec) ! concentration of sub-secondary species [ug/m3] -REAL*4, INTENT(OUT) :: scale_con ! -REAL*4, INTENT(OUT) :: scale_sec ! +REAL*4, INTENT(OUT) :: scale_con +REAL*4, INTENT(OUT) :: scale_sec REAL*4, INTENT(OUT) :: scale_subsec(nsubsec) ! scaling factor for sub-secondary species -REAL*4, INTENT(OUT) :: scale_dep ! +REAL*4, INTENT(OUT) :: scale_dep ! LOCAL VARIABLES INTEGER*4 :: isubsec ! index of sub-secondary species ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_outp_prep') ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! ! 1. Calculate totdep = total deposition = dry deposition + wet deposition ! 2. Correct cpri = NOx concentration (to account for HNO2 and PAN contributions to NO2) -! 3. Calculate concentration of sub-secondary species +! 3. Calculate concentration of sub-secondary species totdep = drydep + wetdep IF (icm == 2) THEN - cpri = cpri * conc_cf + cpri = cpri * conc_cf do isubsec = 1,nsubsec csubsec(:,isubsec) = f_subsec_rcp(:,isubsec)*csec enddo diff --git a/ops_par_chem.f90 b/ops_par_chem.f90 index a281f71..cd33822 100644 --- a/ops_par_chem.f90 +++ b/ops_par_chem.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Get chemical parameters (conversion rates, concentration ratios). @@ -48,54 +48,54 @@ SUBROUTINE ops_par_chem (icm, iopt_vchem, isek, so2sek, no2sek, so2bgtra, no2bgt IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_par_chem') ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: icm -INTEGER*4, INTENT(IN) :: iopt_vchem ! option for chemical conversion rate (0 = old OPS, 1 = EMEP) -INTEGER*4, INTENT(IN) :: isek -REAL*4, INTENT(IN) :: so2sek(NSEK) -REAL*4, INTENT(IN) :: no2sek(NSEK) -REAL*4, INTENT(IN) :: so2bgtra -REAL*4, INTENT(IN) :: no2bgtra -REAL*4, INTENT(IN) :: nh3bgtra +INTEGER*4, INTENT(IN) :: icm +INTEGER*4, INTENT(IN) :: iopt_vchem ! option for chemical conversion rate (0 = old OPS, 1 = EMEP) +INTEGER*4, INTENT(IN) :: isek +REAL*4, INTENT(IN) :: so2sek(NSEK) +REAL*4, INTENT(IN) :: no2sek(NSEK) +REAL*4, INTENT(IN) :: so2bgtra +REAL*4, INTENT(IN) :: no2bgtra +REAL*4, INTENT(IN) :: nh3bgtra type(Tvchem), INTENT(INOUT) :: vchem2 -REAL*4, INTENT(IN) :: disx -REAL*4, INTENT(IN) :: diameter +REAL*4, INTENT(IN) :: disx +REAL*4, INTENT(IN) :: diameter ! SUBROUTINE ARGUMENTS - OUTPUT REAL*4, INTENT(OUT) :: vchemnh3 -REAL*4, INTENT(OUT) :: rhno3 -REAL*4, INTENT(OUT) :: rrno2nox -REAL*4, INTENT(OUT) :: rations +REAL*4, INTENT(OUT) :: rhno3 +REAL*4, INTENT(OUT) :: rrno2nox +REAL*4, INTENT(OUT) :: rations ! LOCAL VARIABLES -REAL*4 :: C1 ! -REAL*4 :: C2 ! -REAL*4 :: ch ! -REAL*4 :: cr ! -REAL*4 :: wdc_so2 ! -REAL*4 :: wdc_no2 ! -REAL*4 :: so2bgtra_corr ! -REAL*4 :: no2bgtra_corr ! -REAL*4 :: nh3bgtra_corr ! +REAL*4 :: C1 +REAL*4 :: C2 +REAL*4 :: ch +REAL*4 :: cr +REAL*4 :: wdc_so2 +REAL*4 :: wdc_no2 +REAL*4 :: so2bgtra_corr +REAL*4 :: no2bgtra_corr +REAL*4 :: nh3bgtra_corr REAL*4 :: nox_threshold ! threshold value for NOx in log-function in NOx -> NO2 conversion REAL*4 :: no2_threshold ! threshold value for NO2 in exp-function in NO2 -> NOx conversion REAL*4 :: alpha ! slope of linear function NOx -> NO2 conversion REAL*4 :: noxbgtra_corr ! conversion of no2bgtra_corr to NOx ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'// char (0) !------------------------------------------------------------------------------------------------------------------------------- ! ! Compute correction factors for SO2 and NO2 background concentration for each wind direction sector; ! derived from regional LML stations over 2003 (SO2) or 2004 (NO2) (eastern wind -> higher SO2 and NO2) -! if the receptor is inside an area source (0 < cr < 1), there are contributions of all directions and +! if the receptor is inside an area source (0 < cr < 1), there are contributions of all directions and ! the wind sector correction is not done (cr = 0, receptor in centre of area source -> wdc_ = 1) or ! maximal (cr = 1 -> edge of area source -> wdc_ = so2sek) -! +! IF (diameter > 0 ) THEN cr = amin1(disx/diameter,1.) wdc_so2 = cr*so2sek(isek)+ (1.-cr) @@ -106,21 +106,21 @@ SUBROUTINE ops_par_chem (icm, iopt_vchem, isek, so2sek, no2sek, so2bgtra, no2bgt ENDIF ! ! Correct trajectory averaged background concentration as function of wind direction. -! NH3 is not corrected, because for NH3 the background is more locally determined. +! NH3 is not corrected, because for NH3 the background is more locally determined. ! so2bgtra_corr = so2bgtra*wdc_so2 no2bgtra_corr = no2bgtra*wdc_no2 nh3bgtra_corr = nh3bgtra IF (icm == 1) THEN - + ! SO2 ! compute N/S ratio; factor 2 is because of (NH4) (SO4) rations = nh3bgtra_corr/(2*so2bgtra_corr) ELSE IF (icm == 2) THEN - + ! NOx ! rhno3 = ratio [HNO3]/[NO3]_total (NO3_total = HNO3+NO3_aerosol) ! This ratio has been computed with the help of a 1D chemistry model (model chemie5) @@ -128,12 +128,12 @@ SUBROUTINE ops_par_chem (icm, iopt_vchem, isek, so2sek, no2sek, so2bgtra, no2bgt ! see also ops_rcp_char. ! Here we use the trajectory averaged, wind sector corrected background NH3 concentration. rhno3 = amin1(0.024*(nh3bgtra_corr/1000)**(-0.44),0.8) - + ! rrno2nox is the spatially variable component in the [NO2]/[NOx] ratio, using an average [NO2]/[NOx] ratio ! in NL equal to 0.65 (see also ops_init). ! This empirical [NO2]/[NOx] ratio follows from a fit of measured yearly averaged concentrations in NL (1993). - - ! + + ! In ops_read_bg, the grid with corrected NOx background concentrations (in ppbv) is converted cellwise to NO2 (in ppbv). ! [NO2] = beta1*log([NOx]) + beta2; coefficients are defined in m_commonconst. Tag: NOx-NO2 relation ! Since this function drops below zero for low values of [NOx], a linear function is used for [NOx] <= NOx_threshold ppbv, @@ -141,12 +141,12 @@ SUBROUTINE ops_par_chem (icm, iopt_vchem, isek, so2sek, no2sek, so2bgtra, no2bgt ! g(x) = alpha*x, f(x) = beta1*log(x) + beta2. ! First derivative equal at threshold x0: alpha = beta1/x0. ! Function equal at x0: (beta1/x0)*x0 = beta1*log(x0) + beta2 <=> x0 = exp(1-beta2/beta1). - ! + ! Here we need the inverse function of this function: ! NO2_threshold = alpha*x0 = beta1 ! NO2 > NO2_threshold -> [NOx] = exp(([NO2]-beta2)/beta1) ! NO2 <= NO2_threshold -> [NOx] = [NO2]/alpha - ! + nox_threshold = exp(1-(nox_no2_beta(2)/nox_no2_beta(1))) no2_threshold = nox_no2_beta(1) alpha = nox_no2_beta(1)/nox_threshold @@ -158,26 +158,26 @@ SUBROUTINE ops_par_chem (icm, iopt_vchem, isek, so2sek, no2sek, so2bgtra, no2bgt rrno2nox=no2bgtra_corr/(0.65*noxbgtra_corr) ELSE - + ! icm = 3, NH3 ! Compute conversion rate NH3 -> NH4; ! ch = [SO2]/[NH3] - - ! note that 1.7*[0.1 0.8 6.3 1.8 -0.17] = [0.17 1.36 10.71 3.06 -0.29] - + + ! note that 1.7*[0.1 0.8 6.3 1.8 -0.17] = [0.17 1.36 10.71 3.06 -0.29] + ! Chemistry model computes hourly concentrations for one column (including emissions, deposition); ! then relations between different components are derived. - + ch = amin1(so2bgtra_corr/nh3bgtra_corr,3.0) - vchemnh3 = 0.1 + 0.8*no2bgtra_corr/nh3bgtra_corr + 6.3*ch + 1.8*ch**4 - 0.17*ch**6 + vchemnh3 = 0.1 + 0.8*no2bgtra_corr/nh3bgtra_corr + 6.3*ch + 1.8*ch**4 - 0.17*ch**6 vchemnh3 = amax1(1.0,vchemnh3*3.0+0.5) ! calibration to bulk measurements (yearly averaged NH3/NH4 ratios) ENDIF ENDIF ! Compute chemical conversion rates [%/h] from averaged mass pre chemistry and mass converted during time step (EMEP option iopt_vchem = 1): IF ((icm == 1 .or. icm == 2 .or. icm == 3) .and. iopt_vchem .eq. 1) THEN - vchem2%vchem = vchem2%mass_conv_dtfac_tra/vchem2%mass_prec_tra ! note: factor (100.0/dt) is already in mass_conv_dtfac_tra + vchem2%vchem = vchem2%mass_conv_dtfac_tra/vchem2%mass_prec_tra ! note: factor (100.0/dt) is already in mass_conv_dtfac_tra ENDIF - + RETURN END SUBROUTINE ops_par_chem diff --git a/ops_plot_uitv.f90 b/ops_plot_uitv.f90 index d8aed11..dd79adf 100644 --- a/ops_plot_uitv.f90 +++ b/ops_plot_uitv.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -28,7 +28,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Write results to plot-file (*.plt) @@ -50,30 +50,30 @@ SUBROUTINE ops_plot_uitv(spgrid, isec, coneh, nrrcp, nsubsec, jump, xorg, yorg, IMPLICIT NONE ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: spgrid ! -LOGICAL, INTENT(IN) :: isec ! -CHARACTER*(*), INTENT(IN) :: coneh ! -INTEGER*4, INTENT(IN) :: nrrcp ! +INTEGER*4, INTENT(IN) :: spgrid +LOGICAL, INTENT(IN) :: isec +CHARACTER*(*), INTENT(IN) :: coneh +INTEGER*4, INTENT(IN) :: nrrcp INTEGER*4, INTENT(IN) :: nsubsec ! number of sub-secondary species INTEGER*4, INTENT(IN) :: jump(nrrcp+1) ! distance between receptor points in grid units -REAL*4, INTENT(IN) :: xorg ! -REAL*4, INTENT(IN) :: yorg ! +REAL*4, INTENT(IN) :: xorg +REAL*4, INTENT(IN) :: yorg INTEGER*4, INTENT(IN) :: nrcol ! number of columns in grid INTEGER*4, INTENT(IN) :: nrrow ! number of row in grid -REAL*4, INTENT(IN) :: grid ! -LOGICAL, INTENT(IN) :: idep ! -CHARACTER*(*), INTENT(IN) :: namco ! -CHARACTER*(*), INTENT(IN) :: namse3 ! -CHARACTER*(*), INTENT(IN) :: namsec ! -CHARACTER*(*), INTENT(IN) :: depeh ! -CHARACTER*(*), INTENT(IN) :: namrcp(nrrcp) ! -REAL*4, INTENT(IN) :: xm(nrrcp) ! -REAL*4, INTENT(IN) :: ym(nrrcp) ! -REAL*4, INTENT(IN) :: cpri(nrrcp) ! -REAL*4, INTENT(IN) :: csec(nrrcp) ! -REAL*4, INTENT(IN) :: drydep(nrrcp) ! -REAL*4, INTENT(IN) :: wetdep(nrrcp) ! -INTEGER*4, INTENT(IN) :: icm ! +REAL*4, INTENT(IN) :: grid +LOGICAL, INTENT(IN) :: idep +CHARACTER*(*), INTENT(IN) :: namco +CHARACTER*(*), INTENT(IN) :: namse3 +CHARACTER*(*), INTENT(IN) :: namsec +CHARACTER*(*), INTENT(IN) :: depeh +CHARACTER*(*), INTENT(IN) :: namrcp(nrrcp) +REAL*4, INTENT(IN) :: xm(nrrcp) +REAL*4, INTENT(IN) :: ym(nrrcp) +REAL*4, INTENT(IN) :: cpri(nrrcp) +REAL*4, INTENT(IN) :: csec(nrrcp) +REAL*4, INTENT(IN) :: drydep(nrrcp) +REAL*4, INTENT(IN) :: wetdep(nrrcp) +INTEGER*4, INTENT(IN) :: icm REAL*4, INTENT(IN) :: csubsec(nrrcp,nsubsec) ! concentration of sub-secondary species [ug/m3] CHARACTER*(*), INTENT(IN) :: nam_subsec(nsubsec) ! names of sub-secondary species @@ -81,20 +81,20 @@ SUBROUTINE ops_plot_uitv(spgrid, isec, coneh, nrrcp, nsubsec, jump, xorg, yorg, TYPE (TError), INTENT(OUT) :: error ! Error handling record ! LOCAL VARIABLES -INTEGER*4 :: ierr ! +INTEGER*4 :: ierr INTEGER*4 :: ls ! lengte textstring namse3 -INTEGER*4 :: j ! -REAL*4 :: xlb ! -REAL*4 :: ylb ! -REAL*4 :: totdep(nrrcp) ! +INTEGER*4 :: j +REAL*4 :: xlb +REAL*4 :: ylb +REAL*4 :: totdep(nrrcp) INTEGER*4 :: isubsec ! index of sub-secondary species ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_plot_uitv') ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -133,7 +133,7 @@ SUBROUTINE ops_plot_uitv(spgrid, isec, coneh, nrrcp, nsubsec, jump, xorg, yorg, ELSE IF (idep) THEN ! ! Depositions -! +! WRITE (fu_plt, '(a4,8x,a8,a8,5a12)', IOSTAT = ierr) 'name', 'x-coord', 'y-coord', 'conc.', 'dry_dep.', 'wet_dep.', & & 'tot_dep.' IF (ierr .GT. 0) GOTO 4200 @@ -170,7 +170,7 @@ SUBROUTINE ops_plot_uitv(spgrid, isec, coneh, nrrcp, nsubsec, jump, xorg, yorg, ENDIF WRITE (fu_plt, '(a1)', IOSTAT = ierr) ' ' ELSE - + !------------------------------------------------------- ! Grid output (APS format) for gridded receptors !------------------------------------------------------- @@ -249,7 +249,7 @@ SUBROUTINE plot_mat(lun, value, nrrcp, jump, nrcol, nrrow, descco, compname, com USE m_utils ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'plot_mat') ! SUBROUTINE ARGUMENTS - INPUT diff --git a/ops_plrise71.f90 b/ops_plrise71.f90 index f083f1e..3c998b6 100644 --- a/ops_plrise71.f90 +++ b/ops_plrise71.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Deze routine berekent de pluimhoogte. @@ -47,48 +47,48 @@ !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE ops_plrise71(z0, xl, ol, uster, hbron, qw, xloc, htt, onder) -USE m_commonconst ! EPS_DELTA only +USE m_commonconst ! EPS_DELTA only IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_plrise71') ! SUBROUTINE ARGUMENTS - INPUT -REAL*4, INTENT(IN) :: z0 ! -REAL*4, INTENT(IN) :: xl ! +REAL*4, INTENT(IN) :: z0 +REAL*4, INTENT(IN) :: xl REAL*4, INTENT(IN) :: ol ! Monin-Obukhovlengte REAL*4, INTENT(IN) :: uster ! frictiesnelheid -REAL*4, INTENT(IN) :: hbron ! +REAL*4, INTENT(IN) :: hbron REAL*4, INTENT(IN) :: qw ! warmte inhoud van het rookgas (MW) -REAL*4, INTENT(IN) :: xloc ! +REAL*4, INTENT(IN) :: xloc ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: htt ! -REAL*4, INTENT(OUT) :: onder ! +REAL*4, INTENT(OUT) :: htt +REAL*4, INTENT(OUT) :: onder ! LOCAL VARIABLES -REAL*4 :: delh ! -REAL*4 :: f ! +REAL*4 :: delh +REAL*4 :: f REAL*4 :: us ! wind speed at effective plume height ! representative for the whole plume rise length -REAL*4 :: dtdz ! -REAL*4 :: hs ! -REAL*4 :: s ! +REAL*4 :: dtdz +REAL*4 :: hs +REAL*4 :: s ! Iteration variables ! iteration converges if |delh - delh_prev| < epsa + epsr*delh integer :: it ! iteration index logical :: converged ! iteration has converged real :: delh_prev ! plume rise of previous iteration -integer, parameter :: maxit = 10 ! maximal number of iterations +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 +real, parameter :: epsr = 0.05 ! relative error tolerance ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -103,15 +103,15 @@ SUBROUTINE ops_plrise71(z0, xl, ol, uster, hbron, qw, xloc, htt, onder) IF ( qw .GT. (0. + EPS_DELTA)) THEN - ! Compute wind speed from logarithmic wind profile at height h_stack: + ! Compute wind speed from logarithmic wind profile at height h_stack: CALL ops_wvprofile(z0,hs,uster,ol, us) ! f = stack buoyancy flux (3.27 OPS report) - ! f = g/(pi*0.0013*T) = 9.81/(3.14*0.0013*273)*qw + ! f = g/(pi*0.0013*T) = 9.81/(3.14*0.0013*273)*qw f = 8.8*qw ! 960107 see briggs (1975) - ! We want to use a wind speed that is representative for the whole plume rise length, + ! 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. @@ -119,8 +119,8 @@ SUBROUTINE ops_plrise71(z0, xl, ol, uster, hbron, qw, xloc, htt, onder) delh_prev = -999. ! Do iteration: - do while (.not. converged .and. it .le. maxit) - + do while (.not. converged .and. it .le. maxit) + ! plume rise for unstable or neutral conditions, L < 0 or |L| > 50 (3.25 - 3.28 OPS report): ! original value plrise_nonstab_Fbsplit = 55 IF ( ol .LT. (0. - EPS_DELTA) .OR. ABS(ol) .GT. 50 ) THEN @@ -141,7 +141,7 @@ SUBROUTINE ops_plrise71(z0, xl, ol, uster, hbron, qw, xloc, htt, onder) ! Check for convergence: converged = (abs(delh - delh_prev) .lt. epsa + epsr*delh ) - + ! Update for next iteration: if (.not. converged .and. it .lt. maxit) then ! Compute wind speed at z = h_stack + 1/2 plume_rise: diff --git a/ops_print_grid.f90 b/ops_print_grid.f90 index c984a13..27c91df 100644 --- a/ops_print_grid.f90 +++ b/ops_print_grid.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by @@ -52,7 +52,7 @@ SUBROUTINE ops_print_grid (nrrcp, nsubsec, jump, project, icm, gasv, idep, isec, IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_print_grid') ! SUBROUTINE ARGUMENTS - INPUT @@ -65,12 +65,12 @@ SUBROUTINE ops_print_grid (nrrcp, nsubsec, jump, project, icm, gasv, idep, isec, LOGICAL, INTENT(IN) :: isec ! sec. comp taken into account LOGICAL, INTENT(IN) :: verb ! extra calculations if true CHARACTER*(*), INTENT(IN) :: namco ! component name -CHARACTER*(*), INTENT(IN) :: namse3 ! +CHARACTER*(*), INTENT(IN) :: namse3 CHARACTER*(*), INTENT(IN) :: coneh ! concentration unit CHARACTER*(*), INTENT(IN) :: depeh ! deposition unit REAL*4, INTENT(IN) :: conc_cf ! concentration correction factor -REAL*4, INTENT(IN) :: amol21 ! -REAL*4, INTENT(IN) :: ugmoldep ! +REAL*4, INTENT(IN) :: amol21 +REAL*4, INTENT(IN) :: ugmoldep INTEGER*4, INTENT(IN) :: nrcol ! number of grid cells in X-dir INTEGER*4, INTENT(IN) :: nrrow ! number of grid cells in Y-dir REAL*4, INTENT(IN) :: grid ! grid cell dimension @@ -82,7 +82,7 @@ SUBROUTINE ops_print_grid (nrrcp, nsubsec, jump, project, icm, gasv, idep, isec, REAL*4, INTENT(IN) :: drydep(nrrcp) ! dry deposition REAL*4, INTENT(IN) :: wetdep(nrrcp) ! wet deposition REAL*4, INTENT(IN) :: ddepri(nrrcp) ! dry depo of primary comp. -INTEGER*4, INTENT(IN) :: lu_rcp_dom_all(nrrcp) ! land use +INTEGER*4, INTENT(IN) :: lu_rcp_dom_all(nrrcp) ! land use REAL*4, INTENT(IN) :: z0_rcp_all(nrrcp) ! roughness lengths for all receptors; from z0-map or receptor file [m] REAL*4, INTENT(IN) :: gemcpri ! grid mean for prim. concentration REAL*4, INTENT(IN) :: gemcsec ! grid mean for sec. concentration @@ -114,7 +114,7 @@ SUBROUTINE ops_print_grid (nrrcp, nsubsec, jump, project, icm, gasv, idep, isec, ! SUBROUTINE ARGUMENTS - I/O LOGICAL, INTENT(INOUT) :: idep ! deposition taken into account LOGICAL, INTENT(INOUT) :: igrid ! print grids if value = 1 -CHARACTER*(*), INTENT(INOUT) :: namsec ! +CHARACTER*(*), INTENT(INOUT) :: namsec ! SUBROUTINE ARGUMENTS - OUTPUT TYPE (TError), INTENT(OUT) :: error ! whether an error occurred @@ -126,7 +126,7 @@ SUBROUTINE ops_print_grid (nrrcp, nsubsec, jump, project, icm, gasv, idep, isec, ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -340,13 +340,13 @@ SUBROUTINE ops_print_grid (nrrcp, nsubsec, jump, project, icm, gasv, idep, isec, !------------------------------------------------------------------------------------------------------------------------------- ! SUBROUTINE : print_mat -! DESCRIPTION: printing of matrix +! DESCRIPTION: printing of matrix !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE print_mat(lun, value, fact, nrrcp, jump, nrcol, nrrow, grid, xorg, yorg, error) USE m_utils ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'print_mat') ! SUBROUTINE ARGUMENTS - INPUT diff --git a/ops_print_info.f90 b/ops_print_info.f90 index f20eb39..7ca7869 100644 --- a/ops_print_info.f90 +++ b/ops_print_info.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Prints input parameters at the end of text output @@ -49,14 +49,14 @@ SUBROUTINE ops_print_info (project, gasv, isec, intpol, spgrid, z0_rcp, namco, n IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_print_info') ! SUBROUTINE ARGUMENTS - INPUT CHARACTER*(*), INTENT(IN) :: project ! project name LOGICAL, INTENT(IN) :: gasv ! code for substance appearance (gas/particle) LOGICAL, INTENT(IN) :: isec ! true when comp=SO2,NOx,NH3 -INTEGER*4, INTENT(IN) :: intpol ! +INTEGER*4, INTENT(IN) :: intpol INTEGER*4, INTENT(IN) :: spgrid ! code for type of receptor points REAL*4, INTENT(IN) :: z0_rcp ! roughness length at receptor; from z0-map [m] CHARACTER*(*), INTENT(IN) :: namco ! substance name @@ -82,7 +82,7 @@ SUBROUTINE ops_print_info (project, gasv, isec, intpol, spgrid, z0_rcp, namco, n INTEGER*4, INTENT(IN) :: jt ! ending year of meteo INTEGER*4, INTENT(IN) :: mt ! ending month of meteo INTEGER*4, INTENT(IN) :: idt ! ending day of meteo -INTEGER*4, INTENT(IN) :: iseiz ! +INTEGER*4, INTENT(IN) :: iseiz LOGICAL*4, INTENT(IN) :: f_z0user ! true if z0 is user specified ! SUBROUTINE ARGUMENTS - I/O @@ -96,17 +96,17 @@ SUBROUTINE ops_print_info (project, gasv, isec, intpol, spgrid, z0_rcp, namco, n INTEGER*4 :: istatgeb ! climatological area ! LOCAL VARIABLES -INTEGER*4 :: i ! -INTEGER*4 :: ierr ! -INTEGER*4 :: indx ! -INTEGER*4 :: jndx ! -INTEGER*4 :: statclass ! +INTEGER*4 :: i +INTEGER*4 :: ierr +INTEGER*4 :: indx +INTEGER*4 :: jndx +INTEGER*4 :: statclass REAL*4 :: qb ! emission of individual source -CHARACTER*1 :: statcode ! -CHARACTER*30 :: climper(0:6) ! +CHARACTER*1 :: statcode +CHARACTER*30 :: climper(0:6) ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) ! DATA @@ -315,12 +315,12 @@ SUBROUTINE ops_print_info (project, gasv, isec, intpol, spgrid, z0_rcp, namco, n SUBROUTINE print_region (regionname, regionindex ) ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'print_region') ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: regionname ! -INTEGER*4, INTENT(IN) :: regionindex ! +CHARACTER*(*), INTENT(IN) :: regionname +INTEGER*4, INTENT(IN) :: regionindex WRITE (fu_prt, '(/,1x,''climatological area : '', a, '' (region '', I1, '')'')') regionname(1:LEN_TRIM(regionname)), & & regionindex diff --git a/ops_print_kop.f90 b/ops_print_kop.f90 index fddc179..6ccb81c 100644 --- a/ops_print_kop.f90 +++ b/ops_print_kop.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-F77/90 ! DESCRIPTION : Print page header ("kop"= head) @@ -46,7 +46,7 @@ SUBROUTINE ops_print_kop(project, namco) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_print_kop') ! SUBROUTINE ARGUMENTS - INPUT @@ -63,7 +63,7 @@ SUBROUTINE ops_print_kop(project, namco) INTEGER*4 :: marginlen ! number of = in margin ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! diff --git a/ops_print_recep.f90 b/ops_print_recep.f90 index adaffd5..8f87209 100644 --- a/ops_print_recep.f90 +++ b/ops_print_recep.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -52,27 +52,27 @@ SUBROUTINE ops_print_recep (project, gasv, idep, isec, igrid, verb, namco, namse IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_print_recep') ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: project ! -LOGICAL, INTENT(IN) :: gasv ! -LOGICAL, INTENT(IN) :: isec ! -LOGICAL, INTENT(IN) :: verb ! -CHARACTER*(*), INTENT(IN) :: namco ! -CHARACTER*(*), INTENT(IN) :: namsec ! -CHARACTER*(*), INTENT(IN) :: namse3 ! -CHARACTER*(*), INTENT(IN) :: coneh ! -CHARACTER*(*), INTENT(IN) :: depeh ! -REAL*4, INTENT(IN) :: conc_cf ! -REAL*4, INTENT(IN) :: amol21 ! -REAL*4, INTENT(IN) :: ugmoldep ! +CHARACTER*(*), INTENT(IN) :: project +LOGICAL, INTENT(IN) :: gasv +LOGICAL, INTENT(IN) :: isec +LOGICAL, INTENT(IN) :: verb +CHARACTER*(*), INTENT(IN) :: namco +CHARACTER*(*), INTENT(IN) :: namsec +CHARACTER*(*), INTENT(IN) :: namse3 +CHARACTER*(*), INTENT(IN) :: coneh +CHARACTER*(*), INTENT(IN) :: depeh +REAL*4, INTENT(IN) :: conc_cf +REAL*4, INTENT(IN) :: amol21 +REAL*4, INTENT(IN) :: ugmoldep INTEGER*4, INTENT(IN) :: nrrcp ! number of receptor points INTEGER*4, INTENT(IN) :: nsubsec ! number of sub-secondary species -CHARACTER*(*), INTENT(IN) :: namrcp (nrrcp) ! -REAL*4, INTENT(IN) :: xm(nrrcp) ! -REAL*4, INTENT(IN) :: ym(nrrcp) ! +CHARACTER*(*), INTENT(IN) :: namrcp (nrrcp) +REAL*4, INTENT(IN) :: xm(nrrcp) +REAL*4, INTENT(IN) :: ym(nrrcp) REAL*4, INTENT(IN) :: precip(nrrcp) ! calculated precipitation REAL*4, INTENT(IN) :: cpri(nrrcp) ! primary concentration REAL*4, INTENT(IN) :: csec(nrrcp) ! secondary concentration @@ -80,7 +80,7 @@ SUBROUTINE ops_print_recep (project, gasv, idep, isec, igrid, verb, namco, namse REAL*4, INTENT(IN) :: ddepri(nrrcp) ! dry depo of primary comp. REAL*4, INTENT(IN) :: wetdep(nrrcp) ! wet deposition REAL*4, INTENT(IN) :: rno2_nox_sum(nrrcp) ! NO2/NOx ratio, weighed sum over classes -INTEGER*4, INTENT(IN) :: lu_rcp_dom_all(nrrcp) ! +INTEGER*4, INTENT(IN) :: lu_rcp_dom_all(nrrcp) REAL*4, INTENT(IN) :: z0_rcp_all(nrrcp) ! roughness lengths for all receptors; from z0-map or receptor file [m] REAL*4, INTENT(IN) :: gemcpri ! mean for prim. concentration REAL*4, INTENT(IN) :: gemcsec ! mean for sec. concentration @@ -102,36 +102,36 @@ SUBROUTINE ops_print_recep (project, gasv, idep, isec, igrid, verb, namco, namse REAL*4, INTENT(IN) :: gem_subsec(nsubsec) ! grid mean for concentration of sub-secondary species [ug/m3] CHARACTER*(*), INTENT(IN) :: nam_subsec(nsubsec) ! names of sub-secondary speciea REAL*4, INTENT(IN) :: totdep(nrrcp) ! total deposition -REAL*4, INTENT(IN) :: scale_con ! -REAL*4, INTENT(IN) :: scale_sec ! +REAL*4, INTENT(IN) :: scale_con +REAL*4, INTENT(IN) :: scale_sec REAL*4, INTENT(IN) :: scale_subsec(nsubsec) ! scaling factor for sub-secondary species -REAL*4, INTENT(IN) :: scale_dep ! +REAL*4, INTENT(IN) :: scale_dep ! SUBROUTINE ARGUMENTS - I/O -LOGICAL, INTENT(INOUT) :: idep ! -LOGICAL, INTENT(INOUT) :: igrid ! +LOGICAL, INTENT(INOUT) :: idep +LOGICAL, INTENT(INOUT) :: igrid ! SUBROUTINE ARGUMENTS - OUTPUT -TYPE (Terror), INTENT(INOUT) :: error ! +TYPE (Terror), INTENT(INOUT) :: error ! LOCAL VARIABLES -INTEGER*4 :: i ! -INTEGER*4 :: j ! +INTEGER*4 :: i +INTEGER*4 :: j INTEGER*4 :: isubsec ! index of sub-secondary species -REAL*4 :: scalec ! -REAL*4 :: scaled ! -REAL*4 :: scalen ! -REAL*4 :: scalsc ! -REAL*4 :: vdpri(nrrcp) ! -REAL*4 :: vdsec(nrrcp) ! +REAL*4 :: scalec +REAL*4 :: scaled +REAL*4 :: scalen +REAL*4 :: scalsc +REAL*4 :: vdpri(nrrcp) +REAL*4 :: vdsec(nrrcp) REAL*4 :: tmp(nrrcp) ! dry+wet deposition -CHARACTER*4 :: vdeh ! -CHARACTER*4 :: z0eh ! -CHARACTER*4 :: lueh ! +CHARACTER*4 :: vdeh +CHARACTER*4 :: z0eh +CHARACTER*4 :: lueh INTEGER*4 :: ircp ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -197,11 +197,11 @@ SUBROUTINE ops_print_recep (project, gasv, idep, isec, igrid, verb, namco, namse IF (.NOT.isec) THEN !---------------------------- - ! only primary species + ! only primary species !---------------------------- IF (.NOT.verb) THEN -! +! ! print primary concentration, drydep, wetdep, totdep in tables ! CALL print_conc_names(namco) @@ -213,7 +213,7 @@ SUBROUTINE ops_print_recep (project, gasv, idep, isec, igrid, verb, namco, namse & scale_dep) ELSE -! +! ! print primary concentration, drydep, wetdep, totdep, vdpri, z0, lu, precip in table ! CALL print_conc_names(namco) @@ -230,13 +230,13 @@ SUBROUTINE ops_print_recep (project, gasv, idep, isec, igrid, verb, namco, namse ELSE !---------------------------- - ! primary + secondary species + ! primary + secondary species !---------------------------- IF (icm == 2) THEN - + ! NOx - + IF (.NOT.verb) THEN ! ! print primary concentration, drydep, wetdep, totdep, secondary concentration, second secondary concentration in tables @@ -262,7 +262,7 @@ SUBROUTINE ops_print_recep (project, gasv, idep, isec, igrid, verb, namco, namse stop ENDIF ELSE -! +! ! print primary concentration, drydep, wetdep, totdep, secondary conc, sub-secondary concentrations, vdpri, vdsec, z0, lu and precip in table ! CALL print_conc_names(namco, namsec, nam_subsec) @@ -294,11 +294,11 @@ SUBROUTINE ops_print_recep (project, gasv, idep, isec, igrid, verb, namco, namse ENDIF ENDIF ELSE - - ! no NOx - + + ! no NOx + IF (.NOT.verb) THEN -! +! ! print primary concentration, drydep, wetdep, totdep, secondary concentration in tables ! CALL print_conc_names(namco, namsec) diff --git a/ops_print_table.f90 b/ops_print_table.f90 index fd7f986..32338e2 100644 --- a/ops_print_table.f90 +++ b/ops_print_table.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Subroutines supporting receptor point printing. @@ -70,12 +70,12 @@ MODULE ops_print_table SUBROUTINE print_conc_names(namco, namsec, nam_subsec) ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'print_conc_names') ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN) :: namco ! -CHARACTER*(*), INTENT(IN), OPTIONAL :: namsec ! +CHARACTER*(*), INTENT(IN) :: namco +CHARACTER*(*), INTENT(IN), OPTIONAL :: namsec CHARACTER*(*), INTENT(IN), OPTIONAL :: nam_subsec(:) ! names of sub-secondary species ! Local variable @@ -106,11 +106,11 @@ END SUBROUTINE print_conc_names SUBROUTINE print_depo_names(namdep) ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'print_depo_names') ! SUBROUTINE ARGUMENTS - INPUT -CHARACTER*(*), INTENT(IN), OPTIONAL :: namdep ! +CHARACTER*(*), INTENT(IN), OPTIONAL :: namdep !------------------------------------------------------------------------------------------------------------------------------- ! @@ -137,18 +137,18 @@ SUBROUTINE print_values (nrrcp, namrcp, xm, ym, error, par1, spar1, par2, sp & par6, spar6, par7, spar7, par8, spar8, par9, spar9, par10, spar10, par11, spar11, par12, & & spar12, par13, spar13, par14, spar14) -INTEGER :: nrparam ! +INTEGER :: nrparam PARAMETER (nrparam = 14) ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'print_values') ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: nrrcp ! -CHARACTER*(*), INTENT(IN) :: namrcp(nrrcp) ! -REAL*4, INTENT(IN) :: xm(nrrcp) ! -REAL*4, INTENT(IN) :: ym(nrrcp) ! +INTEGER*4, INTENT(IN) :: nrrcp +CHARACTER*(*), INTENT(IN) :: namrcp(nrrcp) +REAL*4, INTENT(IN) :: xm(nrrcp) +REAL*4, INTENT(IN) :: ym(nrrcp) REAL*4, INTENT(IN), OPTIONAL :: par1(nrrcp) ! values of parameter REAL*4, INTENT(IN), OPTIONAL :: spar1 ! factor in parameter REAL*4, INTENT(IN), OPTIONAL :: par2(nrrcp) ! values of parameter @@ -182,14 +182,14 @@ SUBROUTINE print_values (nrrcp, namrcp, xm, ym, error, par1, spar1, par2, sp TYPE (TError), INTENT(INOUT) :: error ! should not happen as format string is long enough ! LOCAL VARIABLES -INTEGER*4 :: i ! -INTEGER*4 :: j ! -INTEGER*4 :: values(nrparam) ! -REAL*4 :: factors(nrparam) ! -REAL*4 :: factorscopy(nrparam) ! -INTEGER*4 :: nrpresent ! -INTEGER*4 :: nrunit ! -LOGICAL :: dummybool ! +INTEGER*4 :: i +INTEGER*4 :: j +INTEGER*4 :: values(nrparam) +REAL*4 :: factors(nrparam) +REAL*4 :: factorscopy(nrparam) +INTEGER*4 :: nrpresent +INTEGER*4 :: nrunit +LOGICAL :: dummybool CHARACTER*180 :: formatpar ! format in writing parameter names CHARACTER*180 :: formatval ! format in writing parameter values @@ -295,15 +295,15 @@ END SUBROUTINE print_values LOGICAL FUNCTION has_rcp_values(spar, nrpresent, factors) ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'has_rcp_values') ! SUBROUTINE ARGUMENTS - INPUT REAL*4, INTENT(IN), OPTIONAL :: spar ! factor in parameter ! SUBROUTINE ARGUMENTS - I/O -INTEGER*4, INTENT(INOUT) :: nrpresent ! -REAL*4, INTENT(INOUT) :: factors(:) ! +INTEGER*4, INTENT(INOUT) :: nrpresent +REAL*4, INTENT(INOUT) :: factors(:) has_rcp_values = PRESENT(spar) IF (has_rcp_values) THEN @@ -321,19 +321,19 @@ END FUNCTION has_rcp_values LOGICAL FUNCTION set_rcp_values(formatpar, factors, nrpresent, index, values) ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'set_rcp_values') ! SUBROUTINE ARGUMENTS - INPUT -REAL*4, INTENT(IN) :: formatpar ! -REAL*4, INTENT(IN) :: factors(nrpresent) ! -INTEGER*4, INTENT(IN) :: nrpresent ! +REAL*4, INTENT(IN) :: formatpar +REAL*4, INTENT(IN) :: factors(nrpresent) +INTEGER*4, INTENT(IN) :: nrpresent ! SUBROUTINE ARGUMENTS - I/O -INTEGER*4, INTENT(INOUT) :: index ! +INTEGER*4, INTENT(INOUT) :: index ! SUBROUTINE ARGUMENTS - OUTPUT -INTEGER*4, INTENT(OUT) :: values(nrpresent) ! +INTEGER*4, INTENT(OUT) :: values(nrpresent) set_rcp_values = index /= nrpresent IF (set_rcp_values) THEN diff --git a/ops_rcp_char_1.f90 b/ops_rcp_char_1.f90 index 330e8b7..cbc0bfe 100644 --- a/ops_rcp_char_1.f90 +++ b/ops_rcp_char_1.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Prepares values for landuse and roughness for one receptorpoint. @@ -51,17 +51,17 @@ SUBROUTINE ops_rcp_char_1(isec, ircp, nrrcp, intpol, gxm_rcp, gym_rcp, cs, z0_me IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_rcp_char_1') ! SUBROUTINE ARGUMENTS - INPUT -LOGICAL*4, INTENT(IN) :: isec -INTEGER*4, INTENT(IN) :: ircp -INTEGER*4, INTENT(IN) :: nrrcp -INTEGER*4, INTENT(IN) :: intpol ! +LOGICAL*4, INTENT(IN) :: isec +INTEGER*4, INTENT(IN) :: ircp +INTEGER*4, INTENT(IN) :: nrrcp +INTEGER*4, INTENT(IN) :: intpol REAL*4, INTENT(IN) :: gxm_rcp ! array met x-coordinaat van receptorpunten (lola) REAL*4, INTENT(IN) :: gym_rcp ! array met y-coordinaat van receptorpunten (lola) -REAL*4, INTENT(IN) :: cs(NTRAJ, NCOMP, NSTAB, NSEK, NMETREG) ! +REAL*4, INTENT(IN) :: cs(NTRAJ, NCOMP, NSTAB, NSEK, NMETREG) REAL*4, INTENT(IN) :: z0_metreg(NMETREG) ! roughness lengths of NMETREG meteo regions; scale < 50 km [m] REAL*4, INTENT(IN) :: xreg(NMETREG) ! array met x-coordinaat van meteo-regios REAL*4, INTENT(IN) :: yreg(NMETREG) ! array met y-coordinaat van meteo-regio's @@ -71,21 +71,21 @@ SUBROUTINE ops_rcp_char_1(isec, ircp, nrrcp, intpol, gxm_rcp, gym_rcp, cs, z0_me REAL*4, INTENT(IN) :: y_rcp ! array met y-coordinaat van receptorpunten (RDM) TYPE (TApsGridInt), INTENT(IN) :: lugrid ! grid with land use information LOGICAL*4, INTENT(IN) :: domlu ! index of dominant land use class -LOGICAL*4, INTENT(IN) :: perc ! +LOGICAL*4, INTENT(IN) :: perc INTEGER, INTENT(IN) :: lu_rcp_per_user_all(nrrcp,NLU) ! percentage of landuse for all receptors, used defined in receptor file INTEGER*4, INTENT(IN) :: lu_rcp_dom_all(nrrcp) ! land use at receptor points -LOGICAL*4, INTENT(IN) :: f_z0user +LOGICAL*4, INTENT(IN) :: f_z0user REAL*4, INTENT(IN) :: z0_rcp_all(nrrcp) ! roughness lengths for all receptors; from z0-map or receptor file [m] ! SUBROUTINE ARGUMENTS - I/O -INTEGER*4, INTENT (INOUT) :: i1(NTRAJ-1) ! -REAL*4, INTENT(INOUT) :: astat(NTRAJ,NCOMP,NSTAB,NSEK) ! +INTEGER*4, INTENT (INOUT) :: i1(NTRAJ-1) +REAL*4, INTENT(INOUT) :: astat(NTRAJ,NCOMP,NSTAB,NSEK) ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: uurtot ! +REAL*4, INTENT(OUT) :: uurtot REAL*4, INTENT(OUT) :: z0_metreg_rcp ! roughness length at receptor; interpolated from meteo regions [m] INTEGER*4, INTENT(OUT) :: lu_rcp_dom ! dominant landuse class for receptor REAL*4, INTENT(OUT) :: lu_rcp_per(NLU) ! percentages of landuse classes at receptor points REAL*4, INTENT(OUT) :: z0_rcp ! roughness length at receptor; from z0-map [m] -TYPE (TError) :: error +TYPE (TError) :: error ! LOCAL VARIABLES INTEGER*4 :: lu_rcp_per_int(NLU) ! percentages of landuse classes at receptor points @@ -93,7 +93,7 @@ SUBROUTINE ops_rcp_char_1(isec, ircp, nrrcp, intpol, gxm_rcp, gym_rcp, cs, z0_me LOGICAL :: iscell ! whether point is inside masker grid ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- @@ -102,7 +102,7 @@ SUBROUTINE ops_rcp_char_1(isec, ircp, nrrcp, intpol, gxm_rcp, gym_rcp, cs, z0_me z0_metreg_rcp = 0 ! ! Select the three nearest climatological regions and interpolate between them in order to compute z0_metreg_rcp -! Note: intpol = 0 -> interpolate +! Note: intpol = 0 -> interpolate ! IF (intpol.EQ.0) THEN CALL reginpo(gxm_rcp, gym_rcp, cs, z0_metreg, xreg, yreg, i1, z0_metreg_rcp, uurtot, astat, error) @@ -123,7 +123,7 @@ SUBROUTINE ops_rcp_char_1(isec, ircp, nrrcp, intpol, gxm_rcp, gym_rcp, cs, z0_me IF (isec) THEN DO lu=2,NLU+1 CALL GridValue(x_rcp/1000, y_rcp/1000, lugrid, lu_rcp_per_int(lu-1), iscell, lu) - ENDDO + ENDDO lu_rcp_per = float(lu_rcp_per_int) ENDIF ENDIF @@ -136,7 +136,7 @@ SUBROUTINE ops_rcp_char_1(isec, ircp, nrrcp, intpol, gxm_rcp, gym_rcp, cs, z0_me IF (isec) THEN DO lu=2,NLU+1 CALL GridValue(x_rcp/1000, y_rcp/1000, lugrid, lu_rcp_per_int(lu-1), iscell, lu) - ENDDO + ENDDO lu_rcp_per = float(lu_rcp_per_int) ENDIF ELSE @@ -154,7 +154,7 @@ SUBROUTINE ops_rcp_char_1(isec, ircp, nrrcp, intpol, gxm_rcp, gym_rcp, cs, z0_me ! IF (f_z0user) THEN lu_rcp_dom = 1 -ELSE +ELSE ! ! Set roughness length and dominant landuse class at receptor (not user specified) ! @@ -173,10 +173,10 @@ SUBROUTINE ops_rcp_char_1(isec, ircp, nrrcp, intpol, gxm_rcp, gym_rcp, cs, z0_me 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 @@ -193,7 +193,7 @@ SUBROUTINE reginpo(x, y, cs, z0_metreg, xreg, yreg, i1, z0_metreg_xy, uurtot, as USE Binas, only: deg2rad ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'reginpo') INTEGER*4 :: NONZERO(NCOMP) ! meteo parameters for which no interpolation has to @@ -203,7 +203,7 @@ SUBROUTINE reginpo(x, y, cs, z0_metreg, xreg, yreg, i1, z0_metreg_xy, uurtot, as ! SUBROUTINE ARGUMENTS - INPUT REAL*4, INTENT(IN) :: x ! x-coordinate (longitude; degrees) REAL*4, INTENT(IN) :: y ! y-coordinate (latitude; degrees) -REAL*4, INTENT(IN) :: cs(NTRAJ, NCOMP, NSTAB, NSEK, NMETREG) ! +REAL*4, INTENT(IN) :: cs(NTRAJ, NCOMP, NSTAB, NSEK, NMETREG) REAL*4, INTENT(IN) :: z0_metreg(NMETREG) ! roughness lengths of NMETREG meteo regions; scale < 50 km [m] REAL*4, INTENT(IN) :: xreg(NMETREG) ! x-coordinate region centre (longitude; degrees) REAL*4, INTENT(IN) :: yreg(NMETREG) ! y-coordinate region centre (latitude; degrees) @@ -213,8 +213,8 @@ SUBROUTINE reginpo(x, y, cs, z0_metreg, xreg, yreg, i1, z0_metreg_xy, uurtot, as ! SUBROUTINE ARGUMENTS - OUTPUT REAL*4, INTENT(OUT) :: z0_metreg_xy ! roughness length at (x,y), interpolated from meteo regions [m] -REAL*4, INTENT(OUT) :: uurtot ! -REAL*4, INTENT(OUT) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) ! +REAL*4, INTENT(OUT) :: uurtot +REAL*4, INTENT(OUT) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) TYPE (TError), INTENT(OUT) :: error ! error handling record ! LOCAL VARIABLES @@ -230,16 +230,16 @@ SUBROUTINE reginpo(x, y, cs, z0_metreg, xreg, yreg, i1, z0_metreg_xy, uurtot, as REAL*4 :: r ! distance region - receptor REAL*4 :: rmin ! distance nearest region - receptor REAL*4 :: s ! sum of s1() -REAL*4 :: ss ! -REAL*4 :: rr ! -REAL*4 :: rrtot ! +REAL*4 :: ss +REAL*4 :: rr +REAL*4 :: rrtot REAL*4 :: r1(NTRAJ-1) ! distance of three nearest regions - receptor REAL*4 :: s1(NTRAJ-1) ! inverse distance = 1/r1() -REAL*4 :: ss1(NTRAJ-1) ! +REAL*4 :: ss1(NTRAJ-1) ! DATA ! 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 -DATA NONZERO/0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1/ +DATA NONZERO/0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1/ ! ! If NONZERO = 1 -> no interpolation has to be done when one of the interpolants has a zero frequency of occurrence; ! in this case the weighing coefficients ss1 are used, which are zero if the class does not occur @@ -252,7 +252,7 @@ SUBROUTINE reginpo(x, y, cs, z0_metreg, xreg, yreg, i1, z0_metreg_xy, uurtot, as ! 18. distribution of stability classes over day, receptor oriented [-] ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! Set a = cos(y); needed in computation of dx = (x2 - x1)*cos(y) for geographical coordinates @@ -267,8 +267,8 @@ SUBROUTINE reginpo(x, y, cs, z0_metreg, xreg, yreg, i1, z0_metreg_xy, uurtot, as ! -DO itraj = 1, NTRAJ - 1 - +DO itraj = 1, NTRAJ - 1 + ! Initialise minimal distance at 'HUGE' rmin = 100000. @@ -278,7 +278,7 @@ SUBROUTINE reginpo(x, y, cs, z0_metreg, xreg, yreg, i1, z0_metreg_xy, uurtot, as ! Check whether any index of nearest regions i1 has already been assigned to ireg (in a previous loop over ireg_nearest); ! if so, skip this region. ! - IF (.NOT. ANY(i1(1:itraj-1).EQ.ireg)) THEN + IF (.NOT. ANY(i1(1:itraj-1).EQ.ireg)) THEN ! Compute distance region - receptor r = ((x - xreg(ireg))*a)**2 + (y - yreg(ireg))**2 @@ -295,7 +295,7 @@ SUBROUTINE reginpo(x, y, cs, z0_metreg, xreg, yreg, i1, z0_metreg_xy, uurtot, as ! add inverse distance to som, for this nearest region. Inverse distances are used as weighing coefficients for ! interpolation of z0 over the nearest regions. ! - i1(itraj) = imin + i1(itraj) = imin r1(itraj) = rmin s1(itraj) = 1./(r1(itraj) + .01) s = s + s1(itraj) @@ -318,7 +318,7 @@ SUBROUTINE reginpo(x, y, cs, z0_metreg, xreg, yreg, i1, z0_metreg_xy, uurtot, as ! and ss = sum of all weighing coefficients ! ss = 0. - DO ireg = 1, NTRAJ-1 + DO ireg = 1, NTRAJ-1 ! If {distance,stability,wind sector} class does not occur for the current nearest region, ! ss1 = 0, otherwise ss1 = s1 @@ -338,7 +338,7 @@ SUBROUTINE reginpo(x, y, cs, z0_metreg, xreg, yreg, i1, z0_metreg_xy, uurtot, as ! DO icomp = 1, NCOMP rrtot = 0 - DO ireg = 1, NTRAJ-1 + DO ireg = 1, NTRAJ-1 ! If NONZERO = 1 -> no interpolation has to be done when one of the interpolants has a zero frequency of occurrence; ! in this case the weighing coefficients ss1 are used, which are zero if the class does not occur @@ -374,4 +374,4 @@ SUBROUTINE reginpo(x, y, cs, z0_metreg, xreg, yreg, i1, z0_metreg_xy, uurtot, as END SUBROUTINE reginpo END SUBROUTINE ops_rcp_char_1 - + diff --git a/ops_rcp_char_all.f90 b/ops_rcp_char_all.f90 index 198dd78..0115036 100644 --- a/ops_rcp_char_all.f90 +++ b/ops_rcp_char_all.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Fill arrays with receptor characteristics: @@ -51,17 +51,17 @@ subroutine ops_rcp_char_all(icm, iopt_vchem, isec, nsubsec, xm, ym, f_z0user, z0 IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_rcp_char_all') ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: icm +INTEGER*4, INTENT(IN) :: icm INTEGER*4, INTENT(IN) :: iopt_vchem ! option for chemical conversion rate (0 = old OPS, 1 = EMEP) -LOGICAL*4, INTENT(IN) :: isec -INTEGER*4, INTENT(IN) :: nsubsec ! number of sub-secondary species +LOGICAL*4, INTENT(IN) :: isec +INTEGER*4, INTENT(IN) :: nsubsec ! number of sub-secondary species REAL*4, INTENT(IN) :: xm(nrrcp) ! x-coordinates of receptors REAL*4, INTENT(IN) :: ym(nrrcp) ! y-coordinates of receptors -LOGICAL*4, INTENT(IN) :: f_z0user +LOGICAL*4, INTENT(IN) :: f_z0user REAL*4, INTENT(IN) :: z0_user ! roughness length specified by user [m] TYPE (TApsGridInt), INTENT(IN) :: z0nlgrid ! map of roughness lengths in NL [m] TYPE (TApsGridInt), INTENT(IN) :: z0eurgrid ! map of roughness lengths in Europe [m] @@ -73,9 +73,9 @@ subroutine ops_rcp_char_all(icm, iopt_vchem, isec, nsubsec, xm, ym, f_z0user, z0 LOGICAL*4, INTENT(IN) :: domlu ! index of dominant land use class ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: gxm(nrrcp) -REAL*4, INTENT(OUT) :: gym(nrrcp) -REAL*4, INTENT(OUT) :: rhno3_rcp(nrrcp) +REAL*4, INTENT(OUT) :: gxm(nrrcp) +REAL*4, INTENT(OUT) :: gym(nrrcp) +REAL*4, INTENT(OUT) :: rhno3_rcp(nrrcp) REAL*4, INTENT(OUT) :: nh3bg_rcp(nrrcp) REAL*4, INTENT(OUT) :: so2bg_rcp(nrrcp) REAL*4, INTENT(OUT) :: f_subsec_rcp(nrrcp,nsubsec) ! fractions for sub-secondary species, HNO3/NO3_total, NO3_C/NO3_total, NO3_F/NO3_total [-] @@ -85,20 +85,20 @@ subroutine ops_rcp_char_all(icm, iopt_vchem, isec, nsubsec, xm, ym, f_z0user, z0 ! 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 +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 +TYPE (TError), INTENT(INOUT) :: error ! LOCAL VARIABLES INTEGER*4 :: ircp ! index of receptor INTEGER*4 :: isubsec ! index of sub-secondary species REAL*4 :: so2bgconc ! background concentratie SO2 REAL*4 :: nh3bgconc ! background concentration NH3 at receptor [ppb] -LOGICAL :: z0found +LOGICAL :: z0found INTEGER :: ifield ! field index in f_subsec_grid ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- @@ -143,7 +143,7 @@ subroutine ops_rcp_char_all(icm, iopt_vchem, isec, nsubsec, xm, ym, f_z0user, z0 ! Get background concentrations at receptor CALL ops_bgcon(xm(ircp),ym(ircp),nh3bggrid, nh3bgconc) ! Distribute NO3 and SO4 into sub-secondary species -! +! ! rhno3 = ratio [HNO3]/[NO3]_total (NO3_total = HNO3+NO3_aerosol); all concentrations in ppb. ! ! [NH3]_background -0.44 @@ -161,33 +161,33 @@ subroutine ops_rcp_char_all(icm, iopt_vchem, isec, nsubsec, xm, ym, f_z0user, z0 ! For distributing concentrations over different secondary species, we use f_subsec_rcp, which is read from file. ! IF (icm == 2) THEN - rhno3_rcp(ircp)=amin1(0.024*(nh3bgconc/1000)**(-0.44),0.8) - + rhno3_rcp(ircp)=amin1(0.024*(nh3bgconc/1000)**(-0.44),0.8) + ! Get fractions for different sub-secondary species, HNO3/NO3_total, NO3_C/NO3_total, NO3_F/NO3_total at current receptor location: - if (iopt_vchem .eq. 0) then - + if (iopt_vchem .eq. 0) then + ! File with f_subsec_grid is not present, use old OPS parameterisation rhno3 and do not split into coarse and fine: !WdV f_subsec_rcp(ircp,1) = rhno3_rcp(ircp) ! HNO3 !WdV f_subsec_rcp(ircp,2) = (1.0 - rhno3_rcp(ircp)) ! NO3_AEROSOL f_subsec_rcp(ircp,1) = (1.0 - rhno3_rcp(ircp)) ! NO3_AEROSOL f_subsec_rcp(ircp,2) = rhno3_rcp(ircp) ! HNO3 - ! for NO3-coarse and - fine, fractions are used from BOP-report + ! for NO3-coarse and - fine, fractions are used from BOP-report ! f_subsec_rcp(ircp,2) = frac_no3c_bop*(1.0 - rhno3_rcp(ircp)) ! NO3_C ! f_subsec_rcp(ircp,3) = frac_no3f_bop*(1.0 - rhno3_rcp(ircp)) ! NO3_F else ! Get fraction from EMEP grid: ! (3 fields in f_subsec_grid: HNO3/NO3_total, NO3_C/NO3_total, NO3_F/NO3_total; 4 sub species NO3_aerosol, HNO3, NO3_C, NO3_F) do isubsec = 2,nsubsec - ifield = isubsec - 1 + ifield = isubsec - 1 CALL ops_bgcon(xm(ircp),ym(ircp),f_subsec_grid, f_subsec_rcp(ircp,isubsec),ifield) enddo - + ! Fraction NO3_aerosol / NO3_total: - f_subsec_rcp(ircp,1) = f_subsec_rcp(ircp,3) + f_subsec_rcp(ircp,4) + f_subsec_rcp(ircp,1) = f_subsec_rcp(ircp,3) + f_subsec_rcp(ircp,4) endif ELSE -! +! ! Convert NH3 background concentration from ppb to ug/m3 (is used as such in DEPAC) ! nh3bg_rcp(ircp)=nh3bgconc*17/24 @@ -195,10 +195,10 @@ subroutine ops_rcp_char_all(icm, iopt_vchem, isec, nsubsec, xm, ym, f_z0user, z0 ! Get so2 background concentration at receptor ! CALL ops_bgcon(xm(ircp),ym(ircp),so2bggrid, so2bgconc) -! +! ! Convert SO2 background concentration from ppb to ug/m3 (is used as such in DEPAC) ! - so2bg_rcp(ircp)=so2bgconc*64./24. + so2bg_rcp(ircp)=so2bgconc*64./24. ENDIF 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): ', & diff --git a/ops_read_bg.f90 b/ops_read_bg.f90 index 136dc38..365b5f6 100644 --- a/ops_read_bg.f90 +++ b/ops_read_bg.f90 @@ -1,19 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! !------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -28,7 +27,7 @@ ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO/IS ! LANGUAGE : FORTRAN(HP-UX, HP-F77, HP-F90) ! DESCRIPTION : Handling of background concentrations. @@ -56,7 +55,7 @@ SUBROUTINE ops_read_bg(icm, iopt_vchem, nsubsec, year, so2bggrid, no2bggrid, nh3 ! SUBROUTINE ARGUMENTS - INPUT INTEGER*4, INTENT(IN) :: icm ! substance index INTEGER*4, INTENT(IN) :: iopt_vchem ! option for chemical conversion rate (0 = old OPS, 1 = EMEP) -INTEGER*4, INTENT(IN) :: nsubsec ! number of sub-secondary species +INTEGER*4, INTENT(IN) :: nsubsec ! number of sub-secondary species INTEGER*4, INTENT(IN) :: year ! year under consideration ! SUBROUTINE ARGUMENTS - OUTPUT @@ -64,16 +63,16 @@ SUBROUTINE ops_read_bg(icm, iopt_vchem, nsubsec, year, so2bggrid, no2bggrid, nh3 TYPE (TApsGridReal), INTENT(OUT) :: no2bggrid ! grid with NO2 background concentration [ppb] TYPE (TApsGridReal), INTENT(OUT) :: nh3bggrid ! grid with NH3 background concentration [ppb] TYPE (TApsGridReal), INTENT(OUT) :: f_subsec_grid ! grids of fractions for sub-secondary species, HNO3/NO3_total, NO3_C/NO3_total, NO3_F/NO3_total [-] -TYPE (Tvchem), INTENT(INOUT) :: vchem2 ! +TYPE (Tvchem), INTENT(INOUT) :: vchem2 TYPE (TError), INTENT(OUT) :: error ! error handling record ! LOCAL VARIABLES INTEGER*4 :: i ! column index in grid INTEGER*4 :: j ! row index in grid INTEGER*4 :: mapnumber ! number of background map -INTEGER*4 :: ji ! year index, i.e. the index in the trendfactor +INTEGER*4 :: ji ! year index, i.e. the index in the trendfactor ! arrays tf_... of the current year -REAL*4 :: factor ! combined correction factor (calibration with +REAL*4 :: factor ! combined correction factor (calibration with ! measurements and correction for year) LOGICAL*1 :: future ! TRUE if year is closer to FUTUREYEAR than to last ! historic year @@ -88,21 +87,21 @@ SUBROUTINE ops_read_bg(icm, iopt_vchem, nsubsec, year, so2bggrid, no2bggrid, nh3 INTEGER :: ifield ! field number in f_subsec_grid ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_read_bg') ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! ! Get number of map that is the basis for the calculation of the background concentration. -! Maps are, in general, created by previous runs of OPS. +! Maps are, in general, created by previous runs of OPS. ! -! For each of the components SO2, NOx en NH3, there are 4 maps available; for 3 historic years (1984, 1994, 2005) and for a +! For each of the components SO2, NOx en NH3, there are 4 maps available; for 3 historic years (1984, 1994, 2005) and for a ! future year (FUTUREYEAR). The maps for the historic years are corrected by OPS for the deviation between model and measurements. ! For other years than these three historic years, one of these corrected maps is subsequently scaled to the average Dutch -! concentration for that year. This scaling factor (trend factor) is purely determined from measurements. +! concentration for that year. This scaling factor (trend factor) is purely determined from measurements. ! The map with future concentrations is used in case that the simulation year is closer to the future year than to the last year ! for which the average Dutch concentration is known (i.e. FIRSTYEAR + NYEARS - 1): ! @@ -138,7 +137,7 @@ SUBROUTINE ops_read_bg(icm, iopt_vchem, nsubsec, year, so2bggrid, no2bggrid, nh3 ENDIF ! ! Of which components the background concentration has to be calculated depends on the substance for which the OPS calculation takes place. -! 1: SO2 >> {(NH4)2 SO4} -> SO2, NH3; +! 1: SO2 >> {(NH4)2 SO4} -> SO2, NH3; ! 2: NO2 >> {NH4 NO3} -> NO2, NH3; ! 3: NH3 >> {(NH4)2 SO4}, {NH4 NO3} -> SO2, NO2, NH3 ! @@ -146,7 +145,7 @@ SUBROUTINE ops_read_bg(icm, iopt_vchem, nsubsec, year, so2bggrid, no2bggrid, nh3 ! ! Read and allocate the background grids for SO2 [ug/m3]. ! SO2 background values are not required for icm = 2 (component = NOx). -! +! CALL read_bg_file(map_so2(mapnumber), 'SO2', so2bggrid, error) IF (error%haserror) GOTO 9999 ! @@ -154,23 +153,23 @@ SUBROUTINE ops_read_bg(icm, iopt_vchem, nsubsec, year, so2bggrid, no2bggrid, nh3 ! SetAverage multiplies all grid values with factor and computes a grid average. ! Molw(SO2) = 64; 24.04 l is the volume of 1 mole of gas at STP (20 deg C, 1013 mbar) -! concentration_(ppb) = 24.04/ molecular_weight x concentration_(ug/m3) , +! concentration_(ppb) = 24.04/ molecular_weight x concentration_(ug/m3) , ! factor = 24./64. * cf_so2(mapnumber) * tf_so2(ji) - CALL SetAverage(factor, so2bggrid) + CALL SetAverage(factor, so2bggrid) ENDIF IF (icm /= 1) THEN ! -! Read and allocate the background grids for NOx [ug NO2/m3] to calculate the NO2 background concentration. +! Read and allocate the background grids for NOx [ug NO2/m3] to calculate the NO2 background concentration. ! NO2 background values are not required for icm = 1 (component = SO2). ! CALL read_bg_file(map_nox(mapnumber), 'NOx', no2bggrid, error) IF (error%haserror) GOTO 9999 ! -! First, the NOx background concentration is corrected for the difference between model and measurements (cf_no2). -! Simultaneously the unit is converted from ug NO2 per m3 to ppb. -! The latter is done to be able to use the existing empirical relation for NOx --> NO2. +! First, the NOx background concentration is corrected for the difference between model and measurements (cf_no2). +! Simultaneously the unit is converted from ug NO2 per m3 to ppb. +! The latter is done to be able to use the existing empirical relation for NOx --> NO2. ! Molw(NO2) = 46; 24.04 l is the volume of 1 mole of gas at STP (20 deg C, 1013 mbar) ! factor = cf_nox(mapnumber) * 24./46. @@ -199,15 +198,15 @@ SUBROUTINE ops_read_bg(icm, iopt_vchem, nsubsec, year, so2bggrid, no2bggrid, nh3 ENDDO ENDDO ! Now, no2bggrid contains the NO2-concentration - -! + +! ! Now the correction for the actual year (factor tf_no2) is done. ! factor = tf_no2(ji) CALL SetAverage(factor, no2bggrid) ENDIF ! -! Read and allocate the background grids for NH3 [ug/m3]. NH3 background values are always required. +! Read and allocate the background grids for NH3 [ug/m3]. NH3 background values are always required. ! CALL read_bg_file(map_nh3(mapnumber), 'NH3', nh3bggrid, error) IF (error%haserror) GOTO 9999 @@ -227,9 +226,9 @@ SUBROUTINE ops_read_bg(icm, iopt_vchem, nsubsec, year, so2bggrid, no2bggrid, nh3 write(fnam(i1:i1+3),'(I4)') year CALL read_bg_file(trim(fnam),'mass precursor', vchem2%mass_prec_grid, error) if (error%haserror) GOTO 9999 - - call SetAverage(grid = vchem2%mass_prec_grid) - + + call SetAverage(grid = vchem2%mass_prec_grid) + ! Read MASS_CONV_DTFAC for this year: fnam = map_mass_conv_dtfac write(fnam(1:3),'(A3)') CNAME(icm,1) @@ -237,13 +236,13 @@ SUBROUTINE ops_read_bg(icm, iopt_vchem, nsubsec, year, so2bggrid, no2bggrid, nh3 write(fnam(i1:i1+3),'(I4)') year CALL read_bg_file(trim(fnam),'(100/dt) * mass converted chemistry', vchem2%mass_conv_dtfac_grid, error) if (error%haserror) GOTO 9999 - - call SetAverage(grid = vchem2%mass_conv_dtfac_grid) - - ! write(*,*) 'average of mass_prec_grid: ', vchem2%mass_prec_grid%average + + call SetAverage(grid = vchem2%mass_conv_dtfac_grid) + + ! write(*,*) 'average of mass_prec_grid: ', vchem2%mass_prec_grid%average ! write(*,*) 'average of mass_conv_dtfac_grid: ', vchem2%mass_conv_dtfac_grid%average - ! write(*,*) 'average conversion rate [%/h]: ', vchem2%mass_conv_dtfac_grid%average/vchem2%mass_prec_grid%average - + ! write(*,*) 'average conversion rate [%/h]: ', vchem2%mass_conv_dtfac_grid%average/vchem2%mass_prec_grid%average + ! Read distribution maps for NO3_total: HNO3/NO3_total, NO3_C/NO3_total, NO3_F/NO3_total; ! from file 'no3_distr_yyyy.ops'; yyyy = year (e.g. 2019) if (icm .eq. 2) then @@ -256,11 +255,11 @@ SUBROUTINE ops_read_bg(icm, iopt_vchem, nsubsec, year, so2bggrid, no2bggrid, nh3 if (error%haserror) goto 9999 ! Read fractions for sub-secondary species: - ! write(*,*) 'reading fractions NO3 from file ',trim(apsfile) + ! write(*,*) 'reading fractions NO3 from file ',trim(apsfile) CALL read_bg_file(trim(fnam),'fractions of NO3' , f_subsec_grid, error) if (error%haserror) GOTO 9999 - - ! Get number of fields in f_subsec_grid; should be equal to nsubsec-1 + + ! Get number of fields in f_subsec_grid; should be equal to nsubsec-1 ! (3 fields HNO3/NO3_total, NO3_C/NO3_total, NO3_F/NO3_total; 4 sub species NO3_aerosol, HNO3, NO3_C, NO3_F) nfield = size(f_subsec_grid%value,3) ! WdV write(*,'(a,i6)') '--------------- number of fields read in ops_read_bg ----------------- : ',nfield @@ -276,7 +275,7 @@ SUBROUTINE ops_read_bg(icm, iopt_vchem, nsubsec, year, so2bggrid, no2bggrid, nh3 ! Set average of grid (is used in ops_bgcon for missing (negative) values or values outside grid): do ifield = 1,nfield call SetAverage(grid = f_subsec_grid, fieldnumber = ifield) - ! write(*,*) 'average of grid of secondary component ',ifield,' = ',f_subsec_grid%average(ifield) + ! write(*,*) 'average of grid of secondary component ',ifield,' = ',f_subsec_grid%average(ifield) enddo endif @@ -291,8 +290,8 @@ SUBROUTINE ops_read_bg(icm, iopt_vchem, nsubsec, year, so2bggrid, no2bggrid, nh3 ! qq%value = vchem2%mass_conv_dtfac_grid(1)%value/vchem2%mass_prec_grid(1)%value ! write(*,*) 'grid for conversion factor' ! open(unit = 34, file = 'cvr_tst1.aps') - ! ! - ! ! + + ! ! character*(*) coord_sys ! coordinate system, either 'RDM' or 'lon-lat' ! ! integer lu ! ! real xorg, yorg @@ -305,7 +304,7 @@ SUBROUTINE ops_read_bg(icm, iopt_vchem, nsubsec, year, so2bggrid, no2bggrid, nh3 ! ! character*10 modversie ! ! character*12 kname ! ! character*(*) namegr ! name of grid file (used for error message) - ! ! + ! ! character*12 quantity ! !subroutine saveaps(coord_sys,lu,namegr,xorg,yorg,gridx,gridy,matx,maty,cpri,namco,unit_conc,modversie,kname,quantity,ijg,img,idg,iug) ! call saveaps('RDM',34,'qq0',qq%gridheader%xorgl,qq%gridheader%yorgl,qq%gridheader%grixl,qq%gridheader%griyl,qq%gridheader%nrcol,qq%gridheader%nrrow,qq%value(:,:,1),'conv_rate ','%/h ','OPS_tst ','qq1 ','qq2 ',10,0,0,0) @@ -321,11 +320,11 @@ SUBROUTINE ops_read_bg(icm, iopt_vchem, nsubsec, year, so2bggrid, no2bggrid, nh3 ! !! REAL*4 :: griyl ! vertical size of grid cell [km] ! !! END TYPE TGridHeader ! ! END TEST write to APS file -------------------------------------------------------------------------------------------- - + IF (error%haserror) GOTO 9999 endif -! +! RETURN ! ! Error section @@ -355,7 +354,7 @@ SUBROUTINE read_bg_file(filename, compname, bggrid, error) CHARACTER*512 :: apsfile ! full file name of APS-file to read ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'read_bg_file') !------------------------------------------------------------------------------------------------------------------------------- diff --git a/ops_read_ctr.f90 b/ops_read_ctr.f90 index b801ee9..fd70df9 100644 --- a/ops_read_ctr.f90 +++ b/ops_read_ctr.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,10 +27,10 @@ ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 -! DESCRIPTION : Read parameters for the OPS-model from the control file. +! DESCRIPTION : Read parameters for the OPS-model from the control file. ! EXIT CODES : ! FILES AND OTHER : ! I/O DEVICES @@ -49,56 +49,56 @@ SUBROUTINE ops_read_ctr(project, runid, year, icm, namco, amol1, gasv, idep, kde USE m_commonconst ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_read_ctr') ! SUBROUTINE ARGUMENTS - OUTPUT CHARACTER*(*), INTENT(OUT) :: project ! project name CHARACTER*(*), INTENT(OUT) :: runid ! run identifier (is used in the output) INTEGER*4, INTENT(OUT) :: year ! year under consideration -INTEGER*4, INTENT(OUT) :: icm -CHARACTER*(*), INTENT(OUT) :: namco -REAL*4, INTENT(OUT) :: amol1 +INTEGER*4, INTENT(OUT) :: icm +CHARACTER*(*), INTENT(OUT) :: namco +REAL*4, INTENT(OUT) :: amol1 LOGICAL, INTENT(OUT) :: gasv ! type of component (0: particle; 1: gas) -LOGICAL, INTENT(OUT) :: idep -INTEGER*4, INTENT(OUT) :: kdeppar -REAL*4, INTENT(OUT) :: ddeppar -INTEGER*4, INTENT(OUT) :: knatdeppar -REAL*4, INTENT(OUT) :: wdeppar -REAL*4, INTENT(OUT) :: dg -LOGICAL, INTENT(OUT) :: irev +LOGICAL, INTENT(OUT) :: idep +INTEGER*4, INTENT(OUT) :: kdeppar +REAL*4, INTENT(OUT) :: ddeppar +INTEGER*4, INTENT(OUT) :: knatdeppar +REAL*4, INTENT(OUT) :: wdeppar +REAL*4, INTENT(OUT) :: dg +LOGICAL, INTENT(OUT) :: irev REAL*4, INTENT(OUT) :: vchemc ! chemical conversion rate [%/h] INTEGER*4, INTENT(OUT) :: iopt_vchem ! option for chemical conversion rate (0 = old OPS, 1 = EMEP) -REAL*4, INTENT(OUT) :: vchemv -REAL*4, INTENT(OUT) :: emtrend -INTEGER*4, INTENT(OUT) :: ncatsel -INTEGER*4, INTENT(OUT) :: catsel(*) -INTEGER*4, INTENT(OUT) :: nlandsel -INTEGER*4, INTENT(OUT) :: landsel(*) -INTEGER*4, INTENT(OUT) :: spgrid +REAL*4, INTENT(OUT) :: vchemv +REAL*4, INTENT(OUT) :: emtrend +INTEGER*4, INTENT(OUT) :: ncatsel +INTEGER*4, INTENT(OUT) :: catsel(*) +INTEGER*4, INTENT(OUT) :: nlandsel +INTEGER*4, INTENT(OUT) :: landsel(*) +INTEGER*4, INTENT(OUT) :: spgrid REAL*4, INTENT(OUT) :: xc ! x-coordinate grid centre of user specified grid (spgrid = 1) REAL*4, INTENT(OUT) :: yc ! y-coordinate grid centre of user specified grid (spgrid = 1) -INTEGER*4, INTENT(OUT) :: nrcol -INTEGER*4, INTENT(OUT) :: nrrow +INTEGER*4, INTENT(OUT) :: nrcol +INTEGER*4, INTENT(OUT) :: nrrow REAL*4, INTENT(OUT) :: grid ! grid resolution [m] -LOGICAL, INTENT(OUT) :: igrens +LOGICAL, INTENT(OUT) :: igrens REAL*4, INTENT(OUT) :: z0_user ! roughness length specified by user [m] -INTEGER*4, INTENT(OUT) :: intpol -INTEGER*4, INTENT(OUT) :: ideh -LOGICAL, INTENT(OUT) :: igrid -LOGICAL, INTENT(OUT) :: checked -LOGICAL*4, INTENT(OUT) :: f_z0user -LOGICAL, INTENT(OUT) :: isec -INTEGER*4, INTENT(OUT) :: nsubsec ! number of sub-secondary species +INTEGER*4, INTENT(OUT) :: intpol +INTEGER*4, INTENT(OUT) :: ideh +LOGICAL, INTENT(OUT) :: igrid +LOGICAL, INTENT(OUT) :: checked +LOGICAL*4, INTENT(OUT) :: f_z0user +LOGICAL, INTENT(OUT) :: isec +INTEGER*4, INTENT(OUT) :: nsubsec ! number of sub-secondary species TYPE (TError), INTENT(OUT) :: error ! error handling record ! LOCAL VARIABLES -REAL*4 :: lower ! lower limit (is used for checking variables read) -REAL*4 :: upper ! upper limit (is used for checking variables read) +REAL*4 :: lower ! lower limit (is used for checking variables read) +REAL*4 :: upper ! upper limit (is used for checking variables read) CHARACTER*(512) :: str1 ! string value read from control file ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'// char (0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -166,13 +166,13 @@ SUBROUTINE ops_read_ctr(project, runid, year, icm, namco, amol1, gasv, idep, kde IF (.NOT. GetCheckedKey('DIFFCOEFF', 0., 1., gasv .AND. idep .AND. knatdeppar.EQ.3, dg, error)) GOTO 1000 IF (.NOT. GetKeyValue ('WASHOUT', gasv .AND. idep .AND. knatdeppar.EQ.3, irev, error)) GOTO 1000 -! Read chemical conversion rate vchemc; this can be either the string EMEP (meaning that we use conversion rate maps from the EMEP-model -> -! iopt_vchem = 1) or a fixed value of vchemc. +! Read chemical conversion rate vchemc; this can be either the string EMEP (meaning that we use conversion rate maps from the EMEP-model -> +! iopt_vchem = 1) or a fixed value of vchemc. ! A value of vchemc is only required for non-acidifying components (isec = false), because for acidifying components, we use either ! the EMEP maps or (if EMEP is not specified) an old chemical conversion rate parameterisation (iopt_vchem = 0; see OPS-doc). ! IF (.NOT. GetCheckedKey('CONVRATE', 'EMEP', 'EMEP', gasv .AND. isec, str1, error)) GOTO 1000 -call read_conv_rate(gasv,idep,isec,vchemc,iopt_vchem,error) -if (error%haserror) GOTO 1000 +call read_conv_rate(gasv,idep,isec,vchemc,iopt_vchem,error) +if (error%haserror) GOTO 1000 !!vchemc = MISVALNUM !!iopt_vchem = 0 @@ -183,9 +183,9 @@ SUBROUTINE ops_read_ctr(project, runid, year, icm, namco, amol1, gasv, idep, kde !! iopt_vchem = 1 !! else !! ! EMEP has been found, but is not needed: -!! call ErrorParam('CONVRATE EMEP can only be used for acidifying components SO2, NOx, NH3 ','', error) +!! call ErrorParam('CONVRATE EMEP can only be used for acidifying components SO2, NOx, NH3 ','', error) !! GOTO 1000 -!! endif +!! endif !!ENDIF !!If (iopt_vchem .eq. 0) THEN !! ! vchemc has not been set, read line again and extract vchemc (if required): @@ -195,17 +195,17 @@ SUBROUTINE ops_read_ctr(project, runid, year, icm, namco, amol1, gasv, idep, kde IF (.NOT. GetCheckedKey('LDCONVRATE', 0., 99.99, gasv .AND. idep .AND..NOT.isec, vchemv, error)) GOTO 1000 -! Secondary species are SO4, NO3_total, NH4; +! Secondary species are SO4, NO3_total, NH4; ! for NOx with EMEP chemical conversion, we have 3 sub-secondary species (HNO3, NO3_C (coarse in PM10-PM2.5), NO3_F (fine in PM2.5)): if (icm .eq. 2) then if (iopt_vchem .eq. 0) then ! Old OPS parameterisation; no information on fine and coarse NO3: - nsubsec = 2 - CNAME_SUBSEC(1:nsubsec) = (/'NO3_AER', 'HNO3' /) ! HNO3, NO3_aerosol (in PM10) + nsubsec = 2 else ! EMEP gives also a split between coarse and fine NO3: nsubsec = 4 - CNAME_SUBSEC(1:nsubsec) = (/'NO3_AER', 'HNO3', 'NO3_C', 'NO3_F' /) ! HNO3, NO3_aerosol (in PM10), NO3_coarse (in PM10-PM2.5), NO3_fine (in PM2.5) + CNAME_SUBSEC(3) = 'NO3_C' ! HNO3, NO3_aerosol (in PM10), NO3_coarse (in PM10-PM2.5), NO3_fine (in PM2.5) + CNAME_SUBSEC(4) = 'NO3_F' ! HNO3, NO3_aerosol (in PM10), NO3_coarse (in PM10-PM2.5), NO3_fine (in PM2.5) endif else ! SO4 and NH4 all in fine PM-fraction; no sub-species: @@ -217,7 +217,7 @@ SUBROUTINE ops_read_ctr(project, runid, year, icm, namco, amol1, gasv, idep, kde ! nsubsec = 0 !endif -! Read emission layer (emission file, user defined diurnal variation file, +! Read emission layer (emission file, user defined diurnal variation file, ! user defined particle size distribution file, emission trend factor, selected emission categories, ! selected emission countries) ! @@ -241,7 +241,7 @@ SUBROUTINE ops_read_ctr(project, runid, year, icm, namco, amol1, gasv, idep, kde IF (.NOT. GetCheckedKey('NROWS', 0, MAXROW, spgrid == 1, nrrow, error)) GOTO 1000 ! -! Read grid resolution, logical whether to use also points outside NL (spgrid = 0), +! Read grid resolution, logical whether to use also points outside NL (spgrid = 0), ! name of receptor file (spgrid = 2,3). ! For spgrid = 0,3, the grid resolution must be > 250 m; ! for other receptor types a 1 m resolution is the lower limit. @@ -265,7 +265,7 @@ SUBROUTINE ops_read_ctr(project, runid, year, icm, namco, amol1, gasv, idep, kde ! ! If z0_user = 0 -> read z0 from file ! If z0_user /= 0 -> z0_user is the user defined fixed z0-value -! f_z0user is TRUE if roughness length (z0) is user defined +! f_z0user is TRUE if roughness length (z0) is user defined ! f_z0user = NINT(10000. * z0_user) /= 0 IF (.NOT. GetCheckedKey('Z0FILE', .TRUE., .NOT.f_z0user, z0file, error)) GOTO 1000 @@ -280,7 +280,7 @@ SUBROUTINE ops_read_ctr(project, runid, year, icm, namco, amol1, gasv, idep, kde IF (.NOT. GetCheckedKey('METEOTYPE',0, 2, .TRUE., intpol, error)) GOTO 1000 IF (.NOT. GetCheckedKey('MTFILE', .TRUE., intpol /= 0, kname, error)) GOTO 1000 ! -! Read output layer (option for deposition unit, plot file, print file, option for printing grids, +! Read output layer (option for deposition unit, plot file, print file, option for printing grids, ! logical whether control file has been made by the GUI) ! IF (.NOT. GetCheckedKey('DEPUNIT', 1, NUNIT, .TRUE., ideh, error)) GOTO 1000 @@ -343,22 +343,22 @@ subroutine read_conv_rate(gasv,idep,isec,vchemc,iopt_vchem,error) ! CONVRATE EMEP is not needed; generate error if it is provided in input anyway: if (str1 .eq. 'EMEP') then if (.not. isec) then - call SetError('CONVRATE EMEP can only be used for acidifying components SO2, NOx, NH3 ', error) + call SetError('CONVRATE EMEP can only be used for acidifying components SO2, NOx, NH3 ', error) elseif (.not. idep) then - call SetError('CONVRATE EMEP can only be used if deposition/chemical conversion switched on', error) + call SetError('CONVRATE EMEP can only be used if deposition/chemical conversion switched on', error) else - call SetError('CONVRATE EMEP can only be used for gasuous components', error) + call SetError('CONVRATE EMEP can only be used for gasuous components', error) endif GOTO 1000 endif - endif + endif ENDIF If (iopt_vchem .eq. 0) THEN ! vchemc has not been set; read line again and extract vchemc (if required): backspace(fu_input); error%haserror = .false. IF (GetCheckedKey('CONVRATE', 0., 999., gasv .AND. idep .AND. .NOT.isec, vchemc, error)) then - + ! If 'CONVRATE value' is not required and a value is specified anyway, generate error: if (.not. (gasv .AND. idep .AND. .NOT.isec)) then if (error%haserror) then @@ -367,20 +367,20 @@ subroutine read_conv_rate(gasv,idep,isec,vchemc,iopt_vchem,error) continue ! is ok; no error else if (isec) then - call SetError('CONVRATE value cannot be specified for acidifying components SO2, NOx, NH3 ', error) + call SetError('CONVRATE value cannot be specified for acidifying components SO2, NOx, NH3 ', error) elseif (.not. idep) then - call SetError('CONVRATE value can only be specified if deposition/chemical conversion switched on', error) + call SetError('CONVRATE value can only be specified if deposition/chemical conversion switched on', error) else - call SetError('CONVRATE value can only be used for gasuous components', error) + call SetError('CONVRATE value can only be used for gasuous components', error) endif GOTO 1000 endif - endif + endif else - ! CONVRATE value is required but not found -> error + ! CONVRATE value is required but not found -> error if (vchemc .eq. MISVALNUM) then error%haserror = .false. - call SetError('CONVRATE must have a value ', error) + call SetError('CONVRATE must have a value ', error) endif endif ENDIF diff --git a/ops_read_emis.f90 b/ops_read_emis.f90 index da95dad..0208060 100644 --- a/ops_read_emis.f90 +++ b/ops_read_emis.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -28,7 +28,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Read source file with emissions and files with diurnal emission variations and particle size distributions. @@ -53,16 +53,16 @@ SUBROUTINE ops_read_emis(icm, gasv, ncatsel, catsel, nlandsel, landsel, numbron, IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_read_emis') ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: icm -LOGICAL, INTENT(IN) :: gasv -INTEGER*4, INTENT(IN) :: ncatsel -INTEGER*4, INTENT(IN) :: catsel(*) -INTEGER*4, INTENT(IN) :: nlandsel -INTEGER*4, INTENT(IN) :: landsel(*) +INTEGER*4, INTENT(IN) :: icm +LOGICAL, INTENT(IN) :: gasv +INTEGER*4, INTENT(IN) :: ncatsel +INTEGER*4, INTENT(IN) :: catsel(*) +INTEGER*4, INTENT(IN) :: nlandsel +INTEGER*4, INTENT(IN) :: landsel(*) ! SUBROUTINE ARGUMENTS - I/O @@ -81,7 +81,7 @@ SUBROUTINE ops_read_emis(icm, gasv, ncatsel, catsel, nlandsel, landsel, numbron, ! 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 +LOGICAL, INTENT(OUT) :: building_present1 ! at least one building is present in the source file ! LOCAL VARIABLES @@ -89,7 +89,7 @@ SUBROUTINE ops_read_emis(icm, gasv, ncatsel, catsel, nlandsel, landsel, numbron, INTEGER*4 :: usps ! maximum code uspmd distribution (dummy) ! SCCS-ID VARIABLE -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -109,15 +109,15 @@ SUBROUTINE ops_read_emis(icm, gasv, ncatsel, catsel, nlandsel, landsel, numbron, ENDIF IF (.NOT.gasv) THEN - ! - ! Read standard particle size distributions - ! + + ! Read standard particle size distributions + CALL read_variation(psdnam, 'F7.1', NPARTCLASS, 0, 'particle size distributions', .TRUE., pmd, ps, presentcode(:, 2), & & error) IF (error%haserror) GOTO 9999 - ! - ! Read user-defined particle size distributions (optionally) - ! + + ! Read user-defined particle size distributions (optionally) + IF (LEN_TRIM(uspsdnam) /= 0) THEN CALL read_variation(uspsdnam, 'F7.1', NPARTCLASS, 100, 'user-defined particle size distributions', .TRUE., uspmd, usps, & & presentcode(:,4), error) @@ -135,7 +135,7 @@ SUBROUTINE ops_read_emis(icm, gasv, ncatsel, catsel, nlandsel, landsel, numbron, OPEN(fu_scratch, STATUS = 'SCRATCH') ! -! Read, select and check sources +! Read, select and check sources ! CALL ops_read_source(icm, gasv, ncatsel, catsel, nlandsel, landsel, presentcode, numbron, building_present1, error) @@ -158,19 +158,19 @@ SUBROUTINE ops_read_emis(icm, gasv, ncatsel, catsel, nlandsel, landsel, numbron, ! ! Example of diurnal emission variations file: ! -! code 0-2 2-4 4-6 6-8 8-10 10-12 12-14 14-16 16-18 18-20 20-22 22-24 description +! code 0-2 2-4 4-6 6-8 8-10 10-12 12-14 14-16 16-18 18-20 20-22 22-24 description ! +000 100 100 100 100 100 100 100 100 100 100 100 100 Continuous emission ! +001 73 69 68 100 129 131 124 121 109 97 93 86 Average industrial activity ! +002 33 33 35 80 150 155 120 116 122 135 145 77 Average heating behaviour ! +003 24 16 23 150 175 121 127 154 190 112 60 48 Average traffic intensity ! Example of particle size distribution file: FS -! +! !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE read_variation(distnam, fmt, nrclass, normalvalue, compdesc, fraction, distrib, maxcode, presentcode, error) ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'read_variation') ! SUBROUTINE ARGUMENTS - INPUT @@ -178,20 +178,20 @@ SUBROUTINE read_variation(distnam, fmt, nrclass, normalvalue, compdesc, fraction CHARACTER*(*), INTENT(IN) :: fmt ! format of the numbers in distributions file INTEGER*4, INTENT(IN) :: nrclass ! number of distribution classes read each record INTEGER*4, INTENT(IN) :: normalvalue ! value used in normalisation, 0 if no normalisation - ! normalisation means that the sum of the variation is set to - ! normalvalue (e.g. 100 for a set of percentages or + ! normalisation means that the sum of the variation is set to + ! normalvalue (e.g. 100 for a set of percentages or ! 1200 for a set of 2-hourly percentages in a day) CHARACTER*(*), INTENT(IN) :: compdesc ! type of distributions (diurnal variation or particle size) LOGICAL, INTENT(IN) :: fraction ! whether conversion to fractions is required (instead of %) ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: distrib(nrclass,MAXDISTR) ! 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(MAXDISTR) ! which distribution codes are present TYPE (TError), INTENT(OUT) :: error ! error handling record ! LOCAL VARIABLES -INTEGER*4 :: distcode ! code used for distribution; +INTEGER*4 :: distcode ! code used for distribution; ! read from the first column of the distributions file. ! (|distcode| = index into 2nd dimension of distrib(nclass, MAXDISTR)) @@ -275,7 +275,7 @@ SUBROUTINE read_variation(distnam, fmt, nrclass, normalvalue, compdesc, fraction ENDIF ! ! Normalise any rows, where required. -! Normalisation means that the sum of the variation is set to normalvalue (e.g. 100 for a set of percentages or +! Normalisation means that the sum of the variation is set to normalvalue (e.g. 100 for a set of percentages or ! 1200 for a set of 2-hourly percentages in a day) IF (normalvalue > 0) THEN diff --git a/ops_read_meteo.f90 b/ops_read_meteo.f90 index 5994f3d..31e77b4 100644 --- a/ops_read_meteo.f90 +++ b/ops_read_meteo.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -28,7 +28,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Read meteo statistics. @@ -49,7 +49,7 @@ SUBROUTINE ops_read_meteo(intpol, jb, mb, idb, jt, mt, idt, uurtot, iseiz, zf, a IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_readmeteo') ! SUBROUTINE ARGUMENTS - INPUT @@ -58,37 +58,37 @@ SUBROUTINE ops_read_meteo(intpol, jb, mb, idb, jt, mt, idt, uurtot, iseiz, zf, a ! = 2? use meteo parameters from user specified meteo file ! SUBROUTINE ARGUMENTS - OUTPUT -INTEGER*4, INTENT(OUT) :: jb -INTEGER*4, INTENT(OUT) :: mb -INTEGER*4, INTENT(OUT) :: idb -INTEGER*4, INTENT(OUT) :: jt -INTEGER*4, INTENT(OUT) :: mt -INTEGER*4, INTENT(OUT) :: idt -REAL*4, INTENT(OUT) :: uurtot -INTEGER*4, INTENT(OUT) :: iseiz -REAL*4, INTENT(OUT) :: zf -REAL*4, INTENT(OUT) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) -REAL*4, INTENT(OUT) :: trafst(NTRAJ) -REAL*4, INTENT(OUT) :: gemre +INTEGER*4, INTENT(OUT) :: jb +INTEGER*4, INTENT(OUT) :: mb +INTEGER*4, INTENT(OUT) :: idb +INTEGER*4, INTENT(OUT) :: jt +INTEGER*4, INTENT(OUT) :: mt +INTEGER*4, INTENT(OUT) :: idt +REAL*4, INTENT(OUT) :: uurtot +INTEGER*4, INTENT(OUT) :: iseiz +REAL*4, INTENT(OUT) :: zf +REAL*4, INTENT(OUT) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) +REAL*4, INTENT(OUT) :: trafst(NTRAJ) +REAL*4, INTENT(OUT) :: gemre 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) :: 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) -REAL*4, INTENT(OUT) :: hourreg(NMETREG) +REAL*4, INTENT(OUT) :: cs(NTRAJ, NCOMP, NSTAB, NSEK, NMETREG) +REAL*4, INTENT(OUT) :: rainreg(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) +REAL*4, INTENT(OUT) :: hourreg(NMETREG) TYPE (TError), INTENT(OUT) :: error ! error handling record ! LOCAL VARIABLES INTEGER*4 :: iyr ! year of time stamp of meteo file; currently not used INTEGER*4 :: imon ! month of time stamp of meteo file; currently not used INTEGER*4 :: iday ! day of time stamp of meteo file; currently not used -REAL*4 :: xpos -REAL*4 :: ypos -REAL*4 :: z0_metreg1 ! rougness length of 1 meteo region [m] +REAL*4 :: xpos +REAL*4 :: ypos +REAL*4 :: z0_metreg1 ! rougness length of 1 meteo region [m] ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -96,7 +96,7 @@ SUBROUTINE ops_read_meteo(intpol, jb, mb, idb, jt, mt, idt, uurtot, iseiz, zf, a ! Note that astat is used to store the meteo parameters for one region (output of ops_readstexp); ! cs contains the meteo parameters for all regions (extra dimension NMETREG). ! -IF (intpol.EQ.0) THEN +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, z0_metreg, xreg, yreg, & & hourreg, error) @@ -134,29 +134,29 @@ SUBROUTINE ops_statfil(jb, mb, idb, jt, mt, idt, uurtot, iseiz, zf, astat, trafs REAL*4 :: XP(NMETREG) ! x-coordinate meteo regions in NL REAL*4 :: YP(NMETREG) ! y-coordinate meteo regions in NL ! (XP,YP)~ centre of circle that encompasses a meteo region. - ! (XP,YP) are used for interpolation of meteo parameters in a + ! (XP,YP) are used for interpolation of meteo parameters in a ! specific location -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_statfil') ! SUBROUTINE ARGUMENTS - OUTPUT -INTEGER*4, INTENT(OUT) :: jb -INTEGER*4, INTENT(OUT) :: mb -INTEGER*4, INTENT(OUT) :: idb -INTEGER*4, INTENT(OUT) :: jt -INTEGER*4, INTENT(OUT) :: mt -INTEGER*4, INTENT(OUT) :: idt -REAL*4, INTENT(OUT) :: uurtot -INTEGER*4, INTENT(OUT) :: iseiz -REAL*4, INTENT(OUT) :: zf -REAL*4, INTENT(OUT) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) -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) :: 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) -REAL*4, INTENT(OUT) :: hourreg(NMETREG) +INTEGER*4, INTENT(OUT) :: jb +INTEGER*4, INTENT(OUT) :: mb +INTEGER*4, INTENT(OUT) :: idb +INTEGER*4, INTENT(OUT) :: jt +INTEGER*4, INTENT(OUT) :: mt +INTEGER*4, INTENT(OUT) :: idt +REAL*4, INTENT(OUT) :: uurtot +INTEGER*4, INTENT(OUT) :: iseiz +REAL*4, INTENT(OUT) :: zf +REAL*4, INTENT(OUT) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) +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) :: 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) +REAL*4, INTENT(OUT) :: hourreg(NMETREG) TYPE (TError), INTENT(OUT) :: error ! error handling record ! LOCAL VARIABLES @@ -166,12 +166,12 @@ 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 :: xpos -REAL*4 :: ypos -REAL*4 :: z0_metreg1 ! roughness length of 1 meteo region [m] +REAL*4 :: xpos +REAL*4 :: ypos +REAL*4 :: z0_metreg1 ! roughness length of 1 meteo region [m] CHARACTER*512 :: nfile ! filename for meteo statistics file -! DATA +! DATA ! (XP,YP) are locations of region (~ centre of circle that encompasses region); ! (XP,YP) are used for interpolation of meteo parameters in a specific location. @@ -231,7 +231,7 @@ END SUBROUTINE ops_statfil !------------------------------------------------------------------------------------------------------------------------------- ! SUBROUTINE : ops_readstexp -! DESCRIPTION : This routine reads the climatology (meteo statistics) file and fills the meteodata array. +! 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, iyr, imon, iday, xpos, ypos, z0_metreg1, jt, mt, idt, & @@ -244,12 +244,12 @@ SUBROUTINE ops_readstexp(nfile, jb, mb, idb, gemre, iyr, imon, iday, xpos, ypos, IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_readstexp') INTEGER*4 :: ISCALE(NCOMP) ! OPS scalefactors for the different components in the climatology. - ! All meteo parameters are given as integers and have to be scaled - ! by 10, 100 or 1000 in order to get meaningful real values; + ! All meteo parameters are given as integers and have to be scaled + ! by 10, 100 or 1000 in order to get meaningful real values; ! e.g. wind speed in 0.1 m/s -> m/s ! SUBROUTINE ARGUMENTS - INPUT @@ -263,24 +263,24 @@ SUBROUTINE ops_readstexp(nfile, jb, mb, idb, gemre, iyr, imon, iday, xpos, ypos, 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 -REAL*4, INTENT(OUT) :: xpos -REAL*4, INTENT(OUT) :: ypos -REAL*4, INTENT(OUT) :: z0_metreg1 ! rougness length of 1 meteo region [m] +REAL*4, INTENT(OUT) :: xpos +REAL*4, INTENT(OUT) :: ypos +REAL*4, INTENT(OUT) :: z0_metreg1 ! rougness length of 1 meteo region [m] INTEGER*4, INTENT(OUT) :: jt ! end year (meteo statistics period) ("t" << tot = until) INTEGER*4, INTENT(OUT) :: mt ! end month (meteo statistics period) ("t" << tot = until) INTEGER*4, INTENT(OUT) :: idt ! end day (meteo statistics period) ("t" << tot = until) REAL*4, INTENT(OUT) :: uurtot ! total number of hours ("uur" = hour) -INTEGER*4, INTENT(OUT) :: iseiz -REAL*4, INTENT(OUT) :: zf -REAL*4, INTENT(OUT) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) -REAL*4, INTENT(OUT) :: trafst(NTRAJ) +INTEGER*4, INTENT(OUT) :: iseiz +REAL*4, INTENT(OUT) :: zf +REAL*4, INTENT(OUT) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) +REAL*4, INTENT(OUT) :: trafst(NTRAJ) TYPE (TError), INTENT(OUT) :: error ! error handling record ! LOCAL VARIABLES INTEGER*4 :: jtl ! four digit end year INTEGER*4 :: jbl ! four digit start year INTEGER*4 :: icomp ! index of meteo parameters -INTEGER*2 :: ishort(NSTAB*NSEK) ! meta data of meteo statistics file +INTEGER*2 :: ishort(NSTAB*NSEK) ! meta data of meteo statistics file ! DATA ! OPS scalefactors for the different components in the climatology. @@ -291,23 +291,23 @@ SUBROUTINE ops_readstexp(nfile, jb, mb, idb, gemre, iyr, imon, iday, xpos, ypos, ! 3. wind speed (at 10 m height) [m/s] ! 7. ratio effective dry deposition velocity over transport distance and average dry deposition velocity over transport distance for low sources [-] ! 8. ratio effective dry deposition velocity over transport distance and average dry deposition velocity over transport distance for high sources [-] -! 10. degree day (= 19-T for T < 12 degree C) (domestic heating coefficient) [degree C] +! 10. degree day (= 19-T for T < 12 degree C) (domestic heating coefficient) [degree C] ! 11. precipitation probability [] ! 12. length of rainfall period [] ! 13. rain intensity [] ! 15. wind speed power law coefficient [-] ! 19. friction velocity u* [m/s] ! 23. sensible heat flux H0 [W/m2] -! number 1 2 3 4/5/6 7/8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 +! number 1 2 3 4/5/6 7/8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 DATA ISCALE/ 1, 1, 10, 3*1, 2*100, 1, 10, 1000, 100, 100, 1, 100, 1, 1, 1, 1000, 1, 1, 1, 10, 1, 1, 1, 1/ !------------------------------------------------------------------------------------------------------------------------------- -! Read meta data into ishort and meteo parameters into astat +! Read meta data into ishort and meteo parameters into astat CALL ops_readdata(nfile, ishort, astat, error) IF (error%haserror) GOTO 9999 ! -! Fill meta data of meteo file +! Fill meta data of meteo file ! ! Start year, month, day @@ -353,7 +353,7 @@ SUBROUTINE ops_readstexp(nfile, jb, mb, idb, gemre, iyr, imon, iday, xpos, ypos, astat(:, icomp, :, :) = astat(:, icomp, :, :)/ISCALE(icomp) ENDDO ! -! Compute average precipitation amount [mm/h] +! Compute average precipitation amount [mm/h] ! gemre = SUM( astat(1, 1, :NSTAB, :NSEK) * astat(1, 11, :, :) * astat(1, 13, :, :)) / uurtot ! @@ -366,7 +366,7 @@ SUBROUTINE ops_readstexp(nfile, jb, mb, idb, gemre, iyr, imon, iday, xpos, ypos, ! Get time period (years, year, winter, summer or month) ! and set zf = interpolation factor between summer and winter (zf << "zomer fractie" = summer fraction) ! - + ! year_end > year_start + 1 -> multiple years, iseiz = 0 (long term) IF (jtl .GT. (jbl + 1)) THEN iseiz = 0 @@ -396,7 +396,7 @@ SUBROUTINE ops_readstexp(nfile, jb, mb, idb, gemre, iyr, imon, iday, xpos, ypos, ! all other cases -> iseiz = 4,5 (month) ELSE - + ! month in summer iseiz = 5 IF ((mb .GT. 3) .AND. (mb .LT. 10)) THEN @@ -430,7 +430,7 @@ SUBROUTINE ops_readdata(nfile, ishort, astat, error) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_readdata') ! SUBROUTINE ARGUMENTS - INPUT @@ -438,7 +438,7 @@ SUBROUTINE ops_readdata(nfile, ishort, astat, error) ! SUBROUTINE ARGUMENTS - OUTPUT INTEGER*2, INTENT(OUT) :: ishort(NSTAB*NSEK) ! meta data of meteo statistics file -REAL*4, INTENT(OUT) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) +REAL*4, INTENT(OUT) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) TYPE (TError), INTENT(OUT) :: error ! error handling record ! LOCAL VARIABLES @@ -451,10 +451,10 @@ SUBROUTINE ops_readdata(nfile, ishort, astat, error) INTEGER*4 :: recl ! record length ! FUNCTIONS -LOGICAL :: ops_checkmeteo ! +LOGICAL :: ops_checkmeteo !------------------------------------------------------------------------------------------------------------------------------- ! -! Read meta data from meteo statistics file +! Read meta data from meteo statistics file ! recl = NSTAB*NSEK*2 @@ -467,7 +467,7 @@ SUBROUTINE ops_readdata(nfile, ishort, astat, error) GOTO 9999 ENDIF -! Read from direct access file +! Read from direct access file irec = 1 READ (fu_klim, IOSTAT = ierr, REC = irec) ishort @@ -549,7 +549,7 @@ FUNCTION ops_checkmeteo(value, valueread, paramname, error) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_checkmeteo') ! SUBROUTINE ARGUMENTS - INPUT diff --git a/ops_read_source.f90 b/ops_read_source.f90 index cbcea4c..cb9ee9f 100644 --- a/ops_read_source.f90 +++ b/ops_read_source.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -28,11 +28,11 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Read source file with emissions. -! Emissions are read from a source file and emissions for selected emission categories and countries +! 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 agenerate an error. ! EXIT CODES : @@ -46,24 +46,24 @@ SUBROUTINE ops_read_source(icm, gasv, ncatsel, catsel, nlandsel, landsel, presen USE m_error USE m_commonfile, only: fu_scratch, fu_bron -USE m_commonconst, only: EPS_DELTA, MAXDISTR +USE m_commonconst, only: EPS_DELTA, MAXDISTR USE m_ops_emis USE m_ops_building IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_read_source') ! SUBROUTINE ARGUMENTS - INPUT INTEGER*4, INTENT(IN) :: icm ! component nummer -LOGICAL, INTENT(IN) :: gasv ! component is gasuous +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 +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 @@ -72,7 +72,7 @@ SUBROUTINE ops_read_source(icm, gasv, ncatsel, catsel, nlandsel, landsel, presen ! 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 +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 @@ -85,12 +85,12 @@ SUBROUTINE ops_read_source(icm, gasv, ncatsel, catsel, nlandsel, landsel, presen INTEGER*4 :: ierr ! error value LOGICAL*4 :: end_of_file ! end of file has been reached 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 :: 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]) LOGICAL :: country_selected ! emission country has been selected LOGICAL :: category_selected ! emission category has been selected @@ -103,7 +103,7 @@ SUBROUTINE ops_read_source(icm, gasv, ncatsel, catsel, nlandsel, landsel, presen LOGICAL :: check_psd ! check whether particle size distribution has been read !------------------------------------------------------------------------------------------------------------------------------- - 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 + 50 FORMAT (i8, 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 ! Initialisation: end_of_file = .FALSE. @@ -114,12 +114,12 @@ SUBROUTINE ops_read_source(icm, gasv, ncatsel, catsel, nlandsel, landsel, presen ! 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 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 -! Read source file until end of file: +! Read source file until end of file: DO WHILE (.NOT. end_of_file) ! Do not check particle size distribution for gaseous component: @@ -129,15 +129,15 @@ SUBROUTINE ops_read_source(icm, gasv, ncatsel, catsel, nlandsel, landsel, presen 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 ! Copy valid (emission > 0) and selected sources to scratch file: IF (qob .GT. EPS_DELTA) THEN - + 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 diff --git a/ops_reken.f90 b/ops_reken.f90 index 924b375..d32eee9 100644 --- a/ops_reken.f90 +++ b/ops_reken.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! USAGE : @@ -41,15 +41,15 @@ !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, iopt_vchem, 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, gym, xm, ym, zm, frac, nh3bg_rcp, so2bg_rcp, rhno3_rcp, & + & nrrcp, ircp, gxm, gym, xm, ym, zm, frac, nh3bg_rcp, so2bg_rcp, rhno3_rcp, & & bqrv, bqtr, bx, by, bdiam, bsterkte, bwarmte, bhoogte, & - & bsigmaz, bD_stack, bV_stack, bTs_stack, bemis_horizontal, bbuilding, buildingEffect, & + & 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, vchem2, 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, & - & precip, routpri, dispg, error) + & precip, routpri, dispg, error) !DEC$ ATTRIBUTES DLLEXPORT:: ops_reken @@ -66,29 +66,29 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, iopt_vchem, vchemv, IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_reken') ! SUBROUTINE ARGUMENTS - INPUT LOGICAL, INTENT(IN) :: idep ! TRUE if deposition is modelled LOGICAL, INTENT(IN) :: isec ! TRUE if component is either SO2, NOx or NH3 (and a secondary component is present) -INTEGER*4, INTENT(IN) :: icm ! component number used in OPS - ! 1 SO2 - ! 2 NO2 - ! 3 NH3 +INTEGER*4, INTENT(IN) :: icm ! component number used in OPS + ! 1 SO2 + ! 2 NO2 + ! 3 NH3 ! 24 PM LOGICAL, INTENT(IN) :: gasv ! TRUE if component is a gas -INTEGER*4, INTENT(IN) :: intpol ! option for meteo interpolation +INTEGER*4, INTENT(IN) :: intpol ! option for meteo interpolation ! 0 interpolate between all meteo regions at specified location ! 1 use meteo parameters from user specified meteo region ! 2? use meteo parameters from user specified meteo file REAL*4, INTENT(IN) :: vchemc ! chemical conversion rate, independent of light [%/h] -INTEGER*4, INTENT(IN) :: iopt_vchem ! option for chemical conversion rate (0 = old OPS, 1 = EMEP) +INTEGER*4, INTENT(IN) :: iopt_vchem ! option for chemical conversion rate (0 = old OPS, 1 = EMEP) REAL*4, INTENT(IN) :: vchemv ! chemical conversion rate, dependent on light [%/h] INTEGER*4, INTENT(IN) :: dv ! maximum code diurnal emission variation dverl REAL*4, INTENT(IN) :: amol1 ! molar mass primary component [g/mol] REAL*4, INTENT(IN) :: amol2 ! molar mass secondary component [g/mol] -REAL*4, INTENT(IN) :: amol21 ! (molar mass secondary component)/(molar mass primary component) [-] +REAL*4, INTENT(IN) :: amol21 ! (molar mass secondary component)/(molar mass primary component) [-] REAL*4, INTENT(IN) :: ar ! proportionality constant in relation [OH] = ar Qr, with Qr = global radiation in W/m2 [(cm3 m2)/(molec W2)], see Egmond en Kesseboom (1983) REAL*4, INTENT(IN) :: rno2nox ! season dependent component of [NO2]/[NOx] ratio [-] REAL*4, INTENT(IN) :: ecvl(NSTAB, NTRAJ, *) ! average diurnal emission variation for each stability/distance class @@ -99,50 +99,50 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, iopt_vchem, vchemv, ! knatdeppar = 1: read wdeppar = scavenging coefficient [%/h] ! knatdeppar = 2: read wdeppar = scavenging ratio, i.e. average ratio if rainwater concentrations and air concentration [-] ! knatdeppar = 3: if secondary components are present [SO2, NO2, NH3]. Wash-out and rain-out parameters are fixed in the OPS code (ops_init) [-] -INTEGER*4, INTENT(IN) :: mb ! start month of meteo statistics period ("b" << begin = start) -REAL*4, INTENT(IN) :: ugmoldep ! conversion factor from ug/m2/h to each of the deposition units in DEPUNITS -REAL*4, INTENT(IN) :: dg ! diffusion coefficient in air [cm^2/s] -LOGICAL, INTENT(IN) :: irev ! TRUE for reversible wash-out -REAL*4, INTENT(IN) :: scavcoef ! scavenging rate [%/h] +INTEGER*4, INTENT(IN) :: mb ! start month of meteo statistics period ("b" << begin = start) +REAL*4, INTENT(IN) :: ugmoldep ! conversion factor from ug/m2/h to each of the deposition units in DEPUNITS +REAL*4, INTENT(IN) :: dg ! diffusion coefficient in air [cm^2/s] +LOGICAL, INTENT(IN) :: irev ! TRUE for reversible wash-out +REAL*4, INTENT(IN) :: scavcoef ! scavenging rate [%/h] REAL*4, INTENT(IN) :: koh ! second order reaction rate constant of reaction NO2 + OH -> HNO3 [cm3/(molec s)] REAL*4, INTENT(IN) :: croutpri ! (wash-out + rain-out) ratio primary component, default value without correction for background concentration, season, stability class [-] ! icm = 1 (SO2): croutpri = wash out ratio at an N/S ratio of 1 ! icm = 2 (NOx): croutpri = wash out ratio at an NO2/NOx ratio of 1 ! icm = 3 (NH3): croutpri = wash out ratio (no correction) REAL*4, INTENT(IN) :: rcno ! surface resistance Rc for NO [s/m] -REAL*4, INTENT(IN) :: rhno2 ! ratio [HNO2]/[NOx] -REAL*4, INTENT(IN) :: rchno3 ! surface resistance Rc for HNO3 [s/m] -INTEGER*4, INTENT(IN) :: nrrcp ! number of receptor points +REAL*4, INTENT(IN) :: rhno2 ! ratio [HNO2]/[NOx] +REAL*4, INTENT(IN) :: rchno3 ! surface resistance Rc for HNO3 [s/m] +INTEGER*4, INTENT(IN) :: nrrcp ! number of receptor points INTEGER*4, INTENT(IN) :: ircp ! index of receptorpoint REAL*4, INTENT(IN) :: gxm ! x-coordinate of receptors (lon-lat) [degrees] REAL*4, INTENT(IN) :: gym ! y-coordinate of receptors (lon-lat) [degrees] REAL*4, INTENT(IN) :: xm ! x-coordinate of receptor points (RDM) REAL*4, INTENT(IN) :: ym ! y-coordinate of receptor points (RDM) REAL*4, INTENT(IN) :: zm ! z-coordinate of receptor points (RDM) -REAL*4, INTENT(IN) :: frac ! fraction of grid cell inside NL -REAL*4, INTENT(IN) :: nh3bg_rcp ! NH3 background concentration (used in DEPAC) [ug/m3] -REAL*4, INTENT(IN) :: so2bg_rcp ! SO2 background concentration (used in DEPAC) [ug/m3] -REAL*4, INTENT(IN) :: rhno3_rcp ! ratio [HNO3]/[NO3]_total at receptor points, [NO3]_total = [HNO3] + [NO3_aerosol] +REAL*4, INTENT(IN) :: frac ! fraction of grid cell inside NL +REAL*4, INTENT(IN) :: nh3bg_rcp ! NH3 background concentration (used in DEPAC) [ug/m3] +REAL*4, INTENT(IN) :: so2bg_rcp ! SO2 background concentration (used in DEPAC) [ug/m3] +REAL*4, INTENT(IN) :: rhno3_rcp ! ratio [HNO3]/[NO3]_total at receptor points, [NO3]_total = [HNO3] + [NO3_aerosol] REAL*4, INTENT(IN) :: bqrv ! source strength of space heating source (rv << "ruimteverwarming" = space heating) [g/s] REAL*4, INTENT(IN) :: bqtr ! source strength of traffic source [g/s] -INTEGER*4, INTENT(IN) :: bx ! x-coordinate of source -INTEGER*4, INTENT(IN) :: by ! y-coordinate of source -REAL*4, INTENT(IN) :: bdiam ! source diameter [m]; if bdiam < 0 -> circular source, bdiam > 0 -> square sourc -REAL*4, INTENT(IN) :: bsterkte ! source strength [g/s] -REAL*4, INTENT(IN) :: bwarmte ! heat content of source [MW] -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] +INTEGER*4, INTENT(IN) :: bx ! x-coordinate of source +INTEGER*4, INTENT(IN) :: by ! y-coordinate of source +REAL*4, INTENT(IN) :: bdiam ! source diameter [m]; if bdiam < 0 -> circular source, bdiam > 0 -> square sourc +REAL*4, INTENT(IN) :: bsterkte ! source strength [g/s] +REAL*4, INTENT(IN) :: bwarmte ! heat content of source [MW] +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] +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) :: 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 - ! bdegr < 0 -> user-defined particle size distribution uspmd + ! bdegr < 0 -> user-defined particle size distribution uspmd REAL*4, INTENT(IN) :: z0_src ! roughness length at source; from z0-map [m] REAL*4, INTENT(IN) :: z0_tra ! roughness length representative for trajectory [m] REAL*4, INTENT(IN) :: z0_rcp ! roughness length at receptor; from z0-map [m] @@ -154,37 +154,37 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, iopt_vchem, vchemv, REAL*4, INTENT(IN) :: so2bgtra ! SO2 background concentration, trajectory averaged [ppb] REAL*4, INTENT(IN) :: no2bgtra ! NO2 background concentration, trajectory averaged [ppb] REAL*4, INTENT(IN) :: nh3bgtra ! NH3 background concentration, trajectory averaged [ppb] -type(Tvchem), INTENT(INOUT) :: vchem2 ! +type(Tvchem), INTENT(INOUT) :: vchem2 INTEGER*4, INTENT(IN) :: maxidx ! max. number of particle classes (= 1 for gas) -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 +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 + ! spgrid = 1: rectangular regular grid of receptors, user defined ! spgrid = 2: receptors at specific locations, read from file ! spgrid = 3: receptors at user specific regular grid, not necessarily rectangular -REAL*4, INTENT(IN) :: grid ! grid resolution [m] -LOGICAL, INTENT(IN) :: subbron ! whether to create "subbrons" (sub-sources inside a area source) and "subareas" (sub receptors inside a grid cell) or not +REAL*4, INTENT(IN) :: grid ! grid resolution [m] +LOGICAL, INTENT(IN) :: subbron ! whether to create "subbrons" (sub-sources inside a area source) and "subareas" (sub receptors inside a grid cell) or not REAL*4, INTENT(IN) :: uurtot ! total number of hours in meteo statistics period ("uur"= hour) [hours] REAL*4, INTENT(IN) :: routsec ! in-cloud (rain-out) scavenging ratio for secondary component ! SUBROUTINE ARGUMENTS - I/O (INOUT) -REAL*4, INTENT(INOUT) :: rc ! surface resistance Rc [s/m] -REAL*8, INTENT(INOUT) :: somvnsec(NPARTCLASS) ! summed wet deposition flux secondary component [ug/m2/h] +REAL*4, INTENT(INOUT) :: rc ! surface resistance Rc [s/m] +REAL*8, INTENT(INOUT) :: somvnsec(NPARTCLASS) ! summed wet deposition flux secondary component [ug/m2/h] REAL*8, INTENT(INOUT) :: telvnsec(NPARTCLASS) ! summed deposited mass per area for wet deposition of secondary component [ug/m2] -REAL*8, INTENT(INOUT) :: vvchem(NPARTCLASS) ! summed chemical conversion rate [%/h] +REAL*8, INTENT(INOUT) :: vvchem(NPARTCLASS) ! summed chemical conversion rate [%/h] REAL*8, INTENT(INOUT) :: vtel(NPARTCLASS) ! weighing factors for averaging vvchem (i.e. deposited mass) -REAL*8, INTENT(INOUT) :: somvnpri(NPARTCLASS) ! summed wet deposition flux primary component [ug/m2/h] +REAL*8, INTENT(INOUT) :: somvnpri(NPARTCLASS) ! summed wet deposition flux primary component [ug/m2/h] REAL*8, INTENT(INOUT) :: telvnpri(NPARTCLASS) ! summed deposited mass per area for wet deposition of primary component [ug/m2] -DOUBLE PRECISION, INTENT(INOUT) :: ddepri(nrrcp,NPARTCLASS) ! dry deposition of primary component at receptor points [mol/ha/y] +DOUBLE PRECISION, INTENT(INOUT) :: ddepri(nrrcp,NPARTCLASS) ! dry deposition of primary component at receptor points [mol/ha/y] REAL*8, INTENT(INOUT) :: sdrypri(NPARTCLASS) ! summed dry deposition of primary component [ug/m2/h] REAL*8, INTENT(INOUT) :: snatpri(NPARTCLASS) ! summed wet deposition of primary component [ug/m2/h] (<< "nat" = wet) REAL*8, INTENT(INOUT) :: sdrysec(NPARTCLASS) ! summed dry deposition of secondary component [ug/m2/h] REAL*8, INTENT(INOUT) :: snatsec(NPARTCLASS) ! summed wet deposition of secondary component [ug/m2/h] (<< "nat" = wet) -DOUBLE PRECISION, INTENT(INOUT) :: cpri(nrrcp,NPARTCLASS) ! concentration of primary component at receptor points [ug/m3] -DOUBLE PRECISION, INTENT(INOUT) :: csec(nrrcp,NPARTCLASS) ! concentration of secondary component ar receptor points [ug/m3] -DOUBLE PRECISION, INTENT(INOUT) :: drydep(nrrcp,NPARTCLASS) ! dry deposition at receptor points [mol/ha/y] -DOUBLE PRECISION, INTENT(INOUT) :: wetdep(nrrcp,NPARTCLASS) ! wet deposition at receptor points ["depeh"] +DOUBLE PRECISION, INTENT(INOUT) :: cpri(nrrcp,NPARTCLASS) ! concentration of primary component at receptor points [ug/m3] +DOUBLE PRECISION, INTENT(INOUT) :: csec(nrrcp,NPARTCLASS) ! concentration of secondary component ar receptor points [ug/m3] +DOUBLE PRECISION, INTENT(INOUT) :: drydep(nrrcp,NPARTCLASS) ! dry deposition at receptor points [mol/ha/y] +DOUBLE PRECISION, INTENT(INOUT) :: wetdep(nrrcp,NPARTCLASS) ! wet deposition at receptor points ["depeh"] REAL*4, INTENT(INOUT) :: astat(NTRAJ,NCOMP,NSTAB,NSEK) ! meteo statistics for each distance class, stability/mixing height class, wind direction sector ! 1. number of hours for which a certain combination of classes has occurred [hours] ! 2. maximal mixing height over transport distance [m] @@ -192,20 +192,20 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, iopt_vchem, vchemv, ! 4. boundary layer resistance Rb for SO2 [s/m] ! 5. aerodynamic resistance 4 m + boundary layer resistance [s/m] ! 6. aerodynamic resistance 50 m + boundary layer resistance [s/m] - ! 7. ratio effective dry deposition velocity over transport distance and + ! 7. ratio effective dry deposition velocity over transport distance and ! average dry deposition velocity over transport distance for low sources [-] ! See OPS-doc/meteo; bookmark correction_factor_deposition_velocity - ! 8. ratio effective dry deposition velocity over transport distance and + ! 8. ratio effective dry deposition velocity over transport distance and ! average dry deposition velocity over transport distance for high sources [-] ! See OPS-doc/meteo; bookmark correction_factor_deposition_velocity ! 9. effective travel distance [km] - ! 10. degree day or domestic heating coefficient (= 19-T for T < 12 degree C) [degree C] + ! 10. degree day or domestic heating coefficient (= 19-T for T < 12 degree C) [degree C] ! 11. precipitation probability [-] ! 12. length of rainfall period [hours] ! 13. rain intensity [mm/h] ! 14. global radiation [J/cm2/h] ! 15. wind speed power law coefficient [-] - ! 16. surface resistance Rc for SO2 [s/m] + ! 16. surface resistance Rc for SO2 [s/m] ! 17. percentage of total hours that certain stability/mixing height class occurs per 2 hour block, source oriented [%] ! 18. percentage of total hours that certain stability/mixing height class occurs per 2 hour block, receptor oriented [%] ! 19. friction velocity u* [m/s] @@ -218,146 +218,146 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, iopt_vchem, vchemv, ! 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 - +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) :: 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 [-] ! LOCAL VARIABLES INTEGER*4 :: istab ! teller over stabiliteitsklassen INTEGER*4 :: kdeel ! teller over deeltjesklassen -INTEGER*4 :: ndone ! -INTEGER*4 :: itra ! -INTEGER*4 :: idgr ! -INTEGER*4 :: rond ! -INTEGER*4 :: iwd ! -INTEGER*4 :: ibtg ! -INTEGER*4 :: isek ! +INTEGER*4 :: ndone +INTEGER*4 :: itra +INTEGER*4 :: idgr +INTEGER*4 :: rond +INTEGER*4 :: iwd +INTEGER*4 :: ibtg +INTEGER*4 :: isek INTEGER*4 :: isekt ! uitvoer stat_parexp INTEGER*4 :: nk ! number of sub receptors (needed for grid averaged concentrations) -INTEGER*4 :: nr ! -INTEGER*4 :: mrcp ! -INTEGER*4 :: nrcp ! +INTEGER*4 :: nr +INTEGER*4 :: mrcp +INTEGER*4 :: nrcp INTEGER*4 :: kk ! number of sub area sources -INTEGER*4 :: nb ! -INTEGER*4 :: karea ! -INTEGER*4 :: larea ! +INTEGER*4 :: nb +INTEGER*4 :: karea +INTEGER*4 :: larea REAL*4 :: aind ! voortgangsindicator -REAL*4 :: htot ! -REAL*4 :: c ! -REAL*4 :: ueff ! wind speed at effective transport height heff; +REAL*4 :: htot +REAL*4 :: c +REAL*4 :: ueff ! wind speed at effective transport height heff; ! for short distances heff = plume height; ! for large distances heff = 1/2 mixing height; ! heff is interpolated for intermediate distances. REAL*4 :: rations ! trajectory verhouding N/S -REAL*4 :: qbron ! -REAL*4 :: qtr ! -REAL*4 :: qruim ! -REAL*4 :: grad ! -REAL*4 :: qob ! -REAL*4 :: qww ! -REAL*4 :: hbron ! -REAL*4 :: percvk ! -REAL*4 :: grof ! -REAL*4 :: cgt ! +REAL*4 :: qbron +REAL*4 :: qtr +REAL*4 :: qruim +REAL*4 :: grad +REAL*4 :: qob +REAL*4 :: qww +REAL*4 :: hbron +REAL*4 :: percvk +REAL*4 :: grof +REAL*4 :: cgt REAL*4 :: cgt_z ! hoogte afhankelijkelijke cgt -REAL*4 :: x ! -REAL*4 :: y ! -REAL*4 :: diam ! -REAL*4 :: diameter ! -REAL*4 :: szopp ! +REAL*4 :: x +REAL*4 :: y +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 +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 :: qrv +REAL*4 :: virty +REAL*4 :: consec 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 :: radius +REAL*4 :: uster_metreg_rcp REAL*4 :: temp_C ! temperature at height zmet_T [C] -REAL*4 :: shear ! -REAL*4 :: ol_metreg_rcp ! -REAL*4 :: h0 ! -REAL*4 :: hum ! -REAL*4 :: rcno2d ! -REAL*4 :: rcnh3d ! -REAL*4 :: rcaerd ! -REAL*4 :: vw10 ! -REAL*4 :: pcoef ! -REAL*4 :: htt ! -REAL*4 :: aant ! -REAL*4 :: xl ! -REAL*4 :: rb ! -REAL*4 :: rbm ! -REAL*4 :: ra4 ! -REAL*4 :: ra4m ! -REAL*4 :: ra50 ! -REAL*4 :: ra50m ! -REAL*4 :: xvglbr ! -REAL*4 :: xvghbr ! -REAL*4 :: xloc ! -REAL*4 :: xl100 ! -REAL*4 :: rad ! -REAL*4 :: rcso2 ! -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 ! +REAL*4 :: shear +REAL*4 :: ol_metreg_rcp +REAL*4 :: h0 +REAL*4 :: hum +REAL*4 :: rcno2d +REAL*4 :: rcnh3d +REAL*4 :: rcaerd +REAL*4 :: vw10 +REAL*4 :: pcoef +REAL*4 :: htt +REAL*4 :: aant +REAL*4 :: xl +REAL*4 :: rb +REAL*4 :: rbm +REAL*4 :: ra4 +REAL*4 :: ra4m +REAL*4 :: ra50 +REAL*4 :: ra50m +REAL*4 :: xvglbr +REAL*4 :: xvghbr +REAL*4 :: xloc +REAL*4 :: xl100 +REAL*4 :: rad +REAL*4 :: rcso2 +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 REAL*4 :: aksek(NSEK) ! .... (dummy output van ops_statparexp) REAL*4 :: uster_rcp ! friction velocity at receptor; for z0 at receptor [m/s] -REAL*4 :: ol_rcp ! Monin-Obukhov length at receptor; for z0 at receptor [m/s] -REAL*4 :: uster_src ! -REAL*4 :: ol_src ! -REAL*4 :: uster_tra ! -REAL*4 :: ol_tra ! -REAL*4 :: uh ! -REAL*4 :: zu ! -REAL*4 :: onder ! -REAL*4 :: xlm ! -REAL*4 :: onderm ! -REAL*4 :: qbpri ! -REAL*4 :: qsec ! -REAL*4 :: sigz ! -REAL*4 :: ccc ! undepleted concentration including part above mixing layer; +REAL*4 :: ol_rcp ! Monin-Obukhov length at receptor; for z0 at receptor [m/s] +REAL*4 :: uster_src +REAL*4 :: ol_src +REAL*4 :: uster_tra +REAL*4 :: ol_tra +REAL*4 :: uh +REAL*4 :: zu +REAL*4 :: onder +REAL*4 :: xlm +REAL*4 :: onderm +REAL*4 :: qbpri +REAL*4 :: qsec +REAL*4 :: sigz +REAL*4 :: ccc ! undepleted concentration including part above mixing layer; ! is needed for e.g. wet deposition. -REAL*4 :: rcsec ! -REAL*4 :: rc_sec_rcp ! -REAL*4 :: rb_rcp ! -REAL*4 :: ra50_rcp ! -REAL*4 :: raz_rcp ! -REAL*4 :: rc_rcp ! -REAL*4 :: ra4_rcp ! -REAL*4 :: vg50_rcp ! -REAL*4 :: pr ! +REAL*4 :: rcsec +REAL*4 :: rc_sec_rcp +REAL*4 :: rb_rcp +REAL*4 :: ra50_rcp +REAL*4 :: raz_rcp +REAL*4 :: rc_rcp +REAL*4 :: ra4_rcp +REAL*4 :: vg50_rcp +REAL*4 :: pr REAL*4 :: utr ! average wind speed over the trajectory (m/s) -REAL*4 :: vchem ! -REAL*4 :: vg50trans ! -REAL*4 :: vgpart ! -REAL*4 :: rkc ! -REAL*4 :: ri ! -REAL*4 :: twt ! -REAL*4 :: vnatpri ! -REAL*4 :: cq2 ! -REAL*4 :: cdn ! -REAL*4 :: cch ! -REAL*4 :: cratio ! -REAL*4 :: rhno3 ! -REAL*4 :: rrno2nox ! -REAL*4 :: vchemnh3 ! -REAL*4 :: dx ! -REAL*4 :: dy ! -REAL*4 :: dxsub ! -REAL*4 :: dysub ! -REAL*4 :: gbx ! -REAL*4 :: gby ! +REAL*4 :: vchem +REAL*4 :: vg50trans +REAL*4 :: vgpart +REAL*4 :: rkc +REAL*4 :: ri +REAL*4 :: twt +REAL*4 :: vnatpri +REAL*4 :: cq2 +REAL*4 :: cdn +REAL*4 :: cch +REAL*4 :: cratio +REAL*4 :: rhno3 +REAL*4 :: rrno2nox +REAL*4 :: vchemnh3 +REAL*4 :: dx +REAL*4 :: dy +REAL*4 :: dxsub +REAL*4 :: dysub +REAL*4 :: gbx +REAL*4 :: gby REAL*4 :: rctra_0 REAL*4 :: rctra_50 REAL*4 :: rclocal @@ -375,12 +375,12 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, iopt_vchem, vchemv, LOGICAL :: z0found ! Wel of geen z0 gevonden LOGICAL :: depudone ! Wel of niet ops_depu aangeroepen ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! ! -! Generate precipitation field for this receptor. +! Generate precipitation field for this receptor. ! Can be used to derive concentration in rainwater from deposition flux, ! in order to compare this rainwater concentration with measurements. ! @@ -396,32 +396,32 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, iopt_vchem, vchemv, diam = abs(bdiam) IF (bdiam < 0) rond = 1 ! -! Decide whether we need sub-receptors; they are not needed in case of user-specified receptor locations (spgrid = 2), +! Decide whether we need sub-receptors; they are not needed in case of user-specified receptor locations (spgrid = 2), ! but only for gridded receptors (in order to obtain an averaged grid-value). -! If the current source is an area source with the same diameter as the receptor grid resolution (diam = grid), +! If the current source is an area source with the same diameter as the receptor grid resolution (diam = grid), ! concentration gradients of the source are relatively small and no sub receptors are needed. Note that in this case, ! we also subdivide the area source into several sub-area sources. ! Also check the command line argument subbron. -! - inc_rcp = spgrid /= 2 .AND. diam /= grid +! + inc_rcp = spgrid /= 2 .AND. diam /= grid IF (inc_rcp .AND. subbron) THEN ! ! Compute x- and y-distance between receptor and source ! dx = xm - bx dy = ym - by -! +! ! If source and receptor are close, we have strong gradients; -! low source -> high concentration gradients -> many sub receptors -! small diameter -> point source -> high concentration gradients -> many sub receptors +! low source -> high concentration gradients -> many sub receptors +! small diameter -> point source -> high concentration gradients -> many sub receptors ! IF (abs(dx) <= grid*0.5 .AND. abs(dy) <= grid*0.5) THEN nk = grid/(bhoogte*20 + diam) ! ! If source and receptor are far from each other, we have less strong gradients; -! small distance between source and receptor -> high concentration gradients -> many sub receptors -! low source -> high concentration gradients -> many sub receptors -! small diameter -> point source -> high concentration gradients -> many sub receptors +! small distance between source and receptor -> high concentration gradients -> many sub receptors +! low source -> high concentration gradients -> many sub receptors +! small diameter -> point source -> high concentration gradients -> many sub receptors ! maximal 4 in 1/2 the grid cell -> 8*8 = 64 ! Note: for sources having geographical coordinates (IGEO = 1), the distance for receptors in NL is so large that nk = 0 ! @@ -429,7 +429,7 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, iopt_vchem, vchemv, nk = grid/(sqrt(dx**2+dy**2) + diam + bhoogte*10)*2 nk = min0(nk,4) ! This (4) is an arbitrary limit ENDIF -! +! ! Compute nr = number of sub receptors within a grid cell; ! maximal (128*2+1)**2 = 66049 sub receptors. ! @@ -477,7 +477,7 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, iopt_vchem, vchemv, ELSE kk = int(diam/(sqrt(dxsub**2+dysub**2) + 0.1)*2) ENDIF -! +! ! Compute nb = number of sub area sources; ! maximal (32*2+1)**2 = 4225 sub receptors. ! @@ -490,7 +490,7 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, iopt_vchem, vchemv, ! !++++++ Loop over sub-area sources ++++++++++++++++++++++++ ! -! Simulate an area source by a (large) number of small area sources. +! Simulate an area source by a (large) number of small area sources. ! Note: the next loop is carried out only once in case of a point source (kk=0) ! DO karea = -kk,kk @@ -514,14 +514,14 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, iopt_vchem, vchemv, CALL ops_par_chem(icm, iopt_vchem, isek, so2sek, no2sek, so2bgtra, no2bgtra, nh3bgtra, vchem2, 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 + 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 ++++++++++++++++++++++++ ! - DO istab = 1, NSTAB - + DO istab = 1, NSTAB + ! Compute source radius radius = diameter/2. ! @@ -553,10 +553,10 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, iopt_vchem, vchemv, h0 = 1. ENDIF ! -! If combination of stability, distance and wind direction class occurs +! If combination of stability, distance and wind direction class occurs ! IF (percvk > EPS_DELTA) THEN -! +! ! Skip if point source and receptor coincide ! IF (.NOT. ((ABS(disxx) <= EPS_DELTA) .AND. (ABS(diameter) <= EPS_DELTA))) THEN @@ -576,14 +576,14 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, iopt_vchem, vchemv, ! Continue if source strength > 0 ! IF (qbron > (0. + EPS_DELTA)) THEN - + ! Store parameters xl, onder, rb, ra50 and ra4 for further use xlm = xl onderm = onder rbm = rb ! 960215 ra50m = ra50 ! 960215 ra4m = ra4 ! 960215 - + ! !++++++++++++++++ Loop over particle classes ++++++++++++++++++++++++ ! For a gaseous component, there is only one such class. @@ -605,7 +605,7 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, iopt_vchem, vchemv, ! idgr < 0 -> user-defined particle size distribution uspmd ! IF (.NOT.gasv) THEN - IF (idgr .GE. 0) THEN + IF (idgr .GE. 0) THEN qbpri = qbron*pmd(kdeel, idgr) ELSE qbpri = qbron*uspmd(kdeel, ABS(idgr)) @@ -616,11 +616,11 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, iopt_vchem, vchemv, ENDIF ! ! Continue if source strength of this particle class > 0 -! +! IF (ABS(qbpri) .GT. EPS_DELTA) THEN ! ! Compute initial concentrations due to transport and dispersion; no removal processes yet -! +! 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, error) @@ -639,17 +639,17 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, iopt_vchem, vchemv, & ra4_rcp, ra50_rcp, raz_rcp, z0_src, ol_src, uster_src, z0_tra, rctra_0, rcsrc, & & ra4src, rb_src, ra50src, ra4tra, ra50tra, rb_tra, rclocal, nh3bg_rcp, nh3bgtra, & & so2bg_rcp, so2bgtra, gym, depudone, gasv, lu_rcp_per, lu_tra_per, rnox) - + cratio = 1. CALL ops_depoparexp(kdeel, c, ol_src, qbpri, ra4_rcp, ra50_rcp, raz_rcp, rb_rcp, sigz, ueff, & & uster_src, z0_src, virty, gasv, itra, rb, ra4, istab, grof, ra50, xvghbr, xvglbr, & & regenk, rint, buil, zf, isekt, iseiz, mb, disxx, radius, xl, onder, dg, & & knatdeppar, scavcoef, irev, htt, xloc, xl100, vw10, pcoef, vchem, dispg, htot, & & error, pr, twt, cratio, rc_rcp, grad, rc, utr, vg50_rcp, routpri, & - & vg50trans, rkc, ri, vnatpri, cgt, cgt_z, cq2, cdn, cch, z0_src, ol_src, uster_src,& + & vg50trans, rkc, ri, vnatpri, cgt, cgt_z, cq2, cdn, cch, z0_src, ol_src, uster_src,& & z0_tra, rctra_0, rcsrc, ra4src, rb_src, ra50src, ra4tra, ra50tra, rb_tra, vgpart, & & xm, ym, zm, bx, by, xg) - + IF (.NOT.gasv) rclocal = rc_rcp CALL ops_conc_rek(ueff, qbpri, isec, rcsec, routsec, ccc, amol1, amol2, sigz, utr, rc_sec_rcp, & & ra4_rcp, ra50_rcp, rb_rcp, amol21, ugmoldep, cch, cgt, cgt_z, grof, percvk, onder, & @@ -657,12 +657,12 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, iopt_vchem, vchemv, & htot, twt, rb, ra50, xvghbr, xvglbr, grad, frac, cdn, cq2, c, sdrypri(kdeel), & & 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), qsec, consec, pr, & + & drydep(ircp,kdeel), wetdep(ircp,kdeel), qsec, consec, pr, & & 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: @@ -670,7 +670,7 @@ SUBROUTINE ops_reken(idep, isec, icm, gasv, intpol, vchemc, iopt_vchem, vchemv, ENDIF ! end condition idep (compute deposition) ! ! Update summed concentration for primary concentration -! +! cpri(ircp,kdeel) = cpri(ircp,kdeel) + (c*percvk) IF (idep) THEN rno2_nox_sum(ircp) = rno2_nox_sum(ircp) + (rnox*percvk) @@ -739,71 +739,71 @@ SUBROUTINE wind_rek(bx, by, bdiam, bsterkte, bwarmte, bhoogte, bsigmaz, bD_stack & qtr, rond, diameter, iwd, isek) USE Binas, only: deg2rad, rad2deg - + ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'wind_rek') ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: bx ! -INTEGER*4, INTENT(IN) :: by ! -REAL*4, INTENT(IN) :: bdiam ! -REAL*4, INTENT(IN) :: bsterkte ! -REAL*4, INTENT(IN) :: bwarmte ! -REAL*4, INTENT(IN) :: bhoogte ! -REAL*4, INTENT(IN) :: bsigmaz ! +INTEGER*4, INTENT(IN) :: bx +INTEGER*4, INTENT(IN) :: by +REAL*4, INTENT(IN) :: bdiam +REAL*4, INTENT(IN) :: bsterkte +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] +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 ! -REAL*4, INTENT(IN) :: bqtr ! -REAL*4, INTENT(IN) :: gxm ! -REAL*4, INTENT(IN) :: gym ! -REAL*4, INTENT(IN) :: xm ! -REAL*4, INTENT(IN) :: ym ! -REAL*4, INTENT(IN) :: grid ! -INTEGER*4, INTENT(IN) :: nk ! -INTEGER*4, INTENT(IN) :: nr ! -INTEGER*4, INTENT(IN) :: mrcp ! -INTEGER*4, INTENT(IN) :: nrcp ! -INTEGER*4, INTENT(IN) :: kk ! -INTEGER*4, INTENT(IN) :: nb ! -INTEGER*4, INTENT(IN) :: karea ! -INTEGER*4, INTENT(IN) :: larea ! +INTEGER*4, INTENT(IN) :: btgedr +INTEGER*4, INTENT(IN) :: bdegr +REAL*4, INTENT(IN) :: bqrv +REAL*4, INTENT(IN) :: bqtr +REAL*4, INTENT(IN) :: gxm +REAL*4, INTENT(IN) :: gym +REAL*4, INTENT(IN) :: xm +REAL*4, INTENT(IN) :: ym +REAL*4, INTENT(IN) :: grid +INTEGER*4, INTENT(IN) :: nk +INTEGER*4, INTENT(IN) :: nr +INTEGER*4, INTENT(IN) :: mrcp +INTEGER*4, INTENT(IN) :: nrcp +INTEGER*4, INTENT(IN) :: kk +INTEGER*4, INTENT(IN) :: nb +INTEGER*4, INTENT(IN) :: karea +INTEGER*4, INTENT(IN) :: larea ! SUBROUTINE ARGUMENTS - OUTPUT 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) :: 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] +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 ! -REAL*4, INTENT(OUT) :: qtr ! -INTEGER*4, INTENT(OUT) :: rond ! -REAL*4, INTENT(OUT) :: diameter ! -INTEGER*4, INTENT(OUT) :: iwd ! -INTEGER*4, INTENT(OUT) :: isek ! +INTEGER*4, INTENT(OUT) :: ibtg +INTEGER*4, INTENT(OUT) :: idgr +REAL*4, INTENT(OUT) :: qrv +REAL*4, INTENT(OUT) :: qtr +INTEGER*4, INTENT(OUT) :: rond +REAL*4, INTENT(OUT) :: diameter +INTEGER*4, INTENT(OUT) :: iwd +INTEGER*4, INTENT(OUT) :: isek ! LOCAL VARIABLES -REAL*4 :: dx ! -REAL*4 :: dy ! +REAL*4 :: dx +REAL*4 :: dy ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -822,9 +822,9 @@ SUBROUTINE wind_rek(bx, by, bdiam, bsterkte, bwarmte, bhoogte, bsigmaz, bD_stack 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] +Ts_stack = bTs_stack ! temperature of effluent from stack [K] emis_horizontal = bemis_horizontal ! horizontal outflow of emission -building = bbuilding ! building parameters +building = bbuilding ! building parameters ibtg = btgedr ! diurnal variation code idgr = bdegr ! particle size distribution code @@ -848,9 +848,9 @@ SUBROUTINE wind_rek(bx, by, bdiam, bsterkte, bwarmte, bhoogte, bsigmaz, bD_stack ! 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 +! 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 @@ -862,21 +862,21 @@ SUBROUTINE wind_rek(bx, by, bdiam, bsterkte, bwarmte, bhoogte, bsigmaz, bD_stack dy = ym + nrcp*grid/(nk*2 + 1) - y disx = SQRT((dx*dx) + (dy*dy)) ENDIF - -! North receptor -! | / -! | / -! | / -! dy| / -! | / -! | / -! | /alpha + +! North receptor +! | / +! | / +! | / +! dy| / +! | / +! | / +! | /alpha ! |-------- ! source dx ! -! Determine preliminary wind-sector (some correction will be applied later for a height dependent wind shear, +! Determine preliminary wind-sector (some correction will be applied later for a height dependent wind shear, ! but plume rise is not known at this point). Outcome: 0 <= iwd <= 360. -! Note that in the OPS model, the wind direction is characterised by its angle with the North; +! Note that in the OPS model, the wind direction is characterised by its angle with the North; ! 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. ! diff --git a/ops_resist_rek.f90 b/ops_resist_rek.f90 index e77fb1e..493277e 100644 --- a/ops_resist_rek.f90 +++ b/ops_resist_rek.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-F77/90 ! USAGE : %M% @@ -54,136 +54,136 @@ SUBROUTINE ops_resist_rek(vchemc, iopt_vchem, vchemv, rad, isec, icm, rcso2, reg IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_resist_rek') ! SUBROUTINE ARGUMENTS - INPUT REAL*4, INTENT(IN) :: vchemc ! chemical conversion rate [%/h] INTEGER*4, INTENT(IN) :: iopt_vchem ! option for chemical conversion rate (0 = old OPS, 1 = EMEP) -REAL*4, INTENT(IN) :: vchemv ! -REAL*4, INTENT(IN) :: rad ! +REAL*4, INTENT(IN) :: vchemv +REAL*4, INTENT(IN) :: rad LOGICAL, INTENT(IN) :: isec ! TRUE als component=[SO2, NOx, NH3] -INTEGER*4, INTENT(IN) :: icm ! -REAL*4, INTENT(IN) :: rcso2 ! -REAL*4, INTENT(IN) :: regenk ! +INTEGER*4, INTENT(IN) :: icm +REAL*4, INTENT(IN) :: rcso2 +REAL*4, INTENT(IN) :: regenk REAL*4, INTENT(IN) :: rcaerd ! surface resistance NO3_aerosol [s/m] -INTEGER*4, INTENT(IN) :: iseiz ! -INTEGER*4, INTENT(IN) :: istab ! -INTEGER*4, INTENT(IN) :: itra ! -REAL*4, INTENT(IN) :: ar ! -REAL*4, INTENT(IN) :: rno2nox ! -REAL*4, INTENT(IN) :: rcnh3d ! +INTEGER*4, INTENT(IN) :: iseiz +INTEGER*4, INTENT(IN) :: istab +INTEGER*4, INTENT(IN) :: itra +REAL*4, INTENT(IN) :: ar +REAL*4, INTENT(IN) :: rno2nox +REAL*4, INTENT(IN) :: rcnh3d REAL*4, INTENT(IN) :: vchemnh3 -type(Tvchem), INTENT(IN) :: vchem2 ! -REAL*4, INTENT(IN) :: hum ! +type(Tvchem), INTENT(IN) :: vchem2 +REAL*4, INTENT(IN) :: hum REAL*4, INTENT(IN) :: uster_rcp ! friction velocity at receptor; for z0 at receptor [m/s] REAL*4, INTENT(IN) :: ol_rcp ! Monin-Obukhov length at receptor; for z0 at receptor [m/s] -REAL*4, INTENT(IN) :: uster_tra ! -REAL*4, INTENT(IN) :: ol_tra ! +REAL*4, INTENT(IN) :: uster_tra +REAL*4, INTENT(IN) :: ol_tra REAL*4, INTENT(IN) :: z0_rcp ! roughness length at receptor; from z0-map [m] REAL*4, INTENT(IN) :: z0_metreg_rcp ! roughness length at receptor; interpolated from meteo regions [m] -REAL*4, INTENT(IN) :: rcno2d ! -INTEGER*4, INTENT(IN) :: kdeel ! -INTEGER*4, INTENT(IN) :: mb ! -REAL*4, INTENT(IN) :: vw10 ! +REAL*4, INTENT(IN) :: rcno2d +INTEGER*4, INTENT(IN) :: kdeel +INTEGER*4, INTENT(IN) :: mb +REAL*4, INTENT(IN) :: vw10 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 ! -REAL*4, INTENT(IN) :: rations ! -REAL*4, INTENT(IN) :: rhno3 ! +REAL*4, INTENT(IN) :: disx +REAL*4, INTENT(IN) :: zm +REAL*4, INTENT(IN) :: koh +REAL*4, INTENT(IN) :: rations +REAL*4, INTENT(IN) :: rhno3 REAL*4, INTENT(IN) :: rcno ! surface resistance for NO [s/m] REAL*4, INTENT(IN) :: rhno2 ! ration hno2/nox REAL*4, INTENT(IN) :: rchno3 ! HNO3 -REAL*4, INTENT(IN) :: croutpri ! constant (initial) in-cloud scavenging ratio [-] for primary component +REAL*4, INTENT(IN) :: croutpri ! constant (initial) in-cloud scavenging ratio [-] for primary component REAL*4, INTENT(IN) :: rrno2nox ! ruimtelijke variatie in no2/nox verhouding -REAL*4, INTENT(IN) :: rhno3_rcp ! +REAL*4, INTENT(IN) :: rhno3_rcp REAL*4, INTENT(IN) :: z0_src ! roughness length at source; from z0-map [m] -REAL*4, INTENT(IN) :: ol_src ! -REAL*4, INTENT(IN) :: uster_src ! +REAL*4, INTENT(IN) :: ol_src +REAL*4, INTENT(IN) :: uster_src REAL*4, INTENT(IN) :: z0_tra ! roughness length representative for trajectory [m] -REAL*4, INTENT(IN) :: nh3bg_rcp ! -REAL*4, INTENT(IN) :: nh3bgtra ! -REAL*4, INTENT(IN) :: so2bg_rcp ! -REAL*4, INTENT(IN) :: so2bgtra ! -REAL*4, INTENT(IN) :: gym ! -LOGICAL, INTENT(IN) :: gasv ! +REAL*4, INTENT(IN) :: nh3bg_rcp +REAL*4, INTENT(IN) :: nh3bgtra +REAL*4, INTENT(IN) :: so2bg_rcp +REAL*4, INTENT(IN) :: so2bgtra +REAL*4, INTENT(IN) :: gym +LOGICAL, INTENT(IN) :: gasv REAL*4, INTENT(IN) :: lu_rcp_per(NLU) ! land use percentages for all land use classes of receptor REAL*4, INTENT(IN) :: lu_tra_per(NLU) ! land use percentages for all land use classes over trajectory ! SUBROUTINE ARGUMENTS - I/O -REAL*4, INTENT(INOUT) :: rb ! -REAL*4, INTENT(INOUT) :: ra4 ! -REAL*4, INTENT(INOUT) :: ra50 ! -LOGICAL, INTENT(INOUT) :: depudone ! +REAL*4, INTENT(INOUT) :: rb +REAL*4, INTENT(INOUT) :: ra4 +REAL*4, INTENT(INOUT) :: ra50 +LOGICAL, INTENT(INOUT) :: depudone ! SUBROUTINE ARGUMENTS - OUTPUT REAL*4, INTENT(OUT) :: routpri ! in-cloud scavenging ratio for primary component - ! (rout << rain-out = in-cloud) [-] + ! (rout << rain-out = in-cloud) [-] REAL*4, INTENT(OUT) :: vchem ! chemical conversion rate [%/h] -REAL*4, INTENT(OUT) :: uh ! +REAL*4, INTENT(OUT) :: uh ! Canopy resistances -! Note: for particles, Rc is defined in ops_depoparexp -REAL*4, INTENT(OUT) :: rc ! -REAL*4, INTENT(OUT) :: rcsec ! -REAL*4, INTENT(OUT) :: rc_sec_rcp ! -REAL*4, INTENT(OUT) :: rcsrc ! canopy resistance at the source, no re-emission allowed [s/m]; is used for the computation of - ! cq1 = source depletion ratio for dry deposition for phase 1, area source +! Note: for particles, Rc is defined in ops_depoparexp +REAL*4, INTENT(OUT) :: rc +REAL*4, INTENT(OUT) :: rcsec +REAL*4, INTENT(OUT) :: rc_sec_rcp +REAL*4, INTENT(OUT) :: rcsrc ! canopy resistance at the source, no re-emission allowed [s/m]; is used for the computation of + ! cq1 = source depletion ratio for dry deposition for phase 1, area source REAL*4, INTENT(OUT) :: rctra_0 ! canopy resistance representative for the trajectory, no re-emission allowed [s/m]; ! is used for source depletion (loss over trajectory) REAL*4, INTENT(OUT) :: rc_rcp ! canopy resistance at receptor, no re-emission allowed [s/m]; ! is used for deposition gradient at receptor -REAL*4, INTENT(OUT) :: rclocal ! canopy resistance at receptor, re-emission allowed [s/m]; +REAL*4, INTENT(OUT) :: rclocal ! canopy resistance at receptor, re-emission allowed [s/m]; ! is used for the computation of drypri, the local depsosition at the receptor - -REAL*4, INTENT(OUT) :: rb_rcp ! -REAL*4, INTENT(OUT) :: ra4_rcp ! -REAL*4, INTENT(OUT) :: ra50_rcp ! -REAL*4, INTENT(OUT) :: ra4src ! -REAL*4, INTENT(OUT) :: rb_src ! -REAL*4, INTENT(OUT) :: ra50src ! -REAL*4, INTENT(OUT) :: ra4tra ! -REAL*4, INTENT(OUT) :: ra50tra ! -REAL*4, INTENT(OUT) :: rb_tra ! -REAL*4, INTENT(OUT) :: raz_rcp ! + +REAL*4, INTENT(OUT) :: rb_rcp +REAL*4, INTENT(OUT) :: ra4_rcp +REAL*4, INTENT(OUT) :: ra50_rcp +REAL*4, INTENT(OUT) :: ra4src +REAL*4, INTENT(OUT) :: rb_src +REAL*4, INTENT(OUT) :: ra50src +REAL*4, INTENT(OUT) :: ra4tra +REAL*4, INTENT(OUT) :: ra50tra +REAL*4, INTENT(OUT) :: rb_tra +REAL*4, INTENT(OUT) :: raz_rcp REAL*4, INTENT(OUT) :: rnox ! NO2/NOx ratio - + ! LOCAL VARIABLES -INTEGER*4 :: day_of_year ! -INTEGER*4 :: icmpsec ! -INTEGER*4 :: ipar ! -INTEGER*4 :: mnt ! -INTEGER*4, DIMENSION(2) :: mnt_select ! -INTEGER*4 :: nwet ! -INTEGER*4 :: icnr ! -INTEGER*4 :: luclass ! -REAL*4 :: percn ! -REAL*4 :: chemn ! -REAL*4 :: scno2nox ! -REAL*4 :: chemr ! -REAL*4 :: rcno2 ! -REAL*4 :: r ! -REAL*4 :: glrad ! -REAL*4 :: d ! -REAL*4 :: ratns ! -REAL*4 :: rcc ! -REAL*4 :: vdc ! -REAL*4 :: rcaer ! -REAL*4 :: vdaer ! -REAL*4 :: vg ! -REAL*4 :: rchno2 ! -REAL*4 :: dh ! +INTEGER*4 :: day_of_year +INTEGER*4 :: icmpsec +INTEGER*4 :: ipar +INTEGER*4 :: mnt +INTEGER*4, DIMENSION(2) :: mnt_select +INTEGER*4 :: nwet +INTEGER*4 :: icnr +INTEGER*4 :: luclass +REAL*4 :: percn +REAL*4 :: chemn +REAL*4 :: scno2nox +REAL*4 :: chemr +REAL*4 :: rcno2 +REAL*4 :: r +REAL*4 :: glrad +REAL*4 :: d +REAL*4 :: ratns +REAL*4 :: rcc +REAL*4 :: vdc +REAL*4 :: rcaer +REAL*4 :: vdaer +REAL*4 :: vg +REAL*4 :: rchno2 +REAL*4 :: dh REAL*4 :: fx ! weegfactor -REAL*4 :: som_rc_rcp -REAL*4 :: som2_rc_rcp -REAL*4 :: som_rc_local -REAL*4 :: som2_rctra_0 -REAL*4 :: som_rctra_0 +REAL*4 :: som_rc_rcp +REAL*4 :: som2_rc_rcp +REAL*4 :: som_rc_local +REAL*4 :: som2_rctra_0 +REAL*4 :: som_rctra_0 REAL*4 :: som_rcsrc -REAL*4 :: telmaand -REAL*4 :: catm +REAL*4 :: telmaand +REAL*4 :: catm REAL*4 :: c_ave_prev_nh3 REAL*4 :: c_ave_prev_so2 REAL*4 :: cfact @@ -195,7 +195,7 @@ SUBROUTINE ops_resist_rek(vchemc, iopt_vchem, vchemv, rad, isec, icm, rcso2, reg REAL*4, PARAMETER :: catm_min = 0.1E-05 ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- @@ -210,7 +210,7 @@ SUBROUTINE ops_resist_rek(vchemc, iopt_vchem, vchemv, rad, isec, icm, rcso2, reg ! displacement height (usually 0.7 * vegetation height) (m) ! the effect of the displacement height is neglected here; - + d = 0. ! Component number icnr for calculation of Rb; @@ -221,9 +221,9 @@ SUBROUTINE ops_resist_rek(vchemc, iopt_vchem, vchemv, rad, isec, icm, rcso2, reg icnr = 1 ENDIF - ! Calculate deposition parameters vg, Ra and Rb (=rb) with vg=1./(Ra+Rb+Rc) at source/4 m height, + ! Calculate deposition parameters vg, Ra and Rb (=rb) with vg=1./(Ra+Rb+Rc) at source/4 m height, ! receptor/4 m height and receptor/50 m height: - ! Only results for ra... and rb... are used, vg NOT ! + ! Only results for ra... and rb... are used, vg NOT CALL ops_depu(icnr, z0_rcp, zm, d, rc_rcp, ol_rcp, uster_rcp, vg, raz_rcp, rb_rcp) CALL ops_depu(icnr, z0_src, 4., d, rcsrc, ol_src, uster_src, vg, ra4src, rb_src) CALL ops_depu(icnr, z0_rcp, 4., d, rc_rcp, ol_rcp, uster_rcp, vg, ra4_rcp, rb_rcp) @@ -232,14 +232,14 @@ SUBROUTINE ops_resist_rek(vchemc, iopt_vchem, vchemv, rad, isec, icm, rcso2, reg ! Set Ra at source/50m height equal to Ra at receptor/50 m height: ra50src = ra50_rcp - ! Compute Ra averaged over trajectory at 4 m height and 50 m height; + ! Compute Ra averaged over trajectory at 4 m height and 50 m height; ! ra4 = Ra(4 m) from meteo statistics, based on z0_metreg_rcp, which is interpolated from meteo regions. ! 4.3 OPS report, neglecting the stability corrections psi_h and assuming that u* remains the same. - ! + ! Ra(z=4,trajectory) z=4 z=4 ! ------------------- = ln(-------) / ln(-------------) ! Ra(z=4) z0_tra z0_metreg_rcp - + ra4tra = ra4*alog(4/z0_tra)/alog(4/z0_metreg_rcp) ra50tra = ra50*alog(50/z0_tra)/alog(50/z0_metreg_rcp) @@ -263,9 +263,9 @@ SUBROUTINE ops_resist_rek(vchemc, iopt_vchem, vchemv, rad, isec, icm, rcso2, reg ! rc : surface resistance primary component ! rcsec : surface resistance secondary component over trajectory; taken as 0.8*Rc(NO3_aerosol) ! -! ar = proportionality constant [ppb J-1 cm2 h] in relation [OH] = ar Qr, with -! [OH] = OH radical concentration [ppb] , Qr = global radiation in J/cm2/h, see -! Van Egmond N.D. and Kesseboom H. (1985) A numerical mesoscale model for long-term average NOx and NO2-concentration. +! ar = proportionality constant [ppb J-1 cm2 h] in relation [OH] = ar Qr, with +! [OH] = OH radical concentration [ppb] , Qr = global radiation in J/cm2/h, see +! Van Egmond N.D. and Kesseboom H. (1985) A numerical mesoscale model for long-term average NOx and NO2-concentration. ! Atmospheric Environment 19, 587-595. ! Table 6.1 OPS-report: ! ar(summer) = 7345 molec cm-3 W-1 m2 @@ -286,10 +286,10 @@ SUBROUTINE ops_resist_rek(vchemc, iopt_vchem, vchemv, rad, isec, icm, rcso2, reg ! Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec ! 32.1 40.1 54.0 70.0 83.9 91.9 91.9 83.9 70.0 54.0 40.1 32.1 *1e-8 ! -! k_ho SO2 + OH -> sulphate (gas phase) 3.44 x 10-12 cm3 molec-1 s-1 +! k_ho SO2 + OH -> sulphate (gas phase) 3.44 x 10-12 cm3 molec-1 s-1 ! at T = 20 C, p = 1013 mb: ppbfac = conversion factor ppb -> molec/cm3 = 2.5029e10 molec/cm3/ppb -> -! k_ho = 3.44e-12*3600*2.5029e10 = 309.96 ppb-1 h-1 -! k_ho*[OH] = k_ho*ar*Q = 100*309.96*62e-8*Q %/h = 0.0192*Q %/h +! k_ho = 3.44e-12*3600*2.5029e10 = 309.96 ppb-1 h-1 +! k_ho*[OH] = k_ho*ar*Q = 100*309.96*62e-8*Q %/h = 0.0192*Q %/h ! k_he SO2 -> sulphate (Particle phase) 1.7 x 10-6 s-1 = 0.612 %/h ! k_aq SO2 -> sulphate (Aqueous phase) 4.0 x 10-5 s-1 = 14.4 %/h ! @@ -304,10 +304,10 @@ SUBROUTINE ops_resist_rek(vchemc, iopt_vchem, vchemv, rad, isec, icm, rcso2, reg ENDIF ! write(*,*) 'ops_resist_rek, vchem: ',vchem routpri = croutpri*rations ! Note factor 2 in rations - rc = rcso2 + rc = rcso2 rcsec = rcaerd*0.8 - ! NOx: + ! NOx: ELSE IF (icm .EQ. 2) THEN ! Compute percn = fraction of nighttime hours, depending on season; @@ -323,7 +323,7 @@ SUBROUTINE ops_resist_rek(vchemc, iopt_vchem, vchemv, rad, isec, icm, rcso2, reg ! Compute chemn = chemical conversion rate for NO2+O3 -> NO3 (nigthttime), assuming a 2%/h conversion rate ! Van Egmond N.D. and Kesseboom H. (1983) Mesoscale air pollution dispersion models-II. Lagrangian PUFF model, - ! and comparison with Eulerian GRID model. Atmospheric Environment, 17, 265-274. + ! and comparison with Eulerian GRID model. Atmospheric Environment, 17, 265-274. chemn = percn*2. ! rnox = [NO2]/[NOx] ratio consists of a space varying component (rrno2nox, computed in ops_par_chem), @@ -338,8 +338,8 @@ SUBROUTINE ops_resist_rek(vchemc, iopt_vchem, vchemv, rad, isec, icm, rcso2, reg ! chemr : chemical conversion rate for NO2 + OH -> HNO3; [%/h] (factor 100 is to make percentage instead of fractions) ! rad : global radiation [J/cm2/h] - ! ar : proportionality constant [ppb J-1 cm2 h] in relation [OH] = ar Qr, with - ! [OH] = OH radical concentration [ppb] , Qr = global radiation [J/cm2/h] + ! ar : proportionality constant [ppb J-1 cm2 h] in relation [OH] = ar Qr, with + ! [OH] = OH radical concentration [ppb] , Qr = global radiation [J/cm2/h] ! koh : reaction constant [ppb-1 h-1] (Van Aalst en Bergsma, 1981) ! vchem : total chemical conversion rate, split into daytime and nighttime part chemr = 100*rad*ar*koh*rnox @@ -351,8 +351,8 @@ SUBROUTINE ops_resist_rek(vchemc, iopt_vchem, vchemv, rad, isec, icm, rcso2, reg ELSE ! EMEP maps: vchem = vchem2%vchem - ENDIF - + ENDIF + ! routpri: in-cloud scavenging ratio for primary component (rout << rain-out = in-cloud) [-] routpri = croutpri*rnox ! @@ -362,24 +362,24 @@ SUBROUTINE ops_resist_rek(vchemc, iopt_vchem, vchemv, rad, isec, icm, rcso2, reg ! be calculated as representative for the NO-NO2-HNO2 mixture ! rcno2 = rcno2d ! interpolated value from meteo statistics (ops_statparexp) - r = rb + ra4 ! R = Rb + Ra = Rb + Ra = boundary layer resistance + aerodynamic resistance - rchno2 = rcso2 ! Rc(HNO2) = Rc(SO2) + r = rb + ra4 ! R = Rb + Ra = Rb + Ra = boundary layer resistance + aerodynamic resistance + rchno2 = rcso2 ! Rc(HNO2) = Rc(SO2) + + - ! - ! ! 1 [NO2]/[NOx] (1-[NO2]/[NOx]) [HNO2]/[NOx] ! ------------------- = ------------------ + -------------------- + -------------------- ! Rc(NOx) + Rb + Ra Rc(NO2)+ Rb + Ra Rc(NO) + Rb + Ra Rc(HNO2) + Rb + Ra - ! - ! + + ! 1 [HNO3]/[NO3]_totaal (1-[HNO3]/[NO3]_totaal) - ! ------------------- = ----------------------- + ---------------------------- - ! Rc(NO3) + Rb + Ra Rc(HNO3)+ Rb + Ra Rc(NO3_aerosol) + Rb + Ra - - rc = 1./(rnox/(rcno2+r) + (1.-rnox)/(rcno+r) + rhno2/(rchno2+r)) - r + ! ------------------- = ----------------------- + ---------------------------- + ! Rc(NO3) + Rb + Ra Rc(HNO3)+ Rb + Ra Rc(NO3_aerosol) + Rb + Ra + + rc = 1./(rnox/(rcno2+r) + (1.-rnox)/(rcno+r) + rhno2/(rchno2+r)) - r rcsec = 1./(rhno3/(r+rchno3) + (1.-rhno3)/(r+rcaerd)) - r ! -! icm = 3: NH3 +! icm = 3: NH3 ! ELSE IF (icm .EQ. 3) THEN @@ -404,21 +404,21 @@ SUBROUTINE ops_resist_rek(vchemc, iopt_vchem, vchemv, rad, isec, icm, rcso2, reg vchem = vchem2%vchem ENDIF routpri = croutpri - rc = rcnh3d + rc = rcnh3d rcsec = rcaerd*0.8 ELSE CONTINUE ENDIF ! IF icm = 1,2 or 3 !------------------------------------------------------------------------------------------- -! Compute surface resistance Rc for acidifying components using the DEPAC module -! rcsrc : canopy resistance at the source, re-emission allowed [s/m]; is used for the computation of -! cq1 = source depletion ratio for dry deposition for phase 1, area source +! Compute surface resistance Rc for acidifying components using the DEPAC module +! rcsrc : canopy resistance at the source, re-emission allowed [s/m]; is used for the computation of +! cq1 = source depletion ratio for dry deposition for phase 1, area source ! rctra_0: canopy resistance representative for the trajectory, no re-emission allowed [s/m]; ! is used for source depletion (loss over trajectory) ! 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]; +! rclocal: canopy resistance at receptor, re-emission allowed [s/m]; ! is used for the computation of drypri, the local depsosition at the receptor !------------------------------------------------------------------------------------------- @@ -451,7 +451,7 @@ SUBROUTINE ops_resist_rek(vchemc, iopt_vchem, vchemv, rad, isec, icm, rcso2, reg ! c_ave_prev air concentration averaged over a previous period (e.g. previous year or month) (ug/m3); ! we use here the NH3 background concentration along the trajectory ! catm actual atmospheric concentration (ug/m3); we use here the NH3 background concentration along the trajectory; -! the output Rc is returned in rctra_0 = effective Rc over the trajectory. +! the output Rc is returned in rctra_0 = effective Rc over the trajectory. ! ! (17/24) = conversion factor ppb -> ug/m3. ! @@ -461,11 +461,11 @@ SUBROUTINE ops_resist_rek(vchemc, iopt_vchem, vchemv, rad, isec, icm, rcso2, reg ! CALL ops_depos_rc(icm, iseiz, mb, gym ,temp_C, uster_tra, glrad, hum, nwet, ratns, catm, c_ave_prev_nh3, c_ave_prev_so2, lu_tra_per, & & ra4tra, rb_tra, rctra_0, rclocal) - rcsrc = rctra_0 ! + rcsrc = rctra_0 ! ! 2. Compute surface resistance Rc near the receptor. ! The same as above, but now we use the NH3 background concentration at the receptor as inputs; -! the output Rc is returned in rc_rcp = effective Rc near the receptor (always positive). +! the output Rc is returned in rc_rcp = effective Rc near the receptor (always positive). ! rclocal = effective Rc near the receptor (might become a negative value) ! Note: catm and c_ave_prev are only used for NH3. ! Conversion from ppb -> ug/m3 for nh3bg_rcp already done in ops_rcp_char. @@ -501,34 +501,34 @@ SUBROUTINE ops_resist_rek(vchemc, iopt_vchem, vchemv, rad, isec, icm, rcso2, reg ENDIF ! ! Compute vdaer = deposition velocity at receptor for secondary aerosols -! - CALL vdsecaer (uster_rcp, ol_rcp, vdaer, hum, nwet, uh, ra50_rcp, z0_rcp, icmpsec) +! + CALL vdsecaer (uster_rcp, ol_rcp, vdaer, hum, nwet, uh, ra50_rcp, z0_rcp, icmpsec) - IF (icm .EQ. 2) THEN + IF (icm .EQ. 2) THEN ! ! NOx -! Rc for NOx is, uptil now, Rc for NO2 (from DEPAC); now we compute the +! Rc for NOx is, uptil now, Rc for NO2 (from DEPAC); now we compute the ! effective Rc for NOx (= NO+NO2+HNO2) -! +! ! 1 [NO2]/[NOx] (1-[NO2]/[NOx]) [HNO2]/[NOx] ! ------------------- = ------------------ + -------------------- + -------------------- ! 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 + rcsrc = rctra_0 ! ! Rc for secondary component: 1/vd = Ra + Rb + Rc and Rb is neglected for aerosols ! rc_sec_rcp = 1./vdaer-ra50_rcp ! -! rc_sec_rcp is valid for NO3 aerosol. Calculate now a weighted value for the NO3+HNO3 mixture +! rc_sec_rcp is valid for NO3 aerosol. Calculate now a weighted value for the NO3+HNO3 mixture ! ! 1 [HNO3]/[NO3]_totaal (1-[HNO3]/[NO3]_totaal) -! ------------------- = ----------------------- + ---------------------------- -! Rc(NO3) + Rb + Ra Rc(HNO3)+ Rb + Ra Rc(NO3_aerosol) + Rb + Ra +! ------------------- = ----------------------- + ---------------------------- +! Rc(NO3) + Rb + Ra Rc(HNO3)+ Rb + Ra Rc(NO3_aerosol) + Rb + Ra rc_sec_rcp=1./(rhno3_rcp/(r+rchno3) + (1.-rhno3_rcp)/(r+rc_sec_rcp)) - r @@ -560,7 +560,7 @@ SUBROUTINE ops_resist_rek(vchemc, iopt_vchem, vchemv, rad, isec, icm, rcso2, reg ! a roughness length (znul) < 0.5m and to Erisman et al (1994) and ! Ruijgrok et al. (1994) for forest and other areas with a roughness ! length above 0.5m. -! AUTHOR : OPS-support +! AUTHOR : OPS-support !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE vdsecaer (ust, ol, vd, rh, nwet,Uh, ra, znul, icmp) @@ -568,27 +568,27 @@ SUBROUTINE vdsecaer (ust, ol, vd, rh, nwet,Uh, ra, znul, icmp) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'vdsecaer') ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: icmp ! -INTEGER*4, INTENT(IN) :: nwet ! -REAL*4, INTENT(IN) :: ust ! -REAL*4, INTENT(IN) :: ol ! -REAL*4, INTENT(IN) :: rh ! -REAL*4, INTENT(IN) :: Uh ! -REAL*4, INTENT(IN) :: ra ! -REAL*4, INTENT(IN) :: znul ! +INTEGER*4, INTENT(IN) :: icmp +INTEGER*4, INTENT(IN) :: nwet +REAL*4, INTENT(IN) :: ust +REAL*4, INTENT(IN) :: ol +REAL*4, INTENT(IN) :: rh +REAL*4, INTENT(IN) :: Uh +REAL*4, INTENT(IN) :: ra +REAL*4, INTENT(IN) :: znul ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: vd ! +REAL*4, INTENT(OUT) :: vd ! LOCAL VARIABLES -REAL*4 :: E ! +REAL*4 :: E ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! components: @@ -667,7 +667,7 @@ SUBROUTINE vdsecaer (ust, ol, vd, rh, nwet,Uh, ra, znul, icmp) ENDIF vd = 1./(1./vd+ra) ELSE - vd = 1./((1./(((ust*ust)/Uh)*E)) + ra) + vd = 1./((1./(((ust*ust)/Uh)*E)) + ra) ENDIF RETURN diff --git a/ops_scalefac.f90 b/ops_scalefac.f90 index 1ddaf3a..a91d9c6 100644 --- a/ops_scalefac.f90 +++ b/ops_scalefac.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,10 +27,10 @@ ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 -! DESCRIPTION : Compute scaling factors for printing of concentrations and depositions. A scaling factor is the ratio between the +! DESCRIPTION : Compute scaling factors for printing of concentrations and depositions. A scaling factor is the ratio between the ! computed concentration (or deposition) and the value to be printed. All ratio's are based on an input source strength ! in g/s and an output in ug/m3 for concentrations and mol/ha/y for depositions. ! EXIT CODES : @@ -47,7 +47,7 @@ SUBROUTINE ops_scalefac(nrrcp, nsubsec, cpri, csec, drydep, wetdep, scale_con, s IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_scalefac') ! SUBROUTINE ARGUMENTS - INPUT @@ -83,7 +83,7 @@ SUBROUTINE ops_scalefac(nrrcp, nsubsec, cpri, csec, drydep, wetdep, scale_con, s REAL*4 :: scale_wet ! schaal vergr. concentratie ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -103,7 +103,7 @@ SUBROUTINE ops_scalefac(nrrcp, nsubsec, cpri, csec, drydep, wetdep, scale_con, s IF (PRESENT(csubsec)) scale_subsec = 1.0e-10 scale_dry = 1.0e-10 scale_wet = 1.0e-10 -! +! ! Loop over exponent in scaling factor (scaling factors range from 1e-10 to 1e30); ! Set scaling factor s, such that for a parameter x with maximum xmax: s*xmax < 2000 (or (2000/xmax) > s) ! @@ -120,7 +120,7 @@ SUBROUTINE ops_scalefac(nrrcp, nsubsec, cpri, csec, drydep, wetdep, scale_con, s IF (csubsecmax(isubsec) .GT. (0. + EPS_DELTA) .AND. (2000./csubsecmax(isubsec)) .GT. (s + EPS_DELTA)) THEN scale_subsec(isubsec) = s ENDIF - enddo + enddo ENDIF IF (ddepmax .GT. (0. + EPS_DELTA) .AND. (2000./ddepmax) .GT. (s + EPS_DELTA)) THEN scale_dry = s diff --git a/ops_seccmp.f90 b/ops_seccmp.f90 index 8c30083..9886a7d 100644 --- a/ops_seccmp.f90 +++ b/ops_seccmp.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -21,16 +21,16 @@ ! No part of this software may be used, copied or distributed without permission of RIVM/LLO (2002) ! ! SUBROUTINE -! NAME : %M% +! NAME : %M% ! SCCS(SOURCE) : %P% ! RELEASE - LEVEL : %R% - %L% ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM LLO ! LANGUAGE : FORTRAN-77/90 -! DESCRIPTION : Compute concentration of secondary component (SO4,NO3,NH4) +! DESCRIPTION : Compute concentration of secondary component (SO4,NO3,NH4) ! EXIT CODES : ! FILES AND OTHER : ! I/O DEVICES @@ -48,7 +48,7 @@ SUBROUTINE ops_seccmp(qbpri, ueff, rcsec, routsec, ccc, vv, amol1, amol2, xvg, s IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_seccmp') ! SUBROUTINE ARGUMENTS - INPUT @@ -56,71 +56,71 @@ SUBROUTINE ops_seccmp(qbpri, ueff, rcsec, routsec, ccc, vv, amol1, amol2, xvg, s REAL*4, INTENT(IN) :: ueff ! effective transport velocity of plume [m/s] REAL*4, INTENT(IN) :: rcsec ! opp. weerstand sec. component REAL*4, INTENT(IN) :: routsec ! in-cloud scavenging ratio for secondary component - ! (rout << rain-out = in-cloud) [-] -REAL*4, INTENT(IN) :: ccc ! undepleted concentration including part above mixing layer; + ! (rout << rain-out = in-cloud) [-] +REAL*4, INTENT(IN) :: ccc ! undepleted concentration including part above mixing layer; ! is needed for e.g. wet deposition. REAL*4, INTENT(IN) :: vv ! total source depletion factor for primary component REAL*4, INTENT(IN) :: amol1 ! molgewicht primaire component REAL*4, INTENT(IN) :: amol2 ! molgewicht secundaire component REAL*4, INTENT(IN) :: xvg ! factor not used; xvg = 1 -REAL*4, INTENT(IN) :: sigz ! -REAL*4, INTENT(IN) :: grad ! +REAL*4, INTENT(IN) :: sigz +REAL*4, INTENT(IN) :: grad REAL*4, INTENT(IN) :: utr ! average wind speed over the trajectory (m/s) -REAL*4, INTENT(IN) :: radius ! -REAL*4, INTENT(IN) :: disx ! -REAL*4, INTENT(IN) :: xl ! -REAL*4, INTENT(IN) :: xloc ! -REAL*4, INTENT(IN) :: vw10 ! -REAL*4, INTENT(IN) :: pcoef ! -REAL*4, INTENT(IN) :: virty ! -REAL*4, INTENT(IN) :: regenk ! -REAL*4, INTENT(IN) :: htot ! -REAL*4, INTENT(IN) :: onder ! -REAL*4, INTENT(IN) :: twt ! -REAL*4, INTENT(IN) :: ri ! -REAL*4, INTENT(IN) :: rb ! -REAL*4, INTENT(IN) :: ra50 ! -REAL*4, INTENT(IN) :: cgt ! -REAL*4, INTENT(IN) :: xvghbr ! -REAL*4, INTENT(IN) :: xvglbr ! -REAL*4, INTENT(IN) :: vnatpri ! +REAL*4, INTENT(IN) :: radius +REAL*4, INTENT(IN) :: disx +REAL*4, INTENT(IN) :: xl +REAL*4, INTENT(IN) :: xloc +REAL*4, INTENT(IN) :: vw10 +REAL*4, INTENT(IN) :: pcoef +REAL*4, INTENT(IN) :: virty +REAL*4, INTENT(IN) :: regenk +REAL*4, INTENT(IN) :: htot +REAL*4, INTENT(IN) :: onder +REAL*4, INTENT(IN) :: twt +REAL*4, INTENT(IN) :: ri +REAL*4, INTENT(IN) :: rb +REAL*4, INTENT(IN) :: ra50 +REAL*4, INTENT(IN) :: cgt +REAL*4, INTENT(IN) :: xvghbr +REAL*4, INTENT(IN) :: xvglbr +REAL*4, INTENT(IN) :: vnatpri REAL*4, INTENT(IN) :: vchem ! chemical conversion rate [%/h] -REAL*4, INTENT(IN) :: ra4_rcp ! -REAL*4, INTENT(IN) :: ra50_rcp ! -REAL*4, INTENT(IN) :: rb_rcp ! -REAL*4, INTENT(IN) :: rc_sec_rcp ! -REAL*4, INTENT(IN) :: ra50tra ! -REAL*4, INTENT(IN) :: rb_tra ! +REAL*4, INTENT(IN) :: ra4_rcp +REAL*4, INTENT(IN) :: ra50_rcp +REAL*4, INTENT(IN) :: rb_rcp +REAL*4, INTENT(IN) :: rc_sec_rcp +REAL*4, INTENT(IN) :: ra50tra +REAL*4, INTENT(IN) :: rb_tra ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: pr ! -REAL*4, INTENT(OUT) :: vnatsec ! -REAL*4, INTENT(OUT) :: cgtsec ! +REAL*4, INTENT(OUT) :: pr +REAL*4, INTENT(OUT) :: vnatsec +REAL*4, INTENT(OUT) :: cgtsec REAL*4, INTENT(OUT) :: vgsec ! deposition velocity secondary component [m/s[ REAL*4, INTENT(OUT) :: qsec ! cross-wind integrated mass flux of secondary species [g/s] REAL*4, INTENT(OUT) :: consec ! concentration secondary component [ug/m3] -REAL*4, INTENT(OUT) :: vg50trans ! +REAL*4, INTENT(OUT) :: vg50trans ! LOCAL VARIABLES -REAL*4 :: a ! -REAL*4 :: diameter ! -REAL*4 :: h ! -REAL*4 :: hl ! -REAL*4 :: gradsec ! +REAL*4 :: a +REAL*4 :: diameter +REAL*4 :: h +REAL*4 :: hl +REAL*4 :: gradsec REAL*4 :: qpri ! cross-wind integrated mass flux [g/s] of primary species of depleted source -REAL*4 :: rcrs ! -REAL*4 :: s ! -REAL*4 :: sigzsec ! -REAL*4 :: vgsect ! +REAL*4 :: rcrs +REAL*4 :: s +REAL*4 :: sigzsec +REAL*4 :: vgsect REAL*4 :: vnatrainv ! uitregensnelheid REAL*4 :: vnatwashv ! uitwassnelheid -REAL*4 :: vw ! +REAL*4 :: vw REAL*4 :: qsec_uncorr ! uncorrected qsec (from seccd) REAL*4 :: xg ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -132,13 +132,13 @@ SUBROUTINE ops_seccmp(qbpri, ueff, rcsec, routsec, ccc, vv, amol1, amol2, xvg, s ! IF (radius .GT. (0. + EPS_DELTA)) THEN ! -! disx < radius: receptor inside area source +! disx < radius: receptor inside area source ! IF (disx .LT. (radius - EPS_DELTA)) THEN - sigzsec = 1.5*sigz + sigzsec = 1.5*sigz ENDIF ! -! Compute vw = wind speed at transport height (either xl/2 or sigma_z) +! Compute vw = wind speed at transport height (either xl/2 or sigma_z) ! For a secondary species, and short distance (inside area source), the concentrations is still low, so ! there is relatively more mass in the higher part of the plume (further away), than in the lower part; @@ -148,7 +148,7 @@ SUBROUTINE ops_seccmp(qbpri, ueff, rcsec, routsec, ccc, vv, amol1, amol2, xvg, s IF (sigzsec .GT. (xl/2. + EPS_DELTA)) THEN a = xl/2. ELSE - a = sigzsec + a = sigzsec ENDIF vw = vw10*(a/10)**pcoef IF (vw .LT. (ueff - EPS_DELTA) .OR. disx .GT. (1.01*radius + EPS_DELTA)) THEN @@ -157,10 +157,10 @@ SUBROUTINE ops_seccmp(qbpri, ueff, rcsec, routsec, ccc, vv, amol1, amol2, xvg, s ! ! Compute diameter of area source from given virty. ! Square area source is represented by a circular area source with the same area; -! (area circle with radius r) = (area square with 1/2 side = radius) <=> pi*r**2 = (2*radius)**2 <=> +! (area circle with radius r) = (area square with 1/2 side = radius) <=> pi*r**2 = (2*radius)**2 <=> ! <=> r = 2/sqrt(pi)*radius <=> r = 1.128*radius. -! See ops_virtdist: virty = (radius*12.)/PI*1.128 +! See ops_virtdist: virty = (radius*12.)/PI*1.128 ! diameter = virty*PI/(6.*1.128) ELSE @@ -196,23 +196,23 @@ SUBROUTINE ops_seccmp(qbpri, ueff, rcsec, routsec, ccc, vv, amol1, amol2, xvg, s IF ((ABS(onder) .LE. ( 0 + EPS_DELTA )) .OR. (hl .LT. (0. - EPS_DELTA))) THEN hl = 0. ENDIF - pr = EXP(-(hl + 5)**2/(2*sigzsec*sigzsec*a)) - + pr = EXP(-(hl + 5)**2/(2*sigzsec*sigzsec*a)) + ! Note: in ops_depoparexp/par_nat pr = pr*AMIN1(1., disx/(ueff*3600.)) (correction near source) ! but for secondary components, concentrations near source are relatively low ! Wash out (below cloud) coefficient: -! epsilon = particle - droplet collision efficiency; +! epsilon = particle - droplet collision efficiency; ! for secondary particles, a collision efficiency = 0.31 has been taken (= EPSILON(class 4), see ops_depoparexp) ! vnatwashv = regenk*100./twt*(1. - EXP( -twt*0.31*1.326*ri**.816)) ! ! Rain out (in-cloud) coefficient: -! +! vnatrainv = regenk*100./twt*(1. - EXP( -routsec*twt*ri/1000./xl)) - + ! Wash out (below-cloud), rain out (in-cloud); in-cloud scavenging is more efficient than below-cloud; ! therefore vnatwash must be smaller than vnatrain. ! @@ -221,7 +221,7 @@ SUBROUTINE ops_seccmp(qbpri, ueff, rcsec, routsec, ccc, vv, amol1, amol2, xvg, s ENDIF ! ! Interpolate between wash out and rain out: -! +! vnatsec = vnatwashv*(1. - pr) + vnatrainv*pr ELSE ! rain probability = 0 for this meteo class: @@ -241,7 +241,7 @@ SUBROUTINE ops_seccmp(qbpri, ueff, rcsec, routsec, ccc, vv, amol1, amol2, xvg, s ! cgt = (1 - grad) (1 - exp[-t/tau]) <=> (1 - exp[-t/tau]) = ---------- ! (1 - grad) ! cgt -! and it follows cgtsec = (1.-gradsec) ----------- +! and it follows cgtsec = (1.-gradsec) ----------- ! (1.-grad) ! @@ -258,10 +258,10 @@ SUBROUTINE ops_seccmp(qbpri, ueff, rcsec, routsec, ccc, vv, amol1, amol2, xvg, s vgsec=1/(ra50tra+rcsec+rb_tra) ! ! vgsect = dry deposition velocity averaged over transport distance -! xvglbr = ratio effective dry deposition velocity over transport distance and +! xvglbr = ratio effective dry deposition velocity over transport distance and ! average dry deposition velocity over transport distance for low sources [-] ! See OPS-doc/meteo, bookmark correction_factor_deposition_velocity -! xvghbr = ratio effective dry deposition velocity over transport distance and +! xvghbr = ratio effective dry deposition velocity over transport distance and ! average dry deposition velocity over transport distance for high sources [-] ! See OPS-doc/meteo, bookmark correction_factor_deposition_velocity ! @@ -289,14 +289,14 @@ SUBROUTINE ops_seccmp(qbpri, ueff, rcsec, routsec, ccc, vv, amol1, amol2, xvg, s & qsec) ! ! In reality, we have to deal with variable mixing heigth and a transport speed that depends on emission height -> -! a correction is needed, using the 'exact' depletion factor for primary species vv: +! a correction is needed, using the 'exact' depletion factor for primary species vv: ! ! vv : total source depletion factor for primary species ! qbpri : cross-wind integrated mass flux [g/s] of primary species emitted from source ! qbpri*vv: cross-wind integrated mass flux [g/s] of primary species of depleted source, using 'exact' depletion factor vv ! qpri : cross-wind integrated mass flux [g/s] of primary species of depleted source (numerical approximation from subroutine seccd) ! qsec : cross-wind integrated mass flux [g/s] of secondary species (numerical approximation from subroutine seccd) -! +! ! Correct qsec: ! qbpri*vv ! qsec = qsec ---------- @@ -306,17 +306,17 @@ SUBROUTINE ops_seccmp(qbpri, ueff, rcsec, routsec, ccc, vv, amol1, amol2, xvg, s ! IF (qpri .GT. (0. + EPS_DELTA)) qsec = min(qbpri,(qsec*qbpri*vv)/qpri) ! -! Compute concentration of secondary species +! Compute concentration of secondary species ! ! 1. sigma_z < 1.6*xl -> in Gaussian plume OPS report 3.7, 3.15 FS -! +! ! q q NSEK 2 -h^2 -(2z - h)^2 -(2z + h)^2 ! csec = --- Dy Dz = --- -------- -------------------- [ exp(------------) + exp(------------) + exp(-------------) ] ! u u 2 pi x sqrt(2 pi) sigma_z 2 sigmaz^2 2 sigmaz^2 2 sigmaz^2 ! -! NSEK 2 12 +! NSEK 2 12 ! factor ------ ---------- = --------------- = 1.5238 -! 2 pi sqrt(2 pi) pi sqrt(2 pi) +! 2 pi sqrt(2 pi) pi sqrt(2 pi) ! ! factor 1e6 for conversion g -> ug ! @@ -325,25 +325,25 @@ SUBROUTINE ops_seccmp(qbpri, ueff, rcsec, routsec, ccc, vv, amol1, amol2, xvg, s ! ! csec cpri qsec qsec qbpri qsec ! ---- = ---- -> csec = ---- cpri = ----- ----- cpri = ----- ccc, -! qsec qpri qpri qbpri qpri qbpri +! qsec qpri qpri qbpri qpri qbpri ! ! qbpri ! with ccc = undepleted concentration primary species = ----- cpri ! qpri ! ! 3. sigma_z > 1.6*xl (well mixed plume) AND depleted source strength <= 1e-4*undepleted source strength -> (3.7, 3.9 OPS report) -! -! q q NSEK 1 +! +! q q NSEK 1 ! csec = --- Dy Dz = --- -------- --- ; 2 pi = 6.2832 -! u u 2 pi x xl +! u u 2 pi x xl ! IF (sigzsec .LT. (1.6*xl - EPS_DELTA)) THEN s = 2.*sigzsec*sigzsec h = htot consec = qsec*1.e6*1.5238/(vw*sigzsec*(disx + virty))* (EXP( -h*h/s) + EXP( -(2.*xl - h)**2/s) + EXP(-(2*xl + h)**2/s)) -ELSE IF (qpri .GT. (qbpri*0.0001 + EPS_DELTA)) THEN - ! loss due to deposition/chemical conversion not so large - consec = (qsec/qbpri)*ccc +ELSE IF (qpri .GT. (qbpri*0.0001 + EPS_DELTA)) THEN + ! loss due to deposition/chemical conversion not so large + consec = (qsec/qbpri)*ccc ELSE ! loss due to deposition/chemical conversion large -> further away from source -> fully mixed consec = qsec*1.e6*12/(xl*6.2832*(disx + virty)*ueff) @@ -364,24 +364,24 @@ SUBROUTINE seccd(qbpri, disx, radius, vw, xl, vgpri, vnatpri, vchem, vgsec, vnat IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'seccd') ! SUBROUTINE ARGUMENTS - INPUT REAL*4, INTENT(IN) :: qbpri ! cross-wind integrated mass flux [g/s] of primary species emitted from source -REAL*4, INTENT(IN) :: disx ! -REAL*4, INTENT(IN) :: radius ! +REAL*4, INTENT(IN) :: disx +REAL*4, INTENT(IN) :: radius REAL*4, INTENT(IN) :: vw ! average wind speed over trajectory [m/s] -REAL*4, INTENT(IN) :: xl ! -REAL*4, INTENT(IN) :: vgpri ! +REAL*4, INTENT(IN) :: xl +REAL*4, INTENT(IN) :: vgpri REAL*4, INTENT(IN) :: vnatpri ! loss rate due to wet deposition of primary component [%/h] REAL*4, INTENT(IN) :: vchem ! chemical conversion rate [%/h] -REAL*4, INTENT(IN) :: vgsec ! +REAL*4, INTENT(IN) :: vgsec REAL*4, INTENT(IN) :: vnatsec ! loss rate due to wet deposition of secondary component [%/h] REAL*4, INTENT(IN) :: amol1 ! molecular weight primary component REAL*4, INTENT(IN) :: amol2 ! molecular weight secondary component -REAL*4, INTENT(IN) :: diameter ! -REAL*4, INTENT(IN) :: sigz ! +REAL*4, INTENT(IN) :: diameter +REAL*4, INTENT(IN) :: sigz ! SUBROUTINE ARGUMENTS - OUTPUT REAL*4, INTENT(OUT) :: qpri ! cross-wind integrated mass flux of primary species at receptor [g/s] @@ -391,8 +391,8 @@ SUBROUTINE seccd(qbpri, disx, radius, vw, xl, vgpri, vnatpri, vchem, vgsec, vnat INTEGER*4 :: itim ! time step index INTEGER*4 :: ntim ! number of time steps REAL*4 :: a ! effective transport distance over which conversion takes place -REAL*4 :: a1 ! -REAL*4 :: b ! +REAL*4 :: a1 +REAL*4 :: b REAL*4 :: dt ! length of time step [s] integer :: it ! iteration count integer, parameter :: nit = 10 ! maximal number of iterations @@ -412,16 +412,16 @@ SUBROUTINE seccd(qbpri, disx, radius, vw, xl, vgpri, vnatpri, vchem, vgsec, vnat REAL*4 :: xseg ! end point of plume segment [m] REAL*4 :: dx ! travelled distance during one time step = length of plume segment [m] logical :: lfound_seg_depos ! plume segment where deposition starts has been found - + ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- -! Parameterisation of a = distance over which production of secondary species takes place; +! Parameterisation of a = distance over which production of secondary species takes place; ! a = x, point source; a = R*exp(-kt), inside area source; a = x - R*(1-exp(-kt)), outside area source. ! Production takes place, where the concentration of the primary species is > 0, hence -! the loss term b = exp(-k*t), with k = loss rate primary species (due to dry and wet deposition +! the loss term b = exp(-k*t), with k = loss rate primary species (due to dry and wet deposition ! and chemical conversion), t = travel time = radius/u = diameter/(2*u), u wind speed. ! The loss rate for dry deposition is k_dry_depos = vgpri/a1, a1 = effective plume thickness. @@ -432,7 +432,7 @@ SUBROUTINE seccd(qbpri, disx, radius, vw, xl, vgpri, vnatpri, vchem, vgsec, vnat ELSE a1 = 1.5*sigz ENDIF - b = EXP( - (diameter/(vw*3.)*(vgpri/a1 + (vchem + vnatpri)/360000.))) + b = EXP( - (diameter/(vw*3.)*(vgpri/a1 + (vchem + vnatpri)/360000.))) IF (disx .LE. (radius + EPS_DELTA)) THEN a = diameter/2.*b ELSE @@ -443,8 +443,8 @@ SUBROUTINE seccd(qbpri, disx, radius, vw, xl, vgpri, vnatpri, vchem, vgsec, vnat ENDIF ! Set ntim = number of time steps; start with 6 time steps for each travel distance < 50 km -! and add 1 time step for each further 50 km: -ntim = NINT(a)/50000 + 6 +! and add 1 time step for each further 50 km: +ntim = NINT(a)/50000 + 6 ! Set dt = length of time step [s]; end time = ntim*dt = a/wind_velocity ! and dx = distance travelled in one time step [m] @@ -453,22 +453,22 @@ SUBROUTINE seccd(qbpri, disx, radius, vw, xl, vgpri, vnatpri, vchem, vgsec, vnat ! ------------------------------------------------------------------------ ! vw (m/s) |a (m) 100 1000 10,000 100,000 1000,000 ! ----------|------------------------------------------------------------- -! 1.0 | 17 167 1667 12500 38462 -! 5.0 | 3 33 333 2500 7692 -! 10.0 | 2 17 167 1250 3846 +! 1.0 | 17 167 1667 12500 38462 +! 5.0 | 3 33 333 2500 7692 +! 10.0 | 2 17 167 1250 3846 ! dt = a/vw/ntim dx = dt*vw -! Initialise +! Initialise ! qpri = cross-wind integrated mass flux of primary species [g/s] ! qsec = cross-wind integrated mass flux of secondary species [g/s] ! xseg = end point of plume segment after each time step [m] ! lfound_seg_depos = segment where deposition starts has been found qpri = qbpri qsec = 0.0 -xseg = 0.0 -lfound_seg_depos = .false. +xseg = 0.0 +lfound_seg_depos = .false. ! ! factor 3.6e5 = 3600*100 conversion from %/h to 1/s @@ -482,22 +482,22 @@ SUBROUTINE seccd(qbpri, disx, radius, vw, xl, vgpri, vnatpri, vchem, vgsec, vnat ! k_wetdep = conversion rate for wet deposition = vnatpri/(3600*100) [1/s] ! k_chem = conversion rate for chemical conversion = vchem/(3600*100) [1/s] ! delta_t = time step = dt [s] -! +! ! In order to resolve the interdependency between the primary and secondary species, we use an extra iteration within -! each time step. In tests, this iteration only needs 2-3 iterations to converge. +! each time step. In tests, this iteration only needs 2-3 iterations to converge. ! ! qpri = cross-wind integrated mass flux of primary species at current time step, current iteration (g/s) ! qpri_prev_tim = cross-wind integrated mass flux of primary species at end of previous time step (g/s) ! qpri_prev_it = cross-wind integrated mass flux of primary species at current time step, previous iteration (g/s) ! qsec, qsec_prev_tim, qsec_prev_it: the same for secondary species ! -! prod_sec = production term of secondary species (g/s) = (Msec/Mpri) * (average mass primary) * k_chem = +! prod_sec = production term of secondary species (g/s) = (Msec/Mpri) * (average mass primary) * k_chem = ! = (Msec/Mpri) * delta_t*(qpri_prev_tim + qpri)/2 * k_chem ! e3_pri_sec = factor in production term of secondary species = (Msec/Mpri) * delta_t * k_chem ! ! mass flux at start of time interval : Q(t) ! mass flux at end of time interval, after deposition, chemical conversion : Q(t+dt) = Q(t) exp(-k dt) -! +! ! loss_pri = loss term of primary species (g/s) = Q(t) - Q(t+dt) = Q(t) [1 - exp(-k dt)], k = k_drydep + k_wetdep + k_chem; ! Q = qpri_prev_tim. ! loss_sec = loss term of secondary species (g/s) = Q(t) - Q(t+dt) = Q(t) [1 - exp(-k dt)], k = k_drydep + k_wetdep + k_chem; @@ -519,28 +519,28 @@ SUBROUTINE seccd(qbpri, disx, radius, vw, xl, vgpri, vnatpri, vchem, vgsec, vnat ! Store mass fluxes of previous time step: qpri_prev_tim = qpri qsec_prev_tim = qsec - + ! Loop over iterations: ! NOTE; iteration is only needed if we include both reactions NH3 -> NH4 and ! NH4 -> NH3; if we use the net reaction NH3 -> NH4 only, we don't need an iteration. - ! + ! !it = 0 !converged = .false. !do while (it .lt. nit .and. .not. converged) ! it = it + 1 - + ! Store mass fluxes of previous iteration: qpri_prev_it = qpri qsec_prev_it = qsec - + ! Primary species: loss_pri = qpri_prev_tim*e1_pri qpri = qpri_prev_tim - loss_pri ! Secondary species: prod_sec = 0.5*(qpri_prev_tim + qpri)*e3_pri_sec - loss_sec = (qsec_prev_tim + 0.5*prod_sec)*e1_sec - !loss_sec = (qsec_prev_tim - 0.5*prod_sec)*e1_sec + loss_sec = (qsec_prev_tim + 0.5*prod_sec)*e1_sec + !loss_sec = (qsec_prev_tim - 0.5*prod_sec)*e1_sec qsec = qsec_prev_tim + prod_sec - loss_sec !! Check for convergence: @@ -548,7 +548,7 @@ SUBROUTINE seccd(qbpri, disx, radius, vw, xl, vgpri, vnatpri, vchem, vgsec, vnat !! write(*,*) 'seccd: ',it,qpri,abs(qpri-qpri_prev_it),qsec,abs(qsec-qsec_prev_it) !enddo ! loop over iterations - + ENDDO ! end loop over time steps RETURN diff --git a/ops_src_char.f90 b/ops_src_char.f90 index 8e56c0f..ec83631 100644 --- a/ops_src_char.f90 +++ b/ops_src_char.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! USAGE : @@ -49,7 +49,7 @@ SUBROUTINE ops_src_char (f_z0user, z0_user, xb, yb, z0nlgrid, z0eurgrid, z0_src, IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_src_char') ! SUBROUTINE ARGUMENTS - INPUT @@ -62,10 +62,10 @@ SUBROUTINE ops_src_char (f_z0user, z0_user, xb, yb, z0nlgrid, z0eurgrid, z0_src, ! SUBROUTINE ARGUMENTS - OUTPUT REAL*4, INTENT(OUT) :: z0_src ! roughness length at source; from z0-map [m] -TYPE (TError) :: error +TYPE (TError) :: error ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! diff --git a/ops_stab_rek.f90 b/ops_stab_rek.f90 index 344573c..c2ae268 100644 --- a/ops_stab_rek.f90 +++ b/ops_stab_rek.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! USAGE : @@ -55,38 +55,38 @@ SUBROUTINE ops_stab_rek(icm, rb, temp_C, h0, z0_metreg_rcp, disx, z0_rcp, xl, ra IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_stab_rek') ! SUBROUTINE ARGUMENTS - INPUT INTEGER*4, INTENT(IN) :: icm ! componentnummer -REAL*4, INTENT(IN) :: rb ! -REAL*4, INTENT(IN) :: temp_C ! temperature at height zmet_T [C] -REAL*4, INTENT(IN) :: h0 ! +REAL*4, INTENT(IN) :: rb +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 ! +REAL*4, INTENT(IN) :: disx REAL*4, INTENT(IN) :: z0_rcp ! roughness length at receptor; from z0-map [m] -REAL*4, INTENT(IN) :: xl ! -REAL*4, INTENT(IN) :: radius ! -REAL*4, INTENT(IN) :: qtr ! -REAL*4, INTENT(IN) :: qrv ! -INTEGER*4, INTENT(IN) :: dv ! -REAL*4, INTENT(IN) :: ecvl(NSTAB, NTRAJ, *) ! -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) :: hbron ! -REAL*4, INTENT(IN) :: qww ! +REAL*4, INTENT(IN) :: xl +REAL*4, INTENT(IN) :: radius +REAL*4, INTENT(IN) :: qtr +REAL*4, INTENT(IN) :: qrv +INTEGER*4, INTENT(IN) :: dv +REAL*4, INTENT(IN) :: ecvl(NSTAB, NTRAJ, *) +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) :: 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 ! -REAL*4, INTENT(IN) :: xloc ! -REAL*4, INTENT(IN) :: regenk ! -REAL*4, INTENT(IN) :: ra4 ! +INTEGER*4, INTENT(IN) :: istab +INTEGER*4, INTENT(IN) :: itra +REAL*4, INTENT(IN) :: qob +REAL*4, INTENT(IN) :: xloc +REAL*4, INTENT(IN) :: regenk +REAL*4, INTENT(IN) :: ra4 REAL*4, INTENT(IN) :: z0_tra ! roughness length representative for trajectory [m] REAL*4, INTENT(IN) :: z0_src ! roughness length at source; from z0-map [m] @@ -101,31 +101,31 @@ SUBROUTINE ops_stab_rek(icm, rb, temp_C, h0, z0_metreg_rcp, disx, z0_rcp, xl, ra REAL*4, INTENT(OUT) :: ol_src ! Monin-Obukhov length at source [m] REAL*4, INTENT(OUT) :: uster_tra ! friction velocity u*, trajectory averaged [m/s] REAL*4, INTENT(OUT) :: ol_tra ! Monin-Obukhov length, trajectory averaged [m] -REAL*4, INTENT(OUT) :: htot ! -REAL*4, INTENT(OUT) :: htt ! -REAL*4, INTENT(OUT) :: onder ! -REAL*4, INTENT(OUT) :: uh ! -REAL*4, INTENT(OUT) :: zu ! -REAL*4, INTENT(OUT) :: qruim ! -REAL*4, INTENT(OUT) :: qbron ! -REAL*4, INTENT(OUT) :: dispg(NSTAB) ! +REAL*4, INTENT(OUT) :: htot +REAL*4, INTENT(OUT) :: htt +REAL*4, INTENT(OUT) :: onder +REAL*4, INTENT(OUT) :: uh +REAL*4, INTENT(OUT) :: zu +REAL*4, INTENT(OUT) :: qruim +REAL*4, INTENT(OUT) :: qbron +REAL*4, INTENT(OUT) :: dispg(NSTAB) ! LOCAL VARIABLES REAL*4 :: uster_metreg_from_rb_rcp ! friction velocity at receptor from Rb(SO2); for z0 interpolated from meteo regions [m/s] REAL*4 :: ol_metreg_from_rb_rcp ! Monin-Obukhov length at receptor from Rb(SO2); for z0 interpolated from meteo regions [m/s] -REAL*4 :: dsx ! ratio disx/radius, i.e. +REAL*4 :: dsx ! ratio disx/radius, i.e. ! ! (source-receptor distance)/(radius of area source) -REAL*4 :: sz_rcp_stab_src ! vertical dispersion coefficient sigma_z at receptor with (z0,u*,L,uh,zu) of source site -REAL*4 :: uh_rcp ! -REAL*4 :: zu_rcp ! -REAL*4 :: sz_rcp ! -REAL*4 :: qobb ! -REAL*4 :: qvk ! -REAL*4 :: qrvv ! -REAL*4 :: tcor ! -REAL*4 :: rcor ! -REAL*4 :: dncor ! -REAL*4 :: emf ! +REAL*4 :: sz_rcp_stab_src ! vertical dispersion coefficient sigma_z at receptor with (z0,u*,L,uh,zu) of source site +REAL*4 :: uh_rcp +REAL*4 :: zu_rcp +REAL*4 :: sz_rcp +REAL*4 :: qobb +REAL*4 :: qvk +REAL*4 :: qrvv +REAL*4 :: tcor +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 @@ -135,12 +135,12 @@ SUBROUTINE ops_stab_rek(icm, rb, temp_C, h0, z0_metreg_rcp, disx, z0_rcp, xl, ra LOGICAL :: ops_openlog ! function for opening log file ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! !-------------------------------------------------------------------------------- -! Determine friction velocity uster and Monin-Obukhov length ol +! Determine friction velocity uster and Monin-Obukhov length ol !-------------------------------------------------------------------------------- ! Compute friction velocity u* at the receptor, but still for the standard roughness length of the meteo region. @@ -154,12 +154,12 @@ SUBROUTINE ops_stab_rek(icm, rb, temp_C, h0, z0_metreg_rcp, disx, z0_rcp, xl, ra ! uster_metreg_from_rb_rcp = AMAX1(7.22/(rb + 1),0.06) -! Monin-Obukhov length ol at the receptor, but still for the standard roughness length; +! Monin-Obukhov length ol at the receptor, but still for the standard roughness length; ! important -> sensitive for very stable conditions. ! 0 < L <= 5 -> L = 10 ! L > 5 -> L = L + 5 -! +! ! T rho_a cp (u*)^3 ! (2.1) OPS report: L = ------------------- ! g H0 kappa @@ -167,12 +167,12 @@ SUBROUTINE ops_stab_rek(icm, rb, temp_C, h0, z0_metreg_rcp, disx, z0_rcp, xl, ra ! 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 +! g : accelaration of gravity = 9.81 m/s2 ! 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 + 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 @@ -186,20 +186,20 @@ SUBROUTINE ops_stab_rek(icm, rb, temp_C, h0, z0_metreg_rcp, disx, z0_rcp, xl, ra ! 0 < L <= 5 -> L = 10 ! L > 5 -> L = L + 5 ! -7 < L < 0 -> L = -7 for unstable conditions -! +! IF (ol_metreg_from_rb_rcp .GT. (0. + EPS_DELTA)) THEN IF (ol_metreg_from_rb_rcp .LE. 5.) THEN ! MdH: EPS_DELTA overbodig, want deze is continue ol_metreg_from_rb_rcp = 10. - ELSE + ELSE ol_metreg_from_rb_rcp = ol_metreg_from_rb_rcp + 5. ENDIF ELSEIF (ol_metreg_from_rb_rcp .LT. (0. - EPS_DELTA)) THEN ! MdH: EPS_DELTA overbodig, want deze is continue - IF (ol_metreg_from_rb_rcp .GT. -7.) THEN + IF (ol_metreg_from_rb_rcp .GT. -7.) THEN ol_metreg_from_rb_rcp = -7. ENDIF ENDIF ! -! Determine friction velocity (uster) and Monin-Obukhov length (ol), which are given at a standard roughness length +! Determine friction velocity (uster) and Monin-Obukhov length (ol), which are given at a standard roughness length ! from the meteo regions, at the specific roughness length for source and receptor: CALL ops_z0corr(z0_metreg_rcp, uster_metreg_from_rb_rcp, ol_metreg_from_rb_rcp, z0_rcp, uster_rcp, ol_rcp) @@ -222,7 +222,7 @@ SUBROUTINE ops_stab_rek(icm, rb, temp_C, h0, z0_metreg_rcp, disx, z0_rcp, xl, ra if (error%haserror) goto 9999 !------------------------------------------------ -! Compute vertical dispersion coefficient sigma_z +! Compute vertical dispersion coefficient sigma_z !------------------------------------------------ ! Skip computation of vertical dispersion if point source AND receptor very near point source (disx = disx, disx <= 1) @@ -252,10 +252,10 @@ SUBROUTINE ops_stab_rek(icm, rb, temp_C, h0, z0_metreg_rcp, disx, z0_rcp, xl, ra ! Compute dispersion coefficient dispg of average between sigma_z at source and receptor; ! 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 sz_rcp_stab_src and sz_rcp hereafter. +! we need dispg and disph and we do not use sz_rcp_stab_src and sz_rcp hereafter. dispg(istab) = (sz_rcp_stab_src + 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 @@ -275,9 +275,9 @@ SUBROUTINE ops_stab_rek(icm, rb, temp_C, h0, z0_metreg_rcp, disx, z0_rcp, xl, ra ! T24 = daily average outdoor temperature (C). ! 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*coef_space_heating*qrv +qruim = .1042*coef_space_heating*qrv ! -! Choose type of diurnal variation of emission, depending on ibtg +! Choose type of diurnal variation of emission, depending on ibtg ! and current {stability,distance} class and adjust source strengths. ! qob -> qobb = source strength of industrial source ! qruim -> qrvv = source strength of space heating source (rv << "ruimteverwarming" = space heating) @@ -285,7 +285,7 @@ SUBROUTINE ops_stab_rek(icm, rb, temp_C, h0, z0_metreg_rcp, disx, z0_rcp, xl, ra ! IF (ibtg .GE. 0) THEN - ! ibtg > 0 -> pre-defined diurnal variation for industrial sources, space heating and traffic + ! ibtg > 0 -> pre-defined diurnal variation for industrial sources, space heating and traffic ! ibtg = 0 -> homogeneous industrial sources, pre-defined diurnal variation for space heating and traffic qrvv = qruim*ecvl(istab, itra, 2) qvk = qtr*ecvl(istab, itra, 3) @@ -294,43 +294,43 @@ SUBROUTINE ops_stab_rek(icm, rb, temp_C, h0, z0_metreg_rcp, disx, z0_rcp, xl, ra ELSE qobb = qob*ecvl(istab, itra, ibtg) ENDIF -ELSE +ELSE ! ibtg < 0 -> user-specified diurnal variation qrvv = qruim*ecvl(istab, itra, (dv + 2)) qvk = qtr*ecvl(istab, itra, (dv + 3)) qobb = qob*ecvl(istab, itra, (dv + ABS(ibtg))) ENDIF ! -! NH3 and NOx emissions from animal housing, application and pasture depend on meteo; +! NH3 and NOx emissions from animal housing, application and pasture depend on meteo; ! split between correction for emissions from animal housing and other (= application and pasture) ! IF (icm .EQ. 2 .OR. icm .EQ. 3) THEN - + IF (ibtg .EQ. 4) THEN ! Emissions from animal housing; TNO: (Bas Nijenhuis, 990207) ! temperature correction for NH3 emissions from animal housing systems; OPS report 6.33. ! Tavg = 10 C - ! 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; + ! 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). FS - ! + tcor=amax1((temp_C+24)/34, 0.2) - + ! Influence of day/night rithm of animals on emissions; half the industrial emission variation dncor=1.-(1.-ecvl(istab,itra,1))/2 ! day qobb=qob*tcor*dncor ! 990227 - + ELSEIF (ibtg .EQ. 5) THEN ! application, fertiliser and other; 6.32 OPS report - + ! Corrections are based on DEPASS model - ! + rcor=(1.069-regenk)**2 ! 980922 rcor=amax1(rcor,0.5) rcor=amin1(rcor,1.5) - - emf=0.0000155*((100./(ra4+rb))**0.8*(temp_C+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 CONTINUE diff --git a/ops_statparexp.f90 b/ops_statparexp.f90 index 22e8969..4295534 100644 --- a/ops_statparexp.f90 +++ b/ops_statparexp.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,12 +27,12 @@ ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Get parameters as windspeed, mixing height, frequency etc. from the meteo statistics as a function of ! transport distance, wind direction and stability class. Parameters are interpolated between values of the -! different distance classes and wind sectors. Plume rise is also calculated here, because of its +! different distance classes and wind sectors. Plume rise is also calculated here, because of its ! dependency on wind speed. ! EXIT CODES : ! FILES AND OTHER : @@ -55,114 +55,114 @@ SUBROUTINE ops_statparexp(istab, hbron, qww, D_stack, V_stack, Ts_stack, emis_ho IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_statparexp') ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: istab -REAL*4, INTENT(IN) :: hbron -REAL*4, INTENT(IN) :: qww +INTEGER*4, INTENT(IN) :: istab +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] +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 ! linear distance between source and receptor [m] -INTEGER*4, INTENT(IN) :: isek ! +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 ! 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 ! 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) :: shear ! -REAL*4, INTENT(OUT) :: rcaer ! -REAL*4, INTENT(OUT) :: rcnh3 ! -REAL*4, INTENT(OUT) :: rcno2 ! +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) :: shear +REAL*4, INTENT(OUT) :: rcaer +REAL*4, INTENT(OUT) :: rcnh3 +REAL*4, INTENT(OUT) :: rcno2 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 ! -INTEGER*4, INTENT(OUT) :: itra ! -REAL*4, INTENT(OUT) :: aant ! -REAL*4, INTENT(OUT) :: xl ! -REAL*4, INTENT(OUT) :: rb ! -REAL*4, INTENT(OUT) :: ra4 ! -REAL*4, INTENT(OUT) :: ra50 ! -REAL*4, INTENT(OUT) :: xvglbr ! -REAL*4, INTENT(OUT) :: xvghbr ! -REAL*4, INTENT(OUT) :: xloc ! -REAL*4, INTENT(OUT) :: xl100 ! -REAL*4, INTENT(OUT) :: rad ! -REAL*4, INTENT(OUT) :: rcso2 ! -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 ! -REAL*4, INTENT(OUT) :: percvk ! +REAL*4, INTENT(OUT) :: uster_metreg_rcp +REAL*4, INTENT(OUT) :: pcoef +REAL*4, INTENT(OUT) :: htot +REAL*4, INTENT(OUT) :: htt +INTEGER*4, INTENT(OUT) :: itra +REAL*4, INTENT(OUT) :: aant +REAL*4, INTENT(OUT) :: xl +REAL*4, INTENT(OUT) :: rb +REAL*4, INTENT(OUT) :: ra4 +REAL*4, INTENT(OUT) :: ra50 +REAL*4, INTENT(OUT) :: xvglbr +REAL*4, INTENT(OUT) :: xvghbr +REAL*4, INTENT(OUT) :: xloc +REAL*4, INTENT(OUT) :: xl100 +REAL*4, INTENT(OUT) :: rad +REAL*4, INTENT(OUT) :: rcso2 +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 +REAL*4, INTENT(OUT) :: percvk ! LOCAL VARIABLES -INTEGER*4 :: is ! -INTEGER*4 :: ids ! -INTEGER*4 :: ispecial ! -INTEGER*4 :: iss ! -INTEGER*4 :: itrx ! -INTEGER*4 :: iwdd ! +INTEGER*4 :: is +INTEGER*4 :: ids +INTEGER*4 :: ispecial +INTEGER*4 :: iss +INTEGER*4 :: itrx +INTEGER*4 :: iwdd INTEGER*4 :: itraj ! index of distance class REAL*4 :: ccor ! concentration correction factor for area sources -REAL*4 :: stt(NCOMP) ! -REAL*4 :: tal(NTRAJ) ! -REAL*4 :: dscor(NTRAJ) ! -REAL*4 :: phi ! -REAL*4 :: r ! -REAL*4 :: r4 ! -REAL*4 :: r50 ! +REAL*4 :: stt(NCOMP) +REAL*4 :: tal(NTRAJ) +REAL*4 :: dscor(NTRAJ) +REAL*4 :: phi +REAL*4 :: r +REAL*4 :: r4 +REAL*4 :: r50 REAL*4 :: s ! interpolation factor (0-1) for the contribution of wind sector is - ! (i.e. the second interpolation sector), to the wind direction - ! from source to receptor - + ! (i.e. the second interpolation sector), to the wind direction + ! from source to receptor + REAL*4 :: s1(NTRAJ) ! interpolation factor for distance class (interpolates data between ! lower and upper class boundary). Note that if ids is the class index ! where the source-receptor distance lies in, then 0 <= s1(ids) <= 1 and ! s1(i) = 0 for i /= ids - -REAL*4 :: stta(NCOMP) ! -REAL*4 :: sttr(NCOMP) ! -REAL*4 :: sa ! -REAL*4 :: so ! -REAL*4 :: sp ! + +REAL*4 :: stta(NCOMP) +REAL*4 :: sttr(NCOMP) +REAL*4 :: sa +REAL*4 :: so +REAL*4 :: sp real :: dum ! dummy output variable ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! ! Compute preliminary plume rise; preliminary in the sense that later on (ops_conc_ini) -! stability is defined in terms of L and U*, instead of stability class (as in ops_plumerise_prelim) +! 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 +! 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) +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 +! the wind sector where this direction lies in (iss), the wind sectors between which to ! interpolate (isekt,is) and the interpolation factor (s). ! CALL windsek(istab, htt, disx, iwd, astat, isek, isekt, shear, htot, iwdd, iss, is, s) @@ -179,19 +179,19 @@ SUBROUTINE ops_statparexp(istab, hbron, qww, D_stack, V_stack, Ts_stack, emis_ho ! CALL windcorr(itra, istab, radius, disx, isekt, iwdd, is, astat, iss, ispecial, phi, s) ! -! Compute for the current stability class and for all distance classes -! tal = number of hours of wind blowing from source to receptor (interpolated between sector isekt and is). +! Compute for the current stability class and for all distance classes +! tal = number of hours of wind blowing from source to receptor (interpolated between sector isekt and is). ! -! s : interpolation factor (0-1) for the contribution of sector is to the direction iwdd; -! first half of sector: s = 0.5 - 1; -! second half of sector: s = 0 - 0.5. +! s : interpolation factor (0-1) for the contribution of sector is to the direction iwdd; +! first half of sector: s = 0.5 - 1; +! second half of sector: s = 0 - 0.5. ! For a parameter p, interpolation is given by p(iwdd) = s*p(is) + (1-s)*p(isekt) ! If one of the interpolating sectors does not occur, set interpolation factor to 0 or 1 (NINT(s)) ! first half of sector: s = 1; p(iwdd) = p(is) ! second half of sector: s = 0; p(iwdd) = p(isekt) -! +! ! If the current distance class equals the class where the receptor lies in, reset s to sp ! DO itraj = 1, NTRAJ @@ -213,7 +213,7 @@ SUBROUTINE ops_statparexp(istab, hbron, qww, D_stack, V_stack, Ts_stack, emis_ho tal(itraj) = (1. - sp)*astat(itraj, 1, istab, isekt) + (sp*astat(itraj, 1, istab, is)) ENDDO ! -! Interpolate over distance classes; +! Interpolate over distance classes; ! note that aant is interpolated over both distance classes (ids-1/ids) and wind sectors (isekt/is). ! CALL interp_tra(itra, s1, ids, istab, iss, tal, astat, itrx, aant, stt) @@ -222,7 +222,7 @@ SUBROUTINE ops_statparexp(istab, hbron, qww, D_stack, V_stack, Ts_stack, emis_ho ! IF (aant > EPS_DELTA) THEN ! -! Interpolate meteo parameters over wind sectors +! 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, & & temp_C, ol_metreg_rcp, h0, xloc, xl100, sp, rad, rcso2, hum, pcoef, rcnh3, rcno2, rcaer, & @@ -239,14 +239,14 @@ SUBROUTINE ops_statparexp(istab, hbron, qww, D_stack, V_stack, Ts_stack, emis_ho ! Area source and not a special case; ! average meteo parameters contributions of an area source from multiple contributing sectors to a receptor. ! Two types of average are computed: sa,stta = near-source average, so,sstr = near-receptor average, -! where sa, so = average number of hours of contributing meteo classes, +! where sa, so = average number of hours of contributing meteo classes, ! stta,sttr = average meteo parameter of contributing meteo classes. ! CALL ronafhpar(radius, disxx, istab, s, isekt, astat, s1,ids, aksek, sa, phi, so, stta, sttr) - IF (so .GT. (0. + EPS_DELTA)) sttr = sttr/so + IF (so .GT. (0. + EPS_DELTA)) sttr = sttr/so ! ! Compute r , a measure for the distance between the receptor and the edge of the area source -! disxx << radius : r -> 1 (near source) +! disxx << radius : r -> 1 (near source) ! disxx >= radius : r = 0 ! IF (radius .GT. (disxx + EPS_DELTA)) THEN @@ -261,7 +261,7 @@ SUBROUTINE ops_statparexp(istab, hbron, qww, D_stack, V_stack, Ts_stack, emis_ho ! Note that the interpolated number of hours is stored in variable so. ! -! Note: rcso2 is no longer used; instead OPS uses DEPAC RC-values +! 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) @@ -280,11 +280,11 @@ SUBROUTINE ops_statparexp(istab, hbron, qww, D_stack, V_stack, Ts_stack, emis_ho rcaer = (r*stta(27)) + (1. - r)*sttr(27) ra4 = r4 - rb ra50 = r50 - rb - - + + ELSE - ! Not an area source or a special case; - ! so = aant = interpolated number of hours of the {{ids-1/ids),istab,(isekt/is)} combination + ! Not an area source or a special case; + ! so = aant = interpolated number of hours of the {{ids-1/ids),istab,(isekt/is)} combination so = aant ENDIF ! @@ -293,7 +293,7 @@ SUBROUTINE ops_statparexp(istab, hbron, qww, D_stack, V_stack, Ts_stack, emis_ho ! ccor = so/aant ! -! aant = number of hours of occurrence of combination of distance class and wind direction sector +! aant = number of hours of occurrence of combination of distance class and wind direction sector ! for the current stability class ! percvk = fraction of occurrence of {distance/stability/wind-direction} class ! i.e. (number of hours that a {distance/stability/wind-direction} class occurs) / (total number of hours) @@ -329,40 +329,40 @@ SUBROUTINE ops_statparexp(istab, hbron, qww, D_stack, V_stack, Ts_stack, emis_ho !------------------------------------------------------------------------------------------------------------------------------- ! SUBROUTINE : bepafst -! DESCRIPTION : Compute the effective travel distance between source and receptor. This is done by -! interpolating the ratio (effective travel distance)/(linear distance) for the distance +! DESCRIPTION : Compute the effective travel distance between source and receptor. This is done by +! interpolating the ratio (effective travel distance)/(linear distance) for the distance ! class where the linear source-receptor distance lies in. !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE bepafst(itra, s, trafst, disx, dscor, xl, disxx) ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'bepafst') ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: itra ! -REAL*4, INTENT(IN) :: s(NTRAJ) ! -REAL*4, INTENT(IN) :: trafst(NTRAJ) ! +INTEGER*4, INTENT(IN) :: itra +REAL*4, INTENT(IN) :: s(NTRAJ) +REAL*4, INTENT(IN) :: trafst(NTRAJ) 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 ! +REAL*4, INTENT(INOUT) :: xl ! SUBROUTINE ARGUMENTS - OUTPUT REAL*4, INTENT(OUT) :: disxx ! effective travel distance between source and receptor [m] ! LOCAL VARIABLES -INTEGER*4 :: ids ! +INTEGER*4 :: ids ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! ! Default value for zero dscor values, indicating a non-existent distance/stability/wind-sector class. ! Note: ids is a local variable here -! dscor is in km, trafst is in m +! dscor is in km, trafst is in m ! DO ids = 2, NTRAJ IF (ABS(dscor(ids) - 0.) .LE. EPS_DELTA) THEN @@ -389,7 +389,7 @@ SUBROUTINE bepafst(itra, s, trafst, disx, dscor, xl, disxx) ids = ids - 1 ENDDO ! {ids <= 2 OR disx > trafst(ids)} ! -! Check whether ids = NTRAJ (or equivalently disx > trafst(NTRAJ)) +! Check whether ids = NTRAJ (or equivalently disx > trafst(NTRAJ)) ! IF (ids.EQ.NTRAJ) THEN ! @@ -398,25 +398,25 @@ SUBROUTINE bepafst(itra, s, trafst, disx, dscor, xl, disxx) ! xl : maximum mixing height [m] ! disxx : effective travel distance between source and receptor [m] ! disx : linear distance between source and receptor ('as the crow flies') [m] -! dscor : effective travel distance for each distance class for current stability class and current wind direction +! dscor : effective travel distance for each distance class for current stability class and current wind direction ! (dscor has been interpolated between wind sectors) [km] ! trafst: distance for each distance class [m] -! +! ! The maximum mixing height increases with travelled distance. If travelled distance is larger, ! the chance of meeting a higher mixing height is larger, the mixing volume is larger; compression -! does not take place. +! does not take place. ! Extrapolation after trafst(NTRAJ) is more than dscor(NTRAJ) "more meanders in travel path the further you go" ! -! disx -! xl = xl * [1 + 0.3*(------------- - 1)] ,linear growth in mixing height, each 1000 km a growth of -! trafst(NTRAJ) 0.3 times the original mixing height (assuming trafst(NTRAJ) = 1000 km). +! disx +! xl = xl * [1 + 0.3*(------------- - 1)] ,linear growth in mixing height, each 1000 km a growth of +! trafst(NTRAJ) 0.3 times the original mixing height (assuming trafst(NTRAJ) = 1000 km). ! ! disxx dscor(NTRAJ) disx ! ------- = 1 + [ -------------- - 1] * ------------- ! disx trafst(NTRAJ) trafst(NTRAJ) -! +! xl = xl*(1. + (disx/trafst(NTRAJ) - 1.)*.3) disxx = disx*(1. + (dscor(NTRAJ)*1000./trafst(NTRAJ) - 1.)* disx/trafst(NTRAJ)) ELSE @@ -426,7 +426,7 @@ SUBROUTINE bepafst(itra, s, trafst, disx, dscor, xl, disxx) ! If we leave out the conversion km -> m ! ! disxx dscor(ids) dscor(ids+1) -! ------ = {------------*[1-s(ids+1)] + -------------*s(ids+1) }; +! ------ = {------------*[1-s(ids+1)] + -------------*s(ids+1) }; ! disx trafst(ids) trafst(ids+1) ! ! s is interpolation factor for distance class. @@ -446,33 +446,33 @@ END SUBROUTINE bepafst SUBROUTINE voorlpl(istab, isek, hbron, qww, astat, vw10, pcoef, htt) ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'voorlpl') ! CONSTANTS -REAL*4 :: VWREP(NSTAB) ! +REAL*4 :: VWREP(NSTAB) ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: istab ! -INTEGER*4, INTENT(IN) :: isek ! -REAL*4, INTENT(IN) :: hbron ! -REAL*4, INTENT(IN) :: qww ! -REAL*4, INTENT(IN) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) ! +INTEGER*4, INTENT(IN) :: istab +INTEGER*4, INTENT(IN) :: isek +REAL*4, INTENT(IN) :: hbron +REAL*4, INTENT(IN) :: qww +REAL*4, INTENT(IN) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: vw10 ! -REAL*4, INTENT(OUT) :: pcoef ! -REAL*4, INTENT(OUT) :: htt ! +REAL*4, INTENT(OUT) :: vw10 +REAL*4, INTENT(OUT) :: pcoef +REAL*4, INTENT(OUT) :: htt ! LOCAL VARIABLES -REAL*4 :: delh ! -REAL*4 :: utop ! +REAL*4 :: delh +REAL*4 :: utop ! DATA DATA VWREP /2.6, 3.8, 4.0, 6.9, 1.4, 2.5/ ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -496,14 +496,14 @@ SUBROUTINE voorlpl(istab, isek, hbron, qww, astat, vw10, pcoef, htt) htt = hbron IF (ABS(qww) .GT. EPS_DELTA) THEN -! use power law to determine Utop (wind velocity at top of stack) +! use power law to determine Utop (wind velocity at top of stack) IF (hbron .GT. (10. + EPS_DELTA)) THEN utop = vw10*(hbron/10.)**pcoef ELSE utop = vw10 ENDIF write(*,'(a,2(1x,e12.5))') 'voorlpl a',hbron,utop - + IF (istab .GE. 5) THEN ! ! plume rise for stable conditions @@ -538,7 +538,7 @@ END SUBROUTINE voorlpl ! SUBROUTINE : ronafhpar ! DESCRIPTION : Average meteo parameters contributions of an area source from multiple contributing sectors to a receptor. ! Two types of average are computed: sa,stta = near-source average, so,sstr = near-receptor average, -! where sa, so = average number of hours of contributing meteo classes, +! where sa, so = average number of hours of contributing meteo classes, ! stta,sttr = average meteo parameter of contributing meteo classes. ! (ronafhpar: r << "richting" = direction, onafh << "onafhankelijk" = independent) ! Note: in subroutine call, ronafhpar is called with isek = isekt. @@ -546,49 +546,49 @@ END SUBROUTINE voorlpl SUBROUTINE ronafhpar(radius, disxx, istab, s, isek, astat, s1,ids, aksek, sa, phi, so, stta, sttr) ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ronafhpar') ! SUBROUTINE ARGUMENTS - INPUT -REAL*4, INTENT(IN) :: radius ! -REAL*4, INTENT(IN) :: disxx ! -INTEGER*4, INTENT(IN) :: istab ! -REAL*4, INTENT(IN) :: s ! +REAL*4, INTENT(IN) :: radius +REAL*4, INTENT(IN) :: disxx +INTEGER*4, INTENT(IN) :: istab +REAL*4, INTENT(IN) :: s INTEGER*4, INTENT(IN) :: isek ! middle of contributing wind sectors; note that ronafhpar - ! is called with isek = isekt, i.e. the first of the two + ! is called with isek = isekt, i.e. the first of the two ! interpolating wind sectors -REAL*4, INTENT(IN) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) ! -REAL*4, INTENT(IN) :: s1(NTRAJ) ! -INTEGER*4, INTENT(IN) :: ids ! +REAL*4, INTENT(IN) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) +REAL*4, INTENT(IN) :: s1(NTRAJ) +INTEGER*4, INTENT(IN) :: ids ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: aksek(12) ! -REAL*4, INTENT(OUT) :: sa ! -REAL*4, INTENT(OUT) :: phi ! -REAL*4, INTENT(OUT) :: so ! -REAL*4, INTENT(OUT) :: stta(NCOMP) ! -REAL*4, INTENT(OUT) :: sttr(NCOMP) ! +REAL*4, INTENT(OUT) :: aksek(12) +REAL*4, INTENT(OUT) :: sa +REAL*4, INTENT(OUT) :: phi +REAL*4, INTENT(OUT) :: so +REAL*4, INTENT(OUT) :: stta(NCOMP) +REAL*4, INTENT(OUT) :: sttr(NCOMP) ! LOCAL VARIABLES -INTEGER*4 :: i ! -INTEGER*4 :: icomp ! -INTEGER*4 :: lpsek ! -INTEGER*4 :: jsek ! -INTEGER*4 :: scomp(14) ! -REAL*4 :: a ! -REAL*4 :: asek ! -REAL*4 :: statfactor ! -REAL*4 :: zz ! -REAL*4 :: p1 ! -REAL*4 :: p2 ! -REAL*4 :: pa ! +INTEGER*4 :: i +INTEGER*4 :: icomp +INTEGER*4 :: lpsek +INTEGER*4 :: jsek +INTEGER*4 :: scomp(14) +REAL*4 :: a +REAL*4 :: asek +REAL*4 :: statfactor +REAL*4 :: zz +REAL*4 :: p1 +REAL*4 :: p2 +REAL*4 :: pa ! DATA ! De arrayelementen uit de meteostatistiek die hier gebruikt worden. DATA scomp / 2, 4, 5, 6, 11, 14, 16, 19, 20, 22, 23, 25, 26, 27 / ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -600,7 +600,7 @@ SUBROUTINE ronafhpar(radius, disxx, istab, s, isek, astat, s1,ids, aksek, sa, ph ! 6. aërodynamic resistance 50 m + boundary layer resistance [s/m] ! 11. precipitation probability [] ! 14. global radiation [W/m2] -! 16. surface resistance Rc for SO2 [s/m] +! 16. surface resistance Rc for SO2 [s/m] ! 19. friction velocity u* [m/s] ! 20. temperature T [degree C] ! 22. Monin-Obukhov length L [m] @@ -618,7 +618,7 @@ SUBROUTINE ronafhpar(radius, disxx, istab, s, isek, astat, s1,ids, aksek, sa, ph ! no 7. ratio effective dry deposition velocity over transport distance and average dry deposition velocity over transport distance for low sources [-] ! no 8. ratio effective dry deposition velocity over transport distance and average dry deposition velocity over transport distance for high sources [-] ! no 9. effective travel distance [] -! yes 10. degree day or domestic heating coefficient (= 19-T for T < 12 degree C) [degree C] +! yes 10. degree day or domestic heating coefficient (= 19-T for T < 12 degree C) [degree C] ! no 12. length of rainfall period [] ! no 13. rain intensity [] ! yes 15. wind speed power law coefficient [-] @@ -637,9 +637,9 @@ SUBROUTINE ronafhpar(radius, disxx, istab, s, isek, astat, s1,ids, aksek, sa, ph IF (radius .GE. (disxx - EPS_DELTA)) THEN ! ! Receptor inside area source; compute direction independent averages for several (meteo) parameters. -! Compute weighed average stta for distance class 1 (vicinity of source) with weighing factor = +! Compute weighed average stta for distance class 1 (vicinity of source) with weighing factor = ! = statfactor = number of hours for combination {distance class=1,stability class, wind sector}. -! sa = number of hours of {distance class=1,stability class, wind sector}, summed over all wind sectors +! sa = number of hours of {distance class=1,stability class, wind sector}, summed over all wind sectors ! ! asek = number of contributing sectors ! @@ -656,28 +656,28 @@ SUBROUTINE ronafhpar(radius, disxx, istab, s, isek, astat, s1,ids, aksek, sa, ph ENDDO ! Later on we count only contributions from 6 wind sectors, to keep consistency here we only use half of the hours; - ! note that the receptor is inside the area source, so strictly speaking we have contributions from all sectors. + ! note that the receptor is inside the area source, so strictly speaking we have contributions from all sectors. sa = sa/2 - + ELSE ! ! Receptor outside source: compute number of contributing sectors (3.34, 3.36 new OPS report). -! In this case, averaged meteo parameter in vicinity of source = stta = 0 +! In this case, averaged meteo parameter in vicinity of source = stta = 0 ! zz = SQRT(disxx*disxx - radius*radius) phi = ATAN2(zz, radius) - phi = (2.*PI) - 2.*(phi + 5.*PI/12.) ! = 2*pi - 2*[atan(sqrt(x^2-R^2)/R) + (5/12)*pi] + phi = (2.*PI) - 2.*(phi + 5.*PI/12.) ! = 2*pi - 2*[atan(sqrt(x^2-R^2)/R) + (5/12)*pi] asek = (phi*6.)/PI IF (asek .GT. (6. + EPS_DELTA)) THEN - asek = 6. + asek = 6. ENDIF ENDIF ! Extra distance correction -a = radius*1.7 +a = radius*1.7 IF (disxx .LE. (radius - EPS_DELTA)) THEN ! inside area source - asek = 1 + (asek - 1)*((a - disxx)/a)**0.33 + asek = 1 + (asek - 1)*((a - disxx)/a)**0.33 ELSE r = (radius/disxx)**3 asek = 1 + (asek - 1)*(r*((a - radius)/a)**0.33+(1 - r)) @@ -685,21 +685,21 @@ SUBROUTINE ronafhpar(radius, disxx, istab, s, isek, astat, s1,ids, aksek, sa, ph ! ! Loop over neighbouring sectors (3 sectors before isek) to (3 sectors after isek) ! and average meteo parameters for current source-receptor distance (interpolation -! between distance classes ids-1 and ids). Note that ronafhpar is called with +! between distance classes ids-1 and ids). Note that ronafhpar is called with ! isek = isekt, i.e. the first of the two interpolating wind sectors. ! DO i = -3, 3 - + ! pa is correction factor to correct for the deviation of the neighbouring sector ! w.r.t to the source-receptor direction; ! 0 <= pa <= 1 and for i = 0 (central sector): pa = asek/2 - s + 1/2 - ! + ! iss: wind sector in which the source-receptor direction lies. ! s between 0 and 0.5 -> source-receptor direction lies in isekt, so isekt is the middle of the contributing sectors ! s between 0.5 and 1 -> source-receptor direction lies in isekt+1, so isekt+1 is the middle of the contributing sectors - ! + pa = (asek/2.) - ABS(FLOAT(i) - s) + .5 - + IF (pa .GT. (0. + EPS_DELTA)) THEN IF (pa .GT. (1. + EPS_DELTA)) THEN pa = 1. @@ -718,14 +718,14 @@ SUBROUTINE ronafhpar(radius, disxx, istab, s, isek, astat, s1,ids, aksek, sa, ph ! Compute weighing factors p1 and p2 for interpolation between distance classes ids-1 and ids resp. ! s1: interpolation factor for distance class ids ! - p1 = pa*(1. - s1(ids))*astat(ids-1, 1, istab, jsek) + p1 = pa*(1. - s1(ids))*astat(ids-1, 1, istab, jsek) p2 = pa*s1(ids)*astat(ids, 1, istab, jsek) DO icomp = 1, 14 sttr(scomp(icomp)) = sttr(scomp(icomp)) + p1*astat(ids-1, scomp(icomp), istab, jsek)+ p2*astat(ids, scomp(icomp), & & istab, jsek) ENDDO ! -! so = pa * number of hours in stability class istab, interpolated between distance classes ids and ids-1, +! so = pa * number of hours in stability class istab, interpolated between distance classes ids and ids-1, ! accumulated over windsectors isek-3,isek-2, ... jsek ! so = so + p1 + p2 @@ -733,12 +733,12 @@ SUBROUTINE ronafhpar(radius, disxx, istab, s, isek, astat, s1,ids, aksek, sa, ph IF (pa .LT. (0. - EPS_DELTA)) THEN pa = 0. ENDIF - - aksek(i + 4) = pa + + aksek(i + 4) = pa ENDDO ! -! End of loop -! so = pa * number of hours in stability class istab, interpolated between distance classes ids and ids-1, +! End of loop +! so = pa * number of hours in stability class istab, interpolated between distance classes ids and ids-1, ! accumulated over al contributing windsectors isek-3,isek-2, ... , isek+3. RETURN @@ -753,38 +753,38 @@ END SUBROUTINE ronafhpar SUBROUTINE windsek(istab, htt, disx, iwd, astat, isek, isekt, shear, htot, iwdd, iss, is, s) ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'windsek') ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: istab ! -REAL*4, INTENT(IN) :: htt ! -REAL*4, INTENT(IN) :: disx ! -INTEGER*4, INTENT(IN) :: iwd ! -REAL*4, INTENT(IN) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) ! -INTEGER*4, INTENT(IN) :: isek ! +INTEGER*4, INTENT(IN) :: istab +REAL*4, INTENT(IN) :: htt +REAL*4, INTENT(IN) :: disx +INTEGER*4, INTENT(IN) :: iwd +REAL*4, INTENT(IN) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) +INTEGER*4, INTENT(IN) :: isek ! SUBROUTINE ARGUMENTS - OUTPUT -INTEGER*4, INTENT(OUT) :: isekt ! -REAL*4, INTENT(OUT) :: shear ! -REAL*4, INTENT(OUT) :: htot ! -INTEGER*4, INTENT(OUT) :: iwdd ! -INTEGER*4, INTENT(OUT) :: iss ! -INTEGER*4, INTENT(OUT) :: is ! -REAL*4, INTENT(OUT) :: s ! +INTEGER*4, INTENT(OUT) :: isekt +REAL*4, INTENT(OUT) :: shear +REAL*4, INTENT(OUT) :: htot +INTEGER*4, INTENT(OUT) :: iwdd +INTEGER*4, INTENT(OUT) :: iss +INTEGER*4, INTENT(OUT) :: is +REAL*4, INTENT(OUT) :: s ! LOCAL VARIABLES -REAL*4 :: alpha ! -REAL*4 :: sek ! +REAL*4 :: alpha +REAL*4 :: sek ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! ! Compute wind shear for higher altitudes. ! Use measured wind directions (20-200 m) at Cabauw. The empirical relation of Van Ulden & Holtslag is used for the -! whole mixing layer, also above 200 m. +! whole mixing layer, also above 200 m. ! ! Get turning angle for wind shear at reference height @@ -830,11 +830,11 @@ SUBROUTINE windsek(istab, htt, disx, iwd, astat, isek, isekt, shear, htot, iwdd, ! if iwdd is in the first half of the sector, this is the sector before the sector where iwdd lies in; ! if iwdd is in the second half of the sector, this is the sector where iwdd lies in. ! isekt = INT(sek) -! s : interpolation factor (0-1) for the contribution of sector is to the direction iwdd; -! first half of sector: s = 0.5 - 1; -! halfway sector, coming from 0 degrees: s = 1; -! halfway sector, going to 360 degrees: s = 0; -! second half of sector: s = 0 - 0.5. +! s : interpolation factor (0-1) for the contribution of sector is to the direction iwdd; +! first half of sector: s = 0.5 - 1; +! halfway sector, coming from 0 degrees: s = 1; +! halfway sector, going to 360 degrees: s = 0; +! second half of sector: s = 0 - 0.5. ! For a parameter p, interpolation is given by p(iwdd) = s*p(is) + (1-s)*p(isekt) ! is : index of next sector for interpolation (next in clockwise direction); is = isekt + 1 ! @@ -842,25 +842,25 @@ SUBROUTINE windsek(istab, htt, disx, iwd, astat, isek, isekt, shear, htot, iwdd, ! 000 1.00 1 1 2 0.00 ! 005 1.17 1 1 2 0.17 sector 1: 345 - 15 ! 010 1.33 1 1 2 0.33 -! +! ! 015 1.50 2 1 2 0.50 ! 020 1.67 2 1 2 0.67 ! 025 1.83 2 1 2 0.83 sector 2: 15 - 45 ! 030 2.00 2 2 3 0.00 ! 035 2.17 2 2 3 0.17 ! 040 2.33 2 2 3 0.33 -! +! ! 045 2.50 3 2 3 0.50 ! 050 2.67 3 2 3 0.67 sector 3: 45 - 75 ! 055 2.83 3 2 3 0.83 -! +! ! ...................................................... -! +! ! 325 11.83 12 11 12 0.83 ! 330 12.00 12 12 1 0.00 sector 12: 315 - 345 ! 335 12.17 12 12 1 0.17 ! 340 12.33 12 12 1 0.33 -! +! ! 345 12.50 1 12 1 0.50 ! 350 12.67 1 12 1 0.67 sector 1: 345 - 15 ! 355 12.83 1 12 1 0.83 @@ -898,37 +898,37 @@ SUBROUTINE windcorr(itra, istab, radius, disx, isek, iwdd, is, astat, iss, ispec USE Binas, only: rad2deg ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'windcorr') ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: itra ! -INTEGER*4, INTENT(IN) :: istab ! -REAL*4, INTENT(IN) :: radius ! -REAL*4, INTENT(IN) :: disx ! -INTEGER*4, INTENT(IN) :: isek ! -INTEGER*4, INTENT(IN) :: iwdd ! -INTEGER*4, INTENT(IN) :: is ! -REAL*4, INTENT(IN) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) ! +INTEGER*4, INTENT(IN) :: itra +INTEGER*4, INTENT(IN) :: istab +REAL*4, INTENT(IN) :: radius +REAL*4, INTENT(IN) :: disx +INTEGER*4, INTENT(IN) :: isek +INTEGER*4, INTENT(IN) :: iwdd +INTEGER*4, INTENT(IN) :: is +REAL*4, INTENT(IN) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) ! SUBROUTINE ARGUMENTS - I/O -INTEGER*4, INTENT(INOUT) :: iss ! +INTEGER*4, INTENT(INOUT) :: iss ! SUBROUTINE ARGUMENTS - OUTPUT -INTEGER*4, INTENT(OUT) :: ispecial ! +INTEGER*4, INTENT(OUT) :: ispecial REAL*4, INTENT(OUT) :: phi ! is not used as output -REAL*4, INTENT(OUT) :: s ! +REAL*4, INTENT(OUT) :: s ! LOCAL VARIABLES -INTEGER*4 :: iwr ! +INTEGER*4 :: iwr ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! ! Sector/wind direction correction, in case a wind sector does not occur and the neighbouring sector(s) do(es). -! Area sources can have more than one contributing sectors. +! Area sources can have more than one contributing sectors. ! Default nothing special @@ -939,29 +939,29 @@ SUBROUTINE windcorr(itra, istab, radius, disx, isek, iwdd, is, astat, iss, ispec ! radius < disx (receptor outside area source) -> ! radius >= disx (receptor inside area source) -> phi = 60 degrees - ! disx >> radius, then radius/disx -> 0, asin(radius/disx) -> 0, phi -> pi/NSEK = 15 degrees (NSEK = 12) + ! disx >> radius, then radius/disx -> 0, asin(radius/disx) -> 0, phi -> pi/NSEK = 15 degrees (NSEK = 12) ! disx = radius, then radius/disx -> 1, asin(radius/disx) -> pi/2, phi -> 105 degrees ! disx < radius, then phi = 60 degrees - ! + IF (radius .LT. (disx - EPS_DELTA)) THEN phi = (ASIN(radius/disx) + PI/NSEK)*rad2deg ELSE - phi = 60. + phi = 60. ENDIF - ! iwr = wind direction halfway sector isek + ! iwr = wind direction halfway sector isek iwr = (isek - 1)*360/NSEK -! +! ! Criteria for special case: ! 1. iwr < iwdd < iwr + phi (source-receptor direction lies in second half of isek ! 2. meteo class isek, which is used as first sector for interpolation, does not occur (astat(itra, 1, istab, isek) = 0) ! Note that 1. is split into iwdd > iwr AND phi > iwdd - iwr ! In this case, set iss (wind sector that iwdd is in) = isekt and interpolation factor s = 0 ! Note: isek = isekt here. -! +! ! BUG has only effect for shorter periods; for year runs a non-occurring class does not occur ... -! Note that if ispecial = 1, the contribution of neighbouring sectors is not taken into account (see ronafhpar). +! Note that if ispecial = 1, the contribution of neighbouring sectors is not taken into account (see ronafhpar). ! IF ((iwdd .GT. iwr) .AND. (ABS(astat(itra, 1, istab, isek)) .LE. EPS_DELTA) .AND. & @@ -974,7 +974,7 @@ SUBROUTINE windcorr(itra, istab, radius, disx, isek, iwdd, is, astat, iss, ispec ! 1. iwr - phi < iwdd < iwr (source-receptor direction lies in first half of isek ! 2. meteo class is, which is used as second sector for interpolation, does not occur (astat(itra, 1, istab, is) = 0) ! Note that 1 is split into iwr > iwdd AND phi > iwr - iwdd -! In this case, set iss (wind sector that iwdd is in) = is and interpolation factor s = 1 +! In this case, set iss (wind sector that iwdd is in) = is and interpolation factor s = 1 ! ! BUG has only effect for shorter periods; for year runs a non-occurring class does not occur ... @@ -1001,23 +1001,23 @@ SUBROUTINE interp_ctr(disx, trafst, itra, s, ids) ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'interp_ctr') ! SUBROUTINE ARGUMENTS - INPUT -REAL*4, INTENT(IN) :: disx ! -REAL*4, INTENT(IN) :: trafst(NTRAJ) ! +REAL*4, INTENT(IN) :: disx +REAL*4, INTENT(IN) :: trafst(NTRAJ) ! SUBROUTINE ARGUMENTS - OUTPUT -INTEGER*4, INTENT(OUT) :: itra ! -REAL*4, INTENT(OUT) :: s(NTRAJ) ! -INTEGER*4, INTENT(OUT) :: ids ! +INTEGER*4, INTENT(OUT) :: itra +REAL*4, INTENT(OUT) :: s(NTRAJ) +INTEGER*4, INTENT(OUT) :: ids ! LOCAL VARIABLES -INTEGER*4 :: i ! +INTEGER*4 :: i ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -1033,12 +1033,12 @@ SUBROUTINE interp_ctr(disx, trafst, itra, s, ids) ! -! name current source-receptor distance d ( = disx), then +! name current source-receptor distance d ( = disx), then ! 0 < d <= D(2)/2 -> itra = 1 ! D(2)/2 < d <= D(3)/2 -> itra = 2 ! D(3)/2 < d <= D(4)/2 -> itra = 3 ! D(4)/2 < d -> itra = 4 -! +! itra = NTRAJ DO i = NTRAJ,2,-1 IF (disx .LE. (trafst(itra-1) + (trafst(itra)- 2.*trafst(itra-1))/2.+ EPS_DELTA)) itra = i - 1 @@ -1059,7 +1059,7 @@ SUBROUTINE interp_ctr(disx, trafst, itra, s, ids) ! d = D(ids-1) -> s(ids) = 0 ! d = D(ids) -> s(ids) = 1 ! -! s(i) = 0, for i /= ids +! s(i) = 0, for i /= ids ! IF (disx .LE. (trafst(2) + EPS_DELTA)) THEN ids = 2 @@ -1088,34 +1088,34 @@ END SUBROUTINE interp_ctr !------------------------------------------------------------------------------------------------------------------------------- ! SUBROUTINE : interp_tra -! DESCRIPTION : Interpolate between distance classes for specific meteo parameters (2 <= ICOMP <= 8 OR ICOMP >= 19) +! DESCRIPTION : Interpolate between distance classes for specific meteo parameters (2 <= ICOMP <= 8 OR ICOMP >= 19) ! and store interpolated meteo parameters into stt (same index numbering as astat) !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE interp_tra(itra, s, ids, istab, iss, tal, astat, itrx, aant, stt) ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'interp_tra') ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: itra ! -REAL*4, INTENT(IN) :: s(NTRAJ) ! +INTEGER*4, INTENT(IN) :: itra +REAL*4, INTENT(IN) :: s(NTRAJ) INTEGER*4, INTENT(IN) :: ids ! index element in s dat niet 0 is. -INTEGER*4, INTENT(IN) :: istab ! -INTEGER*4, INTENT(IN) :: iss ! -REAL*4, INTENT(IN) :: tal(NTRAJ) ! -REAL*4, INTENT(IN) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) ! +INTEGER*4, INTENT(IN) :: istab +INTEGER*4, INTENT(IN) :: iss +REAL*4, INTENT(IN) :: tal(NTRAJ) +REAL*4, INTENT(IN) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) ! SUBROUTINE ARGUMENTS - OUTPUT -INTEGER*4, INTENT(OUT) :: itrx ! -REAL*4, INTENT(OUT) :: aant ! -REAL*4, INTENT(OUT) :: stt(NCOMP) ! +INTEGER*4, INTENT(OUT) :: itrx +REAL*4, INTENT(OUT) :: aant +REAL*4, INTENT(OUT) :: stt(NCOMP) ! LOCAL VARIABLES -INTEGER*4 :: icomp ! +INTEGER*4 :: icomp ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -1123,8 +1123,8 @@ SUBROUTINE interp_tra(itra, s, ids, istab, iss, tal, astat, itrx, aant, stt) ! itrx = itra ! -! Interpolate between distance classes ids-1 and ids to get -! aant = number of hours of occurrence of combination of distance class and wind direction sector +! Interpolate between distance classes ids-1 and ids to get +! aant = number of hours of occurrence of combination of distance class and wind direction sector ! for the current stability class ! aant = (1. - s(ids))*tal(ids-1) + s(ids)*tal(ids) @@ -1139,10 +1139,10 @@ SUBROUTINE interp_tra(itra, s, ids, istab, iss, tal, astat, itrx, aant, stt) ENDIF ENDDO ! -! Special cases, one or both meteo classes do not occur -> no interpolation, but get value of meteo +! Special cases, one or both meteo classes do not occur -> no interpolation, but get value of meteo ! parameter 2-8 or 19-NCOMP of neighbouring distance class that does exist (astat = 0); ! if both do not exist stt is undefined -! +! ELSE IF ((itra .EQ. ids-1) .AND. (ABS(astat(ids-1, 1, istab, iss)) .LE. EPS_DELTA)) THEN itrx = ids @@ -1171,60 +1171,60 @@ END SUBROUTINE interp_tra !------------------------------------------------------------------------------------------------------------------------------- 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) + & dscor, coef_space_heating, regenk) ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'interp_sek') ! CONSTANTS INTEGER*4 :: MENGH(NSTAB) ! menghoogte ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: istab ! -INTEGER*4, INTENT(IN) :: iss ! -INTEGER*4, INTENT(IN) :: itrx ! -INTEGER*4, INTENT(IN) :: is ! -REAL*4, INTENT(IN) :: s ! -INTEGER*4, INTENT(IN) :: isek ! -REAL*4, INTENT(IN) :: stt(NCOMP) ! -REAL*4, INTENT(IN) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) ! +INTEGER*4, INTENT(IN) :: istab +INTEGER*4, INTENT(IN) :: iss +INTEGER*4, INTENT(IN) :: itrx +INTEGER*4, INTENT(IN) :: is +REAL*4, INTENT(IN) :: s +INTEGER*4, INTENT(IN) :: isek +REAL*4, INTENT(IN) :: stt(NCOMP) +REAL*4, INTENT(IN) :: astat(NTRAJ, NCOMP, NSTAB, NSEK) ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: xl ! -REAL*4, INTENT(OUT) :: vw10 ! -REAL*4, INTENT(OUT) :: rb ! -REAL*4, INTENT(OUT) :: ra4 ! -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) :: xl +REAL*4, INTENT(OUT) :: vw10 +REAL*4, INTENT(OUT) :: rb +REAL*4, INTENT(OUT) :: ra4 +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) :: 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 ! -REAL*4, INTENT(OUT) :: sp ! -REAL*4, INTENT(OUT) :: rad ! -REAL*4, INTENT(OUT) :: rcso2 ! -REAL*4, INTENT(OUT) :: hum ! -REAL*4, INTENT(OUT) :: pcoef ! -REAL*4, INTENT(OUT) :: rcnh3 ! -REAL*4, INTENT(OUT) :: rcno2 ! -REAL*4, INTENT(OUT) :: rcaer ! -REAL*4, INTENT(OUT) :: buil ! -REAL*4, INTENT(OUT) :: rint ! -REAL*4, INTENT(OUT) :: shear ! -REAL*4, INTENT(OUT) :: dscor(NTRAJ) ! -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) :: ol_metreg_rcp +REAL*4, INTENT(OUT) :: h0 +REAL*4, INTENT(OUT) :: xloc +REAL*4, INTENT(OUT) :: xl100 +REAL*4, INTENT(OUT) :: sp +REAL*4, INTENT(OUT) :: rad +REAL*4, INTENT(OUT) :: rcso2 +REAL*4, INTENT(OUT) :: hum +REAL*4, INTENT(OUT) :: pcoef +REAL*4, INTENT(OUT) :: rcnh3 +REAL*4, INTENT(OUT) :: rcno2 +REAL*4, INTENT(OUT) :: rcaer +REAL*4, INTENT(OUT) :: buil +REAL*4, INTENT(OUT) :: rint +REAL*4, INTENT(OUT) :: shear +REAL*4, INTENT(OUT) :: dscor(NTRAJ) +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 ! MENGH is default value for mixing height for 6 stability classes DATA MENGH /300, 985, 302, 537, 50, 153/ ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -1259,7 +1259,7 @@ SUBROUTINE interp_sek(istab, iss, itrx, is, s, isek, stt, astat, xl, vw10, rb, r h0 = stt(23) ! ! Special cases for mixing height -! xl100: mixing height at 100 km +! xl100: mixing height at 100 km IF (astat(2, 2, istab, iss) .LE. (0. + EPS_DELTA)) THEN xl100 = xl ! default value at receptor ELSE @@ -1289,7 +1289,7 @@ SUBROUTINE interp_sek(istab, iss, itrx, is, s, isek, stt, astat, xl, vw10, rb, r ! ! Get interpolation factor sp for wind sector 'is' (second interpolation sector); -! if sector 'is' does not occur -> sp = 0; otherwise sp = s +! if sector 'is' does not occur -> sp = 0; otherwise sp = s ! IF (ABS(astat(itrx, 1, istab, is)) .LE. EPS_DELTA) THEN sp = 0. @@ -1297,9 +1297,9 @@ SUBROUTINE interp_sek(istab, iss, itrx, is, s, isek, stt, astat, xl, vw10, rb, r sp = s ENDIF ! -! Interpolate meteo parameters 14-16 and 24-27 for current stability class and distance class itrx, +! Interpolate meteo parameters 14-16 and 24-27 for current stability class and distance class itrx, ! between wind direction sector isek (= isekt) and sector is -! +! rad = (1. - sp)*astat(itrx, 14, istab, isek) + sp*astat(itrx, 14, istab, is) hum = (1. - sp)*astat(itrx, 24, istab, isek) + sp*astat(itrx, 24, istab, is) pcoef = (1. - sp)*astat(itrx, 15, istab, isek) + sp*astat(itrx, 15, istab, is) diff --git a/ops_surface.f90 b/ops_surface.f90 index 0e429a1..607eab0 100644 --- a/ops_surface.f90 +++ b/ops_surface.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : This routine calculates sigmaz in the surface layer (all stabilities) on the basis of Monin Obukhov @@ -46,7 +46,7 @@ SUBROUTINE ops_surface(z0, zi, ol, uster, h, x, uh, zu, szs) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_surface') ! CONSTANTS @@ -63,27 +63,27 @@ SUBROUTINE ops_surface(z0, zi, ol, uster, h, x, uh, zu, szs) ! SUBROUTINE ARGUMENTS - OUTPUT REAL*4, INTENT(OUT) :: uh ! wind speed at downwind distance x and height zu [m/s] -REAL*4, INTENT(OUT) :: zu ! representative plume height, taking into account reflection +REAL*4, INTENT(OUT) :: zu ! representative plume height, taking into account reflection ! at the top of the mixing layer and at the ground surface [m] REAL*4, INTENT(OUT) :: szs ! vertical dispersion coefficient for surface layer [m] ! LOCAL VARIABLES -INTEGER*4 :: iter ! -INTEGER*4 :: last ! -REAL*4 :: a ! -REAL*4 :: kz ! -REAL*4 :: phih ! -REAL*4 :: s ! -REAL*4 :: zw ! -REAL*4 :: zwold ! +INTEGER*4 :: iter +INTEGER*4 :: last +REAL*4 :: a +REAL*4 :: kz +REAL*4 :: phih +REAL*4 :: s +REAL*4 :: zw +REAL*4 :: zwold ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! ! An iterative procedure is needed, since sigma_z (verical spread of the plume) -! depends on Kz and u (wind speed) and these two depend on the effective plume +! depends on Kz and u (wind speed) and these two depend on the effective plume ! heights zw (for computation of Kz) and zu (for computation of u), which depend on sigma_z. ! @@ -103,7 +103,7 @@ SUBROUTINE ops_surface(z0, zi, ol, uster, h, x, uh, zu, szs) ENDIF IF (zw .GT. (zi/2. + EPS_DELTA)) THEN zw = zi/2. -ENDIF +ENDIF ! Initially zu = zw. zu = zw @@ -115,24 +115,24 @@ SUBROUTINE ops_surface(z0, zi, ol, uster, h, x, uh, zu, szs) !---------------------- 50 CONTINUE - ! + ! Psi_h = non-dimensional temperature gradient (Businger, 1973, below 3.17 OPS report) - ! + IF (ol .GT. (0. + EPS_DELTA)) THEN - phih = 0.74 + 4.7*zw/ol + phih = 0.74 + 4.7*zw/ol ELSE phih = 0.74*(1.-9*zw/ol)**(-0.5) ENDIF - ! + ! compute wind speed at height zu from log-profile - ! + CALL ops_wvprofile(z0, zu, uster, ol, uh) - ! + ! Compute Kz at effective plume height zw; - ! for L > 0, according to Businger (1973); 3.17 OPS report + ! for L > 0, according to Businger (1973); 3.17 OPS report ! for L <= 0, according to Brost and Wyngaard (1978) ! The Businger formula includes an extra calibration factor a, derived from prairie grass data. - ! + IF (ol .GT. (0. + EPS_DELTA)) THEN a = 1.2 IF (ol .LT. (30. - EPS_DELTA)) THEN @@ -142,19 +142,19 @@ SUBROUTINE ops_surface(z0, zi, ol, uster, h, x, uh, zu, szs) ELSE kz = K*uster*zw/phih*(1. - zw/zi)**1.5 ENDIF - + ! sigma_z as function of Kz (3.18 OPS report) 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 (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 + h/3 + 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) @@ -163,7 +163,7 @@ SUBROUTINE ops_surface(z0, zi, ol, uster, h, x, uh, zu, szs) IF (s .GE. (zi/2. - EPS_DELTA)) THEN zu = zi/2. - ! set new value for zw ref. Sterk, 14-10-2015 + ! set new value for zw ref. Sterk, 14-10-2015 IF (ol .LT. (0. - EPS_DELTA)) THEN zw = zu*0.75 ELSE @@ -180,23 +180,23 @@ SUBROUTINE ops_surface(z0, zi, ol, uster, h, x, uh, zu, szs) ! 2. Plume not well mixed AND plume does not touch the ground (s < h) !-------------------------------------------------------------------------------------------------- ELSE IF (h .GE. (s - EPS_DELTA)) THEN - + ! zw = h - sigma_z - zw = h - szs - ! zw = h - 0.1*s - + 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 - EPS_DELTA)) THEN - ! zw = h + 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.01 + 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 diff --git a/ops_tra_char.f90 b/ops_tra_char.f90 index 6499114..0b9c55e 100644 --- a/ops_tra_char.f90 +++ b/ops_tra_char.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! USAGE : @@ -40,7 +40,7 @@ ! UPDATE HISTORY : !------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE ops_tra_char (icm, iopt_vchem, f_z0user, z0_user, nrrcp, x_rcp, y_rcp, x_src, y_src, & - & lugrid, z0nlgrid, z0eurgrid, so2bggrid, no2bggrid, nh3bggrid, vchem2, domlu, & + & lugrid, z0nlgrid, z0eurgrid, so2bggrid, no2bggrid, nh3bggrid, vchem2, domlu, & & z0_tra, lu_tra_per, so2bgtra, no2bgtra, nh3bgtra, & & error) @@ -53,11 +53,11 @@ SUBROUTINE ops_tra_char (icm, iopt_vchem, f_z0user, z0_user, nrrcp, x_rcp, y_rcp IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_tra_char') ! SUBROUTINE ARGUMENTS - INPUT -INTEGER*4, INTENT(IN) :: icm ! +INTEGER*4, INTENT(IN) :: icm INTEGER*4, INTENT(IN) :: iopt_vchem ! option for chemical conversion rate (0 = old OPS, 1 = EMEP) LOGICAL, INTENT(IN) :: f_z0user ! user overwrites z0 values from meteo input REAL*4, INTENT(IN) :: z0_user ! roughness length specified by the user [m] @@ -69,28 +69,28 @@ SUBROUTINE ops_tra_char (icm, iopt_vchem, f_z0user, z0_user, nrrcp, x_rcp, y_rcp TYPE (TApsGridInt), INTENT(IN) :: lugrid ! land use grid TYPE (TApsGridInt), INTENT(IN) :: z0nlgrid ! map of roughness lengths in NL [m] TYPE (TApsGridInt), INTENT(IN) :: z0eurgrid ! map of roughness lengths in Europe [m] -TYPE (TApsGridReal), INTENT(IN) :: so2bggrid ! -TYPE (TApsGridReal), INTENT(IN) :: no2bggrid ! -TYPE (TApsGridReal), INTENT(IN) :: nh3bggrid ! -TYPE (Tvchem) , INTENT(INOUT) :: vchem2 ! +TYPE (TApsGridReal), INTENT(IN) :: so2bggrid +TYPE (TApsGridReal), INTENT(IN) :: no2bggrid +TYPE (TApsGridReal), INTENT(IN) :: nh3bggrid +TYPE (Tvchem) , INTENT(INOUT) :: vchem2 LOGICAL, INTENT(IN) :: domlu ! SUBROUTINE ARGUMENTS - OUTPUT -REAL*4, INTENT(OUT) :: z0_tra ! roughness length representative for trajectory [m] +REAL*4, INTENT(OUT) :: z0_tra ! roughness length representative for trajectory [m] REAL*4, INTENT(OUT) :: lu_tra_per(NLU) ! percentages of landuse classes over trajectorie (summed over intermediate points) -REAL*4, INTENT(OUT) :: so2bgtra ! -REAL*4, INTENT(OUT) :: no2bgtra ! -REAL*4, INTENT(OUT) :: nh3bgtra ! +REAL*4, INTENT(OUT) :: so2bgtra +REAL*4, INTENT(OUT) :: no2bgtra +REAL*4, INTENT(OUT) :: nh3bgtra TYPE (TError), INTENT(OUT) :: error ! error handling record ! LOCAL VARIABLES: ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! -! If user specified z0 then set z0_tra and lu_tra_per (We assume grass=lu=1 if user specified z0): +! If user specified z0 then set z0_tra and lu_tra_per (We assume grass=lu=1 if user specified z0): ! IF (f_z0user) THEN z0_tra = z0_user diff --git a/ops_vertdisp.f90 b/ops_vertdisp.f90 index bf2fe96..4321018 100644 --- a/ops_vertdisp.f90 +++ b/ops_vertdisp.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Calculation of vertical dispersion coefficient as a function of stability parameters and downwind distance @@ -46,7 +46,7 @@ SUBROUTINE ops_vertdisp(z0, zi, ol, uster, hh, x, uh, zu, sz, error) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_vertdisp') ! SUBROUTINE ARGUMENTS - INPUT @@ -59,7 +59,7 @@ SUBROUTINE ops_vertdisp(z0, zi, ol, uster, hh, x, uh, zu, sz, error) ! SUBROUTINE ARGUMENTS - OUTPUT REAL*4, INTENT(OUT) :: uh ! windspeed at downwind distance x and height zu (m/s) -REAL*4, INTENT(OUT) :: zu ! representative plume height (m), taking into account reflection +REAL*4, INTENT(OUT) :: zu ! representative plume height (m), taking into account reflection ! at the top of the mixing layer and at the ground surface REAL*4, INTENT(OUT) :: sz ! vertical dispersion coefficient (m) @@ -71,8 +71,8 @@ SUBROUTINE ops_vertdisp(z0, zi, ol, uster, hh, x, uh, zu, sz, error) REAL*4 :: szc ! convexe dispersie (m) REAL*4 :: szn ! neutrale dispersie REAL*4 :: szs ! oppervlakte dispersie -REAL*4 :: fm ! -REAL*4 :: fs ! +REAL*4 :: fm +REAL*4 :: fs ! SUBROUTINE AND FUNCTION CALLS EXTERNAL ops_surface @@ -80,7 +80,7 @@ SUBROUTINE ops_vertdisp(z0, zi, ol, uster, hh, x, uh, zu, sz, error) EXTERNAL ops_neutral ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- @@ -104,7 +104,7 @@ SUBROUTINE ops_vertdisp(z0, zi, ol, uster, hh, x, uh, zu, sz, error) ! ! zi/L < 0 -> combination of convective and near neutral layer IF ( zi/ol .LT. 0 - EPS_DELTA ) THEN - + ! Compute fs = interpolation factor between convective/near neutral layer, fs = -0.05*zi/L 960118 ! and limit fs such that 0 <= fs <= 1. ! 1. zi/L <= -20 -> fs = 1 -> convective mixing layer @@ -119,13 +119,13 @@ SUBROUTINE ops_vertdisp(z0, zi, ol, uster, hh, x, uh, zu, sz, error) CONTINUE ENDIF - ! Compute vertical dispersion coefficient sigma_z for convective and near neutral layer + ! Compute vertical dispersion coefficient sigma_z for convective and near neutral layer ! and interpolate: CALL ops_convec(z0,zi,ol,uster,h,x, uh, zu, szc) CALL ops_neutral(z0,zi,ol,uster,h,x, uh, zu, szn) sz = fs*szc + (1. - fs)*szn ELSE - + ! zi/L > 0 -> near neutral upper layer: CALL ops_neutral(z0,zi,ol,uster,h,x, uh, zu, szn) sz = szn @@ -137,7 +137,7 @@ SUBROUTINE ops_vertdisp(z0, zi, ol, uster, hh, x, uh, zu, sz, error) sz = fm*sz + (1. - fm)*szs ENDIF ELSE - + ! fm = 0 -> stack_height <= 0.2*mixing_height, so stack in surface layer: CALL ops_surface(z0,zi,ol,uster,h,x, uh, zu, szs) sz = szs diff --git a/ops_virtdist.f90 b/ops_virtdist.f90 index 2d6cdd2..c90e487 100644 --- a/ops_virtdist.f90 +++ b/ops_virtdist.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : Compute distance between (virtual point source) and (centre of area source); @@ -46,14 +46,14 @@ FUNCTION ops_virtdist (radius, rond) IMPLICIT NONE ! SUBROUTINE ARGUMENTS - INPUT -REAL*4, INTENT(IN) :: radius ! -INTEGER*4, INTENT(IN) :: rond ! +REAL*4, INTENT(IN) :: radius +INTEGER*4, INTENT(IN) :: rond ! RESULT -REAL*4 :: ops_virtdist ! +REAL*4 :: ops_virtdist ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -63,10 +63,10 @@ FUNCTION ops_virtdist (radius, rond) ! IF (rond .EQ. 1) THEN ! Circular area source - ops_virtdist = (radius*12.)/PI + ops_virtdist = (radius*12.)/PI ELSE ! Square area source is represented by a circular area source with the same area; - ! (area circle with radius r) = (area square with 1/2 side = radius) <=> pi*r**2 = (2*radius)**2 <=> + ! (area circle with radius r) = (area square with 1/2 side = radius) <=> pi*r**2 = (2*radius)**2 <=> ! <=> r = (2/sqrt(pi))*radius <=> r = 1.128*radius ops_virtdist = (radius*12.)/PI*1.128 ENDIF diff --git a/ops_write_progress.f90 b/ops_write_progress.f90 index 04b6e36..45312ee 100644 --- a/ops_write_progress.f90 +++ b/ops_write_progress.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH - SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! USAGE : @@ -46,23 +46,23 @@ SUBROUTINE ops_write_progress(progress, formatstring, numbs, memdone) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_write_progress') ! SUBROUTINE ARGUMENTS - INPUT REAL*4, INTENT(IN) :: progress ! percentage of progress reached CHARACTER*(*), INTENT(IN) :: formatstring ! formatstring for writing progress INTEGER*4, INTENT(IN) :: numbs ! number of characters which have to be backspaced - ! in order to remain at the same position of the screen + ! in order to remain at the same position of the screen ! SUBROUTINE ARGUMENTS - I/O -INTEGER*4, INTENT(INOUT) :: memdone +INTEGER*4, INTENT(INOUT) :: memdone ! LOCAL VARIABLES INTEGER*4 :: idx ! do-loop index ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! @@ -77,7 +77,7 @@ SUBROUTINE ops_write_progress(progress, formatstring, numbs, memdone) ! ! FLUSH statements are needed HP-Ux. -! Check whether to write progress, this is done each 2% +! Check whether to write progress, this is done each 2% ! See definition of memdone (2% hidden in the MOD statement). ! memdone is either INT(progress) or INT(progress)-1, with progress the progress of the previous call @@ -97,8 +97,8 @@ SUBROUTINE ops_write_progress(progress, formatstring, numbs, memdone) ENDDO ! ! Update memdone. -! MOD(INT(progress)),2) is either 0 or 1 -! memdone is either INT(progress) or INT(progress)-1 +! MOD(INT(progress)),2) is either 0 or 1 +! memdone is either INT(progress) or INT(progress)-1 ! memdone = INT(progress) - MOD(INT(progress),2) ! diff --git a/ops_wv_powerlaw.f90 b/ops_wv_powerlaw.f90 index bb24327..83e0294 100644 --- a/ops_wv_powerlaw.f90 +++ b/ops_wv_powerlaw.f90 @@ -1,21 +1,21 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 . +! 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, +! 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 diff --git a/ops_wvprofile.f90 b/ops_wvprofile.f90 index 1160bf8..1d6f3c6 100644 --- a/ops_wvprofile.f90 +++ b/ops_wvprofile.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,7 +27,7 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! FIRM/INSTITUTE : RIVM/LLO ! LANGUAGE : FORTRAN-77/90 ! DESCRIPTION : This routine calculates the wind velocity at a certain height, assuming a logarithmic wind profile. @@ -46,7 +46,7 @@ SUBROUTINE ops_wvprofile(z0, zu, uster, ol, uz) IMPLICIT NONE ! CONSTANTS -CHARACTER*512 :: ROUTINENAAM ! +CHARACTER*512 :: ROUTINENAAM PARAMETER (ROUTINENAAM = 'ops_wvprofile') ! CONSTANTS @@ -55,7 +55,7 @@ SUBROUTINE ops_wvprofile(z0, zu, uster, ol, uz) ! SUBROUTINE ARGUMENTS - INPUT REAL*4, INTENT(IN) :: z0 ! roughness length (m) -REAL*4, INTENT(IN) :: zu ! +REAL*4, INTENT(IN) :: zu REAL*4, INTENT(IN) :: uster ! friction velocity (m) REAL*4, INTENT(IN) :: ol ! Monin-Obukhov length (m) @@ -63,11 +63,11 @@ SUBROUTINE ops_wvprofile(z0, zu, uster, ol, uz) REAL*4, INTENT(OUT) :: uz ! wind velocity (m/s) ! LOCAL VARIABLES -REAL*4 :: phim ! +REAL*4 :: phim REAL*4 :: y ! hulpvariabele voor berekening phim ! SCCS-ID VARIABLES -CHARACTER*81 :: sccsida ! +CHARACTER*81 :: sccsida sccsida = '%W%:%E%'//char(0) !------------------------------------------------------------------------------------------------------------------------------- ! diff --git a/ops_z0corr.f90 b/ops_z0corr.f90 index 686446c..6823a03 100644 --- a/ops_z0corr.f90 +++ b/ops_z0corr.f90 @@ -1,18 +1,18 @@ -!------------------------------------------------------------------------------------------------------------------------------- -! -! 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 . -! +!------------------------------------------------------------------------------------------------------------------------------- +! +! 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 by ! National Institute of Public Health and Environment @@ -27,10 +27,10 @@ ! BRANCH -SEQUENCE : %B% - %S% ! DATE - TIME : %E% - %U% ! WHAT : %W%:%E% -! AUTHOR : OPS-support +! AUTHOR : OPS-support ! 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, @@ -49,40 +49,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 @@ -90,16 +90,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 +! 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. @@ -146,13 +146,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 @@ -181,7 +181,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 @@ -195,7 +195,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 diff --git a/r1mach.f90 b/r1mach.f90 new file mode 100644 index 0000000..63a56be --- /dev/null +++ b/r1mach.f90 @@ -0,0 +1,34 @@ +real function r1mach( k ) + +! return smallest difference with 1, from below (k=3) or from above (k=4) +! Gerard Cats, 25 August 2020 + +implicit none +real t +real r(4) +save r +data r /0,0,0,0/ +integer k +if ( r(k) > 0 ) then + r1mach = r(k) + return +endif +t = 1 +if ( k == 3 ) then + do while ( 1 - t < 1 ) + t = t/2 + r(3) = t + enddo + r(k) = r(k) * 2 +else if ( k == 4 ) then + do while ( 1 + t > 1 ) + t = t/2 + r(4) = t + enddo + r(k) = r(k) * 2 +else + print *, "r1mach called with a non-programmed argument, k = " , k + error stop +endif +r1mach = r(k) +end